# This is a patch for perl-5.7.1 to update it to perl-5.7.2
#
# To apply this patch:
# STEP 1: Chdir to the source directory.
# STEP 2: Run the 'applypatch' program with this patch file as input.
#
# If you do not have 'applypatch', it is part of the 'makepatch' package
# that you can fetch from the Comprehensive Perl Archive Network:
# http://www.perl.com/CPAN/authors/Johan_Vromans/makepatch-x.y.tar.gz
# In the above URL, 'x' should be 2 or higher.
#
# To apply this patch without the use of 'applypatch':
# STEP 1: Chdir to the source directory.
# If you have a decent Bourne-type shell:
# STEP 2: Run the shell with this file as input.
# If you don't have such a shell, you may need to manually create/delete
# the files/directories as shown below.
# STEP 3: Run the 'patch' program with this file as input.
#
# These are the commands needed to create/delete files/directories:
#
mkdir 'Cross'
chmod 0755 'Cross'
mkdir 'NetWare'
chmod 0755 'NetWare'
mkdir 'NetWare/bat'
chmod 0755 'NetWare/bat'
mkdir 'NetWare/t'
chmod 0755 'NetWare/t'
mkdir 'NetWare/testnlm'
chmod 0755 'NetWare/testnlm'
mkdir 'NetWare/testnlm/echo'
chmod 0755 'NetWare/testnlm/echo'
mkdir 'NetWare/testnlm/type'
chmod 0755 'NetWare/testnlm/type'
mkdir 'ext/DB_File/t'
chmod 0755 'ext/DB_File/t'
mkdir 'ext/Data/Dumper/t'
chmod 0755 'ext/Data/Dumper/t'
mkdir 'ext/Digest/MD5/t'
chmod 0755 'ext/Digest/MD5/t'
mkdir 'ext/File/Glob/t'
chmod 0755 'ext/File/Glob/t'
mkdir 'ext/Filter/t'
chmod 0755 'ext/Filter/t'
mkdir 'ext/I18N'
chmod 0755 'ext/I18N'
mkdir 'ext/I18N/Langinfo'
chmod 0755 'ext/I18N/Langinfo'
mkdir 'ext/IO/lib/IO/t'
chmod 0755 'ext/IO/lib/IO/t'
mkdir 'ext/List'
chmod 0755 'ext/List'
mkdir 'ext/List/Util'
chmod 0755 'ext/List/Util'
mkdir 'ext/List/Util/lib'
chmod 0755 'ext/List/Util/lib'
mkdir 'ext/List/Util/lib/List'
chmod 0755 'ext/List/Util/lib/List'
mkdir 'ext/List/Util/lib/Scalar'
chmod 0755 'ext/List/Util/lib/Scalar'
mkdir 'ext/List/Util/t'
chmod 0755 'ext/List/Util/t'
mkdir 'ext/MIME/Base64/t'
chmod 0755 'ext/MIME/Base64/t'
mkdir 'ext/PerlIO/t'
chmod 0755 'ext/PerlIO/t'
mkdir 'ext/Safe'
chmod 0755 'ext/Safe'
mkdir 'ext/Storable/t'
chmod 0755 'ext/Storable/t'
mkdir 'ext/Time'
chmod 0755 'ext/Time'
mkdir 'ext/Time/HiRes'
chmod 0755 'ext/Time/HiRes'
mkdir 'ext/Time/HiRes/hints'
chmod 0755 'ext/Time/HiRes/hints'
mkdir 'ext/Time/Piece'
chmod 0755 'ext/Time/Piece'
mkdir 'lib/Attribute'
chmod 0755 'lib/Attribute'
mkdir 'lib/Attribute/Handlers'
chmod 0755 'lib/Attribute/Handlers'
mkdir 'lib/Attribute/Handlers/demo'
chmod 0755 'lib/Attribute/Handlers/demo'
mkdir 'lib/CGI/t'
chmod 0755 'lib/CGI/t'
mkdir 'lib/CPAN/t'
chmod 0755 'lib/CPAN/t'
mkdir 'lib/Class/ISA'
chmod 0755 'lib/Class/ISA'
mkdir 'lib/Env'
chmod 0755 'lib/Env'
mkdir 'lib/File/Find'
chmod 0755 'lib/File/Find'
mkdir 'lib/File/Temp'
chmod 0755 'lib/File/Temp'
mkdir 'lib/File/Temp/t'
chmod 0755 'lib/File/Temp/t'
mkdir 'lib/Filter/Simple'
chmod 0755 'lib/Filter/Simple'
mkdir 'lib/Getopt/Long'
chmod 0755 'lib/Getopt/Long'
mkdir 'lib/Getopt/Long/t'
chmod 0755 'lib/Getopt/Long/t'
mkdir 'lib/I18N/LangTags'
chmod 0755 'lib/I18N/LangTags'
mkdir 'lib/Locale/Codes'
chmod 0755 'lib/Locale/Codes'
mkdir 'lib/Locale/Codes/t'
chmod 0755 'lib/Locale/Codes/t'
mkdir 'lib/Locale/Maketext'
chmod 0755 'lib/Locale/Maketext'
mkdir 'lib/Math/BigInt'
chmod 0755 'lib/Math/BigInt'
mkdir 'lib/Math/BigInt/t'
chmod 0755 'lib/Math/BigInt/t'
mkdir 'lib/Memoize'
chmod 0755 'lib/Memoize'
mkdir 'lib/Memoize/t'
chmod 0755 'lib/Memoize/t'
mkdir 'lib/NEXT'
chmod 0755 'lib/NEXT'
mkdir 'lib/Net/FTP'
chmod 0755 'lib/Net/FTP'
mkdir 'lib/Net/demos'
chmod 0755 'lib/Net/demos'
mkdir 'lib/Net/t'
chmod 0755 'lib/Net/t'
mkdir 'lib/Switch'
chmod 0755 'lib/Switch'
mkdir 'lib/Term/ANSIColor'
chmod 0755 'lib/Term/ANSIColor'
mkdir 'lib/Test/More'
chmod 0755 'lib/Test/More'
mkdir 'lib/Test/More/t'
chmod 0755 'lib/Test/More/t'
mkdir 'lib/Test/Simple'
chmod 0755 'lib/Test/Simple'
mkdir 'lib/Test/Simple/t'
chmod 0755 'lib/Test/Simple/t'
mkdir 'lib/Test/t'
chmod 0755 'lib/Test/t'
mkdir 'lib/Text/Balanced'
chmod 0755 'lib/Text/Balanced'
mkdir 'lib/Text/Balanced/t'
chmod 0755 'lib/Text/Balanced/t'
mkdir 'lib/Text/TabsWrap'
chmod 0755 'lib/Text/TabsWrap'
mkdir 'lib/Text/TabsWrap/t'
chmod 0755 'lib/Text/TabsWrap/t'
mkdir 'lib/Tie/Array'
chmod 0755 'lib/Tie/Array'
mkdir 'lib/Tie/Handle'
chmod 0755 'lib/Tie/Handle'
mkdir 't/lib/Test'
chmod 0755 't/lib/Test'
mkdir 't/lib/Test/More'
chmod 0755 't/lib/Test/More'
mkdir 't/lib/Test/Simple'
chmod 0755 't/lib/Test/Simple'
mkdir 't/lib/Test/Simple/sample_tests'
chmod 0755 't/lib/Test/Simple/sample_tests'
mkdir 't/lib/locale'
chmod 0755 't/lib/locale'
mkdir 't/lib/strict'
chmod 0755 't/lib/strict'
mkdir 't/lib/warnings'
chmod 0755 't/lib/warnings'
mkdir 'uts'
chmod 0755 'uts'
rm -f 'win32/bin/mdelete.bat'
rm -f 't/pragma/warnings.t'
rm -f 't/pragma/warn/util'
rm -f 't/pragma/warn/utf8'
rm -f 't/pragma/warn/universal'
rm -f 't/pragma/warn/toke'
rm -f 't/pragma/warn/taint'
rm -f 't/pragma/warn/sv'
rm -f 't/pragma/warn/run'
rm -f 't/pragma/warn/regexec'
rm -f 't/pragma/warn/regcomp'
rm -f 't/pragma/warn/pp_sys'
rm -f 't/pragma/warn/pp_hot'
rm -f 't/pragma/warn/pp_ctl'
rm -f 't/pragma/warn/pp'
rm -f 't/pragma/warn/perly'
rm -f 't/pragma/warn/perlio'
rm -f 't/pragma/warn/perl'
rm -f 't/pragma/warn/op'
rm -f 't/pragma/warn/mg'
rm -f 't/pragma/warn/malloc'
rm -f 't/pragma/warn/hv'
rm -f 't/pragma/warn/gv'
rm -f 't/pragma/warn/doop'
rm -f 't/pragma/warn/doio'
rm -f 't/pragma/warn/av'
rm -f 't/pragma/warn/9enabled'
rm -f 't/pragma/warn/8signal'
rm -f 't/pragma/warn/7fatal'
rm -f 't/pragma/warn/6default'
rm -f 't/pragma/warn/5nolint'
rm -f 't/pragma/warn/4lint'
rm -f 't/pragma/warn/3both'
rm -f 't/pragma/warn/2use'
rm -f 't/pragma/warn/1global'
rm -f 't/pragma/utf8.t'
rm -f 't/pragma/subs.t'
rm -f 't/pragma/sub_lval.t'
rm -f 't/pragma/strict.t'
rm -f 't/pragma/strict-vars'
rm -f 't/pragma/strict-subs'
rm -f 't/pragma/strict-refs'
rm -f 't/pragma/overload.t'
rm -f 't/pragma/locale/utf8'
rm -f 't/pragma/locale/latin1'
rm -f 't/pragma/locale.t'
rm -f 't/pragma/diagnostics.t'
rm -f 't/pragma/constant.t'
rm -f 't/lib/xs-typemap.t'
rm -f 't/lib/trig.t'
rm -f 't/lib/timelocal.t'
rm -f 't/lib/tie-substrhash.t'
rm -f 't/lib/tie-stdpush.t'
rm -f 't/lib/tie-stdhandle.t'
rm -f 't/lib/tie-stdarray.t'
rm -f 't/lib/tie-splice.t'
rm -f 't/lib/tie-refhash.t'
rm -f 't/lib/tie-push.t'
rm -f 't/lib/thr5005.t'
rm -f 't/lib/textwrap.t'
rm -f 't/lib/texttabs.t'
rm -f 't/lib/textfill.t'
rm -f 't/lib/test-harness.t'
rm -f 't/lib/tb-xvari.t'
rm -f 't/lib/tb-xtagg.t'
rm -f 't/lib/tb-xquot.t'
rm -f 't/lib/tb-xmult.t'
rm -f 't/lib/tb-xdeli.t'
rm -f 't/lib/tb-xcode.t'
rm -f 't/lib/tb-xbrak.t'
rm -f 't/lib/tb-genxt.t'
rm -f 't/lib/syslog.t'
rm -f 't/lib/syslfs.t'
rm -f 't/lib/symbol.t'
rm -f 't/lib/switch.t'
rm -f 't/lib/st-utf8.t'
rm -f 't/lib/st-tieditems.t'
rm -f 't/lib/st-tiedhook.t'
rm -f 't/lib/st-tied.t'
rm -f 't/lib/st-store.t'
rm -f 't/lib/st-retrieve.t'
rm -f 't/lib/st-recurse.t'
rm -f 't/lib/st-overload.t'
rm -f 't/lib/st-lock.t'
rm -f 't/lib/st-freeze.t'
rm -f 't/lib/st-forgive.t'
rm -f 't/lib/st-dclone.t'
rm -f 't/lib/st-canonical.t'
rm -f 't/lib/st-blessed.t'
rm -f 't/lib/st-06compat.t'
rm -f 't/lib/soundex.t'
rm -f 't/lib/socket.t'
rm -f 't/lib/sigaction.t'
rm -f 't/lib/selfloader.t'
rm -f 't/lib/selectsaver.t'
rm -f 't/lib/searchdict.t'
rm -f 't/lib/sdbm.t'
rm -f 't/lib/safe2.t'
rm -f 't/lib/safe1.t'
rm -f 't/lib/posix.t'
rm -f 't/lib/ph.t'
rm -f 't/lib/peek.t'
rm -f 't/lib/parsewords.t'
rm -f 't/lib/ops.t'
rm -f 't/lib/open3.t'
rm -f 't/lib/open2.t'
rm -f 't/lib/opcode.t'
rm -f 't/lib/odbm.t'
rm -f 't/lib/net-hostent.t'
rm -f 't/lib/ndbm.t'
rm -f 't/lib/mimeqp.t'
rm -f 't/lib/mimeb64u.t'
rm -f 't/lib/mimeb64.t'
rm -f 't/lib/md5-file.t'
rm -f 't/lib/md5-badf.t'
rm -f 't/lib/md5-align.t'
rm -f 't/lib/md5-aaa.t'
rm -f 't/lib/lc-uk.t'
rm -f 't/lib/lc-language.t'
rm -f 't/lib/lc-currency.t'
rm -f 't/lib/lc-country.t'
rm -f 't/lib/lc-constants.t'
rm -f 't/lib/lc-all.t'
rm -f 't/lib/ipc_sysv.t'
rm -f 't/lib/io_xs.t'
rm -f 't/lib/io_unix.t'
rm -f 't/lib/io_udp.t'
rm -f 't/lib/io_tell.t'
rm -f 't/lib/io_taint.t'
rm -f 't/lib/io_sock.t'
rm -f 't/lib/io_sel.t'
rm -f 't/lib/io_scalar.t'
rm -f 't/lib/io_poll.t'
rm -f 't/lib/io_pipe.t'
rm -f 't/lib/io_multihomed.t'
rm -f 't/lib/io_linenum.t'
rm -f 't/lib/io_dup.t'
rm -f 't/lib/io_dir.t'
rm -f 't/lib/io_const.t'
rm -f 't/lib/hostname.t'
rm -f 't/lib/h2ph.t'
rm -f 't/lib/gol-oo.t'
rm -f 't/lib/gol-linkage.t'
rm -f 't/lib/gol-compat.t'
rm -f 't/lib/gol-basic.t'
rm -f 't/lib/glob-taint.t'
rm -f 't/lib/glob-global.t'
rm -f 't/lib/glob-case.t'
rm -f 't/lib/glob-basic.t'
rm -f 't/lib/getopt.t'
rm -f 't/lib/gdbm.t'
rm -f 't/lib/ftmp-tempfile.t'
rm -f 't/lib/ftmp-security.t'
rm -f 't/lib/ftmp-posix.t'
rm -f 't/lib/ftmp-mktemp.t'
rm -f 't/lib/findbin.t'
rm -f 't/lib/filter-util.t'
rm -f 't/lib/filespec.t'
rm -f 't/lib/filepath.t'
rm -f 't/lib/filehand.t'
rm -f 't/lib/filefunc.t'
rm -f 't/lib/filefind.t'
rm -f 't/lib/filecopy.t'
rm -f 't/lib/filecache.t'
rm -f 't/lib/fields.t'
rm -f 't/lib/fatal.t'
rm -f 't/lib/errno.t'
rm -f 't/lib/env.t'
rm -f 't/lib/env-array.t'
rm -f 't/lib/english.t'
rm -f 't/lib/encode.t'
rm -f 't/lib/dumper.t'
rm -f 't/lib/dumper-ovl.t'
rm -f 't/lib/dprof.t'
rm -f 't/lib/dosglob.t'
rm -f 't/lib/dirhand.t'
rm -f 't/lib/digest.t'
rm -f 't/lib/db-recno.t'
rm -f 't/lib/db-hash.t'
rm -f 't/lib/db-btree.t'
rm -f 't/lib/cwd.t'
rm -f 't/lib/complex.t'
rm -f 't/lib/class-struct.t'
rm -f 't/lib/class-isa.t'
rm -f 't/lib/checktree.t'
rm -f 't/lib/charnames.t'
rm -f 't/lib/cgi-request.t'
rm -f 't/lib/cgi-pretty.t'
rm -f 't/lib/cgi-html.t'
rm -f 't/lib/cgi-function.t'
rm -f 't/lib/cgi-form.t'
rm -f 't/lib/cgi-esc.t'
rm -f 't/lib/bigintpm.t'
rm -f 't/lib/bigint.t'
rm -f 't/lib/bigfltpm.t'
rm -f 't/lib/bigfloat.t'
rm -f 't/lib/basename.t'
rm -f 't/lib/b.t'
rm -f 't/lib/autoloader.t'
rm -f 't/lib/attrs.t'
rm -f 't/lib/anydbm.t'
rm -f 't/lib/ansicolor.t'
rm -f 't/lib/abbrev.t'
rm -f 't/camel-III/vstring.t'
rm -f 'plan9/perlplan9.pod'
rm -f 'plan9/perlplan9.doc'
rm -f 'lib/unicode/distinct.pm'
rm -f 'lib/unicode/In/YiSyllables.pl'
rm -f 'lib/unicode/In/YiRadicals.pl'
rm -f 'lib/unicode/In/UnifiedCanadianAboriginalSyllabics.pl'
rm -f 'lib/unicode/In/Tibetan.pl'
rm -f 'lib/unicode/In/Thai.pl'
rm -f 'lib/unicode/In/Thaana.pl'
rm -f 'lib/unicode/In/Telugu.pl'
rm -f 'lib/unicode/In/Tamil.pl'
rm -f 'lib/unicode/In/Syriac.pl'
rm -f 'lib/unicode/In/SuperscriptsandSubscripts.pl'
rm -f 'lib/unicode/In/Specials.pl'
rm -f 'lib/unicode/In/SpacingModifierLetters.pl'
rm -f 'lib/unicode/In/SmallFormVariants.pl'
rm -f 'lib/unicode/In/Sinhala.pl'
rm -f 'lib/unicode/In/Runic.pl'
rm -f 'lib/unicode/In/PrivateUse.pl'
rm -f 'lib/unicode/In/Oriya.pl'
rm -f 'lib/unicode/In/OpticalCharacterRecognition.pl'
rm -f 'lib/unicode/In/Ogham.pl'
rm -f 'lib/unicode/In/NumberForms.pl'
rm -f 'lib/unicode/In/Myanmar.pl'
rm -f 'lib/unicode/In/Mongolian.pl'
rm -f 'lib/unicode/In/MiscellaneousTechnical.pl'
rm -f 'lib/unicode/In/MiscellaneousSymbols.pl'
rm -f 'lib/unicode/In/MathematicalOperators.pl'
rm -f 'lib/unicode/In/Malayalam.pl'
rm -f 'lib/unicode/In/LowSurrogates.pl'
rm -f 'lib/unicode/In/LetterlikeSymbols.pl'
rm -f 'lib/unicode/In/LatinExtendedAdditional.pl'
rm -f 'lib/unicode/In/LatinExtended-B.pl'
rm -f 'lib/unicode/In/LatinExtended-A.pl'
rm -f 'lib/unicode/In/Latin-1Supplement.pl'
rm -f 'lib/unicode/In/Lao.pl'
rm -f 'lib/unicode/In/Khmer.pl'
rm -f 'lib/unicode/In/Katakana.pl'
rm -f 'lib/unicode/In/Kannada.pl'
rm -f 'lib/unicode/In/KangxiRadicals.pl'
rm -f 'lib/unicode/In/Kanbun.pl'
rm -f 'lib/unicode/In/IdeographicDescriptionCharacters.pl'
rm -f 'lib/unicode/In/IPAExtensions.pl'
rm -f 'lib/unicode/In/Hiragana.pl'
rm -f 'lib/unicode/In/HighSurrogates.pl'
rm -f 'lib/unicode/In/HighPrivateUseSurrogates.pl'
rm -f 'lib/unicode/In/Hebrew.pl'
rm -f 'lib/unicode/In/HangulSyllables.pl'
rm -f 'lib/unicode/In/HangulJamo.pl'
rm -f 'lib/unicode/In/HangulCompatibilityJamo.pl'
rm -f 'lib/unicode/In/HalfwidthandFullwidthForms.pl'
rm -f 'lib/unicode/In/Gurmukhi.pl'
rm -f 'lib/unicode/In/Gujarati.pl'
rm -f 'lib/unicode/In/GreekExtended.pl'
rm -f 'lib/unicode/In/Greek.pl'
rm -f 'lib/unicode/In/Georgian.pl'
rm -f 'lib/unicode/In/GeometricShapes.pl'
rm -f 'lib/unicode/In/GeneralPunctuation.pl'
rm -f 'lib/unicode/In/Ethiopic.pl'
rm -f 'lib/unicode/In/EnclosedCJKLettersandMonths.pl'
rm -f 'lib/unicode/In/EnclosedAlphanumerics.pl'
rm -f 'lib/unicode/In/Dingbats.pl'
rm -f 'lib/unicode/In/Devanagari.pl'
rm -f 'lib/unicode/In/Cyrillic.pl'
rm -f 'lib/unicode/In/CurrencySymbols.pl'
rm -f 'lib/unicode/In/ControlPictures.pl'
rm -f 'lib/unicode/In/CombiningMarksforSymbols.pl'
rm -f 'lib/unicode/In/CombiningHalfMarks.pl'
rm -f 'lib/unicode/In/CombiningDiacriticalMarks.pl'
rm -f 'lib/unicode/In/Cherokee.pl'
rm -f 'lib/unicode/In/CJKUnifiedIdeographsExtensionA.pl'
rm -f 'lib/unicode/In/CJKUnifiedIdeographs.pl'
rm -f 'lib/unicode/In/CJKSymbolsandPunctuation.pl'
rm -f 'lib/unicode/In/CJKRadicalsSupplement.pl'
rm -f 'lib/unicode/In/CJKCompatibilityIdeographs.pl'
rm -f 'lib/unicode/In/CJKCompatibilityForms.pl'
rm -f 'lib/unicode/In/CJKCompatibility.pl'
rm -f 'lib/unicode/In/BraillePatterns.pl'
rm -f 'lib/unicode/In/BoxDrawing.pl'
rm -f 'lib/unicode/In/BopomofoExtended.pl'
rm -f 'lib/unicode/In/Bopomofo.pl'
rm -f 'lib/unicode/In/BlockElements.pl'
rm -f 'lib/unicode/In/Bengali.pl'
rm -f 'lib/unicode/In/BasicLatin.pl'
rm -f 'lib/unicode/In/Arrows.pl'
rm -f 'lib/unicode/In/Armenian.pl'
rm -f 'lib/unicode/In/ArabicPresentationForms-B.pl'
rm -f 'lib/unicode/In/ArabicPresentationForms-A.pl'
rm -f 'lib/unicode/In/Arabic.pl'
rm -f 'lib/unicode/In/AlphabeticPresentationForms.pl'
rm -f 'lib/unicode/Block.pl'
rm -f 'ext/util/mkbootstrap'
rm -f 'ext/Thread/unsync4.t'
rm -f 'ext/Thread/unsync3.t'
rm -f 'ext/Thread/unsync2.t'
rm -f 'ext/Thread/unsync.t'
rm -f 'ext/Thread/sync2.t'
rm -f 'ext/Thread/sync.t'
rm -f 'ext/Thread/specific.t'
rm -f 'ext/Thread/queue.t'
rm -f 'ext/Thread/lock.t'
rm -f 'ext/Thread/list.t'
rm -f 'ext/Thread/join2.t'
rm -f 'ext/Thread/join.t'
rm -f 'ext/Thread/io.t'
rm -f 'ext/Thread/die2.t'
rm -f 'ext/Thread/die.t'
rm -f 'ext/Thread/create.t'
rm -f 'ext/SDBM_File/sdbm/dbm.h'
rm -f 'ext/SDBM_File/sdbm/dbm.c'
rm -f 'Todo-5.6'
rm -f 'Todo'
touch 'Cross/README'
chmod 0444 'Cross/README'
touch 'NetWare/CLIBsdio.h'
chmod 0444 'NetWare/CLIBsdio.h'
touch 'NetWare/CLIBstr.h'
chmod 0444 'NetWare/CLIBstr.h'
touch 'NetWare/CLIBstuf.c'
chmod 0444 'NetWare/CLIBstuf.c'
touch 'NetWare/CLIBstuf.h'
chmod 0444 'NetWare/CLIBstuf.h'
touch 'NetWare/Main.c'
chmod 0444 'NetWare/Main.c'
touch 'NetWare/Makefile'
chmod 0444 'NetWare/Makefile'
touch 'NetWare/NWTInfo.c'
chmod 0444 'NetWare/NWTInfo.c'
touch 'NetWare/NWUtil.c'
chmod 0444 'NetWare/NWUtil.c'
touch 'NetWare/Nwmain.c'
chmod 0444 'NetWare/Nwmain.c'
touch 'NetWare/Nwpipe.c'
chmod 0444 'NetWare/Nwpipe.c'
touch 'NetWare/bat/BldNWExt.bat'
chmod 0444 'NetWare/bat/BldNWExt.bat'
touch 'NetWare/bat/Buildtype.bat'
chmod 0444 'NetWare/bat/Buildtype.bat'
touch 'NetWare/bat/MPKBuild.bat'
chmod 0444 'NetWare/bat/MPKBuild.bat'
touch 'NetWare/bat/SetNWBld.bat'
chmod 0444 'NetWare/bat/SetNWBld.bat'
touch 'NetWare/bat/Setmpksdk.bat'
chmod 0444 'NetWare/bat/Setmpksdk.bat'
touch 'NetWare/bat/Setnlmsdk.bat'
chmod 0444 'NetWare/bat/Setnlmsdk.bat'
touch 'NetWare/bat/Setwatcom.bat'
chmod 0444 'NetWare/bat/Setwatcom.bat'
touch 'NetWare/bat/ToggleD2.bat'
chmod 0444 'NetWare/bat/ToggleD2.bat'
touch 'NetWare/bat/ToggleXDC.bat'
chmod 0444 'NetWare/bat/ToggleXDC.bat'
touch 'NetWare/config.wc'
chmod 0444 'NetWare/config.wc'
touch 'NetWare/config_H.wc'
chmod 0444 'NetWare/config_H.wc'
touch 'NetWare/config_h.PL'
chmod 0444 'NetWare/config_h.PL'
touch 'NetWare/config_sh.PL'
chmod 0444 'NetWare/config_sh.PL'
touch 'NetWare/deb.h'
chmod 0444 'NetWare/deb.h'
touch 'NetWare/dl_netware.xs'
chmod 0444 'NetWare/dl_netware.xs'
touch 'NetWare/intdef.h'
chmod 0444 'NetWare/intdef.h'
touch 'NetWare/interface.c'
chmod 0444 'NetWare/interface.c'
touch 'NetWare/interface.h'
chmod 0444 'NetWare/interface.h'
touch 'NetWare/iperlhost.h'
chmod 0444 'NetWare/iperlhost.h'
touch 'NetWare/netware.h'
chmod 0444 'NetWare/netware.h'
touch 'NetWare/nw5.c'
chmod 0444 'NetWare/nw5.c'
touch 'NetWare/nw5iop.h'
chmod 0444 'NetWare/nw5iop.h'
touch 'NetWare/nw5sck.c'
chmod 0444 'NetWare/nw5sck.c'
touch 'NetWare/nw5sck.h'
chmod 0444 'NetWare/nw5sck.h'
touch 'NetWare/nw5thread.c'
chmod 0444 'NetWare/nw5thread.c'
touch 'NetWare/nw5thread.h'
chmod 0444 'NetWare/nw5thread.h'
touch 'NetWare/nwperlsys.c'
chmod 0444 'NetWare/nwperlsys.c'
touch 'NetWare/nwperlsys.h'
chmod 0444 'NetWare/nwperlsys.h'
touch 'NetWare/nwpipe.h'
chmod 0444 'NetWare/nwpipe.h'
touch 'NetWare/nwplglob.c'
chmod 0444 'NetWare/nwplglob.c'
touch 'NetWare/nwplglob.h'
chmod 0444 'NetWare/nwplglob.h'
touch 'NetWare/nwstdio.h'
chmod 0444 'NetWare/nwstdio.h'
touch 'NetWare/nwtinfo.h'
chmod 0444 'NetWare/nwtinfo.h'
touch 'NetWare/nwutil.h'
chmod 0444 'NetWare/nwutil.h'
touch 'NetWare/t/NWModify.pl'
chmod 0444 'NetWare/t/NWModify.pl'
touch 'NetWare/t/NWScripts.pl'
chmod 0444 'NetWare/t/NWScripts.pl'
touch 'NetWare/t/Readme.txt'
chmod 0444 'NetWare/t/Readme.txt'
touch 'NetWare/testnlm/echo/echo.c'
chmod 0444 'NetWare/testnlm/echo/echo.c'
touch 'NetWare/testnlm/type/type.c'
chmod 0444 'NetWare/testnlm/type/type.c'
touch 'NetWare/win32ish.h'
chmod 0444 'NetWare/win32ish.h'
touch 'Porting/testall.atom'
chmod 0444 'Porting/testall.atom'
touch 'README.dgux'
chmod 0444 'README.dgux'
touch 'README.netware'
chmod 0444 'README.netware'
touch 'README.tru64'
chmod 0444 'README.tru64'
touch 'README.uts'
chmod 0444 'README.uts'
touch 'ext/B/B.t'
chmod 0444 'ext/B/B.t'
touch 'ext/B/Debug.t'
chmod 0444 'ext/B/Debug.t'
touch 'ext/B/Deparse.t'
chmod 0444 'ext/B/Deparse.t'
touch 'ext/B/Showlex.t'
chmod 0444 'ext/B/Showlex.t'
touch 'ext/B/Stash.t'
chmod 0444 'ext/B/Stash.t'
touch 'ext/Cwd/Cwd.t'
chmod 0444 'ext/Cwd/Cwd.t'
touch 'ext/DB_File/t/db-btree.t'
chmod 0444 'ext/DB_File/t/db-btree.t'
touch 'ext/DB_File/t/db-hash.t'
chmod 0444 'ext/DB_File/t/db-hash.t'
touch 'ext/DB_File/t/db-recno.t'
chmod 0444 'ext/DB_File/t/db-recno.t'
touch 'ext/Data/Dumper/t/dumper.t'
chmod 0444 'ext/Data/Dumper/t/dumper.t'
touch 'ext/Data/Dumper/t/overload.t'
chmod 0444 'ext/Data/Dumper/t/overload.t'
touch 'ext/Devel/Peek/Peek.t'
chmod 0444 'ext/Devel/Peek/Peek.t'
touch 'ext/Digest/MD5/t/aaa.t'
chmod 0444 'ext/Digest/MD5/t/aaa.t'
touch 'ext/Digest/MD5/t/align.t'
chmod 0444 'ext/Digest/MD5/t/align.t'
touch 'ext/Digest/MD5/t/badfile.t'
chmod 0444 'ext/Digest/MD5/t/badfile.t'
touch 'ext/Digest/MD5/t/files.t'
chmod 0444 'ext/Digest/MD5/t/files.t'
touch 'ext/Encode.t'
chmod 0444 'ext/Encode.t'
touch 'ext/Encode/Encode/7bit-jis.enc'
chmod 0444 'ext/Encode/Encode/7bit-jis.enc'
touch 'ext/Encode/Encode/7bit-kana.enc'
chmod 0444 'ext/Encode/Encode/7bit-kana.enc'
touch 'ext/Encode/Encode/7bit-kr.enc'
chmod 0444 'ext/Encode/Encode/7bit-kr.enc'
touch 'ext/Encode/Encode/HZ.enc'
chmod 0444 'ext/Encode/Encode/HZ.enc'
touch 'ext/Encode/Encode/Tcl.t'
chmod 0444 'ext/Encode/Encode/Tcl.t'
touch 'ext/Errno/Errno.t'
chmod 0444 'ext/Errno/Errno.t'
touch 'ext/Fcntl/Fcntl.t'
chmod 0444 'ext/Fcntl/Fcntl.t'
touch 'ext/Fcntl/syslfs.t'
chmod 0444 'ext/Fcntl/syslfs.t'
touch 'ext/File/Glob/t/basic.t'
chmod 0444 'ext/File/Glob/t/basic.t'
touch 'ext/File/Glob/t/case.t'
chmod 0444 'ext/File/Glob/t/case.t'
touch 'ext/File/Glob/t/global.t'
chmod 0444 'ext/File/Glob/t/global.t'
touch 'ext/File/Glob/t/taint.t'
chmod 0444 'ext/File/Glob/t/taint.t'
touch 'ext/Filter/t/call.t'
chmod 0444 'ext/Filter/t/call.t'
touch 'ext/GDBM_File/gdbm.t'
chmod 0444 'ext/GDBM_File/gdbm.t'
touch 'ext/I18N/Langinfo/Langinfo.pm'
chmod 0444 'ext/I18N/Langinfo/Langinfo.pm'
touch 'ext/I18N/Langinfo/Langinfo.t'
chmod 0444 'ext/I18N/Langinfo/Langinfo.t'
touch 'ext/I18N/Langinfo/Langinfo.xs'
chmod 0444 'ext/I18N/Langinfo/Langinfo.xs'
touch 'ext/I18N/Langinfo/Makefile.PL'
chmod 0444 'ext/I18N/Langinfo/Makefile.PL'
touch 'ext/IO/lib/IO/t/io_const.t'
chmod 0444 'ext/IO/lib/IO/t/io_const.t'
touch 'ext/IO/lib/IO/t/io_dir.t'
chmod 0444 'ext/IO/lib/IO/t/io_dir.t'
touch 'ext/IO/lib/IO/t/io_dup.t'
chmod 0444 'ext/IO/lib/IO/t/io_dup.t'
touch 'ext/IO/lib/IO/t/io_linenum.t'
chmod 0444 'ext/IO/lib/IO/t/io_linenum.t'
touch 'ext/IO/lib/IO/t/io_multihomed.t'
chmod 0444 'ext/IO/lib/IO/t/io_multihomed.t'
touch 'ext/IO/lib/IO/t/io_pipe.t'
chmod 0444 'ext/IO/lib/IO/t/io_pipe.t'
touch 'ext/IO/lib/IO/t/io_poll.t'
chmod 0444 'ext/IO/lib/IO/t/io_poll.t'
touch 'ext/IO/lib/IO/t/io_sel.t'
chmod 0444 'ext/IO/lib/IO/t/io_sel.t'
touch 'ext/IO/lib/IO/t/io_sock.t'
chmod 0444 'ext/IO/lib/IO/t/io_sock.t'
touch 'ext/IO/lib/IO/t/io_taint.t'
chmod 0444 'ext/IO/lib/IO/t/io_taint.t'
touch 'ext/IO/lib/IO/t/io_tell.t'
chmod 0444 'ext/IO/lib/IO/t/io_tell.t'
touch 'ext/IO/lib/IO/t/io_udp.t'
chmod 0444 'ext/IO/lib/IO/t/io_udp.t'
touch 'ext/IO/lib/IO/t/io_unix.t'
chmod 0444 'ext/IO/lib/IO/t/io_unix.t'
touch 'ext/IO/lib/IO/t/io_xs.t'
chmod 0444 'ext/IO/lib/IO/t/io_xs.t'
touch 'ext/IPC/SysV/ipcsysv.t'
chmod 0444 'ext/IPC/SysV/ipcsysv.t'
touch 'ext/List/Util/ChangeLog'
chmod 0444 'ext/List/Util/ChangeLog'
touch 'ext/List/Util/Makefile.PL'
chmod 0444 'ext/List/Util/Makefile.PL'
touch 'ext/List/Util/README'
chmod 0444 'ext/List/Util/README'
touch 'ext/List/Util/Util.xs'
chmod 0444 'ext/List/Util/Util.xs'
touch 'ext/List/Util/lib/List/Util.pm'
chmod 0444 'ext/List/Util/lib/List/Util.pm'
touch 'ext/List/Util/lib/Scalar/Util.pm'
chmod 0444 'ext/List/Util/lib/Scalar/Util.pm'
touch 'ext/List/Util/t/blessed.t'
chmod 0444 'ext/List/Util/t/blessed.t'
touch 'ext/List/Util/t/dualvar.t'
chmod 0444 'ext/List/Util/t/dualvar.t'
touch 'ext/List/Util/t/first.t'
chmod 0444 'ext/List/Util/t/first.t'
touch 'ext/List/Util/t/max.t'
chmod 0444 'ext/List/Util/t/max.t'
touch 'ext/List/Util/t/maxstr.t'
chmod 0444 'ext/List/Util/t/maxstr.t'
touch 'ext/List/Util/t/min.t'
chmod 0444 'ext/List/Util/t/min.t'
touch 'ext/List/Util/t/minstr.t'
chmod 0444 'ext/List/Util/t/minstr.t'
touch 'ext/List/Util/t/readonly.t'
chmod 0444 'ext/List/Util/t/readonly.t'
touch 'ext/List/Util/t/reduce.t'
chmod 0444 'ext/List/Util/t/reduce.t'
touch 'ext/List/Util/t/reftype.t'
chmod 0444 'ext/List/Util/t/reftype.t'
touch 'ext/List/Util/t/sum.t'
chmod 0444 'ext/List/Util/t/sum.t'
touch 'ext/List/Util/t/tainted.t'
chmod 0444 'ext/List/Util/t/tainted.t'
touch 'ext/List/Util/t/weak.t'
chmod 0444 'ext/List/Util/t/weak.t'
touch 'ext/MIME/Base64/t/base64.t'
chmod 0444 'ext/MIME/Base64/t/base64.t'
touch 'ext/MIME/Base64/t/qp.t'
chmod 0444 'ext/MIME/Base64/t/qp.t'
touch 'ext/MIME/Base64/t/unicode.t'
chmod 0444 'ext/MIME/Base64/t/unicode.t'
touch 'ext/NDBM_File/hints/linux.pl'
chmod 0444 'ext/NDBM_File/hints/linux.pl'
touch 'ext/NDBM_File/ndbm.t'
chmod 0444 'ext/NDBM_File/ndbm.t'
touch 'ext/ODBM_File/odbm.t'
chmod 0444 'ext/ODBM_File/odbm.t'
touch 'ext/Opcode/Opcode.t'
chmod 0444 'ext/Opcode/Opcode.t'
touch 'ext/Opcode/ops.t'
chmod 0444 'ext/Opcode/ops.t'
touch 'ext/POSIX/POSIX.t'
chmod 0444 'ext/POSIX/POSIX.t'
touch 'ext/POSIX/hints/uts.pl'
chmod 0444 'ext/POSIX/hints/uts.pl'
touch 'ext/POSIX/sigaction.t'
chmod 0444 'ext/POSIX/sigaction.t'
touch 'ext/PerlIO/PerlIO.t'
chmod 0444 'ext/PerlIO/PerlIO.t'
touch 'ext/PerlIO/t/encoding.t'
chmod 0444 'ext/PerlIO/t/encoding.t'
touch 'ext/PerlIO/t/scalar.t'
chmod 0444 'ext/PerlIO/t/scalar.t'
touch 'ext/SDBM_File/sdbm.t'
chmod 0444 'ext/SDBM_File/sdbm.t'
touch 'ext/Safe/safe1.t'
chmod 0444 'ext/Safe/safe1.t'
touch 'ext/Safe/safe2.t'
chmod 0444 'ext/Safe/safe2.t'
touch 'ext/Socket/Socket.t'
chmod 0444 'ext/Socket/Socket.t'
touch 'ext/Storable/t/blessed.t'
chmod 0444 'ext/Storable/t/blessed.t'
touch 'ext/Storable/t/canonical.t'
chmod 0444 'ext/Storable/t/canonical.t'
touch 'ext/Storable/t/compat06.t'
chmod 0444 'ext/Storable/t/compat06.t'
touch 'ext/Storable/t/dclone.t'
chmod 0444 'ext/Storable/t/dclone.t'
touch 'ext/Storable/t/forgive.t'
chmod 0444 'ext/Storable/t/forgive.t'
touch 'ext/Storable/t/freeze.t'
chmod 0444 'ext/Storable/t/freeze.t'
touch 'ext/Storable/t/lock.t'
chmod 0444 'ext/Storable/t/lock.t'
touch 'ext/Storable/t/overload.t'
chmod 0444 'ext/Storable/t/overload.t'
touch 'ext/Storable/t/recurse.t'
chmod 0444 'ext/Storable/t/recurse.t'
touch 'ext/Storable/t/retrieve.t'
chmod 0444 'ext/Storable/t/retrieve.t'
touch 'ext/Storable/t/store.t'
chmod 0444 'ext/Storable/t/store.t'
touch 'ext/Storable/t/tied.t'
chmod 0444 'ext/Storable/t/tied.t'
touch 'ext/Storable/t/tied_hook.t'
chmod 0444 'ext/Storable/t/tied_hook.t'
touch 'ext/Storable/t/tied_items.t'
chmod 0444 'ext/Storable/t/tied_items.t'
touch 'ext/Storable/t/utf8.t'
chmod 0444 'ext/Storable/t/utf8.t'
touch 'ext/Sys/Hostname/Hostname.t'
chmod 0444 'ext/Sys/Hostname/Hostname.t'
touch 'ext/Sys/Syslog/syslog.t'
chmod 0444 'ext/Sys/Syslog/syslog.t'
touch 'ext/Thread/create.tx'
chmod 0444 'ext/Thread/create.tx'
touch 'ext/Thread/die.tx'
chmod 0444 'ext/Thread/die.tx'
touch 'ext/Thread/die2.tx'
chmod 0444 'ext/Thread/die2.tx'
touch 'ext/Thread/io.tx'
chmod 0444 'ext/Thread/io.tx'
touch 'ext/Thread/join.tx'
chmod 0444 'ext/Thread/join.tx'
touch 'ext/Thread/join2.tx'
chmod 0444 'ext/Thread/join2.tx'
touch 'ext/Thread/list.tx'
chmod 0444 'ext/Thread/list.tx'
touch 'ext/Thread/lock.tx'
chmod 0444 'ext/Thread/lock.tx'
touch 'ext/Thread/queue.tx'
chmod 0444 'ext/Thread/queue.tx'
touch 'ext/Thread/specific.tx'
chmod 0444 'ext/Thread/specific.tx'
touch 'ext/Thread/sync.tx'
chmod 0444 'ext/Thread/sync.tx'
touch 'ext/Thread/sync2.tx'
chmod 0444 'ext/Thread/sync2.tx'
touch 'ext/Thread/thr5005.t'
chmod 0444 'ext/Thread/thr5005.t'
touch 'ext/Thread/unsync.tx'
chmod 0444 'ext/Thread/unsync.tx'
touch 'ext/Thread/unsync2.tx'
chmod 0444 'ext/Thread/unsync2.tx'
touch 'ext/Thread/unsync3.tx'
chmod 0444 'ext/Thread/unsync3.tx'
touch 'ext/Thread/unsync4.tx'
chmod 0444 'ext/Thread/unsync4.tx'
touch 'ext/Time/HiRes/Changes'
chmod 0444 'ext/Time/HiRes/Changes'
touch 'ext/Time/HiRes/HiRes.pm'
chmod 0444 'ext/Time/HiRes/HiRes.pm'
touch 'ext/Time/HiRes/HiRes.t'
chmod 0444 'ext/Time/HiRes/HiRes.t'
touch 'ext/Time/HiRes/HiRes.xs'
chmod 0444 'ext/Time/HiRes/HiRes.xs'
touch 'ext/Time/HiRes/Makefile.PL'
chmod 0444 'ext/Time/HiRes/Makefile.PL'
touch 'ext/Time/HiRes/hints/dynixptx.pl'
chmod 0444 'ext/Time/HiRes/hints/dynixptx.pl'
touch 'ext/Time/HiRes/hints/sco.pl'
chmod 0444 'ext/Time/HiRes/hints/sco.pl'
touch 'ext/Time/Piece/Makefile.PL'
chmod 0444 'ext/Time/Piece/Makefile.PL'
touch 'ext/Time/Piece/Piece.pm'
chmod 0444 'ext/Time/Piece/Piece.pm'
touch 'ext/Time/Piece/Piece.t'
chmod 0444 'ext/Time/Piece/Piece.t'
touch 'ext/Time/Piece/Piece.xs'
chmod 0444 'ext/Time/Piece/Piece.xs'
touch 'ext/Time/Piece/README'
chmod 0444 'ext/Time/Piece/README'
touch 'ext/Time/Piece/Seconds.pm'
chmod 0444 'ext/Time/Piece/Seconds.pm'
touch 'ext/XS/Typemap/Typemap.t'
chmod 0444 'ext/XS/Typemap/Typemap.t'
touch 'ext/attrs.t'
chmod 0444 'ext/attrs.t'
touch 'hints/atheos.sh'
chmod 0444 'hints/atheos.sh'
touch 'lib/AnyDBM_File.t'
chmod 0444 'lib/AnyDBM_File.t'
touch 'lib/Attribute/Handlers.pm'
chmod 0444 'lib/Attribute/Handlers.pm'
touch 'lib/Attribute/Handlers/Changes'
chmod 0444 'lib/Attribute/Handlers/Changes'
touch 'lib/Attribute/Handlers/README'
chmod 0444 'lib/Attribute/Handlers/README'
touch 'lib/Attribute/Handlers/demo/Demo.pm'
chmod 0444 'lib/Attribute/Handlers/demo/Demo.pm'
touch 'lib/Attribute/Handlers/demo/Descriptions.pm'
chmod 0444 'lib/Attribute/Handlers/demo/Descriptions.pm'
touch 'lib/Attribute/Handlers/demo/MyClass.pm'
chmod 0444 'lib/Attribute/Handlers/demo/MyClass.pm'
touch 'lib/Attribute/Handlers/demo/demo.pl'
chmod 0444 'lib/Attribute/Handlers/demo/demo.pl'
touch 'lib/Attribute/Handlers/demo/demo2.pl'
chmod 0444 'lib/Attribute/Handlers/demo/demo2.pl'
touch 'lib/Attribute/Handlers/demo/demo3.pl'
chmod 0444 'lib/Attribute/Handlers/demo/demo3.pl'
touch 'lib/Attribute/Handlers/demo/demo4.pl'
chmod 0444 'lib/Attribute/Handlers/demo/demo4.pl'
touch 'lib/Attribute/Handlers/demo/demo_call.pl'
chmod 0444 'lib/Attribute/Handlers/demo/demo_call.pl'
touch 'lib/Attribute/Handlers/demo/demo_chain.pl'
chmod 0444 'lib/Attribute/Handlers/demo/demo_chain.pl'
touch 'lib/Attribute/Handlers/demo/demo_cycle.pl'
chmod 0444 'lib/Attribute/Handlers/demo/demo_cycle.pl'
touch 'lib/Attribute/Handlers/demo/demo_hashdir.pl'
chmod 0444 'lib/Attribute/Handlers/demo/demo_hashdir.pl'
touch 'lib/Attribute/Handlers/demo/demo_phases.pl'
chmod 0444 'lib/Attribute/Handlers/demo/demo_phases.pl'
touch 'lib/Attribute/Handlers/demo/demo_range.pl'
chmod 0444 'lib/Attribute/Handlers/demo/demo_range.pl'
touch 'lib/Attribute/Handlers/demo/demo_rawdata.pl'
chmod 0444 'lib/Attribute/Handlers/demo/demo_rawdata.pl'
touch 'lib/Attribute/Handlers/test.pl'
chmod 0444 'lib/Attribute/Handlers/test.pl'
touch 'lib/AutoLoader.t'
chmod 0444 'lib/AutoLoader.t'
touch 'lib/Benchmark.t'
chmod 0444 'lib/Benchmark.t'
touch 'lib/CGI/t/form.t'
chmod 0444 'lib/CGI/t/form.t'
touch 'lib/CGI/t/function.t'
chmod 0444 'lib/CGI/t/function.t'
touch 'lib/CGI/t/html.t'
chmod 0444 'lib/CGI/t/html.t'
touch 'lib/CGI/t/pretty.t'
chmod 0444 'lib/CGI/t/pretty.t'
touch 'lib/CGI/t/request.t'
chmod 0444 'lib/CGI/t/request.t'
touch 'lib/CGI/t/util.t'
chmod 0444 'lib/CGI/t/util.t'
touch 'lib/CPAN/t/loadme.t'
chmod 0444 'lib/CPAN/t/loadme.t'
touch 'lib/CPAN/t/vcmp.t'
chmod 0444 'lib/CPAN/t/vcmp.t'
touch 'lib/Carp.t'
chmod 0444 'lib/Carp.t'
touch 'lib/Class/ISA/test.pl'
chmod 0444 'lib/Class/ISA/test.pl'
touch 'lib/Class/Struct.t'
chmod 0444 'lib/Class/Struct.t'
touch 'lib/Devel/SelfStubber.t'
chmod 0444 'lib/Devel/SelfStubber.t'
touch 'lib/Digest.t'
chmod 0444 'lib/Digest.t'
touch 'lib/DirHandle.t'
chmod 0444 'lib/DirHandle.t'
touch 'lib/English.t'
chmod 0444 'lib/English.t'
touch 'lib/Env/array.t'
chmod 0444 'lib/Env/array.t'
touch 'lib/Env/env.t'
chmod 0444 'lib/Env/env.t'
touch 'lib/Exporter.t'
chmod 0444 'lib/Exporter.t'
touch 'lib/ExtUtils.t'
chmod 0444 'lib/ExtUtils.t'
touch 'lib/ExtUtils/Constant.pm'
chmod 0444 'lib/ExtUtils/Constant.pm'
touch 'lib/ExtUtils/MM_NW5.pm'
chmod 0444 'lib/ExtUtils/MM_NW5.pm'
touch 'lib/Fatal.t'
chmod 0444 'lib/Fatal.t'
touch 'lib/File/Basename.t'
chmod 0444 'lib/File/Basename.t'
touch 'lib/File/CheckTree.t'
chmod 0444 'lib/File/CheckTree.t'
touch 'lib/File/Compare.t'
chmod 0444 'lib/File/Compare.t'
touch 'lib/File/Copy.t'
chmod 0444 'lib/File/Copy.t'
touch 'lib/File/DosGlob.t'
chmod 0444 'lib/File/DosGlob.t'
touch 'lib/File/Find/find.t'
chmod 0444 'lib/File/Find/find.t'
touch 'lib/File/Find/taint.t'
chmod 0444 'lib/File/Find/taint.t'
touch 'lib/File/Path.t'
chmod 0444 'lib/File/Path.t'
touch 'lib/File/Spec.t'
chmod 0444 'lib/File/Spec.t'
touch 'lib/File/Spec/Functions.t'
chmod 0444 'lib/File/Spec/Functions.t'
touch 'lib/File/Temp/t/mktemp.t'
chmod 0444 'lib/File/Temp/t/mktemp.t'
touch 'lib/File/Temp/t/posix.t'
chmod 0444 'lib/File/Temp/t/posix.t'
touch 'lib/File/Temp/t/security.t'
chmod 0444 'lib/File/Temp/t/security.t'
touch 'lib/File/Temp/t/tempfile.t'
chmod 0444 'lib/File/Temp/t/tempfile.t'
touch 'lib/File/stat.t'
chmod 0444 'lib/File/stat.t'
touch 'lib/FileCache.t'
chmod 0444 'lib/FileCache.t'
touch 'lib/FileHandle.t'
chmod 0444 'lib/FileHandle.t'
touch 'lib/Filter/Simple/test.pl'
chmod 0444 'lib/Filter/Simple/test.pl'
touch 'lib/FindBin.t'
chmod 0444 'lib/FindBin.t'
touch 'lib/Getopt/Long/t/basic.t'
chmod 0444 'lib/Getopt/Long/t/basic.t'
touch 'lib/Getopt/Long/t/compat.t'
chmod 0444 'lib/Getopt/Long/t/compat.t'
touch 'lib/Getopt/Long/t/linkage.t'
chmod 0444 'lib/Getopt/Long/t/linkage.t'
touch 'lib/Getopt/Long/t/oo.t'
chmod 0444 'lib/Getopt/Long/t/oo.t'
touch 'lib/Getopt/Std.t'
chmod 0444 'lib/Getopt/Std.t'
touch 'lib/I18N/Collate.t'
chmod 0444 'lib/I18N/Collate.t'
touch 'lib/I18N/LangTags.pm'
chmod 0444 'lib/I18N/LangTags.pm'
touch 'lib/I18N/LangTags/ChangeLog'
chmod 0444 'lib/I18N/LangTags/ChangeLog'
touch 'lib/I18N/LangTags/List.pm'
chmod 0444 'lib/I18N/LangTags/List.pm'
touch 'lib/I18N/LangTags/README'
chmod 0444 'lib/I18N/LangTags/README'
touch 'lib/I18N/LangTags/test.pl'
chmod 0444 'lib/I18N/LangTags/test.pl'
touch 'lib/IPC/Open2.t'
chmod 0444 'lib/IPC/Open2.t'
touch 'lib/IPC/Open3.t'
chmod 0444 'lib/IPC/Open3.t'
touch 'lib/IPC/SysV.t'
chmod 0444 'lib/IPC/SysV.t'
touch 'lib/Locale/Codes/t/all.t'
chmod 0444 'lib/Locale/Codes/t/all.t'
touch 'lib/Locale/Codes/t/constants.t'
chmod 0444 'lib/Locale/Codes/t/constants.t'
touch 'lib/Locale/Codes/t/country.t'
chmod 0444 'lib/Locale/Codes/t/country.t'
touch 'lib/Locale/Codes/t/currency.t'
chmod 0444 'lib/Locale/Codes/t/currency.t'
touch 'lib/Locale/Codes/t/languages.t'
chmod 0444 'lib/Locale/Codes/t/languages.t'
touch 'lib/Locale/Codes/t/uk.t'
chmod 0444 'lib/Locale/Codes/t/uk.t'
touch 'lib/Locale/Maketext.pm'
chmod 0444 'lib/Locale/Maketext.pm'
touch 'lib/Locale/Maketext.pod'
chmod 0444 'lib/Locale/Maketext.pod'
touch 'lib/Locale/Maketext/ChangeLog'
chmod 0444 'lib/Locale/Maketext/ChangeLog'
touch 'lib/Locale/Maketext/README'
chmod 0444 'lib/Locale/Maketext/README'
touch 'lib/Locale/Maketext/TPJ13.pod'
chmod 0444 'lib/Locale/Maketext/TPJ13.pod'
touch 'lib/Locale/Maketext/test.pl'
chmod 0444 'lib/Locale/Maketext/test.pl'
touch 'lib/Math/BigInt/Calc.pm'
chmod 0444 'lib/Math/BigInt/Calc.pm'
touch 'lib/Math/BigInt/t/bigfltpm.t'
chmod 0444 'lib/Math/BigInt/t/bigfltpm.t'
touch 'lib/Math/BigInt/t/bigintc.t'
chmod 0444 'lib/Math/BigInt/t/bigintc.t'
touch 'lib/Math/BigInt/t/bigintpm.t'
chmod 0444 'lib/Math/BigInt/t/bigintpm.t'
touch 'lib/Math/BigInt/t/mbimbf.t'
chmod 0444 'lib/Math/BigInt/t/mbimbf.t'
touch 'lib/Math/Complex.t'
chmod 0444 'lib/Math/Complex.t'
touch 'lib/Math/Trig.t'
chmod 0444 'lib/Math/Trig.t'
touch 'lib/Memoize.pm'
chmod 0444 'lib/Memoize.pm'
touch 'lib/Memoize/AnyDBM_File.pm'
chmod 0444 'lib/Memoize/AnyDBM_File.pm'
touch 'lib/Memoize/Expire.pm'
chmod 0444 'lib/Memoize/Expire.pm'
touch 'lib/Memoize/ExpireFile.pm'
chmod 0444 'lib/Memoize/ExpireFile.pm'
touch 'lib/Memoize/ExpireTest.pm'
chmod 0444 'lib/Memoize/ExpireTest.pm'
touch 'lib/Memoize/NDBM_File.pm'
chmod 0444 'lib/Memoize/NDBM_File.pm'
touch 'lib/Memoize/README'
chmod 0444 'lib/Memoize/README'
touch 'lib/Memoize/SDBM_File.pm'
chmod 0444 'lib/Memoize/SDBM_File.pm'
touch 'lib/Memoize/Saves.pm'
chmod 0444 'lib/Memoize/Saves.pm'
touch 'lib/Memoize/Storable.pm'
chmod 0444 'lib/Memoize/Storable.pm'
touch 'lib/Memoize/TODO'
chmod 0444 'lib/Memoize/TODO'
touch 'lib/Memoize/t/array.t'
chmod 0444 'lib/Memoize/t/array.t'
touch 'lib/Memoize/t/array_confusion.t'
chmod 0444 'lib/Memoize/t/array_confusion.t'
touch 'lib/Memoize/t/correctness.t'
chmod 0444 'lib/Memoize/t/correctness.t'
touch 'lib/Memoize/t/errors.t'
chmod 0444 'lib/Memoize/t/errors.t'
touch 'lib/Memoize/t/expire.t'
chmod 0444 'lib/Memoize/t/expire.t'
touch 'lib/Memoize/t/expire_file.t'
chmod 0444 'lib/Memoize/t/expire_file.t'
touch 'lib/Memoize/t/expire_module_n.t'
chmod 0444 'lib/Memoize/t/expire_module_n.t'
touch 'lib/Memoize/t/expire_module_t.t'
chmod 0444 'lib/Memoize/t/expire_module_t.t'
touch 'lib/Memoize/t/flush.t'
chmod 0444 'lib/Memoize/t/flush.t'
touch 'lib/Memoize/t/normalize.t'
chmod 0444 'lib/Memoize/t/normalize.t'
touch 'lib/Memoize/t/prototype.t'
chmod 0444 'lib/Memoize/t/prototype.t'
touch 'lib/Memoize/t/speed.t'
chmod 0444 'lib/Memoize/t/speed.t'
touch 'lib/Memoize/t/tie.t'
chmod 0444 'lib/Memoize/t/tie.t'
touch 'lib/Memoize/t/tie_gdbm.t'
chmod 0444 'lib/Memoize/t/tie_gdbm.t'
touch 'lib/Memoize/t/tie_ndbm.t'
chmod 0444 'lib/Memoize/t/tie_ndbm.t'
touch 'lib/Memoize/t/tie_sdbm.t'
chmod 0444 'lib/Memoize/t/tie_sdbm.t'
touch 'lib/Memoize/t/tie_storable.t'
chmod 0444 'lib/Memoize/t/tie_storable.t'
touch 'lib/Memoize/t/tiefeatures.t'
chmod 0444 'lib/Memoize/t/tiefeatures.t'
touch 'lib/Memoize/t/unmemoize.t'
chmod 0444 'lib/Memoize/t/unmemoize.t'
touch 'lib/NEXT.pm'
chmod 0444 'lib/NEXT.pm'
touch 'lib/NEXT/test.pl'
chmod 0444 'lib/NEXT/test.pl'
touch 'lib/Net/ChangeLog.libnet'
chmod 0444 'lib/Net/ChangeLog.libnet'
touch 'lib/Net/Cmd.pm'
chmod 0444 'lib/Net/Cmd.pm'
touch 'lib/Net/Config.eg'
chmod 0444 'lib/Net/Config.eg'
touch 'lib/Net/Config.pm'
chmod 0444 'lib/Net/Config.pm'
touch 'lib/Net/Domain.pm'
chmod 0444 'lib/Net/Domain.pm'
touch 'lib/Net/FTP.pm'
chmod 0444 'lib/Net/FTP.pm'
touch 'lib/Net/FTP/A.pm'
chmod 0444 'lib/Net/FTP/A.pm'
touch 'lib/Net/FTP/E.pm'
chmod 0444 'lib/Net/FTP/E.pm'
touch 'lib/Net/FTP/I.pm'
chmod 0444 'lib/Net/FTP/I.pm'
touch 'lib/Net/FTP/L.pm'
chmod 0444 'lib/Net/FTP/L.pm'
touch 'lib/Net/FTP/dataconn.pm'
chmod 0444 'lib/Net/FTP/dataconn.pm'
touch 'lib/Net/Hostname.eg'
chmod 0444 'lib/Net/Hostname.eg'
touch 'lib/Net/NNTP.pm'
chmod 0444 'lib/Net/NNTP.pm'
touch 'lib/Net/Netrc.pm'
chmod 0444 'lib/Net/Netrc.pm'
touch 'lib/Net/POP3.pm'
chmod 0444 'lib/Net/POP3.pm'
touch 'lib/Net/README.config'
chmod 0444 'lib/Net/README.config'
touch 'lib/Net/README.libnet'
chmod 0444 'lib/Net/README.libnet'
touch 'lib/Net/SMTP.pm'
chmod 0444 'lib/Net/SMTP.pm'
touch 'lib/Net/Time.pm'
chmod 0444 'lib/Net/Time.pm'
touch 'lib/Net/demos/ftp'
chmod 0444 'lib/Net/demos/ftp'
touch 'lib/Net/demos/inetd'
chmod 0444 'lib/Net/demos/inetd'
touch 'lib/Net/demos/nntp'
chmod 0444 'lib/Net/demos/nntp'
touch 'lib/Net/demos/nntp.mirror'
chmod 0444 'lib/Net/demos/nntp.mirror'
touch 'lib/Net/demos/pop3'
chmod 0444 'lib/Net/demos/pop3'
touch 'lib/Net/demos/smtp.self'
chmod 0444 'lib/Net/demos/smtp.self'
touch 'lib/Net/demos/snpp'
chmod 0444 'lib/Net/demos/snpp'
touch 'lib/Net/demos/time'
chmod 0444 'lib/Net/demos/time'
touch 'lib/Net/hostent.t'
chmod 0444 'lib/Net/hostent.t'
touch 'lib/Net/libnet.ppd'
chmod 0444 'lib/Net/libnet.ppd'
touch 'lib/Net/libnetFAQ.pod'
chmod 0444 'lib/Net/libnetFAQ.pod'
touch 'lib/Net/netent.t'
chmod 0444 'lib/Net/netent.t'
touch 'lib/Net/protoent.t'
chmod 0444 'lib/Net/protoent.t'
touch 'lib/Net/servent.t'
chmod 0444 'lib/Net/servent.t'
touch 'lib/Net/t/ftp.t'
chmod 0444 'lib/Net/t/ftp.t'
touch 'lib/Net/t/hostname.t'
chmod 0444 'lib/Net/t/hostname.t'
touch 'lib/Net/t/nntp.t'
chmod 0444 'lib/Net/t/nntp.t'
touch 'lib/Net/t/require.t'
chmod 0444 'lib/Net/t/require.t'
touch 'lib/Net/t/smtp.t'
chmod 0444 'lib/Net/t/smtp.t'
touch 'lib/Search/Dict.t'
chmod 0444 'lib/Search/Dict.t'
touch 'lib/SelectSaver.t'
chmod 0444 'lib/SelectSaver.t'
touch 'lib/SelfLoader.t'
chmod 0444 'lib/SelfLoader.t'
touch 'lib/Switch/test.pl'
chmod 0444 'lib/Switch/test.pl'
touch 'lib/Symbol.t'
chmod 0444 'lib/Symbol.t'
touch 'lib/Term/ANSIColor/ChangeLog'
chmod 0444 'lib/Term/ANSIColor/ChangeLog'
touch 'lib/Term/ANSIColor/README'
chmod 0444 'lib/Term/ANSIColor/README'
touch 'lib/Term/ANSIColor/test.pl'
chmod 0444 'lib/Term/ANSIColor/test.pl'
touch 'lib/Test/Harness.t'
chmod 0444 'lib/Test/Harness.t'
touch 'lib/Test/More.pm'
chmod 0444 'lib/Test/More.pm'
touch 'lib/Test/More/Changes'
chmod 0444 'lib/Test/More/Changes'
touch 'lib/Test/More/t/More.t'
chmod 0444 'lib/Test/More/t/More.t'
touch 'lib/Test/More/t/fail-like.t'
chmod 0444 'lib/Test/More/t/fail-like.t'
touch 'lib/Test/More/t/fail.t'
chmod 0444 'lib/Test/More/t/fail.t'
touch 'lib/Test/More/t/plan_is_noplan.t'
chmod 0444 'lib/Test/More/t/plan_is_noplan.t'
touch 'lib/Test/More/t/skipall.t'
chmod 0444 'lib/Test/More/t/skipall.t'
touch 'lib/Test/Simple.pm'
chmod 0444 'lib/Test/Simple.pm'
touch 'lib/Test/Simple/Changes'
chmod 0444 'lib/Test/Simple/Changes'
touch 'lib/Test/Simple/t/exit.t'
chmod 0444 'lib/Test/Simple/t/exit.t'
touch 'lib/Test/Simple/t/extra.t'
chmod 0444 'lib/Test/Simple/t/extra.t'
touch 'lib/Test/Simple/t/fail.t'
chmod 0444 'lib/Test/Simple/t/fail.t'
touch 'lib/Test/Simple/t/missing.t'
chmod 0444 'lib/Test/Simple/t/missing.t'
touch 'lib/Test/Simple/t/no_plan.t'
chmod 0444 'lib/Test/Simple/t/no_plan.t'
touch 'lib/Test/Simple/t/plan_is_noplan.t'
chmod 0444 'lib/Test/Simple/t/plan_is_noplan.t'
touch 'lib/Test/Simple/t/simple.t'
chmod 0444 'lib/Test/Simple/t/simple.t'
touch 'lib/Test/t/fail.t'
chmod 0444 'lib/Test/t/fail.t'
touch 'lib/Test/t/mix.t'
chmod 0444 'lib/Test/t/mix.t'
touch 'lib/Test/t/onfail.t'
chmod 0444 'lib/Test/t/onfail.t'
touch 'lib/Test/t/qr.t'
chmod 0444 'lib/Test/t/qr.t'
touch 'lib/Test/t/skip.t'
chmod 0444 'lib/Test/t/skip.t'
touch 'lib/Test/t/success.t'
chmod 0444 'lib/Test/t/success.t'
touch 'lib/Test/t/todo.t'
chmod 0444 'lib/Test/t/todo.t'
touch 'lib/Text/Abbrev.t'
chmod 0444 'lib/Text/Abbrev.t'
touch 'lib/Text/Balanced/t/genxt.t'
chmod 0444 'lib/Text/Balanced/t/genxt.t'
touch 'lib/Text/Balanced/t/xbrak.t'
chmod 0444 'lib/Text/Balanced/t/xbrak.t'
touch 'lib/Text/Balanced/t/xcode.t'
chmod 0444 'lib/Text/Balanced/t/xcode.t'
touch 'lib/Text/Balanced/t/xdeli.t'
chmod 0444 'lib/Text/Balanced/t/xdeli.t'
touch 'lib/Text/Balanced/t/xmult.t'
chmod 0444 'lib/Text/Balanced/t/xmult.t'
touch 'lib/Text/Balanced/t/xquot.t'
chmod 0444 'lib/Text/Balanced/t/xquot.t'
touch 'lib/Text/Balanced/t/xtagg.t'
chmod 0444 'lib/Text/Balanced/t/xtagg.t'
touch 'lib/Text/Balanced/t/xvari.t'
chmod 0444 'lib/Text/Balanced/t/xvari.t'
touch 'lib/Text/ParseWords.t'
chmod 0444 'lib/Text/ParseWords.t'
touch 'lib/Text/Soundex.t'
chmod 0444 'lib/Text/Soundex.t'
touch 'lib/Text/TabsWrap/t/fill.t'
chmod 0444 'lib/Text/TabsWrap/t/fill.t'
touch 'lib/Text/TabsWrap/t/tabs.t'
chmod 0444 'lib/Text/TabsWrap/t/tabs.t'
touch 'lib/Text/TabsWrap/t/wrap.t'
chmod 0444 'lib/Text/TabsWrap/t/wrap.t'
touch 'lib/Tie/Array/push.t'
chmod 0444 'lib/Tie/Array/push.t'
touch 'lib/Tie/Array/splice.t'
chmod 0444 'lib/Tie/Array/splice.t'
touch 'lib/Tie/Array/std.t'
chmod 0444 'lib/Tie/Array/std.t'
touch 'lib/Tie/Array/stdpush.t'
chmod 0444 'lib/Tie/Array/stdpush.t'
touch 'lib/Tie/Handle/stdhandle.t'
chmod 0444 'lib/Tie/Handle/stdhandle.t'
touch 'lib/Tie/RefHash.t'
chmod 0444 'lib/Tie/RefHash.t'
touch 'lib/Tie/SubstrHash.t'
chmod 0444 'lib/Tie/SubstrHash.t'
touch 'lib/Time/Local.t'
chmod 0444 'lib/Time/Local.t'
touch 'lib/Time/gmtime.t'
chmod 0444 'lib/Time/gmtime.t'
touch 'lib/Time/localtime.t'
chmod 0444 'lib/Time/localtime.t'
touch 'lib/UnicodeCD.pm'
chmod 0444 'lib/UnicodeCD.pm'
touch 'lib/UnicodeCD.t'
chmod 0444 'lib/UnicodeCD.t'
touch 'lib/User/grent.t'
chmod 0444 'lib/User/grent.t'
touch 'lib/User/pwent.t'
chmod 0444 'lib/User/pwent.t'
touch 'lib/autouse.t'
chmod 0444 'lib/autouse.t'
touch 'lib/bigfloat.t'
chmod 0444 'lib/bigfloat.t'
touch 'lib/bigint.t'
chmod 0444 'lib/bigint.t'
touch 'lib/charnames.t'
chmod 0444 'lib/charnames.t'
touch 'lib/constant.t'
chmod 0444 'lib/constant.t'
touch 'lib/diagnostics.t'
chmod 0444 'lib/diagnostics.t'
touch 'lib/fields.t'
chmod 0444 'lib/fields.t'
touch 'lib/h2ph.t'
chmod 0444 'lib/h2ph.t'
touch 'lib/h2xs.t'
chmod 0444 'lib/h2xs.t'
touch 'lib/locale.t'
chmod 0444 'lib/locale.t'
touch 'lib/overload.t'
chmod 0444 'lib/overload.t'
touch 'lib/ph.t'
chmod 0444 'lib/ph.t'
touch 'lib/strict.t'
chmod 0444 'lib/strict.t'
touch 'lib/subs.t'
chmod 0444 'lib/subs.t'
touch 'lib/unicode/Blocks.pl'
chmod 0444 'lib/unicode/Blocks.pl'
touch 'lib/unicode/In.pl'
chmod 0444 'lib/unicode/In.pl'
touch 'lib/unicode/In/0.pl'
chmod 0444 'lib/unicode/In/0.pl'
touch 'lib/unicode/In/1.pl'
chmod 0444 'lib/unicode/In/1.pl'
touch 'lib/unicode/In/10.pl'
chmod 0444 'lib/unicode/In/10.pl'
touch 'lib/unicode/In/100.pl'
chmod 0444 'lib/unicode/In/100.pl'
touch 'lib/unicode/In/101.pl'
chmod 0444 'lib/unicode/In/101.pl'
touch 'lib/unicode/In/102.pl'
chmod 0444 'lib/unicode/In/102.pl'
touch 'lib/unicode/In/103.pl'
chmod 0444 'lib/unicode/In/103.pl'
touch 'lib/unicode/In/104.pl'
chmod 0444 'lib/unicode/In/104.pl'
touch 'lib/unicode/In/105.pl'
chmod 0444 'lib/unicode/In/105.pl'
touch 'lib/unicode/In/106.pl'
chmod 0444 'lib/unicode/In/106.pl'
touch 'lib/unicode/In/107.pl'
chmod 0444 'lib/unicode/In/107.pl'
touch 'lib/unicode/In/108.pl'
chmod 0444 'lib/unicode/In/108.pl'
touch 'lib/unicode/In/109.pl'
chmod 0444 'lib/unicode/In/109.pl'
touch 'lib/unicode/In/11.pl'
chmod 0444 'lib/unicode/In/11.pl'
touch 'lib/unicode/In/110.pl'
chmod 0444 'lib/unicode/In/110.pl'
touch 'lib/unicode/In/111.pl'
chmod 0444 'lib/unicode/In/111.pl'
touch 'lib/unicode/In/112.pl'
chmod 0444 'lib/unicode/In/112.pl'
touch 'lib/unicode/In/113.pl'
chmod 0444 'lib/unicode/In/113.pl'
touch 'lib/unicode/In/114.pl'
chmod 0444 'lib/unicode/In/114.pl'
touch 'lib/unicode/In/115.pl'
chmod 0444 'lib/unicode/In/115.pl'
touch 'lib/unicode/In/116.pl'
chmod 0444 'lib/unicode/In/116.pl'
touch 'lib/unicode/In/117.pl'
chmod 0444 'lib/unicode/In/117.pl'
touch 'lib/unicode/In/118.pl'
chmod 0444 'lib/unicode/In/118.pl'
touch 'lib/unicode/In/119.pl'
chmod 0444 'lib/unicode/In/119.pl'
touch 'lib/unicode/In/12.pl'
chmod 0444 'lib/unicode/In/12.pl'
touch 'lib/unicode/In/120.pl'
chmod 0444 'lib/unicode/In/120.pl'
touch 'lib/unicode/In/121.pl'
chmod 0444 'lib/unicode/In/121.pl'
touch 'lib/unicode/In/122.pl'
chmod 0444 'lib/unicode/In/122.pl'
touch 'lib/unicode/In/123.pl'
chmod 0444 'lib/unicode/In/123.pl'
touch 'lib/unicode/In/124.pl'
chmod 0444 'lib/unicode/In/124.pl'
touch 'lib/unicode/In/125.pl'
chmod 0444 'lib/unicode/In/125.pl'
touch 'lib/unicode/In/126.pl'
chmod 0444 'lib/unicode/In/126.pl'
touch 'lib/unicode/In/127.pl'
chmod 0444 'lib/unicode/In/127.pl'
touch 'lib/unicode/In/128.pl'
chmod 0444 'lib/unicode/In/128.pl'
touch 'lib/unicode/In/129.pl'
chmod 0444 'lib/unicode/In/129.pl'
touch 'lib/unicode/In/13.pl'
chmod 0444 'lib/unicode/In/13.pl'
touch 'lib/unicode/In/130.pl'
chmod 0444 'lib/unicode/In/130.pl'
touch 'lib/unicode/In/131.pl'
chmod 0444 'lib/unicode/In/131.pl'
touch 'lib/unicode/In/132.pl'
chmod 0444 'lib/unicode/In/132.pl'
touch 'lib/unicode/In/133.pl'
chmod 0444 'lib/unicode/In/133.pl'
touch 'lib/unicode/In/134.pl'
chmod 0444 'lib/unicode/In/134.pl'
touch 'lib/unicode/In/135.pl'
chmod 0444 'lib/unicode/In/135.pl'
touch 'lib/unicode/In/14.pl'
chmod 0444 'lib/unicode/In/14.pl'
touch 'lib/unicode/In/15.pl'
chmod 0444 'lib/unicode/In/15.pl'
touch 'lib/unicode/In/16.pl'
chmod 0444 'lib/unicode/In/16.pl'
touch 'lib/unicode/In/17.pl'
chmod 0444 'lib/unicode/In/17.pl'
touch 'lib/unicode/In/18.pl'
chmod 0444 'lib/unicode/In/18.pl'
touch 'lib/unicode/In/19.pl'
chmod 0444 'lib/unicode/In/19.pl'
touch 'lib/unicode/In/2.pl'
chmod 0444 'lib/unicode/In/2.pl'
touch 'lib/unicode/In/20.pl'
chmod 0444 'lib/unicode/In/20.pl'
touch 'lib/unicode/In/21.pl'
chmod 0444 'lib/unicode/In/21.pl'
touch 'lib/unicode/In/22.pl'
chmod 0444 'lib/unicode/In/22.pl'
touch 'lib/unicode/In/23.pl'
chmod 0444 'lib/unicode/In/23.pl'
touch 'lib/unicode/In/24.pl'
chmod 0444 'lib/unicode/In/24.pl'
touch 'lib/unicode/In/25.pl'
chmod 0444 'lib/unicode/In/25.pl'
touch 'lib/unicode/In/26.pl'
chmod 0444 'lib/unicode/In/26.pl'
touch 'lib/unicode/In/27.pl'
chmod 0444 'lib/unicode/In/27.pl'
touch 'lib/unicode/In/28.pl'
chmod 0444 'lib/unicode/In/28.pl'
touch 'lib/unicode/In/29.pl'
chmod 0444 'lib/unicode/In/29.pl'
touch 'lib/unicode/In/3.pl'
chmod 0444 'lib/unicode/In/3.pl'
touch 'lib/unicode/In/30.pl'
chmod 0444 'lib/unicode/In/30.pl'
touch 'lib/unicode/In/31.pl'
chmod 0444 'lib/unicode/In/31.pl'
touch 'lib/unicode/In/32.pl'
chmod 0444 'lib/unicode/In/32.pl'
touch 'lib/unicode/In/33.pl'
chmod 0444 'lib/unicode/In/33.pl'
touch 'lib/unicode/In/34.pl'
chmod 0444 'lib/unicode/In/34.pl'
touch 'lib/unicode/In/35.pl'
chmod 0444 'lib/unicode/In/35.pl'
touch 'lib/unicode/In/36.pl'
chmod 0444 'lib/unicode/In/36.pl'
touch 'lib/unicode/In/37.pl'
chmod 0444 'lib/unicode/In/37.pl'
touch 'lib/unicode/In/38.pl'
chmod 0444 'lib/unicode/In/38.pl'
touch 'lib/unicode/In/39.pl'
chmod 0444 'lib/unicode/In/39.pl'
touch 'lib/unicode/In/4.pl'
chmod 0444 'lib/unicode/In/4.pl'
touch 'lib/unicode/In/40.pl'
chmod 0444 'lib/unicode/In/40.pl'
touch 'lib/unicode/In/41.pl'
chmod 0444 'lib/unicode/In/41.pl'
touch 'lib/unicode/In/42.pl'
chmod 0444 'lib/unicode/In/42.pl'
touch 'lib/unicode/In/43.pl'
chmod 0444 'lib/unicode/In/43.pl'
touch 'lib/unicode/In/44.pl'
chmod 0444 'lib/unicode/In/44.pl'
touch 'lib/unicode/In/45.pl'
chmod 0444 'lib/unicode/In/45.pl'
touch 'lib/unicode/In/46.pl'
chmod 0444 'lib/unicode/In/46.pl'
touch 'lib/unicode/In/47.pl'
chmod 0444 'lib/unicode/In/47.pl'
touch 'lib/unicode/In/48.pl'
chmod 0444 'lib/unicode/In/48.pl'
touch 'lib/unicode/In/49.pl'
chmod 0444 'lib/unicode/In/49.pl'
touch 'lib/unicode/In/5.pl'
chmod 0444 'lib/unicode/In/5.pl'
touch 'lib/unicode/In/50.pl'
chmod 0444 'lib/unicode/In/50.pl'
touch 'lib/unicode/In/51.pl'
chmod 0444 'lib/unicode/In/51.pl'
touch 'lib/unicode/In/52.pl'
chmod 0444 'lib/unicode/In/52.pl'
touch 'lib/unicode/In/53.pl'
chmod 0444 'lib/unicode/In/53.pl'
touch 'lib/unicode/In/54.pl'
chmod 0444 'lib/unicode/In/54.pl'
touch 'lib/unicode/In/55.pl'
chmod 0444 'lib/unicode/In/55.pl'
touch 'lib/unicode/In/56.pl'
chmod 0444 'lib/unicode/In/56.pl'
touch 'lib/unicode/In/57.pl'
chmod 0444 'lib/unicode/In/57.pl'
touch 'lib/unicode/In/58.pl'
chmod 0444 'lib/unicode/In/58.pl'
touch 'lib/unicode/In/59.pl'
chmod 0444 'lib/unicode/In/59.pl'
touch 'lib/unicode/In/6.pl'
chmod 0444 'lib/unicode/In/6.pl'
touch 'lib/unicode/In/60.pl'
chmod 0444 'lib/unicode/In/60.pl'
touch 'lib/unicode/In/61.pl'
chmod 0444 'lib/unicode/In/61.pl'
touch 'lib/unicode/In/62.pl'
chmod 0444 'lib/unicode/In/62.pl'
touch 'lib/unicode/In/63.pl'
chmod 0444 'lib/unicode/In/63.pl'
touch 'lib/unicode/In/64.pl'
chmod 0444 'lib/unicode/In/64.pl'
touch 'lib/unicode/In/65.pl'
chmod 0444 'lib/unicode/In/65.pl'
touch 'lib/unicode/In/66.pl'
chmod 0444 'lib/unicode/In/66.pl'
touch 'lib/unicode/In/67.pl'
chmod 0444 'lib/unicode/In/67.pl'
touch 'lib/unicode/In/68.pl'
chmod 0444 'lib/unicode/In/68.pl'
touch 'lib/unicode/In/69.pl'
chmod 0444 'lib/unicode/In/69.pl'
touch 'lib/unicode/In/7.pl'
chmod 0444 'lib/unicode/In/7.pl'
touch 'lib/unicode/In/70.pl'
chmod 0444 'lib/unicode/In/70.pl'
touch 'lib/unicode/In/71.pl'
chmod 0444 'lib/unicode/In/71.pl'
touch 'lib/unicode/In/72.pl'
chmod 0444 'lib/unicode/In/72.pl'
touch 'lib/unicode/In/73.pl'
chmod 0444 'lib/unicode/In/73.pl'
touch 'lib/unicode/In/74.pl'
chmod 0444 'lib/unicode/In/74.pl'
touch 'lib/unicode/In/75.pl'
chmod 0444 'lib/unicode/In/75.pl'
touch 'lib/unicode/In/76.pl'
chmod 0444 'lib/unicode/In/76.pl'
touch 'lib/unicode/In/77.pl'
chmod 0444 'lib/unicode/In/77.pl'
touch 'lib/unicode/In/78.pl'
chmod 0444 'lib/unicode/In/78.pl'
touch 'lib/unicode/In/79.pl'
chmod 0444 'lib/unicode/In/79.pl'
touch 'lib/unicode/In/8.pl'
chmod 0444 'lib/unicode/In/8.pl'
touch 'lib/unicode/In/80.pl'
chmod 0444 'lib/unicode/In/80.pl'
touch 'lib/unicode/In/81.pl'
chmod 0444 'lib/unicode/In/81.pl'
touch 'lib/unicode/In/82.pl'
chmod 0444 'lib/unicode/In/82.pl'
touch 'lib/unicode/In/83.pl'
chmod 0444 'lib/unicode/In/83.pl'
touch 'lib/unicode/In/84.pl'
chmod 0444 'lib/unicode/In/84.pl'
touch 'lib/unicode/In/85.pl'
chmod 0444 'lib/unicode/In/85.pl'
touch 'lib/unicode/In/86.pl'
chmod 0444 'lib/unicode/In/86.pl'
touch 'lib/unicode/In/87.pl'
chmod 0444 'lib/unicode/In/87.pl'
touch 'lib/unicode/In/88.pl'
chmod 0444 'lib/unicode/In/88.pl'
touch 'lib/unicode/In/89.pl'
chmod 0444 'lib/unicode/In/89.pl'
touch 'lib/unicode/In/9.pl'
chmod 0444 'lib/unicode/In/9.pl'
touch 'lib/unicode/In/90.pl'
chmod 0444 'lib/unicode/In/90.pl'
touch 'lib/unicode/In/91.pl'
chmod 0444 'lib/unicode/In/91.pl'
touch 'lib/unicode/In/92.pl'
chmod 0444 'lib/unicode/In/92.pl'
touch 'lib/unicode/In/93.pl'
chmod 0444 'lib/unicode/In/93.pl'
touch 'lib/unicode/In/94.pl'
chmod 0444 'lib/unicode/In/94.pl'
touch 'lib/unicode/In/95.pl'
chmod 0444 'lib/unicode/In/95.pl'
touch 'lib/unicode/In/96.pl'
chmod 0444 'lib/unicode/In/96.pl'
touch 'lib/unicode/In/97.pl'
chmod 0444 'lib/unicode/In/97.pl'
touch 'lib/unicode/In/98.pl'
chmod 0444 'lib/unicode/In/98.pl'
touch 'lib/unicode/In/99.pl'
chmod 0444 'lib/unicode/In/99.pl'
touch 'lib/unicode/Scripts.pl'
chmod 0444 'lib/unicode/Scripts.pl'
touch 'lib/utf8.t'
chmod 0444 'lib/utf8.t'
touch 'lib/vars.t'
chmod 0444 'lib/vars.t'
touch 'lib/warnings.t'
chmod 0444 'lib/warnings.t'
touch 'locale.c'
chmod 0444 'locale.c'
touch 'numeric.c'
chmod 0444 'numeric.c'
touch 'os2/os2_base.t'
chmod 0444 'os2/os2_base.t'
touch 'perlyline.pl'
chmod 0444 'perlyline.pl'
touch 'pod/perl572delta.pod'
chmod 0444 'pod/perl572delta.pod'
touch 'pp_pack.c'
chmod 0444 'pp_pack.c'
touch 't/io/fflush.t'
chmod 0555 't/io/fflush.t'
touch 't/lib/MyFilter.pm'
chmod 0444 't/lib/MyFilter.pm'
touch 't/lib/Test/More/Catch.pm'
chmod 0444 't/lib/Test/More/Catch.pm'
touch 't/lib/Test/Simple/Catch.pm'
chmod 0444 't/lib/Test/Simple/Catch.pm'
touch 't/lib/Test/Simple/sample_tests/death.plx'
chmod 0444 't/lib/Test/Simple/sample_tests/death.plx'
touch 't/lib/Test/Simple/sample_tests/death_in_eval.plx'
chmod 0444 't/lib/Test/Simple/sample_tests/death_in_eval.plx'
touch 't/lib/Test/Simple/sample_tests/extras.plx'
chmod 0444 't/lib/Test/Simple/sample_tests/extras.plx'
touch 't/lib/Test/Simple/sample_tests/five_fail.plx'
chmod 0444 't/lib/Test/Simple/sample_tests/five_fail.plx'
touch 't/lib/Test/Simple/sample_tests/last_minute_death.plx'
chmod 0444 't/lib/Test/Simple/sample_tests/last_minute_death.plx'
touch 't/lib/Test/Simple/sample_tests/one_fail.plx'
chmod 0444 't/lib/Test/Simple/sample_tests/one_fail.plx'
touch 't/lib/Test/Simple/sample_tests/require.plx'
chmod 0444 't/lib/Test/Simple/sample_tests/require.plx'
touch 't/lib/Test/Simple/sample_tests/success.plx'
chmod 0444 't/lib/Test/Simple/sample_tests/success.plx'
touch 't/lib/Test/Simple/sample_tests/too_few.plx'
chmod 0444 't/lib/Test/Simple/sample_tests/too_few.plx'
touch 't/lib/Test/Simple/sample_tests/two_fail.plx'
chmod 0444 't/lib/Test/Simple/sample_tests/two_fail.plx'
touch 't/lib/locale/latin1'
chmod 0444 't/lib/locale/latin1'
touch 't/lib/locale/utf8'
chmod 0444 't/lib/locale/utf8'
touch 't/lib/strict/refs'
chmod 0444 't/lib/strict/refs'
touch 't/lib/strict/subs'
chmod 0444 't/lib/strict/subs'
touch 't/lib/strict/vars'
chmod 0444 't/lib/strict/vars'
touch 't/lib/warnings/1global'
chmod 0444 't/lib/warnings/1global'
touch 't/lib/warnings/2use'
chmod 0444 't/lib/warnings/2use'
touch 't/lib/warnings/3both'
chmod 0444 't/lib/warnings/3both'
touch 't/lib/warnings/4lint'
chmod 0444 't/lib/warnings/4lint'
touch 't/lib/warnings/5nolint'
chmod 0444 't/lib/warnings/5nolint'
touch 't/lib/warnings/6default'
chmod 0444 't/lib/warnings/6default'
touch 't/lib/warnings/7fatal'
chmod 0444 't/lib/warnings/7fatal'
touch 't/lib/warnings/8signal'
chmod 0444 't/lib/warnings/8signal'
touch 't/lib/warnings/9enabled'
chmod 0444 't/lib/warnings/9enabled'
touch 't/lib/warnings/av'
chmod 0444 't/lib/warnings/av'
touch 't/lib/warnings/doio'
chmod 0444 't/lib/warnings/doio'
touch 't/lib/warnings/doop'
chmod 0444 't/lib/warnings/doop'
touch 't/lib/warnings/gv'
chmod 0444 't/lib/warnings/gv'
touch 't/lib/warnings/hv'
chmod 0444 't/lib/warnings/hv'
touch 't/lib/warnings/malloc'
chmod 0444 't/lib/warnings/malloc'
touch 't/lib/warnings/mg'
chmod 0444 't/lib/warnings/mg'
touch 't/lib/warnings/op'
chmod 0444 't/lib/warnings/op'
touch 't/lib/warnings/perl'
chmod 0444 't/lib/warnings/perl'
touch 't/lib/warnings/perlio'
chmod 0444 't/lib/warnings/perlio'
touch 't/lib/warnings/perly'
chmod 0444 't/lib/warnings/perly'
touch 't/lib/warnings/pp'
chmod 0444 't/lib/warnings/pp'
touch 't/lib/warnings/pp_ctl'
chmod 0444 't/lib/warnings/pp_ctl'
touch 't/lib/warnings/pp_hot'
chmod 0444 't/lib/warnings/pp_hot'
touch 't/lib/warnings/pp_pack'
chmod 0444 't/lib/warnings/pp_pack'
touch 't/lib/warnings/pp_sys'
chmod 0444 't/lib/warnings/pp_sys'
touch 't/lib/warnings/regcomp'
chmod 0444 't/lib/warnings/regcomp'
touch 't/lib/warnings/regexec'
chmod 0444 't/lib/warnings/regexec'
touch 't/lib/warnings/run'
chmod 0444 't/lib/warnings/run'
touch 't/lib/warnings/sv'
chmod 0444 't/lib/warnings/sv'
touch 't/lib/warnings/taint'
chmod 0444 't/lib/warnings/taint'
touch 't/lib/warnings/toke'
chmod 0444 't/lib/warnings/toke'
touch 't/lib/warnings/universal'
chmod 0444 't/lib/warnings/universal'
touch 't/lib/warnings/utf8'
chmod 0444 't/lib/warnings/utf8'
touch 't/lib/warnings/util'
chmod 0444 't/lib/warnings/util'
touch 't/op/gmagic.t'
chmod 0555 't/op/gmagic.t'
touch 't/op/override.t'
chmod 0555 't/op/override.t'
touch 't/op/sub_lval.t'
chmod 0555 't/op/sub_lval.t'
touch 't/pod/plainer.t'
chmod 0555 't/pod/plainer.t'
touch 't/run/exit.t'
chmod 0555 't/run/exit.t'
touch 'utils.lst'
chmod 0444 'utils.lst'
touch 'utils/libnetcfg.PL'
chmod 0444 'utils/libnetcfg.PL'
touch 'uts/sprintf_wrap.c'
chmod 0444 'uts/sprintf_wrap.c'
touch 'uts/strtol_wrap.c'
chmod 0444 'uts/strtol_wrap.c'
touch 'vos/Makefile'
chmod 0444 'vos/Makefile'
touch 'win32/mdelete.bat'
chmod 0444 'win32/mdelete.bat'
touch 'win32/win32io.c'
chmod 0444 'win32/win32io.c'
rmdir 't/pragma/warn'
rmdir 't/pragma/locale'
rmdir 't/pragma'
rmdir 't/camel-III'
#
# This command terminates the shell and need not be executed manually.
exit
#
#### End of Preamble ####
#### Patch data follows ####
diff -c 'perl-5.7.1/patchlevel.h' 'perl-5.7.2/patchlevel.h'
Index: ./patchlevel.h
*** ./patchlevel.h Tue Apr 10 05:10:26 2001
--- ./patchlevel.h Fri Jul 13 17:14:12 2001
***************
*** 5,11 ****
#define PERL_REVISION 5 /* age */
#define PERL_VERSION 7 /* epoch */
! #define PERL_SUBVERSION 1 /* generation */
/* The following numbers describe the earliest compatible version of
Perl ("compatibility" here being defined as sufficient binary/API
--- 5,11 ----
#define PERL_REVISION 5 /* age */
#define PERL_VERSION 7 /* epoch */
! #define PERL_SUBVERSION 2 /* generation */
/* The following numbers describe the earliest compatible version of
Perl ("compatibility" here being defined as sufficient binary/API
diff -c 'perl-5.7.1/AUTHORS' 'perl-5.7.2/AUTHORS'
Index: ./AUTHORS
*** ./AUTHORS Mon Apr 9 17:18:00 2001
--- ./AUTHORS Fri Jul 13 16:56:13 2001
***************
*** 1,13 ****
# To give due honor to those who have made Perl 5 what is is today,
# here are easily-from-changelogs-extractable people and their
! # (hopefully) current and preferred email addresses (as of late 2000
# if known) from the Changes files. These people have either submitted
# patches or suggestions, or their bug reports or comments have inspired
! # the appropriate patches. Corrections, additions, deletions welcome.
#
--
A. C. Yardley <yardley@tanet.net>
Aaron B. Dossett <aaron@iglou.com>
Abigail <abigail@foad.org>
Achim Bohnet <ach@mpe.mpg.de>
Adam Krolnik <adamk@gypsy.cyrix.com>
--- 1,19 ----
# To give due honor to those who have made Perl 5 what is is today,
# here are easily-from-changelogs-extractable people and their
! # (hopefully) current and preferred email addresses (as of early 2001,
# if known) from the Changes files. These people have either submitted
# patches or suggestions, or their bug reports or comments have inspired
! # the appropriate patches. Corrections, additions, deletions welcome;
! # send them to perl5-porters@perl.org, preferably as the output of diff(1),
! # diff -u or diff -c between the original and a corrected version of this file.
#
+ # The use of this database for anything else than Perl development
+ # is strictly forbidden. (Passive distribution with the Perl source
+ # code kit is naturally allowed.)
--
A. C. Yardley <yardley@tanet.net>
Aaron B. Dossett <aaron@iglou.com>
+ Abhijit Menon-Sen <ams@wiw.org>
Abigail <abigail@foad.org>
Achim Bohnet <ach@mpe.mpg.de>
Adam Krolnik <adamk@gypsy.cyrix.com>
***************
*** 19,33 ****
--- 25,42 ----
Albert Chin-A-Young <china@thewrittenword.com>
Albert Dvornik <bert@genscan.com>
Alex Cough <alex@rcon.rog>
+ Alexander Gough <alexander.gough@st-hughs.oxford.ac.uk>
Alexander Smishlajev <als@turnhere.com>
Alexey V. Barantzev <barancev@kazbek.ispras.ru>
Allen Smith <easmith@beatrice.rutgers.edu>
Ambrose Kofi Laing
+ Ananth Kesari <HYanantha@novell.com>
Andreas Klussmann <andreas@infosys.heitec.de>
Andreas K�nig <a.koenig@mind.de>
Andreas Schwab <schwab@suse.de>
Andrew Bettison <andrewb@zip.com.au>
Andrew Cohen <cohen@andy.bu.edu>
+ andrew deryabin <djsf@technarchy.ru>
Andrew M. Langmead <aml@world.std.com>
Andrew Pimlott <pimlott@abel.math.harvard.edu>
Andrew Vignaux <ajv@nz.sangacorp.com>
***************
*** 37,43 ****
Anthony David <adavid@netinfo.com.au>
Anton Berezin <tobez@tobez.org>
Art Green <Art_Green@mercmarine.com>
! Artur <artur@vogon-solutions.com>
Barrie Slaymaker <barries@slaysys.com>
Barry Friedman
Ben Tilly <ben_tilly@hotmail.com>
--- 46,52 ----
Anthony David <adavid@netinfo.com.au>
Anton Berezin <tobez@tobez.org>
Art Green <Art_Green@mercmarine.com>
! Artur Bergman <artur@contiller.se>
Barrie Slaymaker <barries@slaysys.com>
Barry Friedman
Ben Tilly <ben_tilly@hotmail.com>
***************
*** 60,67 ****
Brian Clarke <clarke@appliedmeta.com>
Brian Grossman
Brian Harrison <brie@corp.home.net>
! Brian Jepson <bjepson@home.com>
Brian Katzung
Brian Reichert <reichert@internet.com>
Brian S. Cashman <bsc@umich.edu>
Bruce Barnett <barnett@grymoire.crd.ge.com>
--- 69,77 ----
Brian Clarke <clarke@appliedmeta.com>
Brian Grossman
Brian Harrison <brie@corp.home.net>
! Brian Jepson <bjepson@oreilly.com>
Brian Katzung
+ Brian McCauley <nobull@mail.com>
Brian Reichert <reichert@internet.com>
Brian S. Cashman <bsc@umich.edu>
Bruce Barnett <barnett@grymoire.crd.ge.com>
***************
*** 70,79 ****
Bud Huff <BAHUFF@us.oracle.com>
Byron Brummer <byron@omix.com>
Calle Dybedahl <calle@lysator.liu.se>
Carl M. Fongheiser <cmf@ins.infonet.net>
Carl Witty <cwitty@newtonlabs.com>
Cary D. Renzema <caryr@mxim.com>
! Casey R. Tweten <crt@kiski.net>
Castor Fu
Chaim Frenkel <chaimf@pobox.com>
Charles Bailey <bailey@newman.upenn.edu>
--- 80,90 ----
Bud Huff <BAHUFF@us.oracle.com>
Byron Brummer <byron@omix.com>
Calle Dybedahl <calle@lysator.liu.se>
+ Carl Eklof <CEklof@endeca.com>
Carl M. Fongheiser <cmf@ins.infonet.net>
Carl Witty <cwitty@newtonlabs.com>
Cary D. Renzema <caryr@mxim.com>
! Casey West <casey@geeknest.com>
Castor Fu
Chaim Frenkel <chaimf@pobox.com>
Charles Bailey <bailey@newman.upenn.edu>
***************
*** 81,86 ****
--- 92,98 ----
Charles Lane <lane@DUPHY4.Physics.Drexel.Edu>
Charles Wilson <cwilson@ece.gatech.edu>
Chip Salzenberg <chip@pobox.com>
+ Chris Bongaarts <cab@tc.umn.edu>
Chris Faylor <cgf@bbc.com>
Chris Nandor <pudge@pobox.com>
Chris Wick <cwick@lmc.com>
***************
*** 102,115 ****
Damian Conway <damian@cs.monash.edu.au>
Damon Atkins <Damon.Atkins@nabaus.com.au>
Dan Boorstein <dan_boo@bellsouth.net>
- Dan Carson <dbc@tc.fluke.COM>
Dan Hale <danhale@us.ibm.com>
Dan Schmidt <dfan@harmonixmusic.com>
Dan Sugalski <dan@sidhe.org>
Daniel Chetlin <daniel@chetlin.com>
Daniel Grisinger <dgris@dimensional.com>
Daniel Mui�o <dmuino@afip.gov.ar>
! Daniel S. Lewart <lewart@vadds.cvm.uiuc.edu>
Daniel Yacob <dmulholl@cs.indiana.edu>
Danny R. Faught <faught@mailhost.rsn.hp.com>
Danny Sadinoff <sadinoff@olf.com>
--- 114,127 ----
Damian Conway <damian@cs.monash.edu.au>
Damon Atkins <Damon.Atkins@nabaus.com.au>
Dan Boorstein <dan_boo@bellsouth.net>
Dan Hale <danhale@us.ibm.com>
Dan Schmidt <dfan@harmonixmusic.com>
Dan Sugalski <dan@sidhe.org>
Daniel Chetlin <daniel@chetlin.com>
Daniel Grisinger <dgris@dimensional.com>
+ Daniel Lieberman <daniel@bitpusher.com>
Daniel Mui�o <dmuino@afip.gov.ar>
! Daniel S. Lewart <d-lewart@uiuc.edu>
Daniel Yacob <dmulholl@cs.indiana.edu>
Danny R. Faught <faught@mailhost.rsn.hp.com>
Danny Sadinoff <sadinoff@olf.com>
***************
*** 128,135 ****
David F. Haertig <dfh@dwroll.lucent.com>
David Filo
David Glasser <me@davidglasser.net>
- David Hammen <hammen@gothamcity.jsc.nasa.gov>
David H. Adler <dha@panix.com>
David J. Fiander <davidf@mks.com>
David Kerry <davidk@tor.securecomputing.com>
David Mitchell <davem@fdgroup.co.uk>
--- 140,147 ----
David F. Haertig <dfh@dwroll.lucent.com>
David Filo
David Glasser <me@davidglasser.net>
David H. Adler <dha@panix.com>
+ David Hammen <hammen@gothamcity.jsc.nasa.gov>
David J. Fiander <davidf@mks.com>
David Kerry <davidk@tor.securecomputing.com>
David Mitchell <davem@fdgroup.co.uk>
***************
*** 142,152 ****
Dean Roehrich <roehrich@cray.com>
Dennis Marsa <dennism@cyrix.com>
dive <dive@ender.com>
Dominic Dunlop <domo@computer.org>
Dominique Dumont <Dominique_Dumont@grenoble.hp.com>
Doug Campbell <soup@ampersand.com>
Doug MacEachern <dougm@covalent.net>
! Douglas E. Wegscheid <wegscd@whirlpool.com>
Douglas Lankshear <dougl@activestate.com>
Dov Grobgeld <dov@Orbotech.Co.IL>
Drago Goricanec <drago@raptor.otsd.ts.fujitsu.co.jp>
--- 154,166 ----
Dean Roehrich <roehrich@cray.com>
Dennis Marsa <dennism@cyrix.com>
dive <dive@ender.com>
+ dLux <dlux@spam.sch.bme.hu>
Dominic Dunlop <domo@computer.org>
Dominique Dumont <Dominique_Dumont@grenoble.hp.com>
Doug Campbell <soup@ampersand.com>
Doug MacEachern <dougm@covalent.net>
! Doug Wilson <Doug_Wilson@intuit.com>
! Douglas E. Wegscheid <dwegscheid@qtm.net>
Douglas Lankshear <dougl@activestate.com>
Dov Grobgeld <dov@Orbotech.Co.IL>
Drago Goricanec <drago@raptor.otsd.ts.fujitsu.co.jp>
***************
*** 154,159 ****
--- 168,174 ----
Ed Peschko <epeschko@den-mdev1>
Edward Avis <epa98@doc.ic.ac.uk>
Edward Peschko <edwardp@excitehome.net>
+ Edward Moy <emoy@apple.com>
Elaine -HFB- Ashton <elaine@chaos.wustl.edu>
Eric Arnold <eric.arnold@sun.com>
Eric Bartley <bartley@icd.cc.purdue.edu>
***************
*** 176,186 ****
Garry T. Williams <garry@zvolve.com>
Gary Clark <GaryC@mail.jeld-wen.com>
Gary Ng <71564.1743@compuserve.com>
Gerben Wierda <G.C.Th.Wierda@AWT.nl>
- Gerrit P. Haase <gerrit.haase@t-online.de>
Gerd Knops <gerti@BITart.com>
Giles Lean <giles@nemeton.com.au>
Gisle Aas <gisle@aas.no>
Gordon J. Miller <gjm@cray.com>
Grace Lee <grace@hal.com>
Graham Barr <gbarr@pobox.com>
--- 191,203 ----
Garry T. Williams <garry@zvolve.com>
Gary Clark <GaryC@mail.jeld-wen.com>
Gary Ng <71564.1743@compuserve.com>
+ Geraint A Edwards <gedge@serf.org>
Gerben Wierda <G.C.Th.Wierda@AWT.nl>
Gerd Knops <gerti@BITart.com>
+ Gerrit P. Haase <gerrit.haase@t-online.de>
Giles Lean <giles@nemeton.com.au>
Gisle Aas <gisle@aas.no>
+ Golubev I. N. <gin@mo.msk.ru>
Gordon J. Miller <gjm@cray.com>
Grace Lee <grace@hal.com>
Graham Barr <gbarr@pobox.com>
***************
*** 194,212 ****
Gregory Martin Pfeil <pfeilgm@technomadic.org>
Guenter Schmidt <gsc@bruker.de>
Guido Flohr <gufl0000@stud.uni-sb.de>
Gurusamy Sarathy <gsar@activestate.com>
Gustaf Neumann
Guy Decoux <decoux@moulon.inra.fr>
H.J. Lu <hjl@nynexst.com>
H.Merijn Brand <h.m.brand@hccnet.nl>
Hal Pomeranz <pomeranz@netcom.com>
Hallvard B Furuseth <h.b.furuseth@usit.uio.no>
Hannu Napari <Hannu.Napari@hut.fi>
Hans Ginzel <hans@kolej.mff.cuni.cz>
- Hans de Graaff <J.J.deGraaff@twi.tudelft.nl>
Hans Mulder <hansmu@xs4all.nl>
! Harri Pasanen <harri.pasanen@trema.com>
Harold O Morris <hom00@utsglobal.com>
Harry Edmon <harry@atmos.washington.edu>
Helmut Jarausch <jarausch@numa1.igpm.rwth-aachen.de>
Henrik Tougaard <ht.000@foa.dk>
--- 211,233 ----
Gregory Martin Pfeil <pfeilgm@technomadic.org>
Guenter Schmidt <gsc@bruker.de>
Guido Flohr <gufl0000@stud.uni-sb.de>
+ Guruprasad S <SGURUPRASAD@novell.com>
Gurusamy Sarathy <gsar@activestate.com>
Gustaf Neumann
Guy Decoux <decoux@moulon.inra.fr>
+ Gwyn Judd <b.judd@xtra.co.nz>
H.J. Lu <hjl@nynexst.com>
H.Merijn Brand <h.m.brand@hccnet.nl>
+ Hal Morris <hom00@utsglobal.com>
Hal Pomeranz <pomeranz@netcom.com>
Hallvard B Furuseth <h.b.furuseth@usit.uio.no>
Hannu Napari <Hannu.Napari@hut.fi>
Hans Ginzel <hans@kolej.mff.cuni.cz>
Hans Mulder <hansmu@xs4all.nl>
! Hans de Graaff <J.J.deGraaff@twi.tudelft.nl>
! Harmon S. Nine <hnine@netarx.com>
Harold O Morris <hom00@utsglobal.com>
+ Harri Pasanen <harri.pasanen@trema.com>
Harry Edmon <harry@atmos.washington.edu>
Helmut Jarausch <jarausch@numa1.igpm.rwth-aachen.de>
Henrik Tougaard <ht.000@foa.dk>
***************
*** 258,267 ****
Jens T. Berger Thielemann <jensthi@ifi.uio.no>
Jens Thomsen <jens@fiend.cis.com>
Jens-Uwe Mager <jum@helios.de>
Jeremy H. Brown <jhbrown@ai.mit.edu>
Jeremy Madea <jmadea@inktomi.com>
- Jeremy D. Zawodny <jzawodn@wcnet.org>
Jerome Abela <abela@hsc.fr>
Jim Anderson <jander@ml.com>
Jim Avera <avera@hal.com>
Jim Balter
--- 279,289 ----
Jens T. Berger Thielemann <jensthi@ifi.uio.no>
Jens Thomsen <jens@fiend.cis.com>
Jens-Uwe Mager <jum@helios.de>
+ Jeremy D. Zawodny <jzawodn@wcnet.org>
Jeremy H. Brown <jhbrown@ai.mit.edu>
Jeremy Madea <jmadea@inktomi.com>
Jerome Abela <abela@hsc.fr>
+ Jes�s Quiroga <jquiroga@pobox.com>
Jim Anderson <jander@ml.com>
Jim Avera <avera@hal.com>
Jim Balter
***************
*** 271,276 ****
--- 293,299 ----
Joachim Huober
Jochen Wiedmann <joe@ispsoft.de>
Joe Buehler <jbuehler@hekimian.com>
+ Joe Orton <jorton@redhat.com>
Joe Smith <jsmith@inwap.com>
Joel Rosi-Schwartz <j.schwartz@agonet.it>
Joerg Porath <Joerg.Porath@informatik.tu-chemnitz.de>
***************
*** 283,299 ****
John Cerney <j-cerney1@ti.com>
John D Groenveld <groenvel@cse.psu.edu>
John Hasstedt <John.Hasstedt@sunysb.edu>
John Hughes <john@AtlanTech.COM>
John L. Allen <allen@grumman.com>
John Macdonald <jmm@revenge.elegant.com>
John Nolan <jpnolan@Op.Net>
John Peacock <jpeacock@rowman.com>
John Pfuntner <pfuntner@vnet.ibm.com>
- John P. Linderman <jpl@research.att.com>
John Rowe
John Salinas <jsalinas@cray.com>
John Stoffel <jfs@fluent.com>
John Tobey <jtobey@john-edwin-tobey.org>
Jon Orwant <orwant@oreilly.com>
Jonathan Biggar <jon@sems.com>
Jonathan D Johnston <jdjohnston2@juno.com>
--- 306,325 ----
John Cerney <j-cerney1@ti.com>
John D Groenveld <groenvel@cse.psu.edu>
John Hasstedt <John.Hasstedt@sunysb.edu>
+ John Holdsworth <coldwvae@bigfoot.com>
John Hughes <john@AtlanTech.COM>
John L. Allen <allen@grumman.com>
John Macdonald <jmm@revenge.elegant.com>
John Nolan <jpnolan@Op.Net>
+ John P. Linderman <jpl@research.att.com>
John Peacock <jpeacock@rowman.com>
John Pfuntner <pfuntner@vnet.ibm.com>
John Rowe
John Salinas <jsalinas@cray.com>
John Stoffel <jfs@fluent.com>
John Tobey <jtobey@john-edwin-tobey.org>
+ Jon Eveland <jweveland@yahoo.com>
+ Jon Gunnip <jongunnip@hotmail.com>
Jon Orwant <orwant@oreilly.com>
Jonathan Biggar <jon@sems.com>
Jonathan D Johnston <jdjohnston2@juno.com>
***************
*** 306,311 ****
--- 332,338 ----
Joshua E. Rodd <jrodd@pbs.org>
Joshua Pritikin <joshua.pritikin@db.com>
Juan Gallego <Little.Boss@physics.mcgill.ca>
+ Juha Laiho <juha.laiho@Elma.Net>
Julian Yip <julian@imoney.com>
Justin Banks <justinb@cray.com>
Ka-Ping Yee <kpyee@aw.sgi.com>
***************
*** 329,345 ****
Kim Frutiger
Kragen Sitaker <kragen@dnaco.net>
Krishna Sethuraman <krishna@sgi.com>
! Kurt D. Starsinic <kstar@smithrenaud.com>
Kyriakos Georgiou
Larry Parmelee <parmelee@CS.Cornell.EDU>
Larry Schuler
Larry Schwimmer <rosebud@cyclone.Stanford.EDU>
Larry W. Virden <lvirden@cas.org>
Larry Wall <larry@wall.org>
Lars Hecking <lhecking@nmrc.ucc.ie>
Laszlo Molnar <laszlo.molnar@eth.ericsson.se>
- Leon Brocard <acme@astray.com>
Len Johnson <lenjay@ibm.net>
Les Peters <lpeters@aol.net>
Lincoln D. Stein <lstein@cshl.org>
Lionel Cons <lionel.cons@cern.ch>
--- 356,373 ----
Kim Frutiger
Kragen Sitaker <kragen@dnaco.net>
Krishna Sethuraman <krishna@sgi.com>
! Kurt D. Starsinic <kstar@wolfetech.com>
Kyriakos Georgiou
Larry Parmelee <parmelee@CS.Cornell.EDU>
Larry Schuler
Larry Schwimmer <rosebud@cyclone.Stanford.EDU>
+ Larry Shatzer <lshatzer@islanddata.com>
Larry W. Virden <lvirden@cas.org>
Larry Wall <larry@wall.org>
Lars Hecking <lhecking@nmrc.ucc.ie>
Laszlo Molnar <laszlo.molnar@eth.ericsson.se>
Len Johnson <lenjay@ibm.net>
+ Leon Brocard <acme@astray.com>
Les Peters <lpeters@aol.net>
Lincoln D. Stein <lstein@cshl.org>
Lionel Cons <lionel.cons@cern.ch>
***************
*** 374,381 ****
Mark-Jason Dominus <mjd@plover.com>
Martien Verbruggen <mgjv@comdyn.com.au>
Martijn Koster <mak@excitecorp.com>
! Martin J. Bligh <mbligh@sequent.com>
! Martin Husemann <martin@duskware.de.
Martin Jost <Martin.Jost@icn.siemens.de>
Martin Lichtin <lichtin@bivio.com>
Martin Plechsmid <plechsmi@karlin.mff.cuni.cz>
--- 402,409 ----
Mark-Jason Dominus <mjd@plover.com>
Martien Verbruggen <mgjv@comdyn.com.au>
Martijn Koster <mak@excitecorp.com>
! Martin Husemann <martin@duskware.de>
! Martin J. Bligh <mbligh@us.ibm.com>
Martin Jost <Martin.Jost@icn.siemens.de>
Martin Lichtin <lichtin@bivio.com>
Martin Plechsmid <plechsmi@karlin.mff.cuni.cz>
***************
*** 391,396 ****
--- 419,425 ----
Matthias Ulrich Neeracher <neeri@iis.ee.ethz.ch>
Matthias Urlichs <smurf@noris.net>
Maurizio Loreti <maurizio.loreti@pd.infn.it>
+ Merijn Broeren <merijnb@iloquent.nl>
Michael Cook <mcook@cognex.com>
Michael De La Rue <mikedlr@tardis.ed.ac.uk>
Michael Engel <engel@nms1.cc.huji.ac.il>
***************
*** 404,415 ****
Mike Hopkirk <hops@sco.com>
Mike Mestnik <MMestnik@rustconsulting.com>
Mike Rogers
Mike Stok <mike@stok.co.uk>
Mike W Ellwood <mwe@rl.ac.uk>
Milton Hankins <webtools@uewrhp03.msd.ray.com>
Milton L. Hankins <mlh@swl.msd.ray.com>
! Molnar Laszlo <molnarl@cdata.tvnet.hu>
! Murray Nesbitt <mjn@pathcom.com>
Nathan Kurz <nate@valleytel.net>
Nathan Torkington <gnat@frii.com>
Neale Ferguson <neale@VMA.TABNSW.COM.AU>
--- 433,444 ----
Mike Hopkirk <hops@sco.com>
Mike Mestnik <MMestnik@rustconsulting.com>
Mike Rogers
+ Mike Schilli <m@perlmeister.com>
Mike Stok <mike@stok.co.uk>
Mike W Ellwood <mwe@rl.ac.uk>
Milton Hankins <webtools@uewrhp03.msd.ray.com>
Milton L. Hankins <mlh@swl.msd.ray.com>
! Murray Nesbitt <murray@nesbitt.ca>
Nathan Kurz <nate@valleytel.net>
Nathan Torkington <gnat@frii.com>
Neale Ferguson <neale@VMA.TABNSW.COM.AU>
***************
*** 439,444 ****
--- 468,474 ----
Paul Schinder <schinder@pobox.com>
Pete Peterson <petersonp@genrad.com>
Peter Chines <pchines@nhgri.nih.gov>
+ Peter Gessner <peter.gessner@post.rwth-aachen.de>
Peter Gordon <peter@valor.com>
Peter Haworth <pmh@edison.ioppublishing.com>
Peter J. Farley III <pjfarley@banet.net>
***************
*** 456,466 ****
--- 486,499 ----
Prymmer/Kahn <pvhp@best.com>
Quentin Fennessy <quentin@arrakeen.amd.com>
Radu Greab <radu@netsoft.ro>
+ Rajesh Vaidheeswarran <rv@gnu.org>
Ralf S. Engelschall <rse@engelschall.com>
Randal L. Schwartz <merlyn@stonehenge.com>
+ Randall Gellens <randy@qualcomm.com>
Randy J. Ray <rjray@redhat.com>
Raphael Manfredi <Raphael.Manfredi@pobox.com>
Raymund Will <ray@caldera.de>
+ Reini Urban <rurban@sbox.tu-graz.ac.at>
Rex Dieter <rdieter@math.unl.edu>
Rich Morin <rdm@cfcl.com>
Rich Salz <rsalz@bbn.com>
***************
*** 468,474 ****
Richard Foley <Richard.Foley@m.dasa.de>
Richard L. England <richard_england@mentorg.com>
Richard L. Maus, Jr. <rmaus@monmouth.com>
! Richard Soderberg <rs@crystalflame.net>
Richard Yeh <rcyeh@cco.caltech.edu>
Rick Delaney <rick@consumercontact.com>
Rick Pluta
--- 501,507 ----
Richard Foley <Richard.Foley@m.dasa.de>
Richard L. England <richard_england@mentorg.com>
Richard L. Maus, Jr. <rmaus@monmouth.com>
! Richard Soderberg <p5-authors@crystalflame.net>
Richard Yeh <rcyeh@cco.caltech.edu>
Rick Delaney <rick@consumercontact.com>
Rick Pluta
***************
*** 490,499 ****
--- 523,535 ----
Russell Fulton <russell@ccu1.auckland.ac.nz>
Russell Mosemann
Ryan Herbert <rherbert@sycamorehq.com>
+ SADAHIRO Tomoyuki <BQW10602@nifty.com>
SAKAI Kiyotaka <ksakai@netwk.ntt-at.co.jp>
Samuli K�rkk�inen <skarkkai@woods.iki.fi>
+ Scott Bronson <bronson@rinspin.com>
Scott Gifford <sgifford@tir.com>
Scott Henry <scotth@sgi.com>
+ Scott L. Miller <Scott.L.Miller@Compaq.com>
Sean Robinson <robinson_s@sc.maricopa.edu>
Sean Sheedy <seans@ncube.com>
Sebastien Barre <Sebastien.Barre@utc.fr>
***************
*** 524,533 ****
Steven Parkes <parkes@sierravista.com>
Sven Verdoolaege <skimo@breughel.ufsia.ac.be>
SynaptiCAD, Inc. <sales@syncad.com>
Taro KAWAGISHI
Ted Ashton <ashted@southern.edu>
Ted Law <tedlaw@cibcwg.com>
! Tels <perl_dummy@bloodgate.com>
Teun Burgers <burgers@ecn.nl>
Thad Floryan <thad@thadlabs.com>
Thomas Bowditch <bowditch@inmet.com>
--- 560,570 ----
Steven Parkes <parkes@sierravista.com>
Sven Verdoolaege <skimo@breughel.ufsia.ac.be>
SynaptiCAD, Inc. <sales@syncad.com>
+ Takis Psarogiannakopoulos <takis@xfree86.org>
Taro KAWAGISHI
Ted Ashton <ashted@southern.edu>
Ted Law <tedlaw@cibcwg.com>
! Tels
Teun Burgers <burgers@ecn.nl>
Thad Floryan <thad@thadlabs.com>
Thomas Bowditch <bowditch@inmet.com>
***************
*** 535,540 ****
--- 572,578 ----
Thomas Dorner <Thomas.Dorner@start.de>
Thomas Kofler
Thomas K�nig
+ Thomas Wegner <wegner_thomas@yahoo.com>
Tim Adye <T.J.Adye@rl.ac.uk>
Tim Ayers <tayers@bridge.com>
Tim Bunce <Tim.Bunce@ig.co.uk>
***************
*** 542,547 ****
--- 580,586 ----
Tim Freeman <tfreeman@infoseek.com>
Tim Jenness <t.jenness@jach.hawaii.edu>
Tim Mooney <mooney@dogbert.cc.ndsu.NoDak.edu>
+ Tim Sweetman <tim@aldigital.co.uk>
Tim Witham <twitham@pcocd2.intel.com>
Timur I. Bakeyev <bsdi@listserv.bat.ru>
Tkil <tkil@reptile.scrye.com>
***************
*** 553,558 ****
--- 592,598 ----
Tom Hughes <tom@compton.nu>
Tom Phoenix <rootbeer@teleport.com>
Tom Spindler <dogcow@isi.net>
+ Tony Bowden <tony@kasei.com>
Tony Camas
Tony Cook <tony@develop-help.com>
Tony Sanders <sanders@bsdi.com>
***************
*** 568,579 ****
Vlad Harchev <hvv@hippo.ru>
Vladimir Alexiev <vladimir@cs.ualberta.ca>
W. Phillip Moore <wpm@ms.com>
Warren Hyde <whyde@pezz.sps.mot.com>
Warren Jones <wjones@tc.fluke.com>
Wayne Berke <berke@panix.com>
Wayne Scott <wscott@ichips.intel.com>
Wayne Thompson <Wayne.Thompson@Ebay.sun.com>
! Wilfredo S�nchez <wsanchez@apple.com>
William J. Middleton <William.Middleton@oslo.mobil.telenor.no>
William Mann <wmann@avici.com>
William R Ward <hermit@BayView.COM>
--- 608,620 ----
Vlad Harchev <hvv@hippo.ru>
Vladimir Alexiev <vladimir@cs.ualberta.ca>
W. Phillip Moore <wpm@ms.com>
+ Walt Mankowski <waltman@netaxs.com>
Warren Hyde <whyde@pezz.sps.mot.com>
Warren Jones <wjones@tc.fluke.com>
Wayne Berke <berke@panix.com>
Wayne Scott <wscott@ichips.intel.com>
Wayne Thompson <Wayne.Thompson@Ebay.sun.com>
! Wilfredo S�nchez <wsanchez@mit.edu>
William J. Middleton <William.Middleton@oslo.mobil.telenor.no>
William Mann <wmann@avici.com>
William R Ward <hermit@BayView.COM>
diff -c 'perl-5.7.1/Changes' 'perl-5.7.2/Changes'
Index: ./Changes
*** ./Changes Tue Apr 10 05:08:36 2001
--- ./Changes Fri Jul 13 16:59:38 2001
***************
*** 28,35 ****
or any other branch.
--------------
! Version v5.7.1 Development release working toward v5.8
--------------
____________________________________________________________________________
[ 9668] By: jhi on 2001/04/10 01:00:38
Log: Regen toc.
--- 28,12403 ----
or any other branch.
--------------
! Version v5.7.2 Development release working toward v5.8
--------------
+ ____________________________________________________________________________
+ [ 11352] By: jhi on 2001/07/13 12:54:49
+ Log: Reword.
+ Branch: perl
+ ! AUTHORS
+ ____________________________________________________________________________
+ [ 11351] By: jhi on 2001/07/13 12:52:47
+ Log: AUTHORS update.
+ Branch: perl
+ ! AUTHORS
+ ____________________________________________________________________________
+ [ 11350] By: jhi on 2001/07/13 12:24:36
+ Log: Ignore PL_regex_pad and PL_regex_padav from symbols
+ unless ithreads.
+ Branch: perl
+ ! makedef.pl
+ ____________________________________________________________________________
+ [ 11349] By: jhi on 2001/07/13 11:54:10
+ Log: Integrate perlio.
+ Branch: perl
+ !> win32/distclean.bat
+ ____________________________________________________________________________
+ [ 11348] By: jhi on 2001/07/13 11:49:50
+ Log: Test the encoding transform only iff we have PerlIO,
+ noticed by H. Merijn Brand.
+ Branch: perl
+ ! ext/PerlIO/t/encoding.t
+ ____________________________________________________________________________
+ [ 11347] By: jhi on 2001/07/13 11:40:13
+ Log: README.netware tweaks from Ananth Kesari.
+ Branch: perl
+ ! README.netware
+ ____________________________________________________________________________
+ [ 11346] By: nick on 2001/07/13 09:18:51
+ Log: Win32/distclean.bat - Down-case all MANIFEST and File::Find results so
+ to avoid /unicode vs /Unicode issues.
+ Branch: perlio
+ ! win32/distclean.bat
+ ____________________________________________________________________________
+ [ 11345] By: nick on 2001/07/13 06:24:18
+ Log: Integrate mainline
+ Branch: perlio
+ +> README.uts lib/UnicodeCD.pm lib/UnicodeCD.t
+ - lib/Unicode/UCD.pm lib/Unicode/UCD.t lib/unicode/distinct.pm
+ !> (integrate 63 files)
+ ____________________________________________________________________________
+ [ 11344] By: jhi on 2001/07/13 04:50:22
+ Log: Add d_bincompat5005 information to perl -V.
+ Branch: perl
+ ! myconfig.SH
+ ____________________________________________________________________________
+ [ 11343] By: jhi on 2001/07/13 03:42:05
+ Log: Subject: Re: [PATCH] Re: Memory corruption? Read-only $_?
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Fri, 13 Jul 2001 07:12:36 +0530
+ Message-ID: <20010713071236.C5669@lustre.dyn.wiw.org>
+ Branch: perl
+ ! sv.c
+ ____________________________________________________________________________
+ [ 11342] By: jhi on 2001/07/13 03:36:22
+ Log: Remove unicode::distinct, as per Inaba Hiroto.
+ Branch: perl
+ - lib/unicode/distinct.pm
+ ! MANIFEST hv.c perl.h pod/perlmodlib.pod pod/perltoc.pod sv.c
+ ! t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 11341] By: jhi on 2001/07/13 00:05:53
+ Log: Paging for Dr Octothorpe.
+ Branch: perl
+ ! pod/perlfaq4.pod
+ ____________________________________________________________________________
+ [ 11340] By: jhi on 2001/07/12 23:53:44
+ Log: cut-n-paste error noticed by mjd.
+ Branch: perl
+ ! pod/perlfaq4.pod
+ ____________________________________________________________________________
+ [ 11339] By: jhi on 2001/07/12 23:39:42
+ Log: Subject: [PATCH: perl@11328] update the octal situation in perlfaq4.pod
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Thu, 12 Jul 2001 17:04:22 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10107121703040.219875-100000@aspara.forte.com>
+ Branch: perl
+ ! pod/perlfaq4.pod
+ ____________________________________________________________________________
+ [ 11338] By: jhi on 2001/07/12 23:38:49
+ Log: Subject: Re: [randy@qualcomm.com: Corrections for ' repository - Using the Perl repository ']
+ From: Randall Gellens <randy@qualcomm.com>
+ Date: Thu, 12 Jul 2001 16:56:23 -0700
+ Message-Id: <p05100301b773e9751c04@[129.46.176.61]>
+ Branch: perl
+ ! Porting/repository.pod
+ ____________________________________________________________________________
+ [ 11337] By: jhi on 2001/07/12 23:35:06
+ Log: Make PTHREAD_ATFORK() to croak if HAS_FORK, noop otherwise.
+ Branch: perl
+ ! thread.h
+ ____________________________________________________________________________
+ [ 11336] By: jhi on 2001/07/12 23:23:39
+ Log: Subject: [PATCH] pthread_atfork on FreeBSD - Part 1: #ifdef HAS_PTHREAD_ATFORK
+ From: coral <coral@moonlight.crystalflame.net>
+ Date: Thu, 12 Jul 2001 16:16:50 -0700 (PDT)
+ Message-Id: <200107122316.f6CNGoq09171@moonlight.crystalflame.net>
+ Branch: perl
+ ! thread.h
+ ____________________________________________________________________________
+ [ 11335] By: jhi on 2001/07/12 23:23:14
+ Log: Metaconfig unit change for #11134.
+ Branch: metaconfig
+ + U/threads/d_pthread_atfork.U
+ ____________________________________________________________________________
+ [ 11334] By: jhi on 2001/07/12 23:22:42
+ Log: Add HAS_PTHREAD_ATFORK.
+ Branch: perl
+ ! Configure NetWare/config.wc NetWare/config_H.wc
+ ! Porting/Glossary Porting/config.sh Porting/config_H
+ ! config_h.SH configure.com epoc/config.sh pod/perltoc.pod
+ ! uconfig.h uconfig.sh vos/config.alpha.def vos/config.alpha.h
+ ! vos/config.ga.def vos/config.ga.h win32/config.bc
+ ! win32/config.gc win32/config.vc win32/config_H.bc
+ ! win32/config_H.gc win32/config_H.vc
+ ____________________________________________________________________________
+ [ 11333] By: jhi on 2001/07/12 22:58:35
+ Log: Subject: [PATCH] File::Copy fails on tied handles
+ From: "Wilson, Doug" <Doug_Wilson@intuit.com>
+ Date: Thu, 12 Jul 2001 15:18:51 -0700
+ Message-ID: <35A280DF784CD411A06B0008C7B130ADB5505B@sdex04.sd.intuit.com>
+ Branch: perl
+ ! lib/File/Copy.pm
+ ____________________________________________________________________________
+ [ 11332] By: jhi on 2001/07/12 22:57:04
+ Log: Subject: [PATCH] Langinfo.t
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Thu, 12 Jul 2001 23:55:38 +0100
+ Message-ID: <20010712235538.M5827@plum.flirble.org>
+ Branch: perl
+ ! ext/I18N/Langinfo/Langinfo.t
+ ____________________________________________________________________________
+ [ 11331] By: jhi on 2001/07/12 22:56:09
+ Log: Subject: [PATCH: perl@11328] informational tweaks to perl572delta.pod
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Thu, 12 Jul 2001 16:38:00 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10107121633340.219875-100000@aspara.forte.com>
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 11330] By: jhi on 2001/07/12 22:55:23
+ Log: Subject: [PATCH] Re: Memory corruption? Read-only $_?
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Fri, 13 Jul 2001 05:21:16 +0530
+ Message-ID: <20010713052116.B5669@lustre.dyn.wiw.org>
+ Branch: perl
+ ! sv.c
+ ____________________________________________________________________________
+ [ 11329] By: jhi on 2001/07/12 22:54:39
+ Log: Subject: [PATCH 20010712.005] Re: Perl bug with "delete" on arrays
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Fri, 13 Jul 2001 03:04:25 +0530
+ Message-ID: <20010713030425.A5669@lustre.dyn.wiw.org>
+ Branch: perl
+ ! av.c
+ ____________________________________________________________________________
+ [ 11328] By: gsar on 2001/07/12 19:02:01
+ Log: s/^M$//g
+ Branch: perl
+ ! win32/Makefile win32/makefile.mk
+ ____________________________________________________________________________
+ [ 11327] By: jhi on 2001/07/12 18:54:09
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 11326] By: jhi on 2001/07/12 18:17:18
+ Log: Typo spotted by Philip Newton.
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 11325] By: jhi on 2001/07/12 18:11:42
+ Log: Subject: [PATCH] fixes perl_clone of perl_clone
+ From: Artur Bergman <artur@contiller.se>
+ Date: Thu, 12 Jul 2001 20:57:09 +0200
+ Message-ID: <B773BFA4.236B%artur@contiller.se>
+ Branch: perl
+ ! sv.c
+ ____________________________________________________________________________
+ [ 11324] By: jhi on 2001/07/12 18:09:17
+ Log: Add README.uts from Hal Morris.
+ Branch: perl
+ + README.uts
+ ! MANIFEST pod/buildtoc.PL pod/perl.pod pod/perl572delta.pod
+ ! pod/perltoc.pod win32/Makefile win32/makefile.mk
+ ____________________________________________________________________________
+ [ 11323] By: jhi on 2001/07/12 17:48:33
+ Log: Subject: Re: AIX 4.3.3 w/ vac 5.0 [ FATAL in B ]
+ From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+ Date: Thu, 12 Jul 2001 20:32:37 +0200
+ Message-Id: <20010712201743.E108.H.M.BRAND@hccnet.nl>
+ Branch: perl
+ ! hints/aix.sh
+ ____________________________________________________________________________
+ [ 11322] By: jhi on 2001/07/12 17:44:29
+ Log: Subject: Patch: document reg_data.what member
+ From: Mark-Jason Dominus <mjd@plover.com>
+ Message-ID: <20010712182532.14821.qmail@plover.com>
+ Date: Thu, 12 Jul 2001 14:25:32 -0400
+ Branch: perl
+ ! regcomp.c regcomp.h
+ ____________________________________________________________________________
+ [ 11321] By: jhi on 2001/07/12 17:43:18
+ Log: Subject: [PATCH] Perl_re_dup()
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Thu, 12 Jul 2001 23:54:32 +0530
+ Message-ID: <20010712235432.J24707@lustre.dyn.wiw.org>
+ Branch: perl
+ ! embed.h embed.pl perlapi.c proto.h sv.c
+ ____________________________________________________________________________
+ [ 11320] By: jhi on 2001/07/12 17:18:54
+ Log: Regen Configure, modlib, toc.
+ Branch: perl
+ ! Configure Porting/Glossary Porting/config.sh Porting/config_H
+ ! pod/perlmodlib.pod pod/perltoc.pod
+ ____________________________________________________________________________
+ [ 11319] By: jhi on 2001/07/12 17:08:15
+ Log: The problem seems to be in PerlIO::Layer::->find() not
+ accepting the ":encoding(blurflur)" arguments.
+ Branch: perl
+ ! lib/PerlIO.pm lib/open.pm
+ ____________________________________________________________________________
+ [ 11318] By: jhi on 2001/07/12 16:58:11
+ Log: AIX doc update.
+ Branch: perl
+ ! README.aix pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 11317] By: jhi on 2001/07/12 16:39:11
+ Log: Subject: AIX README update
+ From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+ Date: Thu, 12 Jul 2001 19:28:30 +0200
+ Message-Id: <20010712192620.E0F9.H.M.BRAND@hccnet.nl>
+ Branch: perl
+ ! README.aix
+ ____________________________________________________________________________
+ [ 11316] By: jhi on 2001/07/12 16:37:15
+ Log: Subject: [PATCH ext/IO/lib/IO/t/io_unix.t] for QNX6
+ From: Norton Allen <allen@huarp.harvard.edu>
+ Date: Thu, 12 Jul 2001 11:30:51 -0400 (edt)
+ Message-Id: <200107121530.LAA12631@bottesini.harvard.edu>
+ Branch: perl
+ ! ext/IO/lib/IO/t/io_unix.t
+ ____________________________________________________________________________
+ [ 11315] By: jhi on 2001/07/12 16:35:53
+ Log: Subject: [PATCH README.qnx hints/qnx.sh]
+ From: Norton Allen <allen@huarp.harvard.edu>
+ Date: Thu, 12 Jul 2001 11:29:19 -0400 (edt)
+ Message-Id: <200107121529.LAA23411@bottesini.harvard.edu>
+ Branch: perl
+ ! README.qnx hints/qnx.sh
+ ____________________________________________________________________________
+ [ 11314] By: jhi on 2001/07/12 16:13:15
+ Log: Subject: [patch] faster PM_GETRE
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Thu, 12 Jul 2001 10:13:27 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0107121011530.28844-100000@mako.covalent.net>
+ Branch: perl
+ ! op.h
+ ____________________________________________________________________________
+ [ 11313] By: jhi on 2001/07/12 16:12:23
+ Log: Subject: Re: [PATCH] Threadsafe PMOPs! We might still win this war.
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Thu, 12 Jul 2001 10:11:28 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0107121010160.28844-100000@mako.covalent.net>
+ Branch: perl
+ ! op.c
+ ____________________________________________________________________________
+ [ 11312] By: jhi on 2001/07/12 16:07:22
+ Log: Tell where the nice Estonian database is.
+ Branch: perl
+ ! lib/open.pm
+ ____________________________________________________________________________
+ [ 11311] By: jhi on 2001/07/12 16:05:31
+ Log: Retract #11309 since #11310 is a better fix.
+ Branch: perl
+ ! t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 11310] By: gsar on 2001/07/12 15:50:40
+ Log: fix for failing fork.t#12 on windows (win32_execvp() tweak in
+ change#11300 needs to return the status of failed win32_spawnvp())
+
+ fix various open.pm bugs: '\0' isn't the same as "\0", so it wasn't
+ splitting correctly; remove unused variables; 'require' at run time
+ rather than 'use' at compile time for I18N::Langinfo, since it
+ isn't everyware
+ Branch: perl
+ ! lib/open.pm win32/win32.c
+ ____________________________________________________________________________
+ [ 11309] By: jhi on 2001/07/12 15:29:55
+ Log: Temporary workaround.
+ Branch: perl
+ ! t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 11308] By: jhi on 2001/07/12 14:44:51
+ Log: UCD typo in #11306 and add also more known-to-be-tested
+ modules to the skip list.
+ Branch: perl
+ ! t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 11307] By: jhi on 2001/07/12 14:38:38
+ Log: Rename Unicode::UCD to UnicodeCD to avoid
+ messups with case-insensitive filesystems.
+ Branch: perl
+ + lib/UnicodeCD.pm lib/UnicodeCD.t
+ - lib/Unicode/UCD.pm lib/Unicode/UCD.t
+ ! MANIFEST pod/perl572delta.pod t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 11306] By: jhi on 2001/07/12 13:32:05
+ Log: Subject: [ID 20010711.005] in Tie::Array, SPLICE ignores context, breaking SHIFT
+ From: daniel@biz.bitpusher.com
+ Date: Wed, 11 Jul 2001 23:25:47 -0700
+ Message-Id: <200107120625.f6C6PkJ13065@biz.bitpusher.com>
+ Branch: perl
+ ! lib/Tie/Array.pm t/op/splice.t
+ ____________________________________________________________________________
+ [ 11305] By: jhi on 2001/07/12 13:05:46
+ Log: Subject: [PATCH] More accurate line numbers in messages
+ From: Paul Johnson <paul@pjcj.net>
+ Date: Thu, 12 Jul 2001 04:14:11 +0200
+ Message-ID: <20010712041411.A3467@pjcj.net>
+
+ (With prototyping and multiplicity tweaks.)
+ Branch: perl
+ ! dump.c embed.h embed.pl t/lib/warnings/util util.c
+ ____________________________________________________________________________
+ [ 11304] By: nick on 2001/07/12 12:53:40
+ Log: Integrate mainline
+ Branch: perlio
+ !> ext/ByteLoader/bytecode.h hints/aix.sh pod/perl572delta.pod
+ !> regexec.c thread.h
+ ____________________________________________________________________________
+ [ 11303] By: jhi on 2001/07/12 12:46:20
+ Log: Cut-and-pasto in #11298.
+ Branch: perl
+ ! ext/ByteLoader/bytecode.h
+ ____________________________________________________________________________
+ [ 11302] By: jhi on 2001/07/12 12:42:35
+ Log: Update the AIX known problems section.
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 11301] By: jhi on 2001/07/12 12:36:46
+ Log: Subject: Re: HiRes on AIX 4.2 in threaded mode
+ From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+ Date: Thu, 12 Jul 2001 12:16:16 +0200
+ Message-Id: <20010712114215.E0D9.H.M.BRAND@hccnet.nl>
+ Branch: perl
+ ! hints/aix.sh
+ ____________________________________________________________________________
+ [ 11300] By: jhi on 2001/07/12 12:35:44
+ Log: Integrate perlio.
+ Branch: perl
+ !> makedef.pl win32/win32.c
+ ____________________________________________________________________________
+ [ 11299] By: jhi on 2001/07/12 12:33:57
+ Log: Subject: [PATCH] fix for PMOP threadness failures
+ From: Artur Bergman <artur@contiller.se>
+ Date: Thu, 12 Jul 2001 09:48:06 +0200
+ Message-ID: <B77322D6.22DD%artur@contiller.se>
+ Branch: perl
+ ! regexec.c
+ ____________________________________________________________________________
+ [ 11298] By: jhi on 2001/07/12 12:27:47
+ Log: Subject: RE: Win32 Failure, was Re: perl@11278 - LAST CALL FOR 5.7.2
+ From: "Konovalov, Vadim Vladimirovich (Vadim)" <vkonovalov@lucent.com>
+ Date: Thu, 12 Jul 2001 09:09:48 +0200
+ Message-ID: <E3FB32585BF1D411B9E900805FF51A0808CE70@RU0022EXCH001U>
+
+ More parentheses to keep bcc happy.
+ Branch: perl
+ ! ext/ByteLoader/bytecode.h
+ ____________________________________________________________________________
+ [ 11297] By: jhi on 2001/07/12 12:24:50
+ Log: Subject: Re: [patch] pthread_atfork bandaid
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Wed, 11 Jul 2001 23:43:17 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0107112342330.28844-100000@mako.covalent.net>
+ Branch: perl
+ ! thread.h
+ ____________________________________________________________________________
+ [ 11296] By: nick on 2001/07/12 11:55:48
+ Log: Exclude reentrant_buffer from .def file
+ Branch: perlio
+ ! makedef.pl
+ ____________________________________________________________________________
+ [ 11295] By: nick on 2001/07/12 11:11:44
+ Log: Honour void-ness of my_exit()
+ Branch: perlio
+ ! win32/win32.c
+ ____________________________________________________________________________
+ [ 11294] By: nick on 2001/07/12 07:51:04
+ Log: Integrate mainline
+ Branch: perlio
+ +> uts/sprintf_wrap.c
+ !> (integrate 35 files)
+ ____________________________________________________________________________
+ [ 11293] By: jhi on 2001/07/12 04:58:08
+ Log: Retract #11289.
+ Branch: perl
+ ! embed.h embed.pl perl.c proto.h thread.h
+ ____________________________________________________________________________
+ [ 11292] By: jhi on 2001/07/12 04:47:43
+ Log: Now the :locale pseudolayer *almost* works...
+ Branch: perl
+ ! lib/open.pm
+ ____________________________________________________________________________
+ [ 11291] By: jhi on 2001/07/12 04:36:47
+ Log: Locale encoding tweaks.
+ Branch: perl
+ ! lib/open.pm
+ ____________________________________________________________________________
+ [ 11290] By: jhi on 2001/07/12 04:25:53
+ Log: Subject: Re: [PATCH: perl@11181] UCD.t fails LATIN|Latin test
+ From: Mark-Jason Dominus <mjd@plover.com>
+ Date: Thu, 12 Jul 2001 00:59:31 -0400
+ Message-ID: <20010712045931.8543.qmail@plover.com>
+
+ Remove the chmod/umask leading zero warning.
+ Branch: perl
+ ! lib/warnings.pm pod/perldiag.pod pod/perllexwarn.pod
+ ! t/lib/warnings/toke toke.c warnings.h warnings.pl
+ ____________________________________________________________________________
+ [ 11289] By: jhi on 2001/07/12 04:16:41
+ Log: (Retracted by #11289.)
+ Branch: perl
+ ! embed.h embed.pl perl.c proto.h thread.h
+ ____________________________________________________________________________
+ [ 11288] By: jhi on 2001/07/12 03:45:11
+ Log: Needed by #11283.
+ Branch: perl
+ ! intrpvar.h
+ ____________________________________________________________________________
+ [ 11287] By: jhi on 2001/07/12 03:40:04
+ Log: Metaconfig unit change for #11286.
+ Branch: metaconfig/U/perl
+ ! patchlevel.U
+ ____________________________________________________________________________
+ [ 11286] By: jhi on 2001/07/12 03:39:18
+ Log: Subject: Re: [PATCH Configure] perl -V broken
+ From: Andy Dougherty <doughera@lafayette.edu>
+ Date: Wed, 11 Jul 2001 13:30:27 -0400 (EDT)
+ Message-ID: <Pine.SOL.4.10.10107111329060.2021-100000@maxwell.phys.lafayette.edu>
+ Branch: perl
+ ! Configure myconfig.SH
+ ____________________________________________________________________________
+ [ 11285] By: jhi on 2001/07/12 03:27:28
+ Log: Retract #11166 (and #11237).
+ Branch: perl
+ ! dump.c embed.h lib/warnings.pm op.c op.h opcode.h opcode.pl
+ ! pod/perldiag.pod pp.sym pp_proto.h t/lib/warnings/op
+ ! t/lib/warnings/toke toke.c warnings.h warnings.pl
+ ____________________________________________________________________________
+ [ 11284] By: jhi on 2001/07/12 02:36:42
+ Log: UTS tweaks for Hal Morris.
+ Branch: perl
+ + uts/sprintf_wrap.c
+ ! MANIFEST hints/uts.sh perl.h
+ ____________________________________________________________________________
+ [ 11283] By: jhi on 2001/07/12 00:52:36
+ Log: Subject: [PATCH] Use reentrant API glibc
+ From: Artur Bergman <artur@contiller.se>
+ Date: Thu, 12 Jul 2001 00:58:21 +0200
+ Message-ID: <B772A6AD.2288%artur@contiller.se>
+ Branch: perl
+ ! embedvar.h intrpvar.h op.h perl.c perlapi.h pod/perlapi.pod
+ ! sv.c
+ ____________________________________________________________________________
+ [ 11282] By: jhi on 2001/07/12 00:35:27
+ Log: Subject: Re: ActivePerl 628 + warnings + fork + exec = spurious "Can't exec"?
+ From: barries <barries@slaysys.com>
+ Date: Wed, 11 Jul 2001 15:11:46 -0400
+ Message-ID: <20010711151146.G24560@jester.slaysys.com>
+ Branch: perl
+ ! pp_sys.c t/lib/warnings/doio win32/win32.c
+ ____________________________________________________________________________
+ [ 11281] By: jhi on 2001/07/12 00:32:17
+ Log: Subject: [patch] pthread_atfork bandaid
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Wed, 11 Jul 2001 08:59:12 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0107110855070.11688-100000@mako.covalent.net>
+ Branch: perl
+ ! miniperlmain.c perl.c
+ ____________________________________________________________________________
+ [ 11280] By: jhi on 2001/07/12 00:31:34
+ Log: Subject: [patch] perl_clone leaks
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Wed, 11 Jul 2001 08:43:32 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0107110842390.11688-100000@mako.covalent.net>
+ Branch: perl
+ ! sv.c
+ ____________________________________________________________________________
+ [ 11279] By: nick on 2001/07/11 15:49:38
+ Log: Integrate mainline
+ Branch: perlio
+ +> ext/Encode/Encode/HZ.enc ext/PerlIO/t/encoding.t
+ +> ext/Time/HiRes/hints/dynixptx.pl lib/Math/BigInt/Calc.pm
+ +> lib/Math/BigInt/t/bigintc.t lib/Term/ANSIColor/ChangeLog
+ +> lib/Term/ANSIColor/README
+ !> (integrate 54 files)
+ ____________________________________________________________________________
+ [ 11278] By: jhi on 2001/07/11 13:52:20
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 11277] By: jhi on 2001/07/11 13:31:43
+ Log: Subject: blead kit timestamps && the problem with running perl embed.pl
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Tue, 10 Jul 2001 19:33:00 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10107101906360.137455-100000@aspara.forte.com>
+
+ Backport of embed.pl to 5.003.
+ Branch: perl
+ ! embed.pl
+ ____________________________________________________________________________
+ [ 11276] By: jhi on 2001/07/11 13:18:07
+ Log: Subject: Re: POSIX test #14 on UTS
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Date: Wed, 11 Jul 2001 03:02:14 +0100
+ Message-Id: <200107110202.f6B22Ea10727@crypt.compulink.co.uk>
+ Branch: perl
+ ! ext/POSIX/POSIX.t
+ ____________________________________________________________________________
+ [ 11275] By: jhi on 2001/07/11 13:15:49
+ Log: Make the I32 an IV to preserve structure alignment and size.
+ Branch: perl
+ ! op.h
+ ____________________________________________________________________________
+ [ 11274] By: jhi on 2001/07/11 13:13:27
+ Log: Subject: [PATCH] Threadsafe PMOPs! We might still win this war.
+ From: "Artur Bergman" <artur@contiller.se>
+ Date: Wed, 11 Jul 2001 14:23:37 +0200
+ Message-ID: <000b01c10a04$4fa16a10$21000a0a@vogw2kdev>
+
+ Threadsafe PMOPs for ithreads, waiting for AMS's Perl_re_dup().
+ Branch: perl
+ ! embedvar.h intrpvar.h op.c op.h perl.c perlapi.h
+ ! pod/perlapi.pod sv.c
+ ____________________________________________________________________________
+ [ 11273] By: jhi on 2001/07/11 03:53:28
+ Log: Tweak until Pod::Parser gets updated.
+ Branch: perl
+ ! t/pod/special_seqs.xr
+ ____________________________________________________________________________
+ [ 11272] By: jhi on 2001/07/11 00:46:05
+ Log: File::Spec usage tweak.
+ Branch: perl
+ ! lib/ExtUtils.t
+ ____________________________________________________________________________
+ [ 11271] By: jhi on 2001/07/11 00:37:19
+ Log: Integrate #11263 from macperl; macos and macosx updates.
+ Branch: perl
+ !> pod/perlport.pod
+ ____________________________________________________________________________
+ [ 11270] By: jhi on 2001/07/11 00:33:27
+ Log: Subject: [PATCH: perl@11238] dynixptx updates for osvers='4.5.2'
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Tue, 10 Jul 2001 15:29:45 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10107101519160.137455-100000@aspara.forte.com>
+ Branch: perl
+ + ext/Time/HiRes/hints/dynixptx.pl
+ ! MANIFEST hints/dynixptx.sh
+ ____________________________________________________________________________
+ [ 11269] By: jhi on 2001/07/11 00:32:16
+ Log: Subject: [PATCH] ExtUtils::Constant (was Re: funny numconvert test in perl@11006 (was Re: report on BS2000 wit h perl@11006))
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Tue, 10 Jul 2001 23:17:43 +0100
+ Message-ID: <20010710231742.B59620@plum.flirble.org>
+ Branch: perl
+ ! lib/ExtUtils.t lib/ExtUtils/Constant.pm
+ ____________________________________________________________________________
+ [ 11268] By: jhi on 2001/07/11 00:30:56
+ Log: Subject: [DOC PATCH] Pluggable runops
+ From: Paul Johnson <paul@pjcj.net>
+ Date: Tue, 10 Jul 2001 21:53:28 +0200
+ Message-ID: <20010710215328.B26577@pjcj.net>
+ Branch: perl
+ ! pod/perlguts.pod
+ ____________________________________________________________________________
+ [ 11267] By: jhi on 2001/07/11 00:29:59
+ Log: Subject: [PATCH] Authors
+ From: Artur Bergman <artur@contiller.se>
+ Date: Tue, 10 Jul 2001 20:39:12 +0200
+ Message-ID: <B771186F.21CD%artur@contiller.se>
+ Branch: perl
+ ! AUTHORS
+ ____________________________________________________________________________
+ [ 11266] By: jhi on 2001/07/11 00:29:13
+ Log: Subject: Re: [PATCH] Small fix to pp_gmtime
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Tue, 10 Jul 2001 11:19:43 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0107101118020.10475-100000@mako.covalent.net>
+ Branch: perl
+ ! pp_ctl.c
+ ____________________________________________________________________________
+ [ 11265] By: jhi on 2001/07/11 00:28:15
+ Log: Subject: doc patch; times() in scalar context
+ From: mjd@plover.com
+ Date: 10 Jul 2001 18:01:17 -0000
+ Message-ID: <20010710180117.12477.qmail@plover.com>
+ Branch: perl
+ ! pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 11264] By: jhi on 2001/07/11 00:27:17
+ Log: Subject: [PATCH] Small fix to pp_gmtime
+ From: Artur Bergman <artur@contiller.se>
+ Date: Tue, 10 Jul 2001 19:54:52 +0200
+ Message-ID: <B7710E0B.21C5%artur@contiller.se>
+ Branch: perl
+ ! pp_sys.c
+ ____________________________________________________________________________
+ [ 11263] By: pudge on 2001/07/10 21:06:10
+ Log: Integrate changes from mainline perl, add notes about
+ Mac OS X and Mac OS.
+ Branch: maint-5.6/macperl
+ ! pod/perlport.pod
+ ____________________________________________________________________________
+ [ 11262] By: jhi on 2001/07/10 15:21:26
+ Log: A proof of the dangers of package; ?
+ Branch: perl
+ ! t/lib/warnings/op
+ ____________________________________________________________________________
+ [ 11261] By: jhi on 2001/07/10 15:02:27
+ Log: Regen toc and modlib.
+ Branch: perl
+ ! pod/perlmodlib.pod pod/perltoc.pod
+ ____________________________________________________________________________
+ [ 11260] By: jhi on 2001/07/10 15:00:37
+ Log: Add compexcl(), casefold(), and casespec() interfaces;
+ and make all interfaces to return hash references instead
+ of hashes.
+ Branch: perl
+ ! lib/Unicode/UCD.pm lib/Unicode/UCD.t
+ ____________________________________________________________________________
+ [ 11259] By: jhi on 2001/07/10 13:50:17
+ Log: Subject: [PATCH bleadperl] Math::Big* doc patches (and some code)
+ From: "Philip Newton" <Philip.Newton@gmx.net>
+ Date: Tue, 10 Jul 2001 09:55:59 +0200
+ Message-ID: <20010710.095300@ID-11583.news.dfncis.de>
+
+ Subject: [DOC PATCH bleadperl] detypo Math::BigInt docs
+ From: "Philip Newton" <Philip.Newton@gmx.net>
+ Date: Tue, 10 Jul 2001 09:56:37 +0200
+ Message-ID: <20010710.095600@ID-11583.news.dfncis.de>
+ Branch: perl
+ ! lib/Math/BigFloat.pm lib/Math/BigInt.pm
+ ! lib/Math/BigInt/Calc.pm lib/Math/BigInt/t/bigintpm.t
+ ____________________________________________________________________________
+ [ 11258] By: jhi on 2001/07/10 13:47:20
+ Log: Subject: [patch] undef &xsub for 1,2
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Mon, 9 Jul 2001 20:16:49 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0107092012570.1913-100000@mako.covalent.net>
+
+ (This version of the patch with a comment from Gisle.)
+ Branch: perl
+ ! op.c
+ ____________________________________________________________________________
+ [ 11257] By: jhi on 2001/07/10 13:45:44
+ Log: Mention package; deprecation and the Win32 problems.
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 11256] By: jhi on 2001/07/10 13:45:12
+ Log: Subject: [PATCH] deprecate package with no arguments
+ From: Robin Houston <robin@kitsite.com>
+ Date: Tue, 10 Jul 2001 13:33:40 +0100
+ Message-ID: <20010710133340.A13452@robin.kitsite.com>
+ Branch: perl
+ ! op.c pod/perldiag.pod pod/perlfunc.pod t/lib/warnings/op
+ ____________________________________________________________________________
+ [ 11255] By: jhi on 2001/07/10 13:16:11
+ Log: Upgrade to podlators 1.10.
+ Branch: perl
+ ! lib/Pod/Man.pm lib/Pod/Text.pm lib/Pod/Text/Color.pm
+ ! lib/Pod/Text/Overstrike.pm lib/Pod/Text/Termcap.pm
+ ! pod/pod2man.PL pod/pod2text.PL
+ ____________________________________________________________________________
+ [ 11254] By: jhi on 2001/07/10 13:09:34
+ Log: Upgrade to Term::ANSIColor 1.04.
+ Branch: perl
+ + lib/Term/ANSIColor/ChangeLog lib/Term/ANSIColor/README
+ ! MANIFEST lib/Term/ANSIColor.pm lib/Term/ANSIColor/test.pl
+ ____________________________________________________________________________
+ [ 11253] By: jhi on 2001/07/10 12:59:27
+ Log: Integrate perlio (the right fix for the ":layer(args)")
+ Branch: perl
+ !> perlio.c
+ ____________________________________________________________________________
+ [ 11252] By: nick on 2001/07/10 06:58:14
+ Log: Fix open(...,"...:layer(xxx)",...)
+ - use memEQ not strEQ as there is '(' not '\0'
+ Branch: perlio
+ ! perlio.c
+ ____________________________________________________________________________
+ [ 11251] By: jhi on 2001/07/10 04:04:18
+ Log: Telling the number of tests helps.
+ Branch: perl
+ ! ext/PerlIO/t/encoding.t
+ ____________________________________________________________________________
+ [ 11250] By: jhi on 2001/07/10 03:55:38
+ Log: Require I18N::Langinfo, not use.
+ Branch: perl
+ ! lib/open.pm
+ ____________________________________________________________________________
+ [ 11249] By: jhi on 2001/07/10 03:50:18
+ Log: Add a test for for PerlIO ":encoding(...)" layer.
+ Branch: perl
+ + ext/PerlIO/t/encoding.t
+ ! MANIFEST ext/Encode/Encode.pm
+ ____________________________________________________________________________
+ [ 11248] By: jhi on 2001/07/10 02:06:57
+ Log: PerlIO ":encoding(foobar)" temporary fix.
+ Not really correct, I think, since the change means
+ that prefixes match.
+ Branch: perl
+ ! perlio.c
+ ____________________________________________________________________________
+ [ 11247] By: jhi on 2001/07/10 01:38:11
+ Log: Update to Math::BigInt 1.36. The biggest news is
+ the separation of the backend; now the pure Perl
+ implementation is in Math::BigInt::Calc, but one
+ can plugin, say, Math::BigInt::BitVect, and get
+ considerable speedup.
+ Branch: perl
+ + lib/Math/BigInt/Calc.pm lib/Math/BigInt/t/bigintc.t
+ ! MANIFEST lib/Math/BigFloat.pm lib/Math/BigInt.pm
+ ! lib/Math/BigInt/t/bigfltpm.t lib/Math/BigInt/t/bigintpm.t
+ ! lib/Math/BigInt/t/mbimbf.t
+ ____________________________________________________________________________
+ [ 11246] By: jhi on 2001/07/10 01:19:55
+ Log: Subject: Re: compatibility question
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Mon, 9 Jul 2001 18:04:33 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10107091619360.86512-100000@aspara.forte.com>
+ Branch: perl
+ ! lib/ExtUtils/MM_VMS.pm
+ ____________________________________________________________________________
+ [ 11245] By: jhi on 2001/07/10 01:18:04
+ Log: Subject: [PATCH ext/File/Glob/t/basic.t]
+ From: Norton Allen <allen@huarp.harvard.edu>
+ Date: Mon, 9 Jul 2001 17:16:15 -0400 (edt)
+ Message-Id: <200107092116.RAA12010@bottesini.harvard.edu>
+ Branch: perl
+ ! ext/File/Glob/t/basic.t
+ ____________________________________________________________________________
+ [ 11244] By: jhi on 2001/07/10 01:16:27
+ Log: Subject: [PATCH] Encode::Tcl. add "HZ" encoding and bugfix
+ From: SADAHIRO Tomoyuki <BQW10602@nifty.com>
+ Date: Tue, 10 Jul 2001 00:29:55 +0900
+ Message-Id: <20010710002756.B497.BQW10602@nifty.com>
+ Branch: perl
+ + ext/Encode/Encode/HZ.enc
+ ! MANIFEST ext/Encode/Encode/7bit-kana.enc
+ ! ext/Encode/Encode/Tcl.pm ext/Encode/Encode/Tcl.t
+ ! ext/Encode/Encode/iso2022-jp.enc
+ ! ext/Encode/Encode/iso2022-kr.enc
+ ____________________________________________________________________________
+ [ 11243] By: pudge on 2001/07/09 22:16:12
+ Log: Add in all them there macos/ files.
+ Branch: maint-5.6/macperl
+ + (add 577 files)
+ ____________________________________________________________________________
+ [ 11242] By: jhi on 2001/07/09 20:26:04
+ Log: Add the new modules to the list of having those own tests.
+ Branch: perl
+ ! t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 11241] By: jhi on 2001/07/09 19:09:58
+ Log: Add INOUT to control both ways at the same time.
+ Branch: perl
+ ! lib/open.pm
+ ____________________________________________________________________________
+ [ 11240] By: nick on 2001/07/09 16:33:50
+ Log: Integrate mainline
+ Branch: perlio
+ +> ext/I18N/Langinfo/Langinfo.pm ext/I18N/Langinfo/Langinfo.t
+ +> ext/I18N/Langinfo/Langinfo.xs ext/I18N/Langinfo/Makefile.PL
+ !> (integrate 41 files)
+ ____________________________________________________________________________
+ [ 11239] By: jhi on 2001/07/09 16:14:35
+ Log: More encoding mapping magic.
+ Branch: perl
+ ! lib/open.pm
+ ____________________________________________________________________________
+ [ 11238] By: jhi on 2001/07/09 14:40:43
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 11237] By: jhi on 2001/07/09 14:27:27
+ Log: (Retracted by #11285).
+
+ Subject: [PATCH] OPpCONST_OCTAL fixes
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Mon, 9 Jul 2001 07:38:45 +0530
+ Message-ID: <20010709073845.A25406@lustre.dyn.wiw.org>
+ Branch: perl
+ ! op.c
+ ____________________________________________________________________________
+ [ 11236] By: jhi on 2001/07/09 14:10:07
+ Log: Add a pseudolayer ":locale" to the open pragma which
+ will get the encoding from the locale. Yet undocumented
+ because I can't get the PerlIO :encoding(foobar) to work.
+ Branch: perl
+ ! ext/Encode/Encode.pm lib/open.pm
+ ____________________________________________________________________________
+ [ 11235] By: jhi on 2001/07/09 13:38:43
+ Log: Add more encoding mappings.
+ Branch: perl
+ ! ext/Encode/Encode.pm
+ ____________________________________________________________________________
+ [ 11234] By: jhi on 2001/07/09 13:24:54
+ Log: Document that using :encoding layer requires using Encode.
+ Branch: perl
+ ! ext/Encode/Encode.pm lib/PerlIO.pm
+ ____________________________________________________________________________
+ [ 11233] By: jhi on 2001/07/09 13:19:34
+ Log: Netware tweak from Ananth Kesari.
+ Branch: perl
+ ! NetWare/netware.h
+ ____________________________________________________________________________
+ [ 11232] By: gsar on 2001/07/09 04:40:07
+ Log: t/harness doesn't know about run/*.t
+ Branch: perl
+ ! t/harness
+ ____________________________________________________________________________
+ [ 11231] By: gsar on 2001/07/09 04:36:30
+ Log: run/exit.t busted on windows
+ Branch: perl
+ ! t/run/exit.t
+ ____________________________________________________________________________
+ [ 11230] By: gsar on 2001/07/09 04:14:54
+ Log: fix a couple of UCD.t tests that fail due to bad case
+ Branch: perl
+ ! lib/Unicode/UCD.t
+ ____________________________________________________________________________
+ [ 11229] By: gsar on 2001/07/09 03:57:06
+ Log: test skip logic was broken
+ Branch: perl
+ ! ext/I18N/Langinfo/Langinfo.t
+ ____________________________________________________________________________
+ [ 11228] By: gsar on 2001/07/09 03:42:20
+ Log: remove *.pdb files on windows upon $(MAKE) clean (fixes
+ failure of ExtUtils.t#27 when built in debug mode)
+ Branch: perl
+ ! lib/ExtUtils/MM_Win32.pm
+ ____________________________________________________________________________
+ [ 11227] By: gsar on 2001/07/09 02:11:04
+ Log: I18N::Langinfo is not available on windows
+ Branch: perl
+ ! win32/FindExt.pm
+ ____________________________________________________________________________
+ [ 11226] By: gsar on 2001/07/09 01:55:23
+ Log: save a dTHX
+ Branch: perl
+ ! ext/POSIX/POSIX.xs
+ ____________________________________________________________________________
+ [ 11225] By: jhi on 2001/07/08 23:42:37
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 11224] By: jhi on 2001/07/08 23:05:41
+ Log: Guard the nl_langinfo() with HAS_NL_LANGINFO
+ as pointed out by Sarathy.
+ Branch: perl
+ ! ext/I18N/Langinfo/Langinfo.xs
+ ____________________________________________________________________________
+ [ 11223] By: jhi on 2001/07/08 22:59:01
+ Log: Retract #11212.
+ Branch: perl
+ ! cv.h ext/Opcode/Opcode.xs op.c pp_hot.c sv.h toke.c
+ ____________________________________________________________________________
+ [ 11222] By: jhi on 2001/07/08 17:41:22
+ Log: Bump up the VERSION of Cwd.xs.
+ Branch: perl
+ ! ext/Cwd/Makefile.PL
+ ____________________________________________________________________________
+ [ 11221] By: jhi on 2001/07/08 17:13:38
+ Log: Retract #11220, the problem wasn't the missing leading zero.
+ Here's the problem:
+ $ ./perl -we 'chmod(oct("755"), ".")'
+ Non-octal literal mode (493) specified at -e line 1.
+ (Did you mean 0493 instead?)
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm
+ ____________________________________________________________________________
+ [ 11220] By: jhi on 2001/07/08 17:05:55
+ Log: (Retracted by #11221)
+ Change the PERM_RW and PERM_RWX to 0644 and 0755
+ (add the leading zero).
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm
+ ____________________________________________________________________________
+ [ 11219] By: jhi on 2001/07/08 16:17:32
+ Log: Integrate changes #11193, 11205, 11209 from macperl.
+
+ Fix up AutoLoader to fudge for Mac paths in import().
+
+ Allow symbols in try_symbol() to begin with "_".
+
+ Small portability fix for Mac OS.
+ Branch: perl
+ !> lib/AutoLoader.pm lib/Cwd.pm makedef.pl
+ ____________________________________________________________________________
+ [ 11218] By: jhi on 2001/07/08 16:10:30
+ Log: Metaconfig unit change for #11217.
+ Branch: metaconfig/U/perl
+ ! Extensions.U
+ ____________________________________________________________________________
+ [ 11217] By: jhi on 2001/07/08 16:10:07
+ Log: Detypo, problem noticed by Gerrit P. Haase.
+ Branch: perl
+ ! Configure config_h.SH
+ ____________________________________________________________________________
+ [ 11216] By: jhi on 2001/07/08 15:58:35
+ Log: Cwd cleanups.
+ Branch: perl
+ ! ext/Cwd/Cwd.xs
+ ____________________________________________________________________________
+ [ 11215] By: jhi on 2001/07/08 15:52:57
+ Log: Slight tweaks on #11213.
+ Branch: perl
+ ! toke.c
+ ____________________________________________________________________________
+ [ 11214] By: jhi on 2001/07/08 14:32:28
+ Log: A missing dTHX noticed by Gerrit P. Haase.
+ Branch: perl
+ ! ext/POSIX/POSIX.xs
+ ____________________________________________________________________________
+ [ 11213] By: jhi on 2001/07/08 14:24:44
+ Log: Subject: [PATCH toke.c] Simplify yytoke()
+ From: Simon Cozens <simon@netthink.co.uk>
+ Date: Sun, 8 Jul 2001 13:24:34 +0100
+ Message-ID: <20010708132434.A9448@deep-dark-truthful-mirror>
+
+ Split out pending_ident().
+ Branch: perl
+ ! embed.h embed.pl pod/perlapi.pod proto.h toke.c
+ ____________________________________________________________________________
+ [ 11212] By: jhi on 2001/07/08 14:17:10
+ Log: (Retracted by #11223.)
+ Subject: [PATCH] Re: Problem with Safe.pm and Perl 5.004
+ Date: Wed, 05 Nov 1997 17:22:34 -0600
+ From: Graham Barr <gbarr@ti.com>
+ Message-Id: <3460FFBA.6DA51F46@ti.com>
+ Branch: perl
+ ! cv.h ext/Opcode/Opcode.xs op.c pp_hot.c sv.h toke.c
+ ____________________________________________________________________________
+ [ 11211] By: jhi on 2001/07/08 13:53:38
+ Log: Fix I18N::Langinfo nits noticed but Philip Newton.
+ Branch: perl
+ ! ext/I18N/Langinfo/Langinfo.pm ext/I18N/Langinfo/Langinfo.t
+ ! pod/perllocale.pod
+ ____________________________________________________________________________
+ [ 11210] By: jhi on 2001/07/08 01:34:09
+ Log: Really do the test under the C locale.
+ Branch: perl
+ ! ext/I18N/Langinfo/Langinfo.t
+ ____________________________________________________________________________
+ [ 11209] By: pudge on 2001/07/08 01:19:25
+ Log: Small portability fix for Mac OS.
+ Branch: maint-5.6/macperl
+ ! lib/Cwd.pm
+ ____________________________________________________________________________
+ [ 11208] By: jhi on 2001/07/08 01:14:58
+ Log: Metaconfig unit change for #11207.
+ Branch: metaconfig/U/perl
+ ! Extensions.U
+ ____________________________________________________________________________
+ [ 11207] By: jhi on 2001/07/08 01:14:02
+ Log: Add I18N::Langinfo, which is basically a wrapper around
+ nl_langinfo(), which is an additional way to query locale
+ specific information.
+ Branch: perl
+ + ext/I18N/Langinfo/Langinfo.pm ext/I18N/Langinfo/Langinfo.t
+ + ext/I18N/Langinfo/Langinfo.xs ext/I18N/Langinfo/Makefile.PL
+ ! Configure MANIFEST pod/perl572delta.pod pod/perllocale.pod
+ ____________________________________________________________________________
+ [ 11206] By: pudge on 2001/07/08 00:56:29
+ Log: Bugfixes for some tests. commonsense.t not in perl 5.6,
+ used in File::Find tests; replace with if.t.
+ Branch: maint-5.6/macperl
+ ! t/lib/filefind-taint.t t/lib/filefind.t t/op/taint.t
+ ! t/pragma/warn/op
+ ____________________________________________________________________________
+ [ 11205] By: pudge on 2001/07/07 23:55:56
+ Log: Allow symbols in try_symbol() to begin with "_".
+ Branch: maint-5.6/macperl
+ ! makedef.pl
+ ____________________________________________________________________________
+ [ 11204] By: pudge on 2001/07/07 23:53:37
+ Log: Sync up the File::Find changes from the rewrite by
+ Thomas Wegner, et al.
+ Branch: maint-5.6/macperl
+ + t/lib/filefind-taint.t
+ ! lib/File/Find.pm t/lib/filefind.t
+ ____________________________________________________________________________
+ [ 11203] By: pudge on 2001/07/07 23:43:06
+ Log: Subject: [PATCHES] :t:pod: and :lib:Pod: stuff
+ From: Thomas Wegner <wegner_thomas@yahoo.com>
+ Date: Thu, 5 Jul 2001 20:31:25 +0200
+ Message-Id: <p04320400b76a0fc8dea5@[149.225.100.38]>
+ Branch: maint-5.6/macperl
+ ! lib/Pod/Find.pm t/pod/find.t t/pod/testp2pt.pl
+ ____________________________________________________________________________
+ [ 11202] By: pudge on 2001/07/07 23:38:36
+ Log: Some more test portability fixes.
+ Branch: maint-5.6/macperl
+ ! t/lib/filecopy.t t/pragma/warn/pp_sys
+ ____________________________________________________________________________
+ [ 11201] By: jhi on 2001/07/07 22:52:38
+ Log: The #11200 removed wrong (non-existent) target. Duh.
+ Branch: perl
+ ! Makefile.SH
+ ____________________________________________________________________________
+ [ 11200] By: jhi on 2001/07/07 22:44:14
+ Log: Zap the lib/re.pm before creating it.
+ Branch: perl
+ ! Makefile.SH
+ ____________________________________________________________________________
+ [ 11199] By: pudge on 2001/07/07 20:54:35
+ Log: Another test. Please ignore.
+ Branch: maint-5.6/macperl
+ ! README.macos
+ ____________________________________________________________________________
+ [ 11198] By: pudge on 2001/07/07 20:44:12
+ Log: Portability fixes for a lot of tests, especially IO-related
+ tests, and warnings, and the harness script.
+ Branch: maint-5.6/macperl
+ ! t/harness t/io/argv.t t/io/dup.t t/io/fs.t t/io/inplace.t
+ ! t/io/iprefix.t t/io/open.t t/io/openpid.t t/lib/filepath.t
+ ! t/lib/findbin.t t/lib/io_dup.t t/lib/socket.t t/op/die_exit.t
+ ! t/op/misc.t t/op/read.t t/op/readdir.t t/op/runlevel.t
+ ! t/op/stat.t t/op/subst_wamp.t t/op/taint.t
+ ! t/pragma/diagnostics.t t/pragma/subs.t t/pragma/warn/doio
+ ! t/pragma/warn/mg t/pragma/warn/op t/pragma/warn/pp_sys
+ ! t/pragma/warnings.t
+ ____________________________________________________________________________
+ [ 11197] By: jhi on 2001/07/07 20:32:28
+ Log: Subject: [PATCH] lib/h2xs.t (was Re: [PATCH] h2xs)
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Sat, 7 Jul 2001 21:00:17 +0100
+ Message-ID: <20010707210017.H59620@plum.flirble.org>
+ Branch: perl
+ ! lib/h2xs.t
+ ____________________________________________________________________________
+ [ 11196] By: jhi on 2001/07/07 20:26:36
+ Log: The UNICOS/mk SysV IPC problem has been fixed.
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 11195] By: jhi on 2001/07/07 19:59:51
+ Log: Slight update tweaks on perlunicode.pod.
+ Branch: perl
+ ! pod/perlunicode.pod
+ ____________________________________________________________________________
+ [ 11194] By: jhi on 2001/07/07 17:53:03
+ Log: Subject: Doc patch DB_File.pm: use umask-friendly modes
+ From: Mark-Jason Dominus <mjd@plover.com>
+ Date: Sat, 07 Jul 2001 13:04:04 -0400
+ Message-ID: <20010707170404.32694.qmail@plover.com>
+ Branch: perl
+ ! ext/DB_File/DB_File.pm
+ ____________________________________________________________________________
+ [ 11193] By: pudge on 2001/07/07 17:26:28
+ Log: Fix up AutoLoader to fudge for Mac paths in import().
+ Branch: maint-5.6/macperl
+ ! lib/AutoLoader.pm
+ ____________________________________________________________________________
+ [ 11192] By: jhi on 2001/07/07 17:03:06
+ Log: Try to force the lib/re.pm to be there before entering
+ the extensions builds, should help for parallel makes.
+ Branch: perl
+ ! Makefile.SH
+ ____________________________________________________________________________
+ [ 11191] By: jhi on 2001/07/07 15:26:16
+ Log: Subject: Re: [PATCH ext/POSIX/POSIX.pm] Re: sigaction.t under QNX
+ From: Norton Allen <allen@huarp.harvard.edu>
+ Date: Fri, 6 Jul 2001 12:01:14 -0400 (edt)
+ Message-Id: <200107061601.MAA00597@bottesini.harvard.edu>
+ Branch: perl
+ ! ext/POSIX/POSIX.xs
+ ____________________________________________________________________________
+ [ 11190] By: jhi on 2001/07/07 15:22:08
+ Log: Subject: [PATCH] Re: op/arith.t
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Sat, 7 Jul 2001 13:04:54 +0100
+ Message-ID: <20010707130454.D59620@plum.flirble.org>
+ Branch: perl
+ ! numeric.c toke.c
+ ____________________________________________________________________________
+ [ 11189] By: jhi on 2001/07/07 15:20:44
+ Log: Subject: [PATCH] h2xs
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Fri, 6 Jul 2001 23:25:14 +0100
+ Message-ID: <20010706232514.X59620@plum.flirble.org>
+ Branch: perl
+ ! utils/h2xs.PL
+ ____________________________________________________________________________
+ [ 11188] By: jhi on 2001/07/07 15:12:36
+ Log: Subject: Re: bleedperl perl_alloc..free leakage
+ From: Radu Greab <radu@netsoft.ro>
+ Date: Fri, 6 Jul 2001 19:48:54 +0300
+ Message-ID: <15173.60406.308246.456184@ix.netsoft.ro>
+
+ Leak-be-gone.
+ Branch: perl
+ ! op.c
+ ____________________________________________________________________________
+ [ 11187] By: pudge on 2001/07/07 02:11:36
+ Log: Test again. Please ignore.
+ Branch: maint-5.6/macperl
+ ! README.macos
+ ____________________________________________________________________________
+ [ 11186] By: pudge on 2001/07/07 02:08:13
+ Log: Test. Please ignore.
+ Branch: maint-5.6/macperl
+ ! README.macos
+ ____________________________________________________________________________
+ [ 11185] By: pudge on 2001/07/06 23:46:57
+ Log: Include changes already sent in separately as patches,
+ before branch was created.
+ Branch: maint-5.6/macperl
+ ! ext/File/Glob/bsd_glob.c ext/IO/lib/IO/Dir.pm gv.c
+ ! lib/DirHandle.pm lib/File/Basename.pm lib/File/Copy.pm
+ ! lib/File/Find.pm lib/diagnostics.pm perl.c t/base/term.t
+ ! t/comp/cpp.t t/comp/multiline.t t/comp/script.t t/comp/term.t
+ ! t/lib/anydbm.t t/lib/autoloader.t t/lib/dirhand.t
+ ! t/lib/filefind.t t/lib/io_dir.t t/lib/selfloader.t
+ ! t/op/anonsub.t t/op/closure.t t/op/defins.t t/op/die_exit.t
+ ! t/op/exec.t t/op/goto.t t/op/misc.t t/op/pack.t t/op/regexp.t
+ ! t/op/regexp_noamp.t t/op/split.t t/op/write.t
+ ! t/pragma/strict.t
+ ____________________________________________________________________________
+ [ 11184] By: jhi on 2001/07/06 16:41:30
+ Log: Subject: [PATCH lib/Cwd.pm] QNX patch extended for NTO
+ From: Norton Allen <allen@huarp.harvard.edu>
+ Date: Fri, 6 Jul 2001 09:39:57 -0400 (edt)
+ Message-Id: <200107061339.JAA12582@bottesini.harvard.edu>
+ Branch: perl
+ ! utf8.h
+ ____________________________________________________________________________
+ [ 11183] By: nick on 2001/07/06 16:27:40
+ Log: Integrate mainline
+ Branch: perlio
+ +> (branch 42 files)
+ - NetWare/perlsdio.h ext/util/mkbootstrap lib/Net/DummyInetd.pm
+ - lib/Net/PH.pm lib/Net/SNPP.pm lib/Net/t/ph.t
+ - win32/bin/mdelete.bat
+ !> (integrate 215 files)
+ ____________________________________________________________________________
+ [ 11182] By: jhi on 2001/07/06 15:57:16
+ Log: The #11166 needed also these updated.
+ Branch: perl
+ ! lib/warnings.pm warnings.h
+ ____________________________________________________________________________
+ [ 11181] By: jhi on 2001/07/06 13:24:42
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 11180] By: jhi on 2001/07/06 13:20:08
+ Log: Regen toc.
+ Branch: perl
+ ! pod/perltoc.pod
+ ____________________________________________________________________________
+ [ 11179] By: jhi on 2001/07/06 12:57:13
+ Log: Nit from Abhijit.
+ Branch: perl
+ ! lib/CPAN.pm
+ ____________________________________________________________________________
+ [ 11178] By: jhi on 2001/07/06 12:53:04
+ Log: Retract #11172.
+ Branch: perl
+ ! t/op/method.t
+ ____________________________________________________________________________
+ [ 11177] By: jhi on 2001/07/06 12:44:51
+ Log: Subject: [PATCH lib/Cwd.pm] QNX patch extended for NTO
+ From: Norton Allen <allen@huarp.harvard.edu>
+ Date: Fri, 6 Jul 2001 09:39:57 -0400 (edt)
+ Message-Id: <200107061339.JAA12582@bottesini.harvard.edu>
+ Branch: perl
+ ! lib/Cwd.pm
+ ____________________________________________________________________________
+ [ 11176] By: jhi on 2001/07/06 12:42:45
+ Log: (Accidentally empty check-in.)
+ Branch: perl
+ ! utf8.h
+ ____________________________________________________________________________
+ [ 11175] By: jhi on 2001/07/06 12:29:56
+ Log: Retract #11165 since Sarathy pointed out it'll not
+ work properly under threads, the problem should be
+ solved using "the savestack, either via SSNEW() or
+ using a newSVpv()+SAVEFREESV() combo."
+ Branch: perl
+ ! ext/POSIX/POSIX.xs
+ ____________________________________________________________________________
+ [ 11174] By: jhi on 2001/07/06 12:27:31
+ Log: Retract #11125 since NI-S pointed out it'll not work in
+ cases where the extension has their own handcrafted INC
+ et alia.
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm
+ ____________________________________________________________________________
+ [ 11173] By: jhi on 2001/07/06 12:20:50
+ Log: Subject: RE: [PATCH] -I and MakeMaker again
+ From: "Konovalov, Vadim Vladimirovich (Vadim)" <vkonovalov@lucent.com>
+ Date: Fri, 6 Jul 2001 09:18:29 +0200
+ Message-ID: <E3FB32585BF1D411B9E900805FF51A0808C221@RU0022EXCH001U>
+ Branch: perl
+ ! lib/ExtUtils/MM_NW5.pm lib/ExtUtils/MM_VMS.pm
+ ! lib/ExtUtils/MM_Win32.pm
+ ____________________________________________________________________________
+ [ 11172] By: jhi on 2001/07/06 12:18:39
+ Log: (Retracted by #11178)
+ Subject: [PATCH t/op/method.t] SUPER:: strangeness
+ From: Piers Cawley <pdcawley@iterative-software.com>
+ Date: 06 Jul 2001 10:49:01 +0100
+ Message-ID: <m2ith6xu9e.fsf@despairon.bofh.org.uk>
+ Branch: perl
+ ! t/op/method.t
+ ____________________________________________________________________________
+ [ 11171] By: jhi on 2001/07/06 01:38:55
+ Log: VOS README update from Paul Green.
+ Branch: perl
+ ! README.vos
+ ____________________________________________________________________________
+ [ 11170] By: jhi on 2001/07/06 01:19:33
+ Log: Subject: [PATCH README.qnx hints/qnx.sh]
+ From: Norton Allen <allen@huarp.harvard.edu>
+ Message-Id: <200107051755.NAA21422@bottesini.harvard.edu>
+ Date: Thu, 5 Jul 2001 13:55:11 -0400 (edt)
+ Branch: perl
+ ! README.qnx hints/qnx.sh
+ ____________________________________________________________________________
+ [ 11169] By: jhi on 2001/07/06 01:17:43
+ Log: Subject: [PATCH] Doc patch for Tie::Hash
+ From: Artur Bergman <artur@contiller.se>
+ Date: Thu, 05 Jul 2001 22:51:18 +0200
+ Message-ID: <B76A9FE6.1F04%artur@contiller.se>
+ Branch: perl
+ ! lib/Tie/Hash.pm
+ ____________________________________________________________________________
+ [ 11168] By: jhi on 2001/07/06 01:16:27
+ Log: Subject: [PATCH] perlfaq4.pod
+ From: "Liney, Dave" <dave.liney@gbr.conoco.com>
+ Message-ID: <1BB544A41666D311836C00902751FF6D01FD2D07@LONEX02>
+ Date: Thu, 5 Jul 2001 18:44:10 +0100
+ Branch: perl
+ ! pod/perlfaq4.pod
+ ____________________________________________________________________________
+ [ 11167] By: jhi on 2001/07/06 01:14:41
+ Log: Subject: [PATCH B::Deparse] Make warnings handling more robust
+ From: Robin Houston <robin@kitsite.com>
+ Date: Thu, 5 Jul 2001 18:33:21 +0100
+ Message-ID: <20010705183321.A27345@robin.kitsite.com>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 11166] By: jhi on 2001/07/06 01:11:50
+ Log: (Retracted by #11285.)
+
+ Subject: Re: [PATCH] mkdir() mode argument is missing initial 0
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Fri, 6 Jul 2001 01:26:32 +0530
+ Message-ID: <20010706012632.A28327@lustre.dyn.wiw.org>
+ Branch: perl
+ ! dump.c op.c op.h opcode.h opcode.pl pod/perldiag.pod pp.sym
+ ! pp_proto.h t/lib/warnings/op t/lib/warnings/toke toke.c
+ ! warnings.pl
+ ____________________________________________________________________________
+ [ 11165] By: jhi on 2001/07/06 00:19:26
+ Log: (Retracted by #11175)
+ Subject: [PATCH ext/POSIX/POSIX.pm] Re: sigaction.t under QNX
+ From: Norton Allen <allen@huarp.harvard.edu>
+ Message-Id: <200107051734.NAA13375@bottesini.harvard.edu>
+ Date: Thu, 5 Jul 2001 13:34:51 -0400 (edt)
+ Branch: perl
+ ! ext/POSIX/POSIX.xs
+ ____________________________________________________________________________
+ [ 11164] By: jhi on 2001/07/06 00:14:57
+ Log: Unterminated C< (noticed by Richard Hatch), and few other
+ small Unicode doc tweaks.
+ Branch: perl
+ ! pod/perlretut.pod
+ ____________________________________________________________________________
+ [ 11163] By: jhi on 2001/07/05 19:33:34
+ Log: More flexible argument understanding; add charblocks() and
+ charscripts(); make charblock() and charscript() two-way;
+ add charinrange(); separate the $Unicode::UCD::VERSION and
+ the version of the Unicode by adding UnicodeVersion().
+ Branch: perl
+ ! lib/Unicode/UCD.pm lib/Unicode/UCD.t
+ ____________________________________________________________________________
+ [ 11162] By: jhi on 2001/07/05 13:38:36
+ Log: Update Unicode::UCD on \p{In...}.
+ Branch: perl
+ ! lib/Unicode/UCD.pm
+ ____________________________________________________________________________
+ [ 11161] By: jhi on 2001/07/05 13:26:00
+ Log: Subject: Re: [PATCH lib/ExtUtils.t] Extra Files for QNX
+ From: Norton Allen <allen@huarp.harvard.edu>
+ Date: Thu, 5 Jul 2001 09:57:14 -0400 (edt)
+ Message-Id: <200107051357.JAA06285@bottesini.harvard.edu>
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm
+ ____________________________________________________________________________
+ [ 11160] By: jhi on 2001/07/05 13:06:53
+ Log: POSIX-BC tweaks from Thomas Dorner.
+ Branch: perl
+ ! hints/posix-bc.sh perlio.h
+ ____________________________________________________________________________
+ [ 11159] By: jhi on 2001/07/05 04:17:18
+ Log: Module updates for the delta.
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 11158] By: jhi on 2001/07/05 03:45:19
+ Log: Subject: [PATCH ext/IO/lib/IO/t/io_sock.t] for QNX
+ From: Norton Allen <allen@huarp.harvard.edu>
+ Message-Id: <200107050259.WAA06843@bottesini.harvard.edu>
+ Date: Wed, 4 Jul 2001 22:59:00 -0400 (edt)
+ Branch: perl
+ ! ext/IO/lib/IO/t/io_sock.t
+ ____________________________________________________________________________
+ [ 11157] By: jhi on 2001/07/05 03:44:19
+ Log: Subject: [PATCH perldiag.pod] Quick fixes
+ From: Simon Cozens <simon@netthink.co.uk>
+ Date: Wed, 4 Jul 2001 20:22:12 +0100
+ Message-ID: <20010704202212.A3690@deep-dark-truthful-mirror>
+ Branch: perl
+ ! pod/perldiag.pod
+ ____________________________________________________________________________
+ [ 11156] By: jhi on 2001/07/05 03:43:28
+ Log: Subject: [PATCH perl@11099]Re: [ID 20010704.003] Taint mode breaks global match
+ From: Radu Greab <radu@netsoft.ro>
+ Date: Wed, 4 Jul 2001 22:13:31 +0300
+ Message-ID: <15171.27355.895094.128142@ix.netsoft.ro>
+ Branch: perl
+ ! op.c sv.c t/op/pos.t
+ ____________________________________________________________________________
+ [ 11155] By: jhi on 2001/07/05 03:40:24
+ Log: Subject: [PATCH] -I and MakeMaker again
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Wed, 4 Jul 2001 15:03:07 -0400
+ Message-ID: <20010704150307.I20340@blackrider>
+
+ (and retract #11145)
+ Branch: perl
+ ! ext/util/make_ext lib/ExtUtils/MM_Unix.pm
+ ! lib/ExtUtils/MakeMaker.pm
+ ____________________________________________________________________________
+ [ 11154] By: jhi on 2001/07/05 03:32:43
+ Log: Subject: Re: PERFORCE change 11142 for review
+ From: "Philip Newton" <Philip.Newton@gmx.net>
+ Date: Wed, 4 Jul 2001 20:46:26 +0200
+ Message-Id: <200107041841.VAA25380@taas.iki.fi>
+ Branch: perl
+ ! lib/ExtUtils/MakeMaker.pm
+ ____________________________________________________________________________
+ [ 11153] By: jhi on 2001/07/05 03:29:21
+ Log: Subject: Re: [PATCH 2 pl2pm.PL] (was Re: [PATCH pl2pm.PL] Make pl2pm be nice with 'strict' and 'warnings')
+ From: Jonathan Stowe <gellyfish@gellyfish.com>
+ Date: Mon, 2 Jul 2001 20:45:53 +0100 (BST)
+ Message-ID: <Pine.LNX.4.33.0107022042570.8640-100000@orpheus.gellyfish.com>
+ Branch: perl
+ ! utils/pl2pm.PL
+ ____________________________________________________________________________
+ [ 11152] By: gsar on 2001/07/05 00:52:57
+ Log: fix the binary compatibility issue when building with/without
+ usemymalloc by exporting Perl_malloc() et al as simple wrappers
+ around the system functions (this allows most extensions built
+ using one mode to coexist with perls built in the other mode)
+
+ XXX the Perl_mfree() wrapper might need to do return(free()) on
+ platforms where Free_t isn't "void"
+ Branch: perl
+ ! embed.h embed.pl makedef.pl proto.h util.c
+ ____________________________________________________________________________
+ [ 11151] By: gsar on 2001/07/05 00:42:49
+ Log: perl built with USE_ITHREADS can deadlock during fork() or backticks
+ since it doesn't ensure threads other than the one calling fork()
+ aren't holding any locks; the fix is to use pthread_atfork() to
+ hold global locks
+
+ building perl with -Dusemymalloc exacerbates the problem since
+ Perl_malloc() holds a mutex, and perl's exec() calls New()
+
+ XXX the code in win32thread.h may be needed on platforms that have
+ no pthread_atfork()
+ Branch: perl
+ ! perl.c thread.h win32/win32thread.h
+ ____________________________________________________________________________
+ [ 11150] By: pudge on 2001/07/04 20:07:54
+ Log: Integrate #11009 from maintperl.
+ Branch: maint-5.6/macperl
+ !> lib/ExtUtils/Manifest.pm
+ ____________________________________________________________________________
+ [ 11149] By: pudge on 2001/07/04 19:54:46
+ Log: Flexing my Perforce muscles.
+ Branch: maint-5.6/macperl
+ ! README.macos
+ ____________________________________________________________________________
+ [ 11148] By: jhi on 2001/07/04 17:14:51
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 11147] By: jhi on 2001/07/04 16:41:25
+ Log: Metaconfig unit change for #11146.
+ Branch: metaconfig/U/perl
+ ! d_fcntl_can_lock.U
+ ____________________________________________________________________________
+ [ 11146] By: jhi on 2001/07/04 16:36:31
+ Log: Somehow the #ifdefs of the added code (in #11093) made
+ HP-UX to fail the fcntl locking test, without the ifdefs
+ the test seems to be working again. Reason unknown:
+ HP-UX cc doesn't complain either way.
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 11145] By: jhi on 2001/07/04 16:08:00
+ Log: (Retracted by #11155) PERLRUNINST needed in some spots.
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm
+ ____________________________________________________________________________
+ [ 11144] By: jhi on 2001/07/04 16:07:35
+ Log: gcc -Wall nit.
+ Branch: perl
+ ! pp_hot.c
+ ____________________________________________________________________________
+ [ 11143] By: jhi on 2001/07/04 15:08:26
+ Log: When removing tests updating the test count is a good idea, too.
+ Branch: perl
+ ! lib/Net/t/require.t
+ ____________________________________________________________________________
+ [ 11142] By: jhi on 2001/07/04 14:57:51
+ Log: Document #11134 and add the new symbols to the list of
+ of MakeMaker known ones.
+ Branch: perl
+ ! lib/ExtUtils/MakeMaker.pm
+ ____________________________________________________________________________
+ [ 11141] By: jhi on 2001/07/04 14:34:11
+ Log: Microperl update.
+ Branch: perl
+ ! uconfig.h
+ ____________________________________________________________________________
+ [ 11140] By: jhi on 2001/07/04 14:32:27
+ Log: Update the libnet tests as per #11138.
+ Branch: perl
+ - lib/Net/t/ph.t
+ ! MANIFEST lib/Net/t/require.t
+ ____________________________________________________________________________
+ [ 11139] By: jhi on 2001/07/04 14:14:33
+ Log: Regen toc and modlib.
+ Branch: perl
+ ! pod/perlmodlib.pod pod/perltoc.pod
+ ____________________________________________________________________________
+ [ 11138] By: jhi on 2001/07/04 14:10:38
+ Log: Remove DummyInetd, PH, and SNPP from the libnet, as per
+ Graham's request.
+ Branch: perl
+ - lib/Net/DummyInetd.pm lib/Net/PH.pm lib/Net/SNPP.pm
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 11137] By: jhi on 2001/07/04 14:06:35
+ Log: Add the OS/390 harness results to the delta.
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 11136] By: jhi on 2001/07/04 13:59:01
+ Log: Avoid the two study tests in OS/390 until the bug has been solved.
+ Branch: perl
+ ! t/op/study.t
+ ____________________________________________________________________________
+ [ 11135] By: jhi on 2001/07/04 13:49:08
+ Log: DOS/DJGPP tweaks from Laszlo Molnar.
+ Branch: perl
+ ! AUTHORS djgpp/djgppsed.sh hints/dos_djgpp.sh t/op/write.t
+ ____________________________________________________________________________
+ [ 11134] By: jhi on 2001/07/04 13:47:46
+ Log: Subject: [PATCH lib/ExtUtils/MM_Unix.pm and others] Fixing extra -I's with PERL_CORE
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Wed, 4 Jul 2001 00:01:16 -0400
+ Message-ID: <20010704000116.C591@blackrider>
+ Branch: perl
+ ! ext/util/make_ext lib/ExtUtils.t lib/ExtUtils/MM_Unix.pm
+ ____________________________________________________________________________
+ [ 11133] By: jhi on 2001/07/04 01:55:20
+ Log: The #11132 missed singleton characters (not part
+ of a unilo..unihi range) in Unicode scripts.
+ Branch: perl
+ ! lib/unicode/In/0.pl lib/unicode/In/1.pl lib/unicode/In/10.pl
+ ! lib/unicode/In/11.pl lib/unicode/In/12.pl lib/unicode/In/13.pl
+ ! lib/unicode/In/15.pl lib/unicode/In/16.pl lib/unicode/In/17.pl
+ ! lib/unicode/In/18.pl lib/unicode/In/19.pl lib/unicode/In/20.pl
+ ! lib/unicode/In/21.pl lib/unicode/In/24.pl lib/unicode/In/29.pl
+ ! lib/unicode/In/3.pl lib/unicode/In/30.pl lib/unicode/In/34.pl
+ ! lib/unicode/In/35.pl lib/unicode/In/37.pl lib/unicode/In/39.pl
+ ! lib/unicode/In/4.pl lib/unicode/In/5.pl lib/unicode/In/6.pl
+ ! lib/unicode/In/8.pl lib/unicode/In/9.pl lib/unicode/Scripts.pl
+ ! lib/unicode/mktables.PL t/op/pat.t
+ ____________________________________________________________________________
+ [ 11132] By: jhi on 2001/07/04 01:32:11
+ Log: Support preferentially the Unicode 'scripts' definition
+ in the \p{In...} notation since according to Unicode the
+ scripts concept is more natural for matching than using
+ the somewhat artificial block names. The block names are
+ still available, though, and if there's a name conflict,
+ the scripts one wins and the blocks one has to do with
+ 'Block' appended to its name. For more information see
+
+ http://www.unicode.org/unicode/reports/tr24/
+ Branch: perl
+ + lib/unicode/In/100.pl lib/unicode/In/101.pl
+ + lib/unicode/In/102.pl lib/unicode/In/103.pl
+ + lib/unicode/In/104.pl lib/unicode/In/105.pl
+ + lib/unicode/In/106.pl lib/unicode/In/107.pl
+ + lib/unicode/In/108.pl lib/unicode/In/109.pl
+ + lib/unicode/In/110.pl lib/unicode/In/111.pl
+ + lib/unicode/In/112.pl lib/unicode/In/113.pl
+ + lib/unicode/In/114.pl lib/unicode/In/115.pl
+ + lib/unicode/In/116.pl lib/unicode/In/117.pl
+ + lib/unicode/In/118.pl lib/unicode/In/119.pl
+ + lib/unicode/In/120.pl lib/unicode/In/121.pl
+ + lib/unicode/In/122.pl lib/unicode/In/123.pl
+ + lib/unicode/In/124.pl lib/unicode/In/125.pl
+ + lib/unicode/In/126.pl lib/unicode/In/127.pl
+ + lib/unicode/In/128.pl lib/unicode/In/129.pl
+ + lib/unicode/In/130.pl lib/unicode/In/131.pl
+ + lib/unicode/In/132.pl lib/unicode/In/133.pl
+ + lib/unicode/In/134.pl lib/unicode/In/135.pl
+ + lib/unicode/In/96.pl lib/unicode/In/97.pl lib/unicode/In/98.pl
+ + lib/unicode/In/99.pl lib/unicode/Scripts.pl
+ ! (edit 106 files)
+ ____________________________________________________________________________
+ [ 11131] By: jhi on 2001/07/03 23:02:02
+ Log: Better document the difference between a block and a script.
+ Branch: perl
+ ! lib/Unicode/UCD.pm
+ ____________________________________________________________________________
+ [ 11130] By: jhi on 2001/07/03 22:49:15
+ Log: Subject: [ perl 5.6.1 ] CPAN.pm doc patch
+ From: Elaine -HFB- Ashton <elaine@chaos.wustl.edu>
+ Date: Tue, 3 Jul 2001 15:04:23 -0500
+ Message-ID: <20010703150423.C9787@chaos.wustl.edu>
+ Branch: perl
+ ! lib/CPAN.pm
+ ____________________________________________________________________________
+ [ 11129] By: jhi on 2001/07/03 22:45:41
+ Log: Add tests for charscript().
+ Branch: perl
+ ! lib/Unicode/UCD.pm lib/Unicode/UCD.t
+ ____________________________________________________________________________
+ [ 11128] By: jhi on 2001/07/03 20:41:54
+ Log: Add charscript() to get the UTR#24 script names of characters.
+ Branch: perl
+ ! lib/Unicode/UCD.pm
+ ____________________________________________________________________________
+ [ 11127] By: jhi on 2001/07/03 19:53:29
+ Log: Todo updates.
+ Branch: perl
+ ! pod/perltodo.pod
+ ____________________________________________________________________________
+ [ 11126] By: jhi on 2001/07/03 19:45:30
+ Log: Unicode::UCD updates.
+ Branch: perl
+ ! lib/Unicode/UCD.pm
+ ____________________________________________________________________________
+ [ 11125] By: jhi on 2001/07/03 16:12:20
+ Log: (Retracted by #11174)
+ Subject: MakeMaker should pass through DEFINE and INC to subdirs
+ From: Alan Burlison <Alan.Burlison@sun.com>
+ Date: Tue, 03 Jul 2001 15:20:13 +0100
+ Message-ID: <3B41D49D.A923D4F9@sun.com>
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm
+ ____________________________________________________________________________
+ [ 11124] By: jhi on 2001/07/03 16:06:53
+ Log: Subject: Patch needed for UTS
+ From: hom00@utsglobal.com (Hal Morris)
+ Date: Tue, 3 Jul 2001 09:38:22 -0700 (PDT)
+ Message-Id: <200107031638.JAA11998@cepheus.utsglobal.com>
+
+ Replace #11113 with a better version.
+ Branch: perl
+ ! perl.h
+ ____________________________________________________________________________
+ [ 11123] By: jhi on 2001/07/03 16:04:49
+ Log: Subject: Re: POINTERRIGOR
+ From: Andy Dougherty <doughera@lafayette.edu>
+ Date: Tue, 3 Jul 2001 11:49:28 -0400 (EDT)
+ Message-ID: <Pine.SOL.4.10.10107031040030.1982-100000@maxwell.phys.lafayette.edu>
+ Branch: perl
+ ! util.c
+ ____________________________________________________________________________
+ [ 11122] By: jhi on 2001/07/03 16:03:31
+ Log: Subject: Re: [PATCH @11016] Fixes compile errors in four files
+ From: "Philip Newton" <pnewton@gmx.de>
+ Date: Tue, 3 Jul 2001 17:03:34 +0200
+ Message-ID: <3B41FAE6.29564.660E117@localhost>
+ Branch: perl
+ ! pp_hot.c
+ ____________________________________________________________________________
+ [ 11121] By: jhi on 2001/07/03 13:26:08
+ Log: Typos.
+ Branch: perl
+ ! INSTALL
+ ____________________________________________________________________________
+ [ 11120] By: jhi on 2001/07/03 11:34:47
+ Log: Subject: [PATCH 5.6.1] debugger fixes
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Tue, 3 Jul 2001 03:38:18 -0400
+ Message-ID: <20010703033818.A16788@math.ohio-state.edu>
+
+ The $^S is working again.
+ Branch: perl
+ ! lib/perl5db.pl
+ ____________________________________________________________________________
+ [ 11119] By: jhi on 2001/07/03 11:33:27
+ Log: Subject: Re: [PATCH 5.6.1] OS/2 improvements
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Tue, 3 Jul 2001 03:34:06 -0400
+ Message-ID: <20010703033406.A16776@math.ohio-state.edu>
+ Branch: perl
+ ! os2/OS2/Process/Process.pm
+ ____________________________________________________________________________
+ [ 11118] By: jhi on 2001/07/03 11:29:54
+ Log: Subject: [PATCH bleadperl] Bad lishp in change 11084
+ From: "Philip Newton" <Philip.Newton@gmx.net>
+ Date: Tue, 3 Jul 2001 09:11:27 +0200
+ Message-Id: <200107030706.KAA04596@taas.iki.fi>
+ Branch: perl
+ ! lib/FindBin.pm
+ ____________________________________________________________________________
+ [ 11117] By: jhi on 2001/07/03 11:25:14
+ Log: Delta delta.
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 11116] By: jhi on 2001/07/02 23:06:50
+ Log: Metaconfig unit change for 11115.
+ Branch: metaconfig
+ ! U/modified/libc.U
+ ____________________________________________________________________________
+ [ 11115] By: jhi on 2001/07/02 23:06:27
+ Log: Whitespace allowed at the ends of /lib/syscalls.exp lines
+ (from Richard Hatch) (this was the cause of pipes() and
+ times() myeteriously not being found)
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 11114] By: jhi on 2001/07/02 22:58:41
+ Log: Retract #10142, the real culprit found by Richard Hatch,
+ coming soon to Configure near you.
+ Branch: perl
+ ! hints/aix.sh
+ ____________________________________________________________________________
+ [ 11113] By: jhi on 2001/07/02 22:56:09
+ Log: (Replaced by #11124) UTS workaround from Hal Morris.
+ Branch: perl
+ ! perl.h
+ ____________________________________________________________________________
+ [ 11112] By: jhi on 2001/07/02 22:53:29
+ Log: Subject: [PATCH] grok not grocking correctly
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Tue, 3 Jul 2001 00:19:08 +0100
+ Message-ID: <20010703001908.H59620@plum.flirble.org>
+ Branch: perl
+ ! numeric.c
+ ____________________________________________________________________________
+ [ 11111] By: jhi on 2001/07/02 22:48:42
+ Log: Subject: [PATCH Deparse.t] test just-posted patches
+ From: Robin Houston <robin@kitsite.com>
+ Date: Mon, 2 Jul 2001 23:46:15 +0100
+ Message-Id: <E15HCUN-0000Rh-00.2001-07-02-23-48-19@mail18.svr.pol.co.uk>
+ Branch: perl
+ ! ext/B/Deparse.t
+ ____________________________________________________________________________
+ [ 11110] By: jhi on 2001/07/02 22:27:10
+ Log: Subject: [PATCH toke.c] autosplit into @F
+ From: Robin Houston <robin@kitsite.com>
+ Date: Mon, 2 Jul 2001 23:18:20 +0100
+ Message-Id: <E15HC3M-0007jL-00.2001-07-02-23-20-24@mail18.svr.pol.co.uk>
+ Branch: perl
+ ! perl.c toke.c
+ ____________________________________________________________________________
+ [ 11109] By: jhi on 2001/07/02 22:25:03
+ Log: Subject: [PATCH B::Deparse] hash key auto-quoting
+ From: Robin Houston <robin@kitsite.com>
+ Date: Mon, 2 Jul 2001 23:00:48 +0100
+ Message-Id: <E15HBmR-0006mc-00.2001-07-02-23-02-55@mail18.svr.pol.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 11108] By: jhi on 2001/07/02 19:21:18
+ Log: Subject: Re: [PATCH perlsnap] '-' !~ /\w/
+ From: "Philip Newton" <Philip.Newton@gmx.net>
+ Date: Mon, 2 Jul 2001 22:06:22 +0200
+ (no Message-Id)
+ Branch: perl
+ ! ext/NDBM_File/hints/linux.pl
+ ____________________________________________________________________________
+ [ 11107] By: jhi on 2001/07/02 19:19:25
+ Log: Subject: Re: Fixed pack problem - sort of
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Mon, 2 Jul 2001 20:59:20 +0100
+ Message-ID: <20010702205919.F59620@plum.flirble.org>
+ Branch: perl
+ ! pp_pack.c t/op/pack.t
+ ____________________________________________________________________________
+ [ 11106] By: jhi on 2001/07/02 19:18:28
+ Log: Subject: Re: [PATCH 5.6.1] OS/2 cwd
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 2 Jul 2001 15:45:41 -0400
+ Message-ID: <20010702154541.B24295@math.ohio-state.edu>
+ Branch: perl
+ ! os2/os2.c
+ ____________________________________________________________________________
+ [ 11105] By: jhi on 2001/07/02 19:17:27
+ Log: (Mistaken retraction)
+ Branch: perl
+ ! utils/pl2pm.PL
+ ____________________________________________________________________________
+ [ 11104] By: jhi on 2001/07/02 18:56:15
+ Log: Detypo in #11103.
+ Branch: perl
+ ! utils/pl2pm.PL
+ ____________________________________________________________________________
+ [ 11103] By: jhi on 2001/07/02 18:54:53
+ Log: Subject: [PATCH 2 pl2pm.PL] (was Re: [PATCH pl2pm.PL] Make pl2pm be nice with 'strict' and 'warnings')
+ From: Jonathan Stowe <gellyfish@gellyfish.com>
+ Date: Mon, 2 Jul 2001 19:17:21 +0100 (BST)
+ Message-ID: <Pine.LNX.4.33.0107021904530.7401-100000@orpheus.gellyfish.com>
+ Branch: perl
+ ! utils/pl2pm.PL
+ ____________________________________________________________________________
+ [ 11102] By: jhi on 2001/07/02 18:16:09
+ Log: Subject: [PATCH perl@11059] UCD.pm: if at first you don't succeed, croak?
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Mon, 02 Jul 2001 14:11:23 -0500
+ Message-Id: <5.1.0.14.0.20010702140058.01b6c9c0@exchi01>
+ Branch: perl
+ ! lib/Unicode/UCD.pm
+ ____________________________________________________________________________
+ [ 11101] By: jhi on 2001/07/02 18:14:51
+ Log: Subject: [PATCH] Re: op/numconvert.t failures
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Mon, 2 Jul 2001 20:10:48 +0100
+ Message-ID: <20010702201048.E59620@plum.flirble.org>
+ Branch: perl
+ ! t/op/numconvert.t
+ ____________________________________________________________________________
+ [ 11100] By: jhi on 2001/07/02 17:51:44
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 11099] By: jhi on 2001/07/02 17:46:31
+ Log: Retract #11055, didn't help much (2736 bytes vs 2725 bytes leaked).
+ The real fix must be more involved. The line of code all the leaky
+ call stacks seem to go through is op.c:2949, the PmopSTASH_set()
+ line of Perl_newPMOP().
+ Branch: perl
+ ! op.h
+ ____________________________________________________________________________
+ [ 11098] By: jhi on 2001/07/02 17:37:44
+ Log: Based on
+
+ Subject: Re: sizeof(struct sembuf)
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Sun, 1 Jul 2001 22:26:48 +0100
+ Message-ID: <20010701222648.W59620@plum.flirble.org>
+
+ but do semop() always the slow way.
+ Branch: perl
+ ! doio.c
+ ____________________________________________________________________________
+ [ 11097] By: jhi on 2001/07/02 17:22:14
+ Log: Subject: [PATCH] Encode/Tcl.t, for esc-seq encodings
+ From: SADAHIRO Tomoyuki <BQW10602@nifty.com>
+ Date: Tue, 03 Jul 2001 00:56:30 +0900
+ Message-Id: <20010703005600.2225.BQW10602@nifty.com>
+ Branch: perl
+ ! ext/Encode/Encode/Tcl.t
+ ____________________________________________________________________________
+ [ 11096] By: jhi on 2001/07/02 17:11:24
+ Log: Subject: [PATCH] Encode/Tcl.pm, continuous sequences
+ From: SADAHIRO Tomoyuki <BQW10602@nifty.com>
+ Date: Tue, 03 Jul 2001 00:55:46 +0900
+ Message-Id: <20010703005516.2222.BQW10602@nifty.com>
+ Branch: perl
+ ! ext/Encode/Encode/Tcl.pm
+ ____________________________________________________________________________
+ [ 11095] By: jhi on 2001/07/02 17:07:14
+ Log: Regen api and toc.
+ Branch: perl
+ ! pod/perlapi.pod pod/perltoc.pod
+ ____________________________________________________________________________
+ [ 11094] By: jhi on 2001/07/02 16:29:42
+ Log: Metaconfig unit change for #11093.
+ Branch: metaconfig/U/perl
+ ! d_fcntl_can_lock.U
+ ____________________________________________________________________________
+ [ 11093] By: jhi on 2001/07/02 16:28:56
+ Log: The fcntl locking test may hang if NFS locking messed up;
+ break out with alarm(10).
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 11092] By: jhi on 2001/07/02 14:11:31
+ Log: Move the mdelete.bat from win32/bin to win32.
+ Branch: perl
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 11091] By: jhi on 2001/07/02 14:10:01
+ Log: Typo in #11083.
+ Branch: perl
+ ! ext/Time/Piece/Piece.t
+ ____________________________________________________________________________
+ [ 11090] By: jhi on 2001/07/02 13:36:58
+ Log: Netware tweaks from Guruprasad.
+ Branch: perl
+ - NetWare/perlsdio.h
+ ! MANIFEST NetWare/Makefile NetWare/interface.c
+ ! NetWare/interface.h NetWare/iperlhost.h NetWare/nwtinfo.h
+ ! perlsdio.h
+ ____________________________________________________________________________
+ [ 11089] By: jhi on 2001/07/02 13:25:40
+ Log: Subject: Re: [PATH] shared -> unique;
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Wed, 27 Jun 2001 03:51:27 +0530
+ Message-ID: <20010627035127.A17623@lustre.lustre.dyn.wiw.org>
+ Branch: perl
+ ! dump.c gv.c gv.h op.c pp_sys.c sv.c toke.c xsutils.c
+ ____________________________________________________________________________
+ [ 11088] By: jhi on 2001/07/02 13:24:27
+ Log: Subject: Re: AIX / gcc-3.0
+ From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+ Date: Mon, 02 Jul 2001 15:20:21 +0200
+ Message-Id: <20010702151904.49BB.H.M.BRAND@hccnet.nl>
+ Branch: perl
+ ! hints/aix.sh
+ ____________________________________________________________________________
+ [ 11087] By: jhi on 2001/07/02 13:23:21
+ Log: Subject: Re: Bug report: split splits on wrong pattern
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Message-ID: <20010702163133.A23186@lustre.dyn.wiw.org>
+ Date: Mon, 2 Jul 2001 16:31:33 +0530
+ Branch: perl
+ ! pp_ctl.c
+ ____________________________________________________________________________
+ [ 11086] By: jhi on 2001/07/02 13:22:30
+ Log: Subject: [PATCH 5.6.1] test harness
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 2 Jul 2001 06:29:21 -0400
+ Message-ID: <20010702062921.A1810@math.ohio-state.edu>
+ Branch: perl
+ ! lib/Test/Harness.pm
+ ____________________________________________________________________________
+ [ 11085] By: jhi on 2001/07/02 13:21:39
+ Log: Subject: [PATCH 5.6.1] debugger goof
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 2 Jul 2001 06:27:22 -0400
+ Message-ID: <20010702062722.A1746@math.ohio-state.edu>
+ Branch: perl
+ ! lib/perl5db.pl
+ ____________________________________________________________________________
+ [ 11084] By: jhi on 2001/07/02 13:20:50
+ Log: Subject: [PATCH 5.6.1] OS/2 cwd
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 2 Jul 2001 06:21:17 -0400
+ Message-ID: <20010702062117.A1401@math.ohio-state.edu>
+ Branch: perl
+ ! lib/Cwd.pm lib/File/Find/taint.t lib/FindBin.pm os2/os2.c
+ ____________________________________________________________________________
+ [ 11083] By: jhi on 2001/07/02 13:19:18
+ Log: Make #11082 more OS/2-specific.
+ Branch: perl
+ ! ext/Time/Piece/Piece.t
+ ____________________________________________________________________________
+ [ 11082] By: jhi on 2001/07/02 13:14:36
+ Log: Subject: [PATCH 5.6.1] OS/2 gmtime()
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 2 Jul 2001 06:06:34 -0400
+ Message-ID: <20010702060634.A1356@math.ohio-state.edu>
+ Branch: perl
+ ! ext/Time/Piece/Piece.t
+ ____________________________________________________________________________
+ [ 11081] By: jhi on 2001/07/02 13:13:08
+ Log: Subject: [PATCH B::Deparse] version number & changes
+ From: Robin Houston <robin@kitsite.com>
+ Date: Sun, 1 Jul 2001 17:17:29 +0100
+ Message-ID: <20010701171729.A30678@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 11080] By: jhi on 2001/07/02 13:11:48
+ Log: Subject: a small fix.
+ From: "Konovalov, Vadim Vladimirovich (Vadim)" <vkonovalov@lucent.com>
+ Date: Mon, 2 Jul 2001 12:17:53 +0200
+ Message-ID: <E3FB32585BF1D411B9E900805FF51A08074B35@RU0022EXCH001U>
+ Branch: perl
+ ! ext/Thread/Thread.xs
+ ____________________________________________________________________________
+ [ 11079] By: jhi on 2001/07/02 13:10:39
+ Log: Subject: RE: perl@10907
+ From: "Konovalov, Vadim Vladimirovich (Vadim)" <vkonovalov@lucent.com>
+ Date: Mon, 2 Jul 2001 12:06:16 +0200
+ Message-ID: <E3FB32585BF1D411B9E900805FF51A08074B2C@RU0022EXCH001U>
+
+ Borland C vs PerlIO.
+ Branch: perl
+ ! win32/config.bc win32/config_H.bc
+ ____________________________________________________________________________
+ [ 11078] By: jhi on 2001/07/02 13:03:44
+ Log: Subject: [PATCH] Report /pro/3gl/CPAN/perl-5.7.1
+ From: "H.M. Brand" <merijn@l1.procura.nl>
+ Date: Mon, 02 Jul 2001 11:18:57 +0200
+ Message-Id: <20010702100811.4999.MERIJN@l1.procura.nl>
+ Branch: perl
+ ! t/op/write.t
+ ____________________________________________________________________________
+ [ 11077] By: jhi on 2001/07/02 12:58:27
+ Log: Subject: [PATCH] Deleting ext/util/mkbootstrap
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Mon, 2 Jul 2001 00:26:24 -0400
+ Message-ID: <20010702002624.A18302@blackrider>
+ Branch: perl
+ - ext/util/mkbootstrap
+ ____________________________________________________________________________
+ [ 11076] By: jhi on 2001/07/02 12:56:20
+ Log: Subject: [PATCH op.h] v minor comment tweak
+ From: Robin Houston <robin@puffinry.freeserve.co.uk>
+ Date: Mon, 2 Jul 2001 00:42:01 +0100
+ Message-Id: <E15GqxK-0006WZ-00.2001-07-02-00-48-46@mail18.svr.pol.co.uk>
+ Branch: perl
+ ! op.h
+ ____________________________________________________________________________
+ [ 11075] By: jhi on 2001/07/02 12:53:48
+ Log: SysV IPC semops use native shorts, not forced-to-16-bit-shorts.
+ Branch: perl
+ ! pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 11074] By: jhi on 2001/07/02 12:52:28
+ Log: Subject: Re: sizeof(struct sembuf)
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Sun, 1 Jul 2001 19:23:16 +0100
+ Message-ID: <20010701192316.V59620@plum.flirble.org>
+
+ s/signaling/signalling/
+ Branch: perl
+ ! pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 11073] By: jhi on 2001/07/02 12:49:51
+ Log: Subject: [PATCH perlsnap] Suggestion for mnemonic for $^N
+ From: "Philip Newton" <Philip.Newton@gmx.net>
+ Date: Sun, 1 Jul 2001 09:37:56 +0200
+ Message-Id: <200107010733.KAA03920@taas.iki.fi>
+ Branch: perl
+ ! pod/perlvar.pod
+ ____________________________________________________________________________
+ [ 11072] By: jhi on 2001/07/02 12:48:03
+ Log: Subject: [PATCH perlsnap] /^qnx|nto$/ --> /^(?:qnx|nto)$/
+ From: "Philip Newton" <Philip.Newton@gmx.net>
+ Date: Sun, 1 Jul 2001 09:37:56 +0200
+ Message-Id: <200107010733.KAA03925@taas.iki.fi>
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm lib/File/Spec/Unix.pm
+ ____________________________________________________________________________
+ [ 11071] By: jhi on 2001/07/02 12:45:12
+ Log: Metaconfig unit change for #11070.
+ Branch: metaconfig
+ ! U/compline/randfunc.U
+ ____________________________________________________________________________
+ [ 11070] By: jhi on 2001/07/02 12:43:58
+ Log: Subject: [PATCH perlsnap] its --> it's --> its
+ From: "Philip Newton" <Philip.Newton@gmx.net>
+ Date: Sun, 1 Jul 2001 09:37:56 +0200
+ Message-Id: <200107010733.KAA03914@taas.iki.fi>
+ Branch: perl
+ ! Porting/config_H
+ ____________________________________________________________________________
+ [ 11069] By: jhi on 2001/07/02 12:01:52
+ Log: Sync with Sarathy; integrate with perlio.
+ Branch: perl
+ !> gv.c
+ ____________________________________________________________________________
+ [ 11068] By: gsar on 2001/07/02 08:07:54
+ Log: regenerate win32/config_H.?c files
+ Branch: perl
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ____________________________________________________________________________
+ [ 11067] By: gsar on 2001/07/02 08:03:55
+ Log: rename s/sv_getcwd/getcwd_sv/ for better conformance to existing
+ naming discipline
+
+ win32 fix: enable getcwd_sv() to work on windows (POSIX.t was failing
+ because of this)
+
+ fix a warning about "fd" being used without being set in Cwd.xs
+ Branch: perl
+ ! embed.h embed.pl ext/Cwd/Cwd.xs ext/POSIX/POSIX.t
+ ! ext/POSIX/POSIX.xs global.sym objXSUB.h perlapi.c
+ ! pod/perlapi.pod proto.h util.c win32/config.bc win32/config.gc
+ ! win32/config.vc
+ ____________________________________________________________________________
+ [ 11066] By: gsar on 2001/07/02 07:12:10
+ Log: win32 fixes: fix various syntax errors ("no preprocessor directives
+ within macro arguments") and warnings ("unary minus applied to
+ unsigned type", among others)
+ Branch: perl
+ ! gv.c hv.c op.c pp.c sv.c toke.c
+ ____________________________________________________________________________
+ [ 11065] By: gsar on 2001/07/02 06:26:22
+ Log: win32 fixes: more spurious CRs
+ Branch: perl
+ ! win32/mdelete.bat
+ ____________________________________________________________________________
+ [ 11064] By: gsar on 2001/07/02 06:25:22
+ Log: win32 tweaks: remove extra CRs from makefile.mk; move mdelete.bat
+ from win32/bin (or it gets deleted by distclean); don't delete
+ lib/Cwd.pm during distclean; mdelete.bat doesn't work properly on
+ NT (should be made Win9x specific, and added to makefile.mk)
+ Branch: perl
+ +> win32/mdelete.bat
+ - win32/bin/mdelete.bat
+ ! win32/Makefile win32/makefile.mk
+ ____________________________________________________________________________
+ [ 11063] By: nick on 2001/07/01 18:54:09
+ Log: Quick for for #ifdef mess
+ Branch: perlio
+ ! gv.c
+ ____________________________________________________________________________
+ [ 11062] By: nick on 2001/07/01 18:47:42
+ Log: Raw integrate - does not build #if mess in gv.c
+ Branch: perlio
+ !> (integrate 29 files)
+ ____________________________________________________________________________
+ [ 11061] By: jhi on 2001/07/01 15:20:38
+ Log: Make 'compile' target a little less broken.
+ Still very broken, though: -Wall warnings from
+ the generated code, boot_Foo prototypes missing,
+ can't autoload Fcntl::SEEK_CUR et alia, ...
+ Branch: perl
+ ! ext/B/B/C.pm pod/Makefile.SH t/TEST utils/Makefile
+ ! utils/perlcc.PL x2p/Makefile.SH
+ ____________________________________________________________________________
+ [ 11060] By: jhi on 2001/07/01 14:04:20
+ Log: Upgrade to Storable 1.0.12, from Raphael Manfredi.
+ Branch: perl
+ ! ext/Storable/ChangeLog ext/Storable/Storable.pm
+ ! ext/Storable/Storable.xs ext/Storable/t/freeze.t
+ ____________________________________________________________________________
+ [ 11059] By: jhi on 2001/07/01 05:02:59
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 11058] By: jhi on 2001/07/01 04:57:05
+ Log: Still one typo, regen toc.
+ Branch: perl
+ ! lib/Unicode/UCD.pm pod/perltoc.pod
+ ____________________________________________________________________________
+ [ 11057] By: jhi on 2001/07/01 04:54:35
+ Log: Detypos and regen toc.
+ Branch: perl
+ ! README.os2 lib/Unicode/UCD.pm pod/perltoc.pod
+ ____________________________________________________________________________
+ [ 11056] By: jhi on 2001/07/01 04:26:08
+ Log: VERSION tweak.
+ Branch: perl
+ ! ext/List/Util/lib/List/Util.pm
+ ____________________________________________________________________________
+ [ 11055] By: jhi on 2001/06/30 22:18:37
+ Log: Attempt at plugging the leak under ithreads detected by Doug.
+ Branch: perl
+ ! op.h
+ ____________________________________________________________________________
+ [ 11054] By: jhi on 2001/06/30 21:33:29
+ Log: gcc -Wall lint after #11051.
+ Branch: perl
+ ! pp_sys.c
+ ____________________________________________________________________________
+ [ 11053] By: jhi on 2001/06/30 21:13:55
+ Log: Integrate perlio.
+ Branch: perl
+ !> lib/File/Find/taint.t
+ ____________________________________________________________________________
+ [ 11052] By: jhi on 2001/06/30 21:07:38
+ Log: Don't use the v-strings for module VERSIONs.
+ Branch: perl
+ ! lib/Unicode/UCD.pm
+ ____________________________________________________________________________
+ [ 11051] By: jhi on 2001/06/30 20:59:57
+ Log: Code cleanup based on turning off the -woffs in IRIX.
+ Not all of the gripes cleaned up (hairy code in hv.c and
+ regcomp.c; unused newsp, gimme, and optype from cop.h macros;
+ unused 'key' arguments in ?DBM_File.xs) (and the -woffs left
+ to the IRIX hints)
+ Branch: perl
+ ! ext/DB_File/DB_File.xs ext/Data/Dumper/Dumper.xs
+ ! ext/IPC/SysV/SysV.xs ext/List/Util/Util.xs
+ ! ext/PerlIO/Scalar/Scalar.xs gv.c mg.c op.c perlio.c pp_sys.c
+ ! regcomp.c sv.c
+ ____________________________________________________________________________
+ [ 11050] By: nick on 2001/06/30 20:46:46
+ Log: Jeffrey Friedl's <jfriedl@yahoo.com> fix for lib/File/Find/taint.t
+ Branch: perlio
+ ! lib/File/Find/taint.t
+ ____________________________________________________________________________
+ [ 11049] By: nick on 2001/06/30 18:13:33
+ Log: Integrate mainline
+ Branch: perlio
+ +> NetWare/nwstdio.h NetWare/perlsdio.h
+ +> ext/Encode/Encode/7bit-jis.enc ext/Encode/Encode/7bit-kana.enc
+ +> ext/Encode/Encode/7bit-kr.enc lib/Unicode/UCD.pm
+ +> lib/Unicode/UCD.t t/run/exit.t
+ !> (integrate 60 files)
+ ____________________________________________________________________________
+ [ 11048] By: jhi on 2001/06/30 16:23:39
+ Log: Delta delta.
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 11047] By: jhi on 2001/06/30 16:03:40
+ Log: More VERSION tuning: to avoid unnecessary Perl upgrades
+ by CPAN.pm, use rather _00.
+ Branch: perl
+ ! ext/Errno/Errno_pm.PL ext/IO/lib/IO/Dir.pm
+ ! ext/IO/lib/IO/Handle.pm ext/IO/lib/IO/Seekable.pm
+ ! ext/IO/lib/IO/Socket/UNIX.pm ext/IPC/SysV/Msg.pm
+ ! ext/IPC/SysV/Semaphore.pm ext/IPC/SysV/SysV.pm
+ ! ext/Time/HiRes/HiRes.pm lib/CGI/Pretty.pm lib/CPAN/Nox.pm
+ ! lib/ExtUtils/Embed.pm lib/Test.pm
+ ____________________________________________________________________________
+ [ 11046] By: jhi on 2001/06/30 15:53:22
+ Log: Add a simple Unicode character database interface, Unicode::UCD.
+ Branch: perl
+ + lib/Unicode/UCD.pm lib/Unicode/UCD.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 11045] By: jhi on 2001/06/30 13:42:37
+ Log: Subject: [PATCH] op/numconver.t
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Sat, 30 Jun 2001 15:40:10 +0100
+ Message-ID: <20010630154010.I59620@plum.flirble.org>
+ Branch: perl
+ ! t/op/numconvert.t
+ ____________________________________________________________________________
+ [ 11044] By: jhi on 2001/06/30 13:29:25
+ Log: The $^N is now taken (by #11038).
+ Branch: perl
+ ! t/base/lex.t
+ ____________________________________________________________________________
+ [ 11043] By: jhi on 2001/06/30 13:15:59
+ Log: The #11040 had slipped to a wrong function...
+ Branch: perl
+ ! sv.c
+ ____________________________________________________________________________
+ [ 11042] By: jhi on 2001/06/30 13:08:25
+ Log: In 64-bit AIX 5L (oslevel 5.1.0.0, ccversion 5.0.2.0)
+ the Configure library symbol probe mysteriously finds all
+ symbols but those of pipe() and times().
+ Branch: perl
+ ! hints/aix.sh
+ ____________________________________________________________________________
+ [ 11041] By: jhi on 2001/06/30 13:01:25
+ Log: Subject: [PATCH] (was Re: not OK: perl@11006 on HP-UX B.11.00)
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Fri, 29 Jun 2001 23:49:07 +0100
+ Message-ID: <20010629234907.D59620@plum.flirble.org>
+ Branch: perl
+ ! lib/ExtUtils.t
+ ____________________________________________________________________________
+ [ 11040] By: jhi on 2001/06/30 13:00:24
+ Log: Subject: [PATCH] weakref fix 2, not yet there
+ From: Artur Bergman <artur@contiller.se>
+ Date: Sat, 30 Jun 2001 01:18:16 +0200
+ Message-ID: <B762D957.1CC9%artur@contiller.se>
+ Branch: perl
+ ! sv.c
+ ____________________________________________________________________________
+ [ 11039] By: jhi on 2001/06/30 12:59:25
+ Log: Subject: [PATCH t/run/exit.t] Another shot at testing exit codes.
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Fri, 29 Jun 2001 19:39:11 -0400
+ Message-ID: <20010629193910.D25304@blackrider>
+ Branch: perl
+ + t/run/exit.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 11038] By: jhi on 2001/06/30 12:58:16
+ Log: Add support for $^N, the most-recently closed group.
+ Branch: perl
+ ! embedvar.h gv.c mg.c perlapi.h pod/perlretut.pod
+ ! pod/perltoc.pod pod/perlvar.pod regexec.c regexp.h t/op/pat.t
+ ! thrdvar.h
+ ____________________________________________________________________________
+ [ 11037] By: jhi on 2001/06/30 12:53:40
+ Log: Subject: [ID 20010630.001] Editorial nits in README.solaris
+ From: lvirden@cas.org
+ Date: Sat, 30 Jun 2001 04:12:36 -0400 (EDT)
+ Message-Id: <200106300812.f5U8CaG10447@lwv26awu.cas.org>
+
+ Subject: [ID 20010630.002] Another editorial tweak to README.solaris
+ From: lvirden@cas.org
+ Date: Sat, 30 Jun 2001 04:17:55 -0400 (EDT)
+ Message-Id: <200106300817.f5U8HtN10626@lwv26awu.cas.org>
+ Branch: perl
+ ! README.solaris
+ ____________________________________________________________________________
+ [ 11036] By: jhi on 2001/06/30 12:51:45
+ Log: Subject: [PATCH] Encode.pm to use escape-sequence encoding
+ From: SADAHIRO Tomoyuki <BQW10602@nifty.com>
+ Date: Sat, 30 Jun 2001 07:33:37 +0900
+ Message-Id: <20010630073226.7C79.BQW10602@nifty.com>
+
+ Subject: Re: [PATCH] Encode.pm to use escape-sequence encoding
+ From: SADAHIRO Tomoyuki <BQW10602@nifty.com>
+ Date: Sat, 30 Jun 2001 21:38:14 +0900
+ Message-Id: <20010630213554.F67A.BQW10602@nifty.com>
+ Branch: perl
+ + ext/Encode/Encode/7bit-jis.enc ext/Encode/Encode/7bit-kana.enc
+ + ext/Encode/Encode/7bit-kr.enc
+ ! MANIFEST ext/Encode/Encode/Tcl.pm
+ ____________________________________________________________________________
+ [ 11035] By: jhi on 2001/06/30 12:44:51
+ Log: NetWare tweaks from Guruprasad.
+ Branch: perl
+ + NetWare/nwstdio.h NetWare/perlsdio.h
+ ! MANIFEST NetWare/Makefile NetWare/config.wc
+ ! NetWare/config_H.wc NetWare/nwperlsys.c NetWare/nwperlsys.h
+ ! NetWare/t/Readme.txt
+ ____________________________________________________________________________
+ [ 11034] By: jhi on 2001/06/29 23:28:16
+ Log: More module $VERSION bump-ups.
+ Branch: perl
+ ! ext/Devel/Peek/Peek.pm lib/ExtUtils/Embed.pm
+ ! lib/ExtUtils/Liblist.pm lib/ExtUtils/Manifest.pm
+ ! lib/ExtUtils/Mksymlists.pm lib/IPC/Open3.pm
+ ____________________________________________________________________________
+ [ 11033] By: jhi on 2001/06/29 21:25:23
+ Log: Doc update due to #11032.
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 11032] By: jhi on 2001/06/29 21:19:44
+ Log: Subject: [PATCH: perl@11006] s/div/lib\$ediv/ in Time::HiRes for VAX
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Fri, 29 Jun 2001 14:02:16 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10106291337520.65853-100000@aspara.forte.com>
+ Branch: perl
+ ! ext/Time/HiRes/HiRes.xs
+ ____________________________________________________________________________
+ [ 11031] By: jhi on 2001/06/29 14:31:53
+ Log: -lpthreads missing in AIX.
+ Branch: perl
+ ! hints/aix.sh
+ ____________________________________________________________________________
+ [ 11030] By: jhi on 2001/06/29 14:08:12
+ Log: Subject: [PATCH] CLONE && weakrefs
+ From: Artur Bergman <artur@contiller.se>
+ Date: Fri, 29 Jun 2001 17:02:00 +0200
+ Message-ID: <B7626508.1CA0%artur@contiller.se>
+ Branch: perl
+ ! sv.c
+ ____________________________________________________________________________
+ [ 11029] By: jhi on 2001/06/29 14:06:50
+ Log: Subject: Re: Bug report: split splits on wrong pattern
+ From: Radu Greab <radu@netsoft.ro>
+ Date: Wed, 27 Jun 2001 21:50:52 +0300
+ Message-ID: <15162.11020.279064.471031@ix.netsoft.ro>
+ Branch: perl
+ ! pp_ctl.c t/op/split.t
+ ____________________________________________________________________________
+ [ 11028] By: jhi on 2001/06/29 13:47:38
+ Log: Metaconfig unit change for #11027.
+ Branch: metaconfig/U/perl
+ ! d_modfl.U
+ ____________________________________________________________________________
+ [ 11027] By: jhi on 2001/06/29 13:47:03
+ Log: I thought this Configure glitch for AIX was just recently fixed?
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 11026] By: jhi on 2001/06/29 13:14:07
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 11025] By: jhi on 2001/06/29 13:07:57
+ Log: Subject: Re: perl@10967, File::Find, and Cwd
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Fri, 29 Jun 2001 14:56:49 +0100
+ Message-Id: <E15FylN-0004LT-00@draco.cus.cam.ac.uk>
+ Branch: perl
+ ! lib/File/Find/taint.t
+ ____________________________________________________________________________
+ [ 11024] By: jhi on 2001/06/29 12:39:23
+ Log: Update the sv_pvprintify() spec.
+ Branch: perl
+ ! pod/perltodo.pod
+ ____________________________________________________________________________
+ [ 11023] By: jhi on 2001/06/29 12:33:33
+ Log: Known test failures update.
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 11022] By: jhi on 2001/06/29 12:24:32
+ Log: Based on
+
+ Subject: [PATCH @11016] More );) fixes
+ From: Richard Soderberg <rs@crystalflame.net>
+ Date: Fri, 29 Jun 2001 04:09:24 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0106290408200.12037-100000@oregonnet.com>
+ Branch: perl
+ ! ext/Thread/Thread.xs ext/Thread/typemap
+ ____________________________________________________________________________
+ [ 11021] By: jhi on 2001/06/29 12:21:51
+ Log: Subject: [PATCH @11016] Fixes compile errors in four files
+ From: Richard Soderberg <rs@crystalflame.net>
+ Date: Fri, 29 Jun 2001 03:35:11 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0106290333270.9768-100000@oregonnet.com>
+ Branch: perl
+ ! mg.c pp.c pp_hot.c util.c
+ ____________________________________________________________________________
+ [ 11020] By: jhi on 2001/06/29 12:05:54
+ Log: AIX hints tweaking continues, from Merijn Brand.
+ Branch: perl
+ ! hints/aix.sh
+ ____________________________________________________________________________
+ [ 11019] By: jhi on 2001/06/29 12:05:10
+ Log: HP-UX needs gccversion sooner, from Merijn Brand.
+ Branch: perl
+ ! hints/hpux.sh
+ ____________________________________________________________________________
+ [ 11018] By: jhi on 2001/06/29 11:52:31
+ Log: Subject: [PATCH 5.6.1] OS/2 docs
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Fri, 29 Jun 2001 02:34:12 -0400
+ Message-ID: <20010629023412.A6033@math.ohio-state.edu>
+ Branch: perl
+ ! README.os2 os2/Changes
+ ____________________________________________________________________________
+ [ 11017] By: nick on 2001/06/29 10:20:30
+ Log: Integrate mainline
+ Branch: perlio
+ +> (branch 37 files)
+ - ext/ODBM_File/sdbm.t
+ !> (integrate 211 files)
+ ____________________________________________________________________________
+ [ 11016] By: jhi on 2001/06/29 03:38:56
+ Log: Bump up the VERSIONs of modules that have changed since 5.6.0,
+ the modules found using a script written by Larry Schatzer Jr.
+ Branch: perl
+ ! ext/IO/lib/IO/Dir.pm ext/IO/lib/IO/Handle.pm
+ ! ext/IO/lib/IO/Seekable.pm ext/IO/lib/IO/Select.pm
+ ! ext/IO/lib/IO/Socket/INET.pm ext/IO/lib/IO/Socket/UNIX.pm
+ ! ext/IPC/SysV/Msg.pm ext/IPC/SysV/Semaphore.pm
+ ! ext/IPC/SysV/SysV.pm ext/Opcode/Opcode.pm ext/Opcode/Safe.pm
+ ! ext/Thread/Thread.pm ext/attrs/attrs.pm ext/re/re.pm
+ ! lib/AutoSplit.pm lib/Benchmark.pm lib/CGI/Pretty.pm
+ ! lib/CPAN/Nox.pm lib/Exporter.pm lib/ExtUtils/Command.pm
+ ! lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Packlist.pm
+ ! lib/File/Compare.pm lib/FileHandle.pm lib/Math/Complex.pm
+ ! lib/Math/Trig.pm lib/Pod/Html.pm lib/Symbol.pm
+ ! lib/Text/ParseWords.pm lib/Text/Soundex.pm lib/Text/Tabs.pm
+ ! lib/Tie/Array.pm lib/attributes.pm lib/autouse.pm lib/base.pm
+ ! lib/constant.pm lib/fields.pm lib/strict.pm
+ ____________________________________________________________________________
+ [ 11015] By: jhi on 2001/06/29 02:55:58
+ Log: The latest JPL from the anoncvs.
+ Branch: perl
+ ! jpl/JNI/JNI.pm jpl/JNI/JNI.xs jpl/JNI/Makefile.PL
+ ____________________________________________________________________________
+ [ 11014] By: jhi on 2001/06/29 02:16:55
+ Log: In EBCDIC assume UTF-EBCDIC, not UTF-8.
+ Branch: perl
+ ! t/op/pat.t
+ ____________________________________________________________________________
+ [ 11013] By: jhi on 2001/06/28 23:14:53
+ Log: Worrying about insecure directories now is a bit too late.
+ Branch: perl
+ ! lib/File/Find/taint.t
+ ____________________________________________________________________________
+ [ 11012] By: jhi on 2001/06/28 21:36:36
+ Log: Cannot DIE() in a void function,
+ from Richard Hatch <rhatch@austin.ibm.com>.
+ Branch: perl
+ ! ext/IPC/SysV/SysV.xs
+ ____________________________________________________________________________
+ [ 11011] By: jhi on 2001/06/28 19:32:13
+ Log: Subject: [PATCH: perl@11006] s/qdiv/div/ in Time::HiRes for VAX
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Thu, 28 Jun 2001 13:00:18 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10106281125220.508935-100000@aspara.forte.com>
+
+ (unfinished: time/hires tests 3, 5, 14 failing, but better
+ than wholesale failure)
+ Branch: perl
+ ! ext/Time/HiRes/HiRes.xs
+ ____________________________________________________________________________
+ [ 11010] By: jhi on 2001/06/28 19:10:54
+ Log: Subject: [PATCH 5.6.1] OS/2 improvements
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Thu, 28 Jun 2001 16:03:14 -0400
+ Message-ID: <20010628160314.A17906@math.ohio-state.edu>
+ Branch: perl
+ + os2/os2_base.t
+ ! MANIFEST hints/os2.sh makedef.pl os2/OS2/PrfDB/PrfDB.xs
+ ! os2/OS2/Process/Process.pm os2/OS2/Process/Process.xs
+ ! os2/OS2/REXX/REXX.xs os2/dl_os2.c os2/dlfcn.h os2/os2.c
+ ! os2/os2ish.h
+ ____________________________________________________________________________
+ [ 11009] By: jhi on 2001/06/28 18:54:14
+ Log: Subject: Incrementing Extutils::Manifest's $VERSION
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Thu, 28 Jun 2001 13:13:49 -0400
+ Message-ID: <20010628131349.A14738@blackrider>
+ Branch: maint-5.6/perl
+ ! lib/ExtUtils/Manifest.pm
+ ____________________________________________________________________________
+ [ 11008] By: jhi on 2001/06/28 18:52:20
+ Log: AIX tweak from Merijn Brand.
+ Branch: perl
+ ! hints/aix.sh
+ ____________________________________________________________________________
+ [ 11007] By: jhi on 2001/06/28 17:46:27
+ Log: Create the macperl branch.
+ Branch: maint-5.6/macperl
+ +> (branch 1728 files)
+ ____________________________________________________________________________
+ [ 11006] By: jhi on 2001/06/28 14:46:21
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 11005] By: jhi on 2001/06/28 14:40:11
+ Log: More Perforce lore.
+ Branch: perl
+ ! Porting/repository.pod
+ ____________________________________________________________________________
+ [ 11004] By: jhi on 2001/06/28 14:12:50
+ Log: Metaconfig unit changes for #11003.
+ Branch: metaconfig/U/perl
+ + d_nl_langinfo.U i_langinfo.U
+ ____________________________________________________________________________
+ [ 11003] By: jhi on 2001/06/28 14:12:27
+ Log: Add Configure probes for nl_langinfo() and <langinfo.h>.
+ Expected not to exist in non-UNIX excepting in VMS, where
+ according to a quick web survey they just might.
+ Branch: perl
+ ! Configure NetWare/config.wc Porting/Glossary Porting/config.sh
+ ! Porting/config_H config_h.SH configure.com epoc/config.sh
+ ! perl.h uconfig.h uconfig.sh vos/config.alpha.def
+ ! vos/config.alpha.h vos/config.ga.def vos/config.ga.h
+ ! win32/config.bc win32/config.gc win32/config.vc
+ ____________________________________________________________________________
+ [ 11002] By: jhi on 2001/06/28 13:39:11
+ Log: One shouldn't use XBS5_ILP32_OFFBIG_CFLAGS et alia
+ in AIX is one is doing a 64-bit build.
+ Branch: perl
+ ! hints/aix.sh
+ ____________________________________________________________________________
+ [ 11001] By: jhi on 2001/06/28 13:28:37
+ Log: Metaconfig unit changes for #11000.
+ Branch: metaconfig/U/perl
+ ! use64bits.U uselfs.U
+ ____________________________________________________________________________
+ [ 11000] By: jhi on 2001/06/28 13:21:16
+ Log: Move use64bitint and use64bitall before uselargefiles.
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10999] By: jhi on 2001/06/28 03:49:07
+ Log: Subject: [ID 20010625.009] open(FILE,"+foo") [PATCH]
+ From: Robert Spier <rspier@pobox.com>
+ Message-ID: <15162.41164.618712.841415@rls.cx>
+ Date: Wed, 27 Jun 2001 23:13:16 -0400
+ Branch: perl
+ ! doio.c
+ ____________________________________________________________________________
+ [ 10998] By: jhi on 2001/06/28 03:42:57
+ Log: Subject: [PATCH: perl@10996] avoid overflow in numeric.c:S_mulexp10() on VAX
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Wed, 27 Jun 2001 19:25:49 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10106271922120.465082-100000@aspara.forte.com>
+ Branch: perl
+ ! numeric.c
+ ____________________________________________________________________________
+ [ 10997] By: jhi on 2001/06/28 03:42:12
+ Log: Subject: [patch perl@10996] "fix" VAX Digest/MD5, Fcntl, brokennes in SDBM
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Wed, 27 Jun 2001 17:33:33 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10106271705390.467850-100000@aspara.forte.com>
+ Branch: perl
+ ! configure.com ext/Digest/MD5/Makefile.PL
+ ____________________________________________________________________________
+ [ 10996] By: jhi on 2001/06/27 20:34:11
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10995] By: jhi on 2001/06/27 20:06:28
+ Log: Tiny EPOC updates.
+ Branch: perl
+ ! epoc/config.sh
+ ____________________________________________________________________________
+ [ 10994] By: jhi on 2001/06/27 19:55:16
+ Log: The Test::More and Test::Simple tests required help
+ thanks to our schizophrenic test scheme.
+ Branch: perl
+ ! lib/Test/More/t/fail-like.t lib/Test/More/t/fail.t
+ ! lib/Test/More/t/plan_is_noplan.t lib/Test/More/t/skipall.t
+ ! lib/Test/Simple/t/exit.t lib/Test/Simple/t/extra.t
+ ! lib/Test/Simple/t/fail.t lib/Test/Simple/t/missing.t
+ ! lib/Test/Simple/t/no_plan.t lib/Test/Simple/t/plan_is_noplan.t
+ ____________________________________________________________________________
+ [ 10993] By: jhi on 2001/06/27 17:17:30
+ Log: Upgrade to Test::Simple 0.09.
+ Branch: perl
+ + lib/Test/Simple/Changes
+ ! MANIFEST lib/Test/Simple.pm lib/Test/Simple/t/exit.t
+ ! lib/Test/Simple/t/extra.t lib/Test/Simple/t/fail.t
+ ! lib/Test/Simple/t/missing.t lib/Test/Simple/t/no_plan.t
+ ! lib/Test/Simple/t/plan_is_noplan.t
+ ____________________________________________________________________________
+ [ 10992] By: jhi on 2001/06/27 17:11:28
+ Log: Upgrade to Test::More 0.07.
+ Branch: perl
+ + lib/Test/More/Changes
+ ! MANIFEST lib/Test/More.pm lib/Test/More/t/fail-like.t
+ ! lib/Test/More/t/fail.t lib/Test/More/t/plan_is_noplan.t
+ ! lib/Test/More/t/skipall.t
+ ____________________________________________________________________________
+ [ 10991] By: jhi on 2001/06/27 17:04:13
+ Log: Subject: Re: [PATCH] gcc-3.0 warnings on HP-UX
+ From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+ Date: Wed, 27 Jun 2001 18:40:04 +0200
+ Message-Id: <20010627182601.7261.H.M.BRAND@hccnet.nl>
+ Branch: perl
+ ! hints/hpux.sh
+ ____________________________________________________________________________
+ [ 10990] By: jhi on 2001/06/27 17:02:55
+ Log: Subject: [PATCH README.qnx hints/qnx.sh]
+ From: Norton Allen <allen@huarp.harvard.edu>
+ Date: Wed, 27 Jun 2001 13:46:03 -0400 (edt)
+ Message-Id: <200106271746.NAA02789@bottesini.harvard.edu>
+ Branch: perl
+ ! README.qnx hints/qnx.sh
+ ____________________________________________________________________________
+ [ 10989] By: jhi on 2001/06/27 14:33:53
+ Log: Subject: [PATCH] two little documentation nits
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Wed, 27 Jun 2001 20:07:50 +0530
+ Message-ID: <20010627200750.A15756@lustre.lustre.dyn.wiw.org>
+ Branch: perl
+ ! sv.c sv.h
+ ____________________________________________________________________________
+ [ 10988] By: jhi on 2001/06/27 13:33:32
+ Log: Subject: [PATCH File/Spec/Unix.pm ExtUtils/MM_Unix.pm] for QNX
+ From: Norton Allen <allen@huarp.harvard.edu>
+ Date: Wed, 27 Jun 2001 10:33:05 -0400 (edt)
+ Message-Id: <200106271433.KAA04947@bottesini.harvard.edu>
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm lib/File/Spec/Unix.pm
+ ____________________________________________________________________________
+ [ 10987] By: jhi on 2001/06/27 12:14:36
+ Log: Subject: [PATCH vms/test.com] Adding TODO tests (was: Re: a report on perl@10930 results on a couple of Alphas)
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Wed, 27 Jun 2001 02:34:58 -0400
+ Message-ID: <20010627023458.K23874@blackrider>
+ Branch: perl
+ ! vms/test.com
+ ____________________________________________________________________________
+ [ 10986] By: jhi on 2001/06/27 12:01:49
+ Log: Add perl_clone_host() for Netware.
+ Branch: perl
+ ! NetWare/nw5.c
+ ____________________________________________________________________________
+ [ 10985] By: jhi on 2001/06/27 11:56:53
+ Log: GCC 3.0 hints for HP-UX.
+ Branch: perl
+ ! hints/hpux.sh
+ ____________________________________________________________________________
+ [ 10984] By: jhi on 2001/06/27 11:55:06
+ Log: In some Linux distributions the libndbm is broken
+ (no null key support), therefore link with libgdbm
+ (if available), since it has a working ndbm emulation,
+ from Jonathan Stowe.
+ Branch: perl
+ + ext/NDBM_File/hints/linux.pl
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10983] By: jhi on 2001/06/27 11:48:56
+ Log: Subject: [PATCH perl@10930] find.t hack for VMS
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Tue, 26 Jun 2001 23:40:25 -0500
+ Message-Id: <a05101000b75f10cdc80f@[192.168.56.145]>
+ Branch: perl
+ ! lib/File/Find/find.t
+ ____________________________________________________________________________
+ [ 10982] By: jhi on 2001/06/27 11:47:30
+ Log: AUTHORS updates.
+ Branch: perl
+ ! AUTHORS
+ ____________________________________________________________________________
+ [ 10981] By: jhi on 2001/06/27 11:46:02
+ Log: Metaconfig unit change like #10980.
+ Branch: metaconfig
+ ! U/compline/d_stdstdio.U
+ ____________________________________________________________________________
+ [ 10980] By: jhi on 2001/06/27 11:45:29
+ Log: "lose the it's", from Abhijit Menon-Sen.
+ ("It's" not searched, pods not searched.)
+ Branch: perl
+ ! Porting/Glossary Porting/config_H README.qnx config_h.SH
+ ! emacs/cperl-mode.el ext/IPC/SysV/Semaphore.pm
+ ! ext/List/Util/lib/Scalar/Util.pm hints/next_3.sh hints/qnx.sh
+ ! lib/CPAN/Nox.pm lib/ExtUtils/Embed.pm lib/ExtUtils/MM_NW5.pm
+ ! lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MM_VMS.pm
+ ! lib/ExtUtils/MM_Win32.pm lib/Net/DummyInetd.pm win32/win32.c
+ ____________________________________________________________________________
+ [ 10979] By: jhi on 2001/06/27 11:36:40
+ Log: "lose the looses", from Abhijit Menon-Sen.
+ Branch: perl
+ ! ext/B/B/Assembler.pm gv.c
+ ____________________________________________________________________________
+ [ 10978] By: jhi on 2001/06/27 11:35:38
+ Log: Catch FP exceptions also in z/OS (aka OS/390), from Peter Prymmer.
+ Branch: perl
+ ! hints/os390.sh
+ ____________________________________________________________________________
+ [ 10977] By: jhi on 2001/06/27 11:33:28
+ Log: DEC C 5.3 on the VAX simply doesn't seem to like
+ compiling the MD5 extension, disable it there for now,
+ from Peter Prymmer.
+ Branch: perl
+ ! configure.com
+ ____________________________________________________________________________
+ [ 10976] By: jhi on 2001/06/26 21:35:40
+ Log: Subject: Re: [PATCH perlfaq3.pod] and a question about it.
+ From: Jonathan Stowe <gellyfish@gellyfish.com>
+ Date: Tue, 26 Jun 2001 20:53:40 +0100 (BST)
+ Message-ID: <Pine.LNX.4.33.0106262052060.10849-100000@orpheus.gellyfish.com>
+ Branch: perl
+ ! pod/perlfaq3.pod
+ ____________________________________________________________________________
+ [ 10975] By: jhi on 2001/06/26 21:32:41
+ Log: Subject: [PATCH 5.6.1] perlxs misprints
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Tue, 26 Jun 2001 17:20:00 -0400
+ Message-ID: <20010626172000.A26951@math.ohio-state.edu>
+ Branch: perl
+ ! pod/perlxs.pod
+ ____________________________________________________________________________
+ [ 10974] By: jhi on 2001/06/26 21:31:51
+ Log: Subject: [PATCH 5.6.1] xsubpp flags from the command line
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Tue, 26 Jun 2001 17:27:07 -0400
+ Message-ID: <20010626172707.A27097@math.ohio-state.edu>
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm
+ ____________________________________________________________________________
+ [ 10973] By: jhi on 2001/06/26 21:27:05
+ Log: Subject: [PATCH 5.6.1] OPTIMIZE=-g
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Tue, 26 Jun 2001 17:23:24 -0400
+ Message-ID: <20010626172324.A27003@math.ohio-state.edu>
+ Branch: perl
+ ! hints/os2.sh lib/ExtUtils/MM_Unix.pm os2/Makefile.SHs
+ ____________________________________________________________________________
+ [ 10972] By: jhi on 2001/06/26 20:27:19
+ Log: Better place for nop IN_LOCALE_NUMERIC, pointed out
+ by Olaf Flebbe.
+ Branch: perl
+ ! perl.h
+ ____________________________________________________________________________
+ [ 10971] By: jhi on 2001/06/26 19:59:41
+ Log: Detypo.
+ Branch: perl
+ ! lib/Memoize/t/tie_sdbm.t
+ ____________________________________________________________________________
+ [ 10970] By: jhi on 2001/06/26 19:10:19
+ Log: perl_clone_host() needs PERL_IMPLICIT_SYS.
+ Branch: perl
+ ! win32/perllib.c
+ ____________________________________________________________________________
+ [ 10969] By: jhi on 2001/06/26 17:21:31
+ Log: Subject: [patch] perl_clone+CvFILE
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Tue, 26 Jun 2001 09:01:16 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0106260900480.28420-100000@mako.covalent.net>
+ Branch: perl
+ ! sv.c
+ ____________________________________________________________________________
+ [ 10968] By: jhi on 2001/06/26 16:48:32
+ Log: Subject: Re: SDBM on VMS (was Re: a report on perl@10930 results on a couple of Alphas)
+ From: Mark-Jason Dominus <mjd@plover.com>
+ Date: Tue, 26 Jun 2001 12:33:01 -0400
+ Message-ID: <20010626163301.31298.qmail@plover.com>
+ Branch: perl
+ ! lib/Memoize/t/tie.t lib/Memoize/t/tie_sdbm.t
+ ____________________________________________________________________________
+ [ 10967] By: jhi on 2001/06/26 14:21:49
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10966] By: jhi on 2001/06/26 14:08:34
+ Log: Also catfile() needs now to explicitly exported.
+ Branch: perl
+ ! lib/Memoize/t/tie.t lib/Memoize/t/tie_sdbm.t
+ ____________________________________________________________________________
+ [ 10965] By: jhi on 2001/06/26 13:57:54
+ Log: Regen toc.
+ Branch: perl
+ ! pod/perltoc.pod
+ ____________________________________________________________________________
+ [ 10964] By: jhi on 2001/06/26 13:56:11
+ Log: Nonexistent pod command.
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 10963] By: jhi on 2001/06/26 13:50:53
+ Log: Be more portable in the quest for tmpdir.
+ Branch: perl
+ ! lib/Memoize/t/tie.t lib/Memoize/t/tie_sdbm.t
+ ____________________________________________________________________________
+ [ 10962] By: jhi on 2001/06/26 13:43:51
+ Log: Be more portable in finding out the home directory,
+ and use File::Spec to do the concat.
+ (Come to think of it, couldn't File::Spec provide
+ for a ->homedir method?)
+ Branch: perl
+ ! lib/Net/Config.pm
+ ____________________________________________________________________________
+ [ 10961] By: jhi on 2001/06/26 13:37:30
+ Log: Doc patch for #10959.
+ Branch: perl
+ ! pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 10960] By: jhi on 2001/06/26 13:33:07
+ Log: Subject: Re: [DOC PATCH bleadperl] Document $count = () = $string =~ /\d+/g
+ From: "Philip Newton" <pnewton@gmx.de>
+ Date: Tue, 26 Jun 2001 16:26:47 +0200
+ Message-ID: <3B38B7C7.32635.1E8DC14@localhost>
+ Branch: perl
+ ! pod/perldata.pod
+ ____________________________________________________________________________
+ [ 10959] By: jhi on 2001/06/26 13:31:57
+ Log: Subject: [PATH] shared -> unique;
+ From: "Artur Bergman" <artur@contiller.se>
+ Date: Tue, 26 Jun 2001 16:18:40 +0200
+ Message-ID: <002001c0fe4a$e623ba30$21000a0a@vogw2kdev>
+
+ Because "shared" isn't: it's read-only.
+ Branch: perl
+ ! toke.c xsutils.c
+ ____________________________________________________________________________
+ [ 10958] By: jhi on 2001/06/26 13:28:27
+ Log: Escape multiline croak messages.
+ Branch: perl
+ ! t/op/ver.t
+ ____________________________________________________________________________
+ [ 10957] By: jhi on 2001/06/26 13:18:34
+ Log: No more pragma/*.t for minitest.
+ Branch: perl
+ ! Makefile.SH
+ ____________________________________________________________________________
+ [ 10956] By: jhi on 2001/06/26 13:18:00
+ Log: AUTHORS updates.
+ Branch: perl
+ ! AUTHORS
+ ____________________________________________________________________________
+ [ 10955] By: jhi on 2001/06/26 13:17:05
+ Log: delta updates.
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 10954] By: jhi on 2001/06/26 12:36:07
+ Log: Subject: [PATCH] Adds perl_clone_host under IMPLICIT SYS
+ From: Artur Bergman <artur@contiller.se>
+ Date: Tue, 26 Jun 2001 15:32:53 +0200
+ Message-ID: <B75E5BA5.1A7C%artur@contiller.se>
+ Branch: perl
+ ! makedef.pl sv.c sv.h win32/perllib.c
+ ____________________________________________________________________________
+ [ 10953] By: jhi on 2001/06/26 12:33:55
+ Log: Subject: [PATCH ext/Time/HiRes/Makefile.PL perl@10929] Test Fails on SCO
+ From: Jonathan Stowe <gellyfish@gellyfish.com>
+ Date: Tue, 26 Jun 2001 10:29:57 +0100 (BST)
+ Message-ID: <Pine.LNX.4.33.0106261021540.18774-100000@orpheus.gellyfish.com>
+
+ SCO OpenServer 5.0.5 needs an explicit -lc for usleep().
+ Branch: perl
+ + ext/Time/HiRes/hints/sco.pl
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10952] By: jhi on 2001/06/26 11:57:44
+ Log: Subject: [PATCH 5.6.1] static build
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Tue, 26 Jun 2001 04:22:25 -0400
+ Message-ID: <20010626042225.A2604@math.ohio-state.edu>
+ Branch: perl
+ ! ext/List/Util/Makefile.PL lib/ExtUtils.t
+ ! lib/ExtUtils/MM_Unix.pm os2/Makefile.SHs
+ ____________________________________________________________________________
+ [ 10951] By: jhi on 2001/06/26 11:55:59
+ Log: DJGPP patches from Laszlo Molnar.
+ Branch: perl
+ ! djgpp/djgpp.c perl.c util.c
+ ____________________________________________________________________________
+ [ 10950] By: jhi on 2001/06/26 11:54:32
+ Log: Netware patches from Ananth Kesari.
+ Branch: perl
+ ! NetWare/Makefile NetWare/config_H.wc NetWare/nw5sck.c
+ ! NetWare/nw5sck.h NetWare/nwperlsys.c NetWare/nwperlsys.h
+ ! NetWare/nwtinfo.h
+ ____________________________________________________________________________
+ [ 10949] By: jhi on 2001/06/26 11:49:09
+ Log: Detypo.
+ Branch: perl
+ ! ext/Errno/Errno_pm.PL
+ ____________________________________________________________________________
+ [ 10948] By: jhi on 2001/06/26 03:44:29
+ Log: There seems to be two ways of spelling the $^O in *STEP.
+ Branch: perl
+ ! ext/Errno/Errno_pm.PL
+ ____________________________________________________________________________
+ [ 10947] By: jhi on 2001/06/26 03:01:01
+ Log: OpenSTEP has gcc 2.7.2.1 which recognizes but does not implement
+ the -dM flag, from Daniel Ashton <jdashton@AshtonFam.org>.
+ Branch: perl
+ ! ext/Errno/Errno_pm.PL
+ ____________________________________________________________________________
+ [ 10946] By: jhi on 2001/06/26 02:50:46
+ Log: Known bugs update.
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 10945] By: jhi on 2001/06/26 01:15:39
+ Log: The default installation of Cygwin has 500 as root's uid.
+ Branch: perl
+ ! lib/User/pwent.t
+ ____________________________________________________________________________
+ [ 10944] By: jhi on 2001/06/26 01:12:39
+ Log: Be even more relaxed (re-allow having only one entry).
+ Branch: perl
+ ! t/op/grent.t t/op/pwent.t
+ ____________________________________________________________________________
+ [ 10943] By: jhi on 2001/06/26 01:03:30
+ Log: Test failure updates.
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 10942] By: jhi on 2001/06/25 23:32:05
+ Log: MPE/iX test tweaks from Mark Bixby.
+ Branch: perl
+ ! ext/POSIX/POSIX.t ext/Storable/t/lock.t ext/Time/HiRes/HiRes.t
+ ! t/io/fs.t t/op/stat.t
+ ____________________________________________________________________________
+ [ 10941] By: jhi on 2001/06/25 22:18:31
+ Log: Microperl findings.
+ Branch: perl
+ ! perl.h pp_sys.c
+ ____________________________________________________________________________
+ [ 10940] By: jhi on 2001/06/25 21:59:29
+ Log: Touch uconfig.h.
+ Branch: perl
+ ! uconfig.h
+ ____________________________________________________________________________
+ [ 10939] By: jhi on 2001/06/25 21:32:52
+ Log: Subject: [PATCH] Proposed fix for Pod::Man
+ From: Rob Napier <rnapier@employees.org>
+ Date: Mon, 25 Jun 2001 15:49:24 -0400
+ Message-ID: <20010625154924.N27568@rnapier-u5.cisco.com>
+
+ Cater for Solaris nroff brokenness (shortchanges daisywheel
+ printers, but hey, we also no more support PDPs.)
+ Branch: perl
+ ! lib/Pod/Man.pm
+ ____________________________________________________________________________
+ [ 10938] By: jhi on 2001/06/25 21:14:41
+ Log: Typo in #10937.
+ Branch: perl
+ ! ext/POSIX/sigaction.t
+ ____________________________________________________________________________
+ [ 10937] By: jhi on 2001/06/25 19:42:02
+ Log: SIGCONT not trappable in VMS.
+ Branch: perl
+ ! ext/POSIX/sigaction.t
+ ____________________________________________________________________________
+ [ 10936] By: jhi on 2001/06/25 19:28:13
+ Log: Subject: [DRAFT] Encode-Tcl.t
+ From: SADAHIRO Tomoyuki <BQW10602@nifty.com>
+ Date: Tue, 26 Jun 2001 03:38:08 +0900
+ Message-Id: <20010626033550.BC35.BQW10602@nifty.com>
+ Branch: perl
+ + ext/Encode/Encode/Tcl.t
+ ! MANIFEST ext/Encode/Encode/Tcl.pm
+ ____________________________________________________________________________
+ [ 10935] By: jhi on 2001/06/25 18:40:03
+ Log: Because of #10932 retract also the perlfunc hunk of #10910.
+ Branch: perl
+ ! pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 10934] By: jhi on 2001/06/25 18:27:19
+ Log: Tweak the XSFUNCTION, from Doug MacEachern, as suggested
+ by Ilya Zakharevich in
+ http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-05/msg01582.html
+ Branch: perl
+ ! XSUB.h
+ ____________________________________________________________________________
+ [ 10933] By: jhi on 2001/06/25 18:25:26
+ Log: Typo in #10889.
+ Branch: perl
+ ! hints/uts.sh
+ ____________________________________________________________________________
+ [ 10932] By: jhi on 2001/06/25 18:23:30
+ Log: Subject: Re: [ID 20010621.007] readline() not quite as equal as <>
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Mon, 25 Jun 2001 23:45:45 +0530
+ Message-ID: <20010625234545.A5022@lustre.linux.in>
+ Branch: perl
+ ! lib/overload.t opcode.h opcode.pl t/op/flip.t
+ ____________________________________________________________________________
+ [ 10931] By: jhi on 2001/06/25 17:50:38
+ Log: Subject: [PATCH lib/Test.pm] Re: "Deprecated interface" ??
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Mon, 25 Jun 2001 14:35:51 -0400
+ Message-ID: <20010625143551.H13819@blackrider>
+ Branch: perl
+ ! lib/Test.pm
+ ____________________________________________________________________________
+ [ 10930] By: jhi on 2001/06/25 14:33:46
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10929] By: jhi on 2001/06/25 14:17:57
+ Log: Regen toc and modlib.
+ Branch: perl
+ ! pod/perlmodlib.pod pod/perltoc.pod
+ ____________________________________________________________________________
+ [ 10928] By: jhi on 2001/06/25 14:13:09
+ Log: Enclose the new symbols in START_EXTERN_C and END_EXTERN_C
+ for the benefit of C++ compilers, as suggested by Guruprasad.
+ Branch: perl
+ ! embed.pl proto.h
+ ____________________________________________________________________________
+ [ 10927] By: jhi on 2001/06/25 14:11:59
+ Log: Subject: [PATCH ] Re: [ID 20010625.003] perlfaq5 correction
+ From: Jonathan Stowe <gellyfish@gellyfish.com>
+ Date: Mon, 25 Jun 2001 14:39:43 +0100 (BST)
+ Message-ID: <Pine.LNX.4.33.0106251438080.14795-100000@orpheus.gellyfish.com>
+ Branch: perl
+ ! pod/perlfaq5.pod
+ ____________________________________________________________________________
+ [ 10926] By: jhi on 2001/06/25 14:04:07
+ Log: Missed from #10925.
+ Branch: perl
+ ! gv.c
+ ____________________________________________________________________________
+ [ 10925] By: jhi on 2001/06/25 14:00:06
+ Log: Subject: [PATCH] Re: CvFILE corruption under ithreads
+ From: Robin Houston <robin@kitsite.com>
+ Date: Sat, 19 May 2001 16:19:34 +0100
+ Message-ID: <20010519161934.A12751@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! cv.h gv.h op.c
+ ____________________________________________________________________________
+ [ 10924] By: jhi on 2001/06/25 13:58:18
+ Log: Netware README tweak.
+ Branch: perl
+ ! README.netware
+ ____________________________________________________________________________
+ [ 10923] By: jhi on 2001/06/25 13:57:13
+ Log: Subject: [PATCH] Re: overload.t fails
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Mon, 25 Jun 2001 14:52:20 +0530
+ Message-ID: <20010625145220.A24114@lustre.linux.in>
+ Branch: perl
+ ! lib/overload.t
+ ____________________________________________________________________________
+ [ 10922] By: jhi on 2001/06/25 13:56:20
+ Log: Subject: Re: [PATCH] Re: [ID 20010624.001] debugger T, and Carp::carp don't trace arg of
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Mon, 25 Jun 2001 11:43:23 +0100
+ Message-Id: <E15ETpz-0007AD-00@draco.cus.cam.ac.uk>
+ Branch: perl
+ ! lib/Carp.pm
+ ____________________________________________________________________________
+ [ 10921] By: jhi on 2001/06/25 13:50:02
+ Log: Subject: Re: [PATCH 5.6.1] OS2 syslog
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sun, 24 Jun 2001 05:17:05 -0400
+ Message-ID: <20010624051704.A27604@math.ohio-state.edu>
+ Branch: perl
+ ! os2/os2ish.h
+ ____________________________________________________________________________
+ [ 10920] By: jhi on 2001/06/25 13:49:13
+ Log: Subject: [PATCH 5.6.1] crypt() on OS/2
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 25 Jun 2001 05:52:27 -0400
+ Message-ID: <20010625055227.A24635@math.ohio-state.edu>
+ Branch: perl
+ ! hints/os2.sh
+ ____________________________________________________________________________
+ [ 10919] By: jhi on 2001/06/25 13:48:30
+ Log: Subject: Re: [PATCH 5.6.1] OS2 system() broken
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 25 Jun 2001 05:23:35 -0400
+ Message-ID: <20010625052334.A24320@math.ohio-state.edu>
+ Branch: perl
+ ! os2/os2.c
+ ____________________________________________________________________________
+ [ 10918] By: jhi on 2001/06/25 13:47:46
+ Log: Subject: Re: [PATCH 5.6.1] OS2::DLL
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 25 Jun 2001 05:04:32 -0400
+ Message-ID: <20010625050432.A24128@math.ohio-state.edu>
+ Branch: perl
+ ! os2/OS2/REXX/DLL/DLL.pm
+ ____________________________________________________________________________
+ [ 10917] By: jhi on 2001/06/25 13:44:14
+ Log: Subject: Re: [PATCH 5.6.1] $^E on OS/2
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 25 Jun 2001 05:02:36 -0400
+ Message-ID: <20010625050235.A24046@math.ohio-state.edu>
+ Branch: perl
+ ! mg.c os2/dl_os2.c os2/os2.c
+ ____________________________________________________________________________
+ [ 10916] By: jhi on 2001/06/25 13:41:20
+ Log: Subject: Re: [PATCH 5.6.1] misprints
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 25 Jun 2001 04:50:50 -0400
+ Message-ID: <20010625045049.A23965@math.ohio-state.edu>
+ Branch: perl
+ ! os2/os2.c pp_sys.c
+ ____________________________________________________________________________
+ [ 10915] By: jhi on 2001/06/25 13:39:59
+ Log: Add Test::More and Test::Simple to the delta.
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 10914] By: jhi on 2001/06/25 13:38:08
+ Log: Add Test::More, from Michael G Schwern.
+ Branch: perl
+ + lib/Test/More.pm lib/Test/More/t/More.t
+ + lib/Test/More/t/fail-like.t lib/Test/More/t/fail.t
+ + lib/Test/More/t/plan_is_noplan.t lib/Test/More/t/skipall.t
+ + t/lib/Test/More/Catch.pm
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10913] By: jhi on 2001/06/25 13:35:41
+ Log: Add Test::Simple from Michael G Schwern.
+ Branch: perl
+ + lib/Test/Simple.pm lib/Test/Simple/t/exit.t
+ + lib/Test/Simple/t/extra.t lib/Test/Simple/t/fail.t
+ + lib/Test/Simple/t/missing.t lib/Test/Simple/t/no_plan.t
+ + lib/Test/Simple/t/plan_is_noplan.t lib/Test/Simple/t/simple.t
+ + t/lib/Test/Simple/Catch.pm
+ + t/lib/Test/Simple/sample_tests/death.plx
+ + t/lib/Test/Simple/sample_tests/death_in_eval.plx
+ + t/lib/Test/Simple/sample_tests/extras.plx
+ + t/lib/Test/Simple/sample_tests/five_fail.plx
+ + t/lib/Test/Simple/sample_tests/last_minute_death.plx
+ + t/lib/Test/Simple/sample_tests/one_fail.plx
+ + t/lib/Test/Simple/sample_tests/require.plx
+ + t/lib/Test/Simple/sample_tests/success.plx
+ + t/lib/Test/Simple/sample_tests/too_few.plx
+ + t/lib/Test/Simple/sample_tests/two_fail.plx
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10912] By: jhi on 2001/06/25 13:31:57
+ Log: Subject: [PATCH perl@10907] RETURN requires dSP in pp_sys.c
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Sun, 24 Jun 2001 23:41:36 -0500
+ Message-Id: <a0510100db75c6d44e34c@[172.16.52.1]>
+ Branch: perl
+ ! pp_sys.c
+ ____________________________________________________________________________
+ [ 10911] By: jhi on 2001/06/25 13:05:00
+ Log: Upgrade to Attribute::Handlers 0.70.
+ Branch: perl
+ + lib/Attribute/Handlers/Changes lib/Attribute/Handlers/README
+ ! MANIFEST lib/Attribute/Handlers.pm
+ ____________________________________________________________________________
+ [ 10910] By: jhi on 2001/06/25 00:09:27
+ Log: Subject: Re: [ID 20010621.007] readline() not quite as equal as <>
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Sat, 23 Jun 2001 05:17:44 +0530
+ Message-ID: <20010623051744.A18583@lustre.linux.in>
+
+ (Can't think of a good place to put tests.)
+ Branch: perl
+ ! opcode.pl pod/perlfunc.pod t/op/flip.t toke.c
+ ____________________________________________________________________________
+ [ 10909] By: jhi on 2001/06/24 23:45:13
+ Log: Subject: [PATCH] t/op/pat.t typo fix
+ From: Richard Soderberg <rs@crystalflame.net>
+ Date: Sun, 24 Jun 2001 12:07:42 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0106241207320.17075-100000@oregonnet.com>
+ Branch: perl
+ ! t/op/pat.t
+ ____________________________________________________________________________
+ [ 10908] By: jhi on 2001/06/24 22:24:49
+ Log: Move the pack warnings to their own file, as pointed
+ out by Spider.
+ Branch: perl
+ + t/lib/warnings/pp_pack
+ ! MANIFEST t/lib/warnings/pp
+ ____________________________________________________________________________
+ [ 10907] By: jhi on 2001/06/24 19:55:15
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10906] By: jhi on 2001/06/24 19:50:40
+ Log: Partially fix a problem noticed by IRIX compiler:
+ the initialization of parse_start was bypassed by
+ several gotos. Now initialized to zero, which may
+ not be the best choice.
+ Branch: perl
+ ! regcomp.c
+ ____________________________________________________________________________
+ [ 10905] By: jhi on 2001/06/24 19:43:25
+ Log: Relax the group and password tests back to moaning only
+ if no matches at all are found. (Even with a small sample
+ I could find many sites where there are, umm, anomalies in
+ the said databases.)
+ Branch: perl
+ ! t/op/grent.t t/op/pwent.t
+ ____________________________________________________________________________
+ [ 10904] By: jhi on 2001/06/24 18:45:55
+ Log: Argh. How hard it can be to re-apply a patch manually? :-)
+ Branch: perl
+ ! pp_ctl.c
+ ____________________________________________________________________________
+ [ 10903] By: jhi on 2001/06/24 18:40:52
+ Log: De-cut-and-pasto in #10902.
+ Branch: perl
+ ! pp_ctl.c
+ ____________________________________________________________________________
+ [ 10902] By: jhi on 2001/06/24 18:35:18
+ Log: The #10771 didn't take?
+ Branch: perl
+ ! pp_ctl.c
+ ____________________________________________________________________________
+ [ 10901] By: jhi on 2001/06/24 18:29:50
+ Log: Undo the filetests part of #10900, under multiplicity
+ weird errors take place.
+ Branch: perl
+ ! pp_sys.c
+ ____________________________________________________________________________
+ [ 10900] By: jhi on 2001/06/24 18:20:36
+ Log: Misplaces dSPs and the like revealed by MPE/iX and Cygwin.
+ Branch: perl
+ ! ext/Cwd/Cwd.xs ext/Devel/Peek/Peek.xs pp_sys.c
+ ____________________________________________________________________________
+ [ 10899] By: jhi on 2001/06/24 17:00:34
+ Log: (Replaced by #10922)
+
+ Subject: Re: [PATCH] Re: [ID 20010624.001] debugger T, and Carp::carp don't trace arg of
+ From: Tony Bowden <tony@kasei.com>
+ Date: Sun, 24 Jun 2001 17:32:40 +0100
+ Message-ID: <20010624173240.A16293@blackstar.co.uk>
+
+ Document (well, mention) shortmess() and longmess()
+ to rob people of their fun of reinventing the weel.
+ Branch: perl
+ ! lib/Carp.pm
+ ____________________________________________________________________________
+ [ 10898] By: jhi on 2001/06/24 16:51:40
+ Log: Subject: Patch: pp_system() bounces out of Cygwin subsystem
+ From: Brian Jepson <bjepson@oreilly.com>
+ Date: Sun, 24 Jun 2001 12:13:21 -0400 (EDT)
+ Message-ID: <Pine.GSO.4.21.0106241044110.15051-200000@sol.east.ora.com>
+ Branch: perl
+ ! pp_sys.c
+ ____________________________________________________________________________
+ [ 10897] By: jhi on 2001/06/24 16:38:23
+ Log: Subject: [PATCH CPAN.pm] missing DATE_OF_02
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Date: Fri, 22 Jun 2001 19:25:56 +0100 (BST)
+ Message-Id: <200106221825.TAA16884@tempest.npl.co.uk>
+ Branch: perl
+ ! lib/CPAN.pm
+ ____________________________________________________________________________
+ [ 10896] By: jhi on 2001/06/24 16:36:32
+ Log: Memoize patch from mjd.
+ Branch: perl
+ ! lib/Memoize/t/tie_storable.t
+ ____________________________________________________________________________
+ [ 10895] By: jhi on 2001/06/24 16:33:59
+ Log: Spec the sv_pvprintify() a bit more.
+ Branch: perl
+ ! pod/perltodo.pod
+ ____________________________________________________________________________
+ [ 10894] By: jhi on 2001/06/24 14:43:36
+ Log: Upgrade to Memoize 0.65.
+ Branch: perl
+ + lib/Memoize/t/array_confusion.t
+ ! MANIFEST lib/Memoize.pm lib/Memoize/AnyDBM_File.pm
+ ! lib/Memoize/Expire.pm lib/Memoize/ExpireFile.pm
+ ! lib/Memoize/ExpireTest.pm lib/Memoize/NDBM_File.pm
+ ! lib/Memoize/README lib/Memoize/SDBM_File.pm
+ ! lib/Memoize/Saves.pm lib/Memoize/Storable.pm lib/Memoize/TODO
+ ! lib/Memoize/t/errors.t lib/Memoize/t/expire.t
+ ! lib/Memoize/t/expire_file.t lib/Memoize/t/expire_module_n.t
+ ! lib/Memoize/t/expire_module_t.t lib/Memoize/t/speed.t
+ ! lib/Memoize/t/tie.t lib/Memoize/t/tie_gdbm.t
+ ! lib/Memoize/t/tie_ndbm.t lib/Memoize/t/tie_sdbm.t
+ ! lib/Memoize/t/tie_storable.t
+ ____________________________________________________________________________
+ [ 10893] By: jhi on 2001/06/24 14:21:09
+ Log: Metaconfig unit change for #10892.
+ Branch: metaconfig
+ ! U/modified/Options.U
+ ____________________________________________________________________________
+ [ 10892] By: jhi on 2001/06/24 14:20:38
+ Log: Subject: Re: [PATCH 5.6.1] OS2 Configure
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sun, 24 Jun 2001 05:24:40 -0400
+ Message-ID: <20010624052440.A27698@math.ohio-state.edu>
+ Branch: perl
+ ! Configure hints/os2.sh
+ ____________________________________________________________________________
+ [ 10891] By: jhi on 2001/06/24 13:50:26
+ Log: Subject: [PATCH] Re: [ID 20010624.001] debugger T, and Carp::carp don't trace arg of
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Sun, 24 Jun 2001 15:28:39 +0100
+ Message-Id: <E15EAsR-0007Bi-00@draco.cus.cam.ac.uk>
+
+ Fix an ancient (5.002) bug.
+ Branch: perl
+ ! lib/Carp/Heavy.pm
+ ____________________________________________________________________________
+ [ 10890] By: jhi on 2001/06/24 13:44:43
+ Log: The #10881 was too vigorous in pp_system() in moving 'unused'
+ variables.
+ Branch: perl
+ ! pp_sys.c
+ ____________________________________________________________________________
+ [ 10889] By: jhi on 2001/06/24 13:24:00
+ Log: Make UTS as per #10888.
+ Branch: perl
+ ! hints/uts.sh
+ ____________________________________________________________________________
+ [ 10888] By: jhi on 2001/06/24 13:21:23
+ Log: Factor the PERL_SYS_INIT() code, from Hugo van der Sanden.
+ Branch: perl
+ ! hints/freebsd.sh hints/posix-bc.sh hints/sco.sh
+ ! mpeix/mpeixish.h perl.h unixish.h
+ ____________________________________________________________________________
+ [ 10887] By: jhi on 2001/06/24 13:15:45
+ Log: AUTHORS update.
+ Branch: perl
+ ! AUTHORS
+ ____________________________________________________________________________
+ [ 10886] By: jhi on 2001/06/24 13:14:31
+ Log: Subject: Encode::Tcl for multibyte doesnot work
+ From: SADAHIRO Tomoyuki <BQW10602@nifty.com>
+ Date: Sun, 24 Jun 2001 22:48:21 +0900
+ Message-Id: <20010624223252.6658.BQW10602@nifty.com>
+ Branch: perl
+ ! ext/Encode/Encode/Tcl.pm
+ ____________________________________________________________________________
+ [ 10885] By: jhi on 2001/06/24 13:12:46
+ Log: Subject: [PATCH] Remove tautology in error messages
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Sun, 24 Jun 2001 13:31:00 +0100
+ Message-Id: <E15E92a-0006em-00@draco.cus.cam.ac.uk>
+ Branch: perl
+ ! pp_sys.c
+ ____________________________________________________________________________
+ [ 10884] By: jhi on 2001/06/24 13:11:36
+ Log: Darwin needs -traditional-cpp for cppflags to build Errno.
+ Branch: perl
+ ! hints/darwin.sh
+ ____________________________________________________________________________
+ [ 10883] By: jhi on 2001/06/24 13:09:55
+ Log: Subject: Re: [PATCH 5.6.1] test suite
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sun, 24 Jun 2001 05:47:05 -0400
+ Message-ID: <20010624054705.A27890@math.ohio-state.edu>
+
+ Test suite fixes.
+ Branch: perl
+ ! ext/POSIX/sigaction.t lib/File/stat.t perl.c t/io/utf8.t
+ ____________________________________________________________________________
+ [ 10882] By: jhi on 2001/06/24 13:07:46
+ Log: Subject: Re: [PATCH 5.6.1] OS2 warnings
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sun, 24 Jun 2001 05:37:19 -0400
+ Message-ID: <20010624053719.A27866@math.ohio-state.edu>
+ Branch: perl
+ ! os2/dl_os2.c os2/os2.c os2/os2ish.h
+ ____________________________________________________________________________
+ [ 10881] By: jhi on 2001/06/24 13:05:24
+ Log: Subject: Re: [PATCH 5.6.1] pp_sys.c warnings
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sun, 24 Jun 2001 05:34:50 -0400
+ Message-ID: <20010624053450.A27856@math.ohio-state.edu>
+
+ Pacify compiler warnings.
+ Branch: perl
+ ! pp_sys.c
+ ____________________________________________________________________________
+ [ 10880] By: jhi on 2001/06/24 13:02:30
+ Log: Subject: Re: [PATCH 5.6.1] OS2 linking
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sun, 24 Jun 2001 05:21:18 -0400
+ Message-ID: <20010624052118.A27615@math.ohio-state.edu>
+
+ Enable compression of executables during link time.
+ Branch: perl
+ ! hints/os2.sh
+ ____________________________________________________________________________
+ [ 10879] By: jhi on 2001/06/24 13:00:47
+ Log: Subject: Re: [PATCH 5.6.1] OS2 linking
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sun, 24 Jun 2001 05:15:11 -0400
+ Message-ID: <20010624051511.A27544@math.ohio-state.edu>
+
+ Add ordinals to the export list for Perl DLL.
+ (Breaks intra-version DLL compatibility.)
+ Branch: perl
+ ! makedef.pl
+ ____________________________________________________________________________
+ [ 10878] By: jhi on 2001/06/24 02:12:04
+ Log: Allow (displaying and) re-editing the Subject in perlbug.
+ Also abstract the Subject quality control into a function.
+ Branch: perl
+ ! utils/perlbug.PL
+ ____________________________________________________________________________
+ [ 10877] By: jhi on 2001/06/24 01:40:53
+ Log: Display $ENV{CYGWIN} in perlbug if set (like #10875 for perl -V).
+ Branch: perl
+ ! utils/perlbug.PL
+ ____________________________________________________________________________
+ [ 10876] By: jhi on 2001/06/24 01:37:05
+ Log: Regen toc and modlib.
+ Branch: perl
+ ! pod/perlmodlib.pod pod/perltoc.pod
+ ____________________________________________________________________________
+ [ 10875] By: jhi on 2001/06/24 01:29:33
+ Log: In Cygwin display the $ENV{CYGWIN} under perl -V, as suggested
+ by John Peacock. (Can be 'ntea' which means emulate UNIX file
+ attribute semantics as much as possible, or 'ntsec' which uses
+ native NTFS semantics.) (See also #10877.)
+ Branch: perl
+ ! perl.c
+ ____________________________________________________________________________
+ [ 10874] By: jhi on 2001/06/23 23:57:28
+ Log: Hack to get rid of the UNEXPECTEDLY succeeded message for now.
+ Branch: perl
+ ! lib/Test/Harness.pm
+ ____________________________________________________________________________
+ [ 10873] By: jhi on 2001/06/23 23:36:56
+ Log: Just zap the -uPerlio.
+ Branch: perl
+ ! ext/B/Stash.t
+ ____________________________________________________________________________
+ [ 10872] By: jhi on 2001/06/23 21:29:10
+ Log: Do not test PerlIO if PerlIO not used.
+ Branch: perl
+ ! ext/PerlIO/PerlIO.t
+ ____________________________________________________________________________
+ [ 10871] By: jhi on 2001/06/23 21:12:49
+ Log: Regen perlapi.
+ Branch: perl
+ ! pod/perlapi.pod
+ ____________________________________________________________________________
+ [ 10870] By: jhi on 2001/06/23 21:03:31
+ Log: Subject: [PATCH] Re: [PATCH] nuke strtol (was Re: One fix for strtoul not setting errno)
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Sat, 23 Jun 2001 22:55:47 +0100
+ Message-ID: <20010623225547.Z98663@plum.flirble.org>
+ Branch: perl
+ ! numeric.c
+ ____________________________________________________________________________
+ [ 10869] By: jhi on 2001/06/23 17:13:21
+ Log: Subject: [PATCH: perl@10825] MacOS fixups for new lib/h2xs.t
+ From: Prymmer/Kahn <pvhp@best.com>
+ Date: Sat, 23 Jun 2001 11:08:52 -0700 (PDT)
+ Message-ID: <Pine.BSF.4.21.0106231105380.25634-100000@shell8.ba.best.com>
+ Branch: perl
+ ! lib/h2xs.t
+ ____________________________________________________________________________
+ [ 10868] By: jhi on 2001/06/23 16:04:38
+ Log: cygwin needs cygwin1.dll in PATH or cwd to run external programs.
+ cygwin does not taint cwd, just like win32.
+ Branch: perl
+ ! lib/File/Find/taint.t t/op/taint.t
+ ____________________________________________________________________________
+ [ 10867] By: jhi on 2001/06/23 15:39:15
+ Log: Retract #10865, the patch should be unnecessary.
+ (But seemingly helpful in Cygwin? Strange.)
+ Branch: perl
+ ! lib/Memoize/t/tie_ndbm.t
+ ____________________________________________________________________________
+ [ 10866] By: jhi on 2001/06/23 15:06:30
+ Log: Misplaced test file; plus Cygwin filesystem semantics.
+ Branch: perl
+ + ext/SDBM_File/sdbm.t
+ - ext/ODBM_File/sdbm.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10865] By: jhi on 2001/06/23 15:01:02
+ Log: (Retracted by #10867.)
+ Branch: perl
+ ! lib/Memoize/t/tie_ndbm.t
+ ____________________________________________________________________________
+ [ 10864] By: jhi on 2001/06/23 14:25:43
+ Log: Metaconfig unit change for #10863.
+ Branch: metaconfig/U/perl
+ ! Extensions.U
+ ____________________________________________________________________________
+ [ 10863] By: jhi on 2001/06/23 14:25:20
+ Log: In Cygwin do not build NDBM_File and ODBM_File unless
+ -lndbm and -ldbm are available.
+ Branch: perl
+ ! Configure config_h.SH
+ ____________________________________________________________________________
+ [ 10862] By: jhi on 2001/06/23 14:02:14
+ Log: More Cygwin filesystem semantics.
+ Branch: perl
+ ! t/io/fs.t t/op/stat.t
+ ____________________________________________________________________________
+ [ 10861] By: jhi on 2001/06/23 13:38:00
+ Log: More DOSish permission semantics for Cygwin.
+ Branch: perl
+ ! lib/AnyDBM_File.t
+ ____________________________________________________________________________
+ [ 10860] By: jhi on 2001/06/23 13:32:41
+ Log: Cygwin too has different permission semantics.
+ Branch: perl
+ ! ext/GDBM_File/gdbm.t
+ ____________________________________________________________________________
+ [ 10859] By: jhi on 2001/06/23 13:30:06
+ Log: The group (and assumedly passwd) databases can have
+ only one entry (this is the case in cygwin).
+ Branch: perl
+ ! t/op/grent.t t/op/pwent.t
+ ____________________________________________________________________________
+ [ 10858] By: jhi on 2001/06/23 13:16:26
+ Log: Also in Cygwin use Socket to figure out domainname
+ (if any) (avoids trying to call external 'domainname',
+ which doesn't at the moment exist in Cygwin)
+ Branch: perl
+ ! lib/Net/Domain.pm
+ ____________________________________________________________________________
+ [ 10857] By: jhi on 2001/06/23 12:48:32
+ Log: Remove also the lib$Foo.def, not just $Foo.def.
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm
+ ____________________________________________________________________________
+ [ 10856] By: jhi on 2001/06/23 12:21:53
+ Log: In UTS do signal(SIGFPE, SIG_IGN) in PERL_SYS_INIT().
+ Branch: perl
+ ! unixish.h
+ ____________________________________________________________________________
+ [ 10855] By: jhi on 2001/06/23 12:14:15
+ Log: Fix for ID 20010619.003, the [[:print:]] is not supposed
+ to match the whole isprint(), only the space character.
+ Branch: perl
+ ! handy.h pod/perlre.pod t/op/pat.t
+ ____________________________________________________________________________
+ [ 10854] By: nick on 2001/06/23 08:09:33
+ Log: Integrate mainline
+ Branch: perlio
+ !> Configure ext/IPC/SysV/Semaphore.pm hints/unicos.sh
+ !> lib/ExtUtils.t lib/File/Find/taint.t
+ !> lib/Math/BigInt/t/bigintpm.t lib/Net/netent.t
+ !> lib/Net/protoent.t lib/Net/servent.t mg.c t/op/mkdir.t
+ !> t/op/sprintf.t vms/descrip_mms.template vms/ext/Stdio/Stdio.xs
+ ____________________________________________________________________________
+ [ 10853] By: jhi on 2001/06/23 03:48:09
+ Log: Make also the bigintpm.t (like op/sprintf.t) be less demanding
+ with its floats in os390 and s390 (UTS).
+ Branch: perl
+ ! lib/Math/BigInt/t/bigintpm.t
+ ____________________________________________________________________________
+ [ 10852] By: jhi on 2001/06/23 03:38:53
+ Log: Add also UTS (s390) to the non-IEEE float platforms.
+ Branch: perl
+ ! t/op/sprintf.t
+ ____________________________________________________________________________
+ [ 10851] By: jhi on 2001/06/23 03:36:04
+ Log: Subject: RFC: what are applicable standards for exponent sizes?
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Tue, 19 Jun 2001 17:18:06 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10106191712070.361736-100000@aspara.forte.com>
+ Branch: perl
+ ! t/op/sprintf.t
+ ____________________________________________________________________________
+ [ 10850] By: jhi on 2001/06/23 03:29:04
+ Log: Subject: [PATCH: perl@10825] build (and test!) VMS::Stdio on VMS
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Fri, 22 Jun 2001 19:08:23 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10106221903270.24012-100000@aspara.forte.com>
+ Branch: perl
+ ! vms/descrip_mms.template vms/ext/Stdio/Stdio.xs
+ ____________________________________________________________________________
+ [ 10849] By: jhi on 2001/06/23 03:27:21
+ Log: Subject: [PATCH: perl@10825] correction to lib/ExtUtils.t patch
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Fri, 22 Jun 2001 17:56:01 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10106221754180.24012-100000@aspara.forte.com>
+ Branch: perl
+ ! lib/ExtUtils.t
+ ____________________________________________________________________________
+ [ 10848] By: jhi on 2001/06/22 21:51:31
+ Log: Retract #10845.
+ Branch: perl
+ ! lib/File/Find/taint.t
+ ____________________________________________________________________________
+ [ 10847] By: jhi on 2001/06/22 21:50:38
+ Log: Yet another error message.
+ Branch: perl
+ ! t/op/mkdir.t
+ ____________________________________________________________________________
+ [ 10846] By: jhi on 2001/06/22 21:48:39
+ Log: The croak message for nonexistent socket functions may vary.
+ Branch: perl
+ ! lib/Net/netent.t lib/Net/protoent.t lib/Net/servent.t
+ ____________________________________________________________________________
+ [ 10845] By: jhi on 2001/06/22 21:42:38
+ Log: (Retracted by #10848.)
+ Branch: perl
+ ! lib/File/Find/taint.t
+ ____________________________________________________________________________
+ [ 10844] By: jhi on 2001/06/22 21:32:58
+ Log: Integrate perlio.
+ Branch: perl
+ !> lib/File/Find/taint.t t/op/write.t
+ ____________________________________________________________________________
+ [ 10843] By: nick on 2001/06/22 21:24:51
+ Log: Back out debug in taint.t
+ Branch: perlio
+ ! lib/File/Find/taint.t
+ ____________________________________________________________________________
+ [ 10842] By: jhi on 2001/06/22 21:20:02
+ Log: setitimer() does not exist in Unicos, despite of what
+ Configure thinks, from Mark P. Lutz.
+ Branch: perl
+ ! hints/unicos.sh
+ ____________________________________________________________________________
+ [ 10841] By: nick on 2001/06/22 21:19:36
+ Log: Skip cwd test on Win32 ???
+ Branch: perlio
+ ! lib/File/Find/taint.t
+ ____________________________________________________________________________
+ [ 10840] By: jhi on 2001/06/22 21:17:34
+ Log: Casting this way seems to keep both 64-bitint x86 FreeBSD
+ and Tru64 gcc -Wall happy.
+ Branch: perl
+ ! mg.c
+ ____________________________________________________________________________
+ [ 10839] By: jhi on 2001/06/22 21:15:32
+ Log: The packs must be done in native shorts, fix from Mark P. Lutz.
+ Branch: perl
+ ! ext/IPC/SysV/Semaphore.pm
+ ____________________________________________________________________________
+ [ 10838] By: jhi on 2001/06/22 21:12:02
+ Log: Metaconfig unit change for #10837.
+ Branch: metaconfig/U/perl
+ ! Cross.U
+ ____________________________________________________________________________
+ [ 10837] By: jhi on 2001/06/22 21:09:42
+ Log: Cleanup of the cross-compilation unit.
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10836] By: nick on 2001/06/22 20:45:12
+ Log: Skip |- based op/write.t on Win32 as well as VMS
+ Branch: perlio
+ ! t/op/write.t
+ ____________________________________________________________________________
+ [ 10835] By: jhi on 2001/06/22 20:44:20
+ Log: Integrate perlio.
+ Branch: perl
+ !> util.c
+ ____________________________________________________________________________
+ [ 10834] By: nick on 2001/06/22 20:41:54
+ Log: Integrate mainline
+ Branch: perlio
+ !> Configure Porting/Glossary Porting/config.sh Porting/config_H
+ !> config_h.SH pp_sys.c uconfig.h util.c vos/config.alpha.h
+ !> vos/config.ga.h
+ ____________________________________________________________________________
+ [ 10833] By: nick on 2001/06/22 20:22:58
+ Log: Patcho fix.
+ Branch: perlio
+ ! util.c
+ ____________________________________________________________________________
+ [ 10832] By: jhi on 2001/06/22 20:13:02
+ Log: Metaconfig unit changes for #10831.
+ Branch: metaconfig
+ ! U/compline/d_safebcpy.U U/compline/d_safemcpy.U
+ ____________________________________________________________________________
+ [ 10831] By: jhi on 2001/06/22 20:12:29
+ Log: Subject: [PATCH 5.7.x] Further tiny bcopy cleanup
+ From: Andy Dougherty <doughera@lafayette.edu>
+ Date: Fri, 22 Jun 2001 14:29:51 -0400 (EDT)
+ Message-ID: <Pine.SOL.4.10.10106221417030.28044-100000@maxwell.phys.lafayette.edu>
+ Branch: perl
+ ! Configure Porting/Glossary Porting/config.sh Porting/config_H
+ ! config_h.SH uconfig.h vos/config.alpha.h vos/config.ga.h
+ ____________________________________________________________________________
+ [ 10830] By: jhi on 2001/06/22 19:50:15
+ Log: MPE/iX prototype nits from Mark Bixby.
+ Branch: perl
+ ! pp_sys.c
+ ____________________________________________________________________________
+ [ 10829] By: jhi on 2001/06/22 16:25:16
+ Log: Detypo.
+ Branch: perl
+ ! util.c
+ ____________________________________________________________________________
+ [ 10828] By: nick on 2001/06/22 15:33:37
+ Log: Integrate mainline (in near desperate attempt to get Win32 to build...)
+ Branch: perlio
+ +> lib/h2xs.t
+ !> AUTHORS Changes MANIFEST Makefile.SH NetWare/t/NWScripts.pl
+ !> ext/B/Deparse.t ext/POSIX/POSIX.xs lib/ExtUtils.t
+ !> lib/ExtUtils/Constant.pm lib/I18N/LangTags.pm
+ !> lib/I18N/LangTags/ChangeLog lib/I18N/LangTags/test.pl
+ !> lib/Locale/Maketext.pm lib/Locale/Maketext.pod
+ !> lib/Locale/Maketext/ChangeLog lib/Locale/Maketext/test.pl
+ !> lib/Math/BigFloat.pm lib/Math/BigInt.pm patchlevel.h
+ !> t/op/write.t t/pod/plainer.t utils/h2xs.PL vms/vms.c
+ !> vms/vmsish.h
+ ____________________________________________________________________________
+ [ 10827] By: jhi on 2001/06/22 14:15:26
+ Log: Subject: [PATCH perl@10800] sigaction workaround for VMS
+ Date: Fri, 22 Jun 2001 10:08:35 -0500
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Message-Id: <a05101001b75908704194@[192.168.56.145]>
+ Branch: perl
+ ! vms/vms.c vms/vmsish.h
+ ____________________________________________________________________________
+ [ 10826] By: jhi on 2001/06/22 13:35:37
+ Log: NetWare scripts tweak from Ananth Kesari.
+ Branch: perl
+ ! NetWare/t/NWScripts.pl
+ ____________________________________________________________________________
+ [ 10825] By: jhi on 2001/06/22 13:00:55
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10824] By: jhi on 2001/06/22 12:46:56
+ Log: Add .i and .s targets.
+ Branch: perl
+ ! Makefile.SH
+ ____________________________________________________________________________
+ [ 10823] By: jhi on 2001/06/22 12:25:20
+ Log: Upgrade to Locale::Maketext 1.03.
+ Branch: perl
+ ! lib/Locale/Maketext.pm lib/Locale/Maketext.pod
+ ! lib/Locale/Maketext/ChangeLog lib/Locale/Maketext/test.pl
+ ____________________________________________________________________________
+ [ 10822] By: jhi on 2001/06/22 12:23:57
+ Log: Upgrade to I18N::LangTags 0.26.
+ Branch: perl
+ ! lib/I18N/LangTags.pm lib/I18N/LangTags/ChangeLog
+ ! lib/I18N/LangTags/test.pl
+ ____________________________________________________________________________
+ [ 10821] By: jhi on 2001/06/22 12:16:41
+ Log: The #10792 didn't take, and s/sighni/signi/, as noticed by
+ Philip Newton.
+ Branch: perl
+ ! lib/ExtUtils/Constant.pm lib/Locale/Maketext.pod
+ ! lib/Math/BigFloat.pm lib/Math/BigInt.pm
+ ____________________________________________________________________________
+ [ 10820] By: jhi on 2001/06/22 12:13:37
+ Log: Subject: [PATCH: perl@10800] trigraphs and tests for h2xs
+ From: Prymmer/Kahn <pvhp@best.com>
+ Date: Fri, 22 Jun 2001 00:03:24 -0700 (PDT)
+ Message-ID: <Pine.BSF.4.21.0106212354510.6026-100000@shell8.ba.best.com>
+ Branch: perl
+ + lib/h2xs.t
+ ! MANIFEST utils/h2xs.PL
+ ____________________________________________________________________________
+ [ 10819] By: jhi on 2001/06/22 12:11:56
+ Log: Subject: [PATCH: perl@10800] nmake specific cleanliness for lib/ExtUtils.t
+ From: Prymmer/Kahn <pvhp@best.com>
+ Date: Thu, 21 Jun 2001 23:53:27 -0700 (PDT)
+ Message-ID: <Pine.BSF.4.21.0106212346540.6026-100000@shell8.ba.best.com>
+ Branch: perl
+ ! lib/ExtUtils.t
+ ____________________________________________________________________________
+ [ 10818] By: jhi on 2001/06/22 12:11:08
+ Log: Subject: [PATCH: perl@10800] clean up after t/pod/plainer.t on Win32
+ From: Prymmer/Kahn <pvhp@best.com>
+ Date: Thu, 21 Jun 2001 23:45:15 -0700 (PDT)
+ Message-ID: <Pine.BSF.4.21.0106212341510.6026-100000@shell8.ba.best.com>
+ Branch: perl
+ ! t/pod/plainer.t
+ ____________________________________________________________________________
+ [ 10817] By: jhi on 2001/06/22 12:10:05
+ Log: AUTHORS update.
+ Branch: perl
+ ! AUTHORS
+ ____________________________________________________________________________
+ [ 10816] By: jhi on 2001/06/22 12:08:24
+ Log: Subject: should POSIX.xs use XSRETURN_UNDEF in sigaction?
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Thu, 21 Jun 2001 18:20:38 -0500
+ Message-Id: <5.1.0.14.0.20010621180227.02a8e930@exchi01>
+ Branch: perl
+ ! ext/POSIX/POSIX.xs
+ ____________________________________________________________________________
+ [ 10815] By: jhi on 2001/06/22 12:07:19
+ Log: Subject: [PATCH perl@10765] fix Deparse.t and write.t for VMS
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Thu, 21 Jun 2001 09:58:52 -0500
+ Message-Id: <5.1.0.14.0.20010620172532.033cdb88@exchi01>
+ Branch: perl
+ ! ext/B/Deparse.t t/op/write.t
+ ____________________________________________________________________________
+ [ 10814] By: nick on 2001/06/22 08:13:09
+ Log: Integrate mainline.
+ Branch: perlio
+ !> (integrate 46 files)
+ ____________________________________________________________________________
+ [ 10813] By: jhi on 2001/06/22 02:48:58
+ Log: Change the prefixes only if $prefix is unset,
+ as originally patched by Marcel Grunauer.
+ Branch: perl
+ ! hints/darwin.sh hints/rhapsody.sh
+ ____________________________________________________________________________
+ [ 10812] By: jhi on 2001/06/22 02:44:41
+ Log: Subject: Re: Patch for hints/darwin.sh
+ From: Wilfredo Sanchez <wsanchez@MIT.EDU>
+ Date: Thu, 21 Jun 2001 11:23:46 -0700
+ Message-Id: <200106211823.OAA01089@melbourne-city-street.mit.edu>
+ Branch: perl
+ ! hints/darwin.sh hints/rhapsody.sh
+ ____________________________________________________________________________
+ [ 10811] By: jhi on 2001/06/22 02:34:27
+ Log: Add .PHONY targets for non-file targets,
+ from Wilfredo S�nchez. Should help saying
+ "make install" on case-insensitive filesystems.
+ Branch: perl
+ ! Makefile.SH
+ ____________________________________________________________________________
+ [ 10810] By: jhi on 2001/06/22 02:01:23
+ Log: Subject: Re: Automated smoke report for patch 10764 (truncated)
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Thu, 21 Jun 2001 19:32:05 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0106211925020.17261-100000@mako.covalent.net>
+
+ plus reword the getcwd() comment, plus use getcwd() buffer
+ size minus one.
+ Branch: perl
+ ! util.c
+ ____________________________________________________________________________
+ [ 10809] By: jhi on 2001/06/22 01:16:58
+ Log: More gprofing from Doug MacEachern.
+ Branch: perl
+ ! Makefile.SH
+ ____________________________________________________________________________
+ [ 10808] By: jhi on 2001/06/22 01:15:11
+ Log: Metaconfig unit change for #10807.
+ Branch: metaconfig/U/perl
+ ! d_sfio.U
+ ____________________________________________________________________________
+ [ 10807] By: jhi on 2001/06/22 01:14:43
+ Log: Tell that you are removing the unneeded -lsfio.
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10806] By: jhi on 2001/06/22 01:03:14
+ Log: More MPE/iX tweaks from Mark Bixby.
+ Branch: perl
+ ! perl.c t/op/magic.t
+ ____________________________________________________________________________
+ [ 10805] By: jhi on 2001/06/21 22:41:11
+ Log: The fchdir() proto is supposed to live in <unistd.h>.
+ Branch: perl
+ ! ext/Cwd/Cwd.xs
+ ____________________________________________________________________________
+ [ 10804] By: jhi on 2001/06/21 22:24:42
+ Log: This town is too small for the Cwd extension and me,
+ it would seem...
+ Branch: perl
+ ! ext/Cwd/Cwd.xs
+ ____________________________________________________________________________
+ [ 10803] By: jhi on 2001/06/21 21:54:00
+ Log: Metaconfig unit change for #10802.
+ Branch: metaconfig/U/perl
+ ! d_modfl.U
+ ____________________________________________________________________________
+ [ 10802] By: jhi on 2001/06/21 21:53:37
+ Log: More d'ohs.
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10801] By: jhi on 2001/06/21 21:38:38
+ Log: Off-by-one. I'm so classic.
+ Branch: perl
+ ! util.c
+ ____________________________________________________________________________
+ [ 10800] By: jhi on 2001/06/21 20:10:19
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10799] By: jhi on 2001/06/21 20:03:54
+ Log: Subject: Documentation patch for Net::FTP
+ From: Marcel Grunauer <marcel@codewerk.com>
+ Date: Wed, 20 Jun 2001 23:03:26 +0200
+ Message-Id: <20010620210309.DCMT6087.viemta06@localhost>
+ Branch: perl
+ ! lib/Net/FTP.pm
+ ____________________________________________________________________________
+ [ 10798] By: jhi on 2001/06/21 20:01:14
+ Log: Retract the #10417 mg.c and embed.pl parts because of
+ strange SEGVs in 64bit x86 FreeBSD observed by
+ Nicholas Clark.
+ Branch: perl
+ ! embed.pl mg.c perlapi.c pod/perlintern.pod proto.h
+ ____________________________________________________________________________
+ [ 10797] By: jhi on 2001/06/21 19:40:34
+ Log: Add fchdir() probe (in non-UNIX systems assume it doesn't exist).
+ Branch: perl
+ ! Configure NetWare/config.wc NetWare/config_H.wc
+ ! Porting/Glossary Porting/config.sh Porting/config_H
+ ! config_h.SH configure.com epoc/config.sh uconfig.h uconfig.sh
+ ! vos/config.alpha.def vos/config.alpha.h vos/config.ga.def
+ ! vos/config.ga.h win32/config.bc win32/config.gc
+ ! win32/config.vc win32/config_H.bc win32/config_H.gc
+ ! win32/config_H.vc
+ ____________________________________________________________________________
+ [ 10796] By: jhi on 2001/06/21 19:08:28
+ Log: Cwd tweak from Doug MacEachern.
+ Branch: perl
+ ! ext/Cwd/Cwd.xs
+ ____________________________________________________________________________
+ [ 10795] By: jhi on 2001/06/21 19:03:48
+ Log: Protect the fchdir() and lstat() with ifdefs.
+ fchdir() needs a Configure probe.
+ Branch: perl
+ ! ext/Cwd/Cwd.xs
+ ____________________________________________________________________________
+ [ 10794] By: nick on 2001/06/21 17:11:35
+ Log: Integrate mainline
+ Branch: perlio
+ +> ext/File/Glob/t/basic.t ext/File/Glob/t/case.t
+ +> ext/File/Glob/t/global.t ext/File/Glob/t/taint.t
+ +> lib/Attribute/Handlers/test.pl lib/File/Temp/t/mktemp.t
+ +> lib/File/Temp/t/posix.t lib/File/Temp/t/security.t
+ +> lib/File/Temp/t/tempfile.t lib/Getopt/Long/t/basic.t
+ +> lib/Getopt/Long/t/compat.t lib/Getopt/Long/t/linkage.t
+ +> lib/Getopt/Long/t/oo.t lib/Text/TabsWrap/t/fill.t
+ +> lib/Text/TabsWrap/t/tabs.t lib/Text/TabsWrap/t/wrap.t
+ - lib/Attribute/Handlers.t lib/File/Glob/basic.t
+ - lib/File/Glob/case.t lib/File/Glob/global.t
+ - lib/File/Glob/taint.t lib/File/Temp/mktemp.t
+ - lib/File/Temp/posix.t lib/File/Temp/security.t
+ - lib/File/Temp/tempfile.t lib/Getopt/Long/basic.t
+ - lib/Getopt/Long/compat.t lib/Getopt/Long/linkage.t
+ - lib/Getopt/Long/oo.t lib/Text/Tabs.t lib/Text/Wrap/fill.t
+ - lib/Text/Wrap/wrap.t
+ !> (integrate 41 files)
+ ____________________________________________________________________________
+ [ 10793] By: jhi on 2001/06/21 17:01:26
+ Log: Subject: [PATCH perl@10765] fix Cwd.xs for VMS
+ From: "Craig A. Berry" <craig.berry@SignalTreeSolutions.com>
+ Date: Thu, 21 Jun 2001 13:04:54 -0500
+ Message-Id: <5.1.0.14.0.20010621124127.029fe120@exchi01>
+ Branch: perl
+ ! ext/Cwd/Cwd.xs
+ ____________________________________________________________________________
+ [ 10792] By: jhi on 2001/06/21 16:13:57
+ Log: Subject: [PATCH pod] overlong =item
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Date: Thu, 21 Jun 2001 18:08:04 +0100 (BST)
+ Message-Id: <200106211708.SAA08097@tempest.npl.co.uk>
+ Branch: perl
+ ! lib/ExtUtils/Constant.pm lib/Locale/Maketext.pod
+ ! lib/Math/BigFloat.pm lib/Math/BigInt.pm
+ ____________________________________________________________________________
+ [ 10791] By: jhi on 2001/06/21 16:10:51
+ Log: Subject: [PATCH perlio.c] format
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Date: Thu, 21 Jun 2001 18:05:02 +0100 (BST)
+ Message-Id: <200106211705.SAA08067@tempest.npl.co.uk>
+ Branch: perl
+ ! perlio.c
+ ____________________________________________________________________________
+ [ 10790] By: jhi on 2001/06/21 15:52:04
+ Log: Subject: Re: [PATCH 5.7.1] sv.c documentation
+ From: Radu Greab <radu@netsoft.ro>
+ Date: Thu, 21 Jun 2001 19:06:02 +0300
+ Message-ID: <15154.7018.376419.295092@ix.netsoft.ro>
+ Branch: perl
+ ! pod/perlapi.pod sv.c
+ ____________________________________________________________________________
+ [ 10789] By: jhi on 2001/06/21 14:48:25
+ Log: The metaconfig unit changes for #10788.
+ Branch: metaconfig/U/perl
+ ! Cross.U fflushall.U
+ ____________________________________________________________________________
+ [ 10788] By: jhi on 2001/06/21 14:47:48
+ Log: Cross-configuration changes: make $from to rm the files
+ before copying them over (this means that he rm can be
+ removed from the fflushall test), create $targetmkdir
+ (not documented in install since it is supposed to internal
+ use only), make $run to copy over the executable only if
+ a stamp file .xok doesn't already exist (to avoid unnecessary
+ copying of the executable)
+ Branch: perl
+ ! Configure Makefile.SH
+ ____________________________________________________________________________
+ [ 10787] By: nick on 2001/06/21 14:16:18
+ Log: Integrate mainline
+ Branch: perlio
+ +> lib/I18N/LangTags/ChangeLog lib/I18N/LangTags/List.pm
+ +> lib/I18N/LangTags/README lib/Locale/Maketext/ChangeLog
+ +> lib/Locale/Maketext/README lib/Locale/Maketext/test.pl
+ - lib/I18N/LangTags/List.pod lib/Locale/Maketext.t
+ !> (integrate 34 files)
+ ____________________________________________________________________________
+ [ 10786] By: jhi on 2001/06/21 13:59:32
+ Log: Re-add the files as text.
+ Branch: perl
+ + t/lib/locale/latin1 t/lib/locale/utf8 t/lib/warnings/utf8
+ ____________________________________________________________________________
+ [ 10785] By: jhi on 2001/06/21 13:57:55
+ Log: Delete the binary files.
+ Branch: perl
+ - t/lib/locale/latin1 t/lib/locale/utf8 t/lib/warnings/utf8
+ ____________________________________________________________________________
+ [ 10784] By: jhi on 2001/06/21 13:49:47
+ Log: Subject: [PATCH 5.7.x] Unnecessary pod2man calls in new extensions
+ From: Andy Dougherty <doughera@lafayette.edu>
+ Date: Thu, 21 Jun 2001 10:44:05 -0400 (EDT)
+ Message-ID: <Pine.SOL.4.10.10106211040180.26439-100000@maxwell.phys.lafayette.edu>
+ Branch: perl
+ ! ext/Digest/MD5/Makefile.PL ext/List/Util/Makefile.PL
+ ! ext/MIME/Base64/Makefile.PL ext/PerlIO/Scalar/Makefile.PL
+ ! ext/PerlIO/Via/Makefile.PL ext/Time/HiRes/Makefile.PL
+ ! ext/Time/Piece/Makefile.PL ext/XS/Typemap/Makefile.PL
+ ____________________________________________________________________________
+ [ 10783] By: jhi on 2001/06/21 13:46:50
+ Log: Subject: [ID 20010621.002] UnixWare 7.1.1 and Perl-5.6.1 problems
+ From: 0000-Admin <root@egg.karlov.mff.cuni.cz>(0000)
+ Date: Wed, 20 Jun 2001 14:11:49 +0200 (MET DST)
+ Message-Id: <200106201211.f5KCBnm24320@egg.karlov.mff.cuni.cz>
+
+ Setting umask to something friendlier.
+ Branch: perl
+ ! installman installperl
+ ____________________________________________________________________________
+ [ 10782] By: jhi on 2001/06/21 13:42:17
+ Log: Shuffle around tests to (ext|lib)/.../t/ subdirectories.
+ Resort MANIFEST with sort -f, looks much better.
+ Branch: perl
+ + ext/File/Glob/t/basic.t ext/File/Glob/t/case.t
+ + ext/File/Glob/t/global.t ext/File/Glob/t/taint.t
+ + lib/Attribute/Handlers/test.pl lib/File/Temp/t/mktemp.t
+ + lib/File/Temp/t/posix.t lib/File/Temp/t/security.t
+ + lib/File/Temp/t/tempfile.t lib/Getopt/Long/t/basic.t
+ + lib/Getopt/Long/t/compat.t lib/Getopt/Long/t/linkage.t
+ + lib/Getopt/Long/t/oo.t lib/Text/TabsWrap/t/fill.t
+ + lib/Text/TabsWrap/t/tabs.t lib/Text/TabsWrap/t/wrap.t
+ - lib/Attribute/Handlers.t lib/File/Glob/basic.t
+ - lib/File/Glob/case.t lib/File/Glob/global.t
+ - lib/File/Glob/taint.t lib/File/Temp/mktemp.t
+ - lib/File/Temp/posix.t lib/File/Temp/security.t
+ - lib/File/Temp/tempfile.t lib/Getopt/Long/basic.t
+ - lib/Getopt/Long/compat.t lib/Getopt/Long/linkage.t
+ - lib/Getopt/Long/oo.t lib/Text/Tabs.t lib/Text/Wrap/fill.t
+ - lib/Text/Wrap/wrap.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10781] By: jhi on 2001/06/21 13:16:04
+ Log: Upgrade to I18N::LangTags 0.25.
+ Branch: perl
+ ! lib/I18N/LangTags.pm lib/I18N/LangTags/ChangeLog
+ ! lib/I18N/LangTags/List.pm
+ ____________________________________________________________________________
+ [ 10780] By: jhi on 2001/06/21 13:12:54
+ Log: Subject: [PATCH] Step 2: Use the new PM_GETRE/SETRE macros everywhere.
+ From: Richard Soderberg <rs@crystalflame.net>
+ Date: Thu, 21 Jun 2001 07:01:22 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0106210657400.1693-100000@oregonnet.com>
+ Branch: perl
+ ! dump.c ext/B/B.xs ext/B/B/C.pm ext/ByteLoader/bytecode.h mg.c
+ ! op.c pp.c pp_ctl.c pp_hot.c regexec.c
+ ____________________________________________________________________________
+ [ 10779] By: jhi on 2001/06/21 12:59:57
+ Log: Test obsoleted by change #10777.
+ Branch: perl
+ ! t/op/sub_lval.t
+ ____________________________________________________________________________
+ [ 10778] By: jhi on 2001/06/21 12:52:37
+ Log: Case of confused test numbering.
+ Branch: perl
+ ! t/op/pat.t
+ ____________________________________________________________________________
+ [ 10777] By: jhi on 2001/06/21 12:30:57
+ Log: Subject: Re: Opinion on undef lvalue
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Sun, 17 Jun 2001 13:04:46 +0530
+ Message-ID: <20010617130446.B27925@lustre.linux.in>
+
+ Allow lvalue subs to return undef in array context.
+ Branch: perl
+ ! pp_hot.c
+ ____________________________________________________________________________
+ [ 10776] By: jhi on 2001/06/21 12:27:48
+ Log: Just a guess that using the same hack for cygwin as
+ for win32 might help.
+ Branch: perl
+ ! lib/File/Find/find.t
+ ____________________________________________________________________________
+ [ 10775] By: jhi on 2001/06/21 12:25:58
+ Log: NetWare tweaks from Guruprasad.
+ Branch: perl
+ ! NetWare/Makefile NetWare/Nwmain.c NetWare/config.wc
+ ! NetWare/config_H.wc NetWare/nw5sck.c NetWare/nw5sck.h
+ ! NetWare/nwperlsys.c NetWare/t/NWModify.pl
+ ! NetWare/t/NWScripts.pl NetWare/t/Readme.txt
+ ____________________________________________________________________________
+ [ 10774] By: jhi on 2001/06/21 12:21:17
+ Log: Subject: Re: perl@10722: Bogus warnings on REs
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Thu, 21 Jun 2001 09:51:17 +0100
+ Message-Id: <200106210851.JAA01942@crypt.compulink.co.uk>
+
+ Unroll to avoid a UTS compiler bug.
+ Branch: perl
+ ! regcomp.c
+ ____________________________________________________________________________
+ [ 10773] By: jhi on 2001/06/21 12:13:13
+ Log: Subject: Re: [PATCH] Make /o work under i?threads
+ From: Artur Bergman <artur@contiller.se>
+ Date: Thu, 21 Jun 2001 14:38:03 +0200
+ Message-ID: <B757B74A.184D%artur@contiller.se>
+ Branch: perl
+ ! t/op/pat.t
+ ____________________________________________________________________________
+ [ 10772] By: jhi on 2001/06/21 12:12:23
+ Log: Subject: Re: [PATCH] Step 1 of moving regexps to the pad
+ From: Artur Bergman <artur@contiller.se>
+ Date: Thu, 21 Jun 2001 14:27:33 +0200
+ Message-ID: <B757B4D4.1849%artur@contiller.se>
+
+ Plus extra parentheses.
+ Branch: perl
+ ! op.h
+ ____________________________________________________________________________
+ [ 10771] By: jhi on 2001/06/21 12:10:29
+ Log: Subject: [PATCH] Make /o work under i?threads
+ From: Richard Soderberg <rs@crystalflame.net>
+ Date: Thu, 21 Jun 2001 05:21:43 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0106210518210.2479-100000@oregonnet.com>
+ Branch: perl
+ ! pp_ctl.c
+ ____________________________________________________________________________
+ [ 10770] By: jhi on 2001/06/21 12:09:28
+ Log: Subject: Re: [PATCH] Step 1 of moving regexps to the pad
+ From: Artur Bergman <artur@contiller.se>
+ Date: Thu, 21 Jun 2001 14:04:54 +0200
+ Message-ID: <B757AF86.1842%artur@contiller.se>
+ Branch: perl
+ ! op.h
+ ____________________________________________________________________________
+ [ 10769] By: jhi on 2001/06/21 12:08:03
+ Log: Subject: Re: perl@10765: sv.c not OK on win32
+ From: Artur Bergman <artur@contiller.se>
+ Date: Thu, 21 Jun 2001 10:31:06 +0200
+ Message-ID: <B7577D69.182C%artur@contiller.se>
+ Branch: perl
+ ! sv.c
+ ____________________________________________________________________________
+ [ 10768] By: jhi on 2001/06/21 12:03:56
+ Log: Subject: [PATCH 5.6.1] OS2 getpw*, getgr*
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Thu, 21 Jun 2001 06:23:56 -0400
+ Message-ID: <20010621062356.A8619@math.ohio-state.edu>
+
+ Subject: Re: [PATCH 5.6.1] OS2 getpw*, getgr*
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Thu, 21 Jun 2001 06:32:21 -0400
+ Message-ID: <20010621063221.A8823@math.ohio-state.edu>
+ Branch: perl
+ ! lib/File/Glob/basic.t makedef.pl os2/os2.c os2/os2ish.h
+ ____________________________________________________________________________
+ [ 10767] By: jhi on 2001/06/21 12:00:07
+ Log: Subject: [PATCH] make syslog test more verbose
+ From: Robert Spier <rspier@pobox.com>
+ Date: Thu, 21 Jun 2001 00:54:32 -0400
+ Message-ID: <15153.32264.295807.333073@rls.cx>
+ Branch: perl
+ ! ext/Sys/Syslog/syslog.t
+ ____________________________________________________________________________
+ [ 10766] By: jhi on 2001/06/20 23:27:57
+ Log: Subject: op/study.t refinements
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Thu, 21 Jun 2001 00:29:07 +0100
+ Message-Id: <200106202329.AAA31397@crypt.compulink.co.uk>
+ Branch: perl
+ ! t/op/study.t
+ ____________________________________________________________________________
+ [ 10765] By: jhi on 2001/06/20 19:51:47
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10764] By: jhi on 2001/06/20 19:00:23
+ Log: Subject: Re: [PATCH] djgpp updates
+ From: Laszlo Molnar <laszlo.molnar@eth.ericsson.se>
+ Date: Wed, 20 Jun 2001 10:05:15 +0200
+ Message-ID: <20010620100515.L5600@libra.eth.ericsson.se>
+ Branch: perl
+ ! djgpp/config.over
+ ____________________________________________________________________________
+ [ 10763] By: jhi on 2001/06/20 18:58:06
+ Log: Fix for ID 20010619.002 "When building hash, hash keys that
+ are function calls are not being called", from Abhijit.
+ Branch: perl
+ ! t/base/lex.t toke.c
+ ____________________________________________________________________________
+ [ 10762] By: jhi on 2001/06/20 18:45:00
+ Log: Upgrade to Locale::Maketext 1.02, from Sean Burke.
+ Branch: perl
+ + lib/Locale/Maketext/ChangeLog lib/Locale/Maketext/README
+ + lib/Locale/Maketext/test.pl
+ - lib/Locale/Maketext.t
+ ! MANIFEST lib/Locale/Maketext.pm lib/Locale/Maketext.pod
+ ! lib/Locale/Maketext/TPJ13.pod
+ ____________________________________________________________________________
+ [ 10761] By: jhi on 2001/06/20 18:44:15
+ Log: Metaconfig unit change for #10760.
+ Branch: metaconfig
+ ! U/modified/Cppsym.U
+ ____________________________________________________________________________
+ [ 10760] By: jhi on 2001/06/20 18:42:04
+ Log: Do not remove the ccsym* Cppsym* files since
+ they are useful for metaconfig units coming after us.
+ (This is the Configure nit mentioned in #10752.)
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10759] By: jhi on 2001/06/20 18:02:18
+ Log: Update to I18N::LangTags 0.24, from Sean Burke.
+ Branch: perl
+ + lib/I18N/LangTags/ChangeLog lib/I18N/LangTags/List.pm
+ + lib/I18N/LangTags/README
+ - lib/I18N/LangTags/List.pod
+ ! MANIFEST lib/I18N/LangTags.pm lib/I18N/LangTags/test.pl
+ ____________________________________________________________________________
+ [ 10758] By: jhi on 2001/06/20 17:34:43
+ Log: Regen headers.
+ Branch: perl
+ ! embed.h embedvar.h global.sym perlapi.c perlapi.h
+ ! pod/perlapi.pod proto.h
+ ____________________________________________________________________________
+ [ 10757] By: jhi on 2001/06/20 17:23:08
+ Log: Subject: [PATCH] Fixes case of CvDEPTH for perl_clone
+ From: Artur Bergman <artur@contiller.se>
+ Date: Wed, 20 Jun 2001 11:31:32 +0200
+ Message-ID: <B7563A14.17D8%artur@contiller.se>
+ Branch: perl
+ ! embed.pl hv.c intrpvar.h sv.c sv.h
+ ____________________________________________________________________________
+ [ 10756] By: jhi on 2001/06/20 17:13:26
+ Log: Subject: Fix for [ID 20010124.001] POSIX::errno unreliable
+ From: Tim Sweetman <tim@aldigital.co.uk>
+ Date: Wed, 13 Jun 2001 14:25:17 +0100
+ Message-ID: <3B2769BD.68B4F4B3@aldigital.co.uk>
+ Branch: perl
+ ! ext/POSIX/POSIX.t lib/AutoLoader.pm
+ ____________________________________________________________________________
+ [ 10755] By: nick on 2001/06/20 16:12:37
+ Log: Integrate mainline
+ Branch: perlio
+ !> embed.h embed.pl ext/Cwd/Cwd.xs ext/Filter/t/call.t
+ !> ext/IO/lib/IO/Socket/INET.pm ext/IO/lib/IO/t/io_sock.t
+ !> ext/POSIX/POSIX.xs hints/mpeix.sh lib/File/Temp/security.t
+ !> lib/FileHandle.t mpeix/mpeixish.h mpeix/relink objXSUB.h
+ !> perlapi.c pod/perldiag.pod pp_sys.c proto.h t/op/pwent.t
+ !> t/op/study.t util.c
+ ____________________________________________________________________________
+ [ 10754] By: gsar on 2001/06/20 15:22:27
+ Log: missing ld entry in Config.pm on Windows (makefile.mk had it,
+ but not Makefile)
+ Branch: maint-5.6/perl
+ ! win32/Makefile
+ ____________________________________________________________________________
+ [ 10753] By: jhi on 2001/06/20 14:03:20
+ Log: Security tweak on readlink().
+ Branch: perl
+ ! pp_sys.c
+ ____________________________________________________________________________
+ [ 10752] By: jhi on 2001/06/20 14:00:23
+ Log: MPE/iX fixes from Mark Bixby (a Configure fix is also needed.)
+ Branch: perl
+ ! ext/Filter/t/call.t ext/IO/lib/IO/t/io_sock.t hints/mpeix.sh
+ ! lib/File/Temp/security.t lib/FileHandle.t mpeix/mpeixish.h
+ ! mpeix/relink t/op/pwent.t
+ ____________________________________________________________________________
+ [ 10751] By: jhi on 2001/06/20 13:57:27
+ Log: Reinstate #10725 (with probe for alarm()).
+ Branch: perl
+ ! t/op/study.t
+ ____________________________________________________________________________
+ [ 10750] By: jhi on 2001/06/20 13:53:46
+ Log: Replace our implementation of realpath() with OpenBSD's
+ (src/lib/libc/stdlib/realpath.c 1.4).
+ Branch: perl
+ ! embed.h embed.pl ext/Cwd/Cwd.xs objXSUB.h perlapi.c
+ ! pod/perldiag.pod proto.h util.c
+ ____________________________________________________________________________
+ [ 10749] By: jhi on 2001/06/20 13:07:49
+ Log: Integrate perlio.
+ Branch: perl
+ !> perlio.c
+ ____________________________________________________________________________
+ [ 10748] By: jhi on 2001/06/20 13:07:18
+ Log: No point in going into memory-saving contortions
+ with getcwd() since there's a danger of buffer overflow.
+ Also make the POSIX extension to use sv_getcwd().
+ Finally, a missed proto.h fragment.
+ Branch: perl
+ ! ext/POSIX/POSIX.xs proto.h util.c
+ ____________________________________________________________________________
+ [ 10747] By: nick on 2001/06/20 12:38:26
+ Log: Fix PERLIO=unix bug, while restoring maximal buffer in PerlIOBuf_unread.
+ Branch: perlio
+ ! perlio.c
+ ____________________________________________________________________________
+ [ 10746] By: jhi on 2001/06/20 11:51:10
+ Log: Subject: Re: Bug in IO::Socket::INET module (repeat)
+ From: Graham Barr <gbarr@pobox.com>
+ Date: Wed, 20 Jun 2001 11:05:49 +0100
+ Message-ID: <20010620110549.I19188@pobox.com>
+
+ reported in
+
+ Subject: Bug in IO::Socket::INET module (repeat)
+ From: "Harmon S. Nine" <hnine@netarx.com>
+ Date: Tue, 19 Jun 2001 09:41:35 -0400
+ Message-ID: <3B2F568F.8080605@netarx.com>
+
+ The bug was that the IO::Socket::INET constructor
+ did not allow a 'LocalPort' of 0.
+ Branch: perl
+ ! ext/IO/lib/IO/Socket/INET.pm
+ ____________________________________________________________________________
+ [ 10745] By: nick on 2001/06/20 08:56:39
+ Log: Integrate mainline.
+ Branch: perlio
+ !> (integrate 37 files)
+ ____________________________________________________________________________
+ [ 10744] By: jhi on 2001/06/20 04:54:53
+ Log: After some reading I don't think we can blindly
+ use systems' realpath(). Too many security problems,
+ too many buggy implementations.
+
+ TODO: the realpath() emulation code in util.c doesn't
+ seem fully operational? (readlink(), for example?)
+ Branch: perl
+ ! Configure Makefile.micro Porting/Glossary Porting/config.sh
+ ! Porting/config_H config_h.SH embed.h embed.pl global.sym
+ ! objXSUB.h perlapi.c pod/perldiag.pod pod/perltoc.pod uconfig.h
+ ! uconfig.sh util.c vos/config.alpha.def vos/config.alpha.h
+ ! vos/config.ga.def vos/config.ga.h win32/config_H.bc
+ ! win32/config_H.gc win32/config_H.vc
+ ____________________________________________________________________________
+ [ 10743] By: jhi on 2001/06/20 00:48:48
+ Log: Metaconfig unit change for #10738.
+ Branch: metaconfig
+ ! U/compline/d_gconvert.U
+ ____________________________________________________________________________
+ [ 10742] By: jhi on 2001/06/20 00:48:20
+ Log: Integrate change #10739 from maintperl:
+
+ C<eval "/x$\r\n/x"> fails to compile correctly
+ Branch: perl
+ !> t/op/pat.t toke.c
+ ____________________________________________________________________________
+ [ 10741] By: jhi on 2001/06/20 00:41:05
+ Log: Retract #10725 (Hugo asked NOT to apply the patch)
+ Branch: perl
+ ! t/op/study.t
+ ____________________________________________________________________________
+ [ 10740] By: jhi on 2001/06/19 23:58:25
+ Log: The test.third results were funnily named because of the
+ new test scheme.
+ Branch: perl
+ ! t/TEST
+ ____________________________________________________________________________
+ [ 10739] By: gsar on 2001/06/19 23:49:15
+ Log: C<eval "/x$\r\n/x"> fails to compile correctly
+ Branch: maint-5.6/perl
+ ! t/op/pat.t toke.c
+ ____________________________________________________________________________
+ [ 10738] By: jhi on 2001/06/19 23:04:15
+ Log: Subject: [ID 20010619.012] Not OK: perl v5.7.1 +DEVEL10721 +devel-10722 on alpha-dec_osf-per lio 4.0f (UNINSTALLED)
+ From: Spider Boardman <spider@Orb.Nashua.NH.US>
+ Date: Tue, 19 Jun 2001 19:15:40 -0400
+ Message-Id: <200106192315.TAA18531@Orb.Nashua.NH.US>
+
+ The bigintpm.t #1183 failing in Tru64 (and also Cygwin)
+ because "1e+129" being expected but "1.e+129" being returned.
+ The culprit (at least in Tru64) is the use of gcvt().
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10737] By: jhi on 2001/06/19 22:56:52
+ Log: Subject: [PATCH perl@10722] test hunting on VMS
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Message-Id: <5.1.0.14.0.20010619183530.01c4bdb8@exchi01>
+ Date: Tue, 19 Jun 2001 18:59:01 -0500
+ Branch: perl
+ ! vms/test.com
+ ____________________________________________________________________________
+ [ 10736] By: jhi on 2001/06/19 21:32:29
+ Log: Subject: [PATCH] s/typos//
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Wed, 20 Jun 2001 02:15:02 +0530
+ Message-ID: <20010620021502.A14541@lustre.linux.in>
+
+ Without the op.h s/bearword/bareword/ hunk, see
+ http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg00370.html
+ Branch: perl
+ ! util.c
+ ____________________________________________________________________________
+ [ 10735] By: jhi on 2001/06/19 21:26:43
+ Log: Metaconfig unit change for #10732 and #10733.
+ Branch: metaconfig/U/perl
+ ! fflushall.U
+ ____________________________________________________________________________
+ [ 10734] By: jhi on 2001/06/19 21:24:41
+ Log: Subject: [PATCH perl@10722] build ext/Socket dynamically on VMS
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Tue, 19 Jun 2001 17:19:48 -0500
+ Message-Id: <5.1.0.14.0.20010619165650.01bd8478@exchi01>
+ Branch: perl
+ ! configure.com vms/descrip_mms.template
+ ____________________________________________________________________________
+ [ 10733] By: jhi on 2001/06/19 19:57:44
+ Log: Subject: [ID 20010619.011] Not OK: perl v5.7.1 +DEVEL10721 +devel-10722 on alpha-dec_osf-per lio 4.0f (UNINSTALLED)
+ From: Spider Boardman <spider@Orb.Nashua.NH.US>
+ Date: Tue, 19 Jun 2001 16:48:07 -0400
+ Message-Id: <200106192048.QAA20849@Orb.Nashua.NH.US>
+
+ Further fixes to fflush(NULL) detection.
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10732] By: jhi on 2001/06/19 19:38:20
+ Log: AIX test -s hangs with non-existent files?
+ (A genuine logic bug in Configure, but AIX also broken?)
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10731] By: jhi on 2001/06/19 19:17:35
+ Log: AUTHORS updates.
+ Branch: perl
+ ! AUTHORS
+ ____________________________________________________________________________
+ [ 10730] By: jhi on 2001/06/19 19:03:07
+ Log: Subject: [ID 20010619.007] Not OK: perl v5.7.1 +DEVEL10721 +devel-10722 on alpha-dec_osf-perlio 4.0f (UNINSTALLED)
+ From: Spider Boardman <spider@Orb.Nashua.NH.US>
+ Date: Tue, 19 Jun 2001 15:33:25 -0400
+ Message-Id: <200106191933.PAA08415@Orb.Nashua.NH.US>
+ Branch: perl
+ ! ext/POSIX/POSIX.t lib/warnings.t perlio.c t/lib/1_compile.t
+ ! t/lib/warnings/pp
+ ____________________________________________________________________________
+ [ 10729] By: jhi on 2001/06/19 18:34:10
+ Log: Integrate perlio.
+ Branch: perl
+ !> lib/File/Find/find.t win32/distclean.bat
+ ____________________________________________________________________________
+ [ 10728] By: nick on 2001/06/19 18:24:53
+ Log: Hack File/Find/find.t to use File::Spec::Unix on Win32.
+ Branch: perlio
+ ! lib/File/Find/find.t win32/distclean.bat
+ ____________________________________________________________________________
+ [ 10727] By: jhi on 2001/06/19 18:07:31
+ Log: Furthwer tweak the fdopen() spot as suggseted by Jeff Pinyan;
+ also add information how to find out whether one has PerlIO.
+ Branch: perl
+ ! pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 10726] By: jhi on 2001/06/19 17:59:30
+ Log: Subject: [ID 20010619.005] two typos in pod/perlfunc.pod
+ From: Jeffrey Friedl <jfriedl@yahoo-inc.com>
+ Date: Tue, 19 Jun 2001 11:36:32 -0700 (PDT)
+ Message-Id: <200106191836.LAA21471@ventrue.corp.yahoo.com>
+ Branch: perl
+ ! pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 10725] By: jhi on 2001/06/19 17:28:30
+ Log: Subject: Re: [ID 20010618.006] some end-anchored regexps hang when using study
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Tue, 19 Jun 2001 12:37:30 +0100
+ Message-Id: <200106191137.MAA15185@crypt.compulink.co.uk>
+ Branch: perl
+ ! t/op/study.t
+ ____________________________________________________________________________
+ [ 10724] By: jhi on 2001/06/19 17:22:20
+ Log: Subject: Re: [ID 20010618.006] some end-anchored regexps hang when using study
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Message-Id: <200106191215.NAA17691@crypt.compulink.co.uk>
+ Date: Tue, 19 Jun 2001 13:15:17 +0100
+ Branch: perl
+ ! util.c
+ ____________________________________________________________________________
+ [ 10723] By: nick on 2001/06/19 14:46:15
+ Log: Integrate mainline
+ Branch: perlio
+ +> ext/IPC/SysV/ipcsysv.t ext/Thread/create.tx ext/Thread/die.tx
+ +> ext/Thread/die2.tx ext/Thread/io.tx ext/Thread/join.tx
+ +> ext/Thread/join2.tx ext/Thread/list.tx ext/Thread/lock.tx
+ +> ext/Thread/queue.tx ext/Thread/specific.tx ext/Thread/sync.tx
+ +> ext/Thread/sync2.tx ext/Thread/unsync.tx ext/Thread/unsync2.tx
+ +> ext/Thread/unsync3.tx ext/Thread/unsync4.tx
+ - ext/Thread/create.t ext/Thread/die.t ext/Thread/die2.t
+ - ext/Thread/io.t ext/Thread/join.t ext/Thread/join2.t
+ - ext/Thread/list.t ext/Thread/lock.t ext/Thread/queue.t
+ - ext/Thread/specific.t ext/Thread/sync.t ext/Thread/sync2.t
+ - ext/Thread/unsync.t ext/Thread/unsync2.t ext/Thread/unsync3.t
+ - ext/Thread/unsync4.t
+ !> Changes MANIFEST NetWare/Makefile NetWare/config.wc
+ !> djgpp/config.over djgpp/fixpmain
+ !> ext/DynaLoader/DynaLoader_pm.PL ext/IPC/SysV/t/msg.t
+ !> ext/IPC/SysV/t/sem.t handy.h hv.c lib/ExtUtils/MM_Unix.pm
+ !> patchlevel.h perl.h utils/libnetcfg.PL win32/Makefile
+ ____________________________________________________________________________
+ [ 10722] By: jhi on 2001/06/19 11:55:30
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10721] By: jhi on 2001/06/19 11:29:34
+ Log: The existence shall be MANIFESted.
+ Branch: perl
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10720] By: jhi on 2001/06/19 10:58:09
+ Log: The old libnet.cfg is first searched from the current directory,
+ only then from the module path.
+ Branch: perl
+ ! utils/libnetcfg.PL
+ ____________________________________________________________________________
+ [ 10719] By: jhi on 2001/06/19 10:55:59
+ Log: NetWare tweaks from Guruprasad.
+ Branch: perl
+ ! NetWare/Makefile NetWare/config.wc
+ ____________________________________________________________________________
+ [ 10718] By: jhi on 2001/06/19 10:54:22
+ Log: Subject: [PATCH] djgpp updates
+ From: Laszlo Molnar <laszlo.molnar@eth.ericsson.se>
+ Date: Tue, 19 Jun 2001 10:59:06 +0200
+ Message-ID: <20010619105906.C5600@libra.eth.ericsson.se>
+ Branch: perl
+ ! djgpp/config.over djgpp/fixpmain
+ ____________________________________________________________________________
+ [ 10717] By: jhi on 2001/06/19 10:53:20
+ Log: Subject: [PATCH: perl@10689]let MS VC 5 resolve _PerlIO_win32
+ From: Prymmer/Kahn <pvhp@best.com>
+ Date: Mon, 18 Jun 2001 23:48:52 -0700 (PDT)
+ Message-ID: <Pine.BSF.4.21.0106182345100.17670-100000@shell8.ba.best.com>
+ Branch: perl
+ ! win32/Makefile
+ ____________________________________________________________________________
+ [ 10716] By: jhi on 2001/06/19 10:52:25
+ Log: The INT32_MIN_BROKEN and INT64_MIN_BROKEN tweaks needs
+ to happen right after the inclusion of <inttypes.h>,
+ from Edward Moy.
+ Branch: perl
+ ! handy.h perl.h
+ ____________________________________________________________________________
+ [ 10715] By: jhi on 2001/06/19 10:49:21
+ Log: Subject: [patch] preserve @DynaLoader::dl_{librefs,modules}
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Mon, 18 Jun 2001 22:13:38 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0106182210570.22114-100000@mako.covalent.net>
+ Branch: perl
+ ! ext/DynaLoader/DynaLoader_pm.PL
+ ____________________________________________________________________________
+ [ 10714] By: jhi on 2001/06/19 10:48:19
+ Log: Revert #10656 for perfomance reasons but leave in the
+ use of Hv*() macros -- in comments, so that grepping the
+ source is easier, from Abhijit. (Also add the ENV_HV_NAME speedup
+ suggested by Sarathy, also by Abhijit.)
+ Branch: perl
+ ! hv.c
+ ____________________________________________________________________________
+ [ 10713] By: jhi on 2001/06/19 10:46:08
+ Log: Subject: [patch] .s MakeMaker suffix
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Mon, 18 Jun 2001 21:23:11 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0106182120250.22114-100000@mako.covalent.net>
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm
+ ____________________________________________________________________________
+ [ 10712] By: jhi on 2001/06/19 10:34:35
+ Log: One test lost in the big shuffle restored.
+ Branch: perl
+ + ext/IPC/SysV/ipcsysv.t
+ ! MANIFEST ext/IPC/SysV/t/msg.t ext/IPC/SysV/t/sem.t
+ ____________________________________________________________________________
+ [ 10711] By: jhi on 2001/06/19 10:25:46
+ Log: Rename the old non-standard threads tests so that
+ they won't be invoked.
+ Branch: perl
+ + ext/Thread/create.tx ext/Thread/die.tx ext/Thread/die2.tx
+ + ext/Thread/io.tx ext/Thread/join.tx ext/Thread/join2.tx
+ + ext/Thread/list.tx ext/Thread/lock.tx ext/Thread/queue.tx
+ + ext/Thread/specific.tx ext/Thread/sync.tx ext/Thread/sync2.tx
+ + ext/Thread/unsync.tx ext/Thread/unsync2.tx
+ + ext/Thread/unsync3.tx ext/Thread/unsync4.tx
+ - ext/Thread/create.t ext/Thread/die.t ext/Thread/die2.t
+ - ext/Thread/io.t ext/Thread/join.t ext/Thread/join2.t
+ - ext/Thread/list.t ext/Thread/lock.t ext/Thread/queue.t
+ - ext/Thread/specific.t ext/Thread/sync.t ext/Thread/sync2.t
+ - ext/Thread/unsync.t ext/Thread/unsync2.t ext/Thread/unsync3.t
+ - ext/Thread/unsync4.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10710] By: jhi on 2001/06/19 10:18:41
+ Log: Integrate perlio.
+ Branch: perl
+ !> win32/config_sh.PL
+ ____________________________________________________________________________
+ [ 10709] By: nick on 2001/06/19 08:18:18
+ Log: Integrate mainline
+ Branch: perlio
+ +> (branch 40 files)
+ - lib/locale/latin1 lib/locale/utf8 lib/strict/refs
+ - lib/strict/subs lib/strict/vars lib/warnings/1global
+ - lib/warnings/2use lib/warnings/3both lib/warnings/4lint
+ - lib/warnings/5nolint lib/warnings/6default lib/warnings/7fatal
+ - lib/warnings/8signal lib/warnings/9enabled lib/warnings/av
+ - lib/warnings/doio lib/warnings/doop lib/warnings/gv
+ - lib/warnings/hv lib/warnings/malloc lib/warnings/mg
+ - lib/warnings/op lib/warnings/perl lib/warnings/perlio
+ - lib/warnings/perly lib/warnings/pp lib/warnings/pp_ctl
+ - lib/warnings/pp_hot lib/warnings/pp_sys lib/warnings/regcomp
+ - lib/warnings/regexec lib/warnings/run lib/warnings/sv
+ - lib/warnings/taint lib/warnings/toke lib/warnings/universal
+ - lib/warnings/utf8 lib/warnings/util
+ !> (integrate 57 files)
+ ____________________________________________________________________________
+ [ 10708] By: nick on 2001/06/19 07:57:10
+ Log: Get Win32 known_extensions and extensions right in config.sh and hence Config.pm
+ Branch: perlio
+ ! win32/config_sh.PL
+ ____________________________________________________________________________
+ [ 10707] By: nick on 2001/06/19 07:05:07
+ Log: Perly.y and related file fixes to keep mainframe yacc (and bison) happy.
+ Branch: perl
+ ! perly.c perly.y perly_c.diff vms/perly_c.vms
+ ____________________________________________________________________________
+ [ 10706] By: jhi on 2001/06/19 02:58:26
+ Log: More perl572delta tweaks.
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 10705] By: jhi on 2001/06/19 01:53:40
+ Log: Update perl572delta.
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 10704] By: jhi on 2001/06/19 01:28:40
+ Log: VOS updates from Paul Green.
+ Branch: perl
+ ! vos/Changes vos/build.cm vos/perl.bind
+ ____________________________________________________________________________
+ [ 10703] By: jhi on 2001/06/19 01:03:53
+ Log: Update the vos/config.*.* files.
+ Branch: perl
+ ! vos/config.alpha.def vos/config.alpha.h vos/config.ga.def
+ ! vos/config.ga.h
+ ____________________________________________________________________________
+ [ 10702] By: jhi on 2001/06/19 01:03:32
+ Log: Add a makefile for more painless adding of symbols to the
+ VOS headers while in UNIX (in VOS the vos/configure_perl.cm
+ takes care of the adding)
+ Branch: perl
+ + vos/Makefile
+ ____________________________________________________________________________
+ [ 10701] By: jhi on 2001/06/19 00:51:44
+ Log: Make libnetcfg by default display the libnet configuration,
+ -c to change, add -i for old config, document all options,
+ regen toc.
+ Branch: perl
+ ! pod/perltoc.pod pod/perlutil.pod utils/libnetcfg.PL
+ ____________________________________________________________________________
+ [ 10700] By: jhi on 2001/06/18 23:45:12
+ Log: gcc -Wall sweep.
+ Branch: perl
+ ! ext/IO/IO.xs ext/Time/Piece/Piece.xs
+ ____________________________________________________________________________
+ [ 10699] By: jhi on 2001/06/18 23:19:53
+ Log: So there.
+ Branch: perl
+ ! universal.c
+ ____________________________________________________________________________
+ [ 10698] By: jhi on 2001/06/18 23:10:22
+ Log: Document the need for sv_printify().
+
+ Document that 'use utf8' has been considered.
+
+ (An unfinished, gcc 3.0 -Wall nit fix also slipped in, gack.)
+ Branch: perl
+ ! pod/perltodo.pod universal.c
+ ____________________________________________________________________________
+ [ 10697] By: jhi on 2001/06/18 22:50:53
+ Log: Subject: Re: [PATCH] Re: [PATCH] Re: perl@10611
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Mon, 18 Jun 2001 23:29:23 +0100
+ Message-ID: <20010618232923.I98663@plum.flirble.org>
+ Branch: perl
+ ! ext/POSIX/Makefile.PL ext/Socket/Makefile.PL
+ ! ext/Sys/Syslog/Makefile.PL
+ ____________________________________________________________________________
+ [ 10696] By: jhi on 2001/06/18 22:39:32
+ Log: Subject: [PATCH: 5.6.1] perl5db.pl v1.07 + docs
+ From: Scott.L.Miller@Compaq.com
+ Date: Mon, 18 Jun 2001 10:12:27 -0500
+ Message-ID: <86256A6F.00538A54.00@omacmta01.custom-edge.com>
+ Branch: perl
+ ! lib/perl5db.pl pod/perldebug.pod
+ ____________________________________________________________________________
+ [ 10695] By: jhi on 2001/06/18 22:35:13
+ Log: Subject: [PATCH lib/Carp/Heavy.pm] malformed POSIX negation
+ From: "Jeff 'japhy' Pinyan" <jeffp@crusoe.net>
+ Date: Mon, 18 Jun 2001 16:52:24 -0400 (EDT)
+ Message-ID: <Pine.GSO.4.21.0106181650590.17386-100000@crusoe.crusoe.net>
+ Branch: perl
+ ! lib/Carp/Heavy.pm
+ ____________________________________________________________________________
+ [ 10694] By: jhi on 2001/06/18 22:34:06
+ Log: Subject: [PATCH] Documentation changes for CLONE
+ From: Artur Bergman <artur@contiller.se>
+ Date: Mon, 18 Jun 2001 22:06:37 +0200
+ Message-ID: <B7542BEC.1719%artur@contiller.se>
+ Branch: perl
+ ! pod/perlmod.pod pod/perlsub.pod
+ ____________________________________________________________________________
+ [ 10693] By: jhi on 2001/06/18 22:31:38
+ Log: Subject: Re: configure.com
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Mon, 18 Jun 2001 16:04:38 -0500
+ Message-Id: <5.1.0.14.0.20010618154549.0318c090@mail.mac.com>
+ Branch: perl
+ ! configure.com
+ ____________________________________________________________________________
+ [ 10692] By: jhi on 2001/06/18 22:30:43
+ Log: Subject: PL_nullstash + perl_clone()
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Mon, 18 Jun 2001 16:24:22 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0106181621040.11974-100000@mako.covalent.net>
+ Branch: perl
+ ! sv.c
+ ____________________________________________________________________________
+ [ 10691] By: jhi on 2001/06/18 22:26:20
+ Log: Subject: Re: [PATCH 5.7.1] sv.c documentation
+ From: davem@fdgroup.co.uk
+ Date: Mon, 18 Jun 2001 21:29:45 +0100 (BST)
+ Message-Id: <200106182029.VAA06503@gizmo.fdgroup.co.uk>
+ Branch: perl
+ ! embed.pl pod/perlapi.pod
+ ____________________________________________________________________________
+ [ 10690] By: jhi on 2001/06/18 22:17:05
+ Log: More cross-compilation defaults gleaned from -Dcc
+ if it is CPU-OS-gcc.
+ Branch: metaconfig
+ ! U/modified/libc.U
+ Branch: metaconfig/U/perl
+ ! Cross.U
+ Branch: perl
+ ! Configure INSTALL
+ ____________________________________________________________________________
+ [ 10689] By: jhi on 2001/06/18 13:59:47
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10688] By: jhi on 2001/06/18 13:44:18
+ Log: Subject: [PATCH 5.7.1] sv.c documentation
+ From: davem@fdgroup.co.uk
+ Date: Mon, 18 Jun 2001 00:47:52 +0100 (BST)
+ Message-Id: <200106172347.AAA05475@gizmo.fdgroup.co.uk>
+ Branch: perl
+ ! embed.pl pod/perlapi.pod pod/perlguts.pod pod/perlintern.pod
+ ! sv.c sv.h
+ ____________________________________________________________________________
+ [ 10687] By: jhi on 2001/06/18 13:38:03
+ Log: Subject: [PATCH bleadperl DOC] $@ Clarification in pod/perlvar.pod
+ From: "Jon Gunnip" <jongunnip@hotmail.com>
+ Date: Sun, 17 Jun 2001 18:24:29 -0400
+ Message-ID: <F136EXUIEAOeIiGXix40000e3a7@hotmail.com>
+ Branch: perl
+ ! pod/perlvar.pod
+ ____________________________________________________________________________
+ [ 10686] By: jhi on 2001/06/18 13:32:13
+ Log: Move the locale/strict/warnings helper files back
+ under the t/lib; this way the amount of non-installabled
+ stuff under lib/ stays smaller.
+ Branch: perl
+ + t/lib/locale/latin1 t/lib/locale/utf8 t/lib/strict/refs
+ + t/lib/strict/subs t/lib/strict/vars t/lib/warnings/1global
+ + t/lib/warnings/2use t/lib/warnings/3both t/lib/warnings/4lint
+ + t/lib/warnings/5nolint t/lib/warnings/6default
+ + t/lib/warnings/7fatal t/lib/warnings/8signal
+ + t/lib/warnings/9enabled t/lib/warnings/av t/lib/warnings/doio
+ + t/lib/warnings/doop t/lib/warnings/gv t/lib/warnings/hv
+ + t/lib/warnings/malloc t/lib/warnings/mg t/lib/warnings/op
+ + t/lib/warnings/perl t/lib/warnings/perlio t/lib/warnings/perly
+ + t/lib/warnings/pp t/lib/warnings/pp_ctl t/lib/warnings/pp_hot
+ + t/lib/warnings/pp_sys t/lib/warnings/regcomp
+ + t/lib/warnings/regexec t/lib/warnings/run t/lib/warnings/sv
+ + t/lib/warnings/taint t/lib/warnings/toke
+ + t/lib/warnings/universal t/lib/warnings/utf8
+ + t/lib/warnings/util
+ - lib/locale/latin1 lib/locale/utf8 lib/strict/refs
+ - lib/strict/subs lib/strict/vars lib/warnings/1global
+ - lib/warnings/2use lib/warnings/3both lib/warnings/4lint
+ - lib/warnings/5nolint lib/warnings/6default lib/warnings/7fatal
+ - lib/warnings/8signal lib/warnings/9enabled lib/warnings/av
+ - lib/warnings/doio lib/warnings/doop lib/warnings/gv
+ - lib/warnings/hv lib/warnings/malloc lib/warnings/mg
+ - lib/warnings/op lib/warnings/perl lib/warnings/perlio
+ - lib/warnings/perly lib/warnings/pp lib/warnings/pp_ctl
+ - lib/warnings/pp_hot lib/warnings/pp_sys lib/warnings/regcomp
+ - lib/warnings/regexec lib/warnings/run lib/warnings/sv
+ - lib/warnings/taint lib/warnings/toke lib/warnings/universal
+ - lib/warnings/utf8 lib/warnings/util
+ ! MANIFEST installperl lib/locale.t lib/strict.t
+ ____________________________________________________________________________
+ [ 10685] By: jhi on 2001/06/18 13:11:49
+ Log: Split off the pack/unpack code, from Nicholas Clark.
+ Branch: perl
+ + pp_pack.c
+ ! MANIFEST Makefile.SH Makefile.micro cflags.SH embed.h embed.pl
+ ! objXSUB.h perlapi.c pod/perlhack.pod pp.c proto.h
+ ! vms/descrip_mms.template win32/Makefile win32/makefile.mk
+ ____________________________________________________________________________
+ [ 10684] By: jhi on 2001/06/18 12:25:55
+ Log: Guard the SysV IPC tests against being invoked in
+ SysV-IPC-less places.
+ Branch: perl
+ ! ext/IPC/SysV/t/msg.t ext/IPC/SysV/t/sem.t
+ ____________________________________________________________________________
+ [ 10683] By: nick on 2001/06/18 12:24:42
+ Log: Integrate mainline (new test scheme now ok on Linux).
+ Branch: perlio
+ +> lib/warnings.t
+ !> dump.c sv.c
+ ____________________________________________________________________________
+ [ 10682] By: jhi on 2001/06/18 12:20:50
+ Log: Add the locale.c and numeric.c to the microperl sources.
+ Branch: perl
+ ! Makefile.micro win32/Makefile
+ ____________________________________________________________________________
+ [ 10681] By: jhi on 2001/06/18 11:57:45
+ Log: Subject: [PATCH dump.c] FLAGS = (...,OUR,TYPED,...)
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Mon, 18 Jun 2001 14:23:44 +0530
+ Message-ID: <20010618142344.A13136@lustre.linux.in>
+ Branch: perl
+ ! dump.c
+ ____________________________________________________________________________
+ [ 10680] By: jhi on 2001/06/18 11:56:12
+ Log: Subject: Re: [PATCH] more anonymous stash cleanups
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Mon, 18 Jun 2001 15:50:32 +0530
+ Message-ID: <20010618155032.A13223@lustre.linux.in>
+
+ Plus the comment left in as suggested by NI-S.
+ Branch: perl
+ ! sv.c
+ ____________________________________________________________________________
+ [ 10679] By: jhi on 2001/06/18 11:49:27
+ Log: One missed file.
+ Branch: perl
+ + lib/warnings.t
+ ____________________________________________________________________________
+ [ 10678] By: nick on 2001/06/18 08:05:29
+ Log: Integrate mainline (part2 - the deletes)
+ Branch: perlio
+ - lib/Text/Abbrev/t/abbrev.t t/lib/anydbm.t t/lib/b-stash.t
+ - t/lib/bigfltpm.t t/lib/bigintpm.t t/lib/cwd.t t/lib/db-btree.t
+ - t/lib/db-hash.t t/lib/db-recno.t t/lib/extutils.t
+ - t/lib/filefind.t t/lib/filehand.t t/lib/filter-util.t
+ - t/lib/findtaint.t t/lib/ftmp-security.t t/lib/gdbm.t
+ - t/lib/glob-basic.t t/lib/glob-case.t t/lib/io_dup.t
+ - t/lib/io_poll.t t/lib/io_sel.t t/lib/io_taint.t t/lib/mbimbf.t
+ - t/lib/ndbm.t t/lib/net-hostent.t t/lib/odbm.t t/lib/open2.t
+ - t/lib/open3.t t/lib/posix.t t/lib/sdbm.t t/lib/sigaction.t
+ - t/lib/syslfs.t t/pragma/locale.t t/pragma/strict.t
+ - t/pragma/subs.t t/pragma/warn/mg t/pragma/warnings.t
+ ____________________________________________________________________________
+ [ 10677] By: nick on 2001/06/18 08:04:44
+ Log: Integrate mainline (part1)
+ Branch: perlio
+ +> (branch 376 files)
+ - (delete 219 files)
+ !> (integrate 151 files)
+ ____________________________________________________________________________
+ [ 10676] By: jhi on 2001/06/18 04:17:15
+ Log: The Grand Trek: move the *.t files from t/ to lib/ and ext/.
+ No doubt I made some mistakes like missed some files or
+ misnamed some files. The naming rules were more or less:
+ (1) if the module is from CPAN, follows its ways, be it
+ t/*.t or test.pl.
+ (2) otherwise if there are multiple tests for a module
+ put them in a t/
+ (3) otherwise if there's only one test put it in Module.t
+ (4) helper files go to module/ (locale, strict, warnings)
+ (5) use longer filenames now that we can (but e.g. the
+ compat-0.6.t and the Text::Balanced test files still
+ were renamed to be more civil against the 8.3 people)
+ installperl was updated appropriately not to install the
+ *.t files or the help files from under lib.
+
+ TODO: some helper files still remain under t/ that could
+ follow their 'masters'. UPDATE: On second thoughts, why
+ should they. They can continue to live under t/lib, and
+ in fact the locale/strict/warnings helpers that were moved
+ could be moved back. This way the amount of non-installable
+ stuff under lib/ stays smaller.
+ Branch: perl
+ + (add 253 files)
+ - (delete 254 files)
+ ! MANIFEST installperl lib/Test/Harness.pm t/TEST t/harness
+ ____________________________________________________________________________
+ [ 10675] By: jhi on 2001/06/18 03:15:02
+ Log: The warning no more comes from util.c, it comes from numeric.c.
+ Branch: perl
+ ! README.tru64
+ ____________________________________________________________________________
+ [ 10674] By: jhi on 2001/06/18 00:56:22
+ Log: Subject: Re: anyone good at casting spells?
+ From: Spider Boardman <spider@Orb.Nashua.NH.US>
+ Date: Sun, 17 Jun 2001 21:21:04 -0400
+ Message-Id: <200106180121.VAA10195@Orb.Nashua.NH.US>
+ Branch: perl
+ ! ext/POSIX/POSIX.xs hv.h
+ ____________________________________________________________________________
+ [ 10673] By: jhi on 2001/06/17 22:24:53
+ Log: Protect the (original) thread tests against testing if no 5.005
+ threads have been configured.
+ Branch: perl
+ ! ext/Thread/create.t ext/Thread/die.t ext/Thread/die2.t
+ ! ext/Thread/io.t ext/Thread/join.t ext/Thread/join2.t
+ ! ext/Thread/list.t ext/Thread/lock.t ext/Thread/queue.t
+ ! ext/Thread/specific.t ext/Thread/sync.t ext/Thread/sync2.t
+ ! ext/Thread/unsync.t ext/Thread/unsync2.t ext/Thread/unsync3.t
+ ! ext/Thread/unsync4.t
+ ____________________________________________________________________________
+ [ 10672] By: jhi on 2001/06/17 22:09:28
+ Log: Try the new test scanning scheme on Text::Abbrev.
+ Branch: perl
+ + lib/Text/Abbrev.t
+ - lib/Text/Abbrev/t/abbrev.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10671] By: jhi on 2001/06/17 22:07:08
+ Log: Change the scan policy of the *.t and test.pl files,
+ now the *.t do not need to live in a t/ directory.
+ Branch: perl
+ ! t/TEST t/harness
+ ____________________________________________________________________________
+ [ 10670] By: jhi on 2001/06/17 20:32:35
+ Log: Subject: [PATCH perlfaq7.pod] fix dangling L<perlobj/"WARNING">
+ From: Ilmari Karonen <iltzu@sci.fi>
+ Date: Mon, 18 Jun 2001 00:30:21 +0300 (EET DST)
+ Message-ID: <Pine.SOL.3.96.1010618002009.6629A-100000@simpukka>
+ Branch: perl
+ ! pod/perlfaq7.pod
+ ____________________________________________________________________________
+ [ 10669] By: jhi on 2001/06/17 20:30:22
+ Log: Quench the warnings from Tru64; the HP-UX is still
+ broken because it really, REALLY, doesn't like the
+ HvARRAY() being lvalue:
+
+ cc: "hv.c", line 192: warning 524: Cast (non-lvalue) appears on left-hand side of assignment.
+ cc: "hv.c", line 192: error 1549: Modifiable lvalue required for assignment operator.
+ Branch: perl
+ ! hv.c
+ ____________________________________________________________________________
+ [ 10668] By: jhi on 2001/06/17 19:13:24
+ Log: Integrate change #10667 from maintperl:
+
+ change#10449 broke the special-case that makes lexicals inside the
+ eval"" within DB::DB() visible
+ Branch: perl
+ !> op.c
+ ____________________________________________________________________________
+ [ 10667] By: gsar on 2001/06/17 19:08:27
+ Log: change#10449 broke the special-case that makes lexicals inside the
+ eval"" within DB::DB() visible
+ Branch: maint-5.6/perl
+ ! op.c
+ ____________________________________________________________________________
+ [ 10666] By: jhi on 2001/06/17 17:50:07
+ Log: Still spurious output; indent the code a bit.
+
+ TODO1: separate the utility functions like MkDir
+ into a helper script?
+
+ TODO2: I see a lot of repetition in the filepath()
+ and dirpath() calls.
+ Branch: perl
+ ! t/lib/filefind.t t/lib/findtaint.t
+ ____________________________________________________________________________
+ [ 10665] By: jhi on 2001/06/17 16:59:42
+ Log: Regen modlib, toc.
+ Branch: perl
+ ! pod/perlmodlib.pod pod/perltoc.pod
+ ____________________________________________________________________________
+ [ 10664] By: jhi on 2001/06/17 16:55:28
+ Log: Add libnetcfg to perlutil.
+ Branch: perl
+ ! pod/perlutil.pod
+ ____________________________________________________________________________
+ [ 10663] By: jhi on 2001/06/17 16:53:29
+ Log: Initial integration of libnet-1.0703.
+ The Configure script renamed as libnetcfg, will be
+ installed along other utilities.
+ Branch: perl
+ + lib/Net/ChangeLog.libnet lib/Net/Cmd.pm lib/Net/Config.eg
+ + lib/Net/Config.pm lib/Net/Domain.pm lib/Net/DummyInetd.pm
+ + lib/Net/FTP.pm lib/Net/FTP/A.pm lib/Net/FTP/E.pm
+ + lib/Net/FTP/I.pm lib/Net/FTP/L.pm lib/Net/FTP/dataconn.pm
+ + lib/Net/Hostname.eg lib/Net/NNTP.pm lib/Net/Netrc.pm
+ + lib/Net/PH.pm lib/Net/POP3.pm lib/Net/README.config
+ + lib/Net/README.libnet lib/Net/SMTP.pm lib/Net/SNPP.pm
+ + lib/Net/Time.pm lib/Net/demos/ftp lib/Net/demos/inetd
+ + lib/Net/demos/nntp lib/Net/demos/nntp.mirror
+ + lib/Net/demos/pop3 lib/Net/demos/smtp.self lib/Net/demos/snpp
+ + lib/Net/demos/time lib/Net/libnet.ppd lib/Net/libnetFAQ.pod
+ + lib/Net/t/ftp.t lib/Net/t/hostname.t lib/Net/t/nntp.t
+ + lib/Net/t/ph.t lib/Net/t/require.t lib/Net/t/smtp.t
+ + utils/libnetcfg.PL
+ ! MANIFEST utils.lst utils/Makefile
+ ____________________________________________________________________________
+ [ 10662] By: jhi on 2001/06/17 15:37:32
+ Log: Less potentially test-harness-confusing output.
+ Branch: perl
+ ! lib/Memoize/t/expire_module_t.t
+ ____________________________________________________________________________
+ [ 10661] By: jhi on 2001/06/17 15:31:04
+ Log: The final print annoys make test.
+ Branch: perl
+ ! t/lib/filefind.t t/lib/findtaint.t
+ ____________________________________________________________________________
+ [ 10660] By: jhi on 2001/06/17 14:00:21
+ Log: Add an option for handling dangling symbolic links.
+ Branch: perl
+ ! lib/File/Find.pm t/lib/filefind.t
+ ____________________________________________________________________________
+ [ 10659] By: jhi on 2001/06/17 13:45:48
+ Log: Subject: Re: [MacPerl-Porters] Re: [PATCH] File::Find for bleadperl, Mac OS etc.
+ From: Thomas Wegner <wegner_thomas@yahoo.com>
+ Date: Sun, 17 Jun 2001 14:43:11 +0200
+ Message-Id: <p04320400b751fb74714a@[149.225.10.45]>
+ Branch: perl
+ + t/lib/findtaint.t
+ ! MANIFEST lib/File/Find.pm t/lib/filefind.t
+ ____________________________________________________________________________
+ [ 10658] By: jhi on 2001/06/17 13:13:25
+ Log: Subject: [PATCH ExtUtils/MM_Unix.pm perl@10654] Remove tmon.out in make clean
+ From: Jonathan Stowe <gellyfish@gellyfish.com>
+ Date: Sun, 17 Jun 2001 11:26:21 +0100 (BST)
+ Message-ID: <Pine.LNX.4.33.0106171120540.28753-100000@orpheus.gellyfish.com>
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm
+ ____________________________________________________________________________
+ [ 10657] By: jhi on 2001/06/17 13:12:25
+ Log: Subject: [PATCH] more anonymous stash cleanups
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Sun, 17 Jun 2001 11:44:06 +0530
+ Message-ID: <20010617114406.A25203@lustre.linux.in>
+ Branch: perl
+ ! op.c
+ ____________________________________________________________________________
+ [ 10656] By: jhi on 2001/06/17 13:11:11
+ Log: Subject: [PATCH #1/7] xhv_array (was Re: Using xhv_foo instead of HvFOO)
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Sun, 17 Jun 2001 08:02:59 +0530
+ Message-ID: <20010617080259.A28776@lustre.linux.in>
+
+ Subject: [PATCH #2/7] xhv_eiter
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Sun, 17 Jun 2001 08:13:18 +0530
+ Message-ID: <20010617081318.B28776@lustre.linux.in>
+
+ Subject: [PATCH #3/7] xhv_fill
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Sun, 17 Jun 2001 08:25:16 +0530
+ Message-ID: <20010617082516.C28776@lustre.linux.in>
+
+ Subject: [PATCH #4/7] xhv_keys
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Sun, 17 Jun 2001 08:36:17 +0530
+ Message-ID: <20010617083617.D28776@lustre.linux.in>
+
+ Subject: [PATCH #5/7] xhv_max
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Sun, 17 Jun 2001 08:39:48 +0530
+ Message-ID: <20010617083948.E28776@lustre.linux.in>
+
+ Subject: [PATCH #6,7/7] xhv_pmroot, xhv_riter
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Sun, 17 Jun 2001 08:51:11 +0530
+ Message-ID: <20010617085111.F28776@lustre.linux.in>
+ Branch: perl
+ ! hv.c
+ ____________________________________________________________________________
+ [ 10655] By: jhi on 2001/06/16 23:32:03
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10654] By: jhi on 2001/06/16 23:18:37
+ Log: Subject: [PATCH] Re: DYNAMIC_ENV_FETCH HvNAME abuse.
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Sat, 16 Jun 2001 07:41:19 +0530
+ Message-ID: <20010616074119.A24720@lustre.linux.in>
+ Branch: perl
+ ! hv.c perl.c vms/vmsish.h win32/win32.h
+ ____________________________________________________________________________
+ [ 10653] By: jhi on 2001/06/16 23:15:11
+ Log: Document tests failing when threaded, since we now have more.
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 10652] By: jhi on 2001/06/16 23:12:19
+ Log: -Wall cleanup.
+ Branch: perl
+ ! ext/Thread/Thread.xs
+ ____________________________________________________________________________
+ [ 10651] By: jhi on 2001/06/16 23:06:55
+ Log: pthread_attr_setstacksize() isn't absolutely necessary
+ to call, only iff THREAD_CREATE_NEEDS_STACK.
+ Branch: perl
+ ! ext/Thread/Thread.xs
+ ____________________________________________________________________________
+ [ 10650] By: jhi on 2001/06/16 22:58:48
+ Log: -Wall strays.
+ Branch: perl
+ ! perl.c util.c
+ ____________________________________________________________________________
+ [ 10649] By: jhi on 2001/06/16 22:47:40
+ Log: Add workaround for Darwin's (Mac OS X's) INT32_MIN
+ (and INT64_MIN) brokenness.
+ Branch: perl
+ ! hints/darwin.sh perl.h
+ ____________________________________________________________________________
+ [ 10648] By: jhi on 2001/06/16 22:27:48
+ Log: Subject: [PATCH] Re: [PATCH] Re: perl@10611
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Sun, 17 Jun 2001 00:16:05 +0100
+ Message-ID: <20010617001605.V98663@plum.flirble.org>
+ Branch: perl
+ ! ext/Fcntl/Fcntl.xs ext/Fcntl/Makefile.PL ext/File/Glob/Glob.pm
+ ! ext/File/Glob/Glob.xs ext/File/Glob/Makefile.PL
+ ! lib/ExtUtils/Constant.pm t/lib/extutils.t
+ ____________________________________________________________________________
+ [ 10647] By: jhi on 2001/06/16 22:24:47
+ Log: Add perlnetware to docs; regen toc; supply skeleton
+ docs for some Memoize submodules.
+ Branch: perl
+ ! lib/Memoize/AnyDBM_File.pm lib/Memoize/ExpireFile.pm
+ ! lib/Memoize/ExpireTest.pm lib/Memoize/NDBM_File.pm
+ ! lib/Memoize/SDBM_File.pm lib/Memoize/Storable.pm
+ ! pod/buildtoc.PL pod/perl.pod pod/perlport.pod pod/perltoc.pod
+ ! win32/Makefile win32/makefile.mk
+ ____________________________________________________________________________
+ [ 10646] By: jhi on 2001/06/16 22:06:52
+ Log: pod cleanup.
+ Branch: perl
+ ! README.netware
+ ____________________________________________________________________________
+ [ 10645] By: jhi on 2001/06/16 21:47:00
+ Log: Integrate Memoize 0.64. Few tweaks were required in
+ the test scripts. Note that the speed and expire*
+ tests take several dozen seconds to run.
+ Branch: perl
+ + lib/Memoize.pm lib/Memoize/AnyDBM_File.pm
+ + lib/Memoize/Expire.pm lib/Memoize/ExpireFile.pm
+ + lib/Memoize/ExpireTest.pm lib/Memoize/NDBM_File.pm
+ + lib/Memoize/README lib/Memoize/SDBM_File.pm
+ + lib/Memoize/Saves.pm lib/Memoize/Storable.pm lib/Memoize/TODO
+ + lib/Memoize/t/array.t lib/Memoize/t/correctness.t
+ + lib/Memoize/t/errors.t lib/Memoize/t/expire.t
+ + lib/Memoize/t/expire_file.t lib/Memoize/t/expire_module_n.t
+ + lib/Memoize/t/expire_module_t.t lib/Memoize/t/flush.t
+ + lib/Memoize/t/normalize.t lib/Memoize/t/prototype.t
+ + lib/Memoize/t/speed.t lib/Memoize/t/tie.t
+ + lib/Memoize/t/tie_gdbm.t lib/Memoize/t/tie_ndbm.t
+ + lib/Memoize/t/tie_sdbm.t lib/Memoize/t/tie_storable.t
+ + lib/Memoize/t/tiefeatures.t lib/Memoize/t/unmemoize.t
+ ! MANIFEST t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 10644] By: jhi on 2001/06/16 20:35:49
+ Log: Document the cross-compilation options.
+ Branch: perl
+ ! Cross/README INSTALL
+ ____________________________________________________________________________
+ [ 10643] By: jhi on 2001/06/16 19:46:38
+ Log: NetWare port from Guruprasad S <SGURUPRASAD@novell.com>.
+ Branch: perl
+ + NetWare/CLIBsdio.h NetWare/CLIBstr.h NetWare/CLIBstuf.c
+ + NetWare/CLIBstuf.h NetWare/Main.c NetWare/Makefile
+ + NetWare/NWTInfo.c NetWare/NWUtil.c NetWare/Nwmain.c
+ + NetWare/Nwpipe.c NetWare/bat/BldNWExt.bat
+ + NetWare/bat/Buildtype.bat NetWare/bat/MPKBuild.bat
+ + NetWare/bat/SetNWBld.bat NetWare/bat/Setmpksdk.bat
+ + NetWare/bat/Setnlmsdk.bat NetWare/bat/Setwatcom.bat
+ + NetWare/bat/ToggleD2.bat NetWare/bat/ToggleXDC.bat
+ + NetWare/config.wc NetWare/config_H.wc NetWare/config_h.PL
+ + NetWare/config_sh.PL NetWare/deb.h NetWare/dl_netware.xs
+ + NetWare/intdef.h NetWare/interface.c NetWare/interface.h
+ + NetWare/iperlhost.h NetWare/netware.h NetWare/nw5.c
+ + NetWare/nw5iop.h NetWare/nw5sck.c NetWare/nw5sck.h
+ + NetWare/nw5thread.c NetWare/nw5thread.h NetWare/nwperlsys.c
+ + NetWare/nwperlsys.h NetWare/nwpipe.h NetWare/nwplglob.c
+ + NetWare/nwplglob.h NetWare/nwtinfo.h NetWare/nwutil.h
+ + NetWare/t/NWModify.pl NetWare/t/NWScripts.pl
+ + NetWare/t/Readme.txt NetWare/testnlm/echo/echo.c
+ + NetWare/testnlm/type/type.c NetWare/win32ish.h README.netware
+ + lib/ExtUtils/MM_NW5.pm
+ ! MANIFEST XSUB.h dosish.h ext/Errno/Errno_pm.PL ext/IO/IO.xs
+ ! ext/POSIX/POSIX.xs ext/Socket/Socket.xs installperl iperlsys.h
+ ! lib/AutoLoader.pm lib/AutoSplit.pm lib/ExtUtils/MakeMaker.pm
+ ! lib/File/Copy.pm lib/File/Find.pm lib/perl5db.pl makedef.pl
+ ! perl.c perl.h perlio.c perlio.h pp_sys.c t/comp/multiline.t
+ ! t/comp/script.t t/io/argv.t t/io/dup.t t/io/fs.t
+ ! t/io/inplace.t t/io/iprefix.t t/io/tell.t t/lib/anydbm.t
+ ! t/lib/b-stash.t t/lib/cwd.t t/lib/db-btree.t t/lib/db-hash.t
+ ! t/lib/db-recno.t t/lib/filehand.t t/lib/filter-util.t
+ ! t/lib/ftmp-security.t t/lib/gdbm.t t/lib/glob-basic.t
+ ! t/lib/glob-case.t t/lib/io_dup.t t/lib/io_poll.t
+ ! t/lib/io_sel.t t/lib/io_taint.t t/lib/ndbm.t
+ ! t/lib/net-hostent.t t/lib/odbm.t t/lib/open2.t t/lib/open3.t
+ ! t/lib/posix.t t/lib/sdbm.t t/lib/sigaction.t t/lib/syslfs.t
+ ! t/op/anonsub.t t/op/closure.t t/op/die_exit.t t/op/exec.t
+ ! t/op/fork.t t/op/goto.t t/op/groups.t t/op/lfs.t t/op/magic.t
+ ! t/op/misc.t t/op/rand.t t/op/runlevel.t t/op/split.t
+ ! t/op/stat.t t/op/sysio.t t/op/taint.t t/op/write.t
+ ! t/pragma/locale.t t/pragma/strict.t t/pragma/subs.t
+ ! t/pragma/warn/mg t/pragma/warnings.t thread.h toke.c util.c
+ ! util.h x2p/a2py.c
+ ____________________________________________________________________________
+ [ 10642] By: jhi on 2001/06/16 19:16:04
+ Log: Resort MANIFEST.
+ Branch: perl
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10641] By: jhi on 2001/06/16 18:52:26
+ Log: Integrate perlio.
+ Branch: perl
+ +> win32/win32io.c
+ !> MANIFEST perlio.c perliol.h win32/makefile.mk
+ ____________________________________________________________________________
+ [ 10640] By: nick on 2001/06/16 18:38:31
+ Log: Disable :win32 layer as default till I get it working
+ Branch: perlio
+ ! MANIFEST perlio.c
+ ____________________________________________________________________________
+ [ 10639] By: jhi on 2001/06/16 18:35:46
+ Log: Try the new scheme by moving the Text::Abbrev test
+ to a new place under lib.
+ Branch: perl
+ + lib/Text/Abbrev/t/abbrev.t
+ - t/lib/abbrev.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10638] By: jhi on 2001/06/16 18:34:30
+ Log: Make the code even more dynamical so that testname
+ suffix length can change.
+ Branch: perl
+ ! lib/Test/Harness.pm t/TEST
+ ____________________________________________________________________________
+ [ 10637] By: jhi on 2001/06/16 18:16:28
+ Log: Allow for deeper t/ and also a single test.pl.
+ Branch: perl
+ ! t/TEST t/harness
+ ____________________________________________________________________________
+ [ 10636] By: jhi on 2001/06/16 18:13:59
+ Log: #define fix from Nicholas Clark.
+ Branch: perl
+ ! ext/POSIX/POSIX.xs
+ ____________________________________________________________________________
+ [ 10635] By: jhi on 2001/06/16 17:50:43
+ Log: Initialization is nice.
+ Branch: perl
+ ! lib/Test/Harness.pm
+ ____________________________________________________________________________
+ [ 10634] By: jhi on 2001/06/16 17:38:53
+ Log: Make t/TEST and t/harness to test also the t/ tests
+ under the main lib/ and ext/ directories. Fix Test::Harness
+ to dynamically change the width of its "foo/bar....ok" output.
+ Branch: perl
+ ! lib/Test/Harness.pm t/TEST t/TestInit.pm t/harness
+ ____________________________________________________________________________
+ [ 10633] By: jhi on 2001/06/16 16:58:57
+ Log: Subject: [PATCH] Re: perl@10611
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Sat, 16 Jun 2001 16:52:47 +0100
+ Message-ID: <20010616165247.O98663@plum.flirble.org>
+
+ The .xs parts, too.
+ Branch: perl
+ ! ext/GDBM_File/GDBM_File.xs ext/POSIX/POSIX.xs
+ ! ext/Socket/Socket.xs ext/Sys/Syslog/Syslog.xs
+ ____________________________________________________________________________
+ [ 10632] By: nick on 2001/06/16 16:44:35
+ Log: Work-in-progress win32 layer semi-functional, checking
+ for UNIX breakage.
+ Branch: perlio
+ ! perlio.c perliol.h win32/makefile.mk win32/win32io.c
+ ____________________________________________________________________________
+ [ 10631] By: jhi on 2001/06/16 16:40:30
+ Log: Subject: [PATCH] Re: perl@10611
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Sat, 16 Jun 2001 16:52:47 +0100
+ Message-ID: <20010616165247.O98663@plum.flirble.org>
+ Branch: perl
+ ! ext/GDBM_File/GDBM_File.xs ext/GDBM_File/Makefile.PL
+ ! ext/POSIX/Makefile.PL ext/POSIX/POSIX.xs
+ ! ext/Socket/Makefile.PL ext/Socket/Socket.xs
+ ! ext/Sys/Syslog/Makefile.PL ext/Sys/Syslog/Syslog.xs
+ ! lib/ExtUtils/Constant.pm
+ ____________________________________________________________________________
+ [ 10630] By: jhi on 2001/06/16 15:11:38
+ Log: Metaconfig unit change for #10629.
+ Branch: metaconfig
+ ! U/modified/Finish.U
+ ____________________________________________________________________________
+ [ 10629] By: jhi on 2001/06/16 15:11:10
+ Log: The extraction changed directories.
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10628] By: jhi on 2001/06/16 14:59:38
+ Log: Math::BigInt 1.35 from Tels.
+ Branch: perl
+ + t/lib/mbimbf.t
+ ! MANIFEST lib/Math/BigFloat.pm lib/Math/BigInt.pm
+ ! t/lib/bigfltpm.t t/lib/bigintpm.t
+ ____________________________________________________________________________
+ [ 10627] By: nick on 2001/06/16 14:54:52
+ Log: Work in progress UNIX-side edit of win32 PerLIO layer
+ Branch: perlio
+ + win32/win32io.c
+ ! perlio.c win32/makefile.mk
+ ____________________________________________________________________________
+ [ 10626] By: jhi on 2001/06/16 14:01:50
+ Log: Subject: [PATCH 5.6.1] os2/diff-configure
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Fri, 15 Jun 2001 01:19:36 -0400
+ Message-ID: <20010615011936.A26982@math.ohio-state.edu>
+
+ Empty all of it because I think #10624 made even the
+ last patch hunk unnecessary.
+ Branch: perl
+ ! os2/diff.configure
+ ____________________________________________________________________________
+ [ 10625] By: jhi on 2001/06/16 13:58:34
+ Log: Metaconfig unit change for 10624.
+ Branch: metaconfig
+ ! U/modified/libc.U
+ Branch: perl
+ ! config_h.SH
+ ____________________________________________________________________________
+ [ 10624] By: jhi on 2001/06/16 13:58:13
+ Log: Move the initialization of libnames to the beginning so
+ that can one 'seed' it (as OS/2 does.)
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10623] By: jhi on 2001/06/16 13:47:54
+ Log: Subject: [PATCH 5.6.1] OS2::DLL patch
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Fri, 15 Jun 2001 19:10:57 -0400
+ Message-ID: <20010615191057.A8050@math.ohio-state.edu>
+ Branch: perl
+ ! os2/OS2/REXX/DLL/DLL.pm
+ ____________________________________________________________________________
+ [ 10622] By: jhi on 2001/06/16 13:29:42
+ Log: Subject: [PATCH perl@10611] make VMS find util.c's offspring
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Fri, 15 Jun 2001 17:00:03 -0500
+ Message-Id: <a05101007b750342599be@[172.16.52.1]>
+ Branch: perl
+ ! vms/descrip_mms.template
+ ____________________________________________________________________________
+ [ 10621] By: jhi on 2001/06/16 13:28:37
+ Log: Subject: [PATCH perl@10611] get extutils.t working on VMS (again)
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Fri, 15 Jun 2001 18:39:42 -0500
+ Message-Id: <a05101008b7503dc9dc2f@[172.16.52.1]>
+ Branch: perl
+ ! lib/File/Spec/VMS.pm t/lib/extutils.t
+ ____________________________________________________________________________
+ [ 10620] By: jhi on 2001/06/16 13:25:06
+ Log: Integrate perlio.
+ Branch: perl
+ !> embed.h embed.pl lib/open.pm perl.c perlio.c proto.h
+ !> t/io/utf8.t t/lib/io_scalar.t
+ ____________________________________________________________________________
+ [ 10619] By: nick on 2001/06/15 21:05:19
+ Log: Generated files
+ Branch: perlio
+ ! embed.h proto.h
+ ____________________________________________________________________________
+ [ 10618] By: nick on 2001/06/15 20:27:42
+ Log: Fix open.pm to work via XS-implemented method calls rather
+ than *open::layers variables which caused all the HV/AV hassle.
+ Branch: perlio
+ ! embed.pl lib/open.pm perl.c perlio.c t/io/utf8.t
+ ! t/lib/io_scalar.t
+ ____________________________________________________________________________
+ [ 10617] By: jhi on 2001/06/15 18:50:53
+ Log: Integrate perlio.
+ Branch: perl
+ !> lib/ExtUtils/Constant.pm
+ ____________________________________________________________________________
+ [ 10616] By: nick on 2001/06/15 18:46:47
+ Log: pTHX_ / aTHX_ for ExtUtils/Constant.pm
+ Branch: perlio
+ ! lib/ExtUtils/Constant.pm
+ ____________________________________________________________________________
+ [ 10615] By: jhi on 2001/06/15 18:36:43
+ Log: Integrate perlio.
+ Branch: perl
+ !> ext/Socket/Socket.xs
+ ____________________________________________________________________________
+ [ 10614] By: nick on 2001/06/15 18:33:37
+ Log: MULTIPLICITY fix for Socket.xs
+ Branch: perlio
+ ! ext/Socket/Socket.xs
+ ____________________________________________________________________________
+ [ 10613] By: jhi on 2001/06/15 16:34:06
+ Log: Subject: Re: perl@10611
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Fri, 15 Jun 2001 10:10:33 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0106151007420.10871-100000@mako.covalent.net>
+ Branch: perl
+ ! ext/Socket/Socket.xs
+ ____________________________________________________________________________
+ [ 10612] By: nick on 2001/06/15 16:14:38
+ Log: Raw integrate on mainline - MULTIPLICITY issues with Socket.xs
+ Branch: perlio
+ !> Changes ext/GDBM_File/GDBM_File.pm ext/GDBM_File/GDBM_File.xs
+ !> ext/Socket/Socket.pm ext/Socket/Socket.xs
+ !> lib/ExtUtils/Constant.pm lib/File/Find.pm opcode.pl
+ !> patchlevel.h perlio.c t/lib/extutils.t t/lib/filefind.t
+ !> t/lib/gdbm.t t/lib/h2ph.h t/lib/h2ph.pht t/lib/h2ph.t
+ !> utils/h2ph.PL
+ ____________________________________________________________________________
+ [ 10611] By: jhi on 2001/06/15 14:29:04
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10610] By: jhi on 2001/06/15 14:20:33
+ Log: Upping the test count.
+ Branch: perl
+ ! t/lib/filefind.t
+ ____________________________________________________________________________
+ [ 10609] By: jhi on 2001/06/15 14:13:29
+ Log: Integrate perlio.
+ Branch: perl
+ !> win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ____________________________________________________________________________
+ [ 10608] By: jhi on 2001/06/15 14:12:31
+ Log: Subject: Re: [ID 20010608.010] File::Find re-entrancy
+ From: andreas.koenig@anima.de (Andreas J. Koenig)
+ Date: 15 Jun 2001 13:30:39 +0200
+ Message-ID: <m3hexikmjk.fsf@ak-71.mind.de>
+
+ Record the grim history.
+ Branch: perl
+ ! lib/File/Find.pm
+ ____________________________________________________________________________
+ [ 10607] By: jhi on 2001/06/15 14:08:19
+ Log: Subject: Re: [ID 20010608.010] File::Find re-entrancy
+ From: Brian McCauley <nobull@mail.com>
+ Date: 15 Jun 2001 07:51:26 +0100
+ Message-Id: <200106150923.f5F9NpG02725@wcl-l.bham.ac.uk>
+ Branch: perl
+ ! lib/File/Find.pm t/lib/filefind.t
+ ____________________________________________________________________________
+ [ 10606] By: nick on 2001/06/15 14:00:08
+ Log: regen_config_h for Win32.
+ Branch: perlio
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ____________________________________________________________________________
+ [ 10605] By: jhi on 2001/06/15 13:49:55
+ Log: Subject: [PATCH: perl@10576] handle tri graphs in h2ph.PL -> h2ph*
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Thu, 14 Jun 2001 16:25:33 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10106141608080.110974-100000@aspara.forte.com>
+ Branch: perl
+ ! t/lib/h2ph.h t/lib/h2ph.pht t/lib/h2ph.t utils/h2ph.PL
+ ____________________________________________________________________________
+ [ 10604] By: jhi on 2001/06/15 13:45:03
+ Log: Some filesystems require writability for rename/unlink.
+ Branch: perl
+ ! opcode.pl
+ ____________________________________________________________________________
+ [ 10603] By: jhi on 2001/06/15 13:41:34
+ Log: Subject: Re: [PATCH} perlio and threading @ 10576 + report
+ From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+ Date: Fri, 15 Jun 2001 12:08:53 +0200
+ Message-Id: <20010615120320.F009.H.M.BRAND@hccnet.nl>
+ Branch: perl
+ ! perlio.c
+ ____________________________________________________________________________
+ [ 10602] By: jhi on 2001/06/15 13:27:04
+ Log: Subject: Re: [PATCH] opcode.pl is chmod'ing the original source tree
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Fri, 15 Jun 2001 14:11:49 +0100
+ Message-Id: <E15AtO9-0006Nd-00@draco.cus.cam.ac.uk>
+ Branch: perl
+ ! opcode.pl
+ ____________________________________________________________________________
+ [ 10601] By: jhi on 2001/06/15 13:21:18
+ Log: Subject: [PATCH ?] INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Thu, 14 Jun 2001 23:52:56 +0100
+ Message-ID: <20010614235256.G98663@plum.flirble.org>
+ Branch: perl
+ ! ext/Socket/Socket.pm ext/Socket/Socket.xs
+ ! lib/ExtUtils/Constant.pm t/lib/extutils.t
+ ____________________________________________________________________________
+ [ 10600] By: jhi on 2001/06/15 13:16:56
+ Log: Subject: Re: [PATCH] GDBM_File (wasRe: ext/ + -Wall)
+ From: Russ Allbery <rra@stanford.edu>
+ Date: 14 Jun 2001 13:24:43 -0700
+ Message-ID: <ylzobaizck.fsf@windlord.stanford.edu>
+ Branch: perl
+ ! ext/GDBM_File/GDBM_File.pm
+ ____________________________________________________________________________
+ [ 10599] By: jhi on 2001/06/15 13:15:26
+ Log: Subject: [PATCH] GDBM_File (wasRe: ext/ + -Wall)
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Thu, 14 Jun 2001 20:37:47 +0100
+ Message-ID: <20010614203747.F98663@plum.flirble.org>
+ Branch: perl
+ ! ext/GDBM_File/GDBM_File.pm ext/GDBM_File/GDBM_File.xs
+ ! t/lib/gdbm.t
+ ____________________________________________________________________________
+ [ 10598] By: jhi on 2001/06/15 13:13:13
+ Log: Integrate perlio.
+ Branch: perl
+ !> makedef.pl sv.c
+ ____________________________________________________________________________
+ [ 10597] By: nick on 2001/06/15 11:08:13
+ Log: Check that HVs with HvNAME() != NULL are really stashes before
+ treating them as such. Also be more defensive on the GvCV.
+ Win32 fork and dprof now working again.
+ Branch: perlio
+ ! sv.c
+ ____________________________________________________________________________
+ [ 10596] By: nick on 2001/06/15 10:11:20
+ Log: Integrate mainline.
+ Branch: perlio
+ +> Cross/README
+ !> Configure Makefile.SH Porting/Glossary Porting/config.sh
+ !> Porting/config_H config_h.SH configure.com epoc/config.sh
+ !> hints/linux.sh pod/perltoc.pod uconfig.h uconfig.sh
+ !> vos/config.alpha.def vos/config.alpha.h vos/config.ga.def
+ !> vos/config.ga.h win32/config.bc win32/config.gc
+ !> win32/config.vc win32/config_H.bc win32/config_H.gc
+ !> win32/config_H.vc
+ ____________________________________________________________________________
+ [ 10595] By: nick on 2001/06/15 09:37:17
+ Log: Skip Perl_my_bcopy in .def file as we do not provide it.
+ - Win32 (VC++) now builds but fails:
+ filefind.t - suspect Win32's builtin cwd is not doing insecure dir test
+ fork.t - No &___ENV_HV_NAME___::CLONE method ???
+ write.t - open(...,"|-") not implemented on Win32
+ Branch: perlio
+ ! makedef.pl
+ ____________________________________________________________________________
+ [ 10594] By: jhi on 2001/06/15 00:17:16
+ Log: Integrate perlio.
+ Branch: perl
+ !> perlio.c win32/makefile.mk
+ ____________________________________________________________________________
+ [ 10593] By: jhi on 2001/06/15 00:16:44
+ Log: Metaconfig unit changes for #10592.
+ Branch: metaconfig
+ + U/modified/i_varhdr.U U/modified/startsh.U
+ - U/a_dvisory/crosscompile.U U/target/Target.U
+ ! U/a_dvisory/intsize.U U/compline/alignbytes.U
+ ! U/compline/bitpbyte.U U/compline/byteorder.U
+ ! U/compline/ccflags.U U/compline/charsize.U
+ ! U/compline/d_casti32.U U/compline/d_castneg.U
+ ! U/compline/d_closedir.U U/compline/d_fd_set.U
+ ! U/compline/d_gconvert.U U/compline/d_gnulibc.U
+ ! U/compline/d_keepsig.U U/compline/d_open3.U
+ ! U/compline/d_safebcpy.U U/compline/d_safemcpy.U
+ ! U/compline/d_sanemcmp.U U/compline/d_scannl.U
+ ! U/compline/d_sgndchr.U U/compline/d_sigsetjmp.U
+ ! U/compline/d_stdstdio.U U/compline/d_vprintf.U
+ ! U/compline/doublesize.U U/compline/floatsize.U
+ ! U/compline/nblock_io.U U/compline/orderlib.U
+ ! U/compline/ptrsize.U U/compline/ssizetype.U U/ebcdic/ebcdic.U
+ ! U/modified/Cppsym.U U/modified/Oldconfig.U U/modified/Signal.U
+ ! U/modified/d_getpgrp.U U/modified/d_longdbl.U
+ ! U/modified/d_longlong.U U/modified/d_setpgrp.U
+ ! U/modified/d_strtoul.U U/modified/d_union_semun.U
+ ! U/modified/spitshell.U U/threads/archname.U
+ ! U/threads/d_pthreadj.U U/typedefs/gidsign.U
+ ! U/typedefs/gidsize.U U/typedefs/lseektype.U
+ ! U/typedefs/pidsign.U U/typedefs/pidsize.U
+ ! U/typedefs/sizesize.U U/typedefs/ssizesize.U
+ ! U/typedefs/uidsign.U U/typedefs/uidsize.U
+ Branch: metaconfig/U/perl
+ + Cross.U
+ ! d_dlsymun.U d_fcntl_can_lock.U d_modfl.U d_printfed.U
+ ! d_strtoll.U d_strtoull.U d_strtouq.U d_u32align.U dlsrc.U
+ ! fflushall.U fpossize.U gccvers.U i_db.U longdblfio.U
+ ! need_va_copy.U perlxv.U quadfio.U selectminbits.U
+ ! stdio_streams.U uselfs.U
+ ____________________________________________________________________________
+ [ 10592] By: jhi on 2001/06/15 00:15:52
+ Log: The first steps towards cross-compilation.
+
+ Abstract execution of compiled test executables with $run,
+ and abstract transfer of files with $to and $from.
+
+ Under cross-compilation the $run, $to, and $from will point
+ to appropriate wrapper scripts, by default ssh and scp,
+ but also rsh, rcp, and cp are supported. If not
+ cross-compiling, they will be set to '', ':', and ':',
+ respectively.
+
+ With these patches I was able to get Configure for
+ iPAQ ARM Linux on an Intel Linux about 95% right
+ (only a few tests failed to execute or they produced
+ incorrect results), and I was able to compile
+ a functional miniperl.
+
+ The symbol crosscompile renamed to be usecrosscompile,
+ the corresponding C symbol from CROSSCOMPILE to
+ USE_CROSS_COMPILE.
+ Branch: perl
+ ! Configure Cross/README Makefile.SH Porting/Glossary
+ ! Porting/config.sh Porting/config_H config_h.SH configure.com
+ ! epoc/config.sh hints/linux.sh pod/perltoc.pod uconfig.h
+ ! uconfig.sh vos/config.alpha.def vos/config.alpha.h
+ ! vos/config.ga.def vos/config.ga.h win32/config.bc
+ ! win32/config.gc win32/config.vc win32/config_H.bc
+ ! win32/config_H.gc win32/config_H.vc
+ ____________________________________________________________________________
+ [ 10591] By: nick on 2001/06/14 20:00:12
+ Log: Steps along the road toward Win32 building again.
+ Branch: perlio
+ ! perlio.c win32/makefile.mk
+ ____________________________________________________________________________
+ [ 10590] By: jhi on 2001/06/14 16:11:11
+ Log: Integrate perlio.
+ Branch: perl
+ !> win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ____________________________________________________________________________
+ [ 10589] By: nick on 2001/06/14 13:54:07
+ Log: Routine regen_config_h for Win32
+ Branch: perlio
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ____________________________________________________________________________
+ [ 10588] By: jhi on 2001/06/14 12:30:46
+ Log: Integrate perlio.
+ Branch: perl
+ +> perlyline.pl
+ !> MANIFEST Makefile.SH perly.c t/lib/filefind.t
+ ____________________________________________________________________________
+ [ 10587] By: jhi on 2001/06/14 12:23:24
+ Log: A placeholder.
+ Branch: perl
+ + Cross/README
+ ____________________________________________________________________________
+ [ 10586] By: nick on 2001/06/14 08:25:07
+ Log: Add new step to run_byacc which:
+ A. Corrects #line NNN "perly.c" lines so warnings etc. are trackable
+ B. Adds extra () to the two if (var = ...) constructs gcc -Wall winges about.
+ Branch: perlio
+ + perlyline.pl
+ ! MANIFEST Makefile.SH perly.c
+ ____________________________________________________________________________
+ [ 10585] By: nick on 2001/06/14 08:22:29
+ Log: Integrate mainline
+ Branch: perlio
+ +> locale.c numeric.c
+ !> Changes cygwin/Makefile.SHs embed.h embed.pl
+ !> ext/re/Makefile.PL lib/Math/BigFloat.pm lib/Math/BigInt.pm
+ !> objXSUB.h opcode.pl patchlevel.h perlapi.c pod/perlapi.pod
+ !> proto.h t/lib/bigfltpm.t t/lib/bigintpm.t util.c
+ !> x2p/Makefile.SH
+ ____________________________________________________________________________
+ [ 10584] By: nick on 2001/06/14 08:05:53
+ Log: Hack to remove insecure directories from PATH so test will run.
+ Branch: perlio
+ ! t/lib/filefind.t
+ ____________________________________________________________________________
+ [ 10583] By: jhi on 2001/06/14 03:11:16
+ Log: The test doesn't work (yet?), Math::BigInt::round_mode() is missing.
+ Branch: perl
+ - t/lib/mbimbf.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10582] By: jhi on 2001/06/14 03:04:51
+ Log: Detypo.
+ Branch: perl
+ ! x2p/Makefile.SH
+ ____________________________________________________________________________
+ [ 10581] By: jhi on 2001/06/14 03:03:14
+ Log: de-$CONFIG continues.
+ Branch: perl
+ ! cygwin/Makefile.SHs x2p/Makefile.SH
+ ____________________________________________________________________________
+ [ 10580] By: jhi on 2001/06/13 23:56:59
+ Log: Subject: [PATCH] opcode.pl is chmod'ing the original source tree
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Wed, 13 Jun 2001 21:20:13 +0100
+ Message-ID: <20010613212013.D98663@plum.flirble.org>
+ Branch: perl
+ ! opcode.pl
+ ____________________________________________________________________________
+ [ 10579] By: jhi on 2001/06/13 23:55:29
+ Log: Subject: splitting util.c
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Thu, 14 Jun 2001 00:41:08 +0100
+ Message-Id: <200106132341.AAA24935@crypt.compulink.co.uk>
+ Branch: perl
+ + locale.c numeric.c
+ ! MANIFEST Makefile.SH embed.h embed.pl objXSUB.h perlapi.c
+ ! pod/perlapi.pod proto.h util.c
+ ____________________________________________________________________________
+ [ 10578] By: jhi on 2001/06/13 23:45:11
+ Log: Upgrade to Math::BigInt 1.34 from Tels.
+ Branch: perl
+ + t/lib/mbimbf.t
+ ! MANIFEST lib/Math/BigFloat.pm lib/Math/BigInt.pm
+ ! t/lib/bigfltpm.t t/lib/bigintpm.t
+ ____________________________________________________________________________
+ [ 10577] By: nick on 2001/06/13 19:02:48
+ Log: Integrate mainline. Storable fail has gone, insecure dependancy still there.
+ Branch: perlio
+ !> (integrate 125 files)
+ ____________________________________________________________________________
+ [ 10576] By: jhi on 2001/06/13 18:10:01
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10575] By: jhi on 2001/06/13 18:05:09
+ Log: Subject: Re: [PATCH perl@10538] make ext/re play nice with DEBUGGING override
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Wed, 13 Jun 2001 13:24:28 -0500
+ Message-Id: <5.1.0.14.0.20010613131907.01bbc210@mail.mac.com>
+ Branch: perl
+ ! ext/re/Makefile.PL
+ ____________________________________________________________________________
+ [ 10574] By: jhi on 2001/06/13 17:34:36
+ Log: Mc.u.c. for #10573.
+ Branch: metaconfig
+ ! U/threads/usethreads.U
+ ____________________________________________________________________________
+ [ 10573] By: jhi on 2001/06/13 17:34:00
+ Log: It would be also be good if I could type.
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10572] By: jhi on 2001/06/13 17:26:29
+ Log: Metaconfig unit change for #10571.
+ Branch: metaconfig
+ ! U/threads/usethreads.U
+ ____________________________________________________________________________
+ [ 10571] By: jhi on 2001/06/13 17:26:05
+ Log: A non-empty default is a good thing.
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10570] By: jhi on 2001/06/13 17:15:16
+ Log: Metaconfig unit change for #10569.
+ Branch: metaconfig
+ ! U/threads/usethreads.U
+ ____________________________________________________________________________
+ [ 10569] By: jhi on 2001/06/13 17:14:17
+ Log: Add Configure directive -Dusereentrant for Artur's ithreads work,
+ extremely experimental, not even prompted for.
+ Branch: perl
+ ! Configure Porting/Glossary Porting/config.sh Porting/config_H
+ ! config_h.SH configure.com epoc/config.sh perl.h uconfig.h
+ ! uconfig.sh vos/config.alpha.def vos/config.ga.def
+ ! win32/config.bc win32/config.gc win32/config.vc
+ ____________________________________________________________________________
+ [ 10568] By: jhi on 2001/06/13 16:22:27
+ Log: FAQ tweak for Vanina Arca <varca@baufest.com>.
+ Branch: perl
+ ! pod/perlfaq6.pod
+ ____________________________________________________________________________
+ [ 10567] By: jhi on 2001/06/13 16:20:23
+ Log: Integrate perlio; conflicts, accept Nick's versions.
+ Branch: perl
+ !> ext/Encode/Encode.xs ext/PerlIO/Scalar/Scalar.xs
+ !> ext/PerlIO/Via/Via.xs perlio.c perlio.h perliol.h
+ ____________________________________________________________________________
+ [ 10566] By: jhi on 2001/06/13 16:17:42
+ Log: Subject: Re: ext/ + -Wall
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Wed, 13 Jun 2001 10:02:16 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0106130959050.24181-100000@mako.covalent.net>
+ Branch: perl
+ ! XSUB.h lib/ExtUtils/xsubpp perl.h
+ ____________________________________________________________________________
+ [ 10565] By: jhi on 2001/06/13 16:16:07
+ Log: Similar logic as DB_File.xs, using the modern macros and
+ defines them to older ones for older Perls where PERL_VERSION
+ is not defined, from Doug MacEachern.
+ Branch: perl
+ ! ext/Storable/Storable.xs
+ ____________________________________________________________________________
+ [ 10564] By: nick on 2001/06/13 15:22:01
+ Log: Avoid AV and HV in perlio.c by inventing PerlIO_list_t which is AV-ish
+ and using that instead (name lookups are sequential search for now).
+ Branch: perlio
+ ! ext/Encode/Encode.xs ext/PerlIO/Scalar/Scalar.xs
+ ! ext/PerlIO/Via/Via.xs perlio.c perlio.h perliol.h
+ ____________________________________________________________________________
+ [ 10563] By: jhi on 2001/06/13 14:07:43
+ Log: Subject: [PATCH] Re: [ID 20010526.001] localized glob loses value when assigned to
+ From: "Richard Soderberg" <rs@crystalflame.net>
+ Date: Sat, 26 May 2001 06:44:20 -0700
+ Message-ID: <NAEKLNAAHLMBPMPNBMLECECHDFAA.rs@crystalflame.net>
+ Branch: perl
+ ! sv.c t/op/glob.t
+ ____________________________________________________________________________
+ [ 10562] By: jhi on 2001/06/13 13:55:10
+ Log: Subject: [PATCH perl@10538] make ext/re play nice with DEBUGGING override
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Tue, 12 Jun 2001 23:55:26 -0500
+ Message-Id: <a05101002b74ca0013cf5@[192.168.56.160]>
+ Branch: perl
+ ! ext/re/Makefile.PL ext/re/re.xs
+ ____________________________________________________________________________
+ [ 10561] By: jhi on 2001/06/13 13:44:58
+ Log: Hide __attribute__((unused)) behind PERL_UNUSED_DECL as
+ suggested by NI-S.
+ Branch: perl
+ ! XSUB.h malloc.c perl.h
+ ____________________________________________________________________________
+ [ 10560] By: jhi on 2001/06/13 13:35:42
+ Log: Regen toc.
+ Branch: perl
+ ! pod/perltoc.pod
+ ____________________________________________________________________________
+ [ 10559] By: jhi on 2001/06/13 12:53:18
+ Log: Subject: [patch] perl.gprof control
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Tue, 12 Jun 2001 23:05:44 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0106122247380.24181-100000@mako.covalent.net>
+ Branch: perl
+ ! miniperlmain.c perl.h
+ ____________________________________________________________________________
+ [ 10558] By: jhi on 2001/06/13 12:51:47
+ Log: Subject: Re: ext/ + -Wall
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Tue, 12 Jun 2001 22:04:50 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0106122151180.24181-100000@mako.covalent.net>
+
+ Document ax and break up dXSARGS.
+ Branch: perl
+ ! XSUB.h pod/perlapi.pod
+ ____________________________________________________________________________
+ [ 10557] By: jhi on 2001/06/13 12:39:55
+ Log: More AIX tweakage from Merijn.
+ Branch: perl
+ ! hints/aix.sh
+ ____________________________________________________________________________
+ [ 10556] By: jhi on 2001/06/13 03:26:58
+ Log: Subject: [PATCH perl@10538] make VMS autosplit earlier in build
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Tue, 12 Jun 2001 22:57:45 -0500
+ Message-Id: <a05101001b74c943d7af4@[192.168.56.160]>
+ Branch: perl
+ ! vms/descrip_mms.template
+ ____________________________________________________________________________
+ [ 10555] By: jhi on 2001/06/13 02:50:43
+ Log: Subject: Re: hacking util.c, attrs.xs, and re.xs to compile on VMS
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Tue, 12 Jun 2001 22:21:39 -0500
+ Message-Id: <a05101000b74c8698483b@[172.16.52.1]>
+ Branch: perl
+ ! configure.com util.c
+ ____________________________________________________________________________
+ [ 10554] By: jhi on 2001/06/13 02:23:16
+ Log: New AIX dynaloading code from Jens-Uwe Mager.
+ Does break binary compatibility.
+ Branch: perl
+ ! ext/DynaLoader/dl_aix.xs hints/aix.sh makedef.pl
+ ____________________________________________________________________________
+ [ 10553] By: jhi on 2001/06/13 02:10:16
+ Log: VMS DEC C compiler found nits by Peter Prymmer.
+ Branch: perl
+ ! util.c
+ ____________________________________________________________________________
+ [ 10552] By: jhi on 2001/06/13 01:36:12
+ Log: Subject: [PATCH: perl@10538] fix for file locking and filecomp test
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Tue, 12 Jun 2001 19:34:08 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10106121927580.15174-100000@aspara.forte.com>
+ Branch: perl
+ ! t/lib/filecomp.t
+ ____________________________________________________________________________
+ [ 10551] By: jhi on 2001/06/13 01:26:53
+ Log: I wonder how many $CONFIGs still lurk in the shadows.
+ Branch: perl
+ ! pod/Makefile.SH x2p/cflags.SH
+ ____________________________________________________________________________
+ [ 10550] By: jhi on 2001/06/13 01:25:12
+ Log: Grok three kinds of line endings, should fix [ID 20010612.003]
+ Branch: perl
+ ! pod/checkpods.PL
+ ____________________________________________________________________________
+ [ 10549] By: jhi on 2001/06/13 01:05:28
+ Log: Use __attribute__((unused)) to silence -Wall on unused ax.
+ Branch: perl
+ ! XSUB.h ext/DB_File/DB_File.xs lib/ExtUtils/xsubpp
+ ____________________________________________________________________________
+ [ 10548] By: jhi on 2001/06/13 00:41:28
+ Log: Subject: [patch] rid local_patches warnings
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Tue, 12 Jun 2001 10:26:34 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0106121024470.24181-100000@mako.covalent.net>
+ Branch: perl
+ ! ext/List/Util/Util.xs ext/Storable/Storable.xs
+ ____________________________________________________________________________
+ [ 10547] By: jhi on 2001/06/13 00:40:29
+ Log: Subject: Re: ext/ + -Wall
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Tue, 12 Jun 2001 09:38:09 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0106120927100.24181-100000@mako.covalent.net>
+ Branch: perl
+ ! ext/attrs/attrs.xs
+ ____________________________________________________________________________
+ [ 10546] By: jhi on 2001/06/13 00:39:06
+ Log: Subject: [PATCH] perlretut.pod: unterminated C<>
+ From: Ronald J Kimball <rjk@linguist.Thayer.dartmouth.edu>
+ Date: Tue, 12 Jun 2001 14:36:20 -0400
+ Message-ID: <20010612143619.A37113@linguist.thayer.dartmouth.edu>
+ Branch: perl
+ ! pod/perlretut.pod
+ ____________________________________________________________________________
+ [ 10545] By: jhi on 2001/06/13 00:38:02
+ Log: Subject: Re: [ID 20010612.001] out of memory during regex compilation
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Tue, 12 Jun 2001 19:10:31 +0100
+ Message-Id: <E159scZ-0000r2-00@draco.cus.cam.ac.uk>
+
+ Subject: Re: [ID 20010612.001] out of memory during regex compilation
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Tue, 12 Jun 2001 19:21:01 +0100
+ Message-Id: <E159smj-0000wY-00@draco.cus.cam.ac.uk>
+ Branch: perl
+ ! pod/perlop.pod
+ ____________________________________________________________________________
+ [ 10544] By: jhi on 2001/06/13 00:34:39
+ Log: AIX tweaks from Merijn H. Brand.
+ Branch: perl
+ ! hints/aix.sh
+ ____________________________________________________________________________
+ [ 10543] By: jhi on 2001/06/13 00:11:42
+ Log: Subject: [PATCH] 5.6.1 -- add LC_MESSAGES constant to POSIX module
+ From: "Brendan O'Dea" <bod@compusol.com.au>
+ Date: Wed, 13 Jun 2001 05:16:47 +1000
+ Message-ID: <20010613051647.A8945@compusol.com.au>
+ Branch: maint-5.6/perl
+ ! ext/POSIX/POSIX.pm ext/POSIX/POSIX.xs
+ ____________________________________________________________________________
+ [ 10542] By: jhi on 2001/06/13 00:07:50
+ Log: Subject: Small bcopy cleanup
+ From: Andy Dougherty <doughera@lafayette.edu>
+ Date: Tue, 12 Jun 2001 17:11:52 -0400 (EDT)
+ Message-ID: <Pine.SOL.4.10.10106121706360.11034-100000@maxwell.phys.lafayette.edu>
+ Branch: perl
+ ! embed.h embed.pl objXSUB.h perlapi.c proto.h util.c x2p/a2p.h
+ ____________________________________________________________________________
+ [ 10541] By: jhi on 2001/06/13 00:05:18
+ Log: Subject: [PATCH] Re: ext/ + -Wall
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Wed, 13 Jun 2001 00:04:30 +0100
+ Message-ID: <20010613000430.M5901@plum.flirble.org>
+ Branch: perl
+ ! ext/POSIX/POSIX.pm ext/POSIX/POSIX.xs
+ ____________________________________________________________________________
+ [ 10540] By: jhi on 2001/06/13 00:02:25
+ Log: Subject: [PATCH] Re: [PATCH] ExtUtils::Constant
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Tue, 12 Jun 2001 23:53:07 +0100
+ Message-ID: <20010612235307.L5901@plum.flirble.org>
+ Branch: perl
+ ! lib/ExtUtils/Constant.pm t/lib/extutils.t
+ ____________________________________________________________________________
+ [ 10539] By: jhi on 2001/06/12 23:59:10
+ Log: MPE/iX tweaks from Mark Bixby.
+ Branch: perl
+ ! hints/mpeix.sh mpeix/mpeixish.h util.c
+ ____________________________________________________________________________
+ [ 10538] By: jhi on 2001/06/12 14:16:15
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10537] By: jhi on 2001/06/12 14:11:26
+ Log: One less -Wall whine (found under DEBUGGING).
+ Branch: perl
+ ! x2p/Makefile.SH x2p/a2p.c
+ ____________________________________________________________________________
+ [ 10536] By: jhi on 2001/06/12 13:32:09
+ Log: s/case-independent/case-insensitive/g
+ Branch: perl
+ ! pod/perldebug.pod
+ ____________________________________________________________________________
+ [ 10535] By: jhi on 2001/06/12 13:27:28
+ Log: As suggested in
+
+ Subject: Re: ext/ + -Wall
+ From: Gurusamy Sarathy <gsar@ActiveState.com>
+ Date: Mon, 11 Jun 2001 23:34:31 -0700
+ Message-Id: <200106120634.f5C6YVM07246@smtp3.ActiveState.com>
+ Branch: perl
+ ! ext/PerlIO/Scalar/Scalar.xs ext/PerlIO/Via/Via.xs globals.c
+ ! perl.h
+ ____________________________________________________________________________
+ [ 10534] By: jhi on 2001/06/12 13:13:27
+ Log: Subject: ext/ + -Wall
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Mon, 11 Jun 2001 22:19:45 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0106112212261.24181-100000@mako.covalent.net>
+ Branch: perl
+ ! ext/ByteLoader/ByteLoader.xs ext/DB_File/DB_File.xs
+ ! ext/DB_File/version.c ext/Devel/DProf/DProf.xs
+ ! ext/DynaLoader/dl_dlopen.xs ext/DynaLoader/dlutils.c
+ ! ext/Encode/Encode.xs ext/File/Glob/bsd_glob.c
+ ! ext/Filter/Util/Call/Call.xs ext/GDBM_File/GDBM_File.xs
+ ! ext/List/Util/Util.xs ext/MIME/Base64/Base64.xs
+ ! ext/POSIX/POSIX.xs ext/PerlIO/Scalar/Scalar.xs
+ ! ext/PerlIO/Via/Via.xs ext/Time/HiRes/HiRes.xs
+ ! ext/Time/Piece/Piece.xs ext/attrs/attrs.xs globals.c
+ ! lib/ExtUtils/xsubpp
+ ____________________________________________________________________________
+ [ 10533] By: jhi on 2001/06/12 12:52:57
+ Log: Subject: [PATCH] anonymous stashes
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Tue, 12 Jun 2001 12:47:04 +0530
+ Message-ID: <20010612124704.A29029@lustre.linux.in>
+ Branch: perl
+ ! dump.c gv.c sv.c xsutils.c
+ ____________________________________________________________________________
+ [ 10532] By: jhi on 2001/06/12 12:37:36
+ Log: One more test for $^S.
+ Branch: perl
+ ! t/op/magic.t
+ ____________________________________________________________________________
+ [ 10531] By: jhi on 2001/06/12 12:35:02
+ Log: Subject: [PATCH 20010612.002] $^S almost entirely broken with 5.6.1
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Tue, 12 Jun 2001 17:35:55 +0530
+ Message-ID: <20010612173555.A32426@lustre.linux.in>
+ Branch: perl
+ ! mg.c t/op/magic.t
+ ____________________________________________________________________________
+ [ 10530] By: jhi on 2001/06/12 12:31:11
+ Log: Subject: Re: [ID 20010612.001] out of memory during regex compilation
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Tue, 12 Jun 2001 13:14:15 +0100
+ Message-Id: <E159n3n-0000xa-00@draco.cus.cam.ac.uk>
+ Branch: perl
+ ! pod/perlop.pod
+ ____________________________________________________________________________
+ [ 10529] By: jhi on 2001/06/12 12:21:06
+ Log: AUTHORS updates.
+ Branch: perl
+ ! AUTHORS
+ ____________________________________________________________________________
+ [ 10528] By: jhi on 2001/06/12 12:19:47
+ Log: Subject: [PATCH] rhapsody/darwin minor cleanup
+ From: Wilfredo Sanchez <wsanchez@MIT.EDU>
+ Content-Transfer-Encoding: 7bit
+ Message-Id: <200106121009.GAA01968@melbourne-city-street.mit.edu>
+ Branch: perl
+ ! Makefile.SH hints/darwin.sh hints/rhapsody.sh
+ ____________________________________________________________________________
+ [ 10527] By: jhi on 2001/06/12 11:58:53
+ Log: Subject: [MacPerl-Porters] Re: [PATCH] Mac OS Compatability for bleadperl
+ From: "Philip Newton" <Philip.Newton@gmx.net>
+ Date: Mon, 11 Jun 2001 07:08:03 +0200
+ Message-Id: <200106120802.LAA08992@taas.iki.fi>
+ Branch: perl
+ ! t/base/term.t
+ ____________________________________________________________________________
+ [ 10526] By: jhi on 2001/06/12 01:35:34
+ Log: Cleanup the a2p.c for -Wall.
+ Branch: perl
+ ! x2p/Makefile.SH x2p/a2p.c
+ ____________________________________________________________________________
+ [ 10525] By: jhi on 2001/06/12 01:10:56
+ Log: File::Find update for MacOS from Chris Nandor.
+ Branch: perl
+ ! lib/File/Find.pm t/lib/filefind.t
+ ____________________________________________________________________________
+ [ 10524] By: jhi on 2001/06/12 00:29:20
+ Log: gcc -Wall nits picked out by a non-UNIX system
+ (courtesy of Mark Bixby)
+ Branch: perl
+ ! doio.c ext/Devel/Peek/Peek.xs ext/DynaLoader/dl_mpeix.xs
+ ! ext/IO/IO.xs ext/PerlIO/Via/Via.xs ext/Socket/Socket.xs
+ ! pp_sys.c util.c
+ ____________________________________________________________________________
+ [ 10523] By: jhi on 2001/06/11 22:34:03
+ Log: Metaconfig unit change for #10522. (The d_modfl changes
+ placate metalint.)
+ Branch: metaconfig/U/perl
+ ! d_modfl.U d_u32align.U
+ ____________________________________________________________________________
+ [ 10522] By: jhi on 2001/06/11 22:33:00
+ Log: Buglet found by Mark Bixby: "./try >&2 >/dev/null" should
+ be "./try 2>&1 >/dev/null".
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10521] By: jhi on 2001/06/11 19:49:54
+ Log: Subject: [PATCH perl@10517] DCL quoting syntax drives pumpking mad
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Mon, 11 Jun 2001 14:00:32 -0500
+ Message-Id: <5.1.0.14.0.20010611134750.03985cb8@exchi01>
+ Branch: perl
+ ! configure.com
+ ____________________________________________________________________________
+ [ 10520] By: jhi on 2001/06/11 17:55:47
+ Log: Move the full \p\P lists to perlunicode.
+ Branch: perl
+ ! pod/perlretut.pod pod/perlunicode.pod
+ ____________________________________________________________________________
+ [ 10519] By: jhi on 2001/06/11 17:10:00
+ Log: VOS build tweak for 5.6.1 from Paul Green.
+ Branch: maint-5.6/perl
+ ! vos/build.cm
+ ____________________________________________________________________________
+ [ 10518] By: jhi on 2001/06/11 17:07:03
+ Log: Subject: [PATCH perl@10476] no PerlIO at startup time on VMS
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Fri, 8 Jun 2001 18:08:18 -0500
+ Message-Id: <a05101000b746f9dd4fca@[192.168.56.145]>
+ Branch: perl
+ ! vms/vms.c
+ ____________________________________________________________________________
+ [ 10517] By: jhi on 2001/06/11 14:52:01
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10516] By: jhi on 2001/06/11 14:46:33
+ Log: Add the modfl_pow32_bug (anti)definition also to VOS headers.
+ Branch: perl
+ ! vos/config.alpha.h vos/config.ga.h
+ ____________________________________________________________________________
+ [ 10515] By: jhi on 2001/06/11 14:39:05
+ Log: VOS updates from Paul Green for @10476.
+ Branch: perl
+ ! README.vos vos/Changes vos/build.cm vos/compile_perl.cm
+ ! vos/config.alpha.def vos/config.alpha.h vos/config.ga.def
+ ! vos/config.ga.h vos/configure_perl.cm
+ ____________________________________________________________________________
+ [ 10514] By: jhi on 2001/06/11 12:58:43
+ Log: Subject: [PATCH] Not many people know this ...
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Mon, 11 Jun 2001 14:55:15 +0100
+ Message-Id: <E159S9z-00015D-00@draco.cus.cam.ac.uk>
+ Branch: perl
+ ! pod/perldebug.pod
+ ____________________________________________________________________________
+ [ 10513] By: jhi on 2001/06/11 12:30:06
+ Log: Add final commas to lists as suggested by Philip Newton.
+ Branch: perl
+ ! lib/ExtUtils/Constant.pm t/lib/extutils.t
+ ____________________________________________________________________________
+ [ 10512] By: jhi on 2001/06/11 12:28:49
+ Log: Subject: [MacPerl-Porters] [PATCH] Mac OS Compatability for bleadperl
+ Date: Sun, 10 Jun 2001 23:35:38 -0400
+ From: Chris Nandor <pudge@pobox.com>
+ Message-Id: <p05100306b749ec0eaade@[10.0.1.177]>
+ Branch: perl
+ ! lib/DirHandle.pm lib/File/Basename.pm lib/diagnostics.pm
+ ! perl.c t/base/term.t t/comp/cpp.t t/comp/multiline.t
+ ! t/comp/script.t t/lib/anydbm.t t/lib/autoloader.t
+ ! t/lib/dirhand.t t/lib/selfloader.t t/op/anonsub.t
+ ! t/op/closure.t t/op/defins.t t/op/exec.t t/op/goto.t
+ ! t/op/pack.t t/op/regexp.t t/op/regexp_noamp.t t/op/split.t
+ ! t/op/write.t t/pragma/strict.t
+ ____________________________________________________________________________
+ [ 10511] By: jhi on 2001/06/11 12:13:31
+ Log: Subject: [RESEND] [PATCH] Mac OS lib patches for bleadperl
+ From: Chris Nandor <pudge@pobox.com>
+ Date: Mon, 11 Jun 2001 08:24:28 -0400
+ Message-Id: <p05100303b74a66faf625@[10.0.1.177]>
+ Branch: perl
+ ! ext/IO/lib/IO/Dir.pm lib/File/Copy.pm t/lib/filecopy.t
+ ! t/lib/io_dir.t
+ ____________________________________________________________________________
+ [ 10510] By: jhi on 2001/06/11 12:03:16
+ Log: One more run_byacc (a hand-tweaked version had slipped in).
+ Branch: perl
+ ! perly.c vms/perly_c.vms
+ ____________________________________________________________________________
+ [ 10509] By: nick on 2001/06/11 07:49:15
+ Log: Integrate mainline
+ Branch: perlio
+ !> Makefile.SH embed.h embed.pl global.sym
+ !> lib/ExtUtils/Constant.pm lib/ExtUtils/Manifest.pm objXSUB.h
+ !> perl.h perlapi.c perlapi.h perly.c perly.fixer perly.h perly.y
+ !> perly_c.diff pod/perl572delta.pod pod/perlapi.pod proto.h sv.c
+ !> t/lib/extutils.t util.c vms/perly_c.vms vms/perly_h.vms
+ ____________________________________________________________________________
+ [ 10508] By: jhi on 2001/06/10 22:38:05
+ Log: Subject: [PATCH] ExtUtils::Manifest not -w clean
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Reply-To: mjtg@cam.ac.uk
+ Message-Id: <E159Ei8-0006Tz-00@draco.cus.cam.ac.uk>
+ Branch: perl
+ ! lib/ExtUtils/Manifest.pm
+ ____________________________________________________________________________
+ [ 10507] By: jhi on 2001/06/10 22:37:16
+ Log: Subject: [PATCH] ExtUtils::Constant
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Sun, 10 Jun 2001 23:25:41 +0100
+ Message-ID: <20010610232540.C76396@plum.flirble.org>
+ Branch: perl
+ ! lib/ExtUtils/Constant.pm t/lib/extutils.t
+ ____________________________________________________________________________
+ [ 10506] By: jhi on 2001/06/10 20:57:20
+ Log: Integrate perlio.
+ Branch: perl
+ !> iperlsys.h
+ ____________________________________________________________________________
+ [ 10505] By: jhi on 2001/06/10 18:37:57
+ Log: Move the grok_number and its lieutenant grok_numeric_radix
+ from sv.c statics to util.c and public.
+ Branch: perl
+ ! embed.h embed.pl global.sym objXSUB.h perl.h perlapi.c
+ ! perlapi.h pod/perlapi.pod proto.h sv.c util.c
+ ____________________________________________________________________________
+ [ 10504] By: nick on 2001/06/10 17:47:06
+ Log: Fix (valid) -Wall warnings in perlio.c
+ Branch: perlio
+ ! iperlsys.h
+ ____________________________________________________________________________
+ [ 10503] By: jhi on 2001/06/10 17:38:28
+ Log: Update perly_c.diff, update perly.fixer to edit away
+ some of the -Wall noise.
+ Branch: perl
+ ! perly.c perly.fixer perly_c.diff vms/perly_c.vms
+ ____________________________________________________________________________
+ [ 10502] By: jhi on 2001/06/10 17:09:42
+ Log: Check the version of byacc.
+ Branch: perl
+ ! Makefile.SH
+ ____________________________________________________________________________
+ [ 10501] By: jhi on 2001/06/10 17:00:08
+ Log: Subject: [PATCH] perly.y overhaul
+ From: Simon Cozens <simon@netthink.co.uk>
+ Date: Sun, 10 Jun 2001 16:56:54 +0100
+ Message-ID: <20010610165654.A16597@deep-dark-truthful-mirror.pmb.ox.ac.uk>
+
+ Plus make run_byacc.
+ Branch: perl
+ ! perly.c perly.h perly.y vms/perly_c.vms vms/perly_h.vms
+ ____________________________________________________________________________
+ [ 10500] By: jhi on 2001/06/10 16:07:28
+ Log: Integrate perlio.
+ Branch: perl
+ !> perlio.c perlsfio.h
+ ____________________________________________________________________________
+ [ 10499] By: nick on 2001/06/10 15:01:08
+ Log: Integrate mainline
+ Branch: perlio
+ !> Changes Configure embed.h embed.pl patchlevel.h proto.h sv.c
+ !> t/pragma/locale.t util.c
+ ____________________________________________________________________________
+ [ 10498] By: jhi on 2001/06/10 13:49:23
+ Log: Put some meat on the perl572delta bones. The list of
+ selected bug fixes needs more work, as does still the
+ whole document.
+ Branch: perl
+ ! pod/perl572delta.pod
+ ____________________________________________________________________________
+ [ 10497] By: nick on 2001/06/10 12:27:51
+ Log: Paper over a crack or two with USE_SFIO
+ Branch: perlio
+ ! perlio.c perlsfio.h
+ ____________________________________________________________________________
+ [ 10496] By: jhi on 2001/06/10 11:04:22
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10495] By: jhi on 2001/06/10 10:55:34
+ Log: Subject: Re: pragma/locale.t #107
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Sun, 10 Jun 2001 11:23:30 +0100
+ Message-Id: <200106101023.LAA32085@crypt.compulink.co.uk>
+
+ Encapsulate the scan of the decimal radix separator.
+ Branch: perl
+ ! embed.h embed.pl proto.h sv.c
+ ____________________________________________________________________________
+ [ 10494] By: jhi on 2001/06/10 03:00:17
+ Log: Try to grok numbers both with the locale specific separator
+ and with the usual "." (if different from the lss); add a test
+ to locale.t to do also a little bit of math in addition to just
+ equalness testing; remove extraneous logic as suggested in
+
+ Subject: Re: pragma/locale.t #107
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Sat, 9 Jun 2001 22:37:36 +0100
+ Message-ID: <20010609223735.Y76396@plum.flirble.org>
+ Branch: perl
+ ! sv.c t/pragma/locale.t
+ ____________________________________________________________________________
+ [ 10493] By: jhi on 2001/06/10 01:25:23
+ Log: Metaconfig unit change for #10492.
+ Branch: metaconfig/U/perl
+ ! Extensions.U
+ ____________________________________________________________________________
+ [ 10492] By: jhi on 2001/06/10 01:23:59
+ Log: Subject: [PATCH] Don't build Thread.pm if USEITHREADS
+ From: Artur Bergman <artur@contiller.se>
+ Date: Sat, 09 Jun 2001 21:03:51 +0200
+ Message-ID: <B7483FB6.1398%artur@contiller.se>
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10491] By: jhi on 2001/06/10 01:15:40
+ Log: Integrate perlio.
+ Branch: perl
+ !> perlsfio.h
+ ____________________________________________________________________________
+ [ 10490] By: jhi on 2001/06/10 01:08:26
+ Log: Do locale specific separator if only in locale.
+ Branch: perl
+ ! util.c
+ ____________________________________________________________________________
+ [ 10489] By: nick on 2001/06/09 19:13:25
+ Log: Make XS/Typemap compile (but fail) with sfio
+ Branch: perlio
+ ! perlsfio.h
+ ____________________________________________________________________________
+ [ 10488] By: nick on 2001/06/09 19:12:51
+ Log: Re-integrate mainline
+ Branch: perlio
+ !> embed.h embed.pl embedvar.h intrpvar.h perl.h perlapi.h
+ !> proto.h sv.c util.c
+ ____________________________________________________________________________
+ [ 10487] By: nick on 2001/06/09 16:26:29
+ Log: Integrate mainline
+ Branch: perlio
+ !> (integrate 31 files)
+ ____________________________________________________________________________
+ [ 10486] By: jhi on 2001/06/09 16:11:51
+ Log: Subject: [PATCH] New attempt to clone callack
+ From: Artur Bergman <artur@contiller.se>
+ Date: Thu, 07 Jun 2001 11:52:16 +0200
+ Message-ID: <B7451B6F.12B7%artur@contiller.se>
+ Branch: perl
+ ! embedvar.h intrpvar.h perlapi.h sv.c
+ ____________________________________________________________________________
+ [ 10485] By: jhi on 2001/06/09 15:23:52
+ Log: Numeric conversion tweaks suggested by Hugo and Nicholas.
+ Branch: perl
+ ! embed.h embed.pl perl.h proto.h sv.c util.c
+ ____________________________________________________________________________
+ [ 10484] By: jhi on 2001/06/09 14:47:25
+ Log: Subject: Re: pragma/locale.t #107
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Sat, 9 Jun 2001 16:26:10 +0100
+ Message-ID: <20010609162609.V76396@plum.flirble.org>
+
+ A missing NVification.
+ Branch: perl
+ ! sv.c
+ ____________________________________________________________________________
+ [ 10483] By: jhi on 2001/06/08 19:40:32
+ Log: Redo the #10482, there already was a test script for formats.
+ Branch: perl
+ - t/io/format.t
+ ! MANIFEST t/op/write.t
+ ____________________________________________________________________________
+ [ 10482] By: jhi on 2001/06/08 19:34:45
+ Log: Twisted format testing, from Merijn.
+ Branch: perl
+ + t/io/format.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10481] By: jhi on 2001/06/08 19:21:56
+ Log: More \p{In...} testing, combined with \N{...}.
+ Branch: perl
+ ! lib/utf8_heavy.pl t/op/pat.t
+ ____________________________________________________________________________
+ [ 10480] By: jhi on 2001/06/08 14:16:06
+ Log: Metaconfig changes for #10479.
+ Branch: metaconfig
+ ! U/Glossary.patch
+ Branch: metaconfig/U/perl
+ ! d_modfl.U
+ ____________________________________________________________________________
+ [ 10479] By: jhi on 2001/06/08 14:15:32
+ Log: Be inspired more by Hugo-- introduce HAS_MODFL_POW32_BUG.
+ Branch: perl
+ ! Configure Porting/Glossary Porting/config.sh Porting/config_H
+ ! config_h.SH configure.com epoc/config.sh pp.c uconfig.h
+ ! uconfig.sh vos/config.alpha.def vos/config.ga.def
+ ! win32/config.bc win32/config.gc win32/config.vc
+ ____________________________________________________________________________
+ [ 10478] By: jhi on 2001/06/08 12:20:41
+ Log: Subject: Re: [PATCH perl@10439] fix old $^S description in perlvms.pod
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Thu, 7 Jun 2001 14:27:20 -0500
+ Message-Id: <a05100e01b7458075db7d@[172.16.52.1]>
+ Branch: perl
+ ! vms/perlvms.pod
+ ____________________________________________________________________________
+ [ 10477] By: jhi on 2001/06/08 12:19:00
+ Log: Subject: [PATCH] Unresolved symbol in ext/re/re.xs
+ From: Gisle Aas <gisle@ActiveState.com>
+ Date: 07 Jun 2001 17:04:29 -0700
+ Message-ID: <lrae3jsupe.fsf@caliper.ActiveState.com>
+ Branch: perl
+ ! ext/re/re.xs
+ ____________________________________________________________________________
+ [ 10476] By: jhi on 2001/06/08 01:35:42
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10475] By: jhi on 2001/06/08 00:53:45
+ Log: Regen Glossary et alia.
+ Branch: perl
+ ! Porting/Glossary Porting/config.sh Porting/config_H
+ ____________________________________________________________________________
+ [ 10474] By: jhi on 2001/06/07 22:06:38
+ Log: Metaconfig unit changes for #10473.
+ Branch: metaconfig/U/perl
+ ! d_modfl.U
+ ____________________________________________________________________________
+ [ 10473] By: jhi on 2001/06/07 22:06:16
+ Log: Harumph, also AIX will spill its guts (i.e. dump core)
+ if an executable contains modfl() but it hasn't been
+ compiled right (in the case of AIX, with cc -qlongdouble).
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10472] By: gsar on 2001/06/07 20:04:28
+ Log: integrate change#10471 from mainline
+
+ in change#10451, check that CvOUTSIDE is a CV before looking in
+ (it can apparently be SVt_NULL during global destruction)
+ Branch: maint-5.6/perl
+ !> op.c
+ ____________________________________________________________________________
+ [ 10471] By: gsar on 2001/06/07 20:01:31
+ Log: in change#10451, check that CvOUTSIDE is a CV before looking in
+ (it can apparently be SVt_NULL during global destruction)
+ Branch: perl
+ ! op.c
+ ____________________________________________________________________________
+ [ 10470] By: jhi on 2001/06/07 12:17:51
+ Log: Subject: Re: [PATCH perl@10439] diagnostics and long C<=item>s
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Date: Thu, 7 Jun 2001 13:01:06 +0100 (BST)
+ Message-Id: <200106071201.NAA13627@tempest.npl.co.uk>
+ Branch: perl
+ ! lib/diagnostics.pm pod/perldiag.pod
+ ____________________________________________________________________________
+ [ 10469] By: jhi on 2001/06/07 12:16:12
+ Log: Subject: [PATCH perl@10439] long =item
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Date: Thu, 7 Jun 2001 12:34:08 +0100 (BST)
+ Message-Id: <200106071134.MAA10288@tempest.npl.co.uk>
+ Branch: perl
+ ! README.amiga lib/Attribute/Handlers.pm
+ ! lib/ExtUtils/Constant.pm lib/Locale/Maketext.pod
+ ____________________________________________________________________________
+ [ 10468] By: jhi on 2001/06/07 12:08:56
+ Log: Subject: [PATCH 5.7.1 pod/perlguts.pod] IOK vs pIOK docs
+ Date: Thu, 7 Jun 2001 10:09:59 +0100 (BST)
+ Reply-To: Dave Mitchell <davem@fdgroup.co.uk>
+ Message-Id: <200106070909.KAA25610@gizmo.fdgroup.co.uk>
+ Branch: perl
+ ! pod/perlguts.pod
+ ____________________________________________________________________________
+ [ 10467] By: jhi on 2001/06/07 12:04:26
+ Log: Integrate perlio.
+ Branch: perl
+ !> sv.c
+ ____________________________________________________________________________
+ [ 10466] By: nick on 2001/06/07 10:25:40
+ Log: MULTIPLICITY fix for S_grok_number(), also a few gratuitious trailing
+ whitespace tweaks.
+ Still coredumps in pragma/overload.t - what a nice hard fail that is...
+ Branch: perlio
+ ! sv.c
+ ____________________________________________________________________________
+ [ 10465] By: nick on 2001/06/07 08:41:58
+ Log: Raw integrate of mainline for S_grok_number debug
+ (sv.c has MULTIPLICITY issues as well as whatever else ...)
+ Branch: perlio
+ - plan9/perlplan9.doc plan9/perlplan9.pod
+ !> (integrate 46 files)
+ ____________________________________________________________________________
+ [ 10464] By: jhi on 2001/06/06 23:33:58
+ Log: The proper prototyping for #10463.
+ Branch: perl
+ ! embed.h embed.pl proto.h sv.c
+ ____________________________________________________________________________
+ [ 10463] By: jhi on 2001/06/06 23:15:30
+ Log: Subject: Re: [PATCH] nuke strtol (was Re: One fix for strtoul not setting errno)
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Thu, 7 Jun 2001 00:29:59 +0100
+ Message-ID: <20010607002959.Z76396@plum.flirble.org>
+ Branch: perl
+ ! sv.c
+ ____________________________________________________________________________
+ [ 10462] By: jhi on 2001/06/06 23:13:19
+ Log: Subject: [PATCH perl@10439] fix old $^S description in perlvms.pod
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Wed, 06 Jun 2001 17:54:30 -0500
+ Message-Id: <5.1.0.14.0.20010606174814.03c2c880@exchi01>
+ Branch: perl
+ ! vms/perlvms.pod
+ ____________________________________________________________________________
+ [ 10461] By: jhi on 2001/06/06 23:10:00
+ Log: Podify the remaining README.platform files;
+ merge README.plan9 and plan9/perlplan9.pod;
+ delete plan9/perlplan9.* (the perlplan.doc needs to
+ be regenerated in Plan 9); make the =head1 and =head2
+ in the README.platform to be a little more verbose
+ (skipped README.os2 not to anger Ilya) so that they
+ look better in the toc; regen toc.
+ Branch: perl
+ - plan9/perlplan9.doc plan9/perlplan9.pod
+ ! MANIFEST README.aix README.amiga README.apollo README.beos
+ ! README.bs2000 README.cygwin README.dgux README.dos README.epoc
+ ! README.hpux README.hurd README.machten README.macos
+ ! README.micro README.mint README.mpeix README.os390
+ ! README.plan9 README.qnx README.solaris README.threads
+ ! README.tru64 README.vmesa README.vms README.vos README.win32
+ ! plan9/mkfile pod/buildtoc.PL pod/perl.pod pod/perlport.pod
+ ! pod/perltoc.pod win32/Makefile win32/makefile.mk
+ ____________________________________________________________________________
+ [ 10460] By: jhi on 2001/06/06 20:58:53
+ Log: Subject: [PATCH] Re: Bug in perlguts documentation?
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Reply-To: mjtg@cam.ac.uk
+ Message-Id: <E157fiS-0006Q7-00@draco.cus.cam.ac.uk>
+ Branch: perl
+ ! pod/perlguts.pod
+ ____________________________________________________________________________
+ [ 10459] By: jhi on 2001/06/06 20:58:15
+ Log: Subject: [PATCH] Re: [ID 20010604.015] taint + comma = false insecurity
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Reply-To: mjtg@cam.ac.uk
+ Message-Id: <E157flx-0006Uz-00@draco.cus.cam.ac.uk>
+ Branch: perl
+ ! pod/perlsec.pod
+ ____________________________________________________________________________
+ [ 10458] By: jhi on 2001/06/06 20:56:04
+ Log: Disable long doubles from pre-5.0 Tru64s.
+ Branch: perl
+ ! README.tru64 hints/dec_osf.sh
+ ____________________________________________________________________________
+ [ 10457] By: jhi on 2001/06/06 20:49:23
+ Log: The #10455 exposed that modfl() is fundamentally busted
+ (as in: dumps core) in pre-5.0 Tru64, so better avoid even
+ testing it.
+ Branch: perl
+ ! hints/dec_osf.sh
+ ____________________________________________________________________________
+ [ 10456] By: jhi on 2001/06/06 20:48:35
+ Log: Metaconfig unit change for #10455.
+ Branch: metaconfig/U/perl
+ ! d_modfl.U
+ ____________________________________________________________________________
+ [ 10455] By: jhi on 2001/06/06 20:48:09
+ Log: Configure check for geborken modfl(), inspired by
+
+ Subject: Re: [20010118.017] op/int.t failure
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Tue, 05 Jun 2001 13:43:27 +0100
+ Message-Id: <200106051243.NAA15525@crypt.compulink.co.uk>
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10454] By: jhi on 2001/06/06 11:45:08
+ Log: Integrate changes #10450 and #10451 from maintperl:
+
+ optimize change#10448 slightly (don't repeat search in eval""s lexical
+ scope, since that has already been searched)
+
+ change#9108 needs subtler treatment for case of closures created
+ within eval""
+ Branch: perl
+ !> op.c t/op/misc.t
+ ____________________________________________________________________________
+ [ 10453] By: jhi on 2001/06/06 11:42:10
+ Log: MakeMaker magic to compile (when no dynamic loading)
+ List/Util.xsc as (ListUtil.c and) ListUtil.o since
+ POSIX-BC (BS2000) linker has an evil limitation of
+ being unable to include in the same executable several
+ object files with the same name - case-insensitively -
+ because otherwise we conflict with util.c.
+ Strictly speaking currently required only in POSIX-BC
+ but probably will do no harm elsewhere where static
+ linking is required.
+ Branch: perl
+ ! ext/List/Util/Makefile.PL
+ ____________________________________________________________________________
+ [ 10452] By: nick on 2001/06/06 08:59:51
+ Log: Integrate mainline.
+ Branch: perlio
+ +> lib/Attribute/Handlers/demo/Demo.pm
+ +> lib/Attribute/Handlers/demo/Descriptions.pm
+ +> lib/Attribute/Handlers/demo/MyClass.pm
+ +> lib/Attribute/Handlers/demo/demo.pl
+ +> lib/Attribute/Handlers/demo/demo2.pl
+ +> lib/Attribute/Handlers/demo/demo3.pl
+ +> lib/Attribute/Handlers/demo/demo4.pl
+ +> lib/Attribute/Handlers/demo/demo_call.pl
+ +> lib/Attribute/Handlers/demo/demo_chain.pl
+ +> lib/Attribute/Handlers/demo/demo_cycle.pl
+ +> lib/Attribute/Handlers/demo/demo_hashdir.pl
+ +> lib/Attribute/Handlers/demo/demo_phases.pl
+ +> lib/Attribute/Handlers/demo/demo_range.pl
+ +> lib/Attribute/Handlers/demo/demo_rawdata.pl t/op/override.t
+ +> uts/strtol_wrap.c
+ !> (integrate 91 files)
+ ____________________________________________________________________________
+ [ 10451] By: gsar on 2001/06/06 07:11:36
+ Log: change#9108 needs subtler treatment for case of closures created
+ within eval""
+ Branch: maint-5.6/perl
+ ! op.c t/op/misc.t
+ ____________________________________________________________________________
+ [ 10450] By: gsar on 2001/06/06 05:47:25
+ Log: optimize change#10448 slightly (don't repeat search in eval""s lexical
+ scope, since that has already been searched)
+ Branch: maint-5.6/perl
+ ! op.c
+ ____________________________________________________________________________
+ [ 10449] By: jhi on 2001/06/06 01:33:31
+ Log: Integrate change #10448 from maintperl; lexicals
+ outside an eval"" weren't resolved correctly inside a subroutine
+ definition inside the eval"" if they were not already referenced
+ in the toplevel of the eval""-ed code
+ Branch: perl
+ !> cop.h op.c pp_ctl.c t/op/misc.t
+ ____________________________________________________________________________
+ [ 10448] By: gsar on 2001/06/06 01:03:26
+ Log: fix yet another bug of hoary vintage found by change#10394: lexicals
+ outside an eval"" weren't resolved correctly inside a subroutine
+ definition inside the eval"" if they were not already referenced
+ in the toplevel of the eval""-ed code
+ Branch: maint-5.6/perl
+ ! cop.h op.c pp_ctl.c t/op/misc.t
+ ____________________________________________________________________________
+ [ 10447] By: jhi on 2001/06/06 00:51:04
+ Log: Subject: [PATCH] perl570delta.pod
+ From: Peter Scott <Peter@PSDT.com>
+ Date: Tue, 05 Jun 2001 18:51:02 -0700
+ Message-Id: <4.3.2.7.2.20010605183619.00a94400@psdt.com>
+ Branch: perl
+ ! pod/perl570delta.pod
+ ____________________________________________________________________________
+ [ 10446] By: jhi on 2001/06/05 23:45:05
+ Log: The fudge factor is no more needed. I hope.
+ Branch: perl
+ ! t/lib/posix.t
+ ____________________________________________________________________________
+ [ 10445] By: jhi on 2001/06/05 23:19:19
+ Log: Subject: Re: [ID 20010529.006] String plus zero inconsistent across platforms
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Tue, 05 Jun 2001 12:58:19 +0100
+ Message-Id: <200106051158.MAA04605@crypt.compulink.co.uk>
+ Branch: perl
+ ! util.c
+ ____________________________________________________________________________
+ [ 10444] By: jhi on 2001/06/05 11:09:01
+ Log: Make up prototypes only for those who have the functions
+ but not the prototypes.
+ Branch: perl
+ ! perl.h
+ ____________________________________________________________________________
+ [ 10443] By: jhi on 2001/06/05 11:02:13
+ Log: Subject: Re: Not OK: perl@10439 on win32
+ From: Prymmer/Kahn <pvhp@best.com>
+ Date: Mon, 4 Jun 2001 22:11:02 -0700 (PDT)
+ Message-ID: <Pine.BSF.4.21.0106042136410.26316-100000@shell8.ba.best.com>
+ Branch: perl
+ ! perl.h util.c
+ ____________________________________________________________________________
+ [ 10442] By: jhi on 2001/06/05 00:55:46
+ Log: The metaconfig units changes for #10441.
+ Branch: metaconfig
+ ! U/modified/Extract.U U/modified/Extractall.U
+ ! U/modified/Finish.U
+ ____________________________________________________________________________
+ [ 10441] By: jhi on 2001/06/05 00:55:17
+ Log: Extraction of the *.SH wasn't quite working with -Dmksymlinks.
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10440] By: jhi on 2001/06/05 00:28:27
+ Log: Unnecessary fuzziness undone, noted by Mike Guy.
+ Branch: perl
+ ! t/op/tr.t
+ ____________________________________________________________________________
+ [ 10439] By: jhi on 2001/06/04 17:14:31
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10438] By: jhi on 2001/06/04 17:10:16
+ Log: Test case for 'eval "a.b.c.d.e.f;sub"' save stack imbalance
+ bug found by Ilmari Karonen; the bug fixed by Sarathy's lexical
+ leakage patch.
+ Branch: perl
+ ! t/op/misc.t
+ ____________________________________________________________________________
+ [ 10437] By: jhi on 2001/06/04 17:01:06
+ Log: Test case for #10433/#10424.
+ Branch: perl
+ ! t/op/misc.t
+ ____________________________________________________________________________
+ [ 10436] By: jhi on 2001/06/04 16:54:21
+ Log: Subject: One fix for strtoul not setting errno
+ From: hom00@utsglobal.com (Hal Morris)
+ Date: Sat, 2 Jun 2001 09:23:11 -0700 (PDT)
+ Message-Id: <200106021623.JAA06906@cepheus.utsglobal.com>
+ Branch: perl
+ + uts/strtol_wrap.c
+ ! MANIFEST hints/uts.sh
+ ____________________________________________________________________________
+ [ 10435] By: jhi on 2001/06/04 16:54:01
+ Log: Metaconfig units changes for #10434.
+ Branch: metaconfig
+ ! U/modified/Cppsym.U
+ Branch: metaconfig/U/perl
+ + d_dbminitproto.U d_flockproto.U d_sockatmarkproto.U
+ + d_syscallproto.U d_usleepproto.U
+ ! longdblfio.U quadfio.U
+ ____________________________________________________________________________
+ [ 10434] By: jhi on 2001/06/04 16:48:33
+ Log: Configure tweaks; add prototype probes, make the cpp symbols
+ probe to cast, not whine; test for %Ld and %Lf before %lld and
+ %llf because the L is the ANSI way.
+ Branch: perl
+ ! Configure config_h.SH configure.com epoc/config.sh
+ ! ext/ODBM_File/ODBM_File.xs perl.h pod/perltoc.pod uconfig.h
+ ! uconfig.sh vos/config.alpha.def vos/config.ga.def
+ ! win32/config.bc win32/config.gc win32/config.vc x2p/str.c
+ ____________________________________________________________________________
+ [ 10433] By: jhi on 2001/06/04 16:45:23
+ Log: Sigh. This is what #10424 was supposed to check in.
+ Branch: perl
+ ! op.c sv.c sv.h
+ ____________________________________________________________________________
+ [ 10432] By: jhi on 2001/06/04 16:29:40
+ Log: More verbose failure.
+ Branch: perl
+ ! t/op/ver.t
+ ____________________________________________________________________________
+ [ 10431] By: jhi on 2001/06/04 16:21:55
+ Log: The .pm changes to go with #10428.
+ Branch: perl
+ ! ext/Fcntl/Fcntl.pm ext/Socket/Socket.pm
+ ! ext/Sys/Syslog/Syslog.pm
+ ____________________________________________________________________________
+ [ 10430] By: jhi on 2001/06/04 16:05:20
+ Log: On second thoughts show to utf8 skippage message only
+ on failures, it's too confusing otherwise,
+ Branch: perl
+ ! t/pragma/locale.t
+ ____________________________________________________________________________
+ [ 10429] By: jhi on 2001/06/04 14:47:50
+ Log: Do not import anything from Encode.
+ Branch: perl
+ ! ext/MIME/Base64/QuotedPrint.pm
+ ____________________________________________________________________________
+ [ 10428] By: jhi on 2001/06/04 14:45:47
+ Log: The #10402 didn't take. Weird.
+ Branch: perl
+ ! ext/Fcntl/Fcntl.xs ext/Socket/Socket.xs
+ ! ext/Sys/Syslog/Syslog.xs
+ ____________________________________________________________________________
+ [ 10427] By: jhi on 2001/06/04 12:55:39
+ Log: Eradicate traces of 'asciirange' re subpragma.
+ Branch: perl
+ ! ext/B/B/Deparse.pm ext/MIME/Base64/QuotedPrint.pm ext/re/re.pm
+ ! pod/perldiag.pod
+ ____________________________________________________________________________
+ [ 10426] By: jhi on 2001/06/04 12:44:05
+ Log: use is a compile-time thing.
+ Branch: perl
+ ! ext/MIME/Base64/QuotedPrint.pm
+ ____________________________________________________________________________
+ [ 10425] By: jhi on 2001/06/04 12:39:44
+ Log: Subject: [PATCH perl@10419] -Wall casting patch
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Date: Mon, 4 Jun 2001 14:27:28 +0100 (BST)
+ Message-Id: <200106041327.OAA15338@tempest.npl.co.uk>
+ Branch: perl
+ ! ext/Devel/DProf/DProf.xs mg.c
+ ____________________________________________________________________________
+ [ 10424] By: jhi on 2001/06/04 12:23:30
+ Log: Subject: [PATCH #2] introducing SVpad_TYPED
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Mon, 4 Jun 2001 12:26:02 +0530
+ Message-ID: <20010604122602.A5775@lustre.linux.in>
+ Branch: perl
+ ! op.c sv.c sv.h
+ ____________________________________________________________________________
+ [ 10423] By: gsar on 2001/06/04 05:12:18
+ Log: testsuite for change#10192 (from Gisle Aas)
+ Branch: perl
+ + t/op/override.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10422] By: gsar on 2001/06/04 02:32:03
+ Log: integrate changes#10414-10416 from mainline
+
+ Potential buffer overrun if the radix separator is more than
+ one byte. Also, under locales, prefer the locale-specific
+ separator over the old boring ".".
+
+ "10.", that is, decimal numbers can have no decimal part at all.
+
+ The non-locale places need love, too.
+ Branch: maint-5.6/perl
+ !> perl.h sv.c
+ ____________________________________________________________________________
+ [ 10421] By: jhi on 2001/06/04 02:25:53
+ Log: Missed from #10420.
+ Branch: perl
+ ! epoc/config.sh
+ ____________________________________________________________________________
+ [ 10420] By: jhi on 2001/06/04 02:19:58
+ Log: Missed HAS_SETRESGID_PROTO. No serious harm done since
+ often this prototype goes with HAS_SETRESUID_PROTO.
+ Branch: perl
+ ! Configure Porting/Glossary Porting/config.sh Porting/config_H
+ ! config_h.SH configure.com perl.h uconfig.h
+ ____________________________________________________________________________
+ [ 10419] By: jhi on 2001/06/04 00:24:55
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10418] By: jhi on 2001/06/03 23:58:04
+ Log: -Wall "subscript has type `char'" cleanup.
+ Branch: perl
+ ! ext/File/Glob/bsd_glob.c x2p/a2py.c x2p/str.c x2p/walk.c
+ ____________________________________________________________________________
+ [ 10417] By: jhi on 2001/06/03 23:37:17
+ Log: Various "cast to pointer from integer of different size"
+ picked up by gcc -Wall (in Tru64 where pointers are 64 bits
+ wide but I32 (int) only 32 bits wide).
+
+ WARNING: the classnum and tagnum changes in Storable.xs
+ may not be wise, they may be breaking binary compatibility
+ (in 64-bit platforms), asked Raphael Manfredi about the changes.
+ Branch: perl
+ ! embed.pl ext/Devel/DProf/DProf.xs ext/Storable/Storable.xs
+ ! mg.c proto.h
+ ____________________________________________________________________________
+ [ 10416] By: jhi on 2001/06/03 23:15:24
+ Log: The non-locale places need love, too.
+ Branch: perl
+ ! perl.h
+ ____________________________________________________________________________
+ [ 10415] By: jhi on 2001/06/03 23:10:55
+ Log: "10.", that is, decimal numbers can have no decimal part at all.
+ Branch: perl
+ ! perl.h
+ ____________________________________________________________________________
+ [ 10414] By: jhi on 2001/06/03 22:49:55
+ Log: Potential buffer overrun if the radix separator is more than
+ one byte. Also, under locales, prefer the locale-specific
+ separator over the old boring ".".
+ Branch: perl
+ ! perl.h sv.c
+ ____________________________________________________________________________
+ [ 10413] By: jhi on 2001/06/03 22:42:10
+ Log: Integrate change #10412 from maintperl; locale is now
+ per-cop, not per-op; plus retweak the locale.t to always
+ list the skipped utf8 locales.
+ Branch: perl
+ ! t/pragma/locale.t
+ !> embed.h lib/locale.pm op.c op.h opcode.h opcode.pl perl.h pp.c
+ !> pp.sym pp_ctl.c pp_proto.h pp_sys.c util.c
+ ____________________________________________________________________________
+ [ 10412] By: gsar on 2001/06/03 22:23:16
+ Log: rationalize locale handling to fix the bugs uncovered by change#10394
+
+ the major issue was that the runtime was looking at PL_hints rather
+ than op_private to notice whether locale was enabled
+
+ the secondary issue was that many locale-sensitive numeric ops didn't
+ have HINT_LOCALE propagated into their op_private
+
+ HINT_LOCALE is now propagated per-statement (i.e., via PL_curcop)
+ instead of per-op, just like HINT_BYTE and the hints for lexical
+ warnings (this makes the hint available to every op via PL_curcop)
+
+ pragma/locale.t may need to be reworked with these fixes in mind
+ (it currently passes its tests)
+ Branch: maint-5.6/perl
+ ! embed.h lib/locale.pm op.c op.h opcode.h opcode.pl perl.h pp.c
+ ! pp.sym pp_ctl.c pp_proto.h pp_sys.c t/pragma/locale.t util.c
+ ____________________________________________________________________________
+ [ 10411] By: jhi on 2001/06/03 17:50:49
+ Log: More verbose debugging.
+ Branch: perl
+ ! t/pragma/locale.t
+ ____________________________________________________________________________
+ [ 10410] By: jhi on 2001/06/03 17:36:40
+ Log: Subject: RE: [PATCHES] regcomp.c, pod/perldiag.pod, t/op/pat.t
+ From: "Paul Marquess" <Paul_Marquess@Yahoo.co.uk>
+ Date: Sat, 2 Jun 2001 22:53:33 +0100
+ Message-ID: <000601c0ebae$77d10dc0$99dcfea9@bfs.phone.com>
+ Branch: perl
+ ! regcomp.c t/pragma/warn/regcomp
+ ____________________________________________________________________________
+ [ 10409] By: jhi on 2001/06/03 17:27:13
+ Log: Mention that lexicalizing $a or $b is a bad idea if one
+ wants to use sort().
+ Branch: perl
+ ! pod/perlvar.pod
+ ____________________________________________________________________________
+ [ 10408] By: jhi on 2001/06/03 16:52:41
+ Log: Tweak the test to be happy if the accuracy is 'good enough'.
+ Branch: perl
+ ! t/lib/posix.t
+ ____________________________________________________________________________
+ [ 10407] By: jhi on 2001/06/03 16:50:33
+ Log: Upgrade to Attribute::Handlers 0.70.
+
+ NOTE: this unearthed the "too late for CHECK block" bug,
+ that's why the 1_compile.t change.
+ Branch: perl
+ + lib/Attribute/Handlers/demo/Demo.pm
+ + lib/Attribute/Handlers/demo/Descriptions.pm
+ + lib/Attribute/Handlers/demo/MyClass.pm
+ + lib/Attribute/Handlers/demo/demo.pl
+ + lib/Attribute/Handlers/demo/demo2.pl
+ + lib/Attribute/Handlers/demo/demo3.pl
+ + lib/Attribute/Handlers/demo/demo4.pl
+ + lib/Attribute/Handlers/demo/demo_call.pl
+ + lib/Attribute/Handlers/demo/demo_chain.pl
+ + lib/Attribute/Handlers/demo/demo_cycle.pl
+ + lib/Attribute/Handlers/demo/demo_hashdir.pl
+ + lib/Attribute/Handlers/demo/demo_phases.pl
+ + lib/Attribute/Handlers/demo/demo_range.pl
+ + lib/Attribute/Handlers/demo/demo_rawdata.pl
+ ! MANIFEST lib/Attribute/Handlers.pm t/lib/1_compile.t
+ ! t/lib/attrhand.t
+ ____________________________________________________________________________
+ [ 10406] By: jhi on 2001/06/03 16:40:03
+ Log: One less -Wall whine.
+ Branch: perl
+ ! regcomp.c
+ ____________________________________________________________________________
+ [ 10405] By: jhi on 2001/06/03 16:30:34
+ Log: Integrate change #10404 from maintperl; eval.t was in pre-10394 mood.
+ Branch: perl
+ !> t/op/eval.t
+ ____________________________________________________________________________
+ [ 10404] By: gsar on 2001/06/03 16:23:07
+ Log: eval.t was relying on pre-change#10394 buggy behavior (lexicals
+ aren't "normally" visible inside eval""s contained in subs unless
+ a cloned reference to them already exists)
+
+ strangely enough, t/harness didn't show this up as a failure
+ (harness needs fixing?)
+ Branch: maint-5.6/perl
+ ! t/op/eval.t
+ ____________________________________________________________________________
+ [ 10403] By: jhi on 2001/06/03 16:22:59
+ Log: Update to Text::Balanced 1.85.
+ Branch: perl
+ ! lib/Text/Balanced.pm t/lib/tb-xvari.t
+ ____________________________________________________________________________
+ [ 10402] By: jhi on 2001/06/03 16:18:09
+ Log: Subject: [PATCH] Re: ext/Socket/Socket.xs
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Sun, 3 Jun 2001 17:54:36 +0100
+ Message-ID: <20010603175436.E76396@plum.flirble.org>
+ Branch: perl
+ ! ext/Fcntl/Fcntl.xs ext/Socket/Socket.xs
+ ! ext/Sys/Syslog/Syslog.xs
+ ____________________________________________________________________________
+ [ 10401] By: jhi on 2001/06/03 16:09:33
+ Log: Unused variables.
+ Branch: perl
+ ! util.c
+ ____________________________________________________________________________
+ [ 10400] By: jhi on 2001/06/03 16:04:26
+ Log: Subject: [PATCH] APIfy op_clear
+ From: Simon Cozens <simon@netthink.co.uk>
+ Date: Sun, 3 Jun 2001 13:51:46 +0100
+ Message-ID: <20010603135146.A9984@deep-dark-truthful-mirror.pmb.ox.ac.uk>
+
+ (despite the subject line, op_null is APIfied by the patch)
+ Branch: perl
+ ! embed.h embed.pl global.sym objXSUB.h perlapi.c
+ ____________________________________________________________________________
+ [ 10399] By: jhi on 2001/06/03 15:51:35
+ Log: Subject: [PATCH] t/lib/extutils.t
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Sat, 2 Jun 2001 23:57:05 +0100
+ Message-ID: <20010602235705.Q12698@plum.flirble.org>
+ Branch: perl
+ ! lib/ExtUtils/Constant.pm t/lib/extutils.t
+ ____________________________________________________________________________
+ [ 10398] By: jhi on 2001/06/03 15:34:11
+ Log: Subject: [PATCH: perl@10360] update two win32 Makefiles
+ From: Prymmer/Kahn <pvhp@best.com>
+ Date: Sun, 3 Jun 2001 08:55:14 -0700 (PDT)
+ Message-ID: <Pine.BSF.4.21.0106030845550.21619-100000@shell8.ba.best.com>
+ Branch: perl
+ ! win32/Makefile win32/makefile.mk
+ ____________________________________________________________________________
+ [ 10397] By: jhi on 2001/06/03 15:12:13
+ Log: Subject: Re: 'decimal digits' macro?
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Sun, 03 Jun 2001 04:26:36 +0100
+ Message-Id: <200106030326.EAA18786@crypt.compulink.co.uk>
+ Branch: perl
+ ! handy.h t/lib/posix.t t/op/tr.t
+ ____________________________________________________________________________
+ [ 10396] By: jhi on 2001/06/03 15:10:49
+ Log: Subject: Re: [ID 20010529.006] String plus zero inconsistent across platforms
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Sun, 03 Jun 2001 14:56:30 +0100
+ Message-Id: <200106031356.OAA12517@crypt.compulink.co.uk>
+ Branch: perl
+ ! util.c
+ ____________________________________________________________________________
+ [ 10395] By: jhi on 2001/06/03 14:59:41
+ Log: Integrate change #10394 from maintperl; lexical file scope leakage.
+ Branch: perl
+ !> perly.c perly.y t/op/misc.t t/pragma/warn/universal
+ !> vms/perly_c.vms
+ ____________________________________________________________________________
+ [ 10394] By: gsar on 2001/06/03 03:05:43
+ Log: fix leakage of lexicals at file scope into subroutines that were
+ declared before them; this appears to be a longstanding bug that
+ meant that lexicals at file scope were never "deintroduced", meaning
+ their scope range was never properly closed, and their visibility
+ extended to all subsequent eval""s or requires
+
+ added a test case
+
+ seems to also fix a case of bogus duplicate warnings
+ Branch: maint-5.6/perl
+ ! perly.c perly.y t/op/misc.t t/pragma/warn/universal
+ ! vms/perly_c.vms
+ ____________________________________________________________________________
+ [ 10393] By: jhi on 2001/06/02 16:55:03
+ Log: More VMS tweaks from Craig A. Berry.
+ Branch: perl
+ ! configure.com t/lib/extutils.t
+ ____________________________________________________________________________
+ [ 10392] By: jhi on 2001/06/02 16:48:26
+ Log: -Wall cleanup continues.
+ Branch: perl
+ ! README.tru64 embed.h embed.pl ext/NDBM_File/NDBM_File.xs
+ ! ext/POSIX/POSIX.xs ext/PerlIO/Scalar/Scalar.xs
+ ! ext/Storable/Storable.xs ext/Sys/Hostname/Hostname.xs
+ ! ext/Sys/Syslog/Syslog.xs perl.c proto.h regcomp.c regexec.c
+ ! run.c toke.c util.c
+ ____________________________________________________________________________
+ [ 10391] By: jhi on 2001/06/02 13:29:47
+ Log: The metaconfig unit change for #10390.
+ Branch: metaconfig/U/perl
+ ! gccvers.U
+ ____________________________________________________________________________
+ [ 10390] By: jhi on 2001/06/02 13:29:12
+ Log: Drop the -ansi from the default gcc flags.
+
+ Off_t/off_t is a struct in Solaris with largefiles, and with -ansi
+ that struct cannot be compared with a flat integer, such as STRLEN.
+ The -ansi will also cause a lot of noise in Solaris because of:
+ /usr/include/sys/resource.h:148: warning: `struct rlimit64' declared inside parameter list
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10389] By: jhi on 2001/06/02 13:14:57
+ Log: Integrate perlio.
+ Branch: perl
+ !> pod/perlapi.pod util.c
+ ____________________________________________________________________________
+ [ 10388] By: nick on 2001/06/02 08:01:12
+ Log: Integrate mainline
+ Branch: perlio
+ +> lib/Attribute/Handlers.pm t/lib/attrhand.t
+ !> MANIFEST configure.com ext/MIME/Base64/QuotedPrint.pm
+ !> lib/File/Find.pm pod/perlmodlib.pod pod/perltoc.pod
+ !> t/lib/1_compile.t t/lib/mimeqp.t
+ ____________________________________________________________________________
+ [ 10387] By: nick on 2001/06/02 07:39:17
+ Log: Tweak util.c's atof2 for MULTIPLICITY
+ Branch: perlio
+ ! util.c
+ ____________________________________________________________________________
+ [ 10386] By: nick on 2001/06/02 07:38:33
+ Log: Integrate mainline
+ Branch: perlio
+ !> (integrate 41 files)
+ ____________________________________________________________________________
+ [ 10385] By: jhi on 2001/06/01 22:12:48
+ Log: Add Attribute::Handlers 0.61 from Damian Conway.
+ Branch: perl
+ + lib/Attribute/Handlers.pm t/lib/attrhand.t
+ ! MANIFEST pod/perlmodlib.pod pod/perltoc.pod t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 10384] By: jhi on 2001/06/01 21:53:14
+ Log: Subject: [PATCH: perl@10328] allow MIME::QuotePrint to handle ASCII code numbers on EBCDIC machines
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Fri, 1 Jun 2001 15:49:22 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10106011545140.323662-100000@aspara.forte.com>
+ Branch: perl
+ ! ext/MIME/Base64/QuotedPrint.pm t/lib/mimeqp.t
+ ____________________________________________________________________________
+ [ 10383] By: jhi on 2001/06/01 21:36:11
+ Log: Subject: [PATCH File::Find] 'do 1' and puzzling (?>...)
+ From: Jeff Pinyan <jeffp@crusoe.net>
+ Date: Fri, 1 Jun 2001 14:13:56 -0400 (EDT)
+ Message-ID: <Pine.GSO.4.21.0106011412520.21027-100000@crusoe.crusoe.net>
+ Branch: perl
+ ! lib/File/Find.pm
+ ____________________________________________________________________________
+ [ 10382] By: jhi on 2001/06/01 21:35:02
+ Log: Subject: [PATCH perl@10381] configure.com tweaks
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Fri, 1 Jun 2001 13:55:43 -0500
+ Message-Id: <a05100e00b73d942aa9da@[172.16.52.1]>
+ Branch: perl
+ ! configure.com
+ ____________________________________________________________________________
+ [ 10381] By: jhi on 2001/06/01 16:37:21
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10380] By: jhi on 2001/06/01 16:19:18
+ Log: Subject: [PATCH] Re: [ID 20010529.004] program doesn't work unless in debug mode
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Fri, 01 Jun 2001 18:17:02 +0100
+ Message-Id: <E155sXm-0001C2-00@draco.cus.cam.ac.uk>
+ Branch: perl
+ ! lib/perl5db.pl
+ ____________________________________________________________________________
+ [ 10379] By: jhi on 2001/06/01 16:13:28
+ Log: Subject: Re: [ID 20010529.006] String plus zero inconsistent across platforms
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Thu, 31 May 2001 20:49:48 +0100
+ Message-Id: <200105311949.UAA02798@crypt.compulink.co.uk>
+ Branch: perl
+ ! embed.h embed.pl global.sym objXSUB.h perl.h perlapi.c proto.h
+ ! util.c
+ ____________________________________________________________________________
+ [ 10378] By: jhi on 2001/06/01 15:56:35
+ Log: Zero() is not available in x2p (or, rather, some of its
+ implementations like memzero() might not be available.)
+ Branch: perl
+ ! x2p/hash.c
+ ____________________________________________________________________________
+ [ 10377] By: jhi on 2001/06/01 15:44:48
+ Log: Subject: [PATCH x2p/hash.c] bzero -> memset
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Fri, 1 Jun 2001 12:00:29 +0100
+ Message-ID: <20010601120029.F29027@blackrider.blackstar.co.uk>
+
+ (But use Zero() instead of memset.)
+ Branch: perl
+ ! x2p/hash.c
+ ____________________________________________________________________________
+ [ 10376] By: jhi on 2001/06/01 15:39:52
+ Log: Subject: Re: [PATCHES] regcomp.c, pod/perldiag.pod, t/op/pat.t
+ From: Jeff Pinyan <jeffp@crusoe.net>
+ Date: Fri, 1 Jun 2001 10:33:55 -0400 (EDT)
+ Message-ID: <Pine.GSO.4.21.0106011032080.21027-100000@crusoe.crusoe.net>
+ Branch: perl
+ ! pod/perldiag.pod regcomp.c t/op/pat.t
+ ____________________________________________________________________________
+ [ 10375] By: jhi on 2001/06/01 15:36:35
+ Log: Retract #10324 and #10333; not needed.
+ Branch: perl
+ ! hints/irix_6.sh hints/linux.sh
+ ____________________________________________________________________________
+ [ 10374] By: jhi on 2001/06/01 15:35:19
+ Log: The #10370 wasn't quite right.
+ Branch: perl
+ ! ext/XS/Typemap/Typemap.xs
+ ____________________________________________________________________________
+ [ 10373] By: jhi on 2001/06/01 15:34:49
+ Log: The metaconfig units changes for #10372.
+ Branch: metaconfig/U/perl
+ + d_realpath.U d_sresgproto.U d_sresuproto.U
+ ! gccvers.U i_db.U
+ ____________________________________________________________________________
+ [ 10372] By: jhi on 2001/06/01 15:34:24
+ Log: Configure tweaks; record the Berkeley DB version,
+ probe for realpath(), for setresuid() and setresgid()
+ prototypes; use realpath() (try to be paranoid enough),
+ use the setres[ug]id prototypes because glibc has the functions
+ but not their prototypes; add -Wall -ansi to gcc ccflags;
+ regen toc.
+ Branch: perl
+ ! Configure Porting/Glossary Porting/config.sh Porting/config_H
+ ! config_h.SH configure.com epoc/config.sh
+ ! ext/DB_File/DB_File.xs perl.h pod/perlapi.pod pod/perltoc.pod
+ ! uconfig.h uconfig.sh util.c vos/config.alpha.def
+ ! vos/config.ga.def win32/config.bc win32/config.gc
+ ! win32/config.vc
+ ____________________________________________________________________________
+ [ 10371] By: jhi on 2001/06/01 12:50:05
+ Log: Subject: Re: [PATCH xsutils.c] Quieting warnings
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Fri, 1 Jun 2001 11:28:14 +0100
+ Message-ID: <20010601112814.B29027@blackrider.blackstar.co.uk>
+ Branch: perl
+ ! lib/attributes.pm xsutils.c
+ ____________________________________________________________________________
+ [ 10370] By: jhi on 2001/06/01 12:48:55
+ Log: Subject: [PATCH] Fix -Wall on XS::Typemap
+ From: Tim Jenness <t.jenness@jach.hawaii.edu>
+ Date: Thu, 31 May 2001 16:15:37 -1000 (HST)
+ Message-ID: <Pine.LNX.4.33.0105311610110.9337-100000@lapaki.jach.hawaii.edu>
+ Branch: perl
+ ! ext/XS/Typemap/Typemap.xs
+ ____________________________________________________________________________
+ [ 10369] By: jhi on 2001/06/01 12:47:21
+ Log: Subject: [patch] Cwd.xs optimizations/abstraction
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Thu, 31 May 2001 17:37:37 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0105311733270.732-100000@mako.covalent.net>
+ Branch: perl
+ ! embed.h embed.pl ext/Cwd/Cwd.xs global.sym lib/Cwd.pm
+ ! objXSUB.h perlapi.c pod/perlapi.pod proto.h util.c
+ ____________________________________________________________________________
+ [ 10368] By: jhi on 2001/06/01 12:32:00
+ Log: Subject: Re: Why t/lib/extutils.t is failing (was Re: [PATCH] Re: [PATCH] Re: [SPAM] Re: [SPAM] Re: [EGGS] Re: [BACON] Re: [TOAST] Re: [PATCH] Re: [PATCH] Re: h2xs [was Re: HEAR YE, HEAR YE!])
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Thu, 31 May 2001 23:56:40 +0100
+ Message-ID: <20010531235640.F12698@plum.flirble.org>
+
+ Make the test work also under only static extensions
+ (sh Configure -Uusedl fakes this nicely)
+ Branch: perl
+ ! t/lib/extutils.t
+ ____________________________________________________________________________
+ [ 10367] By: jhi on 2001/06/01 12:27:53
+ Log: Subject: [PATCH hv.c] Eliminating trigraph
+ From: Michael G Schwern <schwern@pobox.com>
+ Message-ID: <20010601114955.E29027@blackrider.blackstar.co.uk>
+ Date: Fri, 1 Jun 2001 11:49:56 +0100
+ Branch: perl
+ ! hv.c
+ ____________________________________________________________________________
+ [ 10366] By: jhi on 2001/06/01 12:14:57
+ Log: Subject: Re: [PATCH] Tests for File::Compare
+ From: "Philip Newton" <Philip.Newton@gmx.net>
+ Date: Thu, 31 May 2001 19:44:05 +0200
+ Message-Id: <200105311748.f4VHmCt18269@chaos.wustl.edu>
+
+ Unnecessary "quotation marks".
+ Branch: perl
+ ! t/lib/filecomp.t
+ ____________________________________________________________________________
+ [ 10365] By: jhi on 2001/06/01 12:13:26
+ Log: Integrate perlio.
+ Branch: perl
+ !> lib/ExtUtils/MM_Win32.pm t/lib/filecomp.t
+ ____________________________________________________________________________
+ [ 10364] By: nick on 2001/06/01 10:13:31
+ Log: Cleanup dll.base and dll.exp created by GCC builds.
+ Branch: perlio
+ ! lib/ExtUtils/MM_Win32.pm
+ ____________________________________________________________________________
+ [ 10363] By: nick on 2001/06/01 10:02:17
+ Log: Make filecomp test work on CRLF platforms by adding binmode.
+ Branch: perlio
+ ! t/lib/filecomp.t
+ ____________________________________________________________________________
+ [ 10362] By: nick on 2001/06/01 08:37:17
+ Log: Integrate mainline
+ Branch: perlio
+ !> Changes Configure patchlevel.h perlio.c
+ ____________________________________________________________________________
+ [ 10361] By: jhi on 2001/05/31 15:09:34
+ Log: panic:claustrophobia.
+ Branch: perl
+ ! perlio.c
+ ____________________________________________________________________________
+ [ 10360] By: jhi on 2001/05/31 13:04:25
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10359] By: nick on 2001/05/31 12:35:50
+ Log: Integrate mainline.
+ Branch: perlio
+ +> t/lib/filecomp.t
+ !> AUTHORS MANIFEST ext/Storable/Storable.xs gv.c perl.c perl.h
+ !> pp_ctl.c sv.c t/lib/1_compile.t toke.c util.c
+ ____________________________________________________________________________
+ [ 10358] By: jhi on 2001/05/31 12:35:05
+ Log: Integrate perlio.
+ Branch: perl
+ !> t/pragma/warn/toke win32/config_H.bc win32/config_H.gc
+ !> win32/config_H.vc
+ ____________________________________________________________________________
+ [ 10357] By: jhi on 2001/05/31 12:34:04
+ Log: Metaconfig unit change for #10356.
+ Branch: metaconfig
+ ! U/installdirs/inc_version_list.U
+ ____________________________________________________________________________
+ [ 10356] By: jhi on 2001/05/31 12:33:41
+ Log: Allow Configure -Dinc_version_list='5.6.0/$archname 5.6.0' ...
+ (idea from Sarathy; implementation from Andy)
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10355] By: jhi on 2001/05/31 12:18:06
+ Log: More AUTHORS.
+ Branch: perl
+ ! AUTHORS
+ ____________________________________________________________________________
+ [ 10354] By: jhi on 2001/05/31 12:16:24
+ Log: Subject: Re: [PATCH] Tests for File::Compare
+ From: Alexander Gough <alexander.gough@st-hughs.oxford.ac.uk>
+ Date: Thu, 31 May 2001 13:26:34 +0100 (GMT)
+ Message-Id: <E155RX8-0004X2-00@wing1.herald.ox.ac.uk>
+ Branch: perl
+ + t/lib/filecomp.t
+ ! MANIFEST t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 10353] By: jhi on 2001/05/31 12:11:24
+ Log: Subject: [PATCH] DEBUG_* macro cleanups
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Thu, 31 May 2001 12:16:22 +0530
+ Message-ID: <20010531121622.B4829@lustre.linux.in>
+
+ Subject: Re: [PATCH] DEBUG_* macro cleanups
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Thu, 31 May 2001 13:57:01 +0530
+ Message-ID: <20010531135701.A21775@lustre.linux.in>
+
+ (The DEBUG_ definitions in perl.h changed to use the
+ STMT_START and STMT_END.)
+ Branch: perl
+ ! perl.h pp_ctl.c sv.c toke.c
+ ____________________________________________________________________________
+ [ 10352] By: jhi on 2001/05/31 11:53:31
+ Log: Subject: [PATCH] -Wall cleanups: perl.c, gv.c, Storable.xs
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Thu, 31 May 2001 08:27:55 +0530
+ Message-ID: <20010531082755.A10018@lustre.linux.in>
+ Branch: perl
+ ! ext/Storable/Storable.xs gv.c perl.c
+ ____________________________________________________________________________
+ [ 10351] By: jhi on 2001/05/31 11:45:16
+ Log: Subject: [PATCH] AUTHORS
+ From: "Daniel S. Lewart" <d-lewart@uiuc.edu>
+ Date: Thu, 31 May 2001 01:27:59 -0500
+ Message-ID: <20010531012758.A1595@staff1.cso.uiuc.edu>
+
+ Subject: Re: [PATCH] AUTHORS
+ From: "Philip Newton" <Philip.Newton@gmx.net>
+ Date: Thu, 31 May 2001 10:08:06 +0200
+ (Message-Id missing?)
+ Branch: perl
+ ! AUTHORS
+ ____________________________________________________________________________
+ [ 10350] By: nick on 2001/05/31 11:40:43
+ Log: win32 - dmake regen_config_h
+ Branch: perlio
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ____________________________________________________________________________
+ [ 10349] By: jhi on 2001/05/31 11:38:27
+ Log: Subject: Re: [PATCH util.c] More warning cleanups.
+ From: "Philip Newton" <Philip.Newton@gmx.net>
+ Date: Thu, 31 May 2001 07:41:36 +0200
+ Message-Id: <200105310538.IAA25458@taku.hut.fi>
+
+ Undo C++-ism that snekt in.
+ Branch: perl
+ ! util.c
+ ____________________________________________________________________________
+ [ 10348] By: nick on 2001/05/31 11:36:46
+ Log: Tolerate Win32 numerics
+ Branch: perlio
+ ! t/pragma/warn/toke
+ ____________________________________________________________________________
+ [ 10347] By: jhi on 2001/05/31 11:29:40
+ Log: Integrate perlio.
+ Branch: perl
+ !> perlio.c win32/win32.h
+ ____________________________________________________________________________
+ [ 10346] By: nick on 2001/05/31 10:54:55
+ Log: Hack to restore Win32 pseudo fork broken by Multiple Interpreter
+ perlio.c change 10255.
+ Branch: perlio
+ ! perlio.c
+ ____________________________________________________________________________
+ [ 10345] By: nick on 2001/05/31 10:01:57
+ Log: Conditionaly put back some "unused" dTHX which are used
+ with PERL_IMPLICIT_SYS
+ Branch: perlio
+ ! perlio.c
+ ____________________________________________________________________________
+ [ 10344] By: nick on 2001/05/31 10:00:59
+ Log: Fix Win32 for new spelling IN_BYTES
+ Branch: perlio
+ ! win32/win32.h
+ ____________________________________________________________________________
+ [ 10343] By: nick on 2001/05/31 08:01:32
+ Log: perlio.c -Wall cleaner under MULTIPLICITY
+ - still minor noise with linux stdio
+ Branch: perlio
+ ! perlio.c
+ ____________________________________________________________________________
+ [ 10342] By: nick on 2001/05/31 07:52:23
+ Log: Integrate mainline.
+ Branch: perlio
+ !> (integrate 42 files)
+ ____________________________________________________________________________
+ [ 10341] By: jhi on 2001/05/31 01:39:02
+ Log: AUTHORS updates.
+ Branch: perl
+ ! AUTHORS
+ ____________________________________________________________________________
+ [ 10340] By: jhi on 2001/05/31 00:19:29
+ Log: Subject: [PATCH: perl@10328] new md5sum for modified MD5.xs file
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Wed, 30 May 2001 17:57:20 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10105301753210.129765-100000@aspara.forte.com>
+ Branch: perl
+ ! t/lib/md5-file.t
+ ____________________________________________________________________________
+ [ 10339] By: jhi on 2001/05/31 00:16:44
+ Log: Salvage bits and pieces from the experimental 'utf8 everywhere'
+ patch: rename HINT_BYTE and IN_BYTE to HINT_BYTES and IN_BYTES
+ to match the pragma name; various robustness cleanups.
+ Branch: perl
+ ! lib/utf8_heavy.pl mg.c perl.h pp.c pp_ctl.c pp_sys.c regexec.c
+ ! sv.c toke.c utf8.c utf8.h utfebcdic.h
+ ____________________________________________________________________________
+ [ 10338] By: jhi on 2001/05/30 23:56:14
+ Log: More -Wall sweeping.
+ Branch: perl
+ ! av.c doio.c ext/Cwd/Cwd.xs ext/Devel/DProf/DProf.xs
+ ! ext/Devel/Peek/Peek.xs ext/Encode/Encode.xs
+ ! ext/List/Util/Util.xs gv.c op.c pp.c pp_ctl.c pp_hot.c
+ ! regcomp.c sv.c toke.c utf8.c
+ ____________________________________________________________________________
+ [ 10337] By: jhi on 2001/05/30 23:20:23
+ Log: Subject: [PATCH] (was Re: [PATCH] Re: Report /pro/3gl/CPAN/perl-5.7.1)
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Wed, 30 May 2001 22:34:41 +0100
+ Message-ID: <20010530223441.Y86445@plum.flirble.org>
+ Branch: perl
+ ! t/op/cmp.t
+ ____________________________________________________________________________
+ [ 10336] By: jhi on 2001/05/30 23:18:48
+ Log: It's is not, it isn't ain't, and it's it's, not its,
+ if you mean it is. If you don't, it's its. Then too,
+ it's hers. It isn't her's. It isn't our's either.
+ It's ours, and likewise yours and theirs.
+ -- Oxford University Press, Edpress News
+ Branch: perl
+ ! lib/autouse.pm
+ ____________________________________________________________________________
+ [ 10335] By: jhi on 2001/05/30 23:12:30
+ Log: More -Wall silencing from Michael Schwern and Jarkko Hietaniemi.
+ Branch: perl
+ ! doop.c ext/ByteLoader/bytecode.h ext/DB_File/DB_File.xs mg.c
+ ! perl.c perlio.c regexec.c universal.c util.c x2p/a2py.c
+ ! x2p/str.c x2p/walk.c xsutils.c
+ ____________________________________________________________________________
+ [ 10334] By: jhi on 2001/05/30 22:52:41
+ Log: Subject: [PATCH perl.c t/run/runenv.t] (was Re: [[ID 20010514.042] Perl v5.6.1 mangles PERL5OPT])
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Wed, 30 May 2001 17:10:38 +0100
+ Message-ID: <20010530171038.L670@blackrider.blackstar.co.uk>
+
+ Subject: Re: [PATCH perl.c t/run/runenv.t] (was Re: [ID 20010514.042] Perl v5.6.1 mangles PERL5OPT])
+ From: Abhijit Menon-Sen <ams@wiw.org>
+ Date: Wed, 30 May 2001 23:16:13 +0530
+ Message-ID: <20010530231613.A31933@lustre.linux.in>
+ Branch: perl
+ ! perl.c t/run/runenv.t
+ ____________________________________________________________________________
+ [ 10333] By: jhi on 2001/05/30 22:25:02
+ Log: (Retracted by #10375.)
+
+ IRIX hints patch from Merijn Broeren.
+
+ TODO: (this and the earlier Linux hints patch) should be solved
+ at Configure level. Merijn: -ldb should not be used on any platform
+ for perl, just when linking DBFile itself. Trying to be helpful here
+ is counterproductive.
+ Branch: perl
+ ! hints/irix_6.sh
+ ____________________________________________________________________________
+ [ 10332] By: jhi on 2001/05/30 22:11:13
+ Log: Subject: Re: [PATCH doop.c] unused variable in Perl_do_join
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Wed, 30 May 2001 23:20:58 +0100
+ Message-ID: <20010530232058.B86445@plum.flirble.org>
+ Branch: perl
+ ! doop.c
+ ____________________________________________________________________________
+ [ 10331] By: jhi on 2001/05/30 22:09:49
+ Log: Subject: Re: [PATCH perl@10298] fix extutils.t and autouse.t for VMS
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Wed, 30 May 2001 15:24:20 +0100
+ Message-ID: <20010530152420.H670@blackrider.blackstar.co.uk>
+ Branch: perl
+ ! t/pragma/autouse.t
+ ____________________________________________________________________________
+ [ 10330] By: jhi on 2001/05/30 22:02:21
+ Log: The regex trick wasn't a good idea.
+ Branch: perl
+ ! pod/perlfaq4.pod
+ ____________________________________________________________________________
+ [ 10329] By: nick on 2001/05/30 18:34:35
+ Log: Integrate mainline
+ Branch: perlio
+ !> (integrate 40 files)
+ ____________________________________________________________________________
+ [ 10328] By: jhi on 2001/05/30 14:28:39
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10327] By: jhi on 2001/05/30 14:07:01
+ Log: The metaconfig unit change for #10325.
+ Branch: metaconfig
+ + U/modified/afs.U
+ ____________________________________________________________________________
+ [ 10326] By: jhi on 2001/05/30 14:06:36
+ Log: More -Wall cleanup from Schwern; the EBCDIC MD5.xs checksum
+ is now wrong.
+ Branch: perl
+ ! ext/Digest/MD5/MD5.xs t/lib/md5-file.t
+ ____________________________________________________________________________
+ [ 10325] By: jhi on 2001/05/30 14:04:28
+ Log: Introduce $Config{afsroot}.
+ Branch: perl
+ ! Configure Porting/Glossary Porting/config.sh Porting/config_H
+ ! config_h.SH epoc/config.sh uconfig.sh win32/config.bc
+ ! win32/config.gc win32/config.vc
+ ____________________________________________________________________________
+ [ 10324] By: jhi on 2001/05/30 13:49:44
+ Log: (Retracted by #10375.)
+
+ Linux DB tweak from Merijn Broeren <merijnb@iloquent.nl>.
+ Branch: perl
+ ! hints/linux.sh
+ ____________________________________________________________________________
+ [ 10323] By: jhi on 2001/05/30 13:49:29
+ Log: AFS patches from Merijn Broeren <merijnb@iloquent.nl>.
+ (Also Configure tweaks needed; coming up soon.)
+ Branch: perl
+ ! t/io/fs.t t/lib/glob-basic.t t/op/stat.t
+ ____________________________________________________________________________
+ [ 10322] By: jhi on 2001/05/30 13:37:56
+ Log: Subject: [PATCH lib/perl5db.pl] Conditional breakpoints
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Sun, 27 May 2001 10:29:43 +0100
+ Message-ID: <20010527102942.J711@blackrider.blackstar.co.uk>
+ Branch: perl
+ ! lib/perl5db.pl
+ ____________________________________________________________________________
+ [ 10321] By: jhi on 2001/05/30 13:36:28
+ Log: Medley of -Wall cleanups from Michael Schwen, Hugo van der Sanden,
+ and Abhijit Menon-Sen.
+ Branch: perl
+ ! av.c doio.c doop.c dump.c ext/Digest/MD5/MD5.xs malloc.c op.c
+ ! perl.c pp_sys.c regcomp.c
+ ____________________________________________________________________________
+ [ 10320] By: jhi on 2001/05/30 13:35:27
+ Log: Fix the BOOT section to call myU2time properly.
+ Branch: perl
+ ! ext/Time/HiRes/HiRes.xs
+ ____________________________________________________________________________
+ [ 10319] By: jhi on 2001/05/30 13:06:09
+ Log: Subject: Re: [PATCH pod/perlfaq4.pod] Example of working in integers to avoid floating point errors
+ From: Ronald J Kimball <rjk@linguist.thayer.dartmouth.edu>
+ Date: Wed, 30 May 2001 09:44:29 -0400
+ Message-ID: <20010530094429.B133085@linguist.thayer.dartmouth.edu>
+
+ Detypo; plus add one more trick.
+ Branch: perl
+ ! pod/perlfaq4.pod
+ ____________________________________________________________________________
+ [ 10318] By: jhi on 2001/05/30 12:47:11
+ Log: Subject: Re: [PATCH lib/autouse.pm t/pragma/autouse.t] (was Re: [ID 20010528.001] use autouse 'URI::Escape' => qw(URI::Escape::uri_escape) failed)
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Wed, 30 May 2001 14:39:06 +0100
+ Message-ID: <20010530143906.E670@blackrider.blackstar.co.uk>
+ Branch: perl
+ ! lib/autouse.pm t/pragma/autouse.t
+ ____________________________________________________________________________
+ [ 10317] By: jhi on 2001/05/30 12:46:02
+ Log: Subject: Re: AIX and gcc (moving targets)
+ From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+ Date: Wed, 30 May 2001 15:25:08 +0200
+ Message-Id: <20010530152117.7097.H.M.BRAND@hccnet.nl>
+ Branch: perl
+ ! ext/Time/HiRes/HiRes.xs
+ ____________________________________________________________________________
+ [ 10316] By: jhi on 2001/05/30 12:40:46
+ Log: Subject: [PATCH t/TEST] sorting tests
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Wed, 30 May 2001 10:24:02 +0100
+ Message-ID: <20010530102402.Q670@blackrider.blackstar.co.uk>
+ Branch: perl
+ ! t/TEST
+ ____________________________________________________________________________
+ [ 10315] By: jhi on 2001/05/30 12:37:43
+ Log: Subject: [ID 20010529.002] typos in man page perlre
+ From: bart@cg681574-a.adubn1.nj.home.com
+ Date: Tue, 29 May 2001 13:58:59 -0500
+ Message-Id: <E154ohn-00053j-00@debian.adubn1.nj.home.com>
+ Branch: perl
+ ! pod/perlre.pod
+ ____________________________________________________________________________
+ [ 10314] By: jhi on 2001/05/30 12:33:53
+ Log: Subject: [PATCH perl@10298] fix extutils.t and autouse.t for VMS
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Tue, 29 May 2001 23:23:45 -0500
+ Message-Id: <a05100e01b73a21721dee@[192.168.56.153]>
+ Branch: perl
+ ! t/lib/extutils.t t/pragma/autouse.t
+ ____________________________________________________________________________
+ [ 10313] By: jhi on 2001/05/30 12:32:17
+ Log: Subject: Re: [ID 20010529.003] find2perl and File::Find doesn't emulate find when path is a symlink (patch to t/lib/filefind.t as requested)
+ From: David Dyck <dcd@tc.fluke.com>
+ Date: Tue, 29 May 2001 22:05:28 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.33.0105292200060.26992-100000@dd.tc.fluke.com>
+ Branch: perl
+ ! t/lib/filefind.t
+ ____________________________________________________________________________
+ [ 10312] By: jhi on 2001/05/30 12:31:02
+ Log: AIX hints update for gcc from Merijn H. Brand.
+ Branch: perl
+ ! hints/aix.sh
+ ____________________________________________________________________________
+ [ 10311] By: jhi on 2001/05/30 12:18:20
+ Log: Retract #10295 and #10296: a more generic solution
+ is needed (there's something funny with gcc on AIX).
+ Branch: perl
+ ! ext/POSIX/Makefile.PL ext/Storable/Makefile.PL
+ ____________________________________________________________________________
+ [ 10310] By: jhi on 2001/05/30 12:08:07
+ Log: Subject: Re: [ID 20010528.004] dual bug under utf8: $@ has UTF8 flag and \s+ does not match
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Wed, 30 May 2001 11:59:19 +0100
+ Message-Id: <200105301059.LAA03182@crypt.compulink.co.uk>
+
+ localizing $@ has unfortunate semantics - if you die past
+ a local $@, the die message is lost.
+ Branch: perl
+ ! lib/utf8_heavy.pl
+ ____________________________________________________________________________
+ [ 10309] By: nick on 2001/05/30 08:23:02
+ Log: Integrate mainline (autouse works again.)
+ Branch: perlio
+ !> ext/Time/Piece/Piece.pm hints/os2.sh lib/File/Find.pm
+ !> lib/autouse.pm pod/perlfaq4.pod pod/perlfaq6.pod
+ !> pod/perlvar.pod t/op/cmp.t
+ ____________________________________________________________________________
+ [ 10308] By: jhi on 2001/05/30 01:55:02
+ Log: Subject: [ID 20010529.003] find2perl and File::Find doesn't emulate find when path is a symlink (with proposed patch)
+ From: David Dyck <dcd@tc.fluke.com>
+ Date: Tue, 29 May 2001 12:19:38 -0700 (PDT)
+ Message-Id: <Pine.LNX.4.33.0105291216510.17409-100000@dd.tc.fluke.com>
+ Branch: perl
+ ! lib/File/Find.pm
+ ____________________________________________________________________________
+ [ 10307] By: jhi on 2001/05/30 01:47:22
+ Log: Subject: [PATCH] Re: Report /pro/3gl/CPAN/perl-5.7.1
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Tue, 29 May 2001 23:16:09 +0100
+ Message-ID: <20010529231609.U86445@plum.flirble.org>
+
+ Make the test output slightly clearer by distinguishing
+ between '' and undef.
+ Branch: perl
+ ! t/op/cmp.t
+ ____________________________________________________________________________
+ [ 10306] By: jhi on 2001/05/30 01:45:12
+ Log: Subject: [PATCH 5.6.1] flushNULL OS/2
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Tue, 29 May 2001 19:15:19 -0400
+ Message-ID: <20010529191519.A16020@math.ohio-state.edu>
+ Branch: perl
+ ! hints/os2.sh
+ ____________________________________________________________________________
+ [ 10305] By: jhi on 2001/05/30 01:42:36
+ Log: Subject: perlvar.pod addition
+ From: Peter Gessner <peter.gessner@post.rwth-aachen.de>
+ Date: Fri, 25 May 2001 20:23:12 +0200
+ Message-ID: <3B0EA310.B265C048@post.rwth-aachen.de>
+
+ Subject: Re: perlvar.pod addition
+ From: "Abigail" <abigail@foad.org>
+ Date: Fri, 25 May 2001 22:00:39 +0200
+ Message-ID: <20010525200039.28029.qmail@foad.org>
+
+ Mention $a and $b in perlvar.
+ Branch: perl
+ ! pod/perlvar.pod
+ ____________________________________________________________________________
+ [ 10304] By: jhi on 2001/05/30 01:36:37
+ Log: Subject: [PATCH] perlvar.pod -- why isn't @F here?
+ From: Jeff Pinyan <jeffp@crusoe.net>
+ Date: Tue, 29 May 2001 22:27:51 -0400 (EDT)
+ Message-ID: <Pine.GSO.4.21.0105292227150.1961-100000@crusoe.crusoe.net>
+ Branch: perl
+ ! pod/perlvar.pod
+ ____________________________________________________________________________
+ [ 10303] By: jhi on 2001/05/30 01:35:31
+ Log: Subject: Re: [PATCH] perlfaq6.pod -- case-aware s///
+ From: Jeff Pinyan <jeffp@crusoe.net>
+ Date: Tue, 29 May 2001 18:03:27 -0400 (EDT)
+ Message-ID: <Pine.GSO.4.21.0105291802330.1961-100000@crusoe.crusoe.net>
+ Branch: perl
+ ! pod/perlfaq6.pod
+ ____________________________________________________________________________
+ [ 10302] By: jhi on 2001/05/29 20:18:49
+ Log: Mention Time::localtime and Time::gmtime.
+ Branch: perl
+ ! ext/Time/Piece/Piece.pm
+ ____________________________________________________________________________
+ [ 10301] By: jhi on 2001/05/29 20:13:54
+ Log: Subject: [PATCH pod/perlfaq4.pod] Example of working in integers to avoid floating point errors
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Tue, 29 May 2001 18:51:32 +0100
+ Message-ID: <20010529185132.C706@blackrider.blackstar.co.uk>
+ Branch: perl
+ ! pod/perlfaq4.pod
+ ____________________________________________________________________________
+ [ 10300] By: jhi on 2001/05/29 20:12:09
+ Log: Retract #10243.
+ Branch: perl
+ ! lib/autouse.pm
+ ____________________________________________________________________________
+ [ 10299] By: nick on 2001/05/29 18:41:19
+ Log: Post weekend integrate mainline (fails one test pragma/autouse).
+ Branch: perlio
+ +> (branch 29 files)
+ !> (integrate 91 files)
+ ____________________________________________________________________________
+ [ 10298] By: jhi on 2001/05/29 16:29:19
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10297] By: jhi on 2001/05/29 16:25:47
+ Log: Fix Perl_swash_init & Perl_swash_fetch to save ERRSV (= $@)
+ before Perl_load_module/Perl_call_method and restore the value
+ after if !SvTRUE(ERRSV). (from Inaba Hiroto)
+ Branch: perl
+ ! utf8.c
+ ____________________________________________________________________________
+ [ 10296] By: jhi on 2001/05/29 16:01:53
+ Log: Subject: Re: AIX and gcc (moving targets)
+ From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+ Date: Tue, 29 May 2001 17:59:40 +0200
+ Message-Id: <20010529175841.7078.H.M.BRAND@hccnet.nl>
+ Branch: perl
+ ! ext/Storable/Makefile.PL
+ ____________________________________________________________________________
+ [ 10295] By: jhi on 2001/05/29 15:59:05
+ Log: Subject: Re: AIX and gcc (moving targets)
+ From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+ Date: Tue, 29 May 2001 12:32:57 +0200
+ Message-Id: <20010529115151.9FE0.H.M.BRAND@hccnet.nl>
+ Branch: perl
+ ! ext/POSIX/Makefile.PL
+ ____________________________________________________________________________
+ [ 10294] By: jhi on 2001/05/29 15:53:43
+ Log: Subject: [PATCH lib/Test/Harness.pm t/lib/test-harness.t] Syncing with 1.21
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Tue, 29 May 2001 09:53:29 +0100
+ Message-ID: <20010529095329.T675@blackrider.blackstar.co.uk>
+
+ (#10280 retracted)
+ Branch: perl
+ ! lib/Test/Harness.pm t/lib/test-harness.t
+ ____________________________________________________________________________
+ [ 10293] By: jhi on 2001/05/29 15:46:10
+ Log: Subject: [PATCH t/TEST lib/Test.pm t/lib/Test/*.t] Syncing with Test-1.17
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Tue, 29 May 2001 09:19:52 +0100
+ Message-ID: <20010529091952.R675@blackrider.blackstar.co.uk>
+ Branch: perl
+ + t/lib/Test/fail.t t/lib/Test/mix.t t/lib/Test/onfail.t
+ + t/lib/Test/qr.t t/lib/Test/skip.t t/lib/Test/success.t
+ + t/lib/Test/todo.t
+ ! MANIFEST lib/Test.pm t/TEST
+ ____________________________________________________________________________
+ [ 10292] By: jhi on 2001/05/29 15:34:08
+ Log: From: Michael G Schwern <schwern@pobox.com>
+ Subject: Re: [PATCH t/TEST] Allowing deeper test subdirectories
+ Date: Tue, 29 May 2001 08:26:09 +0100
+ Message-ID: <20010529082609.P675@blackrider.blackstar.co.uk>
+ Branch: perl
+ ! t/TEST
+ ____________________________________________________________________________
+ [ 10291] By: jhi on 2001/05/29 15:29:37
+ Log: Add tests for Time::gmtime and Time::localtime.
+ Branch: perl
+ + t/lib/time-gmtime.t t/lib/time-localtime.t
+ ! MANIFEST t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 10290] By: jhi on 2001/05/29 15:15:44
+ Log: Add test for File::stat.
+ Branch: perl
+ + t/lib/filestat.t
+ ! MANIFEST t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 10289] By: jhi on 2001/05/29 15:05:38
+ Log: Add test for Net::servent.
+ Branch: perl
+ + t/lib/net-sent.t
+ ! MANIFEST t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 10288] By: jhi on 2001/05/29 14:57:15
+ Log: Add test for Net::protoent.
+ Branch: perl
+ + t/lib/net-pent.t
+ ! MANIFEST t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 10287] By: jhi on 2001/05/29 14:53:10
+ Log: Add test for Net::netent.
+ Branch: perl
+ + t/lib/net-nent.t
+ ! MANIFEST t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 10286] By: jhi on 2001/05/29 14:31:57
+ Log: Add test for User::grent. Portability doubtful.
+ Branch: perl
+ + t/lib/user-grent.t
+ ! MANIFEST t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 10285] By: jhi on 2001/05/29 14:24:20
+ Log: Add test for User::pwent.
+ Probably will fall down somewhere for portability reasons.
+ Branch: perl
+ + t/lib/user-pwent.t
+ ! MANIFEST t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 10284] By: jhi on 2001/05/29 13:26:43
+ Log: Metaconfig units changes for #10283.
+ Branch: metaconfig
+ ! U/installdirs/inc_version_list.U U/installdirs/perl5.U
+ ! U/installdirs/siteman1.U U/installdirs/siteman3.U
+ ! U/installdirs/sitescript.U U/modified/Signal.U
+ ____________________________________________________________________________
+ [ 10283] By: jhi on 2001/05/29 13:26:24
+ Log: Subject: [PATCH 5.6.1] signal names in Configure
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Tue, 29 May 2001 03:52:25 -0400
+ Message-ID: <20010529035225.A9400@math.ohio-state.edu>
+
+ Subject: [PATCH 5.6.1] older perl in Configure
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Tue, 29 May 2001 03:55:40 -0400
+ Message-ID: <20010529035539.A9411@math.ohio-state.edu>
+
+ Subject: [PATCH 5.6.1] goofs in Configure
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Tue, 29 May 2001 04:13:07 -0400
+ Message-ID: <20010529041307.A9658@math.ohio-state.edu>
+
+ Configure portability tweaks.
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10282] By: jhi on 2001/05/29 12:41:41
+ Log: Subject: [PATCH 5.6.1] extLibpath for OS/2
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Tue, 29 May 2001 04:07:06 -0400
+ Message-ID: <20010529040706.A9579@math.ohio-state.edu>
+ Branch: perl
+ ! os2/os2.c
+ ____________________________________________________________________________
+ [ 10281] By: jhi on 2001/05/29 12:40:31
+ Log: Subject: [PATCH 5.6.1] extra static libs for OS/2
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Tue, 29 May 2001 04:01:38 -0400
+ Message-ID: <20010529040138.A9482@math.ohio-state.edu>
+ Branch: perl
+ ! hints/os2.sh os2/Makefile.SHs
+ ____________________________________________________________________________
+ [ 10280] By: jhi on 2001/05/29 12:38:48
+ Log: Subject: Re: [PATCH 5.6.1] Test::Harness clumsy
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Tue, 29 May 2001 03:50:18 -0400
+ Message-ID: <20010529035018.A9387@math.ohio-state.edu>
+ Branch: perl
+ ! lib/Test/Harness.pm
+ ____________________________________________________________________________
+ [ 10279] By: jhi on 2001/05/29 12:34:53
+ Log: Additional safeguard against $@ getting trampled; idea from Hugo.
+ Branch: perl
+ ! lib/utf8_heavy.pl
+ ____________________________________________________________________________
+ [ 10278] By: jhi on 2001/05/29 02:15:24
+ Log: Subject: Re: [ID 20010528.004] dual bug under utf8: $@ has UTF8 flag and \s+ does not match
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Tue, 29 May 2001 03:03:45 +0100
+ Message-Id: <200105290203.DAA00825@crypt.compulink.co.uk>
+
+ Explanation why the $@ always gets the UTF8 flag when under use utf8--
+ because we told it to have the flag when under use utf8.
+ Branch: perl
+ ! pp_ctl.c
+ ____________________________________________________________________________
+ [ 10277] By: jhi on 2001/05/29 00:51:34
+ Log: At least a partial fix for 20010528.004.
+ Branch: perl
+ ! lib/utf8_heavy.pl
+ ____________________________________________________________________________
+ [ 10276] By: jhi on 2001/05/29 00:42:59
+ Log: Subject: Re: Report /pro/3gl/CPAN/perl-5.7.1
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Mon, 28 May 2001 23:39:38 +0100
+ Message-ID: <20010528233938.M86445@plum.flirble.org>
+
+ More portable non-zero UV.
+ Branch: perl
+ ! t/lib/extutils.t
+ ____________________________________________________________________________
+ [ 10275] By: jhi on 2001/05/29 00:40:28
+ Log: Subject: [PATCH] (was Re: Why t/lib/extutils.t is failing ...
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Mon, 28 May 2001 22:46:09 +0100
+ Message-ID: <20010528224608.L86445@plum.flirble.org>
+
+ Test also "make clean".
+ Branch: perl
+ ! t/lib/extutils.t
+ ____________________________________________________________________________
+ [ 10274] By: jhi on 2001/05/29 00:39:18
+ Log: Subject: Re: Would -Wno-unused -Wall be better?
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Tue, 29 May 2001 00:55:54 +0100
+ Message-ID: <20010529005553.B675@blackrider.blackstar.co.uk>
+ Branch: perl
+ ! pp.h
+ ____________________________________________________________________________
+ [ 10273] By: jhi on 2001/05/29 00:36:06
+ Log: Add a test for 20010528.007, fixed in #10272.
+ Branch: perl
+ ! t/op/misc.t toke.c
+ ____________________________________________________________________________
+ [ 10272] By: jhi on 2001/05/29 00:21:12
+ Log: Subject: Re: [ID 20010528.007] "\x{" causes panic:constant overflowed allocated space
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Tue, 29 May 2001 00:23:23 +0100
+ Message-Id: <200105282323.AAA07930@crypt.compulink.co.uk>
+ Branch: perl
+ ! toke.c
+ ____________________________________________________________________________
+ [ 10271] By: jhi on 2001/05/28 22:52:11
+ Log: Subject: Re: [ID 20010528.001] use autouse 'URI::Escape' => qw(URI::Escape::uri_escape) failed
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Tue, 29 May 2001 00:42:59 +0100
+ Message-ID: <20010529004259.A675@blackrider.blackstar.co.uk>
+ Branch: perl
+ ! t/pragma/autouse.t
+ ____________________________________________________________________________
+ [ 10270] By: jhi on 2001/05/28 21:44:06
+ Log: Some shells seemingly arrange the signal handlers differently
+ (bug id 20010521.004).
+ Branch: perl
+ ! t/lib/sigaction.t
+ ____________________________________________________________________________
+ [ 10269] By: jhi on 2001/05/28 20:34:21
+ Log: Regen perlmodlib.
+ Branch: perl
+ ! pod/perlmodlib.pod
+ ____________________________________________________________________________
+ [ 10268] By: jhi on 2001/05/28 19:08:45
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10267] By: jhi on 2001/05/28 19:03:54
+ Log: Subject: [PATCH] perlnewmod.pod to reflect DLSI(P) change
+ From: Elaine -HFB- Ashton <elaine@chaos.wustl.edu>
+ Date: Mon, 28 May 2001 14:56:35 -0500
+ Message-ID: <20010528145635.L8487@chaos.wustl.edu>
+ Branch: perl
+ ! pod/perlnewmod.pod
+ ____________________________________________________________________________
+ [ 10266] By: jhi on 2001/05/28 18:35:03
+ Log: Regen toc.
+ Branch: perl
+ ! pod/perltoc.pod
+ ____________________________________________________________________________
+ [ 10265] By: jhi on 2001/05/28 18:33:32
+ Log: Subject: [PATCH] RE: [20000223.001] no test cases for splice(@array)
+ From: "Richard Soderberg" <rs@crystalflame.net>
+ Date: Mon, 28 May 2001 12:31:23 -0700
+ Message-ID: <NAEKLNAAHLMBPMPNBMLEOEFLDFAA.rs@crystalflame.net>
+ Branch: perl
+ ! t/op/splice.t
+ ____________________________________________________________________________
+ [ 10264] By: jhi on 2001/05/28 17:59:00
+ Log: The #10260 was too bold: locales and utf8 still do not mix.
+ Branch: perl
+ ! t/pragma/locale.t
+ ____________________________________________________________________________
+ [ 10263] By: jhi on 2001/05/28 17:52:25
+ Log: Subject: [PATCH] Pod nitpicks
+ From: "Richard Soderberg" <rs@crystalflame.net>
+ Date: Mon, 28 May 2001 10:08:58 -0700
+ Message-ID: <NAEKLNAAHLMBPMPNBMLEOEFGDFAA.rs@crystalflame.net>
+ Branch: perl
+ ! pod/perl571delta.pod pod/perlapi.pod sv.h
+ ____________________________________________________________________________
+ [ 10262] By: jhi on 2001/05/28 17:50:05
+ Log: Upgrade to I18N::LangTags 0.22.
+ Branch: perl
+ + lib/I18N/LangTags/List.pod
+ ! MANIFEST lib/I18N/LangTags.pm
+ ____________________________________________________________________________
+ [ 10261] By: jhi on 2001/05/28 17:23:40
+ Log: A slightly more serious bug found by -Mutf8; op/misc and
+ lib/complex dumped core.
+ Branch: perl
+ ! regexec.c
+ ____________________________________________________________________________
+ [ 10260] By: jhi on 2001/05/28 16:58:11
+ Log: Various buglets shaken out by -Mutf8.
+ Branch: perl
+ ! t/io/utf8.t t/lib/charnames.t t/lib/lc-language.t
+ ! t/pragma/locale.t
+ ____________________________________________________________________________
+ [ 10259] By: jhi on 2001/05/28 15:48:46
+ Log: STDERR looks much like STDOUT. (Subtest #2 wasn't really okay.)
+ Branch: perl
+ ! t/lib/carp.t
+ ____________________________________________________________________________
+ [ 10258] By: jhi on 2001/05/28 15:32:41
+ Log: Subject: [PATCH] todo patch
+ From: Artur Bergman <artur@contiller.se>
+ Date: Mon, 28 May 2001 17:03:51 +0200
+ Message-ID: <B7383577.F34%artur@contiller.se>
+ Branch: perl
+ ! pod/perltodo.pod
+ ____________________________________________________________________________
+ [ 10257] By: jhi on 2001/05/28 15:31:25
+ Log: Subject: typo in perlguts.pod
+ From: "John P. Linderman" <jpl@research.att.com>
+ Date: Mon, 28 May 2001 09:35:47 -0400 (EDT)
+ Message-Id: <200105281335.JAA27851@raptor.research.att.com>
+ Branch: perl
+ ! pod/perlguts.pod
+ ____________________________________________________________________________
+ [ 10256] By: jhi on 2001/05/28 15:30:42
+ Log: Subject: AIX and gcc (moving targets)
+ From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+ Date: Mon, 28 May 2001 12:54:04 +0200
+ Message-Id: <20010528124531.9FAB.H.M.BRAND@hccnet.nl>
+ Branch: perl
+ ! hints/aix.sh
+ ____________________________________________________________________________
+ [ 10255] By: jhi on 2001/05/28 15:28:55
+ Log: Subject: Re: perlio + multiple perl_alloc..destruct
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Sun, 27 May 2001 13:47:13 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0105271340370.5938-100000@mako.covalent.net>
+ Branch: perl
+ ! perlio.c
+ ____________________________________________________________________________
+ [ 10254] By: jhi on 2001/05/28 15:27:49
+ Log: The #10251 wasn't quite up-to-the-code.
+ Branch: perl
+ ! t/op/misc.t
+ ____________________________________________________________________________
+ [ 10253] By: jhi on 2001/05/28 15:26:39
+ Log: Test case for bug 20010526.004, fixed in #10252.
+ Branch: perl
+ ! t/op/taint.t
+ ____________________________________________________________________________
+ [ 10252] By: jhi on 2001/05/28 15:26:14
+ Log: Subject: Re: [ID 20010526.004] Taint looses value
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Sun, 27 May 2001 20:39:32 +0100
+ Message-Id: <200105271939.UAA27591@crypt.compulink.co.uk>
+ Branch: perl
+ ! sv.c
+ ____________________________________________________________________________
+ [ 10251] By: jhi on 2001/05/28 15:13:40
+ Log: Test case for 20010422.005, fixed by #10250.
+ Branch: perl
+ ! t/op/misc.t
+ ____________________________________________________________________________
+ [ 10250] By: jhi on 2001/05/28 15:11:16
+ Log: Subject: [PATCH] Re: [ID 20010422.005] perl -e '{s//${}/; //}' # segfaults on FreeBSD
+ From: Spider Boardman <spider@Orb.Nashua.NH.US>
+ Date: Mon, 28 May 2001 06:39:12 -0400
+ Message-Id: <200105281039.GAA03962@Orb.Nashua.NH.US>
+ Branch: perl
+ ! toke.c
+ ____________________________________________________________________________
+ [ 10249] By: jhi on 2001/05/28 15:09:24
+ Log: Linerewrapping.
+ Branch: perl
+ ! lib/open.pm
+ ____________________________________________________________________________
+ [ 10248] By: jhi on 2001/05/28 15:09:07
+ Log: Updates on the modules list.
+ Branch: perl
+ ! t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 10247] By: jhi on 2001/05/28 15:03:35
+ Log: Add a test for PerlIO.
+
+ (I probably got the crlf/raw thing wrong for clrfy platforms...)
+ Branch: perl
+ + t/lib/perlio.t
+ ! MANIFEST lib/PerlIO.pm
+ ____________________________________________________________________________
+ [ 10246] By: jhi on 2001/05/28 14:24:08
+ Log: Add a test for carp et alia.
+ Branch: perl
+ + t/lib/carp.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10245] By: jhi on 2001/05/28 13:42:55
+ Log: Adding the new test would be swell.
+ Branch: perl
+ + t/pragma/autouse.t
+ ____________________________________________________________________________
+ [ 10244] By: jhi on 2001/05/28 13:42:34
+ Log: Add a test for the autouse pragma.
+ Branch: perl
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10243] By: jhi on 2001/05/28 13:26:25
+ Log: Subject: [ID 20010528.001] use autouse 'URI::Escape' => qw(URI::Escape::uri_escape) failed
+ From: dLux <dlux@spam.sch.bme.hu>
+ Date: Sun, 27 May 2001 16:14:26 +0200
+ Message-Id: <E1541JK-0000YC-00@dl.sch.bme.hu>
+ Branch: perl
+ ! lib/autouse.pm
+ ____________________________________________________________________________
+ [ 10242] By: jhi on 2001/05/28 13:21:50
+ Log: Subject: [PATCH #2] RE: [ID 20010528.002] dprofpp: "-R" does not work
+ From: "Richard Soderberg" <rs@crystalflame.net>
+ Date: Mon, 28 May 2001 03:56:36 -0700
+ Message-ID: <NAEKLNAAHLMBPMPNBMLEEEFADFAA.rs@crystalflame.net>
+ Branch: perl
+ ! utils/dprofpp.PL
+ ____________________________________________________________________________
+ [ 10241] By: jhi on 2001/05/28 13:18:56
+ Log: Subject: Re: [ID 20010522.003] Time::Local module bug
+ From: "Stephen P. Potter" <spp@spotter.yi.org>
+ Date: Tue, 22 May 2001 11:40:25 -0400
+ Message-Id: <20010522154030.584F4729E2@belgarath.spotter.yi.org>
+
+ Subject: Re: [ID 20010522.003] Time::Local module bug
+ From: Ronald J Kimball <rjk@linguist.Thayer.dartmouth.edu>
+ Date: Tue, 22 May 2001 11:50:19 -0400
+ Message-ID: <20010522115019.D48634@linguist.thayer.dartmouth.edu>
+ Branch: perl
+ ! lib/Time/Local.pm
+ ____________________________________________________________________________
+ [ 10240] By: jhi on 2001/05/27 22:44:49
+ Log: The PERL_DL_NONLAZY can have whitespace in front.
+ Branch: perl
+ ! t/lib/extutils.t
+ ____________________________________________________________________________
+ [ 10239] By: jhi on 2001/05/27 21:23:21
+ Log: Document strftime() and strptime().
+ Branch: perl
+ ! ext/POSIX/POSIX.pod ext/Time/Piece/Piece.pm t/lib/time-piece.t
+ ____________________________________________________________________________
+ [ 10238] By: jhi on 2001/05/27 20:29:07
+ Log: Make Time::Piece::strptime() to be a function, not a method.
+ Branch: perl
+ ! ext/Time/Piece/Piece.pm t/lib/time-piece.t
+ ____________________________________________________________________________
+ [ 10237] By: jhi on 2001/05/27 20:22:09
+ Log: Tweak the test to be more portable.
+ Branch: perl
+ ! t/lib/extutils.t
+ ____________________________________________________________________________
+ [ 10236] By: jhi on 2001/05/27 19:15:54
+ Log: Subject: PATCH: Re: Re: Attributes that tie
+ From: Leon Brocard <acme@astray.com>
+ Date: Sun, 27 May 2001 12:37:29 +0100
+ Message-ID: <20010527123729.A22663@ns0.astray.com>
+
+ Document that variable attributes are not currently usable
+ for tieing. (An ugly limitation that should be fixed.)
+ Branch: perl
+ ! lib/attributes.pm
+ ____________________________________________________________________________
+ [ 10235] By: jhi on 2001/05/27 19:03:31
+ Log: Microperl tweaks.
+ Branch: perl
+ ! Makefile.micro uconfig.h uconfig.sh
+ ____________________________________________________________________________
+ [ 10234] By: jhi on 2001/05/27 18:22:09
+ Log: Add make target for microperl (kind of silly, but convenient).
+ Branch: perl
+ ! Makefile.SH
+ ____________________________________________________________________________
+ [ 10233] By: jhi on 2001/05/27 18:18:56
+ Log: O_APPEND and O_TRUNC are not portable. (Not available e.g.
+ for microperl.)
+ Branch: perl
+ ! doio.c
+ ____________________________________________________________________________
+ [ 10232] By: jhi on 2001/05/27 17:57:18
+ Log: Subject: [PATCH] [ID 19991013.005] utime undef, undef, @files
+ From: rspier@pobox.com (Robert Spier)
+ Date: Sat, 26 May 2001 20:05:23 -0400
+ Message-ID: <15120.17603.148648.12430@rls.cx>
+
+ Subject: Re: [PATCH] [ID 19991013.005] utime undef, undef, @files
+ From: rspier@pobox.com (Robert Spier)
+ Date: Sun, 27 May 2001 00:23:12 -0400
+ Message-ID: <15120.33072.511966.767230@rls.cx>
+ Branch: perl
+ ! doio.c pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 10231] By: jhi on 2001/05/27 15:45:20
+ Log: Regen toc. (And add the README.tru64 from #10230 to MANIFEST.)
+ Branch: perl
+ ! MANIFEST pod/buildtoc.PL pod/perl.pod pod/perltoc.pod
+ ____________________________________________________________________________
+ [ 10230] By: jhi on 2001/05/27 15:41:06
+ Log: Add README.tru64.
+ Branch: perl
+ + README.tru64
+ ____________________________________________________________________________
+ [ 10229] By: jhi on 2001/05/27 13:50:57
+ Log: Integrate Locale::Maketext 1.01 from Sean Burke.
+ Branch: perl
+ + lib/Locale/Maketext.pm lib/Locale/Maketext.pod
+ + lib/Locale/Maketext/TPJ13.pod t/lib/lc-maketext.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10228] By: jhi on 2001/05/27 13:43:38
+ Log: Integrate I18N::LangTags from Sean Burke.
+
+ TODO: the language list from RFC 3066 needs to be integrated
+ and made available somehow. The list is included in the
+ I18N-LangTags 0.21 distribution, but it is undocumented
+ and unconnected to the module.
+ Branch: perl
+ + lib/I18N/LangTags.pm t/lib/i18n-langtags.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10227] By: jhi on 2001/05/27 01:41:33
+ Log: Allow 'eval "v200"' to work (part of 20000323.059); fix as
+ envisioned by Sarathy.
+ Branch: perl
+ ! t/op/ver.t toke.c
+ ____________________________________________________________________________
+ [ 10226] By: jhi on 2001/05/27 00:28:34
+ Log: Subject: [ID 20010525.001] Pod typo nits fixed
+ From: lvirden@cas.org
+ Date: Fri, 25 May 2001 06:57:43 -0400 (EDT)
+ Message-Id: <200105251057.f4PAvhY13003@lwv26awu.cas.org>
+
+ minus the perlsolaris decimation plus the
+
+ Subject: Re: [ID 20010525.001] Pod typo nits fixed
+ From: "Philip Newton" <Philip.Newton@gmx.net>
+ Date: Fri, 25 May 2001 18:05:55 +0200
+ Message-Id: <200105251604.f4PG4kt15034@chaos.wustl.edu>
+ Branch: perl
+ ! README.amiga README.cygwin README.mpeix pod/perl5005delta.pod
+ ! pod/perldebtut.pod pod/perlebcdic.pod pod/perlfaq3.pod
+ ! pod/perlhack.pod pod/perltoc.pod pod/perltodo.pod
+ ! pod/perlutil.pod pod/perlxstut.pod
+ ____________________________________________________________________________
+ [ 10225] By: jhi on 2001/05/26 22:38:16
+ Log: return clauses are nice.
+ Branch: perl
+ ! sv.c
+ ____________________________________________________________________________
+ [ 10224] By: jhi on 2001/05/26 22:35:31
+ Log: Subject: change 10199 backwards?
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Sat, 26 May 2001 11:26:07 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0105261118510.22038-100000@mako.covalent.net>
+ Branch: perl
+ ! sv.c
+ ____________________________________________________________________________
+ [ 10223] By: jhi on 2001/05/26 22:31:46
+ Log: Subject: Re: 5.6.*, bleadperl: bugs in pp_concat
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Sat, 26 May 2001 17:05:12 +0100
+ Message-Id: <200105261605.RAA12295@crypt.compulink.co.uk>
+ Branch: perl
+ + t/op/gmagic.t
+ ! MANIFEST doop.c embed.h embed.pl global.sym
+ ! lib/File/Basename.pm objXSUB.h perlapi.c pod/perlapi.pod
+ ! pp_hot.c proto.h sv.c sv.h t/pragma/warn/pp_hot
+ ____________________________________________________________________________
+ [ 10222] By: jhi on 2001/05/26 22:10:38
+ Log: Regen headers for #10221.
+ Branch: perl
+ ! global.sym objXSUB.h perlapi.c
+ ____________________________________________________________________________
+ [ 10221] By: jhi on 2001/05/26 22:06:06
+ Log: Subject: [ID 20010506.012] Patch for 5.6.1 embed.pl (shared libperl&mod_perl)
+ From: Juha Laiho <juha.laiho@Elma.Net>
+ Date: Thu, 3 May 2001 09:51:30 +0300
+ Message-Id: <200105030651.JAA327254@tokka.elma.fi>
+ Branch: perl
+ ! embed.pl
+ ____________________________________________________________________________
+ [ 10220] By: jhi on 2001/05/26 22:01:30
+ Log: Subject: Re: [PATCH] Re: stability of sort()?
+ From: "John P. Linderman" <jpl@research.att.com>
+ Date: Sat, 26 May 2001 13:27:19 -0400
+ Message-Id: <200105261727.NAA06654@raptor.research.att.com>
+ Branch: perl
+ ! pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 10219] By: jhi on 2001/05/26 14:02:34
+ Log: Integrate perlio.
+ Branch: perl
+ !> pod/perlguts.pod
+ ____________________________________________________________________________
+ [ 10218] By: jhi on 2001/05/26 13:39:52
+ Log: Subject: [PATCH perl@10210] PerlIO for VMS
+ From: "Craig A. Berry" <craigberry@mac.com>
+ Date: Sat, 26 May 2001 09:34:11 -0500
+ Message-Id: <a05100e0ab734816701a5@[172.16.52.1]>
+ Branch: perl
+ ! configure.com doio.c iperlsys.h perlio.c perlio.h perliol.h
+ ! perlsdio.h vms/ext/Stdio/Stdio.xs vms/gen_shrfls.pl vms/vms.c
+ ! vms/vmsish.h
+ ____________________________________________________________________________
+ [ 10217] By: jhi on 2001/05/26 13:19:05
+ Log: Subject: patch to fix: [ID 20010524.004] perl5db.pl version 1.12 doesn't stop on breakpoints
+ From: David Dyck <dcd@tc.fluke.com>
+ Date: Fri, 25 May 2001 00:03:04 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.33.0105242354030.17331-100000@dd.tc.fluke.com>
+ Branch: perl
+ ! lib/perl5db.pl
+ ____________________________________________________________________________
+ [ 10216] By: jhi on 2001/05/26 13:17:47
+ Log: Subject: utf8 regexp tests
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Fri, 25 May 2001 22:35:01 +0100
+ Message-Id: <200105252135.WAA03197@crypt.compulink.co.uk>
+ Branch: perl
+ ! t/op/regexp.t
+ ____________________________________________________________________________
+ [ 10215] By: jhi on 2001/05/26 13:15:40
+ Log: Subject: [PATCH] Re: stability of sort()?
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Fri, 25 May 2001 22:40:19 +0100
+ Message-ID: <20010525224019.B86445@plum.flirble.org>
+ Branch: perl
+ ! pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 10214] By: jhi on 2001/05/26 13:14:30
+ Log: Subject: Re: [ID 20010426.005] Magic not being removed at scope exit [PATCH]
+ From: John Peacock <jpeacock@rowman.com>
+ Date: Thu, 24 May 2001 22:14:01 -0400
+ Message-ID: <3B0DBFE9.A7C49084@rowman.com>
+ Branch: perl
+ ! mg.c scope.c sv.c
+ ____________________________________________________________________________
+ [ 10213] By: jhi on 2001/05/26 13:08:56
+ Log: Subject: [PATCH] Re: [PATCH] Re: h2xs [was Re: HEAR YE, HEAR YE!]
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Sun, 20 May 2001 19:24:13 +0100
+ Message-ID: <20010520192413.G83222@plum.flirble.org>
+ Branch: perl
+ + lib/ExtUtils/Constant.pm t/lib/extutils.t
+ ! MANIFEST utils/h2xs.PL
+ ____________________________________________________________________________
+ [ 10212] By: nick on 2001/05/26 09:49:28
+ Log: Change perlguts docs to not suggest PUSHi etc. for multiple results,
+ add a few more notes there on use of mortals on the stack.
+ Branch: perlio
+ ! pod/perlguts.pod
+ ____________________________________________________________________________
+ [ 10211] By: nick on 2001/05/26 09:05:36
+ Log: Integrate mainline
+ Branch: perlio
+ +> t/lib/fcntl.t t/pragma/vars.t
+ !> (integrate 49 files)
+ ____________________________________________________________________________
+ [ 10210] By: jhi on 2001/05/25 12:29:16
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10209] By: jhi on 2001/05/25 12:24:45
+ Log: Based on
+
+ Subject: [PATCH pp.c] Wrapping pack("C",256)
+ From: Simon Cozens <simon@netthink.co.uk>
+ Date: Sat, 12 May 2001 17:58:41 +0100
+ Message-ID: <20010512175841.A6132@netthink.co.uk>
+ Branch: perl
+ ! pod/perldiag.pod pp.c t/pragma/warn/pp
+ ____________________________________________________________________________
+ [ 10208] By: jhi on 2001/05/25 01:37:03
+ Log: Subject: [PATCH] 5.6.1 Term::Cap -- add terminfo fallback
+ From: "Brendan O'Dea" <bod@compusol.com.au>
+ Date: Fri, 25 May 2001 11:18:29 +1000
+ Message-ID: <20010525111829.A28411@compusol.com.au>
+
+ (Slightly modified.)
+ Branch: perl
+ ! lib/Term/Cap.pm
+ ____________________________________________________________________________
+ [ 10207] By: jhi on 2001/05/25 01:12:14
+ Log: Subject: Re: [ID 20010506.041] segfault when matching utf8 string
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Fri, 25 May 2001 02:13:25 +0100
+ Message-Id: <200105250113.CAA23158@crypt.compulink.co.uk>
+ Branch: perl
+ ! t/op/misc.t
+ ____________________________________________________________________________
+ [ 10206] By: jhi on 2001/05/25 01:07:59
+ Log: Subject: Re: [ID 20010506.041] segfault when matching utf8 string
+ From: Inaba Hiroto <hiroto.inaba@toshiba.co.jp>
+ Date: Fri, 25 May 2001 10:25:36 +0900
+ Message-Id: <200105250124.KAA19571@toshiba.co.jp>
+ Branch: perl
+ ! regcomp.c regexec.c
+ ____________________________________________________________________________
+ [ 10205] By: jhi on 2001/05/25 01:07:00
+ Log: Subject: [PATCH #2] stash autovivification and method call error messages
+ From: Ilmari Karonen <iltzu@sci.fi>
+ Date: Thu, 24 May 2001 01:51:48 +0300 (EET DST)
+ Message-ID: <Pine.SOL.3.96.1010524013737.18819D-100000@simpukka>
+ Branch: perl
+ ! gv.c pp_hot.c t/op/method.t
+ ____________________________________________________________________________
+ [ 10204] By: jhi on 2001/05/25 01:03:50
+ Log: Add make target and documentation for gprof profiling.
+ Branch: perl
+ ! Makefile.SH pod/perlhack.pod
+ ____________________________________________________________________________
+ [ 10203] By: jhi on 2001/05/24 21:09:36
+ Log: Subject: Don't think about UTF8
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Tue, 22 May 2001 14:35:39 +0100
+ Message-Id: <E152CK3-00028O-00@virgo.cus.cam.ac.uk>
+ Branch: perl
+ ! sv.h
+ ____________________________________________________________________________
+ [ 10202] By: jhi on 2001/05/24 21:07:25
+ Log: Subject: [ID 20010524.002] find2perl bug in fileglob_to_re
+ From: Geraint A Edwards <gedge@serf.org>
+ Date: Thu, 24 May 2001 22:51:24 +0100
+ Message-Id: <20010524225124.A34981@cymru.serf.org>
+ Branch: perl
+ ! x2p/find2perl.PL
+ ____________________________________________________________________________
+ [ 10201] By: jhi on 2001/05/24 21:02:30
+ Log: DB_File has its own attribute story.
+ Branch: perl
+ ! ext/DB_File/DB_File.xs
+ ____________________________________________________________________________
+ [ 10200] By: jhi on 2001/05/24 19:54:21
+ Log: Subject: Re: Making perl with -Wall
+ From: Andy Dougherty <doughera@lafayette.edu>
+ Date: Thu, 24 May 2001 14:33:37 -0400 (EDT)
+ Message-ID: <Pine.SOL.4.10.10105241415460.2443-100000@maxwell.phys.lafayette.edu>
+ Branch: perl
+ ! perl.h
+ ____________________________________________________________________________
+ [ 10199] By: jhi on 2001/05/24 15:15:03
+ Log: Subject: RE: [ID 20010521.003] - [PATCH #2] sv.c: sv_dup_inc(SvRV(sstr)) wasn't checking SvWEAKREF
+ From: "Richard Soderberg" <rs@crystalflame.net>
+ Date: Thu, 24 May 2001 08:58:16 -0700
+ Message-ID: <NAEKLNAAHLMBPMPNBMLEOEPODEAA.rs@crystalflame.net>
+ Branch: perl
+ ! sv.c
+ ____________________________________________________________________________
+ [ 10198] By: jhi on 2001/05/24 15:10:04
+ Log: IV/UV casting fixes from Nicholas Clark.
+ Branch: perl
+ ! perl.h pp_sys.c util.c
+ ____________________________________________________________________________
+ [ 10197] By: jhi on 2001/05/24 14:19:44
+ Log: Subject: Re: Making perl with -Wall
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Thu, 24 May 2001 15:40:28 +0100
+ Message-ID: <20010524154028.B1988@blackrider.blackstar.co.uk>
+ Branch: perl
+ ! malloc.c perl.h
+ ____________________________________________________________________________
+ [ 10196] By: jhi on 2001/05/24 14:04:41
+ Log: Subject: [PATCH] Re: [ID 20010521.004] Two test suite failures on this platform with latest rsync
+ From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+ Date: Tue, 22 May 2001 11:49:37 +0200
+ Message-Id: <20010522114044.BC4E.H.M.BRAND@hccnet.nl>
+ Branch: metaconfig
+ ! U/modified/Oldsym.U
+ Branch: metaconfig/U/perl
+ ! patchlevel.U
+ Branch: perl
+ ! Configure config_h.SH myconfig.SH
+ ____________________________________________________________________________
+ [ 10195] By: jhi on 2001/05/24 13:25:04
+ Log: Under versiononly install also the scripts with the version suffix.
+ (e.g. .../bin/h2xs5.7.1)
+ Branch: perl
+ ! installperl
+ ____________________________________________________________________________
+ [ 10194] By: jhi on 2001/05/24 13:02:49
+ Log: Subject: [PATCH] Stop segfault in mg.c:636
+ From: "Richard Soderberg" <rs@crystalflame.net>
+ Date: Thu, 24 May 2001 05:51:52 -0700
+ Message-ID: <NAEKLNAAHLMBPMPNBMLEGEPGDEAA.rs@crystalflame.net>
+ Branch: perl
+ ! mg.c
+ ____________________________________________________________________________
+ [ 10193] By: jhi on 2001/05/24 12:37:13
+ Log: Iteration continues; hopefully convergently.
+ Branch: perl
+ ! t/lib/b-stash.t
+ ____________________________________________________________________________
+ [ 10192] By: jhi on 2001/05/24 12:36:35
+ Log: Subject: [PATCH] CORE::GLOBAL::require override happens too early
+ From: Gisle Aas <gisle@ActiveState.com>
+ Date: 23 May 2001 16:13:10 -0700
+ Message-ID: <lrofsjfym1.fsf@caliper.ActiveState.com>
+ Branch: perl
+ ! op.c toke.c
+ ____________________________________________________________________________
+ [ 10191] By: jhi on 2001/05/24 12:25:12
+ Log: Subject: [PATCH] lib/dumpvar.pl, lib/perl5db.pl - fix warnings
+ From: "Daniel S. Lewart" <d-lewart@uiuc.edu>
+ Date: Thu, 24 May 2001 05:05:22 -0500
+ Message-ID: <20010524050522.A18997@staff1.cso.uiuc.edu>
+ Branch: perl
+ ! lib/dumpvar.pl lib/perl5db.pl
+ ____________________________________________________________________________
+ [ 10190] By: jhi on 2001/05/24 12:24:07
+ Log: Subject: Re: [ID 20010524.001] perl5db.pl x @INC doesn't work like it used to
+ From: David Dyck <dcd@tc.fluke.com>
+ Date: Thu, 24 May 2001 01:42:09 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.33.0105240134580.5179-100000@dd.tc.fluke.com>
+ Branch: perl
+ ! lib/perl5db.pl
+ ____________________________________________________________________________
+ [ 10189] By: jhi on 2001/05/23 22:43:31
+ Log: Tiny pod nits on READMEs, mostly whitespace issues.
+ Branch: perl
+ ! README.amiga README.dos README.macos README.mpeix README.vmesa
+ ! README.win32
+ ____________________________________________________________________________
+ [ 10188] By: jhi on 2001/05/23 22:26:03
+ Log: The DG/UX part of the 20010521.005.
+ Branch: perl
+ ! README.dgux
+ ____________________________________________________________________________
+ [ 10187] By: jhi on 2001/05/23 22:04:05
+ Log: Subject: Re: [ID 20000716.007] \G in a m//g expression causes problems
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Mon, 21 May 2001 16:32:02 +0100
+ Message-Id: <200105211532.QAA03999@crypt.compulink.co.uk>
+ Branch: perl
+ ! regcomp.c t/op/misc.t
+ ____________________________________________________________________________
+ [ 10186] By: jhi on 2001/05/23 21:42:15
+ Log: Subject: [PATCH] Extra UNIVERSAL tests
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Wed, 23 May 2001 12:29:20 +0100
+ Message-Id: <E152WpM-0001yP-00@virgo.cus.cam.ac.uk>
+ Branch: perl
+ ! t/op/universal.t
+ ____________________________________________________________________________
+ [ 10185] By: jhi on 2001/05/23 21:38:48
+ Log: Subject: [PATCH] Remove EQ keyword
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Message-Id: <E152Vhp-00072x-00@virgo.cus.cam.ac.uk>
+ Date: Wed, 23 May 2001 11:17:29 +0100
+ Branch: perl
+ ! keywords.h keywords.pl
+ ____________________________________________________________________________
+ [ 10184] By: jhi on 2001/05/23 21:29:41
+ Log: Subject: [PATCH] lib/perl5db.pl
+ From: "Daniel S. Lewart" <d-lewart@uiuc.edu>
+ Date: Wed, 23 May 2001 02:18:03 -0500
+ Message-ID: <20010523021803.A21965@staff1.cso.uiuc.edu>
+ Branch: perl
+ ! lib/perl5db.pl
+ ____________________________________________________________________________
+ [ 10183] By: jhi on 2001/05/23 21:27:54
+ Log: Subject: [PATCH lib/Term/Cap.pm] Avoid -W warnings in Tgetent and Tputs
+ From: "Daniel S. Lewart" <d-lewart@uiuc.edu>
+ Date: Tue, 22 May 2001 23:34:41 -0500
+ Message-ID: <20010522233441.A12431@staff1.cso.uiuc.edu>
+ Branch: perl
+ ! lib/Term/Cap.pm
+ ____________________________________________________________________________
+ [ 10182] By: jhi on 2001/05/23 21:24:30
+ Log: Subject: [PATCH emacs/e2ctags.pl] big speedup
+ From: davem@fdgroup.co.uk
+ Date: Tue, 22 May 2001 22:08:09 +0100 (BST)
+ Message-Id: <200105222108.WAA09442@gizmo.fdgroup.co.uk>
+ Branch: perl
+ ! emacs/e2ctags.pl
+ ____________________________________________________________________________
+ [ 10181] By: jhi on 2001/05/23 21:23:29
+ Log: Subject: [PATCH lib/vars.pm] Sensible minimum version
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Tue, 22 May 2001 14:15:09 +0100
+ Message-ID: <20010522141509.J701@blackrider.blackstar.co.uk>
+ Branch: perl
+ ! lib/vars.pm
+ ____________________________________________________________________________
+ [ 10180] By: jhi on 2001/05/23 21:22:14
+ Log: Subject: [PATCH lib/vars.pm] Odd code nit
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Tue, 22 May 2001 14:14:28 +0100
+ Message-ID: <20010522141427.I701@blackrider.blackstar.co.uk>
+ Branch: perl
+ ! lib/vars.pm
+ ____________________________________________________________________________
+ [ 10179] By: jhi on 2001/05/23 21:19:51
+ Log: Use the new use vars feature.
+ Branch: perl
+ ! t/lib/b-stash.t
+ ____________________________________________________________________________
+ [ 10178] By: jhi on 2001/05/23 21:19:28
+ Log: Subject: [PATCH] vars.pm to support qualified variables (was Re: [ID 20010521.001])
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Sender: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Date: Tue, 22 May 2001 13:11:39 +0100
+ Branch: perl
+ + t/pragma/vars.t
+ ! MANIFEST lib/vars.pm t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 10177] By: jhi on 2001/05/23 21:01:48
+ Log: -qlongdouble considered harmful by Merijn.
+ Branch: perl
+ ! hints/aix.sh
+ ____________________________________________________________________________
+ [ 10176] By: jhi on 2001/05/21 13:21:21
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10175] By: jhi on 2001/05/21 13:17:28
+ Log: Add a test of its very own for Fcntl. Hopefully portable.
+ Branch: perl
+ + t/lib/fcntl.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10174] By: jhi on 2001/05/21 12:45:41
+ Log: Must be trickier for 'minitest' not to die.
+ Branch: perl
+ ! t/op/taint.t
+ ____________________________________________________________________________
+ [ 10173] By: jhi on 2001/05/21 11:24:43
+ Log: Can't declare other people's variables.
+ Branch: perl
+ ! t/lib/b-stash.t
+ ____________________________________________________________________________
+ [ 10172] By: jhi on 2001/05/20 20:33:08
+ Log: Fix for ID 20010519.003: sysopen() wasn't tainting :-(
+ Branch: perl
+ ! doio.c t/op/taint.t
+ ____________________________________________________________________________
+ [ 10171] By: jhi on 2001/05/20 20:18:45
+ Log: The OS/2 variable needs to be declared.
+ Branch: perl
+ ! t/lib/b-stash.t
+ ____________________________________________________________________________
+ [ 10170] By: nick on 2001/05/20 16:48:29
+ Log: Integrate mainline
+ Branch: perlio
+ !> (integrate 41 files)
+ ____________________________________________________________________________
+ [ 10169] By: jhi on 2001/05/20 11:50:20
+ Log: Small perlsec updates: clarify the taintedness of filename
+ globbing; suggest using Scalar::Util::tainted().
+ Branch: perl
+ ! pod/perlsec.pod
+ ____________________________________________________________________________
+ [ 10168] By: jhi on 2001/05/20 11:24:11
+ Log: Subject: [PATCH 5.7.1@10135] [LARGE!] symbolic magic
+ From: Dave Mitchell <davem@fdgroup.co.uk>
+ Date: Sat, 19 May 2001 20:12:56 +0100 (BST)
+ Message-Id: <200105191912.UAA23925@gizmo.fdgroup.co.uk>
+ Branch: perl
+ ! av.c cc_runtime.h doop.c dump.c gv.c hv.c mg.c op.c perl.c
+ ! perl.h perlio.c pod/perlguts.pod pp.c pp_ctl.c pp_hot.c
+ ! pp_sys.c regexec.c scope.c sv.c t/lib/peek.t taint.c util.c
+ ! xsutils.c
+ ____________________________________________________________________________
+ [ 10167] By: jhi on 2001/05/20 11:12:14
+ Log: Subject: [PATCH 5.6.1] DLL descriptions on OS/2
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sat, 19 May 2001 04:08:46 -0400
+ Message-ID: <20010519040846.A16969@math.ohio-state.edu>
+ Branch: perl
+ ! lib/ExtUtils/Mksymlists.pm makedef.pl
+ ____________________________________________________________________________
+ [ 10166] By: jhi on 2001/05/20 11:08:27
+ Log: Subject: [PATCH 5.6.1] DLL name mangling on OS/2
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sat, 19 May 2001 04:30:45 -0400
+ Message-ID: <20010519043045.A17033@math.ohio-state.edu>
+ Branch: perl
+ ! os2/os2.c
+ ____________________________________________________________________________
+ [ 10165] By: jhi on 2001/05/20 11:07:06
+ Log: Subject: [PATCH 5.6.1] build bugs OS/2
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sat, 19 May 2001 04:35:28 -0400
+ Message-ID: <20010519043528.A17363@math.ohio-state.edu>
+ Branch: perl
+ ! os2/Makefile.SHs os2/os2.c
+ ____________________________________________________________________________
+ [ 10164] By: jhi on 2001/05/20 11:06:01
+ Log: Subject: [PATCH 5.6.1] Mis-Failing tests
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sat, 19 May 2001 04:04:23 -0400
+ Message-ID: <20010519040423.A16861@math.ohio-state.edu>
+
+ (In bleadperl patched b-stash.t instead of b.t)
+ Branch: perl
+ ! t/lib/b-stash.t t/lib/bigfltpm.t
+ ____________________________________________________________________________
+ [ 10163] By: jhi on 2001/05/20 10:59:46
+ Log: Subject: [PATCH 5.6.1] perl5db
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sat, 19 May 2001 03:49:09 -0400
+ Message-ID: <20010519034909.A14902@math.ohio-state.edu>
+ Branch: perl
+ ! lib/perl5db.pl
+ ____________________________________________________________________________
+ [ 10162] By: jhi on 2001/05/20 10:58:18
+ Log: Subject: [PATCH] require $mod where $mod has touched numeric context
+ From: Gisle Aas <gisle@ActiveState.com>
+ Date: 18 May 2001 14:24:51 -0700
+ Message-ID: <lr3da2cpuk.fsf@caliper.ActiveState.com>
+ Branch: perl
+ ! pp_ctl.c
+ ____________________________________________________________________________
+ [ 10161] By: jhi on 2001/05/20 10:57:00
+ Log: Subject: [PATCH] Chomp should not always stringify
+ From: Gisle Aas <gisle@ActiveState.com>
+ Date: 18 May 2001 07:55:25 -0700
+ Message-ID: <lrk83eogf6.fsf@caliper.ActiveState.com>
+ Branch: perl
+ ! doop.c t/op/chop.t
+ ____________________________________________________________________________
+ [ 10160] By: jhi on 2001/05/20 10:49:40
+ Log: Integrate perlio.
+ Branch: perl
+ !> pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 10159] By: nick on 2001/05/20 09:39:46
+ Log: Document some more of open's features.
+ Branch: perlio
+ ! pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 10158] By: gsar on 2001/05/18 18:43:38
+ Log: back out change#10153 (it has compatibility issues such as the
+ changed behavior of /[~%@+-]/, and after talking to Jarkko, the
+ benefit for 5.6.x doesn't seem worth the risk)
+ Branch: maint-5.6/perl
+ ! toke.c
+ ____________________________________________________________________________
+ [ 10157] By: jhi on 2001/05/18 17:05:40
+ Log: \$escaping the $vars in !GROK!THIS! section is a good idea.
+ Branch: perl
+ ! x2p/s2p.PL
+ ____________________________________________________________________________
+ [ 10156] By: jhi on 2001/05/18 12:06:40
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10155] By: jhi on 2001/05/18 11:58:57
+ Log: Integrate change #10144 from maintperl.
+
+ s/CONFIGDOTSH/PERL_CONFIG_SH/ for Win32, too.
+ Branch: perl
+ !> win32/config.bc win32/config.gc win32/config.vc
+ !> win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ____________________________________________________________________________
+ [ 10154] By: nick on 2001/05/18 07:23:03
+ Log: Integrate mainline.
+ Branch: perlio
+ +> README.dgux t/lib/i18n-collate.t utils.lst
+ !> (integrate 49 files)
+ ____________________________________________________________________________
+ [ 10153] By: jhi on 2001/05/18 00:41:51
+ Log: Integrate change #7224 from mainline into maintperl.
+
+ Allow @+ and @- to be doublequoted, from Simon Cozens.
+ (Approved by Larry, see Tom's comment in 20000830.005.)
+ Branch: maint-5.6/perl
+ !> toke.c
+ ____________________________________________________________________________
+ [ 10152] By: jhi on 2001/05/17 23:18:15
+ Log: Subject: [PATCH bleadperl] small lookbehind fix
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Fri, 18 May 2001 00:07:19 +0100
+ Message-Id: <200105172307.AAA06142@crypt.compulink.co.uk>
+ Branch: perl
+ ! regexec.c
+ ____________________________________________________________________________
+ [ 10151] By: jhi on 2001/05/17 22:00:06
+ Log: Detypos.
+ Branch: perl
+ ! installman utils.lst
+ ____________________________________________________________________________
+ [ 10150] By: jhi on 2001/05/17 20:32:48
+ Log: Add better debug to glob/basic #8 as suggested by Nick Clark
+ in 20001222.001.
+ Branch: perl
+ ! t/lib/glob-basic.t
+ ____________________________________________________________________________
+ [ 10149] By: jhi on 2001/05/17 20:08:58
+ Log: Subject: [PATCH] Test for bug 20010515.004
+ From: Benjamin Sugars <bsugars@canoe.ca>
+ Date: Thu, 17 May 2001 15:48:18 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0105171544270.9064-100000@marmot.rim.canoe.ca>
+ Branch: perl
+ ! t/op/misc.t
+ ____________________________________________________________________________
+ [ 10148] By: jhi on 2001/05/17 20:06:23
+ Log: Integrate #10145 from maintperl.
+
+ fix for ID 20010515.004 (needs test)
+ Branch: perl
+ !> pp_hot.c
+ ____________________________________________________________________________
+ [ 10147] By: jhi on 2001/05/17 19:10:46
+ Log: Thinko noticed by Doug MacEachern.
+ Branch: perl
+ ! thread.h
+ ____________________________________________________________________________
+ [ 10146] By: jhi on 2001/05/17 17:30:37
+ Log: Subject: Re: [PATCH] HERE mark in regex
+ From: Ronald J Kimball <rjk@linguist.Thayer.dartmouth.edu>
+ Date: Thu, 17 May 2001 12:20:33 -0400
+ Message-ID: <20010517122033.B1547290@linguist.thayer.dartmouth.edu>
+ Branch: perl
+ ! t/op/re_tests
+ ____________________________________________________________________________
+ [ 10145] By: gsar on 2001/05/17 16:59:55
+ Log: fix for ID 20010515.004 (needs test)
+ Branch: maint-5.6/perl
+ ! pp_hot.c
+ ____________________________________________________________________________
+ [ 10144] By: gsar on 2001/05/17 16:39:02
+ Log: s/CONFIGDOTSH/PERL_CONFIG_SH/g
+ Branch: maint-5.6/perl
+ ! win32/config.bc win32/config.gc win32/config.vc
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ____________________________________________________________________________
+ [ 10143] By: jhi on 2001/05/17 14:21:08
+ Log: Macrofy the getspecific (and use it also in util.c)
+ Branch: perl
+ ! thread.h util.c
+ ____________________________________________________________________________
+ [ 10142] By: jhi on 2001/05/17 01:43:50
+ Log: Use the unchecked thread-specific key fetch also in Tru64.
+ Branch: perl
+ ! thread.h
+ ____________________________________________________________________________
+ [ 10141] By: jhi on 2001/05/17 01:41:07
+ Log: Subject: [PATCH 5.6.1]Quick thread speedup
+ From: Dan Sugalski <dan@sidhe.org>
+ Date: Wed, 16 May 2001 18:05:19 -0400
+ Message-Id: <5.1.0.14.0.20010516175826.01afde08@24.8.96.48>
+ Branch: perl
+ ! thread.h util.c
+ ____________________________________________________________________________
+ [ 10140] By: jhi on 2001/05/16 19:58:29
+ Log: I think this is quite enough testing for a deprecated feature.
+ Branch: perl
+ + t/lib/i18n-collate.t
+ ! MANIFEST t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 10139] By: jhi on 2001/05/16 18:47:03
+ Log: More HP-UX lore from Jeff Okamoto.
+ Branch: perl
+ ! README.hpux
+ ____________________________________________________________________________
+ [ 10138] By: jhi on 2001/05/16 18:21:04
+ Log: Sort utils.lst for easier maintenance.
+ Branch: perl
+ ! utils.lst
+ ____________________________________________________________________________
+ [ 10137] By: jhi on 2001/05/16 18:12:01
+ Log: Subject: Re: [PATCH] Abstract "utility" information from installman
+ From: Tim Jenness <t.jenness@jach.hawaii.edu>
+ Date: Wed, 16 May 2001 08:59:59 -1000 (HST)
+ Message-ID: <Pine.LNX.4.33.0105160858480.2488-100000@lapaki.jach.hawaii.edu>
+
+ Add pod2latex to utils.lst.
+ Branch: perl
+ ! MANIFEST utils.lst
+ ____________________________________________________________________________
+ [ 10136] By: jhi on 2001/05/16 18:00:00
+ Log: Subject: Re: [PATCH] HERE mark in regex
+ From: Ronald J Kimball <rjk@linguist.Thayer.dartmouth.edu>
+ Date: Wed, 16 May 2001 13:04:43 -0400
+ Message-ID: <20010516130443.E1516273@linguist.thayer.dartmouth.edu>
+ Branch: perl
+ ! pod/perldiag.pod regcomp.c t/op/misc.t t/op/re_tests
+ ! t/op/regmesg.t t/pragma/warn/regcomp
+ ____________________________________________________________________________
+ [ 10135] By: jhi on 2001/05/16 17:51:50
+ Log: Subject: Re: [PATCH] Abstract "utility" information from installman
+ From: Simon Cozens <simon@netthink.co.uk>
+ Date: Wed, 16 May 2001 18:02:08 +0100
+ Message-ID: <20010516180208.A6458@netthink.co.uk>
+ Branch: perl
+ ! installman utils.lst
+ ____________________________________________________________________________
+ [ 10134] By: jhi on 2001/05/16 17:47:26
+ Log: Subject: Re: [ID 20010515.001] -DPERL_Y2KWARN doesn't do what it should (Not OK: perl v5.7.1 +DEVEL10104 on i586-linux 2.2.16-22 (UNINST
+ From: "Philip Newton" <pnewton@gmx.de>
+ Date: Tue, 15 May 2001 15:09:30 +0200
+ Message-ID: <3B0146AA.2839.17BFDA6@localhost>
+
+ Test case for #10128.
+ Branch: perl
+ ! t/pragma/warn/pp_hot
+ ____________________________________________________________________________
+ [ 10133] By: jhi on 2001/05/16 15:12:52
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10132] By: jhi on 2001/05/16 14:50:55
+ Log: Deprecate pseudo-hashes.
+ Branch: perl
+ ! pod/perl572delta.pod pod/perlref.pod pod/perltodo.pod
+ ____________________________________________________________________________
+ [ 10131] By: jhi on 2001/05/16 14:26:01
+ Log: HP-UX hints update from Merijn.
+ Branch: perl
+ ! hints/hpux.sh
+ ____________________________________________________________________________
+ [ 10130] By: jhi on 2001/05/16 14:23:01
+ Log: README.hpux update from Merijn.
+ Branch: perl
+ ! README.hpux
+ ____________________________________________________________________________
+ [ 10129] By: jhi on 2001/05/16 14:18:56
+ Log: Subject: Re: [PATCH] Abstract "utility" information from installman
+ From: Simon Cozens <simon@netthink.co.uk>
+ Date: Wed, 16 May 2001 15:57:55 +0100
+ Message-ID: <20010516155755.A4728@netthink.co.uk>
+ Branch: perl
+ + utils.lst
+ ! MANIFEST installman installperl
+ ____________________________________________________________________________
+ [ 10128] By: jhi on 2001/05/16 14:15:36
+ Log: Subject: Re: [ID 20010515.001] -DPERL_Y2KWARN doesn't do what it should (Not OK: perl v5.7.1 +DEVEL10104 on i586-linux 2.2.16-22 (UNINST
+ From: "Philip Newton" <pnewton@gmx.de>
+ Date: Tue, 15 May 2001 16:31:05 +0200
+ Message-ID: <3B0159C9.1905.1C6AEF9@localhost>
+
+ Fix PERL_Y2KWARN test to check before rather than after appending.
+ Branch: perl
+ ! pp_hot.c
+ ____________________________________________________________________________
+ [ 10127] By: jhi on 2001/05/16 14:08:15
+ Log: Regen Porting stuff.
+ Branch: perl
+ ! Configure Porting/Glossary Porting/config.sh Porting/config_H
+ ! config_h.SH
+ ____________________________________________________________________________
+ [ 10126] By: jhi on 2001/05/16 13:41:50
+ Log: Metaconfig unit change for #10125.
+ Branch: metaconfig
+ ! U/modified/Oldconfig.U
+ ____________________________________________________________________________
+ [ 10125] By: jhi on 2001/05/16 13:41:35
+ Log: Use OSVERS.
+ Branch: perl
+ ! Configure config_h.SH perl.c
+ ____________________________________________________________________________
+ [ 10124] By: jhi on 2001/05/16 13:41:09
+ Log: Regen toc.
+ Branch: perl
+ ! pod/buildtoc.PL pod/perl.pod pod/perltoc.pod
+ ____________________________________________________________________________
+ [ 10123] By: jhi on 2001/05/16 13:25:38
+ Log: Adding the README.dgux to the MANIFEST would be a good idea.
+ Branch: perl
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 10122] By: jhi on 2001/05/16 13:08:33
+ Log: Move the stack desire definition to thread.h.
+ Branch: perl
+ ! ext/Thread/Thread.xs thread.h
+ ____________________________________________________________________________
+ [ 10121] By: jhi on 2001/05/16 13:00:12
+ Log: DG-UX threading patches, including a README.dgux,
+ from Takis Psarogiannakopoulos.
+ Branch: perl
+ + README.dgux
+ ! config_h.SH ext/Thread/Thread.xs hints/dgux.sh perl.c
+ ____________________________________________________________________________
+ [ 10120] By: jhi on 2001/05/16 12:55:33
+ Log: Subject: [PATCH B::Deparse] More on /x regexes
+ From: Robin Houston <robin@kitsite.com>
+ Date: Tue, 15 May 2001 19:09:35 +0100
+ Message-ID: <20010515190935.A27268@penderel>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 10119] By: jhi on 2001/05/16 12:45:29
+ Log: Document that the core time() may be rounding rather
+ than truncating, would have saved at least my confusion.
+ Branch: perl
+ ! ext/Time/HiRes/HiRes.pm
+ ____________________________________________________________________________
+ [ 10118] By: jhi on 2001/05/16 12:37:57
+ Log: Subject: perl-current/t/time-hires.t
+ From: John Peacock <jpeacock@rowman.com>
+ Date: Fri, 11 May 2001 14:09:41 -0400
+ Message-ID: <3AFC2AE5.5E787E54@rowman.com>
+ Branch: perl
+ ! t/lib/time-hires.t
+ ____________________________________________________________________________
+ [ 10117] By: jhi on 2001/05/15 13:40:33
+ Log: Subject: [PATCH dump.c] Op private flags
+ From: Simon Cozens <simon@netthink.co.uk>
+ Date: Sun, 13 May 2001 20:20:36 +0100
+ Message-ID: <20010513202036.A21896@netthink.co.uk>
+ Branch: perl
+ ! dump.c
+ ____________________________________________________________________________
+ [ 10116] By: jhi on 2001/05/15 13:28:26
+ Log: Upgrade to Switch 2.03.
+ Branch: perl
+ ! lib/Switch.pm
+ ____________________________________________________________________________
+ [ 10115] By: jhi on 2001/05/15 13:19:01
+ Log: Integrate change #10113 from mainline: rename CONFIGDOTSH
+ to PERL_CONFIG_SH and use it consistently.
+ Branch: maint-5.6/perl
+ !> Configure Makefile.SH Policy_sh.SH cflags.SH config_h.SH
+ !> configpm configure.com makeaperl.SH makedepend.SH makedir.SH
+ !> myconfig.SH writemain.SH
+ ____________________________________________________________________________
+ [ 10114] By: jhi on 2001/05/15 13:13:21
+ Log: Metaconfig units changes for #10113.
+ Branch: metaconfig
+ ! U/modified/Config_h.U U/modified/Extract.U U/modified/Oldsym.U
+ ____________________________________________________________________________
+ [ 10113] By: jhi on 2001/05/15 13:12:40
+ Log: The problem described in 20010514.031 still wasn't
+ fully cured, there were remnants of $CONFIG when
+ $CONFIGDOTSH was expected. Now renamed to PERL_CONFIG_SH
+ to avoid future conflicts.
+ Branch: perl
+ ! Configure Makefile.SH Policy_sh.SH cflags.SH config_h.SH
+ ! configpm configure.com makeaperl.SH makedepend.SH makedir.SH
+ ! myconfig.SH writemain.SH
+ ____________________________________________________________________________
+ [ 10112] By: jhi on 2001/05/15 11:55:44
+ Log: Half of #10107 got lost.
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 10111] By: nick on 2001/05/15 08:39:14
+ Log: Integrate mainline.
+ Branch: perlio
+ +> ext/POSIX/hints/uts.pl
+ - Todo Todo-5.6 t/camel-III/vstring.t
+ !> (integrate 48 files)
+ ____________________________________________________________________________
+ [ 10110] By: jhi on 2001/05/15 02:04:05
+ Log: Subject: [PATCH TestInit.pm] Give Deparse tester a fair chance
+ From: Robin Houston <robin@kitsite.com>
+ Date: Mon, 14 May 2001 22:27:08 +0100
+ Message-ID: <20010514222708.A22963@penderel>
+ Branch: perl
+ ! t/TestInit.pm
+ ____________________________________________________________________________
+ [ 10109] By: jhi on 2001/05/15 02:03:12
+ Log: Subject: [PATCH B::Deparse] Lvaluable method calls
+ From: Robin Houston <robin@kitsite.com>
+ Date: Mon, 14 May 2001 22:16:43 +0100
+ Message-ID: <20010514221643.A22437@penderel>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 10108] By: jhi on 2001/05/15 02:02:17
+ Log: Subject: [PATCH B::Deparse] C<$foo =~ give_me_a_regex>; /x modifier
+ From: Robin Houston <robin@kitsite.com>
+ Date: Mon, 14 May 2001 22:03:44 +0100
+ Message-ID: <20010514220344.A20643@penderel>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 10107] By: jhi on 2001/05/15 02:01:24
+ Log: Subject: [PATCH B::Deparse] "${foo}_bar"
+ From: Robin Houston <robin@kitsite.com>
+ Date: Mon, 14 May 2001 22:10:07 +0100
+ Message-ID: <20010514221007.A21118@penderel>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 10106] By: jhi on 2001/05/15 01:41:26
+ Log: Fix for 20010514.037; substr() didn't invalidate the locale
+ collation magic.
+ Branch: perl
+ ! pp.c
+ ____________________________________________________________________________
+ [ 10105] By: jhi on 2001/05/14 18:18:24
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10104] By: jhi on 2001/05/14 18:09:07
+ Log: Retract #10094.
+ Branch: perl
+ ! lib/Pod/Text.pm
+ ____________________________________________________________________________
+ [ 10103] By: jhi on 2001/05/14 15:20:58
+ Log: Integrate change #10100 from maintperl.
+
+ PL_last_in_gv may not be a GV if it was a stale filehandle (fix for
+ bug ID 20010514.027)
+ Branch: perl
+ !> mg.c pp_ctl.c
+ ____________________________________________________________________________
+ [ 10102] By: jhi on 2001/05/14 15:19:21
+ Log: Document the deprecatedness of suidperl.
+ Branch: perl
+ ! INSTALL pod/perlfaq1.pod
+ ____________________________________________________________________________
+ [ 10101] By: jhi on 2001/05/14 14:54:31
+ Log: Subject: Re: [ID 20010514.022] Makemaker a bit too prefix-happy
+ From: Ronald J Kimball <rjk@linguist.Thayer.dartmouth.edu>
+ Date: Mon, 14 May 2001 09:38:59 -0400
+ Message-ID: <20010514093859.A1479715@linguist.thayer.dartmouth.edu>
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm
+ ____________________________________________________________________________
+ [ 10100] By: gsar on 2001/05/14 14:43:50
+ Log: PL_last_in_gv may not be a GV if it was a stale filehandle (fix for
+ bug ID 20010514.027)
+
+ TODO: this needs a testsuite addition
+ Branch: maint-5.6/perl
+ ! mg.c pp_ctl.c
+ ____________________________________________________________________________
+ [ 10099] By: jhi on 2001/05/14 13:42:38
+ Log: More DWIMminess for Class::Struct: calling the array or hash
+ accessors only with one argument, an array or a hash reference,
+ sets the underlying array or hash. This mirrors nicely also
+ the usage in the constructor.
+ From Bernd Sokolowsky <ulmo@garozzo.franken.de>, via Damian Conway.
+ Branch: perl
+ ! lib/Class/Struct.pm t/lib/class-struct.t
+ ____________________________________________________________________________
+ [ 10098] By: jhi on 2001/05/14 13:10:34
+ Log: Reference cmp'ing should go through the whole stringification
+ process shebang, as pointed out by Sarathy in #10091.
+ Branch: perl
+ ! pp.c
+ ____________________________________________________________________________
+ [ 10097] By: jhi on 2001/05/14 12:54:31
+ Log: Subject: Re: [LONG] Cleaning up Todo/Todo-5.6/perltodo
+ From: Simon Cozens <simon@netthink.co.uk>
+ Date: Sat, 12 May 2001 16:36:27 +0100
+ Message-ID: <20010512163627.A5522@netthink.co.uk>
+
+ with some additions salvaged from Todo and Todo-5.6 before
+ retiring them.
+ Branch: perl
+ - Todo Todo-5.6
+ ! MANIFEST pod/perltodo.pod
+ ____________________________________________________________________________
+ [ 10096] By: jhi on 2001/05/14 12:37:01
+ Log: Subject: [ID 20010514.025] _SVID3 in <sys/statvfs.h>
+ From: "Golubev I. N." <gin@mo.msk.ru>
+ Date: Mon, 07 May 2001 14:33:34 (GMT)
+ Message-Id: <02453af6b23e63-gin@mo.msk.ru>
+ Branch: perl
+ ! perl.h
+ ____________________________________________________________________________
+ [ 10095] By: jhi on 2001/05/14 12:34:24
+ Log: Subject: [ID 20010514.022] Makemaker a bit too prefix-happy
+ From: "Todd C. Miller" <Todd.Miller@courtesan.com>
+ Date: Mon, 7 May 2001 09:35:57 -0600 (MDT)
+ Message-Id: <200105071535.f47FZvf27235@xerxes.courtesan.com>
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm
+ ____________________________________________________________________________
+ [ 10094] By: jhi on 2001/05/14 12:32:44
+ Log: (Retracted by #10104.)
+
+ Subject: [PATCH bleadperl Pod::Text] avoid overquoting [Was: rand(0) is rand(1)]
+ From: barries <barries@slaysys.com>
+ Date: Sat, 12 May 2001 01:28:10 -0400
+ Message-ID: <20010512012810.B26358@jester.slaysys.com>
+ Branch: perl
+ ! lib/Pod/Text.pm
+ ____________________________________________________________________________
+ [ 10093] By: jhi on 2001/05/14 12:30:38
+ Log: Subject: [PATCH] Incorrect line numbers in AutoSplit
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Sat, 12 May 2001 19:24:33 +0100
+ Message-Id: <E14ye49-0006Fn-00@libra.cus.cam.ac.uk>
+ Branch: perl
+ ! lib/AutoSplit.pm
+ ____________________________________________________________________________
+ [ 10092] By: jhi on 2001/05/14 12:29:21
+ Log: Yet another HP-UX hints tweak from Merijn.
+ Branch: perl
+ ! hints/hpux.sh
+ ____________________________________________________________________________
+ [ 10091] By: gsar on 2001/05/14 04:38:32
+ Log: $ref1 == $ref2 behaves unpredictably on platforms where NV_PRESERVES_UV
+ isn't defined (changes#9366,9368,9370 from mainline without the
+ pp_scmp() change)
+ Branch: maint-5.6/perl
+ ! pp.c pp.h pp_hot.c
+ ____________________________________________________________________________
+ [ 10090] By: jhi on 2001/05/12 13:39:43
+ Log: The sorting seems to happen now automatically.
+ Branch: perl
+ ! t/lib/glob-basic.t
+ ____________________________________________________________________________
+ [ 10089] By: jhi on 2001/05/12 03:38:15
+ Log: Subject: Re: [PATCH perlfunc.pod] split on an empty string
+ From: Benjamin Sugars <bsugars@canoe.ca>
+ Date: Fri, 11 May 2001 11:36:04 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0105111131540.1804-100000@marmot.rim.canoe.ca>
+ Branch: perl
+ ! pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 10088] By: jhi on 2001/05/12 03:37:00
+ Log: Subject: Re: undef(&foo) does not work for XS functions
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Fri, 11 May 2001 16:52:29 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0105111647240.4478-100000@mako.covalent.net>
+ Branch: perl
+ ! op.c
+ ____________________________________________________________________________
+ [ 10087] By: jhi on 2001/05/12 03:35:58
+ Log: Subject: [PATCH: perl@10086] fixup t/op/append.t for UTF-EBCDIC
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Fri, 11 May 2001 17:38:43 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10105111736190.73589-100000@aspara.forte.com>
+ Branch: perl
+ ! t/op/append.t
+ ____________________________________________________________________________
+ [ 10086] By: jhi on 2001/05/11 14:23:08
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10085] By: jhi on 2001/05/11 14:08:20
+ Log: Remove the 'asciir' re subpragma. Should instead implement
+ the 'physical vs logical' range scheme:
+
+ \xAA-\xCC is a native physical range, you want that range of
+ codepoints in your native encoding. In EBCDIC the codepoints
+ in the gaps (between i-j and r-s) should be included.
+
+ \x{AA}-\x{CC} is a physical Unicode range, you want that range of
+ codepoints in Unicode.
+
+ a-z is a logical range, you want that range of 'logical' codepoints
+ in your native encoding. In EBCDIC the codepoints in the gaps
+ (between i-j and r-s) should not be included.
+
+ Mixed cases (a-\xAA, etc) should either be errors, or maybe
+ the 'logical' endpoints should be converted to native/Unicode
+ codepoints, and the range handled as a physical range.
+
+ 'Logical endpoints' are to be recognized only in the A-Z, a-z,
+ and 0-9 ranges. Probably a warning should be given for mixed
+ cases like A-z or a-9 (since such expressions are encoding
+ dependent), with a recommendation to use physical ranges.
+ Branch: perl
+ ! ext/re/re.pm perl.h regcomp.c regcomp.h t/op/pat.t
+ ! t/op/regexp.t
+ ____________________________________________________________________________
+ [ 10084] By: jhi on 2001/05/11 13:56:16
+ Log: Make the test to cleanup the test directory tree
+ both before and after the testing so that we always
+ have a clean slate to work with.
+ Branch: perl
+ ! t/lib/filefind.t
+ ____________________________________________________________________________
+ [ 10083] By: jhi on 2001/05/11 13:46:30
+ Log: Subject: Re: [PATCH perlfunc.pod] split on an empty string
+ From: Jon Eveland <jweveland@yahoo.com>
+ Date: Fri, 11 May 2001 07:36:28 -0700 (PDT)
+ Message-ID: <20010511143628.24225.qmail@web10402.mail.yahoo.com>
+ Branch: perl
+ ! pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 10082] By: jhi on 2001/05/11 13:45:06
+ Log: Merge the camel-III/vstring.t with op/ver.t.
+ Branch: perl
+ - t/camel-III/vstring.t
+ ! MANIFEST t/TEST t/harness t/op/ver.t
+ ____________________________________________________________________________
+ [ 10081] By: jhi on 2001/05/11 13:15:55
+ Log: Add test.deparse make target.
+ Branch: perl
+ ! Makefile.SH
+ ____________________________________________________________________________
+ [ 10080] By: jhi on 2001/05/11 12:52:49
+ Log: Subject: [PATCH B::Deparse] $foo->bar(0)
+ From: Robin Houston <robin@kitsite.com>
+ Date: Fri, 11 May 2001 12:02:22 +0100
+ Message-ID: <20010511120222.A11529@penderel>
+ Branch: perl
+ ! ext/B/B/Deparse.pm t/op/method.t
+ ____________________________________________________________________________
+ [ 10079] By: jhi on 2001/05/11 01:59:06
+ Log: A nicely working combination for UTS from Hal Morris.
+ Branch: perl
+ + ext/POSIX/hints/uts.pl
+ ! MANIFEST hints/uts.sh
+ ____________________________________________________________________________
+ [ 10078] By: jhi on 2001/05/11 01:15:04
+ Log: i_ieeefp=undef for UTS.
+ Branch: perl
+ ! hints/uts.sh
+ ____________________________________________________________________________
+ [ 10077] By: jhi on 2001/05/10 22:42:35
+ Log: Subject: RE: rand(0) is rand(1)
+ From: Larry Shatzer <lshatzer@islanddata.com>
+ Date: Thu, 10 May 2001 11:09:27 -0700
+ Message-ID: <95CD90709D74D4118F4600D0B79E8BC9995027@mail.islanddata.com>
+ Branch: perl
+ ! pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 10076] By: jhi on 2001/05/10 22:36:50
+ Log: Subject: [patch] make op_{clear,null} public
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Thu, 10 May 2001 15:54:09 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0105101546510.2962-100000@mako.covalent.net>
+ Branch: perl
+ ! embed.h embed.pl op.c proto.h
+ ____________________________________________________________________________
+ [ 10075] By: jhi on 2001/05/10 22:28:36
+ Log: Subject: [PATCH B.xs] Extend tr/\0-\377/blah/c support
+ From: Robin Houston <robin@kitsite.com>
+ Date: Thu, 10 May 2001 18:54:59 +0100
+ Message-ID: <20010510185459.A5995@penderel>
+ Branch: perl
+ ! ext/B/B.xs ext/B/B/Deparse.pm t/op/tr.t
+ ____________________________________________________________________________
+ [ 10074] By: jhi on 2001/05/10 22:23:41
+ Log: Subject: [PATCH B::Deparse] t/op/64bitint.t
+ From: Robin Houston <robin@kitsite.com>
+ Date: Thu, 10 May 2001 12:56:39 +0100
+ Message-ID: <20010510125639.A2119@penderel>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 10073] By: jhi on 2001/05/10 14:26:01
+ Log: Retract #10070, not ready yet.
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 10072] By: jhi on 2001/05/10 13:40:24
+ Log: The metaconfig unit change for #10071.
+ Branch: metaconfig
+ ! U/modified/mallocsrc.U
+ ____________________________________________________________________________
+ [ 10071] By: jhi on 2001/05/10 13:39:57
+ Log: The #9525+#9526 didn't allow for overriding usemymalloc.
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10070] By: jhi on 2001/05/10 13:18:42
+ Log: (Retracted by #10073)
+
+ Subject: Re: [PATCH t/TEST] B::Deparse tester
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Thu, 10 May 2001 05:48:09 +0100
+ Message-Id: <200105100448.FAA13584@crypt.compulink.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 10069] By: jhi on 2001/05/10 12:24:06
+ Log: Add a for(func()) test.
+ Branch: perl
+ ! t/cmd/for.t
+ ____________________________________________________________________________
+ [ 10068] By: jhi on 2001/05/10 12:16:00
+ Log: Subject: [PATCH B::Deparse] our() lists and foreach loops
+ From: Robin Houston <robin@kitsite.com>
+ Date: Thu, 10 May 2001 13:50:08 +0100
+ Message-ID: <20010510135008.A2454@penderel>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 10067] By: jhi on 2001/05/10 01:45:03
+ Log: A thinko in #10065.
+ Branch: perl
+ ! hv.c
+ ____________________________________________________________________________
+ [ 10066] By: jhi on 2001/05/10 01:33:12
+ Log: Subject: [PATCH B::Deparse] Fix tr///ansliteration
+ From: Robin Houston <robin@kitsite.com>
+ Date: Thu, 10 May 2001 02:10:34 +0100
+ Message-ID: <20010510021034.A19421@penderel>
+ Branch: perl
+ ! ext/B/B.xs ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 10065] By: jhi on 2001/05/10 01:30:43
+ Log: Subject: [patch] make hv_fetch{_ent} SvGMAGICAL aware
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Mon, 7 May 2001 09:50:58 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.21.0105070947060.23808-100000@mako.covalent.net>
+ Branch: perl
+ ! hv.c
+ ____________________________________________________________________________
+ [ 10064] By: jhi on 2001/05/09 23:13:29
+ Log: One more workaround for the UTS compiler from Hal Morris.
+ Branch: perl
+ ! perl.h
+ ____________________________________________________________________________
+ [ 10063] By: jhi on 2001/05/09 23:09:53
+ Log: Subject: [PATCH B::Debug] Show string for PVOP, and referent for RV
+ From: Robin Houston <robin@kitsite.com>
+ Date: Thu, 10 May 2001 01:02:08 +0100
+ Message-ID: <20010510010208.A18200@penderel>
+ Branch: perl
+ ! ext/B/B/Debug.pm
+ ____________________________________________________________________________
+ [ 10062] By: jhi on 2001/05/09 23:06:25
+ Log: Subject: [PATCH] Simplify deb_curcv() a bit
+ From: Benjamin Sugars <bsugars@canoe.ca>
+ Date: Wed, 9 May 2001 18:14:34 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0105091811340.1160-100000@marmot.rim.canoe.ca>
+ Branch: perl
+ ! run.c
+ ____________________________________________________________________________
+ [ 10061] By: jhi on 2001/05/09 23:05:28
+ Log: Subject: [PATCH] Additional test case for PerlIO::Scalar
+ From: Benjamin Sugars <bsugars@canoe.ca>
+ Date: Wed, 9 May 2001 18:03:45 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0105091758220.1160-100000@marmot.rim.canoe.ca>
+ Branch: perl
+ ! t/lib/io_scalar.t
+ ____________________________________________________________________________
+ [ 10060] By: jhi on 2001/05/09 23:04:38
+ Log: Subject: [PATCH: perl@10022] update md5sum for MD5.xs on IBM-1047
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Wed, 9 May 2001 12:08:02 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10105091205250.455254-100000@aspara.forte.com>
+ Branch: perl
+ ! t/lib/md5-file.t
+ ____________________________________________________________________________
+ [ 10059] By: jhi on 2001/05/09 23:03:52
+ Log: Subject: [PATCH t/TEST] B::Deparse tester
+ From: Robin Houston <robin@kitsite.com>
+ Date: Wed, 9 May 2001 19:17:50 +0100
+ Message-ID: <20010509191750.A16940@penderel>
+ Branch: perl
+ ! ext/B/O.pm t/TEST
+ ____________________________________________________________________________
+ [ 10058] By: jhi on 2001/05/09 23:02:56
+ Log: Subject: [PATCH] Pod::Html -- fixes extra gaps in raw text
+ From: Jeff Pinyan <jeffp@crusoe.net>
+ Date: Wed, 9 May 2001 14:36:25 -0400 (EDT)
+ Message-ID: <Pine.GSO.4.21.0105091430420.357-100000@crusoe.crusoe.net>
+ Branch: perl
+ ! lib/Pod/Html.pm
+ ____________________________________________________________________________
+ [ 10057] By: nick on 2001/05/09 18:37:56
+ Log: Integrate mainline.
+ Branch: perlio
+ !> Changes epoc/epocish.h ext/PerlIO/Scalar/Scalar.xs
+ !> hints/hpux.sh lib/Pod/Html.pm patchlevel.h perlio.c
+ ____________________________________________________________________________
+ [ 10056] By: jhi on 2001/05/09 16:44:44
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10055] By: jhi on 2001/05/09 16:26:47
+ Log: Integrate perlio.
+ Branch: perl
+ !> win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ____________________________________________________________________________
+ [ 10054] By: jhi on 2001/05/09 16:25:42
+ Log: Subject: Re: [PATCH] Test offset when reading from a PerlIO::Scalar
+ From: Benjamin Sugars <bsugars@canoe.ca>
+ Date: Wed, 9 May 2001 12:42:30 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0105091230110.1516-100000@marmot.rim.canoe.ca>
+ Branch: perl
+ ! perlio.c
+ ____________________________________________________________________________
+ [ 10053] By: jhi on 2001/05/09 16:24:37
+ Log: Subject: [PATCH] Test offset when reading from a PerlIO::Scalar
+ From: Benjamin Sugars <bsugars@canoe.ca>
+ Date: Tue, 8 May 2001 17:09:44 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0105081654140.1212-100000@marmot.rim.canoe.ca>
+ Branch: perl
+ ! ext/PerlIO/Scalar/Scalar.xs
+ ____________________________________________________________________________
+ [ 10052] By: jhi on 2001/05/09 16:19:04
+ Log: Subject: [PATCH] Pod::Html doesn't honor =begin ... =end properly
+ From: Jeff Pinyan <jeffp@crusoe.net>
+ Date: Wed, 9 May 2001 12:35:24 -0400 (EDT)
+ Message-ID: <Pine.GSO.4.21.0105091233430.357-100000@crusoe.crusoe.net>
+ Branch: perl
+ ! lib/Pod/Html.pm
+ ____________________________________________________________________________
+ [ 10051] By: jhi on 2001/05/09 15:30:17
+ Log: EPOC tweak from Olaf Flebbe.
+ Branch: perl
+ ! epoc/epocish.h
+ ____________________________________________________________________________
+ [ 10050] By: nick on 2001/05/09 14:37:57
+ Log: win32, regen_config_h
+ Branch: perlio
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ____________________________________________________________________________
+ [ 10049] By: jhi on 2001/05/09 12:33:39
+ Log: Integrate perlio.
+ Branch: perl
+ !> pp_sys.c
+ ____________________________________________________________________________
+ [ 10048] By: nick on 2001/05/09 11:59:50
+ Log: If wait() or waitpid() ends due to EINTR despatch perl interrupt handler
+ and re-try. Fixes "perl 5.7.x prefers suicide over killing more than one child."
+ Branch: perlio
+ ! pp_sys.c
+ ____________________________________________________________________________
+ [ 10047] By: jhi on 2001/05/09 10:50:12
+ Log: Integrate perlio.
+ Branch: perl
+ !> run.c
+ ____________________________________________________________________________
+ [ 10046] By: jhi on 2001/05/09 10:49:34
+ Log: Subject: Re: Less warnings during configure
+ From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+ Date: Wed, 09 May 2001 13:12:49 +0200
+ Message-Id: <20010509125337.995D.H.M.BRAND@hccnet.nl>
+ Branch: perl
+ ! hints/hpux.sh
+ ____________________________________________________________________________
+ [ 10045] By: nick on 2001/05/09 09:56:59
+ Log: MULTIPLICITY/DEBUGGING build fix.
+ Branch: perlio
+ ! run.c
+ ____________________________________________________________________________
+ [ 10044] By: nick on 2001/05/09 09:46:37
+ Log: Merge of mainline (does not build MULTIPLICITY/DEBUGGING issue).
+ Branch: perlio
+ +> hints/atheos.sh pod/perl572delta.pod t/pod/plainer.t
+ - ext/SDBM_File/sdbm/dbm.c ext/SDBM_File/sdbm/dbm.h
+ !> (integrate 65 files)
+ ____________________________________________________________________________
+ [ 10043] By: jhi on 2001/05/08 22:41:49
+ Log: Subject: [PATCH op.c] Deprecate %x->{'foo'}, @y->[23] etc
+ From: Robin Houston <robin@kitsite.com>
+ Date: Tue, 8 May 2001 19:38:00 +0100
+ Message-ID: <20010508193800.A4389@penderel>
+
+ Subject: Re: [PATCH op.c] Deprecate %x->{'foo'}, @y->[23] etc
+ From: Robin Houston <robin@kitsite.com>
+ Date: Tue, 8 May 2001 20:03:57 +0100
+ Message-ID: <20010508200357.A4614@penderel>
+
+ Subject: Re: [PATCH op.c] Deprecate %x->{'foo'}, @y->[23] etc
+ From: Robin Houston <robin@kitsite.com>
+ Date: Wed, 9 May 2001 00:12:05 +0100
+ Message-ID: <20010509001205.A18521@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! op.c pod/perldiag.pod t/pragma/overload.t t/pragma/warn/op
+ ____________________________________________________________________________
+ [ 10042] By: jhi on 2001/05/08 22:09:35
+ Log: Retract #10031.
+ Branch: perl
+ ! pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 10041] By: jhi on 2001/05/08 18:27:34
+ Log: The metaconfig unit changes for #10040.
+ Branch: metaconfig/U/perl
+ ! Checkcc.U d_dlsymun.U dlsrc.U
+ ____________________________________________________________________________
+ [ 10040] By: jhi on 2001/05/08 18:24:47
+ Log: The Configure half of
+
+ Subject: Less warnings during configure
+ From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+ Date: Tue, 08 May 2001 08:44:02 +0200
+ Message-Id: <20010508084158.D793.H.M.BRAND@hccnet.nl>
+ Branch: perl
+ ! Configure
+ ____________________________________________________________________________
+ [ 10039] By: jhi on 2001/05/08 16:48:31
+ Log: Subject: Less warnings during configure
+ From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+ Date: Tue, 08 May 2001 08:44:02 +0200
+ Message-Id: <20010508084158.D793.H.M.BRAND@hccnet.nl>
+ Branch: perl
+ ! hints/hpux.sh
+ ____________________________________________________________________________
+ [ 10038] By: jhi on 2001/05/08 16:32:07
+ Log: Don't forget to whine about \d__\d.
+ Branch: perl
+ ! t/pragma/warn/toke toke.c
+ ____________________________________________________________________________
+ [ 10037] By: jhi on 2001/05/08 16:07:05
+ Log: Allow underscores also in the exponent part.
+ Branch: perl
+ ! t/pragma/warn/toke toke.c
+ ____________________________________________________________________________
+ [ 10036] By: jhi on 2001/05/08 13:33:55
+ Log: CodeMagicCD doesn't look like an *I*DE.
+ Branch: perl
+ ! pod/perlfaq3.pod
+ ____________________________________________________________________________
+ [ 10035] By: jhi on 2001/05/08 13:27:48
+ Log: Add Open Perl IDE, remove Perl Code Magic (the site seems
+ to be consistently down).
+ Branch: perl
+ ! pod/perlfaq3.pod
+ ____________________________________________________________________________
+ [ 10034] By: jhi on 2001/05/08 13:21:07
+ Log: Upgrade to Text::Balanced 1.84.
+ Branch: perl
+ ! lib/Text/Balanced.pm t/lib/tb-xbrak.t
+ ____________________________________________________________________________
+ [ 10033] By: jhi on 2001/05/08 12:41:53
+ Log: Subject: Re: [PATCH] Find the last of the missing pad variables
+ From: Benjamin Sugars <bsugars@canoe.ca>
+ Date: Tue, 8 May 2001 09:14:30 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0105080912370.1930-100000@marmot.rim.canoe.ca>
+ Branch: perl
+ ! run.c
+ ____________________________________________________________________________
+ [ 10032] By: jhi on 2001/05/08 12:40:28
+ Log: Subject: [PATCH: perl@10022] cleaner cleanup for t/pod/plainer.t
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Mon, 7 May 2001 18:13:06 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10105071810100.317708-100000@aspara.forte.com>
+ Branch: perl
+ ! t/pod/plainer.t
+ ____________________________________________________________________________
+ [ 10031] By: jhi on 2001/05/08 12:35:25
+ Log: (Retracted by #10042)
+
+ Subject: Re: [ID 20010506.040] Infinite loop in lib/selfstubber.t under Cygwin
+ From: "Philip Newton" <pnewton@gmx.de>
+ Date: Tue, 8 May 2001 09:18:10 +0200
+ Message-ID: <3AF7B9D2.28861.603732@localhost>
+ Branch: perl
+ ! pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 10030] By: jhi on 2001/05/08 12:32:23
+ Log: Subject: [PATCH B::Deparse] Document known bugs
+ From: Robin Houston <robin@kitsite.com>
+ Date: Tue, 8 May 2001 01:53:34 +0100
+ Message-ID: <20010508015334.A32394@penderel>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 10029] By: jhi on 2001/05/08 12:28:28
+ Log: Subject: Re: Perl book, magazine and website updates.
+ From: "Philip Newton" <pnewton@gmx.de>
+ Date: Mon, 7 May 2001 17:03:58 +0200
+ Message-ID: <3AF6D57E.5387.1E29930@localhost>
+ Branch: perl
+ ! pod/perlfaq2.pod
+ ____________________________________________________________________________
+ [ 10028] By: jhi on 2001/05/07 23:53:30
+ Log: Subject: [PATCH: perl@10022] YA tweak to avoid open file conflict in io/fflush.t
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Mon, 7 May 2001 17:50:48 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10105071746570.317708-100000@aspara.forte.com>
+ Branch: perl
+ ! t/io/fflush.t
+ ____________________________________________________________________________
+ [ 10027] By: jhi on 2001/05/07 23:22:48
+ Log: Subject: [PATCH B::Deparse] Give (?{...}) a taste of its own medicine
+ From: Robin Houston <robin@kitsite.com>
+ Date: Tue, 8 May 2001 01:14:55 +0100
+ Message-ID: <20010508011455.A32162@penderel>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 10026] By: jhi on 2001/05/07 23:15:05
+ Log: Typo in #10025.
+ Branch: perl
+ ! hints/uts.sh
+ ____________________________________________________________________________
+ [ 10025] By: jhi on 2001/05/07 21:15:35
+ Log: cc, cflags, and optimize tweaks for UTS from Hal Morris.
+ Branch: perl
+ ! hints/uts.sh
+ ____________________________________________________________________________
+ [ 10024] By: jhi on 2001/05/07 20:58:40
+ Log: Subject: Re: [ID 20010506.045] question about hash syntax
+ From: Peter Scott <Peter@PSDT.com>
+ Date: Sun, 06 May 2001 13:10:40 -0700
+ Message-Id: <4.3.2.7.2.20010506113015.00b46100@psdt.com>
+ Branch: perl
+ ! pod/perl56delta.pod
+ ____________________________________________________________________________
+ [ 10023] By: jhi on 2001/05/07 20:41:26
+ Log: Configure should figure out the list of dynamic extensions
+ just fine in UTS-- and in fact it does, as reported by Hal Morris.
+ Branch: perl
+ ! hints/uts.sh
+ ____________________________________________________________________________
+ [ 10022] By: jhi on 2001/05/07 20:24:11
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10021] By: jhi on 2001/05/07 20:11:31
+ Log: Subject: [PATCH regcomp.c] Insecure regexes
+ From: Robin Houston <robin@kitsite.com>
+ Date: Mon, 7 May 2001 21:56:12 +0100
+ Message-ID: <20010507215612.A31114@penderel>
+ Branch: perl
+ ! regcomp.c
+ ____________________________________________________________________________
+ [ 10020] By: jhi on 2001/05/07 20:02:30
+ Log: Drop the foobar.perl.com references for now until Simon
+ gets them sorted out.
+ Branch: perl
+ ! pod/perlfaq2.pod
+ ____________________________________________________________________________
+ [ 10019] By: jhi on 2001/05/07 19:54:33
+ Log: Subject: Re: RFC: changing Devel::SelfStubber to relinquish its grasp
+ From: Prymmer/Kahn <pvhp@best.com>
+ Date: Mon, 7 May 2001 07:47:21 -0700 (PDT)
+ Message-ID: <Pine.BSF.4.21.0105070733080.13301-100000@shell8.ba.best.com>
+ Branch: perl
+ ! lib/Devel/SelfStubber.pm
+ ____________________________________________________________________________
+ [ 10018] By: jhi on 2001/05/07 19:53:10
+ Log: Subject: Re: [ID 20010506.022] Win32/Makefile problems in 5.7.1
+ From: Prymmer/Kahn <pvhp@best.com>
+ Date: Sun, 6 May 2001 21:34:56 -0700 (PDT)
+ Message-ID: <Pine.BSF.4.21.0105062131520.17625-100000@shell8.ba.best.com>
+ Branch: perl
+ ! win32/Makefile
+ ____________________________________________________________________________
+ [ 10017] By: jhi on 2001/05/07 19:35:10
+ Log: s/WebTechnique's/WebTechniques/
+ Branch: perl
+ ! pod/perlfaq2.pod
+ ____________________________________________________________________________
+ [ 10016] By: jhi on 2001/05/07 12:26:29
+ Log: Llama 3 updates from Randal.
+ Branch: perl
+ ! pod/perlfaq2.pod
+ ____________________________________________________________________________
+ [ 10015] By: jhi on 2001/05/07 01:34:38
+ Log: Subject: [PATCH] Help -Dt show correct pad variables
+ From: Benjamin Sugars <ben.sugars@home.com>
+ Date: Sun, 6 May 2001 12:54:13 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0105061142040.12858-100000@localhost.localdomain>
+ Branch: perl
+ ! embed.h embed.pl proto.h run.c
+ ____________________________________________________________________________
+ [ 10014] By: jhi on 2001/05/07 01:23:56
+ Log: Subject: [PATCH] Document C<our $foo : shared>
+ From: Benjamin Sugars <ben.sugars@home.com>
+ Date: Sun, 6 May 2001 19:00:55 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0105061847090.9500-100000@localhost.localdomain>
+ Branch: perl
+ ! pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 10013] By: jhi on 2001/05/07 01:22:22
+ Log: Subject: [PATCH B::Deparse] undefined folded constants
+ From: Robin Houston <robin@kitsite.com>
+ Date: Sun, 6 May 2001 17:19:09 +0100
+ Message-ID: <20010506171909.A7046@penderel>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 10012] By: jhi on 2001/05/07 00:57:38
+ Log: Subject: [PATCH B::Deparse] use Foo (sub {...});
+ From: Robin Houston <robin@kitsite.com>
+ Message-ID: <20010506164654.A6848@penderel>
+ Date: Sun, 6 May 2001 16:46:54 +0100
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 10011] By: jhi on 2001/05/07 00:52:18
+ Log: Subject: [PATCH t/op/my_stash.t] Naughty?
+ From: Robin Houston <robin@kitsite.com>
+ Date: Sun, 6 May 2001 14:47:02 +0100
+ Message-ID: <20010506144702.A6308@penderel>
+ Branch: perl
+ ! t/op/my_stash.t
+ ____________________________________________________________________________
+ [ 10010] By: jhi on 2001/05/06 15:07:51
+ Log: Subject: Perl book, magazine and website updates.
+ From: Simon Cozens <simon@netthink.co.uk>
+ Date: Sun, 6 May 2001 16:55:36 +0100
+ Message-ID: <20010506165536.A1795@netthink.co.uk>
+ Branch: perl
+ ! pod/perlbook.pod pod/perlfaq2.pod
+ ____________________________________________________________________________
+ [ 10009] By: jhi on 2001/05/06 14:11:40
+ Log: Tweaks on the Tru64 prof options.
+ Branch: perl
+ ! pod/perlhack.pod
+ ____________________________________________________________________________
+ [ 10008] By: jhi on 2001/05/06 13:51:49
+ Log: Subject: [PATCH t/pod/testp2pt.pl] Give deparse tester a chance
+ From: Robin Houston <robin@kitsite.com>
+ Date: Sun, 6 May 2001 14:40:51 +0100
+ Message-ID: <20010506144051.A6279@penderel>
+ Branch: perl
+ ! t/pod/testp2pt.pl
+ ____________________________________________________________________________
+ [ 10007] By: jhi on 2001/05/06 13:49:31
+ Log: Subject: [PATCH B::Deparse] scoping
+ From: Robin Houston <robin@kitsite.com>
+ Date: Sun, 6 May 2001 14:36:56 +0100
+ Message-ID: <20010506143656.A4006@penderel>
+ Branch: perl
+ ! ext/B/B/Deparse.pm ext/B/defsubs_h.PL t/lib/b-deparse.t
+ ____________________________________________________________________________
+ [ 10006] By: jhi on 2001/05/06 13:24:12
+ Log: Document the undefinedness of bitshifting out of range.
+ Branch: perl
+ ! pod/perlop.pod
+ ____________________________________________________________________________
+ [ 10005] By: jhi on 2001/05/06 13:03:17
+ Log: Retract #10003 and update the IDE descriptions a bit.
+ Branch: perl
+ ! pod/perlfaq3.pod
+ ____________________________________________________________________________
+ [ 10004] By: jhi on 2001/05/06 03:02:41
+ Log: Subject: [PATCH: perl@10001] win32 update (VC,Borland,gcc), nmake update
+ From: Prymmer/Kahn <pvhp@best.com>
+ Date: Sat, 5 May 2001 20:30:49 -0700 (PDT)
+ Message-ID: <Pine.BSF.4.21.0105052017370.3961-100000@shell8.ba.best.com>
+ Branch: perl
+ ! win32/Makefile win32/buildext.pl win32/config.bc
+ ! win32/config.gc win32/config.vc
+ ____________________________________________________________________________
+ [ 10003] By: jhi on 2001/05/05 20:24:44
+ Log: (Retracted by #10005.)
+ Branch: perl
+ ! pod/perlfaq3.pod
+ ____________________________________________________________________________
+ [ 10002] By: jhi on 2001/05/05 19:23:36
+ Log: It's "psed", not "sed".
+ Branch: perl
+ ! x2p/s2p.PL
+ ____________________________________________________________________________
+ [ 10001] By: jhi on 2001/05/05 18:35:38
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 10000] By: jhi on 2001/05/05 18:32:15
+ Log: Subject: Re: bleadperl make install fails due to "psed"
+ From: andreas.koenig@anima.de (Andreas J. Koenig)
+ Date: 05 May 2001 18:23:28 +0200
+ Message-ID: <m3u22zg3y7.fsf@ak-71.mind.de>
+ Branch: perl
+ ! x2p/Makefile.SH x2p/s2p.PL
+ ____________________________________________________________________________
+ [ 9999] By: jhi on 2001/05/05 18:28:09
+ Log: AUTHORS updates.
+ Branch: perl
+ ! AUTHORS
+ ____________________________________________________________________________
+ [ 9998] By: jhi on 2001/05/05 18:16:00
+ Log: Updates on the pods related to the modules included since 5.6.
+
+ TODO: perltodo really could use major updating.
+ Branch: perl
+ ! pod/perlfaq3.pod pod/perlfaq4.pod pod/perlfaq7.pod
+ ! pod/perlfaq8.pod pod/perlfilter.pod pod/perlfunc.pod
+ ! pod/perlop.pod pod/perlport.pod pod/perlsec.pod
+ ! pod/perlsyn.pod pod/perltodo.pod
+ ____________________________________________________________________________
+ [ 9997] By: jhi on 2001/05/05 17:35:17
+ Log: Hints file for AtheOS ( http://www.atheos.cx/ ),
+ from Kurt Skauen.
+ Branch: perl
+ + hints/atheos.sh
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 9996] By: jhi on 2001/05/05 17:25:00
+ Log: Add preemptive #undefs for some of the shorter and more prone
+ to collision regcomp.h #defines. (Background: the MASK collided
+ with a system header #define in Rhapsody.)
+ Branch: perl
+ ! regcomp.h
+ ____________________________________________________________________________
+ [ 9995] By: jhi on 2001/05/05 13:24:21
+ Log: Subject: [PATCH] Re: h2xs [was Re: HEAR YE, HEAR YE!]
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Sat, 5 May 2001 14:46:39 +0100
+ Message-ID: <20010505144639.O53513@plum.flirble.org>
+
+ Add a test for the constants (if any) being processed correctly.
+ Branch: perl
+ ! utils/h2xs.PL
+ ____________________________________________________________________________
+ [ 9994] By: jhi on 2001/05/05 02:11:03
+ Log: Subject: [PATCH & retract: perl@9973] the real fix for t/lib/b-stash.t
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Fri, 4 May 2001 17:44:13 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10105041734280.67333-100000@aspara.forte.com>
+ Branch: perl
+ ! t/lib/b-stash.t
+ ____________________________________________________________________________
+ [ 9993] By: jhi on 2001/05/05 02:03:49
+ Log: Subject: [PATCH: perl@9973] fix const poisioning in PerlIO_openn->fdopen->openn
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Fri, 4 May 2001 17:29:02 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10105041727420.67333-100000@aspara.forte.com>
+ Branch: perl
+ ! perlio.c vms/vmsish.h
+ ____________________________________________________________________________
+ [ 9992] By: jhi on 2001/05/04 17:21:12
+ Log: Subject: [PATHC perl@9944] missing library tests: Pod::Plainer
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Date: Fri, 4 May 2001 18:13:47 +0100 (BST)
+ Message-Id: <200105041713.SAA14842@tempest.npl.co.uk>
+ Branch: perl
+ + t/pod/plainer.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 9991] By: jhi on 2001/05/04 16:47:45
+ Log: Subject: [PATCH perl@9944] -Wformat error from ext/re/re_comp.c
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Date: Fri, 4 May 2001 18:09:13 +0100 (BST)
+ Message-Id: <200105041709.SAA14835@tempest.npl.co.uk>
+ Branch: perl
+ ! regcomp.c
+ ____________________________________________________________________________
+ [ 9990] By: jhi on 2001/05/04 14:37:20
+ Log: Subject: [PATCH: perl@9973] let win32 run t/lib/b-stash.t
+ From: Prymmer/Kahn <pvhp@best.com>
+ Date: Fri, 4 May 2001 07:31:01 -0700 (PDT)
+ Message-ID: <Pine.BSF.4.21.0105040727430.14844-100000@shell8.ba.best.com>
+ Branch: perl
+ ! t/lib/b-stash.t
+ ____________________________________________________________________________
+ [ 9989] By: jhi on 2001/05/04 14:03:58
+ Log: Introduce perl572delta, update Todo, add the missing
+ mention about signal safety since 5.7.1 (though this
+ requires verification and more details.)
+ Branch: perl
+ + pod/perl572delta.pod
+ ! MANIFEST Todo pod/perl571delta.pod
+ ____________________________________________________________________________
+ [ 9988] By: jhi on 2001/05/04 12:41:51
+ Log: Subject: [PATCH perl@9944] long =item
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Date: Fri, 4 May 2001 14:15:20 +0100 (BST)
+ Message-Id: <200105041315.OAA00436@tempest.npl.co.uk>
+ Branch: perl
+ ! ext/Time/HiRes/HiRes.pm
+ ____________________________________________________________________________
+ [ 9987] By: jhi on 2001/05/04 12:39:19
+ Log: The #9901 had removed one line essential for EBCDIC.
+ Branch: perl
+ ! regcomp.c
+ ____________________________________________________________________________
+ [ 9986] By: jhi on 2001/05/04 12:30:23
+ Log: Subject: cygwin/Makefile.SHs INSTALL patch
+ From: Reini Urban <rurban@sbox.tu-graz.ac.at>
+ Date: Mon, 08 Jan 2001 04:59:21 +0200
+ Message-ID: <3A592D09.FD6AD35D@sbox.tu-graz.ac.at>
+ Branch: perl
+ ! cygwin/Makefile.SHs
+ ____________________________________________________________________________
+ [ 9985] By: jhi on 2001/05/04 03:51:39
+ Log: Encode/IO doc tweaks.
+ Branch: perl
+ ! ext/Encode/Encode.pm
+ ____________________________________________________________________________
+ [ 9984] By: jhi on 2001/05/04 03:29:34
+ Log: Remove GDBM_File from the dynamic extensions for UTS,
+ GDBM is not a standard feature.
+ Branch: perl
+ ! hints/uts.sh
+ ____________________________________________________________________________
+ [ 9983] By: jhi on 2001/05/04 03:22:59
+ Log: Document the \pX and \p{Yz} (and \p{BidiXYZ}) classes a bit more.
+ Branch: perl
+ ! pod/perlretut.pod
+ ____________________________________________________________________________
+ [ 9982] By: jhi on 2001/05/03 23:21:03
+ Log: Subject: [PATCH] Let sv_dump understand GvSHARED
+ From: Benjamin Sugars <bsugars@canoe.ca>
+ Date: Thu, 3 May 2001 16:51:07 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0105031645280.805-100000@marmot.rim.canoe.ca>
+ Branch: perl
+ ! dump.c
+ ____________________________________________________________________________
+ [ 9981] By: jhi on 2001/05/03 23:20:05
+ Log: Subject: [PATCH] Allow clobbering of a PerlIO::Scalar and more tests
+ From: Benjamin Sugars <bsugars@canoe.ca>
+ Date: Thu, 3 May 2001 15:28:21 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0105031508360.805-100000@marmot.rim.canoe.ca>
+ Branch: perl
+ ! ext/PerlIO/Scalar/Scalar.xs t/lib/io_scalar.t
+ ____________________________________________________________________________
+ [ 9980] By: jhi on 2001/05/03 23:15:29
+ Log: Integrate perlio.
+ Branch: perl
+ !> ext/Encode/Encode.pm
+ ____________________________________________________________________________
+ [ 9979] By: jhi on 2001/05/03 16:54:59
+ Log: Install psed man page.
+ Branch: perl
+ ! installman
+ ____________________________________________________________________________
+ [ 9978] By: jhi on 2001/05/03 16:45:58
+ Log: Remove unused files; noted by Sarathy.
+ Branch: perl
+ - ext/SDBM_File/sdbm/dbm.c ext/SDBM_File/sdbm/dbm.h
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 9977] By: jhi on 2001/05/03 16:42:30
+ Log: Subject: [PATCH bleadperl] INSTALL patch -- space requirements
+ From: Andy Dougherty <doughera@lafayette.edu>
+ Date: Thu, 3 May 2001 11:16:10 -0400 (EDT)
+ Message-ID: <Pine.SOL.4.10.10105031114500.17868-100000@maxwell.phys.lafayette.edu>
+ Branch: perl
+ ! INSTALL
+ ____________________________________________________________________________
+ [ 9976] By: nick on 2001/05/03 16:40:42
+ Log: Allow $answer = encode($object,$text); like it says in docs.
+ Branch: perlio
+ ! ext/Encode/Encode.pm
+ ____________________________________________________________________________
+ [ 9975] By: nick on 2001/05/03 16:22:30
+ Log: Fix latin1 etc. alias code - (bit rot?) - the @latin2iso array now seems to need
+ to be in scope (fair enough), and also a package variable (our) for eval to see it.
+ Branch: perlio
+ ! ext/Encode/Encode.pm
+ ____________________________________________________________________________
+ [ 9974] By: nick on 2001/05/03 15:48:17
+ Log: Integrate mainline.
+ Branch: perlio
+ +> lib/NEXT.pm t/io/fflush.t t/lib/MyFilter.pm
+ +> t/lib/filter-simple.t t/lib/next.t
+ !> (integrate 70 files)
+ ____________________________________________________________________________
+ [ 9973] By: jhi on 2001/05/03 13:09:09
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 9972] By: jhi on 2001/05/03 12:58:33
+ Log: Subject: [PATCH: perl@9945] fix handling of $Config{variables} in io/fflush.t
+ From: Prymmer/Kahn <pvhp@best.com>
+ Date: Wed, 2 May 2001 23:56:13 -0700 (PDT)
+ Message-ID: <Pine.BSF.4.21.0105022353380.24421-100000@shell8.ba.best.com>
+ Branch: perl
+ ! t/io/fflush.t
+ ____________________________________________________________________________
+ [ 9971] By: jhi on 2001/05/03 12:57:26
+ Log: Subject: [PATCH: perl@9945] two fixes for win32/FindExt.pm
+ From: Prymmer/Kahn <pvhp@best.com>
+ Date: Wed, 2 May 2001 23:42:33 -0700 (PDT)
+ Message-ID: <Pine.BSF.4.21.0105022337070.24421-100000@shell8.ba.best.com>
+ Branch: perl
+ ! win32/FindExt.pm
+ ____________________________________________________________________________
+ [ 9970] By: jhi on 2001/05/03 02:42:46
+ Log: Can't croak sans thread context, from Doug MacEachern.
+ Branch: perl
+ ! toke.c
+ ____________________________________________________________________________
+ [ 9969] By: jhi on 2001/05/03 01:23:48
+ Log: Subject: Random input test and Perl
+ From: Ilya Zakharevich <ilya@math.berkeley.edu>
+ Date: Wed, 2 May 2001 14:35:50 -0700 (PDT)
+ Message-Id: <200105022135.OAA26245@fac-813-1.math.Berkeley.EDU>
+ Branch: perl
+ ! toke.c
+ ____________________________________________________________________________
+ [ 9968] By: jhi on 2001/05/02 22:17:21
+ Log: Subject: [PATCH: perl@9945] fix some misinformation in perlfunc.pod
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Wed, 2 May 2001 15:58:18 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10105021554040.342459-100000@aspara.forte.com>
+ Branch: perl
+ ! pod/perlfunc.pod pod/perlport.pod
+ ____________________________________________________________________________
+ [ 9967] By: jhi on 2001/05/02 20:12:45
+ Log: Workaround for UTS compiler casting bug from Hal Morris.
+ Branch: perl
+ ! perl.h
+ ____________________________________________________________________________
+ [ 9966] By: jhi on 2001/05/02 18:31:37
+ Log: Subject: Re: [PATCH 5.6.1] Multiplicity and thread fixes for VMS
+ From: Dan Sugalski <dan@sidhe.org>
+ Date: Wed, 02 May 2001 15:23:22 -0400
+ Message-Id: <5.0.2.1.0.20010502152210.01f65550@24.8.96.48>
+ Branch: perl
+ ! perl.c vms/vms.c
+ ____________________________________________________________________________
+ [ 9965] By: jhi on 2001/05/02 18:21:29
+ Log: Minor doc tweaks on endianness, closes bug 20010327.004.
+ Branch: perl
+ ! pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 9964] By: jhi on 2001/05/02 18:15:01
+ Log: Document large files in INSTALL, document also the %x
+ limitation if not use64bitint, closes bug 20010326.007.
+ Branch: perl
+ ! INSTALL
+ ____________________________________________________________________________
+ [ 9963] By: jhi on 2001/05/02 17:24:47
+ Log: perlmodlib tweaks; regen pods.
+ Branch: perl
+ ! pod/Makefile.SH pod/perlmodlib.PL pod/perlmodlib.pod
+ ! pod/perltoc.pod
+ ____________________________________________________________________________
+ [ 9962] By: jhi on 2001/05/02 17:14:00
+ Log: Fix for a segfault, from Marc Lehmann.
+ Branch: perl
+ ! ext/POSIX/POSIX.xs ext/Time/Piece/Piece.xs
+ ____________________________________________________________________________
+ [ 9961] By: jhi on 2001/05/02 15:55:53
+ Log: Subject: [DOC PATCH bleadperl] minor nits in perlop.pod
+ From: "Philip Newton" <pnewton@gmx.de>
+ Date: Wed, 2 May 2001 18:39:03 +0200
+ Message-ID: <3AF05447.15525.173B588@localhost>
+ Branch: perl
+ ! pod/perlop.pod
+ ____________________________________________________________________________
+ [ 9960] By: jhi on 2001/05/02 15:35:37
+ Log: Subject: [PATCH 5.6.1] Multiplicity and thread fixes for VMS
+ From: Dan Sugalski <dan@sidhe.org>
+ Date: Wed, 02 May 2001 11:37:27 -0400
+ Message-Id: <5.0.2.1.0.20010502112909.01f24e28@24.8.96.48>
+ Branch: perl
+ ! doio.c ext/File/Glob/bsd_glob.c perl.c perl.h pp_sys.c
+ ! thread.h vms/vms.c vms/vmsish.h
+ ____________________________________________________________________________
+ [ 9959] By: jhi on 2001/05/02 15:21:08
+ Log: Subject: Re: [PATCH] Allow appending on a PerlIO::Scalar
+ From: Benjamin Sugars <bsugars@canoe.ca>
+ Date: Wed, 2 May 2001 10:53:11 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0105021041380.1652-100000@marmot.rim.canoe.ca>
+ Branch: perl
+ ! ext/PerlIO/Scalar/Scalar.xs
+ ____________________________________________________________________________
+ [ 9958] By: jhi on 2001/05/02 15:15:53
+ Log: Bug in #9915, spotted by Mike Guy.
+ Branch: perl
+ ! installperl
+ ____________________________________________________________________________
+ [ 9957] By: jhi on 2001/05/02 13:26:01
+ Log: Add a test for not griping about references as array
+ indices if the reference has magic in it (overloaded
+ methods).
+ Branch: perl
+ ! pod/perldiag.pod t/pragma/warn/pp_hot
+ ____________________________________________________________________________
+ [ 9956] By: jhi on 2001/05/02 13:07:01
+ Log: Retracted a bit too much in #9952.
+ Branch: perl
+ ! t/pragma/sub_lval.t
+ ____________________________________________________________________________
+ [ 9955] By: jhi on 2001/05/02 13:05:38
+ Log: Test for #9952.
+ Branch: perl
+ ! t/op/tie.t
+ ____________________________________________________________________________
+ [ 9954] By: jhi on 2001/05/02 11:48:18
+ Log: Additional note on the encoding example: one cannot
+ convert string constants in-place.
+ Branch: perl
+ ! ext/Encode/Encode.pm
+ ____________________________________________________________________________
+ [ 9953] By: jhi on 2001/05/02 11:43:51
+ Log: Note that if you have recent enough Perl you already
+ have Filter::Util::Call.
+ Branch: perl
+ ! lib/Filter/Simple.pm
+ ____________________________________________________________________________
+ [ 9952] By: jhi on 2001/05/02 11:31:53
+ Log: Retract changes #8254 and #8255, causes coredump in
+ 'tie FH, "main"', reported by Abigail, culprit found by
+ Benjamin Sugars. Mirrors maintperl change #9950.
+ Branch: perl
+ ! op.c t/pragma/sub_lval.t
+ ____________________________________________________________________________
+ [ 9951] By: jhi on 2001/05/02 11:14:29
+ Log: Forgot from #9942. (Needed by t/lib/filter-simple.t.)
+ Branch: perl
+ + t/lib/MyFilter.pm
+ ____________________________________________________________________________
+ [ 9950] By: gsar on 2001/05/02 03:17:11
+ Log: revert integration of changes#8254,8255 in change#8620 (causes
+ a coredump in C<tie FH, 'foo'>; the idea itself may need better
+ rationalization)
+ Branch: maint-5.6/perl
+ ! op.c t/pragma/sub_lval.t
+ ____________________________________________________________________________
+ [ 9949] By: gsar on 2001/05/02 02:56:32
+ Log: integrate changes#9774,9814 from mainline (Unixware fixes)
+
+ Subject: [ID 20010421.010] Perl 5.6.1 on Unixware 7
+
+ Subject: Re: [ID 20010421.010] Perl 5.6.1 on Unixware 7
+ Branch: maint-5.6/perl
+ !> hints/svr5.sh
+ ____________________________________________________________________________
+ [ 9948] By: gsar on 2001/05/02 02:49:15
+ Log: pod/find.t breaks on VMS (from Craig Berry)
+ Branch: maint-5.6/perl
+ ! t/pod/find.t
+ ____________________________________________________________________________
+ [ 9947] By: jhi on 2001/05/02 02:43:09
+ Log: Add an encoding conversion example.
+ Branch: perl
+ ! ext/Encode/Encode.pm
+ ____________________________________________________________________________
+ [ 9946] By: jhi on 2001/05/02 01:34:22
+ Log: Another coat of paint but still nowhere finished.
+ Need to decide on the semantics of strptime(): should
+ strptime() be a function instead of a method? To do
+ the week/monthname-strptiming the i18n/l10n bullet needs
+ to be bitten with gusto.
+ Branch: perl
+ ! ext/Time/Piece/Piece.pm t/lib/time-piece.t
+ ____________________________________________________________________________
+ [ 9945] By: jhi on 2001/05/01 23:40:52
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 9944] By: jhi on 2001/05/01 23:33:37
+ Log: Add known-to-be-tested modules to the list-to-be-skipped.
+ Branch: perl
+ ! t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 9943] By: jhi on 2001/05/01 23:24:40
+ Log: Subject: BorlandC++ fix
+ From: "Vadim Konovalov" <watman@inbox.ru>
+ Date: Mon, 30 Apr 2001 20:12:26 -0700
+ Message-ID: <006e01c0d1ec$8fb1b8d0$406bff87@vad>
+ Branch: perl
+ ! win32/makefile.mk
+ ____________________________________________________________________________
+ [ 9942] By: jhi on 2001/05/01 23:18:02
+ Log: Update to Filter::Simple 0.60, create a test for it.
+ Branch: perl
+ + t/lib/filter-simple.t
+ ! MANIFEST lib/Filter/Simple.pm
+ ____________________________________________________________________________
+ [ 9941] By: jhi on 2001/05/01 19:47:24
+ Log: Subject: Re: bleadperl: s/// failure with \b and /g
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Tue, 01 May 2001 20:12:20 +0100
+ Message-Id: <200105011912.UAA06826@crypt.compulink.co.uk>
+ Branch: perl
+ ! pp_hot.c t/op/re_tests
+ ____________________________________________________________________________
+ [ 9940] By: jhi on 2001/05/01 19:42:16
+ Log: Integrate perlio.
+ Branch: perl
+ !> lib/base.pm t/lib/fields.t
+ ____________________________________________________________________________
+ [ 9939] By: jhi on 2001/05/01 19:39:51
+ Log: Subject: [PATCH] Allow appending on a PerlIO::Scalar
+ From: Benjamin Sugars <bsugars@canoe.ca>
+ Date: Tue, 1 May 2001 16:32:03 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0105011627110.1526-100000@marmot.rim.canoe.ca>
+ Branch: perl
+ ! ext/PerlIO/Scalar/Scalar.xs t/lib/io_scalar.t
+ ____________________________________________________________________________
+ [ 9938] By: jhi on 2001/05/01 19:34:09
+ Log: Add NEXT, a pseudo-class for method redispatching.
+ <Damian>NEXT.pm probably offers more bang-for-buck
+ than anything else I've ever written.</Damian>
+ Branch: perl
+ + lib/NEXT.pm t/lib/next.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 9937] By: jhi on 2001/05/01 19:21:41
+ Log: Update to Switch 2.02.
+ Branch: perl
+ ! lib/Switch.pm t/lib/switch.t
+ ____________________________________________________________________________
+ [ 9936] By: nick on 2001/05/01 19:09:21
+ Log: Fix for base.pm clobbering $VERSION
+ Branch: perlio
+ ! lib/base.pm
+ ____________________________________________________________________________
+ [ 9935] By: nick on 2001/05/01 18:54:38
+ Log: Test for base.pm clobbering $VERSION.
+ Branch: perlio
+ ! t/lib/fields.t
+ ____________________________________________________________________________
+ [ 9934] By: jhi on 2001/05/01 18:39:10
+ Log: Add information about Scalar::Util::blessed.
+ Branch: perl
+ ! pod/perlobj.pod
+ ____________________________________________________________________________
+ [ 9933] By: jhi on 2001/05/01 18:33:51
+ Log: Subject: Extra UNIVERSAL documentation
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Tue, 01 May 2001 20:12:11 +0100
+ Message-Id: <E14ufZD-0007kD-00@libra.cus.cam.ac.uk>
+ Branch: perl
+ ! pod/perlobj.pod
+ ____________________________________________________________________________
+ [ 9932] By: jhi on 2001/05/01 18:26:54
+ Log: Subject: Autoflush in tests as appropriate
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Tue, 01 May 2001 20:05:31 +0100
+ Message-Id: <E14ufSl-0007gS-00@libra.cus.cam.ac.uk>
+ Branch: perl
+ ! t/lib/syslfs.t t/op/die_exit.t t/op/lex_assign.t t/op/lfs.t
+ ! t/op/taint.t
+ ____________________________________________________________________________
+ [ 9931] By: jhi on 2001/05/01 18:02:29
+ Log: Subject: [PATCH] Multiple consecutive writes on PerlIO::Scalar
+ From: Benjamin Sugars <bsugars@canoe.ca>
+ Date: Tue, 1 May 2001 14:58:24 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0105011431300.1526-100000@marmot.rim.canoe.ca>
+ Branch: perl
+ ! ext/PerlIO/Scalar/Scalar.xs t/lib/io_scalar.t
+ ____________________________________________________________________________
+ [ 9930] By: jhi on 2001/05/01 15:12:26
+ Log: Subject: Re: Finally got a round tuit
+ From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+ Date: Tue, 01 May 2001 14:14:10 +0200
+ Message-Id: <20010501135740.19E4.H.M.BRAND@hccnet.nl>
+
+ The -DP part, slightly modified.
+ Branch: perl
+ ! perl.c
+ ____________________________________________________________________________
+ [ 9929] By: jhi on 2001/05/01 14:17:15
+ Log: Subject: Re: Finally got a round tuit
+ From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+ Date: Tue, 01 May 2001 16:34:06 +0200
+ Message-Id: <20010501163255.19F2.H.M.BRAND@hccnet.nl>
+
+ cpp and optimization tweaks for HP-UX.
+ Branch: perl
+ ! hints/hpux.sh
+ ____________________________________________________________________________
+ [ 9928] By: jhi on 2001/05/01 13:24:20
+ Log: Tune the scan_num() comments to reality.
+ Branch: perl
+ ! toke.c
+ ____________________________________________________________________________
+ [ 9927] By: jhi on 2001/05/01 13:14:01
+ Log: Subject: [PATCH B::Deparse] optimised sort
+ From: Robin Houston <robin@kitsite.com>
+ Date: Tue, 1 May 2001 14:07:12 +0100
+ Message-ID: <20010501140712.A4266@penderel>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9926] By: jhi on 2001/05/01 13:10:53
+ Log: Subject: [PATCH t/lib/b-deparse.t]
+ From: Robin Houston <robin@kitsite.com>
+ Date: Tue, 1 May 2001 13:37:42 +0100
+ Message-ID: <20010501133742.A4082@penderel>
+ Branch: perl
+ ! t/lib/b-deparse.t
+ ____________________________________________________________________________
+ [ 9925] By: jhi on 2001/05/01 13:10:13
+ Log: Subject: [PATCH B::Deparse] for(;;), sort
+ From: Robin Houston <robin@kitsite.com>
+ Date: Tue, 1 May 2001 13:35:00 +0100
+ Message-ID: <20010501133500.A4061@penderel>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9924] By: jhi on 2001/05/01 13:09:22
+ Log: Subject: [PATCH B::Deparse] do, warn, use
+ From: Robin Houston <robin@kitsite.com>
+ Date: Tue, 1 May 2001 13:31:03 +0100
+ Message-ID: <20010501133103.A4041@penderel>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9923] By: jhi on 2001/05/01 11:45:36
+ Log: Subject: [PATCH] Test autoflush on fork (Was: Should I remove something?)
+ From: Benjamin Sugars <ben.sugars@home.com>
+ Date: Mon, 30 Apr 2001 22:21:54 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0104302213190.19002-100000@localhost.localdomain>
+ Branch: perl
+ + t/io/fflush.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 9922] By: jhi on 2001/05/01 11:35:42
+ Log: Subject: [PATCH: perl@9917] more VMS tweaks for addn'l selfstubber tests
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Mon, 30 Apr 2001 16:26:30 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10104301621200.161547-100000@aspara.forte.com>
+ Branch: perl
+ ! t/lib/selfstubber.t
+ ____________________________________________________________________________
+ [ 9921] By: jhi on 2001/04/30 16:34:33
+ Log: Subject: [PATCH B::Concise] suppress warning
+ From: Robin Houston <robin@kitsite.com>
+ Date: Mon, 30 Apr 2001 16:09:49 +0100
+ Message-ID: <20010430160949.A25086@penderel>
+ Branch: perl
+ ! ext/B/B/Concise.pm
+ ____________________________________________________________________________
+ [ 9920] By: jhi on 2001/04/30 13:56:04
+ Log: Strip the *markers* from #9919.
+ Branch: perl
+ ! pod/perlfaq.pod pod/perlfaq5.pod
+ ____________________________________________________________________________
+ [ 9919] By: jhi on 2001/04/30 13:54:04
+ Log: Subject: [PATCH] (perlfaq/bleadperl) append mode and locking
+ From: Gwyn Judd <b.judd@xtra.co.nz>
+ Date: Sun, 29 Apr 2001 01:47:49 +1200
+ Message-ID: <20010429014749.A4418@thislove>
+ Branch: perl
+ ! pod/perlfaq.pod pod/perlfaq5.pod
+ ____________________________________________________________________________
+ [ 9918] By: jhi on 2001/04/30 13:13:54
+ Log: More_tweakage.
+ Branch: perl
+ ! pod/perldata.pod pod/perldiag.pod
+ ____________________________________________________________________________
+ [ 9917] By: jhi on 2001/04/30 13:01:27
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 9916] By: jhi on 2001/04/30 12:57:03
+ Log: T_w_e_a_k_a_g_e.
+ Branch: perl
+ ! pod/perldata.pod pod/perldiag.pod
+ ____________________________________________________________________________
+ [ 9915] By: jhi on 2001/04/30 12:39:29
+ Log: Install s2p also as psed.
+
+ TODO: psed documentation?
+ Branch: perl
+ ! installperl
+ ____________________________________________________________________________
+ [ 9914] By: jhi on 2001/04/30 12:29:21
+ Log: Subject: Re: [ID 20010303.009] SOCKS5 work around breaks other sockets
+ From: Jens Hamisch <jens@Strawberry.COM>
+ Date: Fri, 27 Apr 2001 17:00:36 +0200
+ Message-ID: <20010427170036.K1372@Strawberry.COM>
+
+ SOCKS5_VERSION_NAME is the right symbol to detect
+ the presence of SOCKS5. (HAS_SOCKS5_INIT is telling whether
+ function called socks5_init() is available, and even that is
+ not universal, most SOCKS5 installations use SOCKSinit()).
+ Branch: perl
+ ! perlio.c
+ ____________________________________________________________________________
+ [ 9913] By: jhi on 2001/04/30 12:22:15
+ Log: Allow a zero timeout on IO::Socket accept and connect--
+ though one really shouldn't do that. Based on
+
+ Subject: Not possible to set zero second timeout on accept() in IO::Socket and company..
+ From: "John Holdsworth" <coldwave@bigfoot.com>
+ Date: Sun, 4 Feb 2001 12:48:18 +0100
+ Message-ID: <005a01c08ea0$5e6039d0$03ac2ac0@planc>
+ Branch: perl
+ ! ext/IO/lib/IO/Socket.pm
+ ____________________________________________________________________________
+ [ 9912] By: jhi on 2001/04/30 11:27:27
+ Log: Save the spot of regprev (see #9911) for binary compatibility;
+ regen API.
+ Branch: perl
+ ! embedvar.h perlapi.h thrdvar.h
+ ____________________________________________________________________________
+ [ 9911] By: jhi on 2001/04/30 11:22:03
+ Log: Subject: Re: [PATCH bleadperl] [ID 20010426.002] Word boundry regex [...]
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Sun, 29 Apr 2001 17:09:30 +0100
+ Message-Id: <200104291609.RAA17790@crypt.compulink.co.uk>
+ Branch: perl
+ ! regcomp.c regexec.c sv.c t/op/re_tests t/op/subst.t thrdvar.h
+ ____________________________________________________________________________
+ [ 9910] By: jhi on 2001/04/30 11:15:12
+ Log: Change PL_numeric_radix to PL_numeric_radix_sv (and leave in
+ a dummy for PL_numeric_radix); no pressing reason to break
+ binary compatibility; regen API.
+ Branch: perl
+ ! embedvar.h global.sym intrpvar.h objXSUB.h perl.c perl.h
+ ! perlapi.c perlapi.h pod/perlapi.pod sv.c util.c
+ ____________________________________________________________________________
+ [ 9909] By: jhi on 2001/04/30 10:56:08
+ Log: Subject: [DOC PATCH bleadperl] Document generation of random integers
+ From: Walt Mankowski <waltman@netaxs.com>
+ Date: Sun, 29 Apr 2001 21:53:48 -0400
+ Message-ID: <20010429215348.A3971@netaxs.com>
+ Branch: perl
+ ! pod/perlfunc.pod
+ ____________________________________________________________________________
+ [ 9908] By: jhi on 2001/04/30 10:49:40
+ Log: Reintroduce #9889 to unbuffer the stderr/stdout on stdio configs.
+ Branch: perl
+ ! t/lib/selfstubber.t
+ ____________________________________________________________________________
+ [ 9907] By: nick on 2001/04/30 09:26:50
+ Log: Integrate mainline.
+ Branch: perlio
+ !> pod/perldata.pod pod/perldiag.pod t/pragma/warn/toke toke.c
+ ____________________________________________________________________________
+ [ 9906] By: jhi on 2001/04/29 23:24:20
+ Log: Abigail spotted a thinko in #9905.
+ Branch: perl
+ ! pod/perldiag.pod
+ ____________________________________________________________________________
+ [ 9905] By: jhi on 2001/04/29 15:55:39
+ Log: Changed the underscore/undebar syntax in numeric constants;
+ now any grouping will do, as long as the underscores are not
+ consecutive (so "zero-grouping" is out), and they do not begin
+ or end the integer or fractional parts.
+ Branch: perl
+ ! pod/perldata.pod pod/perldiag.pod t/pragma/warn/toke toke.c
+ ____________________________________________________________________________
+ [ 9904] By: nick on 2001/04/29 15:43:22
+ Log: Integrate mainline.
+ Branch: perlio
+ +> (branch 98 files)
+ - lib/unicode/Block.pl
+ - lib/unicode/In/AlphabeticPresentationForms.pl
+ - lib/unicode/In/Arabic.pl
+ - lib/unicode/In/ArabicPresentationForms-A.pl
+ - lib/unicode/In/ArabicPresentationForms-B.pl
+ - lib/unicode/In/Armenian.pl lib/unicode/In/Arrows.pl
+ - lib/unicode/In/BasicLatin.pl lib/unicode/In/Bengali.pl
+ - lib/unicode/In/BlockElements.pl lib/unicode/In/Bopomofo.pl
+ - lib/unicode/In/BopomofoExtended.pl
+ - lib/unicode/In/BoxDrawing.pl lib/unicode/In/BraillePatterns.pl
+ - lib/unicode/In/CJKCompatibility.pl
+ - lib/unicode/In/CJKCompatibilityForms.pl
+ - lib/unicode/In/CJKCompatibilityIdeographs.pl
+ - lib/unicode/In/CJKRadicalsSupplement.pl
+ - lib/unicode/In/CJKSymbolsandPunctuation.pl
+ - lib/unicode/In/CJKUnifiedIdeographs.pl
+ - lib/unicode/In/CJKUnifiedIdeographsExtensionA.pl
+ - lib/unicode/In/Cherokee.pl
+ - lib/unicode/In/CombiningDiacriticalMarks.pl
+ - lib/unicode/In/CombiningHalfMarks.pl
+ - lib/unicode/In/CombiningMarksforSymbols.pl
+ - lib/unicode/In/ControlPictures.pl
+ - lib/unicode/In/CurrencySymbols.pl lib/unicode/In/Cyrillic.pl
+ - lib/unicode/In/Devanagari.pl lib/unicode/In/Dingbats.pl
+ - lib/unicode/In/EnclosedAlphanumerics.pl
+ - lib/unicode/In/EnclosedCJKLettersandMonths.pl
+ - lib/unicode/In/Ethiopic.pl
+ - lib/unicode/In/GeneralPunctuation.pl
+ - lib/unicode/In/GeometricShapes.pl lib/unicode/In/Georgian.pl
+ - lib/unicode/In/Greek.pl lib/unicode/In/GreekExtended.pl
+ - lib/unicode/In/Gujarati.pl lib/unicode/In/Gurmukhi.pl
+ - lib/unicode/In/HalfwidthandFullwidthForms.pl
+ - lib/unicode/In/HangulCompatibilityJamo.pl
+ - lib/unicode/In/HangulJamo.pl lib/unicode/In/HangulSyllables.pl
+ - lib/unicode/In/Hebrew.pl
+ - lib/unicode/In/HighPrivateUseSurrogates.pl
+ - lib/unicode/In/HighSurrogates.pl lib/unicode/In/Hiragana.pl
+ - lib/unicode/In/IPAExtensions.pl
+ - lib/unicode/In/IdeographicDescriptionCharacters.pl
+ - lib/unicode/In/Kanbun.pl lib/unicode/In/KangxiRadicals.pl
+ - lib/unicode/In/Kannada.pl lib/unicode/In/Katakana.pl
+ - lib/unicode/In/Khmer.pl lib/unicode/In/Lao.pl
+ - lib/unicode/In/Latin-1Supplement.pl
+ - lib/unicode/In/LatinExtended-A.pl
+ - lib/unicode/In/LatinExtended-B.pl
+ - lib/unicode/In/LatinExtendedAdditional.pl
+ - lib/unicode/In/LetterlikeSymbols.pl
+ - lib/unicode/In/LowSurrogates.pl lib/unicode/In/Malayalam.pl
+ - lib/unicode/In/MathematicalOperators.pl
+ - lib/unicode/In/MiscellaneousSymbols.pl
+ - lib/unicode/In/MiscellaneousTechnical.pl
+ - lib/unicode/In/Mongolian.pl lib/unicode/In/Myanmar.pl
+ - lib/unicode/In/NumberForms.pl lib/unicode/In/Ogham.pl
+ - lib/unicode/In/OpticalCharacterRecognition.pl
+ - lib/unicode/In/Oriya.pl lib/unicode/In/PrivateUse.pl
+ - lib/unicode/In/Runic.pl lib/unicode/In/Sinhala.pl
+ - lib/unicode/In/SmallFormVariants.pl
+ - lib/unicode/In/SpacingModifierLetters.pl
+ - lib/unicode/In/Specials.pl
+ - lib/unicode/In/SuperscriptsandSubscripts.pl
+ - lib/unicode/In/Syriac.pl lib/unicode/In/Tamil.pl
+ - lib/unicode/In/Telugu.pl lib/unicode/In/Thaana.pl
+ - lib/unicode/In/Thai.pl lib/unicode/In/Tibetan.pl
+ - lib/unicode/In/UnifiedCanadianAboriginalSyllabics.pl
+ - lib/unicode/In/YiRadicals.pl lib/unicode/In/YiSyllables.pl
+ !> INSTALL MANIFEST doop.c embed.h embed.pl ext/B/B/Deparse.pm
+ !> ext/IO/lib/IO/Seekable.pm hints/hpux.sh
+ !> lib/unicode/mktables.PL lib/utf8_heavy.pl objXSUB.h perl.h
+ !> pod/perldiag.pod pod/perlunicode.pod proto.h regcomp.c
+ !> regexec.c t/lib/b-deparse.t t/lib/selfstubber.t t/op/pat.t
+ !> utf8.c win32/Makefile
+ ____________________________________________________________________________
+ [ 9903] By: jhi on 2001/04/29 14:30:53
+ Log: Subject: [PATCH: perl@9885] win32/Makefile (nmake) update
+ From: Prymmer/Kahn <pvhp@best.com>
+ Date: Sat, 28 Apr 2001 21:56:51 -0700 (PDT)
+ Message-ID: <Pine.BSF.4.21.0104282147270.2927-100000@shell8.ba.best.com>
+ Branch: perl
+ ! win32/Makefile
+ ____________________________________________________________________________
+ [ 9902] By: jhi on 2001/04/29 02:52:44
+ Log: Subject: [PATCH ext/IO/lib/IO/Seekable.pm] Doc fixes.
+ From: "Abigail" <abigail@foad.org>
+ Date: Sun, 29 Apr 2001 03:14:25 +0200
+ Message-ID: <20010429011425.24503.qmail@foad.org>
+ Branch: perl
+ ! ext/IO/lib/IO/Seekable.pm
+ ____________________________________________________________________________
+ [ 9901] By: jhi on 2001/04/29 02:04:46
+ Log: In character classes one couldn't have 0x80..0xff characters
+ at the left hand side if there were 0x100.. characters in the
+ character class.
+ Branch: perl
+ ! doop.c embed.h embed.pl objXSUB.h proto.h regcomp.c regexec.c
+ ! t/op/pat.t utf8.c
+ ____________________________________________________________________________
+ [ 9900] By: jhi on 2001/04/28 22:55:04
+ Log: Forgot the latest mktables.PL from #9899.
+ Branch: perl
+ ! lib/unicode/mktables.PL
+ ____________________________________________________________________________
+ [ 9899] By: jhi on 2001/04/28 22:53:28
+ Log: Explain the \p{} and \P{} error message better and
+ have prettier prettyprint in In.pl.
+ Branch: perl
+ ! lib/unicode/In.pl lib/unicode/mktables.PL lib/utf8_heavy.pl
+ ! pod/perldiag.pod
+ ____________________________________________________________________________
+ [ 9898] By: jhi on 2001/04/28 21:03:34
+ Log: Add one possible explanation for the "Invalid [] range" error.
+ Branch: perl
+ ! pod/perldiag.pod
+ ____________________________________________________________________________
+ [ 9897] By: jhi on 2001/04/28 17:18:26
+ Log: Add a level of indirection to the implementation of \p{InFoo}
+ so that we don't have to have long filenames. (Nothing changes
+ in the user interface.) The indirection is defined in
+ the file lib/unicode/In.pl and it is handled in lib/utf8_heavy.pl.
+ Also rename some the character classes by removing '-' from
+ the classnames, and finally renamed Block.pl as Blocks.pl.
+ Branch: perl
+ + lib/unicode/Blocks.pl lib/unicode/In.pl lib/unicode/In/0.pl
+ + lib/unicode/In/1.pl lib/unicode/In/10.pl lib/unicode/In/11.pl
+ + lib/unicode/In/12.pl lib/unicode/In/13.pl lib/unicode/In/14.pl
+ + lib/unicode/In/15.pl lib/unicode/In/16.pl lib/unicode/In/17.pl
+ + lib/unicode/In/18.pl lib/unicode/In/19.pl lib/unicode/In/2.pl
+ + lib/unicode/In/20.pl lib/unicode/In/21.pl lib/unicode/In/22.pl
+ + lib/unicode/In/23.pl lib/unicode/In/24.pl lib/unicode/In/25.pl
+ + lib/unicode/In/26.pl lib/unicode/In/27.pl lib/unicode/In/28.pl
+ + lib/unicode/In/29.pl lib/unicode/In/3.pl lib/unicode/In/30.pl
+ + lib/unicode/In/31.pl lib/unicode/In/32.pl lib/unicode/In/33.pl
+ + lib/unicode/In/34.pl lib/unicode/In/35.pl lib/unicode/In/36.pl
+ + lib/unicode/In/37.pl lib/unicode/In/38.pl lib/unicode/In/39.pl
+ + lib/unicode/In/4.pl lib/unicode/In/40.pl lib/unicode/In/41.pl
+ + lib/unicode/In/42.pl lib/unicode/In/43.pl lib/unicode/In/44.pl
+ + lib/unicode/In/45.pl lib/unicode/In/46.pl lib/unicode/In/47.pl
+ + lib/unicode/In/48.pl lib/unicode/In/49.pl lib/unicode/In/5.pl
+ + lib/unicode/In/50.pl lib/unicode/In/51.pl lib/unicode/In/52.pl
+ + lib/unicode/In/53.pl lib/unicode/In/54.pl lib/unicode/In/55.pl
+ + lib/unicode/In/56.pl lib/unicode/In/57.pl lib/unicode/In/58.pl
+ + lib/unicode/In/59.pl lib/unicode/In/6.pl lib/unicode/In/60.pl
+ + lib/unicode/In/61.pl lib/unicode/In/62.pl lib/unicode/In/63.pl
+ + lib/unicode/In/64.pl lib/unicode/In/65.pl lib/unicode/In/66.pl
+ + lib/unicode/In/67.pl lib/unicode/In/68.pl lib/unicode/In/69.pl
+ + lib/unicode/In/7.pl lib/unicode/In/70.pl lib/unicode/In/71.pl
+ + lib/unicode/In/72.pl lib/unicode/In/73.pl lib/unicode/In/74.pl
+ + lib/unicode/In/75.pl lib/unicode/In/76.pl lib/unicode/In/77.pl
+ + lib/unicode/In/78.pl lib/unicode/In/79.pl lib/unicode/In/8.pl
+ + lib/unicode/In/80.pl lib/unicode/In/81.pl lib/unicode/In/82.pl
+ + lib/unicode/In/83.pl lib/unicode/In/84.pl lib/unicode/In/85.pl
+ + lib/unicode/In/86.pl lib/unicode/In/87.pl lib/unicode/In/88.pl
+ + lib/unicode/In/89.pl lib/unicode/In/9.pl lib/unicode/In/90.pl
+ + lib/unicode/In/91.pl lib/unicode/In/92.pl lib/unicode/In/93.pl
+ + lib/unicode/In/94.pl lib/unicode/In/95.pl
+ - lib/unicode/Block.pl
+ - lib/unicode/In/AlphabeticPresentationForms.pl
+ - lib/unicode/In/Arabic.pl
+ - lib/unicode/In/ArabicPresentationForms-A.pl
+ - lib/unicode/In/ArabicPresentationForms-B.pl
+ - lib/unicode/In/Armenian.pl lib/unicode/In/Arrows.pl
+ - lib/unicode/In/BasicLatin.pl lib/unicode/In/Bengali.pl
+ - lib/unicode/In/BlockElements.pl lib/unicode/In/Bopomofo.pl
+ - lib/unicode/In/BopomofoExtended.pl
+ - lib/unicode/In/BoxDrawing.pl lib/unicode/In/BraillePatterns.pl
+ - lib/unicode/In/CJKCompatibility.pl
+ - lib/unicode/In/CJKCompatibilityForms.pl
+ - lib/unicode/In/CJKCompatibilityIdeographs.pl
+ - lib/unicode/In/CJKRadicalsSupplement.pl
+ - lib/unicode/In/CJKSymbolsandPunctuation.pl
+ - lib/unicode/In/CJKUnifiedIdeographs.pl
+ - lib/unicode/In/CJKUnifiedIdeographsExtensionA.pl
+ - lib/unicode/In/Cherokee.pl
+ - lib/unicode/In/CombiningDiacriticalMarks.pl
+ - lib/unicode/In/CombiningHalfMarks.pl
+ - lib/unicode/In/CombiningMarksforSymbols.pl
+ - lib/unicode/In/ControlPictures.pl
+ - lib/unicode/In/CurrencySymbols.pl lib/unicode/In/Cyrillic.pl
+ - lib/unicode/In/Devanagari.pl lib/unicode/In/Dingbats.pl
+ - lib/unicode/In/EnclosedAlphanumerics.pl
+ - lib/unicode/In/EnclosedCJKLettersandMonths.pl
+ - lib/unicode/In/Ethiopic.pl
+ - lib/unicode/In/GeneralPunctuation.pl
+ - lib/unicode/In/GeometricShapes.pl lib/unicode/In/Georgian.pl
+ - lib/unicode/In/Greek.pl lib/unicode/In/GreekExtended.pl
+ - lib/unicode/In/Gujarati.pl lib/unicode/In/Gurmukhi.pl
+ - lib/unicode/In/HalfwidthandFullwidthForms.pl
+ - lib/unicode/In/HangulCompatibilityJamo.pl
+ - lib/unicode/In/HangulJamo.pl lib/unicode/In/HangulSyllables.pl
+ - lib/unicode/In/Hebrew.pl
+ - lib/unicode/In/HighPrivateUseSurrogates.pl
+ - lib/unicode/In/HighSurrogates.pl lib/unicode/In/Hiragana.pl
+ - lib/unicode/In/IPAExtensions.pl
+ - lib/unicode/In/IdeographicDescriptionCharacters.pl
+ - lib/unicode/In/Kanbun.pl lib/unicode/In/KangxiRadicals.pl
+ - lib/unicode/In/Kannada.pl lib/unicode/In/Katakana.pl
+ - lib/unicode/In/Khmer.pl lib/unicode/In/Lao.pl
+ - lib/unicode/In/Latin-1Supplement.pl
+ - lib/unicode/In/LatinExtended-A.pl
+ - lib/unicode/In/LatinExtended-B.pl
+ - lib/unicode/In/LatinExtendedAdditional.pl
+ - lib/unicode/In/LetterlikeSymbols.pl
+ - lib/unicode/In/LowSurrogates.pl lib/unicode/In/Malayalam.pl
+ - lib/unicode/In/MathematicalOperators.pl
+ - lib/unicode/In/MiscellaneousSymbols.pl
+ - lib/unicode/In/MiscellaneousTechnical.pl
+ - lib/unicode/In/Mongolian.pl lib/unicode/In/Myanmar.pl
+ - lib/unicode/In/NumberForms.pl lib/unicode/In/Ogham.pl
+ - lib/unicode/In/OpticalCharacterRecognition.pl
+ - lib/unicode/In/Oriya.pl lib/unicode/In/PrivateUse.pl
+ - lib/unicode/In/Runic.pl lib/unicode/In/Sinhala.pl
+ - lib/unicode/In/SmallFormVariants.pl
+ - lib/unicode/In/SpacingModifierLetters.pl
+ - lib/unicode/In/Specials.pl
+ - lib/unicode/In/SuperscriptsandSubscripts.pl
+ - lib/unicode/In/Syriac.pl lib/unicode/In/Tamil.pl
+ - lib/unicode/In/Telugu.pl lib/unicode/In/Thaana.pl
+ - lib/unicode/In/Thai.pl lib/unicode/In/Tibetan.pl
+ - lib/unicode/In/UnifiedCanadianAboriginalSyllabics.pl
+ - lib/unicode/In/YiRadicals.pl lib/unicode/In/YiSyllables.pl
+ ! MANIFEST lib/unicode/mktables.PL lib/utf8_heavy.pl
+ ! pod/perlunicode.pod
+ ____________________________________________________________________________
+ [ 9896] By: jhi on 2001/04/28 14:33:17
+ Log: Update the information on shared library path on HP-UX.
+ Branch: perl
+ ! INSTALL
+ ____________________________________________________________________________
+ [ 9895] By: jhi on 2001/04/28 14:32:30
+ Log: Because #9894 seems to do the trick, this workaround can be removed.
+ Branch: perl
+ ! t/lib/selfstubber.t
+ ____________________________________________________________________________
+ [ 9894] By: jhi on 2001/04/28 14:26:13
+ Log: For PerlIO flush the children's file handles (on fork/exec/system).
+ Branch: perl
+ ! perl.h
+ ____________________________________________________________________________
+ [ 9893] By: jhi on 2001/04/28 14:23:15
+ Log: Test tweak for #9891.
+ Branch: perl
+ ! t/lib/b-deparse.t
+ ____________________________________________________________________________
+ [ 9892] By: jhi on 2001/04/28 14:10:13
+ Log: New HP-UX hints from Merijn.
+ Branch: perl
+ ! hints/hpux.sh
+ ____________________________________________________________________________
+ [ 9891] By: jhi on 2001/04/28 14:07:27
+ Log: Subject: [PATCH B::Deparse] non-block scopes
+ From: Robin Houston <robin@kitsite.com>
+ Date: Fri, 27 Apr 2001 19:15:14 +0100
+ Message-ID: <20010427191514.A30951@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9890] By: nick on 2001/04/27 19:41:25
+ Log: Integrate mainline
+ Branch: perlio
+ +> t/lib/selfstubber.t
+ !> (integrate 50 files)
+ ____________________________________________________________________________
+ [ 9889] By: jhi on 2001/04/27 18:23:46
+ Log: Subject: Re: selfstubber test fail on bleadperl
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Fri, 27 Apr 2001 19:31:18 +0100
+ Message-Id: <E14tD1S-0001tJ-00@libra.cus.cam.ac.uk>
+ Branch: perl
+ ! t/lib/selfstubber.t
+ ____________________________________________________________________________
+ [ 9888] By: jhi on 2001/04/27 16:20:54
+ Log: Test tweak for #9886.
+ Branch: perl
+ ! t/lib/b-deparse.t
+ ____________________________________________________________________________
+ [ 9887] By: jhi on 2001/04/27 16:16:33
+ Log: Buffering issue at least in Solaris (even with perlio).
+ Branch: perl
+ ! t/lib/selfstubber.t
+ ____________________________________________________________________________
+ [ 9886] By: jhi on 2001/04/27 14:59:23
+ Log: Subject: [PATCH B::Deparse] Human-readable pragmas &c
+ From: Robin Houston <robin@kitsite.com>
+ Date: Fri, 27 Apr 2001 16:53:20 +0100
+ Message-ID: <20010427165320.A30479@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9885] By: jhi on 2001/04/27 14:23:51
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 9884] By: jhi on 2001/04/27 14:14:12
+ Log: Subject: [DOC PATCH bleadperl] Document underscores in numeric literals
+ From: "Philip Newton" <pnewton@gmx.de>
+ Date: Fri, 27 Apr 2001 16:40:13 +0200
+ Message-ID: <3AE9A0ED.5248.CEA127@localhost>
+ Branch: perl
+ ! pod/perldata.pod
+ ____________________________________________________________________________
+ [ 9883] By: jhi on 2001/04/27 13:28:19
+ Log: Add LOG_PERROR; prettify the "removed".
+ Branch: perl
+ ! ext/Sys/Syslog/Syslog.xs
+ ____________________________________________________________________________
+ [ 9882] By: jhi on 2001/04/27 13:13:18
+ Log: h2xs tweaks: use NV instead of double, "quote" the removed
+ prefixes for clarity (especially when nothing is removed),
+ slight pod reformats.
+ Branch: perl
+ ! utils/h2xs.PL
+ ____________________________________________________________________________
+ [ 9881] By: jhi on 2001/04/27 12:58:48
+ Log: Don't bother creating existing directories.
+ Branch: perl
+ ! utils/h2xs.PL
+ ____________________________________________________________________________
+ [ 9880] By: jhi on 2001/04/27 12:45:39
+ Log: Subject: MakeMaker 'make test' weirdness -- fix for h2xs provided
+ From: Mike Schilli <m@perlmeister.com>
+ Date: Wed, 25 Apr 2001 01:29:21 -0700
+ Message-id: <3AE68AE1.6A981723@perlmeister.com>
+ Branch: perl
+ ! utils/h2xs.PL
+ ____________________________________________________________________________
+ [ 9879] By: jhi on 2001/04/27 12:40:55
+ Log: break is not yet Perl. Added the template license also to README.
+ Branch: perl
+ ! utils/h2xs.PL
+ ____________________________________________________________________________
+ [ 9878] By: jhi on 2001/04/27 03:08:20
+ Log: Subject: Re: [ID 20010426.003] Not OK: perl v5.7.1 +DEVEL9849 on i686-linux-thread-multi-64int-ld 2.2.13
+ From: Tim Jenness <t.jenness@jach.hawaii.edu>
+ Date: Thu, 26 Apr 2001 15:30:17 -1000 (HST)
+ Message-ID: <Pine.LNX.4.33.0104261529300.13049-100000@lapaki.jach.hawaii.edu>
+ Branch: perl
+ ! t/lib/xs-typemap.t
+ ____________________________________________________________________________
+ [ 9877] By: jhi on 2001/04/26 23:54:40
+ Log: Subject: [PATCH: utils/h2xs.PL (bleadperl)] Fill in details we're likely to know.
+ From: "Abigail" <abigail@foad.org>
+ Date: Fri, 27 Apr 2001 01:44:28 +0200
+ Message-ID: <20010426234428.19786.qmail@foad.org>
+ Branch: perl
+ ! utils/h2xs.PL
+ ____________________________________________________________________________
+ [ 9876] By: jhi on 2001/04/26 23:52:06
+ Log: Subject: [PATCH: perl@9865] vms specific tweak to new selfstubber.t
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Thu, 26 Apr 2001 17:41:58 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10104261738370.338047-100000@aspara.forte.com>
+ Branch: perl
+ ! t/lib/selfstubber.t
+ ____________________________________________________________________________
+ [ 9875] By: jhi on 2001/04/26 23:48:10
+ Log: Deparse nits.
+ Branch: perl
+ ! ext/B/B/Deparse.pm t/lib/b-deparse.t
+ ____________________________________________________________________________
+ [ 9874] By: jhi on 2001/04/26 22:46:05
+ Log: Document ANYOF_CLASS.
+ Branch: perl
+ ! regcomp.h
+ ____________________________________________________________________________
+ [ 9873] By: jhi on 2001/04/26 22:35:03
+ Log: Subject: Re: [PATCH @9846] dumping ANYOF
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Thu, 26 Apr 2001 23:33:38 +0100
+ Message-Id: <200104262233.XAA22352@crypt.compulink.co.uk>
+ Branch: perl
+ ! regcomp.c regcomp.h
+ ____________________________________________________________________________
+ [ 9872] By: jhi on 2001/04/26 22:34:31
+ Log: Subject: [PATCH] more for Devel::SelfStubber
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Fri, 27 Apr 2001 00:13:52 +0100
+ Message-ID: <20010427001351.K88186@plum.flirble.org>
+ Branch: perl
+ ! lib/Devel/SelfStubber.pm lib/SelfLoader.pm t/lib/selfstubber.t
+ ____________________________________________________________________________
+ [ 9871] By: jhi on 2001/04/26 21:59:17
+ Log: Subject: [PATCH B::Deparse] formats must be flush left
+ From: Robin Houston <robin@kitsite.com>
+ Date: Thu, 26 Apr 2001 23:54:29 +0100
+ Message-ID: <20010426235429.A28747@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9870] By: jhi on 2001/04/26 21:57:37
+ Log: If some of the constants are prefixes of others,
+ the prefixes may never get recognized. (See 20010426.006.)
+ Branch: perl
+ ! utils/h2xs.PL
+ ____________________________________________________________________________
+ [ 9869] By: jhi on 2001/04/26 21:50:42
+ Log: Subject: [ID 20010426.006] Sys::Syslog ignores LOG_AUTH constant
+ From: Chris Bongaarts <cab@tc.umn.edu>
+ Date: Thu, 26 Apr 2001 17:10:31 -0500
+ Message-Id: <iss.2042.3ae89cd7.6cfba.1@earth.tc.umn.edu>
+ Branch: perl
+ ! ext/Sys/Syslog/Syslog.xs
+ ____________________________________________________________________________
+ [ 9868] By: jhi on 2001/04/26 21:35:12
+ Log: Further cuts and more docs from Graham Barr.
+ Branch: perl
+ ! ext/List/Util/lib/List/Util.pm
+ ! ext/List/Util/lib/Scalar/Util.pm
+ ____________________________________________________________________________
+ [ 9867] By: jhi on 2001/04/26 21:18:57
+ Log: Subject: [PATCH 5.7.1] DB_File-1.77
+ From: "Paul Marquess" <Paul.Marquess@Openwave.com>
+ Date: Thu, 26 Apr 2001 22:37:53 +0100
+ Message-ID: <000a01c0ce99$269cc3e0$99dcfea9@bfs.phone.com>
+ Branch: perl
+ ! ext/DB_File/Changes ext/DB_File/DB_File.pm
+ ! ext/DB_File/DB_File.xs ext/DB_File/version.c
+ ____________________________________________________________________________
+ [ 9866] By: jhi on 2001/04/26 21:12:31
+ Log: Subject: [PATCH B::Deparse] fix easy bugs
+ From: Robin Houston <robin@kitsite.com>
+ Date: Thu, 26 Apr 2001 23:03:33 +0100
+ Message-ID: <20010426230333.A28657@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9865] By: jhi on 2001/04/26 20:26:13
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 9864] By: jhi on 2001/04/26 19:27:48
+ Log: Dethinko from Robin Houston.
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9863] By: jhi on 2001/04/26 19:10:35
+ Log: Subject: [PATCH B::Deparse] C<$x = /(.)/> ne C<($x) = /(.)/>
+ From: Robin Houston <robin@kitsite.com>
+ Date: Thu, 26 Apr 2001 21:08:32 +0100
+ Message-ID: <20010426210832.A28419@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9862] By: jhi on 2001/04/26 19:04:23
+ Log: Subject: Re: [PATCH B::Deparse] fix string uninterpretation
+ From: Robin Houston <robin@kitsite.com>
+ Date: Thu, 26 Apr 2001 20:52:50 +0100
+ Message-ID: <20010426205249.A28328@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9861] By: jhi on 2001/04/26 18:56:14
+ Log: Subject: Re: [PATCH] UNIVERSAL shouldn't require Exporter
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Thu, 26 Apr 2001 14:22:40 +0100
+ Message-Id: <E14sljE-0003X9-00@libra.cus.cam.ac.uk>
+ Branch: perl
+ ! pod/perlobj.pod
+ ____________________________________________________________________________
+ [ 9860] By: jhi on 2001/04/26 18:46:42
+ Log: Subject: Re: [PATCH B::Deparse] fix string uninterpretation
+ From: Robin Houston <robin@kitsite.com>
+ Date: Thu, 26 Apr 2001 20:34:29 +0100
+ Message-ID: <20010426203429.A28261@puffinry.freeserve.co.uk>
+
+ Hashes do not interpolate.
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9859] By: jhi on 2001/04/26 18:43:51
+ Log: Subject: The Time::Piece conspiracy unmasked!!!
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Thu, 26 Apr 2001 19:02:50 +0100
+ Message-Id: <E14sq6M-0002g9-00@libra.cus.cam.ac.uk>
+
+ Subject: [PATCH] that's enough UNIVERSAL stuff for one day ...
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Thu, 26 Apr 2001 19:08:21 +0100
+ Message-Id: <E14sqBh-0002mI-00@libra.cus.cam.ac.uk>
+
+ Subject: Re: [PATCH] that's enough UNIVERSAL stuff for one day ...
+ From: Graham Barr <gbarr@pobox.com>
+ Date: Thu, 26 Apr 2001 19:12:03 +0100
+ Message-ID: <20010426191203.A70835@pobox.com>
+
+ Eradicate UNIVERSAL (Mike) and remove the fallback Perl code (Graham)
+ Branch: perl
+ ! ext/List/Util/lib/List/Util.pm
+ ! ext/List/Util/lib/Scalar/Util.pm ext/Time/Piece/Piece.pm gv.c
+ ____________________________________________________________________________
+ [ 9858] By: jhi on 2001/04/26 18:17:42
+ Log: Subject: [PATCH t/comp/proto.t] disable correct warning
+ From: Robin Houston <robin@kitsite.com>
+ Date: Thu, 26 Apr 2001 16:09:35 +0100
+ Message-ID: <20010426160934.A27140@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! t/comp/proto.t
+ ____________________________________________________________________________
+ [ 9857] By: jhi on 2001/04/26 18:04:59
+ Log: Subject: Re: [PATCH perldiag.pod] Re: [PATCH] Re: Useless use of constants other than 0,1 in void context?
+ From: barries <barries@slaysys.com>
+ Date: Thu, 26 Apr 2001 12:01:10 -0400
+ Message-ID: <20010426120110.E29698@jester.slaysys.com>
+ Branch: perl
+ ! pod/perldiag.pod
+ ____________________________________________________________________________
+ [ 9856] By: jhi on 2001/04/26 18:03:33
+ Log: Subject: [PATCH B::Deparse] fix string uninterpretation
+ Date: Thu, 26 Apr 2001 17:13:41 +0100
+ From: Robin Houston <robin@kitsite.com>
+ Message-ID: <20010426171341.A27299@puffinry.freeserve.co.uk>
+
+ Subject: Re: [PATCH B::Deparse] fix string uninterpretation
+ From: Robin Houston <robin@kitsite.com>
+ Date: Thu, 26 Apr 2001 18:44:29 +0100
+ Message-ID: <20010426184429.A27734@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9855] By: jhi on 2001/04/26 17:56:04
+ Log: Subject: [PATCH B::Deparse] filetests, open(my $x,...), warnings, formats &c
+ From: Robin Houston <robin@kitsite.com>
+ Date: Thu, 26 Apr 2001 17:04:08 +0100
+ Message-ID: <20010426170408.A27257@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9854] By: jhi on 2001/04/26 17:47:26
+ Log: Subject: Re: Short test case for undef %stash:: crash
+ From: Benjamin Sugars <bsugars@canoe.ca>
+ Date: Mon, 23 Apr 2001 16:59:33 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0104231623520.790-100000@marmot.rim.canoe.ca>
+ Changed and moved the perldiag entry.
+ Branch: perl
+ ! gv.c pod/perldiag.pod
+ ____________________________________________________________________________
+ [ 9853] By: jhi on 2001/04/26 14:35:16
+ Log: Beginnings of strptime(). Do not touch the wet paint.
+ Branch: perl
+ ! ext/Time/Piece/Piece.pm t/lib/time-piece.t
+ ____________________________________________________________________________
+ [ 9852] By: jhi on 2001/04/26 13:17:21
+ Log: Retract #9851, core dumps from pod2man.
+ Branch: perl
+ ! regcomp.c
+ ____________________________________________________________________________
+ [ 9851] By: jhi on 2001/04/26 11:54:41
+ Log: (Retracted by #9852.)
+
+ Subject: [PATCH @9846] dumping ANYOF
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Thu, 26 Apr 2001 05:32:38 +0100
+ Message-Id: <200104260432.FAA12669@crypt.compulink.co.uk>
+ Branch: perl
+ ! regcomp.c
+ ____________________________________________________________________________
+ [ 9850] By: jhi on 2001/04/26 02:34:44
+ Log: If ccflags was empty the _previous_ $* containing all the
+ environment variables and Configure variables was used,
+ which lead, among other bad things, into $ccflags being your
+ uname -a output, which lead into test compile with cc failing,
+ which lead into gcc being selected, which didn't work that well
+ since gcc (ancient 2.8.1 in that particular box) wasn't too happy
+ with large files, et cetera.
+ Branch: perl
+ ! hints/hpux.sh
+ ____________________________________________________________________________
+ [ 9849] By: jhi on 2001/04/26 01:44:57
+ Log: Make selfstubber test more portable.
+ Branch: perl
+ ! t/lib/selfstubber.t
+ ____________________________________________________________________________
+ [ 9848] By: jhi on 2001/04/26 00:50:26
+ Log: Subject: Re: [PATCH: perl@9841] fix a typo for Cwd.xs
+ From: Benjamin Sugars <ben.sugars@home.com>
+ Date: Wed, 25 Apr 2001 21:47:37 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0104252145280.30055-100000@localhost.localdomain>
+ Branch: perl
+ ! ext/Cwd/Cwd.xs
+ ____________________________________________________________________________
+ [ 9847] By: jhi on 2001/04/26 00:46:58
+ Log: Subject: [PATCH: perl@9841] VMS updates
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Wed, 25 Apr 2001 18:43:27 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10104251842130.257877-100000@aspara.forte.com>
+ Branch: perl
+ ! README.vms configure.com vms/descrip_mms.template
+ ! vms/ext/filespec.t
+ ____________________________________________________________________________
+ [ 9846] By: jhi on 2001/04/26 00:11:56
+ Log: re 'debug' was broken by #9084.
+ Branch: perl
+ ! ext/re/re.xs
+ ____________________________________________________________________________
+ [ 9845] By: jhi on 2001/04/25 22:33:17
+ Log: Subject: [PATCH] test for Devel::SelfStubber
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Thu, 26 Apr 2001 00:00:54 +0100
+ Message-ID: <20010426000054.D89026@plum.flirble.org>
+ Branch: perl
+ + t/lib/selfstubber.t
+ ! MANIFEST lib/Devel/SelfStubber.pm t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 9844] By: jhi on 2001/04/25 22:29:32
+ Log: Subject: Re: [PATCH 5.7.1] B::Concise and extra variables
+ From: Paul Johnson <paul@pjcj.net>
+ Date: Thu, 26 Apr 2001 00:46:08 +0200
+ Message-ID: <20010426004608.H2338@pjcj.net>
+ Branch: perl
+ ! ext/B/B/Concise.pm
+ ____________________________________________________________________________
+ [ 9843] By: jhi on 2001/04/25 22:28:28
+ Log: Subject: [PATCH: perl@9841] fix a typo for Cwd.xs
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Wed, 25 Apr 2001 16:18:44 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10104251614200.257877-100000@aspara.forte.com>
+ Branch: perl
+ ! ext/Cwd/Cwd.xs
+ ____________________________________________________________________________
+ [ 9842] By: jhi on 2001/04/25 20:58:12
+ Log: Subject: Re: [ID 20010422.002] 5.7.1 Breaks "use Module(version)"
+ From: John Peacock <jpeacock@rowman.com>
+ Date: Wed, 25 Apr 2001 17:30:26 -0400
+ Message-ID: <3AE741F2.B3217464@rowman.com>
+ Branch: perl
+ ! lib/Math/BigInt.pm t/lib/bigintpm.t
+ ____________________________________________________________________________
+ [ 9841] By: jhi on 2001/04/25 20:07:05
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 9840] By: jhi on 2001/04/25 19:56:51
+ Log: Yet another HP-UX hints version from Merijn.
+ Branch: perl
+ ! hints/hpux.sh
+ ____________________________________________________________________________
+ [ 9839] By: jhi on 2001/04/25 19:53:04
+ Log: abs_path() didn't terminate the filename correctly,
+ in DIRNAMLENless systems like HP-UX this would fail.
+ Branch: perl
+ ! ext/Cwd/Cwd.xs
+ ____________________________________________________________________________
+ [ 9838] By: jhi on 2001/04/25 16:37:26
+ Log: Subject: [PATCH] Re: Useless use of constants other than 0,1 in void context?
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Wed, 25 Apr 2001 18:31:47 +0100
+ Message-Id: <E14sT8l-0004IE-00@libra.cus.cam.ac.uk>
+ Branch: perl
+ ! op.c
+ ____________________________________________________________________________
+ [ 9837] By: jhi on 2001/04/25 16:21:53
+ Log: Subject: Re: patch to perl5db.pl (formatting of h h screen)
+ From: Jon Eveland <jweveland@yahoo.com>
+ Date: Wed, 25 Apr 2001 09:42:46 -0700 (PDT)
+ Message-ID: <20010425164246.21611.qmail@web10405.mail.yahoo.com>
+ Branch: perl
+ ! lib/perl5db.pl
+ ____________________________________________________________________________
+ [ 9836] By: jhi on 2001/04/25 14:17:50
+ Log: Subject: [PATCH bleadperl] Porting/patching.pod: update version number format
+ From: "Philip Newton" <pnewton@gmx.de>
+ Date: Wed, 25 Apr 2001 17:05:58 +0200
+ Message-ID: <3AE703F6.3234.1833C45@localhost>
+ Branch: perl
+ ! Porting/patching.pod
+ ____________________________________________________________________________
+ [ 9835] By: jhi on 2001/04/25 13:58:07
+ Log: It would seem that both ar and full_ar need to be overridden
+ for HP-UX to avoid the GNU ar.
+ Branch: perl
+ ! hints/hpux.sh
+ ____________________________________________________________________________
+ [ 9834] By: jhi on 2001/04/25 13:50:40
+ Log: Subject: Re: [PATCH] foreach defelem magic should only be applied to PL_sv_undef
+ From: "Philip Newton" <pnewton@gmx.de>
+ Date: Wed, 25 Apr 2001 16:09:23 +0200
+ Message-ID: <3AE6F6B3.30503.14F6DEB@localhost>
+
+ Detypo.
+ Branch: perl
+ ! t/op/misc.t
+ ____________________________________________________________________________
+ [ 9833] By: jhi on 2001/04/25 12:36:11
+ Log: In HP-UX set ar to /usr/bin/ar but only iff none set.
+ Branch: perl
+ ! hints/hpux.sh
+ ____________________________________________________________________________
+ [ 9832] By: jhi on 2001/04/25 12:33:36
+ Log: New version of HP-UX hints from Merijn.
+ Branch: perl
+ ! hints/hpux.sh
+ ____________________________________________________________________________
+ [ 9831] By: jhi on 2001/04/25 03:39:45
+ Log: Reintroduce the avoidance of mixing HP-UX cc and GNU ar.
+ Branch: perl
+ ! hints/hpux.sh
+ ____________________________________________________________________________
+ [ 9830] By: jhi on 2001/04/25 02:53:25
+ Log: The tzname[] bit is not needed by util.c -- and causes
+ heartburn in VMS (and it missing was probably the cause of
+ the Mac OS X trouble). Ouch.
+ Branch: perl
+ ! ext/POSIX/POSIX.xs util.c
+ ____________________________________________________________________________
+ [ 9829] By: jhi on 2001/04/25 00:10:06
+ Log: Metaconfig unit change for #9828.
+ Branch: metaconfig
+ ! U/compline/ccflags.U
+ ____________________________________________________________________________
+ [ 9828] By: jhi on 2001/04/25 00:04:18
+ Log: Allow setting cppflags hints. This may affect Darwin (Mac OS X)
+ (which is actually the reason for the change, we need to pass
+ cppflags='-traditional-cpp' so that Errno builds right), Dynix/ptx,
+ EP/IX, OS/2, and TitanOS, based on the hints files.
+ Branch: perl
+ ! Configure config_h.SH
+ ____________________________________________________________________________
+ [ 9827] By: jhi on 2001/04/24 23:49:20
+ Log: makedepend.SH patch for AmigaOS from Jan-Erik Karlsson;
+ the $cat must have an absolute path.
+ Branch: perl
+ ! makedepend.SH
+ ____________________________________________________________________________
+ [ 9826] By: jhi on 2001/04/24 23:40:53
+ Log: 5.7.1-updated README.amiga from Jan-Erik Karlsson.
+ Branch: perl
+ ! README.amiga
+ ____________________________________________________________________________
+ [ 9825] By: jhi on 2001/04/24 23:35:35
+ Log: Subject: [ID 20010424.002] [PATCH bleadperl] find2perl: prototypes and doexec
+ From: "Philip Newton" <pnewton@gmx.de>
+ Date: Tue, 24 Apr 2001 18:52:49 +0200
+ Message-Id: <3AE5CB81.12234.1FC246F@localhost>
+ Branch: perl
+ ! x2p/find2perl.PL
+ ____________________________________________________________________________
+ [ 9824] By: jhi on 2001/04/24 23:33:07
+ Log: New HP-UX hints from Jeff and Merijn, should work with IA-64.
+ Some gcc specifics dropped out due to extensive rewriting;
+ will be put back later as needed.
+ Branch: perl
+ ! hints/hpux.sh
+ ____________________________________________________________________________
+ [ 9823] By: jhi on 2001/04/24 23:27:57
+ Log: Mac OS X patch for missing tzname definition from Paul Schinder.
+ Branch: perl
+ ! ext/POSIX/POSIX.xs
+ ____________________________________________________________________________
+ [ 9822] By: jhi on 2001/04/24 23:25:21
+ Log: Subject: Re: [ID 20010421.032] Not OK: perl v5.7.1 +DEVEL9717 on sun4-solaris-64int-ld-stdio 2.8 (UNINSTALLED)
+ From: Tim Jenness <t.jenness@jach.hawaii.edu>
+ Date: Tue, 24 Apr 2001 11:29:28 -1000 (HST)
+ Message-ID: <Pine.LNX.4.30.0104241123020.5085-100000@lapaki.jach.hawaii.edu>
+ Branch: perl
+ ! ext/XS/Typemap/Typemap.xs
+ ____________________________________________________________________________
+ [ 9821] By: jhi on 2001/04/24 23:24:10
+ Log: Subject: [PATCH: pod/perlport.pod] Updated email addresses.
+ From: "Abigail" <abigail@foad.org>
+ Date: Tue, 24 Apr 2001 23:12:03 +0200
+ Message-ID: <20010424211203.7901.qmail@foad.org>
+ Branch: perl
+ ! pod/perlport.pod
+ ____________________________________________________________________________
+ [ 9820] By: jhi on 2001/04/24 23:23:15
+ Log: Subject: [PATCH pod/perlfaq4.pod] Time::Piece additions
+ From: Matt Sergeant <matt@sergeant.org>
+ Date: Tue, 24 Apr 2001 16:48:17 +0100 (BST)
+ Message-ID: <Pine.LNX.4.30.0104241645030.32279-100000@ted.sergeant.org>
+ Branch: perl
+ ! pod/perlfaq4.pod
+ ____________________________________________________________________________
+ [ 9819] By: nick on 2001/04/24 18:49:43
+ Log: Integrate mainline.
+ Branch: perlio
+ +> t/lib/cpan-loadme.t t/lib/cpan-vcmp.t
+ !> (integrate 37 files)
+ ____________________________________________________________________________
+ [ 9818] By: jhi on 2001/04/24 14:35:23
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 9817] By: jhi on 2001/04/24 14:09:17
+ Log: Subject: Re: [PATCH t/lib/1_compile.t] Skipping known tested libraries
+ From: "Philip Newton" <pnewton@gmx.de>
+ Date: Tue, 24 Apr 2001 12:58:12 +0200
+ Message-ID: <3AE57864.8304.B77A0A@localhost>
+
+ plus add CPAN to the list of modules that have their own tests.
+ Branch: perl
+ ! t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 9816] By: jhi on 2001/04/24 14:07:03
+ Log: Subject: Re: [PATCH t/lib/1_compile.t] Skipping known tested libraries
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Sat, 21 Apr 2001 22:35:00 +0100
+ Message-ID: <20010421223500.N2946@blackrider.blackstar.co.uk>
+ Branch: perl
+ ! t/lib/1_compile.t
+ ____________________________________________________________________________
+ [ 9815] By: jhi on 2001/04/24 13:54:32
+ Log: Subject: Re: [ID 20010423.006] Test failed in perl@9794
+ From: Robin Houston <robin@kitsite.com>
+ Date: Tue, 24 Apr 2001 15:51:18 +0100
+ Message-ID: <20010424155118.A22913@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9814] By: jhi on 2001/04/24 13:17:34
+ Log: Subject: Re: [ID 20010421.010] Perl 5.6.1 on Unixware 7
+ From: Bill Glicker <billg@burrelles.com>
+ Date: Tue, 24 Apr 2001 09:22:40 -0400 (EDT)
+ Message-ID: <Pine.SCO.4.30.0104240918160.13514-100000@laura.burrelles.com>
+ Branch: perl
+ ! hints/svr5.sh
+ ____________________________________________________________________________
+ [ 9813] By: jhi on 2001/04/24 12:54:23
+ Log: Prevent path disclosure (probing for existence of filenames)
+ using suidperl; bug id 20010322.218.
+ Branch: perl
+ ! perl.c pod/perldiag.pod
+ ____________________________________________________________________________
+ [ 9812] By: jhi on 2001/04/24 12:08:36
+ Log: Retract #9811.
+ Branch: perl
+ ! ext/POSIX/POSIX.xs
+ ____________________________________________________________________________
+ [ 9811] By: jhi on 2001/04/24 11:57:35
+ Log: (Retracted by #9812.)
+ Branch: perl
+ ! ext/POSIX/POSIX.xs
+ ____________________________________________________________________________
+ [ 9810] By: jhi on 2001/04/24 03:32:35
+ Log: Fix for 20010219.013, "perlio perl -we tell goes SEGV".
+ Branch: perl
+ ! util.c
+ ____________________________________________________________________________
+ [ 9809] By: jhi on 2001/04/24 03:16:13
+ Log: The Math::BigFloat::import() was broken.
+ (Fixes bug id 20010422.002.)
+ Branch: perl
+ ! lib/Math/BigFloat.pm
+ ____________________________________________________________________________
+ [ 9808] By: jhi on 2001/04/24 01:11:40
+ Log: Additional dependencies; should help for parallel makes
+ not to fail on missing lib/lib.pm or lib/re.pm.
+ Branch: perl
+ ! Makefile.SH
+ ____________________________________________________________________________
+ [ 9807] By: jhi on 2001/04/24 00:57:01
+ Log: Update the test failure disclaimer.
+ Branch: perl
+ ! t/pragma/warn/pp_hot
+ ____________________________________________________________________________
+ [ 9806] By: jhi on 2001/04/24 00:54:04
+ Log: Add make target "install-all" which is alias for "install"
+ to cater for case-preserving filesystems like HFS+.
+ Branch: perl
+ ! INSTALL Makefile.SH
+ ____________________________________________________________________________
+ [ 9805] By: jhi on 2001/04/24 00:47:28
+ Log: Subject: Re: 5.6.1 darwin Configure fails to extract Makefile
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Wed, 11 Apr 2001 10:43:52 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10104111038480.113314-100000@aspara.forte.com>
+
+ (Ken William's message forwarded from macosx@perl.org)
+ Branch: perl
+ ! hints/darwin.sh
+ ____________________________________________________________________________
+ [ 9804] By: jhi on 2001/04/23 23:57:35
+ Log: Cut-and-pasto.
+ Branch: perl
+ ! perlio.c
+ ____________________________________________________________________________
+ [ 9803] By: jhi on 2001/04/23 23:52:25
+ Log: More PerlIO robustness.
+ Branch: perl
+ ! perlio.c
+ ____________________________________________________________________________
+ [ 9802] By: jhi on 2001/04/23 23:43:35
+ Log: Make the "STD* opened only for ..." errors more consistent.
+ Branch: perl
+ ! doio.c
+ ____________________________________________________________________________
+ [ 9801] By: jhi on 2001/04/23 23:34:26
+ Log: Test case for #9800.
+ Branch: perl
+ ! t/op/misc.t
+ ____________________________________________________________________________
+ [ 9800] By: jhi on 2001/04/23 23:14:43
+ Log: Avoid coredump on 'close STDERR; die' by making
+ the PerlIO calls more robust. Also use SETERRNO()
+ instead of errno = to be more VMS-ready.
+ Branch: perl
+ ! perlio.c
+ ____________________________________________________________________________
+ [ 9799] By: jhi on 2001/04/23 21:41:10
+ Log: Subject: test for ID 20010423.002
+ From: Robin Houston <robin@kitsite.com>
+ Date: Mon, 23 Apr 2001 16:52:21 +0100
+ Message-ID: <20010423165221.A20739@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! t/op/avhv.t
+ ____________________________________________________________________________
+ [ 9798] By: jhi on 2001/04/23 21:40:07
+ Log: Subject: patch to installperl (change warn to print STDERR in sub yn)
+ From: David Dyck <dcd@tc.fluke.com>
+ Date: Mon, 23 Apr 2001 10:19:46 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.33.0104231018270.10985-100000@dd.tc.fluke.com>
+ Branch: perl
+ ! installperl
+ ____________________________________________________________________________
+ [ 9797] By: jhi on 2001/04/23 21:37:56
+ Log: Subject: [PATCH] Implement Cwd::abs_path in XS
+ From: Benjamin Sugars <bsugars@canoe.ca>
+ Date: Mon, 23 Apr 2001 11:59:48 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0104231151340.3238-100000@marmot.rim.canoe.ca>
+ Branch: perl
+ ! ext/Cwd/Cwd.xs lib/Cwd.pm
+ ____________________________________________________________________________
+ [ 9796] By: jhi on 2001/04/23 21:29:24
+ Log: Synchronize h2xs and pod2man some more on the documentation
+ templates they propose.
+ Branch: perl
+ ! pod/pod2man.PL utils/h2xs.PL
+ ____________________________________________________________________________
+ [ 9795] By: jhi on 2001/04/23 17:30:40
+ Log: Add one more naughty test for base64; make encoding logic cleaner.
+ Branch: perl
+ ! t/lib/mimeb64.t
+ ____________________________________________________________________________
+ [ 9794] By: jhi on 2001/04/23 13:51:32
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 9793] By: jhi on 2001/04/23 13:44:18
+ Log: Duplicate lines.
+ Branch: perl
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 9792] By: jhi on 2001/04/23 13:39:13
+ Log: Subject: Re: PATCH 5.7.1
+ From: Mark-Jason Dominus <mjd@plover.com>
+ Date: Mon, 23 Apr 2001 10:30:21 -0400
+ Message-ID: <20010423143021.17335.qmail@plover.com>
+ Branch: perl
+ ! perl.h sv.c
+ ____________________________________________________________________________
+ [ 9791] By: jhi on 2001/04/23 13:32:40
+ Log: Add the CPAN.pm 1.59_54 tests.
+ Branch: perl
+ + t/lib/cpan-loadme.t t/lib/cpan-vcmp.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 9790] By: jhi on 2001/04/23 13:21:55
+ Log: Subject: Deparse nit
+ From: Robin Houston <robin@kitsite.com>
+ Date: Mon, 23 Apr 2001 12:38:20 +0100
+ Message-ID: <20010423123820.A19945@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9789] By: jhi on 2001/04/23 13:19:07
+ Log: Subject: [PATCH] bug 20010423.002
+ From: Robin Houston <robin@kitsite.com>
+ Date: Mon, 23 Apr 2001 13:12:30 +0100
+ Message-ID: <20010423131230.A20074@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! pp.c
+ ____________________________________________________________________________
+ [ 9788] By: jhi on 2001/04/23 13:02:49
+ Log: Subject: PATCH [5.7.1] hv.c unused #define
+ From: Mark-Jason Dominus <mjd@plover.com>
+ Date: Sun, 22 Apr 2001 14:17:49 -0400
+ Message-ID: <20010422181749.26976.qmail@plover.com>
+ Branch: perl
+ ! hv.c
+ ____________________________________________________________________________
+ [ 9787] By: jhi on 2001/04/23 13:02:02
+ Log: Subject: PATCH 5.7.1
+ From: Mark-Jason Dominus <mjd@plover.com>
+ Date: Sun, 22 Apr 2001 15:12:57 -0400
+ Message-ID: <20010422191258.6539.qmail@plover.com>
+
+ plus Sarathy's STMT_START + STMT_END suggestion.
+ Branch: perl
+ ! perl.h
+ ____________________________________________________________________________
+ [ 9786] By: jhi on 2001/04/23 12:53:25
+ Log: Fix for
+
+ Subject: [ID 20010423.001] perlapi documentation inconsistency (SvGROW)
+ From: dLux <dlux@spam.sch.bme.hu>
+ Date: Mon, 23 Apr 2001 01:25:26 +0200
+ Message-Id: <E14rTEM-0000CB-00@dl.sch.bme.hu>
+
+ (SvGROW really does return a char *.)
+ Branch: perl
+ ! pod/perlapi.pod sv.h
+ ____________________________________________________________________________
+ [ 9785] By: jhi on 2001/04/23 04:34:04
+ Log: Time::Piece work continues. $t->day removed since
+ I think it's too confusing. Now has normal and
+ abbreviated length weekday names and month names,
+ the names change with _names(), not _list().
+ Now has strftime() in Perl, _strftime() is
+ the libc version (to which strftime() falls back
+ if it doesn't know the format. To do: the reverse
+ of strftime, strptime(), and the localisation of both.
+ Branch: perl
+ ! ext/Time/Piece/Piece.pm ext/Time/Piece/Piece.xs
+ ! t/lib/time-piece.t
+ ____________________________________________________________________________
+ [ 9784] By: jhi on 2001/04/23 02:41:46
+ Log: Subject: Re: [PATCH] Re: [ID 20010422.003] Core dump in overloaded bool while using '
+ From: andreas.koenig@anima.de (Andreas J. Koenig)
+ Date: 23 Apr 2001 05:20:55 +0200
+ Message-ID: <m3ofto5mjs.fsf@ak-71.mind.de>
+ Branch: perl
+ ! t/pragma/overload.t
+ ____________________________________________________________________________
+ [ 9783] By: jhi on 2001/04/22 23:32:42
+ Log: Subject: [PATCH B::Deparse] Distinguish package variables, if necessary
+ From: Robin Houston <robin@kitsite.com>
+ Date: Mon, 23 Apr 2001 00:38:18 +0100
+ Message-ID: <20010423003818.A19109@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9782] By: jhi on 2001/04/22 20:55:43
+ Log: Subject: [PATCH] Re: [ID 20010422.003] Core dump in overloaded bool while using '
+ From: Simon Cozens <simon@netthink.co.uk>
+ Date: Sun, 22 Apr 2001 18:47:25 +0100
+ Message-ID: <20010422184725.A14411@netthink.co.uk>
+ Branch: perl
+ ! sv.c t/pragma/overload.t
+ ____________________________________________________________________________
+ [ 9781] By: jhi on 2001/04/22 20:52:13
+ Log: Subject: [PATCH] Support BEGIN blocks in B::Deparse (& more)
+ From: Robin Houston <robin@kitsite.com>
+ Date: Sun, 22 Apr 2001 22:14:50 +0100
+ Message-ID: <20010422221450.A18921@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B/Concise.pm ext/B/B/Deparse.pm ext/B/O.pm
+ ____________________________________________________________________________
+ [ 9780] By: nick on 2001/04/22 20:40:31
+ Log: Integrate mainline.
+ Branch: perlio
+ +> t/lib/b-debug.t t/lib/b-deparse.t t/lib/b-showlex.t
+ +> t/lib/b-stash.t
+ !> (integrate 38 files)
+ ____________________________________________________________________________
+ [ 9779] By: jhi on 2001/04/22 15:16:03
+ Log: Subject: IO::Socket::INET patch
+ From: andrew deryabin <djsf@technarchy.ru>
+ Date: Sat, 21 Apr 2001 17:46:52 +0400
+ Message-ID: <20010421174652.B1426@technarchy>
+ Branch: perl
+ ! ext/IO/lib/IO/Socket/INET.pm
+ ____________________________________________________________________________
+ [ 9778] By: jhi on 2001/04/22 15:14:33
+ Log: Subject: Re: ANYOF_SIZE is wrong in 5.7.1
+ From: Mark-Jason Dominus <mjd@plover.com>
+ Date: Sat, 21 Apr 2001 21:27:49 -0400
+ Message-ID: <20010422012749.27024.qmail@plover.com>
+ Branch: perl
+ ! regcomp.c
+ ____________________________________________________________________________
+ [ 9777] By: jhi on 2001/04/22 15:10:51
+ Log: Subject: Re: Regex debugger patch
+ From: Mark-Jason Dominus <mjd@plover.com>
+ Date: Sat, 21 Apr 2001 21:48:51 -0400
+ Message-ID: <20010422014851.27165.qmail@plover.com>
+ Branch: perl
+ ! pod/perldebguts.pod
+ ____________________________________________________________________________
+ [ 9776] By: jhi on 2001/04/22 15:09:48
+ Log: Subject: Re: Regex debugger patch
+ From: Mark-Jason Dominus <mjd@plover.com>
+ Date: Sat, 21 Apr 2001 14:24:39 -0400
+ Message-ID: <20010421182439.16508.qmail@plover.com>
+
+ Regex debugger backend.
+ Branch: perl
+ ! regcomp.c regexp.h
+ ____________________________________________________________________________
+ [ 9775] By: jhi on 2001/04/21 16:45:40
+ Log: Subject: [PATCH] Typo in utf8.h
+ From: Jes�s Quiroga <jquiroga@pobox.com>
+ Date: Sat, 21 Apr 2001 19:25:33 +0200
+ Message-Id: <5.0.2.1.1.20010421192107.01ce5a50@ix.netcorps.com>
+ Branch: perl
+ ! utf8.h
+ ____________________________________________________________________________
+ [ 9774] By: jhi on 2001/04/21 16:43:52
+ Log: Subject: [ID 20010421.010] Perl 5.6.1 on Unixware 7
+ From: Joe Orton <jorton@redhat.com>
+ Date: Tue, 17 Apr 2001 15:50:43 +0100
+ Message-Id: <20010417155043.D19132@eu.c2.net>
+ Branch: perl
+ ! hints/svr5.sh
+ ____________________________________________________________________________
+ [ 9773] By: jhi on 2001/04/21 15:30:15
+ Log: Subject: Patch utils/h2xs.PL
+ From: Elaine -HFB- Ashton <elaine@chaos.wustl.edu>
+ Date: Sat, 21 Apr 2001 10:32:16 -0500
+ Message-ID: <20010421103216.C14521@chaos.wustl.edu>
+
+ Add MAILING list and LICENSE templates.
+ Branch: perl
+ ! utils/h2xs.PL
+ ____________________________________________________________________________
+ [ 9772] By: jhi on 2001/04/21 15:28:36
+ Log: Subject: perlfaq2.patch for 5.7.1
+ From: Elaine -HFB- Ashton <elaine@chaos.wustl.edu>
+ Message-ID: <20010420164219.J3194@chaos.wustl.edu>
+ Date: Fri, 20 Apr 2001 16:42:19 -0500
+
+ rm an extra tab, a blurb about the xx.cpan to clarify
+ which countries actually have that and dejanews is history
+ as well as most of that nonsensical entry.
+ Branch: perl
+ ! pod/perlfaq2.pod
+ ____________________________________________________________________________
+ [ 9771] By: jhi on 2001/04/21 15:27:17
+ Log: Subject: perlfaq1.patch for 5.7.1
+ From: Elaine -HFB- Ashton <elaine@chaos.wustl.edu>
+ Date: Fri, 20 Apr 2001 16:57:36 -0500
+ Message-ID: <20010420165736.K3194@chaos.wustl.edu>
+
+ Evil URLs must die. Especially when they are broken.
+ Branch: perl
+ ! pod/perlfaq1.pod
+ ____________________________________________________________________________
+ [ 9770] By: jhi on 2001/04/21 15:23:38
+ Log: Subject: [PATCH ext/B/B.pm and tests] B::walksymtable improperly documented?
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Sat, 21 Apr 2001 16:11:12 +0100
+ Message-ID: <20010421161112.L19736@blackrider.blackstar.co.uk>
+ Branch: perl
+ + t/lib/b-debug.t t/lib/b-deparse.t t/lib/b-showlex.t
+ + t/lib/b-stash.t
+ ! MANIFEST ext/B/B.pm t/lib/b.t
+ ____________________________________________________________________________
+ [ 9769] By: jhi on 2001/04/21 15:03:32
+ Log: Subject: [PATCH utils/h2ph.PL] Confused by "#if &__GNUC_PREREQ (2,97)"
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Sat, 21 Apr 2001 09:48:00 +0100
+ Message-ID: <20010421094759.B19736@blackrider.blackstar.co.uk>
+ Branch: perl
+ ! utils/h2ph.PL
+ ____________________________________________________________________________
+ [ 9768] By: jhi on 2001/04/21 14:33:49
+ Log: PerlIO and Encode doc cleanup and tweaks.
+ Branch: perl
+ ! ext/Encode/Encode.pm ext/PerlIO/Scalar/Scalar.pm
+ ! ext/PerlIO/Via/Via.pm lib/PerlIO.pm
+ ____________________________________________________________________________
+ [ 9767] By: jhi on 2001/04/21 12:40:16
+ Log: Integrate perlio.
+ Branch: perl
+ !> doio.c
+ ____________________________________________________________________________
+ [ 9766] By: nick on 2001/04/20 18:28:35
+ Log: Avoid core dump on
+ open(STDOUT,">",\$foo);
+ Branch: perlio
+ ! doio.c
+ ____________________________________________________________________________
+ [ 9765] By: jhi on 2001/04/20 13:23:43
+ Log: Subject: Re: [abigail@foad.org: [ID 20000901.065] -MO=Deparse and $^W and $[ in same string.]
+ From: Robin Houston <robin@kitsite.com>
+ Date: Fri, 20 Apr 2001 14:29:22 +0100
+ Message-ID: <20010420142921.A14960@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B.pm ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9764] By: jhi on 2001/04/20 13:19:33
+ Log: Subject: [PATCH: perl@9742] avoid t/u-*.t test on platforms where List/Util was not built
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Thu, 19 Apr 2001 17:40:14 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10104191737200.348917-100000@aspara.forte.com>
+ Branch: perl
+ ! t/lib/u-blessed.t t/lib/u-dualvar.t t/lib/u-first.t
+ ! t/lib/u-max.t t/lib/u-maxstr.t t/lib/u-min.t t/lib/u-minstr.t
+ ! t/lib/u-readonly.t t/lib/u-reduce.t t/lib/u-reftype.t
+ ! t/lib/u-sum.t t/lib/u-tainted.t t/lib/u-weak.t
+ ____________________________________________________________________________
+ [ 9763] By: jhi on 2001/04/20 12:36:39
+ Log: Subject: Re: A new PerlIO coredump
+ From: Nick Ing-Simmons <nik@tiuk.ti.com>
+ Date: Fri, 20 Apr 2001 14:29:41 +0100 (BST)
+ Message-Id: <200104201329.OAA16021@mikado.tiuk.ti.com>
+ Branch: perl
+ ! doio.c
+ ____________________________________________________________________________
+ [ 9762] By: jhi on 2001/04/19 23:02:30
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 9761] By: jhi on 2001/04/19 22:59:19
+ Log: More cleanup cleanup.
+ Branch: perl
+ ! Makefile.SH win32/Makefile win32/makefile.mk
+ ____________________________________________________________________________
+ [ 9760] By: jhi on 2001/04/19 22:50:31
+ Log: lib/Time is non-empty, let's not rmdir it.
+ Branch: perl
+ ! Makefile.SH
+ ____________________________________________________________________________
+ [ 9759] By: jhi on 2001/04/19 22:36:51
+ Log: Subject: Re: [abigail@foad.org: [ID 20000901.065] -MO=Deparse and $^W and $[ in same string.]
+ From: Robin Houston <robin@kitsite.com>
+ Date: Fri, 20 Apr 2001 00:18:53 +0100
+ Message-ID: <20010420001853.A13350@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9758] By: jhi on 2001/04/19 22:36:00
+ Log: Subject: [PATCH: perl@9742] void close_dir portability fix for Cwd.xs
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Thu, 19 Apr 2001 12:02:40 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10104191158490.348917-100000@aspara.forte.com>
+ Branch: perl
+ ! ext/Cwd/Cwd.xs
+ ____________________________________________________________________________
+ [ 9757] By: nick on 2001/04/19 18:53:54
+ Log: Blind (untested) integrate of mainline.
+ Branch: perlio
+ +> ext/Time/Piece/Makefile.PL ext/Time/Piece/Piece.pm
+ +> ext/Time/Piece/Piece.xs ext/Time/Piece/README
+ +> ext/Time/Piece/Seconds.pm t/lib/time-piece.t
+ !> (integrate 53 files)
+ ____________________________________________________________________________
+ [ 9756] By: jhi on 2001/04/19 16:59:23
+ Log: Document and test Time::Piece.
+ Branch: perl
+ ! ext/POSIX/POSIX.xs ext/Time/Piece/Piece.pm
+ ! ext/Time/Piece/Piece.xs t/lib/time-piece.t
+ ____________________________________________________________________________
+ [ 9755] By: jhi on 2001/04/19 12:13:29
+ Log: A better fix for the \x{12345678} trouble from NI-S.
+ Branch: perl
+ ! utf8.c
+ ____________________________________________________________________________
+ [ 9754] By: jhi on 2001/04/19 11:56:07
+ Log: Subject: PATCH: Propagate low byte of hints in cop.op_private
+ From: Robin Houston <robin@kitsite.com>
+ Date: Wed, 18 Apr 2001 17:58:33 +0100
+ Message-ID: <20010418175833.B8976@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm op.c
+ ____________________________________________________________________________
+ [ 9753] By: jhi on 2001/04/19 04:21:52
+ Log: Subject: [PATCH] h2ph test suite bugfix and refactoring
+ From: "Kurt D. Starsinic" <kstar@wolfetech.com>
+ Date: Thu, 19 Apr 2001 01:11:41 -0400
+ Message-ID: <20010419011141.A5798@cpan.org>
+ Branch: perl
+ ! t/lib/h2ph.h t/lib/h2ph.pht utils/h2ph.PL
+ ____________________________________________________________________________
+ [ 9752] By: jhi on 2001/04/19 02:41:10
+ Log: The new time utils need to be thread-aware, too.
+ Branch: perl
+ ! util.c
+ ____________________________________________________________________________
+ [ 9751] By: jhi on 2001/04/19 02:26:47
+ Log: Compilation nit noticed by AIX compiler.
+ Branch: perl
+ ! perlio.c
+ ____________________________________________________________________________
+ [ 9750] By: jhi on 2001/04/19 02:20:06
+ Log: The new time utils need to be public.
+ Branch: perl
+ ! embed.pl
+ ____________________________________________________________________________
+ [ 9749] By: jhi on 2001/04/19 01:42:39
+ Log: Regen toc.
+ Branch: perl
+ ! pod/perltoc.pod
+ ____________________________________________________________________________
+ [ 9748] By: jhi on 2001/04/19 01:41:10
+ Log: Add Time::Piece, a slight rewrite of Time::Object,
+ from Matt Sergeant.
+ Branch: perl
+ + ext/Time/Piece/Makefile.PL ext/Time/Piece/Piece.pm
+ + ext/Time/Piece/Piece.xs ext/Time/Piece/README
+ + ext/Time/Piece/Seconds.pm t/lib/time-piece.t
+ ! MANIFEST configure.com djgpp/config.over epoc/config.sh
+ ! hints/uts.sh hints/uwin.sh hints/vmesa.sh win32/Makefile
+ ! win32/makefile.mk
+ ____________________________________________________________________________
+ [ 9747] By: jhi on 2001/04/19 00:55:35
+ Log: The new metaconfig unit from strftime.
+ Branch: metaconfig/U/perl
+ + d_strftime.U
+ ____________________________________________________________________________
+ [ 9746] By: jhi on 2001/04/19 00:54:54
+ Log: Move the strftime() wrapper from POSIX.xs to util.c
+ as my_strftime(), requires HAS_STRFTIME.
+ Branch: perl
+ ! Configure Porting/Glossary Porting/config.sh Porting/config_H
+ ! config_h.SH configure.com embed.h embed.pl epoc/config.sh
+ ! ext/POSIX/POSIX.xs proto.h uconfig.h uconfig.sh util.c
+ ! vos/config.alpha.def vos/config.alpha.h vos/config.ga.def
+ ! vos/config.ga.h win32/config.bc win32/config.gc
+ ! win32/config.vc
+ ____________________________________________________________________________
+ [ 9745] By: jhi on 2001/04/18 23:11:03
+ Log: Move the init_tm() and mini_mktime() up from POSIX.xs to util.c
+ in preparation of Time::Piece.
+ Branch: perl
+ ! embed.h embed.pl ext/POSIX/POSIX.xs proto.h util.c
+ ____________________________________________________________________________
+ [ 9744] By: jhi on 2001/04/18 22:33:12
+ Log: Subject: [PATCH: perl@9718] fix new exporter test to work OK on VMS
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Wed, 18 Apr 2001 15:38:28 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10104181536440.272477-100000@aspara.forte.com>
+ Branch: perl
+ ! t/lib/exporter.t
+ ____________________________________________________________________________
+ [ 9743] By: jhi on 2001/04/18 22:32:23
+ Log: Subject: Fwd: pod2html leaves cache files lying around?
+ From: Rajesh Vaidheeswarran <rv@gnu.org>
+ Date: Tue, 17 Apr 2001 09:35:00 -0400 (EDT)
+ Message-Id: <E14pVdE-0004P0-00@fencepost.gnu.org>
+ Branch: perl
+ ! lib/Pod/Html.pm
+ ____________________________________________________________________________
+ [ 9742] By: jhi on 2001/04/18 20:31:49
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 9741] By: jhi on 2001/04/18 20:23:02
+ Log: Declare hints only if needed.
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9740] By: jhi on 2001/04/18 19:06:05
+ Log: Workaround for the "\x{12345678}" plus s/(.)/$1/g plus ord/length
+ bug noticed by Robin Houston; basically the code of detecting
+ value wraparound was acting differently under different compilers
+ and platforms. The workaround is to remove the overflow check
+ for now, a real fix would be to do the overflow (portably) right.
+ Branch: perl
+ ! t/op/pat.t utf8.c
+ ____________________________________________________________________________
+ [ 9739] By: jhi on 2001/04/18 19:01:23
+ Log: Subject: [PATCH B::Deparse] some pragma support
+ From: Robin Houston <robin@kitsite.com>
+ Date: Wed, 18 Apr 2001 19:32:12 +0100
+ Message-ID: <20010418193212.A9184@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9738] By: jhi on 2001/04/18 15:16:37
+ Log: Subject: [PATCH] Test case for C<undef %File::Glob::>
+ From: Benjamin Sugars <bsugars@canoe.ca>
+ Date: Wed, 18 Apr 2001 10:53:44 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0104181047010.2368-100000@marmot.rim.canoe.ca>
+ Branch: perl
+ ! t/op/glob.t
+ ____________________________________________________________________________
+ [ 9737] By: jhi on 2001/04/18 13:24:50
+ Log: Subject: [PATCH] XS::Typemap - T_OPAQUE
+ From: Tim Jenness <t.jenness@jach.hawaii.edu>
+ Date: Tue, 17 Apr 2001 22:49:25 -1000 (HST)
+ Message-ID: <Pine.LNX.4.30.0104172247440.28672-100000@lapaki.jach.hawaii.edu>
+ Branch: perl
+ ! ext/XS/Typemap/Typemap.pm ext/XS/Typemap/Typemap.xs
+ ! ext/XS/Typemap/typemap lib/ExtUtils/typemap t/lib/xs-typemap.t
+ ____________________________________________________________________________
+ [ 9736] By: jhi on 2001/04/18 04:15:14
+ Log: The #9735 also changes the subtest 12.
+ Branch: perl
+ ! t/lib/b.t
+ ____________________________________________________________________________
+ [ 9735] By: jhi on 2001/04/18 03:55:17
+ Log: Subject: Deparse.pm of split(" ") decodes as /\s+/ (with PATCH)
+ From: David Dyck <dcd@tc.fluke.com>
+ Date: Tue, 17 Apr 2001 17:12:58 -0700 (PDT)
+ Message-ID: <Pine.LNX.4.33.0104171508210.23062-100000@dd.tc.fluke.com>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9734] By: jhi on 2001/04/18 03:54:11
+ Log: Subject: [PATCH] foreach defelem magic should only be applied to PL_sv_undef
+ From: Gisle Aas <gisle@ActiveState.com>
+ Date: 17 Apr 2001 19:06:45 -0700
+ Message-ID: <lrae5f9d1m.fsf@caliper.ActiveState.com>
+ Branch: perl
+ ! pp_hot.c t/op/misc.t
+ ____________________________________________________________________________
+ [ 9733] By: jhi on 2001/04/17 22:25:22
+ Log: Subject: [PATCH: ext/Cwd/Cwd.xs & ext/PerlIO/Scalar/Scalar.xs] Missing prototype behaviour
+ From: "Abigail" <abigail@foad.org>
+ Date: Wed, 18 Apr 2001 01:17:46 +0200
+ Message-ID: <20010417231746.21657.qmail@foad.org>
+ Branch: perl
+ ! ext/Cwd/Cwd.xs ext/PerlIO/Scalar/Scalar.xs
+ ____________________________________________________________________________
+ [ 9732] By: jhi on 2001/04/17 20:47:56
+ Log: Subject: Re: Deparse - parenthesise args to undeclared subs
+ From: Robin Houston <robin@kitsite.com>
+ Date: Tue, 17 Apr 2001 22:37:42 +0100
+ Message-ID: <20010417223742.A6681@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9731] By: nick on 2001/04/17 20:46:35
+ Log: Re-sync for t/lib/b.t fix
+ Branch: perlio
+ !> ext/B/B/Deparse.pm t/lib/b.t t/lib/cwd.t
+ ____________________________________________________________________________
+ [ 9730] By: jhi on 2001/04/17 20:45:29
+ Log: Subject: [PATCH B::Deparse] utf8 literal strings (and possibly a unicode/regex bug)
+ From: Robin Houston <robin@kitsite.com>
+ Date: Tue, 17 Apr 2001 22:29:36 +0100
+ Message-ID: <20010417222936.A6644@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B.xs ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9729] By: jhi on 2001/04/17 20:43:11
+ Log: Subject: Deparse - parenthesise args to undeclared subs
+ From: Robin Houston <robin@kitsite.com>
+ Date: Tue, 17 Apr 2001 21:31:05 +0100
+ Message-ID: <20010417213104.A6586@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+ ____________________________________________________________________________
+ [ 9728] By: jhi on 2001/04/17 18:57:30
+ Log: Subject: Re: [PATCH] Fix cwd.t when libpth contains symlinks
+ From: Benjamin Sugars <ben.sugars@home.com>
+ Date: Tue, 17 Apr 2001 15:27:28 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0104171516090.22410-100000@localhost.localdomain>
+ Branch: perl
+ ! t/lib/cwd.t
+ ____________________________________________________________________________
+ [ 9727] By: jhi on 2001/04/17 18:20:20
+ Log: Subject: [PATCH B::Deparse] ambient pragmas
+ From: Robin Houston <robin@kitsite.com>
+ Date: Tue, 17 Apr 2001 20:01:59 +0100
+ Message-ID: <20010417200159.A4882@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B/Deparse.pm t/lib/b.t
+ ____________________________________________________________________________
+ [ 9726] By: nick on 2001/04/17 16:33:51
+ Log: Integrate mainline (t/lib/b.t fails test 2...)
+ Branch: perlio
+ +> ext/List/Util/ChangeLog ext/List/Util/Makefile.PL
+ +> ext/List/Util/README ext/List/Util/Util.xs
+ +> ext/List/Util/lib/List/Util.pm
+ +> ext/List/Util/lib/Scalar/Util.pm t/lib/exporter.t
+ +> t/lib/u-blessed.t t/lib/u-dualvar.t t/lib/u-first.t
+ +> t/lib/u-max.t t/lib/u-maxstr.t t/lib/u-min.t t/lib/u-minstr.t
+ +> t/lib/u-readonly.t t/lib/u-reduce.t t/lib/u-reftype.t
+ +> t/lib/u-sum.t t/lib/u-tainted.t t/lib/u-weak.t
+ !> (integrate 31 files)
+ ____________________________________________________________________________
+ [ 9725] By: jhi on 2001/04/17 12:14:24
+ Log: Subject: multiple B::* changes
+ From: Robin Houston <robin@kitsite.com>
+ Date: Thu, 12 Apr 2001 20:12:27 +0100
+ Message-ID: <20010412201226.A30940@puffinry.freeserve.co.uk>
+ Branch: perl
+ ! ext/B/B.pm ext/B/B/Concise.pm ext/B/B/Deparse.pm ext/B/O.pm
+ ____________________________________________________________________________
+ [ 9724] By: jhi on 2001/04/17 11:59:05
+ Log: Thread-awareness from Doug MacEachern.
+ Branch: perl
+ ! ext/List/Util/Util.xs
+ ____________________________________________________________________________
+ [ 9723] By: jhi on 2001/04/17 11:57:41
+ Log: Make the test more portable.
+ Branch: perl
+ ! t/lib/cwd.t
+ ____________________________________________________________________________
+ [ 9722] By: jhi on 2001/04/17 11:53:50
+ Log: Subject: [PATCH] Fix cwd.t when libpth contains symlinks
+ From: Benjamin Sugars <ben.sugars@home.com>
+ Date: Mon, 16 Apr 2001 22:43:29 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0104162234030.17949-100000@localhost.localdomain>
+ Branch: perl
+ ! t/lib/cwd.t
+ ____________________________________________________________________________
+ [ 9721] By: jhi on 2001/04/17 11:52:17
+ Log: Subject: [PATCH] Fix core dump from undef %File::Glob::
+ From: Benjamin Sugars <bsugars@canoe.ca>
+ Date: Mon, 16 Apr 2001 13:23:59 -0400 (EDT)
+ Message-ID: <Pine.LNX.4.21.0104161313160.1676-100000@marmot.rim.canoe.ca>
+ Branch: perl
+ ! op.c
+ ____________________________________________________________________________
+ [ 9720] By: jhi on 2001/04/17 11:35:42
+ Log: Subject: [MacPerl-Porters] [PATCH] bsd_glob.c, gv.c fixes for Mac OS
+ From: Chris Nandor <pudge@pobox.com>
+ Date: Tue, 17 Apr 2001 00:30:49 -0400
+ Message-Id: <p05100207b701768712de@[10.0.1.177]>
+ Branch: perl
+ ! ext/File/Glob/bsd_glob.c gv.c
+ ____________________________________________________________________________
+ [ 9719] By: jhi on 2001/04/17 11:32:13
+ Log: Subject: [PATCH] Tweten->West
+ From: Casey West <casey@geeknest.com>
+ Date: Mon, 16 Apr 2001 12:11:22 -0400
+ Message-ID: <20010416121122.B14554@stupid.geeknest.com>
+ Branch: perl
+ ! AUTHORS lib/Class/Struct.pm lib/Shell.pm lib/constant.pm
+ ! pod/perltie.pod
+ ____________________________________________________________________________
+ [ 9718] By: jhi on 2001/04/16 03:22:52
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 9717] By: jhi on 2001/04/16 03:06:28
+ Log: Regen toc.
+ Branch: perl
+ ! pod/perltoc.pod
+ ____________________________________________________________________________
+ [ 9716] By: jhi on 2001/04/16 02:58:42
+ Log: Subject: [PATCH: perl@9699] updates to apidoc in utf8.c
+ From: Prymmer/Kahn <pvhp@best.com>
+ Date: Sun, 15 Apr 2001 20:47:45 -0700 (PDT)
+ Message-ID: <Pine.BSF.4.21.0104152037470.8946-100000@shell8.ba.best.com>
+ Branch: perl
+ ! utf8.c
+ ____________________________________________________________________________
+ [ 9715] By: jhi on 2001/04/15 23:40:35
+ Log: Subject: Re: Net::Ping patch, adds stream protocol
+ From: bronson@rinspin.com (Scott Bronson)
+ Date: Tue, 10 Apr 2001 23:58:33 -0700
+ Message-ID: <20010410235833.N29719@rinspin.com>
+ Branch: perl
+ ! lib/Net/Ping.pm
+ ____________________________________________________________________________
+ [ 9714] By: jhi on 2001/04/15 23:31:46
+ Log: Printing out the ok messages helps successful testing.
+ Branch: perl
+ ! t/lib/time-hires.t
+ ____________________________________________________________________________
+ [ 9713] By: jhi on 2001/04/15 21:43:24
+ Log: Update Douglas Wegscheid's email.
+ Branch: perl
+ ! AUTHORS
+ ____________________________________________________________________________
+ [ 9712] By: jhi on 2001/04/15 21:40:41
+ Log: Subject: [PATCH t/lib/exporter.t lib/Exporter/Heavy.pm] Testing Exporter
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Sat, 14 Apr 2001 22:40:50 +0100
+ Message-ID: <20010414224050.A1872@blackrider.blackstar.co.uk>
+ Branch: perl
+ + t/lib/exporter.t
+ ! MANIFEST lib/Exporter/Heavy.pm
+ ____________________________________________________________________________
+ [ 9711] By: jhi on 2001/04/15 21:39:21
+ Log: Subject: [PATCH t/op/loopctl.t] Exit via last, part 1
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Sat, 14 Apr 2001 22:13:59 +0100
+ Message-ID: <20010414221359.A413@blackrider.blackstar.co.uk>
+ Branch: perl
+ ! t/op/loopctl.t
+ ____________________________________________________________________________
+ [ 9710] By: jhi on 2001/04/15 21:30:19
+ Log: Subject: [PATCH t/pragma/warnings.t] Doesn't skip RCS files
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Sat, 14 Apr 2001 22:05:32 +0100
+ Message-ID: <20010414220531.A30178@blackrider.blackstar.co.uk>
+ Branch: perl
+ ! t/pragma/warnings.t
+ ____________________________________________________________________________
+ [ 9709] By: jhi on 2001/04/15 19:34:09
+ Log: Integrate changes #9706,9707 from maintperl into mainline.
+
+ change#7210 broke .packlist generation
+
+ ExtUtils::Installed doesn't quote regex metacharacters in paths
+ before using them in match; also make it work for dosish platforms
+ Branch: perl
+ !> lib/ExtUtils/Install.pm lib/ExtUtils/Installed.pm
+ ____________________________________________________________________________
+ [ 9708] By: jhi on 2001/04/15 19:31:01
+ Log: Test also the scalar aspect of getitimer().
+ Branch: perl
+ ! t/lib/time-hires.t
+ ____________________________________________________________________________
+ [ 9707] By: gsar on 2001/04/15 17:24:20
+ Log: ExtUtils::Installed doesn't quote regex metacharacters in paths
+ before using them in match; also make it work for dosish platforms
+ Branch: maint-5.6/perl
+ ! lib/ExtUtils/Installed.pm
+ ____________________________________________________________________________
+ [ 9706] By: gsar on 2001/04/15 17:21:59
+ Log: change#7210 broke .packlist generation (listed only filename
+ rather than fully qualified path name)
+ Branch: maint-5.6/perl
+ ! lib/ExtUtils/Install.pm
+ ____________________________________________________________________________
+ [ 9705] By: jhi on 2001/04/15 12:36:33
+ Log: Add interval timer (setitimer, getitimer) support to Time::HiRes.
+ Branch: perl
+ ! ext/Time/HiRes/HiRes.pm ext/Time/HiRes/HiRes.xs
+ ! t/lib/time-hires.t
+ ____________________________________________________________________________
+ [ 9704] By: jhi on 2001/04/15 10:49:08
+ Log: Subject: [PATCH: perl@9622]update perlebcdic.pod with UTF tbl; tweak utf8.pm
+ From: Prymmer/Kahn <pvhp@best.com>
+ Date: Sat, 14 Apr 2001 21:36:24 -0700 (PDT)
+ Message-ID: <Pine.BSF.4.21.0104142127580.27582-100000@shell8.ba.best.com>
+ Branch: perl
+ ! lib/utf8.pm pod/perlebcdic.pod
+ ____________________________________________________________________________
+ [ 9703] By: jhi on 2001/04/15 02:26:26
+ Log: I keep forgetting to sort MANIFEST.
+ Branch: perl
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 9702] By: jhi on 2001/04/15 02:07:47
+ Log: Add Scalar-List-Utils 1.02, from Graham Barr.
+ Now we have blessed, reftype, tainted, first, reduce, ...
+ Branch: perl
+ + ext/List/Util/ChangeLog ext/List/Util/Makefile.PL
+ + ext/List/Util/README ext/List/Util/Util.xs
+ + ext/List/Util/lib/List/Util.pm
+ + ext/List/Util/lib/Scalar/Util.pm t/lib/u-blessed.t
+ + t/lib/u-dualvar.t t/lib/u-first.t t/lib/u-max.t
+ + t/lib/u-maxstr.t t/lib/u-min.t t/lib/u-minstr.t
+ + t/lib/u-readonly.t t/lib/u-reduce.t t/lib/u-reftype.t
+ + t/lib/u-sum.t t/lib/u-tainted.t t/lib/u-weak.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 9701] By: jhi on 2001/04/14 15:05:25
+ Log: Subject: RE: dprofpp.pl updates
+ From: Carl Eklof <CEklof@endeca.com>
+ Date: Thu, 12 Apr 2001 18:45:46 -0400
+ Message-ID: <D99914D9109BD411823800508BD957180E1269@exch01.ops.endeca.com>
+ Branch: perl
+ ! utils/dprofpp.PL
+ ____________________________________________________________________________
+ [ 9700] By: jhi on 2001/04/14 14:44:55
+ Log: Do not just blindly add CR.
+ Branch: perl
+ ! Porting/makerel
+ ____________________________________________________________________________
+ [ 9699] By: jhi on 2001/04/13 13:17:01
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+ ____________________________________________________________________________
+ [ 9698] By: jhi on 2001/04/13 12:44:48
+ Log: Integrate perlio.
+ Branch: perl
+ !> ext/PerlIO/Scalar/Scalar.xs
+ ____________________________________________________________________________
+ [ 9697] By: jhi on 2001/04/13 12:29:15
+ Log: Add more debug output to the test.
+ Branch: perl
+ ! t/lib/cwd.t
+ ____________________________________________________________________________
+ [ 9696] By: nick on 2001/04/13 10:14:29
+ Log: Fix core dump on binmode($fh,'Scalar')
+ Branch: perlio
+ ! ext/PerlIO/Scalar/Scalar.xs
+ ____________________________________________________________________________
+ [ 9695] By: nick on 2001/04/13 09:05:42
+ Log: Integrate mainline
+ Branch: perlio
+ +> ext/Time/HiRes/Changes ext/Time/HiRes/HiRes.pm
+ +> ext/Time/HiRes/HiRes.xs ext/Time/HiRes/Makefile.PL
+ +> t/lib/time-hires.t
+ !> AUTHORS MANIFEST Makefile.SH Todo-5.6 configure.com
+ !> ext/Digest/MD5/MD5.xs ext/File/Glob/Glob.pm
+ !> ext/File/Glob/Glob.xs ext/File/Glob/bsd_glob.c
+ !> ext/File/Glob/bsd_glob.h ext/MIME/Base64/Base64.xs
+ !> hints/uts.sh hints/vmesa.sh lib/Devel/SelfStubber.pm opcode.pl
+ !> pod/perlfaq5.pod pp.c regexec.c t/comp/proto.t
+ !> t/lib/md5-file.t t/op/pat.t win32/Makefile win32/makefile.mk
+ ____________________________________________________________________________
+ [ 9694] By: jhi on 2001/04/12 22:23:35
+ Log: Integrate change #9693 from maintperl into mainline.
+
+ $VERSION and Version() on the same line provokes a warning from
+ CPAN.pm (from Jonathan Leffler <jleffler@informix.com>)
+ Branch: perl
+ !> lib/Devel/SelfStubber.pm
+ ____________________________________________________________________________
+ [ 9693] By: gsar on 2001/04/12 21:55:56
+ Log: $VERSION and Version() on the same line provokes a warning from
+ CPAN.pm (from Jonathan Leffler <jleffler@informix.com>)
+ Branch: maint-5.6/perl
+ ! lib/Devel/SelfStubber.pm
+ ____________________________________________________________________________
+ [ 9692] By: jhi on 2001/04/12 13:54:00
+ Log: This is at least 5.005.
+ Branch: perl
+ ! ext/Time/HiRes/HiRes.xs
+ ____________________________________________________________________________
+ [ 9691] By: jhi on 2001/04/12 13:37:20
+ Log: Non-UNIX platforms extensions update. (Well, UTS is UNIX.)
+ Branch: perl
+ ! Makefile.SH configure.com hints/uts.sh hints/vmesa.sh
+ ! win32/Makefile win32/makefile.mk
+ ____________________________________________________________________________
+ [ 9690] By: jhi on 2001/04/12 01:34:46
+ Log: Integrate Time::Hires 1.20 from Douglas E. Wegscheid.
+ Branch: perl
+ + ext/Time/HiRes/Changes ext/Time/HiRes/HiRes.pm
+ + ext/Time/HiRes/HiRes.xs ext/Time/HiRes/Makefile.PL
+ + t/lib/time-hires.t
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 9689] By: jhi on 2001/04/12 00:28:39
+ Log: Subject: [PATCH] Digest::MD5 on UTF8 strings
+ From: Gisle Aas <gisle@ActiveState.com>
+ Date: 11 Apr 2001 16:36:11 -0700
+ Message-ID: <lrlmp7102c.fsf@caliper.ActiveState.com>
+ Branch: perl
+ ! ext/Digest/MD5/MD5.xs t/lib/md5-file.t
+ ____________________________________________________________________________
+ [ 9688] By: jhi on 2001/04/12 00:27:39
+ Log: Subject: Re: [PATCH] [ID 20010410.001] Not OK: perl v5.7.1 on i386-freebsd 4.3-rc (UNINSTALLED)
+ From: Gisle Aas <gisle@ActiveState.com>
+ Date: 11 Apr 2001 11:13:24 -0700
+ Message-ID: <lrbsq371a3.fsf@caliper.ActiveState.com>
+ Branch: perl
+ ! ext/MIME/Base64/Base64.xs
+ ____________________________________________________________________________
+ [ 9687] By: jhi on 2001/04/11 19:51:47
+ Log: Slight update on the Todo list. (Should integrate to Todo?)
+ Branch: perl
+ ! Todo-5.6
+ ____________________________________________________________________________
+ [ 9686] By: jhi on 2001/04/11 16:54:25
+ Log: Subject: [PATCH opcode.pl] Documentation of table format
+ From: Simon Cozens <simon@netthink.co.uk>
+ Date: Wed, 11 Apr 2001 12:59:31 +0100
+ Message-ID: <20010411125931.A25681@netthink.co.uk>
+ Branch: perl
+ ! opcode.pl
+ ____________________________________________________________________________
+ [ 9685] By: jhi on 2001/04/11 16:53:15
+ Log: Subject: [PATCH] prototype("CORE::recv")
+ From: Simon Cozens <simon@netthink.co.uk>
+ Date: Wed, 11 Apr 2001 13:24:35 +0100
+ Message-ID: <20010411132435.A26169@netthink.co.uk>
+ Branch: perl
+ ! pp.c t/comp/proto.t
+ ____________________________________________________________________________
+ [ 9684] By: jhi on 2001/04/11 16:47:13
+ Log: FAQ (and AUTHORS) update from Dan Carson: the information
+ was several years obsolete, Term::Readkey has been updated
+ to have the functionality.
+ Branch: perl
+ ! AUTHORS pod/perlfaq5.pod
+ ____________________________________________________________________________
+ [ 9683] By: jhi on 2001/04/11 12:15:46
+ Log: Subject: Re: [PATCH] [ID 20010410.001] Not OK: perl v5.7.1 on i386-freebsd 4.3-rc (UNINSTALLED)
+ From: Calle Dybedahl <calle@lysator.liu.se>
+ Date: 10 Apr 2001 16:44:16 +0200
+ Message-ID: <86d7akbyrj.fsf@tezcatlipoca.algonet.se>
+ Branch: perl
+ ! ext/MIME/Base64/Base64.xs
+ ____________________________________________________________________________
+ [ 9682] By: jhi on 2001/04/11 12:12:26
+ Log: A more minimal fix for 20010410.006 from Hugo.
+ Branch: perl
+ ! regexec.c
+ ____________________________________________________________________________
+ [ 9681] By: jhi on 2001/04/11 11:34:23
+ Log: Integrate changes #9678,9679 from maintline into mainperl.
+
+ addendum to change#9676
+
+ up $File::Glob::VERSION; add a note pointing out the version of
+ the OpenBSD glob bsd_glob.c resembles
+ Branch: perl
+ !> ext/File/Glob/Glob.pm ext/File/Glob/bsd_glob.c
+ !> ext/File/Glob/bsd_glob.h
+ ____________________________________________________________________________
+ [ 9680] By: jhi on 2001/04/11 11:30:38
+ Log: Bad test numbering in integrate in #9677.
+ Fixes ID 20010411.001.
+ Branch: perl
+ ! t/op/pat.t
+ ____________________________________________________________________________
+ [ 9679] By: gsar on 2001/04/11 03:38:40
+ Log: up $File::Glob::VERSION; add a note pointing out the version of
+ the OpenBSD glob bsd_glob.c resembles
+ Branch: maint-5.6/perl
+ ! ext/File/Glob/Glob.pm ext/File/Glob/bsd_glob.c
+ ! ext/File/Glob/bsd_glob.h
+ ____________________________________________________________________________
+ [ 9678] By: gsar on 2001/04/11 03:09:48
+ Log: addendum to change#9676: some missing changes from OpenBSD glob.c
+ revision 1.8.10.1 found here:
+
+ http://www.openbsd.org/cgi-bin/cvsweb/src/lib/libc/gen/glob.c
+ Branch: maint-5.6/perl
+ ! ext/File/Glob/bsd_glob.c
+ ____________________________________________________________________________
+ [ 9677] By: jhi on 2001/04/11 02:54:39
+ Log: Integrate changes #9675,9676 from maintperl into mainline.
+
+ fix for bug 20010410.006, undo change#7115
+
+ port the OpenBSD glob() security patch
+ Branch: perl
+ !> ext/File/Glob/Glob.pm ext/File/Glob/Glob.xs
+ !> ext/File/Glob/bsd_glob.c ext/File/Glob/bsd_glob.h regexec.c
+ !> t/op/pat.t
+ ____________________________________________________________________________
+ [ 9676] By: gsar on 2001/04/11 02:19:02
+ Log: port the glob() security patch found at:
+
+ ftp://ftp.openbsd.org/pub/OpenBSD/patches/2.8/common/025_glob.patch
+
+ CERT advisory for the issue is here:
+
+ http://www.cert.org/advisories/CA-2001-07.html
+
+ Note that the security scare is only relevant for those who are
+ foolish enough to build suidperl (which is now officially discouraged)
+ Branch: maint-5.6/perl
+ ! ext/File/Glob/Glob.pm ext/File/Glob/Glob.xs
+ ! ext/File/Glob/bsd_glob.c ext/File/Glob/bsd_glob.h
+ ____________________________________________________________________________
+ [ 9675] By: gsar on 2001/04/10 23:52:11
+ Log: fix for bug 20010410.006
+
+ undo change#7115 (came into maint-5.6 as change#8156)
+
+ add tests to keep it from coming back
+ Branch: maint-5.6/perl
+ ! regexec.c t/op/pat.t
+ ____________________________________________________________________________
+ [ 9674] By: nick on 2001/04/10 20:39:31
+ Log: Integrate mainline
+ Branch: perlio
+ +> Porting/testall.atom
+ !> MANIFEST t/lib/lc-all.t t/lib/lc-constants.t
+ !> t/lib/lc-country.t t/lib/lc-currency.t t/lib/lc-language.t
+ !> t/lib/lc-uk.t t/pod/find.t
+ ____________________________________________________________________________
+ [ 9673] By: nick on 2001/04/10 18:46:14
+ Log: Integrate against change 9670 aka perl-5.7.1
+ Branch: perlio
+ +> jpl/ChangeLog jpl/README.JUST-JNI jpl/docs/Tutorial.pod
+ !> (integrate 53 files)
+ ____________________________________________________________________________
+ [ 9672] By: jhi on 2001/04/10 13:45:01
+ Log: Add a script for doing cumulative profile of the test suite.
+ (Requires ATOM, that is, Tru64.)
+ Branch: perl
+ + Porting/testall.atom
+ ! MANIFEST
+ ____________________________________________________________________________
+ [ 9671] By: jhi on 2001/04/10 12:38:53
+ Log: Missing std block.
+ Branch: perl
+ ! t/lib/lc-all.t t/lib/lc-constants.t t/lib/lc-country.t
+ ! t/lib/lc-currency.t t/lib/lc-language.t t/lib/lc-uk.t
+ ! t/pod/find.t
+ ____________________________________________________________________________
+ [ 9670] By: jhi on 2001/04/10 01:25:58
+ Log: This is 5.7.1.
+ Branch: perl
+ ! patchlevel.h
+ ____________________________________________________________________________
+ [ 9669] By: jhi on 2001/04/10 01:09:14
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
____________________________________________________________________________
[ 9668] By: jhi on 2001/04/10 01:00:38
Log: Regen toc.
diff -c 'perl-5.7.1/Configure' 'perl-5.7.2/Configure'
Index: ./Configure
Prereq: 3.0.1.9
*** ./Configure Sun Apr 8 02:04:56 2001
--- ./Configure Fri Jul 13 03:14:40 2001
***************
*** 20,26 ****
# $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $
#
! # Generated on Sun Apr 8 02:03:47 EET DST 2001 [metaconfig 3.0 PL70]
# (with additional metaconfig patches by perlbug@perl.org)
cat >c1$$ <<EOF
--- 20,26 ----
# $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $
#
! # Generated on Fri Jul 13 03:14:01 EET DST 2001 [metaconfig 3.0 PL70]
# (with additional metaconfig patches by perlbug@perl.org)
cat >c1$$ <<EOF
***************
*** 165,170 ****
--- 165,175 ----
ccsymbols=''
cppccsymbols=''
cppsymbols=''
+ from=''
+ run=''
+ targetarch=''
+ to=''
+ usecrosscompile=''
perllibs=''
dynamic_ext=''
extensions=''
***************
*** 273,278 ****
--- 278,284 ----
obj_ext=''
path_sep=''
afs=''
+ afsroot=''
alignbytes=''
ansi2knr=''
archlib=''
***************
*** 307,313 ****
cppminus=''
cpprun=''
cppstdin=''
- crosscompile=''
d__fwalk=''
d_access=''
d_accessx=''
--- 313,318 ----
***************
*** 332,337 ****
--- 337,343 ----
full_csh=''
d_cuserid=''
d_dbl_dig=''
+ d_dbminitproto=''
d_difftime=''
d_dlerror=''
d_dlopen=''
***************
*** 347,352 ****
--- 353,359 ----
d_endpent=''
d_endpwent=''
d_endsent=''
+ d_fchdir=''
d_fchmod=''
d_fchown=''
d_fcntl=''
***************
*** 357,362 ****
--- 364,370 ----
d_fgetpos=''
d_flexfnam=''
d_flock=''
+ d_flockproto=''
d_fork=''
d_fpos64_t=''
d_frexpl=''
***************
*** 447,452 ****
--- 455,461 ----
d_mmap=''
mmaptype=''
d_modfl=''
+ d_modfl_pow32_bug=''
d_mprotect=''
d_msg=''
d_msgctl=''
***************
*** 457,462 ****
--- 466,472 ----
d_msync=''
d_munmap=''
d_nice=''
+ d_nl_langinfo=''
d_off64_t=''
d_open3=''
d_fpathconf=''
***************
*** 467,472 ****
--- 477,483 ----
d_portable=''
d_old_pthread_create_joinable=''
old_pthread_create_joinable=''
+ d_pthread_atfork=''
d_pthread_yield=''
d_sched_yield=''
sched_yield=''
***************
*** 529,534 ****
--- 540,546 ----
d_sigprocmask=''
d_sigsetjmp=''
d_sockatmark=''
+ d_sockatmarkproto=''
d_msg_ctrunc=''
d_msg_dontroute=''
d_msg_oob=''
***************
*** 543,548 ****
--- 555,562 ----
d_socklen_t=''
d_socks5_init=''
d_sqrtl=''
+ d_sresgproto=''
+ d_sresuproto=''
d_statblks=''
d_statfs_f_flags=''
d_statfs_s=''
***************
*** 567,572 ****
--- 581,587 ----
d_strerror=''
d_sysernlst=''
d_syserrlst=''
+ d_strftime=''
d_strtod=''
d_strtol=''
d_strtold=''
***************
*** 578,583 ****
--- 593,599 ----
d_strxfrm=''
d_symlink=''
d_syscall=''
+ d_syscallproto=''
d_sysconf=''
d_system=''
d_tcgetpgrp=''
***************
*** 596,601 ****
--- 612,618 ----
d_semctl_semun=''
d_union_semun=''
d_usleep=''
+ d_usleepproto=''
d_ustat=''
d_vfork=''
usevfork=''
***************
*** 634,639 ****
--- 651,659 ----
i_arpainet=''
db_hashtype=''
db_prefixtype=''
+ db_version_major=''
+ db_version_minor=''
+ db_version_patch=''
i_db=''
i_dbm=''
i_rpcsvcdbm=''
***************
*** 650,655 ****
--- 670,676 ----
i_iconv=''
i_ieeefp=''
i_inttypes=''
+ i_langinfo=''
i_libutil=''
i_limits=''
i_locale=''
***************
*** 815,823 ****
--- 836,846 ----
api_version=''
api_versionstring=''
patchlevel=''
+ perl_patchlevel=''
revision=''
subversion=''
version=''
+ version_patchlevel_string=''
perl5=''
perladmin=''
perlpath=''
***************
*** 948,953 ****
--- 971,977 ----
d_oldpthreads=''
use5005threads=''
useithreads=''
+ usereentrant=''
usethreads=''
incpath=''
mips_type=''
***************
*** 1013,1018 ****
--- 1037,1043 ----
inclwanted=''
groupstype=''
+ libnames=''
: change the next line if compiling for Xenix/286 on Xenix/386
xlibpth='/usr/lib/386 /lib/386'
: Possible local library directories to search.
***************
*** 1041,1046 ****
--- 1066,1072 ----
: set usemultiplicity on the Configure command line to enable multiplicity.
: set usesocks on the Configure command line to enable socks.
: set usethreads on the Configure command line to enable threads.
+ usereentrant='undef'
: full support for void wanted by default
defvoidused=15
***************
*** 1105,1121 ****
spitshell=cat
xcat=/bin/cat
test -f $xcat || xcat=/usr/bin/cat
! echo "#!$xcat" >try
! $eunicefix try
! chmod +x try
! ./try > today
if test -s today; then
sharpbang='#!'
else
! echo "#! $xcat" > try
! $eunicefix try
! chmod +x try
! ./try > today
if test -s today; then
sharpbang='#! '
else
--- 1131,1147 ----
spitshell=cat
xcat=/bin/cat
test -f $xcat || xcat=/usr/bin/cat
! echo "#!$xcat" >sharp
! $eunicefix sharp
! chmod +x sharp
! ./sharp > today
if test -s today; then
sharpbang='#!'
else
! echo "#! $xcat" > sharp
! $eunicefix sharp
! chmod +x sharp
! ./sharp > today
if test -s today; then
sharpbang='#! '
else
***************
*** 1135,1141 ****
echo "I presume that if # doesn't work, #! won't work either!"
sharpbang=': use '
fi
! rm -f try today
: figure out how to guarantee sh startup
case "$startsh" in
--- 1161,1167 ----
echo "I presume that if # doesn't work, #! won't work either!"
sharpbang=': use '
fi
! rm -f sharp today
: figure out how to guarantee sh startup
case "$startsh" in
***************
*** 1142,1162 ****
'') startsh=${sharpbang}${sh} ;;
*)
esac
! cat >try <<EOSS
$startsh
set abc
test "$?abc" != 1
EOSS
! chmod +x try
! $eunicefix try
! if ./try; then
: echo "Yup, it does."
else
echo "Hmm... '$startsh' does not guarantee sh startup..."
echo "You may have to fix up the shell scripts to make sure $sh runs them."
fi
! rm -f try
: Save command line options in file UU/cmdline.opt for later use in
--- 1168,1188 ----
'') startsh=${sharpbang}${sh} ;;
*)
esac
! cat >sharp <<EOSS
$startsh
set abc
test "$?abc" != 1
EOSS
! chmod +x sharp
! $eunicefix sharp
! if ./sharp; then
: echo "Yup, it does."
else
echo "Hmm... '$startsh' does not guarantee sh startup..."
echo "You may have to fix up the shell scripts to make sure $sh runs them."
fi
! rm -f sharp
: Save command line options in file UU/cmdline.opt for later use in
***************
*** 1168,1179 ****
--- 1194,1217 ----
config_argc=$#
EOSH
argn=1
+ args_exp=''
+ args_sep=''
for arg in "$@"; do
cat >>cmdline.opt <<EOSH
config_arg$argn='$arg'
EOSH
+ # Extreme backslashitis: replace each ' by '"'"'
+ cat <<EOC | sed -e "s/'/'"'"'"'"'"'"'/g" > cmdl.opt
+ $arg
+ EOC
+ arg_exp=`cat cmdl.opt`
+ args_exp="$args_exp$args_sep'$arg_exp'"
argn=`expr $argn + 1`
+ args_sep=' '
done
+ # args_exp is good for restarting self: eval "set X $args_exp"; shift; $0 "$@"
+ # used by ./hints/os2.sh
+ rm -f cmdl.opt
: produce awk script to parse command line options
cat >options.awk <<'EOF'
***************
*** 1498,1507 ****
: script used to extract .SH files with variable substitutions
cat >extract <<'EOS'
! CONFIGDOTSH=true
echo "Doing variable substitutions on .SH files..."
! if test -f $src/MANIFEST; then
! set x `awk '{print $1}' <$src/MANIFEST | grep '\.SH$'`
else
echo "(Looking for .SH files under the source directory.)"
set x `(cd $src; find . -name "*.SH" -print)`
--- 1536,1545 ----
: script used to extract .SH files with variable substitutions
cat >extract <<'EOS'
! PERL_CONFIG_SH=true
echo "Doing variable substitutions on .SH files..."
! if test -f MANIFEST; then
! set x `awk '{print $1}' < MANIFEST | grep '\.SH$'`
else
echo "(Looking for .SH files under the source directory.)"
set x `(cd $src; find . -name "*.SH" -print)`
***************
*** 1584,1590 ****
echo " "
. UU/extract
rm -rf UU
! echo "Done."
exit 0
;;
esac
--- 1622,1628 ----
echo " "
. UU/extract
rm -rf UU
! echo "Extraction done."
exit 0
;;
esac
***************
*** 1975,1980 ****
--- 2013,2019 ----
loclist="
awk
cat
+ chmod
comm
cp
echo
***************
*** 2141,2147 ****
return 0;
}
EOM
! if $cc -o try $ccflags try.c; then
:
else
echo "Uh-oh, the C compiler '$cc' doesn't seem to be working." >&4
--- 2180,2186 ----
return 0;
}
EOM
! if $cc -o try $ccflags $ldflags try.c; then
:
else
echo "Uh-oh, the C compiler '$cc' doesn't seem to be working." >&4
***************
*** 2288,2293 ****
--- 2327,2576 ----
;;
esac
+
+ case "$usecrosscompile" in
+ $define|true|[yY]*)
+ $echo "Cross-compiling..."
+ croak=''
+ case "$cc" in
+ *-*-gcc) # A cross-compiling gcc, probably.
+ targetarch=`$echo $cc|$sed 's/-gcc$//'`
+ ar=$targetarch-ar
+ # leave out ld, choosing it is more complex
+ nm=$targetarch-nm
+ ranlib=$targetarch-ranlib
+ $echo 'extern int foo;' > try.c
+ set X `$cc -v -E try.c 2>&1 | $awk '/^#include </,/^End of search /'|$grep '/include'`
+ shift
+ if $test $# -gt 0; then
+ incpth="$incpth $*"
+ incpth="`$echo $incpth|$sed 's/^ //'`"
+ echo "Guessing incpth '$incpth'." >&4
+ for i in $*; do
+ j="`$echo $i|$sed 's,/include$,/lib,'`"
+ if $test -d $j; then
+ libpth="$libpth $j"
+ fi
+ done
+ libpth="`$echo $libpth|$sed 's/^ //'`"
+ echo "Guessing libpth '$libpth'." >&4
+ fi
+ $rm -f try.c
+ ;;
+ esac
+ case "$targetarch" in
+ '') echo "Targetarch not defined." >&4; croak=y ;;
+ *) echo "Using targetarch $targetarch." >&4 ;;
+ esac
+ case "$incpth" in
+ '') echo "Incpth not defined." >&4; croak=y ;;
+ *) echo "Using incpth '$incpth'." >&4 ;;
+ esac
+ case "$libpth" in
+ '') echo "Libpth not defined." >&4; croak=y ;;
+ *) echo "Using libpth '$libpth'." >&4 ;;
+ esac
+ case "$usrinc" in
+ '') for i in $incpth; do
+ if $test -f $i/errno.h -a -f $i/stdio.h -a -f $i/time.h; then
+ usrinc=$i
+ echo "Guessing usrinc $usrinc." >&4
+ break
+ fi
+ done
+ case "$usrinc" in
+ '') echo "Usrinc not defined." >&4; croak=y ;;
+ esac
+ ;;
+ *) echo "Using usrinc $usrinc." >&4 ;;
+ esac
+ case "$targethost" in
+ '') echo "Targethost not defined." >&4; croak=y ;;
+ *) echo "Using targethost $targethost." >&4
+ esac
+ locincpth=' '
+ loclibpth=' '
+ case "$croak" in
+ y) echo "Cannot continue, aborting." >&4; exit 1 ;;
+ esac
+ case "$src" in
+ /*) run=$src/Cross/run
+ targetmkdir=$src/Cross/mkdir
+ to=$src/Cross/to
+ from=$src/Cross/from
+ ;;
+ *) pwd=`$test -f ../Configure & cd ..; pwd`
+ run=$pwd/Cross/run
+ targetmkdir=$pwd/Cross/mkdir
+ to=$pwd/Cross/to
+ from=$pwd/Cross/from
+ ;;
+ esac
+ case "$targetrun" in
+ '') targetrun=ssh ;;
+ esac
+ case "$targetto" in
+ '') targetto=scp ;;
+ esac
+ case "$targetfrom" in
+ '') targetfrom=scp ;;
+ esac
+ run=$run-$targetrun
+ to=$to-$targetto
+ from=$from-$targetfrom
+ case "$targetdir" in
+ '') targetdir=/tmp
+ echo "Guessing targetdir $targetdir." >&4
+ ;;
+ esac
+ case "$targetuser" in
+ '') targetuser=root
+ echo "Guessing targetuser $targetuser." >&4
+ ;;
+ esac
+ case "$targetfrom" in
+ scp) q=-q ;;
+ *) q='' ;;
+ esac
+ case "$targetrun" in
+ ssh|rsh)
+ cat >$run <<EOF
+ #!/bin/sh
+ case "\$1" in
+ -cwd)
+ shift
+ cwd=\$1
+ shift
+ ;;
+ esac
+ case "\$cwd" in
+ '') cwd=$targetdir ;;
+ esac
+ exe=\$1
+ shift
+ if $test ! -f \$exe.xok; then
+ $to \$exe
+ $touch \$exe.xok
+ fi
+ $targetrun -l $targetuser $targethost "cd \$cwd && ./\$exe \$@"
+ EOF
+ ;;
+ *) echo "Unknown targetrun '$targetrun'" >&4
+ exit 1
+ ;;
+ esac
+ case "$targetmkdir" in
+ */Cross/mkdir)
+ cat >$targetmkdir <<EOF
+ #!/bin/sh
+ $targetrun -l $targetuser $targethost "mkdir -p \$@"
+ EOF
+ $chmod a+rx $targetmkdir
+ ;;
+ *) echo "Unknown targetmkdir '$targetmkdir'" >&4
+ exit 1
+ ;;
+ esac
+ case "$targetto" in
+ scp|rcp)
+ cat >$to <<EOF
+ #!/bin/sh
+ for f in \$@
+ do
+ case "\$f" in
+ /*)
+ $targetmkdir \`dirname \$f\`
+ $targetto $q \$f $targetuser@$targethost:\$f || exit 1
+ ;;
+ *)
+ $targetmkdir $targetdir/\`dirname \$f\`
+ $targetto $q \$f $targetuser@$targethost:$targetdir/\$f || exit 1
+ ;;
+ esac
+ done
+ exit 0
+ EOF
+ ;;
+ cp) cat >$to <<EOF
+ #!/bin/sh
+ for f in \$@
+ do
+ case "\$f" in
+ /*)
+ $mkdir -p $targetdir/\`dirname \$f\`
+ $cp \$f $targetdir/\$f || exit 1
+ ;;
+ *)
+ $targetmkdir $targetdir/\`dirname \$f\`
+ $cp \$f $targetdir/\$f || exit 1
+ ;;
+ esac
+ done
+ exit 0
+ EOF
+ ;;
+ *) echo "Unknown targetto '$targetto'" >&4
+ exit 1
+ ;;
+ esac
+ case "$targetfrom" in
+ scp|rcp)
+ cat >$from <<EOF
+ #!/bin/sh
+ for f in \$@
+ do
+ $rm -f \$f
+ $targetfrom $q $targetuser@$targethost:$targetdir/\$f . || exit 1
+ done
+ exit 0
+ EOF
+ ;;
+ cp) cat >$from <<EOF
+ #!/bin/sh
+ for f in \$@
+ do
+ $rm -f \$f
+ cp $targetdir/\$f . || exit 1
+ done
+ exit 0
+ EOF
+ ;;
+ *) echo "Unknown targetfrom '$targetfrom'" >&4
+ exit 1
+ ;;
+ esac
+ if $test ! -f $run; then
+ echo "Target 'run' script '$run' not found." >&4
+ else
+ $chmod a+rx $run
+ fi
+ if $test ! -f $to; then
+ echo "Target 'to' script '$to' not found." >&4
+ else
+ $chmod a+rx $to
+ fi
+ if $test ! -f $from; then
+ echo "Target 'from' script '$from' not found." >&4
+ else
+ $chmod a+rx $from
+ fi
+ if $test ! -f $run -o ! -f $to -o ! -f $from; then
+ exit 1
+ fi
+ cat >&4 <<EOF
+ Using '$run' for remote execution,
+ and '$from' and '$to'
+ for remote file transfer.
+ EOF
+ ;;
+ *) run=''
+ to=:
+ from=:
+ usecrosscompile='undef'
+ targetarch=''
+ ;;
+ esac
+
: see whether [:lower:] and [:upper:] are supported character classes
echo " "
case "`echo AbyZ | $tr '[:lower:]' '[:upper:]' 2>/dev/null`" in
***************
*** 2682,2687 ****
--- 2965,2978 ----
fi
fi
+ case "$targetarch" in
+ '') ;;
+ *) hostarch=$osname
+ osname=`echo $targetarch|sed 's,^[^-]*-,,'`
+ osvers=''
+ ;;
+ esac
+
: Now look for a hint file osname_osvers, unless one has been
: specified already.
case "$hintfile" in
***************
*** 2756,2762 ****
elif $test -f $src/hints/$file.sh; then
. $src/hints/$file.sh
$cat $src/hints/$file.sh >> UU/config.sh
! elif $test X$tans = X -o X$tans = Xnone ; then
: nothing
else
: Give one chance to correct a possible typo.
--- 3047,3053 ----
elif $test -f $src/hints/$file.sh; then
. $src/hints/$file.sh
$cat $src/hints/$file.sh >> UU/config.sh
! elif $test X"$tans" = X -o X"$tans" = Xnone ; then
: nothing
else
: Give one chance to correct a possible typo.
***************
*** 3033,3038 ****
--- 3324,3340 ----
set usemultiplicity
eval $setvar
+
+ case "$usemorebits" in
+ "$define"|true|[yY]*)
+ use64bitint="$define"
+ uselongdouble="$define"
+ usemorebits="$define"
+ ;;
+ *) usemorebits="$undef"
+ ;;
+ esac
+
: make some quick guesses about what we are up against
echo " "
$echo $n "Hmm... $c"
***************
*** 3145,3151 ****
echo " "
echo "Checking for GNU cc in disguise and/or its version number..." >&4
! $cat >gccvers.c <<EOM
#include <stdio.h>
int main() {
#ifdef __GNUC__
--- 3447,3453 ----
echo " "
echo "Checking for GNU cc in disguise and/or its version number..." >&4
! $cat >try.c <<EOM
#include <stdio.h>
int main() {
#ifdef __GNUC__
***************
*** 3158,3165 ****
exit(0);
}
EOM
! if $cc -o gccvers $ccflags $ldflags gccvers.c; then
! gccversion=`./gccvers`
case "$gccversion" in
'') echo "You are not using GNU cc." ;;
*) echo "You are using GNU cc $gccversion."
--- 3460,3467 ----
exit(0);
}
EOM
! if $cc -o try $ccflags $ldflags try.c; then
! gccversion=`$run ./try`
case "$gccversion" in
'') echo "You are not using GNU cc." ;;
*) echo "You are using GNU cc $gccversion."
***************
*** 3177,3183 ****
;;
esac
fi
! $rm -f gccvers*
case "$gccversion" in
1*) cpp=`./loc gcc-cpp $cpp $pth` ;;
esac
--- 3479,3485 ----
;;
esac
fi
! $rm -f try try.*
case "$gccversion" in
1*) cpp=`./loc gcc-cpp $cpp $pth` ;;
esac
***************
*** 3216,3369 ****
'') ccname="$cc" ;;
esac
! : see how we invoke the C preprocessor
! echo " "
! echo "Now, how can we feed standard input to your C preprocessor..." >&4
! cat <<'EOT' >testcpp.c
! #define ABC abc
! #define XYZ xyz
! ABC.XYZ
! EOT
! cd ..
! if test ! -f cppstdin; then
! if test "X$osname" = "Xaix" -a "X$gccversion" = X; then
! # AIX cc -E doesn't show the absolute headerfile
! # locations but we'll cheat by using the -M flag.
! echo 'cat >.$$.c; rm -f .$$.u; '"$cc"' ${1+"$@"} -M -c .$$.c 2>/dev/null; test -s .$$.u && awk '"'"'$2 ~ /\.h$/ { print "# 0 \""$2"\"" }'"'"' .$$.u; rm -f .$$.o .$$.u; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' > cppstdin
! else
! echo 'cat >.$$.c; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' >cppstdin
! fi
! else
! echo "Keeping your $hint cppstdin wrapper."
! fi
! chmod 755 cppstdin
! wrapper=`pwd`/cppstdin
! ok='false'
! cd UU
!
! if $test "X$cppstdin" != "X" && \
! $cppstdin $cppminus <testcpp.c >testcpp.out 2>&1 && \
! $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1
! then
! echo "You used to use $cppstdin $cppminus so we'll use that again."
! case "$cpprun" in
! '') echo "But let's see if we can live without a wrapper..." ;;
! *)
! if $cpprun $cpplast <testcpp.c >testcpp.out 2>&1 && \
! $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1
! then
! echo "(And we'll use $cpprun $cpplast to preprocess directly.)"
! ok='true'
! else
! echo "(However, $cpprun $cpplast does not work, let's see...)"
! fi
! ;;
! esac
! else
! case "$cppstdin" in
! '') ;;
! *)
! echo "Good old $cppstdin $cppminus does not seem to be of any help..."
! ;;
! esac
! fi
!
! if $ok; then
! : nothing
! elif echo 'Maybe "'"$cc"' -E" will work...'; \
! $cc -E <testcpp.c >testcpp.out 2>&1; \
! $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
! echo "Yup, it does."
! x_cpp="$cc -E"
! x_minus='';
! elif echo 'Nope...maybe "'"$cc"' -E -" will work...'; \
! $cc -E - <testcpp.c >testcpp.out 2>&1; \
! $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
! echo "Yup, it does."
! x_cpp="$cc -E"
! x_minus='-';
! elif echo 'Nope...maybe "'"$cc"' -P" will work...'; \
! $cc -P <testcpp.c >testcpp.out 2>&1; \
! $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
! echo "Yipee, that works!"
! x_cpp="$cc -P"
! x_minus='';
! elif echo 'Nope...maybe "'"$cc"' -P -" will work...'; \
! $cc -P - <testcpp.c >testcpp.out 2>&1; \
! $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
! echo "At long last!"
! x_cpp="$cc -P"
! x_minus='-';
! elif echo 'No such luck, maybe "'$cpp'" will work...'; \
! $cpp <testcpp.c >testcpp.out 2>&1; \
! $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
! echo "It works!"
! x_cpp="$cpp"
! x_minus='';
! elif echo 'Nixed again...maybe "'$cpp' -" will work...'; \
! $cpp - <testcpp.c >testcpp.out 2>&1; \
! $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
! echo "Hooray, it works! I was beginning to wonder."
! x_cpp="$cpp"
! x_minus='-';
! elif echo 'Uh-uh. Time to get fancy. Trying a wrapper...'; \
! $wrapper <testcpp.c >testcpp.out 2>&1; \
! $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
! x_cpp="$wrapper"
! x_minus=''
! echo "Eureka!"
! else
! dflt=''
! rp="No dice. I can't find a C preprocessor. Name one:"
! . ./myread
! x_cpp="$ans"
! x_minus=''
! $x_cpp <testcpp.c >testcpp.out 2>&1
! if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
! echo "OK, that will do." >&4
! else
! echo "Sorry, I can't get that to work. Go find one and rerun Configure." >&4
! exit 1
! fi
! fi
!
! case "$ok" in
! false)
! cppstdin="$x_cpp"
! cppminus="$x_minus"
! cpprun="$x_cpp"
! cpplast="$x_minus"
! set X $x_cpp
! shift
! case "$1" in
! "$cpp")
! echo "Perhaps can we force $cc -E using a wrapper..."
! if $wrapper <testcpp.c >testcpp.out 2>&1; \
! $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1
! then
! echo "Yup, we can."
! cppstdin="$wrapper"
! cppminus='';
! else
! echo "Nope, we'll have to live without it..."
! fi
! ;;
! esac
! case "$cpprun" in
! "$wrapper")
! cpprun=''
! cpplast=''
! ;;
! esac
! ;;
esac
- case "$cppstdin" in
- "$wrapper"|'cppstdin') ;;
- *) $rm -f $wrapper;;
- esac
- $rm -f testcpp.c testcpp.out
-
: decide how portable to be. Allow command line overrides.
case "$d_portable" in
"$undef") ;;
--- 3518,3532 ----
'') ccname="$cc" ;;
esac
! case "$gccversion" in
! '') ;;
! *) case "$ccflags" in
! *-Wall*) ;;
! *) ccflags="$ccflags -Wall" ;;
! esac
! ;;
esac
: decide how portable to be. Allow command line overrides.
case "$d_portable" in
"$undef") ;;
***************
*** 3690,3695 ****
--- 3853,4006 ----
;;
esac
+ : see how we invoke the C preprocessor
+ echo " "
+ echo "Now, how can we feed standard input to your C preprocessor..." >&4
+ cat <<'EOT' >testcpp.c
+ #define ABC abc
+ #define XYZ xyz
+ ABC.XYZ
+ EOT
+ cd ..
+ if test ! -f cppstdin; then
+ if test "X$osname" = "Xaix" -a "X$gccversion" = X; then
+ # AIX cc -E doesn't show the absolute headerfile
+ # locations but we'll cheat by using the -M flag.
+ echo 'cat >.$$.c; rm -f .$$.u; '"$cc"' ${1+"$@"} -M -c .$$.c 2>/dev/null; test -s .$$.u && awk '"'"'$2 ~ /\.h$/ { print "# 0 \""$2"\"" }'"'"' .$$.u; rm -f .$$.o .$$.u; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' > cppstdin
+ else
+ echo 'cat >.$$.c; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' >cppstdin
+ fi
+ else
+ echo "Keeping your $hint cppstdin wrapper."
+ fi
+ chmod 755 cppstdin
+ wrapper=`pwd`/cppstdin
+ ok='false'
+ cd UU
+
+ if $test "X$cppstdin" != "X" && \
+ $cppstdin $cppminus <testcpp.c >testcpp.out 2>&1 && \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1
+ then
+ echo "You used to use $cppstdin $cppminus so we'll use that again."
+ case "$cpprun" in
+ '') echo "But let's see if we can live without a wrapper..." ;;
+ *)
+ if $cpprun $cpplast <testcpp.c >testcpp.out 2>&1 && \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1
+ then
+ echo "(And we'll use $cpprun $cpplast to preprocess directly.)"
+ ok='true'
+ else
+ echo "(However, $cpprun $cpplast does not work, let's see...)"
+ fi
+ ;;
+ esac
+ else
+ case "$cppstdin" in
+ '') ;;
+ *)
+ echo "Good old $cppstdin $cppminus does not seem to be of any help..."
+ ;;
+ esac
+ fi
+
+ if $ok; then
+ : nothing
+ elif echo 'Maybe "'"$cc"' -E" will work...'; \
+ $cc -E <testcpp.c >testcpp.out 2>&1; \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "Yup, it does."
+ x_cpp="$cc -E"
+ x_minus='';
+ elif echo 'Nope...maybe "'"$cc"' -E -" will work...'; \
+ $cc -E - <testcpp.c >testcpp.out 2>&1; \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "Yup, it does."
+ x_cpp="$cc -E"
+ x_minus='-';
+ elif echo 'Nope...maybe "'"$cc"' -P" will work...'; \
+ $cc -P <testcpp.c >testcpp.out 2>&1; \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "Yipee, that works!"
+ x_cpp="$cc -P"
+ x_minus='';
+ elif echo 'Nope...maybe "'"$cc"' -P -" will work...'; \
+ $cc -P - <testcpp.c >testcpp.out 2>&1; \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "At long last!"
+ x_cpp="$cc -P"
+ x_minus='-';
+ elif echo 'No such luck, maybe "'$cpp'" will work...'; \
+ $cpp <testcpp.c >testcpp.out 2>&1; \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "It works!"
+ x_cpp="$cpp"
+ x_minus='';
+ elif echo 'Nixed again...maybe "'$cpp' -" will work...'; \
+ $cpp - <testcpp.c >testcpp.out 2>&1; \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "Hooray, it works! I was beginning to wonder."
+ x_cpp="$cpp"
+ x_minus='-';
+ elif echo 'Uh-uh. Time to get fancy. Trying a wrapper...'; \
+ $wrapper <testcpp.c >testcpp.out 2>&1; \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ x_cpp="$wrapper"
+ x_minus=''
+ echo "Eureka!"
+ else
+ dflt=''
+ rp="No dice. I can't find a C preprocessor. Name one:"
+ . ./myread
+ x_cpp="$ans"
+ x_minus=''
+ $x_cpp <testcpp.c >testcpp.out 2>&1
+ if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "OK, that will do." >&4
+ else
+ echo "Sorry, I can't get that to work. Go find one and rerun Configure." >&4
+ exit 1
+ fi
+ fi
+
+ case "$ok" in
+ false)
+ cppstdin="$x_cpp"
+ cppminus="$x_minus"
+ cpprun="$x_cpp"
+ cpplast="$x_minus"
+ set X $x_cpp
+ shift
+ case "$1" in
+ "$cpp")
+ echo "Perhaps can we force $cc -E using a wrapper..."
+ if $wrapper <testcpp.c >testcpp.out 2>&1; \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1
+ then
+ echo "Yup, we can."
+ cppstdin="$wrapper"
+ cppminus='';
+ else
+ echo "Nope, we'll have to live without it..."
+ fi
+ ;;
+ esac
+ case "$cpprun" in
+ "$wrapper")
+ cpprun=''
+ cpplast=''
+ ;;
+ esac
+ ;;
+ esac
+
+ case "$cppstdin" in
+ "$wrapper"|'cppstdin') ;;
+ *) $rm -f $wrapper;;
+ esac
+ $rm -f testcpp.c testcpp.out
+
: Set private lib path
case "$plibpth" in
'') if ./mips; then
***************
*** 4061,4067 ****
esac
: the following weeds options from ccflags that are of no interest to cpp
! cppflags="$ccflags"
case "$gccversion" in
1*) cppflags="$cppflags -D__GNUC__"
esac
--- 4372,4381 ----
esac
: the following weeds options from ccflags that are of no interest to cpp
! case "$cppflags" in
! '') cppflags="$ccflags" ;;
! *) cppflags="$cppflags $ccflags" ;;
! esac
case "$gccversion" in
1*) cppflags="$cppflags -D__GNUC__"
esac
***************
*** 4184,4190 ****
I used the command:
$*
! ./try
and I got the following output:
--- 4498,4504 ----
I used the command:
$*
! $run ./try
and I got the following output:
***************
*** 4191,4198 ****
EOM
dflt=y
if $sh -c "$cc -o try $optimize $ccflags $ldflags try.c $libs" >>try.msg 2>&1; then
! if $sh -c './try' >>try.msg 2>&1; then
! xxx=`./try`
case "$xxx" in
"Ok") dflt=n ;;
*) echo 'The program compiled OK, but produced no output.' >> try.msg
--- 4505,4512 ----
EOM
dflt=y
if $sh -c "$cc -o try $optimize $ccflags $ldflags try.c $libs" >>try.msg 2>&1; then
! if $sh -c "$run ./try" >>try.msg 2>&1; then
! xxx=`$run ./try`
case "$xxx" in
"Ok") dflt=n ;;
*) echo 'The program compiled OK, but produced no output.' >> try.msg
***************
*** 4242,4303 ****
esac
$rm -f try try.* core
- : define an is-a-typedef? function
- typedef='type=$1; var=$2; def=$3; shift; shift; shift; inclist=$@;
- case "$inclist" in
- "") inclist="sys/types.h";;
- esac;
- eval "varval=\$$var";
- case "$varval" in
- "")
- $rm -f temp.c;
- for inc in $inclist; do
- echo "#include <$inc>" >>temp.c;
- done;
- echo "#ifdef $type" >> temp.c;
- echo "printf(\"We have $type\");" >> temp.c;
- echo "#endif" >> temp.c;
- $cppstdin $cppflags $cppminus < temp.c >temp.E 2>/dev/null;
- if $contains $type temp.E >/dev/null 2>&1; then
- eval "$var=\$type";
- else
- eval "$var=\$def";
- fi;
- $rm -f temp.?;;
- *) eval "$var=\$varval";;
- esac'
-
- : define an is-a-typedef? function that prompts if the type is not available.
- typedef_ask='type=$1; var=$2; def=$3; shift; shift; shift; inclist=$@;
- case "$inclist" in
- "") inclist="sys/types.h";;
- esac;
- eval "varval=\$$var";
- case "$varval" in
- "")
- $rm -f temp.c;
- for inc in $inclist; do
- echo "#include <$inc>" >>temp.c;
- done;
- echo "#ifdef $type" >> temp.c;
- echo "printf(\"We have $type\");" >> temp.c;
- echo "#endif" >> temp.c;
- $cppstdin $cppflags $cppminus < temp.c >temp.E 2>/dev/null;
- echo " " ;
- echo "$rp" | $sed -e "s/What is/Looking for/" -e "s/?/./";
- if $contains $type temp.E >/dev/null 2>&1; then
- echo "$type found." >&4;
- eval "$var=\$type";
- else
- echo "$type NOT found." >&4;
- dflt="$def";
- . ./myread ;
- eval "$var=\$ans";
- fi;
- $rm -f temp.?;;
- *) eval "$var=\$varval";;
- esac'
-
: define a shorthand compile call
compile='
mc_file=$1;
--- 4556,4561 ----
***************
*** 4314,4320 ****
case "$intsize" in
'')
echo "Checking to see how big your integers are..." >&4
! $cat >intsize.c <<'EOCP'
#include <stdio.h>
int main()
{
--- 4572,4578 ----
case "$intsize" in
'')
echo "Checking to see how big your integers are..." >&4
! $cat >try.c <<'EOCP'
#include <stdio.h>
int main()
{
***************
*** 4324,4332 ****
exit(0);
}
EOCP
! set intsize
! if eval $compile_ok && ./intsize > /dev/null; then
! eval `./intsize`
echo "Your integers are $intsize bytes long."
echo "Your long integers are $longsize bytes long."
echo "Your short integers are $shortsize bytes long."
--- 4582,4590 ----
exit(0);
}
EOCP
! set try
! if eval $compile_ok && $run ./try > /dev/null; then
! eval `$run ./try`
echo "Your integers are $intsize bytes long."
echo "Your long integers are $longsize bytes long."
echo "Your short integers are $shortsize bytes long."
***************
*** 4353,4549 ****
fi
;;
esac
! $rm -f intsize intsize.*
- : see what type lseek is declared as in the kernel
- rp="What is the type used for lseek's offset on this system?"
- set off_t lseektype long stdio.h sys/types.h
- eval $typedef_ask
-
- echo " "
- echo "Checking to see how big your file offsets are..." >&4
- $cat >try.c <<EOCP
- #include <sys/types.h>
- #include <stdio.h>
- int main()
- {
- printf("%d\n", (int)sizeof($lseektype));
- return(0);
- }
- EOCP
- set try
- if eval $compile_ok; then
- lseeksize=`./try`
- echo "Your file offsets are $lseeksize bytes long."
- else
- dflt=$longsize
- echo " "
- echo "(I can't seem to compile the test program. Guessing...)"
- rp="What is the size of your file offsets (in bytes)?"
- . ./myread
- lseeksize="$ans"
- fi
- $rm -f try.c try
-
- : see what type file positions are declared as in the library
- rp="What is the type for file position used by fsetpos()?"
- set fpos_t fpostype long stdio.h sys/types.h
- eval $typedef_ask
-
- echo " "
- case "$fpostype" in
- *_t) zzz="$fpostype" ;;
- *) zzz="fpos_t" ;;
- esac
- echo "Checking the size of $zzz..." >&4
- cat > try.c <<EOCP
- #include <sys/types.h>
- #include <stdio.h>
- int main() {
- printf("%d\n", (int)sizeof($fpostype));
- exit(0);
- }
- EOCP
- set try
- if eval $compile_ok; then
- yyy=`./try`
- case "$yyy" in
- '') fpossize=4
- echo "(I can't execute the test program--guessing $fpossize.)" >&4
- ;;
- *) fpossize=$yyy
- echo "Your $zzz is $fpossize bytes long."
- ;;
- esac
- else
- dflt="$longsize"
- echo " " >&4
- echo "(I can't compile the test program. Guessing...)" >&4
- rp="What is the size of your file positions (in bytes)?"
- . ./myread
- fpossize="$ans"
- fi
-
-
-
- # Backward compatibility (uselfs is deprecated).
- case "$uselfs" in
- "$define"|true|[yY]*)
- cat <<EOM >&4
-
- *** Configure -Duselfs is deprecated, using -Duselargefiles instead.
- EOM
- uselargefiles="$define"
- ;;
- esac
-
- case "$lseeksize:$fpossize" in
- 8:8) cat <<EOM
-
- You can have files larger than 2 gigabytes.
- EOM
- val="$define" ;;
- *) case "$uselargefiles" in
- "$undef"|false|[nN]*) dflt='n' ;;
- *) dflt='y' ;;
- esac
- cat <<EOM
-
- Perl can be built to understand large files (files larger than 2 gigabytes)
- on some systems. To do so, Configure can be run with -Duselargefiles.
-
- If this doesn't make any sense to you, just accept the default '$dflt'.
- EOM
- rp='Try to understand large files, if available?'
- . ./myread
- case "$ans" in
- y|Y) val="$define" ;;
- *) val="$undef" ;;
- esac
- ;;
- esac
- set uselargefiles
- eval $setvar
- case "$uselargefiles" in
- "$define")
- : Look for a hint-file generated 'call-back-unit'. If the
- : user has specified that a large files perl is to be built,
- : we may need to set or change some other defaults.
- if $test -f uselargefiles.cbu; then
- echo "Your platform has some specific hints for large file builds, using them..."
- . ./uselargefiles.cbu
- echo " "
- echo "Rechecking to see how big your file offsets are..." >&4
- $cat >try.c <<EOCP
- #include <sys/types.h>
- #include <stdio.h>
- int main()
- {
- printf("%d\n", (int)sizeof($lseektype));
- return(0);
- }
- EOCP
- set try
- if eval $compile_ok; then
- lseeksize=`./try`
- $echo "Your file offsets are now $lseeksize bytes long."
- else
- dflt="$lseeksize"
- echo " "
- echo "(I can't seem to compile the test program. Guessing...)"
- rp="What is the size of your file offsets (in bytes)?"
- . ./myread
- lseeksize="$ans"
- fi
- case "$fpostype" in
- *_t) zzz="$fpostype" ;;
- *) zzz="fpos_t" ;;
- esac
- $echo $n "Rechecking the size of $zzz...$c" >&4
- $cat > try.c <<EOCP
- #include <sys/types.h>
- #include <stdio.h>
- int main() {
- printf("%d\n", (int)sizeof($fpostype));
- exit(0);
- }
- EOCP
- set try
- if eval $compile_ok; then
- yyy=`./try`
- dflt="$lseeksize"
- case "$yyy" in
- '') echo " "
- echo "(I can't execute the test program--guessing $fpossize.)" >&4
- ;;
- *) fpossize=$yyy
- echo " $fpossize bytes." >&4
- ;;
- esac
- else
- dflt="$fpossize"
- echo " "
- echo "(I can't compile the test program. Guessing...)" >&4
- rp="What is the size of your file positions (in bytes)?"
- . ./myread
- fpossize="$ans"
- fi
- $rm -f try.c try
- fi
- ;;
- esac
-
-
- case "$usemorebits" in
- "$define"|true|[yY]*)
- use64bitint="$define"
- uselongdouble="$define"
- usemorebits="$define"
- ;;
- *) usemorebits="$undef"
- ;;
- esac
-
: check for void type
echo " "
echo "Checking to see how well your C compiler groks the void type..." >&4
--- 4611,4618 ----
fi
;;
esac
! $rm -f try try.*
: check for void type
echo " "
echo "Checking to see how well your C compiler groks the void type..." >&4
***************
*** 4656,4662 ****
EOCP
set try
if eval $compile_ok; then
! ptrsize=`./try`
echo "Your pointers are $ptrsize bytes long."
else
dflt='4'
--- 4725,4731 ----
EOCP
set try
if eval $compile_ok; then
! ptrsize=`$run ./try`
echo "Your pointers are $ptrsize bytes long."
else
dflt='4'
***************
*** 4700,4706 ****
EOCP
set try
if eval $compile_ok; then
! longlongsize=`./try$exe_ext`
echo "Your long longs are $longlongsize bytes long."
else
dflt='8'
--- 4769,4775 ----
EOCP
set try
if eval $compile_ok; then
! longlongsize=`$run ./try`
echo "Your long longs are $longlongsize bytes long."
else
dflt='8'
***************
*** 5123,5129 ****
echo " "
echo "Checking for GNU C Library..." >&4
! cat >gnulibc.c <<EOM
#include <stdio.h>
int main()
{
--- 5192,5198 ----
echo " "
echo "Checking for GNU C Library..." >&4
! cat >try.c <<EOM
#include <stdio.h>
int main()
{
***************
*** 5134,5141 ****
#endif
}
EOM
! set gnulibc
! if eval $compile_ok && ./gnulibc; then
val="$define"
echo "You are using the GNU C Library"
else
--- 5203,5210 ----
#endif
}
EOM
! set try
! if eval $compile_ok && $run ./try; then
val="$define"
echo "You are using the GNU C Library"
else
***************
*** 5142,5148 ****
val="$undef"
echo "You are not using the GNU C Library"
fi
! $rm -f gnulibc*
set d_gnulibc
eval $setvar
--- 5211,5217 ----
val="$undef"
echo "You are not using the GNU C Library"
fi
! $rm -f try try.*
set d_gnulibc
eval $setvar
***************
*** 5248,5254 ****
esac
;;
esac
- libnames='';
case "$libs" in
'') ;;
*) for thislib in $libs; do
--- 5317,5322 ----
***************
*** 5510,5516 ****
if $test -f /lib/syscalls.exp; then
echo " "
echo "Also extracting names from /lib/syscalls.exp for good ole AIX..." >&4
! $sed -n 's/^\([^ ]*\)[ ]*syscall[0-9]*$/\1/p' /lib/syscalls.exp >>libc.list
fi
;;
esac
--- 5578,5584 ----
if $test -f /lib/syscalls.exp; then
echo " "
echo "Also extracting names from /lib/syscalls.exp for good ole AIX..." >&4
! $sed -n 's/^\([^ ]*\)[ ]*syscall[0-9]*[ ]*$/\1/p' /lib/syscalls.exp >>libc.list
fi
;;
esac
***************
*** 5655,5661 ****
EOCP
set try
if eval $compile_ok; then
! doublesize=`./try`
echo "Your double is $doublesize bytes long."
else
dflt='8'
--- 5723,5729 ----
EOCP
set try
if eval $compile_ok; then
! doublesize=`$run ./try`
echo "Your double is $doublesize bytes long."
else
dflt='8'
***************
*** 5699,5705 ****
set try
set try
if eval $compile; then
! longdblsize=`./try$exe_ext`
echo "Your long doubles are $longdblsize bytes long."
else
dflt='8'
--- 5767,5773 ----
set try
set try
if eval $compile; then
! longdblsize=`$run ./try`
echo "Your long doubles are $longdblsize bytes long."
else
dflt='8'
***************
*** 5783,5788 ****
--- 5851,5860 ----
archname=''
;;
esac
+ case "$targetarch" in
+ '') ;;
+ *) archname=`echo $targetarch|sed 's,^[^-]*-,,'` ;;
+ esac
myarchname="$tarch"
case "$archname" in
'') dflt="$tarch";;
***************
*** 5909,5920 ****
prefix="$ans"
prefixexp="$ansexp"
: is AFS running?
echo " "
case "$afs" in
$define|true) afs=true ;;
$undef|false) afs=false ;;
! *) if test -d /afs; then
afs=true
else
afs=false
--- 5981,5997 ----
prefix="$ans"
prefixexp="$ansexp"
+ case "$afsroot" in
+ '') afsroot=/afs ;;
+ *) afsroot=$afsroot ;;
+ esac
+
: is AFS running?
echo " "
case "$afs" in
$define|true) afs=true ;;
$undef|false) afs=false ;;
! *) if test -d $afsroot; then
afs=true
else
afs=false
***************
*** 5986,5992 ****
esac;;
esac'
-
: get the patchlevel
echo " "
echo "Getting the current patchlevel..." >&4
--- 6063,6068 ----
***************
*** 5997,6002 ****
--- 6073,6079 ----
api_revision=`awk '/define[ ]+PERL_API_REVISION/ {print $3}' $rsrc/patchlevel.h`
api_version=`awk '/define[ ]+PERL_API_VERSION/ {print $3}' $rsrc/patchlevel.h`
api_subversion=`awk '/define[ ]+PERL_API_SUBVERSION/ {print $3}' $rsrc/patchlevel.h`
+ perl_patchlevel=`grep ',"DEVEL[0-9][0-9]*"' $rsrc/patchlevel.h|sed 's/[^0-9]//g'`
else
revision=0
patchlevel=0
***************
*** 6004,6011 ****
api_revision=0
api_version=0
api_subversion=0
fi
! $echo "(You have $package version $patchlevel subversion $subversion.)"
case "$osname" in
dos|vms)
: XXX Should be a Configure test for double-dots in filenames.
--- 6081,6103 ----
api_revision=0
api_version=0
api_subversion=0
+ perl_patchlevel=0
+ $echo "(You do not have patchlevel.h. Eek.)"
fi
! if $test -r $rsrc/.patch ; then
! if $test "`cat $rsrc/.patch`" -gt "$perl_patchlevel" ; then
! perl_patchlevel=`cat $rsrc/.patch`
! fi
! fi
! : Define a handy string here to avoid duplication in myconfig.SH and configpm.
! version_patchlevel_string="version $patchlevel subversion $subversion"
! case "$perl_patchlevel" in
! 0|'') ;;
! *) version_patchlevel_string="$version_patchlevel_string patch $perl_patchlevel" ;;
! esac
!
! $echo "(You have $package $version_patchlevel_string.)"
!
case "$osname" in
dos|vms)
: XXX Should be a Configure test for double-dots in filenames.
***************
*** 6276,6288 ****
: determine which malloc to compile in
echo " "
case "$usemymalloc" in
! ''|[yY]*|true|$define) dflt='y' ;;
! *) dflt='n' ;;
esac
- case "$ptrsize" in
- 4) ;;
- *) dflt='n' ;;
- esac
rp="Do you wish to attempt to use the malloc that comes with $package?"
. ./myread
usemymalloc="$ans"
--- 6368,6381 ----
: determine which malloc to compile in
echo " "
case "$usemymalloc" in
! [yY]*|true|$define) dflt='y' ;;
! [nN]*|false|$undef) dflt='n' ;;
! *) case "$ptrsize" in
! 4) dflt='y' ;;
! *) dflt='n' ;;
! esac
! ;;
esac
rp="Do you wish to attempt to use the malloc that comes with $package?"
. ./myread
usemymalloc="$ans"
***************
*** 6674,6686 ****
: Find perl5.005 or later.
echo "Looking for a previously installed perl5.005 or later... "
case "$perl5" in
! '') for tdir in `echo "$binexp:$PATH" | $sed "s/$path_sep/ /g"`; do
: Check if this perl is recent and can load a simple module
! if $test -x $tdir/perl && $tdir/perl -Mless -e 'use 5.005;' >/dev/null 2>&1; then
perl5=$tdir/perl
break;
! elif $test -x $tdir/perl5 && $tdir/perl5 -Mless -e 'use 5.005;' >/dev/null 2>&1; then
! perl5=$tdir/perl
break;
fi
done
--- 6767,6779 ----
: Find perl5.005 or later.
echo "Looking for a previously installed perl5.005 or later... "
case "$perl5" in
! '') for tdir in `echo "$binexp$path_sep$PATH" | $sed "s/$path_sep/ /g"`; do
: Check if this perl is recent and can load a simple module
! if $test -x $tdir/perl$exe_ext && $tdir/perl -Mless -e 'use 5.005;' >/dev/null 2>&1; then
perl5=$tdir/perl
break;
! elif $test -x $tdir/perl5$exe_ext && $tdir/perl5 -Mless -e 'use 5.005;' >/dev/null 2>&1; then
! perl5=$tdir/perl5
break;
fi
done
***************
*** 6745,6751 ****
EOPL
chmod +x getverlist
case "$inc_version_list" in
! '') if test -x "$perl5"; then
dflt=`$perl5 getverlist`
else
dflt='none'
--- 6838,6844 ----
EOPL
chmod +x getverlist
case "$inc_version_list" in
! '') if test -x "$perl5$exe_ext"; then
dflt=`$perl5 getverlist`
else
dflt='none'
***************
*** 6752,6758 ****
fi
;;
$undef) dflt='none' ;;
! *) dflt="$inc_version_list" ;;
esac
case "$dflt" in
''|' ') dflt=none ;;
--- 6845,6851 ----
fi
;;
$undef) dflt='none' ;;
! *) eval dflt=\"$inc_version_list\" ;;
esac
case "$dflt" in
''|' ') dflt=none ;;
***************
*** 6939,6945 ****
exit(1); /* fail */
}
EOM
! if $cc $ccflags try.c >/dev/null 2>&1 && ./a.out; then
cat <<EOM
You appear to have ELF support. I'll use $cc to build dynamic libraries.
EOM
--- 7032,7038 ----
exit(1); /* fail */
}
EOM
! if $cc $ccflags $ldflags try.c >/dev/null 2>&1 && $run ./a.out; then
cat <<EOM
You appear to have ELF support. I'll use $cc to build dynamic libraries.
EOM
***************
*** 7938,7943 ****
--- 8031,8270 ----
installsitebin="$sitebinexp"
fi
+ : define an is-a-typedef? function
+ typedef='type=$1; var=$2; def=$3; shift; shift; shift; inclist=$@;
+ case "$inclist" in
+ "") inclist="sys/types.h";;
+ esac;
+ eval "varval=\$$var";
+ case "$varval" in
+ "")
+ $rm -f temp.c;
+ for inc in $inclist; do
+ echo "#include <$inc>" >>temp.c;
+ done;
+ echo "#ifdef $type" >> temp.c;
+ echo "printf(\"We have $type\");" >> temp.c;
+ echo "#endif" >> temp.c;
+ $cppstdin $cppflags $cppminus < temp.c >temp.E 2>/dev/null;
+ if $contains $type temp.E >/dev/null 2>&1; then
+ eval "$var=\$type";
+ else
+ eval "$var=\$def";
+ fi;
+ $rm -f temp.?;;
+ *) eval "$var=\$varval";;
+ esac'
+
+ : define an is-a-typedef? function that prompts if the type is not available.
+ typedef_ask='type=$1; var=$2; def=$3; shift; shift; shift; inclist=$@;
+ case "$inclist" in
+ "") inclist="sys/types.h";;
+ esac;
+ eval "varval=\$$var";
+ case "$varval" in
+ "")
+ $rm -f temp.c;
+ for inc in $inclist; do
+ echo "#include <$inc>" >>temp.c;
+ done;
+ echo "#ifdef $type" >> temp.c;
+ echo "printf(\"We have $type\");" >> temp.c;
+ echo "#endif" >> temp.c;
+ $cppstdin $cppflags $cppminus < temp.c >temp.E 2>/dev/null;
+ echo " " ;
+ echo "$rp" | $sed -e "s/What is/Looking for/" -e "s/?/./";
+ if $contains $type temp.E >/dev/null 2>&1; then
+ echo "$type found." >&4;
+ eval "$var=\$type";
+ else
+ echo "$type NOT found." >&4;
+ dflt="$def";
+ . ./myread ;
+ eval "$var=\$ans";
+ fi;
+ $rm -f temp.?;;
+ *) eval "$var=\$varval";;
+ esac'
+
+ : see what type lseek is declared as in the kernel
+ rp="What is the type used for lseek's offset on this system?"
+ set off_t lseektype long stdio.h sys/types.h
+ eval $typedef_ask
+
+ echo " "
+ echo "Checking to see how big your file offsets are..." >&4
+ $cat >try.c <<EOCP
+ #include <sys/types.h>
+ #include <stdio.h>
+ int main()
+ {
+ printf("%d\n", (int)sizeof($lseektype));
+ return(0);
+ }
+ EOCP
+ set try
+ if eval $compile_ok; then
+ lseeksize=`$run ./try`
+ echo "Your file offsets are $lseeksize bytes long."
+ else
+ dflt=$longsize
+ echo " "
+ echo "(I can't seem to compile the test program. Guessing...)"
+ rp="What is the size of your file offsets (in bytes)?"
+ . ./myread
+ lseeksize="$ans"
+ fi
+ $rm -f try.c try
+
+ : see what type file positions are declared as in the library
+ rp="What is the type for file position used by fsetpos()?"
+ set fpos_t fpostype long stdio.h sys/types.h
+ eval $typedef_ask
+
+ echo " "
+ case "$fpostype" in
+ *_t) zzz="$fpostype" ;;
+ *) zzz="fpos_t" ;;
+ esac
+ echo "Checking the size of $zzz..." >&4
+ cat > try.c <<EOCP
+ #include <sys/types.h>
+ #include <stdio.h>
+ int main() {
+ printf("%d\n", (int)sizeof($fpostype));
+ exit(0);
+ }
+ EOCP
+ set try
+ if eval $compile_ok; then
+ yyy=`$run ./try`
+ case "$yyy" in
+ '') fpossize=4
+ echo "(I can't execute the test program--guessing $fpossize.)" >&4
+ ;;
+ *) fpossize=$yyy
+ echo "Your $zzz is $fpossize bytes long."
+ ;;
+ esac
+ else
+ dflt="$longsize"
+ echo " " >&4
+ echo "(I can't compile the test program. Guessing...)" >&4
+ rp="What is the size of your file positions (in bytes)?"
+ . ./myread
+ fpossize="$ans"
+ fi
+
+
+
+ # Backward compatibility (uselfs is deprecated).
+ case "$uselfs" in
+ "$define"|true|[yY]*)
+ cat <<EOM >&4
+
+ *** Configure -Duselfs is deprecated, using -Duselargefiles instead.
+ EOM
+ uselargefiles="$define"
+ ;;
+ esac
+
+ case "$lseeksize:$fpossize" in
+ 8:8) cat <<EOM
+
+ You can have files larger than 2 gigabytes.
+ EOM
+ val="$define" ;;
+ *) case "$uselargefiles" in
+ "$undef"|false|[nN]*) dflt='n' ;;
+ *) dflt='y' ;;
+ esac
+ cat <<EOM
+
+ Perl can be built to understand large files (files larger than 2 gigabytes)
+ on some systems. To do so, Configure can be run with -Duselargefiles.
+
+ If this doesn't make any sense to you, just accept the default '$dflt'.
+ EOM
+ rp='Try to understand large files, if available?'
+ . ./myread
+ case "$ans" in
+ y|Y) val="$define" ;;
+ *) val="$undef" ;;
+ esac
+ ;;
+ esac
+ set uselargefiles
+ eval $setvar
+ case "$uselargefiles" in
+ "$define")
+ : Look for a hint-file generated 'call-back-unit'. If the
+ : user has specified that a large files perl is to be built,
+ : we may need to set or change some other defaults.
+ if $test -f uselargefiles.cbu; then
+ echo "Your platform has some specific hints for large file builds, using them..."
+ . ./uselargefiles.cbu
+ echo " "
+ echo "Rechecking to see how big your file offsets are..." >&4
+ $cat >try.c <<EOCP
+ #include <sys/types.h>
+ #include <stdio.h>
+ int main()
+ {
+ printf("%d\n", (int)sizeof($lseektype));
+ return(0);
+ }
+ EOCP
+ set try
+ if eval $compile_ok; then
+ lseeksize=`$run ./try`
+ $echo "Your file offsets are now $lseeksize bytes long."
+ else
+ dflt="$lseeksize"
+ echo " "
+ echo "(I can't seem to compile the test program. Guessing...)"
+ rp="What is the size of your file offsets (in bytes)?"
+ . ./myread
+ lseeksize="$ans"
+ fi
+ case "$fpostype" in
+ *_t) zzz="$fpostype" ;;
+ *) zzz="fpos_t" ;;
+ esac
+ $echo $n "Rechecking the size of $zzz...$c" >&4
+ $cat > try.c <<EOCP
+ #include <sys/types.h>
+ #include <stdio.h>
+ int main() {
+ printf("%d\n", (int)sizeof($fpostype));
+ exit(0);
+ }
+ EOCP
+ set try
+ if eval $compile_ok; then
+ yyy=`$run ./try`
+ dflt="$lseeksize"
+ case "$yyy" in
+ '') echo " "
+ echo "(I can't execute the test program--guessing $fpossize.)" >&4
+ ;;
+ *) fpossize=$yyy
+ echo " $fpossize bytes." >&4
+ ;;
+ esac
+ else
+ dflt="$fpossize"
+ echo " "
+ echo "(I can't compile the test program. Guessing...)" >&4
+ rp="What is the size of your file positions (in bytes)?"
+ . ./myread
+ fpossize="$ans"
+ fi
+ $rm -f try.c try
+ fi
+ ;;
+ esac
+
case "$vendorprefix" in
'') d_vendorbin="$undef"
vendorbin=''
***************
*** 7984,7990 ****
EOCP
set try
if eval $compile; then
! yyy=`./try$exe_ext`
case "$yyy" in
123.456)
sPRIfldbl='"f"'; sPRIgldbl='"g"'; sPRIeldbl='"e"';
--- 8311,8317 ----
EOCP
set try
if eval $compile; then
! yyy=`$run ./try`
case "$yyy" in
123.456)
sPRIfldbl='"f"'; sPRIgldbl='"g"'; sPRIeldbl='"e"';
***************
*** 8001,8017 ****
#include <stdio.h>
int main() {
long double d = 123.456;
! printf("%.3llf\n", d);
}
EOCP
set try
if eval $compile; then
! yyy=`./try$exe_ext`
case "$yyy" in
123.456)
! sPRIfldbl='"llf"'; sPRIgldbl='"llg"'; sPRIeldbl='"lle"';
! sPRIFUldbl='"llF"'; sPRIGUldbl='"llG"'; sPRIEUldbl='"llE"';
! echo "We will use %llf."
;;
esac
fi
--- 8328,8344 ----
#include <stdio.h>
int main() {
long double d = 123.456;
! printf("%.3Lf\n", d);
}
EOCP
set try
if eval $compile; then
! yyy=`$run ./try`
case "$yyy" in
123.456)
! sPRIfldbl='"Lf"'; sPRIgldbl='"Lg"'; sPRIeldbl='"Le"';
! sPRIFUldbl='"LF"'; sPRIGUldbl='"LG"'; sPRIEUldbl='"LE"';
! echo "We will use %Lf."
;;
esac
fi
***************
*** 8023,8039 ****
#include <stdio.h>
int main() {
long double d = 123.456;
! printf("%.3Lf\n", d);
}
EOCP
set try
if eval $compile; then
! yyy=`./try$exe_ext`
case "$yyy" in
123.456)
! sPRIfldbl='"Lf"'; sPRIgldbl='"Lg"'; sPRIeldbl='"Le"';
! sPRIFUldbl='"LF"'; sPRIGUldbl='"LG"'; sPRIEUldbl='"LE"';
! echo "We will use %Lf."
;;
esac
fi
--- 8350,8366 ----
#include <stdio.h>
int main() {
long double d = 123.456;
! printf("%.3llf\n", d);
}
EOCP
set try
if eval $compile; then
! yyy=`$run ./try`
case "$yyy" in
123.456)
! sPRIfldbl='"llf"'; sPRIgldbl='"llg"'; sPRIeldbl='"lle"';
! sPRIFUldbl='"llF"'; sPRIGUldbl='"llG"'; sPRIEUldbl='"llE"';
! echo "We will use %llf."
;;
esac
fi
***************
*** 8050,8056 ****
EOCP
set try
if eval $compile; then
! yyy=`./try$exe_ext`
case "$yyy" in
123.456)
sPRIfldbl='"lf"'; sPRIgldbl='"lg"'; sPRIeldbl='"le"';
--- 8377,8383 ----
EOCP
set try
if eval $compile; then
! yyy=`$run ./try`
case "$yyy" in
123.456)
sPRIfldbl='"lf"'; sPRIgldbl='"lg"'; sPRIeldbl='"le"';
***************
*** 8193,8198 ****
--- 8520,8532 ----
Gconvert((DOUBLETYPE)123.456, 8, 0, buf);
checkit("123.456", buf);
+ /* Testing of 1e+129 in bigintpm.t must not get extra '.' here. */
+ Gconvert((DOUBLETYPE)1e30, 8, 0, buf);
+ if (strlen(buf) > 5)
+ checkit("1e+030", buf); /* for Microsoft */
+ else
+ checkit("1e+30", buf);
+
exit(0);
}
EOP
***************
*** 8220,8226 ****
set try -DTRY_$xxx_convert
if eval $compile; then
echo "$xxx_convert() found." >&4
! if ./try; then
echo "I'll use $xxx_convert to convert floats into a string." >&4
break;
else
--- 8554,8560 ----
set try -DTRY_$xxx_convert
if eval $compile; then
echo "$xxx_convert() found." >&4
! if $run ./try; then
echo "I'll use $xxx_convert to convert floats into a string." >&4
break;
else
***************
*** 8354,8360 ****
"$define")
echo " "
echo "Checking to see which flavor of getpgrp is in use..."
! $cat >set.c <<EOP
#$i_unistd I_UNISTD
#include <sys/types.h>
#ifdef I_UNISTD
--- 8688,8694 ----
"$define")
echo " "
echo "Checking to see which flavor of getpgrp is in use..."
! $cat >try.c <<EOP
#$i_unistd I_UNISTD
#include <sys/types.h>
#ifdef I_UNISTD
***************
*** 8376,8385 ****
exit(1);
}
EOP
! if $cc -o set -DTRY_BSD_PGRP $ccflags $ldflags set.c $libs >/dev/null 2>&1 && ./set; then
echo "You have to use getpgrp(pid) instead of getpgrp()." >&4
val="$define"
! elif $cc -o set $ccflags $ldflags set.c $libs >/dev/null 2>&1 && ./set; then
echo "You have to use getpgrp() instead of getpgrp(pid)." >&4
val="$undef"
else
--- 8710,8719 ----
exit(1);
}
EOP
! if $cc -o try -DTRY_BSD_PGRP $ccflags $ldflags try.c $libs >/dev/null 2>&1 && $run ./try; then
echo "You have to use getpgrp(pid) instead of getpgrp()." >&4
val="$define"
! elif $cc -o try $ccflags $ldflags try.c $libs >/dev/null 2>&1 && $run ./try; then
echo "You have to use getpgrp() instead of getpgrp(pid)." >&4
val="$undef"
else
***************
*** 8406,8412 ****
esac
set d_bsdgetpgrp
eval $setvar
! $rm -f set set.c
: see if setpgrp exists
set setpgrp d_setpgrp
--- 8740,8746 ----
esac
set d_bsdgetpgrp
eval $setvar
! $rm -f try try.*
: see if setpgrp exists
set setpgrp d_setpgrp
***************
*** 8416,8422 ****
"$define")
echo " "
echo "Checking to see which flavor of setpgrp is in use..."
! $cat >set.c <<EOP
#$i_unistd I_UNISTD
#include <sys/types.h>
#ifdef I_UNISTD
--- 8750,8756 ----
"$define")
echo " "
echo "Checking to see which flavor of setpgrp is in use..."
! $cat >try.c <<EOP
#$i_unistd I_UNISTD
#include <sys/types.h>
#ifdef I_UNISTD
***************
*** 8438,8447 ****
exit(1);
}
EOP
! if $cc -o set -DTRY_BSD_PGRP $ccflags $ldflags set.c $libs >/dev/null 2>&1 && ./set; then
echo 'You have to use setpgrp(pid,pgrp) instead of setpgrp().' >&4
val="$define"
! elif $cc -o set $ccflags $ldflags set.c $libs >/dev/null 2>&1 && ./set; then
echo 'You have to use setpgrp() instead of setpgrp(pid,pgrp).' >&4
val="$undef"
else
--- 8772,8781 ----
exit(1);
}
EOP
! if $cc -o try -DTRY_BSD_PGRP $ccflags $ldflags try.c $libs >/dev/null 2>&1 && $run ./try; then
echo 'You have to use setpgrp(pid,pgrp) instead of setpgrp().' >&4
val="$define"
! elif $cc -o try $ccflags $ldflags try.c $libs >/dev/null 2>&1 && $run ./try; then
echo 'You have to use setpgrp() instead of setpgrp(pid,pgrp).' >&4
val="$undef"
else
***************
*** 8468,8474 ****
esac
set d_bsdsetpgrp
eval $setvar
! $rm -f set set.c
: see if bzero exists
set bzero d_bzero
eval $inlibc
--- 8802,8808 ----
esac
set d_bsdsetpgrp
eval $setvar
! $rm -f try try.*
: see if bzero exists
set bzero d_bzero
eval $inlibc
***************
*** 8558,8564 ****
EOCP
set try
if eval $compile_ok; then
! ./try
yyy=$?
else
echo "(I can't seem to compile the test program--assuming it can't)"
--- 8892,8898 ----
EOCP
set try
if eval $compile_ok; then
! $run ./try
yyy=$?
else
echo "(I can't seem to compile the test program--assuming it can't)"
***************
*** 8654,8660 ****
EOCP
set try
if eval $compile_ok; then
! ./try
castflags=$?
else
echo "(I can't seem to compile the test program--assuming it can't)"
--- 8988,8994 ----
EOCP
set try
if eval $compile_ok; then
! $run ./try
castflags=$?
else
echo "(I can't seem to compile the test program--assuming it can't)"
***************
*** 8677,8683 ****
if set vprintf val -f d_vprintf; eval $csym; $val; then
echo 'vprintf() found.' >&4
val="$define"
! $cat >vprintf.c <<'EOF'
#include <varargs.h>
int main() { xxx("foo"); }
--- 9011,9017 ----
if set vprintf val -f d_vprintf; eval $csym; $val; then
echo 'vprintf() found.' >&4
val="$define"
! $cat >try.c <<'EOF'
#include <varargs.h>
int main() { xxx("foo"); }
***************
*** 8692,8699 ****
exit((unsigned long)vsprintf(buf,"%s",args) > 10L);
}
EOF
! set vprintf
! if eval $compile && ./vprintf; then
echo "Your vsprintf() returns (int)." >&4
val2="$undef"
else
--- 9026,9033 ----
exit((unsigned long)vsprintf(buf,"%s",args) > 10L);
}
EOF
! set try
! if eval $compile && $run ./try; then
echo "Your vsprintf() returns (int)." >&4
val2="$undef"
else
***************
*** 8705,8710 ****
--- 9039,9045 ----
val="$undef"
val2="$undef"
fi
+ $rm -f try try.*
set d_vprintf
eval $setvar
val=$val2
***************
*** 8966,8971 ****
--- 9301,9360 ----
set d_dbl_dig
eval $setvar
+ hasproto='varname=$1; func=$2; shift; shift;
+ while $test $# -ge 2; do
+ case "$1" in
+ $define) echo "#include <$2>";;
+ esac ;
+ shift 2;
+ done > try.c;
+ $cppstdin $cppflags $cppminus < try.c > tryout.c 2>/dev/null;
+ if $contains "$func.*(" tryout.c >/dev/null 2>&1; then
+ echo "$func() prototype found.";
+ val="$define";
+ else
+ echo "$func() prototype NOT found.";
+ val="$undef";
+ fi;
+ set $varname;
+ eval $setvar;
+ $rm -f try.c tryout.c'
+
+ : see if dbm.h is available
+ : see if dbmclose exists
+ set dbmclose d_dbmclose
+ eval $inlibc
+
+ case "$d_dbmclose" in
+ $define)
+ set dbm.h i_dbm
+ eval $inhdr
+ case "$i_dbm" in
+ $define)
+ val="$undef"
+ set i_rpcsvcdbm
+ eval $setvar
+ ;;
+ *) set rpcsvc/dbm.h i_rpcsvcdbm
+ eval $inhdr
+ ;;
+ esac
+ ;;
+ *) echo "We won't be including <dbm.h>"
+ val="$undef"
+ set i_dbm
+ eval $setvar
+ val="$undef"
+ set i_rpcsvcdbm
+ eval $setvar
+ ;;
+ esac
+
+ : see if prototype for dbminit is available
+ echo " "
+ set d_dbminitproto dbminit $i_dbm dbm.h
+ eval $hasproto
+
: see if difftime exists
set difftime d_difftime
eval $inlibc
***************
*** 9087,9093 ****
#include <stdio.h>
#$i_dlfcn I_DLFCN
#ifdef I_DLFCN
! #include <dlfcn.h> /* the dynamic linker include file for Sunos/Solaris */
#else
#include <sys/types.h>
#include <nlist.h>
--- 9476,9482 ----
#include <stdio.h>
#$i_dlfcn I_DLFCN
#ifdef I_DLFCN
! #include <dlfcn.h> /* the dynamic linker include file for SunOS/Solaris */
#else
#include <sys/types.h>
#include <nlist.h>
***************
*** 9131,9139 ****
: Call the object file tmp-dyna.o in case dlext=o.
if $cc $ccflags $cccdlflags -c dyna.c > /dev/null 2>&1 &&
mv dyna${_o} tmp-dyna${_o} > /dev/null 2>&1 &&
! $ld -o dyna.$dlext $lddlflags tmp-dyna${_o} > /dev/null 2>&1 &&
! $cc -o fred $ccflags $ldflags $cccdlflags $ccdlflags fred.c $libs > /dev/null 2>&1; then
! xxx=`./fred`
case $xxx in
1) echo "Test program failed using dlopen." >&4
echo "Perhaps you should not use dynamic loading." >&4;;
--- 9520,9528 ----
: Call the object file tmp-dyna.o in case dlext=o.
if $cc $ccflags $cccdlflags -c dyna.c > /dev/null 2>&1 &&
mv dyna${_o} tmp-dyna${_o} > /dev/null 2>&1 &&
! $ld -o dyna.$dlext $ldflags $lddlflags tmp-dyna${_o} > /dev/null 2>&1 &&
! $cc -o fred $ccflags $ldflags $cccdlflags $ccdlflags fred.c $libs > /dev/null 2>&1 && $to dyna.$dlext; then
! xxx=`$run ./fred`
case $xxx in
1) echo "Test program failed using dlopen." >&4
echo "Perhaps you should not use dynamic loading." >&4;;
***************
*** 9155,9179 ****
set d_dlsymun
eval $setvar
- hasproto='varname=$1; func=$2; shift; shift;
- while $test $# -ge 2; do
- case "$1" in
- $define) echo "#include <$2>";;
- esac ;
- shift 2;
- done > try.c;
- $cppstdin $cppflags $cppminus < try.c > tryout.c 2>/dev/null;
- if $contains "$func.*(" tryout.c >/dev/null 2>&1; then
- echo "$func() prototype found.";
- val="$define";
- else
- echo "$func() prototype NOT found.";
- val="$undef";
- fi;
- set $varname;
- eval $setvar;
- $rm -f try.c tryout.c'
-
: see if prototype for drand48 is available
echo " "
set d_drand48proto drand48 $i_stdlib stdlib.h $i_unistd unistd.h
--- 9544,9549 ----
***************
*** 9213,9219 ****
: Locate the flags for 'open()'
echo " "
! $cat >open3.c <<'EOCP'
#include <sys/types.h>
#ifdef I_FCNTL
#include <fcntl.h>
--- 9583,9589 ----
: Locate the flags for 'open()'
echo " "
! $cat >try.c <<'EOCP'
#include <sys/types.h>
#ifdef I_FCNTL
#include <fcntl.h>
***************
*** 9232,9241 ****
EOCP
: check sys/file.h first to get FREAD on Sun
if $test `./findhdr sys/file.h` && \
! set open3 -DI_SYS_FILE && eval $compile; then
h_sysfile=true;
echo "<sys/file.h> defines the O_* constants..." >&4
! if ./open3; then
echo "and you have the 3 argument form of open()." >&4
val="$define"
else
--- 9602,9611 ----
EOCP
: check sys/file.h first to get FREAD on Sun
if $test `./findhdr sys/file.h` && \
! set try -DI_SYS_FILE && eval $compile; then
h_sysfile=true;
echo "<sys/file.h> defines the O_* constants..." >&4
! if $run ./try; then
echo "and you have the 3 argument form of open()." >&4
val="$define"
else
***************
*** 9243,9252 ****
val="$undef"
fi
elif $test `./findhdr fcntl.h` && \
! set open3 -DI_FCNTL && eval $compile; then
h_fcntl=true;
echo "<fcntl.h> defines the O_* constants..." >&4
! if ./open3; then
echo "and you have the 3 argument form of open()." >&4
val="$define"
else
--- 9613,9622 ----
val="$undef"
fi
elif $test `./findhdr fcntl.h` && \
! set try -DI_FCNTL && eval $compile; then
h_fcntl=true;
echo "<fcntl.h> defines the O_* constants..." >&4
! if $run ./try; then
echo "and you have the 3 argument form of open()." >&4
val="$define"
else
***************
*** 9259,9265 ****
fi
set d_open3
eval $setvar
! $rm -f open3*
: see which of string.h or strings.h is needed
echo " "
--- 9629,9635 ----
fi
set d_open3
eval $setvar
! $rm -f try try.*
: see which of string.h or strings.h is needed
echo " "
***************
*** 9318,9324 ****
EOCP
set try
if eval $compile_ok; then
! o_nonblock=`./try`
case "$o_nonblock" in
'') echo "I can't figure it out, assuming O_NONBLOCK will do.";;
*) echo "Seems like we can use $o_nonblock.";;
--- 9688,9694 ----
EOCP
set try
if eval $compile_ok; then
! o_nonblock=`$run ./try`
case "$o_nonblock" in
'') echo "I can't figure it out, assuming O_NONBLOCK will do.";;
*) echo "Seems like we can use $o_nonblock.";;
***************
*** 9415,9421 ****
set try
if eval $compile_ok; then
echo "$startsh" >mtry
! echo "./try >try.out 2>try.ret 3>try.err || exit 4" >>mtry
chmod +x mtry
./mtry >/dev/null 2>&1
case $? in
--- 9785,9791 ----
set try
if eval $compile_ok; then
echo "$startsh" >mtry
! echo "$run ./try >try.out 2>try.ret 3>try.err || exit 4" >>mtry
chmod +x mtry
./mtry >/dev/null 2>&1
case $? in
***************
*** 9477,9482 ****
--- 9847,9856 ----
esac
$rm -f try try.* .out core head.c mtry
+ : see if fchdir exists
+ set fchdir d_fchdir
+ eval $inlibc
+
: see if fchmod exists
set fchmod d_fchmod
eval $inlibc
***************
*** 9491,9500 ****
echo " "
: See if fcntl-based locking works.
! $cat >try.c <<'EOCP'
#include <stdlib.h>
#include <unistd.h>
#include <fcntl.h>
int main() {
#if defined(F_SETLK) && defined(F_SETLKW)
struct flock flock;
--- 9865,9876 ----
echo " "
: See if fcntl-based locking works.
! $cat >try.c <<EOCP
#include <stdlib.h>
#include <unistd.h>
#include <fcntl.h>
+ #include <signal.h>
+ $signal_t blech(x) int x; { exit(3); }
int main() {
#if defined(F_SETLK) && defined(F_SETLKW)
struct flock flock;
***************
*** 9503,9508 ****
--- 9879,9886 ----
flock.l_type = F_RDLCK;
flock.l_whence = SEEK_SET;
flock.l_start = flock.l_len = 0;
+ signal(SIGALRM, blech);
+ alarm(10);
retval = fcntl(fd, F_SETLK, &flock);
close(fd);
(retval < 0 ? exit(2) : exit(0));
***************
*** 9516,9527 ****
"$define")
set try
if eval $compile_ok; then
! if ./try; then
echo "Yes, it seems to work."
val="$define"
else
echo "Nope, it didn't work."
val="$undef"
fi
else
echo "I'm unable to compile the test program, so I'll assume not."
--- 9894,9917 ----
"$define")
set try
if eval $compile_ok; then
! if $run ./try; then
echo "Yes, it seems to work."
val="$define"
else
echo "Nope, it didn't work."
val="$undef"
+ case "$?" in
+ 3) $cat >&4 <<EOM
+ ***
+ *** I had to forcibly timeout from fcntl(..., F_SETLK, ...).
+ *** This is (almost) impossible.
+ *** If your NFS lock daemons are not feeling well, something like
+ *** this may happen, please investigate. Cannot continue, aborting.
+ ***
+ EOM
+ exit 1
+ ;;
+ esac
fi
else
echo "I'm unable to compile the test program, so I'll assume not."
***************
*** 9630,9636 ****
Checking to see how well your C compiler handles fd_set and friends ...
EOM
! $cat >fd_set.c <<EOCP
#$i_systime I_SYS_TIME
#$i_sysselct I_SYS_SELECT
#$d_socket HAS_SOCKET
--- 10020,10026 ----
Checking to see how well your C compiler handles fd_set and friends ...
EOM
! $cat >try.c <<EOCP
#$i_systime I_SYS_TIME
#$i_sysselct I_SYS_SELECT
#$d_socket HAS_SOCKET
***************
*** 9658,9669 ****
#endif
}
EOCP
! set fd_set -DTRYBITS
if eval $compile; then
d_fds_bits="$define"
d_fd_set="$define"
echo "Well, your system knows about the normal fd_set typedef..." >&4
! if ./fd_set; then
echo "and you have the normal fd_set macros (just as I'd expect)." >&4
d_fd_macros="$define"
else
--- 10048,10059 ----
#endif
}
EOCP
! set try -DTRYBITS
if eval $compile; then
d_fds_bits="$define"
d_fd_set="$define"
echo "Well, your system knows about the normal fd_set typedef..." >&4
! if $run ./try; then
echo "and you have the normal fd_set macros (just as I'd expect)." >&4
d_fd_macros="$define"
else
***************
*** 9676,9687 ****
$cat <<'EOM'
Hmm, your compiler has some difficulty with fd_set. Checking further...
EOM
! set fd_set
if eval $compile; then
d_fds_bits="$undef"
d_fd_set="$define"
echo "Well, your system has some sort of fd_set available..." >&4
! if ./fd_set; then
echo "and you have the normal fd_set macros." >&4
d_fd_macros="$define"
else
--- 10066,10077 ----
$cat <<'EOM'
Hmm, your compiler has some difficulty with fd_set. Checking further...
EOM
! set try
if eval $compile; then
d_fds_bits="$undef"
d_fd_set="$define"
echo "Well, your system has some sort of fd_set available..." >&4
! if $run ./try; then
echo "and you have the normal fd_set macros." >&4
d_fd_macros="$define"
else
***************
*** 9697,9703 ****
d_fd_macros="$undef"
fi
fi
! $rm -f fd_set*
: see if fgetpos exists
set fgetpos d_fgetpos
--- 10087,10093 ----
d_fd_macros="$undef"
fi
fi
! $rm -f try try.*
: see if fgetpos exists
set fgetpos d_fgetpos
***************
*** 9707,9712 ****
--- 10097,10131 ----
set flock d_flock
eval $inlibc
+ : see if this is a sys/file.h system
+ val=''
+ set sys/file.h val
+ eval $inhdr
+
+ : do we need to include sys/file.h ?
+ case "$val" in
+ "$define")
+ echo " "
+ if $h_sysfile; then
+ val="$define"
+ echo "We'll be including <sys/file.h>." >&4
+ else
+ val="$undef"
+ echo "We won't be including <sys/file.h>." >&4
+ fi
+ ;;
+ *)
+ h_sysfile=false
+ ;;
+ esac
+ set i_sysfile
+ eval $setvar
+
+ : see if prototype for flock is available
+ echo " "
+ set d_flockproto flock $i_sysfile sys/file.h
+ eval $hasproto
+
: see if fork exists
set fork d_fork
eval $inlibc
***************
*** 10368,10373 ****
--- 10787,10847 ----
set modfl d_modfl
eval $inlibc
+ d_modfl_pow32_bug="$undef"
+
+ case "$d_longdbl$d_modfl" in
+ $define$define)
+ $cat <<EOM
+ Checking to see whether your modfl() is okay for large values...
+ EOM
+ $cat >try.c <<EOCP
+ #include <math.h>
+ #include <stdio.h>
+ int main() {
+ long double nv = 4294967303.15;
+ long double v, w;
+ v = modfl(nv, &w);
+ #ifdef __GLIBC__
+ printf("glibc");
+ #endif
+ printf(" %"$sPRIfldbl" %"$sPRIfldbl" %"$sPRIfldbl"\n", nv, v, w);
+ return 0;
+ }
+ EOCP
+ case "$osname:$gccversion" in
+ aix:) saveccflags="$ccflags"
+ ccflags="$ccflags -qlongdouble" ;; # to avoid core dump
+ esac
+ set try
+ if eval $compile; then
+ foo=`$run ./try`
+ case "$foo" in
+ *" 4294967303.150000 1.150000 4294967302.000000")
+ echo >&4 "Your modfl() is broken for large values."
+ d_modfl_pow32_bug="$define"
+ case "$foo" in
+ glibc) echo >&4 "You should upgrade your glibc to at least 2.2.2 to get a fixed modfl()."
+ ;;
+ esac
+ ;;
+ *" 4294967303.150000 0.150000 4294967303.000000")
+ echo >&4 "Your modfl() seems okay for large values."
+ ;;
+ *) echo >&4 "I don't understand your modfl() at all."
+ d_modfl="$undef"
+ ;;
+ esac
+ $rm -f try.* try core core.try.*
+ else
+ echo "I cannot figure out whether your modfl() is okay, assuming it isn't."
+ d_modfl="$undef"
+ fi
+ case "$osname:$gccversion" in
+ aix:) ccflags="$saveccflags" ;; # restore
+ esac
+ ;;
+ esac
+
: see if mprotect exists
set mprotect d_mprotect
eval $inlibc
***************
*** 10447,10452 ****
--- 10921,10934 ----
set nice d_nice
eval $inlibc
+ : see if this is a langinfo.h system
+ set langinfo.h i_langinfo
+ eval $inhdr
+
+ : see if nl_langinfo exists
+ set nl_langinfo d_nl_langinfo
+ eval $inlibc
+
: check for length of character
echo " "
case "$charsize" in
***************
*** 10462,10468 ****
EOCP
set try
if eval $compile_ok; then
! dflt=`./try`
else
dflt='1'
echo "(I can't seem to compile the test program. Guessing...)"
--- 10944,10950 ----
EOCP
set try
if eval $compile_ok; then
! dflt=`$run ./try`
else
dflt='1'
echo "(I can't seem to compile the test program. Guessing...)"
***************
*** 10578,10584 ****
case "$i8type" in
'') set try -DINT8
if eval $compile; then
! case "`./try$exe_ext`" in
int8_t) i8type=int8_t
u8type=uint8_t
i8size=1
--- 11060,11066 ----
case "$i8type" in
'') set try -DINT8
if eval $compile; then
! case "`$run ./try`" in
int8_t) i8type=int8_t
u8type=uint8_t
i8size=1
***************
*** 10611,10617 ****
case "$i16type" in
'') set try -DINT16
if eval $compile; then
! case "`./try$exe_ext`" in
int16_t)
i16type=int16_t
u16type=uint16_t
--- 11093,11099 ----
case "$i16type" in
'') set try -DINT16
if eval $compile; then
! case "`$run ./try`" in
int16_t)
i16type=int16_t
u16type=uint16_t
***************
*** 10653,10659 ****
case "$i32type" in
'') set try -DINT32
if eval $compile; then
! case "`./try$exe_ext`" in
int32_t)
i32type=int32_t
u32type=uint32_t
--- 11135,11141 ----
case "$i32type" in
'') set try -DINT32
if eval $compile; then
! case "`$run ./try`" in
int32_t)
i32type=int32_t
u32type=uint32_t
***************
*** 10732,10738 ****
d_nv_preserves_uv="$undef"
if eval $compile; then
! d_nv_preserves_uv_bits="`./try$exe_ext`"
fi
case "$d_nv_preserves_uv_bits" in
\-[1-9]*)
--- 11214,11220 ----
d_nv_preserves_uv="$undef"
if eval $compile; then
! d_nv_preserves_uv_bits="`$run ./try`"
fi
case "$d_nv_preserves_uv_bits" in
\-[1-9]*)
***************
*** 10847,10853 ****
--- 11329,11339 ----
set poll d_poll
eval $inlibc
+ : see if pthread_atfork exists
+ set pthread_atfork d_pthread_atfork
+ eval $inlibc
+
: see whether the various POSIXish _yields exist
$cat >try.c <<EOP
#include <pthread.h>
***************
*** 11062,11073 ****
eval $setvar
: can bcopy handle overlapping blocks?
val="$undef"
! case "$d_bcopy" in
! "$define")
! echo " "
! echo "Checking to see if your bcopy() can do overlapping copies..." >&4
! $cat >try.c <<EOCP
#$i_memory I_MEMORY
#$i_stdlib I_STDLIB
#$i_string I_STRING
--- 11548,11561 ----
eval $setvar
: can bcopy handle overlapping blocks?
+ echo " "
val="$undef"
! case "$d_memmove" in
! "$define") echo "I'll use memmove() instead of bcopy() for overlapping copies." ;;
! *) case "$d_bcopy" in
! "$define")
! echo "Checking to see if bcopy() can do overlapping copies..." >&4
! $cat >try.c <<EOCP
#$i_memory I_MEMORY
#$i_stdlib I_STDLIB
#$i_string I_STRING
***************
*** 11097,11102 ****
--- 11585,11592 ----
int off;
int align;
+ /* Copy "abcde..." string to char abc[] so that gcc doesn't
+ try to store the string in read-only memory. */
bcopy("abcdefghijklmnopqrstuvwxyz0123456789", abc, 36);
for (align = 7; align >= 0; align--) {
***************
*** 11114,11149 ****
exit(0);
}
EOCP
! set try
! if eval $compile_ok; then
! if ./try 2>/dev/null; then
! echo "Yes, it can."
! val="$define"
else
! echo "It can't, sorry."
! case "$d_memmove" in
! "$define") echo "But that's Ok since you have memmove()." ;;
! esac
fi
! else
! echo "(I can't compile the test program, so we'll assume not...)"
! case "$d_memmove" in
! "$define") echo "But that's Ok since you have memmove()." ;;
! esac
! fi
;;
esac
- $rm -f try.* try core
set d_safebcpy
eval $setvar
: can memcpy handle overlapping blocks?
val="$undef"
! case "$d_memcpy" in
! "$define")
! echo " "
! echo "Checking to see if your memcpy() can do overlapping copies..." >&4
! $cat >try.c <<EOCP
#$i_memory I_MEMORY
#$i_stdlib I_STDLIB
#$i_string I_STRING
--- 11604,11637 ----
exit(0);
}
EOCP
! set try
! if eval $compile_ok; then
! if ./try 2>/dev/null; then
! echo "Yes, it can."
! val="$define"
! else
! echo "It can't, sorry."
! fi
else
! echo "(I can't compile the test program, so we'll assume not...)"
fi
! ;;
! esac
! $rm -f try.* try core
;;
esac
set d_safebcpy
eval $setvar
: can memcpy handle overlapping blocks?
+ echo " "
val="$undef"
! case "$d_memmove" in
! "$define") echo "I'll use memmove() instead of memcpy() for overlapping copies." ;;
! *) case "$d_memcpy" in
! "$define")
! echo "Checking to see if memcpy() can do overlapping copies..." >&4
! $cat >try.c <<EOCP
#$i_memory I_MEMORY
#$i_stdlib I_STDLIB
#$i_string I_STRING
***************
*** 11192,11217 ****
exit(0);
}
EOCP
! set try
! if eval $compile_ok; then
! if ./try 2>/dev/null; then
! echo "Yes, it can."
! val="$define"
else
! echo "It can't, sorry."
! case "$d_memmove" in
! "$define") echo "But that's Ok since you have memmove()." ;;
! esac
fi
! else
! echo "(I can't compile the test program, so we'll assume not...)"
! case "$d_memmove" in
! "$define") echo "But that's Ok since you have memmove()." ;;
! esac
! fi
;;
esac
- $rm -f try.* try core
set d_safemcpy
eval $setvar
--- 11680,11701 ----
exit(0);
}
EOCP
! set try
! if eval $compile_ok; then
! if ./try 2>/dev/null; then
! echo "Yes, it can."
! val="$define"
! else
! echo "It can't, sorry."
! fi
else
! echo "(I can't compile the test program, so we'll assume not...)"
fi
! ;;
! esac
! $rm -f try.* try core
;;
esac
set d_safemcpy
eval $setvar
***************
*** 11254,11260 ****
EOCP
set try
if eval $compile_ok; then
! if ./try 2>/dev/null; then
echo "Yes, it can."
val="$define"
else
--- 11738,11744 ----
EOCP
set try
if eval $compile_ok; then
! if $run ./try 2>/dev/null; then
echo "Yes, it can."
val="$define"
else
***************
*** 11423,11429 ****
val="$undef"
set try
if eval $compile; then
! xxx=`./try`
case "$xxx" in
semun) val="$define" ;;
esac
--- 11907,11913 ----
val="$undef"
set try
if eval $compile; then
! xxx=`$run ./try`
case "$xxx" in
semun) val="$define" ;;
esac
***************
*** 11481,11487 ****
val="$undef"
set try
if eval $compile; then
! xxx=`./try`
case "$xxx" in
semid_ds) val="$define" ;;
esac
--- 11965,11971 ----
val="$undef"
set try
if eval $compile; then
! xxx=`$run ./try`
case "$xxx" in
semid_ds) val="$define" ;;
esac
***************
*** 11663,11672 ****
case "$d_sfio" in
$define) ;;
*) : Remove sfio from list of libraries to use
! set `echo X $libs | $sed -e 's/-lsfio / /' -e 's/-lsfio$//'`
! shift
! libs="$*"
! echo "libs = $libs" >&4
;;
esac
--- 12147,12161 ----
case "$d_sfio" in
$define) ;;
*) : Remove sfio from list of libraries to use
! case "$libs" in
! *-lsfio*)
! echo "Removing unneeded -lsfio from library list" >&4
! set `echo X $libs | $sed -e 's/-lsfio / /' -e 's/-lsfio$//'`
! shift
! libs="$*"
! echo "libs = $libs" >&4
! ;;
! esac
;;
esac
***************
*** 11806,11812 ****
EOP
set try
if eval $compile; then
! if ./try >/dev/null 2>&1; then
echo "POSIX sigsetjmp found." >&4
val="$define"
else
--- 12295,12301 ----
EOP
set try
if eval $compile; then
! if $run ./try >/dev/null 2>&1; then
echo "POSIX sigsetjmp found." >&4
val="$define"
else
***************
*** 11836,11845 ****
--- 12325,12349 ----
set sockatmark d_sockatmark
eval $inlibc
+ : see if prototype for sockatmark is available
+ echo " "
+ set d_sockatmarkproto sockatmark $d_socket sys/socket.h
+ eval $hasproto
+
: see if socks5_init exists
set socks5_init d_socks5_init
eval $inlibc
+ : see if prototype for setresgid is available
+ echo " "
+ set d_sresgproto setresgid $i_unistd unistd.h
+ eval $hasproto
+
+ : see if prototype for setresuid is available
+ echo " "
+ set d_sresuproto setresuid $i_unistd unistd.h
+ eval $hasproto
+
: see if sys/stat.h is available
set sys/stat.h i_sysstat
eval $inhdr
***************
*** 11974,11981 ****
EOP
val="$undef"
set try
! if eval $compile; then
! if ./try; then
echo "Your stdio acts pretty std."
val="$define"
else
--- 12478,12485 ----
EOP
val="$undef"
set try
! if eval $compile && $to try.c; then
! if $run ./try; then
echo "Your stdio acts pretty std."
val="$define"
else
***************
*** 12071,12078 ****
}
EOP
set try
! if eval $compile; then
! case `./try$exe_ext` in
Pass_changed)
echo "Increasing ptr in your stdio decreases cnt by the same amount. Good." >&4
d_stdio_ptr_lval_sets_cnt="$define" ;;
--- 12575,12582 ----
}
EOP
set try
! if eval $compile && $to try.c; then
! case `$run ./try` in
Pass_changed)
echo "Increasing ptr in your stdio decreases cnt by the same amount. Good." >&4
d_stdio_ptr_lval_sets_cnt="$define" ;;
***************
*** 12111,12118 ****
}
EOP
set try
! if eval $compile; then
! if ./try; then
echo "And its _base field acts std."
val="$define"
else
--- 12615,12622 ----
}
EOP
set try
! if eval $compile && $to try.c; then
! if $run ./try; then
echo "And its _base field acts std."
val="$define"
else
***************
*** 12142,12148 ****
do
set try -DSTDIO_STREAM_ARRAY=$s
if eval $compile; then
! case "`./try$exe_ext`" in
yes) stdio_stream_array=$s; break ;;
esac
fi
--- 12646,12652 ----
do
set try -DSTDIO_STREAM_ARRAY=$s
if eval $compile; then
! case "`$run ./try`" in
yes) stdio_stream_array=$s; break ;;
esac
fi
***************
*** 12229,12234 ****
--- 12733,12742 ----
fi
fi
+ : see if strftime exists
+ set strftime d_strftime
+ eval $inlibc
+
: see if strtod exists
set strtod d_strtod
eval $inlibc
***************
*** 12284,12290 ****
EOCP
set try
if eval $compile; then
! yyy=`./try`
case "$yyy" in
ok) echo "Your strtoll() seems to be working okay." ;;
*) cat <<EOM >&4
--- 12792,12798 ----
EOCP
set try
if eval $compile; then
! yyy=`$run ./try`
case "$yyy" in
ok) echo "Your strtoll() seems to be working okay." ;;
*) cat <<EOM >&4
***************
*** 12369,12375 ****
EOCP
set try
if eval $compile; then
! case "`./try`" in
ok) echo "Your strtoul() seems to be working okay." ;;
*) cat <<EOM >&4
Your strtoul() doesn't seem to be working okay.
--- 12877,12883 ----
EOCP
set try
if eval $compile; then
! case "`$run ./try`" in
ok) echo "Your strtoul() seems to be working okay." ;;
*) cat <<EOM >&4
Your strtoul() doesn't seem to be working okay.
***************
*** 12423,12429 ****
EOCP
set try
if eval $compile; then
! case "`./try`" in
ok) echo "Your strtoull() seems to be working okay." ;;
*) cat <<EOM >&4
Your strtoull() doesn't seem to be working okay.
--- 12931,12937 ----
EOCP
set try
if eval $compile; then
! case "`$run ./try`" in
ok) echo "Your strtoull() seems to be working okay." ;;
*) cat <<EOM >&4
Your strtoull() doesn't seem to be working okay.
***************
*** 12475,12481 ****
EOCP
set try
if eval $compile; then
! case "`./try`" in
ok) echo "Your strtouq() seems to be working okay." ;;
*) cat <<EOM >&4
Your strtouq() doesn't seem to be working okay.
--- 12983,12989 ----
EOCP
set try
if eval $compile; then
! case "`$run ./try`" in
ok) echo "Your strtouq() seems to be working okay." ;;
*) cat <<EOM >&4
Your strtouq() doesn't seem to be working okay.
***************
*** 12499,12504 ****
--- 13007,13017 ----
set syscall d_syscall
eval $inlibc
+ : see if prototype for syscall is available
+ echo " "
+ set d_syscallproto syscall $i_unistd unistd.h
+ eval $hasproto
+
: see if sysconf exists
set sysconf d_sysconf
eval $inlibc
***************
*** 12558,12567 ****
set d_tzname
eval $setvar
- case "$crosscompile" in
- ''|[nN]*) crosscompile="$undef" ;;
- esac
-
case "$osname" in
next|rhapsody|darwin) multiarch="$define" ;;
esac
--- 13071,13076 ----
***************
*** 12571,12577 ****
: check for ordering of bytes in a long
echo " "
! case "$crosscompile$multiarch" in
*$define*)
$cat <<EOM
You seem to be either cross-compiling or doing a multiarchitecture build,
--- 13080,13086 ----
: check for ordering of bytes in a long
echo " "
! case "$usecrosscompile$multiarch" in
*$define*)
$cat <<EOM
You seem to be either cross-compiling or doing a multiarchitecture build,
***************
*** 12578,12584 ****
skipping the byteorder check.
EOM
! byteorder='0xffff'
;;
*)
case "$byteorder" in
--- 13087,13093 ----
skipping the byteorder check.
EOM
! byteorder='ffff'
;;
*)
case "$byteorder" in
***************
*** 12615,12621 ****
xxx_prompt=y
set try
if eval $compile && ./try > /dev/null; then
! dflt=`./try`
case "$dflt" in
[1-4][1-4][1-4][1-4]|12345678|87654321)
echo "(The test program ran ok.)"
--- 13124,13130 ----
xxx_prompt=y
set try
if eval $compile && ./try > /dev/null; then
! dflt=`$run ./try`
case "$dflt" in
[1-4][1-4][1-4][1-4]|12345678|87654321)
echo "(The test program ran ok.)"
***************
*** 12700,12707 ****
EOCP
set try
if eval $compile_ok; then
! echo "(This test may dump core.)" >&4
! ./try >&2 >/dev/null
case "$?" in
0) cat >&4 <<EOM
You can access character data pretty unalignedly.
--- 13209,13216 ----
EOCP
set try
if eval $compile_ok; then
! echo "(Testing for character data alignment may dump core.)" >&4
! $run ./try 2>&1 >/dev/null
case "$?" in
0) cat >&4 <<EOM
You can access character data pretty unalignedly.
***************
*** 12737,12742 ****
--- 13246,13256 ----
set usleep d_usleep
eval $inlibc
+ : see if prototype for usleep is available
+ echo " "
+ set d_usleepproto usleep $i_unistd unistd.h
+ eval $hasproto
+
: see if ustat exists
set ustat d_ustat
eval $inlibc
***************
*** 12803,12809 ****
"$define")
echo " "
echo "Checking whether closedir() returns a status..." >&4
! cat > closedir.c <<EOM
#$i_dirent I_DIRENT /**/
#$i_sysdir I_SYS_DIR /**/
#$i_sysndir I_SYS_NDIR /**/
--- 13317,13323 ----
"$define")
echo " "
echo "Checking whether closedir() returns a status..." >&4
! cat > try.c <<EOM
#$i_dirent I_DIRENT /**/
#$i_sysdir I_SYS_DIR /**/
#$i_sysndir I_SYS_NDIR /**/
***************
*** 12832,12840 ****
#endif
int main() { return closedir(opendir(".")); }
EOM
! set closedir
if eval $compile_ok; then
! if ./closedir > /dev/null 2>&1 ; then
echo "Yes, it does."
val="$undef"
else
--- 13346,13354 ----
#endif
int main() { return closedir(opendir(".")); }
EOM
! set try
if eval $compile_ok; then
! if $run ./try > /dev/null 2>&1 ; then
echo "Yes, it does."
val="$undef"
else
***************
*** 12852,12858 ****
esac
set d_void_closedir
eval $setvar
! $rm -f closedir*
: see if there is a wait4
set wait4 d_wait4
eval $inlibc
--- 13366,13372 ----
esac
set d_void_closedir
eval $setvar
! $rm -f try try.*
: see if there is a wait4
set wait4 d_wait4
eval $inlibc
***************
*** 12882,12888 ****
: check for alignment requirements
echo " "
! case "$crosscompile$multiarch" in
*$define*)
$cat <<EOM
You seem to be either cross-compiling or doing a multiarchitecture build,
--- 13396,13402 ----
: check for alignment requirements
echo " "
! case "$usecrosscompile$multiarch" in
*$define*)
$cat <<EOM
You seem to be either cross-compiling or doing a multiarchitecture build,
***************
*** 12919,12925 ****
EOCP
set try
if eval $compile_ok; then
! dflt=`./try`
else
dflt='8'
echo "(I can't seem to compile the test program...)"
--- 13433,13439 ----
EOCP
set try
if eval $compile_ok; then
! dflt=`$run ./try`
else
dflt='8'
echo "(I can't seem to compile the test program...)"
***************
*** 12984,12996 ****
#include <sys/types.h>
#include <stdio.h>
#include <db.h>
! int main()
{
#ifdef DB_VERSION_MAJOR /* DB version >= 2 */
int Major, Minor, Patch ;
unsigned long Version ;
(void)db_version(&Major, &Minor, &Patch) ;
! printf("You have Berkeley DB Version 2 or greater\n");
printf("db.h is from Berkeley DB Version %d.%d.%d\n",
DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH);
--- 13498,13516 ----
#include <sys/types.h>
#include <stdio.h>
#include <db.h>
! int main(int argc, char *argv[])
{
#ifdef DB_VERSION_MAJOR /* DB version >= 2 */
int Major, Minor, Patch ;
unsigned long Version ;
(void)db_version(&Major, &Minor, &Patch) ;
! if (argc == 2) {
! printf("%d %d %d %d %d %d\n",
! DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH,
! Major, Minor, Patch);
! exit(0);
! }
! printf("You have Berkeley DB Version 2 or greater.\n");
printf("db.h is from Berkeley DB Version %d.%d.%d\n",
DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH);
***************
*** 12999,13009 ****
/* check that db.h & libdb are compatible */
if (DB_VERSION_MAJOR != Major || DB_VERSION_MINOR != Minor || DB_VERSION_PATCH != Patch) {
! printf("db.h and libdb are incompatible\n") ;
exit(3);
}
! printf("db.h and libdb are compatible\n") ;
Version = DB_VERSION_MAJOR * 1000000 + DB_VERSION_MINOR * 1000
+ DB_VERSION_PATCH ;
--- 13519,13529 ----
/* check that db.h & libdb are compatible */
if (DB_VERSION_MAJOR != Major || DB_VERSION_MINOR != Minor || DB_VERSION_PATCH != Patch) {
! printf("db.h and libdb are incompatible.\n") ;
exit(3);
}
! printf("db.h and libdb are compatible.\n") ;
Version = DB_VERSION_MAJOR * 1000000 + DB_VERSION_MINOR * 1000
+ DB_VERSION_PATCH ;
***************
*** 13011,13017 ****
/* needs to be >= 2.3.4 */
if (Version < 2003004) {
/* if (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && DB_VERSION_PATCH < 5) { */
! printf("but Perl needs Berkeley DB 2.3.4 or greater\n") ;
exit(2);
}
--- 13531,13537 ----
/* needs to be >= 2.3.4 */
if (Version < 2003004) {
/* if (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && DB_VERSION_PATCH < 5) { */
! printf("Perl needs Berkeley DB 2.3.4 or greater.\n") ;
exit(2);
}
***************
*** 13018,13024 ****
exit(0);
#else
#if defined(_DB_H_) && defined(BTREEMAGIC) && defined(HASHMAGIC)
! printf("You have Berkeley DB Version 1\n");
exit(0); /* DB version < 2: the coast is clear. */
#else
exit(1); /* <db.h> not Berkeley DB? */
--- 13538,13548 ----
exit(0);
#else
#if defined(_DB_H_) && defined(BTREEMAGIC) && defined(HASHMAGIC)
! if (argc == 2) {
! printf("1 0 0\n");
! exit(0);
! }
! printf("You have Berkeley DB Version 1.\n");
exit(0); /* DB version < 2: the coast is clear. */
#else
exit(1); /* <db.h> not Berkeley DB? */
***************
*** 13027,13034 ****
}
EOCP
set try
! if eval $compile_ok && ./try; then
echo 'Looks OK.' >&4
else
echo "I can't use Berkeley DB with your <db.h>. I'll disable Berkeley DB." >&4
i_db=$undef
--- 13551,13562 ----
}
EOCP
set try
! if eval $compile_ok && $run ./try; then
echo 'Looks OK.' >&4
+ set `$run ./try 1`
+ db_version_major=$1
+ db_version_minor=$2
+ db_version_patch=$3
else
echo "I can't use Berkeley DB with your <db.h>. I'll disable Berkeley DB." >&4
i_db=$undef
***************
*** 13271,13277 ****
echo " "
echo "Determining whether or not we are on an EBCDIC system..." >&4
! $cat >tebcdic.c <<'EOM'
int main()
{
if ('M'==0xd4) return 0;
--- 13799,13805 ----
echo " "
echo "Determining whether or not we are on an EBCDIC system..." >&4
! $cat >try.c <<'EOM'
int main()
{
if ('M'==0xd4) return 0;
***************
*** 13280,13298 ****
EOM
val=$undef
! set tebcdic
if eval $compile_ok; then
! if ./tebcdic; then
echo "You seem to speak EBCDIC." >&4
val="$define"
else
! echo "Nope, no EBCDIC, probably ASCII or some ISO Latin. Or UTF8." >&4
fi
else
echo "I'm unable to compile the test program." >&4
echo "I'll assume ASCII or some ISO Latin. Or UTF8." >&4
fi
! $rm -f tebcdic.c tebcdic
set ebcdic
eval $setvar
--- 13808,13826 ----
EOM
val=$undef
! set try
if eval $compile_ok; then
! if $run ./try; then
echo "You seem to speak EBCDIC." >&4
val="$define"
else
! echo "Nope, no EBCDIC, probably ASCII or some ISO Latin. Or UTF-8." >&4
fi
else
echo "I'm unable to compile the test program." >&4
echo "I'll assume ASCII or some ISO Latin. Or UTF8." >&4
fi
! $rm -f try try.*
set ebcdic
eval $setvar
***************
*** 13317,13323 ****
# define STDIO_STREAM_ARRAY $stdio_stream_array
#endif
int main() {
! FILE* p = fopen("try.out", "w");
#ifdef TRY_FPUTC
fputc('x', p);
#else
--- 13845,13853 ----
# define STDIO_STREAM_ARRAY $stdio_stream_array
#endif
int main() {
! FILE* p;
! unlink("try.out");
! p = fopen("try.out", "w");
#ifdef TRY_FPUTC
fputc('x', p);
#else
***************
*** 13366,13378 ****
}
EOCP
: first we have to find out how _not_ to flush
if $test "X$fflushNULL" = X -o "X$fflushall" = X; then
output=''
set try -DTRY_FPUTC
if eval $compile; then
! $rm -f try.out
! ./try$exe_ext 2>/dev/null
! if $test ! -s try.out -a "X$?" = X42; then
output=-DTRY_FPUTC
fi
fi
--- 13896,13910 ----
}
EOCP
: first we have to find out how _not_ to flush
+ $to try.c
if $test "X$fflushNULL" = X -o "X$fflushall" = X; then
output=''
set try -DTRY_FPUTC
if eval $compile; then
! $run ./try 2>/dev/null
! code="$?"
! $from try.out
! if $test ! -s try.out -a "X$code" = X42; then
output=-DTRY_FPUTC
fi
fi
***************
*** 13379,13389 ****
case "$output" in
'')
set try -DTRY_FPRINTF
- $rm -f try.out
if eval $compile; then
! $rm -f try.out
! ./try$exe_ext 2>/dev/null
! if $test ! -s try.out -a "X$?" = X42; then
output=-DTRY_FPRINTF
fi
fi
--- 13911,13921 ----
case "$output" in
'')
set try -DTRY_FPRINTF
if eval $compile; then
! $run ./try 2>/dev/null
! code="$?"
! $from try.out
! if $test ! -s try.out -a "X$code" = X42; then
output=-DTRY_FPRINTF
fi
fi
***************
*** 13394,13402 ****
case "$fflushNULL" in
'') set try -DTRY_FFLUSH_NULL $output
if eval $compile; then
! $rm -f try.out
! ./try$exe_ext 2>/dev/null
code="$?"
if $test -s try.out -a "X$code" = X42; then
fflushNULL="`$cat try.out`"
else
--- 13926,13934 ----
case "$fflushNULL" in
'') set try -DTRY_FFLUSH_NULL $output
if eval $compile; then
! $run ./try 2>/dev/null
code="$?"
+ $from try.out
if $test -s try.out -a "X$code" = X42; then
fflushNULL="`$cat try.out`"
else
***************
*** 13442,13448 ****
set tryp
if eval $compile; then
$rm -f tryp.out
! $cat tryp.c | ./tryp$exe_ext 2>/dev/null > tryp.out
if cmp tryp.c tryp.out >/dev/null 2>&1; then
$cat >&4 <<EOM
fflush(NULL) seems to behave okay with input streams.
--- 13974,13980 ----
set tryp
if eval $compile; then
$rm -f tryp.out
! $cat tryp.c | $run ./tryp 2>/dev/null > tryp.out
if cmp tryp.c tryp.out >/dev/null 2>&1; then
$cat >&4 <<EOM
fflush(NULL) seems to behave okay with input streams.
***************
*** 13506,13512 ****
set tryp
if eval $compile; then
$rm -f tryp.out
! $cat tryp.c | ./tryp$exe_ext 2>/dev/null > tryp.out
if cmp tryp.c tryp.out >/dev/null 2>&1; then
$cat >&4 <<EOM
Good, at least fflush(stdin) seems to behave okay when stdin is a pipe.
--- 14038,14044 ----
set tryp
if eval $compile; then
$rm -f tryp.out
! $cat tryp.c | $run ./tryp 2>/dev/null > tryp.out
if cmp tryp.c tryp.out >/dev/null 2>&1; then
$cat >&4 <<EOM
Good, at least fflush(stdin) seems to behave okay when stdin is a pipe.
***************
*** 13518,13526 ****
$cat >&4 <<EOM
(Now testing the other method--but note that this also may fail.)
EOM
! $rm -f try.out
! ./try$exe_ext 2>/dev/null
! if $test -s try.out -a "X$?" = X42; then
fflushall="`$cat try.out`"
fi
fi
--- 14050,14059 ----
$cat >&4 <<EOM
(Now testing the other method--but note that this also may fail.)
EOM
! $run ./try 2>/dev/null
! code=$?
! $from try.out
! if $test -s try.out -a "X$code" = X42; then
fflushall="`$cat try.out`"
fi
fi
***************
*** 13625,13631 ****
EOCP
set try
if eval $compile_ok; then
! yyy=`./try`
case "$yyy" in
'') gidsize=4
echo "(I can't execute the test program--guessing $gidsize.)" >&4
--- 14158,14164 ----
EOCP
set try
if eval $compile_ok; then
! yyy=`$run ./try`
case "$yyy" in
'') gidsize=4
echo "(I can't execute the test program--guessing $gidsize.)" >&4
***************
*** 13659,13665 ****
EOCP
set try
if eval $compile; then
! yyy=`./try`
case "$yyy" in
'') gidsign=1
echo "(I can't execute the test program--guessing unsigned.)" >&4
--- 14192,14198 ----
EOCP
set try
if eval $compile; then
! yyy=`$run ./try`
case "$yyy" in
'') gidsign=1
echo "(I can't execute the test program--guessing unsigned.)" >&4
***************
*** 13694,13700 ****
EOCP
set try
if eval $compile; then
! yyy=`./try$exe_ext`
case "$yyy" in
12345678901)
sPRId64='"d"'; sPRIi64='"i"'; sPRIu64='"u"';
--- 14227,14233 ----
EOCP
set try
if eval $compile; then
! yyy=`$run ./try`
case "$yyy" in
12345678901)
sPRId64='"d"'; sPRIi64='"i"'; sPRIu64='"u"';
***************
*** 13716,13722 ****
EOCP
set try
if eval $compile; then
! yyy=`./try$exe_ext`
case "$yyy" in
12345678901)
sPRId64='"ld"'; sPRIi64='"li"'; sPRIu64='"lu"';
--- 14249,14255 ----
EOCP
set try
if eval $compile; then
! yyy=`$run ./try`
case "$yyy" in
12345678901)
sPRId64='"ld"'; sPRIi64='"li"'; sPRIu64='"lu"';
***************
*** 13739,13745 ****
EOCP
set try
if eval $compile; then
! yyy=`./try$exe_ext`
case "$yyy" in
12345678901)
sPRId64=PRId64; sPRIi64=PRIi64; sPRIu64=PRIu64;
--- 14272,14278 ----
EOCP
set try
if eval $compile; then
! yyy=`$run ./try`
case "$yyy" in
12345678901)
sPRId64=PRId64; sPRIi64=PRIi64; sPRIu64=PRIu64;
***************
*** 13750,13794 ****
fi
fi
! if $test X"$sPRId64" = X -a X"$quadtype" = X"long long"; then
! $cat >try.c <<'EOCP'
#include <sys/types.h>
#include <stdio.h>
int main() {
! long long q = 12345678901LL; /* AIX cc requires the LL suffix. */
! printf("%lld\n", q);
}
EOCP
set try
if eval $compile; then
! yyy=`./try$exe_ext`
case "$yyy" in
12345678901)
! sPRId64='"lld"'; sPRIi64='"lli"'; sPRIu64='"llu"';
! sPRIo64='"llo"'; sPRIx64='"llx"'; sPRIXU64='"llX"';
! echo "We will use the %lld style."
;;
esac
fi
fi
! if $test X"$sPRId64" = X -a X"$quadtype" != X; then
! $cat >try.c <<EOCP
#include <sys/types.h>
#include <stdio.h>
int main() {
! $quadtype q = 12345678901;
! printf("%Ld\n", q);
}
EOCP
set try
if eval $compile; then
! yyy=`./try$exe_ext`
case "$yyy" in
12345678901)
! sPRId64='"Ld"'; sPRIi64='"Li"'; sPRIu64='"Lu"';
! sPRIo64='"Lo"'; sPRIx64='"Lx"'; sPRIXU64='"LX"';
! echo "We will use %Ld."
;;
esac
fi
--- 14283,14327 ----
fi
fi
! if $test X"$sPRId64" = X -a X"$quadtype" != X; then
! $cat >try.c <<EOCP
#include <sys/types.h>
#include <stdio.h>
int main() {
! $quadtype q = 12345678901;
! printf("%Ld\n", q);
}
EOCP
set try
if eval $compile; then
! yyy=`$run ./try`
case "$yyy" in
12345678901)
! sPRId64='"Ld"'; sPRIi64='"Li"'; sPRIu64='"Lu"';
! sPRIo64='"Lo"'; sPRIx64='"Lx"'; sPRIXU64='"LX"';
! echo "We will use %Ld."
;;
esac
fi
fi
! if $test X"$sPRId64" = X -a X"$quadtype" = X"long long"; then
! $cat >try.c <<'EOCP'
#include <sys/types.h>
#include <stdio.h>
int main() {
! long long q = 12345678901LL; /* AIX cc requires the LL suffix. */
! printf("%lld\n", q);
}
EOCP
set try
if eval $compile; then
! yyy=`$run ./try`
case "$yyy" in
12345678901)
! sPRId64='"lld"'; sPRIi64='"lli"'; sPRIu64='"llu"';
! sPRIo64='"llo"'; sPRIx64='"llx"'; sPRIXU64='"llX"';
! echo "We will use the %lld style."
;;
esac
fi
***************
*** 13805,13811 ****
EOCP
set try
if eval $compile; then
! yyy=`./try$exe_ext`
case "$yyy" in
12345678901)
sPRId64='"qd"'; sPRIi64='"qi"'; sPRIu64='"qu"';
--- 14338,14344 ----
EOCP
set try
if eval $compile; then
! yyy=`$run ./try`
case "$yyy" in
12345678901)
sPRId64='"qd"'; sPRIi64='"qi"'; sPRIu64='"qu"';
***************
*** 14126,14133 ****
}
EOCP
set try
! if eval $compile && ./try 2>&1 >/dev/null; then
! case "`./try`" in
"that's all right, then")
okay=yes
;;
--- 14659,14666 ----
}
EOCP
set try
! if eval $compile && $run ./try 2>&1 >/dev/null; then
! case "`$run ./try`" in
"that's all right, then")
okay=yes
;;
***************
*** 14375,14387 ****
$cc $ccflags -c foo.c >/dev/null 2>&1
$ar rc bar$_a bar2$_o bar1$_o >/dev/null 2>&1
if $cc -o foobar $ccflags $ldflags foo$_o bar$_a $libs > /dev/null 2>&1 &&
! ./foobar >/dev/null 2>&1; then
echo "$ar appears to generate random libraries itself."
orderlib=false
ranlib=":"
elif $ar ts bar$_a >/dev/null 2>&1 &&
$cc -o foobar $ccflags $ldflags foo$_o bar$_a $libs > /dev/null 2>&1 &&
! ./foobar >/dev/null 2>&1; then
echo "a table of contents needs to be added with '$ar ts'."
orderlib=false
ranlib="$ar ts"
--- 14908,14920 ----
$cc $ccflags -c foo.c >/dev/null 2>&1
$ar rc bar$_a bar2$_o bar1$_o >/dev/null 2>&1
if $cc -o foobar $ccflags $ldflags foo$_o bar$_a $libs > /dev/null 2>&1 &&
! $run ./foobar >/dev/null 2>&1; then
echo "$ar appears to generate random libraries itself."
orderlib=false
ranlib=":"
elif $ar ts bar$_a >/dev/null 2>&1 &&
$cc -o foobar $ccflags $ldflags foo$_o bar$_a $libs > /dev/null 2>&1 &&
! $run ./foobar >/dev/null 2>&1; then
echo "a table of contents needs to be added with '$ar ts'."
orderlib=false
ranlib="$ar ts"
***************
*** 14521,14527 ****
EOCP
set try
if eval $compile_ok; then
! selectminbits=`./try`
case "$selectminbits" in
'') cat >&4 <<EOM
Cannot figure out on how many bits at a time your select() operates.
--- 15054,15060 ----
EOCP
set try
if eval $compile_ok; then
! selectminbits=`$run ./try`
case "$selectminbits" in
'') cat >&4 <<EOM
Cannot figure out on how many bits at a time your select() operates.
***************
*** 14566,14572 ****
xxx=`echo '#include <signal.h>' |
$cppstdin $cppminus $cppflags 2>/dev/null |
$grep '^[ ]*#.*include' |
! $awk "{print \\$$fieldn}" | $sed 's!"!!g' | $sort | $uniq`
fi
: Check this list of files to be sure we have parsed the cpp output ok.
: This will also avoid potentially non-existent files, such
--- 15099,15105 ----
xxx=`echo '#include <signal.h>' |
$cppstdin $cppminus $cppflags 2>/dev/null |
$grep '^[ ]*#.*include' |
! $awk "{print \\$$fieldn}" | $sed 's!"!!g' | $sed 's!\\\\\\\\!/!g' | $sort | $uniq`
fi
: Check this list of files to be sure we have parsed the cpp output ok.
: This will also avoid potentially non-existent files, such
***************
*** 14713,14725 ****
set signal
if eval $compile_ok; then
! ./signal$_exe | $sort -n +1 | $uniq | $awk -f signal.awk >signal.lst
else
echo "(I can't seem be able to compile the whole test program)" >&4
echo "(I'll try it in little pieces.)" >&4
set signal -DJUST_NSIG
if eval $compile_ok; then
! ./signal$_exe > signal.nsg
$cat signal.nsg
else
echo "I can't seem to figure out how many signals you have." >&4
--- 15246,15258 ----
set signal
if eval $compile_ok; then
! $run ./signal$_exe | $sort -n +1 | $uniq | $awk -f signal.awk >signal.lst
else
echo "(I can't seem be able to compile the whole test program)" >&4
echo "(I'll try it in little pieces.)" >&4
set signal -DJUST_NSIG
if eval $compile_ok; then
! $run ./signal$_exe > signal.nsg
$cat signal.nsg
else
echo "I can't seem to figure out how many signals you have." >&4
***************
*** 14740,14746 ****
set signal
if eval $compile; then
echo "SIG${xx} found."
! ./signal$_exe >> signal.ls1
else
echo "SIG${xx} NOT found."
fi
--- 15273,15279 ----
set signal
if eval $compile; then
echo "SIG${xx} found."
! $run ./signal$_exe >> signal.ls1
else
echo "SIG${xx} NOT found."
fi
***************
*** 14831,14837 ****
EOCP
set try
if eval $compile_ok; then
! yyy=`./try`
case "$yyy" in
'') sizesize=4
echo "(I can't execute the test program--guessing $sizesize.)" >&4
--- 15364,15370 ----
EOCP
set try
if eval $compile_ok; then
! yyy=`$run ./try`
case "$yyy" in
'') sizesize=4
echo "(I can't execute the test program--guessing $sizesize.)" >&4
***************
*** 14925,14931 ****
set ssize_t ssizetype int stdio.h sys/types.h
eval $typedef
dflt="$ssizetype"
! $cat > ssize.c <<EOM
#include <stdio.h>
#include <sys/types.h>
#define Size_t $sizetype
--- 15458,15464 ----
set ssize_t ssizetype int stdio.h sys/types.h
eval $typedef
dflt="$ssizetype"
! $cat > try.c <<EOM
#include <stdio.h>
#include <sys/types.h>
#define Size_t $sizetype
***************
*** 14942,14950 ****
}
EOM
echo " "
! set ssize
! if eval $compile_ok && ./ssize > /dev/null; then
! ssizetype=`./ssize`
echo "I'll be using $ssizetype for functions returning a byte count." >&4
else
$cat >&4 <<EOM
--- 15475,15483 ----
}
EOM
echo " "
! set try
! if eval $compile_ok && $run ./try > /dev/null; then
! ssizetype=`$run ./try`
echo "I'll be using $ssizetype for functions returning a byte count." >&4
else
$cat >&4 <<EOM
***************
*** 14960,14966 ****
. ./myread
ssizetype="$ans"
fi
! $rm -f ssize ssize.*
: see what type of char stdio uses.
echo " "
--- 15493,15499 ----
. ./myread
ssizetype="$ans"
fi
! $rm -f try try.*
: see what type of char stdio uses.
echo " "
***************
*** 15034,15040 ****
EOCP
set try
if eval $compile_ok; then
! yyy=`./try`
case "$yyy" in
'') uidsize=4
echo "(I can't execute the test program--guessing $uidsize.)" >&4
--- 15567,15573 ----
EOCP
set try
if eval $compile_ok; then
! yyy=`$run ./try`
case "$yyy" in
'') uidsize=4
echo "(I can't execute the test program--guessing $uidsize.)" >&4
***************
*** 15067,15073 ****
EOCP
set try
if eval $compile; then
! yyy=`./try`
case "$yyy" in
'') uidsign=1
echo "(I can't execute the test program--guessing unsigned.)" >&4
--- 15600,15606 ----
EOCP
set try
if eval $compile; then
! yyy=`$run ./try`
case "$yyy" in
'') uidsign=1
echo "(I can't execute the test program--guessing unsigned.)" >&4
***************
*** 15155,15214 ****
;;
esac
- : see if dbm.h is available
- : see if dbmclose exists
- set dbmclose d_dbmclose
- eval $inlibc
-
- case "$d_dbmclose" in
- $define)
- set dbm.h i_dbm
- eval $inhdr
- case "$i_dbm" in
- $define)
- val="$undef"
- set i_rpcsvcdbm
- eval $setvar
- ;;
- *) set rpcsvc/dbm.h i_rpcsvcdbm
- eval $inhdr
- ;;
- esac
- ;;
- *) echo "We won't be including <dbm.h>"
- val="$undef"
- set i_dbm
- eval $setvar
- val="$undef"
- set i_rpcsvcdbm
- eval $setvar
- ;;
- esac
-
- : see if this is a sys/file.h system
- val=''
- set sys/file.h val
- eval $inhdr
-
- : do we need to include sys/file.h ?
- case "$val" in
- "$define")
- echo " "
- if $h_sysfile; then
- val="$define"
- echo "We'll be including <sys/file.h>." >&4
- else
- val="$undef"
- echo "We won't be including <sys/file.h>." >&4
- fi
- ;;
- *)
- h_sysfile=false
- ;;
- esac
- set i_sysfile
- eval $setvar
-
: see if fcntl.h is there
val=''
set fcntl.h val
--- 15688,15693 ----
***************
*** 15432,15443 ****
EOSH
cat <<'EOSH' >> Cppsym.try
'length($1) > 0 {
! printf "#ifdef %s\n#if %s+0\nprintf(\"%s=%%ld\\n\", %s);\n#else\nprintf(\"%s\\n\");\n#endif\n#endif\n", $1, $1, $1, $1, $1
! printf "#ifdef _%s\n#if _%s+0\nprintf(\"_%s=%%ld\\n\", _%s);\n#else\nprintf(\"_%s\\n\");\n#endif\n#endif\n", $1, $1, $1, $1, $1
! printf "#ifdef __%s\n#if __%s+0\nprintf(\"__%s=%%ld\\n\", __%s);\n#else\nprintf(\"__%s\\n\");\n#endif\n#endif\n", $1, $1, $1, $1, $1
! printf "#ifdef __%s__\n#if __%s__+0\nprintf(\"__%s__=%%ld\\n\", __%s__);\n#else\nprintf(\"__%s__\\n\");\n#endif\n#endif\n", $1, $1, $1, $1, $1
}' >> try.c
! echo '}' >> try.c
EOSH
cat <<EOSH >> Cppsym.try
ccflags="$ccflags"
--- 15911,15922 ----
EOSH
cat <<'EOSH' >> Cppsym.try
'length($1) > 0 {
! printf "#ifdef %s\n#if %s+0\nprintf(\"%s=%%ld\\n\", (long)%s);\n#else\nprintf(\"%s\\n\");\n#endif\n#endif\n", $1, $1, $1, $1, $1
! printf "#ifdef _%s\n#if _%s+0\nprintf(\"_%s=%%ld\\n\", (long)_%s);\n#else\nprintf(\"_%s\\n\");\n#endif\n#endif\n", $1, $1, $1, $1, $1
! printf "#ifdef __%s\n#if __%s+0\nprintf(\"__%s=%%ld\\n\", (long)__%s);\n#else\nprintf(\"__%s\\n\");\n#endif\n#endif\n", $1, $1, $1, $1, $1
! printf "#ifdef __%s__\n#if __%s__+0\nprintf(\"__%s__=%%ld\\n\", (long)__%s__);\n#else\nprintf(\"__%s__\\n\");\n#endif\n#endif\n", $1, $1, $1, $1, $1
}' >> try.c
! echo 'return 0;}' >> try.c
EOSH
cat <<EOSH >> Cppsym.try
ccflags="$ccflags"
***************
*** 15445,15451 ****
irix-) ccflags="\$ccflags -woff 1178" ;;
os2-*) ccflags="\$ccflags -Zlinker /PM:VIO" ;;
esac
! $cc -o try $optimize \$ccflags $ldflags try.c $libs && ./try$exe_ext
EOSH
chmod +x Cppsym.try
$eunicefix Cppsym.try
--- 15924,15930 ----
irix-) ccflags="\$ccflags -woff 1178" ;;
os2-*) ccflags="\$ccflags -Zlinker /PM:VIO" ;;
esac
! $cc -o try $optimize \$ccflags $ldflags try.c $libs && $run ./try
EOSH
chmod +x Cppsym.try
$eunicefix Cppsym.try
***************
*** 15525,15531 ****
$test "$silent" || sleep 1
fi
fi
- $rm -f ccsym* Cppsym.*
: see if this is a termio system
val="$undef"
--- 16004,16009 ----
***************
*** 15778,15788 ****
$define) avail_ext="$avail_ext $xxx" ;;
esac
;;
NDBM_File|ndbm_fil)
case "$i_ndbm" in
$define)
case "$osname-$use64bitint" in
! hpux-define)
case "$libs" in
*-lndbm*) avail_ext="$avail_ext $xxx" ;;
esac
--- 16256,16271 ----
$define) avail_ext="$avail_ext $xxx" ;;
esac
;;
+ I18N/Langinfo|i18n_lan)
+ case "$i_langinfo$d_nl_langinfo" in
+ $define$define) avail_ext="$avail_ext $xxx" ;;
+ esac
+ ;;
NDBM_File|ndbm_fil)
case "$i_ndbm" in
$define)
case "$osname-$use64bitint" in
! cygwin-*|hpux-define)
case "$libs" in
*-lndbm*) avail_ext="$avail_ext $xxx" ;;
esac
***************
*** 15796,15802 ****
case "${i_dbm}${i_rpcsvcdbm}" in
*"${define}"*)
case "$osname-$use64bitint" in
! hpux-define)
case "$libs" in
*-ldbm*) avail_ext="$avail_ext $xxx" ;;
esac
--- 16279,16285 ----
case "${i_dbm}${i_rpcsvcdbm}" in
*"${define}"*)
case "$osname-$use64bitint" in
! cygwin-*|hpux-define)
case "$libs" in
*-ldbm*) avail_ext="$avail_ext $xxx" ;;
esac
***************
*** 15828,15835 ****
esac
;;
Thread|thread)
! case "$usethreads" in
! true|$define|y) avail_ext="$avail_ext $xxx" ;;
esac
;;
IPC/SysV|ipc/sysv)
--- 16311,16321 ----
esac
;;
Thread|thread)
! case "$usethreads" in
! true|$define|y)
! case "$useithreads" in
! $undef|false|[nN]*) avail_ext="$avail_ext $xxx" ;;
! esac
esac
;;
IPC/SysV|ipc/sysv)
***************
*** 16074,16079 ****
--- 16560,16566 ----
_exe='$_exe'
_o='$_o'
afs='$afs'
+ afsroot='$afsroot'
alignbytes='$alignbytes'
ansi2knr='$ansi2knr'
aphostname='$aphostname'
***************
*** 16129,16135 ****
cpprun='$cpprun'
cppstdin='$cppstdin'
cppsymbols='$cppsymbols'
- crosscompile='$crosscompile'
cryptlib='$cryptlib'
csh='$csh'
d_Gconvert='$d_Gconvert'
--- 16616,16621 ----
***************
*** 16174,16179 ****
--- 16660,16666 ----
d_csh='$d_csh'
d_cuserid='$d_cuserid'
d_dbl_dig='$d_dbl_dig'
+ d_dbminitproto='$d_dbminitproto'
d_difftime='$d_difftime'
d_dirnamlen='$d_dirnamlen'
d_dlerror='$d_dlerror'
***************
*** 16191,16196 ****
--- 16678,16684 ----
d_endsent='$d_endsent'
d_eofnblk='$d_eofnblk'
d_eunice='$d_eunice'
+ d_fchdir='$d_fchdir'
d_fchmod='$d_fchmod'
d_fchown='$d_fchown'
d_fcntl='$d_fcntl'
***************
*** 16201,16206 ****
--- 16689,16695 ----
d_fgetpos='$d_fgetpos'
d_flexfnam='$d_flexfnam'
d_flock='$d_flock'
+ d_flockproto='$d_flockproto'
d_fork='$d_fork'
d_fpathconf='$d_fpathconf'
d_fpos64_t='$d_fpos64_t'
***************
*** 16287,16292 ****
--- 16776,16782 ----
d_mktime='$d_mktime'
d_mmap='$d_mmap'
d_modfl='$d_modfl'
+ d_modfl_pow32_bug='$d_modfl_pow32_bug'
d_mprotect='$d_mprotect'
d_msg='$d_msg'
d_msg_ctrunc='$d_msg_ctrunc'
***************
*** 16303,16308 ****
--- 16793,16799 ----
d_munmap='$d_munmap'
d_mymalloc='$d_mymalloc'
d_nice='$d_nice'
+ d_nl_langinfo='$d_nl_langinfo'
d_nv_preserves_uv='$d_nv_preserves_uv'
d_nv_preserves_uv_bits='$d_nv_preserves_uv_bits'
d_off64_t='$d_off64_t'
***************
*** 16317,16322 ****
--- 16808,16814 ----
d_pipe='$d_pipe'
d_poll='$d_poll'
d_portable='$d_portable'
+ d_pthread_atfork='$d_pthread_atfork'
d_pthread_yield='$d_pthread_yield'
d_pwage='$d_pwage'
d_pwchange='$d_pwchange'
***************
*** 16386,16396 ****
--- 16878,16891 ----
d_sigprocmask='$d_sigprocmask'
d_sigsetjmp='$d_sigsetjmp'
d_sockatmark='$d_sockatmark'
+ d_sockatmarkproto='$d_sockatmarkproto'
d_socket='$d_socket'
d_socklen_t='$d_socklen_t'
d_sockpair='$d_sockpair'
d_socks5_init='$d_socks5_init'
d_sqrtl='$d_sqrtl'
+ d_sresgproto='$d_sresgproto'
+ d_sresuproto='$d_sresuproto'
d_statblks='$d_statblks'
d_statfs_f_flags='$d_statfs_f_flags'
d_statfs_s='$d_statfs_s'
***************
*** 16407,16412 ****
--- 16902,16908 ----
d_strctcpy='$d_strctcpy'
d_strerrm='$d_strerrm'
d_strerror='$d_strerror'
+ d_strftime='$d_strftime'
d_strtod='$d_strtod'
d_strtol='$d_strtol'
d_strtold='$d_strtold'
***************
*** 16419,16424 ****
--- 16915,16921 ----
d_suidsafe='$d_suidsafe'
d_symlink='$d_symlink'
d_syscall='$d_syscall'
+ d_syscallproto='$d_syscallproto'
d_sysconf='$d_sysconf'
d_sysernlst='$d_sysernlst'
d_syserrlst='$d_syserrlst'
***************
*** 16437,16442 ****
--- 16934,16940 ----
d_uname='$d_uname'
d_union_semun='$d_union_semun'
d_usleep='$d_usleep'
+ d_usleepproto='$d_usleepproto'
d_ustat='$d_ustat'
d_vendorarch='$d_vendorarch'
d_vendorbin='$d_vendorbin'
***************
*** 16456,16461 ****
--- 16954,16962 ----
date='$date'
db_hashtype='$db_hashtype'
db_prefixtype='$db_prefixtype'
+ db_version_major='$db_version_major'
+ db_version_minor='$db_version_minor'
+ db_version_patch='$db_version_patch'
defvoidused='$defvoidused'
direntrytype='$direntrytype'
dlext='$dlext'
***************
*** 16480,16485 ****
--- 16981,16987 ----
fpossize='$fpossize'
fpostype='$fpostype'
freetype='$freetype'
+ from='$from'
full_ar='$full_ar'
full_csh='$full_csh'
full_sed='$full_sed'
***************
*** 16520,16525 ****
--- 17022,17028 ----
i_iconv='$i_iconv'
i_ieeefp='$i_ieeefp'
i_inttypes='$i_inttypes'
+ i_langinfo='$i_langinfo'
i_libutil='$i_libutil'
i_limits='$i_limits'
i_locale='$i_locale'
***************
*** 16703,16708 ****
--- 17206,17212 ----
path_sep='$path_sep'
perl5='$perl5'
perl='$perl'
+ perl_patchlevel='$perl_patchlevel'
perladmin='$perladmin'
perllibs='$perllibs'
perlpath='$perlpath'
***************
*** 16729,16734 ****
--- 17233,17239 ----
revision='$revision'
rm='$rm'
rmail='$rmail'
+ run='$run'
runnm='$runnm'
sPRIEUldbl='$sPRIEUldbl'
sPRIFUldbl='$sPRIFUldbl'
***************
*** 16803,16813 ****
--- 17308,17320 ----
sysman='$sysman'
tail='$tail'
tar='$tar'
+ targetarch='$targetarch'
tbl='$tbl'
tee='$tee'
test='$test'
timeincl='$timeincl'
timetype='$timetype'
+ to='$to'
touch='$touch'
tr='$tr'
trnl='$trnl'
***************
*** 16830,16835 ****
--- 17337,17343 ----
use5005threads='$use5005threads'
use64bitall='$use64bitall'
use64bitint='$use64bitint'
+ usecrosscompile='$usecrosscompile'
usedl='$usedl'
useithreads='$useithreads'
uselargefiles='$uselargefiles'
***************
*** 16841,16846 ****
--- 17349,17355 ----
useopcode='$useopcode'
useperlio='$useperlio'
useposix='$useposix'
+ usereentrant='$usereentrant'
usesfio='$usesfio'
useshrplib='$useshrplib'
usesocks='$usesocks'
***************
*** 16865,16870 ****
--- 17374,17380 ----
vendorprefix='$vendorprefix'
vendorprefixexp='$vendorprefixexp'
version='$version'
+ version_patchlevel_string='$version_patchlevel_string'
versiononly='$versiononly'
vi='$vi'
voidflags='$voidflags'
***************
*** 16882,16888 ****
: add special variables
$test -f $src/patchlevel.h && \
awk '/^#define[ ]+PERL_/ {printf "%s=%s\n",$2,$3}' $src/patchlevel.h >>config.sh
! echo "CONFIGDOTSH=true" >>config.sh
: propagate old symbols
if $test -f UU/config.sh; then
--- 17392,17399 ----
: add special variables
$test -f $src/patchlevel.h && \
awk '/^#define[ ]+PERL_/ {printf "%s=%s\n",$2,$3}' $src/patchlevel.h >>config.sh
! echo "PERL_PATCHLEVEL=$perl_patchlevel" >>config.sh
! echo "PERL_CONFIG_SH=true" >>config.sh
: propagate old symbols
if $test -f UU/config.sh; then
***************
*** 16912,16918 ****
case "$alldone" in
exit)
$rm -rf UU
! echo "Done."
exit 0
;;
cont)
--- 17423,17429 ----
case "$alldone" in
exit)
$rm -rf UU
! echo "Extraction done."
exit 0
;;
cont)
***************
*** 16942,16948 ****
--- 17453,17461 ----
echo " "
exec 1>&4
+ pwd=`pwd`
. ./UU/extract
+ cd $pwd
if $contains '^depend:' [Mm]akefile >/dev/null 2>&1; then
dflt=y
***************
*** 16972,16978 ****
echo " "
echo "Now you must run a $make."
else
! echo "Done."
fi
if $test -f Policy.sh; then
--- 17485,17491 ----
echo " "
echo "Now you must run a $make."
else
! echo "Configure done."
fi
if $test -f Policy.sh; then
diff -c /dev/null 'perl-5.7.2/Cross/README'
Index: ./Cross/README
*** ./Cross/README Thu Jan 1 02:00:00 1970
--- ./Cross/README Mon Jul 9 17:09:38 2001
***************
*** 0 ****
--- 1,4 ----
+ If Perl is built using a cross-compilation environment the Cross
+ directory will contain temporary helper scripts for the duration
+ of the build, see INSTALL/Cross-compilation for more information.
+
diff -c 'perl-5.7.1/INSTALL' 'perl-5.7.2/INSTALL'
Index: ./INSTALL
Prereq: 1.58
*** ./INSTALL Mon Mar 19 04:00:56 2001
--- ./INSTALL Mon Jul 9 17:09:38 2001
***************
*** 42,50 ****
make test
make install
! For information on non-Unix systems, see the section on
! L<"Porting information"> below.
If you have problems, corrections, or questions, please see
L<"Reporting Problems"> below.
--- 42,55 ----
make test
make install
! For information on non-Unix systems, see the section on L<"Porting
! information"> below.
+ If "make install" just says "`install' is up to date" or something
+ similar, you may be on case-preserving filesystems such as Mac's HFS+
+ and you should say "make install-all". (This confusion brought to you
+ by the Perl distribution having a file called INSTALL.)
+
If you have problems, corrections, or questions, please see
L<"Reporting Problems"> below.
***************
*** 178,187 ****
=head1 Space Requirements
! The complete perl5 source tree takes up about 20 MB of disk space.
! After completing make, it takes up roughly 30 MB, though the actual
total is likely to be quite system-dependent. The installation
! directories need something on the order of 20 MB, though again that
value is system-dependent.
=head1 Start with a Fresh Distribution
--- 183,192 ----
=head1 Space Requirements
! The complete perl5 source tree takes up about 35 MB of disk space.
! After completing make, it takes up roughly 50 MB, though the actual
total is likely to be quite system-dependent. The installation
! directories need something on the order of 30 MB, though again that
value is system-dependent.
=head1 Start with a Fresh Distribution
***************
*** 725,735 ****
Eventually (by perl v5.6.0) this internal confusion ought to disappear,
and these options may disappear as well.
=head2 64 bit support.
! If your platform does not have 64 bits natively, but can simulate them with
! compiler flags and/or C<long long> or C<int64_t>, you can build a perl that
! uses 64 bits.
There are actually two modes of 64-bitness: the first one is achieved
using Configure -Duse64bitint and the second one using Configure
--- 730,759 ----
Eventually (by perl v5.6.0) this internal confusion ought to disappear,
and these options may disappear as well.
+ =head2 Large file support.
+
+ Since Perl 5.6.0 Perl has supported large files (files larger than
+ 2 gigabytes), and in many common platforms like Linux or Solaris this
+ support is on by default.
+
+ This is both good and bad. It is good in that you can use large files,
+ seek(), stat(), and -s them. It is bad if you are interfacing Perl
+ using some extension, also the components you are connecting to must
+ be large file aware: if Perl thinks files can be large but the other
+ parts of the software puzzle do not understand the concept, bad things
+ will happen. One popular extension suffering from this ailment is the
+ Apache extension mod_perl.
+
+ There's also one known limitation with the current large files
+ implementation: unless you also have 64-bit integers (see the next
+ section), you cannot use the printf/sprintf non-decimal integer
+ formats like C<%x> to print filesizes. You can use C<%d>, though.
+
=head2 64 bit support.
! If your platform does not have 64 bits natively, but can simulate them
! with compiler flags and/or C<long long> or C<int64_t>, you can build a
! perl that uses 64 bits.
There are actually two modes of 64-bitness: the first one is achieved
using Configure -Duse64bitint and the second one using Configure
***************
*** 891,898 ****
To build a shared libperl, the environment variable controlling shared
library search (LD_LIBRARY_PATH in most systems, DYLD_LIBRARY_PATH for
! NeXTSTEP/OPENSTEP/Darwin, LIBRARY_PATH for BeOS, SHLIB_PATH for
! HP-UX, LIBPATH for AIX, PATH for Cygwin) must be set up to include
the Perl build directory because that's where the shared libperl will
be created. Configure arranges makefile to have the correct shared
library search settings.
--- 915,922 ----
To build a shared libperl, the environment variable controlling shared
library search (LD_LIBRARY_PATH in most systems, DYLD_LIBRARY_PATH for
! NeXTSTEP/OPENSTEP/Darwin, LIBRARY_PATH for BeOS, LD_LIBRARY_PATH/SHLIB_PATH
! for HP-UX, LIBPATH for AIX, PATH for Cygwin) must be set up to include
the Perl build directory because that's where the shared libperl will
be created. Configure arranges makefile to have the correct shared
library search settings.
***************
*** 1390,1395 ****
--- 1414,1439 ----
=back
+ =head1 suidperl
+
+ suidperl is an optional component, which is built or installed by default.
+ From perlfaq1:
+
+ On some systems, setuid and setgid scripts (scripts written
+ in the C shell, Bourne shell, or Perl, for example, with the
+ set user or group ID permissions enabled) are insecure due to
+ a race condition in the kernel. For those systems, Perl versions
+ 5 and 4 attempt to work around this vulnerability with an optional
+ component, a special program named suidperl, also known as sperl.
+ This program attempts to emulate the set-user-ID and set-group-ID
+ features of the kernel.
+
+ Because of the buggy history of suidperl, and the difficulty
+ of properly security auditing as large and complex piece of
+ software as Perl, we cannot recommend using suidperl and the feature
+ should be considered deprecated.
+ Instead use for example 'sudo': http://www.courtesan.com/sudo/
+
=head1 make depend
This will look for all the includes. The output is stored in makefile.
***************
*** 1693,1698 ****
--- 1737,1846 ----
=back
+ =head2 Cross-compilation
+
+ Starting from Perl 5.8 Perl has the beginnings of cross-compilation
+ support. What is known to work is running Configure in a
+ cross-compilation environment and building the miniperl executable.
+ What is known not work work is building the perl executable because
+ that would require building extensions: Dynaloader statically and
+ File::Glob dynamically, for extensions one needs MakeMaker and
+ MakeMaker is not yet cross-compilation aware, and neither is
+ the main Makefile.
+
+ Since the functionality is so lacking, it must be considered
+ highly experimental. It is so experimental that it is not even
+ mentioned during an interactive Configure session, a direct command
+ line invocation (detailed shortly) is required to access the
+ functionality.
+
+ NOTE: Perl is routinely built using cross-compilation
+ in the EPOC environment but the solutions from there
+ can't directly be used elsewhere.
+
+ The one environment where cross-compilation has successfully been used
+ as of this writing is the Compaq iPAQ running ARM Linux. The build
+ host was Intel Linux, the networking setup was PPP + SSH. The exact
+ setup details are beyond the scope of this document, see
+ http://www.handhelds.org/ for more information.
+
+ To run Configure in cross-compilation mode the basic switch is
+ C<-Dusecrosscompile>.
+
+ sh ./Configure -des -Dusecrosscompile -D...
+
+ This will make the cpp symbol USE_CROSS_COMPILE and the %Config
+ symbol C<usecrosscompile> available.
+
+ During the Configure and build, certain helper scripts will be created
+ into the Cross/ subdirectory. The scripts are used to execute a
+ cross-compiled executable, and to transfer files to and from the
+ target host. The execution scripts are named F<run-*> and the
+ transfer scripts F<to-*> and F<from-*>. The part after the dash is
+ the method to use for remote execution and transfer: by default the
+ methods are B<ssh> and B<scp>, thus making the scripts F<run-ssh>,
+ F<to-scp>, and F<from-scp>.
+
+ To configure the scripts for a target host and a directory (in which
+ the execution will happen and which is to and from where the transfer
+ happens), supply Configure with
+
+ -Dtargethost=so.me.ho.st -Dtargetdir=/tar/get/dir
+
+ The targethost is what e.g. ssh will use as the hostname, the targetdir
+ must exist (the scripts won't create it), the targetdir defaults to /tmp.
+ You can also specify a username to use for ssh/rsh logins
+
+ -Dtargetuser=luser
+
+ but in case you don't, "root" will be used.
+
+ Because this is a cross-compilation effort, you will also need to specify
+ which target environment and which compilation environment to use.
+ This includes the compiler, the header files, and the libraries.
+ In the below we use the usual settings for the iPAQ cross-compilation
+ environment:
+
+ -Dtargetarch=arm-linux
+ -Dcc=arm-linux-gcc
+ -Dusrinc=/skiff/local/arm-linux/include
+ -Dincpth=/skiff/local/arm-linux/include
+ -Dlibpth=/skiff/local/arm-linux/lib
+
+ If the name of the C<cc> has the usual GNU C semantics for cross
+ compilers, that is, CPU-OS-gcc, the names of the C<ar>, C<nm>, and
+ C<ranlib> will also be automatically chosen to be CPU-OS-ar and so on.
+ (The C<ld> requires more thought and will be chosen later by Configure
+ as appropriate.) Also, in this case the incpth, libpth, and usrinc
+ will be guessed by Configure (unless explicitly set to something else,
+ in which case Configure's guesses with be appended).
+
+ In addition to the default execution/transfer methods you can also
+ choose B<rsh> for execution, and B<rcp> or B<cp> for transfer,
+ for example:
+
+ -Dtargetrun=rsh -Dtargetto=rcp -Dtargetfrom=cp
+
+ Putting it all together:
+
+ sh ./Configure -des -Dusecrosscompile \
+ -Dtargethost=so.me.ho.st \
+ -Dtargetdir=/tar/get/dir \
+ -Dtargetuser=root \
+ -Dtargetarch=arm-linux \
+ -Dcc=arm-linux-gcc \
+ -Dusrinc=/skiff/local/arm-linux/include \
+ -Dincpth=/skiff/local/arm-linux/include \
+ -Dlibpth=/skiff/local/arm-linux/lib \
+ -D...
+
+ or if you are happy with the defaults
+
+ sh ./Configure -des -Dusecrosscompile \
+ -Dtargethost=so.me.ho.st \
+ -Dcc=arm-linux-gcc \
+ -D...
+
=head1 make test
This will run the regression tests on the perl you just made. If
***************
*** 2162,2167 ****
a larger package) please B<do> modify these installation instructions
and the contact information to match your distribution.
- =head1 LAST MODIFIED
-
- $Id: INSTALL,v 1.58 1999/07/23 14:43:00 doughera Exp $
--- 2310,2312 ----
diff -c 'perl-5.7.1/MANIFEST' 'perl-5.7.2/MANIFEST'
Index: ./MANIFEST
*** ./MANIFEST Mon Apr 9 16:55:03 2001
--- ./MANIFEST Fri Jul 13 04:13:28 2001
***************
*** 1,5 ****
! AUTHORS Contact info for contributors
Artistic The "Artistic License"
Changes Differences from previous version
Changes5.000 Differences between 4.x and 5.000
Changes5.001 Differences between 5.000 and 5.001
--- 1,12 ----
! apollo/netinet/in.h Apollo DomainOS port: C header file frontend
Artistic The "Artistic License"
+ AUTHORS Contact info for contributors
+ av.c Array value code
+ av.h Array value header
+ beos/nm.c BeOS port
+ bytecode.pl Produces ext/ByteLoader/byterun.h, ext/ByteLoader/byterun.c and ext/B/Asmdata.pm
+ cc_runtime.h Macros need by runtime of compiler-generated code
+ cflags.SH A script that emits C compilation flags per file
Changes Differences from previous version
Changes5.000 Differences between 4.x and 5.000
Changes5.001 Differences between 5.000 and 5.001
***************
*** 8,88 ****
Changes5.004 Differences between 5.003 and 5.004
Changes5.005 Differences between 5.004 and 5.005
Changes5.6 Differences between 5.005 and 5.6
- Configure Portability tool
- Copying The GNU General Public License
- EXTERN.h Included before foreign .h files
- INSTALL Detailed installation instructions
- INTERN.h Included before domestic .h files
- MANIFEST This list of files
- Makefile.SH A script that generates Makefile
- Makefile.micro microperl Makefile
- Policy_sh.SH Hold site-wide preferences between Configure runs.
- Porting/Contract Social contract for contributed modules in Perl core
- Porting/Glossary Glossary of config.sh variables
- Porting/config.sh Sample config.sh
- Porting/config_H Sample config.h
- Porting/findvars Find occurrences of words
- Porting/fixCORE Find and fix modules that generate warnings
- Porting/fixvars Find undeclared variables with C compiler and fix em
- Porting/genlog Generate formatted changelogs by querying p4d
- Porting/makerel Release making utility
- Porting/p4d2p Generate standard patches from p4 diffs
- Porting/p4desc Smarter 'p4 describe', outputs diffs for new files
- Porting/patching.pod How to report changes made to Perl
- Porting/patchls Flexible patch file listing utility
- Porting/pumpkin.pod Guidelines and hints for Perl maintainers
- Porting/repository.pod How to use the Perl repository
- README The Instructions
- README.Y2K Notes about Year 2000 concerns
- README.aix Notes about AIX port
- README.amiga Notes about AmigaOS port
- README.apollo Notes about Apollo DomainOS port
- README.beos Notes about BeOS port
- README.bs2000 Notes about BS2000 POSIX port
- README.cygwin Notes about Cygwin port
- README.dos Notes about dos/djgpp port
- README.epoc Notes about EPOC port
- README.hpux Notes about HP-UX port
- README.hurd Notes about GNU/Hurd port
- README.machten Notes about Power MachTen port
- README.macos Notes about Mac OS (Classic)
- README.micro Notes about microperl
- README.mint Notes about Atari MiNT port
- README.mpeix Notes about MPE/iX port
- README.os2 Notes about OS/2 port
- README.os390 Notes about OS/390 (nee MVS) port
- README.plan9 Notes about Plan9 port
- README.qnx Notes about QNX port
- README.solaris Notes about Solaris port
- README.threads Notes about multithreading
- README.vmesa Notes about VM/ESA port
- README.vms Notes about installing the VMS port
- README.vos Notes about Stratus VOS port
- README.win32 Notes about Win32 port
- Todo The Wishlist
- Todo-5.6 What needs doing before/during the 5.6.x release cycle
- Todo.micro The Wishlist for microperl
- XSUB.h Include file for extension subroutines
- apollo/netinet/in.h Apollo DomainOS port: C header file frontend
- av.c Array value code
- av.h Array value header
- beos/nm.c BeOS port
- bytecode.pl Produces ext/ByteLoader/byterun.h, ext/ByteLoader/byterun.c and ext/B/Asmdata.pm
- cc_runtime.h Macros need by runtime of compiler-generated code
- cflags.SH A script that emits C compilation flags per file
config_h.SH Produces config.h
configpm Produces lib/Config.pm
configure.com Configure-equivalent for VMS
configure.gnu Crude emulation of GNU configure
cop.h Control operator header
cv.h Code value header
- cygwin/Makefile.SHs Shared library generation for Cygwin port
cygwin/cygwin.c Additional code for Cygwin port
cygwin/ld2.in ld wrapper template for Cygwin port
cygwin/perlld.in dll generator template for Cygwin port
deb.c Debugging routines
! djgpp/config.over DOS/DJGPP port
! djgpp/configure.bat DOS/DJGPP port
djgpp/djgpp.c DOS/DJGPP port
djgpp/djgppsed.sh DOS/DJGPP port
djgpp/fixpmain DOS/DJGPP port
--- 15,36 ----
Changes5.004 Differences between 5.003 and 5.004
Changes5.005 Differences between 5.004 and 5.005
Changes5.6 Differences between 5.005 and 5.6
config_h.SH Produces config.h
configpm Produces lib/Config.pm
+ Configure Portability tool
configure.com Configure-equivalent for VMS
configure.gnu Crude emulation of GNU configure
cop.h Control operator header
+ Copying The GNU General Public License
+ Cross/README Cross-compilation
cv.h Code value header
cygwin/cygwin.c Additional code for Cygwin port
cygwin/ld2.in ld wrapper template for Cygwin port
+ cygwin/Makefile.SHs Shared library generation for Cygwin port
cygwin/perlld.in dll generator template for Cygwin port
deb.c Debugging routines
! djgpp/config.over DOS/DJGPP port
! djgpp/configure.bat DOS/DJGPP port
djgpp/djgpp.c DOS/DJGPP port
djgpp/djgppsed.sh DOS/DJGPP port
djgpp/fixpmain DOS/DJGPP port
***************
*** 102,137 ****
epoc/epoc_stubs.c EPOC port
epoc/epocish.c EPOC port
epoc/epocish.h EPOC port
! epoc/link.pl EPOC port link a exe
ext/B/B.pm Compiler backend support functions and methods
ext/B/B.xs Compiler backend external subroutines
ext/B/B/Asmdata.pm Compiler backend data for assembler
ext/B/B/Assembler.pm Compiler backend assembler support functions
ext/B/B/Bblock.pm Compiler basic block analysis support
ext/B/B/Bytecode.pm Compiler Bytecode backend
ext/B/B/C.pm Compiler C backend
ext/B/B/CC.pm Compiler CC backend
ext/B/B/Concise.pm Compiler Concise backend
ext/B/B/Debug.pm Compiler Debug backend
ext/B/B/Deparse.pm Compiler Deparse backend
ext/B/B/Disassembler.pm Compiler Disassembler backend
ext/B/B/Lint.pm Compiler Lint backend
ext/B/B/Showlex.pm Compiler Showlex backend
ext/B/B/Stackobj.pm Compiler stack objects support functions
ext/B/B/Stash.pm Compiler module to identify stashes
ext/B/B/Terse.pm Compiler Terse backend
ext/B/B/Xref.pm Compiler Xref backend
! ext/B/B/assemble Assemble compiler bytecode
! ext/B/B/cc_harness Simplistic wrapper for using -MO=CC compiler
! ext/B/B/disassemble Disassemble compiler bytecode output
! ext/B/B/makeliblinks Make a simplistic XSUB .so symlink tree for compiler
ext/B/Makefile.PL Compiler backend makefile writer
ext/B/NOTES Compiler backend notes
ext/B/O.pm Compiler front-end module (-MO=...)
- ext/B/README Compiler backend README
- ext/B/TESTS Compiler backend test data
- ext/B/Todo Compiler backend Todo list
- ext/B/defsubs_h.PL Generator for constant subroutines
ext/B/ramblings/cc.notes Compiler ramblings: notes on CC backend
ext/B/ramblings/curcop.runtime Compiler ramblings: notes on curcop use
ext/B/ramblings/flip-flop Compiler ramblings: notes on flip-flop
--- 50,89 ----
epoc/epoc_stubs.c EPOC port
epoc/epocish.c EPOC port
epoc/epocish.h EPOC port
! epoc/link.pl EPOC port link a exe
! ext/attrs.t See if attrs works with C<sub : attrs>
! ext/attrs/attrs.pm attrs extension Perl module
! ext/attrs/attrs.xs attrs extension external subroutines
! ext/attrs/Makefile.PL attrs extension makefile writer
ext/B/B.pm Compiler backend support functions and methods
+ ext/B/B.t See if B works
ext/B/B.xs Compiler backend external subroutines
ext/B/B/Asmdata.pm Compiler backend data for assembler
+ ext/B/B/assemble Assemble compiler bytecode
ext/B/B/Assembler.pm Compiler backend assembler support functions
ext/B/B/Bblock.pm Compiler basic block analysis support
ext/B/B/Bytecode.pm Compiler Bytecode backend
ext/B/B/C.pm Compiler C backend
ext/B/B/CC.pm Compiler CC backend
+ ext/B/B/cc_harness Simplistic wrapper for using -MO=CC compiler
ext/B/B/Concise.pm Compiler Concise backend
ext/B/B/Debug.pm Compiler Debug backend
ext/B/B/Deparse.pm Compiler Deparse backend
+ ext/B/B/disassemble Disassemble compiler bytecode output
ext/B/B/Disassembler.pm Compiler Disassembler backend
ext/B/B/Lint.pm Compiler Lint backend
+ ext/B/B/makeliblinks Make a simplistic XSUB .so symlink tree for compiler
ext/B/B/Showlex.pm Compiler Showlex backend
ext/B/B/Stackobj.pm Compiler stack objects support functions
ext/B/B/Stash.pm Compiler module to identify stashes
ext/B/B/Terse.pm Compiler Terse backend
ext/B/B/Xref.pm Compiler Xref backend
! ext/B/Debug.t See if B::Debug works
! ext/B/defsubs_h.PL Generator for constant subroutines
! ext/B/Deparse.t See if B::Deparse works
ext/B/Makefile.PL Compiler backend makefile writer
ext/B/NOTES Compiler backend notes
ext/B/O.pm Compiler front-end module (-MO=...)
ext/B/ramblings/cc.notes Compiler ramblings: notes on CC backend
ext/B/ramblings/curcop.runtime Compiler ramblings: notes on curcop use
ext/B/ramblings/flip-flop Compiler ramblings: notes on flip-flop
***************
*** 138,168 ****
ext/B/ramblings/magic Compiler ramblings: notes on magic
ext/B/ramblings/reg.alloc Compiler ramblings: register allocation
ext/B/ramblings/runtime.porting Compiler ramblings: porting PP enging
! ext/B/typemap Compiler backend interface types
ext/ByteLoader/ByteLoader.pm Bytecode loader Perl module
ext/ByteLoader/ByteLoader.xs Bytecode loader external subroutines
- ext/ByteLoader/Makefile.PL Bytecode loader makefile writer
- ext/ByteLoader/bytecode.h Bytecode header for bytecode loader
ext/ByteLoader/byterun.c Runtime support for bytecode loader
ext/ByteLoader/byterun.h Header for byterun.c
ext/ByteLoader/hints/sunos.pl Hints for named architecture
! ext/Cwd/Cwd.xs Cwd extension external subroutines
! ext/Cwd/Makefile.PL Cwd extension makefile maker
! ext/DB_File/Changes Berkeley DB extension change log
! ext/DB_File/DB_File.pm Berkeley DB extension Perl module
! ext/DB_File/DB_File.xs Berkeley DB extension external subroutines
! ext/DB_File/DB_File_BS Berkeley DB extension mkbootstrap fodder
! ext/DB_File/Makefile.PL Berkeley DB extension makefile writer
! ext/DB_File/dbinfo Berkeley DB database version checker
! ext/DB_File/hints/dynixptx.pl Hint for DB_File for named architecture
! ext/DB_File/hints/sco.pl Hint for DB_File for named architecture
! ext/DB_File/typemap Berkeley DB extension interface types
! ext/DB_File/version.c Berkeley DB extension interface version check
ext/Data/Dumper/Changes Data pretty printer, changelog
ext/Data/Dumper/Dumper.pm Data pretty printer, module
ext/Data/Dumper/Dumper.xs Data pretty printer, externals
ext/Data/Dumper/Makefile.PL Data pretty printer, makefile writer
ext/Data/Dumper/Todo Data pretty printer, futures
ext/Devel/DProf/Changes Perl code profiler changelog
ext/Devel/DProf/DProf.pm Perl code profiler
ext/Devel/DProf/DProf.xs Perl code profiler
--- 90,131 ----
ext/B/ramblings/magic Compiler ramblings: notes on magic
ext/B/ramblings/reg.alloc Compiler ramblings: register allocation
ext/B/ramblings/runtime.porting Compiler ramblings: porting PP enging
! ext/B/README Compiler backend README
! ext/B/Showlex.t See if B::ShowLex works
! ext/B/Stash.t See if B::Stash works
! ext/B/TESTS Compiler backend test data
! ext/B/Todo Compiler backend Todo list
! ext/B/typemap Compiler backend interface types
! ext/ByteLoader/bytecode.h Bytecode header for bytecode loader
ext/ByteLoader/ByteLoader.pm Bytecode loader Perl module
ext/ByteLoader/ByteLoader.xs Bytecode loader external subroutines
ext/ByteLoader/byterun.c Runtime support for bytecode loader
ext/ByteLoader/byterun.h Header for byterun.c
ext/ByteLoader/hints/sunos.pl Hints for named architecture
! ext/ByteLoader/Makefile.PL Bytecode loader makefile writer
! ext/Cwd/Cwd.t See if Cwd works
! ext/Cwd/Cwd.xs Cwd extension external subroutines
! ext/Cwd/Makefile.PL Cwd extension makefile maker
ext/Data/Dumper/Changes Data pretty printer, changelog
ext/Data/Dumper/Dumper.pm Data pretty printer, module
ext/Data/Dumper/Dumper.xs Data pretty printer, externals
ext/Data/Dumper/Makefile.PL Data pretty printer, makefile writer
+ ext/Data/Dumper/t/dumper.t See if Data::Dumper works
+ ext/Data/Dumper/t/overload.t See if Data::Dumper works for overloaded data
ext/Data/Dumper/Todo Data pretty printer, futures
+ ext/DB_File/Changes Berkeley DB extension change log
+ ext/DB_File/DB_File.pm Berkeley DB extension Perl module
+ ext/DB_File/DB_File.xs Berkeley DB extension external subroutines
+ ext/DB_File/DB_File_BS Berkeley DB extension mkbootstrap fodder
+ ext/DB_File/dbinfo Berkeley DB database version checker
+ ext/DB_File/hints/dynixptx.pl Hint for DB_File for named architecture
+ ext/DB_File/hints/sco.pl Hint for DB_File for named architecture
+ ext/DB_File/Makefile.PL Berkeley DB extension makefile writer
+ ext/DB_File/t/db-btree.t See if DB_File works
+ ext/DB_File/t/db-hash.t See if DB_File works
+ ext/DB_File/t/db-recno.t See if DB_File works
+ ext/DB_File/typemap Berkeley DB extension interface types
+ ext/DB_File/version.c Berkeley DB extension interface version check
ext/Devel/DProf/Changes Perl code profiler changelog
ext/Devel/DProf/DProf.pm Perl code profiler
ext/Devel/DProf/DProf.xs Perl code profiler
***************
*** 171,187 ****
ext/Devel/Peek/Changes Data debugging tool, changelog
ext/Devel/Peek/Makefile.PL Data debugging tool, makefile writer
ext/Devel/Peek/Peek.pm Data debugging tool, module and pod
ext/Devel/Peek/Peek.xs Data debugging tool, externals
! ext/Digest/MD5/Changes Digest::MD5 extension changes
! ext/Digest/MD5/MD5.pm Digest::MD5 extension
! ext/Digest/MD5/MD5.xs Digest::MD5 extension
! ext/Digest/MD5/Makefile.PL Digest::MD5 extension makefile writer
ext/Digest/MD5/hints/irix_6.pl Hints for named architecture
! ext/Digest/MD5/typemap Digest::MD5 extension
! ext/DynaLoader/DynaLoader_pm.PL Dynamic Loader perl module
! ext/DynaLoader/Makefile.PL Dynamic Loader makefile writer
! ext/DynaLoader/README Dynamic Loader notes and intro
! ext/DynaLoader/XSLoader_pm.PL Simple XS Loader perl module
ext/DynaLoader/dl_aix.xs AIX implementation
ext/DynaLoader/dl_beos.xs BeOS implementation
ext/DynaLoader/dl_dld.xs GNU dld style implementation
--- 134,151 ----
ext/Devel/Peek/Changes Data debugging tool, changelog
ext/Devel/Peek/Makefile.PL Data debugging tool, makefile writer
ext/Devel/Peek/Peek.pm Data debugging tool, module and pod
+ ext/Devel/Peek/Peek.t See if Devel::Peek works
ext/Devel/Peek/Peek.xs Data debugging tool, externals
! ext/Digest/MD5/Changes Digest::MD5 extension changes
ext/Digest/MD5/hints/irix_6.pl Hints for named architecture
! ext/Digest/MD5/Makefile.PL Digest::MD5 extension makefile writer
! ext/Digest/MD5/MD5.pm Digest::MD5 extension
! ext/Digest/MD5/MD5.xs Digest::MD5 extension
! ext/Digest/MD5/t/aaa.t See if Digest::MD5 extension works
! ext/Digest/MD5/t/align.t See if Digest::MD5 extension works
! ext/Digest/MD5/t/badfile.t See if Digest::MD5 extension works
! ext/Digest/MD5/t/files.t See if Digest::MD5 extension works
! ext/Digest/MD5/typemap Digest::MD5 extension
ext/DynaLoader/dl_aix.xs AIX implementation
ext/DynaLoader/dl_beos.xs BeOS implementation
ext/DynaLoader/dl_dld.xs GNU dld style implementation
***************
*** 196,209 ****
ext/DynaLoader/dl_vmesa.xs VM/ESA implementation
ext/DynaLoader/dl_vms.xs VMS implementation
ext/DynaLoader/dlutils.c Dynamic loader utilities for dl_*.xs files
ext/DynaLoader/hints/aix.pl Hint for DynaLoader for named architecture
ext/DynaLoader/hints/linux.pl Hint for DynaLoader for named architecture
ext/DynaLoader/hints/netbsd.pl Hint for DynaLoader for named architecture
ext/DynaLoader/hints/openbsd.pl Hint for DynaLoader for named architecture
ext/Encode/Encode.pm Encode extension
ext/Encode/Encode.xs Encode extension
! ext/Encode/Encode/EncodeFormat.pod Encoding table format
! ext/Encode/Encode/Tcl.pm Handler for .enc encodings
ext/Encode/Encode/ascii.enc Encoding tables
ext/Encode/Encode/ascii.ucm Encoding tables
ext/Encode/Encode/big5.enc Encoding tables
--- 160,182 ----
ext/DynaLoader/dl_vmesa.xs VM/ESA implementation
ext/DynaLoader/dl_vms.xs VMS implementation
ext/DynaLoader/dlutils.c Dynamic loader utilities for dl_*.xs files
+ ext/DynaLoader/DynaLoader_pm.PL Dynamic Loader perl module
ext/DynaLoader/hints/aix.pl Hint for DynaLoader for named architecture
ext/DynaLoader/hints/linux.pl Hint for DynaLoader for named architecture
ext/DynaLoader/hints/netbsd.pl Hint for DynaLoader for named architecture
ext/DynaLoader/hints/openbsd.pl Hint for DynaLoader for named architecture
+ ext/DynaLoader/Makefile.PL Dynamic Loader makefile writer
+ ext/DynaLoader/README Dynamic Loader notes and intro
+ ext/DynaLoader/XSLoader_pm.PL Simple XS Loader perl module
+ ext/Encode.t See if Encode works
+ ext/Encode/compile Encode extension
+ ext/Encode/encengine.c Encode extension
+ ext/Encode/encode.h Encode extension
ext/Encode/Encode.pm Encode extension
ext/Encode/Encode.xs Encode extension
! ext/Encode/Encode/7bit-jis.enc Encoding tables
! ext/Encode/Encode/7bit-kana.enc Encoding tables
! ext/Encode/Encode/7bit-kr.enc Encoding tables
ext/Encode/Encode/ascii.enc Encoding tables
ext/Encode/Encode/ascii.ucm Encoding tables
ext/Encode/Encode/big5.enc Encoding tables
***************
*** 246,251 ****
--- 219,225 ----
ext/Encode/Encode/cp950.enc Encoding tables
ext/Encode/Encode/dingbats.enc Encoding tables
ext/Encode/Encode/dingbats.ucm Encoding tables
+ ext/Encode/Encode/EncodeFormat.pod Encoding table format
ext/Encode/Encode/euc-cn.enc Encoding tables
ext/Encode/Encode/euc-jp.enc Encoding tables
ext/Encode/Encode/euc-kr.enc Encoding tables
***************
*** 252,263 ****
ext/Encode/Encode/gb12345.enc Encoding tables
ext/Encode/Encode/gb1988.enc Encoding tables
ext/Encode/Encode/gb2312.enc Encoding tables
! ext/Encode/Encode/gsm0338.enc Encoding tables
ext/Encode/Encode/iso2022-jp.enc Encoding tables
ext/Encode/Encode/iso2022-kr.enc Encoding tables
! ext/Encode/Encode/iso2022.enc Encoding tables
! ext/Encode/Encode/iso8859-1.enc Encoding tables
! ext/Encode/Encode/iso8859-1.ucm Encoding tables
ext/Encode/Encode/iso8859-10.enc Encoding tables
ext/Encode/Encode/iso8859-10.ucm Encoding tables
ext/Encode/Encode/iso8859-13.enc Encoding tables
--- 226,238 ----
ext/Encode/Encode/gb12345.enc Encoding tables
ext/Encode/Encode/gb1988.enc Encoding tables
ext/Encode/Encode/gb2312.enc Encoding tables
! ext/Encode/Encode/gsm0338.enc Encoding tables
! ext/Encode/Encode/HZ.enc Encoding tables
ext/Encode/Encode/iso2022-jp.enc Encoding tables
ext/Encode/Encode/iso2022-kr.enc Encoding tables
! ext/Encode/Encode/iso2022.enc Encoding tables
! ext/Encode/Encode/iso8859-1.enc Encoding tables
! ext/Encode/Encode/iso8859-1.ucm Encoding tables
ext/Encode/Encode/iso8859-10.enc Encoding tables
ext/Encode/Encode/iso8859-10.ucm Encoding tables
ext/Encode/Encode/iso8859-13.enc Encoding tables
***************
*** 268,343 ****
ext/Encode/Encode/iso8859-15.ucm Encoding tables
ext/Encode/Encode/iso8859-16.enc Encoding tables
ext/Encode/Encode/iso8859-16.ucm Encoding tables
! ext/Encode/Encode/iso8859-2.enc Encoding tables
! ext/Encode/Encode/iso8859-2.ucm Encoding tables
! ext/Encode/Encode/iso8859-3.enc Encoding tables
! ext/Encode/Encode/iso8859-3.ucm Encoding tables
! ext/Encode/Encode/iso8859-4.enc Encoding tables
! ext/Encode/Encode/iso8859-4.ucm Encoding tables
! ext/Encode/Encode/iso8859-5.enc Encoding tables
! ext/Encode/Encode/iso8859-5.ucm Encoding tables
! ext/Encode/Encode/iso8859-6.enc Encoding tables
! ext/Encode/Encode/iso8859-6.ucm Encoding tables
! ext/Encode/Encode/iso8859-7.enc Encoding tables
! ext/Encode/Encode/iso8859-7.ucm Encoding tables
! ext/Encode/Encode/iso8859-8.enc Encoding tables
! ext/Encode/Encode/iso8859-8.ucm Encoding tables
! ext/Encode/Encode/iso8859-9.enc Encoding tables
! ext/Encode/Encode/iso8859-9.ucm Encoding tables
! ext/Encode/Encode/jis0201.enc Encoding tables
! ext/Encode/Encode/jis0208.enc Encoding tables
! ext/Encode/Encode/jis0212.enc Encoding tables
! ext/Encode/Encode/koi8-r.enc Encoding tables
! ext/Encode/Encode/koi8-r.ucm Encoding tables
! ext/Encode/Encode/ksc5601.enc Encoding tables
ext/Encode/Encode/macCentEuro.enc Encoding tables
ext/Encode/Encode/macCroatian.enc Encoding tables
ext/Encode/Encode/macCyrillic.enc Encoding tables
ext/Encode/Encode/macDingbats.enc Encoding tables
! ext/Encode/Encode/macGreek.enc Encoding tables
ext/Encode/Encode/macIceland.enc Encoding tables
! ext/Encode/Encode/macJapan.enc Encoding tables
! ext/Encode/Encode/macRoman.enc Encoding tables
ext/Encode/Encode/macRomania.enc Encoding tables
! ext/Encode/Encode/macThai.enc Encoding tables
ext/Encode/Encode/macTurkish.enc Encoding tables
ext/Encode/Encode/macUkraine.enc Encoding tables
! ext/Encode/Encode/posix-bc.enc Encoding tables
! ext/Encode/Encode/posix-bc.ucm Encoding tables
! ext/Encode/Encode/shiftjis.enc Encoding tables
! ext/Encode/Encode/symbol.enc Encoding tables
ext/Encode/Encode/symbol.ucm Encoding tables
! ext/Encode/Makefile.PL Encode extension
! ext/Encode/Todo Encode extension
! ext/Encode/compile Encode extension
! ext/Encode/encengine.c Encode extension
! ext/Encode/encode.h Encode extension
! ext/Errno/ChangeLog Errno perl module change log
! ext/Errno/Errno_pm.PL Errno perl module create script
! ext/Errno/Makefile.PL Errno extension makefile writer
! ext/Fcntl/Fcntl.pm Fcntl extension Perl module
! ext/Fcntl/Fcntl.xs Fcntl extension external subroutines
! ext/Fcntl/Makefile.PL Fcntl extension makefile writer
ext/File/Glob/Changes File::Glob extension changelog
ext/File/Glob/Glob.pm File::Glob extension module
ext/File/Glob/Glob.xs File::Glob extension external subroutines
ext/File/Glob/Makefile.PL File::Glob extension makefile writer
ext/File/Glob/TODO File::Glob extension todo list
! ext/File/Glob/bsd_glob.c File::Glob extension run time code
! ext/File/Glob/bsd_glob.h File::Glob extension header file
ext/Filter/Util/Call/Call.pm Filter::Util::Call extension module
ext/Filter/Util/Call/Call.xs Filter::Util::Call extension external subroutines
ext/Filter/Util/Call/Makefile.PL Filter::Util::Call extension makefile writer
ext/GDBM_File/GDBM_File.pm GDBM extension Perl module
ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines
- ext/GDBM_File/Makefile.PL GDBM extension makefile writer
ext/GDBM_File/hints/sco.pl Hint for GDBM_File for named architecture
ext/GDBM_File/typemap GDBM extension interface types
ext/IO/ChangeLog IO perl module change log
ext/IO/IO.pm Top-level interface to IO::* classes
ext/IO/IO.xs IO extension external subroutines
- ext/IO/Makefile.PL IO extension makefile writer
- ext/IO/README IO extension maintenance notice
ext/IO/lib/IO/Dir.pm IO directory reading package
ext/IO/lib/IO/File.pm IO file handle package
ext/IO/lib/IO/Handle.pm IO base handle package
--- 243,328 ----
ext/Encode/Encode/iso8859-15.ucm Encoding tables
ext/Encode/Encode/iso8859-16.enc Encoding tables
ext/Encode/Encode/iso8859-16.ucm Encoding tables
! ext/Encode/Encode/iso8859-2.enc Encoding tables
! ext/Encode/Encode/iso8859-2.ucm Encoding tables
! ext/Encode/Encode/iso8859-3.enc Encoding tables
! ext/Encode/Encode/iso8859-3.ucm Encoding tables
! ext/Encode/Encode/iso8859-4.enc Encoding tables
! ext/Encode/Encode/iso8859-4.ucm Encoding tables
! ext/Encode/Encode/iso8859-5.enc Encoding tables
! ext/Encode/Encode/iso8859-5.ucm Encoding tables
! ext/Encode/Encode/iso8859-6.enc Encoding tables
! ext/Encode/Encode/iso8859-6.ucm Encoding tables
! ext/Encode/Encode/iso8859-7.enc Encoding tables
! ext/Encode/Encode/iso8859-7.ucm Encoding tables
! ext/Encode/Encode/iso8859-8.enc Encoding tables
! ext/Encode/Encode/iso8859-8.ucm Encoding tables
! ext/Encode/Encode/iso8859-9.enc Encoding tables
! ext/Encode/Encode/iso8859-9.ucm Encoding tables
! ext/Encode/Encode/jis0201.enc Encoding tables
! ext/Encode/Encode/jis0208.enc Encoding tables
! ext/Encode/Encode/jis0212.enc Encoding tables
! ext/Encode/Encode/koi8-r.enc Encoding tables
! ext/Encode/Encode/koi8-r.ucm Encoding tables
! ext/Encode/Encode/ksc5601.enc Encoding tables
ext/Encode/Encode/macCentEuro.enc Encoding tables
ext/Encode/Encode/macCroatian.enc Encoding tables
ext/Encode/Encode/macCyrillic.enc Encoding tables
ext/Encode/Encode/macDingbats.enc Encoding tables
! ext/Encode/Encode/macGreek.enc Encoding tables
ext/Encode/Encode/macIceland.enc Encoding tables
! ext/Encode/Encode/macJapan.enc Encoding tables
! ext/Encode/Encode/macRoman.enc Encoding tables
ext/Encode/Encode/macRomania.enc Encoding tables
! ext/Encode/Encode/macThai.enc Encoding tables
ext/Encode/Encode/macTurkish.enc Encoding tables
ext/Encode/Encode/macUkraine.enc Encoding tables
! ext/Encode/Encode/posix-bc.enc Encoding tables
! ext/Encode/Encode/posix-bc.ucm Encoding tables
! ext/Encode/Encode/shiftjis.enc Encoding tables
! ext/Encode/Encode/symbol.enc Encoding tables
ext/Encode/Encode/symbol.ucm Encoding tables
! ext/Encode/Encode/Tcl.pm Handler for .enc encodings
! ext/Encode/Encode/Tcl.t See if Encode::Tcl works
! ext/Encode/Makefile.PL Encode extension
! ext/Encode/Todo Encode extension
! ext/Errno/ChangeLog Errno perl module change log
! ext/Errno/Errno.t See if Errno works
! ext/Errno/Errno_pm.PL Errno perl module create script
! ext/Errno/Makefile.PL Errno extension makefile writer
! ext/Fcntl/Fcntl.pm Fcntl extension Perl module
! ext/Fcntl/Fcntl.t See if Fcntl works
! ext/Fcntl/Fcntl.xs Fcntl extension external subroutines
! ext/Fcntl/Makefile.PL Fcntl extension makefile writer
! ext/Fcntl/syslfs.t See if large files work for sysio
! ext/File/Glob/bsd_glob.c File::Glob extension run time code
! ext/File/Glob/bsd_glob.h File::Glob extension header file
ext/File/Glob/Changes File::Glob extension changelog
ext/File/Glob/Glob.pm File::Glob extension module
ext/File/Glob/Glob.xs File::Glob extension external subroutines
ext/File/Glob/Makefile.PL File::Glob extension makefile writer
+ ext/File/Glob/t/basic.t See if File::Glob works
+ ext/File/Glob/t/case.t See if File::Glob works
+ ext/File/Glob/t/global.t See if File::Glob works
+ ext/File/Glob/t/taint.t See if File::Glob works
ext/File/Glob/TODO File::Glob extension todo list
! ext/Filter/t/call.t See if Filter::Util::Call works
ext/Filter/Util/Call/Call.pm Filter::Util::Call extension module
ext/Filter/Util/Call/Call.xs Filter::Util::Call extension external subroutines
ext/Filter/Util/Call/Makefile.PL Filter::Util::Call extension makefile writer
+ ext/GDBM_File/gdbm.t See if GDBM_File works
ext/GDBM_File/GDBM_File.pm GDBM extension Perl module
ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines
ext/GDBM_File/hints/sco.pl Hint for GDBM_File for named architecture
+ ext/GDBM_File/Makefile.PL GDBM extension makefile writer
ext/GDBM_File/typemap GDBM extension interface types
+ ext/I18N/Langinfo/Langinfo.pm I18N::Langinfo
+ ext/I18N/Langinfo/Langinfo.t I18N::Langinfo
+ ext/I18N/Langinfo/Langinfo.xs I18N::Langinfo
+ ext/I18N/Langinfo/Makefile.PL I18N::Langinfo
ext/IO/ChangeLog IO perl module change log
ext/IO/IO.pm Top-level interface to IO::* classes
ext/IO/IO.xs IO extension external subroutines
ext/IO/lib/IO/Dir.pm IO directory reading package
ext/IO/lib/IO/File.pm IO file handle package
ext/IO/lib/IO/Handle.pm IO base handle package
***************
*** 348,385 ****
ext/IO/lib/IO/Socket.pm IO socket handle package
ext/IO/lib/IO/Socket/INET.pm IO INET specific socket methods
ext/IO/lib/IO/Socket/UNIX.pm IO UNIX specific socket methods
ext/IO/poll.c IO poll() emulation using select()
ext/IO/poll.h IO poll() emulation using select()
ext/IPC/SysV/ChangeLog IPC::SysV extension Perl module
! ext/IPC/SysV/MANIFEST IPC::SysV extension Perl module
ext/IPC/SysV/Makefile.PL IPC::SysV extension Perl module
ext/IPC/SysV/Msg.pm IPC::SysV extension Perl module
ext/IPC/SysV/README IPC::SysV extension Perl module
ext/IPC/SysV/Semaphore.pm IPC::SysV extension Perl module
ext/IPC/SysV/SysV.pm IPC::SysV extension Perl module
ext/IPC/SysV/SysV.xs IPC::SysV extension Perl module
- ext/IPC/SysV/hints/cygwin.pl Hint for IPC::SysV for named architecture
- ext/IPC/SysV/hints/next_3.pl Hint for IPC::SysV for named architecture
ext/IPC/SysV/t/msg.t IPC::SysV extension Perl module
ext/IPC/SysV/t/sem.t IPC::SysV extension Perl module
ext/MIME/Base64/Base64.pm MIME::Base64 extension
ext/MIME/Base64/Base64.xs MIME::Base64 extension
ext/MIME/Base64/Changes MIME::Base64 extension
ext/MIME/Base64/Makefile.PL MIME::Base64 extension
ext/MIME/Base64/QuotedPrint.pm MIME::Base64 extension
! ext/NDBM_File/Makefile.PL NDBM extension makefile writer
! ext/NDBM_File/NDBM_File.pm NDBM extension Perl module
! ext/NDBM_File/NDBM_File.xs NDBM extension external subroutines
ext/NDBM_File/hints/cygwin.pl Hint for NDBM_File for named architecture
ext/NDBM_File/hints/dec_osf.pl Hint for NDBM_File for named architecture
ext/NDBM_File/hints/dynixptx.pl Hint for NDBM_File for named architecture
ext/NDBM_File/hints/sco.pl Hint for NDBM_File for named architecture
ext/NDBM_File/hints/solaris.pl Hint for NDBM_File for named architecture
ext/NDBM_File/hints/svr4.pl Hint for NDBM_File for named architecture
ext/NDBM_File/typemap NDBM extension interface types
- ext/ODBM_File/Makefile.PL ODBM extension makefile writer
- ext/ODBM_File/ODBM_File.pm ODBM extension Perl module
- ext/ODBM_File/ODBM_File.xs ODBM extension external subroutines
ext/ODBM_File/hints/cygwin.pl Hint for ODBM_File for named architecture
ext/ODBM_File/hints/dec_osf.pl Hint for ODBM_File for named architecture
ext/ODBM_File/hints/hpux.pl Hint for ODBM_File for named architecture
--- 333,408 ----
ext/IO/lib/IO/Socket.pm IO socket handle package
ext/IO/lib/IO/Socket/INET.pm IO INET specific socket methods
ext/IO/lib/IO/Socket/UNIX.pm IO UNIX specific socket methods
+ ext/IO/lib/IO/t/io_const.t See if constants from IO work
+ ext/IO/lib/IO/t/io_dir.t See if directory-related methods from IO work
+ ext/IO/lib/IO/t/io_dup.t See if dup()-related methods from IO work
+ ext/IO/lib/IO/t/io_linenum.t See if I/O line numbers are tracked correctly
+ ext/IO/lib/IO/t/io_multihomed.t See if INET sockets work with multi-homed hosts
+ ext/IO/lib/IO/t/io_pipe.t See if pipe()-related methods from IO work
+ ext/IO/lib/IO/t/io_poll.t See if poll()-related methods from IO work
+ ext/IO/lib/IO/t/io_sel.t See if select()-related methods from IO work
+ ext/IO/lib/IO/t/io_sock.t See if INET socket-related methods from IO work
+ ext/IO/lib/IO/t/io_taint.t See if the untaint method from IO works
+ ext/IO/lib/IO/t/io_tell.t See if seek()/tell()-related methods from IO work
+ ext/IO/lib/IO/t/io_udp.t See if UDP socket-related methods from IO work
+ ext/IO/lib/IO/t/io_unix.t See if UNIX socket-related methods from IO work
+ ext/IO/lib/IO/t/io_xs.t See if XSUB methods from IO work
+ ext/IO/Makefile.PL IO extension makefile writer
ext/IO/poll.c IO poll() emulation using select()
ext/IO/poll.h IO poll() emulation using select()
+ ext/IO/README IO extension maintenance notice
ext/IPC/SysV/ChangeLog IPC::SysV extension Perl module
! ext/IPC/SysV/hints/cygwin.pl Hint for IPC::SysV for named architecture
! ext/IPC/SysV/hints/next_3.pl Hint for IPC::SysV for named architecture
! ext/IPC/SysV/ipcsysv.t See if IPC::SysV works
ext/IPC/SysV/Makefile.PL IPC::SysV extension Perl module
+ ext/IPC/SysV/MANIFEST IPC::SysV extension Perl module
ext/IPC/SysV/Msg.pm IPC::SysV extension Perl module
ext/IPC/SysV/README IPC::SysV extension Perl module
ext/IPC/SysV/Semaphore.pm IPC::SysV extension Perl module
ext/IPC/SysV/SysV.pm IPC::SysV extension Perl module
ext/IPC/SysV/SysV.xs IPC::SysV extension Perl module
ext/IPC/SysV/t/msg.t IPC::SysV extension Perl module
ext/IPC/SysV/t/sem.t IPC::SysV extension Perl module
+ ext/List/Util/ChangeLog Util extension
+ ext/List/Util/lib/List/Util.pm List::Util
+ ext/List/Util/lib/Scalar/Util.pm Scalar::Util
+ ext/List/Util/Makefile.PL Util extension
+ ext/List/Util/README Util extension
+ ext/List/Util/t/blessed.t Scalar::Util
+ ext/List/Util/t/dualvar.t Scalar::Util
+ ext/List/Util/t/first.t List::Util
+ ext/List/Util/t/max.t List::Util
+ ext/List/Util/t/maxstr.t List::Util
+ ext/List/Util/t/min.t List::Util
+ ext/List/Util/t/minstr.t List::Util
+ ext/List/Util/t/readonly.t Scalar::Util
+ ext/List/Util/t/reduce.t List::Util
+ ext/List/Util/t/reftype.t Scalar::Util
+ ext/List/Util/t/sum.t List::Util
+ ext/List/Util/t/tainted.t Scalar::Util
+ ext/List/Util/t/weak.t Scalar::Util
+ ext/List/Util/Util.xs Util extension
ext/MIME/Base64/Base64.pm MIME::Base64 extension
ext/MIME/Base64/Base64.xs MIME::Base64 extension
ext/MIME/Base64/Changes MIME::Base64 extension
ext/MIME/Base64/Makefile.PL MIME::Base64 extension
ext/MIME/Base64/QuotedPrint.pm MIME::Base64 extension
! ext/MIME/Base64/t/base64.t See whether MIME::Base64 works
! ext/MIME/Base64/t/qp.t See whether MIME::QuotedPrint works
! ext/MIME/Base64/t/unicode.t See whether MIME::Base64 works
ext/NDBM_File/hints/cygwin.pl Hint for NDBM_File for named architecture
ext/NDBM_File/hints/dec_osf.pl Hint for NDBM_File for named architecture
ext/NDBM_File/hints/dynixptx.pl Hint for NDBM_File for named architecture
+ ext/NDBM_File/hints/linux.pl Hint for NDBM_File for named architecture
ext/NDBM_File/hints/sco.pl Hint for NDBM_File for named architecture
ext/NDBM_File/hints/solaris.pl Hint for NDBM_File for named architecture
ext/NDBM_File/hints/svr4.pl Hint for NDBM_File for named architecture
+ ext/NDBM_File/Makefile.PL NDBM extension makefile writer
+ ext/NDBM_File/ndbm.t See if NDBM_File works
+ ext/NDBM_File/NDBM_File.pm NDBM extension Perl module
+ ext/NDBM_File/NDBM_File.xs NDBM extension external subroutines
ext/NDBM_File/typemap NDBM extension interface types
ext/ODBM_File/hints/cygwin.pl Hint for ODBM_File for named architecture
ext/ODBM_File/hints/dec_osf.pl Hint for ODBM_File for named architecture
ext/ODBM_File/hints/hpux.pl Hint for ODBM_File for named architecture
***************
*** 387,671 ****
ext/ODBM_File/hints/solaris.pl Hint for ODBM_File for named architecture
ext/ODBM_File/hints/svr4.pl Hint for ODBM_File for named architecture
ext/ODBM_File/hints/ultrix.pl Hint for ODBM_File for named architecture
ext/ODBM_File/typemap ODBM extension interface types
ext/Opcode/Makefile.PL Opcode extension makefile writer
ext/Opcode/Opcode.pm Opcode extension Perl module
ext/Opcode/Opcode.xs Opcode extension external subroutines
- ext/Opcode/Safe.pm Safe extension Perl module
ext/Opcode/ops.pm "Pragma" form of Opcode extension Perl module
! ext/POSIX/Makefile.PL POSIX extension makefile writer
! ext/POSIX/POSIX.pm POSIX extension Perl module
! ext/POSIX/POSIX.pod POSIX extension documentation
! ext/POSIX/POSIX.xs POSIX extension external subroutines
! ext/POSIX/hints/bsdos.pl Hint for POSIX for named architecture
! ext/POSIX/hints/dynixptx.pl Hint for POSIX for named architecture
! ext/POSIX/hints/freebsd.pl Hint for POSIX for named architecture
! ext/POSIX/hints/linux.pl Hint for POSIX for named architecture
! ext/POSIX/hints/mint.pl Hint for POSIX for named architecture
! ext/POSIX/hints/netbsd.pl Hint for POSIX for named architecture
! ext/POSIX/hints/next_3.pl Hint for POSIX for named architecture
! ext/POSIX/hints/openbsd.pl Hint for POSIX for named architecture
! ext/POSIX/hints/sunos_4.pl Hint for POSIX for named architecture
! ext/POSIX/hints/svr4.pl Hint for POSIX for named architecture
! ext/POSIX/typemap POSIX extension interface types
ext/PerlIO/Scalar/Makefile.PL PerlIO layer for scalars
ext/PerlIO/Scalar/Scalar.pm PerlIO layer for scalars
ext/PerlIO/Scalar/Scalar.xs PerlIO layer for scalars
ext/PerlIO/Via/Makefile.PL PerlIO layer for layers in perl
ext/PerlIO/Via/Via.pm PerlIO layer for layers in perl
ext/PerlIO/Via/Via.xs PerlIO layer for layers in perl
ext/SDBM_File/Makefile.PL SDBM extension makefile writer
! ext/SDBM_File/SDBM_File.pm SDBM extension Perl module
! ext/SDBM_File/SDBM_File.xs SDBM extension external subroutines
! ext/SDBM_File/sdbm/CHANGES SDBM kit
! ext/SDBM_File/sdbm/COMPARE SDBM kit
! ext/SDBM_File/sdbm/Makefile.PL SDBM kit
! ext/SDBM_File/sdbm/README SDBM kit
! ext/SDBM_File/sdbm/README.too SDBM kit
! ext/SDBM_File/sdbm/biblio SDBM kit
! ext/SDBM_File/sdbm/dba.c SDBM kit
! ext/SDBM_File/sdbm/dbd.c SDBM kit
! ext/SDBM_File/sdbm/dbe.1 SDBM kit
! ext/SDBM_File/sdbm/dbe.c SDBM kit
! ext/SDBM_File/sdbm/dbm.c SDBM kit
! ext/SDBM_File/sdbm/dbm.h SDBM kit
! ext/SDBM_File/sdbm/dbu.c SDBM kit
! ext/SDBM_File/sdbm/grind SDBM kit
! ext/SDBM_File/sdbm/hash.c SDBM kit
ext/SDBM_File/sdbm/linux.patches SDBM kit
ext/SDBM_File/sdbm/makefile.sdbm SDBM kit
! ext/SDBM_File/sdbm/pair.c SDBM kit
! ext/SDBM_File/sdbm/pair.h SDBM kit
! ext/SDBM_File/sdbm/readme.ms SDBM kit
! ext/SDBM_File/sdbm/sdbm.3 SDBM kit
! ext/SDBM_File/sdbm/sdbm.c SDBM kit
! ext/SDBM_File/sdbm/sdbm.h SDBM kit
! ext/SDBM_File/sdbm/tune.h SDBM kit
! ext/SDBM_File/sdbm/util.c SDBM kit
ext/SDBM_File/typemap SDBM extension interface types
! ext/Socket/Makefile.PL Socket extension makefile writer
! ext/Socket/Socket.pm Socket extension Perl module
! ext/Socket/Socket.xs Socket extension external subroutines
ext/Storable/ChangeLog Storable extension
- ext/Storable/MANIFEST Storable extension
ext/Storable/Makefile.PL Storable extension
ext/Storable/README Storable extension
ext/Storable/Storable.pm Storable extension
ext/Storable/Storable.xs Storable extension
ext/Sys/Hostname/Hostname.pm Sys::Hostname extension Perl module
ext/Sys/Hostname/Hostname.xs Sys::Hostname extension external subroutines
ext/Sys/Hostname/Makefile.PL Sys::Hostname extension makefile writer
ext/Sys/Syslog/Makefile.PL Sys::Syslog extension makefile writer
ext/Sys/Syslog/Syslog.pm Sys::Syslog extension Perl module
ext/Sys/Syslog/Syslog.xs Sys::Syslog extension external subroutines
! ext/Thread/Makefile.PL Thread extension makefile writer
! ext/Thread/Notes Thread notes
! ext/Thread/README Thread README
! ext/Thread/Thread.pm Thread extension Perl module
! ext/Thread/Thread.xs Thread extension external subroutines
ext/Thread/Thread/Queue.pm Thread synchronised queue objects
ext/Thread/Thread/Semaphore.pm Thread semaphore objects
ext/Thread/Thread/Signal.pm Start a thread to run signal handlers
ext/Thread/Thread/Specific.pm Thread specific data access
! ext/Thread/create.t Test thread creation
! ext/Thread/die.t Test thread die()
! ext/Thread/die2.t Test thread die() differently
! ext/Thread/io.t Test threads doing simple I/O
! ext/Thread/join.t Test thread joining
! ext/Thread/join2.t Test thread joining differently
! ext/Thread/list.t Test getting list of all threads
! ext/Thread/lock.t Test lock primitive
! ext/Thread/queue.t Test Thread::Queue module
! ext/Thread/specific.t Test thread-specific user data
! ext/Thread/sync.t Test thread synchronisation
! ext/Thread/sync2.t Test thread synchronisation
! ext/Thread/typemap Thread extension interface types
! ext/Thread/unsync.t Test thread implicit synchronisation
! ext/Thread/unsync2.t Test thread implicit synchronisation
! ext/Thread/unsync3.t Test thread implicit synchronisation
! ext/Thread/unsync4.t Test thread implicit synchronisation
ext/XS/Typemap/Makefile.PL XS::Typemap extension
ext/XS/Typemap/README XS::Typemap extension
- ext/XS/Typemap/Typemap.pm XS::Typemap extension
- ext/XS/Typemap/Typemap.xs XS::Typemap extension
ext/XS/Typemap/stdio.c XS::Typemap extension
ext/XS/Typemap/typemap XS::Typemap extension
! ext/attrs/Makefile.PL attrs extension makefile writer
! ext/attrs/attrs.pm attrs extension Perl module
! ext/attrs/attrs.xs attrs extension external subroutines
! ext/re/Makefile.PL re extension makefile writer
! ext/re/hints/mpeix.pl Hints for re for named architecture
! ext/re/re.pm re extension Perl module
! ext/re/re.xs re extension external subroutines
! ext/util/make_ext Used by Makefile to execute extension Makefiles
! ext/util/mkbootstrap Turns ext/*/*_BS into bootstrap info
! fakesdio.h stdio in terms of PerlIO
! fakethr.h Fake threads header
! form.h Public declarations for the above
! global.sym Symbols that need hiding when embedded
! globals.c File to declare global symbols (for shared library)
! globvar.sym Global variables that need hiding when embedded
! gv.c Glob value code
! gv.h Glob value header
! h2pl/README How to turn .ph files into .pl files
! h2pl/cbreak.pl cbreak routines using .ph
! h2pl/cbreak2.pl cbreak routines using .pl
! h2pl/eg/sizeof.ph Sample sizeof array initialization
! h2pl/eg/sys/errno.pl Sample translated errno.pl
! h2pl/eg/sys/ioctl.pl Sample translated ioctl.pl
! h2pl/eg/sysexits.pl Sample translated sysexits.pl
! h2pl/getioctlsizes Program to extract types from ioctl.h
! h2pl/mksizes Program to make %sizeof array
! h2pl/mkvars Program to make .pl from .ph files
! h2pl/tcbreak cbreak test routine using .ph
! h2pl/tcbreak2 cbreak test routine using .pl
! handy.h Handy definitions
! hints/3b1.sh Hints for named architecture
! hints/3b1cc Hints for named architecture
! hints/README.hints Notes about hints
! hints/aix.sh Hints for named architecture
! hints/altos486.sh Hints for named architecture
! hints/amigaos.sh Hints for named architecture
! hints/apollo.sh Hints for named architecture
! hints/aux_3.sh Hints for named architecture
! hints/beos.sh Hints for named architecture
! hints/broken-db.msg Warning message for systems with broken DB library
! hints/bsdos.sh Hints for named architecture
! hints/convexos.sh Hints for named architecture
! hints/cxux.sh Hints for named architecture
! hints/cygwin.sh Hints for named architecture
! hints/darwin.sh Hints for named architecture
! hints/dcosx.sh Hints for named architecture
! hints/dec_osf.sh Hints for named architecture
! hints/dgux.sh Hints for named architecture
! hints/dos_djgpp.sh Hints for named architecture
! hints/dynix.sh Hints for named architecture
! hints/dynixptx.sh Hints for named architecture
! hints/epix.sh Hints for named architecture
! hints/esix4.sh Hints for named architecture
! hints/fps.sh Hints for named architecture
! hints/freebsd.sh Hints for named architecture
! hints/genix.sh Hints for named architecture
! hints/gnu.sh Hints for named architecture
! hints/greenhills.sh Hints for named architecture
! hints/hpux.sh Hints for named architecture
! hints/i386.sh Hints for named architecture
! hints/irix_4.sh Hints for named architecture
! hints/irix_5.sh Hints for named architecture
! hints/irix_6.sh Hints for named architecture
! hints/irix_6_0.sh Hints for named architecture
! hints/irix_6_1.sh Hints for named architecture
! hints/isc.sh Hints for named architecture
! hints/isc_2.sh Hints for named architecture
! hints/linux.sh Hints for named architecture
! hints/lynxos.sh Hints for named architecture
! hints/machten.sh Hints for named architecture
! hints/machten_2.sh Hints for named architecture
! hints/mint.sh Hints for named architecture
! hints/mips.sh Hints for named architecture
! hints/mpc.sh Hints for named architecture
! hints/mpeix.sh Hints for named architecture
! hints/ncr_tower.sh Hints for named architecture
! hints/netbsd.sh Hints for named architecture
! hints/newsos4.sh Hints for named architecture
! hints/next_3.sh Hints for named architecture
! hints/next_3_0.sh Hints for named architecture
! hints/next_4.sh Hints for named architecture
! hints/nonstopux.sh Hints for named architecture
! hints/openbsd.sh Hints for named architecture
! hints/opus.sh Hints for named architecture
! hints/os2.sh Hints for named architecture
! hints/os390.sh Hints for named architecture
! hints/posix-bc.sh Hints for named architecture
! hints/powerux.sh Hints for named architecture
! hints/qnx.sh Hints for named architecture
! hints/rhapsody.sh Hints for named architecture
! hints/sco.sh Hints for named architecture
! hints/sco_2_3_0.sh Hints for named architecture
! hints/sco_2_3_1.sh Hints for named architecture
! hints/sco_2_3_2.sh Hints for named architecture
! hints/sco_2_3_3.sh Hints for named architecture
! hints/sco_2_3_4.sh Hints for named architecture
! hints/solaris_2.sh Hints for named architecture
! hints/stellar.sh Hints for named architecture
! hints/sunos_4_0.sh Hints for named architecture
! hints/sunos_4_1.sh Hints for named architecture
! hints/svr4.sh Hints for named architecture
! hints/svr5.sh Hints for named architecture
! hints/ti1500.sh Hints for named architecture
! hints/titanos.sh Hints for named architecture
! hints/ultrix_4.sh Hints for named architecture
! hints/umips.sh Hints for named architecture
! hints/unicos.sh Hints for named architecture
! hints/unicosmk.sh Hints for named architecture
! hints/unisysdynix.sh Hints for named architecture
! hints/utekv.sh Hints for named architecture
! hints/uts.sh Hints for named architecture
! hints/uwin.sh Hints for named architecture
! hints/vmesa.sh Hints for named architecture
! hv.c Hash value code
! hv.h Hash value header
! installhtml Perl script to install html files for pods
! installman Perl script to install man pages for pods
! installperl Perl script to do "make install" dirty work
! intrpvar.h Variables held in each interpreter instance
! iperlsys.h Perl's interface to the system
! jpl/ChangeLog Java/Perl Lingo change log
! jpl/JNI/Changes Java Native Interface changes
! jpl/JNI/Closer.java Java Native Interface example
! jpl/JNI/JNI.pm Java Native Interface module
! jpl/JNI/JNI.xs Java Native Interface module
! jpl/JNI/JNIConfig Java Native Interface config
! jpl/JNI/JNIConfig.Win32 Java Native Interface config
! jpl/JNI/JNIConfig.kaffe Java Native Interface config
jpl/JNI/JNIConfig.noembed Java Native Interface config
jpl/JNI/JNIConfig.standard Java Native Interface config
! jpl/JNI/Makefile.PL Java Native Interface makefile generator
! jpl/JNI/test.pl Java Native Interface tests
! jpl/JNI/typemap Java/Perl interface typemap
! jpl/JNI/typemap.gcc Java/Perl interface typemap
! jpl/JNI/typemap.win32 Java/Perl interface typemap
! jpl/JPL/AutoLoader.pm Java/Perl compiler module
! jpl/JPL/Class.pm Java/Perl compiler module
! jpl/JPL/Compile.pm Java/Perl compiler module
! jpl/JPL/Makefile.PL Java/Perl makefile generator
! jpl/JPL_Rolo/JPL_Rolo.jpl Rolodex sample application
! jpl/JPL_Rolo/Makefile.PL Makefile generator
! jpl/JPL_Rolo/README Instructions
! jpl/JPL_Rolo/cardfile Rolodex sample application
! jpl/PerlInterpreter/Makefile.PL Makefile generator
! jpl/PerlInterpreter/PerlInterpreter.c Perl interpreter abstraction
! jpl/PerlInterpreter/PerlInterpreter.h Perl interpreter abstraction
jpl/PerlInterpreter/PerlInterpreter.java Perl interpreter abstraction
! jpl/README JPL instructions
! jpl/README.JUST-JNI JPL instructions
! jpl/SETVARS.PL JPL setup
! jpl/Sample/Makefile.PL JPL sample makefile generator
! jpl/Sample/Sample.jpl JPL sample
! jpl/Test/Makefile.PL JPL tests makefile generator
! jpl/Test/Test.jpl JPL tests
! jpl/bin/jpl JPL compiler
! jpl/docs/Tutorial.pod Perl and Java Tutorial
! jpl/get_jdk/README Instructions for using get_jdk.pl
! jpl/get_jdk/get_jdk.pl JDK download tool
! jpl/get_jdk/jdk_hosts JDK availability list
! jpl/install-jpl JPL install utility
! keywords.h The keyword numbers
! keywords.pl Program to write keywords.h
! lib/AnyDBM_File.pm Perl module to emulate dbmopen
! lib/AutoLoader.pm Autoloader base class
! lib/AutoSplit.pm Split up autoload functions
! lib/Benchmark.pm Measure execution time
! lib/CGI.pm Web server interface ("Common Gateway Interface")
! lib/CGI/Apache.pm Support for Apache's Perl module
! lib/CGI/Carp.pm Log server errors with helpful context
! lib/CGI/Cookie.pm Interface to Netscape Cookies
! lib/CGI/Fast.pm Support for FastCGI (persistent server process)
! lib/CGI/Pretty.pm Output nicely formatted HTML
! lib/CGI/Push.pm Support for server push
! lib/CGI/Switch.pm Simple interface for multiple server types
! lib/CGI/Util.pm Utility functions
! lib/CGI/eg/RunMeFirst Setup script for CGI examples
lib/CGI/eg/caution.xbm CGI example
lib/CGI/eg/clickable_image.cgi CGI example
lib/CGI/eg/cookie.cgi CGI example
--- 410,773 ----
ext/ODBM_File/hints/solaris.pl Hint for ODBM_File for named architecture
ext/ODBM_File/hints/svr4.pl Hint for ODBM_File for named architecture
ext/ODBM_File/hints/ultrix.pl Hint for ODBM_File for named architecture
+ ext/ODBM_File/Makefile.PL ODBM extension makefile writer
+ ext/ODBM_File/odbm.t See if ODBM_File works
+ ext/ODBM_File/ODBM_File.pm ODBM extension Perl module
+ ext/ODBM_File/ODBM_File.xs ODBM extension external subroutines
ext/ODBM_File/typemap ODBM extension interface types
ext/Opcode/Makefile.PL Opcode extension makefile writer
ext/Opcode/Opcode.pm Opcode extension Perl module
+ ext/Opcode/Opcode.t See if Opcode works
ext/Opcode/Opcode.xs Opcode extension external subroutines
ext/Opcode/ops.pm "Pragma" form of Opcode extension Perl module
! ext/Opcode/ops.t See if Opcode works
! ext/Opcode/Safe.pm Safe extension Perl module
! ext/PerlIO/PerlIO.t See if PerlIO works
ext/PerlIO/Scalar/Makefile.PL PerlIO layer for scalars
ext/PerlIO/Scalar/Scalar.pm PerlIO layer for scalars
ext/PerlIO/Scalar/Scalar.xs PerlIO layer for scalars
+ ext/PerlIO/t/encoding.t See if PerlIo encoding conversion works
+ ext/PerlIO/t/scalar.t Test of PerlIO::Scalar
ext/PerlIO/Via/Makefile.PL PerlIO layer for layers in perl
ext/PerlIO/Via/Via.pm PerlIO layer for layers in perl
ext/PerlIO/Via/Via.xs PerlIO layer for layers in perl
+ ext/POSIX/hints/bsdos.pl Hint for POSIX for named architecture
+ ext/POSIX/hints/dynixptx.pl Hint for POSIX for named architecture
+ ext/POSIX/hints/freebsd.pl Hint for POSIX for named architecture
+ ext/POSIX/hints/linux.pl Hint for POSIX for named architecture
+ ext/POSIX/hints/mint.pl Hint for POSIX for named architecture
+ ext/POSIX/hints/netbsd.pl Hint for POSIX for named architecture
+ ext/POSIX/hints/next_3.pl Hint for POSIX for named architecture
+ ext/POSIX/hints/openbsd.pl Hint for POSIX for named architecture
+ ext/POSIX/hints/sunos_4.pl Hint for POSIX for named architecture
+ ext/POSIX/hints/svr4.pl Hint for POSIX for named architecture
+ ext/POSIX/hints/uts.pl Hint for POSIX for named architecture
+ ext/POSIX/Makefile.PL POSIX extension makefile writer
+ ext/POSIX/POSIX.pm POSIX extension Perl module
+ ext/POSIX/POSIX.pod POSIX extension documentation
+ ext/POSIX/POSIX.t See if POSIX works
+ ext/POSIX/POSIX.xs POSIX extension external subroutines
+ ext/POSIX/sigaction.t See if POSIX::sigaction works
+ ext/POSIX/typemap POSIX extension interface types
+ ext/re/hints/mpeix.pl Hints for re for named architecture
+ ext/re/Makefile.PL re extension makefile writer
+ ext/re/re.pm re extension Perl module
+ ext/re/re.xs re extension external subroutines
+ ext/Safe/safe1.t See if Safe works
+ ext/Safe/safe2.t See if Safe works
ext/SDBM_File/Makefile.PL SDBM extension makefile writer
! ext/SDBM_File/sdbm.t See if SDBM_File works
! ext/SDBM_File/sdbm/biblio SDBM kit
! ext/SDBM_File/sdbm/CHANGES SDBM kit
! ext/SDBM_File/sdbm/COMPARE SDBM kit
! ext/SDBM_File/sdbm/dba.c SDBM kit
! ext/SDBM_File/sdbm/dbd.c SDBM kit
! ext/SDBM_File/sdbm/dbe.1 SDBM kit
! ext/SDBM_File/sdbm/dbe.c SDBM kit
! ext/SDBM_File/sdbm/dbu.c SDBM kit
! ext/SDBM_File/sdbm/grind SDBM kit
! ext/SDBM_File/sdbm/hash.c SDBM kit
ext/SDBM_File/sdbm/linux.patches SDBM kit
+ ext/SDBM_File/sdbm/Makefile.PL SDBM kit
ext/SDBM_File/sdbm/makefile.sdbm SDBM kit
! ext/SDBM_File/sdbm/pair.c SDBM kit
! ext/SDBM_File/sdbm/pair.h SDBM kit
! ext/SDBM_File/sdbm/README SDBM kit
! ext/SDBM_File/sdbm/readme.ms SDBM kit
! ext/SDBM_File/sdbm/README.too SDBM kit
! ext/SDBM_File/sdbm/sdbm.3 SDBM kit
! ext/SDBM_File/sdbm/sdbm.c SDBM kit
! ext/SDBM_File/sdbm/sdbm.h SDBM kit
! ext/SDBM_File/sdbm/tune.h SDBM kit
! ext/SDBM_File/sdbm/util.c SDBM kit
! ext/SDBM_File/SDBM_File.pm SDBM extension Perl module
! ext/SDBM_File/SDBM_File.xs SDBM extension external subroutines
ext/SDBM_File/typemap SDBM extension interface types
! ext/Socket/Makefile.PL Socket extension makefile writer
! ext/Socket/Socket.pm Socket extension Perl module
! ext/Socket/Socket.t See if Socket works
! ext/Socket/Socket.xs Socket extension external subroutines
ext/Storable/ChangeLog Storable extension
ext/Storable/Makefile.PL Storable extension
+ ext/Storable/MANIFEST Storable extension
ext/Storable/README Storable extension
ext/Storable/Storable.pm Storable extension
ext/Storable/Storable.xs Storable extension
+ ext/Storable/t/blessed.t See if Storable works
+ ext/Storable/t/canonical.t See if Storable works
+ ext/Storable/t/compat06.t See if Storable works
+ ext/Storable/t/dclone.t See if Storable works
+ ext/Storable/t/forgive.t See if Storable works
+ ext/Storable/t/freeze.t See if Storable works
+ ext/Storable/t/lock.t See if Storable works
+ ext/Storable/t/overload.t See if Storable works
+ ext/Storable/t/recurse.t See if Storable works
+ ext/Storable/t/retrieve.t See if Storable works
+ ext/Storable/t/store.t See if Storable works
+ ext/Storable/t/tied.t See if Storable works
+ ext/Storable/t/tied_hook.t See if Storable works
+ ext/Storable/t/tied_items.t See if Storable works
+ ext/Storable/t/utf8.t See if Storable works
ext/Sys/Hostname/Hostname.pm Sys::Hostname extension Perl module
+ ext/Sys/Hostname/Hostname.t See if Sys::Hostname works
ext/Sys/Hostname/Hostname.xs Sys::Hostname extension external subroutines
ext/Sys/Hostname/Makefile.PL Sys::Hostname extension makefile writer
ext/Sys/Syslog/Makefile.PL Sys::Syslog extension makefile writer
ext/Sys/Syslog/Syslog.pm Sys::Syslog extension Perl module
+ ext/Sys/Syslog/syslog.t See if Sys::Syslog works
ext/Sys/Syslog/Syslog.xs Sys::Syslog extension external subroutines
! ext/Thread/create.tx Test thread creation
! ext/Thread/die.tx Test thread die()
! ext/Thread/die2.tx Test thread die() differently
! ext/Thread/io.tx Test threads doing simple I/O
! ext/Thread/join.tx Test thread joining
! ext/Thread/join2.tx Test thread joining differently
! ext/Thread/list.tx Test getting list of all threads
! ext/Thread/lock.tx Test lock primitive
! ext/Thread/Makefile.PL Thread extension makefile writer
! ext/Thread/Notes Thread notes
! ext/Thread/queue.tx Test Thread::Queue module
! ext/Thread/README Thread README
! ext/Thread/specific.tx Test thread-specific user data
! ext/Thread/sync.tx Test thread synchronisation
! ext/Thread/sync2.tx Test thread synchronisation
! ext/Thread/thr5005.t Test 5.005-style threading (skipped if no use5005threads)
! ext/Thread/Thread.pm Thread extension Perl module
! ext/Thread/Thread.xs Thread extension external subroutines
ext/Thread/Thread/Queue.pm Thread synchronised queue objects
ext/Thread/Thread/Semaphore.pm Thread semaphore objects
ext/Thread/Thread/Signal.pm Start a thread to run signal handlers
ext/Thread/Thread/Specific.pm Thread specific data access
! ext/Thread/typemap Thread extension interface types
! ext/Thread/unsync.tx Test thread implicit synchronisation
! ext/Thread/unsync2.tx Test thread implicit synchronisation
! ext/Thread/unsync3.tx Test thread implicit synchronisation
! ext/Thread/unsync4.tx Test thread implicit synchronisation
! ext/Time/HiRes/Changes Time::HiRes extension
! ext/Time/HiRes/hints/dynixptx.pl Hint for Time::HiRes for named architecture
! ext/Time/HiRes/hints/sco.pl Hints for Time::HiRes for named architecture
! ext/Time/HiRes/HiRes.pm Time::HiRes extension
! ext/Time/HiRes/HiRes.t Test for Time::HiRes
! ext/Time/HiRes/HiRes.xs Time::HiRes extension
! ext/Time/HiRes/Makefile.PL Time::HiRes extension
! ext/Time/Piece/Makefile.PL Time::Piece extension
! ext/Time/Piece/Piece.pm Time::Piece extension
! ext/Time/Piece/Piece.t Test for Time::Piece
! ext/Time/Piece/Piece.xs Time::Piece extension
! ext/Time/Piece/README Time::Piece extension
! ext/Time/Piece/Seconds.pm Time::Piece extension
! ext/util/make_ext Used by Makefile to execute extension Makefiles
ext/XS/Typemap/Makefile.PL XS::Typemap extension
ext/XS/Typemap/README XS::Typemap extension
ext/XS/Typemap/stdio.c XS::Typemap extension
ext/XS/Typemap/typemap XS::Typemap extension
! ext/XS/Typemap/Typemap.pm XS::Typemap extension
! ext/XS/Typemap/Typemap.t test that typemaps work
! ext/XS/Typemap/Typemap.xs XS::Typemap extension
! EXTERN.h Included before foreign .h files
! fakesdio.h stdio in terms of PerlIO
! fakethr.h Fake threads header
! form.h Public declarations for formats
! global.sym Symbols that need hiding when embedded
! globals.c File to declare global symbols (for shared library)
! globvar.sym Global variables that need hiding when embedded
! gv.c Glob value code
! gv.h Glob value header
! h2pl/cbreak.pl cbreak routines using .ph
! h2pl/cbreak2.pl cbreak routines using .pl
! h2pl/eg/sizeof.ph Sample sizeof array initialization
! h2pl/eg/sys/errno.pl Sample translated errno.pl
! h2pl/eg/sys/ioctl.pl Sample translated ioctl.pl
! h2pl/eg/sysexits.pl Sample translated sysexits.pl
! h2pl/getioctlsizes Program to extract types from ioctl.h
! h2pl/mksizes Program to make %sizeof array
! h2pl/mkvars Program to make .pl from .ph files
! h2pl/README How to turn .ph files into .pl files
! h2pl/tcbreak cbreak test routine using .ph
! h2pl/tcbreak2 cbreak test routine using .pl
! handy.h Handy definitions
! hints/3b1.sh Hints for named architecture
! hints/3b1cc Hints for named architecture
! hints/aix.sh Hints for named architecture
! hints/altos486.sh Hints for named architecture
! hints/amigaos.sh Hints for named architecture
! hints/apollo.sh Hints for named architecture
! hints/atheos.sh Hints for named architecture
! hints/aux_3.sh Hints for named architecture
! hints/beos.sh Hints for named architecture
! hints/broken-db.msg Warning message for systems with broken DB library
! hints/bsdos.sh Hints for named architecture
! hints/convexos.sh Hints for named architecture
! hints/cxux.sh Hints for named architecture
! hints/cygwin.sh Hints for named architecture
! hints/darwin.sh Hints for named architecture
! hints/dcosx.sh Hints for named architecture
! hints/dec_osf.sh Hints for named architecture
! hints/dgux.sh Hints for named architecture
! hints/dos_djgpp.sh Hints for named architecture
! hints/dynix.sh Hints for named architecture
! hints/dynixptx.sh Hints for named architecture
! hints/epix.sh Hints for named architecture
! hints/esix4.sh Hints for named architecture
! hints/fps.sh Hints for named architecture
! hints/freebsd.sh Hints for named architecture
! hints/genix.sh Hints for named architecture
! hints/gnu.sh Hints for named architecture
! hints/greenhills.sh Hints for named architecture
! hints/hpux.sh Hints for named architecture
! hints/i386.sh Hints for named architecture
! hints/irix_4.sh Hints for named architecture
! hints/irix_5.sh Hints for named architecture
! hints/irix_6.sh Hints for named architecture
! hints/irix_6_0.sh Hints for named architecture
! hints/irix_6_1.sh Hints for named architecture
! hints/isc.sh Hints for named architecture
! hints/isc_2.sh Hints for named architecture
! hints/linux.sh Hints for named architecture
! hints/lynxos.sh Hints for named architecture
! hints/machten.sh Hints for named architecture
! hints/machten_2.sh Hints for named architecture
! hints/mint.sh Hints for named architecture
! hints/mips.sh Hints for named architecture
! hints/mpc.sh Hints for named architecture
! hints/mpeix.sh Hints for named architecture
! hints/ncr_tower.sh Hints for named architecture
! hints/netbsd.sh Hints for named architecture
! hints/newsos4.sh Hints for named architecture
! hints/next_3.sh Hints for named architecture
! hints/next_3_0.sh Hints for named architecture
! hints/next_4.sh Hints for named architecture
! hints/nonstopux.sh Hints for named architecture
! hints/openbsd.sh Hints for named architecture
! hints/opus.sh Hints for named architecture
! hints/os2.sh Hints for named architecture
! hints/os390.sh Hints for named architecture
! hints/posix-bc.sh Hints for named architecture
! hints/powerux.sh Hints for named architecture
! hints/qnx.sh Hints for named architecture
! hints/README.hints Notes about hints
! hints/rhapsody.sh Hints for named architecture
! hints/sco.sh Hints for named architecture
! hints/sco_2_3_0.sh Hints for named architecture
! hints/sco_2_3_1.sh Hints for named architecture
! hints/sco_2_3_2.sh Hints for named architecture
! hints/sco_2_3_3.sh Hints for named architecture
! hints/sco_2_3_4.sh Hints for named architecture
! hints/solaris_2.sh Hints for named architecture
! hints/stellar.sh Hints for named architecture
! hints/sunos_4_0.sh Hints for named architecture
! hints/sunos_4_1.sh Hints for named architecture
! hints/svr4.sh Hints for named architecture
! hints/svr5.sh Hints for named architecture
! hints/ti1500.sh Hints for named architecture
! hints/titanos.sh Hints for named architecture
! hints/ultrix_4.sh Hints for named architecture
! hints/umips.sh Hints for named architecture
! hints/unicos.sh Hints for named architecture
! hints/unicosmk.sh Hints for named architecture
! hints/unisysdynix.sh Hints for named architecture
! hints/utekv.sh Hints for named architecture
! hints/uts.sh Hints for named architecture
! hints/uwin.sh Hints for named architecture
! hints/vmesa.sh Hints for named architecture
! hv.c Hash value code
! hv.h Hash value header
! INSTALL Detailed installation instructions
! installhtml Perl script to install html files for pods
! installman Perl script to install man pages for pods
! installperl Perl script to do "make install" dirty work
! INTERN.h Included before domestic .h files
! intrpvar.h Variables held in each interpreter instance
! iperlsys.h Perl's interface to the system
! jpl/bin/jpl JPL compiler
! jpl/ChangeLog Java/Perl Lingo change log
! jpl/docs/Tutorial.pod Perl and Java Tutorial
! jpl/get_jdk/get_jdk.pl JDK download tool
! jpl/get_jdk/jdk_hosts JDK availability list
! jpl/get_jdk/README Instructions for using get_jdk.pl
! jpl/install-jpl JPL install utility
! jpl/JNI/Changes Java Native Interface changes
! jpl/JNI/Closer.java Java Native Interface example
! jpl/JNI/JNI.pm Java Native Interface module
! jpl/JNI/JNI.xs Java Native Interface module
! jpl/JNI/JNIConfig Java Native Interface config
! jpl/JNI/JNIConfig.kaffe Java Native Interface config
jpl/JNI/JNIConfig.noembed Java Native Interface config
jpl/JNI/JNIConfig.standard Java Native Interface config
! jpl/JNI/JNIConfig.Win32 Java Native Interface config
! jpl/JNI/Makefile.PL Java Native Interface makefile generator
! jpl/JNI/test.pl Java Native Interface tests
! jpl/JNI/typemap Java/Perl interface typemap
! jpl/JNI/typemap.gcc Java/Perl interface typemap
! jpl/JNI/typemap.win32 Java/Perl interface typemap
! jpl/JPL/AutoLoader.pm Java/Perl compiler module
! jpl/JPL/Class.pm Java/Perl compiler module
! jpl/JPL/Compile.pm Java/Perl compiler module
! jpl/JPL/Makefile.PL Java/Perl makefile generator
! jpl/JPL_Rolo/cardfile Rolodex sample application
! jpl/JPL_Rolo/JPL_Rolo.jpl Rolodex sample application
! jpl/JPL_Rolo/Makefile.PL Makefile generator
! jpl/JPL_Rolo/README Instructions
! jpl/PerlInterpreter/Makefile.PL Makefile generator
! jpl/PerlInterpreter/PerlInterpreter.c Perl interpreter abstraction
! jpl/PerlInterpreter/PerlInterpreter.h Perl interpreter abstraction
jpl/PerlInterpreter/PerlInterpreter.java Perl interpreter abstraction
! jpl/README JPL instructions
! jpl/README.JUST-JNI JPL instructions
! jpl/Sample/Makefile.PL JPL sample makefile generator
! jpl/Sample/Sample.jpl JPL sample
! jpl/SETVARS.PL JPL setup
! jpl/Test/Makefile.PL JPL tests makefile generator
! jpl/Test/Test.jpl JPL tests
! keywords.h The keyword numbers
! keywords.pl Program to write keywords.h
! lib/abbrev.pl An abbreviation table builder
! lib/AnyDBM_File.pm Perl module to emulate dbmopen
! lib/AnyDBM_File.t See if AnyDBM_File works
! lib/assert.pl assertion and panic with stack trace
! lib/Attribute/Handlers.pm Attribute::Handlers
! lib/Attribute/Handlers/Changes Attribute::Handlers
! lib/Attribute/Handlers/demo/demo.pl Attribute::Handlers demo
! lib/Attribute/Handlers/demo/Demo.pm Attribute::Handlers demo
! lib/Attribute/Handlers/demo/demo2.pl Attribute::Handlers demo
! lib/Attribute/Handlers/demo/demo3.pl Attribute::Handlers demo
! lib/Attribute/Handlers/demo/demo4.pl Attribute::Handlers demo
! lib/Attribute/Handlers/demo/demo_call.pl Attribute::Handlers demo
! lib/Attribute/Handlers/demo/demo_chain.pl Attribute::Handlers demo
! lib/Attribute/Handlers/demo/demo_cycle.pl Attribute::Handlers demo
! lib/Attribute/Handlers/demo/demo_hashdir.pl Attribute::Handlers demo
! lib/Attribute/Handlers/demo/demo_phases.pl Attribute::Handlers demo
! lib/Attribute/Handlers/demo/demo_range.pl Attribute::Handlers demo
! lib/Attribute/Handlers/demo/demo_rawdata.pl Attribute::Handlers demo
! lib/Attribute/Handlers/demo/Descriptions.pm Attribute::Handlers demo
! lib/Attribute/Handlers/demo/MyClass.pm Attribute::Handlers demo
! lib/Attribute/Handlers/README Attribute::Handlers
! lib/Attribute/Handlers/test.pl See if Attribute::Handlers works
! lib/attributes.pm For "sub foo : attrlist"
! lib/AutoLoader.pm Autoloader base class
! lib/AutoLoader.t See if AutoLoader works
! lib/AutoSplit.pm Split up autoload functions
! lib/autouse.pm Load and call a function only when it's used
! lib/autouse.t See if autouse works
! lib/base.pm Establish IS-A relationship at compile time
! lib/Benchmark.pm Measure execution time
! lib/Benchmark.t Perl code profiler testsuite driver
! lib/bigfloat.pl An arbitrary precision floating point package
! lib/bigfloat.t See if bigfloat.pl works
! lib/bigint.pl An arbitrary precision integer arithmetic package
! lib/bigint.t See if bigint.pl works
! lib/bigrat.pl An arbitrary precision rational arithmetic package
! lib/blib.pm For "use blib"
! lib/bytes.pm Pragma to enable byte operations
! lib/bytes_heavy.pl Support routines for byte pragma
! lib/cacheout.pl Manages output filehandles when you need too many
! lib/Carp.pm Error message base class
! lib/Carp.t See if Carp works
! lib/Carp/Heavy.pm Error message workhorse
! lib/CGI.pm Web server interface ("Common Gateway Interface")
! lib/CGI/Apache.pm Support for Apache's Perl module
! lib/CGI/Carp.pm Log server errors with helpful context
! lib/CGI/Cookie.pm Interface to Netscape Cookies
lib/CGI/eg/caution.xbm CGI example
lib/CGI/eg/clickable_image.cgi CGI example
lib/CGI/eg/cookie.cgi CGI example
***************
*** 684,1207 ****
lib/CGI/eg/nph-clock.cgi CGI example
lib/CGI/eg/nph-multipart.cgi CGI example
lib/CGI/eg/popup.cgi CGI example
lib/CGI/eg/save_state.cgi CGI example
lib/CGI/eg/tryit.cgi CGI example
lib/CGI/eg/wilogo_gif.uu CGI example
! lib/CPAN.pm Interface to Comprehensive Perl Archive Network
! lib/CPAN/FirstTime.pm Utility for creating CPAN config files
! lib/CPAN/Nox.pm Runs CPAN while avoiding compiled extensions
! lib/Carp.pm Error message base class
! lib/Carp/Heavy.pm Error message workhorse
! lib/Class/ISA.pm Class::ISA
! lib/Class/Struct.pm Declare struct-like datatypes as Perl classes
! lib/Cwd.pm Various cwd routines (getcwd, fastcwd, chdir)
! lib/DB.pm Debugger API (draft)
! lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm
! lib/Digest.pm Digest extensions
! lib/DirHandle.pm like FileHandle only for directories
! lib/Dumpvalue.pm Screen dump of perl values
! lib/English.pm Readable aliases for short variables
! lib/Env.pm Map environment into ordinary variables
! lib/Exporter.pm Exporter base class
! lib/Exporter/Heavy.pm Complicated routines for Exporter
! lib/ExtUtils/Command.pm Utilities for Make on non-UNIX platforms
! lib/ExtUtils/Embed.pm Utilities for embedding Perl in C programs
! lib/ExtUtils/Install.pm Handles 'make install' on extensions
lib/ExtUtils/Installed.pm Information on installed extensions
! lib/ExtUtils/Liblist.pm Locates libraries
lib/ExtUtils/MANIFEST.SKIP The default MANIFEST.SKIP
lib/ExtUtils/MM_Cygwin.pm MakeMaker methods for Cygwin
lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2
lib/ExtUtils/MM_Unix.pm MakeMaker base class for Unix
lib/ExtUtils/MM_VMS.pm MakeMaker methods for VMS
lib/ExtUtils/MM_Win32.pm MakeMaker methods for Win32
- lib/ExtUtils/MakeMaker.pm Write Makefiles for extensions
- lib/ExtUtils/Manifest.pm Utilities to write MANIFEST files
- lib/ExtUtils/Mkbootstrap.pm Writes a bootstrap file (see MakeMaker)
- lib/ExtUtils/Mksymlists.pm Writes a linker options file for extensions
lib/ExtUtils/Packlist.pm Manipulates .packlist files
- lib/ExtUtils/inst Give information about installed extensions
lib/ExtUtils/testlib.pm Fixes up @INC to use just-built extension
lib/ExtUtils/typemap Extension interface types
lib/ExtUtils/xsubpp External subroutine preprocessor
! lib/Fatal.pm Make errors in functions/builtins fatal
! lib/File/Basename.pm Emulate the basename program
! lib/File/CheckTree.pm Perl module supporting wholesale file mode validation
! lib/File/Compare.pm Emulation of cmp command
! lib/File/Copy.pm Emulation of cp command
! lib/File/DosGlob.pm Win32 DOS-globbing module
! lib/File/Find.pm Routines to do a find
! lib/File/Path.pm Do things like `mkdir -p' and `rm -r'
! lib/File/Spec.pm portable operations on file names
! lib/File/Spec/Epoc.pm portable operations on EPOC file names
lib/File/Spec/Functions.pm Function interface to File::Spec object methods
! lib/File/Spec/Mac.pm portable operations on Mac file names
! lib/File/Spec/OS2.pm portable operations on OS2 file names
! lib/File/Spec/Unix.pm portable operations on Unix file names
! lib/File/Spec/VMS.pm portable operations on VMS file names
! lib/File/Spec/Win32.pm portable operations on Win32 file names
! lib/File/Temp.pm create safe temporary files and file handles
! lib/File/stat.pm By-name interface to Perl's builtin stat
! lib/FileCache.pm Keep more files open than the system permits
! lib/FileHandle.pm Backward-compatible front end to IO extension
! lib/Filter/Simple.pm Simple frontend to Filter::Util::Call
! lib/FindBin.pm Find name of currently executing program
! lib/Getopt/Long.pm Fetch command options (GetOptions)
! lib/Getopt/Std.pm Fetch command options (getopt, getopts)
! lib/I18N/Collate.pm Routines to do strxfrm-based collation
! lib/IPC/Open2.pm Open a two-ended pipe
! lib/IPC/Open3.pm Open a three-ended pipe!
! lib/Locale/Constants.pm Locale::Codes
! lib/Locale/Country.pm Locale::Codes
! lib/Locale/Currency.pm Locale::Codes
! lib/Locale/Language.pm Locale::Codes
! lib/Math/BigFloat.pm An arbitrary precision floating-point arithmetic package
! lib/Math/BigInt.pm An arbitrary precision integer arithmetic package
! lib/Math/Complex.pm A Complex package
! lib/Math/Trig.pm A simple interface to complex trigonometry
! lib/Net/Ping.pm Hello, anybody home?
! lib/Net/hostent.pm By-name interface to Perl's builtin gethost*
! lib/Net/netent.pm By-name interface to Perl's builtin getnet*
! lib/Net/protoent.pm By-name interface to Perl's builtin getproto*
! lib/Net/servent.pm By-name interface to Perl's builtin getserv*
! lib/PerlIO.pm PerlIO support module
! lib/Pod/Checker.pm Pod-Parser - check POD documents for syntax errors
! lib/Pod/Find.pm used by pod/splitpod
! lib/Pod/Functions.pm used by pod/splitpod
! lib/Pod/Html.pm Convert POD data to HTML
! lib/Pod/InputObjects.pm Pod-Parser - define objects for input streams
! lib/Pod/LaTeX.pm Convert POD data to LaTeX
! lib/Pod/Man.pm Convert POD data to *roff
! lib/Pod/ParseUtils.pm Pod-Parser - pod utility functions
! lib/Pod/Parser.pm Pod-Parser - define base class for parsing POD
! lib/Pod/Plainer.pm Pod migration utility module
! lib/Pod/Select.pm Pod-Parser - select portions of POD docs
! lib/Pod/Text.pm Pod-Parser - convert POD data to formatted ASCII text
! lib/Pod/Text/Color.pm Convert POD data to color ASCII text
lib/Pod/Text/Overstrike.pm Convert POD data to formatted overstrike text
! lib/Pod/Text/Termcap.pm Convert POD data to ASCII text with format escapes
! lib/Pod/Usage.pm Pod-Parser - print usage messages
! lib/Search/Dict.pm Perform binary search on dictionaries
! lib/SelectSaver.pm Enforce proper select scoping
! lib/SelfLoader.pm Load functions only on demand
! lib/Shell.pm Make AUTOLOADed system() calls
! lib/Switch.pm Switch for Perl
! lib/Symbol.pm Symbol table manipulation routines
! lib/Term/ANSIColor.pm Perl module supporting termcap usage
! lib/Term/Cap.pm Perl module supporting termcap usage
! lib/Term/Complete.pm A command completion subroutine
! lib/Term/ReadLine.pm Stub readline library
! lib/Test.pm A simple framework for writing test scripts
! lib/Test/Harness.pm A test harness
! lib/Text/Abbrev.pm An abbreviation table builder
! lib/Text/Balanced.pm Text::Balanced
! lib/Text/Balanced.pod Text::Balanced
! lib/Text/ParseWords.pm Perl module to split words on arbitrary delimiter
! lib/Text/Soundex.pm Perl module to implement Soundex
! lib/Text/Tabs.pm Do expand and unexpand
! lib/Text/Wrap.pm Paragraph formatter
! lib/Tie/Array.pm Base class for tied arrays
! lib/Tie/Handle.pm Base class for tied handles
! lib/Tie/Hash.pm Base class for tied hashes
! lib/Tie/RefHash.pm Base class for tied hashes with references as keys
! lib/Tie/Scalar.pm Base class for tied scalars
! lib/Tie/SubstrHash.pm Compact hash for known key, value and table size
! lib/Time/Local.pm Reverse translation of localtime, gmtime
! lib/Time/gmtime.pm By-name interface to Perl's builtin gmtime
! lib/Time/localtime.pm By-name interface to Perl's builtin localtime
! lib/Time/tm.pm Internal object for Time::{gm,local}time
! lib/UNIVERSAL.pm Base class for ALL classes
! lib/User/grent.pm By-name interface to Perl's builtin getgr*
! lib/User/pwent.pm By-name interface to Perl's builtin getpw*
! lib/Win32.pod Documentation for Win32 extras
! lib/abbrev.pl An abbreviation table builder
! lib/assert.pl assertion and panic with stack trace
! lib/attributes.pm For "sub foo : attrlist"
! lib/autouse.pm Load and call a function only when it's used
! lib/base.pm Establish IS-A relationship at compile time
! lib/bigfloat.pl An arbitrary precision floating point package
! lib/bigint.pl An arbitrary precision integer arithmetic package
! lib/bigrat.pl An arbitrary precision rational arithmetic package
! lib/blib.pm For "use blib"
! lib/bytes.pm Pragma to enable byte operations
! lib/bytes_heavy.pl Support routines for byte pragma
! lib/cacheout.pl Manages output filehandles when you need too many
! lib/charnames.pm Character names
! lib/complete.pl A command completion subroutine
! lib/constant.pm For "use constant"
! lib/ctime.pl A ctime workalike
! lib/diagnostics.pm Print verbose diagnostics
! lib/dotsh.pl Code to "dot" in a shell script
! lib/dumpvar.pl A variable dumper
! lib/exceptions.pl catch and throw routines
! lib/fastcwd.pl a faster but more dangerous getcwd
! lib/fields.pm Set up object field names for pseudo-hash-using classes
! lib/filetest.pm For "use filetest"
! lib/find.pl A find emulator--used by find2perl
! lib/finddepth.pl A depth-first find emulator--used by find2perl
! lib/flush.pl Routines to do single flush
! lib/ftp.pl FTP code (obsolete, use Net::FTP instead)
! lib/getcwd.pl A getcwd() emulator
! lib/getopt.pl Perl library supporting option parsing
! lib/getopts.pl Perl library supporting option parsing
! lib/hostname.pl Old hostname code
! lib/importenv.pl Perl routine to get environment into variables
! lib/integer.pm For "use integer"
! lib/less.pm For "use less"
! lib/lib_pm.PL For "use lib", produces lib/lib.pm
! lib/locale.pm For "use locale"
! lib/look.pl A "look" equivalent
! lib/newgetopt.pl A perl library supporting long option parsing
! lib/open.pm Pragma to specify default I/O disciplines
! lib/open2.pl Open a two-ended pipe (uses IPC::Open2)
! lib/open3.pl Open a three-ended pipe (uses IPC::Open3)
! lib/overload.pm Module for overloading perl operators
! lib/perl5db.pl Perl debugging routines
! lib/pwd.pl Routines to keep track of PWD environment variable
! lib/shellwords.pl Perl library to split into words with shell quoting
! lib/sigtrap.pm For trapping an abort and giving traceback
! lib/stat.pl Perl library supporting stat function
! lib/strict.pm For "use strict"
! lib/subs.pm Declare overriding subs
! lib/syslog.pl Perl library supporting syslogging
! lib/tainted.pl Old code for tainting
! lib/termcap.pl Perl library supporting termcap usage
! lib/timelocal.pl Perl library supporting inverse of localtime, gmtime
! lib/unicode/ArabLink.pl Unicode character database
! lib/unicode/ArabLnkGrp.pl Unicode character database
! lib/unicode/ArabShap.txt Unicode character database
! lib/unicode/BidiMirr.txt Unicode character database
! lib/unicode/Bidirectional.pl Unicode character database
! lib/unicode/Block.pl Unicode character database
! lib/unicode/Blocks.txt Unicode character database
! lib/unicode/CaseFold.txt Unicode character database
! lib/unicode/Category.pl Unicode character database
! lib/unicode/CombiningClass.pl Unicode character database
! lib/unicode/CompExcl.txt Unicode character database
! lib/unicode/Decomposition.pl Unicode character database
! lib/unicode/EAWidth.txt Unicode character database
! lib/unicode/In/AlphabeticPresentationForms.pl Unicode character database
! lib/unicode/In/Arabic.pl Unicode character database
! lib/unicode/In/ArabicPresentationForms-A.pl Unicode character database
! lib/unicode/In/ArabicPresentationForms-B.pl Unicode character database
! lib/unicode/In/Armenian.pl Unicode character database
! lib/unicode/In/Arrows.pl Unicode character database
! lib/unicode/In/BasicLatin.pl Unicode character database
! lib/unicode/In/Bengali.pl Unicode character database
! lib/unicode/In/BlockElements.pl Unicode character database
! lib/unicode/In/Bopomofo.pl Unicode character database
! lib/unicode/In/BopomofoExtended.pl Unicode character database
! lib/unicode/In/BoxDrawing.pl Unicode character database
! lib/unicode/In/BraillePatterns.pl Unicode character database
! lib/unicode/In/CJKCompatibility.pl Unicode character database
! lib/unicode/In/CJKCompatibilityForms.pl Unicode character database
! lib/unicode/In/CJKCompatibilityIdeographs.pl Unicode character database
! lib/unicode/In/CJKRadicalsSupplement.pl Unicode character database
! lib/unicode/In/CJKSymbolsandPunctuation.pl Unicode character database
! lib/unicode/In/CJKUnifiedIdeographs.pl Unicode character database
! lib/unicode/In/CJKUnifiedIdeographsExtensionA.pl Unicode character database
! lib/unicode/In/Cherokee.pl Unicode character database
! lib/unicode/In/CombiningDiacriticalMarks.pl Unicode character database
! lib/unicode/In/CombiningHalfMarks.pl Unicode character database
! lib/unicode/In/CombiningMarksforSymbols.pl Unicode character database
! lib/unicode/In/ControlPictures.pl Unicode character database
! lib/unicode/In/CurrencySymbols.pl Unicode character database
! lib/unicode/In/Cyrillic.pl Unicode character database
! lib/unicode/In/Devanagari.pl Unicode character database
! lib/unicode/In/Dingbats.pl Unicode character database
! lib/unicode/In/EnclosedAlphanumerics.pl Unicode character database
! lib/unicode/In/EnclosedCJKLettersandMonths.pl Unicode character database
! lib/unicode/In/Ethiopic.pl Unicode character database
! lib/unicode/In/GeneralPunctuation.pl Unicode character database
! lib/unicode/In/GeometricShapes.pl Unicode character database
! lib/unicode/In/Georgian.pl Unicode character database
! lib/unicode/In/Greek.pl Unicode character database
! lib/unicode/In/GreekExtended.pl Unicode character database
! lib/unicode/In/Gujarati.pl Unicode character database
! lib/unicode/In/Gurmukhi.pl Unicode character database
! lib/unicode/In/HalfwidthandFullwidthForms.pl Unicode character database
! lib/unicode/In/HangulCompatibilityJamo.pl Unicode character database
! lib/unicode/In/HangulJamo.pl Unicode character database
! lib/unicode/In/HangulSyllables.pl Unicode character database
! lib/unicode/In/Hebrew.pl Unicode character database
! lib/unicode/In/HighPrivateUseSurrogates.pl Unicode character database
! lib/unicode/In/HighSurrogates.pl Unicode character database
! lib/unicode/In/Hiragana.pl Unicode character database
! lib/unicode/In/IPAExtensions.pl Unicode character database
! lib/unicode/In/IdeographicDescriptionCharacters.pl Unicode character database
! lib/unicode/In/Kanbun.pl Unicode character database
! lib/unicode/In/KangxiRadicals.pl Unicode character database
! lib/unicode/In/Kannada.pl Unicode character database
! lib/unicode/In/Katakana.pl Unicode character database
! lib/unicode/In/Khmer.pl Unicode character database
! lib/unicode/In/Lao.pl Unicode character database
! lib/unicode/In/Latin-1Supplement.pl Unicode character database
! lib/unicode/In/LatinExtended-A.pl Unicode character database
! lib/unicode/In/LatinExtended-B.pl Unicode character database
! lib/unicode/In/LatinExtendedAdditional.pl Unicode character database
! lib/unicode/In/LetterlikeSymbols.pl Unicode character database
! lib/unicode/In/LowSurrogates.pl Unicode character database
! lib/unicode/In/Malayalam.pl Unicode character database
! lib/unicode/In/MathematicalOperators.pl Unicode character database
! lib/unicode/In/MiscellaneousSymbols.pl Unicode character database
! lib/unicode/In/MiscellaneousTechnical.pl Unicode character database
! lib/unicode/In/Mongolian.pl Unicode character database
! lib/unicode/In/Myanmar.pl Unicode character database
! lib/unicode/In/NumberForms.pl Unicode character database
! lib/unicode/In/Ogham.pl Unicode character database
! lib/unicode/In/OpticalCharacterRecognition.pl Unicode character database
! lib/unicode/In/Oriya.pl Unicode character database
! lib/unicode/In/PrivateUse.pl Unicode character database
! lib/unicode/In/Runic.pl Unicode character database
! lib/unicode/In/Sinhala.pl Unicode character database
! lib/unicode/In/SmallFormVariants.pl Unicode character database
! lib/unicode/In/SpacingModifierLetters.pl Unicode character database
! lib/unicode/In/Specials.pl Unicode character database
! lib/unicode/In/SuperscriptsandSubscripts.pl Unicode character database
! lib/unicode/In/Syriac.pl Unicode character database
! lib/unicode/In/Tamil.pl Unicode character database
! lib/unicode/In/Telugu.pl Unicode character database
! lib/unicode/In/Thaana.pl Unicode character database
! lib/unicode/In/Thai.pl Unicode character database
! lib/unicode/In/Tibetan.pl Unicode character database
! lib/unicode/In/UnifiedCanadianAboriginalSyllabics.pl Unicode character database
! lib/unicode/In/YiRadicals.pl Unicode character database
! lib/unicode/In/YiSyllables.pl Unicode character database
! lib/unicode/Index.txt Unicode character database
! lib/unicode/Is/ASCII.pl Unicode character database
! lib/unicode/Is/Alnum.pl Unicode character database
! lib/unicode/Is/Alpha.pl Unicode character database
! lib/unicode/Is/BidiAL.pl Unicode character database
! lib/unicode/Is/BidiAN.pl Unicode character database
! lib/unicode/Is/BidiB.pl Unicode character database
! lib/unicode/Is/BidiBN.pl Unicode character database
! lib/unicode/Is/BidiCS.pl Unicode character database
! lib/unicode/Is/BidiEN.pl Unicode character database
! lib/unicode/Is/BidiES.pl Unicode character database
! lib/unicode/Is/BidiET.pl Unicode character database
! lib/unicode/Is/BidiL.pl Unicode character database
! lib/unicode/Is/BidiLRE.pl Unicode character database
! lib/unicode/Is/BidiLRO.pl Unicode character database
! lib/unicode/Is/BidiNSM.pl Unicode character database
! lib/unicode/Is/BidiON.pl Unicode character database
! lib/unicode/Is/BidiPDF.pl Unicode character database
! lib/unicode/Is/BidiR.pl Unicode character database
! lib/unicode/Is/BidiRLE.pl Unicode character database
! lib/unicode/Is/BidiRLO.pl Unicode character database
! lib/unicode/Is/BidiS.pl Unicode character database
! lib/unicode/Is/BidiWS.pl Unicode character database
! lib/unicode/Is/Blank.pl Unicode character database
! lib/unicode/Is/C.pl Unicode character database
! lib/unicode/Is/Cc.pl Unicode character database
! lib/unicode/Is/Cf.pl Unicode character database
! lib/unicode/Is/Cn.pl Unicode character database
! lib/unicode/Is/Cntrl.pl Unicode character database
! lib/unicode/Is/Co.pl Unicode character database
! lib/unicode/Is/Cs.pl Unicode character database
! lib/unicode/Is/DCcircle.pl Unicode character database
! lib/unicode/Is/DCcompat.pl Unicode character database
! lib/unicode/Is/DCfinal.pl Unicode character database
! lib/unicode/Is/DCfont.pl Unicode character database
! lib/unicode/Is/DCfraction.pl Unicode character database
! lib/unicode/Is/DCinitial.pl Unicode character database
! lib/unicode/Is/DCisolated.pl Unicode character database
! lib/unicode/Is/DCmedial.pl Unicode character database
! lib/unicode/Is/DCnarrow.pl Unicode character database
! lib/unicode/Is/DCnoBreak.pl Unicode character database
! lib/unicode/Is/DCsmall.pl Unicode character database
! lib/unicode/Is/DCsquare.pl Unicode character database
! lib/unicode/Is/DCsub.pl Unicode character database
! lib/unicode/Is/DCsuper.pl Unicode character database
! lib/unicode/Is/DCvertical.pl Unicode character database
! lib/unicode/Is/DCwide.pl Unicode character database
! lib/unicode/Is/DecoCanon.pl Unicode character database
! lib/unicode/Is/DecoCompat.pl Unicode character database
! lib/unicode/Is/Digit.pl Unicode character database
! lib/unicode/Is/Graph.pl Unicode character database
! lib/unicode/Is/L.pl Unicode character database
! lib/unicode/Is/LbrkAI.pl Unicode character database
! lib/unicode/Is/LbrkAL.pl Unicode character database
! lib/unicode/Is/LbrkB2.pl Unicode character database
! lib/unicode/Is/LbrkBA.pl Unicode character database
! lib/unicode/Is/LbrkBB.pl Unicode character database
! lib/unicode/Is/LbrkBK.pl Unicode character database
! lib/unicode/Is/LbrkCB.pl Unicode character database
! lib/unicode/Is/LbrkCL.pl Unicode character database
! lib/unicode/Is/LbrkCM.pl Unicode character database
! lib/unicode/Is/LbrkCR.pl Unicode character database
! lib/unicode/Is/LbrkEX.pl Unicode character database
! lib/unicode/Is/LbrkGL.pl Unicode character database
! lib/unicode/Is/LbrkHY.pl Unicode character database
! lib/unicode/Is/LbrkID.pl Unicode character database
! lib/unicode/Is/LbrkIN.pl Unicode character database
! lib/unicode/Is/LbrkIS.pl Unicode character database
! lib/unicode/Is/LbrkLF.pl Unicode character database
! lib/unicode/Is/LbrkNS.pl Unicode character database
! lib/unicode/Is/LbrkNU.pl Unicode character database
! lib/unicode/Is/LbrkOP.pl Unicode character database
! lib/unicode/Is/LbrkPO.pl Unicode character database
! lib/unicode/Is/LbrkPR.pl Unicode character database
! lib/unicode/Is/LbrkQU.pl Unicode character database
! lib/unicode/Is/LbrkSA.pl Unicode character database
! lib/unicode/Is/LbrkSG.pl Unicode character database
! lib/unicode/Is/LbrkSP.pl Unicode character database
! lib/unicode/Is/LbrkSY.pl Unicode character database
! lib/unicode/Is/LbrkXX.pl Unicode character database
! lib/unicode/Is/LbrkZW.pl Unicode character database
! lib/unicode/Is/Ll.pl Unicode character database
! lib/unicode/Is/Lm.pl Unicode character database
! lib/unicode/Is/Lo.pl Unicode character database
! lib/unicode/Is/Lower.pl Unicode character database
! lib/unicode/Is/Lt.pl Unicode character database
! lib/unicode/Is/Lu.pl Unicode character database
! lib/unicode/Is/M.pl Unicode character database
! lib/unicode/Is/Mc.pl Unicode character database
! lib/unicode/Is/Me.pl Unicode character database
! lib/unicode/Is/Mirrored.pl Unicode character database
! lib/unicode/Is/Mn.pl Unicode character database
! lib/unicode/Is/N.pl Unicode character database
! lib/unicode/Is/Nd.pl Unicode character database
! lib/unicode/Is/Nl.pl Unicode character database
! lib/unicode/Is/No.pl Unicode character database
! lib/unicode/Is/P.pl Unicode character database
! lib/unicode/Is/Pc.pl Unicode character database
! lib/unicode/Is/Pd.pl Unicode character database
! lib/unicode/Is/Pe.pl Unicode character database
! lib/unicode/Is/Pf.pl Unicode character database
! lib/unicode/Is/Pi.pl Unicode character database
! lib/unicode/Is/Po.pl Unicode character database
! lib/unicode/Is/Print.pl Unicode character database
! lib/unicode/Is/Ps.pl Unicode character database
! lib/unicode/Is/Punct.pl Unicode character database
! lib/unicode/Is/S.pl Unicode character database
! lib/unicode/Is/Sc.pl Unicode character database
! lib/unicode/Is/Sk.pl Unicode character database
! lib/unicode/Is/Sm.pl Unicode character database
! lib/unicode/Is/So.pl Unicode character database
! lib/unicode/Is/Space.pl Unicode character database
! lib/unicode/Is/SpacePerl.pl Unicode character database
! lib/unicode/Is/SylA.pl Unicode character database
! lib/unicode/Is/SylAA.pl Unicode character database
! lib/unicode/Is/SylAAI.pl Unicode character database
! lib/unicode/Is/SylAI.pl Unicode character database
! lib/unicode/Is/SylC.pl Unicode character database
! lib/unicode/Is/SylE.pl Unicode character database
! lib/unicode/Is/SylEE.pl Unicode character database
! lib/unicode/Is/SylI.pl Unicode character database
! lib/unicode/Is/SylII.pl Unicode character database
! lib/unicode/Is/SylN.pl Unicode character database
! lib/unicode/Is/SylO.pl Unicode character database
! lib/unicode/Is/SylOO.pl Unicode character database
! lib/unicode/Is/SylU.pl Unicode character database
! lib/unicode/Is/SylV.pl Unicode character database
! lib/unicode/Is/SylWA.pl Unicode character database
! lib/unicode/Is/SylWAA.pl Unicode character database
! lib/unicode/Is/SylWC.pl Unicode character database
! lib/unicode/Is/SylWE.pl Unicode character database
! lib/unicode/Is/SylWEE.pl Unicode character database
! lib/unicode/Is/SylWI.pl Unicode character database
! lib/unicode/Is/SylWII.pl Unicode character database
! lib/unicode/Is/SylWO.pl Unicode character database
! lib/unicode/Is/SylWOO.pl Unicode character database
! lib/unicode/Is/SylWU.pl Unicode character database
! lib/unicode/Is/SylWV.pl Unicode character database
! lib/unicode/Is/Syllable.pl Unicode character database
! lib/unicode/Is/Upper.pl Unicode character database
! lib/unicode/Is/Word.pl Unicode character database
! lib/unicode/Is/XDigit.pl Unicode character database
! lib/unicode/Is/Z.pl Unicode character database
! lib/unicode/Is/Zl.pl Unicode character database
! lib/unicode/Is/Zp.pl Unicode character database
! lib/unicode/Is/Zs.pl Unicode character database
! lib/unicode/Jamo.txt Unicode character database
! lib/unicode/JamoShort.pl Unicode character database
! lib/unicode/LineBrk.txt Unicode character database
! lib/unicode/Makefile Unicode character database
! lib/unicode/Name.pl Unicode character database
! lib/unicode/NamesList.html Unicode character database
! lib/unicode/NamesList.txt Unicode character database
! lib/unicode/Number.pl Unicode character database
! lib/unicode/PropList.html Unicode character database
! lib/unicode/PropList.txt Unicode character database
! lib/unicode/README.perl Unicode character database
! lib/unicode/ReadMe.txt Unicode character database info
! lib/unicode/Scripts.txt Unicode character database
! lib/unicode/SpecCase.txt Unicode character database
! lib/unicode/To/Digit.pl Unicode character database
! lib/unicode/To/Lower.pl Unicode character database
! lib/unicode/To/Title.pl Unicode character database
! lib/unicode/To/Upper.pl Unicode character database
! lib/unicode/UCD.html Unicode character database
! lib/unicode/Unicode.html Unicode character database
! lib/unicode/Unicode.txt Unicode character database
! lib/unicode/distinct.pm Perl pragma to strictly distinguish UTF8 data and non-UTF data
! lib/unicode/mktables.PL Unicode character database generator
! lib/unicode/rename Filename mappings used
! lib/unicode/syllables.txt Unicode character database
! lib/unicode/version The version of the Unicode
! lib/utf8.pm Pragma to control Unicode support
! lib/utf8_heavy.pl Support routines for utf8 pragma
! lib/validate.pl Perl library supporting wholesale file mode validation
! lib/vars.pm Declare pseudo-imported global variables
! lib/warnings.pm For "use warnings"
lib/warnings/register.pm For "use warnings::register"
! makeaperl.SH perl script that produces a new perl binary
! makedef.pl Create symbol export lists for linking
! makedepend.SH Precursor to makedepend
! makedir.SH Precursor to makedir
! malloc.c A version of malloc you might not want
! mg.c Magic code
! mg.h Magic header
! minimod.pl Writes lib/ExtUtils/Miniperl.pm
! miniperlmain.c Basic perl w/o dynamic loading or extensions
! mint/Makefile MiNT port
! mint/README MiNT port
! mint/errno.h MiNT port
! mint/pwd.c MiNT port
! mint/stdio.h MiNT port
! mint/sys/time.h MiNT port
! mint/time.h MiNT port
! mpeix/mpeixish.h MPE/iX port
! mpeix/nm MPE/iX port
! mpeix/relink MPE/iX port
! mv-if-diff Script to mv a file if it changed
! myconfig.SH Prints summary of the current configuration
! nostdio.h Cause compile error on stdio calls
! objXSUB.h Scoping macros for Perl Object in extensions
! op.c Opcode syntax tree code
! op.h Opcode syntax tree header
! opcode.h Automatically generated opcode header
! opcode.pl Opcode header generatore
! opnames.h Automatically generated opcode header
! os2/Changes Changelog for OS/2 port
! os2/Makefile.SHs Shared library generation for OS/2
os2/OS2/ExtAttr/Changes EA access module
os2/OS2/ExtAttr/ExtAttr.pm EA access module
os2/OS2/ExtAttr/ExtAttr.xs EA access module
- os2/OS2/ExtAttr/MANIFEST EA access module
os2/OS2/ExtAttr/Makefile.PL EA access module
os2/OS2/ExtAttr/myea.h EA access module
os2/OS2/ExtAttr/t/os2_ea.t EA access module
os2/OS2/ExtAttr/typemap EA access module
os2/OS2/PrfDB/Changes System database access module
- os2/OS2/PrfDB/MANIFEST System database access module
os2/OS2/PrfDB/Makefile.PL System database access module
os2/OS2/PrfDB/PrfDB.pm System database access module
os2/OS2/PrfDB/PrfDB.xs System database access module
os2/OS2/PrfDB/t/os2_prfdb.t System database access module
os2/OS2/PrfDB/typemap System database access module
- os2/OS2/Process/MANIFEST system() constants in a module
os2/OS2/Process/Makefile.PL system() constants in a module
os2/OS2/Process/Process.pm system() constants in a module
os2/OS2/Process/Process.xs system() constants in a module
os2/OS2/REXX/Changes DLL access module
! os2/OS2/REXX/DLL/Changes DLL access module
os2/OS2/REXX/DLL/DLL.pm DLL access module
os2/OS2/REXX/DLL/DLL.xs DLL access module
- os2/OS2/REXX/DLL/MANIFEST DLL access module
os2/OS2/REXX/DLL/Makefile.PL DLL access module
! os2/OS2/REXX/MANIFEST DLL access module
os2/OS2/REXX/Makefile.PL DLL access module
os2/OS2/REXX/REXX.pm DLL access module
os2/OS2/REXX/REXX.xs DLL access module
os2/OS2/REXX/t/rx_cmprt.t DLL access module
--- 786,1628 ----
lib/CGI/eg/nph-clock.cgi CGI example
lib/CGI/eg/nph-multipart.cgi CGI example
lib/CGI/eg/popup.cgi CGI example
+ lib/CGI/eg/RunMeFirst Setup script for CGI examples
lib/CGI/eg/save_state.cgi CGI example
lib/CGI/eg/tryit.cgi CGI example
lib/CGI/eg/wilogo_gif.uu CGI example
! lib/CGI/Fast.pm Support for FastCGI (persistent server process)
! lib/CGI/Pretty.pm Output nicely formatted HTML
! lib/CGI/Push.pm Support for server push
! lib/CGI/Switch.pm Simple interface for multiple server types
! lib/CGI/t/form.t See if CGI.pm works
! lib/CGI/t/function.t See if CGI.pm works
! lib/CGI/t/html.t See if CGI.pm works
! lib/CGI/t/pretty.t See if CGI.pm works
! lib/CGI/t/request.t See if CGI.pm works
! lib/CGI/t/util.t See if CGI.pm works
! lib/CGI/Util.pm Utility functions
! lib/charnames.pm Character names
! lib/charnames.t See if character names work
! lib/Class/ISA.pm Class::ISA
! lib/Class/ISA/test.pl See if Class::ISA works
! lib/Class/Struct.pm Declare struct-like datatypes as Perl classes
! lib/Class/Struct.t See if Class::Struct works
! lib/complete.pl A command completion subroutine
! lib/constant.pm For "use constant"
! lib/constant.t See if compile-time constants work
! lib/CPAN.pm Interface to Comprehensive Perl Archive Network
! lib/CPAN/FirstTime.pm Utility for creating CPAN config files
! lib/CPAN/Nox.pm Runs CPAN while avoiding compiled extensions
! lib/CPAN/t/loadme.t See if CPAN the module works
! lib/CPAN/t/vcmp.t See if CPAN the module works
! lib/ctime.pl A ctime workalike
! lib/Cwd.pm Various cwd routines (getcwd, fastcwd, chdir)
! lib/DB.pm Debugger API (draft)
! lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm
! lib/Devel/SelfStubber.t See if Devel::SelfStubber works
! lib/diagnostics.pm Print verbose diagnostics
! lib/diagnostics.t See if diagnostics.pm works
! lib/Digest.pm Digest extensions
! lib/Digest.t See if Digest extensions work
! lib/DirHandle.pm like FileHandle only for directories
! lib/DirHandle.t See if DirHandle works
! lib/dotsh.pl Code to "dot" in a shell script
! lib/Dumpvalue.pm Screen dump of perl values
! lib/dumpvar.pl A variable dumper
! lib/English.pm Readable aliases for short variables
! lib/English.t See if English works
! lib/Env.pm Map environment into ordinary variables
! lib/Env/array.t See if Env works
! lib/Env/env.t See if Env works for arrays
! lib/exceptions.pl catch and throw routines
! lib/Exporter.pm Exporter base class
! lib/Exporter.t See if Exporter works
! lib/Exporter/Heavy.pm Complicated routines for Exporter
! lib/ExtUtils.t See if extutils work
! lib/ExtUtils/Command.pm Utilities for Make on non-UNIX platforms
! lib/ExtUtils/Constant.pm generate XS code to import C header constants
! lib/ExtUtils/Embed.pm Utilities for embedding Perl in C programs
! lib/ExtUtils/inst Give information about installed extensions
! lib/ExtUtils/Install.pm Handles 'make install' on extensions
lib/ExtUtils/Installed.pm Information on installed extensions
! lib/ExtUtils/Liblist.pm Locates libraries
! lib/ExtUtils/MakeMaker.pm Write Makefiles for extensions
! lib/ExtUtils/Manifest.pm Utilities to write MANIFEST files
lib/ExtUtils/MANIFEST.SKIP The default MANIFEST.SKIP
+ lib/ExtUtils/Mkbootstrap.pm Writes a bootstrap file (see MakeMaker)
+ lib/ExtUtils/Mksymlists.pm Writes a linker options file for extensions
lib/ExtUtils/MM_Cygwin.pm MakeMaker methods for Cygwin
+ lib/ExtUtils/MM_NW5.pm MakeMaker methods for NetWare
lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2
lib/ExtUtils/MM_Unix.pm MakeMaker base class for Unix
lib/ExtUtils/MM_VMS.pm MakeMaker methods for VMS
lib/ExtUtils/MM_Win32.pm MakeMaker methods for Win32
lib/ExtUtils/Packlist.pm Manipulates .packlist files
lib/ExtUtils/testlib.pm Fixes up @INC to use just-built extension
lib/ExtUtils/typemap Extension interface types
lib/ExtUtils/xsubpp External subroutine preprocessor
! lib/fastcwd.pl a faster but more dangerous getcwd
! lib/Fatal.pm Make errors in functions/builtins fatal
! lib/Fatal.t See if Fatal works
! lib/fields.pm Set up object field names for pseudo-hash-using classes
! lib/fields.t See if base/fields works
! lib/File/Basename.pm Emulate the basename program
! lib/File/Basename.t See if File::Basename works
! lib/File/CheckTree.pm Perl module supporting wholesale file mode validation
! lib/File/CheckTree.t See if File::CheckTree works
! lib/File/Compare.pm Emulation of cmp command
! lib/File/Compare.t See if File::Compare works
! lib/File/Copy.pm Emulation of cp command
! lib/File/Copy.t See if File::Copy works
! lib/File/DosGlob.pm Win32 DOS-globbing module
! lib/File/DosGlob.t See if File::DosGlob works
! lib/File/Find.pm Routines to do a find
! lib/File/Find/find.t See if File::Find works
! lib/File/Find/taint.t See if File::Find works with taint
! lib/File/Path.pm Do things like `mkdir -p' and `rm -r'
! lib/File/Path.t See if File::Path works
! lib/File/Spec.pm portable operations on file names
! lib/File/Spec.t See if File::Spec works
! lib/File/Spec/Epoc.pm portable operations on EPOC file names
lib/File/Spec/Functions.pm Function interface to File::Spec object methods
! lib/File/Spec/Functions.t See if File::Spec::Functions works
! lib/File/Spec/Mac.pm portable operations on Mac file names
! lib/File/Spec/OS2.pm portable operations on OS2 file names
! lib/File/Spec/Unix.pm portable operations on Unix file names
! lib/File/Spec/VMS.pm portable operations on VMS file names
! lib/File/Spec/Win32.pm portable operations on Win32 file names
! lib/File/stat.pm By-name interface to Perl's builtin stat
! lib/File/stat.t See if File::stat works
! lib/File/Temp.pm create safe temporary files and file handles
! lib/File/Temp/t/mktemp.t See if File::Temp works
! lib/File/Temp/t/posix.t See if File::Temp works
! lib/File/Temp/t/security.t See if File::Temp works
! lib/File/Temp/t/tempfile.t See if File::Temp works
! lib/FileCache.pm Keep more files open than the system permits
! lib/FileCache.t See if FileCache works
! lib/FileHandle.pm Backward-compatible front end to IO extension
! lib/FileHandle.t See if FileHandle works
! lib/filetest.pm For "use filetest"
! lib/Filter/Simple.pm Simple frontend to Filter::Util::Call
! lib/Filter/Simple/test.pl See if Filter::Simple works
! lib/find.pl A find emulator--used by find2perl
! lib/FindBin.pm Find name of currently executing program
! lib/FindBin.t See if FindBin works
! lib/finddepth.pl A depth-first find emulator--used by find2perl
! lib/flush.pl Routines to do single flush
! lib/ftp.pl FTP code (obsolete, use Net::FTP instead)
! lib/getcwd.pl A getcwd() emulator
! lib/getopt.pl Perl library supporting option parsing
! lib/Getopt/Long.pm Fetch command options (GetOptions)
! lib/Getopt/Long/t/basic.t See if Getopt::Long works
! lib/Getopt/Long/t/compat.t See if Getopt::Long works
! lib/Getopt/Long/t/linkage.t See if Getopt::Long works
! lib/Getopt/Long/t/oo.t See if Getopt::Long works
! lib/Getopt/Std.pm Fetch command options (getopt, getopts)
! lib/Getopt/Std.t See if Getopt::Std and Getopt::Long work
! lib/getopts.pl Perl library supporting option parsing
! lib/h2ph.t See if h2ph works like it should
! lib/h2xs.t See if h2xs produces expected lists of files
! lib/hostname.pl Old hostname code
! lib/I18N/Collate.pm Routines to do strxfrm-based collation
! lib/I18N/Collate.t See if I18N::Collate works
! lib/I18N/LangTags.pm I18N::LangTags
! lib/I18N/LangTags/ChangeLog I18N::LangTags
! lib/I18N/LangTags/List.pm List of tags for human languages
! lib/I18N/LangTags/README I18N::LangTags
! lib/I18N/LangTags/test.pl See if I18N::LangTags works
! lib/importenv.pl Perl routine to get environment into variables
! lib/integer.pm For "use integer"
! lib/IPC/Open2.pm Open a two-ended pipe
! lib/IPC/Open2.t See if IPC::Open2 works
! lib/IPC/Open3.pm Open a three-ended pipe!
! lib/IPC/Open3.t See if IPC::Open3 works
! lib/IPC/SysV.t See if IPC::SysV works
! lib/less.pm For "use less"
! lib/lib_pm.PL For "use lib", produces lib/lib.pm
! lib/locale.pm For "use locale"
! lib/locale.t See if locale support works
! lib/Locale/Codes/t/all.t See if Locale::Codes work
! lib/Locale/Codes/t/constants.t See if Locale::Codes work
! lib/Locale/Codes/t/country.t See if Locale::Codes work
! lib/Locale/Codes/t/currency.t See if Locale::Codes work
! lib/Locale/Codes/t/languages.t See if Locale::Codes work
! lib/Locale/Codes/t/uk.t See if Locale::Codes work
! lib/Locale/Constants.pm Locale::Codes
! lib/Locale/Country.pm Locale::Codes
! lib/Locale/Currency.pm Locale::Codes
! lib/Locale/Language.pm Locale::Codes
! lib/Locale/Maketext.pm Locale::Maketext
! lib/Locale/Maketext.pod Locale::Maketext documentation
! lib/Locale/Maketext/ChangeLog Locale::Maketext
! lib/Locale/Maketext/README Locale::Maketext
! lib/Locale/Maketext/test.pl See if Locale::Maketext works
! lib/Locale/Maketext/TPJ13.pod Locale::Maketext documentation article
! lib/look.pl A "look" equivalent
! lib/Math/BigFloat.pm An arbitrary precision floating-point arithmetic package
! lib/Math/BigInt.pm An arbitrary precision integer arithmetic package
! lib/Math/BigInt/Calc.pm Pure Perl module to support Math::BigInt
! lib/Math/BigInt/t/bigfltpm.t See if BigFloat.pm works
! lib/Math/BigInt/t/bigintc.t See if BigInt/Calc.pm works
! lib/Math/BigInt/t/bigintpm.t See if BigInt.pm works
! lib/Math/BigInt/t/mbimbf.t BigInt/BigFloat accuracy, precicion and fallback, round_mode
! lib/Math/Complex.pm A Complex package
! lib/Math/Complex.t See if Math::Complex works
! lib/Math/Trig.pm A simple interface to complex trigonometry
! lib/Math/Trig.t See if Math::Trig works
! lib/Memoize.pm Memoize
! lib/Memoize/AnyDBM_File.pm Memoize
! lib/Memoize/Expire.pm Memoize
! lib/Memoize/ExpireFile.pm Memoize
! lib/Memoize/ExpireTest.pm Memoize
! lib/Memoize/NDBM_File.pm Memoize
! lib/Memoize/README Memoize
! lib/Memoize/Saves.pm Memoize
! lib/Memoize/SDBM_File.pm Memoize
! lib/Memoize/Storable.pm Memoize
! lib/Memoize/t/array.t Memoize
! lib/Memoize/t/array_confusion.t Memoize
! lib/Memoize/t/correctness.t Memoize
! lib/Memoize/t/errors.t Memoize
! lib/Memoize/t/expire.t Memoize
! lib/Memoize/t/expire_file.t Memoize
! lib/Memoize/t/expire_module_n.t Memoize
! lib/Memoize/t/expire_module_t.t Memoize
! lib/Memoize/t/flush.t Memoize
! lib/Memoize/t/normalize.t Memoize
! lib/Memoize/t/prototype.t Memoize
! lib/Memoize/t/speed.t Memoize
! lib/Memoize/t/tie.t Memoize
! lib/Memoize/t/tie_gdbm.t Memoize
! lib/Memoize/t/tie_ndbm.t Memoize
! lib/Memoize/t/tie_sdbm.t Memoize
! lib/Memoize/t/tie_storable.t Memoize
! lib/Memoize/t/tiefeatures.t Memoize
! lib/Memoize/t/unmemoize.t Memoize
! lib/Memoize/TODO Memoize
! lib/Net/ChangeLog.libnet libnet
! lib/Net/Cmd.pm libnet
! lib/Net/Config.eg libnet
! lib/Net/Config.pm libnet
! lib/Net/demos/ftp libnet
! lib/Net/demos/inetd libnet
! lib/Net/demos/nntp libnet
! lib/Net/demos/nntp.mirror libnet
! lib/Net/demos/pop3 libnet
! lib/Net/demos/smtp.self libnet
! lib/Net/demos/snpp libnet
! lib/Net/demos/time libnet
! lib/Net/Domain.pm libnet
! lib/Net/FTP.pm libnet
! lib/Net/FTP/A.pm libnet
! lib/Net/FTP/dataconn.pm libnet
! lib/Net/FTP/E.pm libnet
! lib/Net/FTP/I.pm libnet
! lib/Net/FTP/L.pm libnet
! lib/Net/hostent.pm By-name interface to Perl's builtin gethost*
! lib/Net/hostent.t See if Net::hostent works
! lib/Net/Hostname.eg libnet
! lib/Net/libnet.ppd libnet
! lib/Net/libnetFAQ.pod libnet
! lib/Net/netent.pm By-name interface to Perl's builtin getnet*
! lib/Net/netent.t See if Net::netent works
! lib/Net/Netrc.pm libnet
! lib/Net/NNTP.pm libnet
! lib/Net/Ping.pm Hello, anybody home?
! lib/Net/POP3.pm libnet
! lib/Net/protoent.pm By-name interface to Perl's builtin getproto*
! lib/Net/protoent.t See if Net::protoent works
! lib/Net/README.config libnet
! lib/Net/README.libnet libnet
! lib/Net/servent.pm By-name interface to Perl's builtin getserv*
! lib/Net/servent.t See if Net::servtent works
! lib/Net/SMTP.pm libnet
! lib/Net/t/ftp.t libnet
! lib/Net/t/hostname.t libnet
! lib/Net/t/nntp.t libnet
! lib/Net/t/require.t libnet
! lib/Net/t/smtp.t libnet
! lib/Net/Time.pm libnet
! lib/newgetopt.pl A perl library supporting long option parsing
! lib/NEXT.pm Pseudo-class NEXT for method redispatch
! lib/NEXT/test.pl See if NEXT works
! lib/open.pm Pragma to specify default I/O disciplines
! lib/open2.pl Open a two-ended pipe (uses IPC::Open2)
! lib/open3.pl Open a three-ended pipe (uses IPC::Open3)
! lib/overload.pm Module for overloading perl operators
! lib/overload.t See if operator overloading works
! lib/perl5db.pl Perl debugging routines
! lib/PerlIO.pm PerlIO support module
! lib/ph.t See if h2ph works
! lib/Pod/Checker.pm Pod-Parser - check POD documents for syntax errors
! lib/Pod/Find.pm used by pod/splitpod
! lib/Pod/Functions.pm used by pod/splitpod
! lib/Pod/Html.pm Convert POD data to HTML
! lib/Pod/InputObjects.pm Pod-Parser - define objects for input streams
! lib/Pod/LaTeX.pm Convert POD data to LaTeX
! lib/Pod/Man.pm Convert POD data to *roff
! lib/Pod/Parser.pm Pod-Parser - define base class for parsing POD
! lib/Pod/ParseUtils.pm Pod-Parser - pod utility functions
! lib/Pod/Plainer.pm Pod migration utility module
! lib/Pod/Select.pm Pod-Parser - select portions of POD docs
! lib/Pod/Text.pm Pod-Parser - convert POD data to formatted ASCII text
! lib/Pod/Text/Color.pm Convert POD data to color ASCII text
lib/Pod/Text/Overstrike.pm Convert POD data to formatted overstrike text
! lib/Pod/Text/Termcap.pm Convert POD data to ASCII text with format escapes
! lib/Pod/Usage.pm Pod-Parser - print usage messages
! lib/pwd.pl Routines to keep track of PWD environment variable
! lib/Search/Dict.pm Perform binary search on dictionaries
! lib/Search/Dict.t See if Search::Dict works
! lib/SelectSaver.pm Enforce proper select scoping
! lib/SelectSaver.t See if SelectSaver works
! lib/SelfLoader.pm Load functions only on demand
! lib/SelfLoader.t See if SelfLoader works
! lib/Shell.pm Make AUTOLOADed system() calls
! lib/shellwords.pl Perl library to split into words with shell quoting
! lib/sigtrap.pm For trapping an abort and giving traceback
! lib/stat.pl Perl library supporting stat function
! lib/strict.pm For "use strict"
! lib/strict.t See if strictures work
! lib/subs.pm Declare overriding subs
! lib/subs.t See if subroutine pseudo-importation works
! lib/Switch.pm Switch for Perl
! lib/Switch/test.pl Test whether switch works
! lib/Symbol.pm Symbol table manipulation routines
! lib/Symbol.t See if Symbol works
! lib/syslog.pl Perl library supporting syslogging
! lib/tainted.pl Old code for tainting
! lib/Term/ANSIColor.pm Perl module supporting termcap usage
! lib/Term/ANSIColor/ChangeLog Term::ANSIColor
! lib/Term/ANSIColor/README Term::ANSIColor
! lib/Term/ANSIColor/test.pl See if Term::ANSIColor works
! lib/Term/Cap.pm Perl module supporting termcap usage
! lib/Term/Complete.pm A command completion subroutine
! lib/Term/ReadLine.pm Stub readline library
! lib/termcap.pl Perl library supporting termcap usage
! lib/Test.pm A simple framework for writing test scripts
! lib/Test/Harness.pm A test harness
! lib/Test/Harness.t See if Test::Harness works
! lib/Test/More.pm More utilities for writing tests
! lib/Test/More/Changes Test::More changes
! lib/Test/More/t/fail-like.t Test::More test, like() and qr// bug
! lib/Test/More/t/fail.t Test::More test, failing tests
! lib/Test/More/t/More.t Test::More test, basic operation
! lib/Test/More/t/plan_is_noplan.t Test::More test, noplan
! lib/Test/More/t/skipall.t Test::More test, skipping all tests
! lib/Test/Simple.pm Basic utility for writing tests
! lib/Test/Simple/Changes Test::Simple changes
! lib/Test/Simple/t/exit.t Test::Simple test, exit codes
! lib/Test/Simple/t/extra.t Test::Simple test
! lib/Test/Simple/t/fail.t Test::Simple test, test failures
! lib/Test/Simple/t/missing.t Test::Simple test, missing tests
! lib/Test/Simple/t/no_plan.t Test::Simple test, forgot the plan
! lib/Test/Simple/t/plan_is_noplan.t Test::Simple test, no_plan
! lib/Test/Simple/t/simple.t for exit.t
! lib/Test/t/fail.t See if Test works
! lib/Test/t/mix.t See if Test works
! lib/Test/t/onfail.t See if Test works
! lib/Test/t/qr.t See if Test works
! lib/Test/t/skip.t See if Test works
! lib/Test/t/success.t See if Test works
! lib/Test/t/todo.t See if Test works
! lib/Text/Abbrev.pm An abbreviation table builder
! lib/Text/Abbrev.t Test Text::Abbrev
! lib/Text/Balanced.pm Text::Balanced
! lib/Text/Balanced.pod Text::Balanced
! lib/Text/Balanced/t/genxt.t See if Text::Balanced works
! lib/Text/Balanced/t/xbrak.t See if Text::Balanced works
! lib/Text/Balanced/t/xcode.t See if Text::Balanced works
! lib/Text/Balanced/t/xdeli.t See if Text::Balanced works
! lib/Text/Balanced/t/xmult.t See if Text::Balanced works
! lib/Text/Balanced/t/xquot.t See if Text::Balanced works
! lib/Text/Balanced/t/xtagg.t See if Text::Balanced works
! lib/Text/Balanced/t/xvari.t See if Text::Balanced works
! lib/Text/ParseWords.pm Perl module to split words on arbitrary delimiter
! lib/Text/ParseWords.t See if Text::ParseWords works
! lib/Text/Soundex.pm Perl module to implement Soundex
! lib/Text/Soundex.t See if Soundex works
! lib/Text/Tabs.pm Do expand and unexpand
! lib/Text/TabsWrap/t/fill.t See if Text::Wrap::fill works
! lib/Text/TabsWrap/t/tabs.t See if Text::Tabs works
! lib/Text/TabsWrap/t/wrap.t See if Text::Wrap::wrap works
! lib/Text/Wrap.pm Paragraph formatter
! lib/Tie/Array.pm Base class for tied arrays
! lib/Tie/Array/push.t Test for Tie::Array
! lib/Tie/Array/splice.t Test for Tie::Array::SPLICE
! lib/Tie/Array/std.t Test for Tie::StdArray
! lib/Tie/Array/stdpush.t Test for Tie::StdArray
! lib/Tie/Handle.pm Base class for tied handles
! lib/Tie/Handle/stdhandle.t Test for Tie::StdHandle
! lib/Tie/Hash.pm Base class for tied hashes
! lib/Tie/RefHash.pm Base class for tied hashes with references as keys
! lib/Tie/RefHash.t Test for Tie::RefHash and Tie::RefHash::Nestable
! lib/Tie/Scalar.pm Base class for tied scalars
! lib/Tie/SubstrHash.pm Compact hash for known key, value and table size
! lib/Tie/SubstrHash.t Test for Tie::SubstrHash
! lib/Time/gmtime.pm By-name interface to Perl's builtin gmtime
! lib/Time/gmtime.t Test for Time::gmtime
! lib/Time/Local.pm Reverse translation of localtime, gmtime
! lib/Time/Local.t See if Time::Local works
! lib/Time/localtime.pm By-name interface to Perl's builtin localtime
! lib/Time/localtime.t Test for Time::localtime
! lib/Time/tm.pm Internal object for Time::{gm,local}time
! lib/timelocal.pl Perl library supporting inverse of localtime, gmtime
! lib/unicode/ArabLink.pl Unicode character database
! lib/unicode/ArabLnkGrp.pl Unicode character database
! lib/unicode/ArabShap.txt Unicode character database
! lib/unicode/BidiMirr.txt Unicode character database
! lib/unicode/Bidirectional.pl Unicode character database
! lib/unicode/Blocks.pl Unicode character database
! lib/unicode/Blocks.txt Unicode character database
! lib/unicode/CaseFold.txt Unicode character database
! lib/unicode/Category.pl Unicode character database
! lib/unicode/CombiningClass.pl Unicode character database
! lib/unicode/CompExcl.txt Unicode character database
! lib/unicode/Decomposition.pl Unicode character database
! lib/unicode/EAWidth.txt Unicode character database
! lib/unicode/In.pl Unicode character database
! lib/unicode/In/0.pl Unicode character database
! lib/unicode/In/1.pl Unicode character database
! lib/unicode/In/10.pl Unicode character database
! lib/unicode/In/100.pl Unicode character database
! lib/unicode/In/101.pl Unicode character database
! lib/unicode/In/102.pl Unicode character database
! lib/unicode/In/103.pl Unicode character database
! lib/unicode/In/104.pl Unicode character database
! lib/unicode/In/105.pl Unicode character database
! lib/unicode/In/106.pl Unicode character database
! lib/unicode/In/107.pl Unicode character database
! lib/unicode/In/108.pl Unicode character database
! lib/unicode/In/109.pl Unicode character database
! lib/unicode/In/11.pl Unicode character database
! lib/unicode/In/110.pl Unicode character database
! lib/unicode/In/111.pl Unicode character database
! lib/unicode/In/112.pl Unicode character database
! lib/unicode/In/113.pl Unicode character database
! lib/unicode/In/114.pl Unicode character database
! lib/unicode/In/115.pl Unicode character database
! lib/unicode/In/116.pl Unicode character database
! lib/unicode/In/117.pl Unicode character database
! lib/unicode/In/118.pl Unicode character database
! lib/unicode/In/119.pl Unicode character database
! lib/unicode/In/12.pl Unicode character database
! lib/unicode/In/120.pl Unicode character database
! lib/unicode/In/121.pl Unicode character database
! lib/unicode/In/122.pl Unicode character database
! lib/unicode/In/123.pl Unicode character database
! lib/unicode/In/124.pl Unicode character database
! lib/unicode/In/125.pl Unicode character database
! lib/unicode/In/126.pl Unicode character database
! lib/unicode/In/127.pl Unicode character database
! lib/unicode/In/128.pl Unicode character database
! lib/unicode/In/129.pl Unicode character database
! lib/unicode/In/13.pl Unicode character database
! lib/unicode/In/130.pl Unicode character database
! lib/unicode/In/131.pl Unicode character database
! lib/unicode/In/132.pl Unicode character database
! lib/unicode/In/133.pl Unicode character database
! lib/unicode/In/134.pl Unicode character database
! lib/unicode/In/135.pl Unicode character database
! lib/unicode/In/14.pl Unicode character database
! lib/unicode/In/15.pl Unicode character database
! lib/unicode/In/16.pl Unicode character database
! lib/unicode/In/17.pl Unicode character database
! lib/unicode/In/18.pl Unicode character database
! lib/unicode/In/19.pl Unicode character database
! lib/unicode/In/2.pl Unicode character database
! lib/unicode/In/20.pl Unicode character database
! lib/unicode/In/21.pl Unicode character database
! lib/unicode/In/22.pl Unicode character database
! lib/unicode/In/23.pl Unicode character database
! lib/unicode/In/24.pl Unicode character database
! lib/unicode/In/25.pl Unicode character database
! lib/unicode/In/26.pl Unicode character database
! lib/unicode/In/27.pl Unicode character database
! lib/unicode/In/28.pl Unicode character database
! lib/unicode/In/29.pl Unicode character database
! lib/unicode/In/3.pl Unicode character database
! lib/unicode/In/30.pl Unicode character database
! lib/unicode/In/31.pl Unicode character database
! lib/unicode/In/32.pl Unicode character database
! lib/unicode/In/33.pl Unicode character database
! lib/unicode/In/34.pl Unicode character database
! lib/unicode/In/35.pl Unicode character database
! lib/unicode/In/36.pl Unicode character database
! lib/unicode/In/37.pl Unicode character database
! lib/unicode/In/38.pl Unicode character database
! lib/unicode/In/39.pl Unicode character database
! lib/unicode/In/4.pl Unicode character database
! lib/unicode/In/40.pl Unicode character database
! lib/unicode/In/41.pl Unicode character database
! lib/unicode/In/42.pl Unicode character database
! lib/unicode/In/43.pl Unicode character database
! lib/unicode/In/44.pl Unicode character database
! lib/unicode/In/45.pl Unicode character database
! lib/unicode/In/46.pl Unicode character database
! lib/unicode/In/47.pl Unicode character database
! lib/unicode/In/48.pl Unicode character database
! lib/unicode/In/49.pl Unicode character database
! lib/unicode/In/5.pl Unicode character database
! lib/unicode/In/50.pl Unicode character database
! lib/unicode/In/51.pl Unicode character database
! lib/unicode/In/52.pl Unicode character database
! lib/unicode/In/53.pl Unicode character database
! lib/unicode/In/54.pl Unicode character database
! lib/unicode/In/55.pl Unicode character database
! lib/unicode/In/56.pl Unicode character database
! lib/unicode/In/57.pl Unicode character database
! lib/unicode/In/58.pl Unicode character database
! lib/unicode/In/59.pl Unicode character database
! lib/unicode/In/6.pl Unicode character database
! lib/unicode/In/60.pl Unicode character database
! lib/unicode/In/61.pl Unicode character database
! lib/unicode/In/62.pl Unicode character database
! lib/unicode/In/63.pl Unicode character database
! lib/unicode/In/64.pl Unicode character database
! lib/unicode/In/65.pl Unicode character database
! lib/unicode/In/66.pl Unicode character database
! lib/unicode/In/67.pl Unicode character database
! lib/unicode/In/68.pl Unicode character database
! lib/unicode/In/69.pl Unicode character database
! lib/unicode/In/7.pl Unicode character database
! lib/unicode/In/70.pl Unicode character database
! lib/unicode/In/71.pl Unicode character database
! lib/unicode/In/72.pl Unicode character database
! lib/unicode/In/73.pl Unicode character database
! lib/unicode/In/74.pl Unicode character database
! lib/unicode/In/75.pl Unicode character database
! lib/unicode/In/76.pl Unicode character database
! lib/unicode/In/77.pl Unicode character database
! lib/unicode/In/78.pl Unicode character database
! lib/unicode/In/79.pl Unicode character database
! lib/unicode/In/8.pl Unicode character database
! lib/unicode/In/80.pl Unicode character database
! lib/unicode/In/81.pl Unicode character database
! lib/unicode/In/82.pl Unicode character database
! lib/unicode/In/83.pl Unicode character database
! lib/unicode/In/84.pl Unicode character database
! lib/unicode/In/85.pl Unicode character database
! lib/unicode/In/86.pl Unicode character database
! lib/unicode/In/87.pl Unicode character database
! lib/unicode/In/88.pl Unicode character database
! lib/unicode/In/89.pl Unicode character database
! lib/unicode/In/9.pl Unicode character database
! lib/unicode/In/90.pl Unicode character database
! lib/unicode/In/91.pl Unicode character database
! lib/unicode/In/92.pl Unicode character database
! lib/unicode/In/93.pl Unicode character database
! lib/unicode/In/94.pl Unicode character database
! lib/unicode/In/95.pl Unicode character database
! lib/unicode/In/96.pl Unicode character database
! lib/unicode/In/97.pl Unicode character database
! lib/unicode/In/98.pl Unicode character database
! lib/unicode/In/99.pl Unicode character database
! lib/unicode/Index.txt Unicode character database
! lib/unicode/Is/Alnum.pl Unicode character database
! lib/unicode/Is/Alpha.pl Unicode character database
! lib/unicode/Is/ASCII.pl Unicode character database
! lib/unicode/Is/BidiAL.pl Unicode character database
! lib/unicode/Is/BidiAN.pl Unicode character database
! lib/unicode/Is/BidiB.pl Unicode character database
! lib/unicode/Is/BidiBN.pl Unicode character database
! lib/unicode/Is/BidiCS.pl Unicode character database
! lib/unicode/Is/BidiEN.pl Unicode character database
! lib/unicode/Is/BidiES.pl Unicode character database
! lib/unicode/Is/BidiET.pl Unicode character database
! lib/unicode/Is/BidiL.pl Unicode character database
! lib/unicode/Is/BidiLRE.pl Unicode character database
! lib/unicode/Is/BidiLRO.pl Unicode character database
! lib/unicode/Is/BidiNSM.pl Unicode character database
! lib/unicode/Is/BidiON.pl Unicode character database
! lib/unicode/Is/BidiPDF.pl Unicode character database
! lib/unicode/Is/BidiR.pl Unicode character database
! lib/unicode/Is/BidiRLE.pl Unicode character database
! lib/unicode/Is/BidiRLO.pl Unicode character database
! lib/unicode/Is/BidiS.pl Unicode character database
! lib/unicode/Is/BidiWS.pl Unicode character database
! lib/unicode/Is/Blank.pl Unicode character database
! lib/unicode/Is/C.pl Unicode character database
! lib/unicode/Is/Cc.pl Unicode character database
! lib/unicode/Is/Cf.pl Unicode character database
! lib/unicode/Is/Cn.pl Unicode character database
! lib/unicode/Is/Cntrl.pl Unicode character database
! lib/unicode/Is/Co.pl Unicode character database
! lib/unicode/Is/Cs.pl Unicode character database
! lib/unicode/Is/DCcircle.pl Unicode character database
! lib/unicode/Is/DCcompat.pl Unicode character database
! lib/unicode/Is/DCfinal.pl Unicode character database
! lib/unicode/Is/DCfont.pl Unicode character database
! lib/unicode/Is/DCfraction.pl Unicode character database
! lib/unicode/Is/DCinitial.pl Unicode character database
! lib/unicode/Is/DCisolated.pl Unicode character database
! lib/unicode/Is/DCmedial.pl Unicode character database
! lib/unicode/Is/DCnarrow.pl Unicode character database
! lib/unicode/Is/DCnoBreak.pl Unicode character database
! lib/unicode/Is/DCsmall.pl Unicode character database
! lib/unicode/Is/DCsquare.pl Unicode character database
! lib/unicode/Is/DCsub.pl Unicode character database
! lib/unicode/Is/DCsuper.pl Unicode character database
! lib/unicode/Is/DCvertical.pl Unicode character database
! lib/unicode/Is/DCwide.pl Unicode character database
! lib/unicode/Is/DecoCanon.pl Unicode character database
! lib/unicode/Is/DecoCompat.pl Unicode character database
! lib/unicode/Is/Digit.pl Unicode character database
! lib/unicode/Is/Graph.pl Unicode character database
! lib/unicode/Is/L.pl Unicode character database
! lib/unicode/Is/LbrkAI.pl Unicode character database
! lib/unicode/Is/LbrkAL.pl Unicode character database
! lib/unicode/Is/LbrkB2.pl Unicode character database
! lib/unicode/Is/LbrkBA.pl Unicode character database
! lib/unicode/Is/LbrkBB.pl Unicode character database
! lib/unicode/Is/LbrkBK.pl Unicode character database
! lib/unicode/Is/LbrkCB.pl Unicode character database
! lib/unicode/Is/LbrkCL.pl Unicode character database
! lib/unicode/Is/LbrkCM.pl Unicode character database
! lib/unicode/Is/LbrkCR.pl Unicode character database
! lib/unicode/Is/LbrkEX.pl Unicode character database
! lib/unicode/Is/LbrkGL.pl Unicode character database
! lib/unicode/Is/LbrkHY.pl Unicode character database
! lib/unicode/Is/LbrkID.pl Unicode character database
! lib/unicode/Is/LbrkIN.pl Unicode character database
! lib/unicode/Is/LbrkIS.pl Unicode character database
! lib/unicode/Is/LbrkLF.pl Unicode character database
! lib/unicode/Is/LbrkNS.pl Unicode character database
! lib/unicode/Is/LbrkNU.pl Unicode character database
! lib/unicode/Is/LbrkOP.pl Unicode character database
! lib/unicode/Is/LbrkPO.pl Unicode character database
! lib/unicode/Is/LbrkPR.pl Unicode character database
! lib/unicode/Is/LbrkQU.pl Unicode character database
! lib/unicode/Is/LbrkSA.pl Unicode character database
! lib/unicode/Is/LbrkSG.pl Unicode character database
! lib/unicode/Is/LbrkSP.pl Unicode character database
! lib/unicode/Is/LbrkSY.pl Unicode character database
! lib/unicode/Is/LbrkXX.pl Unicode character database
! lib/unicode/Is/LbrkZW.pl Unicode character database
! lib/unicode/Is/Ll.pl Unicode character database
! lib/unicode/Is/Lm.pl Unicode character database
! lib/unicode/Is/Lo.pl Unicode character database
! lib/unicode/Is/Lower.pl Unicode character database
! lib/unicode/Is/Lt.pl Unicode character database
! lib/unicode/Is/Lu.pl Unicode character database
! lib/unicode/Is/M.pl Unicode character database
! lib/unicode/Is/Mc.pl Unicode character database
! lib/unicode/Is/Me.pl Unicode character database
! lib/unicode/Is/Mirrored.pl Unicode character database
! lib/unicode/Is/Mn.pl Unicode character database
! lib/unicode/Is/N.pl Unicode character database
! lib/unicode/Is/Nd.pl Unicode character database
! lib/unicode/Is/Nl.pl Unicode character database
! lib/unicode/Is/No.pl Unicode character database
! lib/unicode/Is/P.pl Unicode character database
! lib/unicode/Is/Pc.pl Unicode character database
! lib/unicode/Is/Pd.pl Unicode character database
! lib/unicode/Is/Pe.pl Unicode character database
! lib/unicode/Is/Pf.pl Unicode character database
! lib/unicode/Is/Pi.pl Unicode character database
! lib/unicode/Is/Po.pl Unicode character database
! lib/unicode/Is/Print.pl Unicode character database
! lib/unicode/Is/Ps.pl Unicode character database
! lib/unicode/Is/Punct.pl Unicode character database
! lib/unicode/Is/S.pl Unicode character database
! lib/unicode/Is/Sc.pl Unicode character database
! lib/unicode/Is/Sk.pl Unicode character database
! lib/unicode/Is/Sm.pl Unicode character database
! lib/unicode/Is/So.pl Unicode character database
! lib/unicode/Is/Space.pl Unicode character database
! lib/unicode/Is/SpacePerl.pl Unicode character database
! lib/unicode/Is/SylA.pl Unicode character database
! lib/unicode/Is/SylAA.pl Unicode character database
! lib/unicode/Is/SylAAI.pl Unicode character database
! lib/unicode/Is/SylAI.pl Unicode character database
! lib/unicode/Is/SylC.pl Unicode character database
! lib/unicode/Is/SylE.pl Unicode character database
! lib/unicode/Is/SylEE.pl Unicode character database
! lib/unicode/Is/SylI.pl Unicode character database
! lib/unicode/Is/SylII.pl Unicode character database
! lib/unicode/Is/Syllable.pl Unicode character database
! lib/unicode/Is/SylN.pl Unicode character database
! lib/unicode/Is/SylO.pl Unicode character database
! lib/unicode/Is/SylOO.pl Unicode character database
! lib/unicode/Is/SylU.pl Unicode character database
! lib/unicode/Is/SylV.pl Unicode character database
! lib/unicode/Is/SylWA.pl Unicode character database
! lib/unicode/Is/SylWAA.pl Unicode character database
! lib/unicode/Is/SylWC.pl Unicode character database
! lib/unicode/Is/SylWE.pl Unicode character database
! lib/unicode/Is/SylWEE.pl Unicode character database
! lib/unicode/Is/SylWI.pl Unicode character database
! lib/unicode/Is/SylWII.pl Unicode character database
! lib/unicode/Is/SylWO.pl Unicode character database
! lib/unicode/Is/SylWOO.pl Unicode character database
! lib/unicode/Is/SylWU.pl Unicode character database
! lib/unicode/Is/SylWV.pl Unicode character database
! lib/unicode/Is/Upper.pl Unicode character database
! lib/unicode/Is/Word.pl Unicode character database
! lib/unicode/Is/XDigit.pl Unicode character database
! lib/unicode/Is/Z.pl Unicode character database
! lib/unicode/Is/Zl.pl Unicode character database
! lib/unicode/Is/Zp.pl Unicode character database
! lib/unicode/Is/Zs.pl Unicode character database
! lib/unicode/Jamo.txt Unicode character database
! lib/unicode/JamoShort.pl Unicode character database
! lib/unicode/LineBrk.txt Unicode character database
! lib/unicode/Makefile Unicode character database
! lib/unicode/mktables.PL Unicode character database generator
! lib/unicode/Name.pl Unicode character database
! lib/unicode/NamesList.html Unicode character database
! lib/unicode/NamesList.txt Unicode character database
! lib/unicode/Number.pl Unicode character database
! lib/unicode/PropList.html Unicode character database
! lib/unicode/PropList.txt Unicode character database
! lib/unicode/README.perl Unicode character database
! lib/unicode/ReadMe.txt Unicode character database info
! lib/unicode/rename Filename mappings used
! lib/unicode/Scripts.pl Unicode character database
! lib/unicode/Scripts.txt Unicode character database
! lib/unicode/SpecCase.txt Unicode character database
! lib/unicode/syllables.txt Unicode character database
! lib/unicode/To/Digit.pl Unicode character database
! lib/unicode/To/Lower.pl Unicode character database
! lib/unicode/To/Title.pl Unicode character database
! lib/unicode/To/Upper.pl Unicode character database
! lib/unicode/UCD.html Unicode character database
! lib/UnicodeCD.pm Unicode character database
! lib/UnicodeCD.t See if Unicode character database works
! lib/unicode/Unicode.html Unicode character database
! lib/unicode/Unicode.txt Unicode character database
! lib/unicode/version The version of the Unicode
! lib/UNIVERSAL.pm Base class for ALL classes
! lib/User/grent.pm By-name interface to Perl's builtin getgr*
! lib/User/grent.t See if User::grwent works
! lib/User/pwent.pm By-name interface to Perl's builtin getpw*
! lib/User/pwent.t See if User::pwent works
! lib/utf8.pm Pragma to control Unicode support
! lib/utf8.t See if utf8 operations work
! lib/utf8_heavy.pl Support routines for utf8 pragma
! lib/validate.pl Perl library supporting wholesale file mode validation
! lib/vars.pm Declare pseudo-imported global variables
! lib/vars.t See if "use vars" work
! lib/warnings.pm For "use warnings"
! lib/warnings.t See if warning controls work
lib/warnings/register.pm For "use warnings::register"
! lib/Win32.pod Documentation for Win32 extras
! locale.c locale-specific utility functions
! makeaperl.SH perl script that produces a new perl binary
! makedef.pl Create symbol export lists for linking
! makedepend.SH Precursor to makedepend
! makedir.SH Precursor to makedir
! Makefile.micro microperl Makefile
! Makefile.SH A script that generates Makefile
! malloc.c A version of malloc you might not want
! MANIFEST This list of files
! mg.c Magic code
! mg.h Magic header
! minimod.pl Writes lib/ExtUtils/Miniperl.pm
! miniperlmain.c Basic perl w/o dynamic loading or extensions
! mint/errno.h MiNT port
! mint/Makefile MiNT port
! mint/pwd.c MiNT port
! mint/README MiNT port
! mint/stdio.h MiNT port
! mint/sys/time.h MiNT port
! mint/time.h MiNT port
! mpeix/mpeixish.h MPE/iX port
! mpeix/nm MPE/iX port
! mpeix/relink MPE/iX port
! mv-if-diff Script to mv a file if it changed
! myconfig.SH Prints summary of the current configuration
! NetWare/bat/BldNWExt.bat Netware port
! NetWare/bat/Buildtype.bat Netware port
! NetWare/bat/MPKBuild.bat Netware port
! NetWare/bat/Setmpksdk.bat Netware port
! NetWare/bat/Setnlmsdk.bat Netware port
! NetWare/bat/SetNWBld.bat Netware port
! NetWare/bat/Setwatcom.bat Netware port
! NetWare/bat/ToggleD2.bat Netware port
! NetWare/bat/ToggleXDC.bat Netware port
! NetWare/CLIBsdio.h Netware port
! NetWare/CLIBstr.h Netware port
! NetWare/CLIBstuf.c Netware port
! NetWare/CLIBstuf.h Netware port
! NetWare/config.wc Netware port
! NetWare/config_h.PL Netware port
! NetWare/config_H.wc Netware port
! NetWare/config_sh.PL Netware port
! NetWare/deb.h Netware port
! NetWare/dl_netware.xs Netware port
! NetWare/intdef.h Netware port
! NetWare/interface.c Netware port
! NetWare/interface.h Netware port
! NetWare/iperlhost.h Netware port
! NetWare/Main.c Netware port
! NetWare/Makefile Netware port
! NetWare/netware.h Netware port
! NetWare/nw5.c Netware port
! NetWare/nw5iop.h Netware port
! NetWare/nw5sck.c Netware port
! NetWare/nw5sck.h Netware port
! NetWare/nw5thread.c Netware port
! NetWare/nw5thread.h Netware port
! NetWare/Nwmain.c Netware port
! NetWare/nwperlsys.c Netware port
! NetWare/nwperlsys.h Netware port
! NetWare/Nwpipe.c Netware port
! NetWare/nwpipe.h Netware port
! NetWare/nwplglob.c Netware port
! NetWare/nwplglob.h Netware port
! NetWare/nwstdio.h Netware port
! NetWare/NWTInfo.c Netware port
! NetWare/nwtinfo.h Netware port
! NetWare/NWUtil.c Netware port
! NetWare/nwutil.h Netware port
! NetWare/t/NWModify.pl Netware port
! NetWare/t/NWScripts.pl Netware port
! NetWare/t/Readme.txt Netware port
! NetWare/testnlm/echo/echo.c Netware port
! NetWare/testnlm/type/type.c Netware port
! NetWare/win32ish.h Netware port
! nostdio.h Cause compile error on stdio calls
! numeric.c Miscellaneous numeric conversion routines
! objXSUB.h Scoping macros for Perl Object in extensions
! op.c Opcode syntax tree code
! op.h Opcode syntax tree header
! opcode.h Automatically generated opcode header
! opcode.pl Opcode header generatore
! opnames.h Automatically generated opcode header
! os2/Changes Changelog for OS/2 port
! os2/diff.configure Patches to Configure
! os2/dl_os2.c Addon for dl_open
! os2/dlfcn.h Addon for dl_open
! os2/Makefile.SHs Shared library generation for OS/2
! os2/os2.c Additional code for OS/2
! os2/os2.sym Additional symbols to export
os2/OS2/ExtAttr/Changes EA access module
os2/OS2/ExtAttr/ExtAttr.pm EA access module
os2/OS2/ExtAttr/ExtAttr.xs EA access module
os2/OS2/ExtAttr/Makefile.PL EA access module
+ os2/OS2/ExtAttr/MANIFEST EA access module
os2/OS2/ExtAttr/myea.h EA access module
os2/OS2/ExtAttr/t/os2_ea.t EA access module
os2/OS2/ExtAttr/typemap EA access module
os2/OS2/PrfDB/Changes System database access module
os2/OS2/PrfDB/Makefile.PL System database access module
+ os2/OS2/PrfDB/MANIFEST System database access module
os2/OS2/PrfDB/PrfDB.pm System database access module
os2/OS2/PrfDB/PrfDB.xs System database access module
os2/OS2/PrfDB/t/os2_prfdb.t System database access module
os2/OS2/PrfDB/typemap System database access module
os2/OS2/Process/Makefile.PL system() constants in a module
+ os2/OS2/Process/MANIFEST system() constants in a module
os2/OS2/Process/Process.pm system() constants in a module
os2/OS2/Process/Process.xs system() constants in a module
os2/OS2/REXX/Changes DLL access module
! os2/OS2/REXX/DLL/Changes DLL access module
os2/OS2/REXX/DLL/DLL.pm DLL access module
os2/OS2/REXX/DLL/DLL.xs DLL access module
os2/OS2/REXX/DLL/Makefile.PL DLL access module
! os2/OS2/REXX/DLL/MANIFEST DLL access module
os2/OS2/REXX/Makefile.PL DLL access module
+ os2/OS2/REXX/MANIFEST DLL access module
os2/OS2/REXX/REXX.pm DLL access module
os2/OS2/REXX/REXX.xs DLL access module
os2/OS2/REXX/t/rx_cmprt.t DLL access module
***************
*** 1214,1931 ****
os2/OS2/REXX/t/rx_tieydb.t DLL access module
os2/OS2/REXX/t/rx_varset.t DLL access module
os2/OS2/REXX/t/rx_vrexx.t DLL access module
! os2/diff.configure Patches to Configure
! os2/dl_os2.c Addon for dl_open
! os2/dlfcn.h Addon for dl_open
! os2/os2.c Additional code for OS/2
! os2/os2.sym Additional symbols to export
! os2/os2add.sym Overriding symbols to export
! os2/os2ish.h Header for OS/2
! os2/os2thread.h pthread-like typedefs
! os2/perl2cmd.pl Corrects installed binaries under OS/2
! patchlevel.h The current patch level of perl
! perl.c main()
! perl.h Global declarations
! perlapi.c Perl API functions
! perlapi.h Perl API function declarations
! perlio.c C code for PerlIO abstraction
! perlio.h PerlIO abstraction
! perlio.sym Symbols for PerlIO abstraction
! perliol.h PerlIO Layer definition
! perlsdio.h Fake stdio using perlio
! perlsfio.h Prototype sfio mapping for PerlIO
! perlsh A poor man's perl shell
! perlvars.h Global variables
! perly.c A byacc'ed perly.y
! perly.fixer A program to remove yacc stack limitations
! perly.h The header file for perly.c
! perly.y Yacc grammar for perl
! perly_c.diff Fixup perly.c to allow recursion
! plan9/aperl Shell to make Perl error messages Acme-friendly
! plan9/arpa/inet.h Plan9 port: replacement C header file
! plan9/buildinfo Plan9 port: configuration information
! plan9/config.plan9 Plan9 port: config.h template
! plan9/exclude Plan9 port: tests to skip
! plan9/fndvers Plan9 port: update Perl version in config.plan9
! plan9/genconfig.pl Plan9 port: generate config.sh
! plan9/mkfile Plan9 port: Mk driver for build
! plan9/myconfig.plan9 Plan9 port: script to print config summary
! plan9/perlplan9.doc Plan9 port: Plan9-specific formatted documentation
! plan9/perlplan9.pod Plan9 port: Plan9-specific pod documentation
! plan9/plan9.c Plan9 port: Plan9-specific C routines
! plan9/plan9ish.h Plan9 port: Plan9-specific C header file
! plan9/setup.rc Plan9 port: script for easy build+install
! plan9/versnum Plan9 port: script to print version number
! pod/Makefile.SH generate Makefile whichs makes pods into something else
! pod/buildtoc.PL generate buildtoc which generates perltoc.pod
! pod/checkpods.PL Tool to check for common errors in pods
! pod/perl.pod Top level perl documentation
! pod/perl5004delta.pod Changes from 5.003 to 5.004
! pod/perl5005delta.pod Changes from 5.004 to 5.005
! pod/perl56delta.pod Changes from 5.005 to 5.6
! pod/perl570delta.pod Changes from 5.6 to 5.7.0
! pod/perl571delta.pod Changes from 5.7.0 to 5.7.1
! pod/perlapi.pod Perl API documentation (autogenerated)
! pod/perlapio.pod PerlIO IO API info
! pod/perlbook.pod Perl book information
! pod/perlboot.pod Beginner's Object-oriented Tutorial
! pod/perlbot.pod Object-oriented Bag o' Tricks
! pod/perlcall.pod Callback info
! pod/perlclib.pod Internal replacements for standard C library functions
! pod/perlcompile.pod Info on using the Compiler suite
! pod/perldata.pod Data structure info
! pod/perldbmfilter.pod Info about DBM Filters
! pod/perldebguts.pod Debugger guts info
! pod/perldebtut.pod Perl debugging tutorial
! pod/perldebug.pod Debugger info
! pod/perldelta.pod Changes since last version
! pod/perldiag.pod Diagnostic info
! pod/perldsc.pod Data Structures Cookbook
! pod/perlebcdic.pod Considerations for running Perl on EBCDIC platforms
! pod/perlembed.pod Embedding info
! pod/perlfaq.pod Frequently Asked Questions, Top Level
! pod/perlfaq1.pod Frequently Asked Questions, Part 1
! pod/perlfaq2.pod Frequently Asked Questions, Part 2
! pod/perlfaq3.pod Frequently Asked Questions, Part 3
! pod/perlfaq4.pod Frequently Asked Questions, Part 4
! pod/perlfaq5.pod Frequently Asked Questions, Part 5
! pod/perlfaq6.pod Frequently Asked Questions, Part 6
! pod/perlfaq7.pod Frequently Asked Questions, Part 7
! pod/perlfaq8.pod Frequently Asked Questions, Part 8
! pod/perlfaq9.pod Frequently Asked Questions, Part 9
! pod/perlfilter.pod Source filters info
! pod/perlfork.pod Info about fork()
! pod/perlform.pod Format info
! pod/perlfunc.pod Function info
! pod/perlguts.pod Internals info
! pod/perlhack.pod Perl hackers guide
! pod/perlhist.pod Perl history info
! pod/perlintern.pod Perl internal function docs (autogenrated)
! pod/perliol.pod Internals of PerlIO with layers.
! pod/perlipc.pod IPC info
! pod/perllexwarn.pod Lexical Warnings info
! pod/perllocale.pod Locale support info
! pod/perllol.pod How to use lists of lists
! pod/perlmod.pod Module mechanism info
! pod/perlmodinstall.pod Installing CPAN Modules
! pod/perlmodlib.PL Generate pod/perlmodlib.pod
! pod/perlmodlib.pod Module policy info
! pod/perlnewmod.pod Preparing a new module for distribution
! pod/perlnumber.pod Semantics of numbers and numeric operations
! pod/perlobj.pod Object info
! pod/perlop.pod Operator info
! pod/perlopentut.pod open() tutorial
! pod/perlpod.pod Pod info
! pod/perlport.pod Portability guide
! pod/perlre.pod Regular expression info
! pod/perlref.pod References info
! pod/perlreftut.pod Mark's references tutorial
! pod/perlrequick.pod Quick start guide for Perl regular expressions
! pod/perlretut.pod Tutorial for Perl regular expressions
! pod/perlrun.pod Execution info
! pod/perlsec.pod Security info
! pod/perlstyle.pod Style info
! pod/perlsub.pod Subroutine info
! pod/perlsyn.pod Syntax info
! pod/perlthrtut.pod Threads tutorial
! pod/perltie.pod Tieing an object class into a simple variable
! pod/perltoc.pod Table of Contents info
! pod/perltodo.pod Todo list explained
! pod/perltoot.pod Tom's object-oriented tutorial
! pod/perltootc.pod Tom's object-oriented tutorial (more on class data)
! pod/perltrap.pod Trap info
! pod/perlunicode.pod Unicode support info
! pod/perlutil.pod Accompanying utilities explained
! pod/perlvar.pod Variable info
! pod/perlxs.pod XS api info
! pod/perlxstut.pod XS tutorial
! pod/pod2html.PL Precursor for translator to turn pod into HTML
! pod/pod2latex.PL Precursor for translator to turn pod into LaTeX
! pod/pod2man.PL Precursor for translator to turn pod into manpage
! pod/pod2text.PL Precursor for translator to turn pod into text
! pod/pod2usage.PL Pod-Parser - print usage messages from POD docs
! pod/podchecker.PL Pod-Parser - Pod::Checker::podchecker() CLI
! pod/podselect.PL Pod-Parser - Pod::Select::podselect() CLI
! pod/roffitall troff the whole man page set
! pod/rofftoc Generate a table of contents in troff format
! pod/splitman Splits perlfunc into multiple man pages
! pod/splitpod Splits perlfunc into multiple pod pages
! pp.c Push/Pop code
! pp.h Push/Pop code defs
! pp.sym Push/Pop code symbols
! pp_ctl.c Push/Pop code for control flow
! pp_hot.c Push/Pop code for heavily used opcodes
! pp_proto.h C++ definitions for Push/Pop code
! pp_sys.c Push/Pop code for system interaction
! proto.h Prototypes
! qnx/ar QNX implementation of "ar" utility
! qnx/cpp QNX implementation of preprocessor filter
! regcomp.c Regular expression compiler
! regcomp.h Private declarations for above
! regcomp.pl Builder of regnodes.h
! regcomp.sym Data for regnodes.h
! regexec.c Regular expression evaluator
! regexp.h Public declarations for the above
! regnodes.h Description of nodes of RE engine
! run.c The interpreter loop
! scope.c Scope entry and exit code
! scope.h Scope entry and exit header
! sv.c Scalar value code
! sv.h Scalar value header
! t/README Instructions for regression tests
! t/TEST The regression tester
! t/TestInit.pm Preamble library for core tests
! t/base/commonsense.t See if configuration meets basic needs
! t/base/cond.t See if conditionals work
! t/base/if.t See if if works
! t/base/lex.t See if lexical items work
! t/base/pat.t See if pattern matching works
! t/base/rs.t See if record-read works
! t/base/term.t See if various terms work
! t/camel-III/vstring.t See if Camel 3rd edition is lying.
! t/cmd/elsif.t See if else-if works
! t/cmd/for.t See if for loops work
! t/cmd/mod.t See if statement modifiers work
! t/cmd/subval.t See if subroutine values work
! t/cmd/switch.t See if switch optimizations work
! t/cmd/while.t See if while loops work
! t/comp/bproto.t See if builtins conform to their prototypes
! t/comp/cmdopt.t See if command optimization works
! t/comp/colon.t See if colons are parsed correctly
! t/comp/cpp.aux main file for cpp.t
! t/comp/cpp.t See if C preprocessor works
! t/comp/decl.t See if declarations work
! t/comp/multiline.t See if multiline strings work
! t/comp/package.t See if packages work
! t/comp/proto.t See if function prototypes work
! t/comp/redef.t See if we get correct warnings on redefined subs
! t/comp/require.t See if require works
! t/comp/script.t See if script invokation works
! t/comp/term.t See if more terms work
! t/comp/use.t See if pragmas work
! t/harness Finer diagnostics from test suite
! t/io/argv.t See if ARGV stuff works
! t/io/dup.t See if >& works right
! t/io/fs.t See if directory manipulations work
! t/io/inplace.t See if inplace editing works
! t/io/iprefix.t See if inplace editing works with prefixes
! t/io/nargv.t See if nested ARGV stuff works
! t/io/open.t See if open works
! t/io/openpid.t See if open works for subprocesses
! t/io/pipe.t See if secure pipes work
! t/io/print.t See if print commands work
! t/io/read.t See if read works
! t/io/tell.t See if file seeking works
! t/io/utf8.t See if file seeking works
! t/lib/1_compile.t See if the various libraries and extensions compile
! t/lib/abbrev.t See if Text::Abbrev works
! t/lib/ansicolor.t See if Term::ANSIColor works
! t/lib/anydbm.t See if AnyDBM_File works
! t/lib/attrs.t See if attrs works with C<sub : attrs>
! t/lib/autoloader.t See if AutoLoader works
! t/lib/b.t See if B backends work
! t/lib/basename.t See if File::Basename works
! t/lib/bigfloat.t See if bigfloat.pl works
! t/lib/bigfltpm.t See if BigFloat.pm works
! t/lib/bigint.t See if bigint.pl works
! t/lib/bigintpm.t See if BigInt.pm works
! t/lib/cgi-esc.t See if CGI.pm works
! t/lib/cgi-form.t See if CGI.pm works
! t/lib/cgi-function.t See if CGI.pm works
! t/lib/cgi-html.t See if CGI.pm works
! t/lib/cgi-pretty.t See if CGI.pm works
! t/lib/cgi-request.t See if CGI.pm works
! t/lib/charnames.t See if character names work
! t/lib/checktree.t See if File::CheckTree works
! t/lib/class-isa.t See if Class::ISA works
! t/lib/class-struct.t See if Class::Struct works
! t/lib/complex.t See if Math::Complex works
! t/lib/compmod.pl Helper for 1_compile.t
! t/lib/cwd.t See if Cwd works
! t/lib/db-btree.t See if DB_File works
! t/lib/db-hash.t See if DB_File works
! t/lib/db-recno.t See if DB_File works
! t/lib/digest.t See if Digest extensions work
! t/lib/dirhand.t See if DirHandle works
! t/lib/dosglob.t See if File::DosGlob works
! t/lib/dprof.t Perl code profiler testsuite driver
! t/lib/dprof/V.pm Perl code profiler tests
! t/lib/dprof/test1_t Perl code profiler tests
! t/lib/dprof/test1_v Perl code profiler tests
! t/lib/dprof/test2_t Perl code profiler tests
! t/lib/dprof/test2_v Perl code profiler tests
! t/lib/dprof/test3_t Perl code profiler tests
! t/lib/dprof/test3_v Perl code profiler tests
! t/lib/dprof/test4_t Perl code profiler tests
! t/lib/dprof/test4_v Perl code profiler tests
! t/lib/dprof/test5_t Perl code profiler tests
! t/lib/dprof/test5_v Perl code profiler tests
! t/lib/dprof/test6_t Perl code profiler tests
! t/lib/dprof/test6_v Perl code profiler tests
! t/lib/dumper-ovl.t See if Data::Dumper works for overloaded data
! t/lib/dumper.t See if Data::Dumper works
! t/lib/encode.t See if Encode works
! t/lib/english.t See if English works
! t/lib/env-array.t See if Env works for arrays
! t/lib/env.t See if Env works
! t/lib/errno.t See if Errno works
! t/lib/fatal.t See if Fatal works
! t/lib/fields.t See if base/fields works
! t/lib/filecache.t See if FileCache works
! t/lib/filecopy.t See if File::Copy works
! t/lib/filefind.t See if File::Find works
! t/lib/filefunc.t See if File::Spec::Functions works
! t/lib/filehand.t See if FileHandle works
! t/lib/filepath.t See if File::Path works
! t/lib/filespec.t See if File::Spec works
! t/lib/filter-util.pl See if Filter::Util::Call works
! t/lib/filter-util.t See if Filter::Util::Call works
! t/lib/findbin.t See if FindBin works
! t/lib/ftmp-mktemp.t See if File::Temp works
! t/lib/ftmp-posix.t See if File::Temp works
! t/lib/ftmp-security.t See if File::Temp works
! t/lib/ftmp-tempfile.t See if File::Temp works
! t/lib/gdbm.t See if GDBM_File works
! t/lib/getopt.t See if Getopt::Std and Getopt::Long work
! t/lib/glob-basic.t See if File::Glob works
! t/lib/glob-case.t See if File::Glob works
! t/lib/glob-global.t See if File::Glob works
! t/lib/glob-taint.t See if File::Glob works
! t/lib/gol-basic.t See if Getopt::Long works
! t/lib/gol-compat.t See if Getopt::Long works
! t/lib/gol-linkage.t See if Getopt::Long works
! t/lib/gol-oo.t See if Getopt::Long works
! t/lib/h2ph.h Test header file for h2ph
! t/lib/h2ph.pht Generated output from h2ph.h by h2ph, for comparison
! t/lib/h2ph.t See if h2ph works like it should
! t/lib/hostname.t See if Sys::Hostname works
! t/lib/io_const.t See if constants from IO work
! t/lib/io_dir.t See if directory-related methods from IO work
! t/lib/io_dup.t See if dup()-related methods from IO work
! t/lib/io_linenum.t See if I/O line numbers are tracked correctly
! t/lib/io_multihomed.t See if INET sockets work with multi-homed hosts
! t/lib/io_pipe.t See if pipe()-related methods from IO work
! t/lib/io_poll.t See if poll()-related methods from IO work
! t/lib/io_scalar.t Test of PerlIO::Scalar
! t/lib/io_sel.t See if select()-related methods from IO work
! t/lib/io_sock.t See if INET socket-related methods from IO work
! t/lib/io_taint.t See if the untaint method from IO works
! t/lib/io_tell.t See if seek()/tell()-related methods from IO work
! t/lib/io_udp.t See if UDP socket-related methods from IO work
! t/lib/io_unix.t See if UNIX socket-related methods from IO work
! t/lib/io_xs.t See if XSUB methods from IO work
! t/lib/ipc_sysv.t See if IPC::SysV works
! t/lib/lc-all.t See if Locale::Codes work
! t/lib/lc-constants.t See if Locale::Codes work
! t/lib/lc-country.t See if Locale::Codes work
! t/lib/lc-currency.t See if Locale::Codes work
! t/lib/lc-language.t See if Locale::Codes work
! t/lib/lc-uk.t See if Locale::Codes work
! t/lib/md5-aaa.t See if Digest::MD5 extension works
! t/lib/md5-align.t See if Digest::MD5 extension works
! t/lib/md5-badf.t See if Digest::MD5 extension works
! t/lib/md5-file.t See if Digest::MD5 extension works
! t/lib/mimeb64.t see whether MIME::Base64 works
! t/lib/mimeb64u.t see whether MIME::Base64 works
! t/lib/mimeqp.t see whether MIME::QuotedPrint works
! t/lib/ndbm.t See if NDBM_File works
! t/lib/net-hostent.t See if Net::hostent works
! t/lib/odbm.t See if ODBM_File works
! t/lib/opcode.t See if Opcode works
! t/lib/open2.t See if IPC::Open2 works
! t/lib/open3.t See if IPC::Open3 works
! t/lib/ops.t See if Opcode works
! t/lib/parsewords.t See if Text::ParseWords works
! t/lib/peek.t See if Devel::Peek works
! t/lib/ph.t See if h2ph works
! t/lib/posix.t See if POSIX works
! t/lib/safe1.t See if Safe works
! t/lib/safe2.t See if Safe works
! t/lib/sample-tests/bailout Test data for Test::Harness
! t/lib/sample-tests/combined Test data for Test::Harness
! t/lib/sample-tests/descriptive Test data for Test::Harness
! t/lib/sample-tests/duplicates Test data for Test::Harness
! t/lib/sample-tests/header_at_end Test data for Test::Harness
! t/lib/sample-tests/no_nums Test data for Test::Harness
! t/lib/sample-tests/simple Test data for Test::Harness
! t/lib/sample-tests/simple_fail Test data for Test::Harness
! t/lib/sample-tests/skip Test data for Test::Harness
! t/lib/sample-tests/skip_all Test data for Test::Harness
! t/lib/sample-tests/todo Test data for Test::Harness
! t/lib/sample-tests/with_comments Test data for Test::Harness
! t/lib/sdbm.t See if SDBM_File works
! t/lib/searchdict.t See if Search::Dict works
! t/lib/selectsaver.t See if SelectSaver works
! t/lib/selfloader.t See if SelfLoader works
! t/lib/sigaction.t See if POSIX::sigaction works
! t/lib/socket.t See if Socket works
! t/lib/soundex.t See if Soundex works
! t/lib/st-06compat.t See if Storable works
! t/lib/st-blessed.t See if Storable works
! t/lib/st-canonical.t See if Storable works
! t/lib/st-dclone.t See if Storable works
! t/lib/st-dump.pl See if Storable works
! t/lib/st-forgive.t See if Storable works
! t/lib/st-freeze.t See if Storable works
! t/lib/st-lock.t See if Storable works
! t/lib/st-overload.t See if Storable works
! t/lib/st-recurse.t See if Storable works
! t/lib/st-retrieve.t See if Storable works
! t/lib/st-store.t See if Storable works
! t/lib/st-tied.t See if Storable works
! t/lib/st-tiedhook.t See if Storable works
! t/lib/st-tieditems.t See if Storable works
! t/lib/st-utf8.t See if Storable works
! t/lib/switch.t Test whether switch works
! t/lib/symbol.t See if Symbol works
! t/lib/syslfs.t See if large files work for sysio
! t/lib/syslog.t See if Sys::Syslog works
! t/lib/tb-genxt.t See if Text::Balanced works
! t/lib/tb-xbrak.t See if Text::Balanced works
! t/lib/tb-xcode.t See if Text::Balanced works
! t/lib/tb-xdeli.t See if Text::Balanced works
! t/lib/tb-xmult.t See if Text::Balanced works
! t/lib/tb-xquot.t See if Text::Balanced works
! t/lib/tb-xtagg.t See if Text::Balanced works
! t/lib/tb-xvari.t See if Text::Balanced works
! t/lib/test-harness.t See if Test::Harness works
! t/lib/textfill.t See if Text::Wrap::fill works
! t/lib/texttabs.t See if Text::Tabs works
! t/lib/textwrap.t See if Text::Wrap::wrap works
! t/lib/thr5005.t Test 5.005-style threading (skipped if no use5005threads)
! t/lib/tie-push.t Test for Tie::Array
! t/lib/tie-refhash.t Test for Tie::RefHash and Tie::RefHash::Nestable
! t/lib/tie-splice.t Test for Tie::Array::SPLICE
! t/lib/tie-stdarray.t Test for Tie::StdArray
! t/lib/tie-stdhandle.t Test for Tie::StdHandle
! t/lib/tie-stdpush.t Test for Tie::StdArray
! t/lib/tie-substrhash.t Test for Tie::SubstrHash
! t/lib/timelocal.t See if Time::Local works
! t/lib/trig.t See if Math::Trig works
! t/lib/xs-typemap.t test that typemaps work
! t/op/64bitint.t See if 64 bit integers work
! t/op/anonsub.t See if anonymous subroutines work
! t/op/append.t See if . works
! t/op/args.t See if operations on @_ work
! t/op/arith.t See if arithmetic works
! t/op/array.t See if array operations work
! t/op/assignwarn.t See if OP= operators warn correctly for undef targets
! t/op/attrs.t See if attributes on declarations work
! t/op/auto.t See if autoincrement et all work
! t/op/avhv.t See if pseudo-hashes work
! t/op/bless.t See if bless works
! t/op/bop.t See if bitops work
! t/op/chars.t See if character escapes work
! t/op/chop.t See if chop works
! t/op/closure.t See if closures work
! t/op/cmp.t See if the various string and numeric compare work
! t/op/concat.t See if string concatenation works
! t/op/cond.t See if conditional expressions work
! t/op/context.t See if context propagation works
! t/op/defins.t See if auto-insert of defined() works
! t/op/delete.t See if delete works
! t/op/die.t See if die works
! t/op/die_exit.t See if die and exit status interaction works
! t/op/do.t See if subroutines work
! t/op/each.t See if hash iterators work
! t/op/eval.t See if eval operator works
! t/op/exec.t See if exec and system work
! t/op/exists_sub.t See if exists(&sub) works
! t/op/exp.t See if math functions work
! t/op/fh.t See if filehandles work
! t/op/filetest.t See if file tests work
! t/op/flip.t See if range operator works
! t/op/fork.t See if fork works
! t/op/glob.t See if <*> works
! t/op/goto.t See if goto works
! t/op/goto_xs.t See if "goto &sub" works on XSUBs
! t/op/grent.t See if getgr*() functions work
! t/op/grep.t See if grep() and map() work
! t/op/groups.t See if $( works
! t/op/gv.t See if typeglobs work
! t/op/hashwarn.t See if warnings for bad hash assignments work
! t/op/inc.t See if inc/dec of integers near 32 bit limit work
! t/op/index.t See if index works
! t/op/int.t See if int works
! t/op/join.t See if join works
! t/op/length.t See if length works
! t/op/lex_assign.t See if ops involving lexicals or pad temps work
! t/op/lfs.t See if large files work for perlio
! t/op/list.t See if array lists work
! t/op/local.t See if local works
! t/op/loopctl.t See if next/last/redo work
! t/op/lop.t See if logical operators work
! t/op/magic.t See if magic variables work
! t/op/method.t See if method calls work
! t/op/misc.t See if miscellaneous bugs have been fixed
! t/op/mkdir.t See if mkdir works
! t/op/my.t See if lexical scoping works
! t/op/my_stash.t See if my Package works
! t/op/nothr5005.t local @_ test which does not work under use5005threads
! t/op/numconvert.t See if accessing fields does not change numeric values
! t/op/oct.t See if oct and hex work
! t/op/ord.t See if ord works
! t/op/pack.t See if pack and unpack work
! t/op/pat.t See if esoteric patterns work
! t/op/pos.t See if pos works
! t/op/push.t See if push and pop work
! t/op/pwent.t See if getpw*() functions work
! t/op/quotemeta.t See if quotemeta works
! t/op/rand.t See if rand works
! t/op/range.t See if .. works
! t/op/re_tests Regular expressions for regexp.t
! t/op/read.t See if read() works
! t/op/readdir.t See if readdir() works
! t/op/recurse.t See if deep recursion works
! t/op/ref.t See if refs and objects work
! t/op/regexp.t See if regular expressions work
! t/op/regexp_noamp.t See if regular expressions work with optimizations
! t/op/regmesg.t See if one can get regular expression errors
! t/op/repeat.t See if x operator works
! t/op/reverse.t See if reverse operator works
! t/op/runlevel.t See if die() works from perl_call_*()
! t/op/sleep.t See if sleep works
! t/op/sort.t See if sort works
! t/op/splice.t See if splice works
! t/op/split.t See if split works
! t/op/sprintf.t See if sprintf works
! t/op/stat.t See if stat works
! t/op/study.t See if study works
! t/op/subst.t See if substitution works
! t/op/subst_amp.t See if $&-related substitution works
! t/op/subst_wamp.t See if substitution works with $& present
! t/op/substr.t See if substr works
! t/op/sysio.t See if sysread and syswrite work
! t/op/taint.t See if tainting works
! t/op/tie.t See if tie/untie functions work
! t/op/tiearray.t See if tie for arrays works
! t/op/tiehandle.t See if tie for handles works
! t/op/time.t See if time functions work
! t/op/tr.t See if tr works
! t/op/undef.t See if undef works
! t/op/universal.t See if UNIVERSAL class works
! t/op/unshift.t See if unshift works
! t/op/utf8decode.t See if UTF-8 decoding works
! t/op/vec.t See if vectors work
! t/op/ver.t See if v-strings and the %v format flag work
! t/op/wantarray.t See if wantarray works
! t/op/write.t See if write works
! t/pod/emptycmd.t Test empty pod directives
! t/pod/emptycmd.xr Expected results for emptycmd.t
! t/pod/find.t See if Pod::Find works
! t/pod/for.t Test =for directive
! t/pod/for.xr Expected results for for.t
! t/pod/headings.t Test =head directives
! t/pod/headings.xr Expected results for headings.t
! t/pod/include.t Test =include directive
! t/pod/include.xr Expected results for include.t
! t/pod/included.t Test =include directive
! t/pod/included.xr Expected results for included.t
! t/pod/lref.t Test L<...> sequences
! t/pod/lref.xr Expected results for lref.t
! t/pod/multiline_items.t Test multiline =items
t/pod/multiline_items.xr Test multiline =items
! t/pod/nested_items.t Test nested =items
! t/pod/nested_items.xr Expected results for nested_items.t
! t/pod/nested_seqs.t Test nested interior sequences
! t/pod/nested_seqs.xr Expected results for nested_seqs.t
! t/pod/oneline_cmds.t Test single paragraph ==cmds
! t/pod/oneline_cmds.xr Expected results for oneline_cmds.t
! t/pod/pod2usage.t Test Pod::Usage
! t/pod/pod2usage.xr Expected results for pod2usage.t
! t/pod/poderrs.t Test POD errors
! t/pod/poderrs.xr Expected results for emptycmd.t
! t/pod/podselect.t Test Pod::Select
! t/pod/podselect.xr Expected results for podselect.t
! t/pod/special_seqs.t Test "special" interior sequences
! t/pod/special_seqs.xr Expected results for emptycmd.t
! t/pod/testcmp.pl Module to compare output against expected results
! t/pod/testp2pt.pl Module to test Pod::PlainText for a given file
! t/pod/testpchk.pl Module to test Pod::Checker for a given file
! t/pod/testpods/lib/Pod/Stuff.pm Sample data for find.t
! t/pragma/constant.t See if compile-time constants work
! t/pragma/diagnostics.t See if diagnostics.pm works
! t/pragma/locale.t See if locale support works
! t/pragma/locale/latin1 Part of locale.t in Latin 1
! t/pragma/locale/utf8 Part of locale.t in UTF8
! t/pragma/overload.t See if operator overloading works
! t/pragma/strict-refs Tests of "use strict 'refs'" for strict.t
! t/pragma/strict-subs Tests of "use strict 'subs'" for strict.t
! t/pragma/strict-vars Tests of "use strict 'vars'" for strict.t
! t/pragma/strict.t See if strictures work
! t/pragma/sub_lval.t See if lvalue subroutines work
! t/pragma/subs.t See if subroutine pseudo-importation works
! t/pragma/utf8.t See if utf8 operations work
! t/pragma/warn/1global Tests of global warnings for warnings.t
! t/pragma/warn/2use Tests for "use warnings" for warnings.t
! t/pragma/warn/3both Tests for interaction of $^W and "use warnings"
! t/pragma/warn/4lint Tests for -W switch
! t/pragma/warn/5nolint Tests for -X switch
! t/pragma/warn/6default Tests default warnings
! t/pragma/warn/7fatal Tests fatal warnings
! t/pragma/warn/8signal Tests warnings + __WARN__ and __DIE__
! t/pragma/warn/9enabled Tests warnings
! t/pragma/warn/av Tests for av.c for warnings.t
! t/pragma/warn/doio Tests for doio.c for warnings.t
! t/pragma/warn/doop Tests for doop.c for warnings.t
! t/pragma/warn/gv Tests for gv.c for warnings.t
! t/pragma/warn/hv Tests for hv.c for warnings.t
! t/pragma/warn/malloc Tests for malloc.c for warnings.t
! t/pragma/warn/mg Tests for mg.c for warnings.t
! t/pragma/warn/op Tests for op.c for warnings.t
! t/pragma/warn/perl Tests for perl.c for warnings.t
! t/pragma/warn/perlio Tests for perlio.c for warnings.t
! t/pragma/warn/perly Tests for perly.y for warnings.t
! t/pragma/warn/pp Tests for pp.c for warnings.t
! t/pragma/warn/pp_ctl Tests for pp_ctl.c for warnings.t
! t/pragma/warn/pp_hot Tests for pp_hot.c for warnings.t
! t/pragma/warn/pp_sys Tests for pp_sys.c for warnings.t
! t/pragma/warn/regcomp Tests for regcomp.c for warnings.t
! t/pragma/warn/regexec Tests for regexec.c for warnings.t
! t/pragma/warn/run Tests for run.c for warnings.t
! t/pragma/warn/sv Tests for sv.c for warnings.t
! t/pragma/warn/taint Tests for taint.c for warnings.t
! t/pragma/warn/toke Tests for toke.c for warnings.t
! t/pragma/warn/universal Tests for universal.c for warnings.t
! t/pragma/warn/utf8 Tests for utf8.c for warnings.t
! t/pragma/warn/util Tests for util.c for warnings.t
! t/pragma/warnings.t See if warning controls work
! t/run/runenv.t Test if perl honors its environment variables.
! taint.c Tainting code
! thrdvar.h Per-thread variables
! thread.h Threading header
! toke.c The tokener
! uconfig.h Configuration header for microperl
! uconfig.sh Configuration script for microperl
! universal.c The default UNIVERSAL package methods
! unixish.h Defines that are assumed on Unix
! utf8.c Unicode routines
! utf8.h Unicode header
! utfebcdic.h Unicode on EBCDIC (UTF-EBCDIC, tr16) header
! util.c Utility routines
! util.h Dummy header
! utils/Makefile Extract the utility scripts
! utils/c2ph.PL program to translate dbx stabs to perl
! utils/dprofpp.PL Perl code profile post-processor
! utils/h2ph.PL A thing to turn C .h files into perl .ph files
! utils/h2xs.PL Program to make .xs files from C header files
! utils/perlbug.PL A simple tool to submit a bug report
! utils/perlcc.PL Front-end for compiler
! utils/perldoc.PL A simple tool to find & display perl's documentation
! utils/pl2pm.PL A pl to pm translator
! utils/splain.PL Stand-alone version of diagnostics.pm
! vmesa/Makefile VM/ESA Makefile
! vmesa/vmesa.c VM/ESA-specific C code for Perl core
! vmesa/vmesaish.h VM/ESA-specific C header for Perl core
! vms/descrip_mms.template Template MM[SK] description file for build
vms/ext/DCLsym/0README.txt ReadMe file for VMS::DCLsym
vms/ext/DCLsym/DCLsym.pm Perl access to CLI symbols
vms/ext/DCLsym/DCLsym.xs Perl access to CLI symbols
vms/ext/DCLsym/Makefile.PL MakeMaker driver for VMS::DCLsym
! vms/ext/DCLsym/test.pl regression tests for VMS::DCLsym
! vms/ext/Filespec.pm VMS-Unix file syntax interconversion
vms/ext/Stdio/0README.txt ReadMe file for VMS::Stdio
vms/ext/Stdio/Makefile.PL MakeMaker driver for VMS::Stdio
! vms/ext/Stdio/Stdio.pm VMS options to stdio routines
! vms/ext/Stdio/Stdio.xs VMS options to stdio routines
! vms/ext/Stdio/test.pl regression tests for VMS::Stdio
! vms/ext/XSSymSet.pm manage linker symbols when building extensions
! vms/ext/filespec.t See if VMS::Filespec funtions work
! vms/ext/vmsish.pm Control VMS-specific behavior of Perl core
! vms/ext/vmsish.t Tests for vmsish.pm
! vms/gen_shrfls.pl generate options files and glue for shareable image
! vms/genconfig.pl retcon config.sh from config.h
! vms/genopt.com hack to write options files in case of broken makes
! vms/make_command.com record MM[SK] command used to build Perl
! vms/mms2make.pl convert descrip.mms to make syntax
! vms/munchconfig.c performs shell $var substitution for VMS
! vms/myconfig.com record local configuration info for bug report
! vms/perlvms.pod VMS-specific additions to Perl documentation
! vms/perly_c.vms perly.c with fixed declarations for global syms
! vms/perly_h.vms perly.h with fixed declarations for global syms
! vms/sockadapt.c glue for SockshShr socket support
! vms/sockadapt.h glue for SockshShr socket support
! vms/test.com DCL driver for regression tests
! vms/vms.c VMS-specific C code for Perl core
! vms/vms_yfix.pl convert Unix perly.[ch] to VMS perly_[ch].vms
! vms/vmsish.h VMS-specific C header for Perl core
! vms/vmspipe.com VMS-specific piped command helper script
! vms/writemain.pl Generate perlmain.c from miniperlmain.c+extensions
! vos/Changes Changes made to port Perl to the VOS operating system
! vos/build.cm VOS command macro to build Perl
! vos/compile_perl.cm VOS command macro to build multiple version of Perl
! vos/config.alpha.def definitions used by config.pl
! vos/config.alpha.h config.h for use with alpha VOS POSIX.1 support
! vos/config.ga.def definitions used by config.pl
! vos/config.ga.h config.h for use with generally-available VOS POSIX.1 support
! vos/config.pl script to convert a config_h.SH to a config.h
! vos/configure_perl.cm VOS command macro to configure perl before building
! vos/install_perl.cm VOS command macro to install perl after building
! vos/perl.bind VOS bind control file
! vos/test_vos_dummies.c Test program for "vos_dummies.c"
! vos/vos_dummies.c Wrappers to soak up undefined functions
! vos/vosish.h VOS-specific header file
! warnings.h The warning numbers
! warnings.pl Program to write warnings.h and lib/warnings.pm
! win32/FindExt.pm Scan for extensions
! win32/Makefile Win32 makefile for NMAKE (Visual C++ build)
! win32/bin/exetype.pl Set executable type to CONSOLE or WINDOWS
! win32/bin/mdelete.bat multifile delete
! win32/bin/perlglob.pl Win32 globbing
! win32/bin/pl2bat.pl wrap perl scripts into batch files
! win32/bin/runperl.pl run perl script via batch file namesake
! win32/bin/search.pl Win32 port
! win32/buildext.pl Build extensions once miniperl is built
! win32/config.bc Win32 base line config.sh (Borland C++ build)
! win32/config.gc Win32 base line config.sh (mingw32/gcc build)
! win32/config.vc Win32 base line config.sh (Visual C++ build)
! win32/config_H.bc Win32 config header (Borland C++ build)
! win32/config_H.gc Win32 config header (GNU build)?
! win32/config_H.vc Win32 config header (Visual C++ build)
! win32/config_h.PL Perl code to convert Win32 config.sh to config.h
! win32/config_sh.PL Perl code to update Win32 config.sh from Makefile
! win32/des_fcrypt.patch Win32 port
! win32/distclean.bat Remove _ALL_ files not listed here in MANIFEST
! win32/dl_win32.xs Win32 port
! win32/genmk95.pl Perl code to generate command.com-usable makefile.95
win32/include/arpa/inet.h Win32 port
win32/include/dirent.h Win32 port
win32/include/netdb.h Win32 port
win32/include/sys/socket.h Win32 port
! win32/makefile.mk Win32 makefile for DMAKE (BC++, VC++ builds)
! win32/perlglob.c Win32 port
! win32/perlhost.h Perl "host" implementation
! win32/perllib.c Win32 port
! win32/pod.mak Win32 port
! win32/runperl.c Win32 port
! win32/sncfnmcs.pl Win32 port
! win32/splittree.pl Win32 port
! win32/vdir.h Perl "host" virtual directory manager
! win32/vmem.h Perl "host" memory manager
! win32/win32.c Win32 port
! win32/win32.h Win32 port
! win32/win32iop.h Win32 port
! win32/win32sck.c Win32 port
! win32/win32thread.c Win32 functions for threads
! win32/win32thread.h Win32 port mapping to threads
! writemain.SH Generate perlmain.c from miniperlmain.c+extensions
! x2p/EXTERN.h Same as above
! x2p/INTERN.h Same as above
! x2p/Makefile.SH Precursor to Makefile
! x2p/a2p.c Output of a2p.y run through byacc
! x2p/a2p.h Global declarations
! x2p/a2p.pod Pod for awk to perl translator
! x2p/a2p.y A yacc grammer for awk
! x2p/a2py.c Awk compiler, sort of
! x2p/cflags.SH A script that emits C compilation flags per file
! x2p/find2perl.PL A find to perl translator
! x2p/hash.c Hashes again
! x2p/hash.h Public declarations for the above
! x2p/proto.h Dummy header
! x2p/s2p.PL Sed to perl translator
! x2p/str.c String handling package
! x2p/str.h Public declarations for the above
! x2p/util.c Utility routines
! x2p/util.h Public declarations for the above
! x2p/walk.c Parse tree walker
! xsutils.c Additional bundled package methods not in UNIVERSAL::
--- 1635,2260 ----
os2/OS2/REXX/t/rx_tieydb.t DLL access module
os2/OS2/REXX/t/rx_varset.t DLL access module
os2/OS2/REXX/t/rx_vrexx.t DLL access module
! os2/os2_base.t Additional tests for builtin methods
! os2/os2add.sym Overriding symbols to export
! os2/os2ish.h Header for OS/2
! os2/os2thread.h pthread-like typedefs
! os2/perl2cmd.pl Corrects installed binaries under OS/2
! patchlevel.h The current patch level of perl
! perl.c main()
! perl.h Global declarations
! perlapi.c Perl API functions
! perlapi.h Perl API function declarations
! perlio.c C code for PerlIO abstraction
! perlio.h PerlIO abstraction
! perlio.sym Symbols for PerlIO abstraction
! perliol.h PerlIO Layer definition
! perlsdio.h Fake stdio using perlio
! perlsfio.h Prototype sfio mapping for PerlIO
! perlsh A poor man's perl shell
! perlvars.h Global variables
! perly.c A byacc'ed perly.y
! perly.fixer A program to remove yacc stack limitations
! perly.h The header file for perly.c
! perly.y Yacc grammar for perl
! perly_c.diff Fixup perly.c to allow recursion
! perlyline.pl Perl code to fix #line directives and gcc warnings in perly.c
! plan9/aperl Shell to make Perl error messages Acme-friendly
! plan9/arpa/inet.h Plan9 port: replacement C header file
! plan9/buildinfo Plan9 port: configuration information
! plan9/config.plan9 Plan9 port: config.h template
! plan9/exclude Plan9 port: tests to skip
! plan9/fndvers Plan9 port: update Perl version in config.plan9
! plan9/genconfig.pl Plan9 port: generate config.sh
! plan9/mkfile Plan9 port: Mk driver for build
! plan9/myconfig.plan9 Plan9 port: script to print config summary
! plan9/plan9.c Plan9 port: Plan9-specific C routines
! plan9/plan9ish.h Plan9 port: Plan9-specific C header file
! plan9/setup.rc Plan9 port: script for easy build+install
! plan9/versnum Plan9 port: script to print version number
! pod/buildtoc.PL generate buildtoc which generates perltoc.pod
! pod/checkpods.PL Tool to check for common errors in pods
! pod/Makefile.SH generate Makefile whichs makes pods into something else
! pod/perl.pod Top level perl documentation
! pod/perl5004delta.pod Changes from 5.003 to 5.004
! pod/perl5005delta.pod Changes from 5.004 to 5.005
! pod/perl56delta.pod Changes from 5.005 to 5.6
! pod/perl570delta.pod Changes from 5.6 to 5.7.0
! pod/perl571delta.pod Changes from 5.7.0 to 5.7.1
! pod/perl572delta.pod Changes from 5.7.1 to 5.7.2
! pod/perlapi.pod Perl API documentation (autogenerated)
! pod/perlapio.pod PerlIO IO API info
! pod/perlbook.pod Perl book information
! pod/perlboot.pod Beginner's Object-oriented Tutorial
! pod/perlbot.pod Object-oriented Bag o' Tricks
! pod/perlcall.pod Callback info
! pod/perlclib.pod Internal replacements for standard C library functions
! pod/perlcompile.pod Info on using the Compiler suite
! pod/perldata.pod Data structure info
! pod/perldbmfilter.pod Info about DBM Filters
! pod/perldebguts.pod Debugger guts info
! pod/perldebtut.pod Perl debugging tutorial
! pod/perldebug.pod Debugger info
! pod/perldelta.pod Changes since last version
! pod/perldiag.pod Diagnostic info
! pod/perldsc.pod Data Structures Cookbook
! pod/perlebcdic.pod Considerations for running Perl on EBCDIC platforms
! pod/perlembed.pod Embedding info
! pod/perlfaq.pod Frequently Asked Questions, Top Level
! pod/perlfaq1.pod Frequently Asked Questions, Part 1
! pod/perlfaq2.pod Frequently Asked Questions, Part 2
! pod/perlfaq3.pod Frequently Asked Questions, Part 3
! pod/perlfaq4.pod Frequently Asked Questions, Part 4
! pod/perlfaq5.pod Frequently Asked Questions, Part 5
! pod/perlfaq6.pod Frequently Asked Questions, Part 6
! pod/perlfaq7.pod Frequently Asked Questions, Part 7
! pod/perlfaq8.pod Frequently Asked Questions, Part 8
! pod/perlfaq9.pod Frequently Asked Questions, Part 9
! pod/perlfilter.pod Source filters info
! pod/perlfork.pod Info about fork()
! pod/perlform.pod Format info
! pod/perlfunc.pod Function info
! pod/perlguts.pod Internals info
! pod/perlhack.pod Perl hackers guide
! pod/perlhist.pod Perl history info
! pod/perlintern.pod Perl internal function docs (autogenrated)
! pod/perliol.pod Internals of PerlIO with layers.
! pod/perlipc.pod IPC info
! pod/perllexwarn.pod Lexical Warnings info
! pod/perllocale.pod Locale support info
! pod/perllol.pod How to use lists of lists
! pod/perlmod.pod Module mechanism info
! pod/perlmodinstall.pod Installing CPAN Modules
! pod/perlmodlib.PL Generate pod/perlmodlib.pod
! pod/perlmodlib.pod Module policy info
! pod/perlnewmod.pod Preparing a new module for distribution
! pod/perlnumber.pod Semantics of numbers and numeric operations
! pod/perlobj.pod Object info
! pod/perlop.pod Operator info
! pod/perlopentut.pod open() tutorial
! pod/perlpod.pod Pod info
! pod/perlport.pod Portability guide
! pod/perlre.pod Regular expression info
! pod/perlref.pod References info
! pod/perlreftut.pod Mark's references tutorial
! pod/perlrequick.pod Quick start guide for Perl regular expressions
! pod/perlretut.pod Tutorial for Perl regular expressions
! pod/perlrun.pod Execution info
! pod/perlsec.pod Security info
! pod/perlstyle.pod Style info
! pod/perlsub.pod Subroutine info
! pod/perlsyn.pod Syntax info
! pod/perlthrtut.pod Threads tutorial
! pod/perltie.pod Tieing an object class into a simple variable
! pod/perltoc.pod Table of Contents info
! pod/perltodo.pod Todo list explained
! pod/perltoot.pod Tom's object-oriented tutorial
! pod/perltootc.pod Tom's object-oriented tutorial (more on class data)
! pod/perltrap.pod Trap info
! pod/perlunicode.pod Unicode support info
! pod/perlutil.pod Accompanying utilities explained
! pod/perlvar.pod Variable info
! pod/perlxs.pod XS api info
! pod/perlxstut.pod XS tutorial
! pod/pod2html.PL Precursor for translator to turn pod into HTML
! pod/pod2latex.PL Precursor for translator to turn pod into LaTeX
! pod/pod2man.PL Precursor for translator to turn pod into manpage
! pod/pod2text.PL Precursor for translator to turn pod into text
! pod/pod2usage.PL Pod-Parser - print usage messages from POD docs
! pod/podchecker.PL Pod-Parser - Pod::Checker::podchecker() CLI
! pod/podselect.PL Pod-Parser - Pod::Select::podselect() CLI
! pod/roffitall troff the whole man page set
! pod/rofftoc Generate a table of contents in troff format
! pod/splitman Splits perlfunc into multiple man pages
! pod/splitpod Splits perlfunc into multiple pod pages
! Policy_sh.SH Hold site-wide preferences between Configure runs.
! Porting/config.sh Sample config.sh
! Porting/config_H Sample config.h
! Porting/Contract Social contract for contributed modules in Perl core
! Porting/findvars Find occurrences of words
! Porting/fixCORE Find and fix modules that generate warnings
! Porting/fixvars Find undeclared variables with C compiler and fix em
! Porting/genlog Generate formatted changelogs by querying p4d
! Porting/Glossary Glossary of config.sh variables
! Porting/makerel Release making utility
! Porting/p4d2p Generate standard patches from p4 diffs
! Porting/p4desc Smarter 'p4 describe', outputs diffs for new files
! Porting/patching.pod How to report changes made to Perl
! Porting/patchls Flexible patch file listing utility
! Porting/pumpkin.pod Guidelines and hints for Perl maintainers
! Porting/repository.pod How to use the Perl repository
! Porting/testall.atom Cumulative profile of the test suite with Third Degree
! pp.c Push/Pop code
! pp.h Push/Pop code defs
! pp.sym Push/Pop code symbols
! pp_ctl.c Push/Pop code for control flow
! pp_hot.c Push/Pop code for heavily used opcodes
! pp_pack.c Push/Pop code for pack/unpack
! pp_proto.h C++ definitions for Push/Pop code
! pp_sys.c Push/Pop code for system interaction
! proto.h Prototypes
! qnx/ar QNX implementation of "ar" utility
! qnx/cpp QNX implementation of preprocessor filter
! README The Instructions
! README.aix Notes about AIX port
! README.amiga Notes about AmigaOS port
! README.apollo Notes about Apollo DomainOS port
! README.beos Notes about BeOS port
! README.bs2000 Notes about BS2000 POSIX port
! README.cygwin Notes about Cygwin port
! README.dgux Notes about DG/UX port
! README.dos Notes about DOS/DJGPP port
! README.epoc Notes about EPOC port
! README.hpux Notes about HP-UX port
! README.hurd Notes about GNU/Hurd port
! README.machten Notes about Power MachTen port
! README.macos Notes about Mac OS (Classic)
! README.micro Notes about microperl
! README.mint Notes about Atari MiNT port
! README.mpeix Notes about MPE/iX port
! README.netware Notes about Netware port
! README.os2 Notes about OS/2 port
! README.os390 Notes about OS/390 (nee MVS) port
! README.plan9 Notes about Plan9 port
! README.qnx Notes about QNX port
! README.solaris Notes about Solaris port
! README.threads Notes about multithreading
! README.tru64 Notes about Tru64
! README.uts Notes about UTS
! README.vmesa Notes about VM/ESA port
! README.vms Notes about installing the VMS port
! README.vos Notes about Stratus VOS port
! README.win32 Notes about Win32 port
! README.Y2K Notes about Year 2000 concerns
! regcomp.c Regular expression compiler
! regcomp.h Private declarations for above
! regcomp.pl Builder of regnodes.h
! regcomp.sym Data for regnodes.h
! regexec.c Regular expression evaluator
! regexp.h Public declarations for the above
! regnodes.h Description of nodes of RE engine
! run.c The interpreter loop
! scope.c Scope entry and exit code
! scope.h Scope entry and exit header
! sv.c Scalar value code
! sv.h Scalar value header
! t/base/commonsense.t See if configuration meets basic needs
! t/base/cond.t See if conditionals work
! t/base/if.t See if if works
! t/base/lex.t See if lexical items work
! t/base/pat.t See if pattern matching works
! t/base/rs.t See if record-read works
! t/base/term.t See if various terms work
! t/cmd/elsif.t See if else-if works
! t/cmd/for.t See if for loops work
! t/cmd/mod.t See if statement modifiers work
! t/cmd/subval.t See if subroutine values work
! t/cmd/switch.t See if switch optimizations work
! t/cmd/while.t See if while loops work
! t/comp/bproto.t See if builtins conform to their prototypes
! t/comp/cmdopt.t See if command optimization works
! t/comp/colon.t See if colons are parsed correctly
! t/comp/cpp.aux main file for cpp.t
! t/comp/cpp.t See if C preprocessor works
! t/comp/decl.t See if declarations work
! t/comp/multiline.t See if multiline strings work
! t/comp/package.t See if packages work
! t/comp/proto.t See if function prototypes work
! t/comp/redef.t See if we get correct warnings on redefined subs
! t/comp/require.t See if require works
! t/comp/script.t See if script invokation works
! t/comp/term.t See if more terms work
! t/comp/use.t See if pragmas work
! t/harness Finer diagnostics from test suite
! t/io/argv.t See if ARGV stuff works
! t/io/dup.t See if >& works right
! t/io/fflush.t See if auto-flush on fork/exec/system/qx works
! t/io/fs.t See if directory manipulations work
! t/io/inplace.t See if inplace editing works
! t/io/iprefix.t See if inplace editing works with prefixes
! t/io/nargv.t See if nested ARGV stuff works
! t/io/open.t See if open works
! t/io/openpid.t See if open works for subprocesses
! t/io/pipe.t See if secure pipes work
! t/io/print.t See if print commands work
! t/io/read.t See if read works
! t/io/tell.t See if file seeking works
! t/io/utf8.t See if file seeking works
! t/lib/1_compile.t See if the various libraries and extensions compile
! t/lib/compmod.pl Helper for 1_compile.t
! t/lib/dprof/test1_t Perl code profiler tests
! t/lib/dprof/test1_v Perl code profiler tests
! t/lib/dprof/test2_t Perl code profiler tests
! t/lib/dprof/test2_v Perl code profiler tests
! t/lib/dprof/test3_t Perl code profiler tests
! t/lib/dprof/test3_v Perl code profiler tests
! t/lib/dprof/test4_t Perl code profiler tests
! t/lib/dprof/test4_v Perl code profiler tests
! t/lib/dprof/test5_t Perl code profiler tests
! t/lib/dprof/test5_v Perl code profiler tests
! t/lib/dprof/test6_t Perl code profiler tests
! t/lib/dprof/test6_v Perl code profiler tests
! t/lib/dprof/V.pm Perl code profiler tests
! t/lib/filter-util.pl See if Filter::Util::Call works
! t/lib/h2ph.h Test header file for h2ph
! t/lib/h2ph.pht Generated output from h2ph.h by h2ph, for comparison
! t/lib/locale/latin1 Part of locale.t in Latin 1
! t/lib/locale/utf8 Part of locale.t in UTF8
! t/lib/MyFilter.pm Helper file for t/lib/filter-simple.t
! t/lib/sample-tests/bailout Test data for Test::Harness
! t/lib/sample-tests/combined Test data for Test::Harness
! t/lib/sample-tests/descriptive Test data for Test::Harness
! t/lib/sample-tests/duplicates Test data for Test::Harness
! t/lib/sample-tests/header_at_end Test data for Test::Harness
! t/lib/sample-tests/no_nums Test data for Test::Harness
! t/lib/sample-tests/simple Test data for Test::Harness
! t/lib/sample-tests/simple_fail Test data for Test::Harness
! t/lib/sample-tests/skip Test data for Test::Harness
! t/lib/sample-tests/skip_all Test data for Test::Harness
! t/lib/sample-tests/todo Test data for Test::Harness
! t/lib/sample-tests/with_comments Test data for Test::Harness
! t/lib/st-dump.pl See if Storable works
! t/lib/strict/refs Tests of "use strict 'refs'" for strict.t
! t/lib/strict/subs Tests of "use strict 'subs'" for strict.t
! t/lib/strict/vars Tests of "use strict 'vars'" for strict.t
! t/lib/Test/More/Catch.pm Utility module for testing Test::More
! t/lib/Test/Simple/Catch.pm Utility module for testing Test::Simple
! t/lib/Test/Simple/sample_tests/death.plx for exit.t
! t/lib/Test/Simple/sample_tests/death_in_eval.plx for exit.t
! t/lib/Test/Simple/sample_tests/extras.plx for exit.t
! t/lib/Test/Simple/sample_tests/five_fail.plx for exit.t
! t/lib/Test/Simple/sample_tests/last_minute_death.plx for exit.t
! t/lib/Test/Simple/sample_tests/one_fail.plx for exit.t
! t/lib/Test/Simple/sample_tests/require.plx for exit.t
! t/lib/Test/Simple/sample_tests/success.plx for exit.t
! t/lib/Test/Simple/sample_tests/too_few.plx for exit.t
! t/lib/Test/Simple/sample_tests/two_fail.plx for exit.t
! t/lib/warnings/1global Tests of global warnings for warnings.t
! t/lib/warnings/2use Tests for "use warnings" for warnings.t
! t/lib/warnings/3both Tests for interaction of $^W and "use warnings"
! t/lib/warnings/4lint Tests for -W switch
! t/lib/warnings/5nolint Tests for -X switch
! t/lib/warnings/6default Tests default warnings
! t/lib/warnings/7fatal Tests fatal warnings
! t/lib/warnings/8signal Tests warnings + __WARN__ and __DIE__
! t/lib/warnings/9enabled Tests warnings
! t/lib/warnings/av Tests for av.c for warnings.t
! t/lib/warnings/doio Tests for doio.c for warnings.t
! t/lib/warnings/doop Tests for doop.c for warnings.t
! t/lib/warnings/gv Tests for gv.c for warnings.t
! t/lib/warnings/hv Tests for hv.c for warnings.t
! t/lib/warnings/malloc Tests for malloc.c for warnings.t
! t/lib/warnings/mg Tests for mg.c for warnings.t
! t/lib/warnings/op Tests for op.c for warnings.t
! t/lib/warnings/perl Tests for perl.c for warnings.t
! t/lib/warnings/perlio Tests for perlio.c for warnings.t
! t/lib/warnings/perly Tests for perly.y for warnings.t
! t/lib/warnings/pp Tests for pp.c for warnings.t
! t/lib/warnings/pp_ctl Tests for pp_ctl.c for warnings.t
! t/lib/warnings/pp_hot Tests for pp_hot.c for warnings.t
! t/lib/warnings/pp_pack Tests for pp_pack.c for warnings.t
! t/lib/warnings/pp_sys Tests for pp_sys.c for warnings.t
! t/lib/warnings/regcomp Tests for regcomp.c for warnings.t
! t/lib/warnings/regexec Tests for regexec.c for warnings.t
! t/lib/warnings/run Tests for run.c for warnings.t
! t/lib/warnings/sv Tests for sv.c for warnings.t
! t/lib/warnings/taint Tests for taint.c for warnings.t
! t/lib/warnings/toke Tests for toke.c for warnings.t
! t/lib/warnings/universal Tests for universal.c for warnings.t
! t/lib/warnings/utf8 Tests for utf8.c for warnings.t
! t/lib/warnings/util Tests for util.c for warnings.t
! t/op/64bitint.t See if 64 bit integers work
! t/op/anonsub.t See if anonymous subroutines work
! t/op/append.t See if . works
! t/op/args.t See if operations on @_ work
! t/op/arith.t See if arithmetic works
! t/op/array.t See if array operations work
! t/op/assignwarn.t See if OP= operators warn correctly for undef targets
! t/op/attrs.t See if attributes on declarations work
! t/op/auto.t See if autoincrement et all work
! t/op/avhv.t See if pseudo-hashes work
! t/op/bless.t See if bless works
! t/op/bop.t See if bitops work
! t/op/chars.t See if character escapes work
! t/op/chop.t See if chop works
! t/op/closure.t See if closures work
! t/op/cmp.t See if the various string and numeric compare work
! t/op/concat.t See if string concatenation works
! t/op/cond.t See if conditional expressions work
! t/op/context.t See if context propagation works
! t/op/defins.t See if auto-insert of defined() works
! t/op/delete.t See if delete works
! t/op/die.t See if die works
! t/op/die_exit.t See if die and exit status interaction works
! t/op/do.t See if subroutines work
! t/op/each.t See if hash iterators work
! t/op/eval.t See if eval operator works
! t/op/exec.t See if exec and system work
! t/op/exists_sub.t See if exists(&sub) works
! t/op/exp.t See if math functions work
! t/op/fh.t See if filehandles work
! t/op/filetest.t See if file tests work
! t/op/flip.t See if range operator works
! t/op/fork.t See if fork works
! t/op/glob.t See if <*> works
! t/op/gmagic.t See if GMAGIC works
! t/op/goto.t See if goto works
! t/op/goto_xs.t See if "goto &sub" works on XSUBs
! t/op/grent.t See if getgr*() functions work
! t/op/grep.t See if grep() and map() work
! t/op/groups.t See if $( works
! t/op/gv.t See if typeglobs work
! t/op/hashwarn.t See if warnings for bad hash assignments work
! t/op/inc.t See if inc/dec of integers near 32 bit limit work
! t/op/index.t See if index works
! t/op/int.t See if int works
! t/op/join.t See if join works
! t/op/length.t See if length works
! t/op/lex_assign.t See if ops involving lexicals or pad temps work
! t/op/lfs.t See if large files work for perlio
! t/op/list.t See if array lists work
! t/op/local.t See if local works
! t/op/loopctl.t See if next/last/redo work
! t/op/lop.t See if logical operators work
! t/op/magic.t See if magic variables work
! t/op/method.t See if method calls work
! t/op/misc.t See if miscellaneous bugs have been fixed
! t/op/mkdir.t See if mkdir works
! t/op/my.t See if lexical scoping works
! t/op/my_stash.t See if my Package works
! t/op/nothr5005.t local @_ test which does not work under use5005threads
! t/op/numconvert.t See if accessing fields does not change numeric values
! t/op/oct.t See if oct and hex work
! t/op/ord.t See if ord works
! t/op/override.t See if operator overriding works
! t/op/pack.t See if pack and unpack work
! t/op/pat.t See if esoteric patterns work
! t/op/pos.t See if pos works
! t/op/push.t See if push and pop work
! t/op/pwent.t See if getpw*() functions work
! t/op/quotemeta.t See if quotemeta works
! t/op/rand.t See if rand works
! t/op/range.t See if .. works
! t/op/re_tests Regular expressions for regexp.t
! t/op/read.t See if read() works
! t/op/readdir.t See if readdir() works
! t/op/recurse.t See if deep recursion works
! t/op/ref.t See if refs and objects work
! t/op/regexp.t See if regular expressions work
! t/op/regexp_noamp.t See if regular expressions work with optimizations
! t/op/regmesg.t See if one can get regular expression errors
! t/op/repeat.t See if x operator works
! t/op/reverse.t See if reverse operator works
! t/op/runlevel.t See if die() works from perl_call_*()
! t/op/sleep.t See if sleep works
! t/op/sort.t See if sort works
! t/op/splice.t See if splice works
! t/op/split.t See if split works
! t/op/sprintf.t See if sprintf works
! t/op/stat.t See if stat works
! t/op/study.t See if study works
! t/op/sub_lval.t See if lvalue subroutines work
! t/op/subst.t See if substitution works
! t/op/subst_amp.t See if $&-related substitution works
! t/op/subst_wamp.t See if substitution works with $& present
! t/op/substr.t See if substr works
! t/op/sysio.t See if sysread and syswrite work
! t/op/taint.t See if tainting works
! t/op/tie.t See if tie/untie functions work
! t/op/tiearray.t See if tie for arrays works
! t/op/tiehandle.t See if tie for handles works
! t/op/time.t See if time functions work
! t/op/tr.t See if tr works
! t/op/undef.t See if undef works
! t/op/universal.t See if UNIVERSAL class works
! t/op/unshift.t See if unshift works
! t/op/utf8decode.t See if UTF-8 decoding works
! t/op/vec.t See if vectors work
! t/op/ver.t See if v-strings and the %v format flag work
! t/op/wantarray.t See if wantarray works
! t/op/write.t See if write works (formats work)
! t/pod/emptycmd.t Test empty pod directives
! t/pod/emptycmd.xr Expected results for emptycmd.t
! t/pod/find.t See if Pod::Find works
! t/pod/for.t Test =for directive
! t/pod/for.xr Expected results for for.t
! t/pod/headings.t Test =head directives
! t/pod/headings.xr Expected results for headings.t
! t/pod/include.t Test =include directive
! t/pod/include.xr Expected results for include.t
! t/pod/included.t Test =include directive
! t/pod/included.xr Expected results for included.t
! t/pod/lref.t Test L<...> sequences
! t/pod/lref.xr Expected results for lref.t
! t/pod/multiline_items.t Test multiline =items
t/pod/multiline_items.xr Test multiline =items
! t/pod/nested_items.t Test nested =items
! t/pod/nested_items.xr Expected results for nested_items.t
! t/pod/nested_seqs.t Test nested interior sequences
! t/pod/nested_seqs.xr Expected results for nested_seqs.t
! t/pod/oneline_cmds.t Test single paragraph ==cmds
! t/pod/oneline_cmds.xr Expected results for oneline_cmds.t
! t/pod/plainer.t Test Pod::Plainer
! t/pod/pod2usage.t Test Pod::Usage
! t/pod/pod2usage.xr Expected results for pod2usage.t
! t/pod/poderrs.t Test POD errors
! t/pod/poderrs.xr Expected results for emptycmd.t
! t/pod/podselect.t Test Pod::Select
! t/pod/podselect.xr Expected results for podselect.t
! t/pod/special_seqs.t Test "special" interior sequences
! t/pod/special_seqs.xr Expected results for emptycmd.t
! t/pod/testcmp.pl Module to compare output against expected results
! t/pod/testp2pt.pl Module to test Pod::PlainText for a given file
! t/pod/testpchk.pl Module to test Pod::Checker for a given file
! t/pod/testpods/lib/Pod/Stuff.pm Sample data for find.t
! t/README Instructions for regression tests
! t/run/exit.t Test perl's exit status.
! t/run/runenv.t Test if perl honors its environment variables.
! t/TEST The regression tester
! t/TestInit.pm Preamble library for core tests
! taint.c Tainting code
! thrdvar.h Per-thread variables
! thread.h Threading header
! Todo.micro The Wishlist for microperl
! toke.c The tokener
! uconfig.h Configuration header for microperl
! uconfig.sh Configuration script for microperl
! universal.c The default UNIVERSAL package methods
! unixish.h Defines that are assumed on Unix
! utf8.c Unicode routines
! utf8.h Unicode header
! utfebcdic.h Unicode on EBCDIC (UTF-EBCDIC, tr16) header
! util.c Utility routines
! util.h Dummy header
! utils.lst Lists utilities bundled with Perl
! utils/c2ph.PL program to translate dbx stabs to perl
! utils/dprofpp.PL Perl code profile post-processor
! utils/h2ph.PL A thing to turn C .h files into perl .ph files
! utils/h2xs.PL Program to make .xs files from C header files
! utils/libnetcfg.PL libnet
! utils/Makefile Extract the utility scripts
! utils/perlbug.PL A simple tool to submit a bug report
! utils/perlcc.PL Front-end for compiler
! utils/perldoc.PL A simple tool to find & display perl's documentation
! utils/pl2pm.PL A pl to pm translator
! utils/splain.PL Stand-alone version of diagnostics.pm
! uts/sprintf_wrap.c sprintf wrapper for UTS
! uts/strtol_wrap.c strtol wrapper for UTS
! vmesa/Makefile VM/ESA Makefile
! vmesa/vmesa.c VM/ESA-specific C code for Perl core
! vmesa/vmesaish.h VM/ESA-specific C header for Perl core
! vms/descrip_mms.template Template MM[SK] description file for build
vms/ext/DCLsym/0README.txt ReadMe file for VMS::DCLsym
vms/ext/DCLsym/DCLsym.pm Perl access to CLI symbols
vms/ext/DCLsym/DCLsym.xs Perl access to CLI symbols
vms/ext/DCLsym/Makefile.PL MakeMaker driver for VMS::DCLsym
! vms/ext/DCLsym/test.pl regression tests for VMS::DCLsym
! vms/ext/Filespec.pm VMS-Unix file syntax interconversion
! vms/ext/filespec.t See if VMS::Filespec funtions work
vms/ext/Stdio/0README.txt ReadMe file for VMS::Stdio
vms/ext/Stdio/Makefile.PL MakeMaker driver for VMS::Stdio
! vms/ext/Stdio/Stdio.pm VMS options to stdio routines
! vms/ext/Stdio/Stdio.xs VMS options to stdio routines
! vms/ext/Stdio/test.pl regression tests for VMS::Stdio
! vms/ext/vmsish.pm Control VMS-specific behavior of Perl core
! vms/ext/vmsish.t Tests for vmsish.pm
! vms/ext/XSSymSet.pm manage linker symbols when building extensions
! vms/gen_shrfls.pl generate options files and glue for shareable image
! vms/genconfig.pl retcon config.sh from config.h
! vms/genopt.com hack to write options files in case of broken makes
! vms/make_command.com record MM[SK] command used to build Perl
! vms/mms2make.pl convert descrip.mms to make syntax
! vms/munchconfig.c performs shell $var substitution for VMS
! vms/myconfig.com record local configuration info for bug report
! vms/perlvms.pod VMS-specific additions to Perl documentation
! vms/perly_c.vms perly.c with fixed declarations for global syms
! vms/perly_h.vms perly.h with fixed declarations for global syms
! vms/sockadapt.c glue for SockshShr socket support
! vms/sockadapt.h glue for SockshShr socket support
! vms/test.com DCL driver for regression tests
! vms/vms.c VMS-specific C code for Perl core
! vms/vms_yfix.pl convert Unix perly.[ch] to VMS perly_[ch].vms
! vms/vmsish.h VMS-specific C header for Perl core
! vms/vmspipe.com VMS-specific piped command helper script
! vms/writemain.pl Generate perlmain.c from miniperlmain.c+extensions
! vos/build.cm VOS command macro to build Perl
! vos/Changes Changes made to port Perl to the VOS operating system
! vos/compile_perl.cm VOS command macro to build multiple version of Perl
! vos/config.alpha.def definitions used by config.pl
! vos/config.alpha.h config.h for use with alpha VOS POSIX.1 support
! vos/config.ga.def definitions used by config.pl
! vos/config.ga.h config.h for use with generally-available VOS POSIX.1 support
! vos/config.pl script to convert a config_h.SH to a config.h
! vos/configure_perl.cm VOS command macro to configure perl before building
! vos/install_perl.cm VOS command macro to install perl after building
! vos/Makefile A helper for maintaining the config.*.* in UNIX
! vos/perl.bind VOS bind control file
! vos/test_vos_dummies.c Test program for "vos_dummies.c"
! vos/vos_dummies.c Wrappers to soak up undefined functions
! vos/vosish.h VOS-specific header file
! warnings.h The warning numbers
! warnings.pl Program to write warnings.h and lib/warnings.pm
! win32/bin/exetype.pl Set executable type to CONSOLE or WINDOWS
! win32/bin/perlglob.pl Win32 globbing
! win32/bin/pl2bat.pl wrap perl scripts into batch files
! win32/bin/runperl.pl run perl script via batch file namesake
! win32/bin/search.pl Win32 port
! win32/buildext.pl Build extensions once miniperl is built
! win32/config.bc Win32 base line config.sh (Borland C++ build)
! win32/config.gc Win32 base line config.sh (mingw32/gcc build)
! win32/config.vc Win32 base line config.sh (Visual C++ build)
! win32/config_H.bc Win32 config header (Borland C++ build)
! win32/config_H.gc Win32 config header (GNU build)?
! win32/config_h.PL Perl code to convert Win32 config.sh to config.h
! win32/config_H.vc Win32 config header (Visual C++ build)
! win32/config_sh.PL Perl code to update Win32 config.sh from Makefile
! win32/des_fcrypt.patch Win32 port
! win32/distclean.bat Remove _ALL_ files not listed here in MANIFEST
! win32/dl_win32.xs Win32 port
! win32/FindExt.pm Scan for extensions
! win32/genmk95.pl Perl code to generate command.com-usable makefile.95
win32/include/arpa/inet.h Win32 port
win32/include/dirent.h Win32 port
win32/include/netdb.h Win32 port
win32/include/sys/socket.h Win32 port
! win32/Makefile Win32 makefile for NMAKE (Visual C++ build)
! win32/makefile.mk Win32 makefile for DMAKE (BC++, VC++ builds)
! win32/mdelete.bat multifile delete
! win32/perlglob.c Win32 port
! win32/perlhost.h Perl "host" implementation
! win32/perllib.c Win32 port
! win32/pod.mak Win32 port
! win32/runperl.c Win32 port
! win32/sncfnmcs.pl Win32 port
! win32/splittree.pl Win32 port
! win32/vdir.h Perl "host" virtual directory manager
! win32/vmem.h Perl "host" memory manager
! win32/win32.c Win32 port
! win32/win32.h Win32 port
! win32/win32io.c Win32 PerlIO layer support
! win32/win32iop.h Win32 port
! win32/win32sck.c Win32 port
! win32/win32thread.c Win32 functions for threads
! win32/win32thread.h Win32 port mapping to threads
! writemain.SH Generate perlmain.c from miniperlmain.c+extensions
! x2p/a2p.c Output of a2p.y run through byacc
! x2p/a2p.h Global declarations
! x2p/a2p.pod Pod for awk to perl translator
! x2p/a2p.y A yacc grammer for awk
! x2p/a2py.c Awk compiler, sort of
! x2p/cflags.SH A script that emits C compilation flags per file
! x2p/EXTERN.h Same as above
! x2p/find2perl.PL A find to perl translator
! x2p/hash.c Hashes again
! x2p/hash.h Public declarations for the above
! x2p/INTERN.h Same as above
! x2p/Makefile.SH Precursor to Makefile
! x2p/proto.h Dummy header
! x2p/s2p.PL Sed to perl translator
! x2p/str.c String handling package
! x2p/str.h Public declarations for the above
! x2p/util.c Utility routines
! x2p/util.h Public declarations for the above
! x2p/walk.c Parse tree walker
! XSUB.h Include file for extension subroutines
! xsutils.c Additional bundled package methods not in UNIVERSAL::
diff -c 'perl-5.7.1/Makefile.SH' 'perl-5.7.2/Makefile.SH'
Index: ./Makefile.SH
*** ./Makefile.SH Sat Apr 7 20:37:53 2001
--- ./Makefile.SH Mon Jul 9 17:09:38 2001
***************
*** 1,5 ****
#! /bin/sh
! case $CONFIGDOTSH in
'')
if test -f config.sh
then TOP=.
--- 1,5 ----
#! /bin/sh
! case $PERL_CONFIG_SH in
'')
if test -f config.sh
then TOP=.
***************
*** 26,32 ****
DPERL_EXTERNAL_GLOB='-DPERL_EXTERNAL_GLOB'
case "$useshrplib" in
true)
! # Prefix all runs of 'miniperl' and 'perl' with
# $ldlibpth so that ./perl finds *this* shared libperl.
case "$LD_LIBRARY_PATH" in
'')
--- 26,32 ----
DPERL_EXTERNAL_GLOB='-DPERL_EXTERNAL_GLOB'
case "$useshrplib" in
true)
! # Prefix all runs of 'miniperl' and 'perl' with
# $ldlibpth so that ./perl finds *this* shared libperl.
case "$LD_LIBRARY_PATH" in
'')
***************
*** 48,54 ****
-compatibility_version 1 \
-current_version \
${api_version}.${api_subversion} \
- -image_base 0x4be00000 \
-install_name \$(shrpdir)/\$@"
;;
cygwin*)
--- 48,53 ----
***************
*** 210,216 ****
# Any special object files needed by this architecture, e.g. os2/os2.obj
ARCHOBJS = $archobjs
! .SUFFIXES: .c \$(OBJ_EXT)
# grrr
SHELL = $sh
--- 209,215 ----
# Any special object files needed by this architecture, e.g. os2/os2.obj
ARCHOBJS = $archobjs
! .SUFFIXES: .c \$(OBJ_EXT) .i .s
# grrr
SHELL = $sh
***************
*** 228,235 ****
## In the following dollars and backticks do not need the extra backslash.
$spitshell >>Makefile <<'!NO!SUBS!'
! CCCMD = `sh $(shellflags) cflags $(LIBPERL) $@`
private = preplibrary lib/ExtUtils/Miniperl.pm lib/Config.pm
# Files to be built with variable substitution before miniperl
--- 227,236 ----
## In the following dollars and backticks do not need the extra backslash.
$spitshell >>Makefile <<'!NO!SUBS!'
! CCCMD = `sh $(shellflags) cflags $(LIBPERL) $@`
+ CCCMDSRC = `sh $(shellflags) cflags $(LIBPERL) $<`
+
private = preplibrary lib/ExtUtils/Miniperl.pm lib/Config.pm
# Files to be built with variable substitution before miniperl
***************
*** 264,276 ****
c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c
c2 = perl.c perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c
c3 = gv.c sv.c taint.c toke.c util.c deb.c run.c universal.c xsutils.c
! c4 = globals.c perlio.c perlapi.c
c = $(c1) $(c2) $(c3) $(c4) miniperlmain.c perlmain.c
obj1 = $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT)
obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT)
! obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) xsutils$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT)
obj = $(obj1) $(obj2) $(obj3) $(ARCHOBJS)
--- 265,277 ----
c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c
c2 = perl.c perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c
c3 = gv.c sv.c taint.c toke.c util.c deb.c run.c universal.c xsutils.c
! c4 = globals.c perlio.c perlapi.c numeric.c locale.c pp_pack.c
c = $(c1) $(c2) $(c3) $(c4) miniperlmain.c perlmain.c
obj1 = $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT)
obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT)
! obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) xsutils$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) numeric$(OBJ_EXT) locale$(OBJ_EXT) pp_pack$(OBJ_EXT)
obj = $(obj1) $(obj2) $(obj3) $(ARCHOBJS)
***************
*** 289,294 ****
--- 290,303 ----
.c$(OBJ_EXT):
$(CCCMD) $(PLDLFLAGS) $*.c
+ .c.i:
+ $(CCCMDSRC) -E $*.c > $*.i
+
+ .c.s:
+ $(CCCMDSRC) -S $*.c
+
+ .PHONY: all compile translators utilities
+
all: $(FIRSTMAKEFILE) miniperl extra.pods $(private) $(public) $(dynamic_ext) $(nonxs_ext)
@echo " ";
@echo " Everything is up to date. 'make test' to run test suite."
***************
*** 296,302 ****
compile: all
echo "testing compilation" > testcompile;
cd utils; $(MAKE) compile;
! cd x2p; $(MAKE) compile;
cd pod; $(MAKE) compile;
translators: miniperl lib/Config.pm FORCE
--- 305,311 ----
compile: all
echo "testing compilation" > testcompile;
cd utils; $(MAKE) compile;
! cd x2p; $(MAKE) compile;
cd pod; $(MAKE) compile;
translators: miniperl lib/Config.pm FORCE
***************
*** 311,316 ****
--- 320,326 ----
# Phony target to force checking subdirectories.
# Apparently some makes require an action for the FORCE target.
+ .PHONY: FORCE
FORCE:
@sh -c true
!NO!SUBS!
***************
*** 482,487 ****
--- 492,498 ----
*)
$spitshell >>Makefile <<'!NO!SUBS!'
miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL) opmini$(OBJ_EXT)
+ -@rm -f miniperl.xok
$(LDLIBPTH) $(CC) $(CLDFLAGS) -o miniperl \
miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) $(LLIBPERL) $(libs)
$(LDLIBPTH) ./miniperl -w -Ilib -MExporter -e '<?>' || $(MAKE) minitest
***************
*** 492,498 ****
$spitshell >>Makefile <<'!NO!SUBS!'
perl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT)
! $(SHRPENV) $(LDLIBPTH) $(CC) -o perl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
# Purify/Quantify Perls.
--- 503,510 ----
$spitshell >>Makefile <<'!NO!SUBS!'
perl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT)
! -@rm -f miniperl.xok
! $(SHRPENV) $(LDLIBPTH) $(CC) -o perl$(PERL_SUFFIX) $(PERL_PROFILING) $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
# Purify/Quantify Perls.
***************
*** 508,526 ****
# Third Degree Perl (Tru64 only)
perl.config.dashg:
! @echo "Checking optimize='-g'..."
! @grep "^optimize=" config.sh
! @grep -q "^optimize='-g'" config.sh || exit 1
perl.third.config: config.sh
@echo "To build perl.third you must Configure -Doptimize=-g -Uusemymalloc, checking..."
@$(MAKE) perl.config.dashg
! @echo "Checking usemymalloc='n'..."
! @grep "^usemymalloc=" config.sh
! @grep -q "^usemymalloc='n'" config.sh || exit 1
perl.third: /usr/bin/atom perl.third.config perl
atom -tool third -L. -all -gp -toolargs="-quiet -invalid -uninit heap+stack+partword+copy -min 0" perl
# Pixie Perls (Tru64 and IRIX only)
--- 520,539 ----
# Third Degree Perl (Tru64 only)
perl.config.dashg:
! @echo "Checking optimize='-g' in config.sh..."
! @grep "^optimize=" config.sh
! @grep "^optimize='-g'" config.sh >/dev/null || exit 1
perl.third.config: config.sh
@echo "To build perl.third you must Configure -Doptimize=-g -Uusemymalloc, checking..."
@$(MAKE) perl.config.dashg
! @echo "Checking usemymalloc='n' in config.sh..."
! @grep "^usemymalloc=" config.sh
! @grep "^usemymalloc='n'" config.sh >/dev/null || exit 1
perl.third: /usr/bin/atom perl.third.config perl
atom -tool third -L. -all -gp -toolargs="-quiet -invalid -uninit heap+stack+partword+copy -min 0" perl
+ @echo "Now you may run perl.third and then study perl.3log."
# Pixie Perls (Tru64 and IRIX only)
***************
*** 540,546 ****
--- 553,584 ----
else \
$(MAKE) perl.pixie.irix; \
fi
+ @echo "Now you may run perl.pixie and then run pixie."
+ # Gprof Perl
+
+ perl.config.dashpg:
+ @echo "Checking optimize='-pg' in config.sh..."
+ @grep "^optimize=" config.sh
+ @grep "^optimize='.*-pg.*'" config.sh >/dev/null || exit 1
+
+ perl.gprof.config: config.sh
+ @echo "To build perl.gprof you must Configure -Doptimize=-pg, checking..."
+ @$(MAKE) perl.config.dashpg
+
+ perl.gprof: /usr/bin/gprof perl.gprof.config
+ @-rm -f perl
+ $(MAKE) PERL_SUFFIX=.gprof PERL_PROFILING=-pg perl
+ @echo "Now you may run perl.gprof and then run gprof perl.gprof."
+
+ # Microperl. This is just a convenience thing if one happens to
+ # build also the full Perl and therefore the real big Makefile:
+ # usually one should manually explicitly issue the below command.
+
+ .PHONY: microperl
+ microperl:
+ $(MAKE) -f Makefile.micro
+
# This version, if specified in Configure, does ONLY those scripts which need
# set-id emulation. Suidperl must be setuid root. It contains the "taint"
# checks as well as the special code to validate that the script in question
***************
*** 564,570 ****
# We have to call our ./makedir because Ultrix 4.3 make can't handle the line
# test -d lib/auto || mkdir lib/auto
#
! preplibrary: miniperl lib/Config.pm
@sh ./makedir lib/auto
@echo " AutoSplitting perl library"
$(LDLIBPTH) ./miniperl -Ilib -e 'use AutoSplit; \
--- 602,609 ----
# We have to call our ./makedir because Ultrix 4.3 make can't handle the line
# test -d lib/auto || mkdir lib/auto
#
! .PHONY: preplibrary
! preplibrary: miniperl lib/Config.pm lib/lib.pm lib/re.pm
@sh ./makedir lib/auto
@echo " AutoSplitting perl library"
$(LDLIBPTH) ./miniperl -Ilib -e 'use AutoSplit; \
***************
*** 571,577 ****
autosplit_lib_modules(@ARGV)' lib/*.pm lib/*/*.pm
# Take care to avoid modifying lib/Config.pm without reason
! # (If trying to create a new port and having problems with the configpm script,
# try 'make minitest' and/or commenting out the tests at the end of configpm.)
lib/Config.pm: config.sh miniperl configpm lib/re.pm
$(LDLIBPTH) ./miniperl configpm configpm.tmp
--- 610,616 ----
autosplit_lib_modules(@ARGV)' lib/*.pm lib/*/*.pm
# Take care to avoid modifying lib/Config.pm without reason
! # (If trying to create a new port and having problems with the configpm script,
# try 'make minitest' and/or commenting out the tests at the end of configpm.)
lib/Config.pm: config.sh miniperl configpm lib/re.pm
$(LDLIBPTH) ./miniperl configpm configpm.tmp
***************
*** 603,612 ****
done
-@test -f vms/perlvms.pod && cd pod && $(LNS) ../vms/perlvms.pod perlvms.pod && cd .. && echo "pod/perlvms.pod" >> extra.pods
install-strip:
$(MAKE) STRIPFLAGS=-s install
! install:
$(MAKE) install.perl install.man STRIPFLAGS=$(STRIPFLAGS)
install-verbose:
--- 642,654 ----
done
-@test -f vms/perlvms.pod && cd pod && $(LNS) ../vms/perlvms.pod perlvms.pod && cd .. && echo "pod/perlvms.pod" >> extra.pods
+ .PHONY: install install-strip install-all install-verbose install-silent \
+ no-install install.perl install.man installman install.html installhtml
+
install-strip:
$(MAKE) STRIPFLAGS=-s install
! install install-all:
$(MAKE) install.perl install.man STRIPFLAGS=$(STRIPFLAGS)
install-verbose:
***************
*** 652,658 ****
# to run with precisely the same version of byacc as I use. You
# normally shouldn't remake perly.[ch].
! run_byacc: FORCE
$(BYACC) -d perly.y
-chmod 664 perly.c perly.h
sh $(shellflags) ./perly.fixer y.tab.c perly.c
--- 694,705 ----
# to run with precisely the same version of byacc as I use. You
# normally shouldn't remake perly.[ch].
! .PHONY: check_byacc run_byacc
!
! check_byacc:
! @$(BYACC) -V 2>&1 | grep 'version 1\.8\.2'
!
! run_byacc: FORCE check_byacc
$(BYACC) -d perly.y
-chmod 664 perly.c perly.h
sh $(shellflags) ./perly.fixer y.tab.c perly.c
***************
*** 660,665 ****
--- 707,713 ----
-e 's/y\.tab/perly/g' perly.c >perly.tmp && mv perly.tmp perly.c
sed -e '/^extern YYSTYPE yy/D' y.tab.h >yh.tmp && mv yh.tmp y.tab.h
cmp -s y.tab.h perly.h && rm -f y.tab.h || mv y.tab.h perly.h
+ perl -i perlyline.pl perly.c
chmod 664 vms/perly_c.vms vms/perly_h.vms
perl vms/vms_yfix.pl perly.c perly.h vms/perly_c.vms vms/perly_h.vms
***************
*** 733,738 ****
--- 781,788 ----
ext/ByteLoader/byterun.c ext/B/B/Asmdata.pm regnodes.h \
warnings.h lib/warnings.pm
+ .PHONY: regen_headers regen_pods regen_all
+
regen_headers: FORCE
-$(CHMOD_W) $(AUTOGEN_FILES)
-perl keywords.pl
***************
*** 761,774 ****
--- 811,832 ----
@$(LDLIBPTH) sh ext/util/make_ext static $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL)
d_dummy $(dynamic_ext): miniperl preplibrary $(DYNALOADER) FORCE
+ @-rm -f lib/re.pm
+ @cat ext/re/re.pm > lib/re.pm
@$(LDLIBPTH) sh ext/util/make_ext dynamic $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL)
s_dummy $(static_ext): miniperl preplibrary $(DYNALOADER) FORCE
+ @-rm -f lib/re.pm
+ @cat ext/re/re.pm > lib/re.pm
@$(LDLIBPTH) sh ext/util/make_ext static $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL)
n_dummy $(nonxs_ext): miniperl preplibrary $(DYNALOADER) FORCE
@$(LDLIBPTH) sh ext/util/make_ext nonxs $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL)
+ .PHONY: clean _tidy _mopup _cleaner1 _cleaner2 \
+ realclean _realcleaner clobber _clobber \
+ distclean veryclean _verycleaner
+
clean: _tidy _mopup
realclean: _realcleaner _mopup
***************
*** 775,780 ****
--- 833,839 ----
@echo "Note that make realclean does not delete config.sh or Policy.sh"
_clobber:
+ -@rm -f Cross/run-* Cross/to-* Cross/from-*
rm -f config.sh cppstdin Policy.sh
clobber: _realcleaner _mopup _clobber
***************
*** 795,801 ****
-rm -f perl.loadmap miniperl.loadmap perl.prelmap miniperl.prelmap
-rm -f perl.third lib*.so.perl.third perl.3log t/perl.third t/perl.3log
-rm -f perl.pixie lib*.so.perl.pixie lib*.so.Addrs
! -rm -f perl.Addrs perl.Counts t/perl.Addrs t/perl.Counts
rm -f perl suidperl miniperl $(LIBPERL) libperl.* microperl
# Do not 'make _tidy' directly.
--- 854,860 ----
-rm -f perl.loadmap miniperl.loadmap perl.prelmap miniperl.prelmap
-rm -f perl.third lib*.so.perl.third perl.3log t/perl.third t/perl.3log
-rm -f perl.pixie lib*.so.perl.pixie lib*.so.Addrs
! -rm -f perl.Addrs perl.Counts t/perl.Addrs t/perl.Counts *perl.xok
rm -f perl suidperl miniperl $(LIBPERL) libperl.* microperl
# Do not 'make _tidy' directly.
***************
*** 827,839 ****
rm -f h2ph.man pstruct
rm -rf .config
rm -f testcompile compilelog
! -rmdir lib/B lib/Data lib/Digest lib/Encode lib/MIME lib/IO/Socket lib/IO lib/Filter/Util lib/PerlIO lib/Sys lib/Thread lib/XS
! _realcleaner:
@$(LDLIBPTH) $(MAKE) _cleaner1 CLEAN=realclean
@$(LDLIBPTH) $(MAKE) _cleaner2
! _verycleaner:
@$(LDLIBPTH) $(MAKE) _cleaner1 CLEAN=veryclean
@$(LDLIBPTH) $(MAKE) _cleaner2
-rm -f *~ *.orig */*~ */*.orig */*/*~ */*/*.orig
--- 886,898 ----
rm -f h2ph.man pstruct
rm -rf .config
rm -f testcompile compilelog
! -rmdir lib/B lib/Data lib/Digest lib/Encode lib/IO/Socket lib/IO lib/Filter/Util lib/List lib/MIME lib/PerlIO lib/Scalar lib/Sys lib/Thread lib/XS
! _realcleaner:
@$(LDLIBPTH) $(MAKE) _cleaner1 CLEAN=realclean
@$(LDLIBPTH) $(MAKE) _cleaner2
! _verycleaner:
@$(LDLIBPTH) $(MAKE) _cleaner1 CLEAN=veryclean
@$(LDLIBPTH) $(MAKE) _cleaner2
-rm -f *~ *.orig */*~ */*.orig */*/*~ */*/*.orig
***************
*** 843,848 ****
--- 902,908 ----
# If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message
# for that spot.
+ .PHONY: lint
lint: $(c)
lint $(lintflags) $(defs) perly.c $(c) > perl.fuzz
***************
*** 859,864 ****
--- 919,925 ----
$(SHELL) config_h.SH
# When done, touch perlmain.c so that it doesn't get remade each time.
+ .PHONY: depend
depend: makedepend
sh ./makedepend MAKE=$(MAKE)
- test -s perlmain.c && touch perlmain.c
***************
*** 868,873 ****
--- 929,941 ----
makedepend: makedepend.SH config.sh
sh ./makedepend.SH
+ .PHONY: test check test_prep _test_prep \
+ test_tty test-tty _test_tty test_notty test-notty _test_notty \
+ utest ucheck test.utf8 check.utf8 \
+ test.third check.third utest.third ucheck.third test_notty.third \
+ test.deparse test_notty.deparse \
+ minitest
+
# Cannot delegate rebuilding of t/perl to make
# to allow interlaced test and minitest
***************
*** 878,895 ****
PERL=./perl $(MAKE) _test_prep
_test_tty:
! cd t && $(LDLIBPTH) $(PERL_DEBUG) $(PERL) TEST $(UTF8) </dev/tty
_test_notty:
! cd t && $(LDLIBPTH) $(PERL_DEBUG) PERL_SKIP_TTY_TEST=1 $(PERL) TEST $(UTF8)
# The second branch is for testing without a tty or controlling terminal,
# see t/op/stat.t
_test:
if (true </dev/tty) >/dev/null 2>&1; then \
! $(MAKE) _test_tty; \
else \
! $(MAKE) _test_notty; \
fi
@echo "Ran tests" > t/rantests
--- 946,963 ----
PERL=./perl $(MAKE) _test_prep
_test_tty:
! cd t && $(LDLIBPTH) $(PERL_DEBUG) $(PERL) TEST $(TEST_ARGS) </dev/tty
_test_notty:
! cd t && $(LDLIBPTH) $(PERL_DEBUG) PERL_SKIP_TTY_TEST=1 $(PERL) TEST $(TEST_ARGS)
# The second branch is for testing without a tty or controlling terminal,
# see t/op/stat.t
_test:
if (true </dev/tty) >/dev/null 2>&1; then \
! $(MAKE) TEST_ARGS=$(TEST_ARGS) _test_tty ; \
else \
! $(MAKE) TEST_ARGS=$(TEST_ARGS) _test_notty ; \
fi
@echo "Ran tests" > t/rantests
***************
*** 902,909 ****
test_notty: test_prep
PERL=./perl $(MAKE) _test_notty
! utest ucheck: test_prep
! PERL=./perl UTF8=-utf8 $(MAKE) _test
test-prep: test_prep
--- 970,977 ----
test_notty: test_prep
PERL=./perl $(MAKE) _test_notty
! utest ucheck test.utf8 check.utf8: test_prep
! PERL=./perl TEST_ARGS=-utf8 $(MAKE) _test
test-prep: test_prep
***************
*** 920,930 ****
PERL=./perl.third PERL_DEBUG=PERL_3LOG=1 $(MAKE) _test
utest.third ucheck.third: test_prep.third perl.third
! PERL=./perl.third PERL_DEBUG=PERL_3LOG=1UTF=-utf8 $(MAKE) _test
test_notty.third: test_prep.third perl.third
PERL=./perl.third $(MAKE) PERL_DEBUG=PERL_3LOG=1 _test_notty
# Can't depend on lib/Config.pm because that might be where miniperl
# is crashing.
minitest: miniperl lib/re.pm
--- 988,1006 ----
PERL=./perl.third PERL_DEBUG=PERL_3LOG=1 $(MAKE) _test
utest.third ucheck.third: test_prep.third perl.third
! PERL=./perl.third PERL_DEBUG=PERL_3LOG=1 TEST_ARGS=-utf8 $(MAKE) _test
test_notty.third: test_prep.third perl.third
PERL=./perl.third $(MAKE) PERL_DEBUG=PERL_3LOG=1 _test_notty
+ # Targets for Deparse testing.
+
+ test.deparse: test_prep
+ PERL=./perl TEST_ARGS=-deparse $(MAKE) _test
+
+ test_notty.deparse: test_prep
+ PERL=./perl TEST_ARGS=-deparse $(MAKE) _test_notty
+
# Can't depend on lib/Config.pm because that might be where miniperl
# is crashing.
minitest: miniperl lib/re.pm
***************
*** 931,942 ****
@echo "You may see some irrelevant test failures if you have been unable"
@echo "to build lib/Config.pm."
- cd t && (rm -f perl$(EXE_EXT); $(LNS) ../miniperl$(EXE_EXT) perl$(EXE_EXT)) \
! && $(LDLIBPTH) ./perl TEST base/*.t comp/*.t cmd/*.t run/*.t io/*.t op/*.t pragma/*.t </dev/tty
# Handy way to run perlbug -ok without having to install and run the
# installed perlbug. We don't re-run the tests here - we trust the user.
# Please *don't* use this unless all tests pass.
# If you want to report test failures, use "make nok" instead.
ok: utilities
$(LDLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)'
--- 1007,1021 ----
@echo "You may see some irrelevant test failures if you have been unable"
@echo "to build lib/Config.pm."
- cd t && (rm -f perl$(EXE_EXT); $(LNS) ../miniperl$(EXE_EXT) perl$(EXE_EXT)) \
! && $(LDLIBPTH) ./perl TEST base/*.t comp/*.t cmd/*.t run/*.t io/*.t op/*.t </dev/tty
# Handy way to run perlbug -ok without having to install and run the
# installed perlbug. We don't re-run the tests here - we trust the user.
# Please *don't* use this unless all tests pass.
# If you want to report test failures, use "make nok" instead.
+
+ .PHONY: ok okfile oknack okfilenack nok nokfile noknack nokfilenack
+
ok: utilities
$(LDLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)'
***************
*** 961,966 ****
--- 1040,1047 ----
nokfilenack: utilities
$(LDLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)' -F perl.nok -A
+ .PHONY: clist hlist shlist pllist
+
clist: $(c)
echo $(c) | tr ' ' $(TRNL) >.clist
***************
*** 976,988 ****
--- 1057,1073 ----
Makefile: Makefile.SH ./config.sh
$(SHELL) Makefile.SH
+ .PHONY: distcheck
distcheck: FORCE
perl '-MExtUtils::Manifest=&fullcheck' -e 'fullcheck()'
+ .PHONY: elc
elc: emacs/cperl-mode.elc
emacs/cperl-mode.elc: emacs/cperl-mode.el
-cd emacs; emacs -batch -q -no-site-file -f batch-byte-compile cperl-mode.el
+
+ .PHONY: etags ctags tags
etags: TAGS
diff -c 'perl-5.7.1/Makefile.micro' 'perl-5.7.2/Makefile.micro'
Index: ./Makefile.micro
*** ./Makefile.micro Tue Mar 6 04:04:16 2001
--- ./Makefile.micro Mon Jul 9 17:09:38 2001
***************
*** 1,7 ****
CC = cc
LD = $(CC)
DEFINES = -DPERL_CORE -DPERL_MICRO
! CFLAGS = $(DEFINES)
LIBS = -lm
_O = .o
--- 1,8 ----
CC = cc
LD = $(CC)
DEFINES = -DPERL_CORE -DPERL_MICRO
! OPTIMIZE =
! CFLAGS = $(DEFINES) $(OPTIMIZE)
LIBS = -lm
_O = .o
***************
*** 11,19 ****
uglobals$(_O) ugv$(_O) uhv$(_O) \
umg$(_O) uperlmain$(_O) uop$(_O) \
uperl$(_O) uperlio$(_O) uperly$(_O) upp$(_O) \
! upp_ctl$(_O) upp_hot$(_O) upp_sys$(_O) \
uregcomp$(_O) uregexec$(_O) urun$(_O) \
uscope$(_O) usv$(_O) utaint$(_O) utoke$(_O) \
uuniversal$(_O) uutf8$(_O) uutil$(_O) uperlapi$(_O)
microperl: $(O)
--- 12,21 ----
uglobals$(_O) ugv$(_O) uhv$(_O) \
umg$(_O) uperlmain$(_O) uop$(_O) \
uperl$(_O) uperlio$(_O) uperly$(_O) upp$(_O) \
! upp_ctl$(_O) upp_hot$(_O) upp_sys$(_O) upp_pack$(_O) \
uregcomp$(_O) uregexec$(_O) urun$(_O) \
uscope$(_O) usv$(_O) utaint$(_O) utoke$(_O) \
+ unumeric$(_O) ulocale$(_O) \
uuniversal$(_O) uutf8$(_O) uutil$(_O) uperlapi$(_O)
microperl: $(O)
***************
*** 90,95 ****
--- 92,100 ----
upp_sys$(_O): $(HE) pp_sys.c
$(CC) -c -o $@ $(CFLAGS) pp_sys.c
+ upp_pack$(_O): $(HE) pp_pack.c
+ $(CC) -c -o $@ $(CFLAGS) pp_pack.c
+
uregcomp$(_O): $(HE) regcomp.c regcomp.h regnodes.h INTERN.h
$(CC) -c -o $@ $(CFLAGS) regcomp.c
***************
*** 110,115 ****
--- 115,126 ----
utoke$(_O): $(HE) toke.c keywords.h
$(CC) -c -o $@ $(CFLAGS) toke.c
+
+ ulocale$(_O): $(HE) locale.c
+ $(CC) -c -o $@ $(CFLAGS) locale.c
+
+ unumeric$(_O): $(HE) numeric.c
+ $(CC) -c -o $@ $(CFLAGS) numeric.c
uuniversal$(_O): $(HE) universal.c objXSUB.h XSUB.h
$(CC) -c -o $@ $(CFLAGS) universal.c
diff -c /dev/null 'perl-5.7.2/NetWare/CLIBsdio.h'
Index: ./NetWare/CLIBsdio.h
*** ./NetWare/CLIBsdio.h Thu Jan 1 02:00:00 1970
--- ./NetWare/CLIBsdio.h Mon Jul 9 17:09:38 2001
***************
*** 0 ****
--- 1,180 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : CLIBsdio.h
+ * DESCRIPTION : Forces the use of clib stdio.h calls over static watcom calls
+ * for C/C++ applications that statically link watcom libraries.
+ *
+ * This file must be included each time that stdio.h is included.
+ * In the case of the Perl project, just include stdio.h and
+ * the make should take care of the rest.
+ * Author : HYAK
+ * Date : January 2001.
+ *
+ */
+
+
+
+ #ifndef _CLIBSDIO_H_
+ #define _CLIBSDIO_H_
+
+
+ #ifdef DEFINE_GPF
+ #define _GPFINIT =0
+ #define _GPFEXT
+ #else
+ #define _GPFINIT
+ #define _GPFEXT extern
+ #endif
+
+ #ifdef __cplusplus
+ extern "C"
+ {
+ #endif
+
+ _GPFEXT void* gpf___get_stdin _GPFINIT;
+ _GPFEXT void* gpf___get_stdout _GPFINIT;
+ _GPFEXT void* gpf___get_stderr _GPFINIT;
+
+ _GPFEXT void* gpf_clearerr _GPFINIT;
+ _GPFEXT void* gpf_fclose _GPFINIT;
+ _GPFEXT void* gpf_feof _GPFINIT;
+ _GPFEXT void* gpf_ferror _GPFINIT;
+ _GPFEXT void* gpf_fflush _GPFINIT;
+ _GPFEXT void* gpf_fgetc _GPFINIT;
+ _GPFEXT void* gpf_fgetpos _GPFINIT;
+ _GPFEXT void* gpf_fgets _GPFINIT;
+ _GPFEXT void* gpf_fopen _GPFINIT;
+ _GPFEXT void* gpf_fprintf _GPFINIT;
+ _GPFEXT void* gpf_fputc _GPFINIT;
+ _GPFEXT void* gpf_fputs _GPFINIT;
+ _GPFEXT void* gpf_fread _GPFINIT;
+ _GPFEXT void* gpf_freopen _GPFINIT;
+ _GPFEXT void* gpf_fscanf _GPFINIT;
+ _GPFEXT void* gpf_fseek _GPFINIT;
+ _GPFEXT void* gpf_fsetpos _GPFINIT;
+ _GPFEXT void* gpf_ftell _GPFINIT;
+ _GPFEXT void* gpf_fwrite _GPFINIT;
+ _GPFEXT void* gpf_getc _GPFINIT;
+ _GPFEXT void* gpf_getchar _GPFINIT;
+ _GPFEXT void* gpf_gets _GPFINIT;
+ _GPFEXT void* gpf_perror _GPFINIT;
+ _GPFEXT void* gpf_printf _GPFINIT;
+ _GPFEXT void* gpf_putc _GPFINIT;
+ _GPFEXT void* gpf_putchar _GPFINIT;
+ _GPFEXT void* gpf_puts _GPFINIT;
+ _GPFEXT void* gpf_rename _GPFINIT;
+ _GPFEXT void* gpf_rewind _GPFINIT;
+ _GPFEXT void* gpf_scanf _GPFINIT;
+ _GPFEXT void* gpf_setbuf _GPFINIT;
+ _GPFEXT void* gpf_setvbuf _GPFINIT;
+ _GPFEXT void* gpf_sprintf _GPFINIT;
+ _GPFEXT void* gpf_sscanf _GPFINIT;
+ _GPFEXT void* gpf_tmpfile _GPFINIT;
+ _GPFEXT void* gpf_tmpnam _GPFINIT;
+ _GPFEXT void* gpf_ungetc _GPFINIT;
+ _GPFEXT void* gpf_vfprintf _GPFINIT;
+ _GPFEXT void* gpf_vfscanf _GPFINIT;
+ _GPFEXT void* gpf_vprintf _GPFINIT;
+ _GPFEXT void* gpf_vscanf _GPFINIT;
+ _GPFEXT void* gpf_vsprintf _GPFINIT;
+ _GPFEXT void* gpf_vsscanf _GPFINIT;
+
+ _GPFEXT void* gpf_fdopen _GPFINIT;
+ _GPFEXT void* gpf_fileno _GPFINIT;
+
+ _GPFEXT void* gpf_cgets _GPFINIT;
+ _GPFEXT void* gpf_cprintf _GPFINIT;
+ _GPFEXT void* gpf_cputs _GPFINIT;
+ _GPFEXT void* gpf_cscanf _GPFINIT;
+ _GPFEXT void* gpf_fcloseall _GPFINIT;
+ _GPFEXT void* gpf_fgetchar _GPFINIT;
+ _GPFEXT void* gpf_flushall _GPFINIT;
+ _GPFEXT void* gpf_fputchar _GPFINIT;
+ _GPFEXT void* gpf_getch _GPFINIT;
+ _GPFEXT void* gpf_getche _GPFINIT;
+ _GPFEXT void* gpf_putch _GPFINIT;
+ _GPFEXT void* gpf_ungetch _GPFINIT;
+ _GPFEXT void* gpf_vcprintf _GPFINIT;
+ _GPFEXT void* gpf_vcscanf _GPFINIT;
+
+ #ifdef __cplusplus
+ }
+ #endif
+
+ #pragma aux __get_stdin = "call gpf___get_stdin";
+ #pragma aux __get_stdout = "call gpf___get_stdout";
+ #pragma aux __get_stderr = "call gpf___get_stderr";
+
+ #pragma aux clearerr = "call gpf_clearerr";
+ #pragma aux fclose = "call gpf_fclose";
+ #pragma aux feof = "call gpf_feof";
+ #pragma aux ferror = "call gpf_ferror";
+ #pragma aux fflush = "call gpf_fflush";
+ #pragma aux fgetc = "call gpf_fgetc";
+ #pragma aux fgetpos = "call gpf_fgetpos";
+ #pragma aux fgets = "call gpf_fgets";
+ #pragma aux fopen = "call gpf_fopen";
+ #pragma aux fprintf = "call gpf_fprintf";
+ #pragma aux fputc = "call gpf_fputc";
+ #pragma aux fputs = "call gpf_fputs";
+ #pragma aux fread = "call gpf_fread";
+ #pragma aux freopen = "call gpf_freopen";
+ #pragma aux fscanf = "call gpf_fscanf";
+ #pragma aux fseek = "call gpf_fseek";
+ #pragma aux fsetpos = "call gpf_fsetpos";
+ #pragma aux ftell = "call gpf_ftell";
+ #pragma aux fwrite = "call gpf_fwrite";
+ #pragma aux getc = "call gpf_getc";
+ #pragma aux getchar = "call gpf_getchar";
+ #pragma aux gets = "call gpf_gets";
+ #pragma aux perror = "call gpf_perror";
+ #pragma aux printf = "call gpf_printf";
+ #pragma aux putc = "call gpf_putc";
+ #pragma aux putchar = "call gpf_putchar";
+ #pragma aux puts = "call gpf_puts";
+ #pragma aux rename = "call gpf_rename";
+ #pragma aux rewind = "call gpf_rewind";
+ #pragma aux scanf = "call gpf_scanf";
+ #pragma aux setbuf = "call gpf_setbuf";
+ #pragma aux setvbuf = "call gpf_setvbuf";
+ #pragma aux sprintf = "call gpf_sprintf";
+ #pragma aux sscanf = "call gpf_sscanf";
+ #pragma aux tmpfile = "call gpf_tmpfile";
+ #pragma aux tmpnam = "call gpf_tmpnam";
+ #pragma aux ungetc = "call gpf_ungetc";
+ #pragma aux vfprintf = "call gpf_vfprintf";
+ #pragma aux vfscanf = "call gpf_vfscanf";
+ #pragma aux vprintf = "call gpf_vprintf";
+ #pragma aux vscanf = "call gpf_vscanf";
+ #pragma aux vsprintf = "call gpf_vsprintf";
+ #pragma aux vsscanf = "call gpf_vsscanf";
+
+ #pragma aux fdopen = "call gpf_fdopen";
+ #pragma aux fileno = "call gpf_fileno";
+
+ #pragma aux cgets = "call gpf_cgets";
+ #pragma aux cprintf = "call gpf_cprintf";
+ #pragma aux cputs = "call gpf_cputs";
+ #pragma aux cscanf = "call gpf_cscanf";
+ #pragma aux fcloseall = "call gpf_fcloseall";
+ #pragma aux fgetchar = "call gpf_fgetchar";
+ #pragma aux flushall = "call gpf_flushall";
+ #pragma aux fputchar = "call gpf_fputchar";
+ #pragma aux getch = "call gpf_getch";
+ #pragma aux getche = "call gpf_getche";
+ #pragma aux putch = "call gpf_putch";
+ #pragma aux ungetch = "call gpf_ungetch";
+ #pragma aux vcprintf = "call gpf_vcprintf";
+ #pragma aux vcscanf = "call gpf_vcscanf";
+
+
+ #endif // _CLIBSDIO_H_
+
diff -c /dev/null 'perl-5.7.2/NetWare/CLIBstr.h'
Index: ./NetWare/CLIBstr.h
*** ./NetWare/CLIBstr.h Thu Jan 1 02:00:00 1970
--- ./NetWare/CLIBstr.h Mon Jul 9 17:09:39 2001
***************
*** 0 ****
--- 1,120 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : CLIBstr.h
+ * DESCRIPTION : Forces the use of clib string.h calls over static watcom calls
+ * for C/C++ applications that statically link watcom libraries.
+ *
+ * This file must be included each time that string.h is included.
+ * In the case of the Perl project, just include string.h and
+ * the make should take care of the rest.
+ * Author : HYAK
+ * Date : January 2001.
+ *
+ */
+
+
+
+ #ifndef _CLIBSTR_H_
+ #define _CLIBSTR_H_
+
+
+ #ifdef DEFINE_GPF
+ #define _GPFINIT =0
+ #define _GPFEXT
+ #else
+ #define _GPFINIT
+ #define _GPFEXT extern
+ #endif
+
+ #ifdef __cplusplus
+ extern "C"
+ {
+ #endif
+
+ _GPFEXT void* gpf_memchr _GPFINIT;
+ _GPFEXT void* gpf_memcmp _GPFINIT;
+ _GPFEXT void* gpf_memcpy _GPFINIT;
+ _GPFEXT void* gpf_memmove _GPFINIT;
+ _GPFEXT void* gpf_memset _GPFINIT;
+ _GPFEXT void* gpf_strchr _GPFINIT;
+ _GPFEXT void* gpf_strcmp _GPFINIT;
+ _GPFEXT void* gpf_strcoll _GPFINIT;
+ _GPFEXT void* gpf_strcspn _GPFINIT;
+ _GPFEXT void* gpf_strerror _GPFINIT;
+ _GPFEXT void* gpf_strtok_r _GPFINIT;
+ _GPFEXT void* gpf_strpbrk _GPFINIT;
+ _GPFEXT void* gpf_strrchr _GPFINIT;
+ _GPFEXT void* gpf_strspn _GPFINIT;
+ _GPFEXT void* gpf_strstr _GPFINIT;
+ _GPFEXT void* gpf_strtok _GPFINIT;
+ _GPFEXT void* gpf_strxfrm _GPFINIT;
+ _GPFEXT void* gpf_memicmp _GPFINIT;
+ _GPFEXT void* gpf_strcmpi _GPFINIT;
+ _GPFEXT void* gpf_stricmp _GPFINIT;
+ _GPFEXT void* gpf_strrev _GPFINIT;
+ _GPFEXT void* gpf_strupr _GPFINIT;
+
+ _GPFEXT void* gpf_strcpy _GPFINIT;
+ _GPFEXT void* gpf_strcat _GPFINIT;
+ _GPFEXT void* gpf_strlen _GPFINIT;
+ _GPFEXT void* gpf_strncpy _GPFINIT;
+ _GPFEXT void* gpf_strncat _GPFINIT;
+ _GPFEXT void* gpf_strncmp _GPFINIT;
+ _GPFEXT void* gpf_strnicmp _GPFINIT;
+ _GPFEXT void* gpf_strdup _GPFINIT;
+ _GPFEXT void* gpf_strlist _GPFINIT;
+ _GPFEXT void* gpf_strlwr _GPFINIT;
+ _GPFEXT void* gpf_strnset _GPFINIT;
+ _GPFEXT void* gpf_strset _GPFINIT;
+
+ #ifdef __cplusplus
+ }
+ #endif
+
+ #pragma aux memchr = "call gpf_memchr";
+ #pragma aux memcmp = "call gpf_memcmp";
+ #pragma aux memcpy = "call gpf_memcpy";
+ #pragma aux memmove = "call gpf_memmove";
+ #pragma aux memset = "call gpf_memset";
+ #pragma aux strchr = "call gpf_strchr";
+ #pragma aux strcmp = "call gpf_strcmp";
+ #pragma aux strcoll = "call gpf_strcoll";
+ #pragma aux strcspn = "call gpf_strcspn";
+ #pragma aux strerror = "call gpf_strerror";
+ #pragma aux strtok_r = "call gpf_strtok_r";
+ #pragma aux strpbrk = "call gpf_strpbrk";
+ #pragma aux strrchr = "call gpf_strrchr";
+ #pragma aux strspn = "call gpf_strspn";
+ #pragma aux strstr = "call gpf_strstr";
+ #pragma aux strtok = "call gpf_strtok";
+ #pragma aux strxfrm = "call gpf_strxfrm";
+ #pragma aux memicmp = "call gpf_memicmp";
+ #pragma aux strcmpi = "call gpf_strcmpi";
+ #pragma aux stricmp = "call gpf_stricmp";
+ #pragma aux strrev = "call gpf_strrev";
+ #pragma aux strupr = "call gpf_strupr";
+
+ #pragma aux strcpy = "call gpf_strcpy";
+ #pragma aux strcat = "call gpf_strcat";
+ #pragma aux strlen = "call gpf_strlen";
+ #pragma aux strncpy = "call gpf_strncpy";
+ #pragma aux strncat = "call gpf_strncat";
+ #pragma aux strncmp = "call gpf_strncmp";
+ #pragma aux strnicmp = "call gpf_strnicmp";
+ #pragma aux strdup = "call gpf_strdup";
+ #pragma aux strlist = "call gpf_strlist";
+ #pragma aux strlwr = "call gpf_strlwr";
+ #pragma aux strnset = "call gpf_strnset";
+ #pragma aux strset = "call gpf_strset";
+
+
+ #endif // _CLIBSTR_H_
+
diff -c /dev/null 'perl-5.7.2/NetWare/CLIBstuf.c'
Index: ./NetWare/CLIBstuf.c
*** ./NetWare/CLIBstuf.c Thu Jan 1 02:00:00 1970
--- ./NetWare/CLIBstuf.c Mon Jul 9 17:09:39 2001
***************
*** 0 ****
--- 1,151 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : CLIBstuf.c
+ * DESCRIPTION : The purpose of clibstuf is to make sure that Perl, cgi2perl and
+ * all the perl extension nlm's (*.NLP) use the Novell Netware CLIB versions
+ * of standard functions. This code loads up a whole bunch of function pointers
+ * to point at the standard CLIB functions.
+ * Author : HYAK
+ * Date : January 2001.
+ *
+ */
+
+
+
+ #define DEFINE_GPF
+ #include "string.h" // Our version of string.h will include clibstr.h
+ #include "stdio.h" // Our version of stdio.h will include clibsdio.h
+ #include "clibstuf.h"
+
+ #include <nwthread.h>
+ #include <nwadv.h>
+ #include <nwconio.h>
+
+
+
+ void ImportFromCLIB (unsigned int nlmHandle, void** psymbol, char* symbolName)
+ {
+ *psymbol = ImportSymbol(nlmHandle, symbolName);
+ if (*psymbol == NULL)
+ {
+ ConsolePrintf("Symbol %s not found, unable to continue\n", symbolName);
+ exit(1);
+ }
+ }
+
+
+ void fnInitGpfGlobals(void)
+ {
+ unsigned int nlmHandle = GetNLMHandle();
+
+ ImportFromCLIB(nlmHandle, &gpf___get_stdin, "__get_stdin");
+ ImportFromCLIB(nlmHandle, &gpf___get_stdout, "__get_stdout");
+ ImportFromCLIB(nlmHandle, &gpf___get_stderr, "__get_stderr");
+ ImportFromCLIB(nlmHandle, &gpf_clearerr, "clearerr");
+ ImportFromCLIB(nlmHandle, &gpf_fclose, "fclose");
+ ImportFromCLIB(nlmHandle, &gpf_feof, "feof");
+ ImportFromCLIB(nlmHandle, &gpf_ferror, "ferror");
+ ImportFromCLIB(nlmHandle, &gpf_fflush, "fflush");
+ ImportFromCLIB(nlmHandle, &gpf_fgetc, "fgetc");
+ ImportFromCLIB(nlmHandle, &gpf_fgetpos, "fgetpos");
+ ImportFromCLIB(nlmHandle, &gpf_fgets, "fgets");
+ ImportFromCLIB(nlmHandle, &gpf_fopen, "fopen");
+ ImportFromCLIB(nlmHandle, &gpf_fputc, "fputc");
+ ImportFromCLIB(nlmHandle, &gpf_fputs, "fputs");
+ ImportFromCLIB(nlmHandle, &gpf_fread, "fread");
+ ImportFromCLIB(nlmHandle, &gpf_freopen, "freopen");
+ ImportFromCLIB(nlmHandle, &gpf_fscanf, "fscanf");
+ ImportFromCLIB(nlmHandle, &gpf_fseek, "fseek");
+ ImportFromCLIB(nlmHandle, &gpf_fsetpos, "fsetpos");
+ ImportFromCLIB(nlmHandle, &gpf_ftell, "ftell");
+ ImportFromCLIB(nlmHandle, &gpf_fwrite, "fwrite");
+ ImportFromCLIB(nlmHandle, &gpf_getc, "getc");
+ ImportFromCLIB(nlmHandle, &gpf_getchar, "getchar");
+ ImportFromCLIB(nlmHandle, &gpf_gets, "gets");
+ ImportFromCLIB(nlmHandle, &gpf_perror, "perror");
+ ImportFromCLIB(nlmHandle, &gpf_putc, "putc");
+ ImportFromCLIB(nlmHandle, &gpf_putchar, "putchar");
+ ImportFromCLIB(nlmHandle, &gpf_puts, "puts");
+ ImportFromCLIB(nlmHandle, &gpf_rename, "rename");
+ ImportFromCLIB(nlmHandle, &gpf_rewind, "rewind");
+ ImportFromCLIB(nlmHandle, &gpf_scanf, "scanf");
+ ImportFromCLIB(nlmHandle, &gpf_setbuf, "setbuf");
+ ImportFromCLIB(nlmHandle, &gpf_setvbuf, "setvbuf");
+ ImportFromCLIB(nlmHandle, &gpf_sscanf, "sscanf");
+ ImportFromCLIB(nlmHandle, &gpf_tmpfile, "tmpfile");
+ ImportFromCLIB(nlmHandle, &gpf_tmpnam, "tmpnam");
+ ImportFromCLIB(nlmHandle, &gpf_ungetc, "ungetc");
+ ImportFromCLIB(nlmHandle, &gpf_vfscanf, "vfscanf");
+ ImportFromCLIB(nlmHandle, &gpf_vscanf, "vscanf");
+ ImportFromCLIB(nlmHandle, &gpf_vsscanf, "vsscanf");
+ ImportFromCLIB(nlmHandle, &gpf_fdopen, "fdopen");
+ ImportFromCLIB(nlmHandle, &gpf_fileno, "fileno");
+ ImportFromCLIB(nlmHandle, &gpf_cgets, "cgets");
+ ImportFromCLIB(nlmHandle, &gpf_cprintf, "cprintf");
+ ImportFromCLIB(nlmHandle, &gpf_cputs, "cputs");
+ ImportFromCLIB(nlmHandle, &gpf_cscanf, "cscanf");
+ ImportFromCLIB(nlmHandle, &gpf_fcloseall, "fcloseall");
+ ImportFromCLIB(nlmHandle, &gpf_fgetchar, "fgetchar");
+ ImportFromCLIB(nlmHandle, &gpf_flushall, "flushall");
+ ImportFromCLIB(nlmHandle, &gpf_fputchar, "fputchar");
+ ImportFromCLIB(nlmHandle, &gpf_getch, "getch");
+ ImportFromCLIB(nlmHandle, &gpf_getche, "getche");
+ ImportFromCLIB(nlmHandle, &gpf_putch, "putch");
+ ImportFromCLIB(nlmHandle, &gpf_ungetch, "ungetch");
+ ImportFromCLIB(nlmHandle, &gpf_vcprintf, "vcprintf");
+ ImportFromCLIB(nlmHandle, &gpf_vcscanf, "vcscanf");
+
+ ImportFromCLIB(nlmHandle, &gpf_memchr, "memchr");
+ ImportFromCLIB(nlmHandle, &gpf_memcmp, "memcmp");
+ ImportFromCLIB(nlmHandle, &gpf_memcpy, "memcpy");
+ ImportFromCLIB(nlmHandle, &gpf_memmove, "memmove");
+ ImportFromCLIB(nlmHandle, &gpf_memset, "memset");
+ ImportFromCLIB(nlmHandle, &gpf_memicmp, "memicmp");
+
+ ImportFromCLIB(nlmHandle, &gpf_strerror, "strerror");
+ ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r");
+
+ ImportFromCLIB(nlmHandle, &gpf_strcpy, "strcpy");
+ ImportFromCLIB(nlmHandle, &gpf_strcat, "strcat");
+ ImportFromCLIB(nlmHandle, &gpf_strchr, "strchr");
+ ImportFromCLIB(nlmHandle, &gpf_strstr, "strstr");
+ ImportFromCLIB(nlmHandle, &gpf_strcoll, "strcoll");
+ ImportFromCLIB(nlmHandle, &gpf_strcspn, "strcspn");
+ ImportFromCLIB(nlmHandle, &gpf_strpbrk, "strpbrk");
+ ImportFromCLIB(nlmHandle, &gpf_strrchr, "strrchr");
+ ImportFromCLIB(nlmHandle, &gpf_strrev, "strrev");
+ ImportFromCLIB(nlmHandle, &gpf_strspn, "strspn");
+ ImportFromCLIB(nlmHandle, &gpf_strupr, "strupr");
+ ImportFromCLIB(nlmHandle, &gpf_strxfrm, "strxfrm");
+ ImportFromCLIB(nlmHandle, &gpf_strcmp, "strcmp");
+ ImportFromCLIB(nlmHandle, &gpf_stricmp, "stricmp");
+ ImportFromCLIB(nlmHandle, &gpf_strtok, "strtok");
+ ImportFromCLIB(nlmHandle, &gpf_strlen, "strlen");
+ ImportFromCLIB(nlmHandle, &gpf_strncpy, "strncpy");
+ ImportFromCLIB(nlmHandle, &gpf_strncat, "strncat");
+ ImportFromCLIB(nlmHandle, &gpf_strncmp, "strncmp");
+ ImportFromCLIB(nlmHandle, &gpf_strcmpi, "strcmpi");
+ ImportFromCLIB(nlmHandle, &gpf_strnicmp, "strnicmp");
+ ImportFromCLIB(nlmHandle, &gpf_strdup, "strdup");
+ ImportFromCLIB(nlmHandle, &gpf_strlist, "strlist");
+ ImportFromCLIB(nlmHandle, &gpf_strlwr, "strlwr");
+ ImportFromCLIB(nlmHandle, &gpf_strnset, "strnset");
+ ImportFromCLIB(nlmHandle, &gpf_strset, "strset");
+ ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r");
+ ImportFromCLIB(nlmHandle, &gpf_printf, "printf");
+ ImportFromCLIB(nlmHandle, &gpf_fprintf, "fprintf");
+ ImportFromCLIB(nlmHandle, &gpf_sprintf, "sprintf");
+ ImportFromCLIB(nlmHandle, &gpf_vprintf, "vprintf");
+ ImportFromCLIB(nlmHandle, &gpf_vfprintf, "vfprintf");
+ ImportFromCLIB(nlmHandle, &gpf_vsprintf, "vsprintf");
+
+ }
+
diff -c /dev/null 'perl-5.7.2/NetWare/CLIBstuf.h'
Index: ./NetWare/CLIBstuf.h
*** ./NetWare/CLIBstuf.h Thu Jan 1 02:00:00 1970
--- ./NetWare/CLIBstuf.h Mon Jul 9 17:09:39 2001
***************
*** 0 ****
--- 1,40 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : CLIBstuf.h
+ * DESCRIPTION : The purpose of clibstuf is to make sure that Perl, cgi2perl and
+ * all the perl extension nlm's (*.NLP) use the Novell Netware CLIB versions
+ * of standard functions. This code loads up a whole bunch of function pointers
+ * to point at the standard CLIB functions.
+ * Author : HYAK
+ * Date : January 2001.
+ *
+ */
+
+
+
+ #ifndef __CLIBstuf_H__
+ #define __CLIBstuf_H__
+
+
+ #ifdef __cplusplus
+ extern "C"
+ {
+ #endif
+
+ void fnInitGpfGlobals(void);
+
+ #ifdef __cplusplus
+ }
+ #endif
+
+
+ #endif // __CLIBstuf_H__
+
diff -c /dev/null 'perl-5.7.2/NetWare/Main.c'
Index: ./NetWare/Main.c
*** ./NetWare/Main.c Thu Jan 1 02:00:00 1970
--- ./NetWare/Main.c Mon Jul 9 17:09:39 2001
***************
*** 0 ****
--- 1,182 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : Main.c
+ * DESCRIPTION : The purpose of clibstuf is to make sure that Perl, cgi2perl and
+ * all the perl extension nlm's (*.NLP) use the Novell Netware CLIB versions
+ * of standard functions. This code loads up a whole bunch of function pointers
+ * to point at the standard CLIB functions.
+ * Author : HYAK
+ * Date : January 2001.
+ *
+ */
+
+
+
+ #define DEFINE_GPF
+
+ #include <nwthread.h>
+ #include <nwadv.h>
+ #include <nwconio.h>
+
+ #include "string.h" // Our version of string.h will include clibstr.h
+ #include "stdio.h" // Our version of stdio.h will include clibsdio.h
+ #include "clibstuf.h"
+ #include "clibstuf.h"
+
+ #ifdef MPK_ON
+ #include <mpktypes.h>
+ #include <mpkapis.h>
+ #endif //MPK_ON
+
+
+
+ /*============================================================================================
+
+ Function : main
+
+ Description : This is called as the first step in an extension.
+
+ Parameters : None
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void main(void)
+ {
+ fnInitGpfGlobals(); // For importing the CLIB calls in place of the Watcom calls
+ SynchronizeStart(); // Don't allow anything else to happen until all the symbols are imported
+ #ifdef MPK_ON
+ ExitThread(TSR_THREAD, 0);
+ #else
+ ExitThread(TSR_THREAD, 0);
+ #endif
+ }
+
+
+ void ImportFromCLIB (unsigned int nlmHandle, void** psymbol, char* symbolName)
+ {
+ *psymbol = ImportSymbol(nlmHandle, symbolName);
+ if (*psymbol == NULL)
+ {
+ ConsolePrintf("Symbol %s not found, unable to continue\n", symbolName);
+ exit(1);
+ }
+ }
+
+
+ void fnInitGpfGlobals(void)
+ {
+ unsigned int nlmHandle = GetNLMHandle();
+
+ ImportFromCLIB(nlmHandle, &gpf___get_stdin, "__get_stdin");
+ ImportFromCLIB(nlmHandle, &gpf___get_stdout, "__get_stdout");
+ ImportFromCLIB(nlmHandle, &gpf___get_stderr, "__get_stderr");
+ ImportFromCLIB(nlmHandle, &gpf_clearerr, "clearerr");
+ ImportFromCLIB(nlmHandle, &gpf_fclose, "fclose");
+ ImportFromCLIB(nlmHandle, &gpf_feof, "feof");
+ ImportFromCLIB(nlmHandle, &gpf_ferror, "ferror");
+ ImportFromCLIB(nlmHandle, &gpf_fflush, "fflush");
+ ImportFromCLIB(nlmHandle, &gpf_fgetc, "fgetc");
+ ImportFromCLIB(nlmHandle, &gpf_fgetpos, "fgetpos");
+ ImportFromCLIB(nlmHandle, &gpf_fgets, "fgets");
+ ImportFromCLIB(nlmHandle, &gpf_fopen, "fopen");
+ ImportFromCLIB(nlmHandle, &gpf_fputc, "fputc");
+ ImportFromCLIB(nlmHandle, &gpf_fputs, "fputs");
+ ImportFromCLIB(nlmHandle, &gpf_fread, "fread");
+ ImportFromCLIB(nlmHandle, &gpf_freopen, "freopen");
+ ImportFromCLIB(nlmHandle, &gpf_fscanf, "fscanf");
+ ImportFromCLIB(nlmHandle, &gpf_fseek, "fseek");
+ ImportFromCLIB(nlmHandle, &gpf_fsetpos, "fsetpos");
+ ImportFromCLIB(nlmHandle, &gpf_ftell, "ftell");
+ ImportFromCLIB(nlmHandle, &gpf_fwrite, "fwrite");
+ ImportFromCLIB(nlmHandle, &gpf_getc, "getc");
+ ImportFromCLIB(nlmHandle, &gpf_getchar, "getchar");
+ ImportFromCLIB(nlmHandle, &gpf_gets, "gets");
+ ImportFromCLIB(nlmHandle, &gpf_perror, "perror");
+ ImportFromCLIB(nlmHandle, &gpf_putc, "putc");
+ ImportFromCLIB(nlmHandle, &gpf_putchar, "putchar");
+ ImportFromCLIB(nlmHandle, &gpf_puts, "puts");
+ ImportFromCLIB(nlmHandle, &gpf_rename, "rename");
+ ImportFromCLIB(nlmHandle, &gpf_rewind, "rewind");
+ ImportFromCLIB(nlmHandle, &gpf_scanf, "scanf");
+ ImportFromCLIB(nlmHandle, &gpf_setbuf, "setbuf");
+ ImportFromCLIB(nlmHandle, &gpf_setvbuf, "setvbuf");
+ ImportFromCLIB(nlmHandle, &gpf_sscanf, "sscanf");
+ ImportFromCLIB(nlmHandle, &gpf_tmpfile, "tmpfile");
+ ImportFromCLIB(nlmHandle, &gpf_tmpnam, "tmpnam");
+ ImportFromCLIB(nlmHandle, &gpf_ungetc, "ungetc");
+ ImportFromCLIB(nlmHandle, &gpf_vfscanf, "vfscanf");
+ ImportFromCLIB(nlmHandle, &gpf_vscanf, "vscanf");
+ ImportFromCLIB(nlmHandle, &gpf_vsscanf, "vsscanf");
+ ImportFromCLIB(nlmHandle, &gpf_fdopen, "fdopen");
+ ImportFromCLIB(nlmHandle, &gpf_fileno, "fileno");
+ ImportFromCLIB(nlmHandle, &gpf_cgets, "cgets");
+ ImportFromCLIB(nlmHandle, &gpf_cprintf, "cprintf");
+ ImportFromCLIB(nlmHandle, &gpf_cputs, "cputs");
+ ImportFromCLIB(nlmHandle, &gpf_cscanf, "cscanf");
+ ImportFromCLIB(nlmHandle, &gpf_fcloseall, "fcloseall");
+ ImportFromCLIB(nlmHandle, &gpf_fgetchar, "fgetchar");
+ ImportFromCLIB(nlmHandle, &gpf_flushall, "flushall");
+ ImportFromCLIB(nlmHandle, &gpf_fputchar, "fputchar");
+ ImportFromCLIB(nlmHandle, &gpf_getch, "getch");
+ ImportFromCLIB(nlmHandle, &gpf_getche, "getche");
+ ImportFromCLIB(nlmHandle, &gpf_putch, "putch");
+ ImportFromCLIB(nlmHandle, &gpf_ungetch, "ungetch");
+ ImportFromCLIB(nlmHandle, &gpf_vcprintf, "vcprintf");
+ ImportFromCLIB(nlmHandle, &gpf_vcscanf, "vcscanf");
+
+ ImportFromCLIB(nlmHandle, &gpf_memchr, "memchr");
+ ImportFromCLIB(nlmHandle, &gpf_memcmp, "memcmp");
+ ImportFromCLIB(nlmHandle, &gpf_memcpy, "memcpy");
+ ImportFromCLIB(nlmHandle, &gpf_memmove, "memmove");
+ ImportFromCLIB(nlmHandle, &gpf_memset, "memset");
+ ImportFromCLIB(nlmHandle, &gpf_memicmp, "memicmp");
+
+ ImportFromCLIB(nlmHandle, &gpf_strerror, "strerror");
+ ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r");
+
+ ImportFromCLIB(nlmHandle, &gpf_strcpy, "strcpy");
+ ImportFromCLIB(nlmHandle, &gpf_strcat, "strcat");
+ ImportFromCLIB(nlmHandle, &gpf_strchr, "strchr");
+ ImportFromCLIB(nlmHandle, &gpf_strstr, "strstr");
+ ImportFromCLIB(nlmHandle, &gpf_strcoll, "strcoll");
+ ImportFromCLIB(nlmHandle, &gpf_strcspn, "strcspn");
+ ImportFromCLIB(nlmHandle, &gpf_strpbrk, "strpbrk");
+ ImportFromCLIB(nlmHandle, &gpf_strrchr, "strrchr");
+ ImportFromCLIB(nlmHandle, &gpf_strrev, "strrev");
+ ImportFromCLIB(nlmHandle, &gpf_strspn, "strspn");
+ ImportFromCLIB(nlmHandle, &gpf_strupr, "strupr");
+ ImportFromCLIB(nlmHandle, &gpf_strxfrm, "strxfrm");
+ ImportFromCLIB(nlmHandle, &gpf_strcmp, "strcmp");
+ ImportFromCLIB(nlmHandle, &gpf_stricmp, "stricmp");
+ ImportFromCLIB(nlmHandle, &gpf_strtok, "strtok");
+ ImportFromCLIB(nlmHandle, &gpf_strlen, "strlen");
+ ImportFromCLIB(nlmHandle, &gpf_strncpy, "strncpy");
+ ImportFromCLIB(nlmHandle, &gpf_strncat, "strncat");
+ ImportFromCLIB(nlmHandle, &gpf_strncmp, "strncmp");
+ ImportFromCLIB(nlmHandle, &gpf_strcmpi, "strcmpi");
+ ImportFromCLIB(nlmHandle, &gpf_strnicmp, "strnicmp");
+ ImportFromCLIB(nlmHandle, &gpf_strdup, "strdup");
+ ImportFromCLIB(nlmHandle, &gpf_strlist, "strlist");
+ ImportFromCLIB(nlmHandle, &gpf_strlwr, "strlwr");
+ ImportFromCLIB(nlmHandle, &gpf_strnset, "strnset");
+ ImportFromCLIB(nlmHandle, &gpf_strset, "strset");
+ ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r");
+ ImportFromCLIB(nlmHandle, &gpf_printf, "printf");
+ ImportFromCLIB(nlmHandle, &gpf_fprintf, "fprintf");
+ ImportFromCLIB(nlmHandle, &gpf_sprintf, "sprintf");
+ ImportFromCLIB(nlmHandle, &gpf_vprintf, "vprintf");
+ ImportFromCLIB(nlmHandle, &gpf_vfprintf, "vfprintf");
+ ImportFromCLIB(nlmHandle, &gpf_vsprintf, "vsprintf");
+
+ }
+
diff -c /dev/null 'perl-5.7.2/NetWare/Makefile'
Index: ./NetWare/Makefile
*** ./NetWare/Makefile Thu Jan 1 02:00:00 1970
--- ./NetWare/Makefile Mon Jul 9 17:09:39 2001
***************
*** 0 ****
--- 1,1525 ----
+ ##
+ ## Makefile to build Perl on NetWare using Microsoft NMAKE and Watcom tools
+ ##
+ ## This will build perl.nlm, perl.lib and extensions called NLPs
+ ##
+
+ ##
+ ## Please read README.netware before starting
+ ##
+
+ ##
+ ## Build configuration. Edit the values below to suit your needs.
+ ##
+
+ ## This file is created by using the makefile that creates Windows Perl as the reference
+ ## Author: sgp
+ ## Date Created: 13th July 2000
+ ## Date Modified: 2nd July 2001
+
+ # Name of the NLM
+ NLM_NAME = perl.nlm
+ NLM_NAME8 = Perl
+
+ MAKE_ACTION = Build
+
+ # Flags
+ DBG_FLAG = -DDEBUGON
+
+ NW_FLAGS = -DNETWARE -DNLM_PLATFORM -DNETDB_USE_INTERNET
+
+ REL_DIR = Release
+ DEB_DIR = Debug
+
+ !ifndef MAKE_TYPE
+ #MAKE_TYPE = Release
+ !message "Run bat\buildtype.bat to set the build type before continuing.\n"
+ !error
+ !endif #!ifndef MAKE_TYPE
+
+ !ifdef USE_MPK
+ MPKFLAGS = -DMPK_ON -DIAPX386
+ MPKMESSAGE = MPK Build...
+ XDCTOOL = mpkxdc
+ !ifndef MPKBASE
+ #MPKBASE = p:\mpk
+ !message "Run bat\setnwbld.bat to set the NetWare MPK SDK before continuing.\n"
+ !error
+ !endif #ifndef MPKBASE
+ NLM_INCLUDE_MP = $(MPKBASE)\include
+ MPKTOOL = $(MPKBASE)\$(XDCTOOL)
+ !else
+ MPKMESSAGE = Non MPK Build...
+ NLM_INCLUDE_MP =
+ MPKTOOL =
+ !endif #ifdef USE_MPK
+
+ !ifndef NLMSDKBASE
+ #NLMSDKBASE = P:\ndk\nwsdk
+ !message "Run bat\setnwbld.bat to set the NetWare SDK before continuing.\n"
+ !error
+ !endif #ifndef NLMSDKBASE
+ NLMIMPORTS = $(NLMSDKBASE)\imports
+
+ !ifdef WATCOM
+ C_COMPILER = wcc386
+ CPP_COMPILER = wpp386
+ NLM_LINK = wlink
+ NLM_LIB = lib386
+ TOOL_HEADERS = $(WATCOM)\H;$(WATCOM)\H\NT
+ TOOL_PATH = $(WATCOM)\BINNT;$(WATCOM)\BINW
+ CCFLAGS = /zp1 /5s /w1 /zq /ms /otexanih /fpi
+ COMPILER_FLAG = -DWATCOM
+ ERROR_FLAG = -Fr
+ !if "$(MAKE_TYPE)"=="Debug"
+ BLDDIR = $(DEB_DIR)
+ BLDMESG = Debug version,
+ !ifdef USE_D2
+ BS_CFLAGS = /od /d2 /en /st /hc -DDEBUGGING -DUSE_D2 $(DBG_FLAG)
+ BLDMESG = $(BLDMESG) Using /d2 option
+ !else
+ BS_CFLAGS = /od /d1 /en /st /hc -DDEBUGGING $(DBG_FLAG)
+ BLDMESG = $(BLDMESG) Using /d1 option
+ !endif #!ifdef USE_D2
+ ! else
+ BLDDIR = $(REL_DIR)
+ BLDMESG = Release version
+ BS_CFLAGS =
+ !endif #if "$(MAKE_TYPE)"=="Debug"
+ !else #ifdef WATCOM
+ !ifdef CODEWARRIOR
+ # Here comes the CW tools - TO BE FILLED TO BUILD WITH CW -
+ C_COMPILER =
+ CPP_COMPILER =
+ NLM_LINK =
+ NLM_LIB =
+ TOOL_HEADERS =
+ TOOL_PATH =
+ CCFLAGS =
+ COMPILER_FLAG =
+ ERROR_FLAG =
+ # Debug flags comes here - Not mandatory - required only for debug build
+ !if "$(MAKE_TYPE)"=="Debug"
+ BLDDIR = $(DEB_DIR)
+ BLDMESG = Debug version,
+ !ifdef USE_D2
+ BS_CFLAGS =
+ BLDMESG = $(BLDMESG) Using /d2 option
+ !else
+ BS_CFLAGS =
+ BLDMESG = $(BLDMESG) Using /d1 option
+ !endif #!ifdef USE_D2
+ ! else
+ BLDDIR = $(REL_DIR)
+ BLDMESG = Release version
+ BS_CFLAGS =
+ !endif #if "$(MAKE_TYPE)"=="Debug"
+ !else #!ifdef CODEWARRIOR
+ !message "Tools base directory is not defined. Run bat\setnwbld.bat before proceeding"
+ !error
+ Run bat\setnwbld.bat
+ !endif #!ifdef CODEWARRIOR
+ !endif #ifdef WATCOM
+
+ ADD_LOCDEFS = -DPERL_CORE
+
+ NLM_INCLUDE = -I$(NLMSDKBASE)\include
+ NLM_INCLUDE_NLM = -I$(NLMSDKBASE)\include\nlm
+ NLM_INCLUDE_NLM_SYS = -I$(NLMSDKBASE)\include\nlm\sys
+ INCLUDE_NW = -I.\include
+ INC_PREV = -I..
+ INC_THIS = -I.\
+
+ NLM_INCLUDE_PATH = $(NLMSDKBASE)\include\nlm;$(NLMSDKBASE)\include;$(NLMSDKBASE)\include\nlm\sys;$(NLM_INCLUDE_MP);$(TOOL_HEADERS)
+
+ INCLUDE = $(NLM_INCLUDE_PATH)
+
+ PATH = $(PATH);$(TOOL_PATH)
+
+ NLM_INCLUDES = -I$(COREDIR) $(INCLUDE_NW) $(INC_THIS) $(INC_PREV)
+
+ COMPLER_FLAGS = $(CCFLAGS) $(BS_CFLAGS) $(ADD_BUILDOPT) $(NW_FLAGS) $(COMPILER_FLAG) $(MPKFLAGS)
+
+ # Source file list
+ NW_H_FILES = \
+ .\iperlhost.h \
+ .\interface.h \
+ .\netware.h \
+ .\nw5iop.h \
+ .\nw5sck.h \
+ .\nwpipe.h \
+ .\nwplglob.h \
+ .\nwtinfo.h \
+ .\nwutil.h \
+ .\nwperlsys.h \
+
+ NW_HOST_H_FILES = \
+ .\iperlhost.h \
+ .\interface.h \
+ .\netware.h \
+ .\nw5sck.h \
+ .\nwperlsys.h \
+
+ CLIB_H_FILES = \
+ .\clibsdio.h \
+ .\clibstr.h \
+ .\clibstuf.h \
+ .\stdio.h \
+ .\string.h \
+
+ NW_SRC = \
+ .\CLIBstuf.c \
+ .\nw5.c \
+ .\nw5sck.c \
+ .\nw5thread.c \
+ .\nwmain.c \
+ .\nwpipe.c \
+ .\nwplglob.c \
+ .\nwtinfo.c \
+ .\nwutil.c \
+
+ EXT_MAIN_SRC = \
+ .\Main.c \
+
+ PERL_IO_SRC = \
+ ..\perlio.c
+
+ PERL_LIB_SRC = \
+ .\interface.c \
+ .\nwperlsys.c \
+
+
+ NW_SRC_OBJ = $(NW_SRC:.c=.obj)
+ NLM_MICROCORE_OBJ = $(MICROCORE_SRC:.c=.obj)
+ PERL_LIB_OBJ = $(PERL_LIB_SRC:.c=.obj)
+ PERL_IO_OBJ = $(PERL_IO_SRC:.c=.obj)
+ NLM_CORE_OBJ = $(NLM_MICROCORE_OBJ)
+ EXT_MAIN_OBJ = $(EXT_MAIN_SRC:.c=.obj)
+
+ # For dependency checking
+ # $(BLDDIR) in place of Release or Debug is not working, should look into this - sgp
+ !if "$(BLDDIR)"=="Release"
+ NLM_OBJ = $(NLM_CORE_OBJ:..\=.\Release\)
+ NEWTARE_OBJ_DEP = $(NW_SRC_OBJ:.\=.\Release\)
+ PERL_LIB_OBJ_DEP = $(PERL_LIB_OBJ:.\=.\Release\)
+ PERL_IO_OBJ_DEP = $(PERL_IO_OBJ:..\=.\Release\)
+ !else
+ NLM_OBJ = $(NLM_CORE_OBJ:..\=.\Debug\)
+ NEWTARE_OBJ_DEP = $(NW_SRC_OBJ:.\=.\Debug\)
+ PERL_LIB_OBJ_DEP = $(PERL_LIB_OBJ:.\=.\Debug\)
+ PERL_IO_OBJ_DEP = $(PERL_IO_OBJ:..\=.\Debug\)
+ !endif
+
+ # Symbol base_import & version added for NETWARE
+ NW_CFG_VARS = \
+ "INST_DRV=$(INST_DRV)" \
+ "INST_TOP=$(INST_TOP)" \
+ "INST_VER=$(INST_VER)" \
+ "INST_ARCH=$(INST_ARCH)" \
+ "INST_NW_TOP1=$(INST_NW_TOP1)" \
+ "INST_NW_TOP2=$(INST_NW_TOP2)" \
+ "INST_NW_VER=$(INST_NW_VER)" \
+ "archname=$(ARCHNAME)" \
+ "cc=$(C_COMPILER)" \
+ "ccflags=$(COMPLER_FLAGS)" \
+ "cf_email=$(EMAIL)" \
+ "d_crypt=$(D_CRYPT)" \
+ "d_mymalloc=$(PERL_MALLOC)" \
+ # "libs=$(LIBFILES)" \
+ "incpath=$(NLM_INCLUDE_PATH)" \
+ "libperl=$(PERLIMPLIB:..\=)" \
+ "libpth=$(LIBPATH)" \
+ # "libc=$(LIBC)" \
+ "make=nmake" \
+ "static_ext=$(STATIC_EXT)" \
+ "dynamic_ext=$(DYNAMIC_EXT)" \
+ "nonxs_ext=$(NONXS_EXT)" \
+ "use5005threads=$(USE_5005THREADS)" \
+ "useithreads=$(USE_ITHREADS)" \
+ "usethreads=$(USE_5005THREADS)" \
+ "usemultiplicity=$(USE_MULTI)" \
+ "ld=$(NLM_LINK)" \
+ "base_import=$(BASE_IMPORT_FILES)" \
+ "LINK_FLAGS=$(LINK_FLAGS:"=\")" \
+ "optimize=" \
+ "d_times=define" \
+ "d_stdio_cnt_lval=undef" \
+ "d_stdio_ptr_lval=undef" \
+ "d_stdiobase=undef" \
+ "d_stdstdio=undef" \
+ "d_times=undef" \
+ "direntrytype=DIR" \
+ "nlm_version=$(NLM_VERSION)" \
+ "d_archname=NetWare" \
+ "mpktool=$(MPKTOOL) $(XDCFLAGS)" \
+ "toolpath=$(TOOL_PATH)"
+
+
+ NW_CFGSH_TMPL = config.wc
+ NW_CFGH_TMPL = config_H.wc
+
+ SOCKET_NLP = $(AUTODIR)\Socket\Socket.nlp
+ FCNTL_NLP = $(AUTODIR)\Fcntl\Fcntl.nlp
+ IO_NLP = $(AUTODIR)\IO\IO.nlp
+ OPCODE_NLP = $(AUTODIR)\Opcode\Opcode.nlp
+ SDBM_FILE_NLP = $(AUTODIR)\SDBM_File\SDBM_File.nlp
+ POSIX_NLP = $(AUTODIR)\POSIX\POSIX.nlp
+ ATTRS_NLP = $(AUTODIR)\attrs\attrs.nlp
+ THREAD_NLP = $(AUTODIR)\Thread\Thread.nlp
+ B_NLP = $(AUTODIR)\B\B.nlp
+ DUMPER_NLP = $(AUTODIR)\Data\Dumper\Dumper.nlp
+ PEEK_NLP = $(AUTODIR)\Devel\Peek\Peek.nlp
+ RE_NLP = $(AUTODIR)\re\re.nlp
+ BYTELOADER_NLP = $(AUTODIR)\ByteLoader\ByteLoader.nlp
+ DPROF_NLP = $(AUTODIR)\Devel\DProf\DProf.nlp
+ GLOB_NLP = $(AUTODIR)\File\Glob\Glob.nlp
+ CWD_NLP = $(AUTODIR)\Cwd\Cwd.nlp
+ STORABLE_NLP = $(AUTODIR)\Storable\Storable.nlp
+ LISTUTIL_NLP = $(AUTODIR)\List\Util\Util.nlp
+ MIMEBASE64_NLP = $(AUTODIR)\MIME\Base64\Base64.nlp
+ XSTYPEMAP_NLP = $(AUTODIR)\XS\Typemap\Typemap.nlp
+
+ EXTENSION_NLP = \
+ $(FCNTL_NLP) \
+ $(BYTELOADER_NLP) \
+ $(IO_NLP) \
+ $(SOCKET_NLP) \
+ $(OPCODE_NLP) \
+ $(B_NLP) \
+ $(ATTRS_NLP) \
+ $(SDBM_FILE_NLP) \
+ $(POSIX_NLP) \
+ $(THREAD_NLP) \
+ $(DUMPER_NLP) \
+ $(GLOB_NLP) \
+ $(PEEK_NLP) \
+ $(RE_NLP) \
+ $(DPROF_NLP) \
+ $(STORABLE_NLP) \
+ $(LISTUTIL_NLP) \
+ $(MIMEBASE64_NLP) \
+ $(XSTYPEMAP_NLP) \
+ # $(CWD_NLP) \
+ # cwd.pm needs to be modifed for NetWare.
+
+ # Begin - Following is required to build NetWare specific extensions Perl2UCS & CGI2Perl
+
+ PERL2UCS = $(EXTDIR)\Perl2UCS\Perl2UCS
+ CGI2PERL = CGI2Perl\CGI2Perl
+
+ PERL2UCS_NLP = $(AUTODIR)\Perl2UCS\Perl2UCS.nlp
+ CGI2PERL_NLP = \CGI2Perl\CGI2Perl.nlp
+
+ NETWARE_EXTNS = \
+ $(PERL2UCS_NLP) \
+ $(CGI2PERL_NLP)
+
+ # End
+
+ ECHO_SRC = TestNLM\echo\echo.c
+ TYPE_SRC = TestNLM\type\type.c
+ ECHO_SRC_OBJ = $(ECHO_SRC:.c=.obj)
+ TYPE_SRC_OBJ = $(TYPE_SRC:.c=.obj)
+ ECHO_NLM = TestNLM\echo\echo.nlm
+ TYPE_NLM = TestNLM\type\type.nlm
+
+ TEST_NLMS = \
+ $(ECHO_NLM) \
+ $(TYPE_NLM) \
+
+ ERRNO_PM_NW = $(LIBDIR)\Errno.pm
+
+ EXTENSION_NPM = \
+ $(ERRNO_PM_NW) \
+
+
+ !ifndef SCREEN
+ SCREEN = 'none'
+ !endif
+
+ !ifndef NLM_DESCRIPTION
+ NLM_DESCRIPTION = $(NLM_NAME8) for Netware
+ !endif
+
+ !ifndef NLM_VERSION
+ NLM_VERSION = 5.72.0
+ !endif
+
+ !ifndef NLM_EXT
+ NLM_EXT = NLM
+ !endif
+
+ !ifndef BUILT
+ BUILT = $(BLDDIR)\$(NLM_NAME8).$(NLM_EXT)
+ !endif
+
+ !ifndef BASE_IMPORT_FILES
+ BASE_IMPORT_FILES = Import @$(NLMIMPORTS)\clib.imp, @$(NLMIMPORTS)\nlmlib.imp, @$(NLMIMPORTS)\threads.imp, @$(NLMIMPORTS)\nit.imp, @$(NLMIMPORTS)\socklib.imp, @$(NLMIMPORTS)\fpsm.imp, @$(NLMIMPORTS)\lib0.imp
+ !endif
+
+ !ifdef USE_MPK
+ BASE_IMPORT_FILES = $(BASE_IMPORT_FILES), @$(MPKBASE)\import\mpkorg.imp
+ !endif
+
+ !ifndef BASE_IMPORT_FNS
+ BASE_IMPORT_FNS = Import ImportSymbol, GetSystemConsoleScreen, LoadModule
+ !endif
+
+ !ifdef WATCOM
+ NWLIBPATH = $(WATCOM)\lib386\netware
+ LIBPATH386 = $(WATCOM)\lib386
+ LIBPATH = $(NWLIBPATH);$(LIBPATH386)
+ !else #!ifdef WATCOM
+ !ifdef CODEWARRIOR
+ NWLIBPATH =
+ LIBPATH386 =
+ LIBPATH =
+ !else #!ifdef CODEWARRIOR
+ !error Please define the tools base directory before proceeding
+ !endif #!ifdef CODEWARRIOR
+ !endif #!ifdef WATCOM
+
+ !ifndef BASE_LIBRARIES
+ !ifdef WATCOM
+ BASE_LIBRARIES = Library plib3s.lib,math3s.lib,clib3s.lib
+ !else
+ !ifdef CODEWARRIOR
+ BASE_LIBRARIES =
+ !endif #!ifdef CODEWARRIOR
+ !endif #!ifdef WATCOM
+ !endif #!ifndef BASE_LIBRARIES
+
+ COPYRIGHT = Copyright 2001 by Novell, Inc. All rights reserved.
+
+ EXPORTS = Export @perl.imp
+
+ #
+ # Set these to wherever you want "nmake install" to put your
+ # newly built perl.
+ #
+ INST_DRV = c:
+ INST_TOP = $(INST_DRV)\perl
+
+ INST_NW_DRV = i:
+ INST_NW_VOL = sys:
+ INST_NW_TOP1 = $(INST_NW_VOL)\perl
+ INST_NW_TOP2 = $(INST_NW_DRV)\perl
+ #INST_NW_VER = \5.6.1
+
+ #
+ # Comment this out if you DON'T want your perl installation to be versioned.
+ # This means that the new installation will overwrite any files from the
+ # old installation at the same INST_TOP location. Leaving it enabled is
+ # the safest route, as perl adds the extra version directory to all the
+ # locations it installs files to. If you disable it, an alternative
+ # versioned installation can be obtained by setting INST_TOP above to a
+ # path that includes an arbitrary version string.
+ #
+ INST_VER = \5.7.2
+
+ #
+ # Comment this out if you DON'T want your perl installation to have
+ # architecture specific components. This means that architecture-
+ # specific files will be installed along with the architecture-neutral
+ # files. Leaving it enabled is safer and more flexible, in case you
+ # want to build multiple flavors of perl and install them together in
+ # the same location. Commenting it out gives you a simpler
+ # installation that is easier to understand for beginners.
+ #
+ INST_ARCH = \$(ARCHNAME)
+
+ #
+ # uncomment to enable multiple interpreters. This is need for fork()
+ # emulation.
+ #
+ USE_MULTI = define
+
+ #
+ # Beginnings of interpreter cloning/threads; still very incomplete.
+ # This should be enabled to get the fork() emulation. This needs
+ # USE_MULTI as well.
+ #
+ USE_ITHREADS = define
+
+ #
+ # uncomment to enable the implicit "host" layer for all system calls
+ # made by perl. This needs USE_MULTI above. This is also needed to
+ # get fork().
+ #
+ USE_IMP_SYS = define
+
+ # uncomment this to enable the experimental PerlIO I/O subsystem
+ # else USE_STDIO will be defined.
+ #USE_PERLIO = define
+ #USE_STDIO = define
+
+ #
+ # WARNING! This option is deprecated and will eventually go away (enable
+ # USE_ITHREADS instead).
+ #
+ # uncomment to enable threads-capabilities. This is incompatible with
+ # USE_ITHREADS, and is only here for people who may have come to rely
+ # on the experimental Thread support that was in 5.005.
+ #
+ #USE_5005THREADS= define
+
+ #
+ # WARNING! This option is deprecated and will eventually go away (enable
+ # USE_MULTI instead).
+ #
+ # uncomment next line if you want to use the PERL_OBJECT build option.
+ # DO NOT ENABLE unless you have legacy code that relies on the C++
+ # CPerlObj class that was available in 5.005. This cannot be enabled
+ # if you ask for USE_5005THREADS above.
+ #
+ #USE_OBJECT = define
+
+ # For now let this be here
+ #
+ #CRYPT_SRC = fcrypt.c
+
+ # For now let this be here
+ #
+ #CRYPT_LIB = fcrypt.lib
+
+ #
+ # set this if you wish to use perl's malloc
+ # WARNING: Turning this on/off WILL break binary compatibility with extensions
+ # you may have compiled with/without it. Be prepared to recompile all
+ # extensions if you change the default. Currently, this cannot be enabled
+ # if you ask for USE_IMP_SYS above.
+ #
+ #PERL_MALLOC = define
+
+ #
+ # set this to your email address (perl will guess a value from
+ # from your loginname and your hostname, which may not be right)
+ #
+ #EMAIL =
+
+ ##
+ ## Build configuration ends.
+ ##
+
+ ##################### CHANGE THESE ONLY IF YOU MUST #####################
+
+ !IF "$(CRYPT_SRC)$(CRYPT_LIB)" == ""
+ D_CRYPT = undef
+ !ELSE
+ D_CRYPT = define
+ CRYPT_FLAG = -DHAVE_DES_FCRYPT
+ !ENDIF
+
+ !IF "$(USE_OBJECT)" == "define"
+ PERL_MALLOC = undef
+ USE_5005THREADS = undef
+ USE_MULTI = undef
+ USE_IMP_SYS = define
+ !ENDIF
+
+ !IF "$(PERL_MALLOC)" == ""
+ PERL_MALLOC = undef
+ !ENDIF
+
+ !IF "$(USE_5005THREADS)" == ""
+ USE_5005THREADS = undef
+ !ENDIF
+
+ !IF "$(USE_5005THREADS)" == "define"
+ USE_ITHREADS = undef
+ !ENDIF
+
+ !IF "$(USE_IMP_SYS)" == "define"
+ PERL_MALLOC = undef
+ !ENDIF
+
+ !IF "$(USE_MULTI)" == ""
+ USE_MULTI = undef
+ !ENDIF
+
+ !IF "$(USE_OBJECT)" == ""
+ USE_OBJECT = undef
+ !ENDIF
+
+ !IF "$(USE_ITHREADS)" == ""
+ USE_ITHREADS = undef
+ !ENDIF
+
+ !IF "$(USE_IMP_SYS)" == ""
+ USE_IMP_SYS = undef
+ !ENDIF
+
+ !IF "$(USE_PERLCRT)" == ""
+ USE_PERLCRT = undef
+ !ENDIF
+
+ !IF "$(USE_IMP_SYS)$(USE_MULTI)$(USE_5005THREADS)$(USE_OBJECT)" == "defineundefundefundef"
+ USE_MULTI = define
+ !ENDIF
+
+ !IF "$(USE_ITHREADS)$(USE_MULTI)$(USE_OBJECT)" == "defineundefundef"
+ USE_MULTI = define
+ USE_5005THREADS = undef
+ !ENDIF
+
+ !IF "$(USE_MULTI)$(USE_5005THREADS)$(USE_OBJECT)" != "undefundefundef"
+ BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_CONTEXT
+ !ENDIF
+
+ !IF "$(USE_IMP_SYS)" != "undef"
+ BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_SYS
+ !ENDIF
+
+ !IF "$(PROCESSOR_ARCHITECTURE)" == ""
+ PROCESSOR_ARCHITECTURE = x86
+ !ENDIF
+
+ !IF "$(USE_OBJECT)" == "define"
+ ARCHNAME = NetWare-$(PROCESSOR_ARCHITECTURE)-object
+ !ELSE
+ !IF "$(USE_5005THREADS)" == "define"
+ ARCHNAME = NetWare-$(PROCESSOR_ARCHITECTURE)-thread
+ !ELSE
+ !IF "$(USE_MULTI)" == "define"
+ ARCHNAME = NetWare-$(PROCESSOR_ARCHITECTURE)-multi
+ !ELSE
+ ARCHNAME = NetWare-$(PROCESSOR_ARCHITECTURE)
+ !ENDIF
+ !ENDIF
+ !ENDIF
+
+ !IF "$(USE_MULTI)$(USE_5005THREADS)$(USE_OBJECT)" != "undefundefundef"
+ ADD_BUILDOPT = $(ADD_BUILDOPT) -DPERL_IMPLICIT_CONTEXT
+ !ENDIF
+
+ !IF "$(USE_IMP_SYS)" != "undef"
+ ADD_BUILDOPT = $(ADD_BUILDOPT) -DPERL_IMPLICIT_SYS
+ !ENDIF
+
+ !IF "$(USE_ITHREADS)" == "define"
+ ARCHNAME = $(ARCHNAME)-thread
+ !ENDIF
+
+ !IF "$(USE_PERLIO)" == "define"
+ USE_STDIO = undef
+ ADD_BUILDOPT = $(ADD_BUILDOPT) -DUSE_PERLIO
+ ARCHNAME = $(ARCHNAME)-perlio
+ !ELSE
+ #USE_STDIO = define
+ #ADD_BUILDOPT = $(ADD_BUILDOPT) -DUSE_STDIO
+ !ENDIF
+
+ ARCHDIR = ..\lib\$(ARCHNAME)
+ COREDIR = ..\lib\CORE
+ AUTODIR = ..\lib\auto
+ LIBDIR = ..\lib
+ EXTDIR = ..\ext
+ PODDIR = ..\pod
+ EXTUTILSDIR = $(LIBDIR)\ExtUtils
+
+ #
+ INST_SCRIPT = $(INST_TOP)$(INST_VER)\bin
+ INST_BIN = $(INST_SCRIPT)$(INST_ARCH)
+ INST_LIB = $(INST_TOP)$(INST_VER)\lib
+ INST_ARCHLIB = $(INST_LIB)$(INST_ARCH)
+ INST_COREDIR = $(INST_ARCHLIB)\CORE
+ INST_POD = $(INST_LIB)\pod
+ INST_HTML = $(INST_POD)\html
+
+ #
+ # Options
+ #
+
+ !IF "$(USE_OBJECT)" == "define"
+ OPTIMIZE = $(OPTIMIZE) $(CXX_FLAG)
+ BUILDOPT = $(BUILDOPT) -DPERL_OBJECT
+ !ENDIF
+
+ OBJOUT_FLAG = -Fo
+ EXEOUT_FLAG = -Fe
+
+
+ #################### do not edit below this line #######################
+ ############# NO USER-SERVICEABLE PARTS BEYOND THIS POINT ##############
+
+ o = .obj
+
+ #
+ # Rules
+ #
+
+ .SUFFIXES : .c $(o) .nlm .lib .nlp
+
+
+ #
+ # various targets
+ PERLIMPLIB = ..\perl.lib
+
+ MINIPERL = ..\miniperl.exe
+ CONFIGPM = ..\lib\Config.pm
+ MINIMOD = ..\lib\ExtUtils\Miniperl.pm
+ X2P = ..\x2p\a2p.nlm
+
+ PL2BAT = ..\win32\bin\pl2bat.pl
+
+ UTILS = \
+ ..\utils\h2ph \
+ ..\utils\splain \
+ ..\utils\dprofpp \
+ ..\utils\perlbug \
+ ..\utils\pl2pm \
+ ..\utils\c2ph \
+ ..\utils\h2xs \
+ ..\utils\perldoc \
+ ..\utils\perlcc \
+ ..\pod\checkpods \
+ ..\pod\pod2html \
+ ..\pod\pod2latex \
+ ..\pod\pod2man \
+ ..\pod\pod2text \
+ ..\pod\pod2usage \
+ ..\pod\podchecker \
+ ..\pod\podselect \
+ ..\x2p\find2perl \
+ ..\x2p\s2p
+
+ MAKE = nmake -nologo
+
+ XCOPY = xcopy /f /r /i /d
+ RCOPY = xcopy /f /r /i /e /d
+ NOOP = @echo
+ NULL =
+
+ #
+ # filenames given to xsubpp must have forward slashes (since it puts
+ # full pathnames in #line strings)
+ XSUBPP = ..\$(MINIPERL) -I..\..\lib ..\$(EXTUTILSDIR)\xsubpp \
+ -C++ -prototypes
+
+ MICROCORE_SRC = \
+ ..\av.c \
+ ..\deb.c \
+ ..\doio.c \
+ ..\doop.c \
+ ..\dump.c \
+ ..\globals.c \
+ ..\gv.c \
+ ..\hv.c \
+ ..\locale.c \
+ ..\mg.c \
+ ..\numeric.c \
+ ..\op.c \
+ ..\perl.c \
+ ..\perlapi.c \
+ ..\perly.c \
+ ..\pp.c \
+ ..\pp_ctl.c \
+ ..\pp_hot.c \
+ ..\pp_pack.c \
+ ..\pp_sys.c \
+ ..\regcomp.c \
+ ..\regexec.c \
+ ..\run.c \
+ ..\scope.c \
+ ..\sv.c \
+ ..\taint.c \
+ ..\toke.c \
+ ..\universal.c \
+ ..\utf8.c \
+ ..\util.c \
+ ..\xsutils.c
+
+ #EXTRACORE_SRC = $(EXTRACORE_SRC) perllib.c
+
+ !IF "$(PERL_MALLOC)" == "define"
+ EXTRACORE_SRC = $(EXTRACORE_SRC) ..\malloc.c
+ !ENDIF
+
+ #!IF "$(USE_OBJECT)" != "define"
+ #EXTRACORE_SRC = $(EXTRACORE_SRC) ..\perlio.c
+ #!ENDIF
+
+ !IF "$(CRYPT_SRC)" != ""
+ NW_SRC = $(NW_SRC) .\$(CRYPT_SRC)
+ !ENDIF
+
+ DLL_SRC = $(DYNALOADER).c
+
+ X2P_SRC = \
+ ..\x2p\a2p.c \
+ ..\x2p\hash.c \
+ ..\x2p\str.c \
+ ..\x2p\util.c \
+ ..\x2p\walk.c
+
+ CORE_NOCFG_H = \
+ ..\av.h \
+ ..\cop.h \
+ ..\cv.h \
+ ..\dosish.h \
+ ..\embed.h \
+ ..\form.h \
+ ..\gv.h \
+ ..\handy.h \
+ ..\hv.h \
+ ..\iperlsys.h \
+ ..\mg.h \
+ ..\nostdio.h \
+ ..\op.h \
+ ..\opcode.h \
+ ..\perl.h \
+ ..\perlapi.h \
+ ..\perlsdio.h \
+ ..\perlsfio.h \
+ ..\perly.h \
+ ..\pp.h \
+ ..\proto.h \
+ ..\regexp.h \
+ ..\scope.h \
+ ..\sv.h \
+ ..\thread.h \
+ ..\unixish.h \
+ ..\utf8.h \
+ ..\util.h \
+ ..\warnings.h \
+ ..\XSUB.h \
+ ..\EXTERN.h \
+ ..\perlvars.h \
+ ..\intrpvar.h \
+ ..\thrdvar.h \
+
+ CORE_H = $(CORE_NOCFG_H) .\config.h
+
+ DLL_OBJ = $(DLL_SRC:.c=.obj)
+ X2P_OBJ = $(X2P_SRC:.c=.obj)
+
+ DYNAMIC_EXT = Socket IO Fcntl Opcode SDBM_File POSIX attrs Thread B re \
+ Data/Dumper Devel/Peek ByteLoader Devel/DProf File/Glob \
+ Storable/Storable List/Util MIME/Base64/Base64 XS/Typemap/Typemap
+
+ STATIC_EXT = DynaLoader
+ NONXS_EXT = Errno
+
+ DYNALOADER = $(EXTDIR)\DynaLoader\DynaLoader
+ SOCKET = $(EXTDIR)\Socket\Socket
+ FCNTL = $(EXTDIR)\Fcntl\Fcntl
+ OPCODE = $(EXTDIR)\Opcode\Opcode
+ SDBM_FILE = $(EXTDIR)\SDBM_File\SDBM_File
+ IO = $(EXTDIR)\IO\IO
+ POSIX = $(EXTDIR)\POSIX\POSIX
+ ATTRS = $(EXTDIR)\attrs\attrs
+ THREAD = $(EXTDIR)\Thread\Thread
+ B = $(EXTDIR)\B\B
+ RE = $(EXTDIR)\re\re
+ DUMPER = $(EXTDIR)\Data\Dumper\Dumper
+ ERRNO = $(EXTDIR)\Errno\Errno
+ PEEK = $(EXTDIR)\Devel\Peek\Peek
+ BYTELOADER = $(EXTDIR)\ByteLoader\ByteLoader
+ DPROF = $(EXTDIR)\Devel\DProf\DProf
+ GLOB = $(EXTDIR)\File\Glob\Glob
+ CWD = $(EXTDIR)\Cwd\Cwd
+ STORABLE = $(EXTDIR)\Storable\Storable
+ LISTUTIL = $(EXTDIR)\List\Util
+ MIMEBASE64 = $(EXTDIR)\MIME\Base64\Base64
+ XSTYPEMAP = $(EXTDIR)\XS\Typemap\Typemap
+
+ EXTENSION_C = \
+ $(SOCKET).c \
+ $(FCNTL).c \
+ $(OPCODE).c \
+ $(SDBM_FILE).c \
+ $(IO).c \
+ $(POSIX).c \
+ $(ATTRS).c \
+ $(THREAD).c \
+ $(RE).c \
+ $(DUMPER).c \
+ $(PEEK).c \
+ $(B).c \
+ $(BYTELOADER).c \
+ $(DPROF).c \
+ $(GLOB).c \
+ $(CWD).c \
+ $(STORABLE).c \
+ $(LISTUTIL).c \
+ $(MIMEBASE64).c \
+ $(XSTYPEMAP).c \
+
+ POD2HTML = $(PODDIR)\pod2html
+ POD2MAN = $(PODDIR)\pod2man
+ POD2LATEX = $(PODDIR)\pod2latex
+ POD2TEXT = $(PODDIR)\pod2text
+
+ #
+ # Top targets
+ #
+
+ all : .cleanoldfiles .\nwconfig.h $(CONFIGPM) $(NLM_NAME) $(EXTENSION_NLP) $(EXTENSION_NPM) $(TEST_NLMS) $(NETWARE_EXTNS)
+
+ #------------------------------------------------------------
+
+ ..\config.sh : config.nw5 $(MINIPERL) config_sh.PL
+ $(MINIPERL) -I..\lib config_sh.PL $(NW_CFG_VARS) config.nw5 > ..\config.sh
+
+ # this target is for when changes to the main config.sh happen
+ # edit config.{b,v,g,w}c and make this target once for each supported
+ # compiler (e.g. `dmake CCTYPE=BORLAND regen_config_h`)
+ regen_config_h:
+ perl config_sh.PL $(NW_CFG_VARS) $(NW_CFGSH_TMPL) > ..\config.sh
+ cd ..
+ -del /f perl.exe
+ perl configpm
+ cd netware
+ -del /f $(NW_CFGH_TMPL)
+ -mkdir $(COREDIR)
+ -perl -I..\lib config_h.PL "INST_VER=$(INST_VER)"
+ rename config.h $(NW_CFGH_TMPL)
+
+ $(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl
+ cd .. && miniperl configpm
+ if exist lib\* $(RCOPY) lib\*.* ..\lib\$(NULL)
+ $(XCOPY) ..\*.h $(COREDIR)\*.*
+ $(XCOPY) *.h $(COREDIR)\*.*
+ $(XCOPY) ..\ext\re\re.pm $(LIBDIR)\*.*
+ if exist include\* $(RCOPY) include $(COREDIR)\*.*
+ $(MINIPERL) -I..\lib config_h.PL "INST_VER=$(INST_VER)" \
+ || $(MAKE) /$(MAKEFLAGS) $(CONFIGPM)
+
+ $(MINIPERL) :
+ $(error)Please build $(MINIPERL) before continuing
+
+ $(MINIMOD) : $(MINIPERL) ..\minimod.pl
+ cd .. && miniperl minimod.pl > lib\ExtUtils\Miniperl.pm
+
+ ..\x2p\a2p$(o) : ..\x2p\a2p.c
+ @echo $(MPKMESSAGE)...$(BLDMESG)...$@
+ @$(C_COMPILER) -I..\x2p $(NLM_INCLUDES) $(COMPLER_FLAGS) $(ADD_LOCDEFS) $(OBJOUT_FLAG)$@ $(ERROR_FLAG)$*.err ..\x2p\a2p.c
+
+ ..\x2p\hash$(o) : ..\x2p\hash.c
+ @echo $(MPKMESSAGE)...$(BLDMESG)...$@
+ @$(C_COMPILER) -I..\x2p $(NLM_INCLUDES) $(COMPLER_FLAGS) $(ADD_LOCDEFS) $(OBJOUT_FLAG)$@ $(ERROR_FLAG)$*.err ..\x2p\hash.c
+
+ ..\x2p\str$(o) : ..\x2p\str.c
+ @echo $(MPKMESSAGE)...$(BLDMESG)...$@
+ @$(C_COMPILER) -I..\x2p $(NLM_INCLUDES) $(COMPLER_FLAGS) $(ADD_LOCDEFS) $(OBJOUT_FLAG)$@ $(ERROR_FLAG)$*.err ..\x2p\str.c
+
+ ..\x2p\util$(o) : ..\x2p\util.c
+ @echo $(MPKMESSAGE)...$(BLDMESG)...$@
+ @$(C_COMPILER) -I..\x2p $(NLM_INCLUDES) $(COMPLER_FLAGS) $(ADD_LOCDEFS) $(OBJOUT_FLAG)$@ $(ERROR_FLAG)$*.err ..\x2p\util.c
+
+ ..\x2p\walk$(o) : ..\x2p\walk.c
+ @echo $(MPKMESSAGE)...$(BLDMESG)...$@
+ @$(C_COMPILER) -I..\x2p $(NLM_INCLUDES) $(COMPLER_FLAGS) $(ADD_LOCDEFS) $(OBJOUT_FLAG)$@ $(ERROR_FLAG)$*.err ..\x2p\walk.c
+
+ $(X2P) : $(MINIPERL) $(X2P_OBJ)
+ $(MINIPERL) ..\x2p\find2perl.PL
+ $(MINIPERL) ..\x2p\s2p.PL
+ !ifdef USE_XDC
+ $(MPKTOOL) $(XDCFLAGS) $*.xdc
+ !endif
+ !ifdef WATCOM
+ @$(NLM_LINK) @<<$*.link
+ Form Novell NLM 'Awk to Perl converter'
+ Name $(X2P)
+ Option Quiet
+ Option Version = $(NLM_VERSION)
+ Option Copyright '$(COPYRIGHT)'
+ Option Caseexact
+ Option Map=$*.map, Verbose, screenname 'System Console'
+ Option Stack=32k
+ Option SYMFILE=$*.sym
+ !ifdef USE_XDC
+ OPTION XDCDATA=$*.xdc
+ !endif
+ Option NoDefaultLibs
+ $(EXTRA_LINK_OPTION)
+ !if "$(MAKE_TYPE)"=="Debug"
+ Debug novell
+ Debug codeview
+ !endif
+ LibPath $(LIBPATH)
+ $(BASE_LIBRARIES)
+ Module clib
+ $(BASE_IMPORT_FNS)
+ $(BASE_IMPORT_FILES)
+ $(ADD_IMPORT_FNS)
+ Import @perl.imp
+ $(EXPORTS)
+ File $(X2P_OBJ:.obj=,) .\$(BLDDIR)\clibstuf.obj
+ <<KEEP
+ !else
+ !ifdef CODEWARRIOR
+ # Linker definitions and lining come here for CODEWARRIOR
+ !endif
+ !endif
+
+ $(EXTDIR)\DynaLoader\dl_netware.xs: dl_netware.xs
+ copy dl_netware.xs $(EXTDIR)\DynaLoader\dl_netware.xs
+
+ HEADERS :
+ @echo . . . . making stdio.h and string.h
+ @copy << stdio.h >\nul
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : stdio.h
+ * DESCRIPTION : Generated header file, do not edit. See makefile.
+ * This header file causes the includer to use clibstuf.h
+ * The purpose of clibstuf is to make sure that Perl, cgi2perl and
+ * all the perl extension nlm's (*.NLP) use the Novell Netware CLIB versions
+ * of standard functions. This code loads up a whole bunch of function pointers
+ * to point at the standard CLIB functions.
+ * Author : HYAK
+ * Date : January 2001.
+ *
+ */
+
+
+ #ifndef __Stdio_H__
+ #define __Stdio_H__
+
+
+ #include "$(NLMSDKBASE)\INCLUDE\NLM\stdio.h"
+ #include "clibsdio.h"
+
+
+ #endif // __Stdio_H__
+
+ <<
+ @copy stdio.h $(COREDIR)
+
+ @copy << string.h >\nul
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : string.h
+ * DESCRIPTION : Generated header file, do not edit. See makefile.
+ * This header file causes the includer to use clibstuf.h
+ * The purpose of clibstuf is to make sure that Perl, cgi2perl and
+ * all the perl extension nlm's (*.NLP) use the Novell Netware CLIB versions
+ * of standard functions. This code loads up a whole bunch of function pointers
+ * to point at the standard CLIB functions.
+ * Author : HYAK
+ * Date : January 2001.
+ *
+ */
+
+
+ #ifndef __String_H__
+ #define __String_H__
+
+
+ #include "$(NLMSDKBASE)\INCLUDE\NLM\string.h"
+ #include "clibstr.h"
+
+
+ #endif // __String_H__
+
+ <<
+ @copy string.h $(COREDIR)
+
+
+ $(NLM_NAME): MESSAGE HEADERS $(BLDDIR)\nul $(NLM_OBJ) $(NEWTARE_OBJ_DEP) $(PERL_IO_OBJ_DEP) $(PERL_LIB_OBJ_DEP) $(DLL_OBJ) .XDC $(PERLIMPLIB) $(EXT_MAIN_OBJ)
+ @echo======= Linking $@ at $(MAKEDIR)\$(BLDDIR) =======
+ !ifdef WATCOM
+ @$(NLM_LINK) @<<$(BLDDIR)\$*.link
+ Form Novell NLM '$(NLM_DESCRIPTION)'
+ Name $(BUILT)
+ Option Quiet
+ Option Version = $(NLM_VERSION)
+ Option Copyright '$(COPYRIGHT)'
+ Option Caseexact
+ Option Map=$(BLDDIR)\$(NLM_NAME8).map, Verbose, screenname $(SCREEN)
+ Option Stack=1000
+ !ifdef NLM_NAME8
+ Option SYMFILE=$(BLDDIR)\$(NLM_NAME8).sym
+ !ifdef USE_XDC
+ OPTION XDCDATA=$(BLDDIR)\$(NLM_NAME8).xdc
+ !endif
+ !else
+ Option SYMFILE=$(BLDDIR)\$(NLM_NAME).sym
+ !ifdef USE_XDC
+ OPTION XDCDATA=$(BLDDIR)\$(NLM_NAME).xdc
+ !endif
+ !endif
+ Option NoDefaultLibs
+ $(EXTRA_LINK_OPTION)
+ !if "$(MAKE_TYPE)"=="Debug"
+ # Debug all
+ Debug novell
+ Debug codeview
+ !endif
+ LibPath $(LIBPATH)
+ $(BASE_LIBRARIES)
+ Module clib
+ $(BASE_IMPORT_FNS)
+ $(BASE_IMPORT_FILES)
+ $(ADD_IMPORT_FNS)
+ Import @perl.imp
+ $(EXPORTS)
+ File $(NEWTARE_OBJ_DEP:.obj=.obj,) $(NLM_OBJ:.obj=.obj,) $(PERL_IO_OBJ_DEP:.obj=.obj,) $(PERL_LIB_OBJ_DEP:.obj=.obj,) $(DLL_OBJ:.obj=.obj,)
+ <<KEEP
+ !else
+ !ifdef CODEWARRIOR
+ # Linker definitions and lining come here for CODEWARRIOR
+ !endif
+ !endif
+ copy ..\win32\splittree.pl ..
+ $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR)
+
+
+ !if "$(MAKE_TYPE)"=="Debug"
+ !ifdef NLM_NAME8
+ .\bat\cvpack $(BLDDIR)\$(NLM_NAME8).sym
+ !else
+ .\bat\cvpack $(BLDDIR)\$(NLM_NAME).sym
+ !endif
+ !endif
+
+ @echo======= Finished building $(BUILT).
+
+ # Create the debug\release directory if not existing
+ $(BLDDIR)\nul:
+ @echo . . . . mkdir $(BLDDIR)
+ @mkdir $(BLDDIR)
+
+ MESSAGE:
+ @echo======= $(MAKE_ACTION)ing $(NLM_NAME) at $(MAKEDIR)\$(BLDDIR) =======
+
+ .XDC:
+ !ifdef USE_XDC
+ @echo======= Creating XDC file
+ !ifdef NLM_NAME8
+ $(MPKTOOL) $(XDCFLAGS) $(BLDDIR)\$(NLM_NAME8).xdc
+ !else
+ $(MPKTOOL) $(XDCFLAGS) $(BLDDIR)\$(NLM_NAME).xdc
+ !endif
+ !endif
+
+ $(PERLIMPLIB): perllib.def
+ $(NLM_LIB) -def:perllib.def -out:$(PERLIMPLIB)
+ $(XCOPY) $(PERLIMPLIB) $(COREDIR)
+
+ perllib.def : $(MINIPERL) $(CONFIGPM) ..\global.sym ..\pp.sym ..\makedef.pl
+ $(MINIPERL) -w ..\makedef.pl PLATFORM=netware FILETYPE=def $(BS_CFLAGS) $(DEFINES) $(ADD_BUILDOPT) \
+ CCTYPE=$(CCTYPE) > perllib.def
+ $(MINIPERL) -w ..\makedef.pl PLATFORM=netware FILETYPE=imp $(BS_CFLAGS) $(DEFINES) $(ADD_BUILDOPT) \
+ CCTYPE=$(CCTYPE) > perl.imp
+
+ $(DLL_OBJ) : $(DYNALOADER).c $(CORE_H) $(EXTDIR)\DynaLoader\dlutils.c
+ @echo $(MPKMESSAGE)...$(BLDMESG)...$@
+ @$(C_COMPILER) @<<$(BLDDIR)\$(*F).options
+ $(NLM_INCLUDES) -I$(EXTDIR)\DynaLoader\ $(COMPLER_FLAGS) $(ADD_LOCDEFS) $(OBJOUT_FLAG)$@ $(ERROR_FLAG)$(BLDDIR)\$(*F).err $(EXTDIR)\DynaLoader\$(*F).c
+ <<KEEP
+
+ $(DYNALOADER).c : $(MINIPERL) $(EXTDIR)\DynaLoader\dl_netware.xs $(CONFIGPM)
+ if not exist $(AUTODIR) mkdir $(AUTODIR)
+ cd $(EXTDIR)\$(*B)
+ ..\$(MINIPERL) -I..\..\lib $(*B)_pm.PL
+ ..\$(MINIPERL) -I..\..\lib XSLoader_pm.PL
+ cd ..\..\netware
+ $(XCOPY) $(EXTDIR)\$(*B)\$(*B).pm $(LIBDIR)\$(NULL)
+ $(XCOPY) $(EXTDIR)\$(*B)\XSLoader.pm $(LIBDIR)\$(NULL)
+ cd $(EXTDIR)\$(*B)
+ $(XSUBPP) dl_netware.xs > $(*B).c
+ cd ..\..\netware
+
+ $(PERL_LIB_OBJ_DEP) : $(NW_HOST_H_FILES) $(*F).c
+ @echo $(MPKMESSAGE)...$(BLDMESG)...$@
+ @$(CPP_COMPILER) @<<$(BLDDIR)\$(*F).options
+ -I.. $(NLM_INCLUDES) $(COMPLER_FLAGS) $(ADD_LOCDEFS) $(OBJOUT_FLAG)$@ $(ERROR_FLAG)$*.err $(*F).c
+ <<KEEP
+
+ $(PERL_IO_OBJ_DEP) : ..\$(*F).c
+ @echo $(MPKMESSAGE) $(BLDMESG) $@
+ @$(C_COMPILER) @<<$(BLDDIR)\$(*F).options
+ $(NLM_INCLUDES) $(COMPLER_FLAGS) $(ADD_LOCDEFS) $(OBJOUT_FLAG)$@ $(ERROR_FLAG)$*.err ..\$(*F).c
+ <<KEEP
+
+ $(NLM_OBJ) : ..\$(*F).c
+ @echo $(MPKMESSAGE) $(BLDMESG) $@
+ @$(C_COMPILER) @<<$(BLDDIR)\$(*F).options
+ $(NLM_INCLUDES) $(COMPLER_FLAGS) $(ADD_LOCDEFS) $(OBJOUT_FLAG)$@ $(ERROR_FLAG)$*.err ..\$(*F).c
+ <<KEEP
+
+ $(NEWTARE_OBJ_DEP) : $(NW_H_FILES) $(NW_HOST_H_FILES) $(*F).c
+ @echo $(MPKMESSAGE) $(BLDMESG) $@
+ @$(C_COMPILER) @<<$(BLDDIR)\$(*F).options
+ $(NLM_INCLUDES) $(COMPLER_FLAGS) $(ADD_LOCDEFS) $(OBJOUT_FLAG)$@ $(ERROR_FLAG)$*.err $(*F).c
+ <<KEEP
+
+ $(EXT_MAIN_OBJ) : $(CLIB_H_FILES)
+ @echo $(MPKMESSAGE) $(BLDMESG) $@
+ @$(C_COMPILER) @<<$(BLDDIR)\$(*F).options
+ $(NLM_INCLUDES) $(COMPLER_FLAGS) $(ADD_LOCDEFS) $(OBJOUT_FLAG)$@ $(ERROR_FLAG)$*.err $(*F).c
+ <<KEEP
+ $(NLM_LIB) $@ $(NLMIMPORTS)\prelude.obj -out:$*.lib
+ @copy $*.lib $(COREDIR)
+
+ # Delete any files that might have got created during building miniperl.exe
+ # config.sh will definitely be created
+ # COREDIR might have got created
+ .cleanoldfiles :
+ -del ..\config.sh
+ -del .\Main.obj
+ -del .\Main.lib
+ -rmdir /s /q $(AUTODIR)
+ -rmdir /s /q $(COREDIR)
+
+ .\nwconfig.h : $(NW_CFGH_TMPL)
+ -del /f config.h
+ copy $(NW_CFGH_TMPL) config.h
+
+ # REQUIRED WHEN WE INCLUDE CONFIGPM OR REGEN_CONFIG - sgp
+ #..\nwconfig.sh : config.nw5 $(MINIPERL) config_sh.PL
+ # $(MINIPERL) -I..\lib config_sh.PL $(NW_CFG_VARS) config.nw5 > ..\config.sh
+ # @pause
+ # cd ..
+ # del config.sh
+ # rename nwconfig.sh config.sh
+ # cd netware
+
+ config.nw5 : $(NW_CFGSH_TMPL)
+ copy $(NW_CFGSH_TMPL) config.nw5
+
+ $(SOCKET_NLP): $(NLM_NAME) $(SOCKET).xs
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\netware
+
+ $(FCNTL_NLP):
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\netware
+
+ $(IO_NLP):
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\netware
+
+ $(OPCODE_NLP):
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\netware
+
+ $(B_NLP):
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\netware
+
+ $(DUMPER_NLP):
+ cd $(EXTDIR)\Data\$(*B)
+ ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\..\netware
+
+ $(PEEK_NLP):
+ cd $(EXTDIR)\Devel\$(*B)
+ ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\..\netware
+
+ $(RE_NLP):
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\netware
+
+ $(BYTELOADER_NLP):
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\netware
+
+ $(DPROF_NLP):
+ cd $(EXTDIR)\Devel\$(*B)
+ ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\..\netware
+
+ $(GLOB_NLP):
+ cd $(EXTDIR)\File\$(*B)
+ ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\..\netware
+
+ $(POSIX_NLP):
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\netware
+
+ $(THREAD_NLP):
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\netware
+
+ $(ATTRS_NLP):
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\netware
+
+ $(SDBM_FILE_NLP):
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\netware
+
+ $(CWD_NLP):
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\netware
+
+ $(STORABLE_NLP):
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\netware
+
+ $(LISTUTIL_NLP):
+ cd $(EXTDIR)\List\$(*B)
+ ..\..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\..\netware
+
+ $(MIMEBASE64_NLP):
+ cd $(EXTDIR)\Mime\$(*B)
+ ..\..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\..\netware
+
+ $(XSTYPEMAP_NLP):
+ cd $(EXTDIR)\XS\$(*B)
+ ..\..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\..\netware
+
+ $(ERRNO_PM_NW):
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\netware
+
+ $(ECHO_SRC_OBJ): $*.c
+ @echo $(MPKMESSAGE) $(BLDMESG) $@
+ @$(C_COMPILER) @<<$*.options
+ $(NLM_INCLUDES) $(COMPLER_FLAGS) $(ADD_LOCDEFS) $(OBJOUT_FLAG)$@ $(ERROR_FLAG)$*.err $*.c
+ <<KEEP
+
+ $(ECHO_NLM): $(ECHO_SRC_OBJ)
+ @echo======= Linking $@ =======
+ !ifdef USE_XDC
+ $(MPKTOOL) $(XDCFLAGS) $*.xdc
+ !endif
+ !ifdef WATCOM
+ @$(NLM_LINK) @<<$*.link
+ Form Novell NLM 'DOS echo emulation for Perl Testing' Name $@
+ Option Quiet Option Version = $(NLM_VERSION) Option Copyright '$(COPYRIGHT)' Option Caseexact Option Map=$*.map, Verbose, screenname 'System Console' Option Stack=1000 Option SYMFILE=$*.sym Option NoDefaultLibs
+ !ifdef USE_XDC
+ OPTION XDCDATA=$*.xdc
+ !endif
+ $(EXTRA_LINK_OPTION)
+ !if "$(MAKE_TYPE)"=="Debug"
+ Debug novell
+ Debug codeview
+ !endif
+ LibPath $(LIBPATH)
+ $(BASE_LIBRARIES) Module clib $(BASE_IMPORT_FNS) $(BASE_IMPORT_FILES) $(ADD_IMPORT_FNS)
+ Import @perl.imp
+ $(EXPORTS)
+ File $(ECHO_SRC_OBJ:.obj=.obj,) .\$(BLDDIR)\clibstuf.obj
+ <<KEEP
+ !else
+ !ifdef CODEWARRIOR
+ # Linker definitions and lining come here for CODEWARRIOR
+ !endif
+ !endif
+ @echo======= Linking Complete =======
+
+ $(TYPE_SRC_OBJ): $*.c
+ @echo $(MPKMESSAGE) $(BLDMESG) $@
+ @$(C_COMPILER) @<<$*.options
+ $(NLM_INCLUDES) $(COMPLER_FLAGS) $(ADD_LOCDEFS) $(OBJOUT_FLAG)$@ $(ERROR_FLAG)$*.err $*.c
+ <<KEEP
+
+ $(TYPE_NLM): $(TYPE_SRC_OBJ)
+ @echo======= Linking $@ =======
+ !ifdef USE_XDC
+ $(MPKTOOL) $(XDCFLAGS) $*.xdc
+ !endif
+ !ifdef WATCOM
+ @$(NLM_LINK) @<<$*.link
+ Form Novell NLM 'DOS type emulation for Perl Testing' Name $@
+ Option Quiet Option Version = $(NLM_VERSION) Option Copyright '$(COPYRIGHT)' Option Caseexact Option Map=$*.map, Verbose, screenname 'System Console' Option Stack=1000 Option SYMFILE=$*.sym
+ !ifdef USE_XDC
+ OPTION XDCDATA=$*.xdc
+ !endif
+ Option NoDefaultLibs
+ $(EXTRA_LINK_OPTION)
+ !if "$(MAKE_TYPE)"=="Debug"
+ Debug novell
+ Debug codeview
+ !endif
+ LibPath $(LIBPATH)
+ $(BASE_LIBRARIES) Module clib $(BASE_IMPORT_FNS) $(BASE_IMPORT_FILES) $(ADD_IMPORT_FNS)
+ Import @perl.imp
+ $(EXPORTS)
+ File $(TYPE_SRC_OBJ:.obj=.obj,) .\$(BLDDIR)\clibstuf.obj
+ <<KEEP
+ !else
+ !ifdef CODEWARRIOR
+ # Linker definitions and lining come here for CODEWARRIOR
+ !endif
+ !endif
+ @echo======= Linking Complete =======
+
+ # Build NetWare specific extensions
+ $(CGI2PERL_NLP):
+ !if "$(NW_EXTNS)"=="yes"
+ cd $(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\netware
+ !endif
+
+ $(PERL2UCS_NLP):
+ !if "$(NW_EXTNS)"=="yes"
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\netware
+ !endif
+
+ nwclean:
+ -rmdir /s /q $(REL_DIR) || rmdir /s $(REL_DIR)
+ -rmdir /s /q $(DEB_DIR) || rmdir /s $(DEB_DIR)
+ @if exist .\stdio.h del .\stdio.h
+ @if exist .\string.h del .\string.h
+ @if exist .\Main.obj del .\Main.obj
+ @if exist .\Main.lib del .\Main.lib
+ cd testnlm\echo
+ -del *.obj *.map *.link *.options *.nlm *.sym *.xdc *.err
+ cd ..\type
+ -del *.obj *.map *.link *.options *.nlm *.sym *.xdc *.err
+ cd ..\..\
+
+ utils: $(BLDDIR)\$(NLM_NAME8).$(NLM_EXT) $(X2P)
+ cd ..\utils
+ $(MAKE) PERL=$(MINIPERL)
+ cd ..\pod
+ copy ..\README.amiga .\perlamiga.pod
+ copy ..\README.cygwin .\perlcygwin.pod
+ copy ..\README.dos .\perldos.pod
+ copy ..\README.hpux .\perlhpux.pod
+ # copy ..\README.machten .\perlmachten.pod
+ copy ..\README.os2 .\perlos2.pod
+ copy ..\vms\perlvms.pod .\perlvms.pod
+ copy ..\README.win32 .\perlwin32.pod
+ copy ..\README.netware .\perlnw5.pod
+ $(MAKE) -f ..\win32\pod.mak converters
+ cd ..\netware
+ $(MINIPERL) $(PL2BAT) $(UTILS)
+
+ distclean: clean nwclean
+ -del /f $(PERLIMPLIB) ..\miniperl.lib $(MINIMOD)
+ -del /f *.def *.map
+ -del /f $(EXTENSION_C) $(DYNALOADER).c $(ERRNO).pm
+ -del /f $(EXTDIR)\DynaLoader\dl_netware.xs
+ -del /f $(LIBDIR)\.exists $(LIBDIR)\attrs.pm $(LIBDIR)\DynaLoader.pm
+ -del /f $(LIBDIR)\XSLoader.pm
+ -del /f $(LIBDIR)\Fcntl.pm $(LIBDIR)\IO.pm $(LIBDIR)\Opcode.pm
+ -del /f $(LIBDIR)\ops.pm $(LIBDIR)\Safe.pm $(LIBDIR)\Thread.pm
+ -del /f $(LIBDIR)\SDBM_File.pm $(LIBDIR)\Socket.pm $(LIBDIR)\POSIX.pm
+ -del /f $(LIBDIR)\B.pm $(LIBDIR)\O.pm $(LIBDIR)\re.pm
+ -del /f $(LIBDIR)\Data\Dumper.pm $(LIBDIR)\ByteLoader.pm
+ -del /f $(LIBDIR)\Devel\Peek.pm $(LIBDIR)\Devel\DProf.pm
+ -del /f $(LIBDIR)\File\Glob.pm
+ -rmdir /s /q $(LIBDIR)\IO || rmdir /s $(LIBDIR)\IO
+ -rmdir /s /q $(LIBDIR)\Thread || rmdir /s $(LIBDIR)\Thread
+ -rmdir /s /q $(LIBDIR)\B || rmdir /s $(LIBDIR)\B
+ -rmdir /s /q $(LIBDIR)\Data || rmdir /s $(LIBDIR)\Data
+ -del /f $(PODDIR)\*.html
+ -del /f $(PODDIR)\*.bat
+ cd ..\utils
+ -del /f h2ph splain perlbug pl2pm c2ph h2xs perldoc dprofpp
+ -del /f *.bat
+ cd ..\netware
+ cd ..\x2p
+ -del /f find2perl s2p
+ -del /f *.bat
+ -del *.obj *.map *.link *.xdc *.err
+ cd ..\netware
+ -del /f ..\config.sh ..\splittree.pl dlutils.c config.h.new
+ -del /f $(CONFIGPM)
+ -del /f bin\*.bat
+ cd $(EXTDIR)
+ -del /s *.lib *.def *.map *.pdb *.bs Makefile *$(o) pm_to_blib *.xdc *.err
+ cd ..\netware
+ !if "$(NW_EXTNS)"=="yes"
+ cd cgi2perl
+ -del *.obj *.bs Makefile *$(o) *.c pm_to_blib *.xdc *.err *.sym *.map
+ cd ..
+ cd $(EXTDIR)\Perl2UCS
+ -del *.obj *.bs Makefile *$(o) *.c pm_to_blib *.xdc *.err *.sym *.map *.c
+ cd ..\..\netware
+ !endif
+ -rmdir /s /q $(AUTODIR) || rmdir /s $(AUTODIR)
+ -rmdir /s /q $(COREDIR) || rmdir /s $(COREDIR)
+ -del ..\config.sh
+
+ installwin:
+ $(MINIPERL) -I..\lib ..\installperl
+
+ install : utils installwin
+
+ installnw:
+ $(MINIPERL) -I..\lib ..\installperl -netware
+
+ install_tests :
+ cd ..\t
+ xcopy /f /r /i /s /d *.* $(INST_NW_TOP2)\scripts\t
+ cd ..\lib
+ xcopy /f /r /i /s /d *.t $(INST_NW_TOP2)\scripts\t\lib
+ cd ..\ext
+ xcopy /f /r /i /s /d *.t $(INST_NW_TOP2)\scripts\t\ext
+ cd ..\netware\t
+ xcopy /f /r /i /s /d *.pl $(INST_NW_TOP2)\scripts\t
+ cd ..
+
+ nwinstall: utils installnw install_tests
+
+ inst_lib : $(CONFIGPM)
+ copy ..\win32\splittree.pl ..
+ $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR)
+ $(RCOPY) ..\lib $(INST_LIB)\*.*
+
+ clean :
+ -@erase miniperlmain$(o)
+ -@erase /f config.h
+ -@erase $(DLL_OBJ)
+ -@erase ..\*$(o) ..\*.lib ..\*.exp *$(o) *.lib *.exp *.res
+ -@erase ..\t\*.exe ..\t\*.dll ..\t\*.bat
+ -@erase ..\x2p\*.nlm ..\x2p\*.bat
+
diff -c /dev/null 'perl-5.7.2/NetWare/NWTInfo.c'
Index: ./NetWare/NWTInfo.c
*** ./NetWare/NWTInfo.c Thu Jan 1 02:00:00 1970
--- ./NetWare/NWTInfo.c Mon Jul 9 17:09:39 2001
***************
*** 0 ****
--- 1,720 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : NWTInfo.c
+ * DESCRIPTION : Thread-local storage for Perl.
+ * The thread's information is stored in a hashed table that is based on
+ * the lowest 5 bits of the current thread ID.
+ * Author : SGP, HYAK
+ * Date : January 2001.
+ *
+ */
+
+
+
+ #include "win32ish.h" // For "BOOL", "TRUE" and "FALSE"
+ #include "nwtinfo.h"
+
+ #ifdef MPK_ON
+ #include <mpktypes.h>
+ #include <mpkapis.h>
+ #else
+ #include <nwsemaph.h>
+ #endif //MPK_ON
+
+ // Number of entries in the hashtable
+ //
+ #define NUM_ENTRIES 32 /* 2^5 */
+
+
+ // macro to calculate the hash index for a given Thread ID
+ //
+ #define INDEXOF(tid) ((tid) & 0x1f)
+
+
+ // Semaphore to control access to global linked list
+ //
+ #ifdef MPK_ON
+ static SEMAPHORE g_tinfoSem = NULL;
+ static SEMAPHORE g_tCtxSem = NULL;
+ #else
+ static LONG g_tinfoSem = 0L;
+ static LONG g_tCtxSem = 0L;
+ #endif //MPK_ON
+
+ // Hash table of thread information structures
+ //
+ ThreadInfo* g_ThreadInfo[NUM_ENTRIES];
+ ThreadContext* g_ThreadCtx;
+
+
+
+ /*============================================================================================
+
+ Function : fnTerminateThreadInfo
+
+ Description : This function undoes fnInitializeThreadInfo; call once per NLM instance.
+
+ Parameters : None.
+
+ Returns : Boolean.
+
+ ==============================================================================================*/
+
+ BOOL fnTerminateThreadInfo(void)
+ {
+ int index = 0;
+
+ if (g_tinfoSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreWait(g_tinfoSem);
+ #else
+ WaitOnLocalSemaphore(g_tinfoSem);
+ #endif //MPK_ON
+ for (index = 0; index < NUM_ENTRIES; index++)
+ {
+ if (g_ThreadInfo[index] != NULL)
+ {
+ #ifdef MPK_ON
+ kSemaphoreSignal(g_tinfoSem);
+ #else
+ SignalLocalSemaphore(g_tinfoSem);
+ #endif //MPK_ON
+ return FALSE;
+ }
+ }
+ #ifdef MPK_ON
+ kSemaphoreFree(g_tinfoSem);
+ g_tinfoSem = NULL;
+ #else
+ CloseLocalSemaphore(g_tinfoSem);
+ g_tinfoSem = 0;
+ #endif //MPK_ON
+ }
+
+ return TRUE;
+ }
+
+
+ /*============================================================================================
+
+ Function : fnInitializeThreadInfo
+
+ Description : Initializes the global ThreadInfo hashtable and semaphore.
+ Call once per NLM instance
+
+ Parameters : None.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnInitializeThreadInfo(void)
+ {
+ int index = 0;
+
+ if (g_tinfoSem)
+ return;
+
+ #ifdef MPK_ON
+ g_tinfoSem = kSemaphoreAlloc((BYTE *)"threadInfo", 1);
+ #else
+ g_tinfoSem = OpenLocalSemaphore(1);
+ #endif //MPK_ON
+
+
+ for (index = 0; index < NUM_ENTRIES; index++)
+ g_ThreadInfo[index] = NULL;
+
+ return;
+ }
+
+
+ /*============================================================================================
+
+ Function : fnRegisterWithThreadTable
+
+ Description : This function registers/adds a new thread with the thread table.
+
+ Parameters : None.
+
+ Returns : Boolean.
+
+ ==============================================================================================*/
+
+ BOOL fnRegisterWithThreadTable(void)
+ {
+ ThreadInfo* tinfo = NULL;
+
+ #ifdef MPK_ON
+ tinfo = fnAddThreadInfo(labs((int)kCurrentThread()));
+ #else
+ tinfo = fnAddThreadInfo(GetThreadID());
+ #endif //MPK_ON
+
+ if (!tinfo)
+ return FALSE;
+ else
+ return TRUE;
+ }
+
+
+ /*============================================================================================
+
+ Function : fnUnregisterWithThreadTable
+
+ Description : This function unregisters/removes a thread from the thread table.
+
+ Parameters : None.
+
+ Returns : Boolean.
+
+ ==============================================================================================*/
+
+ BOOL fnUnregisterWithThreadTable(void)
+ {
+ #ifdef MPK_ON
+ return fnRemoveThreadInfo(labs((int)kCurrentThread()));
+ #else
+ return fnRemoveThreadInfo(GetThreadID());
+ #endif //MPK_ON
+ }
+
+
+ /*============================================================================================
+
+ Function : fnAddThreadInfo
+
+ Description : Adds a new ThreadInfo for the requested thread.
+
+ Parameters : tid (IN) - ID of the thread.
+
+ Returns : Pointer to the ThreadInfo Structure.
+
+ ==============================================================================================*/
+
+ ThreadInfo* fnAddThreadInfo(int tid)
+ {
+ ThreadInfo* tip = NULL;
+ int index = 0;
+
+ if (g_tinfoSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreWait(g_tinfoSem);
+ #else
+ WaitOnLocalSemaphore(g_tinfoSem);
+ #endif //MPK_ON
+ }
+
+ // Add a new one to the beginning of the hash entry
+ //
+ tip = (ThreadInfo *) malloc(sizeof(ThreadInfo));
+ if (tip == NULL)
+ {
+ if (g_tinfoSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreSignal(g_tinfoSem);
+ #else
+ SignalLocalSemaphore(g_tinfoSem);
+ #endif //MPK_ON
+ }
+ return NULL;
+ }
+ index = INDEXOF(tid); // just take the bottom five bits
+ tip->next = g_ThreadInfo[index];
+ tip->tid = tid;
+ tip->m_dontTouchHashLists = FALSE;
+ tip->m_allocList = NULL;
+
+ g_ThreadInfo [index] = tip;
+ if (g_tinfoSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreSignal(g_tinfoSem);
+ #else
+ SignalLocalSemaphore(g_tinfoSem);
+ #endif //MPK_ON
+ }
+
+ return tip;
+ }
+
+
+ /*============================================================================================
+
+ Function : fnRemoveThreadInfo
+
+ Description : Frees the specified thread info structure and removes it from the
+ global linked list.
+
+ Parameters : tid (IN) - ID of the thread.
+
+ Returns : Boolean.
+
+ ==============================================================================================*/
+
+ BOOL fnRemoveThreadInfo(int tid)
+ {
+ ThreadInfo* tip = NULL;
+ ThreadInfo* prevt = NULL;
+ int index = INDEXOF(tid); // just take the bottom five bits
+
+ if (g_tinfoSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreWait(g_tinfoSem);
+ #else
+ WaitOnLocalSemaphore(g_tinfoSem);
+ #endif //MPK_ON
+ }
+
+ for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next)
+ {
+ if (tip->tid == tid)
+ {
+ if (prevt == NULL)
+ g_ThreadInfo[index] = tip->next;
+ else
+ prevt->next = tip->next;
+
+ free(tip);
+ tip=NULL;
+ if (g_tinfoSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreSignal(g_tinfoSem);
+ #else
+ SignalLocalSemaphore(g_tinfoSem);
+ #endif //MPK_ON
+ }
+
+ return TRUE;
+ }
+ prevt = tip;
+ }
+
+ if (g_tinfoSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreSignal(g_tinfoSem);
+ #else
+ SignalLocalSemaphore(g_tinfoSem);
+ #endif //MPK_ON
+ }
+
+ return FALSE; // entry not found
+ }
+
+
+ /*============================================================================================
+
+ Function : fnGetThreadInfo
+
+ Description : Returns the thread info for the given thread ID or NULL if not successful.
+
+ Parameters : tid (IN) - ID of the thread.
+
+ Returns : Pointer to the ThreadInfo Structure.
+
+ ==============================================================================================*/
+
+ ThreadInfo* fnGetThreadInfo(int tid)
+ {
+ ThreadInfo* tip;
+ int index = INDEXOF(tid); // just take the bottom five bits
+
+ if (g_tinfoSem) {
+ #ifdef MPK_ON
+ kSemaphoreWait(g_tinfoSem);
+ #else
+ WaitOnLocalSemaphore(g_tinfoSem);
+ #endif //MPK_ON
+ }
+
+ // see if this is already in the table at the index'th offset
+ //
+ for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next)
+ {
+ if (tip->tid == tid)
+ {
+ if (g_tinfoSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreSignal(g_tinfoSem);
+ #else
+ SignalLocalSemaphore(g_tinfoSem);
+ #endif //MPK_ON
+ }
+ return tip;
+ }
+ }
+
+ if (g_tinfoSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreSignal(g_tinfoSem);
+ #else
+ SignalLocalSemaphore(g_tinfoSem);
+ #endif //MPK_ON
+ }
+
+ return NULL;
+ }
+
+ BOOL fnInsertHashListAddrs(void *addrs, BOOL dontTouchHashList)
+ {
+ ThreadInfo* tip;
+ int index,tid;
+
+ if (g_tinfoSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreWait(g_tinfoSem);
+ #else
+ WaitOnLocalSemaphore(g_tinfoSem);
+ #endif //MPK_ON
+ }
+
+ #ifdef MPK_ON
+ tid=index = abs(kCurrentThread());
+ #else
+ tid=index = GetThreadID();
+ #endif //MPK_ON
+
+ index = INDEXOF(index); // just take the bottom five bits
+
+ // see if this is already in the table at the index'th offset
+ //
+ for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next)
+ {
+ if (tip->tid == tid)
+ {
+ if (g_tinfoSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreSignal(g_tinfoSem);
+ #else
+ SignalLocalSemaphore(g_tinfoSem);
+ #endif //MPK_ON
+ }
+ tip->m_allocList = addrs;
+ tip->m_dontTouchHashLists = dontTouchHashList;
+ return TRUE;
+ }
+ }
+
+ if (g_tinfoSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreSignal(g_tinfoSem);
+ #else
+ SignalLocalSemaphore(g_tinfoSem);
+ #endif //MPK_ON
+ }
+
+ return FALSE;
+ }
+
+ BOOL fnGetHashListAddrs(void **addrs, BOOL *dontTouchHashList)
+ {
+ ThreadInfo* tip;
+ int index,tid;
+
+ if (g_tinfoSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreWait(g_tinfoSem);
+ #else
+ WaitOnLocalSemaphore(g_tinfoSem);
+ #endif //MPK_ON
+ }
+
+ #ifdef MPK_ON
+ tid=index = abs(kCurrentThread());
+ #else
+ tid=index = GetThreadID();
+ #endif //MPK_ON
+
+ index = INDEXOF(index); // just take the bottom five bits
+
+ // see if this is already in the table at the index'th offset
+ //
+ for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next)
+ {
+ if (tip->tid == tid)
+ {
+ if (g_tinfoSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreSignal(g_tinfoSem);
+ #else
+ SignalLocalSemaphore(g_tinfoSem);
+ #endif //MPK_ON
+ }
+ *addrs = tip->m_allocList;
+ *dontTouchHashList = tip->m_dontTouchHashLists;
+ return TRUE;
+ }
+ }
+
+ if (g_tinfoSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreSignal(g_tinfoSem);
+ #else
+ SignalLocalSemaphore(g_tinfoSem);
+ #endif //MPK_ON
+ }
+
+ return FALSE;
+ }
+
+
+ /*============================================================================================
+
+ Function : fnInitializeThreadCtx
+
+ Description : Initialises the thread context.
+
+ Parameters : None.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ long fnInitializeThreadCtx(void)
+ {
+ int index = 0;
+ //long tid;
+
+ if (!g_tCtxSem) {
+ #ifdef MPK_ON
+ g_tCtxSem = kSemaphoreAlloc((BYTE *)"threadCtx", 1);
+ #else
+ g_tCtxSem = OpenLocalSemaphore(1);
+ #endif //MPK_ON
+
+ g_ThreadCtx =NULL;
+ }
+
+ return 0l;
+ }
+
+
+ /*============================================================================================
+
+ Function : fnAddThreadCtx
+
+ Description : Add a new thread context.
+
+ Parameters : lTLSIndex (IN) - Index
+ t (IN) - void pointer.
+
+ Returns : Pointer to ThreadContext structure.
+
+ ==============================================================================================*/
+
+ ThreadContext* fnAddThreadCtx(long lTLSIndex, void *t)
+ {
+ ThreadContext* tip = NULL;
+ ThreadContext* temp = NULL;
+
+ if (g_tCtxSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreWait(g_tCtxSem);
+ #else
+ WaitOnLocalSemaphore(g_tCtxSem);
+ #endif //MPK_ON
+ }
+
+ // add a new one to the beginning of the list
+ //
+ tip = (ThreadContext *) malloc(sizeof(ThreadContext));
+ if (tip == NULL)
+ {
+ if (g_tCtxSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreSignal(g_tCtxSem);
+ #else
+ SignalLocalSemaphore(g_tCtxSem);
+ #endif //MPK_ON
+ }
+ return NULL;
+ }
+
+ #ifdef MPK_ON
+ lTLSIndex = labs(kCurrentThread());
+ #else
+ lTLSIndex = GetThreadID();
+ #endif //MPK_ON
+
+ tip->next = NULL;
+ tip->tid = lTLSIndex;
+ tip->tInfo = t;
+
+ if(g_ThreadCtx==NULL) {
+ g_ThreadCtx = tip;
+ } else {
+ int count=0;
+ //Traverse to the end
+ temp = g_ThreadCtx;
+ while(temp->next != NULL)
+ {
+ temp = temp->next;
+ count++;
+ }
+ temp->next = tip;
+ }
+
+ if (g_tCtxSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreSignal(g_tCtxSem);
+ #else
+ SignalLocalSemaphore(g_tCtxSem);
+ #endif //MPK_ON
+ }
+ return tip;
+ }
+
+
+ /*============================================================================================
+
+ Function : fnRemoveThreadCtx
+
+ Description : Removes a thread context.
+
+ Parameters : lTLSIndex (IN) - Index
+
+ Returns : Boolean.
+
+ ==============================================================================================*/
+
+ BOOL fnRemoveThreadCtx(long lTLSIndex)
+ {
+ ThreadContext* tip = NULL;
+ ThreadContext* prevt = NULL;
+
+ if (g_tCtxSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreWait(g_tCtxSem);
+ #else
+ WaitOnLocalSemaphore(g_tCtxSem);
+ #endif //MPK_ON
+ }
+
+ #ifdef MPK_ON
+ lTLSIndex = labs(kCurrentThread());
+ #else
+ lTLSIndex = GetThreadID();
+ #endif //MPK_ON
+
+ tip = g_ThreadCtx;
+ while(tip) {
+ if (tip->tid == lTLSIndex) {
+ if (prevt == NULL)
+ g_ThreadCtx = tip->next;
+ else
+ prevt->next = tip->next;
+
+ free(tip);
+ tip=NULL;
+ if (g_tCtxSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreSignal(g_tCtxSem);
+ #else
+ SignalLocalSemaphore(g_tCtxSem);
+ #endif //MPK_ON
+ }
+ return TRUE;
+ }
+ prevt = tip;
+ tip = tip->next;
+ }
+
+ if (g_tCtxSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreSignal(g_tCtxSem);
+ #else
+ SignalLocalSemaphore(g_tCtxSem);
+ #endif //MPK_ON
+ }
+
+ return FALSE; // entry not found
+ }
+
+
+ /*============================================================================================
+
+ Function : fnGetThreadCtx
+
+ Description : Get a thread context.
+
+ Parameters : lTLSIndex (IN) - Index
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void* fnGetThreadCtx(long lTLSIndex)
+ {
+ ThreadContext* tip;
+
+ if (g_tCtxSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreWait(g_tCtxSem);
+ #else
+ WaitOnLocalSemaphore(g_tCtxSem);
+ #endif //MPK_ON
+ }
+
+ #ifdef MPK_ON
+ lTLSIndex = labs(kCurrentThread());
+ #else
+ lTLSIndex = GetThreadID();
+ #endif //MPK_ON
+
+ tip = g_ThreadCtx;
+ while(tip) {
+ if (tip->tid == lTLSIndex) {
+ if (g_tCtxSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreSignal(g_tCtxSem);
+ #else
+ SignalLocalSemaphore(g_tCtxSem);
+ #endif //MPK_ON
+ }
+ return (tip->tInfo);
+ }
+ tip=tip->next;
+ }
+
+ if (g_tCtxSem)
+ {
+ #ifdef MPK_ON
+ kSemaphoreSignal(g_tCtxSem);
+ #else
+ SignalLocalSemaphore(g_tCtxSem);
+ #endif //MPK_ON
+ }
+
+ return NULL;
+ }
+
diff -c /dev/null 'perl-5.7.2/NetWare/NWUtil.c'
Index: ./NetWare/NWUtil.c
*** ./NetWare/NWUtil.c Thu Jan 1 02:00:00 1970
--- ./NetWare/NWUtil.c Mon Jul 9 17:09:39 2001
***************
*** 0 ****
--- 1,826 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : NWUtil.c
+ * DESCRIPTION : Utility functions for NetWare implementation of Perl.
+ * Author : HYAK
+ * Date : Januray 2001.
+ *
+ */
+
+
+
+ #include "stdio.h"
+ #include "string.h"
+
+ #include <nwdsdefs.h> // For "MAX_DN_BYTES"
+ #include <malloc.h> // For "malloc" and "free"
+ #include <stdlib.h> // For "getenv"
+ #include <ctype.h> // For "isspace"
+
+ #include <process.h>
+ #include <unistd.h>
+ #include <errno.h>
+ #include <nwerrno.h>
+
+ #include <nwlocale.h>
+ #include <nwadv.h>
+
+ #include "nwutil.h"
+
+
+ #define TRUE 1
+ #define FALSE 0
+
+
+ /**
+ Global variables used for better token parsing. When these were absent,
+ token parsing was not correct when there were more number of arguments passed.
+ These are used in fnCommandLineParser, fnSkipToken and fnScanToken to get/return
+ the correct and updated pointer to the command line string.
+ **/
+ char *s1 = NULL; // Used in fnScanToken.
+ char *s2 = NULL; // Used in fnSkipToken.
+
+
+
+
+ /*============================================================================================
+
+ Function : fnSkipWhite
+
+ Description : This function skips the white space characters in the given string and
+ returns the resultant value.
+
+ Parameters : s (IN) - Input string.
+
+ Returns : String.
+
+ ==============================================================================================*/
+
+ char *fnSkipWhite(char *s)
+ {
+ while (isspace(*s))
+ s++;
+ return s;
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnNwGetEnvironmentStr
+
+ Description : This function returns the NetWare environment string if available,
+ otherwise returns the supplied default value
+
+ Parameters : name (IN) - To hold the NetWare environment value.
+ defaultvalue (IN) - Default value.
+
+
+ Returns : String.
+
+ ==============================================================================================*/
+
+ char *fnNwGetEnvironmentStr(char *name, char *defaultvalue)
+ {
+ char* ret = getenv(name);
+ if (ret == NULL)
+ ret = defaultvalue;
+ return ret;
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnCommandLineParser
+
+ Description : This function parses the command line into argc/argv style of
+ Number of params and array of params.
+
+ Parameters : pclp (IN) - CommandLine structure.
+ commandLine (IN) - CommandLine String.
+ preserverQuotes (IN) - Indicates whether to preserve/copy the quotes or not.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnCommandLineParser(PCOMMANDLINEPARSER pclp, char * commandLine, BOOL preserveQuotes)
+ {
+ char *buffer = NULL;
+
+ int index = 0;
+ int do_delete = 1;
+ int i=0, j=0, k=0;
+
+
+ // +1 makes room for the terminating NULL
+ buffer = (char *) malloc((strlen(commandLine) + 1) * sizeof(char));
+ if (buffer == NULL)
+ {
+ pclp->m_isValid = FALSE;
+ return;
+ }
+
+ if (preserveQuotes)
+ {
+ // No I/O redirection nor quote processing if preserveQuotes
+
+ char *s = NULL;
+ char *sSkippedToken = NULL;
+
+
+ strcpy(buffer, commandLine);
+ s = buffer;
+ s = fnSkipWhite(s); // Skip white spaces.
+
+ s2 = s; // Update the global pointer.
+
+
+ pclp->sSkippedToken = (char *) malloc(MAX_DN_BYTES * sizeof(char));
+ if(pclp->sSkippedToken == NULL)
+ {
+ pclp->m_isValid = FALSE;
+ return;
+ }
+
+ while (*s && pclp->m_isValid)
+ {
+ /****
+ // Commented since only one time malloc and free is enough as is done outside this while loop.
+ // It is not required to do them everytime the execution comes into this while loop.
+ // Still retained here. Remove this once things are proved to be working fine to a good confident level,
+
+ if(pclp->sSkippedToken)
+ {
+ free(pclp->sSkippedToken);
+ pclp->sSkippedToken = NULL;
+ }
+
+ if(pclp->sSkippedToken == NULL)
+ {
+ pclp->sSkippedToken = (char *) malloc(MAX_DN_BYTES * sizeof(char));
+ if(pclp->sSkippedToken == NULL)
+ {
+ pclp->m_isValid = FALSE;
+ return;
+ }
+ }
+ ****/
+
+ // Empty the string.
+ strncpy(pclp->sSkippedToken, "", (MAX_DN_BYTES * sizeof(char)));
+
+ // s is advanced by fnSkipToken
+ pclp->sSkippedToken = fnSkipToken(s, pclp->sSkippedToken); // Collect the next command-line argument.
+
+ s2 = fnSkipWhite(s2); // s2 is already updated by fnSkipToken.
+ s = s2; // Update the local pointer too.
+
+ fnAppendArgument(pclp, pclp->sSkippedToken); // Append the argument into an array.
+ }
+
+ if(pclp->sSkippedToken)
+ {
+ free(pclp->sSkippedToken);
+ pclp->sSkippedToken = NULL;
+ }
+ }
+ else
+ {
+ char *s = NULL;
+
+ strcpy(buffer, commandLine);
+ s = buffer;
+ s = fnSkipWhite(s);
+
+ s1 = s; // Update the global pointer.
+
+ while (*s && pclp->m_isValid)
+ {
+ // s is advanced by fnScanToken
+ // Check for I/O redirection here, *outside* of
+ // fnScanToken(), so that quote-protected angle
+ // brackets do NOT cause redirection.
+ if (*s == '<')
+ {
+ s = fnSkipWhite(s+1); // get stdin redirection
+
+ if(pclp->m_redirInName)
+ {
+ free(pclp->m_redirInName);
+ pclp->m_redirInName = NULL;
+ }
+
+ if(pclp->m_redirInName == NULL)
+ {
+ pclp->m_redirInName = (char *) malloc(MAX_DN_BYTES * sizeof(char));
+ if(pclp->m_redirInName == NULL)
+ {
+ pclp->m_isValid = FALSE;
+ return;
+ }
+ }
+
+ // Collect the next command-line argument.
+ pclp->m_redirInName = fnScanToken(s, pclp->m_redirInName);
+
+ s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken.
+ s = s1; // Update the local pointer too.
+ }
+ else if (*s == '>')
+ {
+ s = fnSkipWhite(s+1); //get stdout redirection
+
+ if(pclp->m_redirOutName)
+ {
+ free(pclp->m_redirOutName);
+ pclp->m_redirOutName = NULL;
+ }
+
+ if(pclp->m_redirOutName == NULL)
+ {
+ pclp->m_redirOutName = (char *) malloc(MAX_DN_BYTES * sizeof(char));
+ if(pclp->m_redirOutName == NULL)
+ {
+ pclp->m_isValid = FALSE;
+ return;
+ }
+ }
+
+ // Collect the next command-line argument.
+ pclp->m_redirOutName = fnScanToken(s, pclp->m_redirOutName);
+
+ s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken.
+ s = s1; // Update the local pointer too.
+ }
+ else if (*s == '2' && s[1] == '>')
+ {
+ s = fnSkipWhite(s+2); // get stderr redirection
+
+ if(pclp->m_redirErrName)
+ {
+ free(pclp->m_redirErrName);
+ pclp->m_redirErrName = NULL;
+ }
+
+ if(pclp->m_redirErrName == NULL)
+ {
+ pclp->m_redirErrName = (char *) malloc(MAX_DN_BYTES * sizeof(char));
+ if(pclp->m_redirErrName == NULL)
+ {
+ pclp->m_isValid = FALSE;
+ return;
+ }
+ }
+
+ // Collect the next command-line argument.
+ pclp->m_redirErrName = fnScanToken(s, pclp->m_redirErrName);
+
+ s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken.
+ s = s1; // Update the local pointer too.
+ }
+ else if (*s == '&' && s[1] == '>')
+ {
+ s = fnSkipWhite(s+2); // get stdout+stderr redirection
+
+ if(pclp->m_redirBothName)
+ {
+ free(pclp->m_redirBothName);
+ pclp->m_redirBothName = NULL;
+ }
+
+ if(pclp->m_redirBothName == NULL)
+ {
+ pclp->m_redirBothName = (char *) malloc(MAX_DN_BYTES * sizeof(char));
+ if(pclp->m_redirBothName == NULL)
+ {
+ pclp->m_isValid = FALSE;
+ return;
+ }
+ }
+
+ // Collect the next command-line argument.
+ pclp->m_redirBothName = fnScanToken(s, pclp->m_redirBothName);
+
+ s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken.
+ s = s1; // Update the local pointer too.
+ }
+ else
+ {
+ if(pclp->nextarg)
+ {
+ free(pclp->nextarg);
+ pclp->nextarg = NULL;
+ }
+
+ if(pclp->nextarg == NULL)
+ {
+ pclp->nextarg = (char *) malloc(MAX_DN_BYTES * sizeof(char));
+ if(pclp->nextarg == NULL)
+ {
+ pclp->m_isValid = FALSE;
+ return;
+ }
+ }
+
+ // Collect the next command-line argument.
+ pclp->nextarg = fnScanToken(s, pclp->nextarg);
+
+ s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken.
+ s = s1; // Update the local pointer too.
+
+ // Append the next command-line argument into an array.
+ fnAppendArgument(pclp, pclp->nextarg);
+ }
+ }
+ }
+
+
+ // The -{ option, the --noscreen option, the --autodestroy option, if present,
+ // are processed now and removed from the argument vector.
+ for(index=0; index < pclp->m_argc; )
+ {
+ // "-q" is replaced by "-{", because of clash with GetOpt - sgp - 7th Nov 2000
+ // Copied from NDK build - Jan 5th 2001
+ if (strncmp(pclp->m_argv[index], (char *)"-{", 2) == 0)
+ {
+ // found a -q option; grab the semaphore number
+ sscanf(pclp->m_argv[index], (char *)"-{%x", &pclp->m_qSemaphore);
+ fnDeleteArgument(pclp, index); // Delete the argument from the list.
+ }
+ else if (strcmp(pclp->m_argv[index], (char *)"--noscreen") == 0)
+ {
+ // found a --noscreen option
+ pclp->m_noScreen = 1;
+ fnDeleteArgument(pclp, index);
+ }
+ else if (strcmp(pclp->m_argv[index], (char *)"--autodestroy") == 0)
+ {
+ // found a --autodestroy option - create a screen but close automatically
+ pclp->m_AutoDestroy = 1;
+ fnDeleteArgument(pclp, index);
+ }
+ else
+ index++;
+ }
+
+ // pclp->m_isValid is TRUE if there are more than 2 command line parameters OR
+ // if there is only one command and if it is the comman PERL.
+ pclp->m_isValid = ((pclp->m_argc >= 2) || ((pclp->m_argc > 0) && (stricmp(pclp->m_argv[0], LOAD_COMMAND) != 0)));
+
+ if(buffer)
+ {
+ free(buffer);
+ buffer = NULL;
+ }
+
+ return;
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnAppendArgument
+
+ Description : This function appends the arguments into a list.
+
+ Parameters : pclp (IN) - CommandLine structure.
+ new_arg (IN) - The new argument to be appended.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnAppendArgument(PCOMMANDLINEPARSER pclp, char *new_arg)
+ {
+ char **new_argv = pclp->new_argv;
+
+ int new_argv_len = pclp->m_argv_len*2;
+ int i = 0, j = 0;
+
+
+ // Lengthen the argument vector if there's not room for another.
+ // Testing for 'm_argc+2' rather than 'm_argc+1' in the test guarantees
+ // that there'll always be a NULL terminator at the end of argv.
+ if ((pclp->m_argc + 2) > pclp->m_argv_len)
+ {
+ new_argv = (char **) malloc(new_argv_len * sizeof(char*)); // get a longer arg-vector
+ if (new_argv == NULL)
+ {
+ pclp->m_isValid = FALSE;
+ return;
+ }
+ for(i=0; i<new_argv_len; i++)
+ {
+ new_argv[i] = (char *) malloc(MAX_DN_BYTES * sizeof(char));
+ if (new_argv[i] == NULL)
+ {
+ for(j=0; j<i; j++)
+ {
+ if(new_argv[j])
+ {
+ free(new_argv[j]);
+ new_argv[j] = NULL;
+ }
+ }
+ if(new_argv)
+ {
+ free(new_argv);
+ new_argv = NULL;
+ }
+
+ pclp->m_isValid = FALSE;
+ return;
+ }
+ }
+
+ for (i=0; i<pclp->m_argc; i++)
+ strcpy(new_argv[i], pclp->m_argv[i]); // copy old arg strings
+
+ for(i=0; i<(pclp->m_argv_len); i++)
+ {
+ if(pclp->m_argv[i])
+ {
+ free(pclp->m_argv[i]);
+ pclp->m_argv[i] = NULL;
+ }
+ }
+ if (pclp->m_argv != NULL)
+ {
+ free(pclp->m_argv);
+ pclp->m_argv = NULL;
+ }
+
+
+ pclp->m_argv = new_argv;
+ pclp->m_argv_len = new_argv_len;
+
+ }
+
+ // Once m_argv is guaranteed long enough, appending the argument is a direct job.
+ strcpy(pclp->m_argv[pclp->m_argc], new_arg); // Appended the new argument.
+ pclp->m_argc++; // Increment the number of parameters appended.
+
+ // The char array is emptied for all elements upto the end so that there are no junk characters.
+ // If this is not done, then the issue is like this:
+ // - Simple perl command like "perl" on the system console works fine for the first time.
+ // - When it is given the second time, a new blank screen should come up which also
+ // allows for editing. This was not consistently working well.
+ // More so when the command was like, "perl ", that is the name "perl"
+ // followed by a few blank spaces. It used to give error in opening file and
+ // would give some junk as the filename unable to open.
+ // Once the below fix was done, it is working fine.
+ for(i=pclp->m_argc; i<pclp->m_argv_len; i++)
+ strncpy(pclp->m_argv[i], "", (MAX_DN_BYTES * sizeof(char))); // MAX_DN_BYTES is the size of pclp->m_argv[].
+
+
+ // Fix for empty command line double quote abend - perl <.pl> ""
+ if ((new_arg==NULL) || ((strlen(new_arg))<=0))
+ {
+ pclp->m_argc--; // Decrement the number of parameters appended.
+ pclp->m_isValid = FALSE;
+ return;
+ }
+
+
+ return;
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnSkipToken
+
+ Description : This function collects the next command-line argument, breaking on
+ unquoted white space. The quote symbols are copied into the output.
+ White space has already been skipped.
+
+ Parameters : s (IN) - Input string in which the token is skipped.
+ r (IN) - The resultant return string.
+
+ Returns : String.
+
+ ==============================================================================================*/
+
+ char *fnSkipToken(char *s, char *r)
+ {
+ register char *t=NULL;
+ register char quote = '\0'; // NULL, single quote, or double quote
+ char ch = '\0';
+
+ for (t=s; t[0]; t++)
+ {
+ ch = t[0];
+ if (!quote)
+ {
+ if (isspace(ch)) // if unquoted whitespace...
+ {
+ break; // ...end of token found
+ }
+ else if (ch=='"' || ch=='\'') // if opening quote...
+ {
+ quote = ch; // ...enter quote mode
+ }
+ }
+ else
+ {
+ if (ch=='\\' && t[1]==quote) // if escaped quote...
+ {
+ t++; // ...skip backslash
+ }
+ else if (ch==quote) // if close quote...
+ {
+ quote = 0; // ...leave quote mode
+ }
+ }
+ }
+
+ r = fnStashString(s, r, t-s); // get heap-allocated token string
+ t = fnSkipWhite(t); // skip any trailing white space
+ s = t; // return updated source pointer
+
+ s2 = t; // return updated global source pointer
+
+ return r; // return heap-allocated token string
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnScanToken
+
+ Description : This function collects the next command-line argument, breaking on
+ unquoted white space or I/O redirection symbols. Quote symbols are not
+ copied into the output.
+ When called, any leading white space has already been skipped.
+
+ Parameters : x (IN) - Input string in which the token is scanned.
+ r (IN) - The resultant return string.
+
+ Returns : String.
+
+ ==============================================================================================*/
+
+ char *fnScanToken(char *x, char *r)
+ {
+ register char *s = x; // input string position
+ register char *t = x; // output string position
+ register char quote = '\0'; // either NULL, or single quote, or double quote
+ register char ch = '\0';
+ register char c = '\0';
+
+ while (*s)
+ {
+ ch = *s; // invariant: ch != 0
+
+ // look to see if we've reached the end of the token
+ if (!quote) // but don't look for token break if we're inside quotes
+ {
+ if (isspace(ch))
+ break; // break on whitespace
+ if (ch=='>')
+ break; // break on ">" (redirect stdout)
+ if (ch=='<')
+ break; // break on "<" (redirect stdin)
+ if (ch=='&' && x[1]=='>')
+ break; // break on "&>" (redirect both stdout & stderr)
+ }
+
+ // process the next source character
+ if (ch=='\\' && (c=s[1]) && (c=='\\'||c=='>'||c=='<'||c==quote))
+ {
+ //-----------------if an escaped '\\', '>', '<', or quote...
+ s++; // ...skip over the backslash...
+ *t++ = *s++; // ...and copy the escaped character
+ }
+ else if (ch==quote) // (won't match unless inside quotes because invariant ch!=0)
+ {
+ //-----------------if close quote...
+ s++; // ...skip over the quote...
+ quote=0; // ...and leave quote mode
+ }
+ else if (!quote && (ch=='"' || ch=='\''))
+ {
+ //-----------------if opening quote...
+ quote = *s++; // ...enter quote mode (remembering quote char, and skipping the quote)
+ }
+ else
+ { //----------if normal character...
+ *t++ = *s++; // ...copy the character
+ }
+ }
+
+ // clean up return values
+ r = fnStashString(x, r, t-x); // get heap-allocated token string
+ s = fnSkipWhite(s); // skip any trailing white space
+ x = s; // return updated source pointer
+
+ s1 = s; // return updated global source pointer
+
+ return r;
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnStashString
+
+ Description : This function return the heap-allocated token string.
+
+ Parameters : s (IN) - Input string from which the token is extracted.
+ buffer (IN) - Return string.
+ length (IN) - Length of the token to be extracted.
+
+ Returns : String.
+
+ ==============================================================================================*/
+
+ char *fnStashString(char *s, char *buffer, int length)
+ {
+ if (length <= 0)
+ {
+ // Copy "" instead of NULL since "" indicates that there is memory allocated having no/null value.
+ // NULL indicates that there is no memory allocated to it!
+ strcpy(buffer, "");
+ }
+ else
+ {
+ strncpy(buffer, s, length);
+ buffer[length] = '\0';
+ }
+
+ return buffer;
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnDeleteArgument
+
+ Description : This function deletes an argument (that was originally appended) from the list.
+
+ Parameters : pclp (IN) - CommandLine structure.
+ index (IN) - Index of the argument to be deleted.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnDeleteArgument(PCOMMANDLINEPARSER pclp, int index)
+ {
+ int i = index;
+
+
+ // If index is greater than the no. of arguments, just return.
+ if (index >= pclp->m_argc)
+ return;
+
+ // Move all the arguments after the index one up.
+ while(i < (pclp->m_argv_len-1))
+ {
+ strcpy(pclp->m_argv[i], pclp->m_argv[i+1]);
+ i++;
+ }
+
+
+ // Delete the last one and free memory.
+ if ( pclp->m_argv[i] )
+ {
+ free(pclp->m_argv[i]);
+ pclp->m_argv[i] = NULL;
+ }
+
+
+ pclp->m_argc--; // Decrement the number of arguments.
+ pclp->m_argv_len--;
+
+ return;
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnMy_MkTemp
+
+ Description : This is a standard ANSI C mktemp for NetWare
+
+ Parameters : templatestr (IN) - Input temp filename.
+
+ Returns : String.
+
+ ==============================================================================================*/
+
+ char* fnMy_MkTemp(char* templatestr)
+ {
+ char* pXs=NULL;
+ char numbuf[50]={'\0'};
+ int count=0;
+ char* pPid=NULL;
+
+ char termchar = '\0';
+ char letter = 'a';
+
+
+ if (templatestr && (pXs = strstr(templatestr, (char *)"XXXXXX")))
+ {
+ // generate temp name
+ termchar = pXs[6];
+ ltoa(GetThreadID(), numbuf, 16);
+ // numbuf[sizeof(numbuf)-1] = '\0';
+ numbuf[strlen(numbuf)-1] = '\0';
+ // beware! thread IDs are 8 hex digits on NW 4.11 and only the
+ // lower digits seem to change, whereas on NW 5 they are in the
+ // range of < 1000 hex or 3 hex digits in length. So the following
+ // logic ensures we use the least significant portion of the number.
+ if (strlen(numbuf) > 5)
+ pPid = &numbuf[strlen(numbuf)-5];
+ else
+ pPid = numbuf;
+
+ letter = 'a';
+ do
+ {
+ sprintf(pXs, (char *)"%c%05.5s", letter, pPid);
+ pXs[6] = termchar;
+ if (access(templatestr, 0) != 0) // File does not exist
+ {
+ return templatestr;
+ }
+ letter++;
+ } while (letter <= 'z');
+
+ errno = ENOENT;
+ return NULL;
+ }
+ else
+ {
+ errno = EINVAL;
+ return NULL;
+ }
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnSystemCommand
+
+ Description : This function constructs a system command from the given
+ null-terminated argv array and runs the command on the system console.
+
+ Parameters : argv (IN) - Array of input commands.
+ argc (IN) - Number of input parameters.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnSystemCommand (char** argv, int argc)
+ {
+ // calculate the size of a temp buffer needed
+ int k = 0;
+ int totalSize = 0;
+ int bytes = 0;
+ char* tempCmd = NULL;
+ char* tptr = NULL;
+
+
+ for(k=0; k<argc; k++)
+ totalSize += strlen(argv[k]) + 1;
+
+ tempCmd = (char *) malloc((totalSize+1) * sizeof(char));
+ if (!tempCmd)
+ return;
+ tptr = tempCmd;
+
+ for(k=0; k<argc; k++)
+ tptr += sprintf(tptr, (char *)"%s ", argv[k]);
+ *tptr = 0;
+
+ if (stricmp(argv[0], PERL_COMMAND_NAME) == 0)
+ fnInternalPerlLaunchHandler(tempCmd); // Launch perl.
+ else
+ system(tempCmd);
+
+
+ free(tempCmd);
+ tempCmd = NULL;
+ return;
+ }
+
diff -c /dev/null 'perl-5.7.2/NetWare/Nwmain.c'
Index: ./NetWare/Nwmain.c
*** ./NetWare/Nwmain.c Thu Jan 1 02:00:00 1970
--- ./NetWare/Nwmain.c Mon Jul 9 17:09:39 2001
***************
*** 0 ****
--- 1,1420 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : NWMain.c
+ * DESCRIPTION : Main function, Commandline handlers and shutdown for NetWare implementation of Perl.
+ * Author : HYAK, SGP
+ * Date : January 2001.
+ *
+ */
+
+
+
+ #ifdef NLM
+ #define N_PLAT_NLM
+ #endif
+
+ #undef BYTE
+ #define BYTE char
+
+
+ #include <nwadv.h>
+ #include <signal.h>
+ #include <nwdsdefs.h>
+
+ #include "perl.h"
+ #include "nwutil.h"
+ #include "stdio.h"
+ #include "clibstuf.h"
+
+ #ifdef MPK_ON
+ #include <mpktypes.h>
+ #include <mpkapis.h>
+ #endif //MPK_ON
+
+
+ // Thread group ID for this NLM. Set only by main when the NLM is initially loaded,
+ // so it should be okay for this to be global.
+ //
+ #ifdef MPK_ON
+ THREAD gThreadHandle;
+ #else
+ int gThreadGroupID = -1;
+ #endif //MPK_ON
+
+
+ // Global to kill all running scripts during NLM unload.
+ //
+ bool gKillAll = FALSE;
+
+
+ // Global structure needed by OS to register command parser.
+ // fnRegisterCommandLineHandler gets called only when the NLM is initially loaded,
+ // so it should be okay for this structure to be a global.
+ //
+ static struct commandParserStructure gCmdParser = {0,0,0};
+
+
+ // True if the command-line parsing procedure has been registered with the OS.
+ // Altered only during initial NLM loading or unloading so it should be okay as a global.
+ //
+ BOOL gCmdProcInit = FALSE;
+
+
+ // Array to hold the screen name for all new screens.
+ //
+ char sPerlScreenName[MAX_DN_BYTES * sizeof(char)] = {'\0'};
+
+
+ // Structure to pass data when spawning new threadgroups to run scripts.
+ //
+ typedef struct tagScriptData
+ {
+ char *m_commandLine;
+ BOOL m_fromConsole;
+ }ScriptData;
+
+
+ #define CS_CMD_NOT_FOUND -1 // Console command not found
+ #define CS_CMD_FOUND 0 // Console command found
+
+ /**
+ The stack size is make 256k from the earlier 64k since complex scripts (charnames.t and complex.t)
+ were failing with the lower stack size. In fact, we tested with 128k and it also failed
+ for the complexity of the script used. In case the complexity of a script is increased,
+ then this might warrant an increase in the stack size. But instead of simply giving a very large stack,
+ a trade off was required and we stopped at 256k!
+ **/
+ #define PERL_COMMAND_STACK_SIZE (256*1024L) // Stack size of thread that runs a perl script from command line
+
+ #define MAX_COMMAND_SIZE 512
+
+
+ #define kMaxValueLen 1024 // Size of the Environment variable value limited/truncated to 1024 characters.
+ #define kMaxVariableNameLen 256 // Size of the Environment variable name.
+
+
+ typedef void (*PFUSEACCURATECASEFORPATHS) (int);
+ typedef LONG (*PFGETFILESERVERMAJORVERSIONNUMBER) (void);
+ typedef void (*PFUCSTERMINATE) (); // For ucs terminate.
+ typedef void (*PFUNAUGMENTASTERISK)(BOOL); // For longfile support.
+ typedef int (*PFFSETMODE) (FILE *, char *);
+
+
+ // local function prototypes
+ //
+ void fnSigTermHandler(int sig);
+ void fnRegisterCommandLineHandler(void);
+ void fnLaunchPerl(void* context);
+ void fnSetUpEnvBlock(char*** penv);
+ void fnDestroyEnvBlock(char** env);
+ int fnFpSetMode(FILE* fp, int mode, int *err);
+
+ void fnGetPerlScreenName(char *sPerlScreenName);
+
+
+
+
+ /*============================================================================================
+
+ Function : main
+
+ Description : Called when the NLM is first loaded. Registers the command-line handler
+ and then terminates-stay-resident.
+
+ Parameters : argc (IN) - No of Input strings.
+ argv (IN) - Array of Input strings.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void main(int argc, char *argv[])
+ {
+ char sysCmdLine[MAX_COMMAND_SIZE] = {'\0'};
+ char cmdLineCopy[sizeof(PERL_COMMAND_NAME)+sizeof(sysCmdLine)+2] = {'\0'};
+
+ ScriptData* psdata = NULL;
+
+
+ // Keep this thread alive, since we use the thread group id of this thread to allocate memory on.
+ // When we unload the NLM, clib will tear the thread down.
+ //
+ #ifdef MPK_ON
+ gThreadHandle = kCurrentThread();
+ #else
+ gThreadGroupID = GetThreadGroupID ();
+ #endif //MPK_ON
+
+ signal (SIGTERM, fnSigTermHandler);
+ fnInitGpfGlobals(); // For importing the CLIB calls in place of the Watcom calls
+ fnInitializeThreadInfo();
+
+
+ // Ensure that we have a "temp" directory
+ fnSetupNamespace();
+ if (access(DEFTEMP, 0) != 0)
+ mkdir(DEFTEMP);
+
+ // Create the file NUL if not present. This is done only once per NLM load.
+ // This is required for -e.
+ // Earlier verions were creating temporary files (in perl.c file) for -e.
+ // Now, the technique of creating temporary files are removed since they were
+ // fragile or insecure or slow. It now uses the memory by setting
+ // the BIT_BUCKET to "nul" on Win32, which is equivalent to /dev/nul of Unix.
+ // Since there is no equivalent of /dev/nul on NetWare, the work-around is that
+ // we create a file called "nul" and the BIT_BUCKET is set to "nul".
+ // This makes sure that -e works on NetWare too without the creation of temporary files
+ // in -e code in perl.c
+ {
+ char sNUL[MAX_DN_BYTES] = {'\0'};
+
+ strcpy(sNUL, DEFPERLROOT);
+ strcat(sNUL, "\\nul");
+ if (access((const char *)sNUL, 0) != 0)
+ {
+ // The file, "nul" is not found and so create the file.
+ FILE *fp = NULL;
+
+ fp = fopen((const char *)sNUL, (const char *)"w");
+ fclose(fp);
+ }
+ }
+
+ fnRegisterCommandLineHandler(); // Register the command line handler
+ SynchronizeStart(); // Restart the NLM startup process when using synchronization mode.
+
+ fnGetPerlScreenName(sPerlScreenName); // Get the screen name. Done only once per NLM load.
+
+
+ // If the command line has two strings, then the first has to be "Perl" and the second is assumed
+ // to be a script to be run. If only one string (i.e., Perl) is input, then there is nothing to do!
+ //
+ if ((argc > 1) && getcmd(sysCmdLine))
+ {
+ strcpy(cmdLineCopy, PERL_COMMAND_NAME);
+ strcat(cmdLineCopy, (char *)" "); // Space between the Perl Command and the input script name.
+ strcat(cmdLineCopy, sysCmdLine); // The command line parameters built into
+
+ // Create a safe copy of the command line and pass it to the
+ // new thread for parsing. The new thread will be responsible
+ // to delete it when it is finished with it.
+ //
+ psdata = (ScriptData *) malloc(sizeof(ScriptData));
+ if (psdata)
+ {
+ psdata->m_commandLine = NULL;
+ psdata->m_commandLine = (char *) malloc(MAX_DN_BYTES * sizeof(char));
+ if(psdata->m_commandLine)
+ {
+ strcpy(psdata->m_commandLine, cmdLineCopy);
+ psdata->m_fromConsole = TRUE;
+
+ #ifdef MPK_ON
+ // kStartThread((char *)"ConsoleHandlerThread", fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void *)psdata);
+ // Establish a new thread within a new thread group.
+ BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata);
+ #else
+ // Start a new thread in its own thread group
+ BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata);
+ #endif //MPK_ON
+ }
+ else
+ {
+ free(psdata);
+ psdata = NULL;
+ return;
+ }
+ }
+ else
+ return;
+ }
+
+
+ // Keep this thread alive, since we use the thread group id of this thread to allocate memory on.
+ // When we unload the NLM, clib will tear the thread down.
+ //
+ #ifdef MPK_ON
+ kSuspendThread(gThreadHandle);
+ #else
+ SuspendThread(GetThreadID());
+ #endif //MPK_ON
+
+
+ return;
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnSigTermHandler
+
+ Description : Called when the NLM is unloaded; used to unregister the console command handler.
+
+ Parameters : sig (IN)
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnSigTermHandler(int sig)
+ {
+ int k = 0;
+
+
+ #ifdef MPK_ON
+ kResumeThread(gThreadHandle);
+ #endif //MPK_ON
+
+ // Unregister the command line handler.
+ //
+ if (gCmdProcInit)
+ {
+ UnRegisterConsoleCommand (&gCmdParser);
+ gCmdProcInit = FALSE;
+ }
+
+ // Free the global environ buffer
+ nw_freeenviron();
+
+ // Kill running scripts.
+ //
+ if (!fnTerminateThreadInfo())
+ {
+ ConsolePrintf("Terminating Perl scripts...\n");
+ gKillAll = TRUE;
+
+ // fnTerminateThreadInfo will be run for 5 threads. If more threads/scripts are run,
+ // then the NLM will unload without terminating the thread info and leaks more memory.
+ // If this number is increased to reduce memory leaks, then it will unnecessarily take more time
+ // to unload when there are a smaller no of threads. Since this is a rare case, the no is kept as 5.
+ //
+ while (!fnTerminateThreadInfo() && k < 5)
+ {
+ sleep(1);
+ k++;
+ }
+ }
+
+ // Delete the file, "nul" if present since the NLM is unloaded.
+ {
+ char sNUL[MAX_DN_BYTES] = {'\0'};
+
+ strcpy(sNUL, DEFPERLROOT);
+ strcat(sNUL, "\\nul");
+ if (access((const char *)sNUL, 0) == 0)
+ {
+ // The file, "nul" is found and so delete it.
+ unlink((const char *)sNUL);
+ }
+ }
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnCommandLineHandler
+
+ Description : Gets called by OS when someone enters an unknown command at the system console,
+ after this routine is registered by RegisterConsoleCommand.
+ For the valid command we just spawn a thread with enough stack space
+ to actually run the script.
+
+ Parameters : screenID (IN) - id for the screen.
+ cmdLine (IN) - Command line string.
+
+ Returns : Long.
+
+ ==============================================================================================*/
+
+ LONG fnCommandLineHandler (LONG screenID, BYTE * cmdLine)
+ {
+ ScriptData* psdata=NULL;
+ int OsThrdGrpID = -1;
+ LONG retCode = CS_CMD_FOUND;
+ char* cptr = NULL;
+
+
+ #ifdef MPK_ON
+ // Initialisation for MPK_ON
+ #else
+ OsThrdGrpID = -1;
+ #endif //MPK_ON
+
+
+ #ifdef MPK_ON
+ // For MPK_ON
+ #else
+ if (gThreadGroupID != -1)
+ OsThrdGrpID = SetThreadGroupID (gThreadGroupID);
+ #endif //MPK_ON
+
+
+ cptr = fnSkipWhite(cmdLine); // Skip white spaces.
+ if ((strnicmp(cptr, PERL_COMMAND_NAME, strlen(PERL_COMMAND_NAME)) == 0) &&
+ ((cptr[strlen(PERL_COMMAND_NAME)] == ' ') ||
+ (cptr[strlen(PERL_COMMAND_NAME)] == '\t') ||
+ (cptr[strlen(PERL_COMMAND_NAME)] == '\0')))
+ {
+ // Create a safe copy of the command line and pass it to the new thread for parsing.
+ // The new thread will be responsible to delete it when it is finished with it.
+ //
+ psdata = (ScriptData *) malloc(sizeof(ScriptData));
+ if (psdata)
+ {
+ psdata->m_commandLine = NULL;
+ psdata->m_commandLine = (char *) malloc(MAX_DN_BYTES * sizeof(char));
+ if(psdata->m_commandLine)
+ {
+ strcpy(psdata->m_commandLine, (char *)cmdLine);
+ psdata->m_fromConsole = TRUE;
+
+ #ifdef MPK_ON
+ // kStartThread((char *)"ConsoleHandlerThread", fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void *)psdata);
+ // Establish a new thread within a new thread group.
+ BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata);
+ #else
+ // Start a new thread in its own thread group
+ BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata);
+ #endif //MPK_ON
+ }
+ else
+ {
+ free(psdata);
+ psdata = NULL;
+ retCode = CS_CMD_NOT_FOUND;
+ }
+ }
+ else
+ retCode = CS_CMD_NOT_FOUND;
+ }
+ else
+ retCode = CS_CMD_NOT_FOUND;
+
+
+ #ifdef MPK_ON
+ // For MPK_ON
+ #else
+ if (OsThrdGrpID != -1)
+ SetThreadGroupID (OsThrdGrpID);
+ #endif //MPK_ON
+
+
+ return retCode;
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnRegisterCommandLineHandler
+
+ Description : Registers the console command-line parsing function with the OS.
+
+ Parameters : None.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnRegisterCommandLineHandler(void)
+ {
+ // Allocates resource tag for Console Command
+ if ((gCmdParser.RTag =
+ AllocateResourceTag (GetNLMHandle(), (char *)"Console Command", ConsoleCommandSignature)) != 0)
+ {
+ gCmdParser.parseRoutine = fnCommandLineHandler; // Set the Console Command parsing routine.
+ RegisterConsoleCommand (&gCmdParser); // Registers the Console Command parsing function
+ gCmdProcInit = TRUE;
+ }
+
+ return;
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnSetupNamespace
+
+ Description : Sets the name space of the current threadgroup to the long name space.
+
+ Parameters : None.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnSetupNamespace(void)
+ {
+ SetCurrentNameSpace(NWOS2_NAME_SPACE);
+
+
+ //LATER: call SetTargetNameSpace(NWOS2_NAME_SPACE)? Currently, if
+ // I make this call, then CPerlExe::Rename fails in certain cases,
+ // and it isn't clear why. Looks like a CLIB bug...
+ // SetTargetNameSpace(NWOS2_NAME_SPACE);
+
+ //Uncommented that above call, retaining the comment so that it will be easy
+ //to revert back if there is any problem - sgp - 10th May 2000
+
+ //Commented again, since Perl debugger had some problems because of
+ //the above call - sgp - 20th June 2000
+
+ {
+ // if running on Moab, call UseAccurateCaseForPaths. This API
+ // does bad things on 4.11 so we call only for Moab.
+ PFGETFILESERVERMAJORVERSIONNUMBER pf_getfileservermajorversionnumber = NULL;
+ pf_getfileservermajorversionnumber = (PFGETFILESERVERMAJORVERSIONNUMBER)
+ ImportSymbol(GetNLMHandle(), (char *)"GetFileServerMajorVersionNumber");
+ if (pf_getfileservermajorversionnumber && ((*pf_getfileservermajorversionnumber)() > 4))
+ {
+ PFUSEACCURATECASEFORPATHS pf_useaccuratecaseforpaths = NULL;
+ pf_useaccuratecaseforpaths = (PFUSEACCURATECASEFORPATHS)
+ ImportSymbol(GetNLMHandle(), (char *)"UseAccurateCaseForPaths");
+ if (pf_useaccuratecaseforpaths)
+ (*pf_useaccuratecaseforpaths)(TRUE);
+ {
+ PFUNAUGMENTASTERISK pf_unaugmentasterisk = NULL;
+ pf_unaugmentasterisk = (PFUNAUGMENTASTERISK)
+ ImportSymbol(GetNLMHandle(), (char *)"UnAugmentAsterisk");
+ if (pf_unaugmentasterisk)
+ (*pf_unaugmentasterisk)(TRUE);
+ }
+ }
+ }
+
+ return;
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnLaunchPerl
+
+ Description : Parse the command line into argc/argv style parameters and then run the script.
+
+ Parameters : context (IN) - void* that will be typecasted to ScriptDate structure.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnLaunchPerl(void* context)
+ {
+ char* defaultDir = NULL;
+ char curdir[_MAX_PATH] = {'\0'};
+ ScriptData* psdata = (ScriptData *) context;
+
+ unsigned int moduleHandle = 0;
+ int currentThreadGroupID = -1;
+
+ #ifdef MPK_ON
+ kExitNetWare();
+ #endif //MPK_ON
+
+ errno = 0;
+
+
+ if (psdata->m_fromConsole)
+ {
+ // get the default working directory name
+ //
+ defaultDir = fnNwGetEnvironmentStr("PERL_ROOT", DEFPERLROOT);
+ }
+ else
+ defaultDir = getcwd(curdir, sizeof(curdir)-1);
+
+ // set long name space
+ //
+ fnSetupNamespace();
+
+ // make the working directory the current directory if from console
+ //
+ if (psdata->m_fromConsole)
+ chdir(defaultDir);
+
+
+ // run the script
+ //
+ fnRunScript(psdata);
+
+
+ // May have to check this, I am blindly calling UCSTerminate, irrespective of
+ // whether it is initialized or not
+ // Copied from the previous Perl - sgp - 31st Oct 2000
+ moduleHandle = FindNLMHandle("UCSCORE.NLM");
+ if (moduleHandle)
+ {
+ PFUCSTERMINATE ucsterminate = (PFUCSTERMINATE)ImportSymbol(moduleHandle, "therealUCSTerminate");
+ if (ucsterminate!=NULL)
+ (*ucsterminate)();
+ }
+
+
+ if (psdata->m_fromConsole)
+ {
+ // change thread groups for the call to free the memory
+ // allocated before the new thread group was started
+ #ifdef MPK_ON
+ // For MPK_ON
+ #else
+ if (gThreadGroupID != -1)
+ currentThreadGroupID = SetThreadGroupID (gThreadGroupID);
+ #endif //MPK_ON
+ }
+
+ // Free memory
+ if (psdata)
+ {
+ if(psdata->m_commandLine)
+ {
+ free(psdata->m_commandLine);
+ psdata->m_commandLine = NULL;
+ }
+
+ free(psdata);
+ psdata = NULL;
+ context = NULL;
+ }
+
+ #ifdef MPK_ON
+ // For MPK_ON
+ #else
+ if (currentThreadGroupID != -1)
+ SetThreadGroupID (currentThreadGroupID);
+ #endif //MPK_ON
+
+ #ifdef MPK_ON
+ // kExitThread(NULL);
+ #else
+ // just let the thread terminate by falling off the end of the
+ // function started by BeginThreadGroup
+ // ExitThread(EXIT_THREAD, 0);
+ #endif
+
+
+ return;
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnRunScript
+
+ Description : Parses and runs a perl script.
+
+ Parameters : psdata (IN) - ScriptData structure.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnRunScript(ScriptData* psdata)
+ {
+ char **av=NULL;
+ char **en=NULL;
+ int exitstatus = 1;
+ int i=0, j=0;
+ int *dummy = 0;
+
+ PCOMMANDLINEPARSER pclp = NULL;
+
+ // Set up the environment block. This will only work on
+ // on Moab; on 4.11 the environment block will be empty.
+ char** env = NULL;
+
+ BOOL use_system_console = TRUE;
+ BOOL newscreen = FALSE;
+ int newscreenhandle = 0;
+
+ // redirect stdin or stdout and run the script
+ FILE* redirOut = NULL;
+ FILE* redirIn = NULL;
+ FILE* redirErr = NULL;
+ FILE* stderr_fp = NULL;
+
+ int stdin_fd=-1, stdin_fd_dup=-1;
+ int stdout_fd=-1, stdout_fd_dup=-1;
+ int stderr_fd=-1, stderr_fd_dup=-1;
+
+
+
+ // Main callback instance
+ //
+ if (fnRegisterWithThreadTable() == FALSE)
+ return;
+
+
+ // parse the command line into argc/argv style:
+ // number of params and char array of params
+ //
+ pclp = (PCOMMANDLINEPARSER) malloc(sizeof(COMMANDLINEPARSER));
+ if (!pclp)
+ {
+ fnUnregisterWithThreadTable();
+ return;
+ }
+
+
+ // Initialise the variables
+ pclp->m_isValid = TRUE;
+ pclp->m_redirInName = NULL;
+ pclp->m_redirOutName = NULL;
+ pclp->m_redirErrName = NULL;
+ pclp->m_redirBothName = NULL;
+ pclp->nextarg = NULL;
+ pclp->sSkippedToken = NULL;
+ pclp->m_argv = NULL;
+ pclp->new_argv = NULL;
+
+ #ifdef MPK_ON
+ pclp->m_qSemaphore = NULL;
+ #else
+ pclp->m_qSemaphore = 0L;
+ #endif //MPK_ON
+
+ pclp->m_noScreen = 0;
+ pclp->m_AutoDestroy = 0;
+ pclp->m_argc = 0;
+ pclp->m_argv_len = 1;
+
+
+ // Allocate memory
+ pclp->m_argv = (char **) malloc(pclp->m_argv_len * sizeof(char *));
+ if (pclp->m_argv == NULL)
+ {
+ free(pclp);
+ pclp = NULL;
+
+ fnUnregisterWithThreadTable();
+ return;
+ }
+
+ pclp->m_argv[0] = (char *) malloc(MAX_DN_BYTES * sizeof(char));
+ if (pclp->m_argv[0] == NULL)
+ {
+ free(pclp->m_argv);
+ pclp->m_argv=NULL;
+
+ free(pclp);
+ pclp = NULL;
+
+ fnUnregisterWithThreadTable();
+ return;
+ }
+
+
+ // Parse the command line
+ fnCommandLineParser(pclp, (char *)psdata->m_commandLine, FALSE);
+ if (!pclp->m_isValid)
+ {
+ if(pclp->m_argv)
+ {
+ for(i=0; i<pclp->m_argv_len; i++)
+ {
+ if(pclp->m_argv[i] != NULL)
+ {
+ free(pclp->m_argv[i]);
+ pclp->m_argv[i] = NULL;
+ }
+ }
+
+ free(pclp->m_argv);
+ pclp->m_argv = NULL;
+ }
+
+ if(pclp->nextarg)
+ {
+ free(pclp->nextarg);
+ pclp->nextarg = NULL;
+ }
+ if(pclp->sSkippedToken != NULL)
+ {
+ free(pclp->sSkippedToken);
+ pclp->sSkippedToken = NULL;
+ }
+
+ if(pclp->m_redirInName)
+ {
+ free(pclp->m_redirInName);
+ pclp->m_redirInName = NULL;
+ }
+ if(pclp->m_redirOutName)
+ {
+ free(pclp->m_redirOutName);
+ pclp->m_redirOutName = NULL;
+ }
+ if(pclp->m_redirErrName)
+ {
+ free(pclp->m_redirErrName);
+ pclp->m_redirErrName = NULL;
+ }
+ if(pclp->m_redirBothName)
+ {
+ free(pclp->m_redirBothName);
+ pclp->m_redirBothName = NULL;
+ }
+
+
+ // Signal a semaphore, if indicated by "-{" option, to indicate that
+ // the script has terminated and files are closed
+ //
+ if (pclp->m_qSemaphore != 0)
+ {
+ #ifdef MPK_ON
+ kSemaphoreSignal(pclp->m_qSemaphore);
+ #else
+ SignalLocalSemaphore(pclp->m_qSemaphore);
+ #endif //MPK_ON
+ }
+
+ free(pclp);
+ pclp = NULL;
+
+ fnUnregisterWithThreadTable();
+ return;
+ }
+
+
+ // Simulating a shell on NetWare can be difficult. If you don't
+ // create a new screen for the script to run in, you can output to
+ // the console but you can't get any input from the console. Therefore,
+ // every invocation of perl potentially needs its own screen unless
+ // you are running either "perl -h" or "perl -v" or you are redirecting
+ // stdin from a file.
+ //
+ // So we need to create a new screen and set that screen as the current
+ // screen when running any script launched from the console that is not
+ // "perl -h" or "perl -v" and is not redirecting stdin from a file.
+ //
+ // But it would be a little weird if we didn't create a new screen only
+ // in the case when redirecting stdin from a file; in only that case,
+ // stdout would be the console instead of a new screen.
+ //
+ // There is also the issue of standard err. In short, we might as well
+ // create a new screen no matter what is going on with redirection, just
+ // for the sake of consistency.
+ //
+ // In summary, we should a create a new screen and make that screen the
+ // current screen unless one of the following is true:
+ // * The command is "perl -h"
+ // * The command is "perl -v"
+ // * The script was launched by another perl script. In this case,
+ // the screen belonging to the parent perl script should probably be
+ // the same screen for this process. And it will be if use BeginThread
+ // instead of BeginThreadGroup when launching Perl from within a Perl
+ // script.
+ //
+ // In those cases where we create a new screen we should probably also display
+ // that screen.
+ //
+
+ use_system_console = pclp->m_noScreen ||
+ ((pclp->m_argc == 2) && (strcmp(pclp->m_argv[1], (char *)"-h") == 0)) ||
+ ((pclp->m_argc == 2) && (strcmp(pclp->m_argv[1], (char *)"-v") == 0));
+
+ newscreen = (!use_system_console) && psdata->m_fromConsole;
+
+ if (newscreen)
+ {
+ newscreenhandle = CreateScreen(sPerlScreenName, 0);
+ if (newscreenhandle)
+ DisplayScreen(newscreenhandle);
+ }
+ else if (use_system_console)
+ CreateScreen((char *)"System Console", 0);
+
+
+ if (pclp->m_redirInName)
+ {
+ if ((stdin_fd = fileno(stdin)) != -1)
+ {
+ stdin_fd_dup = dup(stdin_fd);
+ if (stdin_fd_dup != -1)
+ {
+ redirIn = fdopen (stdin_fd_dup, (char const *)"r");
+ if (redirIn)
+ stdin = freopen (pclp->m_redirInName, (char const *)"r", redirIn);
+ if (!stdin)
+ {
+ redirIn = NULL;
+ // undo the redirect, if possible
+ stdin = fdopen(stdin_fd, (char const *)"r");
+ }
+ }
+ }
+ }
+
+ /**
+ The below code stores the handle for the existing stdout to be used later and the existing stdout is closed.
+ stdout is then initialised to the new File pointer where the operations are done onto that.
+ Later (look below for the code), the saved stdout is restored back.
+ **/
+ if (pclp->m_redirOutName)
+ {
+ if ((stdout_fd = fileno(stdout)) != -1) // Handle of the existing stdout.
+ {
+ stdout_fd_dup = dup(stdout_fd);
+ if (stdout_fd_dup != -1)
+ {
+ // Close the existing stdout.
+ fflush(stdout); // Write any unwritten data to the file.
+
+ // New stdout
+ redirOut = fdopen (stdout_fd_dup, (char const *)"w");
+ if (redirOut)
+ stdout = freopen (pclp->m_redirOutName, (char const *)"w", redirOut);
+ if (!stdout)
+ {
+ redirOut = NULL;
+ // Undo the redirection.
+ stdout = fdopen(stdout_fd, (char const *)"w");
+ }
+ setbuf(stdout, NULL); // Unbuffered file pointer.
+ }
+ }
+ }
+
+ if (pclp->m_redirErrName)
+ {
+ if ((stderr_fd = fileno(stderr)) != -1)
+ {
+ stderr_fd_dup = dup(stderr_fd);
+ if (stderr_fd_dup != -1)
+ {
+ fflush(stderr);
+
+ redirErr = fdopen (stderr_fd_dup, (char const *)"w");
+ if (redirErr)
+ stderr = freopen (pclp->m_redirErrName, (char const *)"w", redirErr);
+ if (!stderr)
+ {
+ redirErr = NULL;
+ // undo the redirect, if possible
+ stderr = fdopen(stderr_fd, (char const *)"w");
+ }
+ setbuf(stderr, NULL); // Unbuffered file pointer.
+ }
+ }
+ }
+
+ if (pclp->m_redirBothName)
+ {
+ if ((stdout_fd = fileno(stdout)) != -1)
+ {
+ stdout_fd_dup = dup(stdout_fd);
+ if (stdout_fd_dup != -1)
+ {
+ fflush(stdout);
+
+ redirOut = fdopen (stdout_fd_dup, (char const *)"w");
+ if (redirOut)
+ stdout = freopen (pclp->m_redirBothName, (char const *)"w", redirOut);
+ if (!stdout)
+ {
+ redirOut = NULL;
+ // undo the redirect, if possible
+ stdout = fdopen(stdout_fd, (char const *)"w");
+ }
+ setbuf(stdout, NULL); // Unbuffered file pointer.
+ }
+ }
+ if ((stderr_fd = fileno(stderr)) != -1)
+ {
+ stderr_fp = stderr;
+ stderr = stdout;
+ }
+ }
+
+
+ env = NULL;
+ fnSetUpEnvBlock(&env); // Set up the ENV block
+
+ // Run the Perl script
+ exitstatus = RunPerl(pclp->m_argc, pclp->m_argv, env);
+
+
+ // clean up any redirection
+ //
+ if (pclp->m_redirInName && redirIn)
+ {
+ fclose(stdin);
+ stdin = fdopen(stdin_fd, (char const *)"r"); // Put back the old handle for stdin.
+ }
+
+ if (pclp->m_redirOutName && redirOut)
+ {
+ // Close the new stdout.
+ fflush(stdout);
+ fclose(stdout);
+
+ // Put back the old handle for stdout.
+ stdout = fdopen(stdout_fd, (char const *)"w");
+ setbuf(stdout, NULL); // Unbuffered file pointer.
+ }
+
+ if (pclp->m_redirErrName && redirErr)
+ {
+ fflush(stderr);
+ fclose(stderr);
+
+ stderr = fdopen(stderr_fd, (char const *)"w"); // Put back the old handle for stderr.
+ setbuf(stderr, NULL); // Unbuffered file pointer.
+ }
+
+ if (pclp->m_redirBothName && redirOut)
+ {
+ stderr = stderr_fp;
+
+ fflush(stdout);
+ fclose(stdout);
+
+ stdout = fdopen(stdout_fd, (char const *)"w"); // Put back the old handle for stdout.
+ setbuf(stdout, NULL); // Unbuffered file pointer.
+ }
+
+
+ if (newscreen && newscreenhandle)
+ {
+ //added for --autodestroy switch
+ if(!pclp->m_AutoDestroy)
+ {
+ if ((redirOut == NULL) && (redirIn == NULL) && (!gKillAll))
+ {
+ printf((char *)"\n\nPress any key to exit\n");
+ getch();
+ }
+ }
+ DestroyScreen(newscreenhandle);
+ }
+
+ // Set the mode for stdin and stdout
+ fnFpSetMode(stdin, O_TEXT, dummy);
+ fnFpSetMode(stdout, O_TEXT, dummy);
+
+ // Cleanup
+ if(pclp->m_argv)
+ {
+ for(i=0; i<pclp->m_argv_len; i++)
+ {
+ if(pclp->m_argv[i] != NULL)
+ {
+ free(pclp->m_argv[i]);
+ pclp->m_argv[i] = NULL;
+ }
+ }
+
+ free(pclp->m_argv);
+ pclp->m_argv = NULL;
+ }
+
+ if(pclp->nextarg)
+ {
+ free(pclp->nextarg);
+ pclp->nextarg = NULL;
+ }
+ if(pclp->sSkippedToken != NULL)
+ {
+ free(pclp->sSkippedToken);
+ pclp->sSkippedToken = NULL;
+ }
+
+ if(pclp->m_redirInName)
+ {
+ free(pclp->m_redirInName);
+ pclp->m_redirInName = NULL;
+ }
+ if(pclp->m_redirOutName)
+ {
+ free(pclp->m_redirOutName);
+ pclp->m_redirOutName = NULL;
+ }
+ if(pclp->m_redirErrName)
+ {
+ free(pclp->m_redirErrName);
+ pclp->m_redirErrName = NULL;
+ }
+ if(pclp->m_redirBothName)
+ {
+ free(pclp->m_redirBothName);
+ pclp->m_redirBothName = NULL;
+ }
+
+
+ // Signal a semaphore, if indicated by -{ option, to indicate that
+ // the script has terminated and files are closed
+ //
+ if (pclp->m_qSemaphore != 0)
+ {
+ #ifdef MPK_ON
+ kSemaphoreSignal(pclp->m_qSemaphore);
+ #else
+ SignalLocalSemaphore(pclp->m_qSemaphore);
+ #endif //MPK_ON
+ }
+
+ if(pclp)
+ {
+ free(pclp);
+ pclp = NULL;
+ }
+
+ if(env)
+ fnDestroyEnvBlock(env);
+ fnUnregisterWithThreadTable();
+ // Remove the thread context set during Perl_set_context
+ Remove_Thread_Ctx();
+
+
+ return;
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnSetUpEnvBlock
+
+ Description : Sets up the initial environment block.
+
+ Parameters : penv (IN) - ENV variable as char***.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnSetUpEnvBlock(char*** penv)
+ {
+ char** env = NULL;
+
+ int sequence = 0;
+ char var[kMaxVariableNameLen+1] = {'\0'};
+ char val[kMaxValueLen+1] = {'\0'};
+ char both[kMaxVariableNameLen + kMaxValueLen + 5] = {'\0'};
+ size_t len = kMaxValueLen;
+ int totalcnt = 0;
+
+ while(scanenv( &sequence, var, &len, val ))
+ {
+ totalcnt++;
+ len = kMaxValueLen;
+ }
+ // add one for null termination
+ totalcnt++;
+
+
+ env = (char **) malloc (totalcnt * sizeof(char *));
+ if (env)
+ {
+ int cnt = 0;
+ int i = 0;
+
+ sequence = 0;
+ len = kMaxValueLen;
+
+ while( (cnt < (totalcnt-1)) && scanenv( &sequence, var, &len, val ) )
+ {
+ val[len] = '\0';
+ strcpy( both, var );
+ strcat( both, (char *)"=" );
+ strcat( both, val );
+
+ env[cnt] = (char *) malloc((sizeof(both)+1) * sizeof(char));
+ if (env[cnt])
+ {
+ strcpy(env[cnt], both);
+ cnt++;
+ }
+ else
+ {
+ for(i=0; i<cnt; i++)
+ {
+ if(env[i])
+ {
+ free(env[i]);
+ env[i] = NULL;
+ }
+ }
+
+ free(env);
+ env = NULL;
+
+ return;
+ }
+
+ len = kMaxValueLen;
+ }
+
+ for(i=cnt; i<=(totalcnt-1); i++)
+ env[i] = NULL;
+ }
+ else
+ return;
+
+ *penv = env;
+
+ return;
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnDestroyEnvBlock
+
+ Description : Frees resources used by the ENV block.
+
+ Parameters : env (IN) - ENV variable as char**.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnDestroyEnvBlock(char** env)
+ {
+ // It is assumed that this block is entered only if env is TRUE. So, the calling function
+ // must check for this condition before calling fnDestroyEnvBlock.
+ // If no check is made by the calling function, then the server abends.
+ int k = 0;
+ while (env[k] != NULL)
+ {
+ free(env[k]);
+ env[k] = NULL;
+ k++;
+ }
+
+ free(env);
+ env = NULL;
+
+ return;
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnFpSetMode
+
+ Description : Sets the mode for a file.
+
+ Parameters : fp (IN) - FILE pointer for the input file.
+ mode (IN) - Mode to be set
+ e (OUT) - Error.
+
+ Returns : Integer which is the set value.
+
+ ==============================================================================================*/
+
+ int fnFpSetMode(FILE* fp, int mode, int *err)
+ {
+ int ret = -1;
+
+ PFFSETMODE pf_fsetmode;
+
+
+ if (mode == O_BINARY || mode == O_TEXT)
+ {
+ if (fp)
+ {
+ errno = 0;
+ // the setmode call is not implemented (correctly) on NetWare,
+ // but the CLIB guys were kind enough to provide another
+ // call, fsetmode, which does a similar thing. It only works
+ // on Moab
+ pf_fsetmode = (PFFSETMODE) ImportSymbol(GetNLMHandle(), (char *)"fsetmode");
+ if (pf_fsetmode)
+ ret = (*pf_fsetmode) (fp, ((mode == O_BINARY) ? "b" : "t"));
+ else
+ {
+ // we are on 4.11 instead of Moab, so we just return an error
+ errno = ESERVER;
+ err = &errno;
+ }
+ if (errno)
+ err = &errno;
+
+ }
+ else
+ {
+ errno = EBADF;
+ err = &errno;
+ }
+ }
+ else
+ {
+ errno = EINVAL;
+ err = &errno;
+ }
+
+
+ return ret;
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnInternalPerlLaunchHandler
+
+ Description : Gets called by perl to spawn a new instance of perl.
+
+ Parameters : cndLine (IN) - Command Line string.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnInternalPerlLaunchHandler(char* cmdLine)
+ {
+ int currentThreadGroup = -1;
+
+ ScriptData* psdata=NULL;
+
+
+ // Create a safe copy of the command line and pass it to the
+ // new thread for parsing. The new thread will be responsible
+ // to delete it when it is finished with it.
+ psdata = (ScriptData *) malloc(sizeof(ScriptData));
+ if (psdata)
+ {
+ psdata->m_commandLine = NULL;
+ psdata->m_commandLine = (char *) malloc(MAX_DN_BYTES * sizeof(char));
+
+ if(psdata->m_commandLine)
+ {
+ strcpy(psdata->m_commandLine, cmdLine);
+ psdata->m_fromConsole = FALSE;
+
+ #ifdef MPK_ON
+ BeginThread(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata);
+ #else
+ // Start a new thread in its own thread group
+ BeginThread(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata);
+ #endif //MPK_ON
+ }
+ else
+ {
+ free(psdata);
+ psdata = NULL;
+ return;
+ }
+ }
+ else
+ return;
+
+ return;
+ }
+
+
+
+ /*============================================================================================
+
+ Function : fnGetPerlScreenName
+
+ Description : This function creates the Perl screen name.
+ Gets called from main only once when the Perl NLM loads.
+
+ Parameters : sPerlScreenName (OUT) - Resultant Perl screen name.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnGetPerlScreenName(char *sPerlScreenName)
+ {
+ // HYAK:
+ // The logic for using 32 in the below array sizes is like this:
+ // The NetWare CLIB SDK documentation says that for base 2 conversion,
+ // this number must be minimum 8. Also, in the example of the documentation,
+ // 20 is used as the size and testing is done for bases from 2 upto 16.
+ // So, to simply chose a number above 20 and also keeping in mind not to reserve
+ // unnecessary big array sizes, I have chosen 32 !
+ // Less than that may also suffice.
+ char sPerlRevision[32 * sizeof(char)] = {'\0'};
+ char sPerlVersion[32 * sizeof(char)] = {'\0'};
+ char sPerlSubVersion[32 * sizeof(char)] = {'\0'};
+
+ // The defines for PERL_REVISION, PERL_VERSION, PERL_SUBVERSION are available in
+ // patchlevel.h under root and gets included when perl.h is included.
+ // The number 10 below indicates base 10.
+ itoa(PERL_REVISION, sPerlRevision, 10);
+ itoa(PERL_VERSION, sPerlVersion, 10);
+ itoa(PERL_SUBVERSION, sPerlSubVersion, 10);
+
+ // Concatenate substrings to get a string like Perl5.6.1 which is used as the screen name.
+ sprintf(sPerlScreenName, "%s%s.%s.%s", PERL_COMMAND_NAME,
+ sPerlRevision, sPerlVersion, sPerlSubVersion);
+
+ return;
+ }
+
+
+
+ // Global variable to hold the environ information.
+ // First time it is accessed, it will be created and initialized and
+ // next time onwards, the pointer will be returned.
+
+ // Improvements - Dynamically read env everytime a request comes - Is this required?
+ char** genviron = NULL;
+
+
+ /*============================================================================================
+
+ Function : nw_getenviron
+
+ Description : Gets the environment information.
+
+ Parameters : None.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ char ***
+ nw_getenviron()
+ {
+ if (genviron)
+ return (&genviron); // This might leak memory upto 11736 bytes on some versions of NetWare.
+ // return genviron; // Abending on some versions of NetWare.
+ else
+ fnSetUpEnvBlock(&genviron);
+
+ return (&genviron);
+ }
+
+
+
+ /*============================================================================================
+
+ Function : nw_freeenviron
+
+ Description : Frees the environment information.
+
+ Parameters : None.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void
+ nw_freeenviron()
+ {
+ if (genviron)
+ {
+ fnDestroyEnvBlock(genviron);
+ genviron=NULL;
+ }
+ }
+
diff -c /dev/null 'perl-5.7.2/NetWare/Nwpipe.c'
Index: ./NetWare/Nwpipe.c
*** ./NetWare/Nwpipe.c Thu Jan 1 02:00:00 1970
--- ./NetWare/Nwpipe.c Mon Jul 9 17:09:39 2001
***************
*** 0 ****
--- 1,704 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : NWPipe.c
+ * DESCRIPTION : Functions to implement pipes on NetWare.
+ * Author : HYAK
+ * Date : January 2001.
+ *
+ */
+
+
+
+ #include <nwadv.h>
+ #include <nwdsdefs.h>
+
+ #include "win32ish.h"
+ #include "nwpipe.h"
+ #include "nwplglob.h"
+
+
+ // This was added since the compile failed saying "undefined P_WAIT"
+ // when USE_ITHREADS was commented in the makefile
+ #ifndef P_WAIT
+ #define P_WAIT 0
+ #endif
+
+ #ifndef P_NOWAIT
+ #define P_NOWAIT 1
+ #endif
+
+
+
+
+ /*============================================================================================
+
+ Function : fnPipeFileMakeArgv
+
+ Description : This function makes the argument array.
+
+ Parameters : ptpf (IN) - Input structure.
+
+ Returns : Boolean.
+
+ ==============================================================================================*/
+
+ BOOL fnPipeFileMakeArgv(PTEMPPIPEFILE ptpf)
+ {
+ int i=0, j=0;
+ int dindex = 0;
+ int sindex = 0;
+
+ ptpf->m_argv_len = 0;
+
+
+ // Below 2 is added for the following reason:
+ // - The first one is for an additional value that will be added through ptpf->m_redirect.
+ // - The second one is for a NULL termination of the array.
+ // This is required for spawnvp API that takes a NULL-terminated array as its 3rd parameter.
+ // If the array is NOT NULL-terminated, then the server abends at the spawnvp call !!
+ ptpf->m_argv = (char **) malloc((ptpf->m_pipeCommand->m_argc + 2) * sizeof(char*));
+ if (ptpf->m_argv == NULL)
+ return FALSE;
+
+ // For memory allocation it is just +1 since the last one is only for NULL-termination
+ // and no memory is required to be allocated.
+ for(i=0; i<(ptpf->m_pipeCommand->m_argc + 1); i++)
+ {
+ ptpf->m_argv[i] = (char *) malloc(MAX_DN_BYTES * sizeof(char));
+ if (ptpf->m_argv[i] == NULL)
+ {
+ for(j=0; j<i; j++)
+ {
+ if(ptpf->m_argv[j])
+ {
+ free(ptpf->m_argv[j]);
+ ptpf->m_argv[j] = NULL;
+ }
+ }
+ free(ptpf->m_argv);
+ ptpf->m_argv = NULL;
+
+ return FALSE;
+ }
+ }
+
+ // Copy over parsed items, removing "load" keyword if necessary.
+ sindex = ((stricmp(ptpf->m_pipeCommand->m_argv[0], LOAD_COMMAND) == 0) ? 1 : 0);
+ while (sindex < ptpf->m_pipeCommand->m_argc)
+ {
+ strcpy(ptpf->m_argv[dindex], ptpf->m_pipeCommand->m_argv[sindex]);
+ dindex++;
+ sindex++;
+ }
+
+ if (stricmp(ptpf->m_argv[0], PERL_COMMAND_NAME) == 0) // If Perl is the first command.
+ {
+ ptpf->m_launchPerl = TRUE;
+
+ #ifdef MPK_ON
+ ptpf->m_perlSynchSemaphore = kSemaphoreAlloc((BYTE *)"pipeSemaphore", 0);
+ #else
+ ptpf->m_perlSynchSemaphore = OpenLocalSemaphore(0);
+ #endif //MPK_ON
+ }
+ else if (stricmp(ptpf->m_argv[0], (char *)"perlglob") == 0)
+ ptpf->m_doPerlGlob = TRUE;
+
+
+ // Create last argument, which will redirect to or from the temp file
+ if (!ptpf->m_doPerlGlob || ptpf->m_mode)
+ {
+ if (!ptpf->m_mode) // If read mode?
+ {
+ if (ptpf->m_launchPerl)
+ strcpy(ptpf->m_redirect, (char *)">");
+ else
+ strcpy(ptpf->m_redirect, (char *)"(CLIB_OPT)/>");
+ }
+ else
+ {
+ if (ptpf->m_launchPerl)
+ strcpy(ptpf->m_redirect, (char *)"<");
+ else
+ strcpy(ptpf->m_redirect, (char *)"(CLIB_OPT)/<");
+ }
+ strcat(ptpf->m_redirect, ptpf->m_fileName);
+
+ if (ptpf->m_launchPerl)
+ {
+ char tbuf[15] = {'\0'};
+ sprintf(tbuf, (char *)" -{%x", ptpf->m_perlSynchSemaphore);
+ strcat(ptpf->m_redirect, tbuf);
+ }
+
+ strcpy(ptpf->m_argv[dindex], (char*) ptpf->m_redirect);
+ dindex++;
+ }
+
+ if (dindex < (ptpf->m_pipeCommand->m_argc + 1))
+ {
+ if(ptpf->m_argv[dindex])
+ {
+ free(ptpf->m_argv[dindex]);
+ ptpf->m_argv[dindex] = NULL; // NULL termination - required for spawnvp call.
+ }
+ }
+
+ ptpf->m_argv_len = dindex; // Length of the argv array OR number of argv string values.
+ ptpf->m_argv[ptpf->m_argv_len] = NULL; // NULL termination - required for spawnvp call.
+
+
+ return TRUE;
+ }
+
+
+ /*============================================================================================
+
+ Function : fnPipeFileOpen
+
+ Description : This function opens the pipe file.
+
+ Parameters : ptpf (IN) - Input structure.
+ command (IN) - Input command string.
+ mode (IN) - Mode of opening.
+
+ Returns : File pointer.
+
+ ==============================================================================================*/
+
+ FILE* fnPipeFileOpen(PTEMPPIPEFILE ptpf, char* command, char* mode)
+ {
+ int i=0, j=0;
+
+ char tempName[_MAX_PATH] = {'\0'};
+
+
+ ptpf->m_fileName = (char *) malloc(_MAX_PATH * sizeof(char));
+ if(ptpf->m_fileName == NULL)
+ return NULL;
+
+ // The char array is emptied so that there is no junk characters.
+ strncpy(ptpf->m_fileName, "", (_MAX_PATH * sizeof(char)));
+
+
+ // Save off stuff
+ //
+ if(strchr(mode,'r') != 0)
+ ptpf->m_mode = FALSE; // Read mode
+ else if(strchr(mode,'w') != 0)
+ ptpf->m_mode = TRUE; // Write mode
+ else
+ {
+ if(ptpf->m_fileName != NULL)
+ {
+ // if (strlen(ptpf->m_fileName))
+ if (ptpf->m_fileName)
+ unlink(ptpf->m_fileName);
+
+ free(ptpf->m_fileName);
+ ptpf->m_fileName = NULL;
+ }
+
+ return NULL;
+ }
+
+
+ ptpf->m_pipeCommand = (PCOMMANDLINEPARSER) malloc(sizeof(COMMANDLINEPARSER));
+ if (!ptpf->m_pipeCommand)
+ {
+ // if (strlen(ptpf->m_fileName))
+ if (ptpf->m_fileName)
+ unlink(ptpf->m_fileName);
+
+ free(ptpf->m_fileName);
+ ptpf->m_fileName = NULL;
+
+ return NULL;
+ }
+
+ // Initialise the variables
+ ptpf->m_pipeCommand->m_isValid = TRUE;
+
+ /****
+ // Commented since these are not being used. Still retained here.
+ // To be removed once things are proved to be working fine to a good confident level,
+
+ ptpf->m_pipeCommand->m_redirInName = NULL;
+ ptpf->m_pipeCommand->m_redirOutName = NULL;
+ ptpf->m_pipeCommand->m_redirErrName = NULL;
+ ptpf->m_pipeCommand->m_redirBothName = NULL;
+ ptpf->m_pipeCommand->nextarg = NULL;
+ ****/
+
+ ptpf->m_pipeCommand->sSkippedToken = NULL;
+ ptpf->m_pipeCommand->m_argv = NULL;
+ ptpf->m_pipeCommand->new_argv = NULL;
+
+ #ifdef MPK_ON
+ ptpf->m_pipeCommand->m_qSemaphore = NULL;
+ #else
+ ptpf->m_pipeCommand->m_qSemaphore = 0L;
+ #endif //MPK_ON
+
+ ptpf->m_pipeCommand->m_noScreen = 0;
+ ptpf->m_pipeCommand->m_AutoDestroy = 0;
+ ptpf->m_pipeCommand->m_argc = 0;
+ ptpf->m_pipeCommand->m_argv_len = 1;
+
+
+ ptpf->m_pipeCommand->m_argv = (char **) malloc(ptpf->m_pipeCommand->m_argv_len * sizeof(char *));
+ if (ptpf->m_pipeCommand->m_argv == NULL)
+ {
+ free(ptpf->m_pipeCommand);
+ ptpf->m_pipeCommand = NULL;
+
+ // if (strlen(ptpf->m_fileName))
+ if (ptpf->m_fileName)
+ unlink(ptpf->m_fileName);
+
+ free(ptpf->m_fileName);
+ ptpf->m_fileName = NULL;
+
+ return NULL;
+ }
+ ptpf->m_pipeCommand->m_argv[0] = (char *) malloc(MAX_DN_BYTES * sizeof(char));
+ if (ptpf->m_pipeCommand->m_argv[0] == NULL)
+ {
+ for(j=0; j<i; j++)
+ {
+ if(ptpf->m_pipeCommand->m_argv[j])
+ {
+ free(ptpf->m_pipeCommand->m_argv[j]);
+ ptpf->m_pipeCommand->m_argv[j]=NULL;
+ }
+ }
+ free(ptpf->m_pipeCommand->m_argv);
+ ptpf->m_pipeCommand->m_argv=NULL;
+
+ free(ptpf->m_pipeCommand);
+ ptpf->m_pipeCommand = NULL;
+
+ // if (strlen(ptpf->m_fileName))
+ if (ptpf->m_fileName)
+ unlink(ptpf->m_fileName);
+
+ free(ptpf->m_fileName);
+ ptpf->m_fileName = NULL;
+
+ return NULL;
+ }
+
+
+ ptpf->m_redirect = (char *) malloc(MAX_DN_BYTES * sizeof(char));
+ if (ptpf->m_redirect == NULL)
+ {
+ for(i=0; i<ptpf->m_pipeCommand->m_argv_len; i++)
+ {
+ if(ptpf->m_pipeCommand->m_argv[i] != NULL)
+ {
+ free(ptpf->m_pipeCommand->m_argv[i]);
+ ptpf->m_pipeCommand->m_argv[i] = NULL;
+ }
+ }
+
+ free(ptpf->m_pipeCommand->m_argv);
+ ptpf->m_pipeCommand->m_argv = NULL;
+
+ free(ptpf->m_pipeCommand);
+ ptpf->m_pipeCommand = NULL;
+
+
+ // if (strlen(ptpf->m_fileName))
+ if (ptpf->m_fileName)
+ unlink(ptpf->m_fileName);
+
+ free(ptpf->m_fileName);
+ ptpf->m_fileName = NULL;
+
+ return NULL;
+ }
+
+ // The char array is emptied.
+ // If it is not done so, then it could contain some junk values and the string length in that case
+ // will not be zero. This causes erroneous results in fnPipeFileMakeArgv() function
+ // where strlen(ptpf->m_redirect) is used as a check for incrementing the parameter count and
+ // it will wrongly get incremented in such cases.
+ strncpy(ptpf->m_redirect, "", (MAX_DN_BYTES * sizeof(char)));
+
+ // Parse the parameters.
+ fnCommandLineParser(ptpf->m_pipeCommand, (char *)command, TRUE);
+ if (!ptpf->m_pipeCommand->m_isValid)
+ {
+ fnTempPipeFileReleaseMemory(ptpf);
+ return NULL;
+ }
+
+
+ // Create a temporary file name
+ //
+ strncpy ( tempName, fnNwGetEnvironmentStr((char *)"TEMP", DEFTEMP), (_MAX_PATH - 20) );
+ tempName[_MAX_PATH-20] = '\0';
+ strcat(tempName, (char *)"\\plXXXXXX.tmp");
+ if (!fnMy_MkTemp(tempName))
+ {
+ fnTempPipeFileReleaseMemory(ptpf);
+ return NULL;
+ }
+
+ // create a temporary place-holder file
+ fclose(fopen(tempName, (char *)"w"));
+ strcpy(ptpf->m_fileName, tempName);
+
+
+ // Make the argument array
+ if(!fnPipeFileMakeArgv(ptpf))
+ {
+ fnTempPipeFileReleaseMemory(ptpf);
+
+ // Release additional memory
+ if(ptpf->m_argv != NULL)
+ {
+ for(i=0; i<ptpf->m_argv_len; i++)
+ {
+ if(ptpf->m_argv[i] != NULL)
+ {
+ free(ptpf->m_argv[i]);
+ ptpf->m_argv[i] = NULL;
+ }
+ }
+
+ free(ptpf->m_argv);
+ ptpf->m_argv = NULL;
+ }
+
+ return NULL;
+ }
+
+
+ // Open the temp file in the appropriate way...
+ //
+ if (!ptpf->m_mode) // If Read mode?
+ {
+ // we wish to spawn a command, intercept its output,
+ // and then get that output
+ //
+ if (!ptpf->m_argv[0])
+ {
+ fnTempPipeFileReleaseMemory(ptpf);
+
+ // Release additional memory
+ if(ptpf->m_argv != NULL)
+ {
+ for(i=0; i<ptpf->m_argv_len; i++)
+ {
+ if(ptpf->m_argv[i] != NULL)
+ {
+ free(ptpf->m_argv[i]);
+ ptpf->m_argv[i] = NULL;
+ }
+ }
+
+ free(ptpf->m_argv);
+ ptpf->m_argv = NULL;
+ }
+
+ return NULL;
+ }
+
+ if (ptpf->m_launchPerl)
+ fnPipeFileDoPerlLaunch(ptpf);
+ else
+ if (ptpf->m_doPerlGlob)
+ fnDoPerlGlob(ptpf->m_argv, ptpf->m_fileName); // hack to do perl globbing
+ else
+ spawnvp(P_WAIT, ptpf->m_argv[0], ptpf->m_argv);
+
+ ptpf->m_file = fopen (ptpf->m_fileName, (char *)"r"); // Get the Pipe file handle
+ }
+ else if (ptpf->m_mode) // If Write mode?
+ {
+ // we wish to open the file for writing now and
+ // do the command later
+ //
+ ptpf->m_file = fopen(ptpf->m_fileName, (char *)"w");
+ }
+
+ fnTempPipeFileReleaseMemory(ptpf);
+
+ // Release additional memory
+ if(ptpf->m_argv != NULL)
+ {
+ for(i=0; i<(ptpf->m_argv_len); i++)
+ {
+ if(ptpf->m_argv[i] != NULL)
+ {
+ free(ptpf->m_argv[i]);
+ ptpf->m_argv[i] = NULL;
+ }
+ }
+
+ free(ptpf->m_argv);
+ ptpf->m_argv = NULL;
+ }
+
+
+ return ptpf->m_file; // Return the Pipe file handle.
+ }
+
+
+ /*============================================================================================
+
+ Function : fnPipeFileClose
+
+ Description : This function closes the pipe file.
+
+ Parameters : ptpf (IN) - Input structure.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnPipeFileClose(PTEMPPIPEFILE ptpf)
+ {
+ int i = 0;
+
+ if (ptpf->m_mode) // If Write mode?
+ {
+ // we wish to spawn a command using our temp file for
+ // its input
+ //
+ if(ptpf->m_file != NULL)
+ {
+ fclose (ptpf->m_file);
+ ptpf->m_file = NULL;
+ }
+
+ if (ptpf->m_launchPerl)
+ fnPipeFileDoPerlLaunch(ptpf);
+ else if (ptpf->m_argv)
+ spawnvp(P_WAIT, ptpf->m_argv[0], ptpf->m_argv);
+ }
+
+
+ // Close the temporary Pipe File, if opened
+ if (ptpf->m_file)
+ {
+ fclose(ptpf->m_file);
+ ptpf->m_file = NULL;
+ }
+ // Delete the temporary Pipe Filename if still valid and free the memory associated with the file name.
+ if(ptpf->m_fileName != NULL)
+ {
+ // if (strlen(ptpf->m_fileName))
+ if (ptpf->m_fileName)
+ unlink(ptpf->m_fileName);
+
+ free(ptpf->m_fileName);
+ ptpf->m_fileName = NULL;
+ }
+
+ /**
+ if(ptpf->m_argv != NULL)
+ {
+ for(i=0; i<(ptpf->m_argv_len); i++)
+ {
+ if(ptpf->m_argv[i] != NULL)
+ {
+ free(ptpf->m_argv[i]);
+ ptpf->m_argv[i] = NULL;
+ }
+ }
+
+ free(ptpf->m_argv);
+ ptpf->m_argv = NULL;
+ }
+ **/
+
+ if (ptpf->m_perlSynchSemaphore)
+ {
+ #ifdef MPK_ON
+ kSemaphoreFree(ptpf->m_perlSynchSemaphore);
+ #else
+ CloseLocalSemaphore(ptpf->m_perlSynchSemaphore);
+ #endif //MPK_ON
+ }
+
+
+ return;
+ }
+
+
+ /*============================================================================================
+
+ Function : fnPipeFileDoPerlLaunch
+
+ Description : This function launches Perl.
+
+ Parameters : ptpf (IN) - Input structure.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnPipeFileDoPerlLaunch(PTEMPPIPEFILE ptpf)
+ {
+ char curdir[_MAX_PATH] = {'\0'};
+ char* pcwd = NULL;
+
+ int i=0;
+
+
+ // save off the current working directory to restore later
+ // this is just a hack! these problems of synchronization and
+ // restoring calling context need a much better solution!
+ pcwd = (char *)getcwd(curdir, sizeof(curdir)-1);
+ fnSystemCommand(ptpf->m_argv, ptpf->m_argv_len);
+ if (ptpf->m_perlSynchSemaphore)
+ {
+ #ifdef MPK_ON
+ kSemaphoreWait(ptpf->m_perlSynchSemaphore);
+ #else
+ WaitOnLocalSemaphore(ptpf->m_perlSynchSemaphore);
+ #endif //MPK_ON
+ }
+
+ if (pcwd)
+ chdir(pcwd);
+
+ return;
+ }
+
+
+ /*============================================================================================
+
+ Function : fnTempPipeFile
+
+ Description : This function initialises the variables of the structure passed in.
+
+ Parameters : ptpf (IN) - Input structure.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnTempPipeFile(PTEMPPIPEFILE ptpf)
+ {
+ ptpf->m_fileName = NULL;
+
+ ptpf->m_mode = FALSE; // Default mode = Read mode.
+ ptpf->m_file = NULL;
+ ptpf->m_pipeCommand = NULL;
+ ptpf->m_argv = NULL;
+
+ ptpf->m_redirect = NULL;
+
+ ptpf->m_launchPerl = FALSE;
+ ptpf->m_doPerlGlob = FALSE;
+
+ #ifdef MPK_ON
+ ptpf->m_perlSynchSemaphore = NULL;
+ #else
+ ptpf->m_perlSynchSemaphore = 0L;
+ #endif
+
+ ptpf->m_argv_len = 0;
+
+ return;
+ }
+
+
+ /*============================================================================================
+
+ Function : fnTempPipeFileReleaseMemory
+
+ Description : This function frees the memory allocated to various buffers.
+
+ Parameters : ptpf (IN) - Input structure.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnTempPipeFileReleaseMemory(PTEMPPIPEFILE ptpf)
+ {
+ int i=0;
+
+
+ if (ptpf->m_pipeCommand)
+ {
+ if(ptpf->m_pipeCommand->m_argv != NULL)
+ {
+ for(i=0; i<ptpf->m_pipeCommand->m_argv_len; i++)
+ {
+ if(ptpf->m_pipeCommand->m_argv[i] != NULL)
+ {
+ free(ptpf->m_pipeCommand->m_argv[i]);
+ ptpf->m_pipeCommand->m_argv[i] = NULL;
+ }
+ }
+
+ free(ptpf->m_pipeCommand->m_argv);
+ ptpf->m_pipeCommand->m_argv = NULL;
+ }
+
+ if(ptpf->m_pipeCommand->sSkippedToken != NULL)
+ {
+ free(ptpf->m_pipeCommand->sSkippedToken);
+ ptpf->m_pipeCommand->sSkippedToken = NULL;
+ }
+ /****
+ // Commented since these are not being used. Still retained here.
+ // To be removed once things are proved to be working fine to a good confident level,
+
+ if(ptpf->m_pipeCommand->nextarg)
+ {
+ free(ptpf->m_pipeCommand->nextarg);
+ ptpf->m_pipeCommand->nextarg = NULL;
+ }
+
+ if(ptpf->m_pipeCommand->m_redirInName)
+ {
+ free(ptpf->m_pipeCommand->m_redirInName);
+ ptpf->m_pipeCommand->m_redirInName = NULL;
+ }
+ if(ptpf->m_pipeCommand->m_redirOutName)
+ {
+ free(ptpf->m_pipeCommand->m_redirOutName);
+ ptpf->m_pipeCommand->m_redirOutName = NULL;
+ }
+ if(ptpf->m_pipeCommand->m_redirErrName)
+ {
+ free(ptpf->m_pipeCommand->m_redirErrName);
+ ptpf->m_pipeCommand->m_redirErrName = NULL;
+ }
+ if(ptpf->m_pipeCommand->m_redirBothName)
+ {
+ free(ptpf->m_pipeCommand->m_redirBothName);
+ ptpf->m_pipeCommand->m_redirBothName = NULL;
+ }
+ ****/
+
+ if(ptpf->m_pipeCommand != NULL)
+ {
+ free(ptpf->m_pipeCommand);
+ ptpf->m_pipeCommand = NULL;
+ }
+ }
+
+ if(ptpf->m_redirect != NULL)
+ {
+ free(ptpf->m_redirect);
+ ptpf->m_redirect = NULL;
+ }
+
+ return;
+ }
+
diff -c /dev/null 'perl-5.7.2/NetWare/bat/BldNWExt.bat'
Index: ./NetWare/bat/BldNWExt.bat
*** ./NetWare/bat/BldNWExt.bat Thu Jan 1 02:00:00 1970
--- ./NetWare/bat/BldNWExt.bat Mon Jul 9 17:09:39 2001
***************
*** 0 ****
--- 1,39 ----
+ @echo off
+ @rem AUTHOR: sgp
+ @rem CREATED: Sat Apr 14 13:05:44 2001
+ @rem LAST REVISED: Sat Apr 14 2001
+ @rem Batch file to toggle b/n building and not building NetWare
+ @rem specific extns - cgi2perl & perl2ucs.
+
+ if "%1" == "" goto Usage
+
+ if "%1" == "/now" goto now
+ if "%1" == "on" goto yes
+ if "%1" == "off" goto no
+ if "%1" == "/?" goto usage
+ if "%1" == "/h" goto usage
+ goto dontknow
+
+ :now
+ if not "%NW_EXTNS%" == "yes" echo NW_EXTNS is removed, doesn't build NetWare specific extensions
+ if "%NW_EXTNS%" == "yes" echo NW_EXTNS is set, builds NetWare specific extensions
+ goto exit
+
+ :yes
+ Set NW_EXTNS=yes
+ echo ....NW_EXTNS is set, builds NetWare specific extensions
+ goto exit
+
+ :no
+ Set NW_EXTNS=
+ echo ....NW_EXTNS is removed, doesn't build NetWare specific extensions
+ goto exit
+
+ :dontknow
+ goto Usage
+
+ :Usage
+ @echo on
+ @echo "Usage: BldNWExt [on|off]"
+ @echo "Usage: BldNWExt /now" - To display current setting
+ :exit
diff -c /dev/null 'perl-5.7.2/NetWare/bat/Buildtype.bat'
Index: ./NetWare/bat/Buildtype.bat
*** ./NetWare/bat/Buildtype.bat Thu Jan 1 02:00:00 1970
--- ./NetWare/bat/Buildtype.bat Mon Jul 9 17:09:39 2001
***************
*** 0 ****
--- 1,53 ----
+ @echo off
+ @rem AUTHOR: sgp
+ @rem CREATED: 24th July 2000
+ @rem LAST REVISED: 6th April 2001
+ @rem Batch file to set debug/release build and toggle D2 flag for
+ @rem debugging in case of debug build.
+ @rem This file calls ToggleD2.bat which switches b/n d2 & d1 flags
+
+ if "%1" == "" goto Usage
+ if "%1" == "/now" goto now
+ if "%1" == "/?" goto usage
+ if "%1" == "/h" goto usage
+
+ if "%1" == "r" goto set_type_rel
+ if "%1" == "R" goto set_type_rel
+
+ if "%1" == "d" goto set_type_dbg
+ if "%1" == "D" goto set_type_dbg
+
+ Rem Invalid input, display help message
+ goto Usage
+
+ :set_type_rel
+ set MAKE_TYPE=Release
+ echo ....Build set to %MAKE_TYPE%
+ goto set_d2_off
+
+ :set_type_dbg
+ set MAKE_TYPE=Debug
+ echo ....Build set to %MAKE_TYPE%
+ if "%2" == "" goto set_d2_off
+ call ToggleD2 %2
+
+ goto exit
+
+ :set_d2_off
+ call ToggleD2 off
+ goto exit
+
+ :now
+ if "%MAKE_TYPE%" == "" echo MAKE_TYPE is not set, hence it defaults to Release build
+ if not "%MAKE_TYPE%" == "" echo Current build type is - %MAKE_TYPE%
+ call ToggleD2 /now
+ goto exit
+
+ :Usage
+ @echo on
+ @echo "Usage: buildtype r/R|d/D [on/off]"
+ @echo on/off - Toggling D2 flag for debug build
+ @echo "Usage: buildtype /now" - To display current setting
+ @echo Ex. buildtype d on
+
+ :exit
diff -c /dev/null 'perl-5.7.2/NetWare/bat/MPKBuild.bat'
Index: ./NetWare/bat/MPKBuild.bat
*** ./NetWare/bat/MPKBuild.bat Thu Jan 1 02:00:00 1970
--- ./NetWare/bat/MPKBuild.bat Mon Jul 9 17:09:39 2001
***************
*** 0 ****
--- 1,64 ----
+ @echo off
+ @rem AUTHOR: sgp
+ @rem CREATED: 22nd May 2000
+ @rem LAST REVISED: 6th April 2001
+ @rem Batch file to set MPK/Non-MPK builds and toggle XDC flag setting
+ @rem This file calls ToggleXDC.bat
+
+ if "%1" == "" goto Usage
+
+ if "%1" == "/now" goto now
+ if "%1" == "on" goto yes
+ if "%1" == "off" goto no
+ if "%1" == "/?" goto usage
+ goto dontknow
+
+ :now
+ if "%USE_MPK%" == "" echo USE_MPK is removed, doesn't use MPK APIs
+ if not "%USE_MPK%" == "" echo USE_MPK is set, uses MPK APIs, MPKBASE set to %MPKBASE%
+ call ToggleXDC %1
+ goto exit
+
+ :yes
+ Set USE_MPK=1
+ echo ....USE_MPK is set, uses MPK APIs
+ if "%2" == "" goto setdef
+ if "%2" == "default" goto setdef
+ SET MPKBASE=%2
+ :yescon1
+ call ToggleXDC on %3 %4
+ echo ....MPKBASE set to %MPKBASE%
+ goto exit
+
+ :no
+ Set USE_MPK=
+ SET MPKBASE=
+ if not "%2" == "" goto xdc_u
+ call ToggleXDC off
+ :nocon1
+ echo ....USE_MPK is removed. doesn't use MPK APIs
+ goto exit
+
+ :dontknow
+ goto Usage
+
+ :setdef
+ SET MPKBASE=p:\apps\mpk
+ goto yescon1
+
+ :xdc_u
+ call ToggleXDC on %2 %3
+ goto nocon1
+
+ :Usage
+ @echo on
+ @echo "Usage: MPKBuild [on][off] [[path][default]] [[flag1] [flag2]]"
+ @echo "Usage: MPKBuild /now" - To display current setting
+ @echo Scenarios...
+ @echo ...Use MPK, path set to default and XDC set to -u :MPKBuild on
+ @echo ...Use MPK, path set to default and XDC set to -u :MPKBuild on default -n
+ @echo ...Use MPK, path set to "path" and XDC set to -n :MPKBuild on "path" -n
+ @echo ...Use MPK, path set to default and XDC set to -n, -u :MPKBuild on default -n -u
+ @echo ...No MPK, No XDC :MPKBuild off
+ @echo ...No MPK, Use XDC with -u flag :MPKBuild off -u
+ :exit
diff -c /dev/null 'perl-5.7.2/NetWare/bat/SetNWBld.bat'
Index: ./NetWare/bat/SetNWBld.bat
*** ./NetWare/bat/SetNWBld.bat Thu Jan 1 02:00:00 1970
--- ./NetWare/bat/SetNWBld.bat Mon Jul 9 17:09:39 2001
***************
*** 0 ****
--- 1,62 ----
+ @echo off
+ @rem AUTHOR: sgp
+ @rem CREATED: Thu 18th Jan 2001 09:18:08
+ @rem LAST REVISED: 6th April 2001
+ @rem Batch file to set the path to NetWare SDK, Watcom directories & MPK SDK
+ @rem This file calls setnlmsdk.bat, setwatcom.bat & setmpksdk.bat
+
+ REM If no parameters are passed, display usage
+ if "%1" == "" goto Usage
+ if "%1" == "/?" goto Usage
+ if "%1" == "/h" goto Usage
+
+ REM Display the current settings
+ if "%1" == "/now" goto now
+
+ REM If na is passed, don't set that parameter
+ if "%1" == "na" goto skip_nlmsdk_msg
+ :setnwsdk
+ call setnlmsdk %1
+ goto skip_nlmsdk_nomsg
+
+ :skip_nlmsdk_msg
+ @echo Retaining NLMSDKBASE=%NLMSDKBASE%
+ :skip_nlmsdk_nomsg
+
+ if "%2" == "" goto exit
+ if "%2" == "na" goto skip_watcom_msg
+ :setwatcom
+ call setwatcom %2
+ goto skip_watcom_nomsg
+
+ :skip_watcom_msg
+ @echo Retaining WATCOM=%WATCOM%
+ :skip_watcom_nomsg
+
+ if "%3" == "" goto exit
+ if "%3" == "na" goto skip_mpksdk_msg
+ :setmpk
+ call setmpksdk %3
+ goto skip_mpksdk_nomsg
+
+ :skip_mpksdk_msg
+ @echo Retaining MPKBASE=%MPKBASE%
+ :skip_mpksdk_nomsg
+
+ goto exit
+
+ :now
+ @echo NLMSDKBASE=%NLMSDKBASE%
+ @echo WATCOM=%WATCOM%
+ @echo MPKBASE=%MPKBASE%
+ goto exit
+
+ goto exit
+ :Usage
+ @echo on
+ @echo "Usage: setnwbld <path to NetWare SDK> [<path to Watcom dir>] [<path to MPK SDK>]"
+ @echo "Usage: setnwbld /now" - To display current setting
+ @echo Pass na if you don't want to change a setting
+ @echo Ex. setnwbld d:\ndk\nwsdk na p:\mpk
+ @echo Ex. setnwbld d:\ndk\
+ :exit
diff -c /dev/null 'perl-5.7.2/NetWare/bat/Setmpksdk.bat'
Index: ./NetWare/bat/Setmpksdk.bat
*** ./NetWare/bat/Setmpksdk.bat Thu Jan 1 02:00:00 1970
--- ./NetWare/bat/Setmpksdk.bat Mon Jul 9 17:09:39 2001
***************
*** 0 ****
--- 1,27 ----
+ @echo off
+ @rem AUTHOR: sgp
+ @rem CREATED: 24th July 2000
+ @rem LAST REVISED: 6th April 2001
+ @rem Batch file to set the path to MPK SDK
+ @rem This file is called from SetNWBld.bat.
+
+ if "%1" == "/now" goto now
+ if "%1" == "" goto Usage
+ if "%1" == "/?" goto usage
+ if "%1" == "/h" goto usage
+
+ SET MPKBASE=%1
+ echo MPKBASE set to %1
+
+ goto exit
+
+ :now
+ @echo MPKBASE=%MPKBASE%
+ goto exit
+
+ :Usage
+ @echo on
+ @echo "Usage: setmpksdk <path to MPK sdk>"
+ @echo "Usage: setmpksdk /now" - To display current setting
+ @echo Ex. setmpksdk p:\sw\mpk
+ :exit
diff -c /dev/null 'perl-5.7.2/NetWare/bat/Setnlmsdk.bat'
Index: ./NetWare/bat/Setnlmsdk.bat
*** ./NetWare/bat/Setnlmsdk.bat Thu Jan 1 02:00:00 1970
--- ./NetWare/bat/Setnlmsdk.bat Mon Jul 9 17:09:39 2001
***************
*** 0 ****
--- 1,28 ----
+ @echo off
+ @rem AUTHOR: sgp
+ @rem CREATED: 24th July 2000
+ @rem LAST REVISED: 6th April 2001
+ @rem Batch file to set the path to NetWare SDK
+ @rem This file is called from SetNWBld.bat.
+
+ if "%1" == "/now" goto now
+ if "%1" == "" goto Usage
+ if "%1" == "/?" goto usage
+ if "%1" == "/h" goto usage
+
+ set NLMSDKBASE=%1
+ echo NLMSDKBASE set to %1
+
+ goto exit
+
+ :now
+ @echo NLMSDKBASE=%NLMSDKBASE%
+ goto exit
+
+ :Usage
+ @echo on
+ @echo "Usage: setnlmsdk <path to NetWare sdk>"
+ @echo "Usage: setnlmsdk /now" - To display current setting
+ @echo Ex. setnlmsdk e:\sdkcd14\nwsdk
+ :exit
+
diff -c /dev/null 'perl-5.7.2/NetWare/bat/Setwatcom.bat'
Index: ./NetWare/bat/Setwatcom.bat
*** ./NetWare/bat/Setwatcom.bat Thu Jan 1 02:00:00 1970
--- ./NetWare/bat/Setwatcom.bat Mon Jul 9 17:09:39 2001
***************
*** 0 ****
--- 1,28 ----
+ @echo off
+ @rem AUTHOR: sgp
+ @rem CREATED: 24th July 2000
+ @rem LAST REVISED: 6th April 2001
+ @rem Batch file to set the path to Watcom directories
+ @rem This file is called from SetNWBld.bat.
+
+ if "%1" == "/now" goto now
+ if "%1" == "" goto Usage
+ if "%1" == "/?" goto usage
+ if "%1" == "/h" goto usage
+
+ set WATCOM=%1
+ echo WATCOM set to %1
+
+ goto exit
+
+ :now
+ @echo WATCOM=%WATCOM%
+ goto exit
+
+ :Usage
+ @echo on
+ @echo "Usage: setwatcom <path to Watcom>"
+ @echo "Usage: setwatcom /now" - To display current setting
+ @echo Ex. setwatcom d:\Watcom
+ :exit
+
diff -c /dev/null 'perl-5.7.2/NetWare/bat/ToggleD2.bat'
Index: ./NetWare/bat/ToggleD2.bat
*** ./NetWare/bat/ToggleD2.bat Thu Jan 1 02:00:00 1970
--- ./NetWare/bat/ToggleD2.bat Mon Jul 9 17:09:40 2001
***************
*** 0 ****
--- 1,40 ----
+ @echo off
+ @rem AUTHOR: sgp
+ @rem CREATED: 23rd August 1999
+ @rem LAST REVISED: 6th April 2001
+ @rem Batch file to toggle D2 flag for debugging in case of debug build
+ @rem and remove in case of release build.
+ @rem This file is called from BuildType.bat
+
+ if "%1" == "" goto Usage
+
+ if "%1" == "/now" goto now
+ if "%1" == "on" goto yes
+ if "%1" == "off" goto no
+ if "%1" == "/?" goto usage
+ if "%1" == "/h" goto usage
+ goto dontknow
+
+ :now
+ if "%USE_D2%" == "" echo USE_D2 is removed, uses /d1
+ if not "%USE_D2%" == "" echo USE_D2 is set, uses /d2
+ goto exit
+
+ :yes
+ Set USE_D2=1
+ echo ....USE_D2 is set, uses /d2
+ goto exit
+
+ :no
+ Set USE_D2=
+ echo ....USE_D2 is removed. uses /d1
+ goto exit
+
+ :dontknow
+ goto Usage
+
+ :Usage
+ @echo on
+ @echo "Usage: ToggleD2 [on|off]"
+ @echo "Usage: ToggleD2 /now" - To display current setting
+ :exit
diff -c /dev/null 'perl-5.7.2/NetWare/bat/ToggleXDC.bat'
Index: ./NetWare/bat/ToggleXDC.bat
*** ./NetWare/bat/ToggleXDC.bat Thu Jan 1 02:00:00 1970
--- ./NetWare/bat/ToggleXDC.bat Mon Jul 9 17:09:40 2001
***************
*** 0 ****
--- 1,43 ----
+ @echo off
+ @rem AUTHOR: sgp
+ @rem CREATED: 2nd November 1999
+ @rem LAST REVISED: 6th April 2001
+ @rem Batch file to toggle XDC flag setting, to link with XDC or not
+ @rem This file is called from MPKBuild.bat.
+
+ if "%1" == "" goto Usage
+
+ if "%1" == "/now" goto now
+ if "%1" == "on" goto yes
+ if "%1" == "off" goto no
+ if "%1" == "/?" goto usage
+ goto dontknow
+
+ :now
+ if "%USE_XDC%" == "" echo USE_XDC is removed, doesn't link with XDCDATA
+ if not "%USE_XDC%" == "" echo USE_XDC is set, links with XDCDATA, XDCFLAGS = %XDCFLAGS%
+ goto exit
+
+ :yes
+ Set USE_XDC=1
+ echo ....USE_XDC is set, links with XDCDATA
+ if "%2" == "" SET XDCFLAGS=-n
+ if not "%2" == "" SET XDCFLAGS=%2
+ if not "%3" == "" SET XDCFLAGS=%XDCFLAGS% %3
+ echo ....XDCFLAGS set to %XDCFLAGS%
+ goto exit
+
+ :no
+ Set USE_XDC=
+ SET XDCFLAGS=
+ echo ....USE_XDC is removed. doesn't link with XDCDATA
+ goto exit
+
+ :dontknow
+ goto Usage
+
+ :Usage
+ @echo on
+ @echo "Usage: ToggleXDC [on|off] [[flag1] [flag2]]"
+ @echo "Usage: ToggleD2 /now" - To display current setting
+ :exit
diff -c /dev/null 'perl-5.7.2/NetWare/config.wc'
Index: ./NetWare/config.wc
*** ./NetWare/config.wc Thu Jan 1 02:00:00 1970
--- ./NetWare/config.wc Fri Jul 13 03:18:23 2001
***************
*** 0 ****
--- 1,805 ----
+ ## Configured by: ~cf_email~
+ ## Target system: NetWare
+ Author='Guruprasad'
+ PERL_CONFIG_SH='true'
+ Date='$Date'
+ Header=''
+ Id='$Id'
+ Locker=''
+ Log='$Log'
+ Mcc='Mcc'
+ RCSfile='$RCSfile'
+ Revision='$Revision'
+ Source=''
+ State=''
+ _a='.lib'
+ _exe='.exe'
+ _nlm='.nlm'
+ _nlp='.nlp'
+ _o='.obj'
+ afs='false'
+ alignbytes='8'
+ ansi2knr=''
+ aphostname=''
+ api_revision='~PERL_API_REVISION~'
+ api_subversion='~PERL_API_SUBVERSION~'
+ api_version='~PERL_API_VERSION~'
+ api_versionstring='~PERL_API_REVISION~.~PERL_API_VERSION~.~PERL_API_SUBVERSION~'
+ ar='lib386'
+ archlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~'
+ archlibexp='~INST_TOP~~INST_VER~\lib~INST_ARCH~'
+ archname64=''
+ archname='NetWare'
+ archobjs=''
+ awk='awk'
+ baserev='5'
+ bash=''
+ bin='~INST_TOP~~INST_VER~\bin~INST_ARCH~'
+ bincompat5005='undef'
+ binexp='~INST_TOP~~INST_VER~\bin~INST_ARCH~'
+ bison=''
+ byacc='byacc'
+ byteorder='1234'
+ c=''
+ castflags='0'
+ cat='type'
+ cc='cl'
+ cccdlflags=' '
+ ccdlflags=' '
+ ccflags='-MD -DNETWARE'
+ ccsymbols=''
+ cf_by='nobody'
+ cf_email='nobody@no.where.net'
+ cf_time=''
+ charsize='1'
+ chgrp=''
+ chmod=''
+ chown=''
+ clocktype='clock_t'
+ comm=''
+ compress=''
+ contains='grep'
+ cp='copy'
+ cpio=''
+ cpp='cl -nologo -E'
+ cpp_stuff='42'
+ cppccsymbols=''
+ cppflags='-DNETWARE'
+ cpplast=''
+ cppminus=''
+ cpprun='cl -nologo -E'
+ cppstdin='cl -nologo -E'
+ cppsymbols=''
+ crosscompile='undef'
+ cryptlib=''
+ csh='undef'
+ d_Gconvert='sprintf((b),"%.*g",(n),(x))'
+ d_PRIEldbl='undef'
+ d_PRIFldbl='undef'
+ d_PRIGldbl='undef'
+ d_PRIX64='undef'
+ d_PRId64='undef'
+ d_PRIeldbl='undef'
+ d_PRIfldbl='undef'
+ d_PRIgldbl='undef'
+ d_PRIi64='undef'
+ d_PRIo64='undef'
+ d_PRIu64='undef'
+ d_PRIx64='undef'
+ d_access='define'
+ d_accessx='undef'
+ d_alarm='undef'
+ d_archlib='define'
+ d_atolf='undef'
+ d_atoll='undef'
+ d_attribut='undef'
+ d_bcmp='undef'
+ d_bcopy='undef'
+ d_bincompat5005='undef'
+ d_bsd='define'
+ d_bsdgetpgrp='undef'
+ d_bsdsetpgrp='undef'
+ d_bzero='undef'
+ d_casti32='undef'
+ d_castneg='define'
+ d_charvspr='undef'
+ d_chown='undef'
+ d_chroot='undef'
+ d_chsize='define'
+ d_closedir='define'
+ d_const='define'
+ d_crypt='undef'
+ d_csh='undef'
+ d_cuserid='undef'
+ d_dbl_dig='define'
+ d_difftime='define'
+ d_dirnamlen='undef'
+ d_dlerror='define'
+ d_dlopen='define'
+ d_dlsymun='undef'
+ d_dosuid='undef'
+ d_drand48proto='undef'
+ d_dup2='define'
+ d_eaccess='undef'
+ d_endgrent='undef'
+ d_endhent='undef'
+ d_endnent='undef'
+ d_endpent='undef'
+ d_endpwent='undef'
+ d_endsent='undef'
+ d_endspent='undef'
+ d_eofnblk='define'
+ d_eunice='undef'
+ d_fchdir='undef'
+ d_fchmod='undef'
+ d_fchown='undef'
+ d_fcntl='undef'
+ d_fd_macros='define'
+ d_fd_set='define'
+ d_fds_bits='define'
+ d_fgetpos='define'
+ d_flexfnam='define'
+ d_flock='define'
+ d_fork='undef'
+ d_fpathconf='undef'
+ d_fpos64_t='undef'
+ d_fs_data_s='undef'
+ d_fseeko='undef'
+ d_fsetpos='define'
+ d_fstatfs='undef'
+ d_fstatvfs='undef'
+ d_ftello='undef'
+ d_ftime='define'
+ d_getcwd='undef'
+ d_getfsstat='undef'
+ d_getgrent='undef'
+ d_getgrps='undef'
+ d_gethbyaddr='define'
+ d_gethbyname='define'
+ d_gethent='undef'
+ d_gethname='define'
+ d_gethostprotos='define'
+ d_getlogin='define'
+ d_getmnt='undef'
+ d_getmntent='undef'
+ d_getnbyaddr='undef'
+ d_getnbyname='undef'
+ d_getnent='undef'
+ d_getnetprotos='define'
+ d_getpbyname='define'
+ d_getpbynumber='define'
+ d_getpent='undef'
+ d_getpgid='undef'
+ d_getpgrp2='undef'
+ d_getpgrp='undef'
+ d_getppid='undef'
+ d_getprior='undef'
+ d_getprotoprotos='define'
+ d_getpwent='undef'
+ d_getsbyname='define'
+ d_getsbyport='define'
+ d_getsent='undef'
+ d_getservprotos='define'
+ d_getspent='undef'
+ d_getspnam='undef'
+ d_gettimeod='undef'
+ d_gnulibc='undef'
+ d_grpasswd='undef'
+ d_hasmntopt='undef'
+ d_htonl='define'
+ d_iconv='undef'
+ d_index='undef'
+ d_inetaton='undef'
+ d_int64_t='undef'
+ d_isascii='define'
+ d_killpg='undef'
+ d_lchown='undef'
+ d_ldbl_dig='define'
+ d_link='define'
+ d_locconv='define'
+ d_lockf='undef'
+ d_longdbl='define'
+ d_longlong='undef'
+ d_lseekproto='define'
+ d_lstat='undef'
+ d_madvise='undef'
+ d_mblen='define'
+ d_mbstowcs='define'
+ d_mbtowc='define'
+ d_memchr='define'
+ d_memcmp='define'
+ d_memcpy='define'
+ d_memmove='define'
+ d_memset='define'
+ d_mkdir='define'
+ d_mkdtemp='undef'
+ d_mkfifo='undef'
+ d_mkstemp='undef'
+ d_mkstemps='undef'
+ d_mktime='define'
+ d_mmap='undef'
+ d_mprotect='undef'
+ d_msg='undef'
+ d_msg_ctrunc='undef'
+ d_msg_dontroute='undef'
+ d_msg_oob='undef'
+ d_msg_peek='undef'
+ d_msg_proxy='undef'
+ d_msgctl='undef'
+ d_msgget='undef'
+ d_msgrcv='undef'
+ d_msgsnd='undef'
+ d_msync='undef'
+ d_munmap='undef'
+ d_mymalloc='undef'
+ d_nice='undef'
+ d_nl_langinfo='undef'
+ d_nv_preserves_uv='define'
+ d_off64_t='undef'
+ d_old_pthread_create_joinable='undef'
+ d_oldpthreads='undef'
+ d_oldsock='undef'
+ d_open3='undef'
+ d_pathconf='undef'
+ d_pause='undef'
+ d_phostname='undef'
+ d_pipe='define'
+ d_poll='undef'
+ d_portable='define'
+ d_pthread_atfork='undef'
+ d_pthread_yield='undef'
+ d_pwage='undef'
+ d_pwchange='undef'
+ d_pwclass='undef'
+ d_pwcomment='undef'
+ d_pwexpire='undef'
+ d_pwgecos='undef'
+ d_pwpasswd='undef'
+ d_pwquota='undef'
+ d_qgcvt='undef'
+ d_quad='undef'
+ d_readdir='define'
+ d_readlink='undef'
+ d_rename='define'
+ d_rewinddir='define'
+ d_rmdir='define'
+ d_safebcpy='undef'
+ d_safemcpy='undef'
+ d_sanemcmp='define'
+ d_sched_yield='undef'
+ d_scm_rights='undef'
+ d_seekdir='define'
+ d_select='define'
+ d_sem='undef'
+ d_semctl='undef'
+ d_semctl_semid_ds='undef'
+ d_semctl_semun='undef'
+ d_semget='undef'
+ d_semop='undef'
+ d_setegid='undef'
+ d_seteuid='undef'
+ d_setgrent='undef'
+ d_setgrps='undef'
+ d_sethent='undef'
+ d_setlinebuf='undef'
+ d_setlocale='define'
+ d_setnent='undef'
+ d_setpent='undef'
+ d_setpgid='undef'
+ d_setpgrp2='undef'
+ d_setpgrp='undef'
+ d_setprior='undef'
+ d_setpwent='undef'
+ d_setregid='undef'
+ d_setresgid='undef'
+ d_setresuid='undef'
+ d_setreuid='undef'
+ d_setrgid='undef'
+ d_setruid='undef'
+ d_setsent='undef'
+ d_setsid='undef'
+ d_setspent='undef'
+ d_setvbuf='define'
+ d_sfio='undef'
+ d_shm='undef'
+ d_shmat='undef'
+ d_shmatprototype='undef'
+ d_shmctl='undef'
+ d_shmdt='undef'
+ d_shmget='undef'
+ d_sigaction='undef'
+ d_sigsetjmp='undef'
+ d_socket='define'
+ d_socklen_t='undef'
+ d_sockpair='undef'
+ d_sqrtl='undef'
+ d_statblks='undef'
+ d_statfs_f_flags='undef'
+ d_statfs_s='undef'
+ d_statvfs='undef'
+ d_stdio_cnt_lval='undef'
+ d_stdio_ptr_lval='undef'
+ d_stdio_stream_array='undef'
+ d_stdiobase='undef'
+ d_stdstdio='undef'
+ d_strchr='define'
+ d_strcoll='define'
+ d_strctcpy='define'
+ d_strerrm='strerror(e)'
+ d_strerror='define'
+ d_strftime='define'
+ d_strtod='define'
+ d_strtol='define'
+ d_strtold='undef'
+ d_strtoll='undef'
+ d_strtoul='define'
+ d_strtoull='undef'
+ d_strtouq='undef'
+ d_strxfrm='define'
+ d_suidsafe='undef'
+ d_symlink='undef'
+ d_syscall='undef'
+ d_sysconf='undef'
+ d_sysernlst=''
+ d_syserrlst='define'
+ d_system='define'
+ d_tcgetpgrp='undef'
+ d_tcsetpgrp='undef'
+ d_telldir='define'
+ d_telldirproto='define'
+ d_time='define'
+ d_times='undef'
+ d_truncate='undef'
+ d_tzname='define'
+ d_umask='define'
+ d_uname='define'
+ d_union_semun='define'
+ d_ustat='undef'
+ d_vendorarch='undef'
+ d_vendorbin='undef'
+ d_vendorlib='undef'
+ d_vfork='undef'
+ d_void_closedir='undef'
+ d_voidsig='define'
+ d_voidtty=''
+ d_volatile='define'
+ d_vprintf='define'
+ d_wait4='undef'
+ d_waitpid='define'
+ d_wcstombs='define'
+ d_wctomb='define'
+ d_xenix='undef'
+ date='date'
+ db_hashtype='int'
+ db_prefixtype='int'
+ defvoidused='15'
+ def_perlroot='sys:\perl\scripts'
+ def_temp='sys:\perl\temp'
+ direntrytype='DIR'
+ dlext='nlp'
+ dlsrc='dl_netware.xs'
+ doublesize='8'
+ drand01='(rand()/(double)((unsigned)1<<RANDBITS))'
+ dynamic_ext='Socket IO Fcntl Opcode SDBM_File attrs Thread'
+ eagain='EAGAIN'
+ ebcdic='undef'
+ echo='echo'
+ egrep='egrep'
+ emacs=''
+ eunicefix=':'
+ exe_ext='.exe'
+ expr='expr'
+ extensions='~static_ext~ ~dynamic_ext~ ~nonxs_ext~'
+ fflushNULL='define'
+ fflushall='undef'
+ find='find'
+ firstmakefile='makefile'
+ flex=''
+ fpossize='4'
+ fpostype='fpos_t'
+ freetype='void'
+ full_ar=''
+ full_csh=''
+ full_sed=''
+ gccversion=''
+ gidformat='"ld"'
+ gidsign='-1'
+ gidsize='4'
+ gidtype='gid_t'
+ glibpth='/usr/shlib /lib/pa1.1 /usr/lib/large /lib /usr/lib /usr/lib/386 /lib/386 /lib/large /usr/lib/small /lib/small /usr/ccs/lib /usr/ucblib /usr/shlib '
+ grep='grep'
+ groupcat=''
+ groupstype='gid_t'
+ gzip='gzip'
+ h_fcntl='false'
+ h_sysfile='true'
+ hint='recommended'
+ hostcat='ypcat hosts'
+ huge=''
+ i16size='2'
+ i16type='short'
+ i32size='4'
+ i32type='long'
+ i64size='8'
+ i64type='__int64'
+ i8size='1'
+ i8type='char'
+ i_arpainet='define'
+ i_bsdioctl=''
+ i_db='undef'
+ i_dbm='undef'
+ i_dirent='define'
+ i_dld='undef'
+ i_dlfcn='define'
+ i_fcntl='define'
+ i_float='define'
+ i_gdbm='undef'
+ i_grp='undef'
+ i_iconv='undef'
+ i_ieeefp='undef'
+ i_inttypes='undef'
+ i_langinfo='undef'
+ i_limits='define'
+ i_locale='define'
+ i_machcthr='undef'
+ i_malloc='define'
+ i_math='define'
+ i_memory='undef'
+ i_mntent='undef'
+ i_ndbm='undef'
+ i_netdb='define'
+ i_neterrno='undef'
+ i_netinettcp='undef'
+ i_niin='define'
+ i_poll='undef'
+ i_pthread='undef'
+ i_pwd='undef'
+ i_rpcsvcdbm='define'
+ i_sfio='undef'
+ i_sgtty='undef'
+ i_shadow='undef'
+ i_socks='undef'
+ i_stdarg='define'
+ i_stddef='define'
+ i_stdlib='define'
+ i_string='define'
+ i_sunmath='undef'
+ i_sysaccess='undef'
+ i_sysdir='undef'
+ i_sysfile='undef'
+ i_sysfilio='define'
+ i_sysin='undef'
+ i_sysioctl='define'
+ i_syslog='undef'
+ i_sysmman='undef'
+ i_sysmode='undef'
+ i_sysmount='undef'
+ i_sysndir='undef'
+ i_sysparam='undef'
+ i_sysresrc='undef'
+ i_syssecrt='undef'
+ i_sysselct='undef'
+ i_syssockio='define'
+ i_sysstatfs='undef'
+ i_sysstatvfs='undef'
+ i_sysstat='define'
+ i_systime='undef'
+ i_systimek='undef'
+ i_systimes='undef'
+ i_systypes='define'
+ i_sysuio='undef'
+ i_sysun='undef'
+ i_sysutsname='define'
+ i_sysvfs='undef'
+ i_syswait='undef'
+ i_termio='undef'
+ i_termios='undef'
+ i_time='define'
+ i_unistd='undef'
+ i_ustat='undef'
+ i_utime='define'
+ i_values='undef'
+ i_varargs='undef'
+ i_varhdr='varargs.h'
+ i_vfork='undef'
+ ignore_versioned_solibs=''
+ inc_version_list=''
+ inc_version_list_init='0'
+ incpath=''
+ inews=''
+ installarchlib='~INST_TOP~~INST_VER~\lib~INST_ARCH~'
+ installbin='~INST_TOP~~INST_VER~\bin~INST_ARCH~'
+ installman1dir='~INST_TOP~~INST_VER~\man\man1'
+ installman3dir='~INST_TOP~~INST_VER~\man\man3'
+ installnwlib='~INST_NW_TOP2~~INST_NW_VER~\lib'
+ installnwscripts='~INST_NW_TOP2~~INST_NW_VER~\scripts'
+ installnwlcgi='~INST_NW_TOP2~~INST_NW_VER~\lcgi'
+ installnwsystem='~INST_NW_TOP2~~INST_NW_VER~\system'
+ installprefix='~INST_TOP~~INST_VER~'
+ installprefixexp='~INST_TOP~~INST_VER~'
+ installhtmldir='~INST_TOP~~INST_VER~\html'
+ installhtmlhelpdir='~INST_TOP~~INST_VER~\htmlhelp'
+ installprivlib='~INST_TOP~~INST_VER~\lib'
+ installscript='~INST_TOP~~INST_VER~\bin'
+ installsitearch='~INST_TOP~\site~INST_VER~\lib~INST_ARCH~'
+ installsitebin='~INST_TOP~~INST_VER~\bin~INST_ARCH~'
+ installsitelib='~INST_TOP~\site~INST_VER~\lib'
+ installstyle='lib'
+ installusrbinperl='undef'
+ installvendorarch=''
+ installvendorbin=''
+ installvendorlib=''
+ intsize='4'
+ ivdformat='"ld"'
+ ivsize='4'
+ ivtype='long'
+ known_extensions='~static_ext~ ~dynamic_ext~ ~nonxs_ext~'
+ ksh=''
+ large=''
+ ld='link'
+ lddlflags='-dll ~LINK_FLAGS~'
+ ldflags='~LINK_FLAGS~'
+ ldlibpthname=''
+ less='less'
+ lib_ext='.lib'
+ libc=''
+ libperl='perl.lib'
+ libpth=''
+ libs=''
+ libsdirs=''
+ libsfiles=''
+ libsfound=''
+ libspath=''
+ libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x'
+ line='line'
+ lint=''
+ lkflags=''
+ ln=''
+ lns='copy'
+ locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include'
+ loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib'
+ longdblsize='10'
+ longlongsize='8'
+ longsize='4'
+ lp=''
+ lpr=''
+ ls='dir'
+ lseeksize='4'
+ lseektype='off_t'
+ mail=''
+ mailx=''
+ make='nmake'
+ make_set_make='#'
+ mallocobj='malloc.o'
+ mallocsrc='malloc.c'
+ malloctype='void *'
+ man1dir='~INST_TOP~~INST_VER~\man\man1'
+ man1direxp='~INST_TOP~~INST_VER~\man\man1'
+ man1ext='1'
+ man3dir='~INST_TOP~~INST_VER~\man\man3'
+ man3direxp='~INST_TOP~~INST_VER~\man\man3'
+ man3ext='3'
+ medium=''
+ mips_type=''
+ mkdir='mkdir'
+ mmaptype='void *'
+ models='none'
+ modetype='mode_t'
+ more='more /e'
+ multiarch='undef'
+ mv=''
+ myarchname='MSWin32'
+ mydomain=''
+ myhostname=''
+ myuname=''
+ n='-n'
+ netdb_hlen_type='int'
+ netdb_host_type='char *'
+ netdb_name_type='char *'
+ netdb_net_type='long'
+ nm=''
+ nm_opt=''
+ nm_so_opt=''
+ nonxs_ext='Errno'
+ nroff=''
+ nvEUformat='"E"'
+ nvFUformat='"F"'
+ nvGUformat='"G"'
+ nveformat='"e"'
+ nvfformat='"f"'
+ nvgformat='"g"'
+ nvsize='8'
+ nvtype='double'
+ o_nonblock='O_NONBLOCK'
+ obj_ext='.obj'
+ old_pthread_create_joinable=''
+ optimize='-O'
+ orderlib='false'
+ osname='NetWare'
+ osvers='5.x'
+ package='perl5'
+ pager='more /e'
+ passcat=''
+ patchlevel='~PATCHLEVEL~'
+ path_sep=';'
+ perl5=''
+ perl='perl'
+ perladmin=''
+ perlpath='~INST_TOP~~INST_VER~\bin~INST_ARCH~\perl.nlm'
+ pg=''
+ phostname='hostname'
+ pidtype='int'
+ plibpth=''
+ pm_apiversion='5.005'
+ pmake=''
+ pr=''
+ prefix='~INST_TOP~'
+ prefixexp='~INST_DRV~'
+ privlib='~INST_NW_TOP1~\lib'
+ privlibexp='~INST_TOP~~INST_VER~\lib'
+ prototype='define'
+ ptrsize='4'
+ quadkind='5'
+ quadtype='__int64'
+ randbits='15'
+ randfunc='rand'
+ randseedtype='unsigned'
+ ranlib='rem'
+ rd_nodata='-1'
+ revision='5'
+ rm='del'
+ rmail=''
+ runnm='true'
+ sPRIEldbl='"E"'
+ sPRIFldbl='"F"'
+ sPRIGldbl='"G"'
+ sPRIX64='"lX"'
+ sPRId64='"ld"'
+ sPRIeldbl='"e"'
+ sPRIfldbl='"f"'
+ sPRIgldbl='"g"'
+ sPRIi64='"li"'
+ sPRIo64='"lo"'
+ sPRIu64='"lu"'
+ sPRIx64='"lx"'
+ sched_yield=''
+ scriptdir='~INST_TOP~~INST_VER~\bin'
+ scriptdirexp='~INST_TOP~~INST_VER~\bin'
+ sed='sed'
+ seedfunc='srand'
+ selectminbits='32'
+ selecttype='fd_set *'
+ sendmail='blat'
+ sh='cmd /x /c'
+ shar=''
+ sharpbang='#!'
+ shmattype='void *'
+ shortsize='2'
+ shrpenv=''
+ shsharp='true'
+ sig_count='26'
+ sig_name='ZERO NUM01 INT QUIT ILL NUM05 NUM06 NUM07 FPE KILL NUM10 SEGV NUM12 PIPE ALRM TERM NUM16 NUM17 NUM18 NUM19 CHLD BREAK ABRT STOP NUM24 CONT CLD'
+ sig_name_init='"ZERO", "NUM01", "INT", "QUIT", "ILL", "NUM05", "NUM06", "NUM07", "FPE", "KILL", "NUM10", "SEGV", "NUM12", "PIPE", "ALRM", "TERM", "NUM16", "NUM17", "NUM18", "NUM19", "CHLD", "BREAK", "ABRT", "STOP", "NUM24", "CONT", "CLD", 0'
+ sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 20 0'
+ sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 20, 0'
+ sig_size='27'
+ signal_t='void'
+ sitearch='~INST_TOP~\site~INST_VER~\lib~INST_ARCH~'
+ sitearchexp='~INST_TOP~\site~INST_VER~\lib~INST_ARCH~'
+ sitebin='~INST_TOP~\site~INST_VER~\bin~INST_ARCH~'
+ sitebinexp='~INST_TOP~\site~INST_VER~\bin~INST_ARCH~'
+ sitelib='~INST_TOP~\site~INST_VER~\lib'
+ sitelib_stem=''
+ sitelibexp='~INST_TOP~\site~INST_VER~\lib'
+ siteprefix='~INST_TOP~\site~INST_VER~'
+ siteprefixexp='~INST_TOP~\site~INST_VER~'
+ sizesize='4'
+ sizetype='size_t'
+ sleep=''
+ smail=''
+ small=''
+ so='dll'
+ sockethdr=''
+ socketlib=''
+ socksizetype='int'
+ sort='sort'
+ spackage='Perl5'
+ spitshell=''
+ split=''
+ src=''
+ ssizetype='int'
+ startperl='#!perl'
+ startsh='#!/bin/sh'
+ static_ext='DynaLoader'
+ stdchar='char'
+ stdio_base='((fp)->_base)'
+ stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)'
+ stdio_cnt='((fp)->_cnt)'
+ stdio_filbuf=''
+ stdio_ptr='((fp)->_ptr)'
+ stdio_stream_array=''
+ strings='/usr/include/string.h'
+ submit=''
+ subversion='~SUBVERSION~'
+ sysman='/usr/man/man1'
+ tail=''
+ tar=''
+ tbl=''
+ tee=''
+ test=''
+ timeincl='/usr/include/sys/time.h '
+ timetype='time_t'
+ touch='touch'
+ tr=''
+ trnl='\012'
+ troff=''
+ u16size='2'
+ u16type='unsigned short'
+ u32size='4'
+ u32type='unsigned long'
+ u64size='8'
+ u64type='unsigned __int64'
+ u8size='1'
+ u8type='unsigned char'
+ uidformat='"ld"'
+ uidsign='-1'
+ uidsize='4'
+ uidtype='uid_t'
+ uname='uname'
+ uniq='uniq'
+ uquadtype='unsigned __int64'
+ use5005threads='undef'
+ use64bitall='undef'
+ use64bitint='undef'
+ usedl='define'
+ useithreads='define'
+ uselargefiles='undef'
+ uselongdouble='undef'
+ usemorebits='undef'
+ usemultiplicity='define'
+ usemymalloc='n'
+ usenm='false'
+ useopcode='true'
+ useperlio='undef'
+ useposix='true'
+ usesfio='false'
+ useshrplib='yes'
+ usesocks='undef'
+ usethreads='undef'
+ usevendorprefix='undef'
+ usevfork='true'
+ usrinc='/usr/include'
+ uuname=''
+ uvoformat='"lo"'
+ uvsize='4'
+ uvtype='unsigned long'
+ uvuformat='"lu"'
+ uvxformat='"lx"'
+ vendorarch=''
+ vendorarchexp=''
+ vendorbin=''
+ vendorbinexp=''
+ vendorlib=''
+ vendorlib_stem=''
+ vendorlibexp=''
+ vendorprefix=''
+ vendorprefixexp=''
+ version='~VERSION~'
+ vi=''
+ voidflags='15'
+ xlibpth='/usr/lib/386 /lib/386'
+ xs_apiversion='5.6.0'
+ zcat=''
+ zip='zip'
+ PERL_REVISION='~PERL_REVISION~'
+ PERL_SUBVERSION='~PERL_SUBVERSION~'
+ PERL_VERSION='~PERL_VERSION~'
+ PERL_API_REVISION='~PERL_API_REVISION~'
+ PERL_API_SUBVERSION='~PERL_API_SUBVERSION~'
+ PERL_API_VERSION='~PERL_API_VERSION~'
+ PATCHLEVEL='~PERL_VERSION~'
+ SUBVERSION='~PERL_SUBVERSION~'
+ base_import=''
+ nlm_version=''
+ mpktool=''
+ toolpath=''
diff -c /dev/null 'perl-5.7.2/NetWare/config_H.wc'
Index: ./NetWare/config_H.wc
*** ./NetWare/config_H.wc Thu Jan 1 02:00:00 1970
--- ./NetWare/config_H.wc Fri Jul 13 03:20:48 2001
***************
*** 0 ****
--- 1,3455 ----
+ /*
+ * This file was produced by running the config_h.SH script, which
+ * gets its values from undef, which is generally produced by
+ * running Configure.
+ *
+ * Feel free to modify any of this as the need arises. Note, however,
+ * that running config_h.SH again will wipe out any changes you've made.
+ * For a more permanent change edit undef and rerun config_h.SH.
+ *
+ * $Id: Config_h.U,v 3.0.1.5 1997/02/28 14:57:43 ram Exp $
+ */
+
+ /*
+ * Package name : perl5
+ * Source directory :
+ * Configuration time: Thu Jun 21 17:44:02 2001
+ * Configured by : Administrator
+ * Target system :
+ */
+
+ #ifndef _config_h_
+ #define _config_h_
+
+ /* LOC_SED:
+ * This symbol holds the complete pathname to the sed program.
+ */
+ #define LOC_SED "" /**/
+
+ /* HAS_ALARM:
+ * This symbol, if defined, indicates that the alarm routine is
+ * available.
+ */
+ /*#define HAS_ALARM /**/
+
+ /* HASATTRIBUTE:
+ * This symbol indicates the C compiler can check for function attributes,
+ * such as printf formats. This is normally only supported by GNU cc.
+ */
+ /*#define HASATTRIBUTE /**/
+ #ifndef HASATTRIBUTE
+ #define __attribute__(_arg_)
+ #endif
+
+ /* HAS_BCMP:
+ * This symbol is defined if the bcmp() routine is available to
+ * compare blocks of memory.
+ */
+ /*#define HAS_BCMP /**/
+
+ /* HAS_BCOPY:
+ * This symbol is defined if the bcopy() routine is available to
+ * copy blocks of memory.
+ */
+ /*#define HAS_BCOPY /**/
+
+ /* HAS_BZERO:
+ * This symbol is defined if the bzero() routine is available to
+ * set a memory block to 0.
+ */
+ /*#define HAS_BZERO /**/
+
+ /* HAS_CHOWN:
+ * This symbol, if defined, indicates that the chown routine is
+ * available.
+ */
+ /*#define HAS_CHOWN /**/
+
+ /* HAS_CHROOT:
+ * This symbol, if defined, indicates that the chroot routine is
+ * available.
+ */
+ /*#define HAS_CHROOT /**/
+
+ /* HAS_CHSIZE:
+ * This symbol, if defined, indicates that the chsize routine is available
+ * to truncate files. You might need a -lx to get this routine.
+ */
+ #define HAS_CHSIZE /**/
+
+ /* HASCONST:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the const type. There is no need to actually test for that symbol
+ * within your programs. The mere use of the "const" keyword will
+ * trigger the necessary tests.
+ */
+ #define HASCONST /**/
+ #ifndef HASCONST
+ #define const
+ #endif
+
+ /* HAS_CRYPT:
+ * This symbol, if defined, indicates that the crypt routine is available
+ * to encrypt passwords and the like.
+ */
+ /*#define HAS_CRYPT /**/
+
+ /* HAS_CUSERID:
+ * This symbol, if defined, indicates that the cuserid routine is
+ * available to get character login names.
+ */
+ /*#define HAS_CUSERID /**/
+
+ /* HAS_DBL_DIG:
+ * This symbol, if defined, indicates that this system's <float.h>
+ * or <limits.h> defines the symbol DBL_DIG, which is the number
+ * of significant digits in a double precision number. If this
+ * symbol is not defined, a guess of 15 is usually pretty good.
+ */
+ #define HAS_DBL_DIG /**/
+
+ /* HAS_DIFFTIME:
+ * This symbol, if defined, indicates that the difftime routine is
+ * available.
+ */
+ #define HAS_DIFFTIME /**/
+
+ /* HAS_DLERROR:
+ * This symbol, if defined, indicates that the dlerror routine is
+ * available to return a string describing the last error that
+ * occurred from a call to dlopen(), dlclose() or dlsym().
+ */
+ #define HAS_DLERROR /**/
+
+ /* HAS_DUP2:
+ * This symbol, if defined, indicates that the dup2 routine is
+ * available to duplicate file descriptors.
+ */
+ #define HAS_DUP2 /**/
+
+ /* HAS_FCHDIR:
+ * This symbol, if defined, indicates that the fchdir routine is
+ * available to change directory using a file descriptor.
+ */
+ /*#define HAS_FCHDIR /**/
+
+ /* HAS_FCHMOD:
+ * This symbol, if defined, indicates that the fchmod routine is available
+ * to change mode of opened files. If unavailable, use chmod().
+ */
+ /*#define HAS_FCHMOD /**/
+
+ /* HAS_FCHOWN:
+ * This symbol, if defined, indicates that the fchown routine is available
+ * to change ownership of opened files. If unavailable, use chown().
+ */
+ /*#define HAS_FCHOWN /**/
+
+ /* HAS_FCNTL:
+ * This symbol, if defined, indicates to the C program that
+ * the fcntl() function exists.
+ */
+ /*#define HAS_FCNTL /**/
+
+ /* HAS_FGETPOS:
+ * This symbol, if defined, indicates that the fgetpos routine is
+ * available to get the file position indicator, similar to ftell().
+ */
+ #define HAS_FGETPOS /**/
+
+ /* HAS_FLOCK:
+ * This symbol, if defined, indicates that the flock routine is
+ * available to do file locking.
+ */
+ #define HAS_FLOCK /**/
+
+ /* HAS_FORK:
+ * This symbol, if defined, indicates that the fork routine is
+ * available.
+ */
+ /*#define HAS_FORK /**/
+
+ /* HAS_FSETPOS:
+ * This symbol, if defined, indicates that the fsetpos routine is
+ * available to set the file position indicator, similar to fseek().
+ */
+ #define HAS_FSETPOS /**/
+
+ /* HAS_GETTIMEOFDAY:
+ * This symbol, if defined, indicates that the gettimeofday() system
+ * call is available for a sub-second accuracy clock. Usually, the file
+ * <sys/resource.h> needs to be included (see I_SYS_RESOURCE).
+ * The type "Timeval" should be used to refer to "struct timeval".
+ */
+ /*#define HAS_GETTIMEOFDAY /**/
+ #ifdef HAS_GETTIMEOFDAY
+ #define Timeval struct timeval /* Structure used by gettimeofday() */
+ #endif
+
+ /* HAS_GETGROUPS:
+ * This symbol, if defined, indicates that the getgroups() routine is
+ * available to get the list of process groups. If unavailable, multiple
+ * groups are probably not supported.
+ */
+ /*#define HAS_GETGROUPS /**/
+
+ /* HAS_GETLOGIN:
+ * This symbol, if defined, indicates that the getlogin routine is
+ * available to get the login name.
+ */
+ #define HAS_GETLOGIN /**/
+
+ /* HAS_GETPGID:
+ * This symbol, if defined, indicates to the C program that
+ * the getpgid(pid) function is available to get the
+ * process group id.
+ */
+ /*#define HAS_GETPGID /**/
+
+ /* HAS_GETPGRP2:
+ * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX)
+ * routine is available to get the current process group.
+ */
+ /*#define HAS_GETPGRP2 /**/
+
+ /* HAS_GETPPID:
+ * This symbol, if defined, indicates that the getppid routine is
+ * available to get the parent process ID.
+ */
+ /*#define HAS_GETPPID /**/
+
+ /* HAS_GETPRIORITY:
+ * This symbol, if defined, indicates that the getpriority routine is
+ * available to get a process's priority.
+ */
+ /*#define HAS_GETPRIORITY /**/
+
+ /* HAS_INET_ATON:
+ * This symbol, if defined, indicates to the C program that the
+ * inet_aton() function is available to parse IP address "dotted-quad"
+ * strings.
+ */
+ /*#define HAS_INET_ATON /**/
+
+ /* HAS_KILLPG:
+ * This symbol, if defined, indicates that the killpg routine is available
+ * to kill process groups. If unavailable, you probably should use kill
+ * with a negative process number.
+ */
+ /*#define HAS_KILLPG /**/
+
+ /* HAS_LINK:
+ * This symbol, if defined, indicates that the link routine is
+ * available to create hard links.
+ */
+ #define HAS_LINK /**/
+
+ /* HAS_LOCALECONV:
+ * This symbol, if defined, indicates that the localeconv routine is
+ * available for numeric and monetary formatting conventions.
+ */
+ #define HAS_LOCALECONV /**/
+
+ /* HAS_LOCKF:
+ * This symbol, if defined, indicates that the lockf routine is
+ * available to do file locking.
+ */
+ /*#define HAS_LOCKF /**/
+
+ /* HAS_LSTAT:
+ * This symbol, if defined, indicates that the lstat routine is
+ * available to do file stats on symbolic links.
+ */
+ /*#define HAS_LSTAT /**/
+
+ /* HAS_MBLEN:
+ * This symbol, if defined, indicates that the mblen routine is available
+ * to find the number of bytes in a multibye character.
+ */
+ #define HAS_MBLEN /**/
+
+ /* HAS_MBSTOWCS:
+ * This symbol, if defined, indicates that the mbstowcs routine is
+ * available to covert a multibyte string into a wide character string.
+ */
+ #define HAS_MBSTOWCS /**/
+
+ /* HAS_MBTOWC:
+ * This symbol, if defined, indicates that the mbtowc routine is available
+ * to covert a multibyte to a wide character.
+ */
+ #define HAS_MBTOWC /**/
+
+ /* HAS_MEMCMP:
+ * This symbol, if defined, indicates that the memcmp routine is available
+ * to compare blocks of memory.
+ */
+ #define HAS_MEMCMP /**/
+
+ /* HAS_MEMCPY:
+ * This symbol, if defined, indicates that the memcpy routine is available
+ * to copy blocks of memory.
+ */
+ #define HAS_MEMCPY /**/
+
+ /* HAS_MEMMOVE:
+ * This symbol, if defined, indicates that the memmove routine is available
+ * to copy potentially overlapping blocks of memory. This should be used
+ * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your
+ * own version.
+ */
+ #define HAS_MEMMOVE /**/
+
+ /* HAS_MEMSET:
+ * This symbol, if defined, indicates that the memset routine is available
+ * to set blocks of memory.
+ */
+ #define HAS_MEMSET /**/
+
+ /* HAS_MKDIR:
+ * This symbol, if defined, indicates that the mkdir routine is available
+ * to create directories. Otherwise you should fork off a new process to
+ * exec /bin/mkdir.
+ */
+ #define HAS_MKDIR /**/
+
+ /* HAS_MKFIFO:
+ * This symbol, if defined, indicates that the mkfifo routine is
+ * available to create FIFOs. Otherwise, mknod should be able to
+ * do it for you. However, if mkfifo is there, mknod might require
+ * super-user privileges which mkfifo will not.
+ */
+ /*#define HAS_MKFIFO /**/
+
+ /* HAS_MKTIME:
+ * This symbol, if defined, indicates that the mktime routine is
+ * available.
+ */
+ #define HAS_MKTIME /**/
+
+ /* HAS_MSYNC:
+ * This symbol, if defined, indicates that the msync system call is
+ * available to synchronize a mapped file.
+ */
+ /*#define HAS_MSYNC /**/
+
+ /* HAS_MUNMAP:
+ * This symbol, if defined, indicates that the munmap system call is
+ * available to unmap a region, usually mapped by mmap().
+ */
+ /*#define HAS_MUNMAP /**/
+
+ /* HAS_NICE:
+ * This symbol, if defined, indicates that the nice routine is
+ * available.
+ */
+ /*#define HAS_NICE /**/
+
+ /* HAS_PATHCONF:
+ * This symbol, if defined, indicates that pathconf() is available
+ * to determine file-system related limits and options associated
+ * with a given filename.
+ */
+ /* HAS_FPATHCONF:
+ * This symbol, if defined, indicates that pathconf() is available
+ * to determine file-system related limits and options associated
+ * with a given open file descriptor.
+ */
+ /*#define HAS_PATHCONF /**/
+ /*#define HAS_FPATHCONF /**/
+
+ /* HAS_PAUSE:
+ * This symbol, if defined, indicates that the pause routine is
+ * available to suspend a process until a signal is received.
+ */
+ /*#define HAS_PAUSE /**/
+
+ /* HAS_PIPE:
+ * This symbol, if defined, indicates that the pipe routine is
+ * available to create an inter-process channel.
+ */
+ #define HAS_PIPE /**/
+
+ /* HAS_POLL:
+ * This symbol, if defined, indicates that the poll routine is
+ * available to poll active file descriptors. You may safely
+ * include <poll.h> when this symbol is defined.
+ */
+ /*#define HAS_POLL /**/
+
+ /* HAS_READDIR:
+ * This symbol, if defined, indicates that the readdir routine is
+ * available to read directory entries. You may have to include
+ * <dirent.h>. See I_DIRENT.
+ */
+ #define HAS_READDIR /**/
+
+ /* HAS_SEEKDIR:
+ * This symbol, if defined, indicates that the seekdir routine is
+ * available. You may have to include <dirent.h>. See I_DIRENT.
+ */
+ #define HAS_SEEKDIR /**/
+
+ /* HAS_TELLDIR:
+ * This symbol, if defined, indicates that the telldir routine is
+ * available. You may have to include <dirent.h>. See I_DIRENT.
+ */
+ #define HAS_TELLDIR /**/
+
+ /* HAS_REWINDDIR:
+ * This symbol, if defined, indicates that the rewinddir routine is
+ * available. You may have to include <dirent.h>. See I_DIRENT.
+ */
+ #define HAS_REWINDDIR /**/
+
+ /* HAS_READLINK:
+ * This symbol, if defined, indicates that the readlink routine is
+ * available to read the value of a symbolic link.
+ */
+ /*#define HAS_READLINK /**/
+
+ /* HAS_RENAME:
+ * This symbol, if defined, indicates that the rename routine is available
+ * to rename files. Otherwise you should do the unlink(), link(), unlink()
+ * trick.
+ */
+ #define HAS_RENAME /**/
+
+ /* HAS_RMDIR:
+ * This symbol, if defined, indicates that the rmdir routine is
+ * available to remove directories. Otherwise you should fork off a
+ * new process to exec /bin/rmdir.
+ */
+ #define HAS_RMDIR /**/
+
+ /* HAS_SELECT:
+ * This symbol, if defined, indicates that the select routine is
+ * available to select active file descriptors. If the timeout field
+ * is used, <sys/time.h> may need to be included.
+ */
+ #define HAS_SELECT /**/
+
+ /* HAS_SETEGID:
+ * This symbol, if defined, indicates that the setegid routine is available
+ * to change the effective gid of the current program.
+ */
+ /*#define HAS_SETEGID /**/
+
+ /* HAS_SETEUID:
+ * This symbol, if defined, indicates that the seteuid routine is available
+ * to change the effective uid of the current program.
+ */
+ /*#define HAS_SETEUID /**/
+
+ /* HAS_SETLINEBUF:
+ * This symbol, if defined, indicates that the setlinebuf routine is
+ * available to change stderr or stdout from block-buffered or unbuffered
+ * to a line-buffered mode.
+ */
+ /*#define HAS_SETLINEBUF /**/
+
+ /* HAS_SETLOCALE:
+ * This symbol, if defined, indicates that the setlocale routine is
+ * available to handle locale-specific ctype implementations.
+ */
+ #define HAS_SETLOCALE /**/
+
+ /* HAS_SETPGID:
+ * This symbol, if defined, indicates that the setpgid(pid, gpid)
+ * routine is available to set process group ID.
+ */
+ /*#define HAS_SETPGID /**/
+
+ /* HAS_SETPGRP2:
+ * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX)
+ * routine is available to set the current process group.
+ */
+ /*#define HAS_SETPGRP2 /**/
+
+ /* HAS_SETPRIORITY:
+ * This symbol, if defined, indicates that the setpriority routine is
+ * available to set a process's priority.
+ */
+ /*#define HAS_SETPRIORITY /**/
+
+ /* HAS_SETREGID:
+ * This symbol, if defined, indicates that the setregid routine is
+ * available to change the real and effective gid of the current
+ * process.
+ */
+ /* HAS_SETRESGID:
+ * This symbol, if defined, indicates that the setresgid routine is
+ * available to change the real, effective and saved gid of the current
+ * process.
+ */
+ /*#define HAS_SETREGID /**/
+ /*#define HAS_SETRESGID /**/
+
+ /* HAS_SETREUID:
+ * This symbol, if defined, indicates that the setreuid routine is
+ * available to change the real and effective uid of the current
+ * process.
+ */
+ /* HAS_SETRESUID:
+ * This symbol, if defined, indicates that the setresuid routine is
+ * available to change the real, effective and saved uid of the current
+ * process.
+ */
+ /*#define HAS_SETREUID /**/
+ /*#define HAS_SETRESUID /**/
+
+ /* HAS_SETRGID:
+ * This symbol, if defined, indicates that the setrgid routine is available
+ * to change the real gid of the current program.
+ */
+ /*#define HAS_SETRGID /**/
+
+ /* HAS_SETRUID:
+ * This symbol, if defined, indicates that the setruid routine is available
+ * to change the real uid of the current program.
+ */
+ /*#define HAS_SETRUID /**/
+
+ /* HAS_SETSID:
+ * This symbol, if defined, indicates that the setsid routine is
+ * available to set the process group ID.
+ */
+ /*#define HAS_SETSID /**/
+
+ /* Shmat_t:
+ * This symbol holds the return type of the shmat() system call.
+ * Usually set to 'void *' or 'char *'.
+ */
+ /* HAS_SHMAT_PROTOTYPE:
+ * This symbol, if defined, indicates that the sys/shm.h includes
+ * a prototype for shmat(). Otherwise, it is up to the program to
+ * guess one. Shmat_t shmat _((int, Shmat_t, int)) is a good guess,
+ * but not always right so it should be emitted by the program only
+ * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs.
+ */
+ #define Shmat_t void * /**/
+ /*#define HAS_SHMAT_PROTOTYPE /**/
+
+ /* HAS_STRCHR:
+ * This symbol is defined to indicate that the strchr()/strrchr()
+ * functions are available for string searching. If not, try the
+ * index()/rindex() pair.
+ */
+ /* HAS_INDEX:
+ * This symbol is defined to indicate that the index()/rindex()
+ * functions are available for string searching.
+ */
+ #define HAS_STRCHR /**/
+ /*#define HAS_INDEX /**/
+
+ /* HAS_STRCOLL:
+ * This symbol, if defined, indicates that the strcoll routine is
+ * available to compare strings using collating information.
+ */
+ #define HAS_STRCOLL /**/
+
+ /* USE_STRUCT_COPY:
+ * This symbol, if defined, indicates that this C compiler knows how
+ * to copy structures. If undefined, you'll need to use a block copy
+ * routine of some sort instead.
+ */
+ #define USE_STRUCT_COPY /**/
+
+ /* HAS_STRTOD:
+ * This symbol, if defined, indicates that the strtod routine is
+ * available to provide better numeric string conversion than atof().
+ */
+ #define HAS_STRTOD /**/
+
+ /* HAS_STRTOL:
+ * This symbol, if defined, indicates that the strtol routine is available
+ * to provide better numeric string conversion than atoi() and friends.
+ */
+ #define HAS_STRTOL /**/
+
+ /* HAS_STRXFRM:
+ * This symbol, if defined, indicates that the strxfrm() routine is
+ * available to transform strings.
+ */
+ #define HAS_STRXFRM /**/
+
+ /* HAS_SYMLINK:
+ * This symbol, if defined, indicates that the symlink routine is available
+ * to create symbolic links.
+ */
+ /*#define HAS_SYMLINK /**/
+
+ /* HAS_SYSCALL:
+ * This symbol, if defined, indicates that the syscall routine is
+ * available to call arbitrary system calls. If undefined, that's tough.
+ */
+ /*#define HAS_SYSCALL /**/
+
+ /* HAS_SYSCONF:
+ * This symbol, if defined, indicates that sysconf() is available
+ * to determine system related limits and options.
+ */
+ /*#define HAS_SYSCONF /**/
+
+ /* HAS_SYSTEM:
+ * This symbol, if defined, indicates that the system routine is
+ * available to issue a shell command.
+ */
+ #define HAS_SYSTEM /**/
+
+ /* HAS_TCGETPGRP:
+ * This symbol, if defined, indicates that the tcgetpgrp routine is
+ * available to get foreground process group ID.
+ */
+ /*#define HAS_TCGETPGRP /**/
+
+ /* HAS_TCSETPGRP:
+ * This symbol, if defined, indicates that the tcsetpgrp routine is
+ * available to set foreground process group ID.
+ */
+ /*#define HAS_TCSETPGRP /**/
+
+ /* HAS_TRUNCATE:
+ * This symbol, if defined, indicates that the truncate routine is
+ * available to truncate files.
+ */
+ /*#define HAS_TRUNCATE /**/
+
+ /* HAS_TZNAME:
+ * This symbol, if defined, indicates that the tzname[] array is
+ * available to access timezone names.
+ */
+ #define HAS_TZNAME /**/
+
+ /* HAS_UMASK:
+ * This symbol, if defined, indicates that the umask routine is
+ * available to set and get the value of the file creation mask.
+ */
+ #define HAS_UMASK /**/
+
+ /* HAS_USLEEP:
+ * This symbol, if defined, indicates that the usleep routine is
+ * available to let the process sleep on a sub-second accuracy.
+ */
+ /*#define HAS_USLEEP /**/
+
+ /* HASVOLATILE:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the volatile declaration.
+ */
+ #define HASVOLATILE /**/
+ #ifndef HASVOLATILE
+ #define volatile
+ #endif
+
+ /* HAS_WAIT4:
+ * This symbol, if defined, indicates that wait4() exists.
+ */
+ /*#define HAS_WAIT4 /**/
+
+ /* HAS_WAITPID:
+ * This symbol, if defined, indicates that the waitpid routine is
+ * available to wait for child process.
+ */
+ #define HAS_WAITPID /**/
+
+ /* HAS_WCSTOMBS:
+ * This symbol, if defined, indicates that the wcstombs routine is
+ * available to convert wide character strings to multibyte strings.
+ */
+ #define HAS_WCSTOMBS /**/
+
+ /* HAS_WCTOMB:
+ * This symbol, if defined, indicates that the wctomb routine is available
+ * to covert a wide character to a multibyte.
+ */
+ #define HAS_WCTOMB /**/
+
+ /* I_ARPA_INET:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <arpa/inet.h> to get inet_addr and friends declarations.
+ */
+ #define I_ARPA_INET /**/
+
+ /* I_DBM:
+ * This symbol, if defined, indicates that <dbm.h> exists and should
+ * be included.
+ */
+ /* I_RPCSVC_DBM:
+ * This symbol, if defined, indicates that <rpcsvc/dbm.h> exists and
+ * should be included.
+ */
+ /*#define I_DBM /**/
+ #define I_RPCSVC_DBM /**/
+
+ /* I_DIRENT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <dirent.h>. Using this symbol also triggers the definition
+ * of the Direntry_t define which ends up being 'struct dirent' or
+ * 'struct direct' depending on the availability of <dirent.h>.
+ */
+ /* DIRNAMLEN:
+ * This symbol, if defined, indicates to the C program that the length
+ * of directory entry names is provided by a d_namlen field. Otherwise
+ * you need to do strlen() on the d_name field.
+ */
+ /* Direntry_t:
+ * This symbol is set to 'struct direct' or 'struct dirent' depending on
+ * whether dirent is available or not. You should use this pseudo type to
+ * portably declare your directory entries.
+ */
+ #define I_DIRENT /**/
+ /*#define DIRNAMLEN /**/
+ #define Direntry_t DIR
+
+ /* I_DLFCN:
+ * This symbol, if defined, indicates that <dlfcn.h> exists and should
+ * be included.
+ */
+ #define I_DLFCN /**/
+
+ /* I_FCNTL:
+ * This manifest constant tells the C program to include <fcntl.h>.
+ */
+ #define I_FCNTL /**/
+
+ /* I_FLOAT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <float.h> to get definition of symbols like DBL_MAX or
+ * DBL_MIN, i.e. machine dependent floating point values.
+ */
+ #define I_FLOAT /**/
+
+ /* I_LIMITS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <limits.h> to get definition of symbols like WORD_BIT or
+ * LONG_MAX, i.e. machine dependant limitations.
+ */
+ #define I_LIMITS /**/
+
+ /* I_LOCALE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <locale.h>.
+ */
+ #define I_LOCALE /**/
+
+ /* I_MATH:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <math.h>.
+ */
+ #define I_MATH /**/
+
+ /* I_MEMORY:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <memory.h>.
+ */
+ /*#define I_MEMORY /**/
+
+ /* I_NDBM:
+ * This symbol, if defined, indicates that <ndbm.h> exists and should
+ * be included.
+ */
+ /*#define I_NDBM /**/
+
+ /* I_NET_ERRNO:
+ * This symbol, if defined, indicates that <net/errno.h> exists and
+ * should be included.
+ */
+ /*#define I_NET_ERRNO /**/
+
+ /* I_NETINET_IN:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <netinet/in.h>. Otherwise, you may try <sys/in.h>.
+ */
+ #define I_NETINET_IN /**/
+
+ /* I_SFIO:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sfio.h>.
+ */
+ /*#define I_SFIO /**/
+
+ /* I_STDDEF:
+ * This symbol, if defined, indicates that <stddef.h> exists and should
+ * be included.
+ */
+ #define I_STDDEF /**/
+
+ /* I_STDLIB:
+ * This symbol, if defined, indicates that <stdlib.h> exists and should
+ * be included.
+ */
+ #define I_STDLIB /**/
+
+ /* I_STRING:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <string.h> (USG systems) instead of <strings.h> (BSD systems).
+ */
+ #define I_STRING /**/
+
+ /* I_SYS_DIR:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/dir.h>.
+ */
+ /*#define I_SYS_DIR /**/
+
+ /* I_SYS_FILE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/file.h> to get definition of R_OK and friends.
+ */
+ /*#define I_SYS_FILE /**/
+
+ /* I_SYS_IOCTL:
+ * This symbol, if defined, indicates that <sys/ioctl.h> exists and should
+ * be included. Otherwise, include <sgtty.h> or <termio.h>.
+ */
+ /* I_SYS_SOCKIO:
+ * This symbol, if defined, indicates the <sys/sockio.h> should be included
+ * to get socket ioctl options, like SIOCATMARK.
+ */
+ #define I_SYS_IOCTL /**/
+ #define I_SYS_SOCKIO /**/
+
+ /* I_SYS_NDIR:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/ndir.h>.
+ */
+ /*#define I_SYS_NDIR /**/
+
+ /* I_SYS_PARAM:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/param.h>.
+ */
+ /*#define I_SYS_PARAM /**/
+
+ /* I_SYS_RESOURCE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/resource.h>.
+ */
+ /*#define I_SYS_RESOURCE /**/
+
+ /* I_SYS_SELECT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/select.h> in order to get definition of struct timeval.
+ */
+ /*#define I_SYS_SELECT /**/
+
+ /* I_SYS_STAT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/stat.h>.
+ */
+ #define I_SYS_STAT /**/
+
+ /* I_SYS_TIMES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/times.h>.
+ */
+ /*#define I_SYS_TIMES /**/
+
+ /* I_SYS_TYPES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/types.h>.
+ */
+ #define I_SYS_TYPES /**/
+
+ /* I_SYS_UN:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/un.h> to get UNIX domain socket definitions.
+ */
+ /*#define I_SYS_UN /**/
+
+ /* I_SYS_WAIT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/wait.h>.
+ */
+ /*#define I_SYS_WAIT /**/
+
+ /* I_TERMIO:
+ * This symbol, if defined, indicates that the program should include
+ * <termio.h> rather than <sgtty.h>. There are also differences in
+ * the ioctl() calls that depend on the value of this symbol.
+ */
+ /* I_TERMIOS:
+ * This symbol, if defined, indicates that the program should include
+ * the POSIX termios.h rather than sgtty.h or termio.h.
+ * There are also differences in the ioctl() calls that depend on the
+ * value of this symbol.
+ */
+ /* I_SGTTY:
+ * This symbol, if defined, indicates that the program should include
+ * <sgtty.h> rather than <termio.h>. There are also differences in
+ * the ioctl() calls that depend on the value of this symbol.
+ */
+ /*#define I_TERMIO /**/
+ /*#define I_TERMIOS /**/
+ /*#define I_SGTTY /**/
+
+ /* I_UNISTD:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <unistd.h>.
+ */
+ /*#define I_UNISTD /**/
+
+ /* I_UTIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <utime.h>.
+ */
+ #define I_UTIME /**/
+
+ /* I_VALUES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <values.h> to get definition of symbols like MINFLOAT or
+ * MAXLONG, i.e. machine dependant limitations. Probably, you
+ * should use <limits.h> instead, if it is available.
+ */
+ /*#define I_VALUES /**/
+
+ /* I_VFORK:
+ * This symbol, if defined, indicates to the C program that it should
+ * include vfork.h.
+ */
+ /*#define I_VFORK /**/
+
+ /* CAN_PROTOTYPE:
+ * If defined, this macro indicates that the C compiler can handle
+ * function prototypes.
+ */
+ /* _:
+ * This macro is used to declare function parameters for folks who want
+ * to make declarations with prototypes using a different style than
+ * the above macros. Use double parentheses. For example:
+ *
+ * int main _((int argc, char *argv[]));
+ */
+ #define CAN_PROTOTYPE /**/
+ #ifdef CAN_PROTOTYPE
+ #define _(args) args
+ #else
+ #define _(args) ()
+ #endif
+
+ /* SH_PATH:
+ * This symbol contains the full pathname to the shell used on this
+ * on this system to execute Bourne shell scripts. Usually, this will be
+ * /bin/sh, though it's possible that some systems will have /bin/ksh,
+ * /bin/pdksh, /bin/ash, /bin/bash, or even something such as
+ * D:/bin/sh.exe.
+ */
+ #define SH_PATH "cmd /x /c" /**/
+
+ /* INTSIZE:
+ * This symbol contains the value of sizeof(int) so that the C
+ * preprocessor can make decisions based on it.
+ */
+ /* LONGSIZE:
+ * This symbol contains the value of sizeof(long) so that the C
+ * preprocessor can make decisions based on it.
+ */
+ /* SHORTSIZE:
+ * This symbol contains the value of sizeof(short) so that the C
+ * preprocessor can make decisions based on it.
+ */
+ #define INTSIZE 4 /**/
+ #define LONGSIZE 4 /**/
+ #define SHORTSIZE 2 /**/
+
+ /* MULTIARCH:
+ * This symbol, if defined, signifies that the build
+ * process will produce some binary files that are going to be
+ * used in a cross-platform environment. This is the case for
+ * example with the NeXT "fat" binaries that contain executables
+ * for several CPUs.
+ */
+ /*#define MULTIARCH /**/
+
+ /* HAS_QUAD:
+ * This symbol, if defined, tells that there's a 64-bit integer type,
+ * Quad_t, and its unsigned counterpar, Uquad_t. QUADKIND will be one
+ * of QUAD_IS_INT, QUAD_IS_LONG, QUAD_IS_LONG_LONG, or QUAD_IS_INT64_T.
+ */
+ /*#define HAS_QUAD /**/
+ #ifdef HAS_QUAD
+ # define Quad_t __int64 /**/
+ # define Uquad_t unsigned __int64 /**/
+ # define QUADKIND 5 /**/
+ # define QUAD_IS_INT 1
+ # define QUAD_IS_LONG 2
+ # define QUAD_IS_LONG_LONG 3
+ # define QUAD_IS_INT64_T 4
+ #endif
+
+ /* HAS_ACCESSX:
+ * This symbol, if defined, indicates that the accessx routine is
+ * available to do extended access checks.
+ */
+ /*#define HAS_ACCESSX /**/
+
+ /* HAS_EACCESS:
+ * This symbol, if defined, indicates that the eaccess routine is
+ * available to do extended access checks.
+ */
+ /*#define HAS_EACCESS /**/
+
+ /* I_SYS_ACCESS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/access.h>.
+ */
+ /*#define I_SYS_ACCESS /**/
+
+ /* I_SYS_SECURITY:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/security.h>.
+ */
+ /*#define I_SYS_SECURITY /**/
+
+ /* OSNAME:
+ * This symbol contains the name of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
+ */
+ /* OSVERS:
+ * This symbol contains the version of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
+ */
+ #define OSNAME "NetWare" /**/
+ #define OSVERS "5.x" /**/
+
+ /* MEM_ALIGNBYTES:
+ * This symbol contains the number of bytes required to align a
+ * double, or a long double when applicable. Usual values are 2,
+ * 4 and 8. The default is eight, for safety.
+ */
+ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
+ # define MEM_ALIGNBYTES 8
+ #else
+ #define MEM_ALIGNBYTES 8
+ #endif
+
+ /* ARCHLIB:
+ * This variable, if defined, holds the name of the directory in
+ * which the user wants to put architecture-dependent public
+ * library files for perl5. It is most often a local directory
+ * such as /usr/local/lib. Programs using this variable must be
+ * prepared to deal with filename expansion. If ARCHLIB is the
+ * same as PRIVLIB, it is not defined, since presumably the
+ * program already searches PRIVLIB.
+ */
+ /* ARCHLIB_EXP:
+ * This symbol contains the ~name expanded version of ARCHLIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+ #define ARCHLIB "c:\\perl\\5.7.2\\lib\\NetWare-x86-multi-thread" /**/
+ /*#define ARCHLIB_EXP "" /**/
+
+ /* ARCHNAME:
+ * This symbol holds a string representing the architecture name.
+ * It may be used to construct an architecture-dependant pathname
+ * where library files may be held under a private library, for
+ * instance.
+ */
+ #define ARCHNAME "NetWare-x86-multi-thread" /**/
+
+ /* HAS_ATOLF:
+ * This symbol, if defined, indicates that the atolf routine is
+ * available to convert strings into long doubles.
+ */
+ /*#define HAS_ATOLF /**/
+
+ /* HAS_ATOLL:
+ * This symbol, if defined, indicates that the atoll routine is
+ * available to convert strings into long longs.
+ */
+ /*#define HAS_ATOLL /**/
+
+ /* BIN:
+ * This symbol holds the path of the bin directory where the package will
+ * be installed. Program must be prepared to deal with ~name substitution.
+ */
+ /* BIN_EXP:
+ * This symbol is the filename expanded version of the BIN symbol, for
+ * programs that do not want to deal with that at run-time.
+ */
+ #define BIN "c:\\perl\\5.7.2\\bin\\NetWare-x86-multi-thread" /**/
+ #define BIN_EXP "c:\\perl\\5.7.2\\bin\\NetWare-x86-multi-thread" /**/
+
+ /* PERL_BINCOMPAT_5005:
+ * This symbol, if defined, indicates that this version of Perl should be
+ * binary-compatible with Perl 5.005. This is impossible for builds
+ * that use features like threads and multiplicity it is always undef
+ * for those versions.
+ */
+ /*#define PERL_BINCOMPAT_5005 /**/
+
+ /* BYTEORDER:
+ * This symbol holds the hexadecimal constant defined in byteorder,
+ * i.e. 0x1234 or 0x4321, etc...
+ * If the compiler supports cross-compiling or multiple-architecture
+ * binaries (eg. on NeXT systems), use compiler-defined macros to
+ * determine the byte order.
+ * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture
+ * Binaries (MAB) on either big endian or little endian machines.
+ * The endian-ness is available at compile-time. This only matters
+ * for perl, where the config.h can be generated and installed on
+ * one system, and used by a different architecture to build an
+ * extension. Older versions of NeXT that might not have
+ * defined either *_ENDIAN__ were all on Motorola 680x0 series,
+ * so the default case (for NeXT) is big endian to catch them.
+ * This might matter for NeXT 3.0.
+ */
+ #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
+ # ifdef __LITTLE_ENDIAN__
+ # if LONGSIZE == 4
+ # define BYTEORDER 0x1234
+ # else
+ # if LONGSIZE == 8
+ # define BYTEORDER 0x12345678
+ # endif
+ # endif
+ # else
+ # ifdef __BIG_ENDIAN__
+ # if LONGSIZE == 4
+ # define BYTEORDER 0x4321
+ # else
+ # if LONGSIZE == 8
+ # define BYTEORDER 0x87654321
+ # endif
+ # endif
+ # endif
+ # endif
+ # if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__))
+ # define BYTEORDER 0x4321
+ # endif
+ #else
+ #define BYTEORDER 0x1234 /* large digits for MSB */
+ #endif /* NeXT */
+
+ /* CAT2:
+ * This macro catenates 2 tokens together.
+ */
+ /* STRINGIFY:
+ * This macro surrounds its token with double quotes.
+ */
+ #if 42 == 1
+ #define CAT2(a,b) a/**/b
+ #define STRINGIFY(a) "a"
+ /* If you can get stringification with catify, tell me how! */
+ #endif
+ #if 42 == 42
+ #define PeRl_CaTiFy(a, b) a ## b
+ #define PeRl_StGiFy(a) #a
+ /* the additional level of indirection enables these macros to be
+ * used as arguments to other macros. See K&R 2nd ed., page 231. */
+ #define CAT2(a,b) PeRl_CaTiFy(a,b)
+ #define StGiFy(a) PeRl_StGiFy(a)
+ #define STRINGIFY(a) PeRl_StGiFy(a)
+ #endif
+ #if 42 != 1 && 42 != 42
+ # include "Bletch: How does this C preprocessor catenate tokens?"
+ #endif
+
+ /* CPPSTDIN:
+ * This symbol contains the first part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. Typical value of "cc -E" or "/lib/cpp", but it can also
+ * call a wrapper. See CPPRUN.
+ */
+ /* CPPMINUS:
+ * This symbol contains the second part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. This symbol will have the value "-" if CPPSTDIN needs a minus
+ * to specify standard input, otherwise the value is "".
+ */
+ /* CPPRUN:
+ * This symbol contains the string which will invoke a C preprocessor on
+ * the standard input and produce to standard output. It needs to end
+ * with CPPLAST, after all other preprocessor flags have been specified.
+ * The main difference with CPPSTDIN is that this program will never be a
+ * pointer to a shell wrapper, i.e. it will be empty if no preprocessor is
+ * available directly to the user. Note that it may well be different from
+ * the preprocessor used to compile the C program.
+ */
+ /* CPPLAST:
+ * This symbol is intended to be used along with CPPRUN in the same manner
+ * symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "".
+ */
+ #define CPPSTDIN "cl -nologo -E"
+ #define CPPMINUS ""
+ #define CPPRUN "cl -nologo -E"
+ #define CPPLAST ""
+
+ /* HAS__FWALK:
+ * This symbol, if defined, indicates that the _fwalk system call is
+ * available to apply a function to all the file handles.
+ */
+ /*#define HAS__FWALK /**/
+
+ /* HAS_ACCESS:
+ * This manifest constant lets the C program know that the access()
+ * system call is available to check for accessibility using real UID/GID.
+ * (always present on UNIX.)
+ */
+ #define HAS_ACCESS /**/
+
+ /* CASTI32:
+ * This symbol is defined if the C compiler can cast negative
+ * or large floating point numbers to 32-bit ints.
+ */
+ /*#define CASTI32 /**/
+
+ /* CASTNEGFLOAT:
+ * This symbol is defined if the C compiler can cast negative
+ * numbers to unsigned longs, ints and shorts.
+ */
+ /* CASTFLAGS:
+ * This symbol contains flags that say what difficulties the compiler
+ * has casting odd floating values to unsigned long:
+ * 0 = ok
+ * 1 = couldn't cast < 0
+ * 2 = couldn't cast >= 0x80000000
+ * 4 = couldn't cast in argument expression list
+ */
+ #define CASTNEGFLOAT /**/
+ #define CASTFLAGS 0 /**/
+
+ /* VOID_CLOSEDIR:
+ * This symbol, if defined, indicates that the closedir() routine
+ * does not return a value.
+ */
+ /*#define VOID_CLOSEDIR /**/
+
+ /* HAS_STRUCT_CMSGHDR:
+ * This symbol, if defined, indicates that the struct cmsghdr
+ * is supported.
+ */
+ /*#define HAS_STRUCT_CMSGHDR /**/
+
+ /* HAS_CSH:
+ * This symbol, if defined, indicates that the C-shell exists.
+ */
+ /* CSH:
+ * This symbol, if defined, contains the full pathname of csh.
+ */
+ /*#define HAS_CSH /**/
+ #ifdef HAS_CSH
+ #define CSH "" /**/
+ #endif
+
+ /* DLSYM_NEEDS_UNDERSCORE:
+ * This symbol, if defined, indicates that we need to prepend an
+ * underscore to the symbol name before calling dlsym(). This only
+ * makes sense if you *have* dlsym, which we will presume is the
+ * case if you're using dl_dlopen.xs.
+ */
+ /*#define DLSYM_NEEDS_UNDERSCORE /**/
+
+ /* HAS_DRAND48_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the drand48() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern double drand48 _((void));
+ */
+ /*#define HAS_DRAND48_PROTO /**/
+
+ /* HAS_ENDGRENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for finalizing sequential access of the group database.
+ */
+ /*#define HAS_ENDGRENT /**/
+
+ /* HAS_ENDHOSTENT:
+ * This symbol, if defined, indicates that the endhostent() routine is
+ * available to close whatever was being used for host queries.
+ */
+ /*#define HAS_ENDHOSTENT /**/
+
+ /* HAS_ENDNETENT:
+ * This symbol, if defined, indicates that the endnetent() routine is
+ * available to close whatever was being used for network queries.
+ */
+ /*#define HAS_ENDNETENT /**/
+
+ /* HAS_ENDPROTOENT:
+ * This symbol, if defined, indicates that the endprotoent() routine is
+ * available to close whatever was being used for protocol queries.
+ */
+ /*#define HAS_ENDPROTOENT /**/
+
+ /* HAS_ENDPWENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for finalizing sequential access of the passwd database.
+ */
+ /*#define HAS_ENDPWENT /**/
+
+ /* HAS_ENDSERVENT:
+ * This symbol, if defined, indicates that the endservent() routine is
+ * available to close whatever was being used for service queries.
+ */
+ /*#define HAS_ENDSERVENT /**/
+
+ /* FCNTL_CAN_LOCK:
+ * This symbol, if defined, indicates that fcntl() can be used
+ * for file locking. Normally on Unix systems this is defined.
+ * It may be undefined on VMS.
+ */
+ /*#define FCNTL_CAN_LOCK /**/
+
+ /* HAS_FD_SET:
+ * This symbol, when defined, indicates presence of the fd_set typedef
+ * in <sys/types.h>
+ */
+ #define HAS_FD_SET /**/
+
+ /* FLEXFILENAMES:
+ * This symbol, if defined, indicates that the system supports filenames
+ * longer than 14 characters.
+ */
+ #define FLEXFILENAMES /**/
+
+ /* HAS_FPOS64_T:
+ * This symbol will be defined if the C compiler supports fpos64_t.
+ */
+ /*#define HAS_FPOS64_T /**/
+
+ /* HAS_FREXPL:
+ * This symbol, if defined, indicates that the frexpl routine is
+ * available to break a long double floating-point number into
+ * a normalized fraction and an integral power of 2.
+ */
+ /*#define HAS_FREXPL /**/
+
+ /* HAS_STRUCT_FS_DATA:
+ * This symbol, if defined, indicates that the struct fs_data
+ * to do statfs() is supported.
+ */
+ /*#define HAS_STRUCT_FS_DATA /**/
+
+ /* HAS_FSEEKO:
+ * This symbol, if defined, indicates that the fseeko routine is
+ * available to fseek beyond 32 bits (useful for ILP32 hosts).
+ */
+ /*#define HAS_FSEEKO /**/
+
+ /* HAS_FSTATFS:
+ * This symbol, if defined, indicates that the fstatfs routine is
+ * available to stat filesystems by file descriptors.
+ */
+ /*#define HAS_FSTATFS /**/
+
+ /* HAS_FSYNC:
+ * This symbol, if defined, indicates that the fsync routine is
+ * available to write a file's modified data and attributes to
+ * permanent storage.
+ */
+ /*#define HAS_FSYNC /**/
+
+ /* HAS_FTELLO:
+ * This symbol, if defined, indicates that the ftello routine is
+ * available to ftell beyond 32 bits (useful for ILP32 hosts).
+ */
+ /*#define HAS_FTELLO /**/
+
+ /* Gconvert:
+ * This preprocessor macro is defined to convert a floating point
+ * number to a string without a trailing decimal point. This
+ * emulates the behavior of sprintf("%g"), but is sometimes much more
+ * efficient. If gconvert() is not available, but gcvt() drops the
+ * trailing decimal point, then gcvt() is used. If all else fails,
+ * a macro using sprintf("%g") is used. Arguments for the Gconvert
+ * macro are: value, number of digits, whether trailing zeros should
+ * be retained, and the output buffer.
+ * Possible values are:
+ * d_Gconvert='gconvert((x),(n),(t),(b))'
+ * d_Gconvert='gcvt((x),(n),(b))'
+ * d_Gconvert='sprintf((b),"%.*g",(n),(x))'
+ * The last two assume trailing zeros should not be kept.
+ */
+ #define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x))
+
+ /* HAS_GETCWD:
+ * This symbol, if defined, indicates that the getcwd routine is
+ * available to get the current working directory.
+ */
+ /*#define HAS_GETCWD /**/
+
+ /* HAS_GETESPWNAM:
+ * This symbol, if defined, indicates that the getespwnam system call is
+ * available to retrieve enchanced (shadow) password entries by name.
+ */
+ /*#define HAS_GETESPWNAM /**/
+
+ /* HAS_GETFSSTAT:
+ * This symbol, if defined, indicates that the getfsstat routine is
+ * available to stat filesystems in bulk.
+ */
+ /*#define HAS_GETFSSTAT /**/
+
+ /* HAS_GETGRENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for sequential access of the group database.
+ */
+ /*#define HAS_GETGRENT /**/
+
+ /* HAS_GETHOSTBYADDR:
+ * This symbol, if defined, indicates that the gethostbyaddr() routine is
+ * available to look up hosts by their IP addresses.
+ */
+ #define HAS_GETHOSTBYADDR /**/
+
+ /* HAS_GETHOSTBYNAME:
+ * This symbol, if defined, indicates that the gethostbyname() routine is
+ * available to look up host names in some data base or other.
+ */
+ #define HAS_GETHOSTBYNAME /**/
+
+ /* HAS_GETHOSTENT:
+ * This symbol, if defined, indicates that the gethostent() routine is
+ * available to look up host names in some data base or another.
+ */
+ /*#define HAS_GETHOSTENT /**/
+
+ /* HAS_GETHOSTNAME:
+ * This symbol, if defined, indicates that the C program may use the
+ * gethostname() routine to derive the host name. See also HAS_UNAME
+ * and PHOSTNAME.
+ */
+ /* HAS_UNAME:
+ * This symbol, if defined, indicates that the C program may use the
+ * uname() routine to derive the host name. See also HAS_GETHOSTNAME
+ * and PHOSTNAME.
+ */
+ /* PHOSTNAME:
+ * This symbol, if defined, indicates the command to feed to the
+ * popen() routine to derive the host name. See also HAS_GETHOSTNAME
+ * and HAS_UNAME. Note that the command uses a fully qualified path,
+ * so that it is safe even if used by a process with super-user
+ * privileges.
+ */
+ /* HAS_PHOSTNAME:
+ * This symbol, if defined, indicates that the C program may use the
+ * contents of PHOSTNAME as a command to feed to the popen() routine
+ * to derive the host name.
+ */
+ #define HAS_GETHOSTNAME /**/
+ #define HAS_UNAME /**/
+ /*#define HAS_PHOSTNAME /**/
+ #ifdef HAS_PHOSTNAME
+ #define PHOSTNAME "" /* How to get the host name */
+ #endif
+
+ /* HAS_GETHOST_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for gethostent(), gethostbyname(), and
+ * gethostbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+ #define HAS_GETHOST_PROTOS /**/
+
+ /* HAS_GETITIMER:
+ * This symbol, if defined, indicates that the getitimer routine is
+ * available to return interval timers.
+ */
+ /*#define HAS_GETITIMER /**/
+
+ /* HAS_GETMNT:
+ * This symbol, if defined, indicates that the getmnt routine is
+ * available to get filesystem mount info by filename.
+ */
+ /*#define HAS_GETMNT /**/
+
+ /* HAS_GETMNTENT:
+ * This symbol, if defined, indicates that the getmntent routine is
+ * available to iterate through mounted file systems to get their info.
+ */
+ /*#define HAS_GETMNTENT /**/
+
+ /* HAS_GETNETBYADDR:
+ * This symbol, if defined, indicates that the getnetbyaddr() routine is
+ * available to look up networks by their IP addresses.
+ */
+ /*#define HAS_GETNETBYADDR /**/
+
+ /* HAS_GETNETBYNAME:
+ * This symbol, if defined, indicates that the getnetbyname() routine is
+ * available to look up networks by their names.
+ */
+ /*#define HAS_GETNETBYNAME /**/
+
+ /* HAS_GETNETENT:
+ * This symbol, if defined, indicates that the getnetent() routine is
+ * available to look up network names in some data base or another.
+ */
+ /*#define HAS_GETNETENT /**/
+
+ /* HAS_GETNET_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getnetent(), getnetbyname(), and
+ * getnetbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+ #define HAS_GETNET_PROTOS /**/
+
+ /* HAS_GETPAGESIZE:
+ * This symbol, if defined, indicates that the getpagesize system call
+ * is available to get system page size, which is the granularity of
+ * many memory management calls.
+ */
+ /*#define HAS_GETPAGESIZE /**/
+
+ /* HAS_GETPROTOENT:
+ * This symbol, if defined, indicates that the getprotoent() routine is
+ * available to look up protocols in some data base or another.
+ */
+ /*#define HAS_GETPROTOENT /**/
+
+ /* HAS_GETPGRP:
+ * This symbol, if defined, indicates that the getpgrp routine is
+ * available to get the current process group.
+ */
+ /* USE_BSD_GETPGRP:
+ * This symbol, if defined, indicates that getpgrp needs one
+ * arguments whereas USG one needs none.
+ */
+ /*#define HAS_GETPGRP /**/
+ /*#define USE_BSD_GETPGRP /**/
+
+ /* HAS_GETPROTOBYNAME:
+ * This symbol, if defined, indicates that the getprotobyname()
+ * routine is available to look up protocols by their name.
+ */
+ /* HAS_GETPROTOBYNUMBER:
+ * This symbol, if defined, indicates that the getprotobynumber()
+ * routine is available to look up protocols by their number.
+ */
+ #define HAS_GETPROTOBYNAME /**/
+ #define HAS_GETPROTOBYNUMBER /**/
+
+ /* HAS_GETPROTO_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getprotoent(), getprotobyname(), and
+ * getprotobyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+ #define HAS_GETPROTO_PROTOS /**/
+
+ /* HAS_GETPRPWNAM:
+ * This symbol, if defined, indicates that the getprpwnam system call is
+ * available to retrieve protected (shadow) password entries by name.
+ */
+ /*#define HAS_GETPRPWNAM /**/
+
+ /* HAS_GETPWENT:
+ * This symbol, if defined, indicates that the getpwent routine is
+ * available for sequential access of the passwd database.
+ * If this is not available, the older getpw() function may be available.
+ */
+ /*#define HAS_GETPWENT /**/
+
+ /* HAS_GETSERVENT:
+ * This symbol, if defined, indicates that the getservent() routine is
+ * available to look up network services in some data base or another.
+ */
+ /*#define HAS_GETSERVENT /**/
+
+ /* HAS_GETSERV_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getservent(), getservbyname(), and
+ * getservbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+ #define HAS_GETSERV_PROTOS /**/
+
+ /* HAS_GETSPNAM:
+ * This symbol, if defined, indicates that the getspnam system call is
+ * available to retrieve SysV shadow password entries by name.
+ */
+ /*#define HAS_GETSPNAM /**/
+
+ /* HAS_GETSERVBYNAME:
+ * This symbol, if defined, indicates that the getservbyname()
+ * routine is available to look up services by their name.
+ */
+ /* HAS_GETSERVBYPORT:
+ * This symbol, if defined, indicates that the getservbyport()
+ * routine is available to look up services by their port.
+ */
+ #define HAS_GETSERVBYNAME /**/
+ #define HAS_GETSERVBYPORT /**/
+
+ /* HAS_GNULIBC:
+ * This symbol, if defined, indicates to the C program that
+ * the GNU C library is being used.
+ */
+ /*#define HAS_GNULIBC /**/
+ #if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE)
+ # define _GNU_SOURCE
+ #endif
+ /* HAS_HASMNTOPT:
+ * This symbol, if defined, indicates that the hasmntopt routine is
+ * available to query the mount options of file systems.
+ */
+ /*#define HAS_HASMNTOPT /**/
+
+ /* HAS_HTONL:
+ * This symbol, if defined, indicates that the htonl() routine (and
+ * friends htons() ntohl() ntohs()) are available to do network
+ * order byte swapping.
+ */
+ /* HAS_HTONS:
+ * This symbol, if defined, indicates that the htons() routine (and
+ * friends htonl() ntohl() ntohs()) are available to do network
+ * order byte swapping.
+ */
+ /* HAS_NTOHL:
+ * This symbol, if defined, indicates that the ntohl() routine (and
+ * friends htonl() htons() ntohs()) are available to do network
+ * order byte swapping.
+ */
+ /* HAS_NTOHS:
+ * This symbol, if defined, indicates that the ntohs() routine (and
+ * friends htonl() htons() ntohl()) are available to do network
+ * order byte swapping.
+ */
+ #define HAS_HTONL /**/
+ #define HAS_HTONS /**/
+ #define HAS_NTOHL /**/
+ #define HAS_NTOHS /**/
+
+ /* HAS_ICONV:
+ * This symbol, if defined, indicates that the iconv routine is
+ * available to do character set conversions.
+ */
+ /*#define HAS_ICONV /**/
+
+ /* HAS_INT64_T:
+ * This symbol will defined if the C compiler supports int64_t.
+ * Usually the <inttypes.h> needs to be included, but sometimes
+ * <sys/types.h> is enough.
+ */
+ /*#define HAS_INT64_T /**/
+
+ /* HAS_ISASCII:
+ * This manifest constant lets the C program know that isascii
+ * is available.
+ */
+ #define HAS_ISASCII /**/
+
+ /* HAS_ISNAN:
+ * This symbol, if defined, indicates that the isnan routine is
+ * available to check whether a double is a NaN.
+ */
+ /*#define HAS_ISNAN /**/
+
+ /* HAS_ISNANL:
+ * This symbol, if defined, indicates that the isnanl routine is
+ * available to check whether a long double is a NaN.
+ */
+ /*#define HAS_ISNANL /**/
+
+ /* HAS_LCHOWN:
+ * This symbol, if defined, indicates that the lchown routine is
+ * available to operate on a symbolic link (instead of following the
+ * link).
+ */
+ /*#define HAS_LCHOWN /**/
+
+ /* HAS_LDBL_DIG:
+ * This symbol, if defined, indicates that this system's <float.h>
+ * or <limits.h> defines the symbol LDBL_DIG, which is the number
+ * of significant digits in a long double precision number. Unlike
+ * for DBL_DIG, there's no good guess for LDBL_DIG if it is undefined.
+ */
+ #define HAS_LDBL_DIG /**/
+
+ /* HAS_LONG_DOUBLE:
+ * This symbol will be defined if the C compiler supports long
+ * doubles.
+ */
+ /* LONG_DOUBLESIZE:
+ * This symbol contains the size of a long double, so that the
+ * C preprocessor can make decisions based on it. It is only
+ * defined if the system supports long doubles.
+ */
+ #define HAS_LONG_DOUBLE /**/
+ #ifdef HAS_LONG_DOUBLE
+ #define LONG_DOUBLESIZE 10 /**/
+ #endif
+
+ /* HAS_LONG_LONG:
+ * This symbol will be defined if the C compiler supports long long.
+ */
+ /* LONGLONGSIZE:
+ * This symbol contains the size of a long long, so that the
+ * C preprocessor can make decisions based on it. It is only
+ * defined if the system supports long long.
+ */
+ /*#define HAS_LONG_LONG /**/
+ #ifdef HAS_LONG_LONG
+ #define LONGLONGSIZE 8 /**/
+ #endif
+
+ /* HAS_LSEEK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the lseek() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern off_t lseek(int, off_t, int);
+ */
+ #define HAS_LSEEK_PROTO /**/
+
+ /* HAS_MADVISE:
+ * This symbol, if defined, indicates that the madvise system call is
+ * available to map a file into memory.
+ */
+ /*#define HAS_MADVISE /**/
+
+ /* HAS_MEMCHR:
+ * This symbol, if defined, indicates that the memchr routine is available
+ * to locate characters within a C string.
+ */
+ #define HAS_MEMCHR /**/
+
+ /* HAS_MKDTEMP:
+ * This symbol, if defined, indicates that the mkdtemp routine is
+ * available to exclusively create a uniquely named temporary directory.
+ */
+ /*#define HAS_MKDTEMP /**/
+
+ /* HAS_MKSTEMP:
+ * This symbol, if defined, indicates that the mkstemp routine is
+ * available to exclusively create and open a uniquely named
+ * temporary file.
+ */
+ /*#define HAS_MKSTEMP /**/
+
+ /* HAS_MKSTEMPS:
+ * This symbol, if defined, indicates that the mkstemps routine is
+ * available to excluslvely create and open a uniquely named
+ * (with a suffix) temporary file.
+ */
+ /*#define HAS_MKSTEMPS /**/
+
+ /* HAS_MMAP:
+ * This symbol, if defined, indicates that the mmap system call is
+ * available to map a file into memory.
+ */
+ /* Mmap_t:
+ * This symbol holds the return type of the mmap() system call
+ * (and simultaneously the type of the first argument).
+ * Usually set to 'void *' or 'cadd_t'.
+ */
+ /*#define HAS_MMAP /**/
+ #define Mmap_t void * /**/
+
+ /* HAS_MODFL:
+ * This symbol, if defined, indicates that the modfl routine is
+ * available to split a long double x into a fractional part f and
+ * an integer part i such that |f| < 1.0 and (f + i) = x.
+ */
+ /* HAS_MODFL_POW32_BUG:
+ * This symbol, if defined, indicates that the modfl routine is
+ * broken for long doubles >= pow(2, 32).
+ * For example from 4294967303.150000 one would get 4294967302.000000
+ * and 1.150000. The bug has been seen in certain versions of glibc,
+ * release 2.2.2 is known to be okay.
+ */
+ /*#define HAS_MODFL /**/
+ /*#define HAS_MODFL_POW32_BUG /**/
+
+ /* HAS_MPROTECT:
+ * This symbol, if defined, indicates that the mprotect system call is
+ * available to modify the access protection of a memory mapped file.
+ */
+ /*#define HAS_MPROTECT /**/
+
+ /* HAS_MSG:
+ * This symbol, if defined, indicates that the entire msg*(2) library is
+ * supported (IPC mechanism based on message queues).
+ */
+ /*#define HAS_MSG /**/
+
+ /* HAS_STRUCT_MSGHDR:
+ * This symbol, if defined, indicates that the struct msghdr
+ * is supported.
+ */
+ /*#define HAS_STRUCT_MSGHDR /**/
+
+ /* HAS_OFF64_T:
+ * This symbol will be defined if the C compiler supports off64_t.
+ */
+ /*#define HAS_OFF64_T /**/
+
+ /* HAS_OPEN3:
+ * This manifest constant lets the C program know that the three
+ * argument form of open(2) is available.
+ */
+ /*#define HAS_OPEN3 /**/
+
+ /* OLD_PTHREAD_CREATE_JOINABLE:
+ * This symbol, if defined, indicates how to create pthread
+ * in joinable (aka undetached) state. NOTE: not defined
+ * if pthread.h already has defined PTHREAD_CREATE_JOINABLE
+ * (the new version of the constant).
+ * If defined, known values are PTHREAD_CREATE_UNDETACHED
+ * and __UNDETACHED.
+ */
+ /*#define OLD_PTHREAD_CREATE_JOINABLE /**/
+
+ /* HAS_PTHREAD_YIELD:
+ * This symbol, if defined, indicates that the pthread_yield
+ * routine is available to yield the execution of the current
+ * thread. sched_yield is preferable to pthread_yield.
+ */
+ /* SCHED_YIELD:
+ * This symbol defines the way to yield the execution of
+ * the current thread. Known ways are sched_yield,
+ * pthread_yield, and pthread_yield with NULL.
+ */
+ /* HAS_SCHED_YIELD:
+ * This symbol, if defined, indicates that the sched_yield
+ * routine is available to yield the execution of the current
+ * thread. sched_yield is preferable to pthread_yield.
+ */
+ /*#define HAS_PTHREAD_YIELD /**/
+ #define SCHED_YIELD /**/
+ /*#define HAS_SCHED_YIELD /**/
+
+ /* HAS_READV:
+ * This symbol, if defined, indicates that the readv routine is
+ * available to do gather reads. You will also need <sys/uio.h>
+ * and there I_SYSUIO.
+ */
+ /*#define HAS_READV /**/
+
+ /* HAS_RECVMSG:
+ * This symbol, if defined, indicates that the recvmsg routine is
+ * available to send structured socket messages.
+ */
+ /*#define HAS_RECVMSG /**/
+
+ /* HAS_SAFE_BCOPY:
+ * This symbol, if defined, indicates that the bcopy routine is available
+ * to copy potentially overlapping memory blocks. Otherwise you should
+ * probably use memmove() or memcpy(). If neither is defined, roll your
+ * own version.
+ */
+ /*#define HAS_SAFE_BCOPY /**/
+
+ /* HAS_SAFE_MEMCPY:
+ * This symbol, if defined, indicates that the memcpy routine is available
+ * to copy potentially overlapping memory blocks. Otherwise you should
+ * probably use memmove() or memcpy(). If neither is defined, roll your
+ * own version.
+ */
+ /*#define HAS_SAFE_MEMCPY /**/
+
+ /* HAS_SANE_MEMCMP:
+ * This symbol, if defined, indicates that the memcmp routine is available
+ * and can be used to compare relative magnitudes of chars with their high
+ * bits set. If it is not defined, roll your own version.
+ */
+ #define HAS_SANE_MEMCMP /**/
+
+ /* HAS_SBRK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the sbrk() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern void* sbrk _((int));
+ * extern void* sbrk _((size_t));
+ */
+ /*#define HAS_SBRK_PROTO /**/
+
+ /* HAS_SEM:
+ * This symbol, if defined, indicates that the entire sem*(2) library is
+ * supported.
+ */
+ /*#define HAS_SEM /**/
+
+ /* HAS_SENDMSG:
+ * This symbol, if defined, indicates that the sendmsg routine is
+ * available to send structured socket messages.
+ */
+ /*#define HAS_SENDMSG /**/
+
+ /* HAS_SETGRENT:
+ * This symbol, if defined, indicates that the setgrent routine is
+ * available for initializing sequential access of the group database.
+ */
+ /*#define HAS_SETGRENT /**/
+
+ /* HAS_SETGROUPS:
+ * This symbol, if defined, indicates that the setgroups() routine is
+ * available to set the list of process groups. If unavailable, multiple
+ * groups are probably not supported.
+ */
+ /*#define HAS_SETGROUPS /**/
+
+ /* HAS_SETHOSTENT:
+ * This symbol, if defined, indicates that the sethostent() routine is
+ * available.
+ */
+ /*#define HAS_SETHOSTENT /**/
+
+ /* HAS_SETITIMER:
+ * This symbol, if defined, indicates that the setitimer routine is
+ * available to set interval timers.
+ */
+ /*#define HAS_SETITIMER /**/
+
+ /* HAS_SETNETENT:
+ * This symbol, if defined, indicates that the setnetent() routine is
+ * available.
+ */
+ /*#define HAS_SETNETENT /**/
+
+ /* HAS_SETPROTOENT:
+ * This symbol, if defined, indicates that the setprotoent() routine is
+ * available.
+ */
+ /*#define HAS_SETPROTOENT /**/
+
+ /* HAS_SETPGRP:
+ * This symbol, if defined, indicates that the setpgrp routine is
+ * available to set the current process group.
+ */
+ /* USE_BSD_SETPGRP:
+ * This symbol, if defined, indicates that setpgrp needs two
+ * arguments whereas USG one needs none. See also HAS_SETPGID
+ * for a POSIX interface.
+ */
+ /*#define HAS_SETPGRP /**/
+ /*#define USE_BSD_SETPGRP /**/
+
+ /* HAS_SETPROCTITLE:
+ * This symbol, if defined, indicates that the setproctitle routine is
+ * available to set process title.
+ */
+ /*#define HAS_SETPROCTITLE /**/
+
+ /* HAS_SETPWENT:
+ * This symbol, if defined, indicates that the setpwent routine is
+ * available for initializing sequential access of the passwd database.
+ */
+ /*#define HAS_SETPWENT /**/
+
+ /* HAS_SETSERVENT:
+ * This symbol, if defined, indicates that the setservent() routine is
+ * available.
+ */
+ /*#define HAS_SETSERVENT /**/
+
+ /* HAS_SETVBUF:
+ * This symbol, if defined, indicates that the setvbuf routine is
+ * available to change buffering on an open stdio stream.
+ * to a line-buffered mode.
+ */
+ #define HAS_SETVBUF /**/
+
+ /* USE_SFIO:
+ * This symbol, if defined, indicates that sfio should
+ * be used.
+ */
+ /*#define USE_SFIO /**/
+
+ /* HAS_SHM:
+ * This symbol, if defined, indicates that the entire shm*(2) library is
+ * supported.
+ */
+ /*#define HAS_SHM /**/
+
+ /* HAS_SIGACTION:
+ * This symbol, if defined, indicates that Vr4's sigaction() routine
+ * is available.
+ */
+ /*#define HAS_SIGACTION /**/
+
+ /* HAS_SIGSETJMP:
+ * This variable indicates to the C program that the sigsetjmp()
+ * routine is available to save the calling process's registers
+ * and stack environment for later use by siglongjmp(), and
+ * to optionally save the process's signal mask. See
+ * Sigjmp_buf, Sigsetjmp, and Siglongjmp.
+ */
+ /* Sigjmp_buf:
+ * This is the buffer type to be used with Sigsetjmp and Siglongjmp.
+ */
+ /* Sigsetjmp:
+ * This macro is used in the same way as sigsetjmp(), but will invoke
+ * traditional setjmp() if sigsetjmp isn't available.
+ * See HAS_SIGSETJMP.
+ */
+ /* Siglongjmp:
+ * This macro is used in the same way as siglongjmp(), but will invoke
+ * traditional longjmp() if siglongjmp isn't available.
+ * See HAS_SIGSETJMP.
+ */
+ /*#define HAS_SIGSETJMP /**/
+ #ifdef HAS_SIGSETJMP
+ #define Sigjmp_buf sigjmp_buf
+ #define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask))
+ #define Siglongjmp(buf,retval) siglongjmp((buf),(retval))
+ #else
+ #define Sigjmp_buf jmp_buf
+ #define Sigsetjmp(buf,save_mask) setjmp((buf))
+ #define Siglongjmp(buf,retval) longjmp((buf),(retval))
+ #endif
+
+ /* HAS_SOCKET:
+ * This symbol, if defined, indicates that the BSD socket interface is
+ * supported.
+ */
+ /* HAS_SOCKETPAIR:
+ * This symbol, if defined, indicates that the BSD socketpair() call is
+ * supported.
+ */
+ /* HAS_MSG_CTRUNC:
+ * This symbol, if defined, indicates that the MSG_CTRUNC is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+ /* HAS_MSG_DONTROUTE:
+ * This symbol, if defined, indicates that the MSG_DONTROUTE is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+ /* HAS_MSG_OOB:
+ * This symbol, if defined, indicates that the MSG_OOB is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+ /* HAS_MSG_PEEK:
+ * This symbol, if defined, indicates that the MSG_PEEK is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+ /* HAS_MSG_PROXY:
+ * This symbol, if defined, indicates that the MSG_PROXY is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+ /* HAS_SCM_RIGHTS:
+ * This symbol, if defined, indicates that the SCM_RIGHTS is supported.
+ * Checking just with #ifdef might not be enough because this symbol
+ * has been known to be an enum.
+ */
+ #define HAS_SOCKET /**/
+ /*#define HAS_SOCKETPAIR /**/
+ /*#define HAS_MSG_CTRUNC /**/
+ /*#define HAS_MSG_DONTROUTE /**/
+ /*#define HAS_MSG_OOB /**/
+ /*#define HAS_MSG_PEEK /**/
+ /*#define HAS_MSG_PROXY /**/
+ /*#define HAS_SCM_RIGHTS /**/
+
+ /* HAS_SOCKS5_INIT:
+ * This symbol, if defined, indicates that the socks5_init routine is
+ * available to initialize SOCKS 5.
+ */
+ /*#define HAS_SOCKS5_INIT /**/
+
+ /* HAS_SQRTL:
+ * This symbol, if defined, indicates that the sqrtl routine is
+ * available to do long double square roots.
+ */
+ /*#define HAS_SQRTL /**/
+
+ /* USE_STAT_BLOCKS:
+ * This symbol is defined if this system has a stat structure declaring
+ * st_blksize and st_blocks.
+ */
+ #ifndef USE_STAT_BLOCKS
+ /*#define USE_STAT_BLOCKS /**/
+ #endif
+
+ /* HAS_STRUCT_STATFS_F_FLAGS:
+ * This symbol, if defined, indicates that the struct statfs
+ * does have the f_flags member containing the mount flags of
+ * the filesystem containing the file.
+ * This kind of struct statfs is coming from <sys/mount.h> (BSD 4.3),
+ * not from <sys/statfs.h> (SYSV). Older BSDs (like Ultrix) do not
+ * have statfs() and struct statfs, they have ustat() and getmnt()
+ * with struct ustat and struct fs_data.
+ */
+ /*#define HAS_STRUCT_STATFS_F_FLAGS /**/
+
+ /* HAS_STRUCT_STATFS:
+ * This symbol, if defined, indicates that the struct statfs
+ * to do statfs() is supported.
+ */
+ /*#define HAS_STRUCT_STATFS /**/
+
+ /* HAS_FSTATVFS:
+ * This symbol, if defined, indicates that the fstatvfs routine is
+ * available to stat filesystems by file descriptors.
+ */
+ /*#define HAS_FSTATVFS /**/
+
+ /* USE_STDIO_PTR:
+ * This symbol is defined if the _ptr and _cnt fields (or similar)
+ * of the stdio FILE structure can be used to access the stdio buffer
+ * for a file handle. If this is defined, then the FILE_ptr(fp)
+ * and FILE_cnt(fp) macros will also be defined and should be used
+ * to access these fields.
+ */
+ /* FILE_ptr:
+ * This macro is used to access the _ptr field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_PTR is defined.
+ */
+ /* STDIO_PTR_LVALUE:
+ * This symbol is defined if the FILE_ptr macro can be used as an
+ * lvalue.
+ */
+ /* FILE_cnt:
+ * This macro is used to access the _cnt field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_PTR is defined.
+ */
+ /* STDIO_CNT_LVALUE:
+ * This symbol is defined if the FILE_cnt macro can be used as an
+ * lvalue.
+ */
+ /* STDIO_PTR_LVAL_SETS_CNT:
+ * This symbol is defined if using the FILE_ptr macro as an lvalue
+ * to increase the pointer by n has the side effect of decreasing the
+ * value of File_cnt(fp) by n.
+ */
+ /* STDIO_PTR_LVAL_NOCHANGE_CNT:
+ * This symbol is defined if using the FILE_ptr macro as an lvalue
+ * to increase the pointer by n leaves File_cnt(fp) unchanged.
+ */
+ /*#define USE_STDIO_PTR /**/
+ #ifdef USE_STDIO_PTR
+ #define FILE_ptr(fp) ((fp)->_ptr)
+ /*#define STDIO_PTR_LVALUE /**/
+ #define FILE_cnt(fp) ((fp)->_cnt)
+ /*#define STDIO_CNT_LVALUE /**/
+ /*#define STDIO_PTR_LVAL_SETS_CNT /**/
+ /*#define STDIO_PTR_LVAL_NOCHANGE_CNT /**/
+ #endif
+
+ /* USE_STDIO_BASE:
+ * This symbol is defined if the _base field (or similar) of the
+ * stdio FILE structure can be used to access the stdio buffer for
+ * a file handle. If this is defined, then the FILE_base(fp) macro
+ * will also be defined and should be used to access this field.
+ * Also, the FILE_bufsiz(fp) macro will be defined and should be used
+ * to determine the number of bytes in the buffer. USE_STDIO_BASE
+ * will never be defined unless USE_STDIO_PTR is.
+ */
+ /* FILE_base:
+ * This macro is used to access the _base field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_BASE is defined.
+ */
+ /* FILE_bufsiz:
+ * This macro is used to determine the number of bytes in the I/O
+ * buffer pointed to by _base field (or equivalent) of the FILE
+ * structure pointed to its argument. This macro will always be defined
+ * if USE_STDIO_BASE is defined.
+ */
+ /*#define USE_STDIO_BASE /**/
+ #ifdef USE_STDIO_BASE
+ #define FILE_base(fp) ((fp)->_base)
+ #define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base)
+ #endif
+
+ /* HAS_STRERROR:
+ * This symbol, if defined, indicates that the strerror routine is
+ * available to translate error numbers to strings. See the writeup
+ * of Strerror() in this file before you try to define your own.
+ */
+ /* HAS_SYS_ERRLIST:
+ * This symbol, if defined, indicates that the sys_errlist array is
+ * available to translate error numbers to strings. The extern int
+ * sys_nerr gives the size of that table.
+ */
+ /* Strerror:
+ * This preprocessor symbol is defined as a macro if strerror() is
+ * not available to translate error numbers to strings but sys_errlist[]
+ * array is there.
+ */
+ #define HAS_STRERROR /**/
+ #define HAS_SYS_ERRLIST /**/
+ #define Strerror(e) strerror(e)
+
+ /* HAS_STRTOLD:
+ * This symbol, if defined, indicates that the strtold routine is
+ * available to convert strings to long doubles.
+ */
+ /*#define HAS_STRTOLD /**/
+
+ /* HAS_STRTOLL:
+ * This symbol, if defined, indicates that the strtoll routine is
+ * available to convert strings to long longs.
+ */
+ /*#define HAS_STRTOLL /**/
+
+ /* HAS_STRTOQ:
+ * This symbol, if defined, indicates that the strtoq routine is
+ * available to convert strings to long longs (quads).
+ */
+ /*#define HAS_STRTOQ /**/
+
+ /* HAS_STRTOUL:
+ * This symbol, if defined, indicates that the strtoul routine is
+ * available to provide conversion of strings to unsigned long.
+ */
+ #define HAS_STRTOUL /**/
+
+ /* HAS_STRTOULL:
+ * This symbol, if defined, indicates that the strtoull routine is
+ * available to convert strings to unsigned long longs.
+ */
+ /*#define HAS_STRTOULL /**/
+
+ /* HAS_STRTOUQ:
+ * This symbol, if defined, indicates that the strtouq routine is
+ * available to convert strings to unsigned long longs (quads).
+ */
+ /*#define HAS_STRTOUQ /**/
+
+ /* HAS_TELLDIR_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the telldir() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern long telldir _((DIR*));
+ */
+ #define HAS_TELLDIR_PROTO /**/
+
+ /* Time_t:
+ * This symbol holds the type returned by time(). It can be long,
+ * or time_t on BSD sites (in which case <sys/types.h> should be
+ * included).
+ */
+ #define Time_t time_t /* Time type */
+
+ /* HAS_TIMES:
+ * This symbol, if defined, indicates that the times() routine exists.
+ * Note that this became obsolete on some systems (SUNOS), which now
+ * use getrusage(). It may be necessary to include <sys/times.h>.
+ */
+ /*#define HAS_TIMES /**/
+
+ /* HAS_UALARM:
+ * This symbol, if defined, indicates that the ualarm routine is
+ * available to do alarms with microsecond granularity.
+ */
+ /*#define HAS_UALARM /**/
+
+ /* HAS_UNION_SEMUN:
+ * This symbol, if defined, indicates that the union semun is
+ * defined by including <sys/sem.h>. If not, the user code
+ * probably needs to define it as:
+ * union semun {
+ * int val;
+ * struct semid_ds *buf;
+ * unsigned short *array;
+ * }
+ */
+ /* USE_SEMCTL_SEMUN:
+ * This symbol, if defined, indicates that union semun is
+ * used for semctl IPC_STAT.
+ */
+ /* USE_SEMCTL_SEMID_DS:
+ * This symbol, if defined, indicates that struct semid_ds * is
+ * used for semctl IPC_STAT.
+ */
+ #define HAS_UNION_SEMUN /**/
+ /*#define USE_SEMCTL_SEMUN /**/
+ /*#define USE_SEMCTL_SEMID_DS /**/
+
+ /* HAS_USTAT:
+ * This symbol, if defined, indicates that the ustat system call is
+ * available to query file system statistics by dev_t.
+ */
+ /*#define HAS_USTAT /**/
+
+ /* HAS_VFORK:
+ * This symbol, if defined, indicates that vfork() exists.
+ */
+ /*#define HAS_VFORK /**/
+
+ /* Signal_t:
+ * This symbol's value is either "void" or "int", corresponding to the
+ * appropriate return type of a signal handler. Thus, you can declare
+ * a signal handler using "Signal_t (*handler)()", and define the
+ * handler using "Signal_t handler(sig)".
+ */
+ #define Signal_t void /* Signal handler's return type */
+
+ /* HAS_VPRINTF:
+ * This symbol, if defined, indicates that the vprintf routine is available
+ * to printf with a pointer to an argument list. If unavailable, you
+ * may need to write your own, probably in terms of _doprnt().
+ */
+ /* USE_CHAR_VSPRINTF:
+ * This symbol is defined if this system has vsprintf() returning type
+ * (char*). The trend seems to be to declare it as "int vsprintf()". It
+ * is up to the package author to declare vsprintf correctly based on the
+ * symbol.
+ */
+ #define HAS_VPRINTF /**/
+ /*#define USE_CHAR_VSPRINTF /**/
+
+ /* HAS_WRITEV:
+ * This symbol, if defined, indicates that the writev routine is
+ * available to do scatter writes.
+ */
+ /*#define HAS_WRITEV /**/
+
+ /* USE_DYNAMIC_LOADING:
+ * This symbol, if defined, indicates that dynamic loading of
+ * some sort is available.
+ */
+ #define USE_DYNAMIC_LOADING /**/
+
+ /* DOUBLESIZE:
+ * This symbol contains the size of a double, so that the C preprocessor
+ * can make decisions based on it.
+ */
+ #define DOUBLESIZE 8 /**/
+
+ /* EBCDIC:
+ * This symbol, if defined, indicates that this system uses
+ * EBCDIC encoding.
+ */
+ /*#define EBCDIC /**/
+
+ /* FFLUSH_NULL:
+ * This symbol, if defined, tells that fflush(NULL) does flush
+ * all pending stdio output.
+ */
+ /* FFLUSH_ALL:
+ * This symbol, if defined, tells that to flush
+ * all pending stdio output one must loop through all
+ * the stdio file handles stored in an array and fflush them.
+ * Note that if fflushNULL is defined, fflushall will not
+ * even be probed for and will be left undefined.
+ */
+ #define FFLUSH_NULL /**/
+ /*#define FFLUSH_ALL /**/
+
+ /* Fpos_t:
+ * This symbol holds the type used to declare file positions in libc.
+ * It can be fpos_t, long, uint, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+ #define Fpos_t fpos_t /* File position type */
+
+ /* Gid_t_f:
+ * This symbol defines the format string used for printing a Gid_t.
+ */
+ #define Gid_t_f "ld" /**/
+
+ /* Gid_t_sign:
+ * This symbol holds the signedess of a Gid_t.
+ * 1 for unsigned, -1 for signed.
+ */
+ #define Gid_t_sign -1 /* GID sign */
+
+ /* Gid_t_size:
+ * This symbol holds the size of a Gid_t in bytes.
+ */
+ #define Gid_t_size 4 /* GID size */
+
+ /* Gid_t:
+ * This symbol holds the return type of getgid() and the type of
+ * argument to setrgid() and related functions. Typically,
+ * it is the type of group ids in the kernel. It can be int, ushort,
+ * gid_t, etc... It may be necessary to include <sys/types.h> to get
+ * any typedef'ed information.
+ */
+ #define Gid_t gid_t /* Type for getgid(), etc... */
+
+ /* Groups_t:
+ * This symbol holds the type used for the second argument to
+ * getgroups() and setgroups(). Usually, this is the same as
+ * gidtype (gid_t) , but sometimes it isn't.
+ * It can be int, ushort, gid_t, etc...
+ * It may be necessary to include <sys/types.h> to get any
+ * typedef'ed information. This is only required if you have
+ * getgroups() or setgroups()..
+ */
+ #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
+ #define Groups_t gid_t /* Type for 2nd arg to [sg]etgroups() */
+ #endif
+
+ /* DB_Prefix_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is u_int32_t.
+ */
+ /* DB_Hash_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is size_t.
+ */
+ /* DB_VERSION_MAJOR_CFG:
+ * This symbol, if defined, defines the major version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ */
+ /* DB_VERSION_MINOR_CFG:
+ * This symbol, if defined, defines the minor version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
+ /* DB_VERSION_PATCH_CFG:
+ * This symbol, if defined, defines the patch version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
+ #define DB_Hash_t int /**/
+ #define DB_Prefix_t int /**/
+ #define DB_VERSION_MAJOR_CFG undef /**/
+ #define DB_VERSION_MINOR_CFG undef /**/
+ #define DB_VERSION_PATCH_CFG undef /**/
+
+ /* I_GRP:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <grp.h>.
+ */
+ /* GRPASSWD:
+ * This symbol, if defined, indicates to the C program that struct group
+ * in <grp.h> contains gr_passwd.
+ */
+ /*#define I_GRP /**/
+ /*#define GRPASSWD /**/
+
+ /* I_ICONV:
+ * This symbol, if defined, indicates that <iconv.h> exists and
+ * should be included.
+ */
+ /*#define I_ICONV /**/
+
+ /* I_IEEEFP:
+ * This symbol, if defined, indicates that <ieeefp.h> exists and
+ * should be included.
+ */
+ /*#define I_IEEEFP /**/
+
+ /* I_INTTYPES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <inttypes.h>.
+ */
+ /*#define I_INTTYPES /**/
+
+ /* I_LIBUTIL:
+ * This symbol, if defined, indicates that <libutil.h> exists and
+ * should be included.
+ */
+ /*#define I_LIBUTIL /**/
+
+ /* I_MACH_CTHREADS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <mach/cthreads.h>.
+ */
+ /*#define I_MACH_CTHREADS /**/
+
+ /* I_MNTENT:
+ * This symbol, if defined, indicates that <mntent.h> exists and
+ * should be included.
+ */
+ /*#define I_MNTENT /**/
+
+ /* I_NETDB:
+ * This symbol, if defined, indicates that <netdb.h> exists and
+ * should be included.
+ */
+ #define I_NETDB /**/
+
+ /* I_NETINET_TCP:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <netinet/tcp.h>.
+ */
+ /*#define I_NETINET_TCP /**/
+
+ /* I_POLL:
+ * This symbol, if defined, indicates that <poll.h> exists and
+ * should be included.
+ */
+ /*#define I_POLL /**/
+
+ /* I_PROT:
+ * This symbol, if defined, indicates that <prot.h> exists and
+ * should be included.
+ */
+ /*#define I_PROT /**/
+
+ /* I_PTHREAD:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <pthread.h>.
+ */
+ /*#define I_PTHREAD /**/
+
+ /* I_PWD:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <pwd.h>.
+ */
+ /* PWQUOTA:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_quota.
+ */
+ /* PWAGE:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_age.
+ */
+ /* PWCHANGE:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_change.
+ */
+ /* PWCLASS:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_class.
+ */
+ /* PWEXPIRE:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_expire.
+ */
+ /* PWCOMMENT:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_comment.
+ */
+ /* PWGECOS:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_gecos.
+ */
+ /* PWPASSWD:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_passwd.
+ */
+ /*#define I_PWD /**/
+ /*#define PWQUOTA /**/
+ /*#define PWAGE /**/
+ /*#define PWCHANGE /**/
+ /*#define PWCLASS /**/
+ /*#define PWEXPIRE /**/
+ /*#define PWCOMMENT /**/
+ /*#define PWGECOS /**/
+ /*#define PWPASSWD /**/
+
+ /* I_SHADOW:
+ * This symbol, if defined, indicates that <shadow.h> exists and
+ * should be included.
+ */
+ /*#define I_SHADOW /**/
+
+ /* I_SOCKS:
+ * This symbol, if defined, indicates that <socks.h> exists and
+ * should be included.
+ */
+ /*#define I_SOCKS /**/
+
+ /* I_SUNMATH:
+ * This symbol, if defined, indicates that <sunmath.h> exists and
+ * should be included.
+ */
+ /*#define I_SUNMATH /**/
+
+ /* I_SYSLOG:
+ * This symbol, if defined, indicates that <syslog.h> exists and
+ * should be included.
+ */
+ /*#define I_SYSLOG /**/
+
+ /* I_SYSMODE:
+ * This symbol, if defined, indicates that <sys/mode.h> exists and
+ * should be included.
+ */
+ /*#define I_SYSMODE /**/
+
+ /* I_SYS_MOUNT:
+ * This symbol, if defined, indicates that <sys/mount.h> exists and
+ * should be included.
+ */
+ /*#define I_SYS_MOUNT /**/
+
+ /* I_SYS_STATFS:
+ * This symbol, if defined, indicates that <sys/statfs.h> exists.
+ */
+ /*#define I_SYS_STATFS /**/
+
+ /* I_SYS_STATVFS:
+ * This symbol, if defined, indicates that <sys/statvfs.h> exists and
+ * should be included.
+ */
+ /*#define I_SYS_STATVFS /**/
+
+ /* I_SYSUIO:
+ * This symbol, if defined, indicates that <sys/uio.h> exists and
+ * should be included.
+ */
+ /*#define I_SYSUIO /**/
+
+ /* I_SYSUTSNAME:
+ * This symbol, if defined, indicates that <sys/utsname.h> exists and
+ * should be included.
+ */
+ #define I_SYSUTSNAME /**/
+
+ /* I_SYS_VFS:
+ * This symbol, if defined, indicates that <sys/vfs.h> exists and
+ * should be included.
+ */
+ /*#define I_SYS_VFS /**/
+
+ /* I_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <time.h>.
+ */
+ /* I_SYS_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h>.
+ */
+ /* I_SYS_TIME_KERNEL:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h> with KERNEL defined.
+ */
+ #define I_TIME /**/
+ /*#define I_SYS_TIME /**/
+ /*#define I_SYS_TIME_KERNEL /**/
+
+ /* I_USTAT:
+ * This symbol, if defined, indicates that <ustat.h> exists and
+ * should be included.
+ */
+ /*#define I_USTAT /**/
+
+ /* PERL_INC_VERSION_LIST:
+ * This variable specifies the list of subdirectories in over
+ * which perl.c:incpush() and lib/lib.pm will automatically
+ * search when adding directories to @INC, in a format suitable
+ * for a C initialization string. See the inc_version_list entry
+ * in Porting/Glossary for more details.
+ */
+ #define PERL_INC_VERSION_LIST 0 /**/
+
+ /* INSTALL_USR_BIN_PERL:
+ * This symbol, if defined, indicates that Perl is to be installed
+ * also as /usr/bin/perl.
+ */
+ /*#define INSTALL_USR_BIN_PERL /**/
+
+ /* PERL_PRIfldbl:
+ * This symbol, if defined, contains the string used by stdio to
+ * format long doubles (format 'f') for output.
+ */
+ /* PERL_PRIgldbl:
+ * This symbol, if defined, contains the string used by stdio to
+ * format long doubles (format 'g') for output.
+ */
+ /* PERL_PRIeldbl:
+ * This symbol, if defined, contains the string used by stdio to
+ * format long doubles (format 'e') for output.
+ */
+ /* PERL_SCNfldbl:
+ * This symbol, if defined, contains the string used by stdio to
+ * format long doubles (format 'f') for input.
+ */
+ /*#define PERL_PRIfldbl "f" /**/
+ /*#define PERL_PRIgldbl "g" /**/
+ /*#define PERL_PRIeldbl "e" /**/
+ /*#define PERL_SCNfldbl undef /**/
+
+ /* Off_t:
+ * This symbol holds the type used to declare offsets in the kernel.
+ * It can be int, long, off_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+ /* LSEEKSIZE:
+ * This symbol holds the number of bytes used by the Off_t.
+ */
+ /* Off_t_size:
+ * This symbol holds the number of bytes used by the Off_t.
+ */
+ #define Off_t off_t /* <offset> type */
+ #define LSEEKSIZE 4 /* <offset> size */
+ #define Off_t_size 4 /* <offset> size */
+
+ /* Free_t:
+ * This variable contains the return type of free(). It is usually
+ * void, but occasionally int.
+ */
+ /* Malloc_t:
+ * This symbol is the type of pointer returned by malloc and realloc.
+ */
+ #define Malloc_t void * /**/
+ #define Free_t void /**/
+
+ /* MYMALLOC:
+ * This symbol, if defined, indicates that we're using our own malloc.
+ */
+ /*#define MYMALLOC /**/
+
+ /* Mode_t:
+ * This symbol holds the type used to declare file modes
+ * for systems calls. It is usually mode_t, but may be
+ * int or unsigned short. It may be necessary to include <sys/types.h>
+ * to get any typedef'ed information.
+ */
+ #define Mode_t mode_t /* file mode parameter for system calls */
+
+ /* VAL_O_NONBLOCK:
+ * This symbol is to be used during open() or fcntl(F_SETFL) to turn on
+ * non-blocking I/O for the file descriptor. Note that there is no way
+ * back, i.e. you cannot turn it blocking again this way. If you wish to
+ * alternatively switch between blocking and non-blocking, use the
+ * ioctl(FIOSNBIO) call instead, but that is not supported by all devices.
+ */
+ /* VAL_EAGAIN:
+ * This symbol holds the errno error code set by read() when no data was
+ * present on the non-blocking file descriptor.
+ */
+ /* RD_NODATA:
+ * This symbol holds the return code from read() when no data is present
+ * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is
+ * not defined, then you can't distinguish between no data and EOF by
+ * issuing a read(). You'll have to find another way to tell for sure!
+ */
+ /* EOF_NONBLOCK:
+ * This symbol, if defined, indicates to the C program that a read() on
+ * a non-blocking file descriptor will return 0 on EOF, and not the value
+ * held in RD_NODATA (-1 usually, in that case!).
+ */
+ #define VAL_O_NONBLOCK O_NONBLOCK
+ #define VAL_EAGAIN EAGAIN
+ #define RD_NODATA -1
+ #define EOF_NONBLOCK
+
+ /* NEED_VA_COPY:
+ * This symbol, if defined, indicates that the system stores
+ * the variable argument list datatype, va_list, in a format
+ * that cannot be copied by simple assignment, so that some
+ * other means must be used when copying is required.
+ * As such systems vary in their provision (or non-provision)
+ * of copying mechanisms, handy.h defines a platform-
+ * independent macro, Perl_va_copy(src, dst), to do the job.
+ */
+ /*#define NEED_VA_COPY /**/
+
+ /* Netdb_host_t:
+ * This symbol holds the type used for the 1st argument
+ * to gethostbyaddr().
+ */
+ /* Netdb_hlen_t:
+ * This symbol holds the type used for the 2nd argument
+ * to gethostbyaddr().
+ */
+ /* Netdb_name_t:
+ * This symbol holds the type used for the argument to
+ * gethostbyname().
+ */
+ /* Netdb_net_t:
+ * This symbol holds the type used for the 1st argument to
+ * getnetbyaddr().
+ */
+ #define Netdb_host_t char * /**/
+ #define Netdb_hlen_t int /**/
+ #define Netdb_name_t char * /**/
+ #define Netdb_net_t long /**/
+
+ /* PERL_OTHERLIBDIRS:
+ * This variable contains a colon-separated set of paths for the perl
+ * binary to search for additional library files or modules.
+ * These directories will be tacked to the end of @INC.
+ * Perl will automatically search below each path for version-
+ * and architecture-specific directories. See PERL_INC_VERSION_LIST
+ * for more details.
+ */
+ /*#define PERL_OTHERLIBDIRS "undef" /**/
+
+ /* IVTYPE:
+ * This symbol defines the C type used for Perl's IV.
+ */
+ /* UVTYPE:
+ * This symbol defines the C type used for Perl's UV.
+ */
+ /* I8TYPE:
+ * This symbol defines the C type used for Perl's I8.
+ */
+ /* U8TYPE:
+ * This symbol defines the C type used for Perl's U8.
+ */
+ /* I16TYPE:
+ * This symbol defines the C type used for Perl's I16.
+ */
+ /* U16TYPE:
+ * This symbol defines the C type used for Perl's U16.
+ */
+ /* I32TYPE:
+ * This symbol defines the C type used for Perl's I32.
+ */
+ /* U32TYPE:
+ * This symbol defines the C type used for Perl's U32.
+ */
+ /* I64TYPE:
+ * This symbol defines the C type used for Perl's I64.
+ */
+ /* U64TYPE:
+ * This symbol defines the C type used for Perl's U64.
+ */
+ /* NVTYPE:
+ * This symbol defines the C type used for Perl's NV.
+ */
+ /* IVSIZE:
+ * This symbol contains the sizeof(IV).
+ */
+ /* UVSIZE:
+ * This symbol contains the sizeof(UV).
+ */
+ /* I8SIZE:
+ * This symbol contains the sizeof(I8).
+ */
+ /* U8SIZE:
+ * This symbol contains the sizeof(U8).
+ */
+ /* I16SIZE:
+ * This symbol contains the sizeof(I16).
+ */
+ /* U16SIZE:
+ * This symbol contains the sizeof(U16).
+ */
+ /* I32SIZE:
+ * This symbol contains the sizeof(I32).
+ */
+ /* U32SIZE:
+ * This symbol contains the sizeof(U32).
+ */
+ /* I64SIZE:
+ * This symbol contains the sizeof(I64).
+ */
+ /* U64SIZE:
+ * This symbol contains the sizeof(U64).
+ */
+ /* NVSIZE:
+ * This symbol contains the sizeof(NV).
+ */
+ /* NV_PRESERVES_UV:
+ * This symbol, if defined, indicates that a variable of type NVTYPE
+ * can preserve all the bits of a variable of type UVTYPE.
+ */
+ /* NV_PRESERVES_UV_BITS:
+ * This symbol contains the number of bits a variable of type NVTYPE
+ * can preserve of a variable of type UVTYPE.
+ */
+ #define IVTYPE long /**/
+ #define UVTYPE unsigned long /**/
+ #define I8TYPE char /**/
+ #define U8TYPE unsigned char /**/
+ #define I16TYPE short /**/
+ #define U16TYPE unsigned short /**/
+ #define I32TYPE long /**/
+ #define U32TYPE unsigned long /**/
+ #ifdef HAS_QUAD
+ #define I64TYPE __int64 /**/
+ #define U64TYPE unsigned __int64 /**/
+ #endif
+ #define NVTYPE double /**/
+ #define IVSIZE 4 /**/
+ #define UVSIZE 4 /**/
+ #define I8SIZE 1 /**/
+ #define U8SIZE 1 /**/
+ #define I16SIZE 2 /**/
+ #define U16SIZE 2 /**/
+ #define I32SIZE 4 /**/
+ #define U32SIZE 4 /**/
+ #ifdef HAS_QUAD
+ #define I64SIZE 8 /**/
+ #define U64SIZE 8 /**/
+ #endif
+ #define NVSIZE 8 /**/
+ #define NV_PRESERVES_UV
+ #define NV_PRESERVES_UV_BITS undef
+
+ /* IVdf:
+ * This symbol defines the format string used for printing a Perl IV
+ * as a signed decimal integer.
+ */
+ /* UVuf:
+ * This symbol defines the format string used for printing a Perl UV
+ * as an unsigned decimal integer.
+ */
+ /* UVof:
+ * This symbol defines the format string used for printing a Perl UV
+ * as an unsigned octal integer.
+ */
+ /* UVxf:
+ * This symbol defines the format string used for printing a Perl UV
+ * as an unsigned hexadecimal integer in lowercase abcdef.
+ */
+ /* UVXf:
+ * This symbol defines the format string used for printing a Perl UV
+ * as an unsigned hexadecimal integer in uppercase ABCDEF.
+ */
+ /* NVef:
+ * This symbol defines the format string used for printing a Perl NV
+ * using %e-ish floating point format.
+ */
+ /* NVff:
+ * This symbol defines the format string used for printing a Perl NV
+ * using %f-ish floating point format.
+ */
+ /* NVgf:
+ * This symbol defines the format string used for printing a Perl NV
+ * using %g-ish floating point format.
+ */
+ #define IVdf "ld" /**/
+ #define UVuf "lu" /**/
+ #define UVof "lo" /**/
+ #define UVxf "lx" /**/
+ #define UVXf undef /**/
+ #define NVef "e" /**/
+ #define NVff "f" /**/
+ #define NVgf "g" /**/
+
+ /* Pid_t:
+ * This symbol holds the type used to declare process ids in the kernel.
+ * It can be int, uint, pid_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+ #define Pid_t int /* PID type */
+
+ /* PRIVLIB:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ */
+ /* PRIVLIB_EXP:
+ * This symbol contains the ~name expanded version of PRIVLIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+ #define PRIVLIB "sys:\\perl\\lib" /**/
+ #define PRIVLIB_EXP (fnNwGetEnvironmentStr("PRIVLIB", PRIVLIB)) /**/
+
+ /* PTRSIZE:
+ * This symbol contains the size of a pointer, so that the C preprocessor
+ * can make decisions based on it. It will be sizeof(void *) if
+ * the compiler supports (void *); otherwise it will be
+ * sizeof(char *).
+ */
+ #define PTRSIZE 4 /**/
+
+ /* Drand01:
+ * This macro is to be used to generate uniformly distributed
+ * random numbers over the range [0., 1.[. You may have to supply
+ * an 'extern double drand48();' in your program since SunOS 4.1.3
+ * doesn't provide you with anything relevant in its headers.
+ * See HAS_DRAND48_PROTO.
+ */
+ /* Rand_seed_t:
+ * This symbol defines the type of the argument of the
+ * random seed function.
+ */
+ /* seedDrand01:
+ * This symbol defines the macro to be used in seeding the
+ * random number generator (see Drand01).
+ */
+ /* RANDBITS:
+ * This symbol indicates how many bits are produced by the
+ * function used to generate normalized random numbers.
+ * Values include 15, 16, 31, and 48.
+ */
+ #define Drand01() (rand()/(double)((unsigned)1<<RANDBITS)) /**/
+ #define Rand_seed_t unsigned /**/
+ #define seedDrand01(x) srand((Rand_seed_t)x) /**/
+ #define RANDBITS 15 /**/
+
+ /* SELECT_MIN_BITS:
+ * This symbol holds the minimum number of bits operated by select.
+ * That is, if you do select(n, ...), how many bits at least will be
+ * cleared in the masks if some activity is detected. Usually this
+ * is either n or 32*ceil(n/32), especially many little-endians do
+ * the latter. This is only useful if you have select(), naturally.
+ */
+ #define SELECT_MIN_BITS 32 /**/
+
+ /* Select_fd_set_t:
+ * This symbol holds the type used for the 2nd, 3rd, and 4th
+ * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET
+ * is defined, and 'int *' otherwise. This is only useful if you
+ * have select(), of course.
+ */
+ #define Select_fd_set_t fd_set * /**/
+
+ /* SIG_NAME:
+ * This symbol contains a list of signal names in order of
+ * signal number. This is intended
+ * to be used as a static array initialization, like this:
+ * char *sig_name[] = { SIG_NAME };
+ * The signals in the list are separated with commas, and each signal
+ * is surrounded by double quotes. There is no leading SIG in the signal
+ * name, i.e. SIGQUIT is known as "QUIT".
+ * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn,
+ * etc., where nn is the actual signal number (e.g. NUM37).
+ * The signal number for sig_name[i] is stored in sig_num[i].
+ * The last element is 0 to terminate the list with a NULL. This
+ * corresponds to the 0 at the end of the sig_num list.
+ */
+ /* SIG_NUM:
+ * This symbol contains a list of signal numbers, in the same order as the
+ * SIG_NAME list. It is suitable for static array initialization, as in:
+ * int sig_num[] = { SIG_NUM };
+ * The signals in the list are separated with commas, and the indices
+ * within that list and the SIG_NAME list match, so it's easy to compute
+ * the signal name from a number or vice versa at the price of a small
+ * dynamic linear lookup.
+ * Duplicates are allowed, but are moved to the end of the list.
+ * The signal number corresponding to sig_name[i] is sig_number[i].
+ * if (i < NSIG) then sig_number[i] == i.
+ * The last element is 0, corresponding to the 0 at the end of
+ * the sig_name list.
+ */
+ /* SIG_SIZE:
+ * This variable contains the number of elements of the sig_name
+ * and sig_num arrays, excluding the final NULL entry.
+ */
+ #define SIG_NAME "ZERO", "NUM01", "INT", "QUIT", "ILL", "NUM05", "NUM06", "NUM07", "FPE", "KILL", "NUM10", "SEGV", "NUM12", "PIPE", "ALRM", "TERM", "NUM16", "NUM17", "NUM18", "NUM19", "CHLD", "BREAK", "ABRT", "STOP", "NUM24", "CONT", "CLD", 0 /**/
+ #define SIG_NUM 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 20, 0 /**/
+ #define SIG_SIZE 27 /**/
+
+ /* SITEARCH:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ * The standard distribution will put nothing in this directory.
+ * After perl has been installed, users may install their own local
+ * architecture-dependent modules in this directory with
+ * MakeMaker Makefile.PL
+ * or equivalent. See INSTALL for details.
+ */
+ /* SITEARCH_EXP:
+ * This symbol contains the ~name expanded version of SITEARCH, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+ #define SITEARCH "c:\\perl\\site\\5.7.2\\lib\\NetWare-x86-multi-thread" /**/
+ /*#define SITEARCH_EXP "" /**/
+
+ /* SITELIB:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ * The standard distribution will put nothing in this directory.
+ * After perl has been installed, users may install their own local
+ * architecture-independent modules in this directory with
+ * MakeMaker Makefile.PL
+ * or equivalent. See INSTALL for details.
+ */
+ /* SITELIB_EXP:
+ * This symbol contains the ~name expanded version of SITELIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+ /* SITELIB_STEM:
+ * This define is SITELIB_EXP with any trailing version-specific component
+ * removed. The elements in inc_version_list (inc_version_list.U) can
+ * be tacked onto this variable to generate a list of directories to search.
+ */
+ #define SITELIB "c:\\perl\\site\\5.7.2\\lib" /**/
+ #define SITELIB_EXP (nw_get_sitelib("5.7.2")) /**/
+ #define SITELIB_STEM "" /**/
+
+ /* Size_t_size:
+ * This symbol holds the size of a Size_t in bytes.
+ */
+ #define Size_t_size 4 /**/
+
+ /* Size_t:
+ * This symbol holds the type used to declare length parameters
+ * for string functions. It is usually size_t, but may be
+ * unsigned long, int, etc. It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+ #define Size_t size_t /* length paramater for string functions */
+
+ /* Sock_size_t:
+ * This symbol holds the type used for the size argument of
+ * various socket calls (just the base type, not the pointer-to).
+ */
+ #define Sock_size_t int /**/
+
+ /* SSize_t:
+ * This symbol holds the type used by functions that return
+ * a count of bytes or an error condition. It must be a signed type.
+ * It is usually ssize_t, but may be long or int, etc.
+ * It may be necessary to include <sys/types.h> or <unistd.h>
+ * to get any typedef'ed information.
+ * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
+ */
+ #define SSize_t int /* signed count of bytes */
+
+ /* STARTPERL:
+ * This variable contains the string to put in front of a perl
+ * script to make sure (one hopes) that it runs with perl and not
+ * some shell.
+ */
+ #define STARTPERL "#!perl" /**/
+
+ /* STDCHAR:
+ * This symbol is defined to be the type of char used in stdio.h.
+ * It has the values "unsigned char" or "char".
+ */
+ #define STDCHAR char /**/
+
+ /* HAS_STDIO_STREAM_ARRAY:
+ * This symbol, if defined, tells that there is an array
+ * holding the stdio streams.
+ */
+ /* STDIO_STREAM_ARRAY:
+ * This symbol tells the name of the array holding the stdio streams.
+ * Usual values include _iob, __iob, and __sF.
+ */
+ /*#define HAS_STDIO_STREAM_ARRAY /**/
+ #define STDIO_STREAM_ARRAY
+
+ /* Uid_t_f:
+ * This symbol defines the format string used for printing a Uid_t.
+ */
+ #define Uid_t_f "ld" /**/
+
+ /* Uid_t_sign:
+ * This symbol holds the signedess of a Uid_t.
+ * 1 for unsigned, -1 for signed.
+ */
+ #define Uid_t_sign -1 /* UID sign */
+
+ /* Uid_t_size:
+ * This symbol holds the size of a Uid_t in bytes.
+ */
+ #define Uid_t_size 4 /* UID size */
+
+ /* Uid_t:
+ * This symbol holds the type used to declare user ids in the kernel.
+ * It can be int, ushort, uid_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+ #define Uid_t uid_t /* UID type */
+
+ /* USE_64_BIT_INT:
+ * This symbol, if defined, indicates that 64-bit integers should
+ * be used when available. If not defined, the native integers
+ * will be employed (be they 32 or 64 bits). The minimal possible
+ * 64-bitness is used, just enough to get 64-bit integers into Perl.
+ * This may mean using for example "long longs", while your memory
+ * may still be limited to 2 gigabytes.
+ */
+ /* USE_64_BIT_ALL:
+ * This symbol, if defined, indicates that 64-bit integers should
+ * be used when available. If not defined, the native integers
+ * will be used (be they 32 or 64 bits). The maximal possible
+ * 64-bitness is employed: LP64 or ILP64, meaning that you will
+ * be able to use more than 2 gigabytes of memory. This mode is
+ * even more binary incompatible than USE_64_BIT_INT. You may not
+ * be able to run the resulting executable in a 32-bit CPU at all or
+ * you may need at least to reboot your OS to 64-bit mode.
+ */
+ #ifndef USE_64_BIT_INT
+ /*#define USE_64_BIT_INT /**/
+ #endif
+
+ #ifndef USE_64_BIT_ALL
+ /*#define USE_64_BIT_ALL /**/
+ #endif
+
+ /* USE_LARGE_FILES:
+ * This symbol, if defined, indicates that large file support
+ * should be used when available.
+ */
+ #ifndef USE_LARGE_FILES
+ /*#define USE_LARGE_FILES /**/
+ #endif
+
+ /* USE_LONG_DOUBLE:
+ * This symbol, if defined, indicates that long doubles should
+ * be used when available.
+ */
+ #ifndef USE_LONG_DOUBLE
+ /*#define USE_LONG_DOUBLE /**/
+ #endif
+
+ /* USE_MORE_BITS:
+ * This symbol, if defined, indicates that 64-bit interfaces and
+ * long doubles should be used when available.
+ */
+ #ifndef USE_MORE_BITS
+ /*#define USE_MORE_BITS /**/
+ #endif
+
+ /* MULTIPLICITY:
+ * This symbol, if defined, indicates that Perl should
+ * be built to use multiplicity.
+ */
+ #ifndef MULTIPLICITY
+ #define MULTIPLICITY /**/
+ #endif
+
+ /* USE_PERLIO:
+ * This symbol, if defined, indicates that the PerlIO abstraction should
+ * be used throughout. If not defined, stdio should be
+ * used in a fully backward compatible manner.
+ */
+ #ifndef USE_PERLIO
+ /*#define USE_PERLIO /**/
+ #endif
+
+ /* USE_SOCKS:
+ * This symbol, if defined, indicates that Perl should
+ * be built to use socks.
+ */
+ #ifndef USE_SOCKS
+ /*#define USE_SOCKS /**/
+ #endif
+
+ /* USE_ITHREADS:
+ * This symbol, if defined, indicates that Perl should be built to
+ * use the interpreter-based threading implementation.
+ */
+ /* USE_5005THREADS:
+ * This symbol, if defined, indicates that Perl should be built to
+ * use the 5.005-based threading implementation.
+ */
+ /* OLD_PTHREADS_API:
+ * This symbol, if defined, indicates that Perl should
+ * be built to use the old draft POSIX threads API.
+ */
+ /* USE_REENTRANT_API:
+ * This symbol, if defined, indicates that Perl should
+ * try to use the various _r versions of library functions.
+ * This is extremely experimental.
+ */
+ /*#define USE_5005THREADS /**/
+ #define USE_ITHREADS /**/
+ #if defined(USE_5005THREADS) && !defined(USE_ITHREADS)
+ #define USE_THREADS /* until src is revised*/
+ #endif
+ /*#define OLD_PTHREADS_API /**/
+ /*#define USE_REENTRANT_API /**/
+
+ /* PERL_VENDORARCH:
+ * If defined, this symbol contains the name of a private library.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world.
+ * It may have a ~ on the front.
+ * The standard distribution will put nothing in this directory.
+ * Vendors who distribute perl may wish to place their own
+ * architecture-dependent modules and extensions in this directory with
+ * MakeMaker Makefile.PL INSTALLDIRS=vendor
+ * or equivalent. See INSTALL for details.
+ */
+ /* PERL_VENDORARCH_EXP:
+ * This symbol contains the ~name expanded version of PERL_VENDORARCH, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+ /*#define PERL_VENDORARCH "" /**/
+ /*#define PERL_VENDORARCH_EXP "" /**/
+
+ /* PERL_VENDORLIB_EXP:
+ * This symbol contains the ~name expanded version of VENDORLIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+ /* PERL_VENDORLIB_STEM:
+ * This define is PERL_VENDORLIB_EXP with any trailing version-specific component
+ * removed. The elements in inc_version_list (inc_version_list.U) can
+ * be tacked onto this variable to generate a list of directories to search.
+ */
+ /*#define PERL_VENDORLIB_EXP "" /**/
+ /*#define PERL_VENDORLIB_STEM "" /**/
+
+ /* VOIDFLAGS:
+ * This symbol indicates how much support of the void type is given by this
+ * compiler. What various bits mean:
+ *
+ * 1 = supports declaration of void
+ * 2 = supports arrays of pointers to functions returning void
+ * 4 = supports comparisons between pointers to void functions and
+ * addresses of void functions
+ * 8 = suports declaration of generic void pointers
+ *
+ * The package designer should define VOIDUSED to indicate the requirements
+ * of the package. This can be done either by #defining VOIDUSED before
+ * including config.h, or by defining defvoidused in Myinit.U. If the
+ * latter approach is taken, only those flags will be tested. If the
+ * level of void support necessary is not present, defines void to int.
+ */
+ #ifndef VOIDUSED
+ #define VOIDUSED 15
+ #endif
+ #define VOIDFLAGS 15
+ #if (VOIDFLAGS & VOIDUSED) != VOIDUSED
+ #define void int /* is void to be avoided? */
+ #define M_VOID /* Xenix strikes again */
+ #endif
+
+ /* PERL_XS_APIVERSION:
+ * This variable contains the version of the oldest perl binary
+ * compatible with the present perl. perl.c:incpush() and
+ * lib/lib.pm will automatically search in c:\\perl\\site\\5.7.2\\lib\\NetWare-x86-multi-thread for older
+ * directories across major versions back to xs_apiversion.
+ * This is only useful if you have a perl library directory tree
+ * structured like the default one.
+ * See INSTALL for how this works.
+ * The versioned site_perl directory was introduced in 5.005,
+ * so that is the lowest possible value.
+ * Since this can depend on compile time options (such as
+ * bincompat) it is set by Configure. Other non-default sources
+ * of potential incompatibility, such as multiplicity, threads,
+ * debugging, 64bits, sfio, etc., are not checked for currently,
+ * though in principle we could go snooping around in old
+ * Config.pm files.
+ */
+ /* PERL_PM_APIVERSION:
+ * This variable contains the version of the oldest perl
+ * compatible with the present perl. (That is, pure perl modules
+ * written for pm_apiversion will still work for the current
+ * version). perl.c:incpush() and lib/lib.pm will automatically
+ * search in c:\\perl\\site\\5.7.2\\lib for older directories across major versions
+ * back to pm_apiversion. This is only useful if you have a perl
+ * library directory tree structured like the default one. The
+ * versioned site_perl library was introduced in 5.005, so that's
+ * the default setting for this variable. It's hard to imagine
+ * it changing before Perl6. It is included here for symmetry
+ * with xs_apiveprsion -- the searching algorithms will
+ * (presumably) be similar.
+ * See the INSTALL file for how this works.
+ */
+ #define PERL_XS_APIVERSION "5.6.0"
+ #define PERL_PM_APIVERSION "5.005"
+
+ /* SETUID_SCRIPTS_ARE_SECURE_NOW:
+ * This symbol, if defined, indicates that the bug that prevents
+ * setuid scripts from being secure is not present in this kernel.
+ */
+ /* DOSUID:
+ * This symbol, if defined, indicates that the C program should
+ * check the script that it is executing for setuid/setgid bits, and
+ * attempt to emulate setuid/setgid on systems that have disabled
+ * setuid #! scripts because the kernel can't do it securely.
+ * It is up to the package designer to make sure that this emulation
+ * is done securely. Among other things, it should do an fstat on
+ * the script it just opened to make sure it really is a setuid/setgid
+ * script, it should make sure the arguments passed correspond exactly
+ * to the argument on the #! line, and it should not trust any
+ * subprocesses to which it must pass the filename rather than the
+ * file descriptor of the script to be executed.
+ */
+ /*#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/
+ /*#define DOSUID /**/
+
+ /* I_STDARG:
+ * This symbol, if defined, indicates that <stdarg.h> exists and should
+ * be included.
+ */
+ /* I_VARARGS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <varargs.h>.
+ */
+ #define I_STDARG /**/
+ /*#define I_VARARGS /**/
+
+ /* USE_CROSS_COMPILE:
+ * This symbol, if defined, indicates that Perl is being cross-compiled.
+ */
+ /* PERL_TARGETARCH:
+ * This symbol, if defined, indicates the target architecture
+ * Perl has been cross-compiled to. Undefined if not a cross-compile.
+ */
+ #ifndef USE_CROSS_COMPILE
+ /*#define USE_CROSS_COMPILE /**/
+ #define PERL_TARGETARCH "undef" /**/
+ #endif
+
+ /* HAS_DBMINIT_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the dbminit() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int dbminit(char *);
+ */
+ /*#define HAS_DBMINIT_PROTO /**/
+
+ /* HAS_FLOCK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the flock() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int flock(int, int);
+ */
+ /*#define HAS_FLOCK_PROTO /**/
+
+ /* HAS_REALPATH:
+ * This symbol, if defined, indicates that the realpath routine is
+ * available to do resolve paths.
+ */
+ /*#define HAS_REALPATH /**/
+
+ /* HAS_SIGPROCMASK:
+ * This symbol, if defined, indicates that the sigprocmask
+ * system call is available to examine or change the signal mask
+ * of the calling process.
+ */
+ /*#define HAS_SIGPROCMASK /**/
+
+ /* HAS_SOCKATMARK:
+ * This symbol, if defined, indicates that the sockatmark routine is
+ * available to test whether a socket is at the out-of-band mark.
+ */
+ /*#define HAS_SOCKATMARK /**/
+
+ /* HAS_SOCKATMARK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the sockatmark() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int sockatmark _((int));
+ */
+ /*#define HAS_SOCKATMARK_PROTO /**/
+
+ /* HAS_SETRESGID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresgid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+ /*#define HAS_SETRESGID_PROTO /**/
+
+ /* HAS_SETRESUID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresuid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+ /*#define HAS_SETRESUID_PROTO /**/
+
+ /* HAS_STRFTIME:
+ * This symbol, if defined, indicates that the strftime routine is
+ * available to do time formatting.
+ */
+ #define HAS_STRFTIME /**/
+
+ /* HAS_SYSCALL_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the syscall() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int syscall(int, ...);
+ * extern int syscall(long, ...);
+ */
+ /*#define HAS_SYSCALL_PROTO /**/
+
+ /* U32_ALIGNMENT_REQUIRED:
+ * This symbol, if defined, indicates that you must access
+ * character data through U32-aligned pointers.
+ */
+ /*#define U32_ALIGNMENT_REQUIRED /**/
+
+ /* HAS_USLEEP_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the usleep() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int usleep(useconds_t);
+ */
+ /*#define HAS_USLEEP_PROTO /**/
+
+ /* HAS_PTHREAD_ATFORK:
+ * This symbol, if defined, indicates that the pthread_atfork routine
+ * is available setup fork handlers.
+ */
+ /*#define HAS_PTHREAD_ATFORK /**/
+
+ #endif
diff -c /dev/null 'perl-5.7.2/NetWare/config_h.PL'
Index: ./NetWare/config_h.PL
*** ./NetWare/config_h.PL Thu Jan 1 02:00:00 1970
--- ./NetWare/config_h.PL Mon Jul 9 17:09:40 2001
***************
*** 0 ****
--- 1,120 ----
+ #
+ use Config;
+ use File::Compare qw(compare);
+ use File::Copy qw(copy);
+ my $OBJ = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i;
+ my $name = $0;
+ $name =~ s#^(.*)\.PL$#../$1.SH#;
+ my %opt;
+ while (@ARGV && $ARGV[0] =~ /^([\w_]+)=(.*)$/)
+ {
+ $opt{$1}=$2;
+ shift(@ARGV);
+ }
+
+ $opt{CONFIG_H} ||= 'config.h';
+
+ my $patchlevel = $opt{INST_VER};
+ $patchlevel =~ s|^[\\/]||;
+ $patchlevel =~ s|~VERSION~|$Config{version}|g;
+ $patchlevel ||= $Config{version};
+ $patchlevel = qq["$patchlevel"];
+
+ open(SH,"<$name") || die "Cannot open $name:$!";
+ while (<SH>)
+ {
+ last if /^sed/;
+ }
+ ($term,$file,$pat) = /^sed\s+<<(\S+)\s+>(\S+)\s+(.*)$/;
+ $file =~ s/^\$(\w+)$/$opt{$1}/g;
+
+ my $str = "sub munge\n{\n";
+
+ while ($pat =~ s/-e\s+'([^']*)'\s*//)
+ {
+ my $e = $1;
+ $e =~ s/\\([\(\)])/$1/g;
+ $e =~ s/\\(\d)/\$$1/g;
+ $str .= "$e;\n";
+ }
+ $str .= "}\n";
+
+ eval $str;
+
+ die "$str:$@" if $@;
+
+ open(H,">$file.new") || die "Cannot open $file.new:$!";
+ binmode H; # no CRs (which cause a spurious rebuild)
+ while (<SH>)
+ {
+ last if /^$term$/o;
+ s/\$([\w_]+)/Config($1)/eg;
+ s/`([^\`]*)`/BackTick($1)/eg;
+ munge();
+ s/\\\$/\$/g;
+ s#/[ *\*]*\*/#/**/#;
+ if (/^\s*#define\s+(SITELIB|VENDORLIB)_EXP/)
+ {
+ $_ = "#define ". $1 . "_EXP (nw_get_". lc($1) . "($patchlevel))\t/**/\n";
+ }
+ # Added for NetWare and removed PRIVLIB from the above, the same thing might have
+ # to be done for other as well
+ elsif (/^\s*#define\s+(PRIVLIB)_EXP/)
+ {
+ $_ = "#define ". $1 . "_EXP (fnNwGetEnvironmentStr(\"PRIVLIB\", PRIVLIB))\t/**/\n";
+ }
+ # incpush() handles archlibs, so disable them
+ elsif (/^\s*#define\s+(ARCHLIB|SITEARCH|VENDORARCH)_EXP/)
+ {
+ $_ = "/*#define ". $1 . "_EXP \"\"\t/**/\n";
+ }
+ print H;
+ }
+ close(H);
+ close(SH);
+
+
+ chmod(0666,"../lib/CORE/config.h");
+ copy("$file.new","../lib/CORE/config.h") || die "Cannot copy:$!";
+ chmod(0444,"../lib/CORE/config.h");
+
+ if (!$OBJ && compare("$file.new",$file))
+ {
+ warn "$file has changed\n";
+ chmod(0666,$file);
+ unlink($file);
+ rename("$file.new",$file);
+ #chmod(0444,$file);
+ exit(1);
+ }
+ else
+ {
+ unlink ("$file.new");
+ exit(0);
+ }
+
+ sub Config
+ {
+ my $var = shift;
+ my $val = $Config{$var};
+ $val = 'undef' unless defined $val;
+ $val =~ s/\\/\\\\/g;
+ return $val;
+ }
+
+ sub BackTick
+ {
+ my $cmd = shift;
+ if ($cmd =~ /^echo\s+(.*?)\s*\|\s+sed\s+'(.*)'\s*$/)
+ {
+ local ($data,$pat) = ($1,$2);
+ $data =~ s/\s+/ /g;
+ eval "\$data =~ $pat";
+ return $data;
+ }
+ else
+ {
+ die "Cannot handle \`$cmd\`";
+ }
+ return $cmd;
+ }
diff -c /dev/null 'perl-5.7.2/NetWare/config_sh.PL'
Index: ./NetWare/config_sh.PL
*** ./NetWare/config_sh.PL Thu Jan 1 02:00:00 1970
--- ./NetWare/config_sh.PL Mon Jul 9 17:09:40 2001
***************
*** 0 ****
--- 1,83 ----
+ # take a semicolon separated path list and turn it into a quoted
+ # list of paths that Text::Parsewords will grok
+ sub mungepath {
+ my $p = shift;
+ # remove leading/trailing semis/spaces
+ $p =~ s/^[ ;]+//;
+ $p =~ s/[ ;]+$//;
+ $p =~ s/'/"/g;
+ my @p = map { $_ = "\"$_\"" if /\s/ and !/^".*"$/; $_ } split /;/, $p;
+ return join(' ', @p);
+ }
+
+ # generate an array of option strings from command-line args
+ # or an option file
+ # -- added by BKS, 10-17-1999 to fix command-line overflow problems
+ sub loadopts {
+ if ($ARGV[0] =~ /--cfgsh-option-file/) {
+ shift @ARGV;
+ my $optfile = shift @ARGV;
+ local (*F);
+ open OPTF, $optfile or die "Can't open $optfile: $!\n";
+ my @opts;
+ chomp(my $line = <OPTF>);
+ my @vars = split(/\t+~\t+/, $line);
+ for (@vars) {
+ push(@opts, $_) unless (/^\s*$/);
+ }
+ close OPTF;
+ return \@opts;
+ }
+ else {
+ return \@ARGV;
+ }
+ }
+
+ my %opt;
+ my $optref = loadopts();
+ while (@{$optref} && $optref->[0] =~ /^([\w_]+)=(.*)$/) {
+ $opt{$1}=$2;
+ shift(@{$optref});
+ }
+
+ my $pl_h = '../patchlevel.h';
+
+ if (-e $pl_h) {
+ open PL, "<$pl_h" or die "Can't open $pl_h: $!";
+ while (<PL>) {
+ if (/^#\s*define\s+(PERL_\w+)\s+([\d.]+)/) {
+ $opt{$1} = $2;
+ }
+ }
+ close PL;
+ }
+ else {
+ die "Can't find $pl_h: $!";
+ }
+ $opt{VERSION} = "$opt{PERL_REVISION}.$opt{PERL_VERSION}.$opt{PERL_SUBVERSION}";
+ $opt{INST_VER} =~ s|~VERSION~|$opt{VERSION}|g;
+
+ $opt{'cf_by'} = $ENV{USERNAME} unless $opt{'cf_by'};
+ $opt{'cf_email'} = $opt{'cf_by'} . '@' . (gethostbyname('localhost'))[0]
+ unless $opt{'cf_email'};
+ $opt{'usemymalloc'} = 'y' if $opt{'d_mymalloc'} eq 'define';
+
+ $opt{libpth} = mungepath($opt{libpth}) if exists $opt{libpth};
+ $opt{incpath} = mungepath($opt{incpath}) if exists $opt{incpath};
+
+ while (<>) {
+ s/~([\w_]+)~/$opt{$1}/g;
+ if (/^([\w_]+)=(.*)$/) {
+ my($k,$v) = ($1,$2);
+ # this depends on cf_time being empty in the template (or we'll
+ # get a loop)
+ if ($k eq 'cf_time') {
+ $_ = "$k='" . localtime(time) . "'\n" if $v =~ /^\s*'\s*'/;
+ }
+ elsif (exists $opt{$k}) {
+ $_ = "$k='$opt{$k}'\n";
+ }
+ }
+ print;
+ }
+
diff -c /dev/null 'perl-5.7.2/NetWare/deb.h'
Index: ./NetWare/deb.h
*** ./NetWare/deb.h Thu Jan 1 02:00:00 1970
--- ./NetWare/deb.h Mon Jul 9 17:09:40 2001
***************
*** 0 ****
--- 1,47 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : deb.h
+ * DESCRIPTION : Defines Breakpoint macro.
+ * Author : SGP
+ * Date : January 2001.
+ *
+ */
+
+
+
+ #ifndef __Inc__deb___
+ #define __Inc__deb___
+
+
+ #include <nwconio.h>
+
+
+ #if defined(DEBUGON) && !defined(USE_D2)
+ //debug build and d1 flag is used, so enable IDB
+ #define DBGMESG ConsolePrintf
+ #define IDB(x) \
+ ConsolePrintf(x); \
+ _asm {int 3}
+ #else
+ #if defined(USE_D2)
+ //debug build and d2 flag is used, so disable IDB
+ #define DBGMESG ConsolePrintf
+ #define IDB ConsolePrintf
+ #else
+ //release build, so disable DBGMESG and IDB
+ #define DBGMESG
+ #define IDB
+ #endif //if defined(USE_D2)
+ #endif //if defined(DEBUGON) && !defined(USE_D2)
+
+
+ #endif /*__Inc__deb___*/
+
diff -c /dev/null 'perl-5.7.2/NetWare/dl_netware.xs'
Index: ./NetWare/dl_netware.xs
*** ./NetWare/dl_netware.xs Thu Jan 1 02:00:00 1970
--- ./NetWare/dl_netware.xs Mon Jul 9 17:09:40 2001
***************
*** 0 ****
--- 1,194 ----
+ /* dl_netware.xs
+ *
+ * Platform: NetWare
+ * Author: SGP
+ * Created: 21st July 2000
+ * Last Modified: 23rd Oct 2000
+ * Note: !!!Any modification to the xs file to be done to the one which is under netware directory!!!
+ * Modification History
+ * 23rd Oct - Failing to find nlms with long names fixed - sdbm_file
+ */
+
+ /*
+
+ NetWare related modifications done on dl_win32.xs file created by Wei-Yuen Tan to get this file.
+
+ */
+
+
+ #include <nwthread.h>
+ #include <nwerrno.h>
+
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+
+
+ //function pointer for UCSInitialize
+ typedef void (*PFUCSINITIALIZE) ();
+
+ #ifdef PERL_OBJECT
+
+ #endif /* PERL_OBJECT */
+
+ #include "dlutils.c" /* SaveError() etc */
+
+ static void
+ dl_private_init(pTHXo)
+ {
+ (void)dl_generic_private_init(aTHXo);
+ }
+
+
+ MODULE = DynaLoader PACKAGE = DynaLoader
+
+ BOOT:
+ (void)dl_private_init(aTHXo);
+
+
+ void *
+ dl_load_file(filename,flags=0)
+ char * filename
+ int flags
+ PREINIT:
+ CODE:
+ {
+ char* mod_name = filename;
+
+ //Names with more than 8 chars can't be found with FindNLMHandle
+ //8 - Name, 1 - Period, 3 - Extension, 1 - String terminator
+ char mod_name8[13]={'\0'};
+ char *p=NULL;
+ char *buffer=NULL;
+ int nNameLength=0;
+ unsigned int nlmHandle=0;
+
+ while (*mod_name) mod_name++;
+
+ //Get the module name with extension to see if it is already loaded
+ while (mod_name > filename && mod_name[-1] != '/' && mod_name[-1] != '\\') mod_name--;
+
+ DLDEBUG(1,PerlIO_printf(Perl_debug_log,"dl_load_file(%s):\n", filename));
+
+ buffer = strdup(mod_name);
+ p = strtok (buffer, ".");
+ if (p) {
+ nNameLength = (strlen(p)>8)?8:strlen(p);
+ memcpy(mod_name8,p,nNameLength);
+ *(mod_name8 + nNameLength) = '.';
+ *(mod_name8 + nNameLength+1) ='\0';
+ p = strtok (NULL, ".");
+ if (p){
+ strcat(mod_name8,p);
+
+ if ( (nlmHandle = FindNLMHandle(mod_name8)) == NULL )
+ {
+ //NLM/NLP not loaded, load it and get the handle
+ if(spawnlp(P_NOWAIT, filename, filename, NULL)!=0)
+ {
+ //failed to load the NLM/NLP, this unlikely
+ //If multiple scripts are executed for the first time before running any other
+ //ucs script, sometimes there used to be an abend.
+ switch(NetWareErrno)
+ {
+ case LOAD_CAN_NOT_LOAD_MULTIPLE_COPIES:
+ nlmHandle = FindNLMHandle(mod_name8);
+ break;
+ case LOAD_ALREADY_IN_PROGRESS:
+ #ifdef MPK_ON
+ kYieldThread();
+ #else
+ ThreadSwitch();
+ #endif //MPK_ON
+ nlmHandle = FindNLMHandle(mod_name8);
+ break;
+ default:
+ nlmHandle = 0;
+ }
+ }
+ else
+ {
+ nlmHandle = FindNLMHandle(mod_name8);
+ }
+ }
+ //use UCSExt encountered-
+ //initialize UCS, this has to be terminated when the script finishes execution
+ //Is the script intending to use UCS Extensions?
+ //This should be done once per script execution
+ if (strcmp(mod_name,"Perl2UCS.nlp")==0)
+ {
+ unsigned int moduleHandle = 0;
+ moduleHandle = FindNLMHandle("UCSCORE.NLM");
+ if (moduleHandle)
+ {
+ PFUCSINITIALIZE ucsinit = (PFUCSINITIALIZE)ImportSymbol(moduleHandle,"UCSInitialize");
+ if (ucsinit!=NULL)
+ (*ucsinit)();
+ }
+ }
+
+ DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", nlmHandle));
+ ST(0) = sv_newmortal() ;
+ if (nlmHandle == NULL)
+ //SaveError(aTHXo_ "load_file:%s",
+ // OS_Error_String(aTHXo)) ;
+ ConsolePrintf("load_file error : %s\n", mod_name8);
+ else
+ sv_setiv( ST(0), (IV)nlmHandle);
+ }
+ }
+ free(buffer);
+
+
+ }
+
+ void *
+ dl_find_symbol(libhandle, symbolname)
+ void * libhandle
+ char * symbolname
+ CODE:
+ DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%s)\n",
+ libhandle, symbolname));
+
+ //import the symbol that the dynaloader is asking for.
+ RETVAL = (void *)ImportSymbol((int)libhandle, symbolname);
+
+ DLDEBUG(2,PerlIO_printf(Perl_debug_log," symbolref = %x\n", RETVAL));
+ ST(0) = sv_newmortal() ;
+ if (RETVAL == NULL)
+ //SaveError(aTHXo_ "find_symbol:%s",
+ // OS_Error_String(aTHXo)) ;
+ ConsolePrintf("find_symbol error \n");
+ 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
+ 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(perl_name,
+ (void(*)(pTHXo_ CV *))symref,
+ filename)));
+
+
+ char *
+ dl_error()
+ CODE:
+ RETVAL = LastError ;
+ OUTPUT:
+ RETVAL
+
+ # end.
+
+
diff -c /dev/null 'perl-5.7.2/NetWare/intdef.h'
Index: ./NetWare/intdef.h
*** ./NetWare/intdef.h Thu Jan 1 02:00:00 1970
--- ./NetWare/intdef.h Mon Jul 9 17:09:40 2001
***************
*** 0 ****
--- 1,86 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : intdef.h
+ * DESCRIPTION : ANSI functions hash defined to equivalent Netware functions.
+ * Author : SGP
+ * Date : July 1999.
+ *
+ */
+
+
+
+ #ifndef __INTDEF__
+ #define __INTDEF__
+
+
+ #include <nwlocale.h>
+ #include "..\utility\utility.h"
+
+
+ //ANSI functions define to equivalent NetWare internationalization functions
+
+ #define setlocale NWLsetlocale
+ #define localeconv NWLlocaleconv
+ #define strncoll NWstrncoll
+ #define strftime NWLstrftime
+
+ #define atoi NWLatoi
+ #define itoa NWitoa
+ #define utoa NWutoa
+ #define ultoa NWultoa
+ #define ltoa NWltoa
+
+ #define isalnum NWLisalnum
+ #define isalpha NWLisalpha
+ #define isdigit NWLisdigit
+
+ #define strlen NWLmbslen
+ #define mblen NWLmblen
+
+ //#define strcpy(x,y) NWLstrbcpy(x,y,NWstrlen(y)+1)
+ #define strcpy(x,y) \
+ NWstrncpy(x,y,NWstrlen(y)); \
+ x[NWstrlen(y)] ='\0';
+ #define strncpy(x,y,z) NWLstrbcpy(x,y,(z + 1))
+ #define strcat(x,y) NWLstrbcpy((x + NWstrlen(x)), y, (NWstrlen(y) +1))
+ #define strncmp(s1,s2,l) NWgstrncmp(s1,s2,l)
+ #define strnicmp(s1,s2,l) NWgstrnicmp(s1,s2,l)
+
+ #define toupper(s1) NWCharUpr(s1)
+ #define wsprintf NWsprintf
+
+ #define strncat(x,y,l) \
+ NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strncat\n"); \
+ strncat(x,y,l);
+
+ #define strdup(s1) \
+ NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strdup\n"); \
+ strdup(s1);
+
+ #define strlist \
+ NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strlist\n"); \
+ strlist;
+
+ #define strlwr(s1) \
+ NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strlwr\n"); \
+ strlwr(s1);
+
+ #define strnset(s1,l1,l2) \
+ NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strnset\n"); \
+ strnset(s1,l1,l2);
+
+ #define strset(s1,l1) \
+ NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strset\n"); \
+ strset(s1,l1);
+
+
+ #endif // __INTDEF__
+
diff -c /dev/null 'perl-5.7.2/NetWare/interface.c'
Index: ./NetWare/interface.c
*** ./NetWare/interface.c Thu Jan 1 02:00:00 1970
--- ./NetWare/interface.c Mon Jul 9 17:09:40 2001
***************
*** 0 ****
--- 1,208 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : interface.c
+ * DESCRIPTION : Calling Perl APIs.
+ * Author : SGP
+ * Date Created : January 2001.
+ * Date Modified: July 2nd 2001.
+ */
+
+
+
+ #include "interface.h"
+ #include "nwtinfo.h"
+
+ static void xs_init(pTHX);
+
+ EXTERN_C int RunPerl(int argc, char **argv, char **env);
+ EXTERN_C void Perl_nw5_init(int *argcp, char ***argvp);
+ EXTERN_C void boot_DynaLoader (pTHXo_ CV* cv);
+
+
+ ClsPerlHost::ClsPerlHost()
+ {
+
+ }
+
+ ClsPerlHost::~ClsPerlHost()
+ {
+
+ }
+
+ ClsPerlHost::VersionNumber()
+ {
+ return 0;
+ }
+
+ bool
+ ClsPerlHost::RegisterWithThreadTable()
+ {
+ return(fnRegisterWithThreadTable());
+ }
+
+ bool
+ ClsPerlHost::UnregisterWithThreadTable()
+ {
+ return(fnUnregisterWithThreadTable());
+ }
+
+ int
+ ClsPerlHost::PerlCreate(PerlInterpreter *my_perl)
+ {
+ /* if (!(my_perl = perl_alloc())) // Allocate memory for Perl.
+ return (1);*/
+ perl_construct(my_perl);
+
+ return 1;
+ }
+
+ int
+ ClsPerlHost::PerlParse(PerlInterpreter *my_perl, int argc, char** argv, char** env)
+ {
+ return(perl_parse(my_perl, xs_init, argc, argv, env)); // Parse the command line.
+ }
+
+ int
+ ClsPerlHost::PerlRun(PerlInterpreter *my_perl)
+ {
+ return(perl_run(my_perl)); // Run Perl.
+ }
+
+ void
+ ClsPerlHost::PerlDestroy(PerlInterpreter *my_perl)
+ {
+ perl_destruct(my_perl); // Destructor for Perl.
+ perl_free(my_perl); // Free the memory allocated for Perl.
+
+ }
+
+ /*============================================================================================
+
+ Function : xs_init
+
+ Description :
+
+ Parameters : pTHX (IN) -
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ static void xs_init(pTHX)
+ {
+ char *file = __FILE__;
+
+ dXSUB_SYS;
+ newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
+ }
+
+
+ EXTERN_C
+ int RunPerl(int argc, char **argv, char **env)
+ {
+ int exitstatus = 0;
+ ClsPerlHost nlm;
+
+ PerlInterpreter *my_perl = NULL; // defined in Perl.h
+ PerlInterpreter *new_perl = NULL; // defined in Perl.h
+
+ #ifdef PERL_GLOBAL_STRUCT
+ #define PERLVAR(var,type)
+ #define PERLVARA(var,type)
+ #define PERLVARI(var,type,init) PL_Vars.var = init;
+ #define PERLVARIC(var,type,init) PL_Vars.var = init;
+
+ #include "perlvars.h"
+
+ #undef PERLVAR
+ #undef PERLVARA
+ #undef PERLVARI
+ #undef PERLVARIC
+ #endif
+
+ PERL_SYS_INIT(&argc, &argv);
+
+ if (!(my_perl = perl_alloc())) // Allocate memory for Perl.
+ return (1);
+
+ if(nlm.PerlCreate(my_perl))
+ {
+ PL_perl_destruct_level = 0;
+
+ exitstatus = nlm.PerlParse(my_perl, argc, argv, env);
+ if(exitstatus == 0)
+ {
+ #if defined(TOP_CLONE) && defined(USE_ITHREADS) // XXXXXX testing
+ # ifdef PERL_OBJECT
+ CPerlHost *h = new CPerlHost();
+ new_perl = perl_clone_using(my_perl, 1,
+ h->m_pHostperlMem,
+ h->m_pHostperlMemShared,
+ h->m_pHostperlMemParse,
+ h->m_pHostperlEnv,
+ h->m_pHostperlStdIO,
+ h->m_pHostperlLIO,
+ h->m_pHostperlDir,
+ h->m_pHostperlSock,
+ h->m_pHostperlProc
+ );
+ CPerlObj *pPerl = (CPerlObj*)new_perl;
+ # else
+ new_perl = perl_clone(my_perl, 1);
+ # endif
+
+ exitstatus = perl_run(new_perl); // Run Perl.
+ PERL_SET_THX(my_perl);
+ #else
+ exitstatus = nlm.PerlRun(my_perl);
+ #endif
+ }
+ nlm.PerlDestroy(my_perl);
+ }
+
+ #ifdef USE_ITHREADS
+ if (new_perl)
+ {
+ PERL_SET_THX(new_perl);
+ nlm.PerlDestroy(new_perl);
+ }
+ #endif
+
+ PERL_SYS_TERM();
+ return exitstatus;
+ }
+
+
+ // FUNCTION: AllocStdPerl
+ //
+ // DESCRIPTION:
+ // Allocates a standard perl handler that other perl handlers
+ // may delegate to. You should call FreeStdPerl to free this
+ // instance when you are done with it.
+ //
+ IPerlHost* AllocStdPerl()
+ {
+ return new ClsPerlHost();
+ }
+
+
+ // FUNCTION: FreeStdPerl
+ //
+ // DESCRIPTION:
+ // Frees an instance of a standard perl handler allocated by
+ // AllocStdPerl.
+ //
+ void FreeStdPerl(IPerlHost* pPerlHost)
+ {
+ delete (ClsPerlHost*) pPerlHost;
+ }
+
+
diff -c /dev/null 'perl-5.7.2/NetWare/interface.h'
Index: ./NetWare/interface.h
*** ./NetWare/interface.h Thu Jan 1 02:00:00 1970
--- ./NetWare/interface.h Mon Jul 9 17:09:40 2001
***************
*** 0 ****
--- 1,45 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : interface.c
+ * DESCRIPTION : Perl parsing and running functions.
+ * Author : SGP
+ * Date Created : January 2001.
+ * Date Modified: July 2nd 2001.
+ */
+
+
+
+ #ifndef __Interface_H__
+ #define __Interface_H__
+
+
+ #include "iperlhost.h"
+
+
+ class ClsPerlHost : public IPerlHost
+ {
+ public:
+ ClsPerlHost(void);
+ virtual ~ClsPerlHost(void);
+
+ int VersionNumber();
+
+ int PerlCreate(PerlInterpreter *my_perl);
+ int PerlParse(PerlInterpreter *my_perl, int argc, char** argv, char** env);
+ int PerlRun(PerlInterpreter *my_perl);
+ void PerlDestroy(PerlInterpreter *my_perl);
+ bool RegisterWithThreadTable(void);
+ bool UnregisterWithThreadTable(void);
+ };
+
+
+ #endif // __Interface_H__
+
diff -c /dev/null 'perl-5.7.2/NetWare/iperlhost.h'
Index: ./NetWare/iperlhost.h
*** ./NetWare/iperlhost.h Thu Jan 1 02:00:00 1970
--- ./NetWare/iperlhost.h Mon Jul 9 17:09:41 2001
***************
*** 0 ****
--- 1,46 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : iperlhost.h
+ * DESCRIPTION : IPerlHost class file.
+ * Author : SGP
+ * Date Created : January 2001.
+ * Date Modified: July 2nd 2001.
+ */
+
+
+
+ #ifndef __iPerlHost_H__
+ #define __iPerlHost_H__
+
+
+ #include "EXTERN.h"
+ #include "perl.h"
+
+
+ class IPerlHost
+ {
+ public:
+ virtual int VersionNumber() = 0;
+
+ virtual int PerlCreate(PerlInterpreter *my_perl) = 0;
+ virtual int PerlParse(PerlInterpreter *my_perl,int argc, char** argv, char** env) = 0;
+ virtual int PerlRun(PerlInterpreter *my_perl) = 0;
+ virtual void PerlDestroy(PerlInterpreter *my_perl) = 0;
+ virtual bool RegisterWithThreadTable(void)=0;
+ virtual bool UnregisterWithThreadTable(void)=0;
+ };
+
+ extern "C" IPerlHost* AllocStdPerl();
+ extern "C" void FreeStdPerl(IPerlHost* pPerlHost);
+
+
+ #endif // __iPerlHost_H__
+
diff -c /dev/null 'perl-5.7.2/NetWare/netware.h'
Index: ./NetWare/netware.h
*** ./NetWare/netware.h Thu Jan 1 02:00:00 1970
--- ./NetWare/netware.h Mon Jul 9 17:19:43 2001
***************
*** 0 ****
--- 1,89 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : netware.h
+ * DESCRIPTION : Include for NetWare stuff.
+ * This is based on the win32.h file of Win32 port.
+ * Author : SGP
+ * Date : January 2001.
+ *
+ */
+
+
+
+ #ifndef _INC_NW_PERL5
+ #define _INC_NW_PERL5
+
+ #include <dirent.h>
+ #include "stdio.h"
+
+ // to get the internal debugger break for functions that are not yet handled
+ #include "deb.h"
+
+ #ifndef EXT
+ #include "EXTERN.h"
+ #endif
+
+ //structure that will be used by times routine.
+ struct tms {
+ long tms_utime;
+ long tms_stime;
+ long tms_cutime;
+ long tms_cstime;
+ };
+
+ #define PERL_GET_CONTEXT_DEFINED
+ #define ENV_IS_CASELESS
+
+ #undef init_os_extras
+ #define init_os_extras Perl_init_os_extras
+
+ #define HAVE_INTERP_INTERN
+ struct interp_intern {
+ void * internal_host;
+ };
+
+ /*
+ * handle socket stuff, assuming socket is always available
+ */
+ #include <sys/socket.h>
+ #include <sys/types.h>
+ #include <netdb.h>
+
+ //This is clashing with a definition in perly.h, hence
+ //undefine, may have to redefine if need be - CHKSGP
+ #undef WORD
+
+ #ifndef SOCKET
+ typedef u_int SOCKET;
+ #endif
+
+ #define nw_internal_host (PL_sys_intern.internal_host)
+
+ EXTERN_C void Perl_nw5_init(int *argcp, char ***argvp);
+
+ #define PTHREAD_ATFORK(prepare,parent,child) NOOP
+
+ /*
+ * This provides a layer of functions and macros to ensure extensions will
+ * get to use the same RTL functions as the core.
+ */
+ #include "nw5iop.h"
+
+ // Below is called in Run.c file when a perl script executes/runs.
+ #ifdef MPK_ON
+ #define PERL_ASYNC_CHECK() kYieldThread();
+ #else
+ #define PERL_ASYNC_CHECK() ThreadSwitch();
+ #endif
+
+
+ #endif /* _INC_NW_PERL5 */
+
diff -c /dev/null 'perl-5.7.2/NetWare/nw5.c'
Index: ./NetWare/nw5.c
*** ./NetWare/nw5.c Thu Jan 1 02:00:00 1970
--- ./NetWare/nw5.c Mon Jul 9 17:09:41 2001
***************
*** 0 ****
--- 1,905 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : nw5.c
+ * DESCRIPTION : Definitions for the redefined functions for NetWare.
+ * Author : SGP, HYAK
+ * Date : January 2001.
+ *
+ */
+
+
+
+ #include <perl.h> // For dTHXo, etc.
+ #include "nwpipe.h"
+
+
+ // This was added since the compile failed saying "undefined P_WAIT"
+ // when USE_ITHREADS was commented in the makefile
+ #ifndef P_WAIT
+ #define P_WAIT 0
+ #endif
+
+ #ifndef P_NOWAIT
+ #define P_NOWAIT 1
+ #endif
+
+ // The array is used to store pointer to the memory allocated to the TempPipeFile structure everytime
+ // a call to the function, nw_Popen. If a simple variable is used, everytime the memory is allocated before
+ // the previously allocated memory is freed, the pointer will get overwritten and the previous memory allocations
+ // are lost! Only the most recent one will get freed when calls are made to nw_Pclose.
+ // By using the array and the iPopenCount to index the array, all memory are freed!
+
+ // The size of the array indicates the limit on the no of times the nw_Popen function can be called (and
+ // memory allocted) from within a script through backtick operators!
+ // This is arbitrarily set to MAX_PIPE_RECURSION=256 which indicates there can be 256 nested backtick operators possible!
+ PTEMPPIPEFILE ptpf1[MAX_PIPE_RECURSION] = {'\0'};
+ int iPopenCount = 0;
+ FILE* File1[MAX_PIPE_RECURSION] = {'\0'};
+
+
+ /**
+ General:
+
+ In this code, wherever there is a FILE *, the error condition is checked; and only if the FILE * is TRUE,
+ then the corresponding operation is done. Otherwise the error value is returned.
+ This is done because the file operations like "open" in the Perl code returns the FILE *,
+ returning a valid value if the file is found or NULL when the particular file is not found.
+ Now, if the return value is NULL, then an operation say "fgets", "fopen" etc. using this this NULL value
+ for FILE * will abend the server. If the check is made then an operation on a non existing file
+ does not abend the server.
+ **/
+
+ void
+ nw_abort(void)
+ {
+ abort(); // Terminate the NLM application abnormally.
+ return;
+ }
+
+ int
+ nw_access(const char *path, int mode)
+ {
+ return access(path, mode);
+ }
+
+ int
+ nw_chmod(const char *path, int mode)
+ {
+ return chmod(path, mode);
+ }
+
+ void
+ nw_clearerr(FILE *pf)
+ {
+ if(pf)
+ clearerr(pf);
+ }
+
+ int
+ nw_close(int fd)
+ {
+ return close(fd);
+ }
+
+ nw_closedir(DIR *dirp)
+ {
+ return (closedir(dirp));
+ }
+
+ void
+ nw_setbuf(FILE *pf, char *buf)
+ {
+ if(pf)
+ setbuf(pf, buf);
+ }
+
+ int
+ nw_setmode(FILE *fp, int mode)
+ {
+ int *dummy = 0;
+ return(fnFpSetMode(fp, mode, dummy));
+ }
+
+ int
+ nw_setvbuf(FILE *pf, char *buf, int type, size_t size)
+ {
+ if(pf)
+ return setvbuf(pf, buf, type, size);
+ else
+ return -1;
+ }
+
+
+ unsigned int
+ nw_sleep(unsigned int t)
+ {
+ delay(t*1000); // Put the thread to sleep for 't' seconds. Initially 't' is passed in milliseconds.
+ return 0;
+ }
+
+ int
+ nw_spawnvp(int mode, char *cmdname, char **argv)
+ {
+ // There is no pass-around environment on NetWare so we throw that
+ // argument away for now.
+
+ // The function "spawnvp" does not work in all situations. Loading
+ // edit.nlm seems to work, for example, but the name of the file
+ // to edit does not appear to get passed correctly. Another problem
+ // is that on Netware, P_WAIT does not really work reliably. It only
+ // works with NLMs built to use CLIB (according to Nile Thayne).
+ // NLMs such as EDIT that are written directly to the system have no
+ // way of running synchronously from another process. The whole
+ // architecture on NetWare seems pretty busted, so we just support it
+ // as best we can.
+ //
+ // The spawnvp function only launches NLMs, it will not execute a command;
+ // the NetWare "system" function is used for that purpose. Unfortunately, "system"
+ // always returns success whether the command is successful or not or even
+ // if the command was not found! To avoid ambiguity--you can have both an
+ // NLM named "perl" and a system command named "perl"--we need to
+ // force perl scripts to carry the word "load" when loading an NLM. This
+ // might be clearer anyway.
+
+ int ret = 0;
+ int argc = 0;
+
+
+ if (stricmp(cmdname, LOAD_COMMAND) == 0)
+ {
+ if (argv[1] != NULL)
+ ret = spawnvp(mode, argv[1], &argv[1]);
+ }
+ else
+ {
+ int i=0;
+ while (argv[i] != '\0')
+ i++;
+ argc = i;
+
+ fnSystemCommand(argv, argc);
+ }
+
+ return ret;
+ }
+
+ int
+ nw_execv(char *cmdname, char **argv)
+ {
+ return spawnvp(P_WAIT, cmdname, (char **)argv);
+ }
+
+
+ int
+ nw_execvp(char *cmdname, char **argv)
+ {
+ return nw_spawnvp(P_WAIT, cmdname, (char **)argv);
+ }
+
+ int
+ nw_stat(const char *path, struct stat *sbuf)
+ {
+ return (stat(path, sbuf));
+ }
+
+ FILE *
+ nw_stderr(void)
+ {
+ return (stderr);
+ }
+
+ FILE *
+ nw_stdin(void)
+ {
+ return (stdin);
+ }
+
+ FILE *
+ nw_stdout()
+ {
+ return (stdout);
+ }
+
+ long
+ nw_telldir(DIR *dirp)
+ {
+ dTHXo;
+ Perl_croak(aTHX_ "telldir function is not implemented");
+ return 0l;
+ }
+
+ int
+ nw_times(struct tms *timebuf)
+ {
+ clock_t now = clock();
+
+ timebuf->tms_utime = now;
+ timebuf->tms_stime = 0;
+ timebuf->tms_cutime = 0;
+ timebuf->tms_cstime = 0;
+
+ return 0;
+ }
+
+ FILE*
+ nw_tmpfile(void)
+ {
+ return tmpfile();
+ }
+
+ int
+ nw_uname(struct utsname *name)
+ {
+ return(uname(name));
+ }
+
+ int
+ nw_ungetc(int c, FILE *pf)
+ {
+ if(pf)
+ return ungetc(c, pf);
+ else
+ return -1;
+ }
+
+ int
+ nw_unlink(const char *filename)
+ {
+ return(unlink(filename));
+ }
+
+ int
+ nw_utime(const char *filename, struct utimbuf *times)
+ {
+ return(utime(filename, times));
+ }
+
+ int
+ nw_vfprintf(FILE *fp, const char *format, va_list args)
+ {
+ if(fp)
+ return (vfprintf(fp, format, args));
+ else
+ return -1;
+ }
+
+ int
+ nw_wait(int *status)
+ {
+ return 0;
+ }
+
+ int
+ nw_waitpid(int pid, int *status, int flags)
+ {
+ return 0;
+ }
+
+ int
+ nw_write(int fd, const void *buf, unsigned int cnt)
+ {
+ return write(fd, buf, cnt);
+ }
+
+ char *
+ nw_crypt(const char *txt, const char *salt)
+ {
+ dTHXo;
+
+ #ifdef HAVE_DES_FCRYPT
+ dTHR;
+ return des_fcrypt(txt, salt, w32_crypt_buffer);
+ #else
+ Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
+ return Nullch;
+ #endif
+ }
+
+ int
+ nw_dup(int fd)
+ {
+ return dup(fd);
+ }
+
+ int
+ nw_dup2(int fd1,int fd2)
+ {
+ return dup2(fd1,fd2);
+ }
+
+ void*
+ nw_dynaload(const char* filename)
+ {
+ return NULL;
+ }
+
+ int
+ nw_fclose(FILE *pf)
+ {
+ if(pf)
+ return (fclose(pf));
+ else
+ return -1;
+ }
+
+ FILE *
+ nw_fdopen(int handle, const char *mode)
+ {
+ return(fdopen(handle, mode));
+ }
+
+ int
+ nw_feof(FILE *fp)
+ {
+ if(fp)
+ return (feof(fp));
+ else
+ return -1;
+ }
+
+ int
+ nw_ferror(FILE *fp)
+ {
+ if(fp)
+ return (ferror(fp));
+ else
+ return -1;
+ }
+
+
+ int
+ nw_fflush(FILE *pf)
+ {
+ if(pf)
+ return fflush(pf);
+ else
+ return -1;
+ }
+
+ int
+ nw_fgetpos(FILE *pf, fpos_t *p)
+ {
+ if(pf)
+ return fgetpos(pf, p);
+ else
+ return -1;
+ }
+
+ char*
+ nw_fgets(char *s, int n, FILE *pf)
+ {
+ if(pf)
+ return(fgets(s, n, pf));
+ else
+ return NULL;
+ }
+
+ int
+ nw_fileno(FILE *pf)
+ {
+ if(pf)
+ return fileno(pf);
+ else
+ return -1;
+ }
+
+ int
+ nw_flock(int fd, int oper)
+ {
+ return 0;
+ }
+
+
+ FILE *
+ nw_fopen(const char *filename, const char *mode)
+ {
+ return (fopen(filename, mode));
+ }
+
+ int
+ nw_fputc(int c, FILE *pf)
+ {
+ if(pf)
+ return fputc(c,pf);
+ else
+ return -1;
+ }
+
+ int
+ nw_fputs(const char *s, FILE *pf)
+ {
+ if(pf)
+ return fputs(s, pf);
+ else
+ return -1;
+ }
+
+ size_t
+ nw_fread(void *buf, size_t size, size_t count, FILE *fp)
+ {
+ if(fp)
+ return fread(buf, size, count, fp);
+ else
+ return -1;
+ }
+
+ FILE *
+ nw_freopen(const char *path, const char *mode, FILE *stream)
+ {
+ if(stream)
+ return freopen(path, mode, stream);
+ else
+ return NULL;
+ }
+
+ int
+ nw_fseek(FILE *pf, long offset, int origin)
+ {
+ if(pf)
+ return (fseek(pf, offset, origin));
+ else
+ return -1;
+ }
+
+ int
+ nw_fsetpos(FILE *pf, const fpos_t *p)
+ {
+ if(pf)
+ return fsetpos(pf, p);
+ else
+ return -1;
+ }
+
+ long
+ nw_ftell(FILE *pf)
+ {
+ if(pf)
+ return ftell(pf);
+ else
+ return -1;
+ }
+
+ size_t
+ nw_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
+ {
+ if(fp)
+ return fwrite(buf, size, count, fp);
+ else
+ return -1;
+ }
+
+ long
+ nw_get_osfhandle(int fd)
+ {
+ return 0l;
+ }
+
+ int
+ nw_getc(FILE *pf)
+ {
+ if(pf)
+ return getc(pf);
+ else
+ return -1;
+ }
+
+ int
+ nw_putc(int c, FILE *pf)
+ {
+ if(pf)
+ return putc(c,pf);
+ else
+ return -1;
+ }
+
+ int
+ nw_fgetc(FILE *pf)
+ {
+ if(pf)
+ return fgetc(pf);
+ else
+ return -1;
+ }
+
+ int
+ nw_getpid(void)
+ {
+ return GetThreadGroupID();
+ }
+
+ int
+ nw_kill(int pid, int sig)
+ {
+ return 0;
+ }
+
+ int
+ nw_link(const char *oldname, const char *newname)
+ {
+ return 0;
+ }
+
+ long
+ nw_lseek(int fd, long offset, int origin)
+ {
+ return lseek(fd, offset, origin);
+ }
+
+ int
+ nw_chdir(const char *dir)
+ {
+ return chdir(dir);
+ }
+
+ int
+ nw_rmdir(const char *dir)
+ {
+ return rmdir(dir);
+ }
+
+ DIR *
+ nw_opendir(char *filename)
+ {
+ char *buff = NULL;
+ int len = 0;
+ DIR *ret = NULL;
+
+ len = strlen(filename);
+ buff = malloc(len + 5);
+ if (buff) {
+ strcpy(buff, filename);
+ if (buff[len-1]=='/' || buff[len-1]=='\\') {
+ buff[--len] = 0;
+ }
+ strcpy(buff+len, "/*.*");
+ ret = opendir(buff);
+ free (buff);
+ buff = NULL;
+ return ret;
+ } else {
+ return NULL;
+ }
+ }
+
+ int
+ nw_open(const char *path, int flag, ...)
+ {
+ va_list ap;
+ int pmode = -1;
+
+ va_start(ap, flag);
+ pmode = va_arg(ap, int);
+ va_end(ap);
+
+ if (stricmp(path, "/dev/null")==0)
+ path = "NUL";
+
+ return open(path, flag, pmode);
+ }
+
+ int
+ nw_open_osfhandle(long handle, int flags)
+ {
+ return 0;
+ }
+
+ unsigned long
+ nw_os_id(void)
+ {
+ return 0l;
+ }
+
+ int nw_Pipe(int* a, int* e)
+ {
+ int ret = 0;
+
+ errno = 0;
+ ret = pipe(a);
+ if(errno)
+ e = &errno;
+
+ return ret;
+ }
+
+ FILE* nw_Popen(char* command, char* mode, int* e)
+ {
+ int i = -1;
+
+ FILE* ret = NULL;
+ PTEMPPIPEFILE ptpf = NULL;
+
+ // this callback is supposed to call _popen, which spawns an
+ // asynchronous command and opens a pipe to it. The returned
+ // file handle can be read or written to; if read, it represents
+ // stdout of the called process and will return EOF when the
+ // called process finishes. If written to, it represents stdin
+ // of the called process. Naturally _popen is not available on
+ // NetWare so we must do some fancy stuff to simulate it. We will
+ // redirect to and from temp files; this has the side effect
+ // of having to run the process synchronously rather than
+ // asynchronously. This means that you will only be able to do
+ // this with CLIB NLMs built to run on the calling thread.
+
+ errno = 0;
+
+ ptpf1[iPopenCount] = (PTEMPPIPEFILE) malloc(sizeof(TEMPPIPEFILE));
+ if (!ptpf1[iPopenCount])
+ return NULL;
+
+ ptpf = ptpf1[iPopenCount];
+ iPopenCount ++;
+ if(iPopenCount > MAX_PIPE_RECURSION)
+ iPopenCount = MAX_PIPE_RECURSION; // Limit to the max no of pipes to be open recursively.
+
+ fnTempPipeFile(ptpf);
+ ret = fnPipeFileOpen((PTEMPPIPEFILE) ptpf, (char *) command, (char *) mode);
+ if (ret)
+ File1[iPopenCount-1] = ret; // Store the obtained Pipe file handle.
+ else
+ { // Pipe file not obtained. So free the allocated memory.
+ if(ptpf1[iPopenCount-1])
+ {
+ free(ptpf1[iPopenCount-1]);
+ ptpf1[iPopenCount-1] = NULL;
+ ptpf = NULL;
+ iPopenCount --;
+ }
+ }
+
+ if (errno)
+ e = &errno;
+
+ return ret;
+ }
+
+ int nw_Pclose(FILE* file, int* e)
+ {
+ int i=0, j=0;
+
+ errno = 0;
+
+ if(file)
+ {
+ if(iPopenCount > 0)
+ {
+ for (i=0; i<iPopenCount; i++)
+ {
+ if(File1[i] == file)
+ {
+ // Delete the memory allocated corresponding to the file handle passed-in and
+ // also close the file corresponding to the file handle passed-in!
+ if(ptpf1[i])
+ {
+ fnPipeFileClose(ptpf1[i]);
+
+ free(ptpf1[i]);
+ ptpf1[i] = NULL;
+ }
+
+ fclose(File1[i]);
+ File1[i] = NULL;
+
+ break;
+ }
+ }
+
+ // Rearrange the file pointer array
+ for(j=i; j<(iPopenCount-1); j++)
+ {
+ File1[j] = File1[j+1];
+ ptpf1[j] = ptpf1[j+1];
+ }
+ iPopenCount--;
+ }
+ }
+ else
+ return -1;
+
+ if (errno)
+ e = &errno;
+
+ return 0;
+ }
+
+
+ int
+ nw_vprintf(const char *format, va_list args)
+ {
+ return (vprintf(format, args));
+ }
+
+ int
+ nw_printf(const char *format, ...)
+ {
+
+ va_list marker;
+ va_start(marker, format); /* Initialize variable arguments. */
+
+ return (vprintf(format, marker));
+ }
+
+ int
+ nw_read(int fd, void *buf, unsigned int cnt)
+ {
+ return read(fd, buf, cnt);
+ }
+
+ struct direct *
+ nw_readdir(DIR *dirp)
+ {
+ DIR* ret=NULL;
+
+ ret = readdir(dirp);
+ if(ret)
+ return((struct direct *)ret);
+ return NULL;
+ }
+
+ int
+ nw_rename(const char *oname, const char *newname)
+ {
+ return(rename(oname,newname));
+ }
+
+ void
+ nw_rewinddir(DIR *dirp)
+ {
+ dTHXo;
+ Perl_croak(aTHX_ "rewinddir function is not implemented");
+ }
+
+ void
+ nw_rewind(FILE *pf)
+ {
+ if(pf)
+ rewind(pf);
+ }
+
+ void
+ nw_seekdir(DIR *dirp, long loc)
+ {
+ dTHXo;
+ Perl_croak(aTHX_ "seekdir function is not implemented");
+ }
+
+ int *
+ nw_errno(void)
+ {
+ return (&errno);
+ }
+
+ char ***
+ nw_environ(void)
+ {
+ return ((char ***)nw_getenviron());
+ }
+
+ char *
+ nw_strerror(int e)
+ {
+ return (strerror(e));
+ }
+
+ int
+ nw_isatty(int fd)
+ {
+ return(isatty(fd));
+ }
+
+ char *
+ nw_mktemp(char *Template)
+ {
+ return (fnMy_MkTemp(Template));
+ }
+
+ int
+ nw_chsize(int handle, long size)
+ {
+ return(chsize(handle,size));
+ }
+
+ #ifdef HAVE_INTERP_INTERN
+ void
+ sys_intern_init(pTHX)
+ {
+
+ }
+
+ void
+ sys_intern_clear(pTHX)
+ {
+
+ }
+
+ void
+ sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
+ {
+
+ }
+ #endif /* HAVE_INTERP_INTERN */
+
+ void
+ Perl_init_os_extras(void)
+ {
+
+ }
+
+ void
+ Perl_nw5_init(int *argcp, char ***argvp)
+ {
+ MALLOC_INIT;
+ }
+
+ #ifdef USE_ITHREADS
+ PerlInterpreter *
+ perl_clone_host(PerlInterpreter* proto_perl, UV flags)
+ {
+ // Perl Clone is not implemented on NetWare.
+ return NULL;
+ }
+ #endif
+
+ // Some more functions:
+
+ char *
+ nw_get_sitelib(const char *pl)
+ {
+ return (NULL);
+ }
+
+ int
+ execv(char *cmdname, char **argv)
+ {
+ // This feature needs to be implemented.
+ // _asm is commented out since it goes into the internal debugger.
+ // _asm {int 3};
+ return(0);
+ }
+
+ int
+ execvp(char *cmdname, char **argv)
+ {
+ // This feature needs to be implemented.
+ // _asm is commented out since it goes into the internal debugger.
+ // _asm {int 3};
+ return(0);
+ }
+
+ int
+ do_aspawn(void *vreally, void **vmark, void **vsp)
+ {
+ // This feature needs to be implemented.
+ // _asm is commented out since it goes into the internal debugger.
+ // _asm {int 3};
+ return(0);
+ }
+
+ int
+ do_spawn2(char *cmd, int exectype)
+ {
+ // This feature needs to be implemented.
+ // _asm is commented out since it goes into the internal debugger.
+ // _asm {int 3};
+ return(0);
+ }
+
+ int
+ do_spawn(char *cmd)
+ {
+ return do_spawn2(cmd, 2);
+ }
+
+ int
+ fork(void)
+ {
+ return 0;
+ }
+
diff -c /dev/null 'perl-5.7.2/NetWare/nw5iop.h'
Index: ./NetWare/nw5iop.h
*** ./NetWare/nw5iop.h Thu Jan 1 02:00:00 1970
--- ./NetWare/nw5iop.h Mon Jul 9 17:09:41 2001
***************
*** 0 ****
--- 1,213 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : nw5iop.h
+ * DESCRIPTION : Redefined functions for NetWare.
+ * Author : SGP, HYAK
+ * Date : January 2001.
+ *
+ */
+
+
+
+ #ifndef NW5IOP_H
+ #define NW5IOP_H
+
+
+ #ifndef START_EXTERN_C
+ #ifdef __cplusplus
+ # define START_EXTERN_C extern "C" {
+ # define END_EXTERN_C }
+ # define EXTERN_C extern "C"
+ #else
+ # define START_EXTERN_C
+ # define END_EXTERN_C
+ # define EXTERN_C
+ #endif
+ #endif
+
+ #if defined(_MSC_VER) || defined(__MINGW32__)
+ # include <sys/utime.h>
+ #else
+ # include <utime.h>
+ #endif
+
+ /*
+ * defines for flock emulation
+ */
+ #define LOCK_SH 1
+ #define LOCK_EX 2
+ #define LOCK_NB 4
+ #define LOCK_UN 8
+
+
+ /*
+ * Make this as close to original stdio as possible.
+ */
+
+ /*
+ * function prototypes for our own win32io layer
+ */
+ /********CHKSGP ****/
+ //making DLLExport as nothing
+ #define DllExport
+ /*******************/
+
+ START_EXTERN_C
+
+ int * nw_errno(void);
+ char *** nw_environ(void);
+
+ FILE* nw_stdin(void);
+ FILE* nw_stdout(void);
+ FILE* nw_stderr(void);
+ int nw_ferror(FILE *fp);
+ int nw_feof(FILE *fp);
+
+ char* nw_strerror(int e);
+
+ int nw_fprintf(FILE *pf, const char *format, ...);
+ int nw_printf(const char *format, ...);
+ int nw_vfprintf(FILE *pf, const char *format, va_list arg);
+ int nw_vprintf(const char *format, va_list arg);
+
+ size_t nw_fread(void *buf, size_t size, size_t count, FILE *pf);
+ size_t nw_fwrite(const void *buf, size_t size, size_t count, FILE *pf);
+ FILE* nw_fopen(const char *path, const char *mode);
+ FILE* nw_fdopen(int fh, const char *mode);
+ FILE* nw_freopen(const char *path, const char *mode, FILE *pf);
+ int nw_fclose(FILE *pf);
+
+ int nw_fputs(const char *s,FILE *pf);
+ int nw_fputc(int c,FILE *pf);
+ int nw_ungetc(int c,FILE *pf);
+ int nw_getc(FILE *pf);
+ int nw_fileno(FILE *pf);
+ void nw_clearerr(FILE *pf);
+ int nw_fflush(FILE *pf);
+ long nw_ftell(FILE *pf);
+ int nw_fseek(FILE *pf,long offset,int origin);
+ int nw_fgetpos(FILE *pf,fpos_t *p);
+ int nw_fsetpos(FILE *pf,const fpos_t *p);
+ void nw_rewind(FILE *pf);
+ FILE* nw_tmpfile(void);
+
+ void nw_abort(void);
+
+ int nw_stat(const char *name,struct stat *sbufptr);
+
+ FILE* nw_Popen(char* command, char* mode, int* e);
+ int nw_Pclose(FILE* file, int* e);
+ int nw_Pipe(int* a, int* e);
+
+ int nw_rename( const char *oname, const char *newname);
+ //int nw_setmode( int fd, int mode);
+ int nw_setmode( FILE *fp, int mode);
+ long nw_lseek( int fd, long offset, int origin);
+ int nw_dup( int fd);
+ int nw_dup2(int h1, int h2);
+ int nw_open(const char *path, int oflag,...);
+ int nw_close(int fd);
+ int nw_read(int fd, void *buf, unsigned int cnt);
+ int nw_write(int fd, const void *buf, unsigned int cnt);
+
+ int nw_spawnvp(int mode, char *cmdname, char **argv);
+
+ int nw_rmdir(const char *dir);
+ int nw_chdir(const char *dir);
+ int nw_flock(int fd, int oper);
+
+ int nw_execv(char *cmdname, char **argv);
+ int nw_execvp(char *cmdname, char **argv);
+
+ void nw_setbuf(FILE *pf, char *buf);
+ int nw_setvbuf(FILE *pf, char *buf, int type, size_t size);
+ char* nw_fgets(char *s, int n, FILE *pf);
+
+ int nw_fgetc(FILE *pf);
+
+ int nw_putc(int c, FILE *pf);
+
+ int nw_open_osfhandle(long handle, int flags);
+ long nw_get_osfhandle(int fd);
+
+ DIR* nw_opendir(char *filename);
+ struct direct* nw_readdir(DIR *dirp);
+ long nw_telldir(DIR *dirp);
+ void nw_seekdir(DIR *dirp, long loc);
+ void nw_rewinddir(DIR *dirp);
+ int nw_closedir(DIR *dirp);
+
+ unsigned int nw_sleep(unsigned int);
+ int nw_times(struct tms *timebuf);
+
+ int nw_stat(const char *path, struct stat *buf);
+ int nw_link(const char *oldname, const char *newname);
+ int nw_unlink(const char *f);
+ int nw_utime(const char *f, struct utimbuf *t);
+ DllExport int nw_uname(struct utsname *n);
+
+ int nw_wait(int *status);
+
+ int nw_waitpid(int pid, int *status, int flags);
+ int nw_kill(int pid, int sig);
+
+ unsigned long nw_os_id(void);
+ void* nw_dynaload(const char*filename);
+
+ int nw_access(const char *path, int mode);
+ int nw_chmod(const char *path, int mode);
+ int nw_getpid(void);
+
+ char * nw_crypt(const char *txt, const char *salt);
+
+ int nw_isatty(int fd);
+ char* nw_mktemp(char *Template);
+ int nw_chsize(int handle, long size);
+ END_EXTERN_C
+
+
+ /*
+ * the following six(6) is #define in stdio.h
+ */
+ #ifndef WIN32IO_IS_STDIO
+ #undef environ
+ #undef feof
+ #undef pipe
+ #undef pause
+ #undef sleep
+ #undef times
+ #undef alarm
+ #undef ioctl
+ #undef unlink
+ #undef utime
+ #undef uname
+ #undef wait
+
+ #ifdef __BORLANDC__
+ #undef ungetc
+ #undef getc
+ #undef putc
+ #undef getchar
+ #undef putchar
+ #undef fileno
+ #endif
+
+ #define environ (*nw_environ())
+
+
+ #if !defined(MYMALLOC) || !defined(PERL_CORE)
+
+ #endif
+
+
+ #endif /* WIN32IO_IS_STDIO */
+ #endif /* NW5IOP_H */
+
diff -c /dev/null 'perl-5.7.2/NetWare/nw5sck.c'
Index: ./NetWare/nw5sck.c
*** ./NetWare/nw5sck.c Thu Jan 1 02:00:00 1970
--- ./NetWare/nw5sck.c Mon Jul 9 17:09:41 2001
***************
*** 0 ****
--- 1,299 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : nw5sck.c
+ * DESCRIPTION : Socket related functions.
+ * Author : SGP
+ * Date : January 2001.
+ * Date Modified: June 26th 2001.
+ */
+
+
+
+ #include "EXTERN.h"
+ #include "perl.h"
+
+ #if defined(PERL_OBJECT)
+ #define NO_XSLOCKS
+ #include "XSUB.h"
+ #endif
+
+ #include "nw5iop.h"
+ #include "nw5sck.h"
+ #include <fcntl.h>
+ #include <sys/stat.h>
+
+ u_long
+ nw_htonl(u_long hostlong)
+ {
+ return htonl(hostlong);
+ }
+
+ u_short
+ nw_htons(u_short hostshort)
+ {
+ return htons(hostshort);
+ }
+
+ u_long
+ nw_ntohl(u_long netlong)
+ {
+ return ntohl(netlong);
+ }
+
+ u_short
+ nw_ntohs(u_short netshort)
+ {
+ return ntohs(netshort);
+ }
+
+ SOCKET
+ nw_accept(SOCKET s, struct sockaddr *addr, int *addrlen)
+ {
+ return ((SOCKET)(accept(s, addr, addrlen)));
+ }
+
+ int
+ nw_bind(SOCKET s, const struct sockaddr *addr, int addrlen)
+ {
+ return ((int)bind(s, (struct sockaddr *)addr, addrlen));
+
+ }
+
+ int
+ nw_connect(SOCKET s, const struct sockaddr *addr, int addrlen)
+ {
+ return((int)connect(s, (struct sockaddr *)addr, addrlen));
+ }
+
+ void
+ nw_endhostent()
+ {
+ endhostent();
+ }
+
+ void
+ nw_endnetent()
+ {
+ endnetent();
+ }
+
+ void
+ nw_endprotoent()
+ {
+ endprotoent();
+ }
+
+ void
+ nw_endservent()
+ {
+ endservent();
+ }
+
+ struct hostent *
+ nw_gethostent()
+ {
+ return(gethostent());
+ }
+
+ struct netent *
+ nw_getnetent(void)
+ {
+ return ((struct netent *) getnetent());
+ }
+
+ struct protoent *
+ nw_getprotoent(void)
+ {
+ return ((struct protoent *) getprotoent());
+ }
+
+ struct hostent *
+ nw_gethostbyname(const char *name)
+ {
+ return(gethostbyname((char*)name));
+ }
+
+ int
+ nw_gethostname(char *name, int len)
+ {
+ return(gethostname(name, len));
+ }
+
+ struct hostent *
+ nw_gethostbyaddr(const char *addr, int len, int type)
+ {
+ return(gethostbyaddr((char*)addr, len, type));
+ }
+
+ struct netent *
+ nw_getnetbyaddr(long net, int type)
+ {
+ return(getnetbyaddr(net,type));
+ }
+
+ struct netent *
+ nw_getnetbyname(char *name)
+ {
+ return (struct netent *)getnetbyname(name);
+ }
+
+ int
+ nw_getpeername(SOCKET s, struct sockaddr *addr, int *addrlen)
+ {
+ return((int)getpeername(s, addr, addrlen));
+ }
+
+ struct protoent *
+ nw_getprotobyname(const char *name)
+ {
+ return ((struct protoent *)getprotobyname((char*)name));
+ }
+
+ struct protoent *
+ nw_getprotobynumber(int num)
+ {
+ return ((struct protoent *)getprotobynumber(num));
+ }
+
+ struct servent *
+ nw_getservbyname(const char *name, const char *proto)
+ {
+ return (struct servent *)getservbyname((char*)name, (char*)proto);
+ }
+
+
+ struct servent *
+ nw_getservbyport(int port, const char *proto)
+ {
+ return (struct servent *)getservbyport(port, (char*)proto);
+ }
+
+ struct servent *
+ nw_getservent(void)
+ {
+ return (struct servent *) getservent();
+ }
+
+ void
+ nw_sethostent(int stayopen)
+ {
+ sethostent(stayopen);
+ }
+
+ void
+ nw_setnetent(int stayopen)
+ {
+ setnetent(stayopen);
+ }
+
+ void
+ nw_setprotoent(int stayopen)
+ {
+ setprotoent(stayopen);
+ }
+
+ void
+ nw_setservent(int stayopen)
+ {
+ setservent(stayopen);
+ }
+
+ int
+ nw_setsockopt(SOCKET s, int level, int optname, const char* optval, int optlen)
+ {
+ return setsockopt(s, level, optname, (char*)optval, optlen);
+ }
+
+ int
+ nw_getsockname(SOCKET s, struct sockaddr *addr, int *addrlen)
+ {
+ return getsockname(s, addr, addrlen);
+ }
+
+ int
+ nw_getsockopt(SOCKET s, int level, int optname, char *optval, int *optlen)
+ {
+ return ((int)getsockopt(s, level, optname, optval, optlen));
+ }
+
+ unsigned long
+ nw_inet_addr(const char *cp)
+ {
+ return inet_addr((char*)cp);
+ }
+
+ SOCKET
+ nw_socket(int af, int type, int protocol)
+ {
+ SOCKET s;
+
+ #ifndef USE_SOCKETS_AS_HANDLES
+ s = socket(af, type, protocol);
+ #else
+ if((s = socket(af, type, protocol)) == INVALID_SOCKET)
+ //errno = WSAGetLastError();
+ else
+ s = s;
+ #endif /* USE_SOCKETS_AS_HANDLES */
+
+ return s;
+ }
+
+ int
+ nw_listen(SOCKET s, int backlog)
+ {
+ return(listen(s, backlog));
+ }
+
+ int
+ nw_send(SOCKET s, const char *buf, int len, int flags)
+ {
+ return(send(s,(char*)buf,len,flags));
+ }
+
+ int
+ nw_recv(SOCKET s, char *buf, int len, int flags)
+ {
+ return (recv(s, buf, len, flags));
+ }
+
+ int
+ nw_sendto(SOCKET s, const char *buf, int len, int flags,
+ const struct sockaddr *to, int tolen)
+ {
+ return(sendto(s, (char*)buf, len, flags, (struct sockaddr *)to, tolen));
+ }
+
+ int
+ nw_recvfrom(SOCKET s, char *buf, int len, int flags, struct sockaddr *from, int *fromlen)
+ {
+ int r;
+ int frombufsize = *fromlen;
+
+ r = recvfrom(s, buf, len, flags, from, fromlen);
+ //Not sure if the is required - chksgp
+ if (r && frombufsize == *fromlen)
+ (void)nw_getpeername(s, from, fromlen);
+ return r;
+ }
+
+ int
+ nw_select(int nfds, fd_set* rd, fd_set* wr, fd_set* ex, const struct timeval* timeout)
+ {
+ return(select(nfds, rd, wr, ex, (struct timeval*)timeout));
+ }
+
+ int
+ nw_shutdown(SOCKET s, int how)
+ {
+ return (shutdown(s, how));
+ }
+
diff -c /dev/null 'perl-5.7.2/NetWare/nw5sck.h'
Index: ./NetWare/nw5sck.h
*** ./NetWare/nw5sck.h Thu Jan 1 02:00:00 1970
--- ./NetWare/nw5sck.h Mon Jul 9 17:09:41 2001
***************
*** 0 ****
--- 1,129 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : nw5sck.h
+ * DESCRIPTION : Socket related functions.
+ * Author : SGP
+ * Date : January 2001.
+ * Date Modified: June 26th 2001.
+ *
+ */
+
+
+
+ #ifndef _INC_NW_SOCKET
+ #define _INC_NW_SOCKET
+
+
+ #include <sys/socket.h>
+ #ifdef __cplusplus
+ extern "C" {
+ #endif
+
+ typedef u_int SOCKET;
+
+ struct nwsockent local_context;
+
+ # undef gethostbyname
+ # undef gethostbyaddr
+
+ # undef endhostent
+ # undef endnetent
+ # undef endprotoent
+ # undef endservent
+ # undef gethostent
+ # undef getprotoent
+ # undef getnetbyaddr
+ # undef getnetbyname
+ # undef gethostbyaddr
+ # undef getprotobyname
+ # undef getservbyname
+ # undef getservbyport
+ # undef getservent
+ # undef sethostent
+ # undef setnetent
+ # undef setprotoent
+ # undef setservent
+
+ # define gethostbyname(name) NetDBgethostbyname(&local_context,name)
+ # define gethostbyaddr(a,l,t) NetDBgethostbyaddr(&local_context,a,l,t)
+
+ # define endhostent() NetDBendhostent(&local_context)
+ # define endnetent() NWendnetent(&local_context)
+ # define endprotoent() NWendprotoent(&local_context)
+ # define endservent() NWendservent(&local_context)
+ # define gethostent() NetDBgethostent(&local_context,NULL)
+ # define getprotoent() NWgetprotoent(&local_context)
+ # define gethostbyaddr(a,l,t) NetDBgethostbyaddr(&local_context,a,l,t)
+ # define getnetbyaddr(net,typ) NWgetnetbyaddr(&local_context,net,typ)
+ # define getnetbyname(name) NWgetnetbyname(&local_context,name)
+ # define getprotobyname(name) NWgetprotobyname(&local_context,name)
+ # define getservbyname(n,p) NWgetservbyname(&local_context,n,p)
+ # define getservbyport(n,p) NWgetservbyport(&local_context,n,p)
+ # define getservent() NWgetservent(&local_context)
+ # define sethostent() NWsethostent(&local_context, stayopen)
+ # define setnetent() NWsetnetent(&local_context, stayopen)
+ # define setprotoent() NWsetprotoent(&local_context, stayopen)
+ # define setservent() NWsetservent(&local_context, stayopen)
+
+ u_long nw_htonl(u_long hostlong);
+ u_short nw_htons(u_short hostshort);
+ u_long nw_ntohl(u_long netlong);
+ u_short nw_ntohs(u_short netshort);
+
+ SOCKET nw_accept(SOCKET s, struct sockaddr *addr, int *addrlen);
+ int nw_bind(SOCKET s, const struct sockaddr *addr, int addrlen);
+ int nw_connect(SOCKET s, const struct sockaddr *addr, int addrlen);
+
+ struct hostent * nw_gethostbyname(const char * name);
+ struct hostent * nw_gethostbyaddr(const char *addr, int len, int type);
+ int nw_gethostname(char *name, int len);
+ struct netent * nw_getnetbyaddr(long net, int type);
+ struct netent *nw_getnetbyname(char *name);
+ int nw_getpeername(SOCKET s, struct sockaddr *addr, int *addrlen);
+ struct protoent * nw_getprotobyname(const char *name);
+ struct protoent * nw_getprotobynumber(int num);
+ struct servent * nw_getservbyname(const char *name, const char *proto);
+ struct servent * nw_getservbyport(int port, const char *proto);
+ struct servent * nw_getservent(void);
+ void nw_sethostent(int stayopen);
+ void nw_setnetent(int stayopen);
+ void nw_setprotoent(int stayopen);
+ void nw_setservent(int stayopen);
+ int nw_setsockopt(SOCKET s, int level, int optname, const char* optval, int optlen);
+
+ int nw_getsockname(SOCKET s, struct sockaddr *addr, int *addrlen);
+ int nw_getsockopt(SOCKET s, int level, int optname, char *optval, int *optlen);
+
+ unsigned long nw_inet_addr(const char *cp);
+
+ void nw_endhostent();
+ void nw_endnetent();
+ void nw_endprotoent();
+ void nw_endservent();
+ struct hostent *nw_gethostent();
+ struct netent *nw_getnetent();
+ struct protoent * nw_getprotoent();
+
+ SOCKET nw_socket(int af, int type, int protocol);
+ int nw_listen(SOCKET s, int backlog);
+ int nw_send(SOCKET s, const char *buf, int len, int flags);
+ int nw_recv(SOCKET s, char *buf, int len, int flags);
+ int nw_sendto(SOCKET s, const char *buf, int len, int flags,const struct sockaddr *to, int tolen);
+ int nw_recvfrom(SOCKET s, char *buf, int len, int flags, struct sockaddr *from, int *fromlen);
+ int nw_select(int nfds, fd_set* rd, fd_set* wr, fd_set* ex, const struct timeval* timeout);
+ int nw_shutdown(SOCKET s, int how);
+ #ifdef __cplusplus
+ }
+ #endif
+
+
+ #endif // _INC_NW_SOCKET
+
diff -c /dev/null 'perl-5.7.2/NetWare/nw5thread.c'
Index: ./NetWare/nw5thread.c
*** ./NetWare/nw5thread.c Thu Jan 1 02:00:00 1970
--- ./NetWare/nw5thread.c Mon Jul 9 17:09:41 2001
***************
*** 0 ****
--- 1,86 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : nw5thread.c
+ * DESCRIPTION : Thread related functions.
+ * Author : SGP
+ * Date : January 2001.
+ *
+ */
+
+
+
+ #include "EXTERN.h"
+ #include "perl.h"
+
+ #if defined(PERL_OBJECT)
+ #define NO_XSLOCKS
+ extern CPerlObj* pPerl;
+ #include "XSUB.h"
+ #endif
+
+ //For Thread Local Storage
+ #include "win32ish.h" // For "BOOL", "TRUE" and "FALSE"
+ #include "nwtinfo.h"
+
+ #ifdef USE_DECLSPEC_THREAD
+ __declspec(thread) void *PL_current_context = NULL;
+ #endif
+
+
+ void
+ Perl_set_context(void *t)
+ {
+ #if defined(USE_THREADS) || defined(USE_ITHREADS)
+ # ifdef USE_DECLSPEC_THREAD
+ Perl_current_context = t;
+ # else
+ fnAddThreadCtx(PL_thr_key, t);
+ # endif
+ #endif
+ }
+
+
+ void *
+ Perl_get_context(void)
+ {
+ #if defined(USE_THREADS) || defined(USE_ITHREADS)
+ # ifdef USE_DECLSPEC_THREAD
+ return Perl_current_context;
+ # else
+ return(fnGetThreadCtx(PL_thr_key));
+ # endif
+ #else
+ return NULL;
+ #endif
+ }
+
+
+ //To Remove the Thread Context stored during Perl_set_context
+ BOOL
+ Remove_Thread_Ctx(void)
+ {
+ #if defined(USE_THREADS) || defined(USE_ITHREADS)
+ # ifdef USE_DECLSPEC_THREAD
+ return TRUE;
+ # else
+ return(fnRemoveThreadCtx(PL_thr_key));
+ # endif
+ # else
+ return TRUE;
+ #endif
+ }
+
+
+ //PL_thr_key - Not very sure if this is global or per thread. When multiple scripts
+ //run simultaneously on NetWare, this will give problems. Hence in nwtinfo.c, the
+ //current thread id is used as the TLS index & PL_thr_key is not used.
+ //This has to be checked???? - sgp
+
diff -c /dev/null 'perl-5.7.2/NetWare/nw5thread.h'
Index: ./NetWare/nw5thread.h
*** ./NetWare/nw5thread.h Thu Jan 1 02:00:00 1970
--- ./NetWare/nw5thread.h Mon Jul 9 17:09:41 2001
***************
*** 0 ****
--- 1,176 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : nw5thread.h
+ * DESCRIPTION : Thread related functions.
+ * Author : SGP
+ * Date : January 2001.
+ *
+ */
+
+
+
+ #ifndef _NW5THREAD_H
+ #define _NW5THREAD_H
+
+
+ #include <nwthread.h>
+
+ #include "netware.h"
+
+ typedef long perl_key;
+
+ #if (defined (USE_ITHREADS) || defined (USE_THREADS)) && defined(MPK_ON)
+ #ifdef __cplusplus
+ extern "C"
+ {
+ #endif
+ #include <mpktypes.h>
+ #include <mpkapis.h>
+ #define kSUCCESS (0)
+ #define ERROR_INVALID_MUTEX (0x1010)
+
+ #ifdef __cplusplus
+ }
+ #endif
+ #undef WORD
+ //On NetWare, since the NLM will be resident, only once the MUTEX_INIT gets called and
+ //this will be freed when the script terminates. But when a new script is executed,
+ //then MUTEX_LOCK will fail since it is already freed. Even if this problem is fixed
+ //by not freeing the mutex when script terminates but when the NLM unloads, there will
+ //still be problems when multiple scripts are running simultaneously in a multi-processor
+ //machine - sgp
+ typedef MUTEX perl_mutex;
+ # define MUTEX_INIT(m) \
+ STMT_START { \
+ /*if ((*(m) = kMutexAlloc("NetWarePerlMutex")) == NULL) */\
+ /*Perl_croak_nocontext("panic: MUTEX_ALLOC"); */\
+ /*ConsolePrintf("Mutex Init %d\n",*(m)); */\
+ } STMT_END
+
+ # define MUTEX_LOCK(m) \
+ STMT_START { \
+ /*ConsolePrintf("Mutex lock %d\n",*(m)); */\
+ /*if (kMutexLock(*(m)) == ERROR_INVALID_MUTEX) */\
+ /*Perl_croak_nocontext("panic: MUTEX_LOCK"); */\
+ } STMT_END
+
+ # define MUTEX_UNLOCK(m) \
+ STMT_START { \
+ /*ConsolePrintf("Mutex unlock %d\n",*(m)); */\
+ /*if (kMutexUnlock(*(m)) != kSUCCESS) \
+ Perl_croak_nocontext("panic: MUTEX_UNLOCK"); */\
+ } STMT_END
+
+ # define MUTEX_DESTROY(m) \
+ STMT_START { \
+ /*ConsolePrintf("Mutex Destroy %d\n",*(m)); */\
+ /*if (kMutexWaitCount(*(m)) == 0 ) */\
+ /*{ */\
+ /*PERL_SET_INTERP(NULL); *//*newly added CHKSGP???*/ \
+ /*if (kMutexFree(*(m)) != kSUCCESS) */ \
+ /*Perl_croak_nocontext("panic: MUTEX_FREE"); */\
+ /*} */\
+ } STMT_END
+
+ #else
+ typedef unsigned long perl_mutex;
+ # define MUTEX_INIT(m)
+ # define MUTEX_LOCK(m)
+ # define MUTEX_UNLOCK(m)
+ # define MUTEX_DESTROY(m)
+ #endif
+
+ /* These macros assume that the mutex associated with the condition
+ * will always be held before COND_{SIGNAL,BROADCAST,WAIT,DESTROY},
+ * so there's no separate mutex protecting access to (c)->waiters
+ */
+ //For now let us just see when this happens -sgp.
+ #define COND_INIT(c) \
+ STMT_START { \
+ ConsolePrintf("In COND_INIT\n"); \
+ } STMT_END
+
+ /* (c)->waiters = 0; \
+ (c)->sem = OpenLocalSemaphore (0); \
+ if ((c)->sem == NULL) \
+ Perl_croak_nocontext("panic: COND_INIT (%ld)",errno); \*/
+
+ #define COND_SIGNAL(c) \
+ STMT_START { \
+ ConsolePrintf("In COND_SIGNAL\n"); \
+ } STMT_END
+ /*if ((c)->waiters > 0 && \
+ SignalLocalSemaphore((c)->sem) != 0) \
+ Perl_croak_nocontext("panic: COND_SIGNAL (%ld)",errno); \*/
+
+ #define COND_BROADCAST(c) \
+ STMT_START { \
+ ConsolePrintf("In COND_BROADCAST\n"); \
+ } STMT_END
+
+ /*if ((c)->waiters > 0 ) { \
+ int count; \
+ for(count=0; count<(c)->waiters; count++) { \
+ if(SignalLocalSemaphore((c)->sem) != 0) \
+ Perl_croak_nocontext("panic: COND_BROADCAST (%ld)",GetLastError());\
+ } \
+ } \*/
+ #define COND_WAIT(c, m) \
+ STMT_START { \
+ ConsolePrintf("In COND_WAIT\n"); \
+ } STMT_END
+
+
+ #define COND_DESTROY(c) \
+ STMT_START { \
+ ConsolePrintf("In COND_DESTROY\n"); \
+ } STMT_END
+
+ /* (c)->waiters = 0; \
+ if (CloseLocalSemaphore((c)->sem) != 0) \
+ Perl_croak_nocontext("panic: COND_DESTROY (%ld)",errno); \*/
+
+ #if 0
+ #define DETACH(t) \
+ STMT_START { \
+ if (CloseHandle((t)->self) == 0) { \
+ MUTEX_UNLOCK(&(t)->mutex); \
+ Perl_croak_nocontext("panic: DETACH"); \
+ } \
+ } STMT_END
+ #endif //#if 0
+
+ //Following has to be defined CHKSGP
+ #if defined(PERLDLL) && defined(USE_DECLSPEC_THREAD) && (!defined(__BORLANDC__) || defined(_DLL))
+ extern __declspec(thread) void *PL_current_context;
+ #define PERL_SET_CONTEXT(t) (PL_current_context = t)
+ #define PERL_GET_CONTEXT PL_current_context
+ #else
+ #define PERL_GET_CONTEXT Perl_get_context()
+ #define PERL_SET_CONTEXT(t) Perl_set_context(t)
+ #endif
+
+ //Check the following, will be used in Thread extension - CHKSGP
+ #define THREAD_RET_TYPE unsigned __stdcall
+ #define THREAD_RET_CAST(p) ((unsigned)(p))
+
+ #define INIT_THREADS NOOP
+
+ //Ideally this should have been PL_thr_key = fnInitializeThreadCtx();
+ //See the comment at the end of file nw5thread.c as to why PL_thr_key is not assigned - sgp
+ #define ALLOC_THREAD_KEY \
+ STMT_START { \
+ fnInitializeThreadCtx(); \
+ } STMT_END
+
+
+ #endif /* _NW5THREAD_H */
+
diff -c /dev/null 'perl-5.7.2/NetWare/nwperlsys.c'
Index: ./NetWare/nwperlsys.c
*** ./NetWare/nwperlsys.c Thu Jan 1 02:00:00 1970
--- ./NetWare/nwperlsys.c Mon Jul 9 17:09:41 2001
***************
*** 0 ****
--- 1,228 ----
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : nwperlsys.c
+ * DESCRIPTION : Contains calls to Perl APIs and
+ * utility functions calls
+ *
+ * Author : SGP
+ * Date Created : June 12th 2001.
+ * Date Modified: June 26th 2001.
+ */
+
+ #include "EXTERN.h"
+ #include "perl.h"
+
+
+ #ifdef PERL_OBJECT
+ #define NO_XSLOCKS
+ #endif
+
+ //CHKSGP
+ //Including this is giving premature end-of-file error during compilation
+ //#include "XSUB.h"
+
+ #ifdef PERL_IMPLICIT_SYS
+
+ //Includes iperlsys.h and function definitions
+ #include "nwperlsys.h"
+
+ /*============================================================================================
+
+ Function : fnFreeMemEntry
+
+ Description : Called for each outstanding memory allocation at the end of a script run.
+ Frees the outstanding allocations
+
+ Parameters : ptr (IN).
+ context (IN)
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnFreeMemEntry(void* ptr, void* context)
+ {
+ if(ptr)
+ {
+ PerlMemFree(NULL, ptr);
+ }
+ }
+ /*============================================================================================
+
+ Function : fnAllocListHash
+
+ Description : Hashing function for hash table of memory allocations.
+
+ Parameters : invalue (IN).
+
+ Returns : unsigned.
+
+ ==============================================================================================*/
+
+ unsigned fnAllocListHash(void* const& invalue)
+ {
+ return (((unsigned) invalue & 0x0000ff00) >> 8);
+ }
+
+ /*============================================================================================
+
+ Function : perl_alloc
+
+ Description : creates a Perl interpreter variable and initializes
+
+ Parameters : none
+
+ Returns : Pointer to Perl interpreter
+
+ ==============================================================================================*/
+
+ EXTERN_C PerlInterpreter*
+ perl_alloc(void)
+ {
+ PerlInterpreter* my_perl = NULL;
+
+ WCValHashTable<void*>* m_allocList;
+ m_allocList = new WCValHashTable<void*> (fnAllocListHash, 256);
+ fnInsertHashListAddrs(m_allocList, FALSE);
+
+ my_perl = perl_alloc_using(&perlMem,
+ NULL,
+ NULL,
+ &perlEnv,
+ &perlStdIO,
+ &perlLIO,
+ &perlDir,
+ &perlSock,
+ &perlProc);
+ if (my_perl) {
+ #ifdef PERL_OBJECT
+ CPerlObj* pPerl = (CPerlObj*)my_perl;
+ #endif
+ //nw5_internal_host = m_allocList;
+ }
+ return my_perl;
+ }
+
+ /*============================================================================================
+
+ Function : perl_alloc_override
+
+ Description : creates a Perl interpreter variable and initializes
+
+ Parameters : Pointer to structure containing function pointers
+
+ Returns : Pointer to Perl interpreter
+
+ ==============================================================================================*/
+ EXTERN_C PerlInterpreter*
+ perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
+ struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
+ struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
+ struct IPerlDir** ppDir, struct IPerlSock** ppSock,
+ struct IPerlProc** ppProc)
+ {
+ PerlInterpreter *my_perl = NULL;
+
+ struct IPerlMem* lpMem;
+ struct IPerlEnv* lpEnv;
+ struct IPerlStdIO* lpStdio;
+ struct IPerlLIO* lpLIO;
+ struct IPerlDir* lpDir;
+ struct IPerlSock* lpSock;
+ struct IPerlProc* lpProc;
+
+ WCValHashTable<void*>* m_allocList;
+ m_allocList = new WCValHashTable<void*> (fnAllocListHash, 256);
+ fnInsertHashListAddrs(m_allocList, FALSE);
+
+ if (!ppMem)
+ lpMem=&perlMem;
+ else
+ lpMem=*ppMem;
+
+ if (!ppEnv)
+ lpEnv=&perlEnv;
+ else
+ lpEnv=*ppEnv;
+
+ if (!ppStdIO)
+ lpStdio=&perlStdIO;
+ else
+ lpStdio=*ppStdIO;
+
+ if (!ppLIO)
+ lpLIO=&perlLIO;
+ else
+ lpLIO=*ppLIO;
+
+ if (!ppDir)
+ lpDir=&perlDir;
+ else
+ lpDir=*ppDir;
+
+ if (!ppSock)
+ lpSock=&perlSock;
+ else
+ lpSock=*ppSock;
+
+ if (!ppProc)
+ lpProc=&perlProc;
+ else
+ lpProc=*ppProc;
+
+ my_perl = perl_alloc_using(lpMem,
+ NULL,
+ NULL,
+ lpEnv,
+ lpStdio,
+ lpLIO,
+ lpDir,
+ lpSock,
+ lpProc);
+
+ if (my_perl) {
+ #ifdef PERL_OBJECT
+ CPerlObj* pPerl = (CPerlObj*)my_perl;
+ #endif
+ //nw5_internal_host = pHost;
+ }
+ return my_perl;
+ }
+ /*============================================================================================
+
+ Function : nw5_delete_internal_host
+
+ Description : Deletes the alloc_list pointer
+
+ Parameters : alloc_list pointer
+
+ Returns : none
+
+ ==============================================================================================*/
+
+ EXTERN_C void
+ nw5_delete_internal_host(void *h)
+ {
+ WCValHashTable<void*>* m_allocList;
+ void **listptr;
+ BOOL m_dontTouchHashLists;
+ if (fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) {
+ m_allocList = (WCValHashTable<void*>*)listptr;
+ fnInsertHashListAddrs(m_allocList, TRUE);
+ if (m_allocList)
+ {
+ m_allocList->forAll(fnFreeMemEntry, NULL);
+ fnInsertHashListAddrs(NULL, FALSE);
+ delete m_allocList;
+ }
+ }
+ }
+
+ #endif /* PERL_IMPLICIT_SYS */
diff -c /dev/null 'perl-5.7.2/NetWare/nwperlsys.h'
Index: ./NetWare/nwperlsys.h
*** ./NetWare/nwperlsys.h Thu Jan 1 02:00:00 1970
--- ./NetWare/nwperlsys.h Mon Jul 9 17:09:41 2001
***************
*** 0 ****
--- 1,1385 ----
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : nwperlsys.h
+ * DESCRIPTION : Derives from iperlsys.h and define the
+ * platform specific function
+ * Author : SGP
+ * Date Created : June 12th 2001.
+ * Date Modified: June 30th 2001.
+ */
+
+ #ifndef ___NWPerlSys_H___
+ #define ___NWPerlSys_H___
+
+
+ #include "iperlsys.h"
+ #include "nwstdio.h"
+
+ #include "nw5iop.h"
+ #include <fcntl.h>
+
+ //Socket related calls
+ #include "nw5sck.h"
+
+ //Store the Watcom hash list
+ #include "nwtinfo.h"
+
+ //Watcom hash list
+ #include <wchash.h>
+
+ #include "win32ish.h"
+
+ START_EXTERN_C
+ extern int do_spawn2(char *cmd, int exectype);
+ extern int do_aspawn(void *vreally, void **vmark, void **vsp);
+ extern void Perl_init_os_extras(void);
+ BOOL fnGetHashListAddrs(void *addrs, BOOL *dontTouchHashList);
+ END_EXTERN_C
+
+ /* IPerlMem - Memory management functions - Begin ========================================*/
+
+ void*
+ PerlMemMalloc(struct IPerlMem* piPerl, size_t size)
+ {
+ void *ptr = NULL;
+ ptr = malloc(size);
+ if (ptr) {
+ void **listptr;
+ BOOL m_dontTouchHashLists;
+ if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) {
+ if (listptr) {
+ WCValHashTable<void*>* m_allocList= (WCValHashTable<void*>*)listptr;
+ (WCValHashTable<void*>*)m_allocList->insert(ptr);
+ }
+ }
+ }
+ return(ptr);
+ }
+
+ void*
+ PerlMemRealloc(struct IPerlMem* piPerl, void* ptr, size_t size)
+ {
+ void *newptr = NULL;
+ WCValHashTable<void*>* m_allocList;
+
+ newptr = realloc(ptr, size);
+
+ if (ptr)
+ {
+ void **listptr;
+ BOOL m_dontTouchHashLists;
+ if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) {
+ m_allocList= (WCValHashTable<void*>*)listptr;
+ (WCValHashTable<void*>*)m_allocList->remove(ptr);
+ }
+ }
+ if (newptr)
+ {
+ if (m_allocList)
+ (WCValHashTable<void*>*)m_allocList->insert(newptr);
+ }
+
+ return(newptr);
+ }
+
+ void
+ PerlMemFree(struct IPerlMem* piPerl, void* ptr)
+ {
+ BOOL m_dontTouchHashLists;
+ WCValHashTable<void*>* m_allocList;
+
+ void **listptr;
+ if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) {
+ m_allocList= (WCValHashTable<void*>*)listptr;
+ // Final clean up, free all the nodes from the hash list
+ if (m_dontTouchHashLists)
+ {
+ if(ptr)
+ {
+ free(ptr);
+ ptr = NULL;
+ }
+ }
+ else
+ {
+ if(ptr && m_allocList)
+ {
+ if ((WCValHashTable<void*>*)m_allocList->remove(ptr))
+ {
+ free(ptr);
+ ptr = NULL;
+ }
+ else
+ {
+ // If it comes here, that means that the memory pointer is not contained in the hash list.
+ // But no need to free now, since if is deleted here, it will result in an abend!!
+ // If the memory is still there, it will be cleaned during final cleanup anyway.
+ }
+ }
+ }
+ }
+ return;
+ }
+
+ void*
+ PerlMemCalloc(struct IPerlMem* piPerl, size_t num, size_t size)
+ {
+ void *ptr = NULL;
+
+ ptr = calloc(num, size);
+ if (ptr) {
+ void **listptr;
+ BOOL m_dontTouchHashLists;
+ if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) {
+ if (listptr) {
+ WCValHashTable<void*>* m_allocList= (WCValHashTable<void*>*)listptr;
+ (WCValHashTable<void*>*)m_allocList->insert(ptr);
+ }
+ }
+ }
+ return(ptr);
+ }
+
+ struct IPerlMem perlMem =
+ {
+ PerlMemMalloc,
+ PerlMemRealloc,
+ PerlMemFree,
+ PerlMemCalloc,
+ };
+
+ /* IPerlMem - Memory management functions - End ========================================*/
+
+ /* IPerlDir - Directory Manipulation functions - Begin ===================================*/
+
+ int
+ PerlDirMakedir(struct IPerlDir* piPerl, const char *dirname, int mode)
+ {
+ return mkdir(dirname);
+ }
+
+ int
+ PerlDirChdir(struct IPerlDir* piPerl, const char *dirname)
+ {
+ return nw_chdir(dirname);
+ }
+
+ int
+ PerlDirRmdir(struct IPerlDir* piPerl, const char *dirname)
+ {
+ return nw_rmdir(dirname);
+ }
+
+ int
+ PerlDirClose(struct IPerlDir* piPerl, DIR *dirp)
+ {
+ return nw_closedir(dirp);
+ }
+
+ DIR*
+ PerlDirOpen(struct IPerlDir* piPerl, char *filename)
+ {
+ return nw_opendir(filename);
+ }
+
+ struct direct *
+ PerlDirRead(struct IPerlDir* piPerl, DIR *dirp)
+ {
+ return nw_readdir(dirp);
+ }
+
+ void
+ PerlDirRewind(struct IPerlDir* piPerl, DIR *dirp)
+ {
+ nw_rewinddir(dirp);
+ }
+
+ void
+ PerlDirSeek(struct IPerlDir* piPerl, DIR *dirp, long loc)
+ {
+ nw_seekdir(dirp, loc);
+ }
+
+ long
+ PerlDirTell(struct IPerlDir* piPerl, DIR *dirp)
+ {
+ return nw_telldir(dirp);
+ }
+
+ struct IPerlDir perlDir =
+ {
+ PerlDirMakedir,
+ PerlDirChdir,
+ PerlDirRmdir,
+ PerlDirClose,
+ PerlDirOpen,
+ PerlDirRead,
+ PerlDirRewind,
+ PerlDirSeek,
+ PerlDirTell,
+ };
+
+ /* IPerlDir - Directory Manipulation functions - End ===================================*/
+
+ /* IPerlEnv - Environment related functions - Begin ======================================*/
+
+ char*
+ PerlEnvGetenv(struct IPerlEnv* piPerl, const char *varname)
+ {
+ return(getenv(varname));
+ };
+
+ int
+ PerlEnvPutenv(struct IPerlEnv* piPerl, const char *envstring)
+ {
+ return(putenv(envstring));
+ };
+
+ char*
+ PerlEnvGetenv_len(struct IPerlEnv* piPerl, const char* varname, unsigned long* len)
+ {
+ *len = 0;
+ char *e = getenv(varname);
+ if (e)
+ *len = strlen(e);
+ return e;
+ }
+
+ int
+ PerlEnvUname(struct IPerlEnv* piPerl, struct utsname *name)
+ {
+ return nw_uname(name);
+ }
+
+ void
+ PerlEnvClearenv(struct IPerlEnv* piPerl)
+ {
+
+ }
+
+ struct IPerlEnv perlEnv =
+ {
+ PerlEnvGetenv,
+ PerlEnvPutenv,
+ PerlEnvGetenv_len,
+ PerlEnvUname,
+ PerlEnvClearenv,
+ /* PerlEnvGetChildenv,
+ PerlEnvFreeChildenv,
+ PerlEnvGetChilddir,
+ PerlEnvFreeChilddir,*/
+ };
+
+ /* IPerlEnv - Environment related functions - End ======================================*/
+
+ /* IPerlStdio - Stdio functions - Begin ================================================*/
+
+ FILE*
+ PerlStdIOStdin(struct IPerlStdIO* piPerl)
+ {
+ return nw_stdin();
+ }
+
+ FILE*
+ PerlStdIOStdout(struct IPerlStdIO* piPerl)
+ {
+ return nw_stdout();
+ }
+
+ FILE*
+ PerlStdIOStderr(struct IPerlStdIO* piPerl)
+ {
+ return nw_stderr();
+ }
+
+ FILE*
+ PerlStdIOOpen(struct IPerlStdIO* piPerl, const char *path, const char *mode)
+ {
+ return nw_fopen(path, mode);
+ }
+
+ int
+ PerlStdIOClose(struct IPerlStdIO* piPerl, FILE* pf)
+ {
+ return nw_fclose(pf);
+ }
+
+ int
+ PerlStdIOEof(struct IPerlStdIO* piPerl, FILE* pf)
+ {
+ return nw_feof(pf);
+ }
+
+ int
+ PerlStdIOError(struct IPerlStdIO* piPerl, FILE* pf)
+ {
+ return nw_ferror(pf);
+ }
+
+ void
+ PerlStdIOClearerr(struct IPerlStdIO* piPerl, FILE* pf)
+ {
+ nw_clearerr(pf);
+ }
+
+ int
+ PerlStdIOGetc(struct IPerlStdIO* piPerl, FILE* pf)
+ {
+ return nw_getc(pf);
+ }
+
+ char*
+ PerlStdIOGetBase(struct IPerlStdIO* piPerl, FILE* pf)
+ {
+ #ifdef FILE_base
+ FILE *f = pf;
+ return FILE_base(f);
+ #else
+ return Nullch;
+ #endif
+ }
+
+ int
+ PerlStdIOGetBufsiz(struct IPerlStdIO* piPerl, FILE* pf)
+ {
+ #ifdef FILE_bufsiz
+ FILE *f = pf;
+ return FILE_bufsiz(f);
+ #else
+ return (-1);
+ #endif
+ }
+
+ int
+ PerlStdIOGetCnt(struct IPerlStdIO* piPerl, FILE* pf)
+ {
+ #ifdef USE_STDIO_PTR
+ FILE *f = pf;
+ return FILE_cnt(f);
+ #else
+ return (-1);
+ #endif
+ }
+
+ char*
+ PerlStdIOGetPtr(struct IPerlStdIO* piPerl, FILE* pf)
+ {
+ #ifdef USE_STDIO_PTR
+ FILE *f = pf;
+ return FILE_ptr(f);
+ #else
+ return Nullch;
+ #endif
+ }
+
+ char*
+ PerlStdIOGets(struct IPerlStdIO* piPerl, FILE* pf, char* s, int n)
+ {
+ return nw_fgets(s, n, pf);
+ }
+
+ int
+ PerlStdIOPutc(struct IPerlStdIO* piPerl, FILE* pf, int c)
+ {
+ return nw_fputc(c, pf);
+ }
+
+ int
+ PerlStdIOPuts(struct IPerlStdIO* piPerl, FILE* pf, const char *s)
+ {
+ return nw_fputs(s, pf);
+ }
+
+ int
+ PerlStdIOFlush(struct IPerlStdIO* piPerl, FILE* pf)
+ {
+ return nw_fflush(pf);
+ }
+
+ int
+ PerlStdIOUngetc(struct IPerlStdIO* piPerl, int c, FILE* pf)
+ {
+ return nw_ungetc(c, pf);
+ }
+
+ int
+ PerlStdIOFileno(struct IPerlStdIO* piPerl, FILE* pf)
+ {
+ return nw_fileno(pf);
+ }
+
+ FILE*
+ PerlStdIOFdopen(struct IPerlStdIO* piPerl, int fd, const char *mode)
+ {
+ return nw_fdopen(fd, mode);
+ }
+
+ FILE*
+ PerlStdIOReopen(struct IPerlStdIO* piPerl, const char*path, const char*mode, FILE* pf)
+ {
+ return nw_freopen(path, mode, pf);
+ }
+
+ SSize_t
+ PerlStdIORead(struct IPerlStdIO* piPerl, void *buffer, Size_t size, Size_t count, FILE* pf)
+ {
+ return nw_fread(buffer, size, count, pf);
+ }
+
+ SSize_t
+ PerlStdIOWrite(struct IPerlStdIO* piPerl, const void *buffer, Size_t size, Size_t count, FILE* pf)
+ {
+ return nw_fwrite(buffer, size, count, pf);
+ }
+
+ void
+ PerlStdIOSetBuf(struct IPerlStdIO* piPerl, FILE* pf, char* buffer)
+ {
+ nw_setbuf(pf, buffer);
+ }
+
+ int
+ PerlStdIOSetVBuf(struct IPerlStdIO* piPerl, FILE* pf, char* buffer, int type, Size_t size)
+ {
+ return nw_setvbuf(pf, buffer, type, size);
+ }
+
+ void
+ PerlStdIOSetCnt(struct IPerlStdIO* piPerl, FILE* pf, int n)
+ {
+ #ifdef STDIO_CNT_LVALUE
+ FILE *f = pf;
+ FILE_cnt(f) = n;
+ #endif
+ }
+
+ void
+ PerlStdIOSetPtr(struct IPerlStdIO* piPerl, FILE* pf, char * ptr)
+ {
+ #ifdef STDIO_PTR_LVALUE
+ FILE *f = pf;
+ FILE_ptr(f) = ptr;
+ #endif
+ }
+
+ void
+ PerlStdIOSetlinebuf(struct IPerlStdIO* piPerl, FILE* pf)
+ {
+ nw_setvbuf(pf, NULL, _IOLBF, 0);
+ }
+
+ int
+ PerlStdIOPrintf(struct IPerlStdIO* piPerl, FILE* pf, const char *format,...)
+ {
+ va_list(arglist);
+ va_start(arglist, format);
+ return nw_vfprintf(pf, format, arglist);
+ }
+
+ int
+ PerlStdIOVprintf(struct IPerlStdIO* piPerl, FILE* pf, const char *format, va_list arglist)
+ {
+ return nw_vfprintf(pf, format, arglist);
+ }
+
+ long
+ PerlStdIOTell(struct IPerlStdIO* piPerl, FILE* pf)
+ {
+ return nw_ftell(pf);
+ }
+
+ int
+ PerlStdIOSeek(struct IPerlStdIO* piPerl, FILE* pf, off_t offset, int origin)
+ {
+ return nw_fseek(pf, offset, origin);
+ }
+
+ void
+ PerlStdIORewind(struct IPerlStdIO* piPerl, FILE* pf)
+ {
+ nw_rewind(pf);
+ }
+
+ FILE*
+ PerlStdIOTmpfile(struct IPerlStdIO* piPerl)
+ {
+ return nw_tmpfile();
+ }
+
+ int
+ PerlStdIOGetpos(struct IPerlStdIO* piPerl, FILE* pf, Fpos_t *p)
+ {
+ return nw_fgetpos(pf, p);
+ }
+
+ int
+ PerlStdIOSetpos(struct IPerlStdIO* piPerl, FILE* pf, const Fpos_t *p)
+ {
+ return nw_fsetpos(pf, p);
+ }
+
+ void
+ PerlStdIOInit(struct IPerlStdIO* piPerl)
+ {
+ }
+
+ void
+ PerlStdIOInitOSExtras(struct IPerlStdIO* piPerl)
+ {
+ Perl_init_os_extras();
+ }
+
+
+ int
+ PerlStdIOOpenOSfhandle(struct IPerlStdIO* piPerl, long osfhandle, int flags)
+ {
+ return nw_open_osfhandle(osfhandle, flags);
+ }
+
+ int
+ PerlStdIOGetOSfhandle(struct IPerlStdIO* piPerl, int filenum)
+ {
+ return nw_get_osfhandle(filenum);
+ }
+
+ FILE*
+ PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf)
+ {
+ FILE* pfdup=NULL;
+ fpos_t pos=0;
+ char mode[3]={'\0'};
+ int fileno = nw_dup(nw_fileno(pf));
+
+ /* open the file in the same mode */
+ if(((FILE*)pf)->_flag & _IOREAD) {
+ mode[0] = 'r';
+ mode[1] = 0;
+ }
+ else if(((FILE*)pf)->_flag & _IOWRT) {
+ mode[0] = 'a';
+ mode[1] = 0;
+ }
+ else if(((FILE*)pf)->_flag & _IORW) {
+ mode[0] = 'r';
+ mode[1] = '+';
+ mode[2] = 0;
+ }
+
+ /* it appears that the binmode is attached to the
+ * file descriptor so binmode files will be handled
+ * correctly
+ */
+ pfdup = nw_fdopen(fileno, mode);
+
+ /* move the file pointer to the same position */
+ if (!fgetpos(pf, &pos)) {
+ fsetpos(pfdup, &pos);
+ }
+ return pfdup;
+ }
+
+ struct IPerlStdIO perlStdIO =
+ {
+ PerlStdIOStdin,
+ PerlStdIOStdout,
+ PerlStdIOStderr,
+ PerlStdIOOpen,
+ PerlStdIOClose,
+ PerlStdIOEof,
+ PerlStdIOError,
+ PerlStdIOClearerr,
+ PerlStdIOGetc,
+ PerlStdIOGetBase,
+ PerlStdIOGetBufsiz,
+ PerlStdIOGetCnt,
+ PerlStdIOGetPtr,
+ PerlStdIOGets,
+ PerlStdIOPutc,
+ PerlStdIOPuts,
+ PerlStdIOFlush,
+ PerlStdIOUngetc,
+ PerlStdIOFileno,
+ PerlStdIOFdopen,
+ PerlStdIOReopen,
+ PerlStdIORead,
+ PerlStdIOWrite,
+ PerlStdIOSetBuf,
+ PerlStdIOSetVBuf,
+ PerlStdIOSetCnt,
+ PerlStdIOSetPtr,
+ PerlStdIOSetlinebuf,
+ PerlStdIOPrintf,
+ PerlStdIOVprintf,
+ PerlStdIOTell,
+ PerlStdIOSeek,
+ PerlStdIORewind,
+ PerlStdIOTmpfile,
+ PerlStdIOGetpos,
+ PerlStdIOSetpos,
+ PerlStdIOInit,
+ PerlStdIOInitOSExtras,
+ PerlStdIOFdupopen,
+ };
+
+ /* IPerlStdio - Stdio functions - End ================================================*/
+
+ /* IPerlLIO - Low-level IO functions - Begin =============================================*/
+
+ int
+ PerlLIOAccess(struct IPerlLIO* piPerl, const char *path, int mode)
+ {
+ return nw_access(path, mode);
+ }
+
+ int
+ PerlLIOChmod(struct IPerlLIO* piPerl, const char *filename, int pmode)
+ {
+ return nw_chmod(filename, pmode);
+ }
+
+ int
+ PerlLIOChown(struct IPerlLIO* piPerl, const char *filename, uid_t owner, gid_t group)
+ {
+ dTHXo;
+ Perl_croak(aTHX_ "chown not implemented!\n");
+ return 0;
+ }
+
+ int
+ PerlLIOChsize(struct IPerlLIO* piPerl, int handle, long size)
+ {
+ return (nw_chsize(handle,size));
+ }
+
+ int
+ PerlLIOClose(struct IPerlLIO* piPerl, int handle)
+ {
+ return nw_close(handle);
+ }
+
+ int
+ PerlLIODup(struct IPerlLIO* piPerl, int handle)
+ {
+ return nw_dup(handle);
+ }
+
+ int
+ PerlLIODup2(struct IPerlLIO* piPerl, int handle1, int handle2)
+ {
+ return nw_dup2(handle1, handle2);
+ }
+
+ int
+ PerlLIOFlock(struct IPerlLIO* piPerl, int fd, int oper)
+ {
+ //On NetWare simulate flock by locking a range on the file
+ return nw_flock(fd, oper);
+ }
+
+ int
+ PerlLIOFileStat(struct IPerlLIO* piPerl, int handle, struct stat *buffer)
+ {
+ return fstat(handle, buffer);
+ }
+
+ int
+ PerlLIOIOCtl(struct IPerlLIO* piPerl, int i, unsigned int u, char *data)
+ {
+ return 0;
+ }
+
+ int
+ PerlLIOIsatty(struct IPerlLIO* piPerl, int fd)
+ {
+ return nw_isatty(fd);
+ }
+
+ int
+ PerlLIOLink(struct IPerlLIO* piPerl, const char*oldname, const char *newname)
+ {
+ return nw_link(oldname, newname);
+ }
+
+ long
+ PerlLIOLseek(struct IPerlLIO* piPerl, int handle, long offset, int origin)
+ {
+ return nw_lseek(handle, offset, origin);
+ }
+
+ int
+ PerlLIOLstat(struct IPerlLIO* piPerl, const char *path, struct stat *buffer)
+ {
+ return nw_stat(path, buffer);
+ }
+
+ char*
+ PerlLIOMktemp(struct IPerlLIO* piPerl, char *Template)
+ {
+ return(nw_mktemp(Template));
+ }
+
+ int
+ PerlLIOOpen(struct IPerlLIO* piPerl, const char *filename, int oflag)
+ {
+ return nw_open(filename, oflag);
+ }
+
+ int
+ PerlLIOOpen3(struct IPerlLIO* piPerl, const char *filename, int oflag, int pmode)
+ {
+ return nw_open(filename, oflag, pmode);
+ }
+
+ int
+ PerlLIORead(struct IPerlLIO* piPerl, int handle, void *buffer, unsigned int count)
+ {
+ return nw_read(handle, buffer, count);
+ }
+
+ int
+ PerlLIORename(struct IPerlLIO* piPerl, const char *OldFileName, const char *newname)
+ {
+ return nw_rename(OldFileName, newname);
+ }
+
+ int
+ PerlLIOSetmode(struct IPerlLIO* piPerl, FILE *fp, int mode)
+ {
+ return nw_setmode(fp, mode);
+ }
+
+ int
+ PerlLIONameStat(struct IPerlLIO* piPerl, const char *path, struct stat *buffer)
+ {
+ return nw_stat(path, buffer);
+ }
+
+ char*
+ PerlLIOTmpnam(struct IPerlLIO* piPerl, char *string)
+ {
+ return tmpnam(string);
+ }
+
+ int
+ PerlLIOUmask(struct IPerlLIO* piPerl, int pmode)
+ {
+ return umask(pmode);
+ }
+
+ int
+ PerlLIOUnlink(struct IPerlLIO* piPerl, const char *filename)
+ {
+ return nw_unlink(filename);
+ }
+
+ int
+ PerlLIOUtime(struct IPerlLIO* piPerl, char *filename, struct utimbuf *times)
+ {
+ return nw_utime(filename, times);
+ }
+
+ int
+ PerlLIOWrite(struct IPerlLIO* piPerl, int handle, const void *buffer, unsigned int count)
+ {
+ return nw_write(handle, buffer, count);
+ }
+
+ struct IPerlLIO perlLIO =
+ {
+ PerlLIOAccess,
+ PerlLIOChmod,
+ PerlLIOChown,
+ PerlLIOChsize,
+ PerlLIOClose,
+ PerlLIODup,
+ PerlLIODup2,
+ PerlLIOFlock,
+ PerlLIOFileStat,
+ PerlLIOIOCtl,
+ PerlLIOIsatty,
+ PerlLIOLink,
+ PerlLIOLseek,
+ PerlLIOLstat,
+ PerlLIOMktemp,
+ PerlLIOOpen,
+ PerlLIOOpen3,
+ PerlLIORead,
+ PerlLIORename,
+ PerlLIOSetmode,
+ PerlLIONameStat,
+ PerlLIOTmpnam,
+ PerlLIOUmask,
+ PerlLIOUnlink,
+ PerlLIOUtime,
+ PerlLIOWrite,
+ };
+
+ /* IPerlLIO - Low-level IO functions - End =============================================*/
+
+ /* IPerlProc - Process control functions - Begin =========================================*/
+
+ #define EXECF_EXEC 1
+ #define EXECF_SPAWN 2
+
+ void
+ PerlProcAbort(struct IPerlProc* piPerl)
+ {
+ nw_abort();
+ }
+
+ char *
+ PerlProcCrypt(struct IPerlProc* piPerl, const char* clear, const char* salt)
+ {
+ return nw_crypt(clear, salt);
+ }
+
+ void
+ PerlProcExit(struct IPerlProc* piPerl, int status)
+ {
+ // exit(status);
+ dTHX;
+ dJMPENV;
+ JMPENV_JUMP(2);
+ }
+
+ void
+ PerlProc_Exit(struct IPerlProc* piPerl, int status)
+ {
+ // _exit(status);
+ dTHX;
+ dJMPENV;
+ JMPENV_JUMP(2);
+ }
+
+ int
+ PerlProcExecl(struct IPerlProc* piPerl, const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3)
+ {
+ dTHXo;
+ Perl_croak(aTHX_ "execl not implemented!\n");
+ return 0;
+ }
+
+ int
+ PerlProcExecv(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv)
+ {
+ return nw_execvp((char *)cmdname, (char **)argv);
+ }
+
+ int
+ PerlProcExecvp(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv)
+ {
+ return nw_execvp((char *)cmdname, (char **)argv);
+ }
+
+ uid_t
+ PerlProcGetuid(struct IPerlProc* piPerl)
+ {
+ return 0;
+ }
+
+ uid_t
+ PerlProcGeteuid(struct IPerlProc* piPerl)
+ {
+ return 0;
+ }
+
+ gid_t
+ PerlProcGetgid(struct IPerlProc* piPerl)
+ {
+ return 0;
+ }
+
+ gid_t
+ PerlProcGetegid(struct IPerlProc* piPerl)
+ {
+ return 0;
+ }
+
+ char *
+ PerlProcGetlogin(struct IPerlProc* piPerl)
+ {
+ return NULL;
+ }
+
+ int
+ PerlProcKill(struct IPerlProc* piPerl, int pid, int sig)
+ {
+ return nw_kill(pid, sig);
+ }
+
+ int
+ PerlProcKillpg(struct IPerlProc* piPerl, int pid, int sig)
+ {
+ dTHXo;
+ Perl_croak(aTHX_ "killpg not implemented!\n");
+ return 0;
+ }
+
+ int
+ PerlProcPauseProc(struct IPerlProc* piPerl)
+ {
+ return nw_sleep((32767L << 16) + 32767);
+ }
+
+ PerlIO*
+ PerlProcPopen(struct IPerlProc* piPerl, const char *command, const char *mode)
+ {
+ dTHXo;
+ PERL_FLUSHALL_FOR_CHILD;
+
+ return (PerlIO*)nw_Popen((char *)command, (char *)mode, (int *)errno);
+ }
+
+ int
+ PerlProcPclose(struct IPerlProc* piPerl, PerlIO *stream)
+ {
+ return nw_Pclose((FILE*)stream, (int *)errno);
+ }
+
+ int
+ PerlProcPipe(struct IPerlProc* piPerl, int *phandles)
+ {
+ return nw_Pipe((int *)phandles, (int *)errno);
+ }
+
+ int
+ PerlProcSetuid(struct IPerlProc* piPerl, uid_t u)
+ {
+ return 0;
+ }
+
+ int
+ PerlProcSetgid(struct IPerlProc* piPerl, gid_t g)
+ {
+ return 0;
+ }
+
+ int
+ PerlProcSleep(struct IPerlProc* piPerl, unsigned int s)
+ {
+ return nw_sleep(s);
+ }
+
+ int
+ PerlProcTimes(struct IPerlProc* piPerl, struct tms *timebuf)
+ {
+ return nw_times(timebuf);
+ }
+
+ int
+ PerlProcWait(struct IPerlProc* piPerl, int *status)
+ {
+ return nw_wait(status);
+ }
+
+ int
+ PerlProcWaitpid(struct IPerlProc* piPerl, int pid, int *status, int flags)
+ {
+ return nw_waitpid(pid, status, flags);
+ }
+
+ Sighandler_t
+ PerlProcSignal(struct IPerlProc* piPerl, int sig, Sighandler_t subcode)
+ {
+ return 0;
+ }
+
+ int
+ PerlProcFork(struct IPerlProc* piPerl)
+ {
+ return 0;
+ }
+
+ int
+ PerlProcGetpid(struct IPerlProc* piPerl)
+ {
+ return nw_getpid();
+ }
+
+ /*BOOL
+ PerlProcDoCmd(struct IPerlProc* piPerl, char *cmd)
+ {
+ do_spawn2(cmd, EXECF_EXEC);
+ return FALSE;
+ }*/
+
+ int
+ PerlProcSpawn(struct IPerlProc* piPerl, char* cmds)
+ {
+ return do_spawn2(cmds, EXECF_SPAWN);
+ }
+
+ int
+ PerlProcSpawnvp(struct IPerlProc* piPerl, int mode, const char *cmdname, const char *const *argv)
+ {
+ return nw_spawnvp(mode, (char *)cmdname, (char **)argv);
+ }
+
+ int
+ PerlProcASpawn(struct IPerlProc* piPerl, void *vreally, void **vmark, void **vsp)
+ {
+ return do_aspawn(vreally, vmark, vsp);
+ }
+
+ struct IPerlProc perlProc =
+ {
+ PerlProcAbort,
+ PerlProcCrypt,
+ PerlProcExit,
+ PerlProc_Exit,
+ PerlProcExecl,
+ PerlProcExecv,
+ PerlProcExecvp,
+ PerlProcGetuid,
+ PerlProcGeteuid,
+ PerlProcGetgid,
+ PerlProcGetegid,
+ PerlProcGetlogin,
+ PerlProcKill,
+ PerlProcKillpg,
+ PerlProcPauseProc,
+ PerlProcPopen,
+ PerlProcPclose,
+ PerlProcPipe,
+ PerlProcSetuid,
+ PerlProcSetgid,
+ PerlProcSleep,
+ PerlProcTimes,
+ PerlProcWait,
+ PerlProcWaitpid,
+ PerlProcSignal,
+ PerlProcFork,
+ PerlProcGetpid,
+ //PerlProcLastHost;
+ //PerlProcPopenList;
+ };
+
+ /* IPerlProc - Process control functions - End =========================================*/
+
+ /* IPerlSock - Socket functions - Begin ==================================================*/
+
+ u_long
+ PerlSockHtonl(struct IPerlSock* piPerl, u_long hostlong)
+ {
+ return(nw_htonl(hostlong));
+ }
+
+ u_short
+ PerlSockHtons(struct IPerlSock* piPerl, u_short hostshort)
+ {
+ return(nw_htons(hostshort));
+ }
+
+ u_long
+ PerlSockNtohl(struct IPerlSock* piPerl, u_long netlong)
+ {
+ return nw_ntohl(netlong);
+ }
+
+ u_short
+ PerlSockNtohs(struct IPerlSock* piPerl, u_short netshort)
+ {
+ return nw_ntohs(netshort);
+ }
+
+ SOCKET PerlSockAccept(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* addr, int* addrlen)
+ {
+ return nw_accept(s, addr, addrlen);
+ }
+
+ int
+ PerlSockBind(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen)
+ {
+ return nw_bind(s, name, namelen);
+ }
+
+ int
+ PerlSockConnect(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen)
+ {
+ return nw_connect(s, name, namelen);
+ }
+
+ void
+ PerlSockEndhostent(struct IPerlSock* piPerl)
+ {
+ nw_endhostent();
+ }
+
+ void
+ PerlSockEndnetent(struct IPerlSock* piPerl)
+ {
+ nw_endnetent();
+ }
+
+ void
+ PerlSockEndprotoent(struct IPerlSock* piPerl)
+ {
+ nw_endprotoent();
+ }
+
+ void
+ PerlSockEndservent(struct IPerlSock* piPerl)
+ {
+ nw_endservent();
+ }
+
+ struct hostent*
+ PerlSockGethostbyaddr(struct IPerlSock* piPerl, const char* addr, int len, int type)
+ {
+ return(nw_gethostbyaddr(addr,len,type));
+ }
+
+ struct hostent*
+ PerlSockGethostbyname(struct IPerlSock* piPerl, const char* name)
+ {
+ return nw_gethostbyname(name);
+ }
+
+ struct hostent*
+ PerlSockGethostent(struct IPerlSock* piPerl)
+ {
+ return(nw_gethostent());
+ }
+
+ int
+ PerlSockGethostname(struct IPerlSock* piPerl, char* name, int namelen)
+ {
+ return nw_gethostname(name,namelen);
+ }
+
+ struct netent *
+ PerlSockGetnetbyaddr(struct IPerlSock* piPerl, long net, int type)
+ {
+ return nw_getnetbyaddr(net, type);
+ }
+
+ struct netent *
+ PerlSockGetnetbyname(struct IPerlSock* piPerl, const char *name)
+ {
+ return nw_getnetbyname((char*)name);
+ }
+
+ struct netent *
+ PerlSockGetnetent(struct IPerlSock* piPerl)
+ {
+ return nw_getnetent();
+ }
+
+ int PerlSockGetpeername(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen)
+ {
+ return nw_getpeername(s, name, namelen);
+ }
+
+ struct protoent*
+ PerlSockGetprotobyname(struct IPerlSock* piPerl, const char* name)
+ {
+ return nw_getprotobyname(name);
+ }
+
+ struct protoent*
+ PerlSockGetprotobynumber(struct IPerlSock* piPerl, int number)
+ {
+ return nw_getprotobynumber(number);
+ }
+
+ struct protoent*
+ PerlSockGetprotoent(struct IPerlSock* piPerl)
+ {
+ return nw_getprotoent();
+ }
+
+ struct servent*
+ PerlSockGetservbyname(struct IPerlSock* piPerl, const char* name, const char* proto)
+ {
+ return nw_getservbyname((char*)name, (char*)proto);
+ }
+
+ struct servent*
+ PerlSockGetservbyport(struct IPerlSock* piPerl, int port, const char* proto)
+ {
+ return nw_getservbyport(port, proto);
+ }
+
+ struct servent*
+ PerlSockGetservent(struct IPerlSock* piPerl)
+ {
+ return nw_getservent();
+ }
+
+ int
+ PerlSockGetsockname(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen)
+ {
+ return nw_getsockname(s, name, namelen);
+ }
+
+ int
+ PerlSockGetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, char* optval, int* optlen)
+ {
+ return nw_getsockopt(s, level, optname, optval, optlen);
+ }
+
+ unsigned long
+ PerlSockInetAddr(struct IPerlSock* piPerl, const char* cp)
+ {
+ return(nw_inet_addr(cp));
+ }
+
+ char*
+ PerlSockInetNtoa(struct IPerlSock* piPerl, struct in_addr in)
+ {
+ return NULL;
+ }
+
+ int
+ PerlSockListen(struct IPerlSock* piPerl, SOCKET s, int backlog)
+ {
+ return (nw_listen(s, backlog));
+ }
+
+ int
+ PerlSockRecv(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags)
+ {
+ return (nw_recv(s, buffer, len, flags));
+ }
+
+ int
+ PerlSockRecvfrom(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags, struct sockaddr* from, int* fromlen)
+ {
+ return nw_recvfrom(s, buffer, len, flags, from, fromlen);
+ }
+
+ int
+ PerlSockSelect(struct IPerlSock* piPerl, int nfds, char* readfds, char* writefds, char* exceptfds, const struct timeval* timeout)
+ {
+ return nw_select(nfds, (fd_set*) readfds, (fd_set*) writefds, (fd_set*) exceptfds, timeout);
+ }
+
+ int
+ PerlSockSend(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags)
+ {
+ return (nw_send(s, buffer, len, flags));
+ }
+
+ int
+ PerlSockSendto(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags, const struct sockaddr* to, int tolen)
+ {
+ return(nw_sendto(s, buffer, len, flags, to, tolen));
+ }
+
+ void
+ PerlSockSethostent(struct IPerlSock* piPerl, int stayopen)
+ {
+ nw_sethostent(stayopen);
+ }
+
+ void
+ PerlSockSetnetent(struct IPerlSock* piPerl, int stayopen)
+ {
+ nw_setnetent(stayopen);
+ }
+
+ void
+ PerlSockSetprotoent(struct IPerlSock* piPerl, int stayopen)
+ {
+ nw_setprotoent(stayopen);
+ }
+
+ void
+ PerlSockSetservent(struct IPerlSock* piPerl, int stayopen)
+ {
+ nw_setservent(stayopen);
+ }
+
+ int
+ PerlSockSetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, const char* optval, int optlen)
+ {
+ dTHXo;
+ Perl_croak(aTHX_ "setsockopt not implemented!\n");
+ return 0;
+ }
+
+ int
+ PerlSockShutdown(struct IPerlSock* piPerl, SOCKET s, int how)
+ {
+ return nw_shutdown(s, how);
+ }
+
+ SOCKET
+ PerlSockSocket(struct IPerlSock* piPerl, int af, int type, int protocol)
+ {
+ return nw_socket(af, type, protocol);
+ }
+
+ int
+ PerlSockSocketpair(struct IPerlSock* piPerl, int domain, int type, int protocol, int* fds)
+ {
+ dTHXo;
+ Perl_croak(aTHX_ "socketpair not implemented!\n");
+ return 0;
+ }
+
+ int
+ PerlSockIoctlsocket(struct IPerlSock* piPerl, SOCKET s, long cmd, u_long *argp)
+ {
+ dTHXo;
+ Perl_croak(aTHX_ "ioctlsocket not implemented!\n");
+ return 0;
+ }
+
+ struct IPerlSock perlSock =
+ {
+ PerlSockHtonl,
+ PerlSockHtons,
+ PerlSockNtohl,
+ PerlSockNtohs,
+ PerlSockAccept,
+ PerlSockBind,
+ PerlSockConnect,
+ PerlSockEndhostent,
+ PerlSockEndnetent,
+ PerlSockEndprotoent,
+ PerlSockEndservent,
+ PerlSockGethostname,
+ PerlSockGetpeername,
+ PerlSockGethostbyaddr,
+ PerlSockGethostbyname,
+ PerlSockGethostent,
+ PerlSockGetnetbyaddr,
+ PerlSockGetnetbyname,
+ PerlSockGetnetent,
+ PerlSockGetprotobyname,
+ PerlSockGetprotobynumber,
+ PerlSockGetprotoent,
+ PerlSockGetservbyname,
+ PerlSockGetservbyport,
+ PerlSockGetservent,
+ PerlSockGetsockname,
+ PerlSockGetsockopt,
+ PerlSockInetAddr,
+ PerlSockInetNtoa,
+ PerlSockListen,
+ PerlSockRecv,
+ PerlSockRecvfrom,
+ PerlSockSelect,
+ PerlSockSend,
+ PerlSockSendto,
+ PerlSockSethostent,
+ PerlSockSetnetent,
+ PerlSockSetprotoent,
+ PerlSockSetservent,
+ PerlSockSetsockopt,
+ PerlSockShutdown,
+ PerlSockSocket,
+ PerlSockSocketpair,
+ };
+
+ /* IPerlSock - Socket functions - End ==================================================*/
+
+ #endif /* ___NWPerlSys_H___ */
diff -c /dev/null 'perl-5.7.2/NetWare/nwpipe.h'
Index: ./NetWare/nwpipe.h
*** ./NetWare/nwpipe.h Thu Jan 1 02:00:00 1970
--- ./NetWare/nwpipe.h Mon Jul 9 17:09:41 2001
***************
*** 0 ****
--- 1,62 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : NWPipe.h
+ * DESCRIPTION : Functions to implement pipes on NetWare.
+ * Author : HYAK
+ * Date : January 2001.
+ *
+ */
+
+
+
+ #ifndef __NWPipe_H__
+ #define __NWPipe_H__
+
+
+ #include "stdio.h"
+ #include "nwutil.h"
+
+ #define MAX_PIPE_RECURSION 256
+
+
+ typedef struct tagTempPipeFile
+ {
+ BOOL m_mode; // FALSE - Read mode ; TRUE - Write mode
+ BOOL m_launchPerl;
+ BOOL m_doPerlGlob;
+
+ int m_argv_len;
+
+ char * m_fileName;
+ char** m_argv;
+ char * m_redirect;
+
+ #ifdef MPK_ON
+ SEMAPHORE m_perlSynchSemaphore;
+ #else
+ long m_perlSynchSemaphore;
+ #endif
+
+ FILE* m_file;
+ PCOMMANDLINEPARSER m_pipeCommand;
+
+ } TEMPPIPEFILE, *PTEMPPIPEFILE;
+
+
+ void fnPipeFileClose(PTEMPPIPEFILE ptpf);
+ void fnPipeFileDoPerlLaunch(PTEMPPIPEFILE ptpf);
+ BOOL fnPipeFileMakeArgv(PTEMPPIPEFILE ptpf);
+ FILE* fnPipeFileOpen(PTEMPPIPEFILE ptpf, char* command, char* mode);
+ void fnTempPipeFileReleaseMemory(PTEMPPIPEFILE ptpf);
+
+
+ #endif // __NWPipe_H__
+
diff -c /dev/null 'perl-5.7.2/NetWare/nwplglob.c'
Index: ./NetWare/nwplglob.c
*** ./NetWare/nwplglob.c Thu Jan 1 02:00:00 1970
--- ./NetWare/nwplglob.c Mon Jul 9 17:09:41 2001
***************
*** 0 ****
--- 1,90 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : nwplglob.c
+ * DESCRIPTION : Perl globbing support for NetWare. Other platforms have usually lauched
+ * a separate executable for this in order to take advantage of their
+ * shell's capability for generating a list of files from a given
+ * wildcard file spec. On NetWare, we don't have that luxury.
+ * So we just hack the support into pipe open support (which we also had to hack).
+ * Author : HYAK
+ * Date : January 2001.
+ *
+ */
+
+
+
+ #include <nwtypes.h>
+ #include "stdio.h"
+ #include <dirent.h>
+
+ #include "win32ish.h"
+ #include "nwplglob.h"
+
+
+
+ /*============================================================================================
+
+ Function : fnDoPerlGlob
+
+ Description : Perl globbing support: Takes an array of wildcard descriptors
+ and produces from it a list of files that the wildcards expand into.
+ The list of files is written to the temporary file named by fileName.
+
+ Parameters : argv (IN) - Input argument vector.
+ fileName (IN) - Input file name for storing globed file names.
+
+ Returns : Nothing.
+
+ ==============================================================================================*/
+
+ void fnDoPerlGlob(char** argv, char* fileName)
+ {
+ FILE * redirOut = NULL;
+
+ if (*argv)
+ argv++;
+ if (*argv == NULL)
+ return;
+
+ redirOut = fopen((const char *)fileName, (const char *)"w");
+ if (!redirOut)
+ return;
+
+ do
+ {
+ DIR* dir = NULL;
+ DIR* fil = NULL;
+ char* pattern = NULL;
+
+ pattern = *argv++;
+
+ dir = opendir((const char *)pattern);
+ if (!dir)
+ continue;
+
+ /* find the last separator in pattern, NetWare has three: /\: */
+ while (fil = readdir(dir))
+ {
+ // The below displays the files separated by tab character.
+ // Also, it displays only the file names and not directories.
+ // If any other format is desired, it needs to be done here.
+ fprintf(redirOut, "%s\t", fil->d_name);
+ }
+
+ closedir(dir);
+
+ } while (*argv);
+
+ fclose(redirOut);
+
+ return;
+ }
+
diff -c /dev/null 'perl-5.7.2/NetWare/nwplglob.h'
Index: ./NetWare/nwplglob.h
*** ./NetWare/nwplglob.h Thu Jan 1 02:00:00 1970
--- ./NetWare/nwplglob.h Mon Jul 9 17:09:41 2001
***************
*** 0 ****
--- 1,27 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : nwplglob.h
+ * DESCRIPTION : Perl globbing support for NetWare.
+ * Author : HYAK
+ * Date : January 2001.
+ *
+ */
+
+
+ #ifndef __NWplGlob_H__
+ #define __NWplGlob_H__
+
+
+ void fnDoPerlGlob(char** argv, char* fileName);
+
+
+ #endif // __NWplGlob_H__
+
diff -c /dev/null 'perl-5.7.2/NetWare/nwstdio.h'
Index: ./NetWare/nwstdio.h
*** ./NetWare/nwstdio.h Thu Jan 1 02:00:00 1970
--- ./NetWare/nwstdio.h Mon Jul 9 17:09:41 2001
***************
*** 0 ****
--- 1,122 ----
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : nwstdio.h
+ * DESCRIPTION : Making stdio calls go thro' the
+ * NetWare specific implementation.
+ * This gets included if PERLIO_IS_STDIO. Instead
+ * of directly calling stdio functions this goes
+ * thro' IPerlStdIO, this ensures that cgi2perl
+ * can call CGI functions and send the o/p to
+ * browser or console.
+ * Author : SGP
+ * Date Created : June 29th 2001.
+ * Date Modified: June 30th 2001.
+ */
+
+ #ifndef ___NWStdio_H___
+ #define ___NWStdio_H___
+
+ #define PerlIO FILE
+
+ #define PerlIO_putc(f,c) (*PL_StdIO->pPutc)(PL_StdIO, (f),(c))
+ #define PerlIO_fileno(f) (*PL_StdIO->pFileno)(PL_StdIO, (f))
+ #define PerlIO_close(f) (*PL_StdIO->pClose)(PL_StdIO, (f))
+ #define PerlIO_stderr() (*PL_StdIO->pStderr)(PL_StdIO)
+ #define PerlIO_printf Perl_fprintf_nocontext
+ #define PerlIO_vprintf(f,fmt,a) (*PL_StdIO->pVprintf)(PL_StdIO, (f),(fmt),a)
+ #define PerlIO_flush(f) (*PL_StdIO->pFlush)(PL_StdIO, (f))
+ #define PerlIO_stdout() (*PL_StdIO->pStdout)(PL_StdIO)
+ #define PerlIO_stdin() (*PL_StdIO->pStdin)(PL_StdIO)
+ #define PerlIO_clearerr(f) (*PL_StdIO->pClearerr)(PL_StdIO, (f))
+ #define PerlIO_fdopen(f,s) (*PL_StdIO->pFdopen)(PL_StdIO, (f),(s))
+ #define PerlIO_getc(f) (*PL_StdIO->pGetc)(PL_StdIO, (f))
+ #define PerlIO_ungetc(f,c) (*PL_StdIO->pUngetc)(PL_StdIO, (c),(f))
+ #define PerlIO_tell(f) (*PL_StdIO->pTell)(PL_StdIO, (f))
+ #define PerlIO_seek(f,o,w) (*PL_StdIO->pSeek)(PL_StdIO, (f),(o),(w))
+ #define PerlIO_error(f) (*PL_StdIO->pError)(PL_StdIO, (f))
+ #define PerlIO_write(f,buf,size) (*PL_StdIO->pWrite)(PL_StdIO, (buf), (size),1, (f))
+ #define PerlIO_puts(f,s) (*PL_StdIO->pPuts)(PL_StdIO, (f),(s))
+ #define PerlIO_read(f,buf,size) (*PL_StdIO->pRead)(PL_StdIO, (buf), (size), 1, (f))
+ #define PerlIO_eof(f) (*PL_StdIO->pEof)(PL_StdIO, (f))
+ #define PerlIO_fdupopen(f) (*PL_StdIO->pFdupopen)(PL_StdIO, (f))
+ #define PerlIO_reopen(p,m,f) (*PL_StdIO->pReopen)(PL_StdIO, (p), (m), (f))
+ #define PerlIO_open(x,y) (*PL_StdIO->pOpen)(PL_StdIO, (x),(y))
+
+ #ifdef HAS_SETLINEBUF
+ #define PerlIO_setlinebuf(f) (*PL_StdIO->pSetlinebuf)(PL_StdIO, (f))
+ #else
+ #define PerlIO_setlinebuf(f) setvbuf(f, Nullch, _IOLBF, 0)
+ #endif
+
+ #define PerlIO_isutf8(f) 0
+
+ #ifdef USE_STDIO_PTR
+ #define PerlIO_has_cntptr(f) 1
+ #define PerlIO_get_ptr(f) FILE_ptr(f)
+ #define PerlIO_get_cnt(f) FILE_cnt(f)
+
+ #ifdef STDIO_CNT_LVALUE
+ #define PerlIO_canset_cnt(f) 1
+ #define PerlIO_set_cnt(f,c) (FILE_cnt(f) = (c))
+ #ifdef STDIO_PTR_LVALUE
+ #ifdef STDIO_PTR_LVAL_NOCHANGE_CNT
+ #define PerlIO_fast_gets(f) 1
+ #endif
+ #endif /* STDIO_PTR_LVALUE */
+ #else /* STDIO_CNT_LVALUE */
+ #define PerlIO_canset_cnt(f) 0
+ #define PerlIO_set_cnt(f,c) abort()
+ #endif
+
+ #ifdef STDIO_PTR_LVALUE
+ #ifdef STDIO_PTR_LVAL_NOCHANGE_CNT
+ #define PerlIO_set_ptrcnt(f,p,c) STMT_START {FILE_ptr(f) = (p), PerlIO_set_cnt(f,c);} STMT_END
+ #else
+ #ifdef STDIO_PTR_LVAL_SETS_CNT
+ /* assert() may pre-process to ""; potential syntax error (FILE_ptr(), ) */
+ #define PerlIO_set_ptrcnt(f,p,c) STMT_START {FILE_ptr(f) = (p); assert(FILE_cnt(f) == (c));} STMT_END
+ #define PerlIO_fast_gets(f) 1
+ #else
+ #define PerlIO_set_ptrcnt(f,p,c) abort()
+ #endif
+ #endif
+ #endif
+
+ #else /* USE_STDIO_PTR */
+
+ #define PerlIO_has_cntptr(f) 0
+ #define PerlIO_canset_cnt(f) 0
+ #define PerlIO_get_cnt(f) (abort(),0)
+ #define PerlIO_get_ptr(f) (abort(),(void *)0)
+ #define PerlIO_set_cnt(f,c) abort()
+ #define PerlIO_set_ptrcnt(f,p,c) abort()
+
+ #endif /* USE_STDIO_PTR */
+
+ #ifndef PerlIO_fast_gets
+ #define PerlIO_fast_gets(f) 0
+ #endif
+
+ #ifdef FILE_base
+ #define PerlIO_has_base(f) 1
+ #define PerlIO_get_bufsiz(f) (*PL_StdIO->pGetBufsiz)(PL_StdIO, (f))
+ #define PerlIO_get_base(f) (*PL_StdIO->pGetBase)(PL_StdIO, (f))
+ #else
+ #define PerlIO_has_base(f) 0
+ #define PerlIO_get_base(f) (abort(),(void *)0)
+ #define PerlIO_get_bufsiz(f) (abort(),0)
+ #endif
+
+ #define PerlIO_importFILE(f,fl) (f)
+ #define PerlIO_exportFILE(f,fl) (f)
+ #define PerlIO_findFILE(f) (f)
+ #define PerlIO_releaseFILE(p,f) ((void) 0)
+
+ #endif /* ___NWStdio_H___ */
diff -c /dev/null 'perl-5.7.2/NetWare/nwtinfo.h'
Index: ./NetWare/nwtinfo.h
*** ./NetWare/nwtinfo.h Thu Jan 1 02:00:00 1970
--- ./NetWare/nwtinfo.h Mon Jul 9 17:09:42 2001
***************
*** 0 ****
--- 1,73 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : NWTInfo.h
+ * DESCRIPTION : Thread-local storage for Perl.
+ * Author : SGP, HYAK
+ * Date Created : January 2001.
+ * Date Modified: July 2nd 2001.
+ */
+
+
+
+ #ifndef __NWTInfo_H__
+ #define __NWTInfo_H__
+
+
+ #include "win32ish.h" // For "BOOL", "TRUE" and "FALSE"
+
+ typedef struct tagThreadInfo
+ {
+ int tid;
+ struct tagThreadInfo *next;
+ BOOL m_dontTouchHashLists;
+ void* m_allocList;
+ }ThreadInfo;
+
+ void fnInitializeThreadInfo(void);
+ BOOL fnTerminateThreadInfo(void);
+
+ ThreadInfo* fnAddThreadInfo(int tid);
+ BOOL fnRemoveThreadInfo(int tid);
+ ThreadInfo* fnGetThreadInfo(int tid);
+
+ #ifdef __cplusplus
+ //For storing and retrieving Watcom Hash list address
+ extern "C" BOOL fnInsertHashListAddrs(void *addrs, BOOL dontTouchHashList);
+ //Registering with the Thread table
+ extern "C" BOOL fnRegisterWithThreadTable(void);
+ extern "C" BOOL fnUnregisterWithThreadTable(void);
+ #else
+ //For storing and retrieving Watcom Hash list address
+ BOOL fnInsertHashListAddrs(void *addrs, BOOL dontTouchHashList);
+ //Registering with the Thread table
+ BOOL fnRegisterWithThreadTable(void);
+ BOOL fnUnregisterWithThreadTable(void);
+ #endif
+
+ BOOL fnGetHashListAddrs(void **addrs, BOOL *dontTouchHashList);
+
+ //New TLS to set and get the thread contex - may be redundant,
+ //or see if the above portion can be removed once this works properly
+ typedef struct tagThreadCtx
+ {
+ long tid;
+ void *tInfo;
+ struct tagThreadCtx *next;
+ }ThreadContext;
+
+
+ long fnInitializeThreadCtx(void);
+ ThreadContext* fnAddThreadCtx(long lTLSIndex, void *t);
+ BOOL fnRemoveThreadCtx(long lTLSIndex);
+ void* fnGetThreadCtx(long lTLSIndex);
+
+ #endif // __NWTInfo_H__
+
diff -c /dev/null 'perl-5.7.2/NetWare/nwutil.h'
Index: ./NetWare/nwutil.h
*** ./NetWare/nwutil.h Thu Jan 1 02:00:00 1970
--- ./NetWare/nwutil.h Mon Jul 9 17:09:42 2001
***************
*** 0 ****
--- 1,99 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : NWUtil.h
+ * DESCRIPTION : Utility functions for NetWare implementation of Perl.
+ * Author : HYAK, SGP
+ * Date : January 2001.
+ *
+ */
+
+
+
+ #ifndef __NWUtil_H__
+ #define __NWUtil_H__
+
+
+ #include "stdio.h"
+ #include <stdlib.h>
+ #include "win32ish.h" // For "BOOL", "TRUE" and "FALSE"
+
+
+ #ifdef MPK_ON
+ #include <mpktypes.h>
+ #include <mpkapis.h>
+ #else
+ #include <nwsemaph.h>
+ #endif //MPK_ON
+
+
+ // Name of console command to invoke perl
+ #define PERL_COMMAND_NAME "perl"
+
+ // Name of console command to load an NLM
+ #define LOAD_COMMAND "load"
+
+
+ typedef struct tagCommandLineParser
+ {
+ BOOL m_noScreen;
+ BOOL m_AutoDestroy;
+ BOOL m_isValid;
+
+ int m_argc;
+ int m_argv_len;
+
+ #ifdef MPK_ON
+ SEMAPHORE m_qSemaphore;
+ #else
+ long m_qSemaphore;
+ #endif
+
+ char* m_redirInName;
+ char* m_redirOutName;
+ char* m_redirErrName;
+ char* m_redirBothName;
+ char* nextarg;
+ char* sSkippedToken;
+
+ char** m_argv;
+ char** new_argv;
+
+ }COMMANDLINEPARSER, *PCOMMANDLINEPARSER;
+
+
+
+ char* fnSkipWhite(char* cptr);
+ char* fnNwGetEnvironmentStr(char *name, char *defaultvalue);
+ char* fnSkipToken(char *s, char *r);
+ char* fnScanToken(char* x, char *r);
+ char* fnStashString(char *s, char *r, int length);
+ void fnAppendArgument(PCOMMANDLINEPARSER pclp, char * new_arg);
+ void fnDeleteArgument(PCOMMANDLINEPARSER pclp, int index);
+ void fnCommandLineParser(PCOMMANDLINEPARSER pclp, char * commandLine, BOOL preserveQuotes);
+ void fnSystemCommand (char** argv, int argc);
+ void fnInternalPerlLaunchHandler(char* cmdLine);
+ char* fnMy_MkTemp(char* templatestr);
+
+
+ /* DEFPERLROOT:
+ * This symbol contains the name of the starting default directory to search
+ * for scripts to run.
+ */
+ #define DEFPERLROOT "sys:\\perl\\scripts"
+
+ /* DEFTEMP:
+ * This symbol contains the name of the default temp files directory.
+ */
+ #define DEFTEMP "sys:\\perl\\temp"
+
+
+ #endif // __NWUtil_H__
+
diff -c /dev/null 'perl-5.7.2/NetWare/t/NWModify.pl'
Index: ./NetWare/t/NWModify.pl
*** ./NetWare/t/NWModify.pl Thu Jan 1 02:00:00 1970
--- ./NetWare/t/NWModify.pl Mon Jul 9 17:09:42 2001
***************
*** 0 ****
--- 1,130 ----
+
+
+ print "\nModifying the '.t' files...\n\n";
+
+ use File::Basename;
+ use File::Copy;
+
+ ## Change the below line to the folder you want to process
+ $DirName = "/perl/scripts/t";
+
+ $FilesTotal = 0;
+ $FilesRead = 0;
+ $FilesModified = 0;
+
+ opendir(DIR, $DirName);
+ @Dirs = readdir(DIR);
+
+ foreach $DirItem(@Dirs)
+ {
+ $DirItem = $DirName."/".$DirItem;
+ push @DirNames, $DirItem; # All items under $DirName folder is copied into an array.
+ }
+
+ foreach $FileName(@DirNames)
+ {
+ if(-d $FileName)
+ { # If an item is a folder, then open it further.
+
+ opendir(SUBDIR, $FileName);
+ @SubDirs = readdir(SUBDIR);
+ close(SUBDIR);
+
+ foreach $SubFileName(@SubDirs)
+ {
+ if(-f $SubFileName)
+ {
+ &Process_File($SubFileName); # If file, process it.
+ }
+ else
+ {
+ $SubFileName = $FileName."/".$SubFileName;
+ push @DirNames, $SubFileName; # If sub-folder, push it into the array.
+ }
+ }
+ }
+ else
+ {
+ if(-f $FileName)
+ {
+ &Process_File($FileName); # If file, process it.
+ }
+ }
+ }
+
+ close(DIR);
+
+ print "\n\n\nTotal number of files present = $FilesTotal\n";
+ print "Total number of '.t' files read = $FilesRead\n";
+ print "Total number of '.t' files modified = $FilesModified\n\n";
+
+
+
+
+ # Process the file.
+ sub Process_File
+ {
+ local($FileToProcess) = @_; # File name.
+ local($Modified) = 0;
+
+ if(!(-w $FileToProcess)) {
+ # If the file is a read-only file, then change its mode to read-write.
+ chmod(0777, $FileToProcess);
+ }
+
+ ## For example:
+ ## If the value of $FileToProcess is '/perl/scripts/t/pragma/warnings.t', then
+ ## $dir = '/perl/scripts/t/pragma/'
+ ## $base = 'warnings'
+ ## $ext = '.t'
+ $dir = dirname($FileToProcess); # Get the folder name
+ $base = basename($FileToProcess); # Get the base name
+ ($base, $dir, $ext) = fileparse($FileToProcess, '\..*'); # Get the extension of the file passed.
+
+
+ # Do the processing only if the file has '.t' extension.
+ if($ext eq '.t') {
+
+ open(FH, "+< $FileToProcess") or die "Unable to open the file, $FileToProcess for reading and writing.\n";
+ @ARRAY = <FH>; # Get the contents of the file into an array.
+
+ flock(FH, LOCK_EX); # Lock the file for safety purposes.
+ foreach $Line(@ARRAY) # Get each line of the file.
+ {
+ if($Line =~ m/\@INC = /)
+ { # If the line contains the string (@INC = ), then replace it
+
+ # Replace "@INC = " with "unshift @INC, "
+ $Line =~ s/\@INC = /unshift \@INC, /;
+
+ $Modified = 1;
+ }
+
+ if($Line =~ m/push \@INC, /)
+ { # If the line contains the string (push @INC, ), then replace it
+
+ # Replace "push @INC, " with "unshift @INC, "
+ $Line =~ s/push \@INC, /unshift \@INC, /;
+
+ $Modified = 1;
+ }
+ }
+
+ seek(FH, 0, 0); # Seek to the beginning.
+ print FH @ARRAY; # Write the changed array into the file.
+ flock(FH, LOCK_UN); # unlock the file.
+ close FH; # close the file.
+
+ $FilesRead++; # One more file read.
+
+ if($Modified) {
+ print "Modified the file, $FileToProcess\n";
+ $Modified = 0;
+
+ $FilesModified++; # One more file modified.
+ }
+ }
+
+ $FilesTotal++; # One more file present.
+ }
+
diff -c /dev/null 'perl-5.7.2/NetWare/t/NWScripts.pl'
Index: ./NetWare/t/NWScripts.pl
*** ./NetWare/t/NWScripts.pl Thu Jan 1 02:00:00 1970
--- ./NetWare/t/NWScripts.pl Mon Jul 9 17:09:42 2001
***************
*** 0 ****
--- 1,249 ----
+
+
+ print "\nGenerating automated scripts for NetWare...\n\n\n";
+
+
+ use File::Basename;
+ use File::Copy;
+
+ chdir '/perl/scripts/';
+ $DirName = "t";
+
+ # These scripts have problems (either abend or hang) as of now (11 May 2001).
+ # So, they are commented out in the corresponding auto scripts, io.pl and lib.pl
+ @ScriptsNotUsed = ("t/io/argv.t", "t/io/openpid.t", "t/lib/filehandle.t", "t/lib/warnings.t");
+
+ opendir(DIR, $DirName);
+ @Dirs = readdir(DIR);
+ close(DIR);
+ foreach $DirItem(@Dirs)
+ {
+ $DirItem1 = $DirName."/".$DirItem;
+ push @DirNames, $DirItem1; # All items under $DirName folder is copied into an array.
+
+ if(-d $DirItem1)
+ { # If an item is a folder, then open it further.
+
+ # Intemediary automated script like base.pl, lib.pl, cmd.pl etc.
+ $IntAutoScript = "t/".$DirItem.".pl";
+
+ # Open once in write mode since later files are opened in append mode,
+ # and if there already exists a file with the same name, all further opens
+ # will append to that file!!
+ open(FHW, "> $IntAutoScript") or die "Unable to open the file, $IntAutoScript for writing.\n";
+ seek(FHW, 0, 0); # seek to the beginning of the file.
+ close FHW; # close the file.
+ }
+ }
+
+
+ print "Generating t/nwauto.pl ...\n\n\n";
+
+ open(FHWA, "> t/nwauto.pl") or die "Unable to open the file, t/nwauto.pl for writing.\n";
+ seek(FHWA, 0, 0); # seek to the beginning of the file.
+ flock(FHWA, LOCK_EX); # Lock the file for safety purposes.
+
+ $version = sprintf("%vd",$^V);
+ print FHWA "\n\nprint \"Automated Unit Testing of Perl$version for NetWare\\n\\n\\n\"\;\n\n\n";
+
+
+ foreach $FileName(@DirNames)
+ {
+ $index = 0;
+ if(-d $FileName)
+ { # If an item is a folder, then open it further.
+
+ $dir = dirname($FileName); # Get the folder name
+
+ foreach $DirItem1(@Dirs)
+ {
+ $DirItem2 = $DirItem1;
+ if($FileName =~ m/$DirItem2/)
+ {
+ $DirItem = $DirItem1;
+
+ # Intemediary automated script like base.pl, lib.pl, cmd.pl etc.
+ $IntAutoScript = "t/".$DirItem.".pl";
+ }
+ }
+
+ # Write into the intermediary auto script.
+ open(FHW, ">> $IntAutoScript") or die "Unable to open the file, $IntAutoScript for appending.\n";
+ seek(FHW, 0, 2); # seek to the end of the file.
+ flock(FHW, LOCK_EX); # Lock the file for safety purposes.
+
+ $pos = tell(FHW);
+ if($pos <= 0)
+ {
+ print "Generating $IntAutoScript...\n";
+ print FHW "\n\nprint \"Testing $DirItem folder:\\n\\n\\n\"\;\n\n\n";
+ }
+
+ opendir(SUBDIR, $FileName);
+ @SubDirs = readdir(SUBDIR);
+ close(SUBDIR);
+ foreach $SubFileName(@SubDirs)
+ {
+ $SubFileName = $FileName."/".$SubFileName;
+ if(-d $SubFileName)
+ {
+ push @DirNames, $SubFileName; # If sub-folder, push it into the array.
+ }
+ else
+ {
+ &Process_File($SubFileName); # If file, process it.
+ }
+
+ $index++;
+ }
+
+ flock(FHW, LOCK_UN); # unlock the file.
+ close FHW; # close the file.
+
+ if($index <= 0)
+ {
+ # The folder is empty and delete the corresponding '.pl' file.
+ unlink($IntAutoScript);
+ print "Deleted $IntAutoScript since it corresponded to an empty folder.\n";
+ }
+ else
+ {
+ if($pos <= 0)
+ { # This logic to make sure that it is written only once.
+ # Only if something is written into the intermediary auto script,
+ # only then make an entry of the intermediary auto script in nwauto.pl
+ print FHWA "print \`perl $IntAutoScript\`\;\n";
+ print FHWA "print \"\\n\\n\\n\"\;\n\n";
+ }
+ }
+ }
+ else
+ {
+ if(-f $FileName)
+ {
+ $dir = dirname($FileName); # Get the folder name
+ $base = basename($FileName); # Get the base name
+ ($base, $dir, $ext) = fileparse($FileName, '\..*'); # Get the extension of the file passed.
+
+ # Do the processing only if the file has '.t' extension.
+ if($ext eq '.t')
+ {
+ print FHWA "print \`perl $FileName\`\;\n";
+ print FHWA "print \"\\n\\n\\n\"\;\n\n";
+ }
+ }
+ }
+ }
+
+
+ ## Below adds the ending comments into all the intermediary auto scripts:
+
+ opendir(DIR, $DirName);
+ @Dirs = readdir(DIR);
+ close(DIR);
+ foreach $DirItem(@Dirs)
+ {
+ $index = 0;
+
+ $FileName = $DirName."/".$DirItem;
+ if(-d $FileName)
+ { # If an item is a folder, then open it further.
+
+ opendir(SUBDIR, $FileName);
+ @SubDirs = readdir(SUBDIR);
+ close(SUBDIR);
+
+ # To not to write into the file if the corresponding folder was empty.
+ foreach $SubDir(@SubDirs)
+ {
+ $index++;
+ }
+
+ if($index > 0)
+ {
+ # The folder not empty.
+
+ # Intemediary automated script like base.pl, lib.pl, cmd.pl etc.
+ $IntAutoScript = "t/".$DirItem.".pl";
+
+ # Write into the intermediary auto script.
+ open(FHW, ">> $IntAutoScript") or die "Unable to open the file, $IntAutoScript for appending.\n";
+ seek(FHW, 0, 2); # seek to the end of the file.
+ flock(FHW, LOCK_EX); # Lock the file for safety purposes.
+
+ # Write into the intermediary auto script.
+ print FHW "\nprint \"Testing of $DirItem folder done!\\n\\n\"\;\n\n";
+
+ flock(FHW, LOCK_UN); # unlock the file.
+ close FHW; # close the file.
+ }
+ }
+ }
+
+
+ # Write into nwauto.pl
+ print FHWA "\nprint \"Automated Unit Testing of Perl$version for NetWare done!\\n\\n\"\;\n\n";
+
+ flock(FHWA, LOCK_UN); # unlock the file.
+ close FHWA; # close the file.
+
+ print "\n\nGeneration of t/nwauto.pl Done!\n\n";
+
+ print "\nGeneration of automated scripts for NetWare DONE!\n";
+
+
+
+
+ # Process the file.
+ sub Process_File
+ {
+ local($FileToProcess) = @_; # File name.
+ local($Script) = 0;
+ local($HeadCut) = 0;
+
+ ## For example:
+ ## If the value of $FileToProcess is '/perl/scripts/t/pragma/warnings.t', then
+ ## $dir1 = '/perl/scripts/t/pragma/'
+ ## $base1 = 'warnings'
+ ## $ext1 = '.t'
+ $dir1 = dirname($FileToProcess); # Get the folder name
+ $base1 = basename($FileToProcess); # Get the base name
+ ($base1, $dir1, $ext1) = fileparse($FileToProcess, '\..*'); # Get the extension of the file passed.
+
+ # Do the processing only if the file has '.t' extension.
+ if($ext1 eq '.t')
+ {
+ foreach $Script(@ScriptsNotUsed)
+ {
+ # The variables are converted to lower case before they are compared.
+ # This is done to remove the case-sensitive comparison done by 'eq'.
+ $Script1 = lc($Script);
+ $FileToProcess1 = lc($FileToProcess);
+ if($Script1 eq $FileToProcess1)
+ {
+ $HeadCut = 1;
+ }
+ }
+
+ if($HeadCut)
+ {
+ # Write into the intermediary auto script.
+ print FHW "=head\n";
+ }
+
+ # Write into the intermediary auto script.
+ print FHW "print \"Testing $base1"."$ext1:\\n\\n\"\;\n";
+ print FHW "print \`perl $FileToProcess\`\;\n"; # Write the changed array into the file.
+ print FHW "print \"\\n\\n\\n\"\;\n";
+
+ if($HeadCut)
+ {
+ # Write into the intermediary auto script.
+ print FHW "=cut\n";
+ }
+
+ $HeadCut = 0;
+ print FHW "\n";
+ }
+ }
+
diff -c /dev/null 'perl-5.7.2/NetWare/t/Readme.txt'
Index: ./NetWare/t/Readme.txt
*** ./NetWare/t/Readme.txt Thu Jan 1 02:00:00 1970
--- ./NetWare/t/Readme.txt Mon Jul 9 17:09:42 2001
***************
*** 0 ****
--- 1,99 ----
+
+
+ Automated Testing of Perl5 Interpreter for NetWare.
+
+
+
+ A set of Standard Unit Test Scripts to test all the functionalities of
+ Perl5 Interpreter are available along with the CPAN download. They are
+ all located under 't' folder. These include sub-folders under 't' such
+ as: 'base', 'cmd', 'comp', 'io', lib', 'op', 'pod', 'pragma' and 'run'.
+ Each of these sub-folders contain few test scripts ('.t' files) under
+ them.
+
+ Executing these test scripts on NetWare can be automated as per the
+ following:
+
+ 1. Generate automated scripts like 'base.pl', 'cmd.pl', 'comp.pl', 'io.pl',
+ 'lib.pl', 'op.pl', 'pod.pl', 'pragma.pl', 'run.pl' that execute all the
+ test scripts ('.t' files) under the corresponding folder.
+
+ For example, 'base.pl' to test all the scripts
+ under 'sys:\perl\scripts\t\base' folder,
+ 'comp.pl' to test all the scripts
+ under 'sys:\perl\scripts\t\comp' folder and so on.
+
+ 2. Generate an automated script, 'nwauto.pl' that executes all the above
+ mentioned '.pl' automated scripts, thus in turn executing all the '.t'
+ scripts.
+
+ The script, 'NWScripts.pl' available under the 'NetWare\t' folder of the
+ CPAN download, is written to generate these automated scripts when
+ executed on a NetWare server. It generates 'base.pl', 'cmd.pl', 'comp.pl',
+ 'io.pl', 'lib.pl', 'op.pl', 'pod.pl', 'pragma.pl', 'run.pl' and also
+ 'nwauto.pl' by including all the corresponding '.t' scripts in them in
+ backtick operators.
+
+ For example, all the scripts that are under 't\base' folder will be
+ entered in 'base.pl' and so on. 'nwauto.pl' includes all these '.pl'
+ scripts like 'base.pl', 'comp.pl' etc.
+
+ Perform the following steps to execute the automated scripts:
+
+ 1. Make sure that your NetWare server is mapped to "i:".
+
+ 2. Execute "nmake nwinstall" (after building interpreter and extensions)
+ in the 'NetWare' folder of the CPAN download. This installs all the
+ library files, perl modules and all the 't' scripts in appropriate
+ folders onto your server.
+
+ 3. Execute the command "perl t\NWModify.pl" on the console command
+ prompt of your server. This script replaces
+
+ "@INC = " with "unshift @INC, " and
+ "push @INC, " with "unshift @INC, "
+
+ from all the scripts under 'sys:\perl\scripts\t' folder.
+
+ This is done to include the correct path for libraries into the scripts
+ when executed on NetWare. If this is not done, some of the scripts will
+ not get executed since they cannot locate the corresponding libraries.
+
+ 4. Execute the command "perl t\NWScripts.pl" on the console command
+ prompt to generate the automated scripts mentioned above
+ under the 'sys:\perl\scripts\t' folder.
+
+ 5. Execute the command "perl t\nwauto.pl" on the server console command
+ prompt. This runs all the standard test scripts. If you desire to
+ redirect or save the results into a file, say 'nwauto.txt', then the
+ console command to execute is: "perl t\nwauto.pl > nwauto.txt".
+
+ 6. If you wish to execute only a certain set of scripts, then run the
+ corresponding '.pl' file. For example, if you wish to execute only the
+ 'lib' scripts, then execute 'lib.pl' through the server console command,
+ "perl t\lib.pl'. To redirect the results into a file, the console command
+ is, "perl t\lib.pl > lib.txt".
+
+
+
+ Known Issues:
+
+ The following scripts are commented out in the corresponding autoscript:
+
+ 1. 'openpid.t' in 'sys:\perl\scripts\t\io.pl' script
+ Reason:
+ This either hangs or abends the server when executing through auto
+ scripts. When run individually, the script execution goes through
+ fine.
+
+ 2. 'argv.t' in 'sys:\perl\scripts\t\io.pl' script
+ Reason:
+ This either hangs or abends the server when executing through auto
+ scripts. When run individually, the script execution goes through
+ fine.
+
+ 3. 'filehandle.t' in 'sys:\perl\scripts\t\lib.pl' script
+ Reason:
+ This hangs in the last test case where it uses FileHandle::Pipe
+ whether run individually or through an auto script.
+
diff -c /dev/null 'perl-5.7.2/NetWare/testnlm/echo/echo.c'
Index: ./NetWare/testnlm/echo/echo.c
*** ./NetWare/testnlm/echo/echo.c Thu Jan 1 02:00:00 1970
--- ./NetWare/testnlm/echo/echo.c Mon Jul 9 17:09:42 2001
***************
*** 0 ****
--- 1,31 ----
+ /**********************************************************************
+ *
+ * C Source: echo.c
+ * Instance: idc_rads_2
+ * Description: DOS echo Emulation
+ * %created_by: smscm %
+ * %date_created: Fri Apr 20 19:05:31 2001 %
+ *
+ **********************************************************************/
+ #ifndef lint
+ static char *_csrc = "@(#) %filespec: echo.c~1 % (%full_filespec: echo.c~1:csrc:idc_rads#3 %)";
+ #endif
+
+ #include <stdio.h>
+ //#include <process.h>
+ #include "clibstuf.h"
+
+ void main (int argc, char** argv)
+ {
+ fnInitGpfGlobals();
+ if (argc>1 && argv[1]!=NULL && strcmp(argv[1],"-d")==0) {
+ int n;
+ for (n=0; n < argc; n++) {
+ printf("%2d: '%s'\n", n, argv[n]);
+ }
+ } else {
+ while (--argc) {
+ printf("%s%c", *++argv, argc==1 ? '\n' : ' ');
+ }
+ }
+ }
diff -c /dev/null 'perl-5.7.2/NetWare/testnlm/type/type.c'
Index: ./NetWare/testnlm/type/type.c
*** ./NetWare/testnlm/type/type.c Thu Jan 1 02:00:00 1970
--- ./NetWare/testnlm/type/type.c Mon Jul 9 17:09:42 2001
***************
*** 0 ****
--- 1,48 ----
+ /**********************************************************************
+ *
+ * C Source: type.c
+ * Instance: idc_rads_2
+ * Description: DOS type Emulation
+ * %created_by: smscm %
+ * %date_created: Fri Apr 20 19:05:34 2001 %
+ *
+ **********************************************************************/
+ #ifndef lint
+ static char *_csrc = "@(#) %filespec: type.c~1 % (%full_filespec: type.c~1:csrc:idc_rads#3 %)";
+ #endif
+
+ #include <stdio.h>
+ #include <nwfattr.h>
+ #include "clibstuf.h"
+
+ void main (int argc, char** argv)
+ {
+ FILE* pfile = NULL;
+ int k;
+ int thechar;
+ char* defaultDir;
+
+ fnInitGpfGlobals();
+ SetCurrentNameSpace(NWOS2_NAME_SPACE);
+ defaultDir = getenv("PERL_ROOT");
+ if (!defaultDir || (strlen(defaultDir) == 0))
+ defaultDir = "sys:\\perl\\scripts";
+ chdir(defaultDir);
+
+ k = 1;
+ while (k < argc)
+ {
+ // open the next file and print it out
+ pfile = fopen(argv[k],"r");
+ if (pfile)
+ {
+ while ((thechar = getc(pfile)) != EOF)
+ {
+ if (thechar != 0x0d)
+ printf("%c",thechar);
+ }
+ fclose (pfile);
+ }
+ k++;
+ }
+ }
diff -c /dev/null 'perl-5.7.2/NetWare/win32ish.h'
Index: ./NetWare/win32ish.h
*** ./NetWare/win32ish.h Thu Jan 1 02:00:00 1970
--- ./NetWare/win32ish.h Mon Jul 9 17:09:42 2001
***************
*** 0 ****
--- 1,46 ----
+
+ /*
+ * Copyright � 2001 Novell, Inc. All Rights Reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * FILENAME : Win32ish.h
+ * DESCRIPTION : For Win32 type definitions like BOOL.
+ * Author : HYAK
+ * Date : January 2001.
+ *
+ */
+
+
+
+ #ifndef __Win32ish_H__
+ #define __Win32ish_H__
+
+
+ #ifndef BOOL
+ typedef unsigned int BOOL;
+ #endif
+
+ #ifndef DWORD
+ typedef unsigned long DWORD;
+ #endif
+
+ typedef DWORD LCID;
+ typedef long HRESULT;
+ typedef void* LPVOID;
+
+ #ifndef TRUE
+ #define TRUE 1
+ #endif
+
+ #ifndef FALSE
+ #define FALSE 0
+ #endif
+
+
+ #endif // __Win32ish_H__
+
diff -c 'perl-5.7.1/Policy_sh.SH' 'perl-5.7.2/Policy_sh.SH'
Index: ./Policy_sh.SH
*** ./Policy_sh.SH Tue Mar 6 04:04:16 2001
--- ./Policy_sh.SH Mon Jul 9 17:09:42 2001
***************
*** 1,4 ****
! case $CONFIGDOTSH in
'') . ./config.sh ;;
esac
echo "Extracting Policy.sh (with variable substitutions)"
--- 1,4 ----
! case $PERL_CONFIG_SH in
'') . ./config.sh ;;
esac
echo "Extracting Policy.sh (with variable substitutions)"
diff -c 'perl-5.7.1/Porting/Glossary' 'perl-5.7.2/Porting/Glossary'
Index: ./Porting/Glossary
*** ./Porting/Glossary Sun Apr 8 02:08:32 2001
--- ./Porting/Glossary Fri Jul 13 03:18:58 2001
***************
*** 24,29 ****
--- 24,35 ----
with a hint value or command line option, but you'd better know
what you are doing.
+ afsroot (afs.U):
+ This variable is by default set to '/afs'. In the unlikely case
+ this is not the correct root, it is possible to override this with
+ a hint value or command line option. This will be used in subsequent
+ tests for AFSness in the Perl configure and test process.
+
alignbytes (alignbytes.U):
This variable holds the number of bytes required to align a
double-- or a long double when applicable. Usual values are
***************
*** 237,244 ****
The value is a plain '' and is not useful.
chmod (Loc.U):
! This variable is defined but not used by Configure.
! The value is a plain '' and is not useful.
chown (Loc.U):
This variable is defined but not used by Configure.
--- 243,251 ----
The value is a plain '' and is not useful.
chmod (Loc.U):
! This variable is used internally by Configure to determine the
! full pathname (if any) of the chmod program. After Configure runs,
! the value is reset to a plain "chmod" and is not useful.
chown (Loc.U):
This variable is defined but not used by Configure.
***************
*** 258,267 ****
This variable is defined but not used by Configure.
The value is a plain '' and is not useful.
- CONFIGDOTSH (Oldsyms.U):
- This is set to 'true' in config.sh so that a shell script
- sourcing config.sh can tell if it has been sourced already.
-
contains (contains.U):
This variable holds the command to do a grep with a proper return
status. On most sane systems it is simply "grep". On insane systems
--- 265,270 ----
***************
*** 326,336 ****
not in this list, see ccsymbols and cppccsymbols.
The list is a space-separated list of symbol=value tokens.
- crosscompile (crosscompile.U):
- This variable conditionally defines the CROSSCOMPILE symbol
- which signifies that the build process is be a cross-compilation.
- This is normally set by hints files or from Configure command line.
-
cryptlib (d_crypt.U):
This variable holds -lcrypt or the path to a libcrypt.a archive if
the crypt() function is not defined in the standard C library. It is
--- 329,334 ----
***************
*** 465,470 ****
--- 463,474 ----
header files provide DBL_DIG, which is the number of significant
digits in a double precision number.
+ d_dbminitproto (d_dbminitproto.U):
+ This variable conditionally defines the HAS_DBMINIT_PROTO symbol,
+ which indicates to the C program that the system provides
+ a prototype for the dbminit() function. Otherwise, it is
+ up to the program to supply one.
+
d_difftime (d_difftime.U):
This variable conditionally defines the HAS_DIFFTIME symbol, which
indicates to the C program that the difftime() routine is available.
***************
*** 540,545 ****
--- 544,553 ----
This variable conditionally defines the symbols EUNICE and VAX, which
alerts the C program that it must deal with ideosyncracies of VMS.
+ d_fchdir (d_fchdir.U):
+ This variable conditionally defines the HAS_FCHDIR symbol, which
+ indicates to the C program that the fchdir() routine is available.
+
d_fchmod (d_fchmod.U):
This variable conditionally defines the HAS_FCHMOD symbol, which
indicates to the C program that the fchmod() routine is available
***************
*** 586,591 ****
--- 594,605 ----
This variable conditionally defines HAS_FLOCK if flock() is
available to do file locking.
+ d_flockproto (d_flockproto.U):
+ This variable conditionally defines the HAS_FLOCK_PROTO symbol,
+ which indicates to the C program that the system provides
+ a prototype for the flock() function. Otherwise, it is
+ up to the program to supply one.
+
d_fork (d_fork.U):
This variable conditionally defines the HAS_FORK symbol, which
indicates to the C program that the fork() routine is available.
***************
*** 991,996 ****
--- 1005,1017 ----
This variable conditionally defines the HAS_MODFL symbol, which
indicates to the C program that the modfl() routine is available.
+ d_modfl_pow32_bug (d_modfl.U):
+ This variable conditionally defines the HAS_MODFL_POW32_BUG symbol,
+ which indicates that modfl() is broken for long doubles >= pow(2, 32).
+ For example from 4294967303.150000 one would get 4294967302.000000
+ and 1.150000. The bug has been seen in certain versions of glibc,
+ release 2.2.2 is known to be okay.
+
d_mprotect (d_mprotect.U):
This variable conditionally defines HAS_MPROTECT if mprotect() is
available to modify the access protection of a memory mapped file.
***************
*** 1061,1066 ****
--- 1082,1091 ----
This variable conditionally defines the HAS_NICE symbol, which
indicates to the C program that the nice() routine is available.
+ d_nl_langinfo (d_nl_langinfo.U):
+ This variable conditionally defines the HAS_NL_LANGINFO symbol, which
+ indicates to the C program that the nl_langinfo() routine is available.
+
d_nv_preserves_uv (perlxv.U):
This variable indicates whether a variable of type nvtype
can preserve all the bits a variable of type uvtype.
***************
*** 1184,1189 ****
--- 1209,1219 ----
The 'U' in the name is to separate this from d_PRIx64 so that even
case-blind systems can see the difference.
+ d_pthread_atfork (d_pthread_atfork.U):
+ This variable conditionally defines the HAS_PTHREAD_ATFORK symbol,
+ which indicates to the C program that the pthread_atfork()
+ routine is available.
+
d_pthread_yield (d_pthread_y.U):
This variable conditionally defines the HAS_PTHREAD_YIELD
symbol if the pthread_yield routine is available to yield
***************
*** 1261,1271 ****
d_safebcpy (d_safebcpy.U):
This variable conditionally defines the HAS_SAFE_BCOPY symbol if
! the bcopy() routine can do overlapping copies.
d_safemcpy (d_safemcpy.U):
This variable conditionally defines the HAS_SAFE_MEMCPY symbol if
the memcpy() routine can do overlapping copies.
d_sanemcmp (d_sanemcmp.U):
This variable conditionally defines the HAS_SANE_MEMCMP symbol if
--- 1291,1303 ----
d_safebcpy (d_safebcpy.U):
This variable conditionally defines the HAS_SAFE_BCOPY symbol if
! the bcopy() routine can do overlapping copies. Normally, you
! should probably use memmove().
d_safemcpy (d_safemcpy.U):
This variable conditionally defines the HAS_SAFE_MEMCPY symbol if
the memcpy() routine can do overlapping copies.
+ For overlapping copies, memmove() should be used, if available.
d_sanemcmp (d_sanemcmp.U):
This variable conditionally defines the HAS_SANE_MEMCMP symbol if
***************
*** 1492,1497 ****
--- 1524,1535 ----
This variable conditionally defines the HAS_SOCKATMARK symbol, which
indicates to the C program that the sockatmark() routine is available.
+ d_sockatmarkproto (d_sockatmarkproto.U):
+ This variable conditionally defines the HAS_SOCKATMARK_PROTO symbol,
+ which indicates to the C program that the system provides
+ a prototype for the sockatmark() function. Otherwise, it is
+ up to the program to supply one.
+
d_socket (d_socket.U):
This variable conditionally defines HAS_SOCKET, which indicates
that the BSD socket interface is supported.
***************
*** 1511,1516 ****
--- 1549,1566 ----
This variable conditionally defines the HAS_SQRTL symbol, which
indicates to the C program that the sqrtl() routine is available.
+ d_sresgproto (d_sresgproto.U):
+ This variable conditionally defines the HAS_SETRESGID_PROTO symbol,
+ which indicates to the C program that the system provides
+ a prototype for the setresgid() function. Otherwise, it is
+ up to the program to supply one.
+
+ d_sresuproto (d_sresuproto.U):
+ This variable conditionally defines the HAS_SETRESUID_PROTO symbol,
+ which indicates to the C program that the system provides
+ a prototype for the setresuid() function. Otherwise, it is
+ up to the program to supply one.
+
d_statblks (d_statblks.U):
This variable conditionally defines USE_STAT_BLOCKS
if this system has a stat structure declaring
***************
*** 1584,1589 ****
--- 1634,1643 ----
This variable conditionally defines HAS_STRERROR if strerror() is
available to translate error numbers to strings.
+ d_strftime (d_strftime.U):
+ This variable conditionally defines the HAS_STRFTIME symbol, which
+ indicates to the C program that the strftime() routine is available.
+
d_strtod (d_strtod.U):
This variable conditionally defines the HAS_STRTOD symbol, which
indicates to the C program that the strtod() routine is available
***************
*** 1636,1641 ****
--- 1690,1701 ----
This variable conditionally defines HAS_SYSCALL if syscall() is
available call arbitrary system calls.
+ d_syscallproto (d_syscallproto.U):
+ This variable conditionally defines the HAS_SYSCALL_PROTO symbol,
+ which indicates to the C program that the system provides
+ a prototype for the syscall() function. Otherwise, it is
+ up to the program to supply one.
+
d_sysconf (d_sysconf.U):
This variable conditionally defines the HAS_SYSCONF symbol, which
indicates to the C program that the sysconf() routine is available
***************
*** 1717,1722 ****
--- 1777,1788 ----
This variable conditionally defines HAS_USLEEP if usleep() is
available to do high granularity sleeps.
+ d_usleepproto (d_usleepproto.U):
+ This variable conditionally defines the HAS_USLEEP_PROTO symbol,
+ which indicates to the C program that the system provides
+ a prototype for the usleep() function. Otherwise, it is
+ up to the program to supply one.
+
d_ustat (d_ustat.U):
This variable conditionally defines HAS_USTAT if ustat() is
available to query file system statistics by dev_t.
***************
*** 1800,1805 ****
--- 1866,1885 ----
in the <db.h> header file. In older versions of DB, it was
int, while in newer ones it is size_t.
+ db_version_major (i_db.U):
+ This variable contains the major version number of
+ Berkeley DB found in the <db.h> header file.
+
+ db_version_minor (i_db.U):
+ This variable contains the minor version number of
+ Berkeley DB found in the <db.h> header file.
+ For DB version 1 this is always 0.
+
+ db_version_patch (i_db.U):
+ This variable contains the patch version number of
+ Berkeley DB found in the <db.h> header file.
+ For DB version 1 this is always 0.
+
defvoidused (voidflags.U):
This variable contains the default value of the VOIDUSED symbol (15).
***************
*** 1911,1916 ****
--- 1991,2002 ----
This variable contains the return type of free(). It is usually
void, but occasionally int.
+ from (Cross.U):
+ This variable contains the command used by Configure
+ to copy files from the target host. Useful and available
+ only during Perl build.
+ The string ':' if not cross-compiling.
+
full_ar (Loc_ar.U):
This variable contains the full pathname to 'ar', whether or
not the user has specified 'portability'. This is only used
***************
*** 2088,2093 ****
--- 2174,2183 ----
This variable conditionally defines the I_INTTYPES symbol,
and indicates whether a C program should include <inttypes.h>.
+ i_langinfo (i_langinfo.U):
+ This variable conditionally defines the I_LANGINFO symbol,
+ and indicates whether a C program should include <langinfo.h>.
+
i_libutil (i_libutil.U):
This variable conditionally defines the I_LIBUTIL symbol, and indicates
whether a C program should include <libutil.h>.
***************
*** 2972,2977 ****
--- 3062,3075 ----
This variable is defined but not used by Configure.
The value is a plain '' and is not useful.
+ perl_patchlevel (patchlevel.U):
+ This is the Perl patch level, a numeric change identifier,
+ as defined by whichever source code maintenance system
+ is used to maintain the patches; currently Perforce.
+ It does not correlate with the Perl version numbers or
+ the maintenance versus development dichotomy except
+ by also being increasing.
+
PERL_REVISION (Oldsyms.U):
In a Perl version number such as 5.6.2, this is the 5.
This value is manually set in patchlevel.h
***************
*** 3116,3121 ****
--- 3214,3225 ----
This variable is defined but not used by Configure.
The value is a plain '' and is not useful.
+ run (Cross.U):
+ This variable contains the command used by Configure
+ to copy and execute a cross-compiled executable in the
+ target host. Useful and available only during Perl build.
+ Empty string '' if not cross-compiling.
+
runnm (usenm.U):
This variable contains 'true' or 'false' depending whether the
nm extraction should be performed or not, according to the value
***************
*** 3460,3466 ****
stdio_filbuf (d_stdstdio.U):
This variable defines how, given a FILE pointer, fp, to tell
! stdio to refill it's internal buffers (?). This will
be used to define the macro FILE_filbuf(fp).
stdio_ptr (d_stdstdio.U):
--- 3564,3570 ----
stdio_filbuf (d_stdstdio.U):
This variable defines how, given a FILE pointer, fp, to tell
! stdio to refill its internal buffers (?). This will
be used to define the macro FILE_filbuf(fp).
stdio_ptr (d_stdstdio.U):
***************
*** 3501,3506 ****
--- 3605,3614 ----
This variable is defined but not used by Configure.
The value is a plain '' and is not useful.
+ targetarch (Cross.U):
+ If cross-compiling, this variable contains the target architecture.
+ If not, this will be empty.
+
tbl (Loc.U):
This variable is defined but not used by Configure.
The value is a plain '' and is not useful.
***************
*** 3522,3527 ****
--- 3630,3641 ----
or time_t on BSD sites (in which case <sys/types.h> should be
included). Anyway, the type Time_t should be used.
+ to (Cross.U):
+ This variable contains the command used by Configure
+ to copy to from the target host. Useful and available
+ only during Perl build.
+ The string ':' if not cross-compiling.
+
touch (Loc.U):
This variable is used internally by Configure to determine the
full pathname (if any) of the touch program. After Configure runs,
***************
*** 3618,3623 ****
--- 3732,3741 ----
This may mean using for example "long longs", while your memory
may still be limited to 2 gigabytes.
+ usecrosscompile (Cross.U):
+ This variable conditionally defines the USE_CROSS_COMPILE symbol,
+ and indicates that Perl has been cross-compiled.
+
usedl (dlsrc.U):
This variable indicates if the system supports dynamic
loading of some sort. See also dlsrc and dlobj.
***************
*** 3675,3680 ****
--- 3793,3805 ----
for hints files to indicate that POSIX will not compile
on a particular system.
+ usereentrant (usethreads.U):
+ This variable conditionally defines the USE_REENTRANT_API symbol,
+ which indicates that the thread code may try to use the various
+ _r versions of library functions. This is only potentially
+ meaningful if usethreads is set and is very experimental, it is
+ not even prompted for.
+
usesfio (d_sfio.U):
This variable is set to true when the user agrees to use sfio.
It is set to false when sfio is not available or when the user
***************
*** 3792,3797 ****
--- 3917,3931 ----
full version number, including any possible subversions.
This is suitable for use as a directory name, and hence is
filesystem dependent.
+
+ version_patchlevel_string (patchlevel.U):
+ This is a string combining version, subversion and
+ perl_patchlevel (if perl_patchlevel is non-zero).
+ It is typically something like
+ 'version 7 subversion 1' or
+ 'version 7 subversion 1 patchlevel 11224'
+ It is computed here to avoid duplication of code in myconfig.SH
+ and lib/Config.pm.
versiononly (versiononly.U):
If set, this symbol indicates that only the version-specific
diff -c 'perl-5.7.1/Porting/config.sh' 'perl-5.7.2/Porting/config.sh'
Index: ./Porting/config.sh
*** ./Porting/config.sh Sun Apr 8 02:08:13 2001
--- ./Porting/config.sh Fri Jul 13 17:08:57 2001
***************
*** 8,14 ****
# Package name : perl5
# Source directory : .
! # Configuration time: Sun Apr 8 02:05:27 EET DST 2001
# Configured by : jhi
# Target system : osf1 alpha.hut.fi v4.0 878 alpha
--- 8,14 ----
# Package name : perl5
# Source directory : .
! # Configuration time: Fri Jul 13 03:15:46 EET DST 2001
# Configured by : jhi
# Target system : osf1 alpha.hut.fi v4.0 878 alpha
***************
*** 27,32 ****
--- 27,33 ----
_exe=''
_o='.o'
afs='false'
+ afsroot='/afs'
alignbytes='8'
ansi2knr=''
aphostname=''
***************
*** 35,42 ****
api_version='5'
api_versionstring='5.005'
ar='ar'
! archlib='/opt/perl/lib/5.7.1/alpha-dec_osf-thread'
! archlibexp='/opt/perl/lib/5.7.1/alpha-dec_osf-thread'
archname64=''
archname='alpha-dec_osf-thread'
archobjs=''
--- 36,43 ----
api_version='5'
api_versionstring='5.005'
ar='ar'
! archlib='/opt/perl/lib/5.7.2/alpha-dec_osf-thread'
! archlibexp='/opt/perl/lib/5.7.2/alpha-dec_osf-thread'
archname64=''
archname='alpha-dec_osf-thread'
archobjs=''
***************
*** 54,60 ****
cat='cat'
cc='cc'
cccdlflags=' '
! ccdlflags=' -Wl,-rpath,/opt/perl/lib/5.7.1/alpha-dec_osf-thread/CORE'
ccflags='-pthread -std -DLANGUAGE_C'
ccflags_uselargefiles=''
ccname='cc'
--- 55,61 ----
cat='cat'
cc='cc'
cccdlflags=' '
! ccdlflags=' -Wl,-rpath,/opt/perl/lib/5.7.2/alpha-dec_osf-thread/CORE'
ccflags='-pthread -std -DLANGUAGE_C'
ccflags_uselargefiles=''
ccname='cc'
***************
*** 62,71 ****
ccversion='V5.6-082'
cf_by='jhi'
cf_email='yourname@yourhost.yourplace.com'
! cf_time='Sun Apr 8 02:05:27 EET DST 2001'
charsize='1'
chgrp=''
! chmod=''
chown=''
clocktype='clock_t'
comm='comm'
--- 63,72 ----
ccversion='V5.6-082'
cf_by='jhi'
cf_email='yourname@yourhost.yourplace.com'
! cf_time='Fri Jul 13 03:15:46 EET DST 2001'
charsize='1'
chgrp=''
! chmod='chmod'
chown=''
clocktype='clock_t'
comm='comm'
***************
*** 82,91 ****
cpprun='/usr/bin/cpp'
cppstdin='cppstdin'
cppsymbols='_AES_SOURCE=1 __alpha=1 __ALPHA=1 _ANSI_C_SOURCE=1 __LANGUAGE_C__=1 _LONGLONG=1 __osf__=1 _OSF_SOURCE=1 _POSIX_C_SOURCE=199506 _POSIX_SOURCE=1 _REENTRANT=1 __STDC__=1 _SYSTYPE_BSD=1 __unix__=1 _XOPEN_SOURCE=1'
- crosscompile='undef'
cryptlib=''
csh='csh'
! d_Gconvert='gcvt((x),(n),(b))'
d_PRIEUldbl='define'
d_PRIFUldbl='define'
d_PRIGUldbl='define'
--- 83,91 ----
cpprun='/usr/bin/cpp'
cppstdin='cppstdin'
cppsymbols='_AES_SOURCE=1 __alpha=1 __ALPHA=1 _ANSI_C_SOURCE=1 __LANGUAGE_C__=1 _LONGLONG=1 __osf__=1 _OSF_SOURCE=1 _POSIX_C_SOURCE=199506 _POSIX_SOURCE=1 _REENTRANT=1 __STDC__=1 _SYSTYPE_BSD=1 __unix__=1 _XOPEN_SOURCE=1'
cryptlib=''
csh='csh'
! d_Gconvert='sprintf((b),"%.*g",(n),(x))'
d_PRIEUldbl='define'
d_PRIFUldbl='define'
d_PRIGUldbl='define'
***************
*** 127,132 ****
--- 127,133 ----
d_csh='define'
d_cuserid='define'
d_dbl_dig='define'
+ d_dbminitproto='undef'
d_difftime='define'
d_dirnamlen='define'
d_dlerror='define'
***************
*** 144,149 ****
--- 145,151 ----
d_endsent='define'
d_eofnblk='define'
d_eunice='undef'
+ d_fchdir='define'
d_fchmod='define'
d_fchown='define'
d_fcntl='define'
***************
*** 154,159 ****
--- 156,162 ----
d_fgetpos='define'
d_flexfnam='define'
d_flock='define'
+ d_flockproto='undef'
d_fork='define'
d_fpathconf='define'
d_fpos64_t='undef'
***************
*** 239,245 ****
d_mkstemps='undef'
d_mktime='define'
d_mmap='define'
! d_modfl='define'
d_mprotect='define'
d_msg='define'
d_msg_ctrunc='define'
--- 242,249 ----
d_mkstemps='undef'
d_mktime='define'
d_mmap='define'
! d_modfl='undef'
! d_modfl_pow32_bug='undef'
d_mprotect='define'
d_msg='define'
d_msg_ctrunc='define'
***************
*** 256,261 ****
--- 260,266 ----
d_munmap='define'
d_mymalloc='undef'
d_nice='define'
+ d_nl_langinfo='define'
d_nv_preserves_uv='undef'
d_nv_preserves_uv_bits='53'
d_off64_t='undef'
***************
*** 270,275 ****
--- 275,281 ----
d_pipe='define'
d_poll='define'
d_portable='define'
+ d_pthread_atfork='define'
d_pthread_yield='undef'
d_pwage='undef'
d_pwchange='undef'
***************
*** 288,294 ****
d_rename='define'
d_rewinddir='define'
d_rmdir='define'
! d_safebcpy='define'
d_safemcpy='undef'
d_sanemcmp='define'
d_sbrkproto='define'
--- 294,300 ----
d_rename='define'
d_rewinddir='define'
d_rmdir='define'
! d_safebcpy='undef'
d_safemcpy='undef'
d_sanemcmp='define'
d_sbrkproto='define'
***************
*** 339,349 ****
--- 345,358 ----
d_sigprocmask='define'
d_sigsetjmp='define'
d_sockatmark='undef'
+ d_sockatmarkproto='undef'
d_socket='define'
d_socklen_t='undef'
d_sockpair='define'
d_socks5_init='undef'
d_sqrtl='define'
+ d_sresgproto='undef'
+ d_sresuproto='undef'
d_statblks='define'
d_statfs_f_flags='define'
d_statfs_s='define'
***************
*** 360,365 ****
--- 369,375 ----
d_strctcpy='define'
d_strerrm='strerror(e)'
d_strerror='define'
+ d_strftime='define'
d_strtod='define'
d_strtol='define'
d_strtold='undef'
***************
*** 372,377 ****
--- 382,388 ----
d_suidsafe='undef'
d_symlink='define'
d_syscall='define'
+ d_syscallproto='undef'
d_sysconf='define'
d_sysernlst=''
d_syserrlst='define'
***************
*** 390,395 ****
--- 401,407 ----
d_uname='define'
d_union_semun='undef'
d_usleep='define'
+ d_usleepproto='undef'
d_ustat='define'
d_vendorarch='undef'
d_vendorbin='undef'
***************
*** 409,414 ****
--- 421,429 ----
date='date'
db_hashtype='u_int32_t'
db_prefixtype='size_t'
+ db_version_major='1'
+ db_version_minor='0'
+ db_version_patch='0'
defvoidused='15'
direntrytype='struct dirent'
dlext='so'
***************
*** 415,421 ****
dlsrc='dl_dlopen.xs'
doublesize='8'
drand01='drand48()'
! dynamic_ext='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call IO IPC/SysV MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/Scalar PerlIO/Via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread XS/Typemap attrs re'
eagain='EAGAIN'
ebcdic='undef'
echo='echo'
--- 430,436 ----
dlsrc='dl_dlopen.xs'
doublesize='8'
drand01='drand48()'
! dynamic_ext='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/Scalar PerlIO/Via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread Time/HiRes Time/Piece XS/Typemap attrs re'
eagain='EAGAIN'
ebcdic='undef'
echo='echo'
***************
*** 424,430 ****
eunicefix=':'
exe_ext=''
expr='expr'
! extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call IO IPC/SysV MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/Scalar PerlIO/Via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread XS/Typemap attrs re Errno'
fflushNULL='define'
fflushall='undef'
find=''
--- 439,445 ----
eunicefix=':'
exe_ext=''
expr='expr'
! extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/Scalar PerlIO/Via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread Time/HiRes Time/Piece XS/Typemap attrs re Errno'
fflushNULL='define'
fflushall='undef'
find=''
***************
*** 433,438 ****
--- 448,454 ----
fpossize='8'
fpostype='fpos_t'
freetype='void'
+ from=':'
full_ar='/usr/bin/ar'
full_csh='/usr/bin/csh'
full_sed='/usr/bin/sed'
***************
*** 473,478 ****
--- 489,495 ----
i_iconv='define'
i_ieeefp='undef'
i_inttypes='undef'
+ i_langinfo='define'
i_libutil='undef'
i_limits='define'
i_locale='define'
***************
*** 543,559 ****
inc_version_list_init='0'
incpath=''
inews=''
! installarchlib='/opt/perl/lib/5.7.1/alpha-dec_osf-thread'
installbin='/opt/perl/bin'
installman1dir='/opt/perl/man/man1'
installman3dir='/opt/perl/man/man3'
installprefix='/opt/perl'
installprefixexp='/opt/perl'
! installprivlib='/opt/perl/lib/5.7.1'
installscript='/opt/perl/bin'
! installsitearch='/opt/perl/lib/site_perl/5.7.1/alpha-dec_osf-thread'
installsitebin='/opt/perl/bin'
! installsitelib='/opt/perl/lib/site_perl/5.7.1'
installstyle='lib'
installusrbinperl='undef'
installvendorarch=''
--- 560,576 ----
inc_version_list_init='0'
incpath=''
inews=''
! installarchlib='/opt/perl/lib/5.7.2/alpha-dec_osf-thread'
installbin='/opt/perl/bin'
installman1dir='/opt/perl/man/man1'
installman3dir='/opt/perl/man/man3'
installprefix='/opt/perl'
installprefixexp='/opt/perl'
! installprivlib='/opt/perl/lib/5.7.2'
installscript='/opt/perl/bin'
! installsitearch='/opt/perl/lib/site_perl/5.7.2/alpha-dec_osf-thread'
installsitebin='/opt/perl/bin'
! installsitelib='/opt/perl/lib/site_perl/5.7.2'
installstyle='lib'
installusrbinperl='undef'
installvendorarch=''
***************
*** 564,570 ****
ivdformat='"ld"'
ivsize='8'
ivtype='long'
! known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File IO IPC/SysV MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/Scalar PerlIO/Via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread XS/Typemap attrs re'
ksh=''
ld='ld'
lddlflags='-shared -expect_unresolved "*" -msym -std -s'
--- 581,587 ----
ivdformat='"ld"'
ivsize='8'
ivtype='long'
! known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/Scalar PerlIO/Via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread Time/HiRes Time/Piece XS/Typemap attrs re'
ksh=''
ld='ld'
lddlflags='-shared -expect_unresolved "*" -msym -std -s'
***************
*** 654,661 ****
passcat='cat /etc/passwd'
patchlevel='7'
path_sep=':'
! perl5='/u/vieraat/vieraat/jhi/Perl/bin/perl'
perl=''
perladmin='yourname@yourhost.yourplace.com'
perllibs='-lm -liconv -lutil -lpthread -lexc'
perlpath='/opt/perl/bin/perl'
--- 671,679 ----
passcat='cat /etc/passwd'
patchlevel='7'
path_sep=':'
! perl5='perl'
perl=''
+ perl_patchlevel='11326'
perladmin='yourname@yourhost.yourplace.com'
perllibs='-lm -liconv -lutil -lpthread -lexc'
perlpath='/opt/perl/bin/perl'
***************
*** 668,675 ****
pr=''
prefix='/opt/perl'
prefixexp='/opt/perl'
! privlib='/opt/perl/lib/5.7.1'
! privlibexp='/opt/perl/lib/5.7.1'
prototype='define'
ptrsize='8'
quadkind='2'
--- 686,693 ----
pr=''
prefix='/opt/perl'
prefixexp='/opt/perl'
! privlib='/opt/perl/lib/5.7.2'
! privlibexp='/opt/perl/lib/5.7.2'
prototype='define'
ptrsize='8'
quadkind='2'
***************
*** 682,687 ****
--- 700,706 ----
revision='5'
rm='rm'
rmail=''
+ run=''
runnm='true'
sPRIEUldbl='"E"'
sPRIFUldbl='"F"'
***************
*** 718,730 ****
sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 6, 6, 16, 20, 23, 23, 23, 29, 48, 0'
sig_size='58'
signal_t='void'
! sitearch='/opt/perl/lib/site_perl/5.7.1/alpha-dec_osf-thread'
! sitearchexp='/opt/perl/lib/site_perl/5.7.1/alpha-dec_osf-thread'
sitebin='/opt/perl/bin'
sitebinexp='/opt/perl/bin'
! sitelib='/opt/perl/lib/site_perl/5.7.1'
sitelib_stem='/opt/perl/lib/site_perl'
! sitelibexp='/opt/perl/lib/site_perl/5.7.1'
siteprefix='/opt/perl'
siteprefixexp='/opt/perl'
sizesize='8'
--- 737,749 ----
sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 6, 6, 16, 20, 23, 23, 23, 29, 48, 0'
sig_size='58'
signal_t='void'
! sitearch='/opt/perl/lib/site_perl/5.7.2/alpha-dec_osf-thread'
! sitearchexp='/opt/perl/lib/site_perl/5.7.2/alpha-dec_osf-thread'
sitebin='/opt/perl/bin'
sitebinexp='/opt/perl/bin'
! sitelib='/opt/perl/lib/site_perl/5.7.2'
sitelib_stem='/opt/perl/lib/site_perl'
! sitelibexp='/opt/perl/lib/site_perl/5.7.2'
siteprefix='/opt/perl'
siteprefixexp='/opt/perl'
sizesize='8'
***************
*** 740,746 ****
spitshell='cat'
src='.'
ssizetype='ssize_t'
! startperl='#!/opt/perl/bin/perl5.7.1'
startsh='#!/bin/sh'
static_ext=' '
stdchar='unsigned char'
--- 759,765 ----
spitshell='cat'
src='.'
ssizetype='ssize_t'
! startperl='#!/opt/perl/bin/perl5.7.2'
startsh='#!/bin/sh'
static_ext=' '
stdchar='unsigned char'
***************
*** 756,766 ****
--- 775,787 ----
sysman='/usr/man/man1'
tail=''
tar=''
+ targetarch=''
tbl=''
tee=''
test='test'
timeincl='/usr/include/sys/time.h '
timetype='time_t'
+ to=':'
touch='touch'
tr='tr'
trnl='\n'
***************
*** 783,788 ****
--- 804,810 ----
use5005threads='define'
use64bitall='define'
use64bitint='define'
+ usecrosscompile='undef'
usedl='define'
useithreads='undef'
uselargefiles='define'
***************
*** 794,799 ****
--- 816,822 ----
useopcode='true'
useperlio='define'
useposix='true'
+ usereentrant='undef'
usesfio='false'
useshrplib='true'
usesocks='undef'
***************
*** 817,829 ****
vendorlibexp=''
vendorprefix=''
vendorprefixexp=''
! version='5.7.1'
versiononly='define'
vi=''
voidflags='15'
xlibpth='/usr/lib/386 /lib/386'
! xs_apiversion='5.7.1'
! yacc='/u/vieraat/vieraat/jhi/Perl/bin/byacc'
yaccflags=''
zcat=''
zip='zip'
--- 840,853 ----
vendorlibexp=''
vendorprefix=''
vendorprefixexp=''
! version='5.7.2'
! version_patchlevel_string='version 7 subversion 1 patch 11326'
versiononly='define'
vi=''
voidflags='15'
xlibpth='/usr/lib/386 /lib/386'
! xs_apiversion='5.7.2'
! yacc='byacc'
yaccflags=''
zcat=''
zip='zip'
***************
*** 850,855 ****
PERL_API_REVISION=5
PERL_API_VERSION=5
PERL_API_SUBVERSION=0
! CONFIGDOTSH=true
# Variables propagated from previous config.sh file.
pp_sys_cflags='ccflags="$ccflags -DNO_EFF_ONLY_OK"'
--- 874,880 ----
PERL_API_REVISION=5
PERL_API_VERSION=5
PERL_API_SUBVERSION=0
! PERL_PATCHLEVEL=11326
! PERL_CONFIG_SH=true
# Variables propagated from previous config.sh file.
pp_sys_cflags='ccflags="$ccflags -DNO_EFF_ONLY_OK"'
diff -c 'perl-5.7.1/Porting/config_H' 'perl-5.7.2/Porting/config_H'
Index: ./Porting/config_H
Prereq: 3.0.1.5
*** ./Porting/config_H Sun Apr 8 02:08:13 2001
--- ./Porting/config_H Fri Jul 13 17:07:18 2001
***************
*** 17,23 ****
/*
* Package name : perl5
* Source directory : .
! * Configuration time: Sun Apr 8 02:05:27 EET DST 2001
* Configured by : jhi
* Target system : osf1 alpha.hut.fi v4.0 878 alpha
*/
--- 17,23 ----
/*
* Package name : perl5
* Source directory : .
! * Configuration time: Fri Jul 13 03:15:46 EET DST 2001
* Configured by : jhi
* Target system : osf1 alpha.hut.fi v4.0 878 alpha
*/
***************
*** 125,150 ****
*/
#define HAS_DLERROR /**/
- /* SETUID_SCRIPTS_ARE_SECURE_NOW:
- * This symbol, if defined, indicates that the bug that prevents
- * setuid scripts from being secure is not present in this kernel.
- */
- /* DOSUID:
- * This symbol, if defined, indicates that the C program should
- * check the script that it is executing for setuid/setgid bits, and
- * attempt to emulate setuid/setgid on systems that have disabled
- * setuid #! scripts because the kernel can't do it securely.
- * It is up to the package designer to make sure that this emulation
- * is done securely. Among other things, it should do an fstat on
- * the script it just opened to make sure it really is a setuid/setgid
- * script, it should make sure the arguments passed correspond exactly
- * to the argument on the #! line, and it should not trust any
- * subprocesses to which it must pass the filename rather than the
- * file descriptor of the script to be executed.
- */
- /*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/
- /*#define DOSUID / **/
-
/* HAS_DUP2:
* This symbol, if defined, indicates that the dup2 routine is
* available to duplicate file descriptors.
--- 125,130 ----
***************
*** 922,938 ****
*/
#define I_VALUES /**/
- /* I_STDARG:
- * This symbol, if defined, indicates that <stdarg.h> exists and should
- * be included.
- */
- /* I_VARARGS:
- * This symbol, if defined, indicates to the C program that it should
- * include <varargs.h>.
- */
- #define I_STDARG /**/
- /*#define I_VARARGS / **/
-
/* I_VFORK:
* This symbol, if defined, indicates to the C program that it should
* include vfork.h.
--- 902,907 ----
***************
*** 966,977 ****
*/
#define SH_PATH "/bin/sh" /**/
- /* CROSSCOMPILE:
- * This symbol, if defined, signifies that we our
- * build process is a cross-compilation.
- */
- /*#define CROSSCOMPILE / **/
-
/* INTSIZE:
* This symbol contains the value of sizeof(int) so that the C
* preprocessor can make decisions based on it.
--- 935,940 ----
***************
*** 1042,1048 ****
--- 1005,1017 ----
* by Configure. You shouldn't rely on it too much; the specific
* feature tests from Configure are generally more reliable.
*/
+ /* OSVERS:
+ * This symbol contains the version of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
+ */
#define OSNAME "dec_osf" /**/
+ #define OSVERS "4.0d" /**/
/* MEM_ALIGNBYTES:
* This symbol contains the number of bytes required to align a
***************
*** 1049,1055 ****
* double, or a long double when applicable. Usual values are 2,
* 4 and 8. The default is eight, for safety.
*/
! #if defined(CROSSCOMPILE) || defined(MULTIARCH)
# define MEM_ALIGNBYTES 8
#else
#define MEM_ALIGNBYTES 8
--- 1018,1024 ----
* double, or a long double when applicable. Usual values are 2,
* 4 and 8. The default is eight, for safety.
*/
! #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
# define MEM_ALIGNBYTES 8
#else
#define MEM_ALIGNBYTES 8
***************
*** 1068,1075 ****
* This symbol contains the ~name expanded version of ARCHLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define ARCHLIB "/opt/perl/lib/5.7.1/alpha-dec_osf-thread" /**/
! #define ARCHLIB_EXP "/opt/perl/lib/5.7.1/alpha-dec_osf-thread" /**/
/* ARCHNAME:
* This symbol holds a string representing the architecture name.
--- 1037,1044 ----
* This symbol contains the ~name expanded version of ARCHLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define ARCHLIB "/opt/perl/lib/5.7.2/alpha-dec_osf-thread" /**/
! #define ARCHLIB_EXP "/opt/perl/lib/5.7.2/alpha-dec_osf-thread" /**/
/* ARCHNAME:
* This symbol holds a string representing the architecture name.
***************
*** 1126,1132 ****
* so the default case (for NeXT) is big endian to catch them.
* This might matter for NeXT 3.0.
*/
! #if defined(CROSSCOMPILE) || defined(MULTIARCH)
# ifdef __LITTLE_ENDIAN__
# if LONGSIZE == 4
# define BYTEORDER 0x1234
--- 1095,1101 ----
* so the default case (for NeXT) is big endian to catch them.
* This might matter for NeXT 3.0.
*/
! #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
# ifdef __LITTLE_ENDIAN__
# if LONGSIZE == 4
# define BYTEORDER 0x1234
***************
*** 1316,1321 ****
--- 1285,1296 ----
*/
#define HAS_ENDSERVENT /**/
+ /* HAS_FCHDIR:
+ * This symbol, if defined, indicates that the fchdir routine is
+ * available to change directory using a file descriptor.
+ */
+ #define HAS_FCHDIR /**/
+
/* FCNTL_CAN_LOCK:
* This symbol, if defined, indicates that fcntl() can be used
* for file locking. Normally on Unix systems this is defined.
***************
*** 1393,1399 ****
* d_Gconvert='sprintf((b),"%.*g",(n),(x))'
* The last two assume trailing zeros should not be kept.
*/
! #define Gconvert(x,n,t,b) gcvt((x),(n),(b))
/* HAS_GETCWD:
* This symbol, if defined, indicates that the getcwd routine is
--- 1368,1374 ----
* d_Gconvert='sprintf((b),"%.*g",(n),(x))'
* The last two assume trailing zeros should not be kept.
*/
! #define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x))
/* HAS_GETCWD:
* This symbol, if defined, indicates that the getcwd routine is
***************
*** 1774,1780 ****
* available to split a long double x into a fractional part f and
* an integer part i such that |f| < 1.0 and (f + i) = x.
*/
! #define HAS_MODFL /**/
/* HAS_MPROTECT:
* This symbol, if defined, indicates that the mprotect system call is
--- 1749,1763 ----
* available to split a long double x into a fractional part f and
* an integer part i such that |f| < 1.0 and (f + i) = x.
*/
! /* HAS_MODFL_POW32_BUG:
! * This symbol, if defined, indicates that the modfl routine is
! * broken for long doubles >= pow(2, 32).
! * For example from 4294967303.150000 one would get 4294967302.000000
! * and 1.150000. The bug has been seen in certain versions of glibc,
! * release 2.2.2 is known to be okay.
! */
! /*#define HAS_MODFL / **/
! /*#define HAS_MODFL_POW32_BUG / **/
/* HAS_MPROTECT:
* This symbol, if defined, indicates that the mprotect system call is
***************
*** 1849,1865 ****
/* HAS_SAFE_BCOPY:
* This symbol, if defined, indicates that the bcopy routine is available
! * to copy potentially overlapping memory blocks. Otherwise you should
* probably use memmove() or memcpy(). If neither is defined, roll your
* own version.
*/
! #define HAS_SAFE_BCOPY /**/
/* HAS_SAFE_MEMCPY:
* This symbol, if defined, indicates that the memcpy routine is available
! * to copy potentially overlapping memory blocks. Otherwise you should
! * probably use memmove() or memcpy(). If neither is defined, roll your
! * own version.
*/
/*#define HAS_SAFE_MEMCPY / **/
--- 1832,1848 ----
/* HAS_SAFE_BCOPY:
* This symbol, if defined, indicates that the bcopy routine is available
! * to copy potentially overlapping memory blocks. Normally, you should
* probably use memmove() or memcpy(). If neither is defined, roll your
* own version.
*/
! /*#define HAS_SAFE_BCOPY / **/
/* HAS_SAFE_MEMCPY:
* This symbol, if defined, indicates that the memcpy routine is available
! * to copy potentially overlapping memory blocks. If you need to
! * copy overlapping memory blocks, you should check HAS_MEMMOVE and
! * use memmove() instead, if available.
*/
/*#define HAS_SAFE_MEMCPY / **/
***************
*** 2405,2412 ****
--- 2388,2412 ----
* in the <db.h> header file. In older versions of DB, it was
* int, while in newer ones it is size_t.
*/
+ /* DB_VERSION_MAJOR_CFG:
+ * This symbol, if defined, defines the major version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ */
+ /* DB_VERSION_MINOR_CFG:
+ * This symbol, if defined, defines the minor version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
+ /* DB_VERSION_PATCH_CFG:
+ * This symbol, if defined, defines the patch version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
#define DB_Hash_t u_int32_t /**/
#define DB_Prefix_t size_t /**/
+ #define DB_VERSION_MAJOR_CFG 1 /**/
+ #define DB_VERSION_MINOR_CFG 0 /**/
+ #define DB_VERSION_PATCH_CFG 0 /**/
/* I_GRP:
* This symbol, if defined, indicates to the C program that it should
***************
*** 2922,2929 ****
* This symbol contains the ~name expanded version of PRIVLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define PRIVLIB "/opt/perl/lib/5.7.1" /**/
! #define PRIVLIB_EXP "/opt/perl/lib/5.7.1" /**/
/* PTRSIZE:
* This symbol contains the size of a pointer, so that the C preprocessor
--- 2922,2929 ----
* This symbol contains the ~name expanded version of PRIVLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define PRIVLIB "/opt/perl/lib/5.7.2" /**/
! #define PRIVLIB_EXP "/opt/perl/lib/5.7.2" /**/
/* PTRSIZE:
* This symbol contains the size of a pointer, so that the C preprocessor
***************
*** 2937,2943 ****
* This macro is to be used to generate uniformly distributed
* random numbers over the range [0., 1.[. You may have to supply
* an 'extern double drand48();' in your program since SunOS 4.1.3
! * doesn't provide you with anything relevant in it's headers.
* See HAS_DRAND48_PROTO.
*/
/* Rand_seed_t:
--- 2937,2943 ----
* This macro is to be used to generate uniformly distributed
* random numbers over the range [0., 1.[. You may have to supply
* an 'extern double drand48();' in your program since SunOS 4.1.3
! * doesn't provide you with anything relevant in its headers.
* See HAS_DRAND48_PROTO.
*/
/* Rand_seed_t:
***************
*** 3026,3033 ****
* This symbol contains the ~name expanded version of SITEARCH, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define SITEARCH "/opt/perl/lib/site_perl/5.7.1/alpha-dec_osf-thread" /**/
! #define SITEARCH_EXP "/opt/perl/lib/site_perl/5.7.1/alpha-dec_osf-thread" /**/
/* SITELIB:
* This symbol contains the name of the private library for this package.
--- 3026,3033 ----
* This symbol contains the ~name expanded version of SITEARCH, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define SITEARCH "/opt/perl/lib/site_perl/5.7.2/alpha-dec_osf-thread" /**/
! #define SITEARCH_EXP "/opt/perl/lib/site_perl/5.7.2/alpha-dec_osf-thread" /**/
/* SITELIB:
* This symbol contains the name of the private library for this package.
***************
*** 3049,3056 ****
* removed. The elements in inc_version_list (inc_version_list.U) can
* be tacked onto this variable to generate a list of directories to search.
*/
! #define SITELIB "/opt/perl/lib/site_perl/5.7.1" /**/
! #define SITELIB_EXP "/opt/perl/lib/site_perl/5.7.1" /**/
#define SITELIB_STEM "/opt/perl/lib/site_perl" /**/
/* Size_t_size:
--- 3049,3056 ----
* removed. The elements in inc_version_list (inc_version_list.U) can
* be tacked onto this variable to generate a list of directories to search.
*/
! #define SITELIB "/opt/perl/lib/site_perl/5.7.2" /**/
! #define SITELIB_EXP "/opt/perl/lib/site_perl/5.7.2" /**/
#define SITELIB_STEM "/opt/perl/lib/site_perl" /**/
/* Size_t_size:
***************
*** 3087,3093 ****
* script to make sure (one hopes) that it runs with perl and not
* some shell.
*/
! #define STARTPERL "#!/opt/perl/bin/perl5.7.1" /**/
/* STDCHAR:
* This symbol is defined to be the type of char used in stdio.h.
--- 3087,3093 ----
* script to make sure (one hopes) that it runs with perl and not
* some shell.
*/
! #define STARTPERL "#!/opt/perl/bin/perl5.7.2" /**/
/* STDCHAR:
* This symbol is defined to be the type of char used in stdio.h.
***************
*** 3216,3221 ****
--- 3216,3226 ----
* This symbol, if defined, indicates that Perl should
* be built to use the old draft POSIX threads API.
*/
+ /* USE_REENTRANT_API:
+ * This symbol, if defined, indicates that Perl should
+ * try to use the various _r versions of library functions.
+ * This is extremely experimental.
+ */
#define USE_5005THREADS /**/
/*#define USE_ITHREADS / **/
#if defined(USE_5005THREADS) && !defined(USE_ITHREADS)
***************
*** 3222,3227 ****
--- 3227,3233 ----
#define USE_THREADS /* until src is revised*/
#endif
/*#define OLD_PTHREADS_API / **/
+ /*#define USE_REENTRANT_API / **/
/* PERL_VENDORARCH:
* If defined, this symbol contains the name of a private library.
***************
*** 3281,3287 ****
/* PERL_XS_APIVERSION:
* This variable contains the version of the oldest perl binary
* compatible with the present perl. perl.c:incpush() and
! * lib/lib.pm will automatically search in /opt/perl/lib/site_perl/5.7.1/alpha-dec_osf-thread for older
* directories across major versions back to xs_apiversion.
* This is only useful if you have a perl library directory tree
* structured like the default one.
--- 3287,3293 ----
/* PERL_XS_APIVERSION:
* This variable contains the version of the oldest perl binary
* compatible with the present perl. perl.c:incpush() and
! * lib/lib.pm will automatically search in /opt/perl/lib/site_perl/5.7.2/alpha-dec_osf-thread for older
* directories across major versions back to xs_apiversion.
* This is only useful if you have a perl library directory tree
* structured like the default one.
***************
*** 3300,3306 ****
* compatible with the present perl. (That is, pure perl modules
* written for pm_apiversion will still work for the current
* version). perl.c:incpush() and lib/lib.pm will automatically
! * search in /opt/perl/lib/site_perl/5.7.1 for older directories across major versions
* back to pm_apiversion. This is only useful if you have a perl
* library directory tree structured like the default one. The
* versioned site_perl library was introduced in 5.005, so that's
--- 3306,3312 ----
* compatible with the present perl. (That is, pure perl modules
* written for pm_apiversion will still work for the current
* version). perl.c:incpush() and lib/lib.pm will automatically
! * search in /opt/perl/lib/site_perl/5.7.2 for older directories across major versions
* back to pm_apiversion. This is only useful if you have a perl
* library directory tree structured like the default one. The
* versioned site_perl library was introduced in 5.005, so that's
***************
*** 3310,3318 ****
* (presumably) be similar.
* See the INSTALL file for how this works.
*/
! #define PERL_XS_APIVERSION "5.7.1"
#define PERL_PM_APIVERSION "5.005"
/* HAS_SIGPROCMASK:
* This symbol, if defined, indicates that the sigprocmask
* system call is available to examine or change the signal mask
--- 3316,3390 ----
* (presumably) be similar.
* See the INSTALL file for how this works.
*/
! #define PERL_XS_APIVERSION "5.7.2"
#define PERL_PM_APIVERSION "5.005"
+ /* SETUID_SCRIPTS_ARE_SECURE_NOW:
+ * This symbol, if defined, indicates that the bug that prevents
+ * setuid scripts from being secure is not present in this kernel.
+ */
+ /* DOSUID:
+ * This symbol, if defined, indicates that the C program should
+ * check the script that it is executing for setuid/setgid bits, and
+ * attempt to emulate setuid/setgid on systems that have disabled
+ * setuid #! scripts because the kernel can't do it securely.
+ * It is up to the package designer to make sure that this emulation
+ * is done securely. Among other things, it should do an fstat on
+ * the script it just opened to make sure it really is a setuid/setgid
+ * script, it should make sure the arguments passed correspond exactly
+ * to the argument on the #! line, and it should not trust any
+ * subprocesses to which it must pass the filename rather than the
+ * file descriptor of the script to be executed.
+ */
+ /*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/
+ /*#define DOSUID / **/
+
+ /* I_STDARG:
+ * This symbol, if defined, indicates that <stdarg.h> exists and should
+ * be included.
+ */
+ /* I_VARARGS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <varargs.h>.
+ */
+ #define I_STDARG /**/
+ /*#define I_VARARGS / **/
+
+ /* USE_CROSS_COMPILE:
+ * This symbol, if defined, indicates that Perl is being cross-compiled.
+ */
+ /* PERL_TARGETARCH:
+ * This symbol, if defined, indicates the target architecture
+ * Perl has been cross-compiled to. Undefined if not a cross-compile.
+ */
+ #ifndef USE_CROSS_COMPILE
+ /*#define USE_CROSS_COMPILE / **/
+ #define PERL_TARGETARCH "" /**/
+ #endif
+
+ /* HAS_DBMINIT_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the dbminit() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int dbminit(char *);
+ */
+ /*#define HAS_DBMINIT_PROTO / **/
+
+ /* HAS_FLOCK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the flock() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int flock(int, int);
+ */
+ /*#define HAS_FLOCK_PROTO / **/
+
+ /* HAS_NL_LANGINFO:
+ * This symbol, if defined, indicates that the nl_langinfo routine is
+ * available to return local data. You will also need <langinfo.h>
+ * and therefore I_LANGINFO.
+ */
+ #define HAS_NL_LANGINFO /**/
+
/* HAS_SIGPROCMASK:
* This symbol, if defined, indicates that the sigprocmask
* system call is available to examine or change the signal mask
***************
*** 3326,3335 ****
--- 3398,3466 ----
*/
/*#define HAS_SOCKATMARK / **/
+ /* HAS_SOCKATMARK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the sockatmark() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int sockatmark _((int));
+ */
+ /*#define HAS_SOCKATMARK_PROTO / **/
+
+ /* HAS_SETRESGID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresgid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+ /*#define HAS_SETRESGID_PROTO / **/
+
+ /* HAS_SETRESUID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresuid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+ /*#define HAS_SETRESUID_PROTO / **/
+
+ /* HAS_STRFTIME:
+ * This symbol, if defined, indicates that the strftime routine is
+ * available to do time formatting.
+ */
+ #define HAS_STRFTIME /**/
+
+ /* HAS_SYSCALL_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the syscall() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int syscall(int, ...);
+ * extern int syscall(long, ...);
+ */
+ /*#define HAS_SYSCALL_PROTO / **/
+
/* U32_ALIGNMENT_REQUIRED:
* This symbol, if defined, indicates that you must access
* character data through U32-aligned pointers.
*/
#define U32_ALIGNMENT_REQUIRED /**/
+
+ /* HAS_USLEEP_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the usleep() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int usleep(useconds_t);
+ */
+ /*#define HAS_USLEEP_PROTO / **/
+
+ /* I_LANGINFO:
+ * This symbol, if defined, indicates that <langinfo.h> exists and
+ * should be included.
+ */
+ #define I_LANGINFO /**/
+
+ /* HAS_PTHREAD_ATFORK:
+ * This symbol, if defined, indicates that the pthread_atfork routine
+ * is available setup fork handlers.
+ */
+ #define HAS_PTHREAD_ATFORK /**/
#endif
diff -c 'perl-5.7.1/Porting/makerel' 'perl-5.7.2/Porting/makerel'
Index: ./Porting/makerel
*** ./Porting/makerel Tue Mar 6 04:04:17 2001
--- ./Porting/makerel Mon Jul 9 17:09:44 2001
***************
*** 141,147 ****
win32/Makefile
win32/makefile.mk
);
! system("perl -pi -e 's/\$/\\r/' @crlf");
print "\n";
chdir ".." or die $!;
--- 141,147 ----
win32/Makefile
win32/makefile.mk
);
! system("perl -pi -e 's/\015*\012/\015\012/' @crlf");
print "\n";
chdir ".." or die $!;
diff -c 'perl-5.7.1/Porting/patching.pod' 'perl-5.7.2/Porting/patching.pod'
Index: ./Porting/patching.pod
*** ./Porting/patching.pod Tue Mar 6 04:04:17 2001
--- ./Porting/patching.pod Mon Jul 9 17:09:44 2001
***************
*** 256,268 ****
emacs MANIFEST
(make changes)
cd ..
! diff -c perl5.008_42/MANIFEST.old perl5.008_42/MANIFEST > mypatch
(testing the patch:)
! mv perl5.008_42/MANIFEST perl5.008_42/MANIFEST.new
! cp perl5.008_42/MANIFEST.old perl5.008_42/MANIFEST
patch -p < mypatch
(should succeed)
! diff perl5.008_42/MANIFEST perl5.008_42/MANIFEST.new
(should produce no output)
=head2 Submitting your patch
--- 256,268 ----
emacs MANIFEST
(make changes)
cd ..
! diff -c perl5.7.42/MANIFEST.old perl5.7.42/MANIFEST > mypatch
(testing the patch:)
! mv perl5.7.42/MANIFEST perl5.7.42/MANIFEST.new
! cp perl5.7.42/MANIFEST.old perl5.7.42/MANIFEST
patch -p < mypatch
(should succeed)
! diff perl5.7.42/MANIFEST perl5.7.42/MANIFEST.new
(should produce no output)
=head2 Submitting your patch
***************
*** 288,294 ****
The subject line on your patch should read
! [PATCH 5.xxx_xx AREA] Description
where the x's are replaced by the appropriate version number.
The description should be a very brief but accurate summary of the
--- 288,294 ----
The subject line on your patch should read
! [PATCH 5.x.x AREA] Description
where the x's are replaced by the appropriate version number.
The description should be a very brief but accurate summary of the
***************
*** 296,306 ****
Examples:
! [PATCH 5.004_04 DOC] fix minor typos
! [PATCH 5.004_99 CORE] New warning for foo() when frobbing
! [PATCH 5.005_42 CONFIG] Added support for fribnatz 1.5
The name of the file being patched makes for a poor subject line if
no other descriptive text accompanies it.
--- 296,306 ----
Examples:
! [PATCH 5.6.4 DOC] fix minor typos
! [PATCH 5.7.9 CORE] New warning for foo() when frobbing
! [PATCH 5.7.16 CONFIG] Added support for fribnatz 1.5
The name of the file being patched makes for a poor subject line if
no other descriptive text accompanies it.
***************
*** 384,390 ****
=head1 Author and Copyright Information
! Copyright (c) 1998 Daniel Grisinger
Adapted from a posting to perl5-porters by Tim Bunce (Tim.Bunce@ig.co.uk).
--- 384,390 ----
=head1 Author and Copyright Information
! Copyright (c) 1998, 1999 Daniel Grisinger
Adapted from a posting to perl5-porters by Tim Bunce (Tim.Bunce@ig.co.uk).
diff -c 'perl-5.7.1/Porting/repository.pod' 'perl-5.7.2/Porting/repository.pod'
Index: ./Porting/repository.pod
*** ./Porting/repository.pod Tue Mar 6 04:04:18 2001
--- ./Porting/repository.pod Fri Jul 13 03:39:08 2001
***************
*** 191,210 ****
=item P4CLIENT
The value of this is the name by which Perforce knows your
! host's workspace. You need to pick a name (for example, your
! hostname unless that clashes with someone else's client name)
when you first start using the perl repository and then
! stick with it. If you connect from multiple hosts (with
! different workspaces) then maybe you could have multiple
! clients. There is a licence limit on the number of perforce
! clients which can be created. Although we have been told that
! Perforce will raise our licence limits within reason, it's
! probably best not to use additional clients unless needed.
! Note that perforce only needs the client name so that it can
! find the directory under which your client files are stored.
If you have multiple hosts sharing the same directory structure
! via NFS then only one client name is necessary.
The C<p4 clients> command lists all currently known clients.
--- 191,218 ----
=item P4CLIENT
The value of this is the name by which Perforce knows your
! host's workspace. You need to pick a name (normally, your
! Perforce username, a dash, and your hostname)
when you first start using the perl repository and then
! stick with it.
! Perforce keeps track of the files you have on your machine. It
! does this through your client. When you first sync a version of a
! file, the file comes from the server to your machine. If you sync
! the same file again the server does nothing because it
! knows you already have the file.
!
! You should NOT use the same client on different machines. If you do
! you probably won't get the files you expect, and may end up with
! nasty corruption. Perforce allows you to have as many clients as
! you want. For example, sally-home, sally-openbsd, sally-laptop.
!
! Also, never change the client's root and view at the same time.
! See C<http://www.perforce.com/perforce/doc.002/manuals/p4guide/04_details.html#1048341>
!
If you have multiple hosts sharing the same directory structure
! via NFS then you may be able to get away with only one client name,
! but be careful.
The C<p4 clients> command lists all currently known clients.
***************
*** 213,223 ****
This is the username by which perforce knows you. Use your
username if you have a well known or obvious one or else pick
a new one which other perl5-porters will recognise. There is
! a licence limit on the number of these usernames. Perforce
! doesn't enforce security between usernames. If you set P4USER
! to be somebody else's username then perforce will believe you
! completely with regard to access control, logging and so on.
The C<p4 users> command lists all currently known users.
=back
--- 221,249 ----
This is the username by which perforce knows you. Use your
username if you have a well known or obvious one or else pick
a new one which other perl5-porters will recognise. There is
! a licence limit on the number of these usernames, so be sure not
! to use more than one.
+ It is very important to set a password for your Perforce username,
+ or else anyone can impersonate you. Use the C<p4 passwd> command
+ to do this. Once a password is set for your account, you'll need
+ to tell Perforce what it is. You can do this by setting the
+ environment variable P4PASSWD, or you can use the C<-P> flag
+ with the C<p4> command.
+
+ There are a few techniques you can use to avoid having to either
+ set an environment variable or type the password on every command.
+ One is to create a shell alias, for example, in bash, add something like
+ alias p4='p4 -P secret'
+ to your F<.bash_profile> file. Another way is to create a small shell
+ script, for example
+ #!/bin/bash
+ p4 -P secret $@
+ And use this instead of running C<p4> directly.
+
+ With either of these, be sure the file containing your password
+ (the F<.bash_profile> or shell script file) is only readable by you.
+
The C<p4 users> command lists all currently known users.
=back
***************
*** 254,264 ****
Here is the current structure of the repository:
/----+-----perl - Mainline development (bleadperl)
! +-----cfgperl - Configure Pumpkin's Perl
+-----vmsperl - VMS Pumpkin's Perl
+-----maint-5.004------perl - Maintainance branches
+-----maint-5.005------perl
+-----maint-5.6------perl
Perforce uses a branching model that simply tracks relationships
between files. It does not care about directories at all, so
--- 280,291 ----
Here is the current structure of the repository:
/----+-----perl - Mainline development (bleadperl)
! +-----perlio - PerlIO Pumpkin's Perl
+-----vmsperl - VMS Pumpkin's Perl
+-----maint-5.004------perl - Maintainance branches
+-----maint-5.005------perl
+-----maint-5.6------perl
+ +-----maint-5.6------pureperl
Perforce uses a branching model that simply tracks relationships
between files. It does not care about directories at all, so
***************
*** 275,282 ****
The mainline (aka "trunk") code in the Perl repository is under
"//depot/perl/...". Most branches typically map its entire
contents under a directory that goes by the same name as the branch
! name. Thus the contents of the cfgperl branch are to be found
! in //depot/cfgperl.
Run `p4 client` to specify how the repository contents should map to
your local disk. Most users will typically have a client map that
--- 302,309 ----
The mainline (aka "trunk") code in the Perl repository is under
"//depot/perl/...". Most branches typically map its entire
contents under a directory that goes by the same name as the branch
! name. Thus the contents of the perlio branch are to be found
! in //depot/perlio.
Run `p4 client` to specify how the repository contents should map to
your local disk. Most users will typically have a client map that
***************
*** 288,303 ****
if there are any changes in the mainline that you need to merge into
your own branch. A typical merging session looks like this:
! % cd ~/p4view/cfgperl
! % p4 integrate -b cfgperl # to bring parent changes into cfgperl
! % p4 resolve -a ./... # auto merge the changes
% p4 resolve ./... # manual merge conflicting changes
% p4 submit ./... # check in
! If the owner of the mainline wants to bring the changes in cfgperl
back into the mainline, they do:
! % p4 integrate -r -b cfgperl
...
Generating a patch for change#42 is done as follows:
--- 315,330 ----
if there are any changes in the mainline that you need to merge into
your own branch. A typical merging session looks like this:
! % cd ~/p4view/perlio
! % p4 integrate -b perlio # to bring parent changes into perlio
! % p4 resolve -am ./... # auto merge the changes
% p4 resolve ./... # manual merge conflicting changes
% p4 submit ./... # check in
! If the owner of the mainline wants to bring the changes in perlio
back into the mainline, they do:
! % p4 integrate -r -b perlio
...
Generating a patch for change#42 is done as follows:
***************
*** 304,311 ****
% p4 describe -du 42 | p4desc | p4d2p > change-42.patch
! p4desc and p4d2p are to be found in //depot/perl/Porting/.
=head1 Contact Information
The mail alias <perl-repository-keepers@perl.org> can be used to reach
--- 331,390 ----
% p4 describe -du 42 | p4desc | p4d2p > change-42.patch
! F<p4desc> and F<>p4d2p> are to be found in //depot/perl/Porting/.
+ The usual routine to apply a patch is
+
+ % p4 edit file.c file.h
+ % patch < patch.txt
+
+ (any necessary, re-Configure, make regen_headers, make clean, etc, here)
+
+ % make all test
+
+ (preferably make all test in several platforms and under several
+ different Configurations)
+
+ % while unhappy
+ do
+ $EDITOR
+ make all test
+ done
+ % p4 submit
+
+ Other useful Perforce commands
+
+ % p4 describe -du 12345 # show change 12345
+
+ Note: the output of "p4 describe" is not in proper diff format, use
+ the F<Porting/p4d2p> to convert.
+
+ % p4 diff -se ./... # have I modified something but forgotten
+ # to "p4 edit", easy faux pas with autogenerated
+ # files like proto.h, or if one forgets to
+ # look carefully which files a patch modifies
+ % p4 sync file.h # if someone else has modified file.h
+ % p4 opened # which files are opened (p4 edit) by me
+ % p4 opened -a # which files are opened by anybody
+ % p4 diff -du file.c # what changes have I done
+ % p4 revert file.h # never mind my changes
+ % p4 sync -f argh.c # forcibly synchronize your file
+ # from the repository
+ % p4 diff -sr | p4 -x - revert
+ # throw away (opened but) unchanged files
+ # (in Perforce it's a little bit too easy
+ # to checkin unchanged files)
+
+ Integrate patch 12345 from the mainline to the maint-5.6 branch:
+ (you have to in the directory that has both the mainline and
+ the maint-5.6/perl as subdirectories)
+
+ % p4 integrate -d perl/...@12345,12345 maint-5.6/perl/...
+
+ Integrate patches 12347-12350 from the perlio branch to the mainline:
+
+ % p4 integrate -d perlio/...@12347,12350 perl/...
+
=head1 Contact Information
The mail alias <perl-repository-keepers@perl.org> can be used to reach
***************
*** 320,326 ****
Gurusamy Sarathy, gsar@activestate.com, 8 May 1999.
! Slightly updated by Simon Cozens, simon@brecon.co.uk, 3 July 2000
=cut
--- 399,409 ----
Gurusamy Sarathy, gsar@activestate.com, 8 May 1999.
! Slightly updated by Simon Cozens, simon@brecon.co.uk, 3 July 2000.
!
! More updates by Jarkko Hietaniemi, jhi@iki.fi, 28 June 2001.
!
! Perforce clarifications by Randall Gellens, rcg@users.sourceforge.net, 12 July 2001.
=cut
diff -c /dev/null 'perl-5.7.2/Porting/testall.atom'
Index: ./Porting/testall.atom
*** ./Porting/testall.atom Thu Jan 1 02:00:00 1970
--- ./Porting/testall.atom Mon Jul 9 17:09:44 2001
***************
*** 0 ****
--- 1,80 ----
+ #!/bin/sh
+
+ #
+ # testall.atom
+ #
+ # This script creates all.Counts file that can be fed to prof(1)
+ # to produce various basic block counting profiles.
+ #
+ # This script needs to be run at the top level of the Perl build
+ # directory after the "make all" and "make test" targets have been run.
+ #
+ # You will also need to have perl.pixie built,
+ # which means that you will also have Configured with -Doptimize=-g.
+ #
+ # After the script has been run (this will take several minutes)
+ # you will have a file called all.Counts, which contains the cumulative
+ # basic block counting results over the whole Perl test suite.
+ # You can produce various reports using prof(1);
+ #
+ # prof -pixie -all -L. perl all.Counts
+ # prof -pixie -heavy -all -L. perl all.Counts
+ # prof -pixie -invocations -all -L. perl all.Counts
+ # prof -pixie -lines -all -L. perl all.Counts
+ # prof -pixie -testcoverage -all -L. perl all.Counts
+ # prof -pixie -zero -all -L. perl all.Counts
+ #
+ # io/openpid and op/fork core on me, I don't know why and haven't
+ # taken a look yet.
+ #
+ # jhi@iki.fi
+ #
+
+ if test ! -f /usr/bin/atom
+ then
+ echo "$0: no /usr/bin/atom"
+ exit 1
+ fi
+
+ if test ! -f perl; then echo "$0: no perl"; exit 1; fi
+ if test ! -f perl.pixie; then echo "$0: no perl.pixie; exit 1; fi
+ if test ! -f t/perl; then echo "$0: no t/perl; exit 1; fi
+
+ LD_LIBRARY_PATH=`pwd`
+ export LD_LIBRARY_PATH
+
+ cd t || exit 1
+
+ ln -sf ../perl.pixie .
+
+ the_t=`echo base/*.t comp/*.t cmd/*.t run/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t pod/*.t camel-III/*.t`
+
+ PERL_DESTRUCT_LEVEL=2
+ export PERL_DESTRUCT_LEVEL
+
+ rm -f all.Counts
+
+ for t in $the_t
+ do
+ echo `echo $t|sed s:\.t$::`" \c"
+ case "$t" in
+ *taint*|pragma/locale.t|lib/basename.t)
+ T=-T ;;
+ *)
+ T='' ;;
+ esac
+ ./perl.pixie $T $t > /dev/null
+ if cd ..
+ then
+ if test -f all.Counts
+ then
+ prof -pixie -merge new.Counts -L. -incobj libperl.so perl t/perl.Counts all.Counts
+ mv new.Counts all.Counts
+ else
+ mv t/perl.Counts all.Counts
+ fi
+ cd t
+ fi
+ done
+
+ exit 0
diff -c 'perl-5.7.1/README.aix' 'perl-5.7.2/README.aix'
Index: ./README.aix
*** ./README.aix Tue Mar 6 04:04:18 2001
--- ./README.aix Thu Jul 12 20:59:37 2001
***************
*** 24,30 ****
upgrade to the latest available patch level. Currently:
xlC.C 3.1.4.0
! vac.C 4.4.0.3 (5.0 is already available)
Perl can be compiled with either IBM's ANSI C compiler or with gcc.
The former is recommended, as not only can it compile Perl with no
--- 24,30 ----
upgrade to the latest available patch level. Currently:
xlC.C 3.1.4.0
! vac.C 4.4.0.3 or 5.0.2.0
Perl can be compiled with either IBM's ANSI C compiler or with gcc.
The former is recommended, as not only can it compile Perl with no
***************
*** 31,39 ****
difficulty, but also can take advantage of features listed later that
require the use of IBM compiler-specific command-line flags.
If you decide to use gcc, make sure your installation is recent and
complete, and be sure to read the Perl README file for more gcc-specific
! details.
=head2 OS level
--- 31,46 ----
difficulty, but also can take advantage of features listed later that
require the use of IBM compiler-specific command-line flags.
+ The IBM's compiler patch levels 5.0.0.0 and 5.0.1.0 have compiler
+ optimization bugs that affect compiling perl.c and regcomp.c,
+ respectively. If Perl's configuration detects those compiler patch
+ levels, optimization is turned off for the said source code files.
+ Upgrading to at least 5.0.2.0 is recommended.
+
If you decide to use gcc, make sure your installation is recent and
complete, and be sure to read the Perl README file for more gcc-specific
! details. Please report any hoops you had to jump through to the development
! team.
=head2 OS level
***************
*** 54,65 ****
Shared libraries end with the suffix .a, which is a bit misleading,
because *all* libraries are shared ;-).
=head2 The IBM ANSI C Compiler
All defaults for Configure can be used.
If you've chosen to use vac 4, be sure to run 4.4.0.3. Older versions
! will turn up nasty later on.
Here's a brief lead of how to upgrade the compiler to the latest
level. Of course this is subject to changes. You can only upgrade
--- 61,80 ----
Shared libraries end with the suffix .a, which is a bit misleading,
because *all* libraries are shared ;-).
+ Note that starting from Perl 5.7.2 (and consequently 5.8.0) and AIX
+ 4.3 or newer Perl uses the AIX native dynamic loading interface
+ instead of the emulated interface that was used in Perl releases 5.6.1
+ and earlier or, for AIX releases 4.2 and earlier. This change will
+ probably break backward compatibility with compiled modules.
+ The change was made to make Perl more compliant with other applications
+ like modperl which are using the AIX native interface.
+
=head2 The IBM ANSI C Compiler
All defaults for Configure can be used.
If you've chosen to use vac 4, be sure to run 4.4.0.3. Older versions
! will turn up nasty later on. For vac 5 be sure to run at least 5.0.1.0.
Here's a brief lead of how to upgrade the compiler to the latest
level. Of course this is subject to changes. You can only upgrade
***************
*** 139,166 ****
=head2 Using GNU's gcc for building perl
! ... ?
=head2 Using Large Files with Perl
! ... ?
=head2 Threaded Perl
! ... ?
=head2 64-bit Perl
! ... ?
! =head2 GDBM and Threads
! ... ?
- =head2 NFS filesystems and utime(2)
-
- ... ?
-
=head1 AUTHOR
H.Merijn Brand <h.m.brand@hccnet.nl>
--- 154,186 ----
=head2 Using GNU's gcc for building perl
! We're woking on this using gcc-3.0 ... (any input highly appreciated)
=head2 Using Large Files with Perl
! Should yield no problems.
=head2 Threaded Perl
! Threads seem to work OK, though at the moment not all tests pass when
! threads are used in combination with 64bit configurations.
=head2 64-bit Perl
! If your AIX is installed with 64-bit support, you can expect 64bit
! configurations to work. In combination with threads some tests might
! still fail.
! =head2 AIX 4.2 and extensions using C++ with statics
! In AIX 4.2 Perl extensions that use C++ functions that use statics
! may have problems in that the statics are not getting initialized.
! In newer AIX releases this has been solved by linking Perl with
! the libC_r library, but unfortunately in AIX 4.2 the said library
! has an obscure bug where the various functions related to time
! (such as time() and gettimeofday()) return broken values, and
! therefore in AIX 4.2 Perl is not linked against the libC_r.
=head1 AUTHOR
H.Merijn Brand <h.m.brand@hccnet.nl>
***************
*** 169,174 ****
=head1 DATE
! Version 0.0.1: 16-10-2000
=cut
--- 189,194 ----
=head1 DATE
! Version 0.0.3: 12 Jul 2001
=cut
diff -c 'perl-5.7.1/README.amiga' 'perl-5.7.2/README.amiga'
Index: ./README.amiga
*** ./README.amiga Tue Mar 6 04:04:18 2001
--- ./README.amiga Mon Jul 9 17:09:45 2001
***************
*** 18,24 ****
A recent version of perl for the Amiga can be found at the Geek Gadgets
section of the Aminet:
!
http://www.aminet.net/~aminet/dirs/dev_gg.html
=cut
--- 18,24 ----
A recent version of perl for the Amiga can be found at the Geek Gadgets
section of the Aminet:
!
http://www.aminet.net/~aminet/dirs/dev_gg.html
=cut
***************
*** 40,46 ****
- GNU info files
- LaTeX docs
BUILD
! - Prerequisites
- Getting the perl source
- Application of the patches
- Making
--- 40,46 ----
- GNU info files
- LaTeX docs
BUILD
! - Build Prerequisites
- Getting the perl source
- Application of the patches
- Making
***************
*** 51,57 ****
=head1 DESCRIPTION
! =head2 Prerequisites
=over 6
--- 51,57 ----
=head1 DESCRIPTION
! =head2 Prerequisites for Compiling Perl on AmigaOS
=over 6
***************
*** 101,113 ****
Perl under AmigaOS lacks some features of perl under UNIX because of
deficiencies in the UNIX-emulation, most notably:
! =over 4
! =item *
fork()
! =item *
some features of the UNIX filesystem regarding link count and file dates
--- 101,113 ----
Perl under AmigaOS lacks some features of perl under UNIX because of
deficiencies in the UNIX-emulation, most notably:
! =over 6
! =item *
fork()
! =item *
some features of the UNIX filesystem regarding link count and file dates
***************
*** 139,145 ****
=head1 Accessing documentation
! =head2 Manpages
If you have C<man> installed on your system, and you installed perl
manpages, use something like this:
--- 139,145 ----
=head1 Accessing documentation
! =head2 Manpages for Perl on AmigaOS
If you have C<man> installed on your system, and you installed perl
manpages, use something like this:
***************
*** 161,167 ****
above - to avoid shadowing by the I<less(1) manpage>.
! =head2 B<HTML>
If you have some WWW browser available, you can build B<HTML> docs.
Cd to directory with F<.pod> files, and do like this
--- 161,167 ----
above - to avoid shadowing by the I<less(1) manpage>.
! =head2 Perl HTML Documentation on AmigaOS
If you have some WWW browser available, you can build B<HTML> docs.
Cd to directory with F<.pod> files, and do like this
***************
*** 174,199 ****
Alternatively you may be able to get these docs prebuilt from C<CPAN>.
! =head2 B<GNU> C<info> files
Users of C<Emacs> would appreciate it very much, especially with
C<CPerl> mode loaded. You need to get latest C<pod2info> from C<CPAN>,
or, alternately, prebuilt info pages.
! =head2 C<LaTeX> docs
! can be constructed using C<pod2latex>.
! =head1 BUILD
Here we discuss how to build Perl under AmigaOS.
! =head2 Prerequisites
You need to have the latest B<ixemul> (Unix emulation for Amiga)
from Aminet.
! =head2 Getting the perl source
You can either get the latest perl-for-amiga source from Ninemoons
and extract it with:
--- 174,199 ----
Alternatively you may be able to get these docs prebuilt from C<CPAN>.
! =head2 Perl GNU Info Files on AmigaOS
Users of C<Emacs> would appreciate it very much, especially with
C<CPerl> mode loaded. You need to get latest C<pod2info> from C<CPAN>,
or, alternately, prebuilt info pages.
! =head2 Perl LaTeX Documentation on AmigaOS
! Can be constructed using C<pod2latex>.
! =head1 BUILDING PERL ON AMIGAOS
Here we discuss how to build Perl under AmigaOS.
! =head2 Build Prerequisites for Perl on AmigaOS
You need to have the latest B<ixemul> (Unix emulation for Amiga)
from Aminet.
! =head2 Getting the Perl Source for AmigaOS
You can either get the latest perl-for-amiga source from Ninemoons
and extract it with:
***************
*** 212,275 ****
is normal and expected. (There is a conflict with a similarly-named file
F<configure>, but it causes no harm.)
! =head2 Making
! =over 4
! =item *
! remember to use a healthy sized stack (I used 2000000)
! =item *
- your PATH environment variable must include /bin (e.g. ".:/bin" is good)
- (or, more precisely, it must include the directory where you have your
- basic UNIX utilities like test, cat, sed, and so on)
-
- =item *
-
- sh Configure -Dprefix=/ade -Dloclibpth=/ade/lib
-
- =item *
-
- fix makedepend
-
- In the file 'makedepend' there are three spots like this `$cat ...`:
- a for loop near line 75, an egrep near line 161, and a for loop near
- line 175. In all those spots using an editor change the $cat to
- /bin/cat.
-
- =item *
-
- now type make depend
-
- When the make depend has ended load the gnumakefile into
- an editor and go to the end of the file.
-
- Move upwards in the file until you reach av.o: EXTERN.h
- and delete all lines down to # WARNING: Put....
-
- =item *
-
- now go to the x2p directory
-
- Load the gnumakefile into an editor.
-
- Go to the end moveup until you reach hash.o: EXTERN.h
- and delete all lines dowonwards until you reach a line saying
-
- # WARNING: Put nothing....
-
- =item *
-
Now!
make
! =back
- =head2 Testing
-
Now run
make test
--- 212,233 ----
is normal and expected. (There is a conflict with a similarly-named file
F<configure>, but it causes no harm.)
! =head2 Making Perl on AmigaOS
! Remember to use a hefty wad of stack (I use 2000000)
! sh configure.gnu --prefix=/gg
! Now type
! make depend
Now!
make
! =head2 Testing Perl on AmigaOS
Now run
make test
***************
*** 279,285 ****
F<io/pipe.t>, F<op/fork.t>, F<lib/filehand.t>, F<lib/open2.t>, F<lib/open3.t>,
F<lib/io_pipe.t>, F<lib/io_sock.t>
! =head2 Installing the built perl
Run
--- 237,243 ----
F<io/pipe.t>, F<op/fork.t>, F<lib/filehand.t>, F<lib/open2.t>, F<lib/open3.t>,
F<lib/io_pipe.t>, F<lib/io_sock.t>
! =head2 Installing the built Perl on AmigaOS
Run
diff -c 'perl-5.7.1/README.apollo' 'perl-5.7.2/README.apollo'
Index: ./README.apollo
*** ./README.apollo Tue Mar 6 04:04:19 2001
--- ./README.apollo Mon Jul 9 17:09:45 2001
***************
*** 1,3 ****
--- 1,13 ----
+ If you read this file _as_is_, just ignore the funny characters you see.
+ It is written in the POD format (see pod/perlpod.pod) which is specially
+ designed to be readable as is.
+
+ =head1 NAME
+
+ README.apollo - Perl version 5 on Apollo DomainOS
+
+ =head1 DESCRIPTION
+
The following tests are known to fail as of Perl 5.005_03:
comp/decl..........FAILED at test 0
***************
*** 7,11 ****
--- 17,23 ----
lib/findbin........stat(/ressel/ABT/USER/vta/jk/proj.local/perl/perl5.005_03-MAINT_TRIAL_5/t/lib/): No such file or directory at ../lib/FindBin.pm line 162
stat(/ressel/ABT/USER/vta/jk/proj.local/perl/perl5.005_03-MAINT_TRIAL_5/t/lib/): No such file or directory at ../lib/FindBin.pm line 163
FAILED at test 1
+
+ =head1 AUTHOR
Johann Klasek <jk@auto.tuwien.ac.at>
diff -c 'perl-5.7.1/README.beos' 'perl-5.7.2/README.beos'
Index: ./README.beos
*** ./README.beos Tue Mar 6 04:04:19 2001
--- ./README.beos Mon Jul 9 17:09:45 2001
***************
*** 1,39 ****
! Notes on building perl under BeOS:
! GENERAL ISSUES
! --------------
! how to compile perl:
To compile perl under BeOS R4 x86:
! `./Configure -d` and hit ^C when it asks you if you want to make changes
! to config.sh;
edit config.sh and do the following:
change d_socket='define' to ='undef';
remove SDBM, Errno, and Socket from dynamic_ext= and nonxs_ext=;
-
add '#define bool short' to x2p/a2p.h;
! ../Configure -S; make; make install
! cd ~/config/lib; ln -s 5.00502/BeOS-BePC/CORE/libperl.so .
(substitute 5.00502 with the appropriate filename)
! OS RELEASE-SPECIFIC NOTES
! -------------------------
! R4 x86 - dynamic loading finally works! Yay! This means you can compile
! your own modules into perl. However, Sockets and Errno still don't work.
(Hopefully, sockets will at least work by R5, if not sooner.)
! R4 PPC - I have not tested this. I rather severely doubt that dynamic
! loading will work. (My BeBox is in pieces right now, following a nasty
! disk crash.) You may have to disable dynamic loading to get the thing
! to compile at all. (use `./Configure` without -d, and say 'no' to
! 'Build a shared libperl.so'.)
! CONTACT INFORMATION
! -------------------
If you have comments, problem reports, or even patches or bugfixes (gasp!)
please email me.
--- 1,55 ----
! If you read this file _as_is_, just ignore the funny characters you see.
! It is written in the POD format (see pod/perlpod.pod) which is specially
! designed to be readable as is.
! =head1 NAME
+ README.beos - Perl version 5 on BeOS
+
+ =head1 DESCRIPTION
+
+ Notes for building Perl under BeOS.
+
+ =head2 General Issues with Perl on BeOS
+
To compile perl under BeOS R4 x86:
! ./Configure -d
+ and hit ^C when it asks you if you want to make changes to config.sh;
edit config.sh and do the following:
change d_socket='define' to ='undef';
remove SDBM, Errno, and Socket from dynamic_ext= and nonxs_ext=;
add '#define bool short' to x2p/a2p.h;
! ../Configure -S; make; make install
! cd ~/config/lib; ln -s 5.00502/BeOS-BePC/CORE/libperl.so .
!
(substitute 5.00502 with the appropriate filename)
! =head2 BeOS Release-specific Notes
!
! =over 4
!
! =item R4 x86
!
! Dynamic loading finally works! Yay! This means you can compile your
! own modules into perl. However, Sockets and Errno still don't work.
(Hopefully, sockets will at least work by R5, if not sooner.)
! =item R4 PPC
! I have not tested this. I rather severely doubt that dynamic loading
! will work. (My BeBox is in pieces right now, following a nasty disk
! crash.) You may have to disable dynamic loading to get the thing to
! compile at all. (use `./Configure` without -d, and say 'no' to 'Build
! a shared libperl.so'.)
!
! =back
!
! =head2 Contact Information
!
If you have comments, problem reports, or even patches or bugfixes (gasp!)
please email me.
diff -c 'perl-5.7.1/README.bs2000' 'perl-5.7.2/README.bs2000'
Index: ./README.bs2000
*** ./README.bs2000 Tue Mar 6 04:04:19 2001
--- ./README.bs2000 Mon Jul 9 17:09:45 2001
***************
*** 20,31 ****
You may need the following GNU programs in order to install perl:
! =head2 gzip
We used version 1.2.4, which could be installed out of the box with
one failure during 'make check'.
! =head2 bison
The yacc coming with BS2000 POSIX didn't work for us. So we had to
use bison. We had to make a few changes to perl in order to use the
--- 20,31 ----
You may need the following GNU programs in order to install perl:
! =head2 gzip on BS2000
We used version 1.2.4, which could be installed out of the box with
one failure during 'make check'.
! =head2 bison on BS2000
The yacc coming with BS2000 POSIX didn't work for us. So we had to
use bison. We had to make a few changes to perl in order to use the
***************
*** 33,39 ****
add a few changes due to EBCDIC. See below for more details
concerning yacc.
! =head2 Unpacking
To extract an ASCII tar archive on BS2000 POSIX you need an ASCII
filesystem (we used the mountpoint /usr/local/ascii for this). Now
--- 33,39 ----
add a few changes due to EBCDIC. See below for more details
concerning yacc.
! =head2 Unpacking Perl Distribution on BS2000
To extract an ASCII tar archive on BS2000 POSIX you need an ASCII
filesystem (we used the mountpoint /usr/local/ascii for this). Now
***************
*** 55,61 ****
IO_CONVERSION=YES
cp -r /usr/local/ascii/perl5.005_02 ./
! =head2 Compiling
There is a "hints" file for BS2000 called hints.posix-bc (because
posix-bc is the OS name given by `uname`) that specifies the correct
--- 55,61 ----
IO_CONVERSION=YES
cp -r /usr/local/ascii/perl5.005_02 ./
! =head2 Compiling Perl on BS2000
There is a "hints" file for BS2000 called hints.posix-bc (because
posix-bc is the OS name given by `uname`) that specifies the correct
***************
*** 102,108 ****
We build perl using GNU make. We tried the native make once and it
worked too.
! =head2 Testing
We still got a few errors during C<make test>. Some of them are the
result of using bison. Bison prints I<parser error> instead of I<syntax
--- 102,108 ----
We build perl using GNU make. We tried the native make once and it
worked too.
! =head2 Testing Perl on BS2000
We still got a few errors during C<make test>. Some of them are the
result of using bison. Bison prints I<parser error> instead of I<syntax
***************
*** 120,132 ****
lib/dumper..........FAILED tests 43, 45
Failed 11/231 test scripts, 95.24% okay. 57/10595 subtests failed, 99.46% okay.
! =head2 Install
We have no nroff on BS2000 POSIX (yet), so we ignored any errors while
installing the documentation.
! =head2 Using Perl in the Posix-Shell
BS2000 POSIX doesn't support the shebang notation
(C<#!/usr/local/bin/perl>), so you have to use the following lines
--- 120,132 ----
lib/dumper..........FAILED tests 43, 45
Failed 11/231 test scripts, 95.24% okay. 57/10595 subtests failed, 99.46% okay.
! =head2 Installing Perl on BS2000
We have no nroff on BS2000 POSIX (yet), so we ignored any errors while
installing the documentation.
! =head2 Using Perl in the Posix-Shell of BS2000
BS2000 POSIX doesn't support the shebang notation
(C<#!/usr/local/bin/perl>), so you have to use the following lines
***************
*** 158,164 ****
possibilities of the commandline prompt (look for
PARAMETER-PROMPTING).
! =head2 Floating point anomalies
There appears to be a bug in the floating point implementation on BS2000 POSIX
systems such that calling int() on the product of a number and a small
--- 158,164 ----
possibilities of the commandline prompt (look for
PARAMETER-PROMPTING).
! =head2 Floating point anomalies on BS2000
There appears to be a bug in the floating point implementation on BS2000 POSIX
systems such that calling int() on the product of a number and a small
diff -c 'perl-5.7.1/README.cygwin' 'perl-5.7.2/README.cygwin'
Index: ./README.cygwin
*** ./README.cygwin Tue Mar 6 04:04:19 2001
--- ./README.cygwin Mon Jul 9 17:09:45 2001
***************
*** 18,24 ****
http://cygutils.netpedia.net/
! =head1 PREREQUISITES
=head2 Cygwin = GNU+Cygnus+Windows (Don't leave UNIX without it)
--- 18,24 ----
http://cygutils.netpedia.net/
! =head1 PREREQUISITES FOR COMPILING PERL ON CYGWIN
=head2 Cygwin = GNU+Cygnus+Windows (Don't leave UNIX without it)
***************
*** 84,90 ****
=back
! =head1 CONFIGURE
The default options gathered by Configure with the assistance of
F<hints/cygwin.sh> will build a Perl that supports dynamic loading
--- 84,90 ----
=back
! =head1 CONFIGURE PERL ON CYGWIN
The default options gathered by Configure with the assistance of
F<hints/cygwin.sh> will build a Perl that supports dynamic loading
***************
*** 97,103 ****
If you are willing to accept all the defaults run Configure with B<-de>.
However, several useful customizations are available.
! =head2 Strip Binaries
It is possible to strip the EXEs and DLLs created by the build process.
The resulting binaries will be significantly smaller. If you want the
--- 97,103 ----
If you are willing to accept all the defaults run Configure with B<-de>.
However, several useful customizations are available.
! =head2 Stripping Perl Binaries on Cygwin
It is possible to strip the EXEs and DLLs created by the build process.
The resulting binaries will be significantly smaller. If you want the
***************
*** 112,118 ****
or you can edit F<hints/cygwin.sh> and uncomment the relevant variables
near the end of the file.
! =head2 Optional Libraries
Several Perl functions and modules depend on the existence of
some optional libraries. Configure will find them if they are
--- 112,118 ----
or you can edit F<hints/cygwin.sh> and uncomment the relevant variables
near the end of the file.
! =head2 Optional Libraries for Perl on Cygwin
Several Perl functions and modules depend on the existence of
some optional libraries. Configure will find them if they are
***************
*** 168,174 ****
=back
! =head2 Configure-time Options
The F<INSTALL> document describes several Configure-time options. Some of
these will work with Cygwin, others are not yet possible. Also, some of
--- 168,174 ----
=back
! =head2 Configure-time Options for Perl on Cygwin
The F<INSTALL> document describes several Configure-time options. Some of
these will work with Cygwin, others are not yet possible. Also, some of
***************
*** 219,225 ****
=back
! =head2 Suspicious Warnings
You may see some messages during Configure that seem suspicious.
--- 219,225 ----
=back
! =head2 Suspicious Warnings on Cygwin
You may see some messages during Configure that seem suspicious.
***************
*** 265,277 ****
=back
! =head1 MAKE
Simply run I<make> and wait:
make 2>&1 | tee log.make
! =head2 Warnings
Warnings like these are normal:
--- 265,277 ----
=back
! =head1 MAKE ON CYGWIN
Simply run I<make> and wait:
make 2>&1 | tee log.make
! =head2 Warnings on Cygwin
Warnings like these are normal:
***************
*** 281,287 ****
dllwrap: no export definition file provided
dllwrap: creating one, but that may not be what you want
! =head2 ld2
During `C<make>', I<ld2> will be created and installed in your $installbin
directory (where you said to put public executables). It does not
--- 281,287 ----
dllwrap: no export definition file provided
dllwrap: creating one, but that may not be what you want
! =head2 ld2 on Cygwin
During `C<make>', I<ld2> will be created and installed in your $installbin
directory (where you said to put public executables). It does not
***************
*** 293,299 ****
just manually copy I<ld2> from the source directory to somewhere in
your C<PATH>.
! =head1 TEST
There are two steps to running the test suite:
--- 293,299 ----
just manually copy I<ld2> from the source directory to somewhere in
your C<PATH>.
! =head1 TEST ON CYGWIN
There are two steps to running the test suite:
***************
*** 310,316 ****
for Perl to pass all the tests, but it is more likely that some tests
will fail for one of the reasons listed below.
! =head2 File Permissions
UNIX file permissions are based on sets of mode bits for
{read,write,execute} for each {user,group,other}. By default Cygwin
--- 310,316 ----
for Perl to pass all the tests, but it is more likely that some tests
will fail for one of the reasons listed below.
! =head2 File Permissions on Cygwin
UNIX file permissions are based on sets of mode bits for
{read,write,execute} for each {user,group,other}. By default Cygwin
***************
*** 336,342 ****
lib/sdbm.t 2
op/stat.t 9, 20 (.tmp not an executable extension)
! =head2 Hard Links
FAT partitions do not support hard links (whereas NTFS does), in which
case Cygwin implements link() by copying the file. On remote (network)
--- 336,342 ----
lib/sdbm.t 2
op/stat.t 9, 20 (.tmp not an executable extension)
! =head2 Hard Links on Cygwin
FAT partitions do not support hard links (whereas NTFS does), in which
case Cygwin implements link() by copying the file. On remote (network)
***************
*** 349,355 ****
io/fs.t 4
op/stat.t 3
! =head2 Filetime Granularity
On FAT partitions the filetime granularity is 2 seconds. The following
test will fail:
--- 349,355 ----
io/fs.t 4
op/stat.t 3
! =head2 Filetime Granularity on Cygwin
On FAT partitions the filetime granularity is 2 seconds. The following
test will fail:
***************
*** 358,364 ****
------------------------------------
io/fs.t 18
! =head2 Tainting Checks
When Perl is running in taint mode, C<$ENV{PATH}> is considered tainted
and not used, so DLLs not in the default system directories will not
--- 358,364 ----
------------------------------------
io/fs.t 18
! =head2 Tainting Checks on Cygwin
When Perl is running in taint mode, C<$ENV{PATH}> is considered tainted
and not used, so DLLs not in the default system directories will not
***************
*** 390,396 ****
or one of the Windows system directories (although, this is B<not>
recommended).
! =head2 /etc/group
Cygwin does not require F</etc/group>, in which case the F<op/grent.t>
test will be skipped. The check performed by F<op/grent.t> expects to
--- 390,396 ----
or one of the Windows system directories (although, this is B<not>
recommended).
! =head2 /etc/group on Cygwin
Cygwin does not require F</etc/group>, in which case the F<op/grent.t>
test will be skipped. The check performed by F<op/grent.t> expects to
***************
*** 400,406 ****
------------------------------------
op/grent.t 1
! =head2 Script Portability
Cygwin does an outstanding job of providing UNIX-like semantics on top of
Win32 systems. However, in addition to the items noted above, there are
--- 400,406 ----
------------------------------------
op/grent.t 1
! =head2 Script Portability on Cygwin
Cygwin does an outstanding job of providing UNIX-like semantics on top of
Win32 systems. However, in addition to the items noted above, there are
***************
*** 466,472 ****
=back
! =head1 INSTALL
This will install Perl, including I<man> pages.
--- 466,472 ----
=back
! =head1 INSTALL PERL ON CYGWIN
This will install Perl, including I<man> pages.
***************
*** 481,487 ****
Information on installing the Perl documentation in HTML format can be
found in the F<INSTALL> document.
! =head1 MANIFEST
These are the files in the Perl release that contain references to Cygwin.
These very brief notes attempt to explain the reason for all conditional
--- 481,487 ----
Information on installing the Perl documentation in HTML format can be
found in the F<INSTALL> document.
! =head1 MANIFEST ON CYGWIN
These are the files in the Perl release that contain references to Cygwin.
These very brief notes attempt to explain the reason for all conditional
***************
*** 559,565 ****
=back
! =head1 BUGS
When I<make> starts, it warns about overriding commands for F<perlmain.o>.
--- 559,565 ----
=back
! =head1 BUGS ON CYGWIN
When I<make> starts, it warns about overriding commands for F<perlmain.o>.
diff -c /dev/null 'perl-5.7.2/README.dgux'
Index: ./README.dgux
*** ./README.dgux Thu Jan 1 02:00:00 1970
--- ./README.dgux Mon Jul 9 17:09:45 2001
***************
*** 0 ****
--- 1,117 ----
+ If you read this file _as_is_, just ignore the funny characters you
+ see. It is written in the POD format (see perlpod manpage) which is
+ specially designed to be readable as is.
+
+ =head1 NAME
+
+ perldgux - Perl under DG/UX.
+
+ =head1 SYNOPSIS
+
+ One can read this document in the following formats:
+
+ man perldgux
+ view perl perldgux
+ explorer perldgux.html
+ info perldgux
+
+ to list some (not all may be available simultaneously), or it may
+ be read I<as is>: as F<README.dgux>.
+
+ =cut
+
+ Contents
+
+ perldgux - Perl under DG/UX.
+
+ NAME
+ SYNOPSIS
+ DESCRIPTION
+ BUILD
+ - Non-threaded Case
+ - Threaded Case
+ - Testing
+ - Installing the built perl
+ AUTHOR
+ SEE ALSO
+
+ =head1 DESCRIPTION
+
+ Perl 5.7/8.x for DG/UX ix86 R4.20MU0x
+
+ =head1 BUILDING PERL ON DG/UX
+
+ =head2 Non-threaded Perl on DG/UX
+
+ Just run ./Configure script from the top directory.
+ Then give "make" to compile.
+
+ =head2 Threaded Perl on DG/UX
+
+ If you are using as compiler GCC-2.95.x rev(DG/UX)
+ an easy solution for configuring perl in your DG/UX
+ machine is to run the command:
+
+ ./Configure -Dusethreads -Duse5005threads -des
+
+ This will automatically accept all the defaults and
+ in particular /usr/local/ as installation directory.
+ Note that GCC-2.95.x rev(DG/UX) knows the switch
+ -pthread whcih allows it to link correctly DG/UX's
+ -lthread library.
+
+ If you want to change the installtion directory or
+ have a standard DG/UX with C compiler GCC-2.7.2.x
+ then you have no choice than to do an interactive
+ build by issuing the command:
+
+ ./Configure -Dusethreads -Duse5005threads
+
+ In particular with GCC-2.7.2.x accept all the defaults
+ and *watch* out for the message:
+
+ Any additional ld flags (NOT including libraries)? [ -pthread]
+
+ Instead of -pthread put here -lthread. CGCC-2.7.2.x
+ that comes with the DG/UX OS does NOT know the -pthread
+ switch. So your build will fail if you choose the defaults.
+ After configuration is done correctly give "make" to compile.
+
+ =head2 Testing Perl on DG/UX
+
+ Issuing a "make test" will run all the tests.
+ If the test lib/ftmp-security gives you as a result
+ something like
+
+ lib/ftmp-security....File::Temp::_gettemp:
+ Parent directory (/tmp/) is not safe (sticky bit not set
+ when world writable?) at lib/ftmp-security.t line 100
+
+ don't panic and just set the sticky bit in your /tmp
+ directory by doing the following as root:
+
+ cd /
+ chmod +t /tmp (=set the sticky bit to /tmp).
+
+ Then rerun the tests. This time all must be OK.
+
+ =head2 Installing the built perl on DG/UX
+
+ Run the command "make install"
+
+ =head1 AUTHOR
+
+ Takis Psarogiannakopoulos
+ Universirty of Cambridge
+ Centre for Mathematical Sciences
+ Department of Pure Mathematics
+ Wilberforce road
+ Cambridge CB3 0WB , UK
+ email <takis@xfree86.org>
+
+ =head1 SEE ALSO
+
+ perl(1).
+
+ =cut
+
diff -c 'perl-5.7.1/README.dos' 'perl-5.7.2/README.dos'
Index: ./README.dos
*** ./README.dos Tue Apr 10 05:29:17 2001
--- ./README.dos Fri Jul 13 17:18:32 2001
***************
*** 1,333 ****
! If you read this file _as_is_, just ignore the funny characters you
! see. It is written in the POD format (see perlpod manpage) which is
! specially designed to be readable as is.
!
! =head1 NAME
!
! perldos - Perl under DOS, W31, W95.
!
! =head1 SYNOPSIS
!
! These are instructions for building Perl under DOS (or w??), using
! DJGPP v2.03 or later. Under w95 long filenames are supported.
!
! =head1 DESCRIPTION
!
! Before you start, you should glance through the README file
! found in the top-level directory where the Perl distribution
! was extracted. Make sure you read and understand the terms under
! which this software is being distributed.
!
! This port currently supports MakeMaker (the set of modules that
! is used to build extensions to perl). Therefore, you should be
! able to build and install most extensions found in the CPAN sites.
!
! Detailed instructions on how to build and install perl extension
! modules, including XS-type modules, is included. See 'BUILDING AND
! INSTALLING MODULES'.
!
! =head2 Prerequisites
!
! =over 4
!
! =item DJGPP
!
! DJGPP is a port of GNU C/C++ compiler and development tools to 32-bit,
! protected-mode environment on Intel 32-bit CPUs running MS-DOS and compatible
! operating systems, by DJ Delorie <dj@delorie.com> and friends.
!
! For more details (FAQ), check out the home of DJGPP at:
!
! http://www.delorie.com/djgpp/
!
! If you have questions about DJGPP, try posting to the DJGPP newsgroup:
! comp.os.msdos.djgpp, or use the email gateway djgpp@delorie.com.
!
! You can find the full DJGPP distribution on any SimTel.Net mirror all over
! the world. Like:
!
! ftp://ftp.simtel.net/pub/simtelnet/gnu/djgpp/v2*
!
! You need the following files to build perl (or add new modules):
!
! v2/djdev203.zip
! v2/bnu2951b.zip
! v2gnu/gcc2952b.zip
! v2gnu/bsh204b.zip
! v2gnu/mak3791b.zip
! v2gnu/fil316b.zip
! v2gnu/sed302b.zip
! v2gnu/txt20b.zip
! v2gnu/dif272b.zip
! v2gnu/grep24b.zip
! v2gnu/shl112b.zip
! v2gnu/gawk303b.zip
! v2misc/csdpmi4b.zip
!
! or possibly any newer version.
!
! =item Pthreads
!
! Thread support is not tested in this version of the djgpp perl.
!
! =back
!
! =head2 Shortcomings of Perl under DOS
!
! Perl under DOS lacks some features of perl under UNIX because of
! deficiencies in the UNIX-emulation, most notably:
!
! =over 4
!
! =item *
!
! fork() and pipe()
!
! =item *
!
! some features of the UNIX filesystem regarding link count and file dates
!
! =item *
!
! in-place operation is a little bit broken with short filenames
!
! =item *
!
! sockets
!
! =back
!
! =head2 Building
!
! =over 4
!
! =item *
!
! Unpack the source package F<perl5.6*.tar.gz> with djtarx. If you want
! to use long file names under w95 and also to get Perl to pass all its
! tests, don't forget to use
!
! set LFN=y
! set FNCASE=y
!
! before unpacking the archive.
!
! =item *
!
! Create a "symlink" or copy your bash.exe to sh.exe in your C<($DJDIR)/bin>
! directory.
!
! ln -s bash.exe sh.exe
!
! [If you have the recommended version of bash for DJGPP, this is already
! done for you.]
!
! And make the C<SHELL> environment variable point to this F<sh.exe>:
!
! set SHELL=c:/djgpp/bin/sh.exe (use full path name!)
!
! You can do this in F<djgpp.env> too. Add this line BEFORE any section
! definition:
!
! +SHELL=%DJDIR%/bin/sh.exe
!
! =item *
!
! If you have F<split.exe> and F<gsplit.exe> in your path, then rename
! F<split.exe> to F<djsplit.exe>, and F<gsplit.exe> to F<split.exe>.
! Copy or link F<gecho.exe> to F<echo.exe> if you don't have F<echo.exe>.
! Copy or link F<gawk.exe> to F<awk.exe> if you don't have F<awk.exe>.
!
! [If you have the recommended versions of djdev, shell utilities and
! gawk, all these are already done for you, and you will not need to do
! anything.]
!
! =item *
!
! Chdir to the djgpp subdirectory of perl toplevel and type the following
! commands:
!
! set FNCASE=y
! configure.bat
!
! This will do some preprocessing then run the Configure script for you.
! The Configure script is interactive, but in most cases you just need to
! press ENTER. The "set" command ensures that DJGPP preserves the letter
! case of file names when reading directories. If you already issued this
! set command when unpacking the archive, and you are in the same DOS
! session as when you unpacked the archive, you don't have to issue the
! set command again. This command is necessary *before* you start to
! (re)configure or (re)build perl in order to ensure both that perl builds
! correctly and that building XS-type modules can succeed. See the DJGPP
! info entry for "_preserve_fncase" for more information:
!
! info libc alphabetical _preserve_fncase
!
! If the script says that your package is incomplete, and asks whether
! to continue, just answer with Y (this can only happen if you don't use
! long filenames or forget to issue "set FNCASE=y" first).
!
! When Configure asks about the extensions, I suggest IO and Fcntl,
! and if you want database handling then SDBM_File or GDBM_File
! (you need to install gdbm for this one). If you want to use the
! POSIX extension (this is the default), make sure that the stack
! size of your F<cc1.exe> is at least 512kbyte (you can check this
! with: C<stubedit cc1.exe>).
!
! You can use the Configure script in non-interactive mode too.
! When I built my F<perl.exe>, I used something like this:
!
! configure.bat -des
!
! You can find more info about Configure's command line switches in
! the F<INSTALL> file.
!
! When the script ends, and you want to change some values in the
! generated F<config.sh> file, then run
!
! sh Configure -S
!
! after you made your modifications.
!
! IMPORTANT: if you use this C<-S> switch, be sure to delete the CONFIG
! environment variable before running the script:
!
! set CONFIG=
!
! =item *
!
! Now you can compile Perl. Type:
!
! make
!
! =back
!
! =head2 Testing
!
! Type:
!
! make test
!
! If you're lucky you should see "All tests successful". But there can be
! a few failed subtests (less than 5 hopefully) depending on some external
! conditions (e.g. some subtests fail under linux/dosemu or plain dos
! with short filenames only).
!
! =head2 Installation
!
! Type:
!
! make install
!
! This will copy the newly compiled perl and libraries into your DJGPP
! directory structure. Perl.exe and the utilities go into C<($DJDIR)/bin>,
! and the library goes under C<($DJDIR)/lib/perl5>. The pod documentation
! goes under C<($DJDIR)/lib/perl5/pod>.
!
! =head1 BUILDING AND INSTALLING MODULES
!
!
! =head2 Prerequisites
!
! For building and installing non-XS modules, all you need is a working
! perl under DJGPP. Non-XS modules do not require re-linking the perl
! binary, and so are simpler to build and install.
!
! XS-type modules do require re-linking the perl binary, because part of
! an XS module is written in "C", and has to be linked together with the
! perl binary to be executed. This is required because perl under DJGPP
! is built with the "static link" option, due to the lack of "dynamic
! linking" in the DJGPP environment.
!
! Because XS modules require re-linking of the perl binary, you need both
! the perl binary distribution and the perl source distribution to build
! an XS extension module. In addition, you will have to have built your
! perl binary from the source distribution so that all of the components
! of the perl binary are available for the required link step.
!
! =head2 Unpacking CPAN Modules
!
! First, download the module package from CPAN (e.g., the "Comma Separated
! Value" text package, Text-CSV-0.01.tar.gz). Then expand the contents of
! the package into some location on your disk. Most CPAN modules are
! built with an internal directory structure, so it is usually safe to
! expand it in the root of your DJGPP installation. Some people prefer to
! locate source trees under /usr/src (i.e., C<($DJDIR)/usr/src>), but you may
! put it wherever seems most logical to you, *EXCEPT* under the same
! directory as your perl source code. There are special rules that apply
! to modules which live in the perl source tree that do not apply to most
! of the modules in CPAN.
!
! Unlike other DJGPP packages, which are normal "zip" files, most CPAN
! module packages are "gzipped tarballs". Recent versions of WinZip will
! safely unpack and expand them, *UNLESS* they have zero-length files. It
! is a known WinZip bug (as of v7.0) that it will not extract zero-length
! files.
!
! From the command line, you can use the djtar utility provided with DJGPP
! to unpack and expand these files. For example:
!
! C:\djgpp>djtarx -v Text-CSV-0.01.tar.gz
!
! This will create the new directory C<($DJDIR)/Text-CSV-0.01>, filling
! it with the source for this module.
!
! =head2 Building Non-XS Modules
!
! To build a non-XS module, you can use the standard module-building
! instructions distributed with perl modules.
!
! perl Makefile.PL
! make
! make test
! make install
!
! This is sufficient because non-XS modules install only ".pm" files and
! (sometimes) pod and/or man documentation. No re-linking of the perl
! binary is needed to build, install or use non-XS modules.
!
! =head2 Building XS Modules
!
! To build an XS module, you must use the standard module-building
! instructions distributed with perl modules *PLUS* three extra
! instructions specific to the DJGPP "static link" build environment.
!
! set FNCASE=y
! perl Makefile.PL
! make
! make perl
! make test
! make -f Makefile.aperl inst_perl MAP_TARGET=perl.exe
! make install
!
! The first extra instruction sets DJGPP's FNCASE environment variable so
! that the new perl binary which you must build for an XS-type module will
! build correctly. The second extra instruction re-builds the perl binary
! in your module directory before you run "make test", so that you are
! testing with the new module code you built with "make". The third extra
! instruction installs the perl binary from your module directory into the
! standard DJGPP binary directory, C<($DJDIR)/bin>, replacing your
! previous perl binary.
!
! Note that the MAP_TARGET value *must* have the ".exe" extension or you
! will not create a "perl.exe" to replace the one in C<($DJDIR)/bin>.
!
! When you are done, the XS-module install process will have added information
! to yout "perllocal" information telling that the perl binary has been replaced,
! and what module was installed. you can view this information at any time
! by using the command:
!
! perl -S perldoc perllocal
!
! =head1 AUTHOR
!
! Laszlo Molnar, F<laszlo.molnar@eth.ericsson.se> [Installing/building perl]
!
! Peter J. Farley III F<pjfarley@banet.net> [Building/installing modules]
!
! =head1 SEE ALSO
!
! perl(1).
!
! =cut
!
--- 1,332 ----
! If you read this file _as_is_, just ignore the funny characters you
! see. It is written in the POD format (see perlpod manpage) which is
! specially designed to be readable as is.
!
! =head1 NAME
!
! perldos - Perl under DOS, W31, W95.
!
! =head1 SYNOPSIS
!
! These are instructions for building Perl under DOS (or w??), using
! DJGPP v2.03 or later. Under w95 long filenames are supported.
!
! =head1 DESCRIPTION
!
! Before you start, you should glance through the README file
! found in the top-level directory where the Perl distribution
! was extracted. Make sure you read and understand the terms under
! which this software is being distributed.
!
! This port currently supports MakeMaker (the set of modules that
! is used to build extensions to perl). Therefore, you should be
! able to build and install most extensions found in the CPAN sites.
!
! Detailed instructions on how to build and install perl extension
! modules, including XS-type modules, is included. See 'BUILDING AND
! INSTALLING MODULES'.
!
! =head2 Prerequisites for Compiling Perl on DOS
!
! =over 4
!
! =item DJGPP
!
! DJGPP is a port of GNU C/C++ compiler and development tools to 32-bit,
! protected-mode environment on Intel 32-bit CPUs running MS-DOS and compatible
! operating systems, by DJ Delorie <dj@delorie.com> and friends.
!
! For more details (FAQ), check out the home of DJGPP at:
!
! http://www.delorie.com/djgpp/
!
! If you have questions about DJGPP, try posting to the DJGPP newsgroup:
! comp.os.msdos.djgpp, or use the email gateway djgpp@delorie.com.
!
! You can find the full DJGPP distribution on any SimTel.Net mirror all over
! the world. Like:
!
! ftp://ftp.simtel.net/pub/simtelnet/gnu/djgpp/v2*
!
! You need the following files to build perl (or add new modules):
!
! v2/djdev203.zip
! v2/bnu2951b.zip
! v2gnu/gcc2952b.zip
! v2gnu/bsh204b.zip
! v2gnu/mak3791b.zip
! v2gnu/fil316b.zip
! v2gnu/sed302b.zip
! v2gnu/txt20b.zip
! v2gnu/dif272b.zip
! v2gnu/grep24b.zip
! v2gnu/shl112b.zip
! v2gnu/gawk303b.zip
! v2misc/csdpmi4b.zip
!
! or possibly any newer version.
!
! =item Pthreads
!
! Thread support is not tested in this version of the djgpp perl.
!
! =back
!
! =head2 Shortcomings of Perl under DOS
!
! Perl under DOS lacks some features of perl under UNIX because of
! deficiencies in the UNIX-emulation, most notably:
!
! =over 4
!
! =item *
!
! fork() and pipe()
!
! =item *
!
! some features of the UNIX filesystem regarding link count and file dates
!
! =item *
!
! in-place operation is a little bit broken with short filenames
!
! =item *
!
! sockets
!
! =back
!
! =head2 Building Perl on DOS
!
! =over 4
!
! =item *
!
! Unpack the source package F<perl5.6*.tar.gz> with djtarx. If you want
! to use long file names under w95 and also to get Perl to pass all its
! tests, don't forget to use
!
! set LFN=y
! set FNCASE=y
!
! before unpacking the archive.
!
! =item *
!
! Create a "symlink" or copy your bash.exe to sh.exe in your C<($DJDIR)/bin>
! directory.
!
! ln -s bash.exe sh.exe
!
! [If you have the recommended version of bash for DJGPP, this is already
! done for you.]
!
! And make the C<SHELL> environment variable point to this F<sh.exe>:
!
! set SHELL=c:/djgpp/bin/sh.exe (use full path name!)
!
! You can do this in F<djgpp.env> too. Add this line BEFORE any section
! definition:
!
! +SHELL=%DJDIR%/bin/sh.exe
!
! =item *
!
! If you have F<split.exe> and F<gsplit.exe> in your path, then rename
! F<split.exe> to F<djsplit.exe>, and F<gsplit.exe> to F<split.exe>.
! Copy or link F<gecho.exe> to F<echo.exe> if you don't have F<echo.exe>.
! Copy or link F<gawk.exe> to F<awk.exe> if you don't have F<awk.exe>.
!
! [If you have the recommended versions of djdev, shell utilities and
! gawk, all these are already done for you, and you will not need to do
! anything.]
!
! =item *
!
! Chdir to the djgpp subdirectory of perl toplevel and type the following
! commands:
!
! set FNCASE=y
! configure.bat
!
! This will do some preprocessing then run the Configure script for you.
! The Configure script is interactive, but in most cases you just need to
! press ENTER. The "set" command ensures that DJGPP preserves the letter
! case of file names when reading directories. If you already issued this
! set command when unpacking the archive, and you are in the same DOS
! session as when you unpacked the archive, you don't have to issue the
! set command again. This command is necessary *before* you start to
! (re)configure or (re)build perl in order to ensure both that perl builds
! correctly and that building XS-type modules can succeed. See the DJGPP
! info entry for "_preserve_fncase" for more information:
!
! info libc alphabetical _preserve_fncase
!
! If the script says that your package is incomplete, and asks whether
! to continue, just answer with Y (this can only happen if you don't use
! long filenames or forget to issue "set FNCASE=y" first).
!
! When Configure asks about the extensions, I suggest IO and Fcntl,
! and if you want database handling then SDBM_File or GDBM_File
! (you need to install gdbm for this one). If you want to use the
! POSIX extension (this is the default), make sure that the stack
! size of your F<cc1.exe> is at least 512kbyte (you can check this
! with: C<stubedit cc1.exe>).
!
! You can use the Configure script in non-interactive mode too.
! When I built my F<perl.exe>, I used something like this:
!
! configure.bat -des
!
! You can find more info about Configure's command line switches in
! the F<INSTALL> file.
!
! When the script ends, and you want to change some values in the
! generated F<config.sh> file, then run
!
! sh Configure -S
!
! after you made your modifications.
!
! IMPORTANT: if you use this C<-S> switch, be sure to delete the CONFIG
! environment variable before running the script:
!
! set CONFIG=
!
! =item *
!
! Now you can compile Perl. Type:
!
! make
!
! =back
!
! =head2 Testing Perl on DOS
!
! Type:
!
! make test
!
! If you're lucky you should see "All tests successful". But there can be
! a few failed subtests (less than 5 hopefully) depending on some external
! conditions (e.g. some subtests fail under linux/dosemu or plain dos
! with short filenames only).
!
! =head2 Installation of Perl on DOS
!
! Type:
!
! make install
!
! This will copy the newly compiled perl and libraries into your DJGPP
! directory structure. Perl.exe and the utilities go into C<($DJDIR)/bin>,
! and the library goes under C<($DJDIR)/lib/perl5>. The pod documentation
! goes under C<($DJDIR)/lib/perl5/pod>.
!
! =head1 BUILDING AND INSTALLING MODULES ON DOS
!
! =head2 Building Prerequisites for Perl on DOS
!
! For building and installing non-XS modules, all you need is a working
! perl under DJGPP. Non-XS modules do not require re-linking the perl
! binary, and so are simpler to build and install.
!
! XS-type modules do require re-linking the perl binary, because part of
! an XS module is written in "C", and has to be linked together with the
! perl binary to be executed. This is required because perl under DJGPP
! is built with the "static link" option, due to the lack of "dynamic
! linking" in the DJGPP environment.
!
! Because XS modules require re-linking of the perl binary, you need both
! the perl binary distribution and the perl source distribution to build
! an XS extension module. In addition, you will have to have built your
! perl binary from the source distribution so that all of the components
! of the perl binary are available for the required link step.
!
! =head2 Unpacking CPAN Modules on DOS
!
! First, download the module package from CPAN (e.g., the "Comma Separated
! Value" text package, Text-CSV-0.01.tar.gz). Then expand the contents of
! the package into some location on your disk. Most CPAN modules are
! built with an internal directory structure, so it is usually safe to
! expand it in the root of your DJGPP installation. Some people prefer to
! locate source trees under /usr/src (i.e., C<($DJDIR)/usr/src>), but you may
! put it wherever seems most logical to you, *EXCEPT* under the same
! directory as your perl source code. There are special rules that apply
! to modules which live in the perl source tree that do not apply to most
! of the modules in CPAN.
!
! Unlike other DJGPP packages, which are normal "zip" files, most CPAN
! module packages are "gzipped tarballs". Recent versions of WinZip will
! safely unpack and expand them, *UNLESS* they have zero-length files. It
! is a known WinZip bug (as of v7.0) that it will not extract zero-length
! files.
!
! From the command line, you can use the djtar utility provided with DJGPP
! to unpack and expand these files. For example:
!
! C:\djgpp>djtarx -v Text-CSV-0.01.tar.gz
!
! This will create the new directory C<($DJDIR)/Text-CSV-0.01>, filling
! it with the source for this module.
!
! =head2 Building Non-XS Modules on DOS
!
! To build a non-XS module, you can use the standard module-building
! instructions distributed with perl modules.
!
! perl Makefile.PL
! make
! make test
! make install
!
! This is sufficient because non-XS modules install only ".pm" files and
! (sometimes) pod and/or man documentation. No re-linking of the perl
! binary is needed to build, install or use non-XS modules.
!
! =head2 Building XS Modules on DOS
!
! To build an XS module, you must use the standard module-building
! instructions distributed with perl modules *PLUS* three extra
! instructions specific to the DJGPP "static link" build environment.
!
! set FNCASE=y
! perl Makefile.PL
! make
! make perl
! make test
! make -f Makefile.aperl inst_perl MAP_TARGET=perl.exe
! make install
!
! The first extra instruction sets DJGPP's FNCASE environment variable so
! that the new perl binary which you must build for an XS-type module will
! build correctly. The second extra instruction re-builds the perl binary
! in your module directory before you run "make test", so that you are
! testing with the new module code you built with "make". The third extra
! instruction installs the perl binary from your module directory into the
! standard DJGPP binary directory, C<($DJDIR)/bin>, replacing your
! previous perl binary.
!
! Note that the MAP_TARGET value *must* have the ".exe" extension or you
! will not create a "perl.exe" to replace the one in C<($DJDIR)/bin>.
!
! When you are done, the XS-module install process will have added information
! to yout "perllocal" information telling that the perl binary has been replaced,
! and what module was installed. you can view this information at any time
! by using the command:
!
! perl -S perldoc perllocal
!
! =head1 AUTHOR
!
! Laszlo Molnar, F<laszlo.molnar@eth.ericsson.se> [Installing/building perl]
!
! Peter J. Farley III F<pjfarley@banet.net> [Building/installing modules]
!
! =head1 SEE ALSO
!
! perl(1).
!
! =cut
!
diff -c 'perl-5.7.1/README.epoc' 'perl-5.7.2/README.epoc'
Index: ./README.epoc
*** ./README.epoc Tue Mar 6 04:04:19 2001
--- ./README.epoc Mon Jul 9 17:09:45 2001
***************
*** 73,79 ****
=head1 USING PERL ON EPOC
! =head2 I/O Redirection
You can redirect the output with the UNIX bourne shell syntax (this is
built into perl rather then eshell) For instance the following command
--- 73,79 ----
=head1 USING PERL ON EPOC
! =head2 I/O Redirection on Epoc
You can redirect the output with the UNIX bourne shell syntax (this is
built into perl rather then eshell) For instance the following command
***************
*** 85,91 ****
Alternatively you can use 2>&1 in order to add the standard error
output to stdout.
! =head2 PATH Names
ESHELL looks for executables in ?:/System/Programs. The SIS file
installs perl in this special folder directory. The default drive and
--- 85,91 ----
Alternatively you can use 2>&1 in order to add the standard error
output to stdout.
! =head2 PATH Names on Epoc
ESHELL looks for executables in ?:/System/Programs. The SIS file
installs perl in this special folder directory. The default drive and
***************
*** 107,122 ****
perl.exe C:/test.pl >C:/output.txt
! =head2 Editors
A suitable text editor can be downloaded from symbian
http://developer.epocworld.com/downloads/progs/Editor.zip
! =head2 Features
The built-in function EPOC::getcwd returns the current directory.
! =head2 Restrictions
Features are left out, because of restrictions of the POSIX support in
EPOC:
--- 107,122 ----
perl.exe C:/test.pl >C:/output.txt
! =head2 Editors on Epoc
A suitable text editor can be downloaded from symbian
http://developer.epocworld.com/downloads/progs/Editor.zip
! =head2 Features of Perl on Epoc
The built-in function EPOC::getcwd returns the current directory.
! =head2 Restrictions of Perl on Epoc
Features are left out, because of restrictions of the POSIX support in
EPOC:
***************
*** 214,220 ****
=back
! =head1 SUPPORT STATUS
I'm offering this port "as is". You can ask me questions, but I can't
guarantee I'll be able to answer them.
--- 214,220 ----
=back
! =head1 SUPPORT STATUS OF PERL ON EPOC
I'm offering this port "as is". You can ask me questions, but I can't
guarantee I'll be able to answer them.
diff -c 'perl-5.7.1/README.hpux' 'perl-5.7.2/README.hpux'
Index: ./README.hpux
*** ./README.hpux Tue Mar 6 04:04:19 2001
--- ./README.hpux Mon Jul 9 17:09:45 2001
***************
*** 42,48 ****
The original version of PA-RISC, HP no longer sells any system with this chip.
! The following systems contain PA-RISC 1.0 chips:
600, 635, 645, 808, 815, 822, 825, 832, 834, 835, 840, 842, 845, 850, 852,
855, 860, 865, 870, 890
--- 42,48 ----
The original version of PA-RISC, HP no longer sells any system with this chip.
! The following systems contained PA-RISC 1.0 chips:
600, 635, 645, 808, 815, 822, 825, 832, 834, 835, 840, 842, 845, 850, 852,
855, 860, 865, 870, 890
***************
*** 83,89 ****
/opt/langtools/lib/sched.models. The first column corresponds to the
output of the "uname -m" command (without the leading "9000/"). The
second column is the PA-RISC version and the third column is the exact
! chip type used.
=head2 Portability Between PA-RISC Versions
--- 83,89 ----
/opt/langtools/lib/sched.models. The first column corresponds to the
output of the "uname -m" command (without the leading "9000/"). The
second column is the PA-RISC version and the third column is the exact
! chip type used. (Start browsing at the bottom to prevent confusion ;-)
=head2 Portability Between PA-RISC Versions
***************
*** 94,105 ****
+DS32 should be used.
It is no longer possible to compile PA-RISC 1.0 executables on either
! the PA-RISC 1.1 or 2.0 platforms.
=head2 Building Dynamic Extensions on HP-UX
HP-UX supports dynamically loadable libraries (shared libraries).
! Shared libraries end with the suffix .sl.
Shared libraries created on a platform using a particular PA-RISC
version are not usable on platforms using an earlier PA-RISC version by
--- 94,120 ----
+DS32 should be used.
It is no longer possible to compile PA-RISC 1.0 executables on either
! the PA-RISC 1.1 or 2.0 platforms. The command-line flags are accepted,
! but the resulting executable will not run when transferred to a PA-RISC
! 1.0 system.
+ =head2 Itanium Processor Family and HP-UX
+
+ HP-UX also runs on the new Itanium processor. This requires the use
+ of a different version of HP-UX (currently 11.20), and with the exception
+ of a few differences detailed below and in later sections, Perl should
+ compile with no problems.
+
+ Although PA-RISC binaries can run on Itanium systems, you should not
+ attempt to use a PA-RISC version of Perl on an Itanium system. This is
+ because shared libraries created on an Itanium system cannot be loaded
+ while running a PA-RISC executable.
+
=head2 Building Dynamic Extensions on HP-UX
HP-UX supports dynamically loadable libraries (shared libraries).
! Shared libraries end with the suffix .sl. On Itanium systems,
! they end with the suffix .so.
Shared libraries created on a platform using a particular PA-RISC
version are not usable on platforms using an earlier PA-RISC version by
***************
*** 107,112 ****
--- 122,133 ----
same +DAportable compiler flag (with the same PA-RISC 1.0 caveat
mentioned above).
+ Shared libraries created on an Itanium platform cannot be loaded on
+ a PA-RISC platform. Shared libraries created on a PA-RISC platform
+ can only be loaded on an Itanium platform if it is a PA-RISC executable
+ that is attempting to load the PA-RISC library. A PA-RISC shared
+ library cannot be loaded into an Itanium executable nor vice-versa.
+
To create a shared library, the following steps must be performed:
1. Compile source modules with +z or +Z flag to create a .o module
***************
*** 140,154 ****
Note that it is okay to create a library which contains a dependent
library that is already linked into perl.
! It is no longer possible to link PA-RISC 1.0 shared libraries.
=head2 The HP ANSI C Compiler
When using this compiler to build Perl, you should make sure that the
flag -Aa is added to the cpprun and cppstdin variables in the config.sh
! file (though see the section on 64-bit perl below).
! =head2 Using Large Files with Perl
Beginning with HP-UX version 10.20, files larger than 2GB (2^31 bytes)
may be created and manipulated. Three separate methods of doing this
--- 161,219 ----
Note that it is okay to create a library which contains a dependent
library that is already linked into perl.
! Some extensions, like DB_File and Compress::Zlib use/require prebuilt
! libraries for the perl extensions/modules to work. If these libraries
! are built using the default configuration, it might happen that you run
! into an error like "invalid loader fixup" during load phase. HP is aware
! of this problem and address it at
! http://devresource.hp.com/devresource/Docs/TechTips/cxxTips.html#tip13
+ A more general approach is to intervene manually, as with an example for
+ the DB_File module, which requires SleepyCat's libdb.sl:
+
+ # cd .../db-3.2.9/build_unix
+ # vi Makefile
+ ... add +Z to all cflags to create shared objects
+ CFLAGS= -c $(CPPFLAGS) +Z -Ae +O2 +Onolimit \
+ -I/usr/local/include -I/usr/include/X11R6
+ CXXFLAGS= -c $(CPPFLAGS) +Z -Ae +O2 +Onolimit \
+ -I/usr/local/include -I/usr/include/X11R6
+
+ # make clean
+ # make
+ # mkdir tmp
+ # cd tmp
+ # ar x ../libdb.a
+ # ld -b -o libdb-3.2.sl *.o
+ # mv libdb-3.2.sl /usr/local/lib
+ # rm *.o
+ # cd /usr/local/lib
+ # rm -f libdb.sl
+ # ln -s libdb-3.2.sl libdb.sl
+
+ # cd .../DB_File-1.76
+ # make distclean
+ # perl Makefile.PL
+ # make
+ # make test
+ # make install
+
+ It is no longer possible to link PA-RISC 1.0 shared libraries (even
+ though the command-line flags are still present).
+
+ PA-RISC and Itanium object files are not interchangeable. Although
+ you may be able to use ar to create an archive library of PA-RISC
+ object files on an Itanium system, you cannot link against it using
+ an Itanium link editor.
+
=head2 The HP ANSI C Compiler
When using this compiler to build Perl, you should make sure that the
flag -Aa is added to the cpprun and cppstdin variables in the config.sh
! file (though see the section on 64-bit perl below). If you are using a
! recent version of the Perl distribution, these flags are set automatically.
! =head2 Using Large Files with Perl on HP-UX
Beginning with HP-UX version 10.20, files larger than 2GB (2^31 bytes)
may be created and manipulated. Three separate methods of doing this
***************
*** 183,189 ****
large files when Configure asks you, you may get a configuration that
cannot be compiled, or that does not function as expected.
! =head2 Threaded Perl
It is possible to compile a version of threaded Perl on any version of
HP-UX before 10.30, but it is strongly suggested that you be running on
--- 248,254 ----
large files when Configure asks you, you may get a configuration that
cannot be compiled, or that does not function as expected.
! =head2 Threaded Perl on HP-UX
It is possible to compile a version of threaded Perl on any version of
HP-UX before 10.30, but it is strongly suggested that you be running on
***************
*** 192,202 ****
To compile Perl with threads, add -Dusethreads to the arguments of
Configure. Verify that the -D_POSIX_C_SOURCE=199506L compiler flag is
automatically added to the list of flags. Also make sure that -lpthread
! is listed before -lc in the list of libraries to link Perl with.
- As of the date of this document, Perl threads are not fully supported on
- HP-UX.
-
HP-UX versions before 10.30 require a seperate installation of a POSIX
threads library package. Two examples are the HP DCE package, available
on "HP-UX Hardware Extensions 3.0, Install and Core OS, Release 10.20,
--- 257,266 ----
To compile Perl with threads, add -Dusethreads to the arguments of
Configure. Verify that the -D_POSIX_C_SOURCE=199506L compiler flag is
automatically added to the list of flags. Also make sure that -lpthread
! is listed before -lc in the list of libraries to link Perl with. The
! hints provided for HP-UX during Configure will try very hard to get
! this right for you.
HP-UX versions before 10.30 require a seperate installation of a POSIX
threads library package. Two examples are the HP DCE package, available
on "HP-UX Hardware Extensions 3.0, Install and Core OS, Release 10.20,
***************
*** 204,210 ****
though worldwide HP-UX mirrors of precompiled packages
(e.g. http://hpux.tn.tudelft.nl/hppd/hpux/alpha.html)
! =head2 64-bit Perl
Beginning with HP-UX 11.00, programs compiled under HP-UX can take
advantage of the LP64 programming environment (LP64 means Longs and
--- 268,274 ----
though worldwide HP-UX mirrors of precompiled packages
(e.g. http://hpux.tn.tudelft.nl/hppd/hpux/alpha.html)
! =head2 64-bit Perl on HP-UX
Beginning with HP-UX 11.00, programs compiled under HP-UX can take
advantage of the LP64 programming environment (LP64 means Longs and
***************
*** 235,241 ****
compiler. If you want to compile Perl using gcc, you will have to get a
version of the compiler that support 64-bit operations.)
! =head2 GDBM and Threads
If you attempt to compile Perl with threads on an 11.X system and also
link in the GDBM library, then Perl will immediately core dump when it
--- 299,305 ----
compiler. If you want to compile Perl using gcc, you will have to get a
version of the compiler that support 64-bit operations.)
! =head2 GDBM and Threads on HP-UX
If you attempt to compile Perl with threads on an 11.X system and also
link in the GDBM library, then Perl will immediately core dump when it
***************
*** 242,254 ****
starts up. The only workaround at this point is to relink the GDBM
library under 11.X, then relink it into Perl.
! =head2 NFS filesystems and utime(2)
If you are compiling Perl on a remotely-mounted NFS filesystem, the test
io/fs.t may fail on test #18. This appears to be a bug in HP-UX and no
fix is currently available.
! =head2 perl -P and //
In HP-UX Perl is compiled with flags that will cause problems if the
-P flag of Perl (preprocess Perl code with the C preprocessor before
--- 306,318 ----
starts up. The only workaround at this point is to relink the GDBM
library under 11.X, then relink it into Perl.
! =head2 NFS filesystems and utime(2) on HP-UX
If you are compiling Perl on a remotely-mounted NFS filesystem, the test
io/fs.t may fail on test #18. This appears to be a bug in HP-UX and no
fix is currently available.
! =head2 perl -P and // and HP-UX
In HP-UX Perl is compiled with flags that will cause problems if the
-P flag of Perl (preprocess Perl code with the C preprocessor before
***************
*** 267,272 ****
--- 331,353 ----
s!foo!!;
+ =head2 HP-UX Kernel Parameters (maxdsiz) for Compiling Perl
+
+ By default, HP-UX comes configured with a maximum data segment size of
+ 64MB. This is too small to correctly compile Perl with the maximum
+ optimization levels. You can increase the size of the maxdsiz kernel
+ parameter through the use of SAM.
+
+ When using the GUI version of SAM, click on the Kernel Configuration
+ icon, then the Configurable Parameters icon. Scroll down and select
+ the maxdsiz line. From the Actions menu, select the Modify Configurable
+ Parameter item. Insert the new formula into the Formula/Value box.
+ Then follow the instructions to rebuild your kernel and reboot your
+ system.
+
+ In general, a value of 256MB (or "256*1024*1024") is sufficient for
+ Perl to compile at maximum optimization.
+
=head1 AUTHOR
Jeff Okamoto <okamoto@corp.hp.com>
***************
*** 275,280 ****
=head1 DATE
! Version 0.6.2: 2001-02-02
=cut
--- 356,361 ----
=head1 DATE
! Version 0.6.3: 2001-05-16
=cut
diff -c 'perl-5.7.1/README.hurd' 'perl-5.7.2/README.hurd'
Index: ./README.hurd
*** ./README.hurd Tue Mar 6 04:04:19 2001
--- ./README.hurd Mon Jul 9 17:09:45 2001
***************
*** 1,13 ****
! Notes on Perl on the Hurd
! Last Updated: Fri, 29 Oct 1999 22:50:30 +0200
! Written by: Mark Kettenis <kettenis@gnu.org>
If you want to use Perl on the Hurd, I recommend using the Debian
GNU/Hurd distribution (see http://www.debian.org), even if an
official, stable release has not yet been made. The old `gnu-0.2'
binary distribution will most certainly have additional problems.
! * Known Problems
The Perl test suite may still report some errors on the Hurd. The
`lib/anydbm' and `pragma/warnings' tests will almost certainly fail.
--- 1,19 ----
! If you read this file _as_is_, just ignore the funny characters you see.
! It is written in the POD format (see pod/perlpod.pod) which is specially
! designed to be readable as is.
+ =head1 NAME
+
+ README.hurd - Perl version 5 on Hurd
+
+ =head1 DESCRIPTION
+
If you want to use Perl on the Hurd, I recommend using the Debian
GNU/Hurd distribution (see http://www.debian.org), even if an
official, stable release has not yet been made. The old `gnu-0.2'
binary distribution will most certainly have additional problems.
! =head2 Known Problems with Perl on Hurd
The Perl test suite may still report some errors on the Hurd. The
`lib/anydbm' and `pragma/warnings' tests will almost certainly fail.
***************
*** 21,33 ****
Here are the statistics for Perl 5.005_62 on my system:
! Failed Test Status Wstat Total Fail Failed List of failed
! -------------------------------------------------------------------------------
! lib/anydbm.t 12 1 8.33% 12
! pragma/warnings 333 1 0.30% 215
! 8 tests and 24 subtests skipped.
! Failed 2/229 test scripts, 99.13% okay. 2/10850 subtests failed, 99.98% okay.
There are quite a few systems out there that do worse!
However, since I am running a very recent Hurd snapshot, in which a lot of
--- 27,40 ----
Here are the statistics for Perl 5.005_62 on my system:
! Failed Test Status Wstat Total Fail Failed List of failed
! -------------------------------------------------------------------------
! lib/anydbm.t 12 1 8.33% 12
! pragma/warnings 333 1 0.30% 215
+ 8 tests and 24 subtests skipped.
+ Failed 2/229 test scripts, 99.13% okay. 2/10850 subtests failed, 99.98% okay.
+
There are quite a few systems out there that do worse!
However, since I am running a very recent Hurd snapshot, in which a lot of
***************
*** 38,40 ****
--- 45,54 ----
In any way, if you're seeing failures beyond those mentioned in this
document, please consider upgrading to the latest Hurd before reporting
the failure as a bug.
+
+ =head1 AUTHOR
+
+ Mark Kettenis <kettenis@gnu.org>
+
+ Last Updated: Fri, 29 Oct 1999 22:50:30 +0200
+
diff -c 'perl-5.7.1/README.machten' 'perl-5.7.2/README.machten'
Index: ./README.machten
*** ./README.machten Tue Mar 6 04:04:19 2001
--- ./README.machten Mon Jul 9 17:09:45 2001
***************
*** 31,37 ****
For much more information on building perl -- for example, on how to
change the default installation directory -- see F<INSTALL>.
! =head2 Failures during C<make test>
=over 4
--- 31,37 ----
For much more information on building perl -- for example, on how to
change the default installation directory -- see F<INSTALL>.
! =head2 Failures during C<make test> on MachTen
=over 4
***************
*** 57,63 ****
=back
! =head2 Building external modules
To add an external module to perl, build in the normal way, which
is documented in L<ExtUtils::MakeMaker>, or which can be driven
--- 57,63 ----
=back
! =head2 Building external modules on MachTen
To add an external module to perl, build in the normal way, which
is documented in L<ExtUtils::MakeMaker>, or which can be driven
diff -c 'perl-5.7.1/README.macos' 'perl-5.7.2/README.macos'
Index: ./README.macos
*** ./README.macos Fri Apr 6 16:18:30 2001
--- ./README.macos Mon Jul 9 17:09:45 2001
***************
*** 6,12 ****
README.macos - Perl under Mac OS (Classic)
-
=head1 SYNOPSIS
This document briefly describes perl under Mac OS (Classic).
--- 6,11 ----
***************
*** 16,22 ****
When we say "Mac OS" below, we mean pre-Mac OS X, which includes
Mac OS 7, 8, and 9.
-
=head1 DESCRIPTION
The perl 5.6.1 source itself builds on Mac OS, with some additional
--- 15,20 ----
***************
*** 47,59 ****
MacPerl 5.2.0r4 is available on the CPAN and on SourceForge. It
is based on perl 5.004.
-
=head1 AUTHOR
perl was ported to Mac OS by Matthias Neeracher
E<lt>neeracher@mac.comE<gt>. It is currently maintained by Chris
Nandor E<lt>pudge@pobox.comE<gt>.
-
=head1 DATE
--- 45,55 ----
diff -c 'perl-5.7.1/README.micro' 'perl-5.7.2/README.micro'
Index: ./README.micro
*** ./README.micro Tue Mar 6 04:04:19 2001
--- ./README.micro Mon Jul 9 17:09:45 2001
***************
*** 4,9 ****
operating system are left very -- minimal.
All this is experimental. If you don't know what to do with microperl
! you probably shouldn't.
--- 4,15 ----
operating system are left very -- minimal.
All this is experimental. If you don't know what to do with microperl
! you probably shouldn't. Do not report bugs in microperl; fix the bugs.
!
! If you are still reading this and you are itching to try out microperl:
!
! make -f Makefile.micro
!
!
diff -c 'perl-5.7.1/README.mint' 'perl-5.7.2/README.mint'
Index: ./README.mint
*** ./README.mint Tue Mar 6 04:04:19 2001
--- ./README.mint Mon Jul 9 17:09:45 2001
***************
*** 1,7 ****
! ##########################################################################
! # *** README.mint
! ##########################################################################
If you want to build perl yourself on MiNT (or maybe on an Atari without
MiNT) you may want to accept some advice from somebody who already did it...
--- 1,13 ----
! If you read this file _as_is_, just ignore the funny characters you see.
! It is written in the POD format (see pod/perlpod.pod) which is specially
! designed to be readable as is.
+ =head1 NAME
+
+ README.mint - Perl version 5 on Atari MiNT
+
+ =head1 DESCRIPTION
+
If you want to build perl yourself on MiNT (or maybe on an Atari without
MiNT) you may want to accept some advice from somebody who already did it...
***************
*** 23,30 ****
standard envariables like $PATH, $HOME, ... are set, there is a
POSIX compliant shell in /bin/sh, and...)
! Known problems
! ==============
The problems you may encounter when building perl on your machine
are most probably due to deficiencies in MiNT resp. the Atari
--- 29,35 ----
standard envariables like $PATH, $HOME, ... are set, there is a
POSIX compliant shell in /bin/sh, and...)
! =head1 Known problems with Perl on MiNT
The problems you may encounter when building perl on your machine
are most probably due to deficiencies in MiNT resp. the Atari
***************
*** 210,216 ****
Have fun with Perl!
Guido Flohr
! --
! mailto:gufl0000@stud.uni-sb.de
! http://stud.uni-sb.de/~gufl0000
--- 215,224 ----
Have fun with Perl!
+ =head1 AUTHOR
+
Guido Flohr
!
! mailto:gufl0000@stud.uni-sb.de
! http://stud.uni-sb.de/~gufl0000
!
diff -c 'perl-5.7.1/README.mpeix' 'perl-5.7.2/README.mpeix'
Index: ./README.mpeix
*** ./README.mpeix Tue Mar 6 04:04:19 2001
--- ./README.mpeix Mon Jul 9 17:09:45 2001
***************
*** 5,26 ****
=head1 NAME
README.mpeix - Perl/iX for HP e3000 MPE
!
=head1 SYNOPSIS
http://www.bixby.org/mark/perlix.html
Perl language for MPE
Last updated June 2, 2000 @ 0400 UTC
!
=head1 NOTE
This is a podified version of the above-mentioned web page,
podified by Jarkko Hietaniemi 2001-Jan-01.
! =head1 What's New
June 1, 2000
!
=over 4
=item *
--- 5,26 ----
=head1 NAME
README.mpeix - Perl/iX for HP e3000 MPE
!
=head1 SYNOPSIS
http://www.bixby.org/mark/perlix.html
Perl language for MPE
Last updated June 2, 2000 @ 0400 UTC
!
=head1 NOTE
This is a podified version of the above-mentioned web page,
podified by Jarkko Hietaniemi 2001-Jan-01.
! =head1 What's New in Perl ffor MPE/iX
June 1, 2000
!
=over 4
=item *
***************
*** 27,33 ****
Rebuilt to be compatible with mod_perl. If you plan on using
mod_perl, you MUST download and install this version of Perl/iX!
!
=item *
bincompat5005="undef": sorry, but you will have to recompile any
--- 27,33 ----
Rebuilt to be compatible with mod_perl. If you plan on using
mod_perl, you MUST download and install this version of Perl/iX!
!
=item *
bincompat5005="undef": sorry, but you will have to recompile any
***************
*** 34,40 ****
binary 5.005 extensions that you may be using (if any; there is no
5.005 code in what you download from bixby.org)
uselargefiles="undef": not available in MPE for POSIX files yet.
!
=item *
Now bundled with various add-on packages:
--- 34,40 ----
binary 5.005 extensions that you may be using (if any; there is no
5.005 code in what you download from bixby.org)
uselargefiles="undef": not available in MPE for POSIX files yet.
!
=item *
Now bundled with various add-on packages:
***************
*** 48,59 ****
=item *
libwww-perl (LWP) which lets Perl programs behave like web browsers:
!
1. #!/PERL/PUB/perl
2. use LWP::Simple;
3. $doc = get('http://www.bixby.org/mark/perlix.html'); # reads the
web page into variable $doc
!
(http://www.bixby.org/mark/perlix.html)
=item *
--- 48,59 ----
=item *
libwww-perl (LWP) which lets Perl programs behave like web browsers:
!
1. #!/PERL/PUB/perl
2. use LWP::Simple;
3. $doc = get('http://www.bixby.org/mark/perlix.html'); # reads the
web page into variable $doc
!
(http://www.bixby.org/mark/perlix.html)
=item *
***************
*** 62,70 ****
soon with Apache/iX 1.3.12 from bixby.org). This module allows you to
write high performance persistent Perl CGI scripts and all sorts of
cool things. (http://perl.apache.org/)
!
and much much more hiding under /PERL/PUB/.cpan/
!
=item *
The CPAN module now works for automatic downloading and
--- 62,70 ----
soon with Apache/iX 1.3.12 from bixby.org). This module allows you to
write high performance persistent Perl CGI scripts and all sorts of
cool things. (http://perl.apache.org/)
!
and much much more hiding under /PERL/PUB/.cpan/
!
=item *
The CPAN module now works for automatic downloading and
***************
*** 73,79 ****
1. export FTP_PASSIVE=1
2. perl -MCPAN -e shell
3. Ignore any terminal I/O related complaints!
!
(http://theoryx5.uwinnipeg.ca/CPAN/data/perl/CPAN.html)
=back
--- 73,79 ----
1. export FTP_PASSIVE=1
2. perl -MCPAN -e shell
3. Ignore any terminal I/O related complaints!
!
(http://theoryx5.uwinnipeg.ca/CPAN/data/perl/CPAN.html)
=back
***************
*** 92,98 ****
Perl's getpwnam() function which had regressed to being
unimplemented on MPE is now implemented once again.
!
=back
September 17, 1999
--- 92,98 ----
Perl's getpwnam() function which had regressed to being
unimplemented on MPE is now implemented once again.
!
=back
September 17, 1999
***************
*** 104,112 ****
Migrated from cccd.edu to bixby.org.
=back
-
- =head1 Welcome
This is the official home page for the HP e3000 MPE/iX
(http://www.businessservers.hp.com/) port of the Perl scripting
language (http://www.perl.com/) which gives you all of the power of C,
--- 104,112 ----
Migrated from cccd.edu to bixby.org.
=back
+ =head1 Welcome to Perl/iX
+
This is the official home page for the HP e3000 MPE/iX
(http://www.businessservers.hp.com/) port of the Perl scripting
language (http://www.perl.com/) which gives you all of the power of C,
***************
*** 115,141 ****
about major milestones will also be posted to the HP3000-L mailing list
(http://www.lsoft.com/scripts/wl.exe?SL1=HP3000-L&H=RAVEN.UTC.EDU) and
its associated gatewayed newsgroup comp.sys.hp.mpe.
!
I'm doing this port because I can't live without Perl on the Unix
machines that I administer, and I want to have the same power
available to me on MPE.
!
Please send your comments, questions, and bug reports directly to me,
Mark Bixby (http://www.bixby.org/mark/), by e-mailing to
mark@bixby.org. Or just post them to HP3000-L.
!
The platform I'm using to do this port is an HP 3000 957RX running
MPE/iX 6.0 and using the GNU gcc C compiler
(http://jazz.external.hp.com/src/gnu/gnuframe.html).
!
The combined porting wisdom from all of my ports can be found in my
MPE/iX Porting Guide (http://www.bixby.org/mark/porting.html).
!
IMPORTANT NOTICE: Yes, I do work for the HP CSY R&D lab, but ALL of
the software you download from bixby.org is my personal freeware that
is NOT supported by HP.
! =head1 System Requirements
=over 4
--- 115,141 ----
about major milestones will also be posted to the HP3000-L mailing list
(http://www.lsoft.com/scripts/wl.exe?SL1=HP3000-L&H=RAVEN.UTC.EDU) and
its associated gatewayed newsgroup comp.sys.hp.mpe.
!
I'm doing this port because I can't live without Perl on the Unix
machines that I administer, and I want to have the same power
available to me on MPE.
!
Please send your comments, questions, and bug reports directly to me,
Mark Bixby (http://www.bixby.org/mark/), by e-mailing to
mark@bixby.org. Or just post them to HP3000-L.
!
The platform I'm using to do this port is an HP 3000 957RX running
MPE/iX 6.0 and using the GNU gcc C compiler
(http://jazz.external.hp.com/src/gnu/gnuframe.html).
!
The combined porting wisdom from all of my ports can be found in my
MPE/iX Porting Guide (http://www.bixby.org/mark/porting.html).
!
IMPORTANT NOTICE: Yes, I do work for the HP CSY R&D lab, but ALL of
the software you download from bixby.org is my personal freeware that
is NOT supported by HP.
! =head1 System Requirements for Perl/iX
=over 4
***************
*** 192,203 ****
=item 5.
Convert your *.a system archive libraries to *.sl shared libraries
!
=back
Download Perl using FTP.ARPA.SYS from your HP 3000 (the preferred
method).....
!
:HELLO MANAGER.SYS
:XEQ FTP.ARPA.SYS
open ftp.bixby.org
--- 192,203 ----
=item 5.
Convert your *.a system archive libraries to *.sl shared libraries
!
=back
Download Perl using FTP.ARPA.SYS from your HP 3000 (the preferred
method).....
!
:HELLO MANAGER.SYS
:XEQ FTP.ARPA.SYS
open ftp.bixby.org
***************
*** 210,216 ****
.....Or download using some other generic web or ftp client (the alternate
method)
!
Download the following files (make sure that you use "binary mode" or
whatever client feature that is 8-bit clean):
--- 210,216 ----
.....Or download using some other generic web or ftp client (the alternate
method)
!
Download the following files (make sure that you use "binary mode" or
whatever client feature that is 8-bit clean):
***************
*** 225,241 ****
or
ftp://ftp.bixby.org/pub/mpe/perl-5.6.0-mpe.tar.Z
!
=item *
Upload those files to your HP 3000 in an 8-bit clean bytestream manner to:
/tmp/perl.tar.Z
!
=item *
Then extract the installation script (after both download methods)
!
:CHDIR /tmp
:XEQ TAR.HPBIN.SYS 'xvfopz /tmp/perl.tar.Z INSTALL'
--- 225,241 ----
or
ftp://ftp.bixby.org/pub/mpe/perl-5.6.0-mpe.tar.Z
!
=item *
Upload those files to your HP 3000 in an 8-bit clean bytestream manner to:
/tmp/perl.tar.Z
!
=item *
Then extract the installation script (after both download methods)
!
:CHDIR /tmp
:XEQ TAR.HPBIN.SYS 'xvfopz /tmp/perl.tar.Z INSTALL'
***************
*** 242,248 ****
=item *
Edit the installation script
!
Examine the accounting structure creation commands and modify if
necessary (adding additional capabilities, choosing a non-system
volume set, etc).
--- 242,248 ----
=item *
Edit the installation script
!
Examine the accounting structure creation commands and modify if
necessary (adding additional capabilities, choosing a non-system
volume set, etc).
***************
*** 252,258 ****
=item *
Run the installation script.
!
The accounting structure will be created and then all files will be
extracted from the archive.
--- 252,258 ----
=item *
Run the installation script.
!
The accounting structure will be created and then all files will be
extracted from the archive.
***************
*** 261,267 ****
=item *
Convert your *.a system archive libraries to *.sl shared libraries
!
You only have to do this ONCE on your MPE/iX 5.5 machine in order to
convert /lib/lib*.a and /usr/lib/lib*.a libraries to their *.sl
equivalents. This step should not be necessary on MPE/iX 6.0 or later
--- 261,267 ----
=item *
Convert your *.a system archive libraries to *.sl shared libraries
!
You only have to do this ONCE on your MPE/iX 5.5 machine in order to
convert /lib/lib*.a and /usr/lib/lib*.a libraries to their *.sl
equivalents. This step should not be necessary on MPE/iX 6.0 or later
***************
*** 271,277 ****
=back
! =head1 Distribution Contents Highlights
=over 4
--- 271,277 ----
=back
! =head1 Perl/iX Distribution Contents Highlights
=over 4
***************
*** 278,305 ****
=item README
The file you're reading now.
!
=item INSTALL
Perl/iX Installation script.
!
=item LIBSHP3K
Script to convert *.a system archive libraries to *.sl shared libraries.
!
=item PERL
Perl NMPRG executable. A version-numbered backup copy also
exists. You might wish to "ln -s /PERL/PUB/PERL /usr/local/bin/perl".
!
=item .cpan/
Much add-on source code downloaded with the CPAN module.
!
=item lib/
Perl libraries, both core and add-on.
!
=item man/
Perl man page documentation.
--- 278,305 ----
=item README
The file you're reading now.
!
=item INSTALL
Perl/iX Installation script.
!
=item LIBSHP3K
Script to convert *.a system archive libraries to *.sl shared libraries.
!
=item PERL
Perl NMPRG executable. A version-numbered backup copy also
exists. You might wish to "ln -s /PERL/PUB/PERL /usr/local/bin/perl".
!
=item .cpan/
Much add-on source code downloaded with the CPAN module.
!
=item lib/
Perl libraries, both core and add-on.
!
=item man/
Perl man page documentation.
***************
*** 307,319 ****
=item public_html/feedback.cgi
Sample feedback CGI form written in Perl.
!
=item src/perl-5.6.0-mpe
Source code.
=back
!
=head1 How to Compile Perl/iX
=over 4
--- 307,319 ----
=item public_html/feedback.cgi
Sample feedback CGI form written in Perl.
!
=item src/perl-5.6.0-mpe
Source code.
=back
!
=head1 How to Compile Perl/iX
=over 4
***************
*** 352,358 ****
Optionally create symbolic links that point to the Perl
executable, i.e. ln -s /PERL/PUB/PERL /usr/local/bin/perl
!
=back
The summary test results from "cd t; ./perl -I../lib harness":
--- 352,358 ----
Optionally create symbolic links that point to the Perl
executable, i.e. ln -s /PERL/PUB/PERL /usr/local/bin/perl
!
=back
The summary test results from "cd t; ./perl -I../lib harness":
***************
*** 374,380 ****
Create your Perl script files with "#!/PERL/PUB/perl" (or an
equivalent symbolic link) as the first line. Use the chmod command to
make sure that your script has execute permission. Run your script!
!
Be sure to take a look at the CPAN module list
(http://www.cpan.org/CPAN.html). A wide variety of free Perl software
is available. You can automatically download these packages by using
--- 374,380 ----
Create your Perl script files with "#!/PERL/PUB/perl" (or an
equivalent symbolic link) as the first line. Use the chmod command to
make sure that your script has execute permission. Run your script!
!
Be sure to take a look at the CPAN module list
(http://www.cpan.org/CPAN.html). A wide variety of free Perl software
is available. You can automatically download these packages by using
***************
*** 435,447 ****
GETPRIVMODE() solution similar to bind().
=back
-
- =head1 Known Bugs Under Investigation
None.
-
- =head1 To-Do List
=over 4
=item *
--- 435,447 ----
GETPRIVMODE() solution similar to bind().
=back
+ =head1 Known Perl/iX Bugs Under Investigation
+
None.
+ =head1 Perl/iX To-Do List
+
=over 4
=item *
***************
*** 460,472 ****
Write an MPE XS extension library containing miscellaneous important
MPE functions like GETPRIVMODE(), GETUSERMODE(), and sfcntl().
!
=back
! =head1 Change History
May 6, 1999
!
=over 4
=item *
--- 460,472 ----
Write an MPE XS extension library containing miscellaneous important
MPE functions like GETPRIVMODE(), GETUSERMODE(), and sfcntl().
!
=back
! =head1 Perl/iX Change History
May 6, 1999
!
=over 4
=item *
***************
*** 473,479 ****
Patch LBCJXT6A is required on MPE/iX 5.5 machines in order to prevent
Perl/iX from dying with an unresolved external reference to _getenv_libc.
!
=back
April 7, 1999
--- 473,479 ----
Patch LBCJXT6A is required on MPE/iX 5.5 machines in order to prevent
Perl/iX from dying with an unresolved external reference to _getenv_libc.
!
=back
April 7, 1999
***************
*** 498,504 ****
The LIBSHP3K *.a -> *.sl library conversion script is now included
as /PERL/PUB/LIBSHP3K.
!
=back
November 20, 1998
--- 498,504 ----
The LIBSHP3K *.a -> *.sl library conversion script is now included
as /PERL/PUB/LIBSHP3K.
!
=back
November 20, 1998
***************
*** 527,535 ****
The current incarnation of the POSIX filename extended characters
patch is now MPEKXJ3A.
!
=back
!
August 14, 1998
=over 4
--- 527,535 ----
The current incarnation of the POSIX filename extended characters
patch is now MPEKXJ3A.
!
=back
!
August 14, 1998
=over 4
***************
*** 538,546 ****
The previous POSIX filename extended characters patch MPEKX44C has
been superseded by MPEKXB5A.
!
=back
!
August 7, 1998
=over 4
--- 538,546 ----
The previous POSIX filename extended characters patch MPEKX44C has
been superseded by MPEKXB5A.
!
=back
!
August 7, 1998
=over 4
***************
*** 549,567 ****
The previous POSIX filename extended characters patch MPEKX76A has
been superseded by MPEKX44C.
-
- =over 4
=back
!
July 28, 1998
=item *
Updated to version 5.005_01.
!
=back
!
July 23, 1998
=over 4
--- 549,567 ----
The previous POSIX filename extended characters patch MPEKX76A has
been superseded by MPEKX44C.
=back
!
July 28, 1998
+ =over 4
+
=item *
Updated to version 5.005_01.
!
=back
!
July 23, 1998
=over 4
***************
*** 570,578 ****
Updated to version 5.005 (production release). The public
freeware sources are now 100% MPE-ready "straight out of the box".
!
=back
!
July 17, 1998
=over 4
--- 570,578 ----
Updated to version 5.005 (production release). The public
freeware sources are now 100% MPE-ready "straight out of the box".
!
=back
!
July 17, 1998
=over 4
***************
*** 588,596 ****
=item *
My MPE binary release is now extracted using my standard INSTALL script.
!
=back
!
July 15, 1998
=over 4
--- 588,596 ----
=item *
My MPE binary release is now extracted using my standard INSTALL script.
!
=back
!
July 15, 1998
=over 4
***************
*** 599,607 ****
Changed startperl to #!/PERL/PUB/perl so that Perl will recognize
scripts more easily and efficiently.
!
=back
!
July 8, 1998
=over 4
--- 599,607 ----
Changed startperl to #!/PERL/PUB/perl so that Perl will recognize
scripts more easily and efficiently.
!
=back
!
July 8, 1998
=over 4
***************
*** 614,622 ****
was strictly internal to me and never publicly released. Note that
[21]BIND/iX is now required (well, the include files and libbind.a) if
you wish to compile Perl/iX.
!
=back
!
November 6, 1997
=over 4
--- 614,622 ----
was strictly internal to me and never publicly released. Note that
[21]BIND/iX is now required (well, the include files and libbind.a) if
you wish to compile Perl/iX.
!
=back
!
November 6, 1997
=over 4
***************
*** 624,632 ****
=item *
Updated to version 5.004_04. No changes in MPE-specific functionality.
!
=back
!
October 16, 1997
=over 4
--- 624,632 ----
=item *
Updated to version 5.004_04. No changes in MPE-specific functionality.
!
=back
!
October 16, 1997
=over 4
***************
*** 635,643 ****
Added Demos section to the Perl/iX home page so you can see some
sample Perl applications running on my 3000.
!
=back
!
October 3, 1997
=over 4
--- 635,643 ----
Added Demos section to the Perl/iX home page so you can see some
sample Perl applications running on my 3000.
!
=back
!
October 3, 1997
=over 4
***************
*** 646,654 ****
Added System Requirements section to the Perl/iX home page just so the
prerequisites stand out more. Various other home page tweaks.
!
=back
!
October 2, 1997
=over 4
--- 646,654 ----
Added System Requirements section to the Perl/iX home page just so the
prerequisites stand out more. Various other home page tweaks.
!
=back
!
October 2, 1997
=over 4
***************
*** 656,664 ****
=item *
Initial public release.
!
=back
!
September 1997
=over 4
--- 656,664 ----
=item *
Initial public release.
!
=back
!
September 1997
=over 4
***************
*** 668,675 ****
Porting begins.
=back
!
! =head1 Author
!
Mark Bixby, mark@bixby.org
--- 668,675 ----
Porting begins.
=back
!
! =head1 AUTHOR
!
Mark Bixby, mark@bixby.org
diff -c /dev/null 'perl-5.7.2/README.netware'
Index: ./README.netware
*** ./README.netware Thu Jan 1 02:00:00 1970
--- ./README.netware Fri Jul 13 15:40:40 2001
***************
*** 0 ****
--- 1,187 ----
+ If you read this file _as_is_, just ignore the funny characters you
+ see. It is written in the POD format (see pod/perlpod.pod) which is
+ specifically designed to be readable as is.
+
+ =head1 Name
+
+ Perl for NetWare5.x
+
+ =head1 Description
+
+ This file gives the instructions for building Perl5.6 and above for
+ NetWare5.x. Please read and understand the terms under which this
+ software is distributed.
+
+ =head1 Build
+
+ This section describes the steps to be performed to build a Perl NLM
+ and other associated NLMs.
+
+ =head2 Tools & SDK
+
+ The build requires Watcom 11.x compiler and linker. In addition,
+ the "NetWare SDK", "NLM & NetWare Libraries for C" and
+ "NetWare Server Protocol Libraries for C", all available at
+ L<http://developer.novell.com/ndk/>, are also required.
+ Microsoft Visual C++ version 4.2 or later is also required.
+
+ Currently the interpreter builds only with Watcom and we do have plans of
+ making this work with CodeWarrior as well.
+
+ =head2 Setup
+
+ The build process is dependent on the location of the NetWare SDK.
+ Once the required software is installed, the build environment has to
+ be setup. The following batch files setup the environment.
+
+ =over 4
+
+ =item Buildtype.bat
+
+ This sets the build type to release or debug.
+
+ =item SetNWBld.bat
+
+ This sets the NetWare SDK path, Compiler & other tools path & MPK SDK path.
+
+ =item MPKBuild.bat
+
+ This is required only it we are building multi-processor enabled NLMs.
+
+ These batch files are under NetWare\bat folder. These batch files
+ call a couple of other batch files to setup the environment. Invoking
+ the batch file with I</now> will show the current settings and I</h>
+ or I</?> gives the usage help.
+
+ =back
+
+ =head2 Make
+
+ The make process runs only under WinNT shell.
+ The NetWare makefile is located under the NetWare folder.
+ The makefile for NetWare makes use of miniperl.exe to run some of
+ the Perl scripts. To create miniperl.exe, run nmake from
+ win32 folder through WinNT commond prompt. The build process
+ can be stopped after miniperl.exe is created. Then run nmake
+ from NetWare folder through WinNT command prompt.
+
+ Currently the follwing two build types are tested on NetWare
+
+ =over 4
+
+ =item *
+
+ USE_MULTI, USE_ITHREADS & USE_IMP_SYS defined
+
+ =item *
+
+ USE_MULTI & USE_IMP_SYS defined and USE_ITHREADS not defined
+
+ =back
+
+ =head2 Interpreter
+
+ Once miniperl.exe creation is over, run nmake from the NetWare folder.
+ This will build the Perl interpreter for NetWare as I<perl.nlm>.
+ This is copied under the I<Release> folder if you are doing
+ a release build, else will be copied under I<Debug> folder for debug builds.
+
+ =head2 Extensions
+
+ The make process also creates the Perl extensions which are called
+ NLPs (NetWare Loadable Perl).
+
+ =head1 Install
+
+ To install NetWare Perl onto a NetWare server, first map the Sys volume
+ of a NetWare server to I<i:>. This is because the makefile by default
+ sets the drive letter to I<i:>. Type I<nmake nwinstall> from NetWare folder
+ on a WinNT command prompt. This will copy the binaries and module files
+ onto the NetWare server. The Perl interpreter, I<perl.nlm>, is copied under
+ I<sys:\perl\system> folder. Copy I<perl.nlm> to I<sys:\system> folder.
+
+ =head1 Build new extensions
+
+ To build extensions other than standard extensions, NetWare Perl has
+ to be installed on Windows as well. This can be done by invoking
+ I<nmake install> from the NetWare folder on a WinNT command prompt.
+ This will copy all the *.pm files and other required files.
+ Documentation files are not copied. This has to be done after
+ installing Perl for Windows. Once this is done, do the following
+ to build any extension:
+
+ =over 4
+
+ =item *
+
+ perl -II<path to NetWare lib dir> -II<path to lib> Makefile.pl
+
+ For example:
+
+ perl -Ic:/perl/5.6.1/lib/NetWare-multi-thread -Ic:\perl\5.6.1\lib MakeFile.pl
+
+ =item *
+
+ nmake
+
+ =item *
+
+ nmake install
+
+ Install will copy the files into the Windows machine where NetWare
+ Perl is installed, these files have to be copied to the NetWare server
+ manually. Alternatively, pass I<INSTALLSITELIB=i:\perl\lib> as an
+ input to makefile.pl above. Where I<i:> is the mapped drive to the
+ sys: volume of the server where Perl on NetWare is installed. Now
+ saying I<nmake install>, will copy the files to the server.
+
+ =back
+
+ =head1 Known Issues
+
+ =over 4
+
+ =item *
+
+ With USE_ITHREADS not defined, backtick seems to be having some problems.
+
+ =item *
+
+ The utility scripts (pod2html.pl, pod2man.pl, perldoc.pl etc.) are not
+ yet ported to work on NetWare.
+
+ =item *
+
+ Also fork() is not currently implemented.
+
+ =back
+
+ =head1 Acknowledgements
+
+ The makefile for Win32 is used as a reference to create the makefile
+ for NetWare build. Also, the make process for NetWare port uses
+ miniperl.exe to run scripts during the make and installation process.
+
+ =head1 Authors
+
+ Guruprasad S (sguruprasad@novell.com)
+ Anantha Kesari H Y (hyanantha@novell.com)
+
+ =head1 Date
+
+ =over 4
+
+ =item *
+
+ Created - 18th Jan 2001
+
+ =item *
+
+ Modified - 25th June 2001
+
+ =item *
+
+ Modified - 13 July 2001
+
+ =back
+
diff -c 'perl-5.7.1/README.os2' 'perl-5.7.2/README.os2'
Index: ./README.os2
*** ./README.os2 Tue Mar 13 03:50:47 2001
--- ./README.os2 Mon Jul 9 17:09:46 2001
***************
*** 1053,1060 ****
ports of '94 - 95. The priorities are absolute, go from 32 to -95,
lower is quicker. 0 is the default priority.
! B<WARNING>. Calling C<getpriority> on a non-existing process can lock the
! system before Warp3 fixpak22.
=head2 C<system()>
--- 1053,1063 ----
ports of '94 - 95. The priorities are absolute, go from 32 to -95,
lower is quicker. 0 is the default priority.
! B<WARNING>. Calling C<getpriority> on a non-existing process could lock
! the system before Warp3 fixpak22. Starting with Warp3, Perl will use
! a workaround: it aborts getpriority() if the process is not present.
! This is not possible on older versions C<2.*>, and has a race
! condition anyway.
=head2 C<system()>
***************
*** 1063,1069 ****
L<OS2::Process>.
When finding a program to run, Perl first asks the OS to look for executables
! on C<PATH>. If not found, it looks for a script with possible extensions
added in this order: no extension, F<.cmd>, F<.btm>,
F<.bat>, F<.pl>. If found, Perl checks the start of the file for magic
strings C<"#!"> and C<"extproc ">. If found, Perl uses the rest of the
--- 1066,1073 ----
L<OS2::Process>.
When finding a program to run, Perl first asks the OS to look for executables
! on C<PATH> (OS/2 adds extension F<.exe> if no extension is present).
! If not found, it looks for a script with possible extensions
added in this order: no extension, F<.cmd>, F<.btm>,
F<.bat>, F<.pl>. If found, Perl checks the start of the file for magic
strings C<"#!"> and C<"extproc ">. If found, Perl uses the rest of the
***************
*** 1077,1084 ****
extproc /bin/bash -x -c
! If F</bin/bash> is not found, and appending of executable extensions to
! F</bin/bash> does not help either, then Perl looks for an executable F<bash> on
C<PATH>. If found in F<C:/emx.add/bin/bash.exe>, then the above system() is
translated to
--- 1081,1087 ----
extproc /bin/bash -x -c
! If F</bin/bash.exe> is not found, then Perl looks for an executable F<bash.exe> on
C<PATH>. If found in F<C:/emx.add/bin/bash.exe>, then the above system() is
translated to
***************
*** 1098,1103 ****
--- 1101,1111 ----
current session, it will start the new process in a separate session of
necessary type. Call via C<OS2::Process> to disable this magic.
+ B<WARNING>. Due to the described logic, you need to explicitly
+ specify F<.com> extension if needed. Moreover, if the executable
+ F<perl5.6.1> is requested, Perl will not look for F<perl5.6.1.exe>.
+ [This may change in the future.]
+
=head2 C<extproc> on the first line
If the first chars of a Perl script are C<"extproc ">, this line is treated
***************
*** 1748,1754 ****
C<setpriority> and C<getpriority> are not compatible with earlier
ports by Andreas Kaiser. See C<"setpriority, getpriority">.
! =head2 DLL name mangling
With the release 5.003_01 the dynamically loadable libraries
should be rebuilt when a different version of Perl is compiled. In particular,
--- 1756,1762 ----
C<setpriority> and C<getpriority> are not compatible with earlier
ports by Andreas Kaiser. See C<"setpriority, getpriority">.
! =head2 DLL name mangling: pre 5.6.2
With the release 5.003_01 the dynamically loadable libraries
should be rebuilt when a different version of Perl is compiled. In particular,
***************
*** 1782,1787 ****
--- 1790,1925 ----
=back
+ =head2 DLL name mangling: 5.6.2 and beyond
+
+ In fact mangling of I<extension> DLLs was done due to misunderstanding
+ of the OS/2 dynaloading model. OS/2 (effectively) maintains two
+ different tables of loaded DLL:
+
+ =over
+
+ =item Global DLLs
+
+ those loaded by the base name from C<LIBPATH>; including those
+ associated at link time;
+
+ =item specific DLLs
+
+ loaded by the full name.
+
+ =back
+
+ When resolving a request for a global DLL, the table of already-loaded
+ specific DLLs is (effectively) ignored; moreover, specific DLLs are
+ I<always> loaded from the prescribed path.
+
+ There is/was a minor twist which makes this scheme fragile: what to do
+ with DLLs loaded from
+
+ =over
+
+ =item C<BEGINLIBPATH> and C<ENDLIBPATH>
+
+ (which depend on the process)
+
+ =item F<.> from C<LIBPATH>
+
+ which I<effectively> depends on the process (although C<LIBPATH> is the
+ same for all the processes).
+
+ =back
+
+ Unless C<LIBPATHSTRICT> is set to C<T> (and the kernel is after
+ 2000/09/01), such DLLs are considered to be global. When loading a
+ global DLL it is first looked in the table of already-loaded global
+ DLLs. Because of this the fact that one executable loaded a DLL from
+ C<BEGINLIBPATH> and C<ENDLIBPATH>, or F<.> from C<LIBPATH> may affect
+ I<which> DLL is loaded when I<another> executable requests a DLL with
+ the same name. I<This> is the reason for version-specific mangling of
+ the DLL name for perl DLL.
+
+ Since the Perl extension DLLs are always loaded with the full path,
+ there is no need to mangle their names in a version-specific ways:
+ their directory already reflects the corresponding version of perl,
+ and @INC takes into account binary compatibility with older version.
+ Starting from C<5.6.2> the name mangling scheme is fixed to be the
+ same as for Perl 5.005_53 (same as in a popular binary release). Thus
+ new Perls will be able to I<resolve the names> of old extension DLLs
+ if @INC allows finding their directories.
+
+ However, this still does not guarantie that these DLL may be loaded.
+ The reason is the mangling of the name of the I<Perl DLL>. And since
+ the extension DLLs link with the Perl DLL, extension DLLs for older
+ versions would load an older Perl DLL, and would most probably
+ segfault (since the data in this DLL is not properly initialized).
+
+ There is a partial workaround (which can be made complete with newer
+ OS/2 kernels): create a forwarder DLL with the same name as the DLL of
+ the older version of Perl, which forwards the entry points to the
+ newer Perl's DLL. Make this DLL accessible on (say) the C<BEGINLIBPATH> of
+ the new Perl executable. When the new executable accesses old Perl's
+ extension DLLs, they would request the old Perl's DLL by name, get the
+ forwarder instead, so effectively will link with the currently running
+ (new) Perl DLL.
+
+ This may break in two ways:
+
+ =over
+
+ =item *
+
+ Old perl executable is started when a new executable is running has
+ loaded an extension compiled for the old executable (ouph!). In this
+ case the old executable will get a forwarder DLL instead of the old
+ perl DLL, so would link with the new perl DLL. While not directly
+ fatal, it will behave the same as new excutable. This beats the whole
+ purpose of explicitly starting an old executable.
+
+ =item *
+
+ A new executable loads an extension compiled for the old executable
+ when an old perl executable is running. In this case the extension
+ will not pick up the forwarder - with fatal results.
+
+ =back
+
+ With support for C<LIBPATHSTRICT> this may be circumvented - unless
+ one of DLLs is started from F<.> from C<LIBPATH> (I do not know
+ whether C<LIBPATHSTRICT> affects this case).
+
+ B<REMARK>. Unless newer kernels allow F<.> in C<BEGINLIBPATH> (older
+ do not), this mess cannot be completely cleaned.
+
+
+ B<REMARK>. C<LIBPATHSTRICT>, C<BEGINLIBPATH> and C<ENDLIBPATH> are
+ not environment variables, although F<cmd.exe> emulates them on C<SET
+ ...> lines. From Perl they may be accessed by L<Cwd::extLibpath> and
+ L<Cwd::extLibpath_set>.
+
+ =head2 DLL forwarder generation
+
+ Assume that the old DLL is named F<perlE0AC.dll> (as is one for
+ 5.005_53), and the new version is 5.6.1. Create a file
+ F<perl5shim.def-leader> with
+
+ LIBRARY 'perlE0AC' INITINSTANCE TERMINSTANCE
+ DESCRIPTION '@#perl5-porters@perl.org:5.006001#@ Perl module for 5.00553 -> Perl 5.6.1 forwarder'
+ CODE LOADONCALL
+ DATA LOADONCALL NONSHARED MULTIPLE
+ EXPORTS
+
+ modifying the versions/names as needed. Run
+
+ perl -wnle "next if 0../EXPORTS/; print qq( \"$1\") if /\"(\w+)\"/" perl5.def >lst
+
+ in the Perl build directory (to make the DLL smaller replace perl5.def
+ with the definition file for the older version of Perl if present).
+
+ cat perl5shim.def-leader lst >perl5shim.def
+ gcc -Zomf -Zdll -o perlE0AC.dll perl5shim.def -s -llibperl
+
+ (ignore multiple C<warning L4085>).
+
=head2 Threading
As of release 5.003_01 perl is linked to multithreaded C RTL
***************
*** 1901,1906 ****
--- 2039,2049 ----
Note that these problems should not discourage experimenting, since they
have a low probability of affecting small programs.
+
+ =head1 BUGS
+
+ This description was not updated since 5.6.1, see F<os2/Changes> for
+ more info.
=cut
diff -c 'perl-5.7.1/README.os390' 'perl-5.7.2/README.os390'
Index: ./README.os390
*** ./README.os390 Mon Mar 26 21:35:04 2001
--- ./README.os390 Mon Jul 9 17:09:46 2001
***************
*** 1,9 ****
-
This document is written in pod format hence there are punctuation
! characters in odd places. Do not worry, you've apparently got
! the ASCII->EBCDIC translation worked out correctly. You can read
! more about pod in pod/perlpod.pod or the short summary in the
! INSTALL file.
=head1 NAME
--- 1,7 ----
This document is written in pod format hence there are punctuation
! characters in odd places. Do not worry, you've apparently got the
! ASCII->EBCDIC translation worked out correctly. You can read more
! about pod in pod/perlpod.pod or the short summary in the INSTALL file.
=head1 NAME
***************
*** 23,29 ****
You may need to carry out some system configuration tasks before
running the Configure script for Perl.
! =head2 Unpacking
Gunzip/gzip for OS/390 is discussed at:
--- 21,27 ----
You may need to carry out some system configuration tasks before
running the Configure script for Perl.
! =head2 Unpacking Perl distribution on OS/390
Gunzip/gzip for OS/390 is discussed at:
***************
*** 33,39 ****
pax -o to=IBM-1047,from=ISO8859-1 -r < latest.tar
! =head2 Setup and utilities
Be sure that your yacc installation is in place including any necessary
parser template files. If you have not already done so then be sure to:
--- 31,37 ----
pax -o to=IBM-1047,from=ISO8859-1 -r < latest.tar
! =head2 Setup and utilities for Perl on OS/390
Be sure that your yacc installation is in place including any necessary
parser template files. If you have not already done so then be sure to:
***************
*** 87,93 ****
For successful testing you may need to turn on the sticky bit for your
world readable /tmp directory if you have not already done so (see man chmod).
! =head2 Configure
Once you've unpacked the distribution, run "sh Configure" (see INSTALL
for a full discussion of the Configure options). There is a "hints" file
--- 85,91 ----
For successful testing you may need to turn on the sticky bit for your
world readable /tmp directory if you have not already done so (see man chmod).
! =head2 Configure Perl on OS/390
Once you've unpacked the distribution, run "sh Configure" (see INSTALL
for a full discussion of the Configure options). There is a "hints" file
***************
*** 156,162 ****
=back
! =head2 Build, test, install
Simply put:
--- 154,160 ----
=back
! =head2 Build, Test, Install Perl on OS/390
Simply put:
***************
*** 172,178 ****
on how you answered the questions that Configure asked and whether
or not you have write access to the directories you specified.
! =head2 build anomalies
"Out of memory!" messages during the build of Perl are most often fixed
by re building the GNU make utility for OS/390 from a source code kit.
--- 170,176 ----
on how you answered the questions that Configure asked and whether
or not you have write access to the directories you specified.
! =head2 Build Anomalies with Perl on OS/390
"Out of memory!" messages during the build of Perl are most often fixed
by re building the GNU make utility for OS/390 from a source code kit.
***************
*** 196,202 ****
Socket extension then be sure to fix the syntax error in the system
header /usr/include/sys/socket.h.
! =head2 testing anomalies
The `make test` step runs a Perl Verification Procedure, usually before
installation. You might encounter STDERR messages even during a successful
--- 194,200 ----
Socket extension then be sure to fix the syntax error in the system
header /usr/include/sys/socket.h.
! =head2 Testing Anomalies with Perl on OS/390
The `make test` step runs a Perl Verification Procedure, usually before
installation. You might encounter STDERR messages even during a successful
***************
*** 279,291 ****
=back
! =head2 installation anomalies
The installman script will try to run on OS/390. There will be fewer errors
if you have a roff utility installed. You can obtain GNU groff from the
Redbook SG24-5944-00 ftp site.
! =head2 Usage Hints
When using perl on OS/390 please keep in mind that the EBCDIC and ASCII
character sets are different. See perlebcdic.pod for more on such character
--- 277,289 ----
=back
! =head2 Installation Anomalies with Perl on OS/390
The installman script will try to run on OS/390. There will be fewer errors
if you have a roff utility installed. You can obtain GNU groff from the
Redbook SG24-5944-00 ftp site.
! =head2 Usage Hints for Perl on OS/390
When using perl on OS/390 please keep in mind that the EBCDIC and ASCII
character sets are different. See perlebcdic.pod for more on such character
***************
*** 307,313 ****
rlogin or telnet client. Try to avoid older 3270 emulators and ISHELL for
working with Perl on USS.
! =head2 Floating point anomalies
There appears to be a bug in the floating point implementation on S/390
systems such that calling int() on the product of a number and a small
--- 305,311 ----
rlogin or telnet client. Try to avoid older 3270 emulators and ISHELL for
working with Perl on USS.
! =head2 Floating Point Anomalies with Perl on OS/390
There appears to be a bug in the floating point implementation on S/390
systems such that calling int() on the product of a number and a small
***************
*** 341,347 ****
/* y is 0.000000e+00 and z is 1.000000e+05 (with c89) */
}
! =head2 Modules and Extensions
Pure pure (that is non xs) modules may be installed via the usual:
--- 339,345 ----
/* y is 0.000000e+00 and z is 1.000000e+05 (with c89) */
}
! =head2 Modules and Extensions for Perl on OS/390
Pure pure (that is non xs) modules may be installed via the usual:
***************
*** 402,408 ****
http://publibz.boulder.ibm.com:80/cgi-bin/bookmgr_OS390/BOOKS/CBCUG030/
! =head2 Mailing list
The Perl Institute (http://www.perl.org/) maintains a perl-mvs
mailing list of interest to all folks building and/or
--- 400,406 ----
http://publibz.boulder.ibm.com:80/cgi-bin/bookmgr_OS390/BOOKS/CBCUG030/
! =head2 Mailing list for Perl on OS/390
The Perl Institute (http://www.perl.org/) maintains a perl-mvs
mailing list of interest to all folks building and/or
diff -c 'perl-5.7.1/README.plan9' 'perl-5.7.2/README.plan9'
Index: ./README.plan9
*** ./README.plan9 Tue Mar 6 04:04:20 2001
--- ./README.plan9 Mon Jul 9 17:09:46 2001
***************
*** 1,27 ****
WELCOME to Plan 9 Perl, brave soul!
- This is a preliminary alpha version of Plan 9 Perl. Still to be implemented are MakeMaker and DynaLoader. Many perl commands are missing or currently behave in an inscrutable manner. These gaps will, with perserverance and a modicum of luck, be remedied in the near future.To install this software:
! 1. Create the source directories and libraries for perl by running the plan9/setup.rc command (i.e., located in the plan9 subdirectory). Note: the setup routine assumes that you haven't dearchived these files into /sys/src/cmd/perl. After running setup.rc you may delete the copy of the source you originally detarred, as source code has now been installed in /sys/src/cmd/perl. If you plan on installing perl binaries for all architectures, run "setup.rc -a".
! After
! 2. Making sure that you have adequate privileges to build system software, from /sys/src/cmd/perl/5.00301 run:
! mk install
! If you wish to install perl versions for all architectures (68020, mips, sparc and 386) run:
! mk installall
! 3. Wait. The build process will take a *long* time because perl bootstraps itself. A 75MHz Pentium, 16MB RAM machine takes roughly 30 minutes to build the distribution from scratch.
! INSTALLING DOCUMENTATION
! This perl distribution comes with a tremendous amount of documentation. To add these to the built-in manuals that come with Plan 9, from /sys/src/cmd/perl/5.00301 run:
! mk man
To begin your reading, start with:
- man perl
- This is a good introduction and will direct you towards other man pages that may interest you. For information specific to Plan 9 Perl, try:
- man perlplan9
(Note: "mk man" may produce some extraneous noise. Fear not.)
! Direct questions, comments, and the unlikely bug report (ahem) direct comments toward:
! lutherh@stratcom.com
! Luther Huffman
Strategic Computer Solutions, Inc.
--- 1,146 ----
+ If you read this file _as_is_, just ignore the funny characters you see.
+ It is written in the POD format (see pod/perlpod.pod) which is specially
+ designed to be readable as is.
+
+ =head1 NAME
+
+ perlplan9 - Plan 9-specific documentation for Perl
+
+ =head1 DESCRIPTION
+
+ These are a few notes describing features peculiar to
+ Plan 9 Perl. As such, it is not intended to be a replacement
+ for the rest of the Perl 5 documentation (which is both
+ copious and excellent). If you have any questions to
+ which you can't find answers in these man pages, contact
+ Luther Huffman at lutherh@stratcom.com and we'll try to
+ answer them.
+
+ =head2 Invoking Perl
+
+ Perl is invoked from the command line as described in
+ L<perl>. Most perl scripts, however, do have a first line
+ such as "#!/usr/local/bin/perl". This is known as a shebang
+ (shell-bang) statement and tells the OS shell where to find
+ the perl interpreter. In Plan 9 Perl this statement should be
+ "#!/bin/perl" if you wish to be able to directly invoke the
+ script by its name.
+ Alternatively, you may invoke perl with the command "Perl"
+ instead of "perl". This will produce Acme-friendly error
+ messages of the form "filename:18".
+
+ Some scripts, usually identified with a *.PL extension, are
+ self-configuring and are able to correctly create their own
+ shebang path from config information located in Plan 9
+ Perl. These you won't need to be worried about.
+
+ =head2 What's in Plan 9 Perl
+
+ Although Plan 9 Perl currently only provides static
+ loading, it is built with a number of useful extensions.
+ These include Opcode, FileHandle, Fcntl, and POSIX. Expect
+ to see others (and DynaLoading!) in the future.
+
+ =head2 What's not in Plan 9 Perl
+
+ As mentioned previously, dynamic loading isn't currently
+ available nor is MakeMaker. Both are high-priority items.
+
+ =head2 Perl5 Functions not currently supported in Plan 9 Perl
+
+ Some, such as C<chown> and C<umask> aren't provided
+ because the concept does not exist within Plan 9. Others,
+ such as some of the socket-related functions, simply
+ haven't been written yet. Many in the latter category
+ may be supported in the future.
+
+ The functions not currently implemented include:
+
+ chown, chroot, dbmclose, dbmopen, getsockopt,
+ setsockopt, recvmsg, sendmsg, getnetbyname,
+ getnetbyaddr, getnetent, getprotoent, getservent,
+ sethostent, setnetent, setprotoent, setservent,
+ endservent, endnetent, endprotoent, umask
+
+ There may be several other functions that have undefined
+ behavior so this list shouldn't be considered complete.
+
+ =head2 Signals in Plan 9 Perl
+
+ For compatibility with perl scripts written for the Unix
+ environment, Plan 9 Perl uses the POSIX signal emulation
+ provided in Plan 9's ANSI POSIX Environment (APE). Signal stacking
+ isn't supported. The signals provided are:
+
+ SIGHUP, SIGINT, SIGQUIT, SIGILL, SIGABRT,
+ SIGFPE, SIGKILL, SIGSEGV, SIGPIPE, SIGPIPE, SIGALRM,
+ SIGTERM, SIGUSR1, SIGUSR2, SIGCHLD, SIGCONT,
+ SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU
+
+ =head1 COMPILING AND INSTALLING PERL ON PLAN 9
+
WELCOME to Plan 9 Perl, brave soul!
! This is a preliminary alpha version of Plan 9 Perl. Still to be
! implemented are MakeMaker and DynaLoader. Many perl commands are
! missing or currently behave in an inscrutable manner. These gaps will,
! with perserverance and a modicum of luck, be remedied in the near
! future.To install this software:
! 1. Create the source directories and libraries for perl by running the
! plan9/setup.rc command (i.e., located in the plan9 subdirectory).
! Note: the setup routine assumes that you haven't dearchived these
! files into /sys/src/cmd/perl. After running setup.rc you may delete
! the copy of the source you originally detarred, as source code has now
! been installed in /sys/src/cmd/perl. If you plan on installing perl
! binaries for all architectures, run "setup.rc -a".
! 2. After making sure that you have adequate privileges to build system
! software, from /sys/src/cmd/perl/5.00301 (adjust version
! appropriately) run:
!
! mk install
!
! If you wish to install perl versions for all architectures (68020,
! mips, sparc and 386) run:
!
! mk installall
!
! 3. Wait. The build process will take a *long* time because perl
! bootstraps itself. A 75MHz Pentium, 16MB RAM machine takes roughly 30
! minutes to build the distribution from scratch.
!
! =head2 Installing Perl Documentation on Plan 9
!
! This perl distribution comes with a tremendous amount of
! documentation. To add these to the built-in manuals that come with
! Plan 9, from /sys/src/cmd/perl/5.00301 (adjust version appropriately)
! run:
!
! mk man
!
To begin your reading, start with:
+ man perl
+
+ This is a good introduction and will direct you towards other man
+ pages that may interest you.
+
(Note: "mk man" may produce some extraneous noise. Fear not.)
! =head1 BUGS
! "As many as there are grains of sand on all the beaches of the
! world . . ." - Carl Sagan
!
! =head1 Revision date
!
! This document was revised 09-October-1996 for Perl 5.003_7.
!
! =head1 AUTHOR
!
! Direct questions, comments, and the unlikely bug report (ahem) direct
! comments toward:
!
! Luther Huffman, lutherh@stratcom.com,
Strategic Computer Solutions, Inc.
diff -c 'perl-5.7.1/README.qnx' 'perl-5.7.2/README.qnx'
Index: ./README.qnx
*** ./README.qnx Tue Mar 6 04:04:20 2001
--- ./README.qnx Thu Jul 12 20:36:17 2001
***************
*** 1,22 ****
! README.qnx
! Please see hints/qnx.sh for more detailed information about compiling
! perl under QNX4.
The files in the "qnx" directory are:
! * "qnx/ar" is a script that emulates the standard unix archive (aka
! library) utility. Under Watcom 10.6, ar is linked to wlib and
! provides the expected interface. With Watcom 9.5, a cover function
! is required. This one is fairly crude but has proved adequate for
! compiling perl. A more thorough version is available at:
http://www.fdma.com/pub/qnx/porting/ar
! * "qnx/cpp" is a script that provides C preprocessing functionality.
! Configure can generate a similar cover, but it doesn't handle all
! the command-line options that perl throws at it. This might be
! reasonably placed in /usr/local/bin.
! --
Norton T. Allen (allen@huarp.harvard.edu)
--- 1,126 ----
! If you read this file _as_is_, just ignore the funny characters you see.
! It is written in the POD format (see pod/perlpod.pod) which is specially
! designed to be readable as is.
! =head1 NAME
+ README.qnx - Perl version 5 on QNX
+
+ =head1 DESCRIPTION
+
+ As of perl5.7.2 all tests pass under:
+
+ QNX 4.24G
+ Watcom 10.6 with Beta/970211.wcc.update.tar.F
+ socket3r.lib Nov21 1996.
+
+ Some tests may complain under known circumstances. See
+ below and hints/qnx.sh for more information.
+
+ Under QNX 6.1.0 there are still a few tests which fail.
+ See below and hints/qnx.sh for more information.
+
+ =head2 Required Software for Compiling Perl on QNX4
+
+ As with many unix ports, this one depends on a few "standard"
+ unix utilities which are not necessarily standard for QNX4.
+
+ =over 4
+
+ =item /bin/sh
+
+ This is used heavily by Configure and then by
+ perl itself. QNX4's version is fine, but Configure
+ will choke on the 16-bit version, so if you are
+ running QNX 4.22, link /bin/sh to /bin32/ksh
+
+ =item ar
+
+ This is the standard unix library builder.
+ We use wlib. With Watcom 10.6, when wlib is
+ linked as "ar", it behaves like ar and all is
+ fine. Under 9.5, a cover is required. One is
+ included in ../qnx
+
+ =item nm
+
+ This is used (optionally) by configure to list
+ the contents of libraries. I will generate
+ a cover function on the fly in the UU directory.
+
+ =item cpp
+
+ Configure and perl need a way to invoke a C
+ preprocessor. I have created a simple cover
+ for cc which does the right thing. Without this,
+ Configure will create its own wrapper which works,
+ but it doesn't handle some of the command line arguments
+ that perl will throw at it.
+
+ =item make
+
+ You really need GNU make to compile this. GNU make
+ ships by default with QNX 4.23, but you can get it
+ from quics for earlier versions.
+
+ =back
+
+ =head2 Outstanding Issues with Perl on QNX4
+
+ There is no support for dynamically linked libraries in QNX4.
+
+ The following tests may report errors under QNX4:
+
+ ext/Cwd/Cwd.t will complain if `pwd` and cwd don't give
+ the same results. cwd calls `fullpath -t`, so if you
+ cd `fullpath -t` before running the test, it will
+ pass.
+
+ lib/File/Find/taint.t will complain if '.' is in your
+ PATH. The PATH test is triggered because cwd calls
+ `fullpath -t`.
+
+ ext/IO/lib/IO/t/io_sock.t: Subtest 14 is skipped due to
+ the fact that the functionality to read back the non-blocking
+ status of a socket is not implemented in QNX's TCP/IP. This
+ has been reported to QNX and it may work with later versions
+ of TCP/IP.
+
+ =head2 QNX auxiliary files
+
The files in the "qnx" directory are:
! =over 4
+ =item qnx/ar
+
+ A script that emulates the standard unix archive (aka library)
+ utility. Under Watcom 10.6, ar is linked to wlib and provides the
+ expected interface. With Watcom 9.5, a cover function is
+ required. This one is fairly crude but has proved adequate for
+ compiling perl. A more thorough version is available at:
+
http://www.fdma.com/pub/qnx/porting/ar
! =item qnx/cpp
! A script that provides C preprocessing functionality. Configure can
! generate a similar cover, but it doesn't handle all the command-line
! options that perl throws at it. This might be reasonably placed in
! /usr/local/bin.
!
! =head2 Outstanding issues with perl under QNX6
!
! The following tests are still failing for Perl 5.7.1 under QNX 6.1.0:
!
! op/sprintf.........................FAILED at test 91
! lib/1_compile......................FAILED at test 33
! ext/IO/lib/IO/t/io_sock............FAILED at test 12
! ext/IO/lib/IO/t/io_udp.............FAILED at test 4
!
! =back
!
! =head1 AUTHOR
!
Norton T. Allen (allen@huarp.harvard.edu)
+
diff -c 'perl-5.7.1/README.solaris' 'perl-5.7.2/README.solaris'
Index: ./README.solaris
Prereq: 1.4
*** ./README.solaris Tue Mar 6 04:04:20 2001
--- ./README.solaris Mon Jul 9 17:09:46 2001
***************
*** 47,53 ****
=head1 RESOURCES
! There are many, many source for Solaris information. A few of the
important ones for perl:
=over 4
--- 47,53 ----
=head1 RESOURCES
! There are many, many sources for Solaris information. A few of the
important ones for perl:
=over 4
***************
*** 63,79 ****
=item Precompiled Binaries
Precompiled binaries, links to many sites, and much, much more is
! available at L<http://www.sunfreeware.com>.
=item Solaris Documentation
! All Solaris documentation is available on-line at L<http://docs.sun.com>.
=back
=head1 SETTING UP
! =head2 File Extraction Problems.
Be sure to use a tar program compiled under Solaris (not SunOS 4.x)
to extract the perl-5.x.x.tar.gz file. Do not use GNU tar compiled
--- 63,79 ----
=item Precompiled Binaries
Precompiled binaries, links to many sites, and much, much more is
! available at L<http://www.sunfreeware.com/>.
=item Solaris Documentation
! All Solaris documentation is available on-line at L<http://docs.sun.com/>.
=back
=head1 SETTING UP
! =head2 File Extraction Problems on Solaris.
Be sure to use a tar program compiled under Solaris (not SunOS 4.x)
to extract the perl-5.x.x.tar.gz file. Do not use GNU tar compiled
***************
*** 81,91 ****
When you run SunOS4 binaries on Solaris, the run-time system magically
alters pathnames matching m#lib/locale# so that when tar tries to create
lib/locale.pm, a file named lib/oldlocale.pm gets created instead.
! If you found this advice it too late and used a SunOS4-compiled tar
anyway, you must find the incorrectly renamed file and move it back
to lib/locale.pm.
! =head2 Compiler and Related Tools.
You must use an ANSI C compiler to build perl. Perl can be compiled
with either Sun's add-on C compiler or with gcc. The C compiler that
--- 81,91 ----
When you run SunOS4 binaries on Solaris, the run-time system magically
alters pathnames matching m#lib/locale# so that when tar tries to create
lib/locale.pm, a file named lib/oldlocale.pm gets created instead.
! If you found this advice too late and used a SunOS4-compiled tar
anyway, you must find the incorrectly renamed file and move it back
to lib/locale.pm.
! =head2 Compiler and Related Tools on Solaris.
You must use an ANSI C compiler to build perl. Perl can be compiled
with either Sun's add-on C compiler or with gcc. The C compiler that
***************
*** 197,203 ****
Configure from even looking in /usr/ucblib for libraries, and also
explicitly omits -lucb.
! =head2 Environment
=head3 PATH
--- 197,203 ----
Configure from even looking in /usr/ucblib for libraries, and also
explicitly omits -lucb.
! =head2 Environment for Compiling Perl on Solaris
=head3 PATH
***************
*** 234,240 ****
Only Solaris-specific issues are discussed here. Usually, the
defaults should be fine.
! =head2 64-bit Issues.
See the INSTALL file for general information regarding 64-bit compiles.
In general, the defaults should be fine for most people.
--- 234,240 ----
Only Solaris-specific issues are discussed here. Usually, the
defaults should be fine.
! =head2 64-bit Issues with Perl on Solaris.
See the INSTALL file for general information regarding 64-bit compiles.
In general, the defaults should be fine for most people.
***************
*** 258,264 ****
and this is the default for perl-5.6.0.
For a more complete explanation of 64-bit issues, see the Solaris 64-bit
! Developer's Guide at http://docs.sun.com:80/ab2/coll.45.13/SOL64TRANS/
You can detect the OS mode using "isainfo -v", e.g.
--- 258,264 ----
and this is the default for perl-5.6.0.
For a more complete explanation of 64-bit issues, see the Solaris 64-bit
! Developer's Guide at L<http://docs.sun.com:80/ab2/coll.45.13/SOL64TRANS/>
You can detect the OS mode using "isainfo -v", e.g.
***************
*** 270,276 ****
want to allocate more than ~ 4GB of memory inside Perl, you probably
don't need Perl to be a 64-bit app.
! =head3 Large File Suppprt
For Solaris 2.6 and onwards, there are two different ways for 32-bit
applications to manipulate large files (files whose size is > 2GByte).
--- 270,276 ----
want to allocate more than ~ 4GB of memory inside Perl, you probably
don't need Perl to be a 64-bit app.
! =head3 Large File Support
For Solaris 2.6 and onwards, there are two different ways for 32-bit
applications to manipulate large files (files whose size is > 2GByte).
***************
*** 362,368 ****
As of 5.6.0, long doubles are not working.
! =head2 Threads.
It is possible to build a threaded version of perl on Solaris. The entire
perl thread implementation is still experimental, however, so beware.
--- 362,368 ----
As of 5.6.0, long doubles are not working.
! =head2 Threads in Perl on Solaris.
It is possible to build a threaded version of perl on Solaris. The entire
perl thread implementation is still experimental, however, so beware.
***************
*** 370,376 ****
to 2.6, that function is in -lposix4. Starting with Solaris 7, it is
in -lrt. The hints file should handle adding this automatically.
! =head2 Malloc Issues.
Starting from Perl 5.7.1 Perl uses the Solaris malloc, since the perl
malloc breaks when dealing with more than 2GB of memory, and the Solaris
--- 370,376 ----
to 2.6, that function is in -lposix4. Starting with Solaris 7, it is
in -lrt. The hints file should handle adding this automatically.
! =head2 Malloc Issues with Perl on Solaris.
Starting from Perl 5.7.1 Perl uses the Solaris malloc, since the perl
malloc breaks when dealing with more than 2GB of memory, and the Solaris
***************
*** 385,391 ****
You should not use perl's malloc if you are building with gcc. There
are reports of core dumps, especially in the PDL module. The problem
appears to go away under -DDEBUGGING, so it has been difficult to
! track down. Sun's compiler appears to be ok with or without perl's
malloc. [XXX further investigation is needed here.]
=head1 MAKE PROBLEMS.
--- 385,391 ----
You should not use perl's malloc if you are building with gcc. There
are reports of core dumps, especially in the PDL module. The problem
appears to go away under -DDEBUGGING, so it has been difficult to
! track down. Sun's compiler appears to be okay with or without perl's
malloc. [XXX further investigation is needed here.]
=head1 MAKE PROBLEMS.
***************
*** 431,437 ****
=head1 MAKE TEST
! =head2 op/stat.t test 4
op/stat.t test 4 may fail if you are on a tmpfs of some sort.
Building in /tmp sometimes shows this behavior. The
--- 431,437 ----
=head1 MAKE TEST
! =head2 op/stat.t test 4 in Solaris
op/stat.t test 4 may fail if you are on a tmpfs of some sort.
Building in /tmp sometimes shows this behavior. The
***************
*** 438,444 ****
test suite detects if you are building in /tmp, but it may not be able
to catch all tmpfs situations.
! =head1 PREBUILT BINARIES.
You can pick up prebuilt binaries for Solaris from
L<http://www.sunfreeware.com/>, ActiveState L<http://www.activestate.com/>,
--- 438,444 ----
test suite detects if you are building in /tmp, but it may not be able
to catch all tmpfs situations.
! =head1 PREBUILT BINARIES OF PERL FOR SOLARIS.
You can pick up prebuilt binaries for Solaris from
L<http://www.sunfreeware.com/>, ActiveState L<http://www.activestate.com/>,
***************
*** 446,454 ****
There are probably other sources as well. Please note that these sites
are under the control of their respective owners, not the perl developers.
! =head1 RUNTIME ISSUES.
! =head2 Limits on Numbers of Open Files.
The stdio(3C) manpage notes that only 255 files may be opened using
fopen(), and only file descriptors 0 through 255 can be used in a
--- 446,454 ----
There are probably other sources as well. Please note that these sites
are under the control of their respective owners, not the perl developers.
! =head1 RUNTIME ISSUES FOR PERL ON SOLARIS.
! =head2 Limits on Numbers of Open Files on Solaris.
The stdio(3C) manpage notes that only 255 files may be opened using
fopen(), and only file descriptors 0 through 255 can be used in a
***************
*** 463,469 ****
=head1 SOLARIS-SPECIFIC PROBLEMS WITH MODULES.
! =head2 Proc::ProcessTable
Proc::ProcessTable does not compile on Solaris with perl5.6.0 and higher
if you have LARGEFILES defined. Since largefile support is the
--- 463,469 ----
=head1 SOLARIS-SPECIFIC PROBLEMS WITH MODULES.
! =head2 Proc::ProcessTable on Solaris
Proc::ProcessTable does not compile on Solaris with perl5.6.0 and higher
if you have LARGEFILES defined. Since largefile support is the
***************
*** 483,495 ****
Proc::ProcessTable doesn't try to share off_t's with the rest of perl,
or if it does they should be explicitly specified as off64_t.
! =head2 BSD::Resource
BSD::Resource versions earlier than 1.09 do not compile on Solaris
with perl 5.6.0 and higher, for the same reasons as Proc::ProcessTable.
BSD::Resource versions starting from 1.09 have a workaround for the problem.
! =head2 Net::SSLeay
Net::SSLeay requires a /dev/urandom to be present. This device is not
part of Solaris. You can either get the package SUNWski (packaged with
--- 483,495 ----
Proc::ProcessTable doesn't try to share off_t's with the rest of perl,
or if it does they should be explicitly specified as off64_t.
! =head2 BSD::Resource on Solaris
BSD::Resource versions earlier than 1.09 do not compile on Solaris
with perl 5.6.0 and higher, for the same reasons as Proc::ProcessTable.
BSD::Resource versions starting from 1.09 have a workaround for the problem.
! =head2 Net::SSLeay on Solaris
Net::SSLeay requires a /dev/urandom to be present. This device is not
part of Solaris. You can either get the package SUNWski (packaged with
diff -c /dev/null 'perl-5.7.2/README.tru64'
Index: ./README.tru64
*** ./README.tru64 Thu Jan 1 02:00:00 1970
--- ./README.tru64 Mon Jul 9 17:09:46 2001
***************
*** 0 ****
--- 1,90 ----
+ If you read this file _as_is_, just ignore the funny characters you see.
+ It is written in the POD format (see pod/perlpod.pod) which is specially
+ designed to be readable as is.
+
+ =head1 NAME
+
+ README.tru64 - Perl version 5 on Tru64 (formerly known as Digital UNIX formerly known as DEC OSF/1) systems
+
+ =head1 DESCRIPTION
+
+ This document describes various features of Compaq's (formerly Digital's)
+ Unix operating system (Tru64) that will affect how Perl version 5
+ is compiled and/or runs.
+
+ =head2 Compiling Perl 5 on Tru64
+
+ The recommended compiler to use in Tru64 is the native C compiler.
+ The native compiler produces much faster code (the speed difference
+ is noticeable: several dozen percentages) and also more correct code:
+ if you are considering using the GNU C compiler you should use the
+ gcc 2.95.3 since all older gcc releases are known to produce broken
+ code when compiling Perl. One manifestation of this brokenness is
+ the lib/sdbm test dumping core; another is the op/regexp dumping core
+ (depending on the GCC release).
+
+ =head2 Using Large Files with Perl on Tru64
+
+ In Tru64 Perl is automatically able to use large files, that is, files
+ larger than 2 gigabytes, there is no need to use the Configure
+ -Duselargefiles option as described in INSTALL.
+
+ =head2 Threaded Perl on Tru64
+
+ To compile Perl to use the old Perl 5.005 threads model, run Configure
+ with the -Dusethreads -Duse5005threads options as described in INSTALL.
+ This will probably only work in Tru64 4.0 and newer releases, older
+ operating releases like 3.2 aren't probably going to work properly
+ with threads.
+
+ Beware: the Perl 5.005 threads model is known to have bugs, for
+ example the regular expressions are not thread-safe. The bugs are
+ very hard to fix are and therefore the 5.005 threads model is still
+ classified as an experimental feature.
+
+ =head2 Long Doubles on Tru64
+
+ You cannot Configure Perl to use long doubles unless you have at least
+ Tru64 V5.0, the long double support simply wasn't functional before
+ that.
+
+ =head2 64-bit Perl on Tru64
+
+ In Tru64 Perl's integers are automatically 64-bit wide, there is
+ no need to use the Configure -Duse64bitint option as described
+ in INSTALL. Similarly, there is no need for -Duse64bitall.
+
+ =head2 Warnings about floating-point overflow when compiling Perl on Tru64
+
+ When compiling Perl in Tru64 you may (depending on the compiler
+ release) see two warnings like this
+
+ cc: Warning: numeric.c, line 104: In this statement, floating-point overflow occurs in evaluating the expression "1.8e308". (floatoverfl)
+ return HUGE_VAL;
+ -----------^
+
+ cc: Warning: POSIX.xs, line 1304: In this statement, floating-point overflow occurs in evaluating the expression "1.8e308". (floatoverfl)
+ return HUGE_VAL;
+ -------------------^
+
+ The exact line numbers may vary between Perl releases.
+ The warnings are benign and can be ignored.
+
+ When the file F<pp_sys.c> is being compiled you may (depending on the
+ operating system release) see an additional compiler flag being used:
+ C<-DNO_EFF_ONLY_OK>. This is normal and refers to a feature that is
+ relevant only if you use the C<filetest> pragma. In older releases of
+ the operating system the feature was broken and the NO_EFF_ONLY_OK
+ instructs Perl not to use the feature.
+
+ =head1 Testing Perl on Tru64
+
+ During "make test" the C<comp/cpp> will be skipped because on Tru64 it
+ cannot be tested before Perl has been installed. The test refers to
+ the use of the C<-P> option of Perl.
+
+ =head1 AUTHOR
+
+ Jarkko Hietaniemi <jhi@iki.fi>
+
+ =cut
diff -c /dev/null 'perl-5.7.2/README.uts'
Index: ./README.uts
*** ./README.uts Thu Jan 1 02:00:00 1970
--- ./README.uts Thu Jul 12 21:55:51 2001
***************
*** 0 ****
--- 1,107 ----
+ If you read this file _as_is_, just ignore the funny characters you
+ see. It is written in the POD format (see perlpod manpage) which is
+ specially designed to be readable as is.
+
+ =head1 NAME
+
+ perluts - Perl under UTS
+
+ =head1 SYNOPSIS
+
+ This document can be read I<as is>: as F<README.uts>, or you
+ can read it after you build your package using "man perluts".
+
+ The purpose is to help you build Perl for UTS, which, if you
+ follow these instructions, should be easy, and result in
+ a solidly working installation.
+
+ =head1 DESCRIPTION
+
+ Perl 5.7.2 (Developmental) or Perl 5.8.x (forthcoming) for UTS
+
+ =head1 BUILDING PERL ON UTS
+
+ NOTE: Some sites have redefined the way uname works, and if yours
+ does this, special steps must be taken so that Configure can
+ recognize your system as a UTS system. To see if you are in
+ this category, issue the command "uname -a". It should look
+ something like:
+
+ uts juno 4 4.4 9672 370
+
+ At any rate, the first field should be "uts". If this is not
+ the case; supposing it is, say telcoUTS, create a script, uts/uname
+ (i.e. uname, in the subdirectory "uts" of the main Perl source dir):
+ # uname
+ /usr/bin/uname "$@" | sed -e 's/^telcoUTS/uts/'
+
+ and when you execute Configure, do it as below, except for adding
+ PATH=uts:$PATH as a prefix. I.e. do:
+
+ PATH=uts:$PATH ./Configure ...
+
+ There is no need to do an interactive configure, just type
+
+ ./Configure -de [-Dusedevel] [-Doptimize=-g ] 2>&1 | tee Conf.out
+
+ "-Dusedevel" may be required to configure Perl 5.7.2 non-interactively.
+ Use -Doptimize=-g if you want to run Perl under sdb or gdb, OR
+ if you want to be able to use the -D command line flags to perl,
+ which are occasionally useful in debugging perl scripts.
+
+ In this and the following steps, the "2>&1 | tee XXX.out" records all
+ output from the process, which will be useful if anything unexpected
+ goes wrong.
+
+ Then do the compilation with
+
+ make 2>&1 | tee make.out
+
+ Finally, test using
+
+ make test 2>&1 | tee make-test.out
+
+ In the output, the only failures you should see should look like:
+
+ lib/Math/BigInt/t/bigfltpm.........Use of uninitialized value ...
+ FAILED at test 57
+ lib/Math/BigInt/t/bigintc..........ok
+ lib/Math/BigInt/t/bigintpm.........FAILED at test 204
+ lib/Math/BigInt/t/mbimbf...........Use of uninitialized value ...
+ Illegal division by zero at ../lib/Math/BigInt/Calc.pm line 314.
+ FAILED at test 71
+ lib/Math/Complex...................exp: OVERFLOW
+ FAILED at test 250
+ lib/Math/Trig......................exp: OVERFLOW
+ ok
+ lib/Memoize/t/array................ok
+ ...
+ lib/Net/protoent...................ok
+ lib/Net/servent....................FAILED at test 0
+
+ This means that everything passes except for some problems in the
+ packages "Math::BigInt", "Math::Complex", and "Math::Trig".
+ The lib/Net/servent failure seems to be a bug in the test
+ program. To confirm this, from the main Perl source dir, do:
+
+ LD_LIBRARY_PATH=`pwd` ./perl -Ilib lib/Net/servent.t
+
+ and it should output
+
+ 1..3
+ ok 1
+ ok 2
+ ok 3
+
+ =head1 Installing the built perl on UTS
+
+ Run the command "make install"
+
+ =head1 AUTHOR
+
+ Hal Morris
+ UTS Global LLC
+ email: hom00@utsglobal.com
+
+ =cut
+
diff -c 'perl-5.7.1/README.vmesa' 'perl-5.7.2/README.vmesa'
Index: ./README.vmesa
*** ./README.vmesa Mon Mar 19 20:59:13 2001
--- ./README.vmesa Mon Jul 9 17:09:46 2001
***************
*** 26,38 ****
installed by default). You may need to worry about the networking
configuration files discussed in the last bullet below.
! =head2 Unpacking
To extract an ASCII tar archive on VM/ESA, try this:
pax -o to=IBM-1047,from=ISO8859-1 -r < latest.tar
! =head2 Setup and utilities
GNU make for VM/ESA, which may be required for the build of perl,
is available from:
--- 26,38 ----
installed by default). You may need to worry about the networking
configuration files discussed in the last bullet below.
! =head2 Unpacking Perl Distribution on VM/ESA
To extract an ASCII tar archive on VM/ESA, try this:
pax -o to=IBM-1047,from=ISO8859-1 -r < latest.tar
! =head2 Setup Perl and utilities on VM/ESA
GNU make for VM/ESA, which may be required for the build of perl,
is available from:
***************
*** 39,45 ****
http://pucc.princeton.edu/~neale/vmoe.html
! =head2 Configure
Once you've unpacked the distribution, run Configure (see INSTALL for
full discussion of the Configure options), and then run make, then
--- 39,45 ----
http://pucc.princeton.edu/~neale/vmoe.html
! =head2 Configure Perl on VM/ESA
Once you've unpacked the distribution, run Configure (see INSTALL for
full discussion of the Configure options), and then run make, then
***************
*** 56,68 ****
this port does support dynamic loading but it's not had much testing
=item *
!
Don't turn on the compiler optimization flag "-O". There's
a bug in the compiler (APAR PQ18812) that generates some bad code
the optimizer is on.
=item *
!
As VM/ESA doesn't fully support the fork() API programs relying on
this call will not work. I've replaced fork()/exec() with spawn()
and the standalone exec() with spawn(). This has a side effect when
--- 56,68 ----
this port does support dynamic loading but it's not had much testing
=item *
!
Don't turn on the compiler optimization flag "-O". There's
a bug in the compiler (APAR PQ18812) that generates some bad code
the optimizer is on.
=item *
!
As VM/ESA doesn't fully support the fork() API programs relying on
this call will not work. I've replaced fork()/exec() with spawn()
and the standalone exec() with spawn(). This has a side effect when
***************
*** 79,85 ****
=back
! =head2 testing anomalies
The `make test` step runs a Perl Verification Procedure, usually before
installation. As the 5.6.1 kit was was being assembled
--- 79,85 ----
=back
! =head2 Testing Anomalies of Perl on VM/ESA
The `make test` step runs a Perl Verification Procedure, usually before
installation. As the 5.6.1 kit was was being assembled
***************
*** 89,96 ****
[the list of failures being compiled]
! =head2 Usage Hints
!
When using perl on VM/ESA please keep in mind that the EBCDIC and ASCII
character sets are different. Perl builtin functions that may behave
differently under EBCDIC are mentioned in the perlport.pod document.
--- 89,96 ----
[the list of failures being compiled]
! =head2 Usage Hints for Perl on VM/ESA
!
When using perl on VM/ESA please keep in mind that the EBCDIC and ASCII
character sets are different. Perl builtin functions that may behave
differently under EBCDIC are mentioned in the perlport.pod document.
***************
*** 112,123 ****
L<INSTALL>, L<perlport>, L<perlebcdic>.
! =head2 Mailing list
! If you are interested in the VM and OS/390 ports of perl then see the
! perl-mvs mailing list: The Perl Institute (http://www.perl.org/)
! maintains a mailing list of interest to all folks building and/or
! using perl on EBCDIC platforms. To subscribe, send a message of:
subscribe perl-mvs
--- 112,124 ----
L<INSTALL>, L<perlport>, L<perlebcdic>.
! =head2 Mailing list for Perl on VM/ESA
! If you are interested in the VM/ESA, z/OS (formerly known as OS/390)
! and POSIX-BC (BS2000) ports of Perl then see the perl-mvs mailing list:
! The Perl Institute (http://www.perl.org/) maintains a mailing list of
! interest to all folks building and/or using perl on EBCDIC platforms.
! To subscribe, send a message of:
subscribe perl-mvs
diff -c 'perl-5.7.1/README.vms' 'perl-5.7.2/README.vms'
Index: ./README.vms
*** ./README.vms Fri Apr 6 01:51:37 2001
--- ./README.vms Mon Jul 9 17:09:46 2001
***************
*** 36,42 ****
instead.
! =head2 Introduction
The VMS port of Perl is as functionally complete as any other Perl port
(and as complete as the ports on some Unix systems). The Perl binaries
--- 36,42 ----
instead.
! =head2 Introduction to Perl on VMS
The VMS port of Perl is as functionally complete as any other Perl port
(and as complete as the ports on some Unix systems). The Perl binaries
***************
*** 59,65 ****
relatively modern version, check the "DEC C issues" section later on in this
document.
! =head2 Other required software
In addition to VMS and DCL you will need two things:
--- 59,65 ----
relatively modern version, check the "DEC C issues" section later on in this
document.
! =head2 Other required software for Compiling Perl on VMS
In addition to VMS and DCL you will need two things:
***************
*** 79,85 ****
=back
! =head2 Additional software that is optional
You may also want to have on hand:
--- 79,85 ----
=back
! =head2 Additional software that is optional for Perl on VMS
You may also want to have on hand:
***************
*** 180,185 ****
--- 180,187 ----
T "LOGICAL"
FOO "LOGICAL"
EXT "LOGICAL"
+ SOME_LOGICAL_NAME_NOT_LIKELY "LOGICAL"
+ DOWN_LOGICAL_NAME_NOT_LIKELY "LOGICAL"
TEST "SYMBOL"
As a handy shortcut, the command:
***************
*** 205,211 ****
fresh (optional)" and the checklist of items in the "CAVEATS" sections
below.
! =head2 Changing compile-time options (optional)
Most of the user definable features of Perl are enabled or disabled in
[.VMS]CONFIG.VMS. There is code in there to Do The Right Thing, but that
--- 207,213 ----
fresh (optional)" and the checklist of items in the "CAVEATS" sections
below.
! =head2 Changing compile-time options (optional) for Perl on VMS
Most of the user definable features of Perl are enabled or disabled in
[.VMS]CONFIG.VMS. There is code in there to Do The Right Thing, but that
***************
*** 222,228 ****
requires changes in genconfig.pl as well. Be really careful if you need to
change these, as they can cause some fairly subtle problems.
! =head2 Socket Support (optional)
Perl includes a number of functions for IP sockets, which are available if
you choose to compile Perl with socket support. Since IP networking is an
--- 224,230 ----
requires changes in genconfig.pl as well. Be really careful if you need to
change these, as they can cause some fairly subtle problems.
! =head2 Socket Support (optional) for Perl on VMS
Perl includes a number of functions for IP sockets, which are available if
you choose to compile Perl with socket support. Since IP networking is an
***************
*** 320,326 ****
MMK you are running try "MMS/ident" or "MMK /ident". The GNU make version
can be identified with "make --version".
! =head2 Cleaning up and starting fresh (optional)
If you need to recompile from scratch, you have to make sure you clean up
first. There is a procedure to do it--enter the *exact* MMS line you used
--- 322,328 ----
MMK you are running try "MMS/ident" or "MMK /ident". The GNU make version
can be identified with "make --version".
! =head2 Cleaning up and starting fresh (optional) installing Perl on VMS
If you need to recompile from scratch, you have to make sure you clean up
first. There is a procedure to do it--enter the *exact* MMS line you used
***************
*** 406,412 ****
See also the "INSTALLing images (optional)" section.
! =head2 Installing Perl into DCLTABLES (optional)
Execute the following command file to define PERL as a DCL command.
You'll need CMKRNL privilege to install the new dcltables.exe.
--- 408,414 ----
See also the "INSTALLing images (optional)" section.
! =head2 Installing Perl into DCLTABLES (optional) on VMS
Execute the following command file to define PERL as a DCL command.
You'll need CMKRNL privilege to install the new dcltables.exe.
***************
*** 424,430 ****
$ install replace sys$common:[syslib]dcltables.exe
$ exit
! =head2 INSTALLing images (optional)
On systems that are using perl quite a bit, and particularly those with
minimal RAM, you can boost the performance of perl by INSTALLing it as
--- 426,432 ----
$ install replace sys$common:[syslib]dcltables.exe
$ exit
! =head2 INSTALLing Perl images (optional) on VMS
On systems that are using perl quite a bit, and particularly those with
minimal RAM, you can boost the performance of perl by INSTALLing it as
***************
*** 492,498 ****
build. If things go wrong make sure you do a "(MMK|MMS|make) realclean"
before you rebuild.
! =head2 DEC C issues
Note to DEC C users: Some early versions (pre-5.2, some pre-4. If you're DEC
C 5.x or higher, with current patches if any, you're fine) of the DECCRTL
--- 494,500 ----
build. If things go wrong make sure you do a "(MMK|MMS|make) realclean"
before you rebuild.
! =head2 DEC C issues with Perl on VMS
Note to DEC C users: Some early versions (pre-5.2, some pre-4. If you're DEC
C 5.x or higher, with current patches if any, you're fine) of the DECCRTL
***************
*** 529,535 ****
Please note that in later versions "DEC C" may also be known as
"Compaq C".
! =head2 GNU issues
It has been a while since the GNU utilities such as GCC or GNU make
were used to build perl on VMS. Hence they may require a great deal
--- 531,537 ----
Please note that in later versions "DEC C" may also be known as
"Compaq C".
! =head2 GNU issues with Perl on VMS
It has been a while since the GNU utilities such as GCC or GNU make
were used to build perl on VMS. Hence they may require a great deal
***************
*** 553,563 ****
on the web at:
http://www.xray.mpe.mpg.de/mailing-lists/vmsperl/
!
To unsubscribe from VMSPERL send a message to VMSPERL-UNSUBSCRIBE@PERL.ORG.
Be sure to do so from the subscribed account that you are canceling.
! =head2 Web sites
Vmsperl pages on the web include:
--- 555,565 ----
on the web at:
http://www.xray.mpe.mpg.de/mailing-lists/vmsperl/
!
To unsubscribe from VMSPERL send a message to VMSPERL-UNSUBSCRIBE@PERL.ORG.
Be sure to do so from the subscribed account that you are canceling.
! =head2 Web sites for Perl on VMS
Vmsperl pages on the web include:
diff -c 'perl-5.7.1/README.vos' 'perl-5.7.2/README.vos'
Index: ./README.vos
*** ./README.vos Tue Mar 6 04:04:20 2001
--- ./README.vos Mon Jul 9 17:09:46 2001
***************
*** 8,16 ****
=head1 SYNOPSIS
! This is a port of Perl version 5, revision 7, to VOS. Perl is a
! scripting or macro language that is popular on many systems. See your
! local computer bookstore for a number of good books on Perl.
=head2 Stratus POSIX Support
--- 8,16 ----
=head1 SYNOPSIS
! This is a port of Perl version 5 to VOS. Perl is a scripting or
! macro language that is popular on many systems. See your local
! computer bookstore for a number of good books on Perl.
=head2 Stratus POSIX Support
***************
*** 17,26 ****
Note that there are two different implementations of POSIX.1
support on VOS. There is an alpha version of POSIX that is
available from the Stratus anonymous ftp site
! (ftp://ftp.stratus.com/pub/vos/posix/alpha/alpha.html). There
! is a generally-available version of POSIX that comes with the
! VOS Standard C compiler and C runtime in VOS Release 14.3.0 or
! higher. This port of POSIX will compile and bind with either
version of POSIX.
Most of the Perl features should work on VOS regardless of which
--- 17,26 ----
Note that there are two different implementations of POSIX.1
support on VOS. There is an alpha version of POSIX that is
available from the Stratus anonymous ftp site
! (ftp://ftp.stratus.com/pub/vos/posix/alpha/alpha.html). There is
! a generally-available version of POSIX that comes with the VOS
! Standard C Compiler or VOS C runtime in VOS Release 14.3.0 or
! higher. This port of perl will compile and bind with either
version of POSIX.
Most of the Perl features should work on VOS regardless of which
***************
*** 29,39 ****
attempt by perl.pm to call the following unimplemented POSIX
functions will result in an error message and an immediate and
fatal call to the VOS debugger. They are "dup", "fork", and
! "waitpid". The lack of these functions pretty much prevents you
! from starting VOS commands and grabbing their output in perl.
! The workaround is to run the commands outside of perl, then have
! perl process the output file. These functions are all available
! in the generally-available version of POSIX.
=head1 INSTALLING PERL IN VOS
--- 29,39 ----
attempt by perl.pm to call the following unimplemented POSIX
functions will result in an error message and an immediate and
fatal call to the VOS debugger. They are "dup", "fork", and
! "waitpid". The lack of these functions prevents you from
! starting VOS commands and grabbing their output in perl. The
! workaround is to run the commands outside of perl, then have perl
! process the output file. These functions are all available in
! the generally-available version of POSIX.
=head1 INSTALLING PERL IN VOS
***************
*** 46,53 ****
=item 1
! The VOS Standard C Compiler and Runtime, or the VOS Standard C
! Cross-Compiler. This is a standard Stratus product.
=item 2
--- 46,56 ----
=item 1
! The VOS Standard C Compiler (or the VOS Standard C
! Cross-Compiler) and the VOS C Runtime. If you are using
! the generally-available version of POSIX support, you may
! instead use the the VOS GNU C/C++ Compiler. These are
! standard Stratus products.
=item 2
***************
*** 72,81 ****
are at ftp://ftp.stratus.com/pub/vos/utility/utility.html.
This is not a standard Stratus product.
! The generally-available version of POSIX.1 support is
! bundled with the VOS Standard C compiler and Runtime (or
! Cross-Compiler) in VOS Release 14.3.0 or higher. This is a
! standard Stratus product.
=item 4
--- 75,85 ----
are at ftp://ftp.stratus.com/pub/vos/utility/utility.html.
This is not a standard Stratus product.
! In VOS Release 14.3.0, the generally-available version of
! POSIX.1 support is bundled with the VOS Standard C compiler
! (or Standard C Cross-Compiler). In VOS Release 14.4.0 or
! higher, it is also bundled with the VOS C Runtime. These
! are standard Stratus products.
=item 4
***************
*** 85,90 ****
--- 89,104 ----
release-compatibility rules, this port of perl may not
execute on VOS Release 12 or earlier.
+ =item 5
+
+ If you are using the generally-available version of VOS POSIX
+ support, then you should also acquire the VOS GNU C/C++ Compiler
+ and GNU Tools product because it provides many common Unix or
+ POSIX commands. When perl is built with this version of POSIX
+ support, it assumes that it can find "bash", "sed" and other
+ POSIX-compatible commands in the directory
+ /system/gnu_library/bin.
+
=back
To build perl 5, change to the "vos" subdirectory and type the
***************
*** 93,98 ****
--- 107,122 ----
Note that the generally-available version of POSIX.1 support is
not available for the mc68020 or i80860 processors.
+ Use the "-version alpha" control argument to build perl with
+ the alpha version of POSIX support, and use the "-version
+ ga" control argument to build it with the
+ generally-available version of POSIX. The default is "ga".
+
+ Use the "-compiler cc" control argument to build perl with
+ the VOS Standard C compiler. Use the "-compiler gcc"
+ control argument to build it with the GNU GCC compiler. The
+ default is "cc".
+
You must have purchased the VOS Standard C Cross Compiler in
order to compile perl for a processor type that is different
from the processor type of the module.
***************
*** 172,178 ****
=head1 USING PERL IN VOS
! =head2 Unimplemented Features
If perl is built with the alpha version of VOS POSIX.1 support
and if it attempts to call an unimplemented VOS POSIX.1
--- 196,202 ----
=head1 USING PERL IN VOS
! =head2 Unimplemented Features of Perl on VOS
If perl is built with the alpha version of VOS POSIX.1 support
and if it attempts to call an unimplemented VOS POSIX.1
***************
*** 182,188 ****
functions are unimplemented and what the error message looks
like, compile and execute "test_vos_dummies.c".
! =head2 Restrictions
This port of Perl version 5 to VOS prefers Unix-style,
slash-separated pathnames over VOS-style greater-than-separated
--- 206,212 ----
functions are unimplemented and what the error message looks
like, compile and execute "test_vos_dummies.c".
! =head2 Restrictions of Perl on VOS
This port of Perl version 5 to VOS prefers Unix-style,
slash-separated pathnames over VOS-style greater-than-separated
***************
*** 213,218 ****
=head1 LAST UPDATE
! October 24, 2000
=cut
--- 237,242 ----
=head1 LAST UPDATE
! July 4, 2001
=cut
diff -c 'perl-5.7.1/README.win32' 'perl-5.7.2/README.win32'
Index: ./README.win32
*** ./README.win32 Tue Apr 10 05:29:17 2001
--- ./README.win32 Fri Jul 13 17:18:33 2001
***************
*** 1,716 ****
! If you read this file _as_is_, just ignore the funny characters you
! see. It is written in the POD format (see pod/perlpod.pod) which is
! specially designed to be readable as is.
!
! =head1 NAME
!
! perlwin32 - Perl under Win32
!
! =head1 SYNOPSIS
!
! These are instructions for building Perl under Windows (9x, NT and
! 2000).
!
! =head1 DESCRIPTION
!
! Before you start, you should glance through the README file
! found in the top-level directory to which the Perl distribution
! was extracted. Make sure you read and understand the terms under
! which this software is being distributed.
!
! Also make sure you read L<BUGS AND CAVEATS> below for the
! known limitations of this port.
!
! The INSTALL file in the perl top-level has much information that is
! only relevant to people building Perl on Unix-like systems. In
! particular, you can safely ignore any information that talks about
! "Configure".
!
! You may also want to look at two other options for building
! a perl that will work on Windows NT: the README.cygwin and
! README.os2 files, each of which give a different set of rules to
! build a Perl that will work on Win32 platforms. Those two methods
! will probably enable you to build a more Unix-compatible perl, but
! you will also need to download and use various other build-time and
! run-time support software described in those files.
!
! This set of instructions is meant to describe a so-called "native"
! port of Perl to Win32 platforms. The resulting Perl requires no
! additional software to run (other than what came with your operating
! system). Currently, this port is capable of using one of the
! following compilers:
!
! Borland C++ version 5.02 or later
! Microsoft Visual C++ version 4.2 or later
! Mingw32 with GCC version 2.95.2 or better
!
! The last of these is a high quality freeware compiler. Support
! for it is still experimental. (Older versions of GCC are known
! not to work.)
!
! This port currently supports MakeMaker (the set of modules that
! is used to build extensions to perl). Therefore, you should be
! able to build and install most extensions found in the CPAN sites.
! See L<Usage Hints> below for general hints about this.
!
! =head2 Setting Up
!
! =over 4
!
! =item Make
!
! You need a "make" program to build the sources. If you are using
! Visual C++ under Windows NT or 2000, nmake will work. All other
! builds need dmake.
!
! dmake is a freely available make that has very nice macro features
! and parallelability.
!
! A port of dmake for Windows is available from:
!
! http://www.cpan.org/authors/id/GSAR/dmake-4.1pl1-win32.zip
!
! (This is a fixed version of the original dmake sources obtained from
! http://www.wticorp.com/dmake/. As of version 4.1PL1, the original
! sources did not build as shipped and had various other problems.
! A patch is included in the above fixed version.)
!
! Fetch and install dmake somewhere on your path (follow the instructions
! in the README.NOW file).
!
! There exists a minor coexistence problem with dmake and Borland C++
! compilers. Namely, if a distribution has C files named with mixed
! case letters, they will be compiled into appropriate .obj-files named
! with all lowercase letters, and every time dmake is invoked
! to bring files up to date, it will try to recompile such files again.
! For example, Tk distribution has a lot of such files, resulting in
! needless recompiles everytime dmake is invoked. To avoid this, you
! may use the script "sncfnmcs.pl" after a successful build. It is
! available in the win32 subdirectory of the Perl source distribution.
!
! =item Command Shell
!
! Use the default "cmd" shell that comes with NT. Some versions of the
! popular 4DOS/NT shell have incompatibilities that may cause you trouble.
! If the build fails under that shell, try building again with the cmd
! shell.
!
! The nmake Makefile also has known incompatibilities with the
! "command.com" shell that comes with Windows 9x. You will need to
! use dmake and makefile.mk to build under Windows 9x.
!
! The surest way to build it is on Windows NT, using the cmd shell.
!
! Make sure the path to the build directory does not contain spaces. The
! build usually works in this circumstance, but some tests will fail.
!
! =item Borland C++
!
! If you are using the Borland compiler, you will need dmake.
! (The make that Borland supplies is seriously crippled and will not
! work for MakeMaker builds.)
!
! See L</"Make"> above.
!
! =item Microsoft Visual C++
!
! The nmake that comes with Visual C++ will suffice for building.
! You will need to run the VCVARS32.BAT file, usually found somewhere
! like C:\MSDEV4.2\BIN. This will set your build environment.
!
! You can also use dmake to build using Visual C++; provided, however,
! you set OSRELEASE to "microsft" (or whatever the directory name
! under which the Visual C dmake configuration lives) in your environment
! and edit win32/config.vc to change "make=nmake" into "make=dmake". The
! latter step is only essential if you want to use dmake as your default
! make for building extensions using MakeMaker.
!
! =item Mingw32 with GCC
!
! GCC-2.95.2 binaries can be downloaded from:
!
! ftp://ftp.xraylith.wisc.edu/pub/khan/gnu-win32/mingw32/
!
! You also need dmake. See L</"Make"> above on how to get it.
!
! The GCC-2.95.2 bundle comes with Mingw32 libraries and headers.
!
! Make sure you install the binaries that work with MSVCRT.DLL as indicated
! in the README for the GCC bundle. You may need to set up a few environment
! variables (usually ran from a batch file).
!
! There are a couple of problems with the version of gcc-2.95.2-msvcrt.exe
! released 7 November 1999:
!
! =over
!
! =item *
!
! It left out a fix for certain command line quotes. To fix this, be sure
! to download and install the file fixes/quote-fix-msvcrt.exe from the above
! ftp location.
!
! =item *
!
! The definition of the fpos_t type in stdio.h may be wrong. If your
! stdio.h has this problem, you will see an exception when running the
! test t/lib/io_xs.t. To fix this, change the typedef for fpos_t from
! "long" to "long long" in the file i386-mingw32msvc/include/stdio.h,
! and rebuild.
!
! =back
!
! A potentially simpler to install (but probably soon-to-be-outdated) bundle
! of the above package with the mentioned fixes already applied is available
! here:
!
! http://downloads.ActiveState.com/pub/staff/gsar/gcc-2.95.2-msvcrt.zip
! ftp://ftp.ActiveState.com/pub/staff/gsar/gcc-2.95.2-msvcrt.zip
!
! =back
!
! =head2 Building
!
! =over 4
!
! =item *
!
! Make sure you are in the "win32" subdirectory under the perl toplevel.
! This directory contains a "Makefile" that will work with
! versions of nmake that come with Visual C++, and a dmake "makefile.mk"
! that will work for all supported compilers. The defaults in the dmake
! makefile are setup to build using the GCC compiler.
!
! =item *
!
! Edit the makefile.mk (or Makefile, if you're using nmake) and change
! the values of INST_DRV and INST_TOP. You can also enable various
! build flags. These are explained in the makefiles.
!
! You will have to make sure that CCTYPE is set correctly and that
! CCHOME points to wherever you installed your compiler.
!
! The default value for CCHOME in the makefiles for Visual C++
! may not be correct for some versions. Make sure the default exists
! and is valid.
!
! If you have either the source or a library that contains des_fcrypt(),
! enable the appropriate option in the makefile. des_fcrypt() is not
! bundled with the distribution due to US Government restrictions
! on the export of cryptographic software. Nevertheless, this routine
! is part of the "libdes" library (written by Eric Young) which is widely
! available worldwide, usually along with SSLeay (for example,
! "ftp://fractal.mta.ca/pub/crypto/SSLeay/DES/"). Set CRYPT_SRC to the
! name of the file that implements des_fcrypt(). Alternatively, if
! you have built a library that contains des_fcrypt(), you can set
! CRYPT_LIB to point to the library name. The location above contains
! many versions of the "libdes" library, all with slightly different
! implementations of des_fcrypt(). Older versions have a single,
! self-contained file (fcrypt.c) that implements crypt(), so they may be
! easier to use. A patch against the fcrypt.c found in libdes-3.06 is
! in des_fcrypt.patch.
!
! Perl will also build without des_fcrypt(), but the crypt() builtin will
! fail at run time.
!
! Be sure to read the instructions near the top of the makefiles carefully.
!
! =item *
!
! Type "dmake" (or "nmake" if you are using that make).
!
! This should build everything. Specifically, it will create perl.exe,
! perl56.dll at the perl toplevel, and various other extension dll's
! under the lib\auto directory. If the build fails for any reason, make
! sure you have done the previous steps correctly.
!
! =back
!
! =head2 Testing
!
! Type "dmake test" (or "nmake test"). This will run most of the tests from
! the testsuite (many tests will be skipped).
!
! There should be no test failures when running under Windows NT 4.0 or
! Windows 2000. Many tests I<will> fail under Windows 9x due to the inferior
! command shell.
!
! Some test failures may occur if you use a command shell other than the
! native "cmd.exe", or if you are building from a path that contains
! spaces. So don't do that.
!
! If you are running the tests from a emacs shell window, you may see
! failures in op/stat.t. Run "dmake test-notty" in that case.
!
! If you're using the Borland compiler, you may see a failure in op/taint.t
! arising from the inability to find the Borland Runtime DLLs on the system
! default path. You will need to copy the DLLs reported by the messages
! from where Borland chose to install it, into the Windows system directory
! (usually somewhere like C:\WINNT\SYSTEM32) and rerun the test.
!
! If you're using Borland compiler versions 5.2 and below, you may run into
! problems finding the correct header files when building extensions. For
! example, building the "Tk" extension may fail because both perl and Tk
! contain a header file called "patchlevel.h". The latest Borland compiler
! (v5.5) is free of this misbehaviour, and it even supports an
! option -VI- for backward (bugward) compatibility for using the old Borland
! search algorithm to locate header files.
!
! Please report any other failures as described under L<BUGS AND CAVEATS>.
!
! =head2 Installation
!
! Type "dmake install" (or "nmake install"). This will put the newly
! built perl and the libraries under whatever C<INST_TOP> points to in the
! Makefile. It will also install the pod documentation under
! C<$INST_TOP\$VERSION\lib\pod> and HTML versions of the same under
! C<$INST_TOP\$VERSION\lib\pod\html>. To use the Perl you just installed,
! you will need to add two components to your PATH environment variable,
! C<$INST_TOP\$VERSION\bin> and C<$INST_TOP\$VERSION\bin\$ARCHNAME>.
! For example:
!
! set PATH c:\perl\5.6.0\bin;c:\perl\5.6.0\bin\MSWin32-x86;%PATH%
!
! If you opt to comment out INST_VER and INST_ARCH in the makefiles, the
! installation structure is much simpler. In that case, it will be
! sufficient to add a single entry to the path, for instance:
!
! set PATH c:\perl\bin;%PATH%
!
! =head2 Usage Hints
!
! =over 4
!
! =item Environment Variables
!
! The installation paths that you set during the build get compiled
! into perl, so you don't have to do anything additional to start
! using that perl (except add its location to your PATH variable).
!
! If you put extensions in unusual places, you can set PERL5LIB
! to a list of paths separated by semicolons where you want perl
! to look for libraries. Look for descriptions of other environment
! variables you can set in L<perlrun>.
!
! You can also control the shell that perl uses to run system() and
! backtick commands via PERL5SHELL. See L<perlrun>.
!
! Perl does not depend on the registry, but it can look up certain default
! values if you choose to put them there. Perl attempts to read entries from
! C<HKEY_CURRENT_USER\Software\Perl> and C<HKEY_LOCAL_MACHINE\Software\Perl>.
! Entries in the former override entries in the latter. One or more of the
! following entries (of type REG_SZ or REG_EXPAND_SZ) may be set:
!
! lib-$] version-specific standard library path to add to @INC
! lib standard library path to add to @INC
! sitelib-$] version-specific site library path to add to @INC
! sitelib site library path to add to @INC
! vendorlib-$] version-specific vendor library path to add to @INC
! vendorlib vendor library path to add to @INC
! PERL* fallback for all %ENV lookups that begin with "PERL"
!
! Note the C<$]> in the above is not literal. Substitute whatever version
! of perl you want to honor that entry, e.g. C<5.6.0>. Paths must be
! separated with semicolons, as usual on win32.
!
! =item File Globbing
!
! By default, perl handles file globbing using the File::Glob extension,
! which provides portable globbing.
!
! If you want perl to use globbing that emulates the quirks of DOS
! filename conventions, you might want to consider using File::DosGlob
! to override the internal glob() implementation. See L<File::DosGlob> for
! details.
!
! =item Using perl from the command line
!
! If you are accustomed to using perl from various command-line
! shells found in UNIX environments, you will be less than pleased
! with what Windows offers by way of a command shell.
!
! The crucial thing to understand about the Windows environment is that
! the command line you type in is processed twice before Perl sees it.
! First, your command shell (usually CMD.EXE on Windows NT, and
! COMMAND.COM on Windows 9x) preprocesses the command line, to handle
! redirection, environment variable expansion, and location of the
! executable to run. Then, the perl executable splits the remaining
! command line into individual arguments, using the C runtime library
! upon which Perl was built.
!
! It is particularly important to note that neither the shell nor the C
! runtime do any wildcard expansions of command-line arguments (so
! wildcards need not be quoted). Also, the quoting behaviours of the
! shell and the C runtime are rudimentary at best (and may, if you are
! using a non-standard shell, be inconsistent). The only (useful) quote
! character is the double quote ("). It can be used to protect spaces
! and other special characters in arguments.
!
! The Windows NT documentation has almost no description of how the
! quoting rules are implemented, but here are some general observations
! based on experiments: The C runtime breaks arguments at spaces and
! passes them to programs in argc/argv. Double quotes can be used to
! prevent arguments with spaces in them from being split up. You can
! put a double quote in an argument by escaping it with a backslash and
! enclosing the whole argument within double quotes. The backslash and
! the pair of double quotes surrounding the argument will be stripped by
! the C runtime.
!
! The file redirection characters "<", ">", and "|" can be quoted by
! double quotes (although there are suggestions that this may not always
! be true). Single quotes are not treated as quotes by the shell or
! the C runtime, they don't get stripped by the shell (just to make
! this type of quoting completely useless). The caret "^" has also
! been observed to behave as a quoting character, but this appears
! to be a shell feature, and the caret is not stripped from the command
! line, so Perl still sees it (and the C runtime phase does not treat
! the caret as a quote character).
!
! Here are some examples of usage of the "cmd" shell:
!
! This prints two doublequotes:
!
! perl -e "print '\"\"' "
!
! This does the same:
!
! perl -e "print \"\\\"\\\"\" "
!
! This prints "bar" and writes "foo" to the file "blurch":
!
! perl -e "print 'foo'; print STDERR 'bar'" > blurch
!
! This prints "foo" ("bar" disappears into nowhereland):
!
! perl -e "print 'foo'; print STDERR 'bar'" 2> nul
!
! This prints "bar" and writes "foo" into the file "blurch":
!
! perl -e "print 'foo'; print STDERR 'bar'" 1> blurch
!
! This pipes "foo" to the "less" pager and prints "bar" on the console:
!
! perl -e "print 'foo'; print STDERR 'bar'" | less
!
! This pipes "foo\nbar\n" to the less pager:
!
! perl -le "print 'foo'; print STDERR 'bar'" 2>&1 | less
!
! This pipes "foo" to the pager and writes "bar" in the file "blurch":
!
! perl -e "print 'foo'; print STDERR 'bar'" 2> blurch | less
!
!
! Discovering the usefulness of the "command.com" shell on Windows 9x
! is left as an exercise to the reader :)
!
! One particularly pernicious problem with the 4NT command shell for
! Windows NT is that it (nearly) always treats a % character as indicating
! that environment variable expansion is needed. Under this shell, it is
! therefore important to always double any % characters which you want
! Perl to see (for example, for hash variables), even when they are
! quoted.
!
! =item Building Extensions
!
! The Comprehensive Perl Archive Network (CPAN) offers a wealth
! of extensions, some of which require a C compiler to build.
! Look in http://www.cpan.org/ for more information on CPAN.
!
! Note that not all of the extensions available from CPAN may work
! in the Win32 environment; you should check the information at
! http://testers.cpan.org/ before investing too much effort into
! porting modules that don't readily build.
!
! Most extensions (whether they require a C compiler or not) can
! be built, tested and installed with the standard mantra:
!
! perl Makefile.PL
! $MAKE
! $MAKE test
! $MAKE install
!
! where $MAKE is whatever 'make' program you have configured perl to
! use. Use "perl -V:make" to find out what this is. Some extensions
! may not provide a testsuite (so "$MAKE test" may not do anything or
! fail), but most serious ones do.
!
! It is important that you use a supported 'make' program, and
! ensure Config.pm knows about it. If you don't have nmake, you can
! either get dmake from the location mentioned earlier or get an
! old version of nmake reportedly available from:
!
! ftp://ftp.microsoft.com/Softlib/MSLFILES/nmake15.exe
!
! Another option is to use the make written in Perl, available from
! CPAN:
!
! http://www.cpan.org/authors/id/NI-S/Make-0.03.tar.gz
!
! You may also use dmake. See L</"Make"> above on how to get it.
!
! Note that MakeMaker actually emits makefiles with different syntax
! depending on what 'make' it thinks you are using. Therefore, it is
! important that one of the following values appears in Config.pm:
!
! make='nmake' # MakeMaker emits nmake syntax
! make='dmake' # MakeMaker emits dmake syntax
! any other value # MakeMaker emits generic make syntax
! (e.g GNU make, or Perl make)
!
! If the value doesn't match the 'make' program you want to use,
! edit Config.pm to fix it.
!
! If a module implements XSUBs, you will need one of the supported
! C compilers. You must make sure you have set up the environment for
! the compiler for command-line compilation.
!
! If a module does not build for some reason, look carefully for
! why it failed, and report problems to the module author. If
! it looks like the extension building support is at fault, report
! that with full details of how the build failed using the perlbug
! utility.
!
! =item Command-line Wildcard Expansion
!
! The default command shells on DOS descendant operating systems (such
! as they are) usually do not expand wildcard arguments supplied to
! programs. They consider it the application's job to handle that.
! This is commonly achieved by linking the application (in our case,
! perl) with startup code that the C runtime libraries usually provide.
! However, doing that results in incompatible perl versions (since the
! behavior of the argv expansion code differs depending on the
! compiler, and it is even buggy on some compilers). Besides, it may
! be a source of frustration if you use such a perl binary with an
! alternate shell that *does* expand wildcards.
!
! Instead, the following solution works rather well. The nice things
! about it are 1) you can start using it right away; 2) it is more
! powerful, because it will do the right thing with a pattern like
! */*/*.c; 3) you can decide whether you do/don't want to use it; and
! 4) you can extend the method to add any customizations (or even
! entirely different kinds of wildcard expansion).
!
! C:\> copy con c:\perl\lib\Wild.pm
! # Wild.pm - emulate shell @ARGV expansion on shells that don't
! use File::DosGlob;
! @ARGV = map {
! my @g = File::DosGlob::glob($_) if /[*?]/;
! @g ? @g : $_;
! } @ARGV;
! 1;
! ^Z
! C:\> set PERL5OPT=-MWild
! C:\> perl -le "for (@ARGV) { print }" */*/perl*.c
! p4view/perl/perl.c
! p4view/perl/perlio.c
! p4view/perl/perly.c
! perl5.005/win32/perlglob.c
! perl5.005/win32/perllib.c
! perl5.005/win32/perlglob.c
! perl5.005/win32/perllib.c
! perl5.005/win32/perlglob.c
! perl5.005/win32/perllib.c
!
! Note there are two distinct steps there: 1) You'll have to create
! Wild.pm and put it in your perl lib directory. 2) You'll need to
! set the PERL5OPT environment variable. If you want argv expansion
! to be the default, just set PERL5OPT in your default startup
! environment.
!
! If you are using the Visual C compiler, you can get the C runtime's
! command line wildcard expansion built into perl binary. The resulting
! binary will always expand unquoted command lines, which may not be
! what you want if you use a shell that does that for you. The expansion
! done is also somewhat less powerful than the approach suggested above.
!
! =item Win32 Specific Extensions
!
! A number of extensions specific to the Win32 platform are available
! from CPAN. You may find that many of these extensions are meant to
! be used under the Activeware port of Perl, which used to be the only
! native port for the Win32 platform. Since the Activeware port does not
! have adequate support for Perl's extension building tools, these
! extensions typically do not support those tools either and, therefore,
! cannot be built using the generic steps shown in the previous section.
!
! To ensure smooth transitioning of existing code that uses the
! ActiveState port, there is a bundle of Win32 extensions that contains
! all of the ActiveState extensions and most other Win32 extensions from
! CPAN in source form, along with many added bugfixes, and with MakeMaker
! support. This bundle is available at:
!
! http://www.cpan.org/authors/id/GSAR/libwin32-0.151.zip
!
! See the README in that distribution for building and installation
! instructions. Look for later versions that may be available at the
! same location.
!
! =item Running Perl Scripts
!
! Perl scripts on UNIX use the "#!" (a.k.a "shebang") line to
! indicate to the OS that it should execute the file using perl.
! Win32 has no comparable means to indicate arbitrary files are
! executables.
!
! Instead, all available methods to execute plain text files on
! Win32 rely on the file "extension". There are three methods
! to use this to execute perl scripts:
!
! =over 8
!
! =item 1
!
! There is a facility called "file extension associations" that will
! work in Windows NT 4.0. This can be manipulated via the two
! commands "assoc" and "ftype" that come standard with Windows NT
! 4.0. Type "ftype /?" for a complete example of how to set this
! up for perl scripts (Say what? You thought Windows NT wasn't
! perl-ready? :).
!
! =item 2
!
! Since file associations don't work everywhere, and there are
! reportedly bugs with file associations where it does work, the
! old method of wrapping the perl script to make it look like a
! regular batch file to the OS, may be used. The install process
! makes available the "pl2bat.bat" script which can be used to wrap
! perl scripts into batch files. For example:
!
! pl2bat foo.pl
!
! will create the file "FOO.BAT". Note "pl2bat" strips any
! .pl suffix and adds a .bat suffix to the generated file.
!
! If you use the 4DOS/NT or similar command shell, note that
! "pl2bat" uses the "%*" variable in the generated batch file to
! refer to all the command line arguments, so you may need to make
! sure that construct works in batch files. As of this writing,
! 4DOS/NT users will need a "ParameterChar = *" statement in their
! 4NT.INI file or will need to execute "setdos /p*" in the 4DOS/NT
! startup file to enable this to work.
!
! =item 3
!
! Using "pl2bat" has a few problems: the file name gets changed,
! so scripts that rely on C<$0> to find what they must do may not
! run properly; running "pl2bat" replicates the contents of the
! original script, and so this process can be maintenance intensive
! if the originals get updated often. A different approach that
! avoids both problems is possible.
!
! A script called "runperl.bat" is available that can be copied
! to any filename (along with the .bat suffix). For example,
! if you call it "foo.bat", it will run the file "foo" when it is
! executed. Since you can run batch files on Win32 platforms simply
! by typing the name (without the extension), this effectively
! runs the file "foo", when you type either "foo" or "foo.bat".
! With this method, "foo.bat" can even be in a different location
! than the file "foo", as long as "foo" is available somewhere on
! the PATH. If your scripts are on a filesystem that allows symbolic
! links, you can even avoid copying "runperl.bat".
!
! Here's a diversion: copy "runperl.bat" to "runperl", and type
! "runperl". Explain the observed behavior, or lack thereof. :)
! Hint: .gnidnats llits er'uoy fi ,"lrepnur" eteled :tniH
!
! =back
!
! =item Miscellaneous Things
!
! A full set of HTML documentation is installed, so you should be
! able to use it if you have a web browser installed on your
! system.
!
! C<perldoc> is also a useful tool for browsing information contained
! in the documentation, especially in conjunction with a pager
! like C<less> (recent versions of which have Win32 support). You may
! have to set the PAGER environment variable to use a specific pager.
! "perldoc -f foo" will print information about the perl operator
! "foo".
!
! If you find bugs in perl, you can run C<perlbug> to create a
! bug report (you may have to send it manually if C<perlbug> cannot
! find a mailer on your system).
!
! =back
!
! =head1 BUGS AND CAVEATS
!
! Norton AntiVirus interferes with the build process, particularly if
! set to "AutoProtect, All Files, when Opened". Unlike large applications
! the perl build process opens and modifies a lot of files. Having the
! the AntiVirus scan each and every one slows build the process significantly.
! Worse, with PERLIO=stdio the build process fails with peculiar messages
! as the virus checker interacts badly with miniperl.exe writing configure
! files (it seems to either catch file part written and treat it as suspicious,
! or virus checker may have it "locked" in a way which inhibits miniperl
! updating it). The build does complete with
!
! set PERLIO=perlio
!
! but that may be just luck. Other AntiVirus software may have similar issues.
!
! Some of the built-in functions do not act exactly as documented in
! L<perlfunc>, and a few are not implemented at all. To avoid
! surprises, particularly if you have had prior exposure to Perl
! in other operating environments or if you intend to write code
! that will be portable to other environments. See L<perlport>
! for a reasonably definitive list of these differences.
!
! Not all extensions available from CPAN may build or work properly
! in the Win32 environment. See L</"Building Extensions">.
!
! Most C<socket()> related calls are supported, but they may not
! behave as on Unix platforms. See L<perlport> for the full list.
!
! Signal handling may not behave as on Unix platforms (where it
! doesn't exactly "behave", either :). For instance, calling C<die()>
! or C<exit()> from signal handlers will cause an exception, since most
! implementations of C<signal()> on Win32 are severely crippled.
! Thus, signals may work only for simple things like setting a flag
! variable in the handler. Using signals under this port should
! currently be considered unsupported.
!
! Please send detailed descriptions of any problems and solutions that
! you may find to <F<perlbug@perl.com>>, along with the output produced
! by C<perl -V>.
!
! =head1 AUTHORS
!
! =over 4
!
! =item Gary Ng E<lt>71564.1743@CompuServe.COME<gt>
!
! =item Gurusamy Sarathy E<lt>gsar@activestate.comE<gt>
!
! =item Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt>
!
! =back
!
! This document is maintained by Gurusamy Sarathy.
!
! =head1 SEE ALSO
!
! L<perl>
!
! =head1 HISTORY
!
! This port was originally contributed by Gary Ng around 5.003_24,
! and borrowed from the Hip Communications port that was available
! at the time. Various people have made numerous and sundry hacks
! since then.
!
! Borland support was added in 5.004_01 (Gurusamy Sarathy).
!
! GCC/mingw32 support was added in 5.005 (Nick Ing-Simmons).
!
! Support for PERL_OBJECT was added in 5.005 (ActiveState Tool Corp).
!
! Support for fork() emulation was added in 5.6 (ActiveState Tool Corp).
!
! Win9x support was added in 5.6 (Benjamin Stuhl).
!
! Last updated: 1 April 2001
!
! =cut
--- 1,716 ----
! If you read this file _as_is_, just ignore the funny characters you
! see. It is written in the POD format (see pod/perlpod.pod) which is
! specially designed to be readable as is.
!
! =head1 NAME
!
! perlwin32 - Perl under Win32
!
! =head1 SYNOPSIS
!
! These are instructions for building Perl under Windows (9x, NT and
! 2000).
!
! =head1 DESCRIPTION
!
! Before you start, you should glance through the README file
! found in the top-level directory to which the Perl distribution
! was extracted. Make sure you read and understand the terms under
! which this software is being distributed.
!
! Also make sure you read L<BUGS AND CAVEATS> below for the
! known limitations of this port.
!
! The INSTALL file in the perl top-level has much information that is
! only relevant to people building Perl on Unix-like systems. In
! particular, you can safely ignore any information that talks about
! "Configure".
!
! You may also want to look at two other options for building
! a perl that will work on Windows NT: the README.cygwin and
! README.os2 files, each of which give a different set of rules to
! build a Perl that will work on Win32 platforms. Those two methods
! will probably enable you to build a more Unix-compatible perl, but
! you will also need to download and use various other build-time and
! run-time support software described in those files.
!
! This set of instructions is meant to describe a so-called "native"
! port of Perl to Win32 platforms. The resulting Perl requires no
! additional software to run (other than what came with your operating
! system). Currently, this port is capable of using one of the
! following compilers:
!
! Borland C++ version 5.02 or later
! Microsoft Visual C++ version 4.2 or later
! Mingw32 with GCC version 2.95.2 or better
!
! The last of these is a high quality freeware compiler. Support
! for it is still experimental. (Older versions of GCC are known
! not to work.)
!
! This port currently supports MakeMaker (the set of modules that
! is used to build extensions to perl). Therefore, you should be
! able to build and install most extensions found in the CPAN sites.
! See L<Usage Hints for Perl on Win32> below for general hints about this.
!
! =head2 Setting Up Perl on Win32
!
! =over 4
!
! =item Make
!
! You need a "make" program to build the sources. If you are using
! Visual C++ under Windows NT or 2000, nmake will work. All other
! builds need dmake.
!
! dmake is a freely available make that has very nice macro features
! and parallelability.
!
! A port of dmake for Windows is available from:
!
! http://www.cpan.org/authors/id/GSAR/dmake-4.1pl1-win32.zip
!
! (This is a fixed version of the original dmake sources obtained from
! http://www.wticorp.com/dmake/. As of version 4.1PL1, the original
! sources did not build as shipped and had various other problems.
! A patch is included in the above fixed version.)
!
! Fetch and install dmake somewhere on your path (follow the instructions
! in the README.NOW file).
!
! There exists a minor coexistence problem with dmake and Borland C++
! compilers. Namely, if a distribution has C files named with mixed
! case letters, they will be compiled into appropriate .obj-files named
! with all lowercase letters, and every time dmake is invoked
! to bring files up to date, it will try to recompile such files again.
! For example, Tk distribution has a lot of such files, resulting in
! needless recompiles everytime dmake is invoked. To avoid this, you
! may use the script "sncfnmcs.pl" after a successful build. It is
! available in the win32 subdirectory of the Perl source distribution.
!
! =item Command Shell
!
! Use the default "cmd" shell that comes with NT. Some versions of the
! popular 4DOS/NT shell have incompatibilities that may cause you trouble.
! If the build fails under that shell, try building again with the cmd
! shell.
!
! The nmake Makefile also has known incompatibilities with the
! "command.com" shell that comes with Windows 9x. You will need to
! use dmake and makefile.mk to build under Windows 9x.
!
! The surest way to build it is on Windows NT, using the cmd shell.
!
! Make sure the path to the build directory does not contain spaces. The
! build usually works in this circumstance, but some tests will fail.
!
! =item Borland C++
!
! If you are using the Borland compiler, you will need dmake.
! (The make that Borland supplies is seriously crippled and will not
! work for MakeMaker builds.)
!
! See L</"Make"> above.
!
! =item Microsoft Visual C++
!
! The nmake that comes with Visual C++ will suffice for building.
! You will need to run the VCVARS32.BAT file, usually found somewhere
! like C:\MSDEV4.2\BIN. This will set your build environment.
!
! You can also use dmake to build using Visual C++; provided, however,
! you set OSRELEASE to "microsft" (or whatever the directory name
! under which the Visual C dmake configuration lives) in your environment
! and edit win32/config.vc to change "make=nmake" into "make=dmake". The
! latter step is only essential if you want to use dmake as your default
! make for building extensions using MakeMaker.
!
! =item Mingw32 with GCC
!
! GCC-2.95.2 binaries can be downloaded from:
!
! ftp://ftp.xraylith.wisc.edu/pub/khan/gnu-win32/mingw32/
!
! You also need dmake. See L</"Make"> above on how to get it.
!
! The GCC-2.95.2 bundle comes with Mingw32 libraries and headers.
!
! Make sure you install the binaries that work with MSVCRT.DLL as indicated
! in the README for the GCC bundle. You may need to set up a few environment
! variables (usually ran from a batch file).
!
! There are a couple of problems with the version of gcc-2.95.2-msvcrt.exe
! released 7 November 1999:
!
! =over
!
! =item *
!
! It left out a fix for certain command line quotes. To fix this, be sure
! to download and install the file fixes/quote-fix-msvcrt.exe from the above
! ftp location.
!
! =item *
!
! The definition of the fpos_t type in stdio.h may be wrong. If your
! stdio.h has this problem, you will see an exception when running the
! test t/lib/io_xs.t. To fix this, change the typedef for fpos_t from
! "long" to "long long" in the file i386-mingw32msvc/include/stdio.h,
! and rebuild.
!
! =back
!
! A potentially simpler to install (but probably soon-to-be-outdated) bundle
! of the above package with the mentioned fixes already applied is available
! here:
!
! http://downloads.ActiveState.com/pub/staff/gsar/gcc-2.95.2-msvcrt.zip
! ftp://ftp.ActiveState.com/pub/staff/gsar/gcc-2.95.2-msvcrt.zip
!
! =back
!
! =head2 Building
!
! =over 4
!
! =item *
!
! Make sure you are in the "win32" subdirectory under the perl toplevel.
! This directory contains a "Makefile" that will work with
! versions of nmake that come with Visual C++, and a dmake "makefile.mk"
! that will work for all supported compilers. The defaults in the dmake
! makefile are setup to build using the GCC compiler.
!
! =item *
!
! Edit the makefile.mk (or Makefile, if you're using nmake) and change
! the values of INST_DRV and INST_TOP. You can also enable various
! build flags. These are explained in the makefiles.
!
! You will have to make sure that CCTYPE is set correctly and that
! CCHOME points to wherever you installed your compiler.
!
! The default value for CCHOME in the makefiles for Visual C++
! may not be correct for some versions. Make sure the default exists
! and is valid.
!
! If you have either the source or a library that contains des_fcrypt(),
! enable the appropriate option in the makefile. des_fcrypt() is not
! bundled with the distribution due to US Government restrictions
! on the export of cryptographic software. Nevertheless, this routine
! is part of the "libdes" library (written by Eric Young) which is widely
! available worldwide, usually along with SSLeay (for example,
! "ftp://fractal.mta.ca/pub/crypto/SSLeay/DES/"). Set CRYPT_SRC to the
! name of the file that implements des_fcrypt(). Alternatively, if
! you have built a library that contains des_fcrypt(), you can set
! CRYPT_LIB to point to the library name. The location above contains
! many versions of the "libdes" library, all with slightly different
! implementations of des_fcrypt(). Older versions have a single,
! self-contained file (fcrypt.c) that implements crypt(), so they may be
! easier to use. A patch against the fcrypt.c found in libdes-3.06 is
! in des_fcrypt.patch.
!
! Perl will also build without des_fcrypt(), but the crypt() builtin will
! fail at run time.
!
! Be sure to read the instructions near the top of the makefiles carefully.
!
! =item *
!
! Type "dmake" (or "nmake" if you are using that make).
!
! This should build everything. Specifically, it will create perl.exe,
! perl56.dll at the perl toplevel, and various other extension dll's
! under the lib\auto directory. If the build fails for any reason, make
! sure you have done the previous steps correctly.
!
! =back
!
! =head2 Testing Perl on Win32
!
! Type "dmake test" (or "nmake test"). This will run most of the tests from
! the testsuite (many tests will be skipped).
!
! There should be no test failures when running under Windows NT 4.0 or
! Windows 2000. Many tests I<will> fail under Windows 9x due to the inferior
! command shell.
!
! Some test failures may occur if you use a command shell other than the
! native "cmd.exe", or if you are building from a path that contains
! spaces. So don't do that.
!
! If you are running the tests from a emacs shell window, you may see
! failures in op/stat.t. Run "dmake test-notty" in that case.
!
! If you're using the Borland compiler, you may see a failure in op/taint.t
! arising from the inability to find the Borland Runtime DLLs on the system
! default path. You will need to copy the DLLs reported by the messages
! from where Borland chose to install it, into the Windows system directory
! (usually somewhere like C:\WINNT\SYSTEM32) and rerun the test.
!
! If you're using Borland compiler versions 5.2 and below, you may run into
! problems finding the correct header files when building extensions. For
! example, building the "Tk" extension may fail because both perl and Tk
! contain a header file called "patchlevel.h". The latest Borland compiler
! (v5.5) is free of this misbehaviour, and it even supports an
! option -VI- for backward (bugward) compatibility for using the old Borland
! search algorithm to locate header files.
!
! Please report any other failures as described under L<BUGS AND CAVEATS>.
!
! =head2 Installation of Perl on Win32
!
! Type "dmake install" (or "nmake install"). This will put the newly
! built perl and the libraries under whatever C<INST_TOP> points to in the
! Makefile. It will also install the pod documentation under
! C<$INST_TOP\$VERSION\lib\pod> and HTML versions of the same under
! C<$INST_TOP\$VERSION\lib\pod\html>. To use the Perl you just installed,
! you will need to add two components to your PATH environment variable,
! C<$INST_TOP\$VERSION\bin> and C<$INST_TOP\$VERSION\bin\$ARCHNAME>.
! For example:
!
! set PATH c:\perl\5.6.0\bin;c:\perl\5.6.0\bin\MSWin32-x86;%PATH%
!
! If you opt to comment out INST_VER and INST_ARCH in the makefiles, the
! installation structure is much simpler. In that case, it will be
! sufficient to add a single entry to the path, for instance:
!
! set PATH c:\perl\bin;%PATH%
!
! =head2 Usage Hints for Perl on Win32
!
! =over 4
!
! =item Environment Variables
!
! The installation paths that you set during the build get compiled
! into perl, so you don't have to do anything additional to start
! using that perl (except add its location to your PATH variable).
!
! If you put extensions in unusual places, you can set PERL5LIB
! to a list of paths separated by semicolons where you want perl
! to look for libraries. Look for descriptions of other environment
! variables you can set in L<perlrun>.
!
! You can also control the shell that perl uses to run system() and
! backtick commands via PERL5SHELL. See L<perlrun>.
!
! Perl does not depend on the registry, but it can look up certain default
! values if you choose to put them there. Perl attempts to read entries from
! C<HKEY_CURRENT_USER\Software\Perl> and C<HKEY_LOCAL_MACHINE\Software\Perl>.
! Entries in the former override entries in the latter. One or more of the
! following entries (of type REG_SZ or REG_EXPAND_SZ) may be set:
!
! lib-$] version-specific standard library path to add to @INC
! lib standard library path to add to @INC
! sitelib-$] version-specific site library path to add to @INC
! sitelib site library path to add to @INC
! vendorlib-$] version-specific vendor library path to add to @INC
! vendorlib vendor library path to add to @INC
! PERL* fallback for all %ENV lookups that begin with "PERL"
!
! Note the C<$]> in the above is not literal. Substitute whatever version
! of perl you want to honor that entry, e.g. C<5.6.0>. Paths must be
! separated with semicolons, as usual on win32.
!
! =item File Globbing
!
! By default, perl handles file globbing using the File::Glob extension,
! which provides portable globbing.
!
! If you want perl to use globbing that emulates the quirks of DOS
! filename conventions, you might want to consider using File::DosGlob
! to override the internal glob() implementation. See L<File::DosGlob> for
! details.
!
! =item Using perl from the command line
!
! If you are accustomed to using perl from various command-line
! shells found in UNIX environments, you will be less than pleased
! with what Windows offers by way of a command shell.
!
! The crucial thing to understand about the Windows environment is that
! the command line you type in is processed twice before Perl sees it.
! First, your command shell (usually CMD.EXE on Windows NT, and
! COMMAND.COM on Windows 9x) preprocesses the command line, to handle
! redirection, environment variable expansion, and location of the
! executable to run. Then, the perl executable splits the remaining
! command line into individual arguments, using the C runtime library
! upon which Perl was built.
!
! It is particularly important to note that neither the shell nor the C
! runtime do any wildcard expansions of command-line arguments (so
! wildcards need not be quoted). Also, the quoting behaviours of the
! shell and the C runtime are rudimentary at best (and may, if you are
! using a non-standard shell, be inconsistent). The only (useful) quote
! character is the double quote ("). It can be used to protect spaces
! and other special characters in arguments.
!
! The Windows NT documentation has almost no description of how the
! quoting rules are implemented, but here are some general observations
! based on experiments: The C runtime breaks arguments at spaces and
! passes them to programs in argc/argv. Double quotes can be used to
! prevent arguments with spaces in them from being split up. You can
! put a double quote in an argument by escaping it with a backslash and
! enclosing the whole argument within double quotes. The backslash and
! the pair of double quotes surrounding the argument will be stripped by
! the C runtime.
!
! The file redirection characters "<", ">", and "|" can be quoted by
! double quotes (although there are suggestions that this may not always
! be true). Single quotes are not treated as quotes by the shell or
! the C runtime, they don't get stripped by the shell (just to make
! this type of quoting completely useless). The caret "^" has also
! been observed to behave as a quoting character, but this appears
! to be a shell feature, and the caret is not stripped from the command
! line, so Perl still sees it (and the C runtime phase does not treat
! the caret as a quote character).
!
! Here are some examples of usage of the "cmd" shell:
!
! This prints two doublequotes:
!
! perl -e "print '\"\"' "
!
! This does the same:
!
! perl -e "print \"\\\"\\\"\" "
!
! This prints "bar" and writes "foo" to the file "blurch":
!
! perl -e "print 'foo'; print STDERR 'bar'" > blurch
!
! This prints "foo" ("bar" disappears into nowhereland):
!
! perl -e "print 'foo'; print STDERR 'bar'" 2> nul
!
! This prints "bar" and writes "foo" into the file "blurch":
!
! perl -e "print 'foo'; print STDERR 'bar'" 1> blurch
!
! This pipes "foo" to the "less" pager and prints "bar" on the console:
!
! perl -e "print 'foo'; print STDERR 'bar'" | less
!
! This pipes "foo\nbar\n" to the less pager:
!
! perl -le "print 'foo'; print STDERR 'bar'" 2>&1 | less
!
! This pipes "foo" to the pager and writes "bar" in the file "blurch":
!
! perl -e "print 'foo'; print STDERR 'bar'" 2> blurch | less
!
!
! Discovering the usefulness of the "command.com" shell on Windows 9x
! is left as an exercise to the reader :)
!
! One particularly pernicious problem with the 4NT command shell for
! Windows NT is that it (nearly) always treats a % character as indicating
! that environment variable expansion is needed. Under this shell, it is
! therefore important to always double any % characters which you want
! Perl to see (for example, for hash variables), even when they are
! quoted.
!
! =item Building Extensions
!
! The Comprehensive Perl Archive Network (CPAN) offers a wealth
! of extensions, some of which require a C compiler to build.
! Look in http://www.cpan.org/ for more information on CPAN.
!
! Note that not all of the extensions available from CPAN may work
! in the Win32 environment; you should check the information at
! http://testers.cpan.org/ before investing too much effort into
! porting modules that don't readily build.
!
! Most extensions (whether they require a C compiler or not) can
! be built, tested and installed with the standard mantra:
!
! perl Makefile.PL
! $MAKE
! $MAKE test
! $MAKE install
!
! where $MAKE is whatever 'make' program you have configured perl to
! use. Use "perl -V:make" to find out what this is. Some extensions
! may not provide a testsuite (so "$MAKE test" may not do anything or
! fail), but most serious ones do.
!
! It is important that you use a supported 'make' program, and
! ensure Config.pm knows about it. If you don't have nmake, you can
! either get dmake from the location mentioned earlier or get an
! old version of nmake reportedly available from:
!
! ftp://ftp.microsoft.com/Softlib/MSLFILES/nmake15.exe
!
! Another option is to use the make written in Perl, available from
! CPAN:
!
! http://www.cpan.org/authors/id/NI-S/Make-0.03.tar.gz
!
! You may also use dmake. See L</"Make"> above on how to get it.
!
! Note that MakeMaker actually emits makefiles with different syntax
! depending on what 'make' it thinks you are using. Therefore, it is
! important that one of the following values appears in Config.pm:
!
! make='nmake' # MakeMaker emits nmake syntax
! make='dmake' # MakeMaker emits dmake syntax
! any other value # MakeMaker emits generic make syntax
! (e.g GNU make, or Perl make)
!
! If the value doesn't match the 'make' program you want to use,
! edit Config.pm to fix it.
!
! If a module implements XSUBs, you will need one of the supported
! C compilers. You must make sure you have set up the environment for
! the compiler for command-line compilation.
!
! If a module does not build for some reason, look carefully for
! why it failed, and report problems to the module author. If
! it looks like the extension building support is at fault, report
! that with full details of how the build failed using the perlbug
! utility.
!
! =item Command-line Wildcard Expansion
!
! The default command shells on DOS descendant operating systems (such
! as they are) usually do not expand wildcard arguments supplied to
! programs. They consider it the application's job to handle that.
! This is commonly achieved by linking the application (in our case,
! perl) with startup code that the C runtime libraries usually provide.
! However, doing that results in incompatible perl versions (since the
! behavior of the argv expansion code differs depending on the
! compiler, and it is even buggy on some compilers). Besides, it may
! be a source of frustration if you use such a perl binary with an
! alternate shell that *does* expand wildcards.
!
! Instead, the following solution works rather well. The nice things
! about it are 1) you can start using it right away; 2) it is more
! powerful, because it will do the right thing with a pattern like
! */*/*.c; 3) you can decide whether you do/don't want to use it; and
! 4) you can extend the method to add any customizations (or even
! entirely different kinds of wildcard expansion).
!
! C:\> copy con c:\perl\lib\Wild.pm
! # Wild.pm - emulate shell @ARGV expansion on shells that don't
! use File::DosGlob;
! @ARGV = map {
! my @g = File::DosGlob::glob($_) if /[*?]/;
! @g ? @g : $_;
! } @ARGV;
! 1;
! ^Z
! C:\> set PERL5OPT=-MWild
! C:\> perl -le "for (@ARGV) { print }" */*/perl*.c
! p4view/perl/perl.c
! p4view/perl/perlio.c
! p4view/perl/perly.c
! perl5.005/win32/perlglob.c
! perl5.005/win32/perllib.c
! perl5.005/win32/perlglob.c
! perl5.005/win32/perllib.c
! perl5.005/win32/perlglob.c
! perl5.005/win32/perllib.c
!
! Note there are two distinct steps there: 1) You'll have to create
! Wild.pm and put it in your perl lib directory. 2) You'll need to
! set the PERL5OPT environment variable. If you want argv expansion
! to be the default, just set PERL5OPT in your default startup
! environment.
!
! If you are using the Visual C compiler, you can get the C runtime's
! command line wildcard expansion built into perl binary. The resulting
! binary will always expand unquoted command lines, which may not be
! what you want if you use a shell that does that for you. The expansion
! done is also somewhat less powerful than the approach suggested above.
!
! =item Win32 Specific Extensions
!
! A number of extensions specific to the Win32 platform are available
! from CPAN. You may find that many of these extensions are meant to
! be used under the Activeware port of Perl, which used to be the only
! native port for the Win32 platform. Since the Activeware port does not
! have adequate support for Perl's extension building tools, these
! extensions typically do not support those tools either and, therefore,
! cannot be built using the generic steps shown in the previous section.
!
! To ensure smooth transitioning of existing code that uses the
! ActiveState port, there is a bundle of Win32 extensions that contains
! all of the ActiveState extensions and most other Win32 extensions from
! CPAN in source form, along with many added bugfixes, and with MakeMaker
! support. This bundle is available at:
!
! http://www.cpan.org/authors/id/GSAR/libwin32-0.151.zip
!
! See the README in that distribution for building and installation
! instructions. Look for later versions that may be available at the
! same location.
!
! =item Running Perl Scripts
!
! Perl scripts on UNIX use the "#!" (a.k.a "shebang") line to
! indicate to the OS that it should execute the file using perl.
! Win32 has no comparable means to indicate arbitrary files are
! executables.
!
! Instead, all available methods to execute plain text files on
! Win32 rely on the file "extension". There are three methods
! to use this to execute perl scripts:
!
! =over 8
!
! =item 1
!
! There is a facility called "file extension associations" that will
! work in Windows NT 4.0. This can be manipulated via the two
! commands "assoc" and "ftype" that come standard with Windows NT
! 4.0. Type "ftype /?" for a complete example of how to set this
! up for perl scripts (Say what? You thought Windows NT wasn't
! perl-ready? :).
!
! =item 2
!
! Since file associations don't work everywhere, and there are
! reportedly bugs with file associations where it does work, the
! old method of wrapping the perl script to make it look like a
! regular batch file to the OS, may be used. The install process
! makes available the "pl2bat.bat" script which can be used to wrap
! perl scripts into batch files. For example:
!
! pl2bat foo.pl
!
! will create the file "FOO.BAT". Note "pl2bat" strips any
! .pl suffix and adds a .bat suffix to the generated file.
!
! If you use the 4DOS/NT or similar command shell, note that
! "pl2bat" uses the "%*" variable in the generated batch file to
! refer to all the command line arguments, so you may need to make
! sure that construct works in batch files. As of this writing,
! 4DOS/NT users will need a "ParameterChar = *" statement in their
! 4NT.INI file or will need to execute "setdos /p*" in the 4DOS/NT
! startup file to enable this to work.
!
! =item 3
!
! Using "pl2bat" has a few problems: the file name gets changed,
! so scripts that rely on C<$0> to find what they must do may not
! run properly; running "pl2bat" replicates the contents of the
! original script, and so this process can be maintenance intensive
! if the originals get updated often. A different approach that
! avoids both problems is possible.
!
! A script called "runperl.bat" is available that can be copied
! to any filename (along with the .bat suffix). For example,
! if you call it "foo.bat", it will run the file "foo" when it is
! executed. Since you can run batch files on Win32 platforms simply
! by typing the name (without the extension), this effectively
! runs the file "foo", when you type either "foo" or "foo.bat".
! With this method, "foo.bat" can even be in a different location
! than the file "foo", as long as "foo" is available somewhere on
! the PATH. If your scripts are on a filesystem that allows symbolic
! links, you can even avoid copying "runperl.bat".
!
! Here's a diversion: copy "runperl.bat" to "runperl", and type
! "runperl". Explain the observed behavior, or lack thereof. :)
! Hint: .gnidnats llits er'uoy fi ,"lrepnur" eteled :tniH
!
! =back
!
! =item Miscellaneous Things
!
! A full set of HTML documentation is installed, so you should be
! able to use it if you have a web browser installed on your
! system.
!
! C<perldoc> is also a useful tool for browsing information contained
! in the documentation, especially in conjunction with a pager
! like C<less> (recent versions of which have Win32 support). You may
! have to set the PAGER environment variable to use a specific pager.
! "perldoc -f foo" will print information about the perl operator
! "foo".
!
! If you find bugs in perl, you can run C<perlbug> to create a
! bug report (you may have to send it manually if C<perlbug> cannot
! find a mailer on your system).
!
! =back
!
! =head1 BUGS AND CAVEATS
!
! Norton AntiVirus interferes with the build process, particularly if
! set to "AutoProtect, All Files, when Opened". Unlike large applications
! the perl build process opens and modifies a lot of files. Having the
! the AntiVirus scan each and every one slows build the process significantly.
! Worse, with PERLIO=stdio the build process fails with peculiar messages
! as the virus checker interacts badly with miniperl.exe writing configure
! files (it seems to either catch file part written and treat it as suspicious,
! or virus checker may have it "locked" in a way which inhibits miniperl
! updating it). The build does complete with
!
! set PERLIO=perlio
!
! but that may be just luck. Other AntiVirus software may have similar issues.
!
! Some of the built-in functions do not act exactly as documented in
! L<perlfunc>, and a few are not implemented at all. To avoid
! surprises, particularly if you have had prior exposure to Perl
! in other operating environments or if you intend to write code
! that will be portable to other environments. See L<perlport>
! for a reasonably definitive list of these differences.
!
! Not all extensions available from CPAN may build or work properly
! in the Win32 environment. See L</"Building Extensions">.
!
! Most C<socket()> related calls are supported, but they may not
! behave as on Unix platforms. See L<perlport> for the full list.
!
! Signal handling may not behave as on Unix platforms (where it
! doesn't exactly "behave", either :). For instance, calling C<die()>
! or C<exit()> from signal handlers will cause an exception, since most
! implementations of C<signal()> on Win32 are severely crippled.
! Thus, signals may work only for simple things like setting a flag
! variable in the handler. Using signals under this port should
! currently be considered unsupported.
!
! Please send detailed descriptions of any problems and solutions that
! you may find to <F<perlbug@perl.com>>, along with the output produced
! by C<perl -V>.
!
! =head1 AUTHORS
!
! =over 4
!
! =item Gary Ng E<lt>71564.1743@CompuServe.COME<gt>
!
! =item Gurusamy Sarathy E<lt>gsar@activestate.comE<gt>
!
! =item Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt>
!
! =back
!
! This document is maintained by Gurusamy Sarathy.
!
! =head1 SEE ALSO
!
! L<perl>
!
! =head1 HISTORY
!
! This port was originally contributed by Gary Ng around 5.003_24,
! and borrowed from the Hip Communications port that was available
! at the time. Various people have made numerous and sundry hacks
! since then.
!
! Borland support was added in 5.004_01 (Gurusamy Sarathy).
!
! GCC/mingw32 support was added in 5.005 (Nick Ing-Simmons).
!
! Support for PERL_OBJECT was added in 5.005 (ActiveState Tool Corp).
!
! Support for fork() emulation was added in 5.6 (ActiveState Tool Corp).
!
! Win9x support was added in 5.6 (Benjamin Stuhl).
!
! Last updated: 1 April 2001
!
! =cut
diff -c 'perl-5.7.1/XSUB.h' 'perl-5.7.2/XSUB.h'
Index: ./XSUB.h
*** ./XSUB.h Tue Mar 6 04:04:21 2001
--- ./XSUB.h Mon Jul 9 17:09:46 2001
***************
*** 18,23 ****
--- 18,28 ----
XSUB. This is always the proper type for the C++ object. See C<CLASS> and
L<perlxs/"Using XS With C++">.
+ =for apidoc Amn|I32|ax
+ Variable which is setup by C<xsubpp> to indicate the stack base offset,
+ used by the C<ST>, C<XSprePUSH> and C<XSRETURN> macros. The C<dMARK> macro
+ must be called prior to setup the C<MARK> variable.
+
=for apidoc Amn|I32|items
Variable which is setup by C<xsubpp> to indicate the number of
items on the stack. See L<perlxs/"Variable-length Parameter Lists">.
***************
*** 33,42 ****
Macro to declare an XSUB and its C parameter list. This is handled by
C<xsubpp>.
=for apidoc Ams||dXSARGS
! Sets up stack and mark pointers for an XSUB, calling dSP and dMARK. This
! is usually handled automatically by C<xsubpp>. Declares the C<items>
! variable to indicate the number of items on the stack.
=for apidoc Ams||dXSI32
Sets up the C<ix> variable for an XSUB which has aliases. This is usually
--- 38,55 ----
Macro to declare an XSUB and its C parameter list. This is handled by
C<xsubpp>.
+ =for apidoc Ams||dAX
+ Sets up the C<ax> variable.
+ This is usually handled automatically by C<xsubpp> by calling C<dXSARGS>.
+
+ =for apidoc Ams||dITEMS
+ Sets up the C<items> variable.
+ This is usually handled automatically by C<xsubpp> by calling C<dXSARGS>.
+
=for apidoc Ams||dXSARGS
! Sets up stack and mark pointers for an XSUB, calling dSP and dMARK.
! Sets up the C<ax> and C<items> variables by calling C<dAX> and C<dITEMS>.
! This is usually handled automatically by C<xsubpp>.
=for apidoc Ams||dXSI32
Sets up the C<ix> variable for an XSUB which has aliases. This is usually
***************
*** 53,62 ****
# define XS(name) void name(pTHXo_ CV* cv)
#endif
#define dXSARGS \
dSP; dMARK; \
! I32 ax = mark - PL_stack_base + 1; \
! I32 items = sp - mark
#define dXSTARG SV * targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \
? PAD_SV(PL_op->op_targ) : sv_newmortal())
--- 66,78 ----
# define XS(name) void name(pTHXo_ CV* cv)
#endif
+ #define dAX I32 ax = MARK - PL_stack_base + 1
+
+ #define dITEMS I32 items = SP - MARK
+
#define dXSARGS \
dSP; dMARK; \
! dAX; dITEMS
#define dXSTARG SV * targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \
? PAD_SV(PL_op->op_targ) : sv_newmortal())
***************
*** 74,80 ****
# define XSINTERFACE_CVT(ret,name) ret (*name)()
#endif
#define dXSFUNCTION(ret) XSINTERFACE_CVT(ret,XSFUNCTION)
! #define XSINTERFACE_FUNC(ret,cv,f) ((XSINTERFACE_CVT(ret,cv))(f))
#define XSINTERFACE_FUNC_SET(cv,f) \
CvXSUBANY(cv).any_dptr = (void (*) (pTHXo_ void*))(f)
--- 90,96 ----
# define XSINTERFACE_CVT(ret,name) ret (*name)()
#endif
#define dXSFUNCTION(ret) XSINTERFACE_CVT(ret,XSFUNCTION)
! #define XSINTERFACE_FUNC(ret,cv,f) ((XSINTERFACE_CVT(ret,))(f))
#define XSINTERFACE_FUNC_SET(cv,f) \
CvXSUBANY(cv).any_dptr = (void (*) (pTHXo_ void*))(f)
***************
*** 242,247 ****
--- 258,272 ----
#if (defined(PERL_CAPI) || defined(PERL_IMPLICIT_SYS)) && !defined(PERL_CORE)
# ifndef NO_XSLOCKS
+ # if defined (NETWARE) && defined (USE_STDIO)
+ # define times PerlProc_times
+ # define setuid PerlProc_setuid
+ # define setgid PerlProc_setgid
+ # define getpid PerlProc_getpid
+ # define pause PerlProc_pause
+ # define exit PerlProc_exit
+ # define _exit PerlProc__exit
+ # else
# undef closedir
# undef opendir
# undef stdin
***************
*** 257,262 ****
--- 282,316 ----
# undef ungetc
# undef fileno
+ //Following symbols were giving redefinition errors while building extensions - sgp 17th Oct 2000
+ #ifdef NETWARE
+ # undef readdir
+ # undef fstat
+ # undef stat
+ # undef longjmp
+ # undef endhostent
+ # undef endnetent
+ # undef endprotoent
+ # undef endservent
+ # undef gethostbyaddr
+ # undef gethostbyname
+ # undef gethostent
+ # undef getnetbyaddr
+ # undef getnetbyname
+ # undef getnetent
+ # undef getprotobyname
+ # undef getprotobynumber
+ # undef getprotoent
+ # undef getservbyname
+ # undef getservbyport
+ # undef getservent
+ # undef inet_ntoa
+ # undef sethostent
+ # undef setnetent
+ # undef setprotoent
+ # undef setservent
+ #endif /* NETWARE */
+
# define mkdir PerlDir_mkdir
# define chdir PerlDir_chdir
# define rmdir PerlDir_rmdir
***************
*** 394,399 ****
--- 448,454 ----
# define shutdown PerlSock_shutdown
# define socket PerlSock_socket
# define socketpair PerlSock_socketpair
+ # endif /* NETWARE && USE_STDIO */
# endif /* NO_XSLOCKS */
#endif /* PERL_CAPI */
diff -c 'perl-5.7.1/av.c' 'perl-5.7.2/av.c'
Index: ./av.c
*** ./av.c Tue Mar 6 04:04:21 2001
--- ./av.c Fri Jul 13 02:55:59 2001
***************
*** 25,31 ****
if (AvREAL(av))
return;
#ifdef DEBUGGING
! if (SvTIED_mg((SV*)av, 'P') && ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ WARN_DEBUGGING, "av_reify called on tied array");
#endif
key = AvMAX(av) + 1;
--- 25,31 ----
if (AvREAL(av))
return;
#ifdef DEBUGGING
! if (SvTIED_mg((SV*)av, PERL_MAGIC_tied) && ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ WARN_DEBUGGING, "av_reify called on tied array");
#endif
key = AvMAX(av) + 1;
***************
*** 57,63 ****
Perl_av_extend(pTHX_ AV *av, I32 key)
{
MAGIC *mg;
! if ((mg = SvTIED_mg((SV*)av, 'P'))) {
dSP;
ENTER;
SAVETMPS;
--- 57,63 ----
Perl_av_extend(pTHX_ AV *av, I32 key)
{
MAGIC *mg;
! if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
dSP;
ENTER;
SAVETMPS;
***************
*** 96,102 ****
}
else {
if (AvALLOC(av)) {
! #ifndef STRANGE_MALLOC
MEM_SIZE bytes;
IV itmp;
#endif
--- 96,102 ----
}
else {
if (AvALLOC(av)) {
! #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
MEM_SIZE bytes;
IV itmp;
#endif
***************
*** 130,136 ****
--- 130,138 ----
Safefree(AvALLOC(av));
AvALLOC(av) = ary;
#endif
+ #if defined(MYMALLOC) && !defined(LEAKTEST)
resized:
+ #endif
ary = AvALLOC(av) + AvMAX(av) + 1;
tmp = newmax - AvMAX(av);
if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
***************
*** 185,191 ****
}
if (SvRMAGICAL(av)) {
! if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) {
sv = sv_newmortal();
mg_copy((SV*)av, sv, 0, key);
PL_av_fetch_sv = sv;
--- 187,195 ----
}
if (SvRMAGICAL(av)) {
! if (mg_find((SV*)av, PERL_MAGIC_tied) ||
! mg_find((SV*)av, PERL_MAGIC_regdata))
! {
sv = sv_newmortal();
mg_copy((SV*)av, sv, 0, key);
PL_av_fetch_sv = sv;
***************
*** 253,259 ****
Perl_croak(aTHX_ PL_no_modify);
if (SvRMAGICAL(av)) {
! if (mg_find((SV*)av,'P')) {
if (val != &PL_sv_undef) {
mg_copy((SV*)av, val, 0, key);
}
--- 257,263 ----
Perl_croak(aTHX_ PL_no_modify);
if (SvRMAGICAL(av)) {
! if (mg_find((SV*)av, PERL_MAGIC_tied)) {
if (val != &PL_sv_undef) {
mg_copy((SV*)av, val, 0, key);
}
***************
*** 438,444 ****
/*SUPPRESS 560*/
/* Give any tie a chance to cleanup first */
! if (SvTIED_mg((SV*)av, 'P'))
av_fill(av, -1); /* mg_clear() ? */
if (AvREAL(av)) {
--- 442,448 ----
/*SUPPRESS 560*/
/* Give any tie a chance to cleanup first */
! if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
av_fill(av, -1); /* mg_clear() ? */
if (AvREAL(av)) {
***************
*** 474,480 ****
if (SvREADONLY(av))
Perl_croak(aTHX_ PL_no_modify);
! if ((mg = SvTIED_mg((SV*)av, 'P'))) {
dSP;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
--- 478,484 ----
if (SvREADONLY(av))
Perl_croak(aTHX_ PL_no_modify);
! if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
dSP;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
***************
*** 510,516 ****
return &PL_sv_undef;
if (SvREADONLY(av))
Perl_croak(aTHX_ PL_no_modify);
! if ((mg = SvTIED_mg((SV*)av, 'P'))) {
dSP;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
--- 514,520 ----
return &PL_sv_undef;
if (SvREADONLY(av))
Perl_croak(aTHX_ PL_no_modify);
! if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
dSP;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
***************
*** 556,562 ****
if (SvREADONLY(av))
Perl_croak(aTHX_ PL_no_modify);
! if ((mg = SvTIED_mg((SV*)av, 'P'))) {
dSP;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
--- 560,566 ----
if (SvREADONLY(av))
Perl_croak(aTHX_ PL_no_modify);
! if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
dSP;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
***************
*** 622,628 ****
return &PL_sv_undef;
if (SvREADONLY(av))
Perl_croak(aTHX_ PL_no_modify);
! if ((mg = SvTIED_mg((SV*)av, 'P'))) {
dSP;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
--- 626,632 ----
return &PL_sv_undef;
if (SvREADONLY(av))
Perl_croak(aTHX_ PL_no_modify);
! if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
dSP;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
***************
*** 680,686 ****
Perl_croak(aTHX_ "panic: null array");
if (fill < 0)
fill = -1;
! if ((mg = SvTIED_mg((SV*)av, 'P'))) {
dSP;
ENTER;
SAVETMPS;
--- 684,690 ----
Perl_croak(aTHX_ "panic: null array");
if (fill < 0)
fill = -1;
! if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
dSP;
ENTER;
SAVETMPS;
***************
*** 743,755 ****
}
if (SvRMAGICAL(av)) {
SV **svp;
! if ((mg_find((SV*)av,'P') || mg_find((SV*)av,'D'))
&& (svp = av_fetch(av, key, TRUE)))
{
sv = *svp;
mg_clear(sv);
! if (mg_find(sv, 'p')) {
! sv_unmagic(sv, 'p'); /* No longer an element */
return sv;
}
return Nullsv; /* element cannot be deleted */
--- 747,760 ----
}
if (SvRMAGICAL(av)) {
SV **svp;
! if ((mg_find((SV*)av, PERL_MAGIC_tied) ||
! mg_find((SV*)av, PERL_MAGIC_regdata))
&& (svp = av_fetch(av, key, TRUE)))
{
sv = *svp;
mg_clear(sv);
! if (mg_find(sv, PERL_MAGIC_tiedelem)) {
! sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
return sv;
}
return Nullsv; /* element cannot be deleted */
***************
*** 760,765 ****
--- 765,771 ----
else {
sv = AvARRAY(av)[key];
if (key == AvFILLp(av)) {
+ AvARRAY(av)[key] = &PL_sv_undef;
do {
AvFILLp(av)--;
} while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
***************
*** 797,808 ****
return FALSE;
}
if (SvRMAGICAL(av)) {
! if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) {
SV *sv = sv_newmortal();
MAGIC *mg;
mg_copy((SV*)av, sv, 0, key);
! mg = mg_find(sv, 'p');
if (mg) {
magic_existspack(sv, mg);
return SvTRUE(sv);
--- 803,816 ----
return FALSE;
}
if (SvRMAGICAL(av)) {
! if (mg_find((SV*)av, PERL_MAGIC_tied) ||
! mg_find((SV*)av, PERL_MAGIC_regdata))
! {
SV *sv = sv_newmortal();
MAGIC *mg;
mg_copy((SV*)av, sv, 0, key);
! mg = mg_find(sv, PERL_MAGIC_tiedelem);
if (mg) {
magic_existspack(sv, mg);
return SvTRUE(sv);
diff -c 'perl-5.7.1/cc_runtime.h' 'perl-5.7.2/cc_runtime.h'
Index: ./cc_runtime.h
*** ./cc_runtime.h Tue Mar 6 04:04:21 2001
--- ./cc_runtime.h Mon Jul 9 17:09:46 2001
***************
*** 14,20 ****
#define MAYBE_TAINT_SASSIGN_SRC(sv) \
if (PL_tainting && PL_tainted && (!SvGMAGICAL(left) || !SvSMAGICAL(left) || \
! !((mg=mg_find(left, 't')) && mg->mg_len & 1)))\
TAINT_NOT
#define PP_PREINC(sv) do { \
--- 14,20 ----
#define MAYBE_TAINT_SASSIGN_SRC(sv) \
if (PL_tainting && PL_tainted && (!SvGMAGICAL(left) || !SvSMAGICAL(left) || \
! !((mg=mg_find(left, PERL_MAGIC_taint)) && mg->mg_len & 1)))\
TAINT_NOT
#define PP_PREINC(sv) do { \
diff -c 'perl-5.7.1/cflags.SH' 'perl-5.7.2/cflags.SH'
Index: ./cflags.SH
*** ./cflags.SH Tue Mar 6 04:04:21 2001
--- ./cflags.SH Mon Jul 9 17:09:47 2001
***************
*** 1,4 ****
! case $CONFIG in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
--- 1,4 ----
! case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
***************
*** 28,34 ****
: In the following dollars and backticks do not need the extra backslash.
$spitshell >>cflags <<'!NO!SUBS!'
! case $CONFIGDOTSH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
--- 28,34 ----
: In the following dollars and backticks do not need the extra backslash.
$spitshell >>cflags <<'!NO!SUBS!'
! case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
***************
*** 99,108 ****
--- 99,110 ----
dump) ;;
gv) ;;
hv) ;;
+ locale) ;;
main) ;;
malloc) ;;
mg) ;;
miniperlmain) ;;
+ numeric) ;;
op) ;;
perl) ;;
perlapi) ;;
***************
*** 111,116 ****
--- 113,119 ----
pp) ;;
pp_ctl) ;;
pp_hot) ;;
+ pp_pack) ;;
pp_sys) ;;
regcomp) ;;
regexec) ;;
diff -c 'perl-5.7.1/config_h.SH' 'perl-5.7.2/config_h.SH'
Index: ./config_h.SH
Prereq: 3.0.1.5
*** ./config_h.SH Sun Apr 8 02:04:56 2001
--- ./config_h.SH Fri Jul 13 03:14:40 2001
***************
*** 4,10 ****
case "$CONFIG_H" in
'') CONFIG_H=config.h ;;
esac
! case $CONFIG in
'')
if test -f $CONFIG_SH; then TOP=.;
elif test -f ../$CONFIG_SH; then TOP=..;
--- 4,10 ----
case "$CONFIG_H" in
'') CONFIG_H=config.h ;;
esac
! case $PERL_CONFIG_SH in
'')
if test -f $CONFIG_SH; then TOP=.;
elif test -f ../$CONFIG_SH; then TOP=..;
***************
*** 145,170 ****
*/
#$d_dlerror HAS_DLERROR /**/
- /* SETUID_SCRIPTS_ARE_SECURE_NOW:
- * This symbol, if defined, indicates that the bug that prevents
- * setuid scripts from being secure is not present in this kernel.
- */
- /* DOSUID:
- * This symbol, if defined, indicates that the C program should
- * check the script that it is executing for setuid/setgid bits, and
- * attempt to emulate setuid/setgid on systems that have disabled
- * setuid #! scripts because the kernel can't do it securely.
- * It is up to the package designer to make sure that this emulation
- * is done securely. Among other things, it should do an fstat on
- * the script it just opened to make sure it really is a setuid/setgid
- * script, it should make sure the arguments passed correspond exactly
- * to the argument on the #! line, and it should not trust any
- * subprocesses to which it must pass the filename rather than the
- * file descriptor of the script to be executed.
- */
- #$d_suidsafe SETUID_SCRIPTS_ARE_SECURE_NOW /**/
- #$d_dosuid DOSUID /**/
-
/* HAS_DUP2:
* This symbol, if defined, indicates that the dup2 routine is
* available to duplicate file descriptors.
--- 145,150 ----
***************
*** 942,958 ****
*/
#$i_values I_VALUES /**/
- /* I_STDARG:
- * This symbol, if defined, indicates that <stdarg.h> exists and should
- * be included.
- */
- /* I_VARARGS:
- * This symbol, if defined, indicates to the C program that it should
- * include <varargs.h>.
- */
- #$i_stdarg I_STDARG /**/
- #$i_varargs I_VARARGS /**/
-
/* I_VFORK:
* This symbol, if defined, indicates to the C program that it should
* include vfork.h.
--- 922,927 ----
***************
*** 986,997 ****
*/
#define SH_PATH "$sh" /**/
- /* CROSSCOMPILE:
- * This symbol, if defined, signifies that we our
- * build process is a cross-compilation.
- */
- #$crosscompile CROSSCOMPILE /**/
-
/* INTSIZE:
* This symbol contains the value of sizeof(int) so that the C
* preprocessor can make decisions based on it.
--- 955,960 ----
***************
*** 1062,1068 ****
--- 1025,1037 ----
* by Configure. You shouldn't rely on it too much; the specific
* feature tests from Configure are generally more reliable.
*/
+ /* OSVERS:
+ * This symbol contains the version of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
+ */
#define OSNAME "$osname" /**/
+ #define OSVERS "$osvers" /**/
/* MEM_ALIGNBYTES:
* This symbol contains the number of bytes required to align a
***************
*** 1069,1075 ****
* double, or a long double when applicable. Usual values are 2,
* 4 and 8. The default is eight, for safety.
*/
! #if defined(CROSSCOMPILE) || defined(MULTIARCH)
# define MEM_ALIGNBYTES 8
#else
#define MEM_ALIGNBYTES $alignbytes
--- 1038,1044 ----
* double, or a long double when applicable. Usual values are 2,
* 4 and 8. The default is eight, for safety.
*/
! #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
# define MEM_ALIGNBYTES 8
#else
#define MEM_ALIGNBYTES $alignbytes
***************
*** 1146,1152 ****
* so the default case (for NeXT) is big endian to catch them.
* This might matter for NeXT 3.0.
*/
! #if defined(CROSSCOMPILE) || defined(MULTIARCH)
# ifdef __LITTLE_ENDIAN__
# if LONGSIZE == 4
# define BYTEORDER 0x1234
--- 1115,1121 ----
* so the default case (for NeXT) is big endian to catch them.
* This might matter for NeXT 3.0.
*/
! #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
# ifdef __LITTLE_ENDIAN__
# if LONGSIZE == 4
# define BYTEORDER 0x1234
***************
*** 1336,1341 ****
--- 1305,1316 ----
*/
#$d_endsent HAS_ENDSERVENT /**/
+ /* HAS_FCHDIR:
+ * This symbol, if defined, indicates that the fchdir routine is
+ * available to change directory using a file descriptor.
+ */
+ #$d_fchdir HAS_FCHDIR /**/
+
/* FCNTL_CAN_LOCK:
* This symbol, if defined, indicates that fcntl() can be used
* for file locking. Normally on Unix systems this is defined.
***************
*** 1794,1800 ****
--- 1769,1783 ----
* available to split a long double x into a fractional part f and
* an integer part i such that |f| < 1.0 and (f + i) = x.
*/
+ /* HAS_MODFL_POW32_BUG:
+ * This symbol, if defined, indicates that the modfl routine is
+ * broken for long doubles >= pow(2, 32).
+ * For example from 4294967303.150000 one would get 4294967302.000000
+ * and 1.150000. The bug has been seen in certain versions of glibc,
+ * release 2.2.2 is known to be okay.
+ */
#$d_modfl HAS_MODFL /**/
+ #$d_modfl_pow32_bug HAS_MODFL_POW32_BUG /**/
/* HAS_MPROTECT:
* This symbol, if defined, indicates that the mprotect system call is
***************
*** 1869,1875 ****
/* HAS_SAFE_BCOPY:
* This symbol, if defined, indicates that the bcopy routine is available
! * to copy potentially overlapping memory blocks. Otherwise you should
* probably use memmove() or memcpy(). If neither is defined, roll your
* own version.
*/
--- 1852,1858 ----
/* HAS_SAFE_BCOPY:
* This symbol, if defined, indicates that the bcopy routine is available
! * to copy potentially overlapping memory blocks. Normally, you should
* probably use memmove() or memcpy(). If neither is defined, roll your
* own version.
*/
***************
*** 1877,1885 ****
/* HAS_SAFE_MEMCPY:
* This symbol, if defined, indicates that the memcpy routine is available
! * to copy potentially overlapping memory blocks. Otherwise you should
! * probably use memmove() or memcpy(). If neither is defined, roll your
! * own version.
*/
#$d_safemcpy HAS_SAFE_MEMCPY /**/
--- 1860,1868 ----
/* HAS_SAFE_MEMCPY:
* This symbol, if defined, indicates that the memcpy routine is available
! * to copy potentially overlapping memory blocks. If you need to
! * copy overlapping memory blocks, you should check HAS_MEMMOVE and
! * use memmove() instead, if available.
*/
#$d_safemcpy HAS_SAFE_MEMCPY /**/
***************
*** 2425,2432 ****
--- 2408,2432 ----
* in the <db.h> header file. In older versions of DB, it was
* int, while in newer ones it is size_t.
*/
+ /* DB_VERSION_MAJOR_CFG:
+ * This symbol, if defined, defines the major version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ */
+ /* DB_VERSION_MINOR_CFG:
+ * This symbol, if defined, defines the minor version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
+ /* DB_VERSION_PATCH_CFG:
+ * This symbol, if defined, defines the patch version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
#define DB_Hash_t $db_hashtype /**/
#define DB_Prefix_t $db_prefixtype /**/
+ #define DB_VERSION_MAJOR_CFG $db_version_major /**/
+ #define DB_VERSION_MINOR_CFG $db_version_minor /**/
+ #define DB_VERSION_PATCH_CFG $db_version_patch /**/
/* I_GRP:
* This symbol, if defined, indicates to the C program that it should
***************
*** 2957,2963 ****
* This macro is to be used to generate uniformly distributed
* random numbers over the range [0., 1.[. You may have to supply
* an 'extern double drand48();' in your program since SunOS 4.1.3
! * doesn't provide you with anything relevant in it's headers.
* See HAS_DRAND48_PROTO.
*/
/* Rand_seed_t:
--- 2957,2963 ----
* This macro is to be used to generate uniformly distributed
* random numbers over the range [0., 1.[. You may have to supply
* an 'extern double drand48();' in your program since SunOS 4.1.3
! * doesn't provide you with anything relevant in its headers.
* See HAS_DRAND48_PROTO.
*/
/* Rand_seed_t:
***************
*** 3236,3241 ****
--- 3236,3246 ----
* This symbol, if defined, indicates that Perl should
* be built to use the old draft POSIX threads API.
*/
+ /* USE_REENTRANT_API:
+ * This symbol, if defined, indicates that Perl should
+ * try to use the various _r versions of library functions.
+ * This is extremely experimental.
+ */
#$use5005threads USE_5005THREADS /**/
#$useithreads USE_ITHREADS /**/
#if defined(USE_5005THREADS) && !defined(USE_ITHREADS)
***************
*** 3242,3247 ****
--- 3247,3253 ----
#define USE_THREADS /* until src is revised*/
#endif
#$d_oldpthreads OLD_PTHREADS_API /**/
+ #$usereentrant USE_REENTRANT_API /**/
/* PERL_VENDORARCH:
* If defined, this symbol contains the name of a private library.
***************
*** 3333,3338 ****
--- 3339,3410 ----
#define PERL_XS_APIVERSION "$xs_apiversion"
#define PERL_PM_APIVERSION "$pm_apiversion"
+ /* SETUID_SCRIPTS_ARE_SECURE_NOW:
+ * This symbol, if defined, indicates that the bug that prevents
+ * setuid scripts from being secure is not present in this kernel.
+ */
+ /* DOSUID:
+ * This symbol, if defined, indicates that the C program should
+ * check the script that it is executing for setuid/setgid bits, and
+ * attempt to emulate setuid/setgid on systems that have disabled
+ * setuid #! scripts because the kernel can't do it securely.
+ * It is up to the package designer to make sure that this emulation
+ * is done securely. Among other things, it should do an fstat on
+ * the script it just opened to make sure it really is a setuid/setgid
+ * script, it should make sure the arguments passed correspond exactly
+ * to the argument on the #! line, and it should not trust any
+ * subprocesses to which it must pass the filename rather than the
+ * file descriptor of the script to be executed.
+ */
+ #$d_suidsafe SETUID_SCRIPTS_ARE_SECURE_NOW /**/
+ #$d_dosuid DOSUID /**/
+
+ /* I_STDARG:
+ * This symbol, if defined, indicates that <stdarg.h> exists and should
+ * be included.
+ */
+ /* I_VARARGS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <varargs.h>.
+ */
+ #$i_stdarg I_STDARG /**/
+ #$i_varargs I_VARARGS /**/
+
+ /* USE_CROSS_COMPILE:
+ * This symbol, if defined, indicates that Perl is being cross-compiled.
+ */
+ /* PERL_TARGETARCH:
+ * This symbol, if defined, indicates the target architecture
+ * Perl has been cross-compiled to. Undefined if not a cross-compile.
+ */
+ #ifndef USE_CROSS_COMPILE
+ #$usecrosscompile USE_CROSS_COMPILE /**/
+ #define PERL_TARGETARCH "$targetarch" /**/
+ #endif
+
+ /* HAS_DBMINIT_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the dbminit() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int dbminit(char *);
+ */
+ #$d_dbminitproto HAS_DBMINIT_PROTO /**/
+
+ /* HAS_FLOCK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the flock() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int flock(int, int);
+ */
+ #$d_flockproto HAS_FLOCK_PROTO /**/
+
+ /* HAS_NL_LANGINFO:
+ * This symbol, if defined, indicates that the nl_langinfo routine is
+ * available to return local data. You will also need <langinfo.h>
+ * and therefore I_LANGINFO.
+ */
+ #$d_nl_langinfo HAS_NL_LANGINFO /**/
+
/* HAS_SIGPROCMASK:
* This symbol, if defined, indicates that the sigprocmask
* system call is available to examine or change the signal mask
***************
*** 3346,3356 ****
--- 3418,3487 ----
*/
#$d_sockatmark HAS_SOCKATMARK /**/
+ /* HAS_SOCKATMARK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the sockatmark() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int sockatmark _((int));
+ */
+ #$d_sockatmarkproto HAS_SOCKATMARK_PROTO /**/
+
+ /* HAS_SETRESGID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresgid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+ #$d_sresgproto HAS_SETRESGID_PROTO /**/
+
+ /* HAS_SETRESUID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresuid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+ #$d_sresuproto HAS_SETRESUID_PROTO /**/
+
+ /* HAS_STRFTIME:
+ * This symbol, if defined, indicates that the strftime routine is
+ * available to do time formatting.
+ */
+ #$d_strftime HAS_STRFTIME /**/
+
+ /* HAS_SYSCALL_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the syscall() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int syscall(int, ...);
+ * extern int syscall(long, ...);
+ */
+ #$d_syscallproto HAS_SYSCALL_PROTO /**/
+
/* U32_ALIGNMENT_REQUIRED:
* This symbol, if defined, indicates that you must access
* character data through U32-aligned pointers.
*/
#$d_u32align U32_ALIGNMENT_REQUIRED /**/
+
+ /* HAS_USLEEP_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the usleep() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int usleep(useconds_t);
+ */
+ #$d_usleepproto HAS_USLEEP_PROTO /**/
+
+ /* I_LANGINFO:
+ * This symbol, if defined, indicates that <langinfo.h> exists and
+ * should be included.
+ */
+ #$i_langinfo I_LANGINFO /**/
+
+ /* HAS_PTHREAD_ATFORK:
+ * This symbol, if defined, indicates that the pthread_atfork routine
+ * is available setup fork handlers.
+ */
+ #$d_pthread_atfork HAS_PTHREAD_ATFORK /**/
#endif
!GROK!THIS!
diff -c 'perl-5.7.1/configpm' 'perl-5.7.2/configpm'
Index: ./configpm
*** ./configpm Fri Mar 16 04:54:46 2001
--- ./configpm Mon Jul 9 17:09:47 2001
***************
*** 60,66 ****
while (<>) {
next if m:^#!/bin/sh:;
! # Catch CONFIGDOTSH=true and PERL_VERSION=n line from Configure.
s/^(\w+)=(true|\d+)\s*$/$1='$2'\n/;
my ($k,$v) = ($1,$2);
# grandfather PATCHLEVEL and SUBVERSION and CONFIG
--- 60,66 ----
while (<>) {
next if m:^#!/bin/sh:;
! # Catch PERL_CONFIG_SH=true and PERL_VERSION=n line from Configure.
s/^(\w+)=(true|\d+)\s*$/$1='$2'\n/;
my ($k,$v) = ($1,$2);
# grandfather PATCHLEVEL and SUBVERSION and CONFIG
***************
*** 71,77 ****
elsif ($k eq 'PERL_SUBVERSION') {
push @v_others, "SUBVERSION='$v'\n";
}
! elsif ($k eq 'CONFIGDOTSH') {
push @v_others, "CONFIG='$v'\n";
}
}
--- 71,77 ----
elsif ($k eq 'PERL_SUBVERSION') {
push @v_others, "SUBVERSION='$v'\n";
}
! elsif ($k eq 'PERL_CONFIG_SH') {
push @v_others, "CONFIG='$v'\n";
}
}
***************
*** 474,484 ****
import Config;
die "$0: $config_pm not valid"
! unless $Config{'CONFIGDOTSH'} eq 'true';
die "$0: error processing $config_pm"
if defined($Config{'an impossible name'})
! or $Config{'CONFIGDOTSH'} ne 'true' # test cache
;
die "$0: error processing $config_pm"
--- 474,484 ----
import Config;
die "$0: $config_pm not valid"
! unless $Config{'PERL_CONFIG_SH'} eq 'true';
die "$0: error processing $config_pm"
if defined($Config{'an impossible name'})
! or $Config{'PERL_CONFIG_SH'} ne 'true' # test cache
;
die "$0: error processing $config_pm"
diff -c 'perl-5.7.1/configure.com' 'perl-5.7.2/configure.com'
Index: ./configure.com
*** ./configure.com Thu Apr 5 20:00:19 2001
--- ./configure.com Fri Jul 13 03:16:13 2001
***************
*** 1,3 ****
--- 1,4 ----
+ $! OpenVMS configuration procedure for Perl -- do not attempt to run under DOS
$ sav_ver = 'F$VERIFY(0)'
$! SET VERIFY
$!
***************
*** 583,607 ****
$!: Configure runs within the UU subdirectory
$!
$!: compute the number of columns on the terminal for proper question formatting
! $! (sfn, will assume 80-ish)
$!
$!: set up the echo used in my read !sfn
$!: now set up to do reads with possible shell escape and default assignment !sfn
$ GOTO Beyond_myread
$!
$myread:
$ ans = ""
$ If (fastread)
$ Then
! $ echo4 "''rp'"
$ Else
$ If (.NOT. silent) Then echo ""
! $ READ SYS$COMMAND/PROMPT="''rp'" ans
$ IF (ans .EQS. "&-d")
$ THEN
$ echo4 "(OK, I will run with -d after this question.)"
$ IF (.NOT. silent) THEN echo ""
! $ READ SYS$COMMAND/PROMPT="''rp'" ans
$ fastread := yes
$ ENDIF
$ IF (ans .EQS. "&-s")
--- 584,652 ----
$!: Configure runs within the UU subdirectory
$!
$!: compute the number of columns on the terminal for proper question formatting
! $ IF F$MODE() .EQS. "BATCH"
! $! else it winds up being 512 in batch
! $ THEN COLUMNS = 80
! $ ELSE COLUMNS = F$GETDVI("SYS$OUTPUT","DEVBUFSIZ")
! $ ENDIF
! $! "-des" sets SYS$OUTPUT to NL: with a DEVBUFSIZ too large (512 again)
! $ IF COLUMNS .GT. 210 THEN COLUMNS = 80
! $! not sure if this would actually be needed - it hopefully will not hurt
! $ IF COLUMNS .LT. 40 THEN COLUMNS = 40
$!
$!: set up the echo used in my read !sfn
$!: now set up to do reads with possible shell escape and default assignment !sfn
$ GOTO Beyond_myread
$!
+ $! The sub_rp splitting is intended to handle long symbols such as the dflt for
+ $! extensions.
+ $!
$myread:
$ ans = ""
+ $ len_rp = F$LENGTH(rp)
$ If (fastread)
$ Then
! $ IF len_rp .GT. 210
! $ THEN
! $ i_rp = 0
! $ fastread_rp_loop:
! $ sub_rp = F$EXTRACT(i_rp,COLUMNS,rp)
! $ echo4 "''sub_rp'"
! $ i_rp = i_rp + COLUMNS
! $ IF i_rp .LT. len_rp THEN GOTO fastread_rp_loop
! $ ELSE
! $ echo4 "''rp'"
! $ ENDIF
$ Else
$ If (.NOT. silent) Then echo ""
! $ IF len_rp .GT. 210
! $ THEN
! $ i_rp = 0
! $ firstread_rp_loop:
! $ sub_rp = F$EXTRACT(i_rp,COLUMNS,rp)
! $ echo4 "''sub_rp'"
! $ i_rp = i_rp + COLUMNS
! $ IF i_rp .LT. len_rp THEN GOTO firstread_rp_loop
! $ READ SYS$COMMAND/PROMPT="''sub_rp'" ans
! $ ELSE
! $ READ SYS$COMMAND/PROMPT="''rp'" ans
! $ ENDIF
$ IF (ans .EQS. "&-d")
$ THEN
$ echo4 "(OK, I will run with -d after this question.)"
$ IF (.NOT. silent) THEN echo ""
! $ IF len_rp .GT. 210
! $ THEN
! $ i_rp = 0
! $ secondread_rp_loop:
! $ sub_rp = F$EXTRACT(i_rp,COLUMNS,rp)
! $ echo4 "''sub_rp'"
! $ i_rp = i_rp + COLUMNS
! $ IF i_rp .LT. len_rp THEN GOTO secondread_rp_loop
! $ READ SYS$COMMAND/PROMPT="''sub_rp'" ans
! $ ELSE
! $ READ SYS$COMMAND/PROMPT="''rp'" ans
! $ ENDIF
$ fastread := yes
$ ENDIF
$ IF (ans .EQS. "&-s")
***************
*** 608,614 ****
$ THEN
$ echo4 "(OK, I will run with -s after this question.)"
$ echo ""
! $ READ SYS$COMMAND/PROMPT="''rp'" ans
$ silent := true
$ GOSUB Shut_up
$ ENDIF
--- 653,670 ----
$ THEN
$ echo4 "(OK, I will run with -s after this question.)"
$ echo ""
! $ IF len_rp .GT. 210
! $ THEN
! $ i_rp = 0
! $ thirdread_rp_loop:
! $ sub_rp = F$EXTRACT(i_rp,COLUMNS,rp)
! $ echo4 "''sub_rp'"
! $ i_rp = i_rp + COLUMNS
! $ IF i_rp .LT. len_rp THEN GOTO thirdread_rp_loop
! $ READ SYS$COMMAND/PROMPT="''sub_rp'" ans
! $ ELSE
! $ READ SYS$COMMAND/PROMPT="''rp'" ans
! $ ENDIF
$ silent := true
$ GOSUB Shut_up
$ ENDIF
***************
*** 1020,1025 ****
--- 1076,1084 ----
$! genconfig.pl has either archname='VMS_AXP' or 'VMS_VAX'
$! Note that DCL in VMS V5.4 does not have F$GETSYI("ARCH_NAME")
$! but does have F$GETSYI("HW_MODEL").
+ $! Please try to use either archname .EQS. "VMS_VAX" or archname .EQS.
+ $! "VMS_AXP" from here on to allow cross-platform configuration (e.g.
+ $! configure a VAX build on an Alpha).
$!
$ IF (F$GETSYI("HW_MODEL") .LT. 1024)
$ THEN
***************
*** 1048,1059 ****
$ vms_prefixup = F$EDIT(vms_prefix,"UPCASE")
$ rp = "Will you be sharing your ''vms_prefixup' with ''otherarch'? [''dflt'] "
$ GOSUB myread
! $ if ans.NES.""
$ THEN
- $ ans = F$EXTRACT(0,1,F$EDIT(ans,"COLLAPSE, UPCASE"))
- $ ENDIF
- $ IF (ans.NES."Y")
- $ THEN
$ sharedperl = "N"
$ ELSE
$ sharedperl = "Y"
--- 1107,1115 ----
$ vms_prefixup = F$EDIT(vms_prefix,"UPCASE")
$ rp = "Will you be sharing your ''vms_prefixup' with ''otherarch'? [''dflt'] "
$ GOSUB myread
! $ if ans .EQS. "" THEN ans = dflt
! $ IF .NOT. ans
$ THEN
$ sharedperl = "N"
$ ELSE
$ sharedperl = "Y"
***************
*** 1141,1149 ****
$!
$ ENDIF !%Config-I-VMS, skip remaining "where install" questions
$!
! $ perl_symbol = "true"
! $ perl_verb = ""
! $ dflt = "y"
$ IF .NOT.silent
$ THEN
$ echo ""
--- 1197,1208 ----
$!
$ ENDIF !%Config-I-VMS, skip remaining "where install" questions
$!
! $ IF F$TYPE(perl_symbol) .EQS. "" THEN perl_symbol := true
! $ IF F$TYPE(perl_verb) .EQS. "" THEN perl_verb = ""
! $ IF perl_symbol
! $ THEN dflt = "y"
! $ ELSE dflt = "n"
! $ ENDIF
$ IF .NOT.silent
$ THEN
$ echo ""
***************
*** 1154,1164 ****
$ ENDIF
$ rp = "Invoke perl as a global symbol foreign command? [''dflt'] "
$ GOSUB myread
! $ IF (.NOT.ans).AND.(ans.NES."") THEN perl_symbol = "false"
$!
$ IF (.NOT.perl_symbol)
$ THEN
! $ dflt = "y"
$ IF .NOT.silent
$ THEN
$ echo ""
--- 1213,1227 ----
$ ENDIF
$ rp = "Invoke perl as a global symbol foreign command? [''dflt'] "
$ GOSUB myread
! $ IF (ans.EQS."") THEN ans = dflt
! $ IF (.NOT.ans) THEN perl_symbol = "false"
$!
$ IF (.NOT.perl_symbol)
$ THEN
! $ IF perl_verb .EQS. "DCLTABLES"
! $ THEN dflt = "n"
! $ ELSE dflt = "y"
! $ ENDIF
$ IF .NOT.silent
$ THEN
$ echo ""
***************
*** 1168,1174 ****
$ ENDIF
$ rp = "Invoke perl as a per process command verb? [ ''dflt' ] "
$ GOSUB myread
! $ IF (.NOT.ans).AND.(ans.NES."")
$ THEN perl_verb = "DCLTABLES"
$ ELSE perl_verb = "PROCESS"
$ ENDIF
--- 1231,1238 ----
$ ENDIF
$ rp = "Invoke perl as a per process command verb? [ ''dflt' ] "
$ GOSUB myread
! $ IF (ans.EQS."") THEN ans = dflt
! $ IF (.NOT.ans)
$ THEN perl_verb = "DCLTABLES"
$ ELSE perl_verb = "PROCESS"
$ ENDIF
***************
*** 1889,1895 ****
$List_Parse:
$ OPEN/READ CONFIG ccvms.lis
$ READ CONFIG line
! $ IF (F$GETSYI("HW_MODEL") .LT. 1024)
$ THEN
$ read CONFIG line
$ archsufx = "VAX"
--- 1953,1959 ----
$List_Parse:
$ OPEN/READ CONFIG ccvms.lis
$ READ CONFIG line
! $ IF archname .EQS. "VMS_VAX"
$ THEN
$ read CONFIG line
$ archsufx = "VAX"
***************
*** 2085,2094 ****
$ IF ans.eqs."decc" then Has_Dec_C_Sockets = "T"
$ IF ans.eqs."socketshr" then Has_socketshr = "T"
$ ENDIF
- $ IF Has_Dec_C_Sockets .or. Has_socketshr
- $ THEN
- $ static_ext = f$edit(static_ext+" "+"Socket","trim,compress")
- $ ENDIF
$!
$!
$! Ask if they want to build with VMS_DEBUG perl
--- 2149,2154 ----
***************
*** 2387,2392 ****
--- 2447,2492 ----
$ if ans.eqs."PACK_MALLOC" then use_pack_malloc = "Y"
$ ENDIF
$!
+ $ known_extensions = ""
+ $ xxx = ""
+ $ OPEN/READ CONFIG 'manifestfound'
+ $ext_loop:
+ $ READ/END_OF_FILE=end_ext/ERROR=end_ext CONFIG line
+ $ IF F$EXTRACT(0,4,line) .NES. "ext/" .AND. -
+ F$EXTRACT(0,8,line) .NES. "vms/ext/" THEN goto ext_loop
+ $ line = F$EDIT(line,"COMPRESS")
+ $ line = F$ELEMENT(0," ",line)
+ $ line_len = F$LENGTH(line)
+ $ IF F$EXTRACT(line_len - 12,12,line) .NES. "/Makefile.PL" THEN goto ext_loop
+ $ IF F$EXTRACT(0,4,line) .EQS. "ext/" THEN -
+ xxx = F$EXTRACT(4,line_len - 16,line)
+ $ IF xxx .EQS. "DynaLoader" THEN goto ext_loop ! omit
+ $ IF xxx .EQS. "SDBM_File/sdbm" THEN goto ext_loop ! sub extension - omit
+ $ IF F$EXTRACT(0,8,line) .EQS. "vms/ext/" THEN -
+ xxx = "VMS/" + F$EXTRACT(8,line_len - 20,line)
+ $ known_extensions = known_extensions + " ''xxx'"
+ $ goto ext_loop
+ $end_ext:
+ $ close CONFIG
+ $ DELETE/SYMBOL xxx
+ $ known_extensions = F$EDIT(known_extensions,"TRIM,COMPRESS")
+ $ dflt = known_extensions
+ $ IF ccname .NES. "DEC" .AND. ccname .NES. "CXX"
+ $ THEN
+ $ dflt = dflt - "POSIX" ! not with VAX C or GCC
+ $ ENDIF
+ $ dflt = dflt - "ByteLoader" ! needs to be ported
+ $ dflt = dflt - "DB_File" ! needs to be ported
+ $ dflt = dflt - "GDBM_File" ! needs porting/special library
+ $ dflt = dflt - "IPC/SysV" ! needs to be ported
+ $ dflt = dflt - "NDBM_File" ! needs porting/special library
+ $ dflt = dflt - "ODBM_File" ! needs porting/special library
+ $ IF .NOT. Has_socketshr .AND. .NOT. Has_Dec_C_Sockets
+ $ THEN
+ $ dflt = dflt - "Socket" ! optional on VMS
+ $ ENDIF
+ $ dflt = F$EDIT(dflt,"TRIM,COMPRESS")
+ $!
$! Ask for their default list of extensions to build
$ echo ""
$ echo "It is time to specify which modules you want to build into"
***************
*** 2395,2446 ****
$ echo "SDBM_File if you have the GDBM library built on your machine."
$ echo ""
$ echo "Which modules do you want to build into perl?"
- $! we need to add Byteloader to this list:
- $ dflt = "re Fcntl Encode Errno File::Glob Filter::Util::Call IO Opcode Devel::Peek Devel::DProf Data::Dumper attrs VMS::Stdio VMS::DCLsym B SDBM_File Storable Thread Sys::Hostname Digest::MD5 PerlIO::Scalar MIME::Base64 XS::Typemap"
- $ IF ccname .EQS. "DEC" .OR. ccname .EQS. "CXX"
- $ THEN
- $ dflt = dflt + " POSIX"
- $ ENDIF
$ rp = "[''dflt'] "
$ GOSUB myread
! $ if ans.eqs."" then ans = "''dflt'"
! $ a = ""
! $ j = 0
! $ xloop1:
! $ x = f$elem(j," ",ans)
! $ j = j + 1
! $ if x .eqs. " " then goto exloop1
! $ xloop2:
! $ k = f$locate("::",x)
! $ if k .ge. f$len(x) then goto exloop2
! $ x = f$extract(0,k,x) + "/" + f$extract(k+2,f$len(x)-2,x)
! $ goto xloop2
! $ exloop2:
! $ a = a + " " + x
! $ goto xloop1
! $ exloop1:
! $ ans = f$edit(a,"trim")
$!
- $ a = ""
- $ j = 0
- $ xloop3:
- $ x = f$elem(j," ",dflt)
- $ j = j + 1
- $ if x .eqs. " " then goto exloop3
- $ xloop4:
- $ k = f$locate("::",x)
- $ if k .ge. f$len(x) then goto exloop4
- $ x = f$extract(0,k,x) + "/" + f$extract(k+2,f$len(x)-2,x)
- $ goto xloop4
- $ exloop4:
- $ a = a + " " + x
- $ goto xloop3
- $ exloop3:
- $ dflt = f$edit(a,"trim")
- $!
- $ extensions = "''ans'"
- $ known_extensions = "''dflt'"
- $!
$! %Config-I-VMS, determine build/make utility here (make gmake mmk mms)
$ echo ""
$ echo "Checking your ""make"" utilities..."
--- 2495,2505 ----
$ echo "SDBM_File if you have the GDBM library built on your machine."
$ echo ""
$ echo "Which modules do you want to build into perl?"
$ rp = "[''dflt'] "
$ GOSUB myread
! $ if ans .eqs. "" then ans = "''dflt'"
! $ extensions = F$EDIT(ans,"TRIM,COMPRESS")
$!
$! %Config-I-VMS, determine build/make utility here (make gmake mmk mms)
$ echo ""
$ echo "Checking your ""make"" utilities..."
***************
*** 2665,2671 ****
$! - also take vms/descrip_mms.template -> descrip.mms (VMS Makefile)
$! vms/Makefile.in -> Makefile. (VMS GNU Makefile?)
$! vms/Makefile.SH -> Makefile. (VMS GNU Makefile?)
- $! - build make_ext.com extension builder procedure.
$!
$! Note for folks from other platforms changing things in here:
$!
--- 2724,2729 ----
***************
*** 2764,2770 ****
$!
$ perl_cc=Mcc
$!
! $ IF (sharedperl .AND. F$GETSYI("HW_MODEL") .GE. 1024)
$ THEN
$ obj_ext=".abj"
$ so="axe"
--- 2822,2828 ----
$!
$ perl_cc=Mcc
$!
! $ IF (sharedperl .AND. archname .EQS. "VMS_AXP")
$ THEN
$ obj_ext=".abj"
$ so="axe"
***************
*** 3596,3602 ****
$ WS "int main()"
$ WS "{"
$ WS "char * place;"
! $ WS "place = memchr(""foo"", 47, 3)"
$ WS "exit(0);"
$ WS "}"
$ CS
--- 3654,3660 ----
$ WS "int main()"
$ WS "{"
$ WS "char * place;"
! $ WS "place = memchr(""foo"", 47, 3);"
$ WS "exit(0);"
$ WS "}"
$ CS
***************
*** 4553,4558 ****
--- 4611,4632 ----
$ d_sysconf="undef"
$ d_sigsetjmp="undef"
$ ENDIF
+ $!: see if tzname[] exists
+ $ OS
+ $ WS "#include <stdio.h>"
+ $ WS "#include <time.h>"
+ $ WS "int main() { extern short tzname[]; printf(""%hd"", tzname[0]); }"
+ $ CS
+ $ GOSUB compile_ok
+ $ IF compile_status .EQ. good_compile
+ $ THEN
+ $ d_tzname = "undef"
+ $ echo4 "tzname[] NOT found."
+ $ ELSE
+ $ d_tzname = "define"
+ $ echo4 "tzname[] found."
+ $ ENDIF
+ $ IF F$SEARCH("try.obj") .NES. "" THEN DELETE/NOLOG/NOCONFIRM try.obj;
$!
$ IF d_gethname .EQS. "undef" .AND. d_uname .EQS. "undef"
$ THEN
***************
*** 4577,4583 ****
--- 4651,4659 ----
$ d_strxfrm="define"
$ d_wctomb="define"
$ i_locale="define"
+ $ i_langinfo="define"
$ d_locconv="define"
+ $ d_nl_langinfo="define"
$ d_setlocale="define"
$ vms_cc_type="decc"
$ ELSE
***************
*** 4594,4604 ****
$ d_strxfrm="undef"
$ d_wctomb="undef"
$ i_locale="undef"
$ d_locconv="undef"
$ d_setlocale="undef"
$ ENDIF
$ d_stdio_ptr_lval_sets_cnt="undef"
! $ d_stdio_ptr_lval_nochange_cnt="undef"
$!
$! Sockets?
$ if Has_Socketshr .OR. Has_Dec_C_Sockets
--- 4670,4682 ----
$ d_strxfrm="undef"
$ d_wctomb="undef"
$ i_locale="undef"
+ $ i_langinfo="undef"
$ d_locconv="undef"
+ $ d_nl_langinfo="undef"
$ d_setlocale="undef"
$ ENDIF
$ d_stdio_ptr_lval_sets_cnt="undef"
! $ d_stdio_ptr_lval_nochange_cnt="define"
$!
$! Sockets?
$ if Has_Socketshr .OR. Has_Dec_C_Sockets
***************
*** 4895,4908 ****
$ WC "cppminus='" + cppminus + "'"
$ WC "cpprun='" + cpprun + "'"
$ WC "cppstdin='" + cppstdin + "'"
- $ WC "crosscompile='undef'"
- $ WC "d__fwalk='undef'"
$ WC "d_Gconvert='my_gconvert(x,n,t,b)'"
- $ WC "d_PRId64='" + d_PRId64 + "'"
$ WC "d_PRIEldbl='" + d_PRIEUldbl + "'"
$ WC "d_PRIFldbl='" + d_PRIFUldbl + "'"
$ WC "d_PRIGldbl='" + d_PRIGUldbl + "'"
$ WC "d_PRIX64='" + d_PRIXU64 + "'"
$ WC "d_PRIeldbl='" + d_PRIeldbl + "'"
$ WC "d_PRIfldbl='" + d_PRIfldbl + "'"
$ WC "d_PRIgldbl='" + d_PRIgldbl + "'"
--- 4973,4984 ----
$ WC "cppminus='" + cppminus + "'"
$ WC "cpprun='" + cpprun + "'"
$ WC "cppstdin='" + cppstdin + "'"
$ WC "d_Gconvert='my_gconvert(x,n,t,b)'"
$ WC "d_PRIEldbl='" + d_PRIEUldbl + "'"
$ WC "d_PRIFldbl='" + d_PRIFUldbl + "'"
$ WC "d_PRIGldbl='" + d_PRIGUldbl + "'"
$ WC "d_PRIX64='" + d_PRIXU64 + "'"
+ $ WC "d_PRId64='" + d_PRId64 + "'"
$ WC "d_PRIeldbl='" + d_PRIeldbl + "'"
$ WC "d_PRIfldbl='" + d_PRIfldbl + "'"
$ WC "d_PRIgldbl='" + d_PRIgldbl + "'"
***************
*** 4910,4915 ****
--- 4986,4992 ----
$ WC "d_PRIu64='" + d_PRIu64 + "'"
$ WC "d_PRIx64='" + d_PRIx64 + "'"
$ WC "d_SCNfldbl='" + d_SCNfldbl + "'"
+ $ WC "d__fwalk='undef'"
$ WC "d_access='" + d_access + "'"
$ WC "d_accessx='undef'"
$ WC "d_alarm='define'"
***************
*** 4921,4928 ****
$ WC "d_bcopy='" + d_bcopy + "'"
$ WC "d_bincompat3='undef'"
$ WC "d_bincompat5005='undef'"
- $ WC "d_bsdgetpgrp='undef'"
$! WC "d_bsdpgrp='undef'"
$ WC "d_bsdsetpgrp='undef'"
$ WC "d_bzero='" + d_bzero + "'"
$ WC "d_casti32='define'"
--- 4998,5005 ----
$ WC "d_bcopy='" + d_bcopy + "'"
$ WC "d_bincompat3='undef'"
$ WC "d_bincompat5005='undef'"
$! WC "d_bsdpgrp='undef'"
+ $ WC "d_bsdgetpgrp='undef'"
$ WC "d_bsdsetpgrp='undef'"
$ WC "d_bzero='" + d_bzero + "'"
$ WC "d_casti32='define'"
***************
*** 4937,4942 ****
--- 5014,5020 ----
$ WC "d_csh='undef'"
$ WC "d_cuserid='define'"
$ WC "d_dbl_dig='define'"
+ $ WC "d_dbminitproto='undef'"
$ WC "d_difftime='define'"
$ WC "d_dirnamlen='define'"
$ WC "d_dlerror='undef'"
***************
*** 4954,4959 ****
--- 5032,5038 ----
$ WC "d_eofnblk='undef'"
$ WC "d_eunice='undef'"
$ WC "d_fchmod='undef'"
+ $ WC "d_fchdir='undef'"
$ WC "d_fchown='undef'"
$ WC "d_fcntl='" + d_fcntl + "'"
$ WC "d_fcntl_can_lock='" + d_fcntl_can_lock + "'"
***************
*** 4961,4966 ****
--- 5040,5046 ----
$ WC "d_fgetpos='define'"
$ WC "d_flexfnam='define'"
$ WC "d_flock='undef'"
+ $ WC "d_flockproto='undef'"
$ WC "d_fork='undef'"
$ WC "d_fpathconf='" + d_fpathconf + "'"
$ WC "d_fpos64_t='" + d_fpos64_t + "'"
***************
*** 4972,4978 ****
$ WC "d_fstatvfs='undef'"
$ WC "d_fsync='undef'"
$ WC "d_ftello='undef'"
! $ WC "d_getcwd='undef'"
$ WC "d_getespwnam='undef'"
$ WC "d_getfsstat='undef'"
$ WC "d_getgrent='define'"
--- 5052,5058 ----
$ WC "d_fstatvfs='undef'"
$ WC "d_fsync='undef'"
$ WC "d_ftello='undef'"
! $ WC "d_getcwd='define'"
$ WC "d_getespwnam='undef'"
$ WC "d_getfsstat='undef'"
$ WC "d_getgrent='define'"
***************
*** 5048,5053 ****
--- 5128,5134 ----
$ WC "d_mktime='" + d_mktime + "'"
$ WC "d_mmap='undef'"
$ WC "d_modfl='" + d_modfl + "'"
+ $ WC "d_modfl_pow32_bug='undef'"
$ WC "d_mprotect='undef'"
$ WC "d_msg='undef'"
$ WC "d_msg_ctrunc='undef'"
***************
*** 5060,5065 ****
--- 5141,5147 ----
$ WC "d_munmap='undef'"
$ WC "d_mymalloc='" + d_mymalloc + "'"
$ WC "d_nice='define'"
+ $ WC "d_nl_langinfo='" + d_nl_langinfo + "'"
$ WC "d_nv_preserves_uv='" + d_nv_preserves_uv + "'"
$ WC "d_nv_preserves_uv_bits='" + d_nv_preserves_uv_bits + "'"
$ WC "d_off64_t='" + d_off64_t + "'"
***************
*** 5073,5078 ****
--- 5155,5161 ----
$ WC "d_phostname='" + d_phostname + "'"
$ WC "d_pipe='define'"
$ WC "d_poll='undef'"
+ $ WC "d_pthread_atfork='undef'"
$ WC "d_pthread_yield='" + d_pthread_yield + "'"
$ WC "d_pthreads_created_joinable='" + d_pthreads_created_joinable + "'"
$ WC "d_pwage='undef'"
***************
*** 5088,5093 ****
--- 5171,5177 ----
$ WC "d_readdir='define'"
$ WC "d_readlink='undef'"
$ WC "d_readv='undef'"
+ $ WC "d_realpath='undef'"
$ WC "d_recvmsg='undef'"
$ WC "d_rename='define'"
$ WC "d_rewinddir='define'"
***************
*** 5137,5147 ****
--- 5221,5236 ----
$ WC "d_sigprocmask='" + d_sigprocmask + "'"
$ WC "d_sigsetjmp='" + d_sigsetjmp + "'"
$ WC "d_sockatmark='undef'"
+ $ WC "d_sockatmarkproto='undef'"
$ WC "d_socket='" + d_socket + "'"
$ WC "d_socklen_t='" + d_socklen_t + "'"
$ WC "d_sockpair='undef'"
$ WC "d_socks5_init='undef'"
$ WC "d_sqrtl='define'"
+ $ WC "d_sresgproto='undef'"
+ $ WC "d_sresgproto='undef'"
+ $ WC "d_sresproto='undef'"
+ $ WC "d_sresuproto='undef'"
$ WC "d_statblks='undef'"
$ WC "d_statfs_f_flags='undef'"
$ WC "d_statfs_s='undef'"
***************
*** 5148,5155 ****
$ WC "d_statfsflags='undef'"
$ WC "d_stdio_cnt_lval='" + d_stdio_cnt_lval + "'"
$ WC "d_stdio_ptr_lval='" + d_stdio_ptr_lval + "'"
- $ WC "d_stdio_ptr_lval_sets_cnt='" + d_stdio_ptr_lval_sets_cnt + "'"
$ WC "d_stdio_ptr_lval_nochange_cnt='" + d_stdio_ptr_lval_nochange_cnt + "'"
$ WC "d_stdio_stream_array='undef'"
$ WC "d_stdiobase='" + d_stdiobase + "'"
$ WC "d_stdstdio='" + d_stdstdio + "'"
--- 5237,5244 ----
$ WC "d_statfsflags='undef'"
$ WC "d_stdio_cnt_lval='" + d_stdio_cnt_lval + "'"
$ WC "d_stdio_ptr_lval='" + d_stdio_ptr_lval + "'"
$ WC "d_stdio_ptr_lval_nochange_cnt='" + d_stdio_ptr_lval_nochange_cnt + "'"
+ $ WC "d_stdio_ptr_lval_sets_cnt='" + d_stdio_ptr_lval_sets_cnt + "'"
$ WC "d_stdio_stream_array='undef'"
$ WC "d_stdiobase='" + d_stdiobase + "'"
$ WC "d_stdstdio='" + d_stdstdio + "'"
***************
*** 5158,5163 ****
--- 5247,5253 ----
$ WC "d_strctcpy='define'"
$ WC "d_strerrm='strerror((e),vaxc$errno)'"
$ WC "d_strerror='define'"
+ $ WC "d_strftime='define'"
$ WC "d_strtod='define'"
$ WC "d_strtol='define'"
$ WC "d_strtold='" + d_strtold + "'"
***************
*** 5170,5175 ****
--- 5260,5266 ----
$ WC "d_suidsafe='undef'"
$ WC "d_symlink='undef'"
$ WC "d_syscall='undef'"
+ $ WC "d_syscallproto='undef'"
$ WC "d_sysconf='" + d_sysconf + "'"
$ WC "d_syserrlst='undef'"
$ WC "d_system='define'"
***************
*** 5179,5185 ****
$ WC "d_telldirproto='define'"
$ WC "d_times='define'"
$ WC "d_truncate='" + d_truncate + "'"
! $ WC "d_tzname='undef'"
$ WC "d_u32align='define'"
$ WC "d_ualarm='undef'"
$ WC "d_umask='define'"
--- 5270,5276 ----
$ WC "d_telldirproto='define'"
$ WC "d_times='define'"
$ WC "d_truncate='" + d_truncate + "'"
! $ WC "d_tzname='" + d_tzname + "'"
$ WC "d_u32align='define'"
$ WC "d_ualarm='undef'"
$ WC "d_umask='define'"
***************
*** 5187,5192 ****
--- 5278,5284 ----
$ WC "d_union_semun='undef'"
$ WC "d_unlink_all_versions='undef'"
$ WC "d_usleep='undef'"
+ $ WC "d_usleepproto='undef'"
$ WC "d_ustat='undef'"
$ WC "d_vendorarch='undef'"
$ WC "d_vendorlib='undef'"
***************
*** 5212,5224 ****
$ WC "dlsrc='dl_vms.c'"
$ WC "doublesize='" + doublesize + "'"
$ WC "drand01='" + drand01 + "'"
! $ WC "dynamic_ext='" + extensions + "'"
$ WC "eagain=' '"
$ WC "ebcdic='undef'"
$ WC "embedmymalloc='" + mymalloc + "'"
$ WC "eunicefix=':'"
$ WC "exe_ext='" + exe_ext + "'"
! $ WC "extensions='" + extensions + "'"
$ WC "fflushNULL='define'"
$ WC "fflushall='undef'"
$ WC "fpostype='fpos_t'"
--- 5304,5326 ----
$ WC "dlsrc='dl_vms.c'"
$ WC "doublesize='" + doublesize + "'"
$ WC "drand01='" + drand01 + "'"
! $!
! $! The extensions symbol may be quite long
! $!
! $ tmp = "dynamic_ext='" + extensions + "'"
! $ WC/symbol tmp
! $ DELETE/SYMBOL tmp
$ WC "eagain=' '"
$ WC "ebcdic='undef'"
$ WC "embedmymalloc='" + mymalloc + "'"
$ WC "eunicefix=':'"
$ WC "exe_ext='" + exe_ext + "'"
! $!
! $! The extensions symbol may be quite long
! $!
! $ tmp = "extensions='" + extensions + "'"
! $ WC/symbol tmp
! $ DELETE/SYMBOL tmp
$ WC "fflushNULL='define'"
$ WC "fflushall='undef'"
$ WC "fpostype='fpos_t'"
***************
*** 5252,5257 ****
--- 5354,5360 ----
$ WC "i_iconv='" + i_iconv +"'"
$ WC "i_ieeefp='undef'"
$ WC "i_inttypes='" + i_inttypes + "'"
+ $ WC "i_langinfo='" + i_langinfo + "'"
$ WC "i_libutil='" + i_libutil + "'"
$ WC "i_limits='define'"
$ WC "i_locale='" + i_locale + "'"
***************
*** 5329,5335 ****
$ WC "ivdformat='" + ivdformat + "'"
$ WC "ivsize='" + ivsize + "'"
$ WC "ivtype='" + ivtype + "'"
! $ WC "known_extensions='" + known_extensions + "'"
$ WC "ld='" + ld + "'"
$ WC "lddlflags='/Share'"
$ WC "ldflags='" + ldflags + "'"
--- 5432,5443 ----
$ WC "ivdformat='" + ivdformat + "'"
$ WC "ivsize='" + ivsize + "'"
$ WC "ivtype='" + ivtype + "'"
! $!
! $! The known_extensions symbol may be quite long
! $!
! $ tmp = "known_extensions='" + known_extensions + "'"
! $ WC/symbol tmp
! $ DELETE/SYMBOL tmp
$ WC "ld='" + ld + "'"
$ WC "lddlflags='/Share'"
$ WC "ldflags='" + ldflags + "'"
***************
*** 5463,5468 ****
--- 5571,5577 ----
$ WC "use64bitall='" + use64bitall + "'"
$ WC "use64bitint='" + use64bitint + "'"
$ WC "usedebugging_perl='" + use_debugging_perl + "'"
+ $ WC "usecrosscompile='undef'"
$ WC "usedl='" + usedl + "'"
$ WC "useithreads='" + useithreads + "'"
$ WC "uselargefiles='" + uselargefiles + "'"
***************
*** 5472,5477 ****
--- 5581,5587 ----
$ WC "usemymalloc='" + usemymalloc + "'"
$ WC "useperlio='" + useperlio + "'"
$ WC "useposix='false'"
+ $ WC "usereentrant='undef'"
$ WC "usesocks='undef'"
$ WC "usethreads='" + usethreads + "'"
$ WC "usevfork='true'"
***************
*** 5490,5496 ****
$ WC "vms_ver='" + vms_ver + "'" ! VMS specific
$ WC "voidflags='15'"
$ WC "xs_apiversion='" + version + "'"
! $ WC "CONFIGDOTSH='true'"
$!
$! ##END WRITE NEW CONSTANTS HERE##
$!
--- 5600,5606 ----
$ WC "vms_ver='" + vms_ver + "'" ! VMS specific
$ WC "voidflags='15'"
$ WC "xs_apiversion='" + version + "'"
! $ WC "PERL_CONFIG_SH='true'"
$!
$! ##END WRITE NEW CONSTANTS HERE##
$!
***************
*** 5589,5594 ****
--- 5699,5711 ----
$ IF d_herrno .EQS. "undef" THEN WC "#define NEED_AN_H_ERRNO"
$ WC "#define HAS_ENVGETENV"
$ WC "#define PERL_EXTERNAL_GLOB"
+ $ IF archname .EQS. "VMS_VAX" .AND. -
+ ccname .EQS. "DEC" .AND. -
+ ccversion .LE. 50390006
+ $ THEN
+ $! Alas this does not help to build Fcntl
+ $! WC "#define PERL_IGNORE_FPUSIG SIGFPE"
+ $ ENDIF
$ CLOSE CONFIG
$!
$ echo4 "Doing variable substitutions on .SH files..."
***************
*** 5658,5663 ****
--- 5775,5781 ----
"''Thread_Live_Dangerously'" "PV=''version'" "FLAGS=FLAGS=''extra_flags'"
$! Clean up after ourselves
$ DELETE/NOLOG/NOCONFIRM []munchconfig.exe;
+ $!
$ echo4 "Extracting make_ext.com (without variable substitutions)"
$ Create Sys$Disk:[-]make_ext.com
$ Deck/Dollar="$EndOfTpl$"
***************
*** 5666,5682 ****
$! Any changes made to it directly will be lost. If you need to make any
$! changes, please edit the template in Configure.Com instead.
$ def = F$Environment("Default")
! $ exts1 = F$Edit(p1,"Compress")
! $ p2 = F$Edit(p2,"Upcase,Compress,Trim")
! $ If F$Locate("MCR ",p2).eq.0 Then p2 = F$Extract(3,255,p2)
! $ miniperl = "$" + F$Search(F$Parse(p2,".Exe"))
! $ makeutil = p3
! $ if f$type('p3') .nes. "" then makeutil = 'p3'
! $ targ = F$Edit(p4,"Lowercase")
$ i = 0
$ next_ext:
! $ ext = F$Element(i," ",p1)
! $ If ext .eqs. " " Then Goto done
$ Define/User_mode Perl_Env_Tables CLISYM_LOCAL
$ miniperl
$ deck
--- 5784,5814 ----
$! Any changes made to it directly will be lost. If you need to make any
$! changes, please edit the template in Configure.Com instead.
$ def = F$Environment("Default")
! $! p1 - how to invoke miniperl (passed in from descrip.mms)
! $ p1 = F$Edit(p1,"Upcase,Compress,Trim")
! $ If F$Locate("MCR ",p1).eq.0 Then p1 = F$Extract(3,255,p1)
! $ miniperl = "$" + F$Search(F$Parse(p1,".Exe"))
! $! p2 - how to invoke local make utility (passed in from descrip.mms)
! $ makeutil = p2
! $ if f$type('p2') .nes. "" then makeutil = 'p2'
! $! p3 - make target (passed in from descrip.mms)
! $ targ = F$Edit(p3,"Lowercase")
! $ sts = 1
! $ extensions = ""
! $ open/read CONFIG config.sh
! $ find_ext_loop:
! $ read/end=end_ext_loop CONFIG line
! $ if (f$extract(0,12,line) .NES. "extensions='")
! $ then goto find_ext_loop
! $ else extensions = f$extract(12,f$length(line),line) - "'"
! $ endif
! $ end_ext_loop:
! $ close CONFIG
! $ extensions = f$edit(extensions,"TRIM,COMPRESS")
$ i = 0
$ next_ext:
! $ ext = f$element(i," ",extensions)
! $ If ext .eqs. " " .or. ext .eqs. "" Then Goto done
$ Define/User_mode Perl_Env_Tables CLISYM_LOCAL
$ miniperl
$ deck
***************
*** 5811,5816 ****
--- 5943,5950 ----
$ CALL Bad_environment "T"
$ CALL Bad_environment "FOO"
$ CALL Bad_environment "EXT"
+ $ CALL Bad_environment "SOME_LOGICAL_NAME_NOT_LIKELY"
+ $ CALL Bad_environment "DOWN_LOGICAL_NAME_NOT_LIKELY"
$ CALL Bad_environment "TEST" "SYMBOL"
$ IF f$search("config.msg") .eqs. "" THEN echo "OK."
$!
***************
*** 5823,5829 ****
$ echo4 "The perl.cld file is now being written..."
$ OPEN/WRITE CONFIG 'file_2_find'
$ ext = ".exe"
! $ IF ((sharedperl) .AND. (F$GETSYI("HW_MODEL") .GE. 1024)) THEN ext := .AXE
$ IF (use_vmsdebug_perl)
$ THEN
$ WRITE CONFIG "define verb dbgperl"
--- 5957,5963 ----
$ echo4 "The perl.cld file is now being written..."
$ OPEN/WRITE CONFIG 'file_2_find'
$ ext = ".exe"
! $ IF (sharedperl .AND. archname .EQS. "VMS_AXP") THEN ext := .AXE
$ IF (use_vmsdebug_perl)
$ THEN
$ WRITE CONFIG "define verb dbgperl"
diff -c 'perl-5.7.1/cop.h' 'perl-5.7.2/cop.h'
Index: ./cop.h
*** ./cop.h Sat Mar 17 20:34:46 2001
--- ./cop.h Mon Jul 9 17:09:47 2001
***************
*** 156,161 ****
--- 156,162 ----
SV * old_namesv;
OP * old_eval_root;
SV * cur_text;
+ CV * cv;
};
#define PUSHEVAL(cx,n,fgv) \
***************
*** 165,170 ****
--- 166,172 ----
cx->blk_eval.old_namesv = (n ? newSVpv(n,0) : Nullsv); \
cx->blk_eval.old_eval_root = PL_eval_root; \
cx->blk_eval.cur_text = PL_linestr; \
+ cx->blk_eval.cv = Nullcv; /* set by doeval(), as applicable */ \
} STMT_END
#define POPEVAL(cx) \
diff -c 'perl-5.7.1/cv.h' 'perl-5.7.2/cv.h'
Index: ./cv.h
*** ./cv.h Tue Mar 6 04:04:23 2001
--- ./cv.h Mon Jul 9 17:09:47 2001
***************
*** 55,60 ****
--- 55,65 ----
#define CvXSUBANY(sv) ((XPVCV*)SvANY(sv))->xcv_xsubany
#define CvGV(sv) ((XPVCV*)SvANY(sv))->xcv_gv
#define CvFILE(sv) ((XPVCV*)SvANY(sv))->xcv_file
+ #ifdef USE_ITHREADS
+ # define CvFILE_set_from_cop(sv, cop) (CvFILE(sv) = savepv(CopFILE(cop)))
+ #else
+ # define CvFILE_set_from_cop(sv, cop) (CvFILE(sv) = CopFILE(cop))
+ #endif
#define CvFILEGV(sv) (gv_fetchfile(CvFILE(sv))
#define CvDEPTH(sv) ((XPVCV*)SvANY(sv))->xcv_depth
#define CvPADLIST(sv) ((XPVCV*)SvANY(sv))->xcv_padlist
diff -c 'perl-5.7.1/cygwin/Makefile.SHs' 'perl-5.7.2/cygwin/Makefile.SHs'
Index: ./cygwin/Makefile.SHs
*** ./cygwin/Makefile.SHs Tue Mar 6 04:04:23 2001
--- ./cygwin/Makefile.SHs Mon Jul 9 17:09:47 2001
***************
*** 8,14 ****
#
#! /bin/sh
! case $CONFIG in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
--- 8,14 ----
#
#! /bin/sh
! case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
***************
*** 36,42 ****
# install is included in Cygwin distributions, and we make a note of th
# requirement in the README.cygwin file. However, let's give them
# a warning.
! @install -c -m 755 ld2 ${installbin}/ld2
@if test ! -f ${installbin}/ld2; then \
echo "*************************************************" ; \
echo "Make will probably fail in a few more steps." ; \
--- 36,42 ----
# install is included in Cygwin distributions, and we make a note of th
# requirement in the README.cygwin file. However, let's give them
# a warning.
! @/usr/bin/install -c -m 755 ld2 ${installbin}/ld2
@if test ! -f ${installbin}/ld2; then \
echo "*************************************************" ; \
echo "Make will probably fail in a few more steps." ; \
diff -c 'perl-5.7.1/djgpp/config.over' 'perl-5.7.2/djgpp/config.over'
Index: ./djgpp/config.over
*** ./djgpp/config.over Sun Mar 25 07:14:46 2001
--- ./djgpp/config.over Mon Jul 9 17:09:48 2001
***************
*** 40,46 ****
-e 's=filter/util/call=Filter/Util/Call=' \
-e 's=digest/md5=Digest/MD5=' \
-e 's=perlio/scalar=PerlIO/Scalar=' \
! -e 's=mime/base64=MIME/Base64='
}
static_ext=$(repair "$static_ext")
extensions=$(repair "$extensions")
--- 40,52 ----
-e 's=filter/util/call=Filter/Util/Call=' \
-e 's=digest/md5=Digest/MD5=' \
-e 's=perlio/scalar=PerlIO/Scalar=' \
! -e 's=mime/base64=MIME/Base64=' \
! -e 's=time/hires=Time/HiRes=' \
! -e 's=list/util=List/Util=' \
! -e 's=time/piece=Time/Piece=' \
! -e 's=cwd=Cwd=' \
! -e 's=perlio/via=PerlIO/Via=' \
! -e 's=xs/typemap=XS/Typemap='
}
static_ext=$(repair "$static_ext")
extensions=$(repair "$extensions")
diff -c 'perl-5.7.1/djgpp/configure.bat' 'perl-5.7.2/djgpp/configure.bat'
Index: ./djgpp/configure.bat
*** ./djgpp/configure.bat Tue Apr 10 05:29:17 2001
--- ./djgpp/configure.bat Fri Jul 13 17:18:32 2001
***************
*** 1,37 ****
! @echo off
! set CONFIG=
! set PATH_SEPARATOR=;
! set PATH_EXPAND=y
! sh -c 'if test $PATH_SEPARATOR = ";"; then exit 1; fi'
! if ERRORLEVEL 1 goto path_sep_ok
! echo Error:
! echo Make sure the environment variable PATH_SEPARATOR=; while building perl!
! echo Please check your DJGPP.ENV!
! goto end
!
! :path_sep_ok
! sh -c 'if test $PATH_EXPAND = "Y" -o $PATH_EXPAND = "y"; then exit 1; fi'
! if ERRORLEVEL 1 goto path_exp_ok
! echo Error:
! echo Make sure the environment variable PATH_EXPAND=Y while building perl!
! echo Please check your DJGPP.ENV!
! goto end
!
! :path_exp_ok
! sh -c '$SHELL -c "exit 128"'
! if ERRORLEVEL 128 goto shell_ok
!
! echo Error:
! echo The SHELL environment variable must be set to the full path of your sh.exe!
! goto end
!
! :shell_ok
! sh -c 'if test ! -d /tmp; then mkdir /tmp; fi'
! cp djgpp.c config.over ..
! cd ..
! echo Running sed...
! sh djgpp/djgppsed.sh
!
! echo Running Configure...
! sh Configure %1 %2 %3 %4 %5 %6 %7 %8 %9
! :end
--- 1,37 ----
! @echo off
! set CONFIG=
! set PATH_SEPARATOR=;
! set PATH_EXPAND=y
! sh -c 'if test $PATH_SEPARATOR = ";"; then exit 1; fi'
! if ERRORLEVEL 1 goto path_sep_ok
! echo Error:
! echo Make sure the environment variable PATH_SEPARATOR=; while building perl!
! echo Please check your DJGPP.ENV!
! goto end
!
! :path_sep_ok
! sh -c 'if test $PATH_EXPAND = "Y" -o $PATH_EXPAND = "y"; then exit 1; fi'
! if ERRORLEVEL 1 goto path_exp_ok
! echo Error:
! echo Make sure the environment variable PATH_EXPAND=Y while building perl!
! echo Please check your DJGPP.ENV!
! goto end
!
! :path_exp_ok
! sh -c '$SHELL -c "exit 128"'
! if ERRORLEVEL 128 goto shell_ok
!
! echo Error:
! echo The SHELL environment variable must be set to the full path of your sh.exe!
! goto end
!
! :shell_ok
! sh -c 'if test ! -d /tmp; then mkdir /tmp; fi'
! cp djgpp.c config.over ..
! cd ..
! echo Running sed...
! sh djgpp/djgppsed.sh
!
! echo Running Configure...
! sh Configure %1 %2 %3 %4 %5 %6 %7 %8 %9
! :end
diff -c 'perl-5.7.1/djgpp/djgpp.c' 'perl-5.7.2/djgpp/djgpp.c'
Index: ./djgpp/djgpp.c
*** ./djgpp/djgpp.c Tue Mar 6 04:04:23 2001
--- ./djgpp/djgpp.c Mon Jul 9 17:09:48 2001
***************
*** 1,3 ****
--- 1,4 ----
+ #define PERLIO_NOT_STDIO 0
#include <libc/stubs.h>
#include <io.h>
#include <errno.h>
***************
*** 27,33 ****
static struct pipe_list *pl = NULL;
FILE *
! popen (const char *cm, const char *md) /* program name, pipe mode */
{
struct pipe_list *l1;
int fd;
--- 28,34 ----
static struct pipe_list *pl = NULL;
FILE *
! djgpp_popen (const char *cm, const char *md) /* program name, pipe mode */
{
struct pipe_list *l1;
int fd;
***************
*** 75,81 ****
}
int
! pclose (FILE *pp)
{
struct pipe_list *l1, **l2; /* list pointers */
int retval=-1; /* function return value */
--- 76,82 ----
}
int
! djgpp_pclose (FILE *pp)
{
struct pipe_list *l1, **l2; /* list pointers */
int retval=-1; /* function return value */
diff -c 'perl-5.7.1/djgpp/djgppsed.sh' 'perl-5.7.2/djgpp/djgppsed.sh'
Index: ./djgpp/djgppsed.sh
*** ./djgpp/djgppsed.sh Tue Mar 6 04:04:24 2001
--- ./djgpp/djgppsed.sh Mon Jul 9 17:09:48 2001
***************
*** 36,44 ****
sed -e $SCPP t/comp/cpp.aux |tr -d '\r' >s; mv -f s t/comp/cpp.aux
sed -e $SARGV -e $SDOTTMP t/io/argv.t >s; mv -f s t/io/argv.t
sed -e $SABC t/io/inplace.t >s; mv -f s t/io/inplace.t
! sed -e $SDBMX t/lib/anydbm.t >s; mv -f s t/lib/anydbm.t
! sed -e $SDBMX -e $SDBHASH t/lib/gdbm.t >s; mv -f s t/lib/gdbm.t
! sed -e $SDBMX -e $SDBHASH t/lib/sdbm.t >s; mv -f s t/lib/sdbm.t
sed -e $SSTAT -e $STMP2 t/op/stat.t >s; mv -f s t/op/stat.t
sed -e $SLIST x2p/Makefile.SH |tr -d '\r' >s; mv -f s x2p/Makefile.SH
sed -e 's=^#define.\([A-Z]\+\)_EXP.*$=#define \1_EXP djgpp_pathexp("\1")=g' config_h.SH >s; mv -f s config_h.SH
--- 36,42 ----
sed -e $SCPP t/comp/cpp.aux |tr -d '\r' >s; mv -f s t/comp/cpp.aux
sed -e $SARGV -e $SDOTTMP t/io/argv.t >s; mv -f s t/io/argv.t
sed -e $SABC t/io/inplace.t >s; mv -f s t/io/inplace.t
! sed -e $SDBMX -e $SDBHASH ext/GDBM_File/gdbm.t >s; mv -f s ext/GDBM_File/gdbm.t
sed -e $SSTAT -e $STMP2 t/op/stat.t >s; mv -f s t/op/stat.t
sed -e $SLIST x2p/Makefile.SH |tr -d '\r' >s; mv -f s x2p/Makefile.SH
sed -e 's=^#define.\([A-Z]\+\)_EXP.*$=#define \1_EXP djgpp_pathexp("\1")=g' config_h.SH >s; mv -f s config_h.SH
diff -c 'perl-5.7.1/djgpp/fixpmain' 'perl-5.7.2/djgpp/fixpmain'
Index: ./djgpp/fixpmain
*** ./djgpp/fixpmain Tue Mar 6 04:04:24 2001
--- ./djgpp/fixpmain Mon Jul 9 17:09:48 2001
***************
*** 20,26 ****
{
$dosname=join ("__",map {lc substr ($_,0,8)} split /\//,$realname);
$realname =~ s!/!__!g;
! $perlmain =~ s/\bboot_$dosname/boot_$realname/gm;
$perlmain =~ s/\b$dosname(::bootstrap)/$realname$1/gm;
}
--- 20,28 ----
{
$dosname=join ("__",map {lc substr ($_,0,8)} split /\//,$realname);
$realname =~ s!/!__!g;
! $perlmain =~ s/\bboot_$dosname\b/boot_$realname/gm;
! $dosname =~ s/__/::/;
! $realname =~ s/__/::/;
$perlmain =~ s/\b$dosname(::bootstrap)/$realname$1/gm;
}
diff -c 'perl-5.7.1/doio.c' 'perl-5.7.2/doio.c'
Index: ./doio.c
*** ./doio.c Thu Apr 5 06:54:55 2001
--- ./doio.c Mon Jul 9 17:09:48 2001
***************
*** 141,152 ****
/* sysopen style args, i.e. integer mode and permissions */
STRLEN ix = 0;
if (num_svs != 0) {
! Perl_croak(aTHX_ "panic:sysopen with multiple args");
}
mode[ix++] = '#'; /* Marker to openn to use numeric "sysopen" */
#if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
! rawmode |= O_LARGEFILE;
#endif
#ifndef O_ACCMODE
--- 141,161 ----
/* sysopen style args, i.e. integer mode and permissions */
STRLEN ix = 0;
if (num_svs != 0) {
! Perl_croak(aTHX_ "panic: sysopen with multiple args");
}
+ if (rawmode & (O_WRONLY|O_RDWR|O_CREAT
+ #ifdef O_APPEND /* Not fully portable. */
+ |O_APPEND
+ #endif
+ #ifdef O_TRUNC /* Not fully portable. */
+ |O_TRUNC
+ #endif
+ ))
+ TAINT_PROPER("sysopen");
mode[ix++] = '#'; /* Marker to openn to use numeric "sysopen" */
#if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
! rawmode |= O_LARGEFILE; /* Transparently largefiley. */
#endif
#ifndef O_ACCMODE
***************
*** 193,199 ****
num_svs = 1;
svp = &namesv;
type = Nullch;
! fp = PerlIO_openn(aTHX_ type,mode, -1, rawmode, rawperm, NULL, num_svs, svp);
}
else {
/* Regular (non-sys) open */
--- 202,208 ----
num_svs = 1;
svp = &namesv;
type = Nullch;
! fp = PerlIO_openn(aTHX_ type, mode, -1, rawmode, rawperm, NULL, num_svs, svp);
}
else {
/* Regular (non-sys) open */
***************
*** 223,229 ****
len = tend-type;
}
IoTYPE(io) = *type;
! if ((*type == IoTYPE_RDWR) && ((!num_svs || tend > type+1 && tend[-1] != IoTYPE_PIPE))) { /* scary */
mode[1] = *type++;
writing = 1;
}
--- 232,240 ----
len = tend-type;
}
IoTYPE(io) = *type;
! if ((*type == IoTYPE_RDWR) && /* scary */
! (*(type+1) == IoTYPE_RDONLY || *(type+1) == IoTYPE_WRONLY) &&
! ((!num_svs || (tend > type+1 && tend[-1] != IoTYPE_PIPE)))) {
mode[1] = *type++;
writing = 1;
}
***************
*** 504,514 ****
if (ckWARN(WARN_IO)) {
if ((IoTYPE(io) == IoTYPE_RDONLY) &&
(fp == PerlIO_stdout() || fp == PerlIO_stderr())) {
! Perl_warner(aTHX_ WARN_IO, "'std%s' opened only for input",
! (fp == PerlIO_stdout()) ? "out" : "err");
}
else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) {
! Perl_warner(aTHX_ WARN_IO, "'stdin' opened only for output");
}
}
--- 515,527 ----
if (ckWARN(WARN_IO)) {
if ((IoTYPE(io) == IoTYPE_RDONLY) &&
(fp == PerlIO_stdout() || fp == PerlIO_stderr())) {
! Perl_warner(aTHX_ WARN_IO,
! "Filehandle STD%s opened only for input",
! (fp == PerlIO_stdout()) ? "OUT" : "ERR");
}
else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) {
! Perl_warner(aTHX_ WARN_IO,
! "Filehandle STDIN opened only for output");
}
}
***************
*** 555,567 ****
if (savefd != fd) {
Pid_t pid;
SV *sv;
! PerlLIO_dup2(fd, savefd);
#ifdef VMS
if (savefd != PerlIO_fileno(PerlIO_stdin())) {
char newname[FILENAME_MAX+1];
! if (fgetname(fp, newname)) {
! if (savefd == PerlIO_fileno(PerlIO_stdout())) Perl_vmssetuserlnm("SYS$OUTPUT", newname);
! if (savefd == PerlIO_fileno(PerlIO_stderr())) Perl_vmssetuserlnm("SYS$ERROR", newname);
}
}
#endif
--- 568,583 ----
if (savefd != fd) {
Pid_t pid;
SV *sv;
! if (PerlLIO_dup2(fd, savefd) < 0) {
! (void)PerlIO_close(fp);
! goto say_false;
! }
#ifdef VMS
if (savefd != PerlIO_fileno(PerlIO_stdin())) {
char newname[FILENAME_MAX+1];
! if (PerlIO_getname(fp, newname)) {
! if (fd == PerlIO_fileno(PerlIO_stdout())) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT", newname);
! if (fd == PerlIO_fileno(PerlIO_stderr())) Perl_vmssetuserlnm(aTHX_ "SYS$ERROR", newname);
}
}
#endif
***************
*** 996,1002 ****
Off_t
Perl_do_tell(pTHX_ GV *gv)
{
! register IO *io;
register PerlIO *fp;
if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
--- 1012,1018 ----
Off_t
Perl_do_tell(pTHX_ GV *gv)
{
! register IO *io = 0;
register PerlIO *fp;
if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
***************
*** 1015,1021 ****
bool
Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
{
! register IO *io;
register PerlIO *fp;
if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
--- 1031,1037 ----
bool
Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
{
! register IO *io = 0;
register PerlIO *fp;
if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
***************
*** 1034,1040 ****
Off_t
Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
{
! register IO *io;
register PerlIO *fp;
if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
--- 1050,1056 ----
Off_t
Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
{
! register IO *io = 0;
register PerlIO *fp;
if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
***************
*** 1317,1323 ****
Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
#else
register char **a;
! char *tmps;
STRLEN n_a;
if (sp > mark) {
--- 1333,1339 ----
Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
#else
register char **a;
! char *tmps = Nullch;
STRLEN n_a;
if (sp > mark) {
***************
*** 1380,1386 ****
{
register char **a;
register char *s;
- char flags[10];
while (*cmd && isSPACE(*cmd))
cmd++;
--- 1396,1401 ----
***************
*** 1388,1415 ****
/* save an extra exec if possible */
#ifdef CSH
! if (strnEQ(cmd,PL_cshname,PL_cshlen) && strnEQ(cmd+PL_cshlen," -c",3)) {
! strcpy(flags,"-c");
! s = cmd+PL_cshlen+3;
! if (*s == 'f') {
! s++;
! strcat(flags,"f");
! }
! if (*s == ' ')
! s++;
! if (*s++ == '\'') {
! char *ncmd = s;
! while (*s)
! s++;
! if (s[-1] == '\n')
! *--s = '\0';
! if (s[-1] == '\'') {
! *--s = '\0';
! PerlProc_execl(PL_cshname,"csh", flags,ncmd,(char*)0);
! *s = '\'';
! return FALSE;
! }
}
}
#endif /* CSH */
--- 1403,1434 ----
/* save an extra exec if possible */
#ifdef CSH
! {
! char flags[10];
! if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
! strnEQ(cmd+PL_cshlen," -c",3)) {
! strcpy(flags,"-c");
! s = cmd+PL_cshlen+3;
! if (*s == 'f') {
! s++;
! strcat(flags,"f");
! }
! if (*s == ' ')
! s++;
! if (*s++ == '\'') {
! char *ncmd = s;
! while (*s)
! s++;
! if (s[-1] == '\n')
! *--s = '\0';
! if (s[-1] == '\'') {
! *--s = '\0';
! PerlProc_execl(PL_cshname,"csh", flags, ncmd, (char*)0);
! *s = '\'';
! return FALSE;
! }
! }
}
}
#endif /* CSH */
***************
*** 1427,1433 ****
goto doshell;
for (s = cmd; *s; s++) {
! if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
if (*s == '\n' && !s[1]) {
*s = '\0';
break;
--- 1446,1453 ----
goto doshell;
for (s = cmd; *s; s++) {
! if (*s != ' ' && !isALPHA(*s) &&
! strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
if (*s == '\n' && !s[1]) {
*s = '\0';
break;
***************
*** 1660,1672 ****
} utbuf;
#endif
Zero(&utbuf, sizeof utbuf, char);
#ifdef BIG_TIME
! utbuf.actime = (Time_t)SvNVx(*++mark); /* time accessed */
! utbuf.modtime = (Time_t)SvNVx(*++mark); /* time modified */
#else
! utbuf.actime = (Time_t)SvIVx(*++mark); /* time accessed */
! utbuf.modtime = (Time_t)SvIVx(*++mark); /* time modified */
#endif
APPLY_TAINT_PROPER();
tot = sp - mark;
--- 1680,1703 ----
} utbuf;
#endif
+ SV* accessed = *++mark;
+ SV* modified = *++mark;
+ void * utbufp = &utbuf;
+
+ /* be like C, and if both times are undefined, let the C
+ library figure out what to do. This usually means
+ "current time" */
+
+ if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
+ utbufp = NULL;
+
Zero(&utbuf, sizeof utbuf, char);
#ifdef BIG_TIME
! utbuf.actime = (Time_t)SvNVx(accessed); /* time accessed */
! utbuf.modtime = (Time_t)SvNVx(modified); /* time modified */
#else
! utbuf.actime = (Time_t)SvIVx(accessed); /* time accessed */
! utbuf.modtime = (Time_t)SvIVx(modified); /* time modified */
#endif
APPLY_TAINT_PROPER();
tot = sp - mark;
***************
*** 1673,1679 ****
while (++mark <= sp) {
char *name = SvPVx(*mark, n_a);
APPLY_TAINT_PROPER();
! if (PerlLIO_utime(name, &utbuf))
tot--;
}
}
--- 1704,1710 ----
while (++mark <= sp) {
char *name = SvPVx(*mark, n_a);
APPLY_TAINT_PROPER();
! if (PerlLIO_utime(name, utbufp))
tot--;
}
}
***************
*** 1998,2010 ****
id = SvIVx(*++mark);
opstr = *++mark;
opbuf = SvPV(opstr, opsize);
! if (opsize < sizeof(struct sembuf)
! || (opsize % sizeof(struct sembuf)) != 0) {
SETERRNO(EINVAL,LIB$_INVARG);
return -1;
}
SETERRNO(0,0);
! return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
#else
Perl_croak(aTHX_ "semop not implemented");
#endif
--- 2029,2070 ----
id = SvIVx(*++mark);
opstr = *++mark;
opbuf = SvPV(opstr, opsize);
! if (opsize < 3 * SHORTSIZE
! || (opsize % (3 * SHORTSIZE))) {
SETERRNO(EINVAL,LIB$_INVARG);
return -1;
}
SETERRNO(0,0);
! /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */
! {
! int nsops = opsize / (3 * sizeof (short));
! int i = nsops;
! short *ops = (short *) opbuf;
! short *o = ops;
! struct sembuf *temps, *t;
! I32 result;
!
! New (0, temps, nsops, struct sembuf);
! t = temps;
! while (i--) {
! t->sem_num = *o++;
! t->sem_op = *o++;
! t->sem_flg = *o++;
! t++;
! }
! result = semop(id, temps, nsops);
! t = temps;
! o = ops;
! i = nsops;
! while (i--) {
! *o++ = t->sem_num;
! *o++ = t->sem_op;
! *o++ = t->sem_flg;
! t++;
! }
! Safefree(temps);
! return result;
! }
#else
Perl_croak(aTHX_ "semop not implemented");
#endif
***************
*** 2096,2102 ****
char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
char vmsspec[NAM$C_MAXRSS+1];
char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
- char tmpfnam[L_tmpnam] = "SYS$SCRATCH:";
$DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
PerlIO *tmpfp;
STRLEN i;
--- 2156,2161 ----
***************
*** 2111,2117 ****
((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
but that's unsupported, so I don't want to do it now and
have it bite someone in the future. */
- strcat(tmpfnam,PerlLIO_tmpnam(NULL));
cp = SvPV(tmpglob,i);
for (; i; i--) {
if (cp[i] == ';') hasver = 1;
--- 2170,2175 ----
***************
*** 2128,2134 ****
break;
}
}
! if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) {
Stat_t st;
if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode))
ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL);
--- 2186,2192 ----
break;
}
}
! if ((tmpfp = PerlIO_tmpfile()) != NULL) {
Stat_t st;
if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode))
ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL);
diff -c 'perl-5.7.1/doop.c' 'perl-5.7.2/doop.c'
Index: ./doop.c
*** ./doop.c Thu Apr 5 06:54:57 2001
--- ./doop.c Mon Jul 9 17:09:48 2001
***************
*** 141,147 ****
I32 grows = PL_op->op_private & OPpTRANS_GROWS;
I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
I32 del = PL_op->op_private & OPpTRANS_DELETE;
! STRLEN len, rlen;
short *tbl;
I32 ch;
--- 141,147 ----
I32 grows = PL_op->op_private & OPpTRANS_GROWS;
I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
I32 del = PL_op->op_private & OPpTRANS_DELETE;
! STRLEN len, rlen = 0;
short *tbl;
I32 ch;
***************
*** 308,314 ****
SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
UV none = svp ? SvUV(*svp) : 0x7fffffff;
UV extra = none + 1;
! UV final;
UV uv;
I32 isutf8;
U8 hibit = 0;
--- 308,314 ----
SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
UV none = svp ? SvUV(*svp) : 0x7fffffff;
UV extra = none + 1;
! UV final = 0;
UV uv;
I32 isutf8;
U8 hibit = 0;
***************
*** 344,350 ****
}
while (s < send) {
! if ((uv = swash_fetch(rv, s)) < none) {
s += UTF8SKIP(s);
matches++;
d = uvuni_to_utf8(d, uv);
--- 344,350 ----
}
while (s < send) {
! if ((uv = swash_fetch(rv, s, TRUE)) < none) {
s += UTF8SKIP(s);
matches++;
d = uvuni_to_utf8(d, uv);
***************
*** 397,403 ****
S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */
{
U8 *s;
! U8 *start, *send;
I32 matches = 0;
STRLEN len;
--- 397,403 ----
S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */
{
U8 *s;
! U8 *start = 0, *send;
I32 matches = 0;
STRLEN len;
***************
*** 423,429 ****
send = s + len;
while (s < send) {
! if ((uv = swash_fetch(rv, s)) < none || uv == extra)
matches++;
s += UTF8SKIP(s);
}
--- 423,429 ----
send = s + len;
while (s < send) {
! if ((uv = swash_fetch(rv, s, TRUE)) < none || uv == extra)
matches++;
s += UTF8SKIP(s);
}
***************
*** 448,454 ****
SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
UV none = svp ? SvUV(*svp) : 0x7fffffff;
UV extra = none + 1;
! UV final;
bool havefinal = FALSE;
UV uv;
STRLEN len;
--- 448,454 ----
SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
UV none = svp ? SvUV(*svp) : 0x7fffffff;
UV extra = none + 1;
! UV final = 0;
bool havefinal = FALSE;
UV uv;
STRLEN len;
***************
*** 491,497 ****
if (squash) {
UV puv = 0xfeedface;
while (s < send) {
! uv = swash_fetch(rv, s);
if (d > dend) {
STRLEN clen = d - dstart;
--- 491,497 ----
if (squash) {
UV puv = 0xfeedface;
while (s < send) {
! uv = swash_fetch(rv, s, TRUE);
if (d > dend) {
STRLEN clen = d - dstart;
***************
*** 546,552 ****
}
else {
while (s < send) {
! uv = swash_fetch(rv, s);
if (d > dend) {
STRLEN clen = d - dstart;
STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
--- 546,552 ----
}
else {
while (s < send) {
! uv = swash_fetch(rv, s, TRUE);
if (d > dend) {
STRLEN clen = d - dstart;
STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
***************
*** 646,654 ****
register I32 items = sp - mark;
register STRLEN len;
STRLEN delimlen;
- register char *delim = SvPV(del, delimlen);
STRLEN tmplen;
mark++;
len = (items > 0 ? (delimlen * (items - 1) ) : 0);
(void)SvUPGRADE(sv, SVt_PV);
--- 646,656 ----
register I32 items = sp - mark;
register STRLEN len;
STRLEN delimlen;
STRLEN tmplen;
+ (void) SvPV(del, delimlen); /* stringify and get the delimlen */
+ /* SvCUR assumes it's SvPOK() and woe betide you if it's not. */
+
mark++;
len = (items > 0 ? (delimlen * (items - 1) ) : 0);
(void)SvUPGRADE(sv, SVt_PV);
***************
*** 667,680 ****
++mark;
}
if (items-- > 0) {
- sv_setpv(sv, "");
if (*mark)
sv_catsv(sv, *mark);
mark++;
}
! else
! sv_setpv(sv,"");
if (delimlen) {
for (; items > 0; items--,mark++) {
sv_catsv(sv,del);
--- 669,684 ----
++mark;
}
+ sv_setpv(sv, "");
+ if (PL_tainting && SvMAGICAL(sv))
+ SvTAINTED_off(sv);
+
if (items-- > 0) {
if (*mark)
sv_catsv(sv, *mark);
mark++;
}
!
if (delimlen) {
for (; items > 0; items--,mark++) {
sv_catsv(sv,del);
***************
*** 989,994 ****
--- 993,999 ----
{
register I32 count;
STRLEN len;
+ STRLEN n_a;
char *s;
if (RsSNARF(PL_rs))
***************
*** 1020,1027 ****
else if (SvREADONLY(sv))
Perl_croak(aTHX_ PL_no_modify);
s = SvPV(sv, len);
- if (len && !SvPOKp(sv))
- s = SvPV_force(sv, len);
if (s && len) {
s += --len;
if (RsPARA(PL_rs)) {
--- 1025,1030 ----
***************
*** 1052,1063 ****
count += rslen;
}
}
! *s = '\0';
SvCUR_set(sv, len);
SvNIOK_off(sv);
}
nope:
- SvSETMAGIC(sv);
return count;
}
--- 1055,1067 ----
count += rslen;
}
}
! s = SvPV_force(sv, n_a);
SvCUR_set(sv, len);
+ *SvEND(sv) = '\0';
SvNIOK_off(sv);
+ SvSETMAGIC(sv);
}
nope:
return count;
}
***************
*** 1080,1086 ****
char *rsave;
bool left_utf = DO_UTF8(left);
bool right_utf = DO_UTF8(right);
! I32 needlen;
if (left_utf && !right_utf)
sv_utf8_upgrade(right);
--- 1084,1090 ----
char *rsave;
bool left_utf = DO_UTF8(left);
bool right_utf = DO_UTF8(right);
! I32 needlen = 0;
if (left_utf && !right_utf)
sv_utf8_upgrade(right);
***************
*** 1291,1297 ****
if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
! sv_magic(TARG, Nullsv, 'k', Nullch, 0);
}
LvTYPE(TARG) = 'k';
if (LvTARG(TARG) != (SV*)keys) {
--- 1295,1301 ----
if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
! sv_magic(TARG, Nullsv, PERL_MAGIC_nkeys, Nullch, 0);
}
LvTYPE(TARG) = 'k';
if (LvTARG(TARG) != (SV*)keys) {
***************
*** 1303,1309 ****
RETURN;
}
! if (! SvTIED_mg((SV*)keys, 'P'))
i = HvKEYS(keys);
else {
i = 0;
--- 1307,1313 ----
RETURN;
}
! if (! SvTIED_mg((SV*)keys, PERL_MAGIC_tied))
i = HvKEYS(keys);
else {
i = 0;
diff -c 'perl-5.7.1/dosish.h' 'perl-5.7.2/dosish.h'
Index: ./dosish.h
*** ./dosish.h Tue Mar 6 04:04:24 2001
--- ./dosish.h Mon Jul 9 17:09:48 2001
***************
*** 25,32 ****
# define PERL_SYS_INIT(c,v) Perl_win32_init(c,v)
# define BIT_BUCKET "nul"
# else
! # define PERL_SYS_INIT(c,v)
! # define BIT_BUCKET "\\dev\\nul" /* "wanna be like, umm, Newlined, or somethin?" */
# endif
#endif /* DJGPP */
--- 25,37 ----
# define PERL_SYS_INIT(c,v) Perl_win32_init(c,v)
# define BIT_BUCKET "nul"
# else
! # ifdef NETWARE
! # define PERL_SYS_INIT(c,v) Perl_nw5_init(c,v)
! # define BIT_BUCKET "nul"
! # else
! # define PERL_SYS_INIT(c,v)
! # define BIT_BUCKET "\\dev\\nul" /* "wanna be like, umm, Newlined, or somethin?" */
! # endif /* NETWARE */
# endif
#endif /* DJGPP */
diff -c 'perl-5.7.1/dump.c' 'perl-5.7.2/dump.c'
Index: ./dump.c
*** ./dump.c Sat Apr 7 21:25:59 2001
--- ./dump.c Thu Jul 12 16:54:38 2001
***************
*** 60,67 ****
dump_sub(gv);
if (GvFORM(gv))
dump_form(gv);
! if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
! (hv = GvHV(gv)) && HvNAME(hv) && hv != PL_defstash)
dump_packsubs(hv); /* nested package */
}
}
--- 60,67 ----
dump_sub(gv);
if (GvFORM(gv))
dump_form(gv);
! if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
! && (hv = GvHV(gv)) && hv != PL_defstash)
dump_packsubs(hv); /* nested package */
}
}
***************
*** 319,327 ****
ch = '?';
else
ch = '/';
! if (pm->op_pmregexp)
Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
! ch, pm->op_pmregexp->precomp, ch,
(pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
else
Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
--- 319,327 ----
ch = '?';
else
ch = '/';
! if (PM_GETRE(pm))
Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
! ch, PM_GETRE(pm)->precomp, ch,
(pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
else
Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
***************
*** 329,335 ****
Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
op_dump(pm->op_pmreplroot);
}
! if (pm->op_pmflags || (pm->op_pmregexp && pm->op_pmregexp->check_substr)) {
SV *tmpsv = newSVpvn("", 0);
if (pm->op_pmdynflags & PMdf_USED)
sv_catpv(tmpsv, ",USED");
--- 329,335 ----
Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
op_dump(pm->op_pmreplroot);
}
! if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
SV *tmpsv = newSVpvn("", 0);
if (pm->op_pmdynflags & PMdf_USED)
sv_catpv(tmpsv, ",USED");
***************
*** 337,347 ****
sv_catpv(tmpsv, ",TAINTED");
if (pm->op_pmflags & PMf_ONCE)
sv_catpv(tmpsv, ",ONCE");
! if (pm->op_pmregexp && pm->op_pmregexp->check_substr
! && !(pm->op_pmregexp->reganch & ROPT_NOSCAN))
sv_catpv(tmpsv, ",SCANFIRST");
! if (pm->op_pmregexp && pm->op_pmregexp->check_substr
! && pm->op_pmregexp->reganch & ROPT_CHECK_ALL)
sv_catpv(tmpsv, ",ALL");
if (pm->op_pmflags & PMf_SKIPWHITE)
sv_catpv(tmpsv, ",SKIPWHITE");
--- 337,347 ----
sv_catpv(tmpsv, ",TAINTED");
if (pm->op_pmflags & PMf_ONCE)
sv_catpv(tmpsv, ",ONCE");
! if (PM_GETRE(pm) && PM_GETRE(pm)->check_substr
! && !(PM_GETRE(pm)->reganch & ROPT_NOSCAN))
sv_catpv(tmpsv, ",SCANFIRST");
! if (PM_GETRE(pm) && PM_GETRE(pm)->check_substr
! && PM_GETRE(pm)->reganch & ROPT_CHECK_ALL)
sv_catpv(tmpsv, ",ALL");
if (pm->op_pmflags & PMf_SKIPWHITE)
sv_catpv(tmpsv, ",SKIPWHITE");
***************
*** 392,398 ****
--- 392,411 ----
PerlIO_printf(file, "DONE\n");
if (o->op_targ) {
if (o->op_type == OP_NULL)
+ {
Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
+ if (o->op_targ == OP_NEXTSTATE)
+ {
+ if (CopLINE(cCOPo))
+ Perl_dump_indent(aTHX_ level, file, "LINE = %d\n",CopLINE(cCOPo));
+ if (CopSTASHPV(cCOPo))
+ Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
+ CopSTASHPV(cCOPo));
+ if (cCOPo->cop_label)
+ Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
+ cCOPo->cop_label);
+ }
+ }
else
Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
}
***************
*** 436,442 ****
if (o->op_private & OPpTARGET_MY)
sv_catpv(tmpsv, ",TARGET_MY");
}
! if (o->op_type == OP_AASSIGN) {
if (o->op_private & OPpASSIGN_COMMON)
sv_catpv(tmpsv, ",COMMON");
if (o->op_private & OPpASSIGN_HASH)
--- 449,462 ----
if (o->op_private & OPpTARGET_MY)
sv_catpv(tmpsv, ",TARGET_MY");
}
! else if (o->op_type == OP_LEAVESUB ||
! o->op_type == OP_LEAVE ||
! o->op_type == OP_LEAVESUBLV ||
! o->op_type == OP_LEAVEWRITE) {
! if (o->op_private & OPpREFCOUNTED)
! sv_catpv(tmpsv, ",REFCOUNTED");
! }
! else if (o->op_type == OP_AASSIGN) {
if (o->op_private & OPpASSIGN_COMMON)
sv_catpv(tmpsv, ",COMMON");
if (o->op_private & OPpASSIGN_HASH)
***************
*** 453,458 ****
--- 473,482 ----
sv_catpv(tmpsv, ",DELETE");
if (o->op_private & OPpTRANS_COMPLEMENT)
sv_catpv(tmpsv, ",COMPLEMENT");
+ if (o->op_private & OPpTRANS_IDENTICAL)
+ sv_catpv(tmpsv, ",IDENTICAL");
+ if (o->op_private & OPpTRANS_GROWS)
+ sv_catpv(tmpsv, ",GROWS");
}
else if (o->op_type == OP_REPEAT) {
if (o->op_private & OPpREPEAT_DOLIST)
***************
*** 474,481 ****
sv_catpv(tmpsv, ",DB");
if (o->op_private & OPpENTERSUB_HASTARG)
sv_catpv(tmpsv, ",HASTARG");
}
! else
switch (o->op_private & OPpDEREF) {
case OPpDEREF_SV:
sv_catpv(tmpsv, ",SV");
--- 498,509 ----
sv_catpv(tmpsv, ",DB");
if (o->op_private & OPpENTERSUB_HASTARG)
sv_catpv(tmpsv, ",HASTARG");
+ if (o->op_private & OPpENTERSUB_NOPAREN)
+ sv_catpv(tmpsv, ",NOPAREN");
+ if (o->op_private & OPpENTERSUB_INARGS)
+ sv_catpv(tmpsv, ",INARGS");
}
! else {
switch (o->op_private & OPpDEREF) {
case OPpDEREF_SV:
sv_catpv(tmpsv, ",SV");
***************
*** 487,492 ****
--- 515,523 ----
sv_catpv(tmpsv, ",HV");
break;
}
+ if (o->op_private & OPpMAYBE_LVSUB)
+ sv_catpv(tmpsv, ",MAYBE_LVSUB");
+ }
if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
if (o->op_private & OPpLVAL_DEFER)
sv_catpv(tmpsv, ",LVAL_DEFER");
***************
*** 503,508 ****
--- 534,545 ----
sv_catpv(tmpsv, ",BARE");
if (o->op_private & OPpCONST_STRICT)
sv_catpv(tmpsv, ",STRICT");
+ if (o->op_private & OPpCONST_ARYBASE)
+ sv_catpv(tmpsv, ",ARYBASE");
+ if (o->op_private & OPpCONST_WARNING)
+ sv_catpv(tmpsv, ",WARNING");
+ if (o->op_private & OPpCONST_ENTERED)
+ sv_catpv(tmpsv, ",ENTERED");
}
else if (o->op_type == OP_FLIP) {
if (o->op_private & OPpFLIP_LINENUM)
***************
*** 515,520 ****
--- 552,599 ----
if (o->op_private & OPpLVAL_INTRO)
sv_catpv(tmpsv, ",INTRO");
}
+ else if (o->op_type == OP_GV) {
+ if (o->op_private & OPpEARLY_CV)
+ sv_catpv(tmpsv, ",EARLY_CV");
+ }
+ else if (o->op_type == OP_LIST) {
+ if (o->op_private & OPpLIST_GUESSED)
+ sv_catpv(tmpsv, ",GUESSED");
+ }
+ else if (o->op_type == OP_DELETE) {
+ if (o->op_private & OPpSLICE)
+ sv_catpv(tmpsv, ",SLICE");
+ }
+ else if (o->op_type == OP_EXISTS) {
+ if (o->op_private & OPpEXISTS_SUB)
+ sv_catpv(tmpsv, ",EXISTS_SUB");
+ }
+ else if (o->op_type == OP_SORT) {
+ if (o->op_private & OPpSORT_NUMERIC)
+ sv_catpv(tmpsv, ",NUMERIC");
+ if (o->op_private & OPpSORT_INTEGER)
+ sv_catpv(tmpsv, ",INTEGER");
+ if (o->op_private & OPpSORT_REVERSE)
+ sv_catpv(tmpsv, ",REVERSE");
+ }
+ else if (o->op_type == OP_THREADSV) {
+ if (o->op_private & OPpDONE_SVREF)
+ sv_catpv(tmpsv, ",SVREF");
+ }
+ else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
+ if (o->op_private & OPpOPEN_IN_RAW)
+ sv_catpv(tmpsv, ",IN_RAW");
+ if (o->op_private & OPpOPEN_IN_CRLF)
+ sv_catpv(tmpsv, ",IN_CRLF");
+ if (o->op_private & OPpOPEN_OUT_RAW)
+ sv_catpv(tmpsv, ",OUT_RAW");
+ if (o->op_private & OPpOPEN_OUT_CRLF)
+ sv_catpv(tmpsv, ",OUT_CRLF");
+ }
+ else if (o->op_type == OP_EXIT) {
+ if (o->op_private & OPpEXIT_VMSISH)
+ sv_catpv(tmpsv, ",EXIST_VMSISH");
+ }
if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
sv_catpv(tmpsv, ",INTRO");
if (SvCUR(tmpsv))
***************
*** 640,645 ****
--- 719,768 ----
Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
}
+
+ /* map magic types to the symbolic name
+ * (with the PERL_MAGIC_ prefixed stripped)
+ */
+
+ static struct { char type; char *name; } magic_names[] = {
+ { PERL_MAGIC_sv, "sv(\\0)" },
+ { PERL_MAGIC_arylen, "arylen(#)" },
+ { PERL_MAGIC_glob, "glob(*)" },
+ { PERL_MAGIC_pos, "pos(.)" },
+ { PERL_MAGIC_backref, "backref(<)" },
+ { PERL_MAGIC_overload, "overload(A)" },
+ { PERL_MAGIC_bm, "bm(B)" },
+ { PERL_MAGIC_regdata, "regdata(D)" },
+ { PERL_MAGIC_env, "env(E)" },
+ { PERL_MAGIC_isa, "isa(I)" },
+ { PERL_MAGIC_dbfile, "dbfile(L)" },
+ { PERL_MAGIC_tied, "tied(P)" },
+ { PERL_MAGIC_sig, "sig(S)" },
+ { PERL_MAGIC_uvar, "uvar(U)" },
+ { PERL_MAGIC_overload_elem, "overload_elem(a)" },
+ { PERL_MAGIC_overload_table, "overload_table(c)" },
+ { PERL_MAGIC_regdatum, "regdatum(d)" },
+ { PERL_MAGIC_envelem, "envelem(e)" },
+ { PERL_MAGIC_fm, "fm(f)" },
+ { PERL_MAGIC_regex_global, "regex_global(g)" },
+ { PERL_MAGIC_isaelem, "isaelem(i)" },
+ { PERL_MAGIC_nkeys, "nkeys(k)" },
+ { PERL_MAGIC_dbline, "dbline(l)" },
+ { PERL_MAGIC_mutex, "mutex(m)" },
+ { PERL_MAGIC_collxfrm, "collxfrm(o)" },
+ { PERL_MAGIC_tiedelem, "tiedelem(p)" },
+ { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
+ { PERL_MAGIC_qr, "qr(r)" },
+ { PERL_MAGIC_sigelem, "sigelem(s)" },
+ { PERL_MAGIC_taint, "taint(t)" },
+ { PERL_MAGIC_vec, "vec(v)" },
+ { PERL_MAGIC_substr, "substr(x)" },
+ { PERL_MAGIC_defelem, "defelem(y)" },
+ { PERL_MAGIC_ext, "ext(~)" },
+ /* this null string terminates the list */
+ { 0, 0 },
+ };
+
void
Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
{
***************
*** 687,696 ****
if (mg->mg_private)
Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
! if (isPRINT(mg->mg_type))
! Perl_dump_indent(aTHX_ level, file, " MG_TYPE = '%c'\n", mg->mg_type);
! else
! Perl_dump_indent(aTHX_ level, file, " MG_TYPE = '\\%o'\n", mg->mg_type);
if (mg->mg_flags) {
Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
--- 810,831 ----
if (mg->mg_private)
Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
! {
! int n;
! char *name = 0;
! for (n=0; magic_names[n].name; n++) {
! if (mg->mg_type == magic_names[n].type) {
! name = magic_names[n].name;
! break;
! }
! }
! if (name)
! Perl_dump_indent(aTHX_ level, file,
! " MG_TYPE = PERL_MAGIC_%s\n", name);
! else
! Perl_dump_indent(aTHX_ level, file,
! " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
! }
if (mg->mg_flags) {
Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
***************
*** 761,767 ****
Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
if (sv && GvNAME(sv)) {
PerlIO_printf(file, "\t\"");
! if (GvSTASH(sv) && HvNAME(GvSTASH(sv)))
PerlIO_printf(file, "%s\" :: \"", HvNAME(GvSTASH(sv)));
PerlIO_printf(file, "%s\"\n", GvNAME(sv));
}
--- 896,902 ----
Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
if (sv && GvNAME(sv)) {
PerlIO_printf(file, "\t\"");
! if (GvSTASH(sv))
PerlIO_printf(file, "%s\" :: \"", HvNAME(GvSTASH(sv)));
PerlIO_printf(file, "%s\"\n", GvNAME(sv));
}
***************
*** 838,845 ****
--- 973,982 ----
case SVt_PVGV:
if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
+ if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
+ if (flags & SVpad_OUR) sv_catpv(d, "OUR,");
if (GvIMPORTED(sv)) {
sv_catpv(d, "IMPORT");
if (GvIMPORTED(sv) == GVf_IMPORTED)
***************
*** 853,859 ****
sv_catpv(d, " ),");
}
}
! /* FALL THROGH */
default:
if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
if (SvIsUV(sv)) sv_catpv(d, "IsUV,");
--- 990,996 ----
sv_catpv(d, " ),");
}
}
! /* FALL THROUGH */
default:
if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
if (SvIsUV(sv)) sv_catpv(d, "IsUV,");
***************
*** 862,867 ****
--- 999,1008 ----
case SVt_PVBM:
if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
if (SvVALID(sv)) sv_catpv(d, "VALID,");
+ break;
+ case SVt_PVMG:
+ if (flags & SVpad_TYPED)
+ sv_catpv(d, "TYPED,");
break;
}
diff -c 'perl-5.7.1/emacs/cperl-mode.el' 'perl-5.7.2/emacs/cperl-mode.el'
Index: ./emacs/cperl-mode.el
Prereq: 4.32
*** ./emacs/cperl-mode.el Tue Mar 6 04:04:25 2001
--- ./emacs/cperl-mode.el Mon Jul 9 17:09:49 2001
***************
*** 1610,1616 ****
ftp://ftp.math.ohio-state.edu/pub/users/ilya/cperl-mode/patches
\(this upgrades syntax-parsing abilities of RMS Emaxen v19.34 and
v20.2 up to the level of RMS Emacs v20.3 - a must for a good Perl
! mode.) You will not get much from XEmacs, it's syntax abilities are
too primitive.
Get support packages choose-color.el (or font-lock-extra.el before
--- 1610,1616 ----
ftp://ftp.math.ohio-state.edu/pub/users/ilya/cperl-mode/patches
\(this upgrades syntax-parsing abilities of RMS Emaxen v19.34 and
v20.2 up to the level of RMS Emacs v20.3 - a must for a good Perl
! mode.) You will not get much from XEmacs; its syntax abilities are
too primitive.
Get support packages choose-color.el (or font-lock-extra.el before
diff -c 'perl-5.7.1/emacs/e2ctags.pl' 'perl-5.7.2/emacs/e2ctags.pl'
Index: ./emacs/e2ctags.pl
*** ./emacs/e2ctags.pl Tue Mar 6 04:04:25 2001
--- ./emacs/e2ctags.pl Mon Jul 9 17:09:49 2001
***************
*** 16,21 ****
--- 16,22 ----
my $filename;
my ($tag,$line_no,$line);
my %tags = ();
+ my %filetags = ();
my %files = ();
my @lines = ();
***************
*** 34,54 ****
next if /struct/;
if (/\x01/) {
($tag,$line_no) = /\x7F(\w+)\x01(\d+)/;
- next unless $tag;
- ##Take only the first entry per tag
- next if defined($tags{$tag});
- $tags{$tag}{FILE} = $filename;
- $tags{$tag}{LINE_NO} = $line_no;
}
else {
tr/(//d;
($tag,$line_no) = /(\w+)\s*\x7F(\d+),/;
- next unless $tag;
- ##Take only the first entry per tag
- next if defined($tags{$tag});
- $tags{$tag}{FILE} = $filename;
- $tags{$tag}{LINE_NO} = $line_no;
}
}
foreach $filename (keys %files) {
--- 35,51 ----
next if /struct/;
if (/\x01/) {
($tag,$line_no) = /\x7F(\w+)\x01(\d+)/;
}
else {
tr/(//d;
($tag,$line_no) = /(\w+)\s*\x7F(\d+),/;
}
+ next unless $tag;
+ ##Take only the first entry per tag
+ next if defined($tags{$tag});
+ $tags{$tag}{FILE} = $filename;
+ $tags{$tag}{LINE_NO} = $line_no;
+ push @{$filetags{$filename}}, $tag;
}
foreach $filename (keys %files) {
***************
*** 56,63 ****
@lines = <FILE>;
close FILE;
chomp @lines;
! foreach $tag ( keys %tags ) {
! next unless $filename eq $tags{$tag}{FILE};
$line = $lines[$tags{$tag}{LINE_NO}-1];
if (length($line) >= 50) {
$line = substr($line,0,50);
--- 53,59 ----
@lines = <FILE>;
close FILE;
chomp @lines;
! foreach $tag ( @{$filetags{$filename}} ) {
$line = $lines[$tags{$tag}{LINE_NO}-1];
if (length($line) >= 50) {
$line = substr($line,0,50);
diff -c 'perl-5.7.1/embed.h' 'perl-5.7.2/embed.h'
Index: ./embed.h
*** ./embed.h Fri Apr 6 16:42:03 2001
--- ./embed.h Thu Jul 12 21:34:39 2001
***************
*** 101,106 ****
--- 101,107 ----
#define block_gimme Perl_block_gimme
#define block_start Perl_block_start
#define boot_core_UNIVERSAL Perl_boot_core_UNIVERSAL
+ #define boot_core_PerlIO Perl_boot_core_PerlIO
#define call_list Perl_call_list
#define cando Perl_cando
#define cast_ulong Perl_cast_ulong
***************
*** 271,276 ****
--- 272,278 ----
#define ingroup Perl_ingroup
#define init_debugger Perl_init_debugger
#define init_stacks Perl_init_stacks
+ #define init_tm Perl_init_tm
#define intro_my Perl_intro_my
#define instr Perl_instr
#define io_close Perl_io_close
***************
*** 333,338 ****
--- 335,342 ----
#define leave_scope Perl_leave_scope
#define lex_end Perl_lex_end
#define lex_start Perl_lex_start
+ #define op_null Perl_op_null
+ #define op_clear Perl_op_clear
#define linklist Perl_linklist
#define list Perl_list
#define listkids Perl_listkids
***************
*** 340,345 ****
--- 344,351 ----
#define vload_module Perl_vload_module
#define localize Perl_localize
#define looks_like_number Perl_looks_like_number
+ #define grok_number Perl_grok_number
+ #define grok_numeric_radix Perl_grok_numeric_radix
#define magic_clearenv Perl_magic_clearenv
#define magic_clear_all_env Perl_magic_clear_all_env
#define magic_clearpack Perl_magic_clearpack
***************
*** 409,420 ****
#define mg_magical Perl_mg_magical
#define mg_set Perl_mg_set
#define mg_size Perl_mg_size
#define mod Perl_mod
#define mode_from_discipline Perl_mode_from_discipline
#define moreswitches Perl_moreswitches
#define my Perl_my
#define my_atof Perl_my_atof
! #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
#define my_bcopy Perl_my_bcopy
#endif
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
--- 415,427 ----
#define mg_magical Perl_mg_magical
#define mg_set Perl_mg_set
#define mg_size Perl_mg_size
+ #define mini_mktime Perl_mini_mktime
#define mod Perl_mod
#define mode_from_discipline Perl_mode_from_discipline
#define moreswitches Perl_moreswitches
#define my Perl_my
#define my_atof Perl_my_atof
! #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
#define my_bcopy Perl_my_bcopy
#endif
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
***************
*** 437,442 ****
--- 444,450 ----
#endif
#define my_setenv Perl_my_setenv
#define my_stat Perl_my_stat
+ #define my_strftime Perl_my_strftime
#if defined(MYSWAP)
#define my_swap Perl_my_swap
#define my_htonl Perl_my_htonl
***************
*** 637,643 ****
#define sv_2iv Perl_sv_2iv
#define sv_2mortal Perl_sv_2mortal
#define sv_2nv Perl_sv_2nv
- #define sv_2pv Perl_sv_2pv
#define sv_2pvutf8 Perl_sv_2pvutf8
#define sv_2pvbyte Perl_sv_2pvbyte
#define sv_2uv Perl_sv_2uv
--- 645,650 ----
***************
*** 654,661 ****
#define sv_catpvf Perl_sv_catpvf
#define sv_vcatpvf Perl_sv_vcatpvf
#define sv_catpv Perl_sv_catpv
- #define sv_catpvn Perl_sv_catpvn
- #define sv_catsv Perl_sv_catsv
#define sv_chop Perl_sv_chop
#define sv_clean_all Perl_sv_clean_all
#define sv_clean_objs Perl_sv_clean_objs
--- 661,666 ----
***************
*** 666,671 ****
--- 671,677 ----
#define sv_collxfrm Perl_sv_collxfrm
#endif
#define sv_compile_2op Perl_sv_compile_2op
+ #define getcwd_sv Perl_getcwd_sv
#define sv_dec Perl_sv_dec
#define sv_dump Perl_sv_dump
#define sv_derived_from Perl_sv_derived_from
***************
*** 687,693 ****
#define sv_peek Perl_sv_peek
#define sv_pos_u2b Perl_sv_pos_u2b
#define sv_pos_b2u Perl_sv_pos_b2u
- #define sv_pvn_force Perl_sv_pvn_force
#define sv_pvutf8n_force Perl_sv_pvutf8n_force
#define sv_pvbyten_force Perl_sv_pvbyten_force
#define sv_reftype Perl_sv_reftype
--- 693,698 ----
***************
*** 707,713 ****
#define sv_setref_pvn Perl_sv_setref_pvn
#define sv_setpv Perl_sv_setpv
#define sv_setpvn Perl_sv_setpvn
- #define sv_setsv Perl_sv_setsv
#define sv_taint Perl_sv_taint
#define sv_tainted Perl_sv_tainted
#define sv_unmagic Perl_sv_unmagic
--- 712,717 ----
***************
*** 827,833 ****
#define sv_pv Perl_sv_pv
#define sv_pvutf8 Perl_sv_pvutf8
#define sv_pvbyte Perl_sv_pvbyte
- #define sv_utf8_upgrade Perl_sv_utf8_upgrade
#define sv_utf8_downgrade Perl_sv_utf8_downgrade
#define sv_utf8_encode Perl_sv_utf8_encode
#define sv_utf8_decode Perl_sv_utf8_decode
--- 831,836 ----
***************
*** 910,917 ****
#define scalarboolean S_scalarboolean
#define too_few_arguments S_too_few_arguments
#define too_many_arguments S_too_many_arguments
- #define op_clear S_op_clear
- #define null S_null
#define pad_addlex S_pad_addlex
#define pad_findlex S_pad_findlex
#define newDEFSVOP S_newDEFSVOP
--- 913,918 ----
***************
*** 965,973 ****
# endif
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
- #define doencodes S_doencodes
#define refto S_refto
#define seed S_seed
#define mul128 S_mul128
#define is_an_int S_is_an_int
#define div128 S_div128
--- 966,976 ----
# endif
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
#define refto S_refto
#define seed S_seed
+ #endif
+ #if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
+ #define doencodes S_doencodes
#define mul128 S_mul128
#define is_an_int S_is_an_int
#define div128 S_div128
***************
*** 1018,1025 ****
--- 1021,1030 ----
#define regtail S_regtail
#define regwhite S_regwhite
#define nextchar S_nextchar
+ # ifdef DEBUGGING
#define dumpuntil S_dumpuntil
#define put_byte S_put_byte
+ # endif
#define scan_commit S_scan_commit
#define cl_anything S_cl_anything
#define cl_is_anything S_cl_is_anything
***************
*** 1050,1056 ****
--- 1055,1064 ----
#define find_byclass S_find_byclass
#endif
#if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
+ # ifdef DEBUGGING
+ #define deb_curcv S_deb_curcv
#define debprof S_debprof
+ # endif
#endif
#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
#define save_scalar_at S_save_scalar_at
***************
*** 1100,1110 ****
#define visit S_visit
#define sv_add_backref S_sv_add_backref
#define sv_del_backref S_sv_del_backref
! # if defined(DEBUGGING)
#define del_sv S_del_sv
# endif
# if !defined(NV_PRESERVES_UV)
- #define sv_2inuv_non_preserve S_sv_2inuv_non_preserve
#define sv_2iuv_non_preserve S_sv_2iuv_non_preserve
# endif
#define expect_number S_expect_number
--- 1108,1117 ----
#define visit S_visit
#define sv_add_backref S_sv_add_backref
#define sv_del_backref S_sv_del_backref
! # ifdef DEBUGGING
#define del_sv S_del_sv
# endif
# if !defined(NV_PRESERVES_UV)
#define sv_2iuv_non_preserve S_sv_2iuv_non_preserve
# endif
#define expect_number S_expect_number
***************
*** 1118,1123 ****
--- 1125,1131 ----
#define force_version S_force_version
#define force_word S_force_word
#define tokeq S_tokeq
+ #define pending_ident S_pending_ident
#define scan_const S_scan_const
#define scan_formline S_scan_formline
#define scan_heredoc S_scan_heredoc
***************
*** 1145,1151 ****
--- 1153,1161 ----
#define filter_gets S_filter_gets
#define find_in_my_stash S_find_in_my_stash
#define new_constant S_new_constant
+ # if defined(DEBUGGING)
#define tokereport S_tokereport
+ # endif
#define ao S_ao
#define depcom S_depcom
#define incl_perldb S_incl_perldb
***************
*** 1163,1170 ****
#if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT)
#define isa_lookup S_isa_lookup
#endif
! #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
#define stdize_locale S_stdize_locale
#define mess_alloc S_mess_alloc
# if defined(LEAKTEST)
#define xstat S_xstat
--- 1173,1183 ----
#if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT)
#define isa_lookup S_isa_lookup
#endif
! #if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT)
#define stdize_locale S_stdize_locale
+ #endif
+ #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
+ #define closest_cop S_closest_cop
#define mess_alloc S_mess_alloc
# if defined(LEAKTEST)
#define xstat S_xstat
***************
*** 1172,1177 ****
--- 1185,1197 ----
#endif
#if defined(PERL_OBJECT)
#endif
+ #define sv_setsv_flags Perl_sv_setsv_flags
+ #define sv_catpvn_flags Perl_sv_catpvn_flags
+ #define sv_catsv_flags Perl_sv_catsv_flags
+ #define sv_utf8_upgrade_flags Perl_sv_utf8_upgrade_flags
+ #define sv_pvn_force_flags Perl_sv_pvn_force_flags
+ #define sv_2pv_flags Perl_sv_2pv_flags
+ #define my_atof2 Perl_my_atof2
#define ck_anoncode Perl_ck_anoncode
#define ck_bitop Perl_ck_bitop
#define ck_concat Perl_ck_concat
***************
*** 1184,1190 ****
#define ck_exit Perl_ck_exit
#define ck_ftst Perl_ck_ftst
#define ck_fun Perl_ck_fun
- #define ck_fun_locale Perl_ck_fun_locale
#define ck_glob Perl_ck_glob
#define ck_grep Perl_ck_grep
#define ck_index Perl_ck_index
--- 1204,1209 ----
***************
*** 1202,1208 ****
#define ck_rfun Perl_ck_rfun
#define ck_rvconst Perl_ck_rvconst
#define ck_sassign Perl_ck_sassign
- #define ck_scmp Perl_ck_scmp
#define ck_select Perl_ck_select
#define ck_shift Perl_ck_shift
#define ck_sort Perl_ck_sort
--- 1221,1226 ----
***************
*** 1615,1620 ****
--- 1633,1639 ----
#define block_gimme() Perl_block_gimme(aTHX)
#define block_start(a) Perl_block_start(aTHX_ a)
#define boot_core_UNIVERSAL() Perl_boot_core_UNIVERSAL(aTHX)
+ #define boot_core_PerlIO() Perl_boot_core_PerlIO(aTHX)
#define call_list(a,b) Perl_call_list(aTHX_ a,b)
#define cando(a,b,c) Perl_cando(aTHX_ a,b,c)
#define cast_ulong(a) Perl_cast_ulong(aTHX_ a)
***************
*** 1766,1771 ****
--- 1785,1791 ----
#define ingroup(a,b) Perl_ingroup(aTHX_ a,b)
#define init_debugger() Perl_init_debugger(aTHX)
#define init_stacks() Perl_init_stacks(aTHX)
+ #define init_tm(a) Perl_init_tm(aTHX_ a)
#define intro_my() Perl_intro_my(aTHX)
#define instr(a,b) Perl_instr(aTHX_ a,b)
#define io_close(a,b) Perl_io_close(aTHX_ a,b)
***************
*** 1828,1833 ****
--- 1848,1855 ----
#define leave_scope(a) Perl_leave_scope(aTHX_ a)
#define lex_end() Perl_lex_end(aTHX)
#define lex_start(a) Perl_lex_start(aTHX_ a)
+ #define op_null(a) Perl_op_null(aTHX_ a)
+ #define op_clear(a) Perl_op_clear(aTHX_ a)
#define linklist(a) Perl_linklist(aTHX_ a)
#define list(a) Perl_list(aTHX_ a)
#define listkids(a) Perl_listkids(aTHX_ a)
***************
*** 1834,1839 ****
--- 1856,1863 ----
#define vload_module(a,b,c,d) Perl_vload_module(aTHX_ a,b,c,d)
#define localize(a,b) Perl_localize(aTHX_ a,b)
#define looks_like_number(a) Perl_looks_like_number(aTHX_ a)
+ #define grok_number(a,b,c) Perl_grok_number(aTHX_ a,b,c)
+ #define grok_numeric_radix(a,b) Perl_grok_numeric_radix(aTHX_ a,b)
#define magic_clearenv(a,b) Perl_magic_clearenv(aTHX_ a,b)
#define magic_clear_all_env(a,b) Perl_magic_clear_all_env(aTHX_ a,b)
#define magic_clearpack(a,b) Perl_magic_clearpack(aTHX_ a,b)
***************
*** 1902,1913 ****
#define mg_magical(a) Perl_mg_magical(aTHX_ a)
#define mg_set(a) Perl_mg_set(aTHX_ a)
#define mg_size(a) Perl_mg_size(aTHX_ a)
#define mod(a,b) Perl_mod(aTHX_ a,b)
#define mode_from_discipline(a) Perl_mode_from_discipline(aTHX_ a)
#define moreswitches(a) Perl_moreswitches(aTHX_ a)
#define my(a) Perl_my(aTHX_ a)
#define my_atof(a) Perl_my_atof(aTHX_ a)
! #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
#define my_bcopy Perl_my_bcopy
#endif
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
--- 1926,1938 ----
#define mg_magical(a) Perl_mg_magical(aTHX_ a)
#define mg_set(a) Perl_mg_set(aTHX_ a)
#define mg_size(a) Perl_mg_size(aTHX_ a)
+ #define mini_mktime(a) Perl_mini_mktime(aTHX_ a)
#define mod(a,b) Perl_mod(aTHX_ a,b)
#define mode_from_discipline(a) Perl_mode_from_discipline(aTHX_ a)
#define moreswitches(a) Perl_moreswitches(aTHX_ a)
#define my(a) Perl_my(aTHX_ a)
#define my_atof(a) Perl_my_atof(aTHX_ a)
! #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
#define my_bcopy Perl_my_bcopy
#endif
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
***************
*** 1930,1935 ****
--- 1955,1961 ----
#endif
#define my_setenv(a,b) Perl_my_setenv(aTHX_ a,b)
#define my_stat() Perl_my_stat(aTHX)
+ #define my_strftime(a,b,c,d,e,f,g,h,i,j) Perl_my_strftime(aTHX_ a,b,c,d,e,f,g,h,i,j)
#if defined(MYSWAP)
#define my_swap(a) Perl_my_swap(aTHX_ a)
#define my_htonl(a) Perl_my_htonl(aTHX_ a)
***************
*** 2129,2135 ****
#define sv_2iv(a) Perl_sv_2iv(aTHX_ a)
#define sv_2mortal(a) Perl_sv_2mortal(aTHX_ a)
#define sv_2nv(a) Perl_sv_2nv(aTHX_ a)
- #define sv_2pv(a,b) Perl_sv_2pv(aTHX_ a,b)
#define sv_2pvutf8(a,b) Perl_sv_2pvutf8(aTHX_ a,b)
#define sv_2pvbyte(a,b) Perl_sv_2pvbyte(aTHX_ a,b)
#define sv_2uv(a) Perl_sv_2uv(aTHX_ a)
--- 2155,2160 ----
***************
*** 2145,2152 ****
#define sv_bless(a,b) Perl_sv_bless(aTHX_ a,b)
#define sv_vcatpvf(a,b,c) Perl_sv_vcatpvf(aTHX_ a,b,c)
#define sv_catpv(a,b) Perl_sv_catpv(aTHX_ a,b)
- #define sv_catpvn(a,b,c) Perl_sv_catpvn(aTHX_ a,b,c)
- #define sv_catsv(a,b) Perl_sv_catsv(aTHX_ a,b)
#define sv_chop(a,b) Perl_sv_chop(aTHX_ a,b)
#define sv_clean_all() Perl_sv_clean_all(aTHX)
#define sv_clean_objs() Perl_sv_clean_objs(aTHX)
--- 2170,2175 ----
***************
*** 2157,2162 ****
--- 2180,2186 ----
#define sv_collxfrm(a,b) Perl_sv_collxfrm(aTHX_ a,b)
#endif
#define sv_compile_2op(a,b,c,d) Perl_sv_compile_2op(aTHX_ a,b,c,d)
+ #define getcwd_sv(a) Perl_getcwd_sv(aTHX_ a)
#define sv_dec(a) Perl_sv_dec(aTHX_ a)
#define sv_dump(a) Perl_sv_dump(aTHX_ a)
#define sv_derived_from(a,b) Perl_sv_derived_from(aTHX_ a,b)
***************
*** 2178,2184 ****
#define sv_peek(a) Perl_sv_peek(aTHX_ a)
#define sv_pos_u2b(a,b,c) Perl_sv_pos_u2b(aTHX_ a,b,c)
#define sv_pos_b2u(a,b) Perl_sv_pos_b2u(aTHX_ a,b)
- #define sv_pvn_force(a,b) Perl_sv_pvn_force(aTHX_ a,b)
#define sv_pvutf8n_force(a,b) Perl_sv_pvutf8n_force(aTHX_ a,b)
#define sv_pvbyten_force(a,b) Perl_sv_pvbyten_force(aTHX_ a,b)
#define sv_reftype(a,b) Perl_sv_reftype(aTHX_ a,b)
--- 2202,2207 ----
***************
*** 2197,2203 ****
#define sv_setref_pvn(a,b,c,d) Perl_sv_setref_pvn(aTHX_ a,b,c,d)
#define sv_setpv(a,b) Perl_sv_setpv(aTHX_ a,b)
#define sv_setpvn(a,b,c) Perl_sv_setpvn(aTHX_ a,b,c)
- #define sv_setsv(a,b) Perl_sv_setsv(aTHX_ a,b)
#define sv_taint(a) Perl_sv_taint(aTHX_ a)
#define sv_tainted(a) Perl_sv_tainted(aTHX_ a)
#define sv_unmagic(a,b) Perl_sv_unmagic(aTHX_ a,b)
--- 2220,2225 ----
***************
*** 2210,2216 ****
#define sv_vsetpvfn(a,b,c,d,e,f,g) Perl_sv_vsetpvfn(aTHX_ a,b,c,d,e,f,g)
#define str_to_version(a) Perl_str_to_version(aTHX_ a)
#define swash_init(a,b,c,d,e) Perl_swash_init(aTHX_ a,b,c,d,e)
! #define swash_fetch(a,b) Perl_swash_fetch(aTHX_ a,b)
#define taint_env() Perl_taint_env(aTHX)
#define taint_proper(a,b) Perl_taint_proper(aTHX_ a,b)
#define to_utf8_lower(a) Perl_to_utf8_lower(aTHX_ a)
--- 2232,2238 ----
#define sv_vsetpvfn(a,b,c,d,e,f,g) Perl_sv_vsetpvfn(aTHX_ a,b,c,d,e,f,g)
#define str_to_version(a) Perl_str_to_version(aTHX_ a)
#define swash_init(a,b,c,d,e) Perl_swash_init(aTHX_ a,b,c,d,e)
! #define swash_fetch(a,b,c) Perl_swash_fetch(aTHX_ a,b,c)
#define taint_env() Perl_taint_env(aTHX)
#define taint_proper(a,b) Perl_taint_proper(aTHX_ a,b)
#define to_utf8_lower(a) Perl_to_utf8_lower(aTHX_ a)
***************
*** 2311,2317 ****
#define sv_pv(a) Perl_sv_pv(aTHX_ a)
#define sv_pvutf8(a) Perl_sv_pvutf8(aTHX_ a)
#define sv_pvbyte(a) Perl_sv_pvbyte(aTHX_ a)
- #define sv_utf8_upgrade(a) Perl_sv_utf8_upgrade(aTHX_ a)
#define sv_utf8_downgrade(a,b) Perl_sv_utf8_downgrade(aTHX_ a,b)
#define sv_utf8_encode(a) Perl_sv_utf8_encode(aTHX_ a)
#define sv_utf8_decode(a) Perl_sv_utf8_decode(aTHX_ a)
--- 2333,2338 ----
***************
*** 2326,2342 ****
#define my_attrs(a,b) Perl_my_attrs(aTHX_ a,b)
#define boot_core_xsutils() Perl_boot_core_xsutils(aTHX)
#if defined(USE_ITHREADS)
! #define cx_dup(a,b,c) Perl_cx_dup(aTHX_ a,b,c)
! #define si_dup(a) Perl_si_dup(aTHX_ a)
! #define ss_dup(a) Perl_ss_dup(aTHX_ a)
#define any_dup(a,b) Perl_any_dup(aTHX_ a,b)
! #define he_dup(a,b) Perl_he_dup(aTHX_ a,b)
! #define re_dup(a) Perl_re_dup(aTHX_ a)
#define fp_dup(a,b) Perl_fp_dup(aTHX_ a,b)
#define dirp_dup(a) Perl_dirp_dup(aTHX_ a)
! #define gp_dup(a) Perl_gp_dup(aTHX_ a)
! #define mg_dup(a) Perl_mg_dup(aTHX_ a)
! #define sv_dup(a) Perl_sv_dup(aTHX_ a)
#if defined(HAVE_INTERP_INTERN)
#define sys_intern_dup(a,b) Perl_sys_intern_dup(aTHX_ a,b)
#endif
--- 2347,2363 ----
#define my_attrs(a,b) Perl_my_attrs(aTHX_ a,b)
#define boot_core_xsutils() Perl_boot_core_xsutils(aTHX)
#if defined(USE_ITHREADS)
! #define cx_dup(a,b,c,d) Perl_cx_dup(aTHX_ a,b,c,d)
! #define si_dup(a,b) Perl_si_dup(aTHX_ a,b)
! #define ss_dup(a,b) Perl_ss_dup(aTHX_ a,b)
#define any_dup(a,b) Perl_any_dup(aTHX_ a,b)
! #define he_dup(a,b,c) Perl_he_dup(aTHX_ a,b,c)
! #define re_dup(a,b) Perl_re_dup(aTHX_ a,b)
#define fp_dup(a,b) Perl_fp_dup(aTHX_ a,b)
#define dirp_dup(a) Perl_dirp_dup(aTHX_ a)
! #define gp_dup(a,b) Perl_gp_dup(aTHX_ a,b)
! #define mg_dup(a,b) Perl_mg_dup(aTHX_ a,b)
! #define sv_dup(a,b) Perl_sv_dup(aTHX_ a,b)
#if defined(HAVE_INTERP_INTERN)
#define sys_intern_dup(a,b) Perl_sys_intern_dup(aTHX_ a,b)
#endif
***************
*** 2394,2401 ****
#define scalarboolean(a) S_scalarboolean(aTHX_ a)
#define too_few_arguments(a,b) S_too_few_arguments(aTHX_ a,b)
#define too_many_arguments(a,b) S_too_many_arguments(aTHX_ a,b)
- #define op_clear(a) S_op_clear(aTHX_ a)
- #define null(a) S_null(aTHX_ a)
#define pad_addlex(a) S_pad_addlex(aTHX_ a)
#define pad_findlex(a,b,c,d,e,f,g) S_pad_findlex(aTHX_ a,b,c,d,e,f,g)
#define newDEFSVOP() S_newDEFSVOP(aTHX)
--- 2415,2420 ----
***************
*** 2449,2457 ****
# endif
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
- #define doencodes(a,b,c) S_doencodes(aTHX_ a,b,c)
#define refto(a) S_refto(aTHX_ a)
#define seed() S_seed(aTHX)
#define mul128(a,b) S_mul128(aTHX_ a,b)
#define is_an_int(a,b) S_is_an_int(aTHX_ a,b)
#define div128(a,b) S_div128(aTHX_ a,b)
--- 2468,2478 ----
# endif
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
#define refto(a) S_refto(aTHX_ a)
#define seed() S_seed(aTHX)
+ #endif
+ #if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
+ #define doencodes(a,b,c) S_doencodes(aTHX_ a,b,c)
#define mul128(a,b) S_mul128(aTHX_ a,b)
#define is_an_int(a,b) S_is_an_int(aTHX_ a,b)
#define div128(a,b) S_div128(aTHX_ a,b)
***************
*** 2502,2509 ****
--- 2523,2532 ----
#define regtail(a,b,c) S_regtail(aTHX_ a,b,c)
#define regwhite(a,b) S_regwhite(aTHX_ a,b)
#define nextchar(a) S_nextchar(aTHX_ a)
+ # ifdef DEBUGGING
#define dumpuntil(a,b,c,d,e) S_dumpuntil(aTHX_ a,b,c,d,e)
#define put_byte(a,b) S_put_byte(aTHX_ a,b)
+ # endif
#define scan_commit(a,b) S_scan_commit(aTHX_ a,b)
#define cl_anything(a,b) S_cl_anything(aTHX_ a,b)
#define cl_is_anything(a) S_cl_is_anything(aTHX_ a)
***************
*** 2533,2539 ****
--- 2556,2565 ----
#define find_byclass(a,b,c,d,e,f) S_find_byclass(aTHX_ a,b,c,d,e,f)
#endif
#if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
+ # ifdef DEBUGGING
+ #define deb_curcv(a) S_deb_curcv(aTHX_ a)
#define debprof(a) S_debprof(aTHX_ a)
+ # endif
#endif
#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
#define save_scalar_at(a) S_save_scalar_at(aTHX_ a)
***************
*** 2583,2593 ****
#define visit(a) S_visit(aTHX_ a)
#define sv_add_backref(a,b) S_sv_add_backref(aTHX_ a,b)
#define sv_del_backref(a) S_sv_del_backref(aTHX_ a)
! # if defined(DEBUGGING)
#define del_sv(a) S_del_sv(aTHX_ a)
# endif
# if !defined(NV_PRESERVES_UV)
- #define sv_2inuv_non_preserve(a,b) S_sv_2inuv_non_preserve(aTHX_ a,b)
#define sv_2iuv_non_preserve(a,b) S_sv_2iuv_non_preserve(aTHX_ a,b)
# endif
#define expect_number(a) S_expect_number(aTHX_ a)
--- 2609,2618 ----
#define visit(a) S_visit(aTHX_ a)
#define sv_add_backref(a,b) S_sv_add_backref(aTHX_ a,b)
#define sv_del_backref(a) S_sv_del_backref(aTHX_ a)
! # ifdef DEBUGGING
#define del_sv(a) S_del_sv(aTHX_ a)
# endif
# if !defined(NV_PRESERVES_UV)
#define sv_2iuv_non_preserve(a,b) S_sv_2iuv_non_preserve(aTHX_ a,b)
# endif
#define expect_number(a) S_expect_number(aTHX_ a)
***************
*** 2601,2606 ****
--- 2626,2632 ----
#define force_version(a) S_force_version(aTHX_ a)
#define force_word(a,b,c,d,e) S_force_word(aTHX_ a,b,c,d,e)
#define tokeq(a) S_tokeq(aTHX_ a)
+ #define pending_ident() S_pending_ident(aTHX)
#define scan_const(a) S_scan_const(aTHX_ a)
#define scan_formline(a) S_scan_formline(aTHX_ a)
#define scan_heredoc(a) S_scan_heredoc(aTHX_ a)
***************
*** 2628,2634 ****
--- 2654,2662 ----
#define filter_gets(a,b,c) S_filter_gets(aTHX_ a,b,c)
#define find_in_my_stash(a,b) S_find_in_my_stash(aTHX_ a,b)
#define new_constant(a,b,c,d,e,f) S_new_constant(aTHX_ a,b,c,d,e,f)
+ # if defined(DEBUGGING)
#define tokereport(a,b,c) S_tokereport(aTHX_ a,b,c)
+ # endif
#define ao(a) S_ao(aTHX_ a)
#define depcom() S_depcom(aTHX)
#define incl_perldb() S_incl_perldb(aTHX)
***************
*** 2646,2653 ****
#if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT)
#define isa_lookup(a,b,c,d) S_isa_lookup(aTHX_ a,b,c,d)
#endif
! #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
#define stdize_locale(a) S_stdize_locale(aTHX_ a)
#define mess_alloc() S_mess_alloc(aTHX)
# if defined(LEAKTEST)
#define xstat(a) S_xstat(aTHX_ a)
--- 2674,2684 ----
#if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT)
#define isa_lookup(a,b,c,d) S_isa_lookup(aTHX_ a,b,c,d)
#endif
! #if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT)
#define stdize_locale(a) S_stdize_locale(aTHX_ a)
+ #endif
+ #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
+ #define closest_cop(a,b) S_closest_cop(aTHX_ a,b)
#define mess_alloc() S_mess_alloc(aTHX)
# if defined(LEAKTEST)
#define xstat(a) S_xstat(aTHX_ a)
***************
*** 2655,2660 ****
--- 2686,2698 ----
#endif
#if defined(PERL_OBJECT)
#endif
+ #define sv_setsv_flags(a,b,c) Perl_sv_setsv_flags(aTHX_ a,b,c)
+ #define sv_catpvn_flags(a,b,c,d) Perl_sv_catpvn_flags(aTHX_ a,b,c,d)
+ #define sv_catsv_flags(a,b,c) Perl_sv_catsv_flags(aTHX_ a,b,c)
+ #define sv_utf8_upgrade_flags(a,b) Perl_sv_utf8_upgrade_flags(aTHX_ a,b)
+ #define sv_pvn_force_flags(a,b,c) Perl_sv_pvn_force_flags(aTHX_ a,b,c)
+ #define sv_2pv_flags(a,b,c) Perl_sv_2pv_flags(aTHX_ a,b,c)
+ #define my_atof2(a,b) Perl_my_atof2(aTHX_ a,b)
#define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a)
#define ck_bitop(a) Perl_ck_bitop(aTHX_ a)
#define ck_concat(a) Perl_ck_concat(aTHX_ a)
***************
*** 2667,2673 ****
#define ck_exit(a) Perl_ck_exit(aTHX_ a)
#define ck_ftst(a) Perl_ck_ftst(aTHX_ a)
#define ck_fun(a) Perl_ck_fun(aTHX_ a)
- #define ck_fun_locale(a) Perl_ck_fun_locale(aTHX_ a)
#define ck_glob(a) Perl_ck_glob(aTHX_ a)
#define ck_grep(a) Perl_ck_grep(aTHX_ a)
#define ck_index(a) Perl_ck_index(aTHX_ a)
--- 2705,2710 ----
***************
*** 2685,2691 ****
#define ck_rfun(a) Perl_ck_rfun(aTHX_ a)
#define ck_rvconst(a) Perl_ck_rvconst(aTHX_ a)
#define ck_sassign(a) Perl_ck_sassign(aTHX_ a)
- #define ck_scmp(a) Perl_ck_scmp(aTHX_ a)
#define ck_select(a) Perl_ck_select(aTHX_ a)
#define ck_shift(a) Perl_ck_shift(aTHX_ a)
#define ck_sort(a) Perl_ck_sort(aTHX_ a)
--- 2722,2727 ----
***************
*** 3052,3062 ****
# if defined(PERL_IMPLICIT_SYS)
# endif
#endif
- #if defined(MYMALLOC)
#define malloc Perl_malloc
#define calloc Perl_calloc
#define realloc Perl_realloc
#define mfree Perl_mfree
#define malloced_size Perl_malloced_size
#endif
#define get_context Perl_get_context
--- 3088,3098 ----
# if defined(PERL_IMPLICIT_SYS)
# endif
#endif
#define malloc Perl_malloc
#define calloc Perl_calloc
#define realloc Perl_realloc
#define mfree Perl_mfree
+ #if defined(MYMALLOC)
#define malloced_size Perl_malloced_size
#endif
#define get_context Perl_get_context
***************
*** 3138,3143 ****
--- 3174,3181 ----
#define block_start Perl_block_start
#define Perl_boot_core_UNIVERSAL CPerlObj::Perl_boot_core_UNIVERSAL
#define boot_core_UNIVERSAL Perl_boot_core_UNIVERSAL
+ #define Perl_boot_core_PerlIO CPerlObj::Perl_boot_core_PerlIO
+ #define boot_core_PerlIO Perl_boot_core_PerlIO
#define Perl_call_list CPerlObj::Perl_call_list
#define call_list Perl_call_list
#define Perl_cando CPerlObj::Perl_cando
***************
*** 3462,3467 ****
--- 3500,3507 ----
#define init_debugger Perl_init_debugger
#define Perl_init_stacks CPerlObj::Perl_init_stacks
#define init_stacks Perl_init_stacks
+ #define Perl_init_tm CPerlObj::Perl_init_tm
+ #define init_tm Perl_init_tm
#define Perl_intro_my CPerlObj::Perl_intro_my
#define intro_my Perl_intro_my
#define Perl_instr CPerlObj::Perl_instr
***************
*** 3586,3591 ****
--- 3626,3635 ----
#define lex_end Perl_lex_end
#define Perl_lex_start CPerlObj::Perl_lex_start
#define lex_start Perl_lex_start
+ #define Perl_op_null CPerlObj::Perl_op_null
+ #define op_null Perl_op_null
+ #define Perl_op_clear CPerlObj::Perl_op_clear
+ #define op_clear Perl_op_clear
#define Perl_linklist CPerlObj::Perl_linklist
#define linklist Perl_linklist
#define Perl_list CPerlObj::Perl_list
***************
*** 3600,3605 ****
--- 3644,3653 ----
#define localize Perl_localize
#define Perl_looks_like_number CPerlObj::Perl_looks_like_number
#define looks_like_number Perl_looks_like_number
+ #define Perl_grok_number CPerlObj::Perl_grok_number
+ #define grok_number Perl_grok_number
+ #define Perl_grok_numeric_radix CPerlObj::Perl_grok_numeric_radix
+ #define grok_numeric_radix Perl_grok_numeric_radix
#define Perl_magic_clearenv CPerlObj::Perl_magic_clearenv
#define magic_clearenv Perl_magic_clearenv
#define Perl_magic_clear_all_env CPerlObj::Perl_magic_clear_all_env
***************
*** 3732,3737 ****
--- 3780,3787 ----
#define mg_set Perl_mg_set
#define Perl_mg_size CPerlObj::Perl_mg_size
#define mg_size Perl_mg_size
+ #define Perl_mini_mktime CPerlObj::Perl_mini_mktime
+ #define mini_mktime Perl_mini_mktime
#define Perl_mod CPerlObj::Perl_mod
#define mod Perl_mod
#define Perl_mode_from_discipline CPerlObj::Perl_mode_from_discipline
***************
*** 3742,3748 ****
#define my Perl_my
#define Perl_my_atof CPerlObj::Perl_my_atof
#define my_atof Perl_my_atof
! #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
#define Perl_my_bcopy CPerlObj::Perl_my_bcopy
#define my_bcopy Perl_my_bcopy
#endif
--- 3792,3798 ----
#define my Perl_my
#define Perl_my_atof CPerlObj::Perl_my_atof
#define my_atof Perl_my_atof
! #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
#define Perl_my_bcopy CPerlObj::Perl_my_bcopy
#define my_bcopy Perl_my_bcopy
#endif
***************
*** 3778,3783 ****
--- 3828,3835 ----
#define my_setenv Perl_my_setenv
#define Perl_my_stat CPerlObj::Perl_my_stat
#define my_stat Perl_my_stat
+ #define Perl_my_strftime CPerlObj::Perl_my_strftime
+ #define my_strftime Perl_my_strftime
#if defined(MYSWAP)
#define Perl_my_swap CPerlObj::Perl_my_swap
#define my_swap Perl_my_swap
***************
*** 4231,4236 ****
--- 4283,4290 ----
#endif
#define Perl_sv_compile_2op CPerlObj::Perl_sv_compile_2op
#define sv_compile_2op Perl_sv_compile_2op
+ #define Perl_getcwd_sv CPerlObj::Perl_getcwd_sv
+ #define getcwd_sv Perl_getcwd_sv
#define Perl_sv_dec CPerlObj::Perl_sv_dec
#define sv_dec Perl_sv_dec
#define Perl_sv_dump CPerlObj::Perl_sv_dump
***************
*** 4683,4692 ****
#define too_few_arguments S_too_few_arguments
#define S_too_many_arguments CPerlObj::S_too_many_arguments
#define too_many_arguments S_too_many_arguments
- #define S_op_clear CPerlObj::S_op_clear
- #define op_clear S_op_clear
- #define S_null CPerlObj::S_null
- #define null S_null
#define S_pad_addlex CPerlObj::S_pad_addlex
#define pad_addlex S_pad_addlex
#define S_pad_findlex CPerlObj::S_pad_findlex
--- 4737,4742 ----
***************
*** 4779,4790 ****
# endif
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
- #define S_doencodes CPerlObj::S_doencodes
- #define doencodes S_doencodes
#define S_refto CPerlObj::S_refto
#define refto S_refto
#define S_seed CPerlObj::S_seed
#define seed S_seed
#define S_mul128 CPerlObj::S_mul128
#define mul128 S_mul128
#define S_is_an_int CPerlObj::S_is_an_int
--- 4829,4842 ----
# endif
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
#define S_refto CPerlObj::S_refto
#define refto S_refto
#define S_seed CPerlObj::S_seed
#define seed S_seed
+ #endif
+ #if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
+ #define S_doencodes CPerlObj::S_doencodes
+ #define doencodes S_doencodes
#define S_mul128 CPerlObj::S_mul128
#define mul128 S_mul128
#define S_is_an_int CPerlObj::S_is_an_int
***************
*** 4873,4882 ****
--- 4925,4936 ----
#define regwhite S_regwhite
#define S_nextchar CPerlObj::S_nextchar
#define nextchar S_nextchar
+ # ifdef DEBUGGING
#define S_dumpuntil CPerlObj::S_dumpuntil
#define dumpuntil S_dumpuntil
#define S_put_byte CPerlObj::S_put_byte
#define put_byte S_put_byte
+ # endif
#define S_scan_commit CPerlObj::S_scan_commit
#define scan_commit S_scan_commit
#define S_cl_anything CPerlObj::S_cl_anything
***************
*** 4933,4940 ****
--- 4987,4998 ----
#define find_byclass S_find_byclass
#endif
#if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
+ # ifdef DEBUGGING
+ #define S_deb_curcv CPerlObj::S_deb_curcv
+ #define deb_curcv S_deb_curcv
#define S_debprof CPerlObj::S_debprof
#define debprof S_debprof
+ # endif
#endif
#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
#define S_save_scalar_at CPerlObj::S_save_scalar_at
***************
*** 5029,5041 ****
#define sv_add_backref S_sv_add_backref
#define S_sv_del_backref CPerlObj::S_sv_del_backref
#define sv_del_backref S_sv_del_backref
! # if defined(DEBUGGING)
#define S_del_sv CPerlObj::S_del_sv
#define del_sv S_del_sv
# endif
# if !defined(NV_PRESERVES_UV)
- #define S_sv_2inuv_non_preserve CPerlObj::S_sv_2inuv_non_preserve
- #define sv_2inuv_non_preserve S_sv_2inuv_non_preserve
#define S_sv_2iuv_non_preserve CPerlObj::S_sv_2iuv_non_preserve
#define sv_2iuv_non_preserve S_sv_2iuv_non_preserve
# endif
--- 5087,5097 ----
#define sv_add_backref S_sv_add_backref
#define S_sv_del_backref CPerlObj::S_sv_del_backref
#define sv_del_backref S_sv_del_backref
! # ifdef DEBUGGING
#define S_del_sv CPerlObj::S_del_sv
#define del_sv S_del_sv
# endif
# if !defined(NV_PRESERVES_UV)
#define S_sv_2iuv_non_preserve CPerlObj::S_sv_2iuv_non_preserve
#define sv_2iuv_non_preserve S_sv_2iuv_non_preserve
# endif
***************
*** 5057,5062 ****
--- 5113,5120 ----
#define force_word S_force_word
#define S_tokeq CPerlObj::S_tokeq
#define tokeq S_tokeq
+ #define S_pending_ident CPerlObj::S_pending_ident
+ #define pending_ident S_pending_ident
#define S_scan_const CPerlObj::S_scan_const
#define scan_const S_scan_const
#define S_scan_formline CPerlObj::S_scan_formline
***************
*** 5111,5118 ****
--- 5169,5178 ----
#define find_in_my_stash S_find_in_my_stash
#define S_new_constant CPerlObj::S_new_constant
#define new_constant S_new_constant
+ # if defined(DEBUGGING)
#define S_tokereport CPerlObj::S_tokereport
#define tokereport S_tokereport
+ # endif
#define S_ao CPerlObj::S_ao
#define ao S_ao
#define S_depcom CPerlObj::S_depcom
***************
*** 5138,5146 ****
#define S_isa_lookup CPerlObj::S_isa_lookup
#define isa_lookup S_isa_lookup
#endif
! #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
#define S_stdize_locale CPerlObj::S_stdize_locale
#define stdize_locale S_stdize_locale
#define S_mess_alloc CPerlObj::S_mess_alloc
#define mess_alloc S_mess_alloc
# if defined(LEAKTEST)
--- 5198,5210 ----
#define S_isa_lookup CPerlObj::S_isa_lookup
#define isa_lookup S_isa_lookup
#endif
! #if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT)
#define S_stdize_locale CPerlObj::S_stdize_locale
#define stdize_locale S_stdize_locale
+ #endif
+ #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
+ #define S_closest_cop CPerlObj::S_closest_cop
+ #define closest_cop S_closest_cop
#define S_mess_alloc CPerlObj::S_mess_alloc
#define mess_alloc S_mess_alloc
# if defined(LEAKTEST)
***************
*** 5150,5155 ****
--- 5214,5233 ----
#endif
#if defined(PERL_OBJECT)
#endif
+ #define Perl_sv_setsv_flags CPerlObj::Perl_sv_setsv_flags
+ #define sv_setsv_flags Perl_sv_setsv_flags
+ #define Perl_sv_catpvn_flags CPerlObj::Perl_sv_catpvn_flags
+ #define sv_catpvn_flags Perl_sv_catpvn_flags
+ #define Perl_sv_catsv_flags CPerlObj::Perl_sv_catsv_flags
+ #define sv_catsv_flags Perl_sv_catsv_flags
+ #define Perl_sv_utf8_upgrade_flags CPerlObj::Perl_sv_utf8_upgrade_flags
+ #define sv_utf8_upgrade_flags Perl_sv_utf8_upgrade_flags
+ #define Perl_sv_pvn_force_flags CPerlObj::Perl_sv_pvn_force_flags
+ #define sv_pvn_force_flags Perl_sv_pvn_force_flags
+ #define Perl_sv_2pv_flags CPerlObj::Perl_sv_2pv_flags
+ #define sv_2pv_flags Perl_sv_2pv_flags
+ #define Perl_my_atof2 CPerlObj::Perl_my_atof2
+ #define my_atof2 Perl_my_atof2
#define Perl_ck_anoncode CPerlObj::Perl_ck_anoncode
#define ck_anoncode Perl_ck_anoncode
#define Perl_ck_bitop CPerlObj::Perl_ck_bitop
***************
*** 5174,5181 ****
#define ck_ftst Perl_ck_ftst
#define Perl_ck_fun CPerlObj::Perl_ck_fun
#define ck_fun Perl_ck_fun
- #define Perl_ck_fun_locale CPerlObj::Perl_ck_fun_locale
- #define ck_fun_locale Perl_ck_fun_locale
#define Perl_ck_glob CPerlObj::Perl_ck_glob
#define ck_glob Perl_ck_glob
#define Perl_ck_grep CPerlObj::Perl_ck_grep
--- 5252,5257 ----
***************
*** 5210,5217 ****
#define ck_rvconst Perl_ck_rvconst
#define Perl_ck_sassign CPerlObj::Perl_ck_sassign
#define ck_sassign Perl_ck_sassign
- #define Perl_ck_scmp CPerlObj::Perl_ck_scmp
- #define ck_scmp Perl_ck_scmp
#define Perl_ck_select CPerlObj::Perl_ck_select
#define ck_select Perl_ck_select
#define Perl_ck_shift CPerlObj::Perl_ck_shift
--- 5286,5291 ----
diff -c 'perl-5.7.1/embed.pl' 'perl-5.7.2/embed.pl'
Index: ./embed.pl
*** ./embed.pl Fri Apr 6 16:19:51 2001
--- ./embed.pl Thu Jul 12 21:34:33 2001
***************
*** 49,55 ****
else {
@args = split /\s*\|\s*/, $_;
}
! print $F $function->(@args);
}
print $F $trailer if $trailer;
close $F unless ref $filename;
--- 49,56 ----
else {
@args = split /\s*\|\s*/, $_;
}
! my @outs = &{$function}(@args);
! print $F @outs; # $function->(@args) is not 5.003
}
print $F $trailer if $trailer;
close $F unless ref $filename;
***************
*** 251,257 ****
readvars %thread, 'thrdvar.h','T';
readvars %globvar, 'perlvars.h','G';
! foreach my $sym (sort keys %thread) {
warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
}
--- 252,259 ----
readvars %thread, 'thrdvar.h','T';
readvars %globvar, 'perlvars.h','G';
! my $sym;
! foreach $sym (sort keys %thread) {
warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
}
***************
*** 856,870 ****
EOT
! foreach my $sym (sort keys %intrp) {
print CAPIH bincompat_var('I',$sym);
}
! foreach my $sym (sort keys %thread) {
print CAPIH bincompat_var('T',$sym);
}
! foreach my $sym (sort keys %globvar) {
print CAPIH bincompat_var('G',$sym);
}
--- 858,872 ----
EOT
! foreach $sym (sort keys %intrp) {
print CAPIH bincompat_var('I',$sym);
}
! foreach $sym (sort keys %thread) {
print CAPIH bincompat_var('T',$sym);
}
! foreach $sym (sort keys %globvar) {
print CAPIH bincompat_var('G',$sym);
}
***************
*** 985,991 ****
if (length $return) {
$decl .= " $rettype retval;\n";
$retarg .= "retval = ";
! $return = "\n ${return}retval;\n";
}
$emitval .= <<EOT
$rettype
--- 987,993 ----
if (length $return) {
$decl .= " $rettype retval;\n";
$retarg .= "retval = ";
! $return = "\n " . $return . "retval;\n";
}
$emitval .= <<EOT
$rettype
***************
*** 1011,1017 ****
}
# XXXX temporary hack
- my $sym;
for $sym (qw(
perl_construct
perl_destruct
--- 1013,1018 ----
***************
*** 1136,1142 ****
redo FUNC;
}
} else {
! warn "$file:$line:$in";
}
}
}
--- 1137,1143 ----
redo FUNC;
}
} else {
! warn "$file:$line:$in (=cut missing?)";
}
}
}
***************
*** 1348,1355 ****
Ajnod |int |perl_parse |PerlInterpreter* interp|XSINIT_t xsinit \
|int argc|char** argv|char** env
#if defined(USE_ITHREADS)
! : XXX: perl_clone needs docs
! Ajno |PerlInterpreter*|perl_clone|PerlInterpreter* interp, UV flags
# if defined(PERL_IMPLICIT_SYS)
Ajno |PerlInterpreter*|perl_clone_using|PerlInterpreter *interp|UV flags \
|struct IPerlMem* m|struct IPerlMem* ms \
--- 1349,1355 ----
Ajnod |int |perl_parse |PerlInterpreter* interp|XSINIT_t xsinit \
|int argc|char** argv|char** env
#if defined(USE_ITHREADS)
! Ajnod |PerlInterpreter*|perl_clone|PerlInterpreter* interp, UV flags
# if defined(PERL_IMPLICIT_SYS)
Ajno |PerlInterpreter*|perl_clone_using|PerlInterpreter *interp|UV flags \
|struct IPerlMem* m|struct IPerlMem* ms \
***************
*** 1360,1370 ****
# endif
#endif
- #if defined(MYMALLOC)
Ajnop |Malloc_t|malloc |MEM_SIZE nbytes
Ajnop |Malloc_t|calloc |MEM_SIZE elements|MEM_SIZE size
Ajnop |Malloc_t|realloc |Malloc_t where|MEM_SIZE nbytes
Ajnop |Free_t |mfree |Malloc_t where
jnp |MEM_SIZE|malloced_size |void *p
#endif
--- 1360,1370 ----
# endif
#endif
Ajnop |Malloc_t|malloc |MEM_SIZE nbytes
Ajnop |Malloc_t|calloc |MEM_SIZE elements|MEM_SIZE size
Ajnop |Malloc_t|realloc |Malloc_t where|MEM_SIZE nbytes
Ajnop |Free_t |mfree |Malloc_t where
+ #if defined(MYMALLOC)
jnp |MEM_SIZE|malloced_size |void *p
#endif
***************
*** 1427,1432 ****
--- 1427,1433 ----
Ap |I32 |block_gimme
p |int |block_start |int full
p |void |boot_core_UNIVERSAL
+ p |void |boot_core_PerlIO
Ap |void |call_list |I32 oldscope|AV* av_list
p |bool |cando |Mode_t mode|Uid_t effective|Stat_t* statbufp
Ap |U32 |cast_ulong |NV f
***************
*** 1610,1615 ****
--- 1611,1617 ----
p |bool |ingroup |Gid_t testgid|Uid_t effective
p |void |init_debugger
Ap |void |init_stacks
+ Ap |void |init_tm |struct tm *ptm
p |U32 |intro_my
Ap |char* |instr |const char* big|const char* little
p |bool |io_close |IO* io|bool not_implicit
***************
*** 1672,1677 ****
--- 1674,1681 ----
Ap |void |leave_scope |I32 base
p |void |lex_end
p |void |lex_start |SV* line
+ Ap |void |op_null |OP* o
+ p |void |op_clear |OP* o
p |OP* |linklist |OP* o
p |OP* |list |OP* o
p |OP* |listkids |OP* o
***************
*** 1679,1684 ****
--- 1683,1690 ----
Ap |void |vload_module|U32 flags|SV* name|SV* ver|va_list* args
p |OP* |localize |OP* arg|I32 lexical
Apd |I32 |looks_like_number|SV* sv
+ Apd |int |grok_number |const char *pv|STRLEN len|UV *valuep
+ Apd |bool |grok_numeric_radix|const char **sp|const char *send
p |int |magic_clearenv |SV* sv|MAGIC* mg
p |int |magic_clear_all_env|SV* sv|MAGIC* mg
p |int |magic_clearpack|SV* sv|MAGIC* mg
***************
*** 1748,1759 ****
Apd |void |mg_magical |SV* sv
Apd |int |mg_set |SV* sv
Ap |I32 |mg_size |SV* sv
p |OP* |mod |OP* o|I32 type
p |int |mode_from_discipline|SV* discp
Ap |char* |moreswitches |char* s
p |OP* |my |OP* o
Ap |NV |my_atof |const char *s
! #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
Anp |char* |my_bcopy |const char* from|char* to|I32 len
#endif
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
--- 1754,1766 ----
Apd |void |mg_magical |SV* sv
Apd |int |mg_set |SV* sv
Ap |I32 |mg_size |SV* sv
+ Ap |void |mini_mktime |struct tm *pm
p |OP* |mod |OP* o|I32 type
p |int |mode_from_discipline|SV* discp
Ap |char* |moreswitches |char* s
p |OP* |my |OP* o
Ap |NV |my_atof |const char *s
! #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
Anp |char* |my_bcopy |const char* from|char* to|I32 len
#endif
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
***************
*** 1776,1781 ****
--- 1783,1789 ----
#endif
Ap |void |my_setenv |char* nam|char* val
Ap |I32 |my_stat
+ Ap |char * |my_strftime |char *fmt|int sec|int min|int hour|int mday|int mon|int year|int wday|int yday|int isdst
#if defined(MYSWAP)
Ap |short |my_swap |short s
Ap |long |my_htonl |long l
***************
*** 1819,1825 ****
Ap |OP* |newPVOP |I32 type|I32 flags|char* pv
Ap |SV* |newRV |SV* pref
Apd |SV* |newRV_noinc |SV *sv
! Ap |SV* |newSV |STRLEN len
Ap |OP* |newSVREF |OP* o
Ap |OP* |newSVOP |I32 type|I32 flags|SV* sv
Apd |SV* |newSViv |IV i
--- 1827,1833 ----
Ap |OP* |newPVOP |I32 type|I32 flags|char* pv
Ap |SV* |newRV |SV* pref
Apd |SV* |newRV_noinc |SV *sv
! Apd |SV* |newSV |STRLEN len
Ap |OP* |newSVREF |OP* o
Ap |OP* |newSVOP |I32 type|I32 flags|SV* sv
Apd |SV* |newSViv |IV i
***************
*** 1920,1926 ****
Ap |Sighandler_t|rsignal |int i|Sighandler_t t
p |int |rsignal_restore|int i|Sigsave_t* t
p |int |rsignal_save |int i|Sighandler_t t1|Sigsave_t* t2
! p |Sighandler_t|rsignal_state|int i
p |void |rxres_free |void** rsp
p |void |rxres_restore |void** rsp|REGEXP* prx
p |void |rxres_save |void** rsp|REGEXP* prx
--- 1928,1934 ----
Ap |Sighandler_t|rsignal |int i|Sighandler_t t
p |int |rsignal_restore|int i|Sigsave_t* t
p |int |rsignal_save |int i|Sighandler_t t1|Sigsave_t* t2
! Ap |Sighandler_t|rsignal_state|int i
p |void |rxres_free |void** rsp
p |void |rxres_restore |void** rsp|REGEXP* prx
p |void |rxres_save |void** rsp|REGEXP* prx
***************
*** 1989,2035 ****
Ap |SV** |stack_grow |SV** sp|SV**p|int n
Ap |I32 |start_subparse |I32 is_format|U32 flags
p |void |sub_crush_depth|CV* cv
! Ap |bool |sv_2bool |SV* sv
! Ap |CV* |sv_2cv |SV* sv|HV** st|GV** gvp|I32 lref
! Ap |IO* |sv_2io |SV* sv
! Ap |IV |sv_2iv |SV* sv
Apd |SV* |sv_2mortal |SV* sv
! Ap |NV |sv_2nv |SV* sv
! Ap |char* |sv_2pv |SV* sv|STRLEN* lp
! Ap |char* |sv_2pvutf8 |SV* sv|STRLEN* lp
! Ap |char* |sv_2pvbyte |SV* sv|STRLEN* lp
! Ap |UV |sv_2uv |SV* sv
! Ap |IV |sv_iv |SV* sv
! Ap |UV |sv_uv |SV* sv
! Ap |NV |sv_nv |SV* sv
! Ap |char* |sv_pvn |SV *sv|STRLEN *len
! Ap |char* |sv_pvutf8n |SV *sv|STRLEN *len
! Ap |char* |sv_pvbyten |SV *sv|STRLEN *len
Apd |I32 |sv_true |SV *sv
! p |void |sv_add_arena |char* ptr|U32 size|U32 flags
! Ap |int |sv_backoff |SV* sv
Apd |SV* |sv_bless |SV* sv|HV* stash
Afpd |void |sv_catpvf |SV* sv|const char* pat|...
Ap |void |sv_vcatpvf |SV* sv|const char* pat|va_list* args
Apd |void |sv_catpv |SV* sv|const char* ptr
! Apd |void |sv_catpvn |SV* sv|const char* ptr|STRLEN len
! Apd |void |sv_catsv |SV* dsv|SV* ssv
Apd |void |sv_chop |SV* sv|char* ptr
! p |I32 |sv_clean_all
! p |void |sv_clean_objs
Apd |void |sv_clear |SV* sv
Apd |I32 |sv_cmp |SV* sv1|SV* sv2
Apd |I32 |sv_cmp_locale |SV* sv1|SV* sv2
#if defined(USE_LOCALE_COLLATE)
! Ap |char* |sv_collxfrm |SV* sv|STRLEN* nxp
#endif
Ap |OP* |sv_compile_2op |SV* sv|OP** startp|char* code|AV** avp
Apd |void |sv_dec |SV* sv
Ap |void |sv_dump |SV* sv
Apd |bool |sv_derived_from|SV* sv|const char* name
Apd |I32 |sv_eq |SV* sv1|SV* sv2
Apd |void |sv_free |SV* sv
! p |void |sv_free_arenas
Apd |char* |sv_gets |SV* sv|PerlIO* fp|I32 append
Apd |char* |sv_grow |SV* sv|STRLEN newlen
Apd |void |sv_inc |SV* sv
--- 1997,2044 ----
Ap |SV** |stack_grow |SV** sp|SV**p|int n
Ap |I32 |start_subparse |I32 is_format|U32 flags
p |void |sub_crush_depth|CV* cv
! Apd |bool |sv_2bool |SV* sv
! Apd |CV* |sv_2cv |SV* sv|HV** st|GV** gvp|I32 lref
! Apd |IO* |sv_2io |SV* sv
! Apd |IV |sv_2iv |SV* sv
Apd |SV* |sv_2mortal |SV* sv
! Apd |NV |sv_2nv |SV* sv
! Aop |char* |sv_2pv |SV* sv|STRLEN* lp
! Apd |char* |sv_2pvutf8 |SV* sv|STRLEN* lp
! Apd |char* |sv_2pvbyte |SV* sv|STRLEN* lp
! Apd |UV |sv_2uv |SV* sv
! Apd |IV |sv_iv |SV* sv
! Apd |UV |sv_uv |SV* sv
! Apd |NV |sv_nv |SV* sv
! Apd |char* |sv_pvn |SV *sv|STRLEN *len
! Apd |char* |sv_pvutf8n |SV *sv|STRLEN *len
! Apd |char* |sv_pvbyten |SV *sv|STRLEN *len
Apd |I32 |sv_true |SV *sv
! pd |void |sv_add_arena |char* ptr|U32 size|U32 flags
! Apd |int |sv_backoff |SV* sv
Apd |SV* |sv_bless |SV* sv|HV* stash
Afpd |void |sv_catpvf |SV* sv|const char* pat|...
Ap |void |sv_vcatpvf |SV* sv|const char* pat|va_list* args
Apd |void |sv_catpv |SV* sv|const char* ptr
! Aopd |void |sv_catpvn |SV* sv|const char* ptr|STRLEN len
! Aopd |void |sv_catsv |SV* dsv|SV* ssv
Apd |void |sv_chop |SV* sv|char* ptr
! pd |I32 |sv_clean_all
! pd |void |sv_clean_objs
Apd |void |sv_clear |SV* sv
Apd |I32 |sv_cmp |SV* sv1|SV* sv2
Apd |I32 |sv_cmp_locale |SV* sv1|SV* sv2
#if defined(USE_LOCALE_COLLATE)
! Apd |char* |sv_collxfrm |SV* sv|STRLEN* nxp
#endif
Ap |OP* |sv_compile_2op |SV* sv|OP** startp|char* code|AV** avp
+ Apd |int |getcwd_sv |SV* sv
Apd |void |sv_dec |SV* sv
Ap |void |sv_dump |SV* sv
Apd |bool |sv_derived_from|SV* sv|const char* name
Apd |I32 |sv_eq |SV* sv1|SV* sv2
Apd |void |sv_free |SV* sv
! pd |void |sv_free_arenas
Apd |char* |sv_gets |SV* sv|PerlIO* fp|I32 append
Apd |char* |sv_grow |SV* sv|STRLEN newlen
Apd |void |sv_inc |SV* sv
***************
*** 2043,2059 ****
|I32 namlen
Apd |SV* |sv_mortalcopy |SV* oldsv
Apd |SV* |sv_newmortal
! Ap |SV* |sv_newref |SV* sv
Ap |char* |sv_peek |SV* sv
! Ap |void |sv_pos_u2b |SV* sv|I32* offsetp|I32* lenp
! Ap |void |sv_pos_b2u |SV* sv|I32* offsetp
! Apd |char* |sv_pvn_force |SV* sv|STRLEN* lp
Apd |char* |sv_pvutf8n_force|SV* sv|STRLEN* lp
! Ap |char* |sv_pvbyten_force|SV* sv|STRLEN* lp
Apd |char* |sv_reftype |SV* sv|int ob
Apd |void |sv_replace |SV* sv|SV* nsv
! Ap |void |sv_report_used
! Ap |void |sv_reset |char* s|HV* stash
Afpd |void |sv_setpvf |SV* sv|const char* pat|...
Ap |void |sv_vsetpvf |SV* sv|const char* pat|va_list* args
Apd |void |sv_setiv |SV* sv|IV num
--- 2052,2068 ----
|I32 namlen
Apd |SV* |sv_mortalcopy |SV* oldsv
Apd |SV* |sv_newmortal
! Apd |SV* |sv_newref |SV* sv
Ap |char* |sv_peek |SV* sv
! Apd |void |sv_pos_u2b |SV* sv|I32* offsetp|I32* lenp
! Apd |void |sv_pos_b2u |SV* sv|I32* offsetp
! Aopd |char* |sv_pvn_force |SV* sv|STRLEN* lp
Apd |char* |sv_pvutf8n_force|SV* sv|STRLEN* lp
! Apd |char* |sv_pvbyten_force|SV* sv|STRLEN* lp
Apd |char* |sv_reftype |SV* sv|int ob
Apd |void |sv_replace |SV* sv|SV* nsv
! Apd |void |sv_report_used
! Apd |void |sv_reset |char* s|HV* stash
Afpd |void |sv_setpvf |SV* sv|const char* pat|...
Ap |void |sv_vsetpvf |SV* sv|const char* pat|va_list* args
Apd |void |sv_setiv |SV* sv|IV num
***************
*** 2068,2080 ****
|STRLEN n
Apd |void |sv_setpv |SV* sv|const char* ptr
Apd |void |sv_setpvn |SV* sv|const char* ptr|STRLEN len
! Apd |void |sv_setsv |SV* dsv|SV* ssv
! Ap |void |sv_taint |SV* sv
! Ap |bool |sv_tainted |SV* sv
Apd |int |sv_unmagic |SV* sv|int type
Apd |void |sv_unref |SV* sv
Apd |void |sv_unref_flags |SV* sv|U32 flags
! Ap |void |sv_untaint |SV* sv
Apd |bool |sv_upgrade |SV* sv|U32 mt
Apd |void |sv_usepvn |SV* sv|char* ptr|STRLEN len
Apd |void |sv_vcatpvfn |SV* sv|const char* pat|STRLEN patlen \
--- 2077,2089 ----
|STRLEN n
Apd |void |sv_setpv |SV* sv|const char* ptr
Apd |void |sv_setpvn |SV* sv|const char* ptr|STRLEN len
! Aopd |void |sv_setsv |SV* dsv|SV* ssv
! Apd |void |sv_taint |SV* sv
! Apd |bool |sv_tainted |SV* sv
Apd |int |sv_unmagic |SV* sv|int type
Apd |void |sv_unref |SV* sv
Apd |void |sv_unref_flags |SV* sv|U32 flags
! Apd |void |sv_untaint |SV* sv
Apd |bool |sv_upgrade |SV* sv|U32 mt
Apd |void |sv_usepvn |SV* sv|char* ptr|STRLEN len
Apd |void |sv_vcatpvfn |SV* sv|const char* pat|STRLEN patlen \
***************
*** 2086,2092 ****
Ap |NV |str_to_version |SV *sv
Ap |SV* |swash_init |char* pkg|char* name|SV* listsv \
|I32 minbits|I32 none
! Ap |UV |swash_fetch |SV *sv|U8 *ptr
Ap |void |taint_env
Ap |void |taint_proper |const char* f|const char* s
Ap |UV |to_utf8_lower |U8 *p
--- 2095,2101 ----
Ap |NV |str_to_version |SV *sv
Ap |SV* |swash_init |char* pkg|char* name|SV* listsv \
|I32 minbits|I32 none
! Ap |UV |swash_fetch |SV *sv|U8 *ptr|bool do_utf8
Ap |void |taint_env
Ap |void |taint_proper |const char* f|const char* s
Ap |UV |to_utf8_lower |U8 *p
***************
*** 2119,2125 ****
p |void |vivify_ref |SV* sv|U32 to_what
p |I32 |wait4pid |Pid_t pid|int* statusp|int flags
p |void |report_evil_fh |GV *gv|IO *io|I32 op
! p |void |report_uninit
Afpd |void |warn |const char* pat|...
Ap |void |vwarn |const char* pat|va_list* args
Afp |void |warner |U32 err|const char* pat|...
--- 2128,2134 ----
p |void |vivify_ref |SV* sv|U32 to_what
p |I32 |wait4pid |Pid_t pid|int* statusp|int flags
p |void |report_evil_fh |GV *gv|IO *io|I32 op
! pd |void |report_uninit
Afpd |void |warn |const char* pat|...
Ap |void |vwarn |const char* pat|va_list* args
Afp |void |warner |U32 err|const char* pat|...
***************
*** 2193,2210 ****
|protect_body_t body|va_list *args
#endif
Ap |void |reginitcolors
! Ap |char* |sv_2pv_nolen |SV* sv
! Ap |char* |sv_2pvutf8_nolen|SV* sv
! Ap |char* |sv_2pvbyte_nolen|SV* sv
! Ap |char* |sv_pv |SV *sv
! Ap |char* |sv_pvutf8 |SV *sv
! Ap |char* |sv_pvbyte |SV *sv
! Apd |STRLEN |sv_utf8_upgrade|SV *sv
ApdM |bool |sv_utf8_downgrade|SV *sv|bool fail_ok
Apd |void |sv_utf8_encode |SV *sv
ApdM |bool |sv_utf8_decode |SV *sv
! Ap |void |sv_force_normal|SV *sv
! Ap |void |sv_force_normal_flags|SV *sv|U32 flags
Ap |void |tmps_grow |I32 n
Apd |SV* |sv_rvweaken |SV *sv
p |int |magic_killbackrefs|SV *sv|MAGIC *mg
--- 2202,2219 ----
|protect_body_t body|va_list *args
#endif
Ap |void |reginitcolors
! Apd |char* |sv_2pv_nolen |SV* sv
! Apd |char* |sv_2pvutf8_nolen|SV* sv
! Apd |char* |sv_2pvbyte_nolen|SV* sv
! Apd |char* |sv_pv |SV *sv
! Apd |char* |sv_pvutf8 |SV *sv
! Apd |char* |sv_pvbyte |SV *sv
! Aopd |STRLEN |sv_utf8_upgrade|SV *sv
ApdM |bool |sv_utf8_downgrade|SV *sv|bool fail_ok
Apd |void |sv_utf8_encode |SV *sv
ApdM |bool |sv_utf8_decode |SV *sv
! Apd |void |sv_force_normal|SV *sv
! Apd |void |sv_force_normal_flags|SV *sv|U32 flags
Ap |void |tmps_grow |I32 n
Apd |SV* |sv_rvweaken |SV *sv
p |int |magic_killbackrefs|SV *sv|MAGIC *mg
***************
*** 2214,2230 ****
p |OP * |my_attrs |OP *o|OP *attrs
p |void |boot_core_xsutils
#if defined(USE_ITHREADS)
! Ap |PERL_CONTEXT*|cx_dup |PERL_CONTEXT* cx|I32 ix|I32 max
! Ap |PERL_SI*|si_dup |PERL_SI* si
! Ap |ANY* |ss_dup |PerlInterpreter* proto_perl
Ap |void* |any_dup |void* v|PerlInterpreter* proto_perl
! Ap |HE* |he_dup |HE* e|bool shared
! Ap |REGEXP*|re_dup |REGEXP* r
Ap |PerlIO*|fp_dup |PerlIO* fp|char type
Ap |DIR* |dirp_dup |DIR* dp
! Ap |GP* |gp_dup |GP* gp
! Ap |MAGIC* |mg_dup |MAGIC* mg
! Ap |SV* |sv_dup |SV* sstr
#if defined(HAVE_INTERP_INTERN)
Ap |void |sys_intern_dup |struct interp_intern* src \
|struct interp_intern* dst
--- 2223,2239 ----
p |OP * |my_attrs |OP *o|OP *attrs
p |void |boot_core_xsutils
#if defined(USE_ITHREADS)
! Ap |PERL_CONTEXT*|cx_dup |PERL_CONTEXT* cx|I32 ix|I32 max|clone_params* param
! Ap |PERL_SI*|si_dup |PERL_SI* si|clone_params* param
! Ap |ANY* |ss_dup |PerlInterpreter* proto_perl|clone_params* param
Ap |void* |any_dup |void* v|PerlInterpreter* proto_perl
! Ap |HE* |he_dup |HE* e|bool shared|clone_params* param
! Ap |REGEXP*|re_dup |REGEXP* r|clone_params* param
Ap |PerlIO*|fp_dup |PerlIO* fp|char type
Ap |DIR* |dirp_dup |DIR* dp
! Ap |GP* |gp_dup |GP* gp|clone_params* param
! Ap |MAGIC* |mg_dup |MAGIC* mg|clone_params* param
! Ap |SV* |sv_dup |SV* sstr|clone_params* param
#if defined(HAVE_INTERP_INTERN)
Ap |void |sys_intern_dup |struct interp_intern* src \
|struct interp_intern* dst
***************
*** 2293,2300 ****
s |OP* |scalarboolean |OP *o
s |OP* |too_few_arguments|OP *o|char* name
s |OP* |too_many_arguments|OP *o|char* name
- s |void |op_clear |OP* o
- s |void |null |OP* o
s |PADOFFSET|pad_addlex |SV* name
s |PADOFFSET|pad_findlex |char* name|PADOFFSET newoff|U32 seq \
|CV* startcv|I32 cx_ix|I32 saweval|U32 flags
--- 2302,2307 ----
***************
*** 2351,2359 ****
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
- s |void |doencodes |SV* sv|char* s|I32 len
s |SV* |refto |SV* sv
s |U32 |seed
s |SV* |mul128 |SV *sv|U8 m
s |SV* |is_an_int |char *s|STRLEN l
s |int |div128 |SV *pnum|bool *done
--- 2358,2369 ----
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
s |SV* |refto |SV* sv
s |U32 |seed
+ #endif
+
+ #if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
+ s |void |doencodes |SV* sv|char* s|I32 len
s |SV* |mul128 |SV *sv|U8 m
s |SV* |is_an_int |char *s|STRLEN l
s |int |div128 |SV *pnum|bool *done
***************
*** 2409,2417 ****
--- 2419,2429 ----
s |void |regtail |struct RExC_state_t*|regnode *|regnode *
s |char*|regwhite |char *|char *
s |char*|nextchar |struct RExC_state_t*
+ # ifdef DEBUGGING
s |regnode*|dumpuntil |regnode *start|regnode *node \
|regnode *last|SV* sv|I32 l
s |void |put_byte |SV* sv|int c
+ # endif
s |void |scan_commit |struct RExC_state_t*|struct scan_data_t *data
s |void |cl_anything |struct RExC_state_t*|struct regnode_charclass_class *cl
s |int |cl_is_anything |struct regnode_charclass_class *cl
***************
*** 2448,2454 ****
--- 2460,2469 ----
#endif
#if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
+ # ifdef DEBUGGING
+ s |CV* |deb_curcv |I32 ix
s |void |debprof |OP *o
+ # endif
#endif
#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
***************
*** 2500,2510 ****
s |I32 |visit |SVFUNC_t f
s |void |sv_add_backref |SV *tsv|SV *sv
s |void |sv_del_backref |SV *sv
! # if defined(DEBUGGING)
s |void |del_sv |SV *p
# endif
# if !defined(NV_PRESERVES_UV)
- s |int |sv_2inuv_non_preserve |SV *sv|I32 numtype
s |int |sv_2iuv_non_preserve |SV *sv|I32 numtype
# endif
s |I32 |expect_number |char** pattern
--- 2515,2524 ----
s |I32 |visit |SVFUNC_t f
s |void |sv_add_backref |SV *tsv|SV *sv
s |void |sv_del_backref |SV *sv
! # ifdef DEBUGGING
s |void |del_sv |SV *p
# endif
# if !defined(NV_PRESERVES_UV)
s |int |sv_2iuv_non_preserve |SV *sv|I32 numtype
# endif
s |I32 |expect_number |char** pattern
***************
*** 2521,2526 ****
--- 2535,2541 ----
s |char* |force_word |char *start|int token|int check_keyword \
|int allow_pack|int allow_tick
s |SV* |tokeq |SV *sv
+ s |int |pending_ident
s |char* |scan_const |char *start
s |char* |scan_formline |char *s
s |char* |scan_heredoc |char *s
***************
*** 2551,2557 ****
--- 2566,2574 ----
s |HV * |find_in_my_stash|char *pkgname|I32 len
s |SV* |new_constant |char *s|STRLEN len|const char *key|SV *sv \
|SV *pv|const char *type
+ # if defined(DEBUGGING)
s |void |tokereport |char *thing|char *s|I32 rv
+ # endif
s |int |ao |int toketype
s |void |depcom
s |char* |incl_perldb
***************
*** 2571,2578 ****
s |SV*|isa_lookup |HV *stash|const char *name|int len|int level
#endif
! #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
s |char* |stdize_locale |char* locs
s |SV* |mess_alloc
# if defined(LEAKTEST)
s |void |xstat |int
--- 2588,2599 ----
s |SV*|isa_lookup |HV *stash|const char *name|int len|int level
#endif
! #if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT)
s |char* |stdize_locale |char* locs
+ #endif
+
+ #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
+ s |COP* |closest_cop |COP *cop|OP *o
s |SV* |mess_alloc
# if defined(LEAKTEST)
s |void |xstat |int
***************
*** 2582,2584 ****
--- 2603,2618 ----
#if defined(PERL_OBJECT)
};
#endif
+
+ START_EXTERN_C
+
+ Apd |void |sv_setsv_flags |SV* dsv|SV* ssv|I32 flags
+ Apd |void |sv_catpvn_flags|SV* sv|const char* ptr|STRLEN len|I32 flags
+ Apd |void |sv_catsv_flags |SV* dsv|SV* ssv|I32 flags
+ Apd |STRLEN |sv_utf8_upgrade_flags|SV *sv|I32 flags
+ Apd |char* |sv_pvn_force_flags|SV* sv|STRLEN* lp|I32 flags
+ Apd |char* |sv_2pv_flags |SV* sv|STRLEN* lp|I32 flags
+ Ap |char* |my_atof2 |const char *s|NV* value
+
+ END_EXTERN_C
+
diff -c 'perl-5.7.1/embedvar.h' 'perl-5.7.2/embedvar.h'
Index: ./embedvar.h
*** ./embedvar.h Fri Apr 6 16:42:03 2001
--- ./embedvar.h Thu Jul 12 21:34:40 2001
***************
*** 99,104 ****
--- 99,105 ----
#define PL_regcode (vTHX->Tregcode)
#define PL_regcomp_parse (vTHX->Tregcomp_parse)
#define PL_regcomp_rx (vTHX->Tregcomp_rx)
+ #define PL_regcompat1 (vTHX->Tregcompat1)
#define PL_regcompp (vTHX->Tregcompp)
#define PL_regdata (vTHX->Tregdata)
#define PL_regdummy (vTHX->Tregdummy)
***************
*** 112,123 ****
#define PL_regint_start (vTHX->Tregint_start)
#define PL_regint_string (vTHX->Tregint_string)
#define PL_reginterp_cnt (vTHX->Treginterp_cnt)
#define PL_reglastparen (vTHX->Treglastparen)
#define PL_regnarrate (vTHX->Tregnarrate)
#define PL_regnaughty (vTHX->Tregnaughty)
#define PL_regnpar (vTHX->Tregnpar)
#define PL_regprecomp (vTHX->Tregprecomp)
- #define PL_regprev (vTHX->Tregprev)
#define PL_regprogram (vTHX->Tregprogram)
#define PL_regsawback (vTHX->Tregsawback)
#define PL_regseen (vTHX->Tregseen)
--- 113,124 ----
#define PL_regint_start (vTHX->Tregint_start)
#define PL_regint_string (vTHX->Tregint_string)
#define PL_reginterp_cnt (vTHX->Treginterp_cnt)
+ #define PL_reglastcloseparen (vTHX->Treglastcloseparen)
#define PL_reglastparen (vTHX->Treglastparen)
#define PL_regnarrate (vTHX->Tregnarrate)
#define PL_regnaughty (vTHX->Tregnaughty)
#define PL_regnpar (vTHX->Tregnpar)
#define PL_regprecomp (vTHX->Tregprecomp)
#define PL_regprogram (vTHX->Tregprogram)
#define PL_regsawback (vTHX->Tregsawback)
#define PL_regseen (vTHX->Tregseen)
***************
*** 325,333 ****
#define PL_nthreads (PERL_GET_INTERP->Inthreads)
#define PL_nthreads_cond (PERL_GET_INTERP->Inthreads_cond)
#define PL_nullstash (PERL_GET_INTERP->Inullstash)
#define PL_numeric_local (PERL_GET_INTERP->Inumeric_local)
#define PL_numeric_name (PERL_GET_INTERP->Inumeric_name)
! #define PL_numeric_radix (PERL_GET_INTERP->Inumeric_radix)
#define PL_numeric_standard (PERL_GET_INTERP->Inumeric_standard)
#define PL_ofmt (PERL_GET_INTERP->Iofmt)
#define PL_oldbufptr (PERL_GET_INTERP->Ioldbufptr)
--- 326,335 ----
#define PL_nthreads (PERL_GET_INTERP->Inthreads)
#define PL_nthreads_cond (PERL_GET_INTERP->Inthreads_cond)
#define PL_nullstash (PERL_GET_INTERP->Inullstash)
+ #define PL_numeric_compat1 (PERL_GET_INTERP->Inumeric_compat1)
#define PL_numeric_local (PERL_GET_INTERP->Inumeric_local)
#define PL_numeric_name (PERL_GET_INTERP->Inumeric_name)
! #define PL_numeric_radix_sv (PERL_GET_INTERP->Inumeric_radix_sv)
#define PL_numeric_standard (PERL_GET_INTERP->Inumeric_standard)
#define PL_ofmt (PERL_GET_INTERP->Iofmt)
#define PL_oldbufptr (PERL_GET_INTERP->Ioldbufptr)
***************
*** 358,363 ****
--- 360,368 ----
#define PL_psig_pend (PERL_GET_INTERP->Ipsig_pend)
#define PL_psig_ptr (PERL_GET_INTERP->Ipsig_ptr)
#define PL_ptr_table (PERL_GET_INTERP->Iptr_table)
+ #define PL_reentrant_buffer (PERL_GET_INTERP->Ireentrant_buffer)
+ #define PL_regex_pad (PERL_GET_INTERP->Iregex_pad)
+ #define PL_regex_padav (PERL_GET_INTERP->Iregex_padav)
#define PL_replgv (PERL_GET_INTERP->Ireplgv)
#define PL_rsfp (PERL_GET_INTERP->Irsfp)
#define PL_rsfp_filters (PERL_GET_INTERP->Irsfp_filters)
***************
*** 606,614 ****
#define PL_nthreads (vTHX->Inthreads)
#define PL_nthreads_cond (vTHX->Inthreads_cond)
#define PL_nullstash (vTHX->Inullstash)
#define PL_numeric_local (vTHX->Inumeric_local)
#define PL_numeric_name (vTHX->Inumeric_name)
! #define PL_numeric_radix (vTHX->Inumeric_radix)
#define PL_numeric_standard (vTHX->Inumeric_standard)
#define PL_ofmt (vTHX->Iofmt)
#define PL_oldbufptr (vTHX->Ioldbufptr)
--- 611,620 ----
#define PL_nthreads (vTHX->Inthreads)
#define PL_nthreads_cond (vTHX->Inthreads_cond)
#define PL_nullstash (vTHX->Inullstash)
+ #define PL_numeric_compat1 (vTHX->Inumeric_compat1)
#define PL_numeric_local (vTHX->Inumeric_local)
#define PL_numeric_name (vTHX->Inumeric_name)
! #define PL_numeric_radix_sv (vTHX->Inumeric_radix_sv)
#define PL_numeric_standard (vTHX->Inumeric_standard)
#define PL_ofmt (vTHX->Iofmt)
#define PL_oldbufptr (vTHX->Ioldbufptr)
***************
*** 639,644 ****
--- 645,653 ----
#define PL_psig_pend (vTHX->Ipsig_pend)
#define PL_psig_ptr (vTHX->Ipsig_ptr)
#define PL_ptr_table (vTHX->Iptr_table)
+ #define PL_reentrant_buffer (vTHX->Ireentrant_buffer)
+ #define PL_regex_pad (vTHX->Iregex_pad)
+ #define PL_regex_padav (vTHX->Iregex_padav)
#define PL_replgv (vTHX->Ireplgv)
#define PL_rsfp (vTHX->Irsfp)
#define PL_rsfp_filters (vTHX->Irsfp_filters)
***************
*** 805,810 ****
--- 814,820 ----
#define PL_regcode (aTHXo->interp.Tregcode)
#define PL_regcomp_parse (aTHXo->interp.Tregcomp_parse)
#define PL_regcomp_rx (aTHXo->interp.Tregcomp_rx)
+ #define PL_regcompat1 (aTHXo->interp.Tregcompat1)
#define PL_regcompp (aTHXo->interp.Tregcompp)
#define PL_regdata (aTHXo->interp.Tregdata)
#define PL_regdummy (aTHXo->interp.Tregdummy)
***************
*** 818,829 ****
#define PL_regint_start (aTHXo->interp.Tregint_start)
#define PL_regint_string (aTHXo->interp.Tregint_string)
#define PL_reginterp_cnt (aTHXo->interp.Treginterp_cnt)
#define PL_reglastparen (aTHXo->interp.Treglastparen)
#define PL_regnarrate (aTHXo->interp.Tregnarrate)
#define PL_regnaughty (aTHXo->interp.Tregnaughty)
#define PL_regnpar (aTHXo->interp.Tregnpar)
#define PL_regprecomp (aTHXo->interp.Tregprecomp)
- #define PL_regprev (aTHXo->interp.Tregprev)
#define PL_regprogram (aTHXo->interp.Tregprogram)
#define PL_regsawback (aTHXo->interp.Tregsawback)
#define PL_regseen (aTHXo->interp.Tregseen)
--- 828,839 ----
#define PL_regint_start (aTHXo->interp.Tregint_start)
#define PL_regint_string (aTHXo->interp.Tregint_string)
#define PL_reginterp_cnt (aTHXo->interp.Treginterp_cnt)
+ #define PL_reglastcloseparen (aTHXo->interp.Treglastcloseparen)
#define PL_reglastparen (aTHXo->interp.Treglastparen)
#define PL_regnarrate (aTHXo->interp.Tregnarrate)
#define PL_regnaughty (aTHXo->interp.Tregnaughty)
#define PL_regnpar (aTHXo->interp.Tregnpar)
#define PL_regprecomp (aTHXo->interp.Tregprecomp)
#define PL_regprogram (aTHXo->interp.Tregprogram)
#define PL_regsawback (aTHXo->interp.Tregsawback)
#define PL_regseen (aTHXo->interp.Tregseen)
***************
*** 1023,1031 ****
#define PL_nthreads (aTHXo->interp.Inthreads)
#define PL_nthreads_cond (aTHXo->interp.Inthreads_cond)
#define PL_nullstash (aTHXo->interp.Inullstash)
#define PL_numeric_local (aTHXo->interp.Inumeric_local)
#define PL_numeric_name (aTHXo->interp.Inumeric_name)
! #define PL_numeric_radix (aTHXo->interp.Inumeric_radix)
#define PL_numeric_standard (aTHXo->interp.Inumeric_standard)
#define PL_ofmt (aTHXo->interp.Iofmt)
#define PL_oldbufptr (aTHXo->interp.Ioldbufptr)
--- 1033,1042 ----
#define PL_nthreads (aTHXo->interp.Inthreads)
#define PL_nthreads_cond (aTHXo->interp.Inthreads_cond)
#define PL_nullstash (aTHXo->interp.Inullstash)
+ #define PL_numeric_compat1 (aTHXo->interp.Inumeric_compat1)
#define PL_numeric_local (aTHXo->interp.Inumeric_local)
#define PL_numeric_name (aTHXo->interp.Inumeric_name)
! #define PL_numeric_radix_sv (aTHXo->interp.Inumeric_radix_sv)
#define PL_numeric_standard (aTHXo->interp.Inumeric_standard)
#define PL_ofmt (aTHXo->interp.Iofmt)
#define PL_oldbufptr (aTHXo->interp.Ioldbufptr)
***************
*** 1056,1061 ****
--- 1067,1075 ----
#define PL_psig_pend (aTHXo->interp.Ipsig_pend)
#define PL_psig_ptr (aTHXo->interp.Ipsig_ptr)
#define PL_ptr_table (aTHXo->interp.Iptr_table)
+ #define PL_reentrant_buffer (aTHXo->interp.Ireentrant_buffer)
+ #define PL_regex_pad (aTHXo->interp.Iregex_pad)
+ #define PL_regex_padav (aTHXo->interp.Iregex_padav)
#define PL_replgv (aTHXo->interp.Ireplgv)
#define PL_rsfp (aTHXo->interp.Irsfp)
#define PL_rsfp_filters (aTHXo->interp.Irsfp_filters)
***************
*** 1305,1313 ****
#define PL_Inthreads PL_nthreads
#define PL_Inthreads_cond PL_nthreads_cond
#define PL_Inullstash PL_nullstash
#define PL_Inumeric_local PL_numeric_local
#define PL_Inumeric_name PL_numeric_name
! #define PL_Inumeric_radix PL_numeric_radix
#define PL_Inumeric_standard PL_numeric_standard
#define PL_Iofmt PL_ofmt
#define PL_Ioldbufptr PL_oldbufptr
--- 1319,1328 ----
#define PL_Inthreads PL_nthreads
#define PL_Inthreads_cond PL_nthreads_cond
#define PL_Inullstash PL_nullstash
+ #define PL_Inumeric_compat1 PL_numeric_compat1
#define PL_Inumeric_local PL_numeric_local
#define PL_Inumeric_name PL_numeric_name
! #define PL_Inumeric_radix_sv PL_numeric_radix_sv
#define PL_Inumeric_standard PL_numeric_standard
#define PL_Iofmt PL_ofmt
#define PL_Ioldbufptr PL_oldbufptr
***************
*** 1338,1343 ****
--- 1353,1361 ----
#define PL_Ipsig_pend PL_psig_pend
#define PL_Ipsig_ptr PL_psig_ptr
#define PL_Iptr_table PL_ptr_table
+ #define PL_Ireentrant_buffer PL_reentrant_buffer
+ #define PL_Iregex_pad PL_regex_pad
+ #define PL_Iregex_padav PL_regex_padav
#define PL_Ireplgv PL_replgv
#define PL_Irsfp PL_rsfp
#define PL_Irsfp_filters PL_rsfp_filters
***************
*** 1500,1505 ****
--- 1518,1524 ----
#define PL_regcode (aTHX->Tregcode)
#define PL_regcomp_parse (aTHX->Tregcomp_parse)
#define PL_regcomp_rx (aTHX->Tregcomp_rx)
+ #define PL_regcompat1 (aTHX->Tregcompat1)
#define PL_regcompp (aTHX->Tregcompp)
#define PL_regdata (aTHX->Tregdata)
#define PL_regdummy (aTHX->Tregdummy)
***************
*** 1513,1524 ****
#define PL_regint_start (aTHX->Tregint_start)
#define PL_regint_string (aTHX->Tregint_string)
#define PL_reginterp_cnt (aTHX->Treginterp_cnt)
#define PL_reglastparen (aTHX->Treglastparen)
#define PL_regnarrate (aTHX->Tregnarrate)
#define PL_regnaughty (aTHX->Tregnaughty)
#define PL_regnpar (aTHX->Tregnpar)
#define PL_regprecomp (aTHX->Tregprecomp)
- #define PL_regprev (aTHX->Tregprev)
#define PL_regprogram (aTHX->Tregprogram)
#define PL_regsawback (aTHX->Tregsawback)
#define PL_regseen (aTHX->Tregseen)
--- 1532,1543 ----
#define PL_regint_start (aTHX->Tregint_start)
#define PL_regint_string (aTHX->Tregint_string)
#define PL_reginterp_cnt (aTHX->Treginterp_cnt)
+ #define PL_reglastcloseparen (aTHX->Treglastcloseparen)
#define PL_reglastparen (aTHX->Treglastparen)
#define PL_regnarrate (aTHX->Tregnarrate)
#define PL_regnaughty (aTHX->Tregnaughty)
#define PL_regnpar (aTHX->Tregnpar)
#define PL_regprecomp (aTHX->Tregprecomp)
#define PL_regprogram (aTHX->Tregprogram)
#define PL_regsawback (aTHX->Tregsawback)
#define PL_regseen (aTHX->Tregseen)
***************
*** 1636,1641 ****
--- 1655,1661 ----
#define PL_Tregcode PL_regcode
#define PL_Tregcomp_parse PL_regcomp_parse
#define PL_Tregcomp_rx PL_regcomp_rx
+ #define PL_Tregcompat1 PL_regcompat1
#define PL_Tregcompp PL_regcompp
#define PL_Tregdata PL_regdata
#define PL_Tregdummy PL_regdummy
***************
*** 1649,1660 ****
#define PL_Tregint_start PL_regint_start
#define PL_Tregint_string PL_regint_string
#define PL_Treginterp_cnt PL_reginterp_cnt
#define PL_Treglastparen PL_reglastparen
#define PL_Tregnarrate PL_regnarrate
#define PL_Tregnaughty PL_regnaughty
#define PL_Tregnpar PL_regnpar
#define PL_Tregprecomp PL_regprecomp
- #define PL_Tregprev PL_regprev
#define PL_Tregprogram PL_regprogram
#define PL_Tregsawback PL_regsawback
#define PL_Tregseen PL_regseen
--- 1669,1680 ----
#define PL_Tregint_start PL_regint_start
#define PL_Tregint_string PL_regint_string
#define PL_Treginterp_cnt PL_reginterp_cnt
+ #define PL_Treglastcloseparen PL_reglastcloseparen
#define PL_Treglastparen PL_reglastparen
#define PL_Tregnarrate PL_regnarrate
#define PL_Tregnaughty PL_regnaughty
#define PL_Tregnpar PL_regnpar
#define PL_Tregprecomp PL_regprecomp
#define PL_Tregprogram PL_regprogram
#define PL_Tregsawback PL_regsawback
#define PL_Tregseen PL_regseen
diff -c 'perl-5.7.1/epoc/config.sh' 'perl-5.7.2/epoc/config.sh'
Index: ./epoc/config.sh
*** ./epoc/config.sh Sun Apr 8 01:56:59 2001
--- ./epoc/config.sh Fri Jul 13 03:15:39 2001
***************
*** 25,30 ****
--- 25,31 ----
_exe='.exe'
_o='.o'
afs='false'
+ afsroot='/afs'
alignbytes='8'
ansi2knr=''
aphostname=''
***************
*** 32,39 ****
apisubversion=''
apiversion=''
ar='arm-pe-ar'
! archlib='?:/perl/lib/5.7.1/epoc'
! archlibexp='?:/perl/lib/5.7.1/epoc'
archname64=''
archname='epoc'
archobjs='epoc.o epocish.o epoc_stubs.o'
--- 33,40 ----
apisubversion=''
apiversion=''
ar='arm-pe-ar'
! archlib='?:/perl/lib/5.7.2/epoc'
! archlibexp='?:/perl/lib/5.7.2/epoc'
archname64=''
archname='epoc'
archobjs='epoc.o epocish.o epoc_stubs.o'
***************
*** 75,84 ****
cpprun='arm-pe-gcc -E -B/usr/local/lib/gcc-lib/arm-pe/cygnus-2.7.2-960323/'
cppstdin='arm-pe-gcc -E -B/usr/local/lib/gcc-lib/arm-pe/cygnus-2.7.2-960323/'
cppsymbols=''
- crosscompile='define'
cryptlib=''
csh='csh'
- d__fwalk='undef'
d_Gconvert='epoc_gcvt((x),(n),(b))'
d_PRIEUldbl='undef'
d_PRIFUldbl='undef'
--- 76,83 ----
***************
*** 92,97 ****
--- 91,97 ----
d_PRIo64='undef'
d_PRIu64='undef'
d_PRIx64='undef'
+ d__fwalk='undef'
d_access='undef'
d_accessx='undef'
d_alarm='undef'
***************
*** 114,125 ****
d_chsize='undef'
d_closedir='undef'
d_cmsghdr_s='undef'
- d_const='define'
d_cmsghdr_s='undef'
d_crypt='undef'
d_csh='undef'
d_cuserid='undef'
d_dbl_dig='undef'
d_difftime='define'
d_dirnamlen='undef'
d_dlerror='undef'
--- 114,126 ----
d_chsize='undef'
d_closedir='undef'
d_cmsghdr_s='undef'
d_cmsghdr_s='undef'
+ d_const='define'
d_crypt='undef'
d_csh='undef'
d_cuserid='undef'
d_dbl_dig='undef'
+ d_dbminitproto='undef'
d_difftime='define'
d_dirnamlen='undef'
d_dlerror='undef'
***************
*** 137,142 ****
--- 138,144 ----
d_endsent='undef'
d_eofnblk='define'
d_eunice='undef'
+ d_fchdir='undef'
d_fchmod='undef'
d_fchown='undef'
d_fcntl='undef'
***************
*** 147,152 ****
--- 149,155 ----
d_fgetpos='define'
d_flexfnam='define'
d_flock='undef'
+ d_flockproto='undef'
d_fork='undef'
d_fpathconf='undef'
d_fpos64_t='undef'
***************
*** 229,234 ****
--- 232,238 ----
d_mktime='define'
d_mmap='undef'
d_modfl='undef'
+ d_modfl_pow32_bug='undef'
d_mprotect='undef'
d_msg='undef'
d_msg_ctrunc='undef'
***************
*** 237,245 ****
d_msg_peek='undef'
d_msg_proxy='undef'
d_msgctl='undef'
- d_msghdr_s='undef'
d_msgget='undef'
d_msghdr_s='undef'
d_msgrcv='undef'
d_msgsnd='undef'
d_msync='undef'
--- 241,249 ----
d_msg_peek='undef'
d_msg_proxy='undef'
d_msgctl='undef'
d_msgget='undef'
d_msghdr_s='undef'
+ d_msghdr_s='undef'
d_msgrcv='undef'
d_msgsnd='undef'
d_msync='undef'
***************
*** 246,251 ****
--- 250,256 ----
d_munmap='undef'
d_mymalloc='undef'
d_nice='undef'
+ d_nl_langinfo='undef'
d_off64_t='undef'
d_old_pthread_create_joinable='undef'
d_oldpthreads='undef'
***************
*** 258,263 ****
--- 263,269 ----
d_pipe='undef'
d_poll='undef'
d_portable='undef'
+ d_pthread_atfork='undef'
d_pthread_yield='undef'
d_pwage='undef'
d_pwchange='undef'
***************
*** 271,279 ****
d_readdir='define'
d_readlink='undef'
d_readv='undef'
- d_recvmsg='undef'
d_readv='undef'
d_recvmsg='undef'
d_rename='define'
d_rewinddir='define'
d_rmdir='define'
--- 277,285 ----
d_readdir='define'
d_readlink='undef'
d_readv='undef'
d_readv='undef'
d_recvmsg='undef'
+ d_recvmsg='undef'
d_rename='define'
d_rewinddir='define'
d_rmdir='define'
***************
*** 305,312 ****
d_setpgid='undef'
d_setpgrp2='undef'
d_setpgrp='undef'
- d_setproctitle='undef'
d_setprior='undef'
d_setpwent='undef'
d_setregid='undef'
d_setresgid='undef'
--- 311,318 ----
d_setpgid='undef'
d_setpgrp2='undef'
d_setpgrp='undef'
d_setprior='undef'
+ d_setproctitle='undef'
d_setpwent='undef'
d_setregid='undef'
d_setresgid='undef'
***************
*** 328,336 ****
--- 334,345 ----
d_sigprocmask='undef'
d_sigsetjmp='undef'
d_sockatmark='undef'
+ d_sockatmarkproto='undef'
d_socket='define'
d_sockpair='undef'
d_socks5_init='undef'
+ d_sresgproto='undef'
+ d_sresuproto='undef'
d_statblks='define'
d_statfs='undef'
d_statfsflags='define'
***************
*** 337,344 ****
d_statvfs='undef'
d_stdio_cnt_lval='define'
d_stdio_ptr_lval='define'
- d_stdio_ptr_lval_sets_cnt='undef'
d_stdio_ptr_lval_nochange_cnt='undef'
d_stdio_stream_array='undef'
d_stdiobase='undef'
d_stdstdio='undef'
--- 346,353 ----
d_statvfs='undef'
d_stdio_cnt_lval='define'
d_stdio_ptr_lval='define'
d_stdio_ptr_lval_nochange_cnt='undef'
+ d_stdio_ptr_lval_sets_cnt='undef'
d_stdio_stream_array='undef'
d_stdiobase='undef'
d_stdstdio='undef'
***************
*** 347,362 ****
d_strctcpy='define'
d_strerrm='strerror(e)'
d_strerror='define'
d_strtod='define'
d_strtol='define'
d_strtoq='undef'
d_strtoul='define'
- d_strtouq='undef'
d_strtoull='undef'
d_strxfrm='define'
d_suidsafe='undef'
d_symlink='undef'
d_syscall='undef'
d_sysconf='define'
d_sysernlst='undef'
d_syserrlst='undef'
--- 356,373 ----
d_strctcpy='define'
d_strerrm='strerror(e)'
d_strerror='define'
+ d_strftime='define'
d_strtod='define'
d_strtol='define'
d_strtoq='undef'
d_strtoul='define'
d_strtoull='undef'
+ d_strtouq='undef'
d_strxfrm='define'
d_suidsafe='undef'
d_symlink='undef'
d_syscall='undef'
+ d_syscallproto='undef'
d_sysconf='define'
d_sysernlst='undef'
d_syserrlst='undef'
***************
*** 374,379 ****
--- 385,391 ----
d_umask='undef'
d_uname='undef'
d_union_semun='undef'
+ d_usleepproto='undef'
d_vendorlib='undef'
d_vfork='undef'
d_void_closedir='undef'
***************
*** 405,411 ****
eunicefix=':'
exe_ext=''
expr='expr'
! extensions='Data/Dumper Digest/MD5 Errno Fcntl File/Glob Filter::Util::Call IO MIME::Base64 Opcode PerlIO::Scalar Socket Storable Sys/Hostname attrs re'
fflushNULL='undef'
fflushall='define'
find=''
--- 417,423 ----
eunicefix=':'
exe_ext=''
expr='expr'
! extensions='Data/Dumper Digest/MD5 Errno Fcntl File/Glob Filter/Util/Call IO List/Util MIME/Base64 Opcode PerlIO/Scalar Socket Storable Sys/Hostname Time/Piece attrs re'
fflushNULL='undef'
fflushall='define'
find=''
***************
*** 441,446 ****
--- 453,459 ----
i_iconv='undef'
i_ieeefp='undef'
i_inttypes='undef'
+ i_langinfo='undef'
i_libutil='undef'
i_limits='define'
i_locale='undef'
***************
*** 619,626 ****
pr=''
prefix=''
prefixexp=''
! privlib='?:/perl/lib/5.7.1'
! privlibexp='?:/perl/lib/5.7.1'
prototype='define'
ptrsize='4'
randbits='31'
--- 632,639 ----
pr=''
prefix=''
prefixexp=''
! privlib='?:/perl/lib/5.7.2'
! privlibexp='?:/perl/lib/5.7.2'
prototype='define'
ptrsize='4'
randbits='31'
***************
*** 664,674 ****
sig_num_init='0, 0'
sig_size='1'
signal_t='void'
! sitearch='?:/perl/lib/site_perl/5.7.1/epoc'
! sitearchexp='?:/perl/lib/site_perl/5.7.1/epoc'
! sitelib='?:/perl/lib/site_perl/5.7.1/'
sitelib_stem='?:/perl/lib/site_perl'
! sitelibexp='?:/perl/lib/site_perl/5.7.1/'
siteprefix=''
siteprefixexp=''
sizesize='4'
--- 677,687 ----
sig_num_init='0, 0'
sig_size='1'
signal_t='void'
! sitearch='?:/perl/lib/site_perl/5.7.2/epoc'
! sitearchexp='?:/perl/lib/site_perl/5.7.2/epoc'
! sitelib='?:/perl/lib/site_perl/5.7.2/'
sitelib_stem='?:/perl/lib/site_perl'
! sitelibexp='?:/perl/lib/site_perl/5.7.2/'
siteprefix=''
siteprefixexp=''
sizesize='4'
***************
*** 715,720 ****
--- 728,734 ----
uniq='uniq'
use64bitall='undef'
use64bitint='undef'
+ usecrosscompile='define'
usedl='undef'
uselargefiles='undef'
uselongdouble='undef'
***************
*** 725,730 ****
--- 739,745 ----
useopcode=''
useperlio='undef'
useposix=''
+ usereentrant='undef'
usesfio=''
useshrplib=''
usesocks='undef'
***************
*** 738,744 ****
vendorlibexp=''
vendorprefix=''
vendorprefixexp=''
! version='5.7.1'
versiononly='undef'
vi=''
voidflags='15'
--- 753,759 ----
vendorlibexp=''
vendorprefix=''
vendorprefixexp=''
! version='5.7.2'
versiononly='undef'
vi=''
voidflags='15'
***************
*** 766,772 ****
PERL_API_REVISION=5
PERL_API_VERSION=6
PERL_API_SUBVERSION=0
! CONFIGDOTSH=true
# Variables propagated from previous config.sh file.
pp_sys_cflags=''
epocish_cflags='ccflags="$cflags -xc++"'
--- 781,787 ----
PERL_API_REVISION=5
PERL_API_VERSION=6
PERL_API_SUBVERSION=0
! PERL_CONFIG_SH=true
# Variables propagated from previous config.sh file.
pp_sys_cflags=''
epocish_cflags='ccflags="$cflags -xc++"'
***************
*** 871,877 ****
vendorlibexp=''
vendorprefix=''
vendorprefixexp=''
! version='5.7.1'
vi=''
voidflags='15'
xlibpth=''
--- 886,892 ----
vendorlibexp=''
vendorprefix=''
vendorprefixexp=''
! version='5.7.2'
vi=''
voidflags='15'
xlibpth=''
diff -c 'perl-5.7.1/epoc/epocish.h' 'perl-5.7.2/epoc/epocish.h'
Index: ./epoc/epocish.h
*** ./epoc/epocish.h Tue Mar 6 04:04:27 2001
--- ./epoc/epocish.h Mon Jul 9 17:09:50 2001
***************
*** 143,145 ****
--- 143,148 ----
#define init_os_extras Perl_init_os_extras
#define NO_ENVIRON_ARRAY
+
+ #define ARG_MAX 4096
+
diff -c 'perl-5.7.1/ext/B/B.pm' 'perl-5.7.2/ext/B/B.pm'
Index: ./ext/B/B.pm
*** ./ext/B/B.pm Thu Apr 5 21:28:14 2001
--- ./ext/B/B.pm Mon Jul 9 17:09:50 2001
***************
*** 66,72 ****
# The regex below corresponds to the isCONTROLVAR macro
# from toke.c
! $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".chr(64 ^ ord($1))/e;
return $name;
}
--- 66,77 ----
# The regex below corresponds to the isCONTROLVAR macro
# from toke.c
! $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".
! chr( utf8::unicode_to_native( 64 ^ ord($1) ))/e;
!
! # When we say unicode_to_native we really mean ascii_to_native,
! # which matters iff this is a non-ASCII platform (EBCDIC).
!
return $name;
}
***************
*** 75,80 ****
--- 80,89 ----
return (($self->FLAGS() & SVf_IVisUV()) ? $self->UVX : $self->IV);
}
+ sub B::NULL::as_string() {""}
+ sub B::IV::as_string() {goto &B::IV::int_value}
+ sub B::PV::as_string() {goto &B::PV::PV}
+
my $debug;
my $op_count = 0;
my @parents = ();
***************
*** 834,845 ****
the description of C<walkoptree> above for what the debugging flag
does.
! =item walksymtable(SYMREF, METHOD, RECURSE)
Walk the symbol table starting at SYMREF and call METHOD on each
! symbol visited. When the walk reached package symbols "Foo::" it
! invokes RECURSE and only recurses into the package if that sub
! returns true.
=item svref_2object(SV)
--- 843,866 ----
the description of C<walkoptree> above for what the debugging flag
does.
! =item walksymtable(SYMREF, METHOD, RECURSE, PREFIX)
Walk the symbol table starting at SYMREF and call METHOD on each
! symbol (a B::GV object) visited. When the walk reaches package
! symbols (such as "Foo::") it invokes RECURSE, passing in the symbol
! name, and only recurses into the package if that sub returns true.
!
! PREFIX is the name of the SYMREF you're walking.
!
! For example...
!
! # Walk CGI's symbol table calling print_subs on each symbol.
! # Only recurse into CGI::Util::
! walksymtable(\%CGI::, 'print_subs', sub { $_[0] eq 'CGI::Util::' },
! 'CGI::');
!
! print_subs() is a B::GV method you have declared.
!
=item svref_2object(SV)
diff -c /dev/null 'perl-5.7.2/ext/B/B.t'
Index: ./ext/B/B.t
*** ./ext/B/B.t Thu Jan 1 02:00:00 1970
--- ./ext/B/B.t Mon Jul 9 17:09:50 2001
***************
*** 0 ****
--- 1,63 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ } else {
+ @INC = '.';
+ push @INC, '../lib';
+ }
+ }
+
+ $| = 1;
+ use warnings;
+ use strict;
+ use Config;
+
+ print "1..2\n";
+
+ my $test = 1;
+
+ sub ok { print "ok $test\n"; $test++ }
+
+ use B;
+
+
+ package Testing::Symtable;
+ use vars qw($This @That %wibble $moo %moo);
+ my $not_a_sym = 'moo';
+
+ sub moo { 42 }
+ sub car { 23 }
+
+
+ package Testing::Symtable::Foo;
+ sub yarrow { "Hock" }
+
+ package Testing::Symtable::Bar;
+ sub hock { "yarrow" }
+
+ package main;
+ use vars qw(%Subs);
+ local %Subs = ();
+ B::walksymtable(\%Testing::Symtable::, 'find_syms', sub { $_[0] =~ /Foo/ },
+ 'Testing::Symtable::');
+
+ sub B::GV::find_syms {
+ my($symbol) = @_;
+
+ $main::Subs{$symbol->STASH->NAME . '::' . $symbol->NAME}++;
+ }
+
+ my @syms = map { 'Testing::Symtable::'.$_ } qw(This That wibble moo car
+ BEGIN);
+ push @syms, "Testing::Symtable::Foo::yarrow";
+
+ # Make sure we hit all the expected symbols.
+ print "not " unless join('', sort @syms) eq join('', sort keys %Subs);
+ ok;
+
+ # Make sure we only hit them each once.
+ print "not " unless !grep $_ != 1, values %Subs;
+ ok;
diff -c 'perl-5.7.1/ext/B/B.xs' 'perl-5.7.2/ext/B/B.xs'
Index: ./ext/B/B.xs
*** ./ext/B/B.xs Thu Apr 5 06:53:18 2001
--- ./ext/B/B.xs Mon Jul 9 17:09:50 2001
***************
*** 667,673 ****
#define PMOP_pmreplroot(o) o->op_pmreplroot
#define PMOP_pmreplstart(o) o->op_pmreplstart
#define PMOP_pmnext(o) o->op_pmnext
! #define PMOP_pmregexp(o) o->op_pmregexp
#define PMOP_pmflags(o) o->op_pmflags
#define PMOP_pmpermflags(o) o->op_pmpermflags
--- 667,673 ----
#define PMOP_pmreplroot(o) o->op_pmreplroot
#define PMOP_pmreplstart(o) o->op_pmreplstart
#define PMOP_pmnext(o) o->op_pmnext
! #define PMOP_pmregexp(o) PM_GETRE(o)
#define PMOP_pmflags(o) o->op_pmflags
#define PMOP_pmpermflags(o) o->op_pmpermflags
***************
*** 712,718 ****
REGEXP * rx = NO_INIT
CODE:
ST(0) = sv_newmortal();
! rx = o->op_pmregexp;
if (rx)
sv_setpvn(ST(0), rx->precomp, rx->prelen);
--- 712,718 ----
REGEXP * rx = NO_INIT
CODE:
ST(0) = sv_newmortal();
! rx = PM_GETRE(o);
if (rx)
sv_setpvn(ST(0), rx->precomp, rx->prelen);
***************
*** 756,766 ****
B::PVOP o
CODE:
/*
! * OP_TRANS uses op_pv to point to a table of 256 shorts
* whereas other PVOPs point to a null terminated string.
*/
! ST(0) = sv_2mortal(newSVpv(o->op_pv, (o->op_type == OP_TRANS) ?
! 256 * sizeof(short) : 0));
#define LOOP_redoop(o) o->op_redoop
#define LOOP_nextop(o) o->op_nextop
--- 756,777 ----
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_private & OPpTRANS_COMPLEMENT) &&
! !(o->op_private & OPpTRANS_DELETE))
! {
! short* tbl = (short*)o->op_pv;
! short entries = 257 + tbl[256];
! ST(0) = sv_2mortal(newSVpv(o->op_pv, entries * sizeof(short)));
! }
! else if (o->op_type == OP_TRANS) {
! ST(0) = sv_2mortal(newSVpv(o->op_pv, 256 * sizeof(short)));
! }
! else
! ST(0) = sv_2mortal(newSVpv(o->op_pv, 0));
#define LOOP_redoop(o) o->op_redoop
#define LOOP_nextop(o) o->op_nextop
***************
*** 911,916 ****
--- 922,928 ----
CODE:
ST(0) = sv_newmortal();
sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv));
+ SvFLAGS(ST(0)) |= SvUTF8(sv);
STRLEN
SvLEN(sv)
diff -c 'perl-5.7.1/ext/B/B/Assembler.pm' 'perl-5.7.2/ext/B/B/Assembler.pm'
Index: ./ext/B/B/Assembler.pm
*** ./ext/B/B/Assembler.pm Tue Mar 6 04:04:28 2001
--- ./ext/B/B/Assembler.pm Mon Jul 9 17:09:50 2001
***************
*** 55,61 ****
sub B::Asmdata::PUT_U16 { pack("S", $_[0]) }
sub B::Asmdata::PUT_U32 { pack("L", $_[0]) }
sub B::Asmdata::PUT_I32 { pack("L", $_[0]) }
! sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...)
# may not even be portable between compilers
sub B::Asmdata::PUT_objindex { pack("L", $_[0]) } # could allow names here
sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
--- 55,61 ----
sub B::Asmdata::PUT_U16 { pack("S", $_[0]) }
sub B::Asmdata::PUT_U32 { pack("L", $_[0]) }
sub B::Asmdata::PUT_I32 { pack("L", $_[0]) }
! sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" loses precision and pack('d',...)
# may not even be portable between compilers
sub B::Asmdata::PUT_objindex { pack("L", $_[0]) } # could allow names here
sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
diff -c 'perl-5.7.1/ext/B/B/C.pm' 'perl-5.7.2/ext/B/B/C.pm'
Index: ./ext/B/B/C.pm
*** ./ext/B/B/C.pm Thu Apr 5 06:53:26 2001
--- ./ext/B/B/C.pm Mon Jul 9 17:09:50 2001
***************
*** 362,368 ****
if (defined($re)) {
my $resym = sprintf("re%d", $re_index++);
$decl->add(sprintf("static char *$resym = %s;", cstring($re)));
! $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
length($re)));
}
if ($gvsym) {
--- 362,368 ----
if (defined($re)) {
my $resym = sprintf("re%d", $re_index++);
$decl->add(sprintf("static char *$resym = %s;", cstring($re)));
! $init->add(sprintf("PM_SETRE(&$pm,pregcomp($resym, $resym + %u, &$pm));",
length($re)));
}
if ($gvsym) {
diff -c 'perl-5.7.1/ext/B/B/Concise.pm' 'perl-5.7.2/ext/B/B/Concise.pm'
Index: ./ext/B/B/Concise.pm
*** ./ext/B/B/Concise.pm Thu Apr 5 21:21:50 2001
--- ./ext/B/B/Concise.pm Mon Jul 9 17:09:50 2001
***************
*** 3,10 ****
# This program is free software; you can redistribute and/or modify it
# under the same terms as Perl itself.
- our $VERSION = "0.51";
use strict;
use B qw(class ppname main_start main_root main_cv cstring svref_2object
SVf_IOK SVf_NOK SVf_POK OPf_KIDS);
--- 3,17 ----
# This program is free software; you can redistribute and/or modify it
# under the same terms as Perl itself.
use strict;
+ use warnings;
+
+ use Exporter ();
+
+ our $VERSION = "0.52";
+ our @ISA = qw(Exporter);
+ our @EXPORT_OK = qw(set_style add_callback);
+
use B qw(class ppname main_start main_root main_cv cstring svref_2object
SVf_IOK SVf_NOK SVf_POK OPf_KIDS);
***************
*** 38,44 ****
--- 45,60 ----
my($format, $gotofmt, $treefmt);
my $curcv;
my($seq_base, $cop_seq_base);
+ my @callbacks;
+ sub set_style {
+ ($format, $gotofmt, $treefmt) = @_;
+ }
+
+ sub add_callback {
+ push @callbacks, @_;
+ }
+
sub concise_cv {
my ($order, $cvref) = @_;
my $cv = svref_2object($cvref);
***************
*** 68,78 ****
my $order = "basic";
sub compile {
my @options = grep(/^-/, @_);
my @args = grep(!/^-/, @_);
my $do_main = 0;
- ($format, $gotofmt, $treefmt) = @{$style{"concise"}};
for my $o (@options) {
if ($o eq "-basic") {
$order = "basic";
--- 84,95 ----
my $order = "basic";
+ set_style(@{$style{concise}});
+
sub compile {
my @options = grep(/^-/, @_);
my @args = grep(!/^-/, @_);
my $do_main = 0;
for my $o (@options) {
if ($o eq "-basic") {
$order = "basic";
***************
*** 97,103 ****
} elsif ($o eq "-littleendian") {
$big_endian = 0;
} elsif (exists $style{substr($o, 1)}) {
! ($format, $gotofmt, $treefmt) = @{$style{substr($o, 1)}};
} else {
warn "Option $o unrecognized";
}
--- 114,120 ----
} elsif ($o eq "-littleendian") {
$big_endian = 0;
} elsif (exists $style{substr($o, 1)}) {
! set_style(@{$style{substr($o, 1)}});
} else {
warn "Option $o unrecognized";
}
***************
*** 136,141 ****
--- 153,159 ----
'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*",
'PVOP' => '"', 'LOOP' => "{", 'COP' => ";");
+ no warnings 'qw'; # "Possible attempt to put comments..."
my @linenoise =
qw'# () sc ( @? 1 $* gv *{ m$ m@ m% m? p/ *$ $ $# & a& pt \\ s\\ rf bl
` *? <> ?? ?/ r/ c/ // qr s/ /c y/ = @= C sC Cp sp df un BM po +1 +I
***************
*** 283,289 ****
"link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system",
"exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority",
"setpriority", "time", "sleep");
! @{$priv{"const"}}{8,16,32,64,128} = ("STRICT","ENTERED", "$[", "BARE", "WARN");
$priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM";
$priv{"list"}{64} = "GUESSED";
$priv{"delete"}{64} = "SLICE";
--- 301,307 ----
"link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system",
"exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority",
"setpriority", "time", "sleep");
! @{$priv{"const"}}{8,16,32,64,128} = ("STRICT","ENTERED", '$[', "BARE", "WARN");
$priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM";
$priv{"list"}{64} = "GUESSED";
$priv{"delete"}{64} = "SLICE";
***************
*** 339,348 ****
$h{svclass} = $h{svaddr} = $h{svval} = "";
if ($h{class} eq "PMOP") {
my $precomp = $op->precomp;
! $precomp = defined($precomp) ? "/$precomp/" : "";
my $pmreplroot = $op->pmreplroot;
! my ($pmreplroot, $pmreplstart);
! if ($ {$pmreplroot = $op->pmreplroot} && $pmreplroot->isa("B::GV")) {
# with C<@stash_array = split(/pat/, str);>,
# *stash_array is stored in pmreplroot.
$h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
--- 357,375 ----
$h{svclass} = $h{svaddr} = $h{svval} = "";
if ($h{class} eq "PMOP") {
my $precomp = $op->precomp;
! if (defined $precomp) {
! # Escape literal control sequences
! for ($precomp) {
! s/\t/\\t/g; s/\n/\\n/g; s/\r/\\r/g;
! # How can we do the below portably?
! #s/([\0-\037\177-\377])/"\\".sprintf("%03o", ord($1))/eg;
! }
! $precomp = "/$precomp/";
! }
! else { $precomp = ""; }
my $pmreplroot = $op->pmreplroot;
! my $pmreplstart;
! if ($$pmreplroot && $pmreplroot->isa("B::GV")) {
# with C<@stash_array = split(/pat/, str);>,
# *stash_array is stored in pmreplroot.
$h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
***************
*** 423,428 ****
--- 450,456 ----
$h{label} = $labels{$op->seq};
$h{typenum} = $op->type;
$h{noise} = $linenoise[$op->type];
+ $_->(\%h, $op, \$format, \$level) for @callbacks;
return fmt_line(\%h, $format, $level);
}
***************
*** 488,493 ****
--- 516,523 ----
perl -MO=Concise[,OPTIONS] foo.pl
+ use B::Concise qw(set_style add_callback);
+
=head1 DESCRIPTION
This compiler backend prints the internal OPs of a Perl program's syntax
***************
*** 815,820 ****
--- 845,887 ----
" PVOP An OP with a string
{ LOOP An OP that holds pointers for a loop
; COP An OP that marks the start of a statement
+
+ =head1 Using B::Concise outside of the O framework
+
+ It is possible to extend B<B::Concise> by using it outside of the B<O>
+ framework and providing new styles and new variables.
+
+ use B::Concise qw(set_style add_callback);
+ set_style($format, $gotofmt, $treefmt);
+ add_callback
+ (
+ sub
+ {
+ my ($h, $op, $level, $format) = @_;
+ $h->{variable} = some_func($op);
+ }
+ );
+ B::Concise::compile(@options)->();
+
+ You can specify a style by calling the B<set_style> subroutine. If you
+ have a new variable in your style, or you want to change the value of an
+ existing variable, you will need to add a callback to specify the value
+ for that variable.
+
+ This is done by calling B<add_callback> passing references to any
+ callback subroutines. The subroutines are called in the same order as
+ they are added. Each subroutine is passed four parameters. These are a
+ reference to a hash, the keys of which are the names of the variables
+ and the values of which are their values, the op, the level and the
+ format.
+
+ To define your own variables, simply add them to the hash, or change
+ existing values if you need to. The level and format are passed in as
+ references to scalars, but it is unlikely that they will need to be
+ changed or even used.
+
+ To see the output, call the subroutine returned by B<compile> in the
+ same way that B<O> does.
=head1 AUTHOR
diff -c 'perl-5.7.1/ext/B/B/Debug.pm' 'perl-5.7.2/ext/B/B/Debug.pm'
Index: ./ext/B/B/Debug.pm
*** ./ext/B/B/Debug.pm Thu Apr 5 21:21:50 2001
--- ./ext/B/B/Debug.pm Mon Jul 9 17:09:50 2001
***************
*** 90,96 ****
sub B::PVOP::debug {
my ($op) = @_;
$op->B::OP::debug();
! printf "\top_pv\t\t0x%x\n", $op->pv;
}
sub B::PADOP::debug {
--- 90,96 ----
sub B::PVOP::debug {
my ($op) = @_;
$op->B::OP::debug();
! printf "\top_pv\t\t%s\n", cstring($op->pv);
}
sub B::PADOP::debug {
***************
*** 125,130 ****
--- 125,139 ----
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 {
diff -c 'perl-5.7.1/ext/B/B/Deparse.pm' 'perl-5.7.2/ext/B/B/Deparse.pm'
Index: ./ext/B/B/Deparse.pm
*** ./ext/B/B/Deparse.pm Fri Apr 6 01:13:49 2001
--- ./ext/B/B/Deparse.pm Mon Jul 9 17:09:51 2001
***************
*** 8,24 ****
package B::Deparse;
use Carp 'cluck', 'croak';
! use B qw(class main_root main_start main_cv svref_2object opnumber
OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
! OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL
! OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
! SVf_IOK SVf_NOK SVf_ROK SVf_POK
CVf_METHOD CVf_LOCKED CVf_LVALUE
! PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
! $VERSION = 0.60;
use strict;
# Changes between 0.50 and 0.51:
# - fixed nulled leave with live enter in sort { }
--- 8,27 ----
package B::Deparse;
use Carp 'cluck', 'croak';
! use B qw(class main_root main_start main_cv svref_2object opnumber cstring
OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
! OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD
! 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
! SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR
CVf_METHOD CVf_LOCKED CVf_LVALUE
! PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE
PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
! $VERSION = 0.61;
use strict;
+ use warnings ();
# Changes between 0.50 and 0.51:
# - fixed nulled leave with live enter in sort { }
***************
*** 89,105 ****
# - separate recognition of constant subs
# - rewrote continue block handling, now recoginizing for loops
# - added more control of expanding control structures
# Todo:
# - finish tr/// changes
# - add option for even more parens (generalize \&foo change)
- # - {} around variables in strings ("${var}letters")
- # base/lex.t 25-27
- # comp/term.t 11
# - left/right context
- # - recognize `use utf8', `use integer', etc
# - treat top-level block specially for incremental output
- # - interpret high bit chars in string as utf8 \x{...} (when?)
# - copy comments (look at real text with $^P?)
# - avoid semis in one-statement blocks
# - associativity of &&=, ||=, ?:
--- 92,118 ----
# - 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)
# 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
# - treat top-level block specially for incremental output
# - copy comments (look at real text with $^P?)
# - avoid semis in one-statement blocks
# - associativity of &&=, ||=, ?:
***************
*** 109,125 ****
# - more style options: brace style, hex vs. octal, quotes, ...
# - print big ints as hex/octal instead of decimal (heuristic?)
# - handle `my $x if 0'?
- # - include values of variables (e.g. set in BEGIN)
# - coordinate with Data::Dumper (both directions? see previous)
# - version using op_next instead of op_first/sibling?
# - avoid string copies (pass arrays, one big join?)
- # - auto-apply `-u'?
- # - -uPackage:: descend recursively?
# - here-docs?
- # - <DATA>?
# Tests that will always fail:
! # comp/redef.t -- all (redefinition happens at compile time)
# Object fields (were globals):
#
--- 122,134 ----
# - more style options: brace style, hex vs. octal, quotes, ...
# - print big ints as hex/octal instead of decimal (heuristic?)
# - handle `my $x if 0'?
# - coordinate with Data::Dumper (both directions? see previous)
# - version using op_next instead of op_first/sibling?
# - avoid string copies (pass arrays, one big join?)
# - here-docs?
# Tests that will always fail:
! # (see t/TEST for the short list)
# Object fields (were globals):
#
***************
*** 134,144 ****
# curcv:
# CV for current sub (or main program) being deparsed
#
# curstash:
# name of the current package for deparsed code
#
# subs_todo:
! # array of [cop_seq, GV, is_format?] for subs and formats we still
# want to deparse
#
# protos_todo:
--- 143,161 ----
# 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:
***************
*** 148,153 ****
--- 165,174 ----
# 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.
+ #
# parens: -p
# linenums: -l
# unquote: -q
***************
*** 200,205 ****
--- 221,233 ----
# 1 statement modifiers
# 0 statement level
+ # Also, lineseq may pass a fourth parameter to the pp_ routines:
+ # if present, the fourth parameter is passed on by deparse.
+ #
+ # If present and true, it means that the op exists directly as
+ # part of a lineseq. Currently it's only used by scopeop to
+ # decide whether its results need to be enclosed in a do {} block.
+
# Nonprinting characters with special meaning:
# \cS - steal parens (see maybe_parens_unop)
# \n - newline and indent
***************
*** 215,221 ****
sub todo {
my $self = shift;
! my($gv, $cv, $is_form) = @_;
my $seq;
if (!null($cv->START) and is_state($cv->START)) {
$seq = $cv->START->cop_seq;
--- 243,250 ----
sub todo {
my $self = shift;
! my($cv, $is_form) = @_;
! return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
my $seq;
if (!null($cv->START) and is_state($cv->START)) {
$seq = $cv->START->cop_seq;
***************
*** 222,310 ****
} else {
$seq = 0;
}
! push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
}
sub next_todo {
my $self = shift;
my $ent = shift @{$self->{'subs_todo'}};
! my $name = $self->gv_name($ent->[1]);
if ($ent->[2]) {
return "format $name =\n"
! . $self->deparse_format($ent->[1]->FORM). "\n";
} else {
! return "sub $name " . $self->deparse_sub($ent->[1]->CV);
}
}
! sub walk_tree {
! my($op, $sub) = @_;
! $sub->($op);
! if ($op->flags & OPf_KIDS) {
! my $kid;
! for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
! walk_tree($kid, $sub);
! }
}
! }
! sub walk_sub {
! my $self = shift;
! my $cv = shift;
! my $op = $cv->ROOT;
! $op = shift if null $op;
! return if !$op or null $op;
! walk_tree($op, sub {
! my $op = shift;
! if ($op->name eq "gv") {
! my $gv = $self->gv_or_padgv($op);
! if ($op->next->name eq "entersub") {
! return if $self->{'subs_done'}{$$gv}++;
! return if class($gv->CV) eq "SPECIAL";
! $self->todo($gv, $gv->CV, 0);
! $self->walk_sub($gv->CV);
! } elsif ($op->next->name eq "enterwrite"
! or ($op->next->name eq "rv2gv"
! and $op->next->next->name eq "enterwrite")) {
! return if $self->{'forms_done'}{$$gv}++;
! return if class($gv->FORM) eq "SPECIAL";
! $self->todo($gv, $gv->FORM, 1);
! $self->walk_sub($gv->FORM);
! }
! }
! });
}
sub stash_subs {
! my $self = shift;
! my $pack = shift;
! my(%stash, @ret);
! { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
! if ($pack eq "main") {
! $pack = "";
! } else {
! $pack = $pack . "::";
}
! my($key, $val);
! while (($key, $val) = each %stash) {
my $class = class($val);
if ($class eq "PV") {
! # Just a prototype
push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
} elsif ($class eq "IV") {
! # Just a name
push @{$self->{'protos_todo'}}, [$pack . $key, undef];
} elsif ($class eq "GV") {
! if (class($val->CV) ne "SPECIAL") {
next if $self->{'subs_done'}{$$val}++;
! $self->todo($val, $val->CV, 0);
! $self->walk_sub($val->CV);
}
! if (class($val->FORM) ne "SPECIAL") {
next if $self->{'forms_done'}{$$val}++;
! $self->todo($val, $val->FORM, 1);
! $self->walk_sub($val->FORM);
}
}
}
}
--- 251,425 ----
} else {
$seq = 0;
}
! push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
}
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)) {
! 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";
! }
! return "${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 = const($self->const_sv($req_op->first));
! }
! 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)->int_value;
! $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') {
! 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) {
! next if $key eq 'main::'; # avoid infinite recursion
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);
+ }
}
}
}
***************
*** 346,352 ****
--- 461,469 ----
my $class = shift;
my $self = bless {}, $class;
$self->{'subs_todo'} = [];
+ $self->{'files'} = {};
$self->{'curstash'} = "main";
+ $self->{'curcop'} = undef;
$self->{'cuddle'} = "\n";
$self->{'indent_size'} = 4;
$self->{'use_tabs'} = 0;
***************
*** 355,363 ****
$self->{'linenums'} = 0;
$self->{'parens'} = 0;
$self->{'ex_const'} = "'???'";
while (my $arg = shift @_) {
! if (substr($arg, 0, 2) eq "-u") {
! $self->stash_subs(substr($arg, 2));
} elsif ($arg eq "-p") {
$self->{'parens'} = 1;
} elsif ($arg eq "-l") {
--- 472,486 ----
$self->{'linenums'} = 0;
$self->{'parens'} = 0;
$self->{'ex_const'} = "'???'";
+
+ $self->{'ambient_arybase'} = 0;
+ $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
+ $self->{'ambient_hints'} = 0;
+ $self->init();
+
while (my $arg = shift @_) {
! if ($arg =~ /^-f(.*)/) {
! $self->{'files'}{$1} = 1;
} elsif ($arg eq "-p") {
$self->{'parens'} = 1;
} elsif ($arg eq "-l") {
***************
*** 373,385 ****
return $self;
}
sub compile {
my(@args) = @_;
return sub {
my $self = B::Deparse->new(@args);
! $self->stash_subs("main");
$self->{'curcv'} = main_cv;
! $self->walk_sub(main_cv, main_start);
print $self->print_protos;
@{$self->{'subs_todo'}} =
sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
--- 496,541 ----
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'} & 0xFF;
+
+ # 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);
! my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_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, @INITs, @ENDs) {
! $self->todo($block, 0);
! }
! $self->stash_subs();
$self->{'curcv'} = main_cv;
! $self->{'curcvlex'} = undef;
print $self->print_protos;
@{$self->{'subs_todo'}} =
sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
***************
*** 390,395 ****
--- 546,558 ----
push @text, $self->next_todo;
}
print $self->indent(join("", @text)), "\n" if @text;
+
+ # Print __DATA__ section, if necessary
+ no strict 'refs';
+ if (defined *{$self->{'curstash'}."::DATA"}{IO}) {
+ print "__DATA__\n";
+ print readline(*{$self->{'curstash'}."::DATA"});
+ }
}
}
***************
*** 397,412 ****
my $self = shift;
my $sub = shift;
croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
return $self->indent($self->deparse_sub(svref_2object($sub)));
}
sub deparse {
my $self = shift;
! my($op, $cx) = @_;
! # cluck if class($op) eq "NULL";
! # cluck unless $op;
! # return $self->$ {\("pp_" . $op->name)}($op, $cx);
my $meth = "pp_" . $op->name;
return $self->$meth($op, $cx);
}
--- 560,684 ----
my $self = shift;
my $sub = shift;
croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
+
+ $self->init();
return $self->indent($self->deparse_sub(svref_2object($sub)));
}
+ sub ambient_pragmas {
+ my $self = shift;
+ my ($arybase, $hint_bits, $warning_bits) = (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;
+ }
+
+ 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;
+ }
+
sub deparse {
my $self = shift;
! my($op, $cx, $flags) = @_;
!
! Carp::confess("Null op in deparse") if !defined($op)
! || class($op) eq "NULL";
my $meth = "pp_" . $op->name;
+ if (is_scope($op)) {
+ return $self->$meth($op, $cx, $flags);
+ }
return $self->$meth($op, $cx);
}
***************
*** 442,447 ****
--- 714,722 ----
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 . ") ";
}
***************
*** 453,471 ****
}
local($self->{'curcv'}) = $cv;
! local($self->{'curstash'}) = $self->{'curstash'};
if (not null $cv->ROOT) {
! # skip leavesub
! return $proto . "{\n\t" .
! $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
}
! my $sv = $cv->const_sv;
! if ($$sv) {
! # uh-oh. inlinable sub... format it differently
! return $proto . "{ " . const($sv) . " }\n";
! } else { # XSUB?
! return $proto . "{}\n";
}
}
sub deparse_format {
--- 728,765 ----
}
local($self->{'curcv'}) = $cv;
! local($self->{'curcvlex'});
! local(@$self{qw'curstash warnings hints'})
! = @$self{qw'curstash warnings hints'};
! 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 . "{ " . const($sv) . " }\n";
! } else { # XSUB? (or just a declaration)
! return "$proto;\n";
! }
}
+ return $proto ."{\n\t$body\n\b}" ."\n";
}
sub deparse_format {
***************
*** 473,479 ****
my $form = shift;
my @text;
local($self->{'curcv'}) = $form;
! local($self->{'curstash'}) = $self->{'curstash'};
my $op = $form->ROOT;
my $kid;
$op = $op->first->first; # skip leavewrite, lineseq
--- 767,775 ----
my $form = shift;
my @text;
local($self->{'curcv'}) = $form;
! local($self->{'curcvlex'});
! local(@$self{qw'curstash warnings hints'})
! = @$self{'curstash warnings hints'};
my $op = $form->ROOT;
my $kid;
$op = $op->first->first; # skip leavewrite, lineseq
***************
*** 481,495 ****
$op = $op->sibling; # skip nextstate
my @exprs;
$kid = $op->first->sibling; # skip pushmark
! push @text, $self->const_sv($kid)->PV;
$kid = $kid->sibling;
for (; not null $kid; $kid = $kid->sibling) {
push @exprs, $self->deparse($kid, 0);
}
! push @text, join(", ", @exprs)."\n" if @exprs;
$op = $op->sibling;
}
! return join("", @text) . ".";
}
sub is_scope {
--- 777,791 ----
$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 {
***************
*** 547,555 ****
my $self = shift;
my($name, $kid, $cx) = @_;
if ($cx > 16 or $self->{'parens'}) {
! return "$name(" . $self->deparse($kid, 1) . ")";
} else {
$kid = $self->deparse($kid, 16);
if (substr($kid, 0, 1) eq "\cS") {
# use kid's parens
return $name . substr($kid, 1);
--- 843,858 ----
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);
***************
*** 576,586 ****
sub maybe_local {
my $self = shift;
my($op, $cx, $text) = @_;
! if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
if (want_scalar($op)) {
! return "local $text";
} else {
! return $self->maybe_parens_func("local", $text, $cx, 16);
}
} else {
return $text;
--- 879,892 ----
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 (want_scalar($op)) {
! return "$our_local $text";
} else {
! return $self->maybe_parens_func("$our_local", $text, $cx, 16);
}
} else {
return $text;
***************
*** 674,679 ****
--- 980,990 ----
return "XXX";
}
+ sub pp_method_named {
+ cluck "unexpected OP_METHOD_NAMED";
+ return "XXX";
+ }
+
sub pp_flip { # see also flop
cluck "unexpected OP_FLIP";
return "XXX";
***************
*** 704,738 ****
return "XXX";
}
sub lineseq {
! my $self = shift;
! my(@ops) = @_;
my($expr, @exprs);
for (my $i = 0; $i < @ops; $i++) {
$expr = "";
if (is_state $ops[$i]) {
$expr = $self->deparse($ops[$i], 0);
$i++;
! last if $i > $#ops;
}
! if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and
! $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3)
{
! push @exprs, $expr . $self->for_loop($ops[$i], 0);
! $i++;
! next;
}
! $expr .= $self->deparse($ops[$i], 0);
! push @exprs, $expr if length $expr;
}
! return join(";\n", @exprs);
}
sub scopeop {
! my($real_block, $self, $op, $cx) = @_;
my $kid;
my @kids;
! local($self->{'curstash'}) = $self->{'curstash'} if $real_block;
if ($real_block) {
$kid = $op->first->sibling; # skip enter
if (is_miniwhile($kid)) {
--- 1015,1082 ----
return "XXX";
}
+ # $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 = $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;
for (my $i = 0; $i < @ops; $i++) {
$expr = "";
if (is_state $ops[$i]) {
$expr = $self->deparse($ops[$i], 0);
$i++;
! if ($i > $#ops) {
! push @exprs, $expr;
! last;
! }
}
! if (!is_state $ops[$i] and (my $ls = $ops[$i+1]) and
! !null($ops[$i+1]) and $ops[$i+1]->name eq "lineseq")
{
! if ($ls->first && !null($ls->first) && is_state($ls->first)
! && (my $sib = $ls->first->sibling)) {
! if (!null($sib) && $sib->name eq "leaveloop") {
! push @exprs, $expr . $self->for_loop($ops[$i], 0);
! $i++;
! next;
! }
! }
}
! $expr .= $self->deparse($ops[$i], 0, (@ops != 1));
! $expr =~ s/;\n?\z//;
! push @exprs, $expr;
}
! my $body = join(";\n", grep {length} @exprs);
! my $subs = "";
! if (defined $root && defined $limit_seq) {
! $subs = join "\n", $self->seq_subs($limit_seq);
! }
! return join(";\n", grep {length} $body, $subs);
}
sub scopeop {
! my($real_block, $self, $op, $cx, $flags) = @_;
my $kid;
my @kids;
!
! local(@$self{qw'curstash warnings hints'})
! = @$self{qw'curstash warnings hints'} if $real_block;
if ($real_block) {
$kid = $op->first->sibling; # skip enter
if (is_miniwhile($kid)) {
***************
*** 757,766 ****
for (; !null($kid); $kid = $kid->sibling) {
push @kids, $kid;
}
! if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
! return "do { " . $self->lineseq(@kids) . " }";
} else {
! return $self->lineseq(@kids) . ";";
}
}
--- 1101,1111 ----
for (; !null($kid); $kid = $kid->sibling) {
push @kids, $kid;
}
! if ($flags || $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;" : "");
}
}
***************
*** 777,782 ****
--- 1122,1128 ----
sub gv_name {
my $self = shift;
my $gv = shift;
+ Carp::confess() if $gv->isa("B::CV");
my $stash = $gv->STASH->NAME;
my $name = $gv->SAFENAME;
if ($stash eq $self->{'curstash'} or $globalnames{$name}
***************
*** 792,808 ****
return $stash . $name;
}
! # Notice how subs and formats are inserted between statements here
! sub pp_nextstate {
my $self = shift;
! my($op, $cx) = @_;
! my @text;
! @text = $op->label . ": " if $op->label;
my $seq = $op->cop_seq;
while (scalar(@{$self->{'subs_todo'}})
and $seq > $self->{'subs_todo'}[0][0]) {
push @text, $self->next_todo;
}
my $stash = $op->stashpv;
if ($stash ne $self->{'curstash'}) {
push @text, "package $stash;\n";
--- 1138,1263 ----
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->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 = $ns[$i]->NVX;
! my $seq_en = int($ns[$i]->IVX);
!
! 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::cluck() if !defined $op;
! return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
!
! 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)->NVX);
! my $e = $self->padname_sv($o->targ)->IVX;
! $scope_st = $s if !defined($scope_st) || $s < $scope_st;
! $scope_en = $e if !defined($scope_en) || $e > $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;
! }
! elsif ($o->flags & OPf_KIDS) {
! ($scope_st, $scope_en) =
! $self->find_scope($o, $scope_st, $scope_en)
! }
! }
!
! 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";
***************
*** 812,820 ****
--- 1267,1341 ----
push @text, "\f#line " . $op->line .
' "' . $op->file, qq'"\n';
}
+
+ 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->private) {
+ push @text, declare_hints($self->{'hints'}, $op->private);
+ $self->{'hints'} = $op->private;
+ }
+
return join("", @text);
}
+ sub declare_warnings {
+ my ($from, $to) = @_;
+ if (($to & WARN_MASK) eq warnings::bits("all")) {
+ return "use warnings;\n";
+ }
+ elsif (($to & WARN_MASK) eq "\0"x length($to)) {
+ return "no warnings;\n";
+ }
+ return "BEGIN {\${^WARNING_BITS} = ".cstring($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;
+ }
+
+ 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(@_) }
***************
*** 826,832 ****
return $name;
}
! sub pp_stub { baseop(@_, "()") }
sub pp_wantarray { baseop(@_, "wantarray") }
sub pp_fork { baseop(@_, "fork") }
sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
--- 1347,1362 ----
return $name;
}
! sub pp_stub {
! my $self = shift;
! my($op, $cx, $name) = @_;
! if ($cx) {
! return "()";
! }
! else {
! return "();";
! }
! }
sub pp_wantarray { baseop(@_, "wantarray") }
sub pp_fork { baseop(@_, "fork") }
sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
***************
*** 902,907 ****
--- 1432,1443 ----
my $kid;
if ($op->flags & OPf_KIDS) {
$kid = $op->first;
+ if (defined prototype("CORE::$name")
+ && prototype("CORE::$name") =~ /^;?\*/
+ && $kid->name eq "rv2gv") {
+ $kid = $kid->first;
+ }
+
return $self->maybe_parens_unop($name, $kid, $cx);
} else {
return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
***************
*** 991,996 ****
--- 1527,1543 ----
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);
}
***************
*** 1000,1009 ****
--- 1547,1568 ----
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);
***************
*** 1019,1025 ****
my $name = $self->const_sv($op->first)->PV;
$name =~ s[/][::]g;
$name =~ s/\.pm//g;
! return "require($name)";
} else {
$self->unop($op, $cx, "require");
}
--- 1578,1584 ----
my $name = $self->const_sv($op->first)->PV;
$name =~ s[/][::]g;
$name =~ s/\.pm//g;
! return "require $name";
} else {
$self->unop($op, $cx, "require");
}
***************
*** 1091,1097 ****
my($op, $cx) = @_;
my $kid = $op->first;
$kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
! return "<" . $self->deparse($kid, 1) . ">";
}
# Unary operators that can occur as pseudo-listops inside double quotes
--- 1650,1657 ----
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");
}
# Unary operators that can occur as pseudo-listops inside double quotes
***************
*** 1155,1162 ****
sub pp_ftrwrite { ftst(@_, "-W") }
sub pp_ftrexec { ftst(@_, "-X") }
sub pp_fteread { ftst(@_, "-r") }
! sub pp_ftewrite { ftst(@_, "-r") }
! sub pp_fteexec { ftst(@_, "-r") }
sub pp_ftis { ftst(@_, "-e") }
sub pp_fteowned { ftst(@_, "-O") }
sub pp_ftrowned { ftst(@_, "-o") }
--- 1715,1722 ----
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") }
***************
*** 1181,1186 ****
--- 1741,1747 ----
sub SWAP_CHILDREN () { 1 }
sub ASSIGN () { 2 } # has OP= variant
+ sub LIST_CONTEXT () { 4 } # Assignment is in list context
my(%left, %right);
***************
*** 1283,1288 ****
--- 1844,1851 ----
($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);
}
***************
*** 1329,1335 ****
sub pp_scmp { binop(@_, "cmp", 14) }
sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
! sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
# `.' 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
--- 1892,1898 ----
sub pp_scmp { binop(@_, "cmp", 14) }
sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
! sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
# `.' 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
***************
*** 1452,1458 ****
my $parens = ($cx >= 5) || $self->{'parens'};
my $kid = $op->first->sibling;
return $name if null $kid;
! my $first = $self->deparse($kid, 6);
$first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
push @exprs, $first;
$kid = $kid->sibling;
--- 2015,2032 ----
my $parens = ($cx >= 5) || $self->{'parens'};
my $kid = $op->first->sibling;
return $name if null $kid;
! my $first;
! if (defined prototype("CORE::$name")
! && prototype("CORE::$name") =~ /^;?\*/
! && $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;
***************
*** 1598,1603 ****
--- 2172,2179 ----
$indir = $indir->first; # skip rv2gv
if (is_scope($indir)) {
$indir = "{" . $self->deparse($indir, 0) . "}";
+ } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
+ $indir = $self->const_sv($indir)->PV;
} else {
$indir = $self->deparse($indir, 24);
}
***************
*** 1604,1609 ****
--- 2180,2192 ----
$indir = $indir . " ";
$kid = $kid->sibling;
}
+ if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
+ $indir = ($op->private & OPpSORT_REVERSE) ? '{$b <=> $a} '
+ : '{$a <=> $b} ';
+ }
+ elsif ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
+ $indir = '{$b cmp $a} ';
+ }
for (; !null($kid); $kid = $kid->sibling) {
$expr = $self->deparse($kid, 6);
push @exprs, $expr;
***************
*** 1645,1665 ****
my($expr, @exprs);
my $kid = $op->first->sibling; # skip pushmark
my $lop;
! my $local = "either"; # could be local(...) or my(...)
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.
! unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef")
{
$local = ""; # or not
last;
}
if ($lop->name =~ /^pad[ash]v$/) { # my()
! ($local = "", last) if $local eq "local";
$local = "my";
} elsif ($lop->name ne "undef") { # local()
! ($local = "", last) if $local eq "my";
$local = "local";
}
}
--- 2228,2262 ----
my($expr, @exprs);
my $kid = $op->first->sibling; # skip pushmark
my $lop;
! my $local = "either"; # could be local(...), my(...) 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$/) { # my()
! ($local = "", last) if $local eq "local" || $local eq "our";
$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 eq "my" || $local eq "local";
+ $local = "our";
} elsif ($lop->name ne "undef") { # local()
! ($local = "", last) if $local eq "my" || $local eq "our";
$local = "local";
}
}
***************
*** 1737,1743 ****
my($op, $cx, $init) = @_;
my $enter = $op->first;
my $kid = $enter->sibling;
! local($self->{'curstash'}) = $self->{'curstash'};
my $head = "";
my $bare = 0;
my $body;
--- 2334,2341 ----
my($op, $cx, $init) = @_;
my $enter = $op->first;
my $kid = $enter->sibling;
! local(@$self{qw'curstash warnings hints'})
! = @$self{qw'curstash warnings hints'};
my $head = "";
my $bare = 0;
my $body;
***************
*** 1744,1750 ****
my $cond = undef;
if ($kid->name eq "lineseq") { # bare or infinite loop
if (is_state $kid->last) { # infinite
! $head = "for (;;) "; # shorter than while (1)
$cond = "";
} else {
$bare = 1;
--- 2342,2348 ----
my $cond = undef;
if ($kid->name eq "lineseq") { # bare or infinite loop
if (is_state $kid->last) { # infinite
! $head = "while (1) "; # Can't use for(;;) if there's a continue
$cond = "";
} else {
$bare = 1;
***************
*** 1798,1804 ****
# block (or the last in a bare loop).
my $cont_start = $enter->nextop;
my $cont;
! if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) {
if ($bare) {
$cont = $body->last;
} else {
--- 2396,2402 ----
# block (or the last in a bare loop).
my $cont_start = $enter->nextop;
my $cont;
! if ($$cont_start != $$op && ${$cont_start->sibling} != ${$body->last}) {
if ($bare) {
$cont = $body->last;
} else {
***************
*** 1813,1819 ****
for (; $$state != $$cont; $state = $state->sibling) {
push @states, $state;
}
! $body = $self->lineseq(@states);
if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
$head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
$cont = "\cK";
--- 2411,2417 ----
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";
***************
*** 1822,1831 ****
$self->deparse($cont, 0) . "\n\b}\cK";
}
} else {
$cont = "\cK";
$body = $self->deparse($body, 0);
}
! return $head . "{\n\t" . $body . "\n\b}" . $cont;
}
sub pp_leaveloop { loop_common(@_, "") }
--- 2420,2435 ----
$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 { loop_common(@_, "") }
***************
*** 1834,1840 ****
my $self = shift;
my($op, $cx) = @_;
my $init = $self->deparse($op, 1);
! return $self->loop_common($op->sibling, $cx, $init);
}
sub pp_leavetry {
--- 2438,2444 ----
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 {
***************
*** 1844,1849 ****
--- 2448,2455 ----
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;
***************
*** 1869,1874 ****
--- 2475,2482 ----
return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
. $self->deparse($op->first->sibling, 20),
$cx, 20);
+ } elsif ($op->flags & OPf_SPECIAL && $cx == 0 && !$op->targ) {
+ return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
} else {
return $self->deparse($op->first, $cx);
}
***************
*** 1924,1930 ****
my $self = shift;
my($op, $cx) = @_;
my $gv = $self->gv_or_padgv($op);
! return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv));
}
sub pp_gv {
--- 2532,2539 ----
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 {
***************
*** 1938,1952 ****
my $self = shift;
my($op, $cx) = @_;
my $gv = $self->gv_or_padgv($op);
! return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
}
sub rv2x {
my $self = shift;
my($op, $cx, $type) = @_;
my $kid = $op->first;
my $str = $self->deparse($kid, 0);
! return $type . (is_scalar($kid) ? $str : "{$str}");
}
sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
--- 2547,2572 ----
my $self = shift;
my($op, $cx) = @_;
my $gv = $self->gv_or_padgv($op);
! my $name = $self->gv_name($gv);
! $name = $self->{'curstash'}."::$name"
! if $name !~ /::/ && $self->lex_in_scope('@'.$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::cluck("Unexpected op in pp_rv2x");
+ return 'XXX';
+ }
my $kid = $op->first;
my $str = $self->deparse($kid, 0);
! return $self->stash_variable($type, $str) if is_scalar($kid);
! return $type ."{$str}";
}
sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
***************
*** 1966,1972 ****
}
# skip down to the old, ex-rv2cv
! sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
sub pp_rv2av {
my $self = shift;
--- 2586,2602 ----
}
# 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 pp_rv2av {
my $self = shift;
***************
*** 2010,2015 ****
--- 2640,2652 ----
$array = $self->padany($array);
} elsif (is_scope($array)) { # ${expr}[0]
$array = "{" . $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);
+ }
} elsif (is_scalar $array) { # $x[0], $$x[0], ...
$array = $self->deparse($array, 24);
} else {
***************
*** 2019,2024 ****
--- 2656,2690 ----
$left . $self->deparse($idx, 1) . $right;
}
$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 "\$" . $array . $left . $idx . $right;
}
***************
*** 2122,2128 ****
} else {
$obj = $kid;
$kid = $kid->sibling;
! for (; not null $kid->sibling; $kid = $kid->sibling) {
push @exprs, $self->deparse($kid, 6);
}
$meth = $kid;
--- 2788,2795 ----
} else {
$obj = $kid;
$kid = $kid->sibling;
! for (; !null ($kid->sibling) && $kid->name ne "method_named";
! $kid = $kid->sibling) {
push @exprs, $self->deparse($kid, 6);
}
$meth = $kid;
***************
*** 2142,2148 ****
}
my $args = join(", ", @exprs);
$kid = $obj . "->" . $meth;
! if ($args) {
return $kid . "(" . $args . ")"; # parens mandatory
} else {
return $kid;
--- 2809,2815 ----
}
my $args = join(", ", @exprs);
$kid = $obj . "->" . $meth;
! if (length $args) {
return $kid . "(" . $args . ")"; # parens mandatory
} else {
return $kid;
***************
*** 2232,2238 ****
my $prefix = "";
my $amper = "";
my($kid, @exprs);
! if ($op->flags & OPf_SPECIAL) {
$prefix = "do ";
} elsif ($op->private & OPpENTERSUB_AMPER) {
$amper = "&";
--- 2899,2905 ----
my $prefix = "";
my $amper = "";
my($kid, @exprs);
! if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
$prefix = "do ";
} elsif ($op->private & OPpENTERSUB_AMPER) {
$amper = "&";
***************
*** 2254,2260 ****
}
$simple = 1; # only calls of named functions can be prototyped
$kid = $self->deparse($kid, 24);
! } elsif (is_scalar $kid->first) {
$amper = "&";
$kid = $self->deparse($kid, 24);
} else {
--- 2921,2927 ----
}
$simple = 1; # only calls of named functions can be prototyped
$kid = $self->deparse($kid, 24);
! } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
$amper = "&";
$kid = $self->deparse($kid, 24);
} else {
***************
*** 2262,2269 ****
my $arrow = is_subscriptable($kid->first) ? "" : "->";
$kid = $self->deparse($kid, 24) . $arrow;
}
my $args;
! if (defined $proto and not $amper) {
($amper, $args) = $self->check_proto($proto, @exprs);
if ($amper eq "&") {
$args = join(", ", map($self->deparse($_, 6), @exprs));
--- 2929,2945 ----
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 = exists $self->{'subs_declared'}{$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));
***************
*** 2278,2286 ****
return $prefix . $amper. $kid;
}
} else {
! if (defined $proto and $proto eq "") {
return $kid;
! } elsif (defined $proto and $proto eq "\$") {
return $self->maybe_parens_func($kid, $args, $cx, 16);
} elsif (defined($proto) && $proto or $simple) {
return $self->maybe_parens_func($kid, $args, $cx, 5);
--- 2954,2977 ----
return $prefix . $amper. $kid;
}
} else {
! # glob() invocations can be translated into calls of
! # CORE::GLOBAL::glob with an 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:://;
!
! if (!$declared) {
! return "$kid(" . $args . ")";
! } elsif (defined $proto and $proto eq "") {
return $kid;
! } elsif (defined $proto and $proto eq "\$" and is_scalar($exprs[0])) {
return $self->maybe_parens_func($kid, $args, $cx, 16);
} elsif (defined($proto) && $proto or $simple) {
return $self->maybe_parens_func($kid, $args, $cx, 5);
***************
*** 2296,2316 ****
# but not character escapes
sub uninterp {
my($str) = @_;
! $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
return $str;
}
! # the same, but treat $|, $), and $ at the end of the string differently
sub re_uninterp {
my($str) = @_;
! $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
! $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
return $str;
}
# character escapes, but not delimiters that might need to be escaped
! sub escape_str { # ASCII
my($str) = @_;
$str =~ s/\a/\\a/g;
# $str =~ s/\cH/\\b/g; # \b means someting different in a regex
$str =~ s/\t/\\t/g;
--- 2987,3069 ----
# 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]
! )
!
! /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)
+ )
+ | [\$\@]
+ (?!\||\)|\(|$)
+ | \\[uUlLQE]
+ )
+
+ /length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
+
+ return $str;
+ }
+ }
+
# 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 someting different in a regex
$str =~ s/\t/\\t/g;
***************
*** 2323,2328 ****
--- 3076,3091 ----
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/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
+ $str =~ s/\n/\n\f/g;
+ return $str;
+ }
+
# Don't do this for regexen
sub unback {
my($str) = @_;
***************
*** 2330,2335 ****
--- 3093,3108 ----
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)\\(\\\\)*(?=[\0-\031\177-\377])/$1$2/g;
+ return $str;
+ }
+
sub balanced_delim {
my($str) = @_;
my @str = split //, $str;
***************
*** 2377,2389 ****
my $sv = shift;
if (class($sv) eq "SPECIAL") {
return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
} elsif ($sv->FLAGS & SVf_IOK) {
return $sv->int_value;
} elsif ($sv->FLAGS & SVf_NOK) {
! return $sv->NV;
! } elsif ($sv->FLAGS & SVf_ROK) {
return "\\(" . const($sv->RV) . ")"; # constant folded
! } else {
my $str = $sv->PV;
if ($str =~ /[^ -~]/) { # ASCII for non-printing
return single_delim("qq", '"', uninterp escape_str unback $str);
--- 3150,3170 ----
my $sv = shift;
if (class($sv) eq "SPECIAL") {
return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
+ } elsif (class($sv) eq "NULL") {
+ return 'undef';
} elsif ($sv->FLAGS & SVf_IOK) {
return $sv->int_value;
} elsif ($sv->FLAGS & SVf_NOK) {
! # try the default stringification
! my $r = "".$sv->NV;
! if ($r =~ /e/) {
! # If it's in scientific notation, we might have lost information
! return sprintf("%.20e", $sv->NV);
! }
! return $r;
! } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
return "\\(" . const($sv->RV) . ")"; # constant folded
! } elsif ($sv->FLAGS & SVf_POK) {
my $str = $sv->PV;
if ($str =~ /[^ -~]/) { # ASCII for non-printing
return single_delim("qq", '"', uninterp escape_str unback $str);
***************
*** 2390,2395 ****
--- 3171,3178 ----
} else {
return single_delim("q", "'", unback $str);
}
+ } else {
+ return "undef";
}
}
***************
*** 2405,2410 ****
--- 3188,3196 ----
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;
# }
***************
*** 2419,2432 ****
my $op = shift;
my $type = $op->name;
if ($type eq "const") {
! return uninterp(escape_str(unback($self->const_sv($op)->PV)));
} elsif ($type eq "concat") {
my $first = $self->dq($op->first);
my $last = $self->dq($op->last);
# Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
! if ($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';
--- 3205,3222 ----
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]"
! ($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';
***************
*** 2492,2501 ****
--- 3282,3294 ----
}
}
+ # 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") {
***************
*** 2538,2549 ****
return $str;
}
- # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
- # and backslashes.
-
sub tr_decode_byte {
my($table, $flags) = @_;
! my(@table) = unpack("s256", $table);
my($c, $tr, @from, @to, @delfrom, $delhyphen);
if ($table[ord "-"] != -1 and
$table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
--- 3331,3340 ----
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)
***************
*** 2557,2563 ****
$delhyphen = 1;
}
}
! for ($c = 0; $c < 256; $c++) {
$tr = $table[$c];
if ($tr >= 0) {
push @from, $c; push @to, $tr;
--- 3348,3354 ----
$delhyphen = 1;
}
}
! for ($c = 0; $c < @table; $c++) {
$tr = $table[$c];
if ($tr >= 0) {
push @from, $c; push @to, $tr;
***************
*** 2589,2594 ****
--- 3380,3387 ----
my $x = shift;
if ($x == ord "-") {
return "\\-";
+ } elsif ($x == ord "\\") {
+ return "\\\\";
} else {
return chr $x;
}
***************
*** 2711,2738 ****
# Like dq(), but different
sub re_dq {
my $self = shift;
! my $op = shift;
my $type = $op->name;
if ($type eq "const") {
! return re_uninterp($self->const_sv($op)->PV);
} elsif ($type eq "concat") {
! my $first = $self->re_dq($op->first);
! my $last = $self->re_dq($op->last);
# Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
! if ($last =~ /^[{\[\w]/) {
! $first =~ s/([%\$@])([A-Za-z_]\w*)$/${1}{$2}/;
! }
return $first . $last;
} elsif ($type eq "uc") {
! return '\U' . $self->re_dq($op->first->sibling) . '\E';
} elsif ($type eq "lc") {
! return '\L' . $self->re_dq($op->first->sibling) . '\E';
} elsif ($type eq "ucfirst") {
! return '\u' . $self->re_dq($op->first->sibling);
} elsif ($type eq "lcfirst") {
! return '\l' . $self->re_dq($op->first->sibling);
} elsif ($type eq "quotemeta") {
! return '\Q' . $self->re_dq($op->first->sibling) . '\E';
} elsif ($type eq "join") {
return $self->deparse($op->last, 26); # was join($", @ary)
} else {
--- 3504,3539 ----
# 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);
!
# 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;
} 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 {
***************
*** 2740,2754 ****
}
}
! sub pp_regcomp {
my $self = shift;
! my($op, $cx) = @_;
my $kid = $op->first;
$kid = $kid->first if $kid->name eq "regcmaybe";
$kid = $kid->first if $kid->name eq "regcreset";
! return $self->re_dq($kid);
}
# osmic acid -- see osmium tetroxide
my %matchwords;
--- 3541,3596 ----
}
}
! sub pure_string {
! my ($self, $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 =~ /^(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(fast)?$/) {
! 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";
! 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;
***************
*** 2766,2775 ****
$var = $self->deparse($kid, 20);
$kid = $kid->sibling;
}
if (null $kid) {
! $re = re_uninterp(escape_str($op->precomp));
} else {
! $re = $self->deparse($kid, 1);
}
my $flags = "";
$flags .= "c" if $op->pmflags & PMf_CONTINUE;
--- 3608,3626 ----
$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::cluck("found ".$kid->name." where regcomp expected");
} else {
! ($re, $quote) = $self->regcomp($kid, 1, $extended);
}
my $flags = "";
$flags .= "c" if $op->pmflags & PMf_CONTINUE;
***************
*** 2783,2792 ****
if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
$re =~ s/\?/\\?/g;
$re = "?$re?";
! } else {
$re = single_delim($name, $delim, $re);
}
! $re = $re . $flags;
if ($binop) {
return $self->maybe_parens("$var =~ $re", $cx, 20);
} else {
--- 3634,3643 ----
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 {
***************
*** 2804,2814 ****
my($kid, @exprs, $ary, $expr);
$kid = $op->first;
if ($ {$kid->pmreplroot}) {
! $ary = '@' . $self->gv_name($kid->pmreplroot);
}
for (; !null($kid); $kid = $kid->sibling) {
push @exprs, $self->deparse($kid, 6);
}
$expr = "split(" . join(", ", @exprs) . ")";
if ($ary) {
return $self->maybe_parens("$ary = $expr", $cx, 7);
--- 3655,3674 ----
my($kid, @exprs, $ary, $expr);
$kid = $op->first;
if ($ {$kid->pmreplroot}) {
! $ary = $self->stash_variable('@', $self->gv_name($kid->pmreplroot));
}
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
+ && $exprs[0] eq '/\\s+/'
+ && $kid->pmflags & PMf_SKIPWHITE ) {
+ $exprs[0] = '" "';
+ }
+
$expr = "split(" . join(", ", @exprs) . ")";
if ($ary) {
return $self->maybe_parens("$ary = $expr", $cx, 7);
***************
*** 2853,2862 ****
$repl = $self->dq($repl);
}
}
if (null $kid) {
! $re = re_uninterp(escape_str($op->precomp));
} else {
! $re = $self->deparse($kid, 1);
}
$flags .= "e" if $op->pmflags & PMf_EVAL;
$flags .= "g" if $op->pmflags & PMf_GLOBAL;
--- 3713,3729 ----
$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;
***************
*** 2864,2870 ****
$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 = $substwords{$flags} if $substwords{$flags};
if ($binop) {
return $self->maybe_parens("$var =~ s"
--- 3731,3737 ----
$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"
***************
*** 2957,2975 ****
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<-u>I<PACKAGE>
! Normally, B::Deparse deparses the main code of a program, all the subs
! called by the main program (and all the subs called by them,
! recursively), and any other subs in the main:: package. To include
! subs in other packages that aren't called directly, such as AUTOLOAD,
! DESTROY, other subs called automatically by perl, and methods (which
! aren't resolved to subs until runtime), use the B<-u> option. The
! argument to B<-u> is the name of a package, and should follow directly
! after the 'u'. Multiple B<-u> options may be given, separated by
! commas. Note that unlike some other backends, B::Deparse doesn't
! (yet) try to guess automatically when B<-u> is needed -- you must
! invoke it yourself.
=item B<-s>I<LETTERS>
--- 3824,3837 ----
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<-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<-s>I<LETTERS>
***************
*** 3106,3111 ****
--- 3968,4103 ----
options, like B<-u>, don't make sense for a single subroutine, so
don't pass them.
+ =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.
+
+ =back
+
=head2 coderef2text
$body = $deparse->coderef2text(\&func)
***************
*** 3121,3133 ****
=head1 BUGS
! See the 'to do' list at the beginning of the module file.
=head1 AUTHOR
Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
! contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
! der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.
=cut
--- 4113,4192 ----
=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.
+ 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 be very hard
+ 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 *
+
+ C<sort foo (1, 2, 3)> comes out as C<sort (foo 1, 2, 3)>, which
+ causes perl to issue a warning.
+
+ The obvious fix doesn't work, because these are different:
+
+ print (FOO 1, 2, 3), 4, 5, 6;
+ print FOO (1, 2, 3), 4, 5, 6;
+
+ =item *
+
+ Constants (other than simple strings or numbers) don't work properly.
+ Pathological examples that fail (and probably always will) include:
+
+ use constant E2BIG => ($!=7);
+ use constant x=>\$x; print x
+
+ The following could (and should) be made to work:
+
+ use constant regex => qr/blah/;
+ print regex;
+
+ =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 *
+
+ There are probably many more bugs on non-ASCII platforms (EBCDIC).
+
+ =back
+
=head1 AUTHOR
Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
! contributions from Gisle Aas, James Duncan, Albert Dvornik, Robin
! Houston, Hugo van der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.
=cut
diff -c /dev/null 'perl-5.7.2/ext/B/Debug.t'
Index: ./ext/B/Debug.t
*** ./ext/B/Debug.t Thu Jan 1 02:00:00 1970
--- ./ext/B/Debug.t Mon Jul 9 17:09:51 2001
***************
*** 0 ****
--- 1,70 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ } else {
+ @INC = '.';
+ push @INC, '../lib';
+ }
+ }
+
+ $| = 1;
+ use warnings;
+ use strict;
+ use Config;
+
+ print "1..3\n";
+
+ my $test = 1;
+
+ sub ok { print "ok $test\n"; $test++ }
+
+
+ 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`;
+ print "not " unless $a =~
+ /\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s;
+ ok;
+
+
+ $a = `$^X $path "-MO=Terse" -e 1 $redir`;
+ print "not " unless $a =~
+ /\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s;
+ ok;
+
+ $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+$//;
+ 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 nextstate
+ 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 nextstate
+ EOF
+ }
+ $b=~s/\n/ /g;$b=~s/\s+/ /g;
+ $b =~ s/\s+$//;
+ print "# [$a]\n# vs\n# [$b]\nnot " if $a ne $b;
+ ok;
+
diff -c /dev/null 'perl-5.7.2/ext/B/Deparse.t'
Index: ./ext/B/Deparse.t
*** ./ext/B/Deparse.t Thu Jan 1 02:00:00 1970
--- ./ext/B/Deparse.t Mon Jul 9 17:09:51 2001
***************
*** 0 ****
--- 1,179 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ } else {
+ @INC = '.';
+ push @INC, '../lib';
+ }
+ }
+
+ $| = 1;
+ use warnings;
+ use strict;
+ use Config;
+
+ print "1..15\n";
+
+ use B::Deparse;
+ my $deparse = B::Deparse->new() or print "not ";
+ my $i=1;
+ print "ok " . $i++ . "\n";
+
+
+ # Tell B::Deparse about our ambient pragmas
+ { my ($hint_bits, $warning_bits);
+ BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
+ $deparse->ambient_pragmas (
+ hint_bits => $hint_bits,
+ warning_bits => $warning_bits,
+ '$[' => 0 + $[
+ );
+ }
+
+ $/ = "\n####\n";
+ while (<DATA>) {
+ chomp;
+ s/#.*$//mg;
+
+ my ($input, $expected);
+ if (/(.*)\n>>>>\n(.*)/s) {
+ ($input, $expected) = ($1, $2);
+ }
+ else {
+ ($input, $expected) = ($_, $_);
+ }
+
+ my $coderef = eval "sub {$input}";
+
+ if ($@) {
+ print "not ok " . $i++ . "\n";
+ print "# $@";
+ }
+ else {
+ my $deparsed = $deparse->coderef2text( $coderef );
+ my $regex = quotemeta($expected);
+ do {
+ no warnings 'misc';
+ $regex =~ s/\s+/\s+/g;
+ };
+
+ my $ok = ($deparsed =~ /^\{\s*$regex\s*\}$/);
+ print (($ok ? "ok " : "not ok ") . $i++ . "\n");
+ if (!$ok) {
+ print "# EXPECTED:\n";
+ $regex =~ s/^/# /mg;
+ print "$regex\n";
+
+ print "\n# GOT: \n";
+ $deparsed =~ s/^/# /mg;
+ print "$deparsed\n";
+ }
+ }
+ }
+
+ use constant 'c', 'stuff';
+ print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
+ print "ok " . $i++ . "\n";
+
+ $a = 0;
+ print "not " if "{\n (-1) ** \$a;\n}"
+ ne $deparse->coderef2text(sub{(-1) ** $a });
+ print "ok " . $i++ . "\n";
+
+ # XXX ToDo - constsub that returns a reference
+ #use constant cr => ['hello'];
+ #my $string = "sub " . $deparse->coderef2text(\&cr);
+ #my $val = (eval $string)->();
+ #print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
+ #print "ok " . $i++ . "\n";
+
+ 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=Deparse" -anle 1 $redir`;
+ $a =~ s/-e syntax OK\n//g;
+ $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';
+
+ LINE: while (defined($_ = <ARGV>)) {
+ chomp $_;
+ our(@F) = split(" ", $_, 0);
+ '???';
+ }
+
+ EOF
+ print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b;
+ print "ok " . $i++ . "\n";
+
+ __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()};
diff -c 'perl-5.7.1/ext/B/O.pm' 'perl-5.7.2/ext/B/O.pm'
Index: ./ext/B/O.pm
*** ./ext/B/O.pm Tue Mar 6 04:04:34 2001
--- ./ext/B/O.pm Mon Jul 9 17:09:51 2001
***************
*** 3,21 ****
use Carp;
sub import {
! my ($class, $backend, @options) = @_;
! eval "use B::$backend ()";
! if ($@) {
! croak "use of backend $backend failed: $@";
}
! my $compilesub = &{"B::${backend}::compile"}(@options);
! if (ref($compilesub) eq "CODE") {
! minus_c;
! save_BEGINs;
! eval 'CHECK { &$compilesub() }';
! } else {
! die $compilesub;
! }
}
1;
--- 3,50 ----
use Carp;
sub import {
! my ($class, @options) = @_;
! my ($quiet, $veryquiet) = (0, 0);
! if ($options[0] eq '-q' || $options[0] eq '-qq') {
! $quiet = 1;
! open (SAVEOUT, ">&STDOUT");
! close STDOUT;
! open (STDOUT, ">", \$O::BEGIN_output);
! if ($options[0] eq '-qq') {
! $veryquiet = 1;
! }
! shift @options;
}
! my $backend = shift (@options);
! eval q[
! BEGIN {
! minus_c;
! save_BEGINs;
! }
!
! CHECK {
! if ($quiet) {
! close STDOUT;
! open (STDOUT, ">&SAVEOUT");
! close SAVEOUT;
! }
! use B::].$backend.q[ ();
! if ($@) {
! croak "use of backend $backend failed: $@";
! }
!
!
! my $compilesub = &{"B::${backend}::compile"}(@options);
! if (ref($compilesub) ne "CODE") {
! die $compilesub;
! }
!
! &$compilesub();
!
! close STDERR if $veryquiet;
! }
! ];
! die $@ if $@;
}
1;
***************
*** 28,38 ****
=head1 SYNOPSIS
! perl -MO=Backend[,OPTIONS] foo.pl
=head1 DESCRIPTION
This is the module that is used as a frontend to the Perl Compiler.
=head1 CONVENTIONS
--- 57,80 ----
=head1 SYNOPSIS
! perl -MO=[-q,]Backend[,OPTIONS] foo.pl
=head1 DESCRIPTION
This is the module that is used as a frontend to the Perl Compiler.
+
+ If you pass the C<-q> option to the module, then the STDOUT
+ filehandle will be redirected into the variable C<$O::BEGIN_output>
+ during compilation. This has the effect that any output printed
+ to STDOUT by BEGIN blocks or use'd modules will be stored in this
+ variable rather than printed. It's useful with those backends which
+ produce output themselves (C<Deparse>, C<Concise> etc), so that
+ their output is not confused with that generated by the code
+ being compiled.
+
+ The C<-qq> option behaves like C<-q>, except that it also closes
+ STDERR after deparsing has finished. This suppresses the "Syntax OK"
+ message normally produced by perl.
=head1 CONVENTIONS
diff -c /dev/null 'perl-5.7.2/ext/B/Showlex.t'
Index: ./ext/B/Showlex.t
*** ./ext/B/Showlex.t Thu Jan 1 02:00:00 1970
--- ./ext/B/Showlex.t Mon Jul 9 17:09:51 2001
***************
*** 0 ****
--- 1,39 ----
+ #!./perl
+
+ BEGIN {
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ }
+ }
+
+ $| = 1;
+ use warnings;
+ use strict;
+ use Config;
+
+ print "1..1\n";
+
+ my $test = 1;
+
+ sub ok { print "ok $test\n"; $test++ }
+
+ 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";
+ my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
+
+ if ($is_thread) {
+ print "# use5005threads: test $test skipped\n";
+ } else {
+ $a = `$^X $path "-MO=Showlex" -e "my %one" $redir`;
+ if (ord('A') != 193) { # ASCIIish
+ print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s;
+ }
+ else { # EBCDICish C<1: PVNV (0x1a7ede34) "%\226\225\205">
+ print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%\\[0-9].*sv_undef.*HV/s;
+ }
+ }
+ ok;
diff -c /dev/null 'perl-5.7.2/ext/B/Stash.t'
Index: ./ext/B/Stash.t
*** ./ext/B/Stash.t Thu Jan 1 02:00:00 1970
--- ./ext/B/Stash.t Mon Jul 9 17:09:51 2001
***************
*** 0 ****
--- 1,60 ----
+ #!./perl
+
+ BEGIN {
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ }
+ }
+
+ $| = 1;
+ use warnings;
+ use strict;
+ use Config;
+
+ print "1..1\n";
+
+ my $test = 1;
+
+ sub ok { print "ok $test\n"; $test++ }
+
+
+ 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";
+
+
+ chomp($a = `$^X $path "-MB::Stash" "-Mwarnings" -e1`);
+ $a = join ',', sort split /,/, $a;
+ $a =~ s/-u(PerlIO|open)(?:::\w+)?,//g;
+ $a =~ s/-uWin32,// if $^O eq 'MSWin32';
+ $a =~ s/-uNetWare,// if $^O eq 'NetWare';
+ $a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2';
+ $a =~ s/-uCwd,// if $^O eq 'cygwin';
+ $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,'
+ . '-umain,-ustrict,-uutf8,-uwarnings';
+ if ($Is_VMS) {
+ $a =~ s/-uFile,-uFile::Copy,//;
+ $a =~ s/-uVMS,-uVMS::Filespec,//;
+ $a =~ s/-uSocket,//; # Socket is optional/compiler version dependent
+ }
+
+ {
+ no strict 'vars';
+ use vars '$OS2::is_aout';
+ }
+ if (($Config{static_ext} eq ' ' ||
+ ($Config{static_ext} eq 'Socket' && $Is_VMS))
+ && !($^O eq 'os2' and $OS2::is_aout)
+ ) {
+ if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a)
+ $b = join ',', sort split /,/, $b;
+ }
+ print "# [$a]\n# vs.\n# [$b]\nnot " if $a ne $b;
+ ok;
+ } else {
+ print "ok $test # skipped: one or more static extensions\n"; $test++;
+ }
+
diff -c 'perl-5.7.1/ext/B/defsubs_h.PL' 'perl-5.7.2/ext/B/defsubs_h.PL'
Index: ./ext/B/defsubs_h.PL
*** ./ext/B/defsubs_h.PL Sat Mar 10 23:57:52 2001
--- ./ext/B/defsubs_h.PL Mon Jul 9 17:09:52 2001
***************
*** 13,19 ****
GVf_IMPORTED_AV GVf_IMPORTED_HV
GVf_IMPORTED_SV GVf_IMPORTED_CV
CVf_METHOD CVf_LOCKED CVf_LVALUE
! SVf_IOK SVf_IVisUV SVf_NOK SVf_POK
SVf_ROK SVp_IOK SVp_POK SVp_NOK
))
{
--- 13,19 ----
GVf_IMPORTED_AV GVf_IMPORTED_HV
GVf_IMPORTED_SV GVf_IMPORTED_CV
CVf_METHOD CVf_LOCKED CVf_LVALUE
! SVpad_OUR SVf_IOK SVf_IVisUV SVf_NOK SVf_POK
SVf_ROK SVp_IOK SVp_POK SVp_NOK
))
{
diff -c 'perl-5.7.1/ext/ByteLoader/ByteLoader.xs' 'perl-5.7.2/ext/ByteLoader/ByteLoader.xs'
Index: ./ext/ByteLoader/ByteLoader.xs
*** ./ext/ByteLoader/ByteLoader.xs Tue Mar 6 04:04:35 2001
--- ./ext/ByteLoader/ByteLoader.xs Mon Jul 9 17:09:52 2001
***************
*** 117,123 ****
PROTOTYPES: ENABLE
void
! import(...)
PREINIT:
SV *sv = newSVpvn ("", 0);
PPCODE:
--- 117,124 ----
PROTOTYPES: ENABLE
void
! import(package="ByteLoader", ...)
! char *package
PREINIT:
SV *sv = newSVpvn ("", 0);
PPCODE:
***************
*** 126,131 ****
filter_add(byteloader_filter, sv);
void
! unimport(...)
PPCODE:
filter_del(byteloader_filter);
--- 127,133 ----
filter_add(byteloader_filter, sv);
void
! unimport(package="ByteLoader", ...)
! char *package
PPCODE:
filter_del(byteloader_filter);
diff -c 'perl-5.7.1/ext/ByteLoader/bytecode.h' 'perl-5.7.2/ext/ByteLoader/bytecode.h'
Index: ./ext/ByteLoader/bytecode.h
*** ./ext/ByteLoader/bytecode.h Tue Mar 6 04:04:35 2001
--- ./ext/ByteLoader/bytecode.h Thu Jul 12 16:46:47 2001
***************
*** 74,80 ****
#define BGET_op_tr_array(arg) do { \
unsigned short *ary; \
- int i; \
New(666, ary, 256, unsigned short); \
BGET_FREAD(ary, sizeof(unsigned short), 256); \
arg = (char *) ary; \
--- 74,79 ----
***************
*** 133,140 ****
hv_store((HV*)sv, bstate->bs_pv.xpv_pv, bstate->bs_pv.xpv_cur, arg, 0)
#define BSET_pv_free(pv) Safefree(pv.xpv_pv)
#define BSET_pregcomp(o, arg) \
! ((PMOP*)o)->op_pmregexp = arg ? \
! CALLREGCOMP(aTHX_ arg, arg + bstate->bs_pv.xpv_cur, ((PMOP*)o)) : 0
#define BSET_newsv(sv, arg) \
STMT_START { \
sv = (arg == SVt_PVAV ? (SV*)newAV() : \
--- 132,139 ----
hv_store((HV*)sv, bstate->bs_pv.xpv_pv, bstate->bs_pv.xpv_cur, arg, 0)
#define BSET_pv_free(pv) Safefree(pv.xpv_pv)
#define BSET_pregcomp(o, arg) \
! (PM_SETRE(((PMOP*)o), (arg ? \
! CALLREGCOMP(aTHX_ arg, arg + bstate->bs_pv.xpv_cur, ((PMOP*)o)) : 0)))
#define BSET_newsv(sv, arg) \
STMT_START { \
sv = (arg == SVt_PVAV ? (SV*)newAV() : \
diff -c /dev/null 'perl-5.7.2/ext/Cwd/Cwd.t'
Index: ./ext/Cwd/Cwd.t
*** ./ext/Cwd/Cwd.t Thu Jan 1 02:00:00 1970
--- ./ext/Cwd/Cwd.t Mon Jul 9 17:09:52 2001
***************
*** 0 ****
--- 1,134 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use Config;
+ use Cwd;
+ use strict;
+ use warnings;
+
+ print "1..14\n";
+
+ # check imports
+ print +(defined(&cwd) &&
+ defined(&getcwd) &&
+ defined(&fastcwd) &&
+ defined(&fastgetcwd) ?
+ "" : "not "), "ok 1\n";
+ print +(!defined(&chdir) &&
+ !defined(&abs_path) &&
+ !defined(&fast_abs_path) ?
+ "" : "not "), "ok 2\n";
+
+ # XXX force Cwd to bootsrap its XSUBs since we have set @INC = "../lib"
+ # XXX and subsequent chdir()s can make them impossible to find
+ eval { fastcwd };
+
+ # Must find an external pwd (or equivalent) command.
+
+ my $pwd_cmd =
+ ($^O eq "MSWin32" || $^O eq "NetWare") ? "cd" : (grep { -x && -f } map { "$_/pwd" }
+ split m/$Config{path_sep}/, $ENV{PATH})[0];
+
+ if ($^O eq 'VMS') { $pwd_cmd = 'SHOW DEFAULT'; }
+
+ if (defined $pwd_cmd) {
+ chomp(my $start = `$pwd_cmd`);
+ # Win32's cd returns native C:\ style
+ $start =~ s,\\,/,g if ($^O eq 'MSWin32' || $^O eq "NetWare");
+ # DCL SHOW DEFAULT has leading spaces
+ $start =~ s/^\s+// if $^O eq 'VMS';
+ if ($?) {
+ for (3..6) {
+ print "ok $_ # Skip: '$pwd_cmd' failed\n";
+ }
+ } else {
+ my $cwd = cwd;
+ my $getcwd = getcwd;
+ my $fastcwd = fastcwd;
+ my $fastgetcwd = fastgetcwd;
+ print +($cwd eq $start ? "" : "not "), "ok 3\n";
+ print +($getcwd eq $start ? "" : "not "), "ok 4\n";
+ print +($fastcwd eq $start ? "" : "not "), "ok 5\n";
+ print +($fastgetcwd eq $start ? "" : "not "), "ok 6\n";
+ }
+ } else {
+ for (3..6) {
+ print "ok $_ # Skip: no pwd command found\n";
+ }
+ }
+
+ mkdir "pteerslt", 0777;
+ mkdir "pteerslt/path", 0777;
+ mkdir "pteerslt/path/to", 0777;
+ mkdir "pteerslt/path/to/a", 0777;
+ mkdir "pteerslt/path/to/a/dir", 0777;
+ Cwd::chdir "pteerslt/path/to/a/dir";
+ my $cwd = cwd;
+ my $getcwd = getcwd;
+ my $fastcwd = fastcwd;
+ my $fastgetcwd = fastgetcwd;
+ my $want = "t/pteerslt/path/to/a/dir";
+ print "# cwd = '$cwd'\n";
+ print "# getcwd = '$getcwd'\n";
+ print "# fastcwd = '$fastcwd'\n";
+ print "# fastgetcwd = '$fastgetcwd'\n";
+ # This checked out OK on ODS-2 and ODS-5:
+ $want = "T\.PTEERSLT\.PATH\.TO\.A\.DIR\]" if $^O eq 'VMS';
+ print +($cwd =~ m|$want$| ? "" : "not "), "ok 7\n";
+ print +($getcwd =~ m|$want$| ? "" : "not "), "ok 8\n";
+ print +($fastcwd =~ m|$want$| ? "" : "not "), "ok 9\n";
+ print +($fastgetcwd =~ m|$want$| ? "" : "not "), "ok 10\n";
+
+ # Cwd::chdir should also update $ENV{PWD}
+ print "#$ENV{PWD}\n";
+ print +($ENV{PWD} =~ m|$want$| ? "" : "not "), "ok 11\n";
+ Cwd::chdir ".."; rmdir "dir";
+ print "#$ENV{PWD}\n";
+ Cwd::chdir ".."; rmdir "a";
+ print "#$ENV{PWD}\n";
+ Cwd::chdir ".."; rmdir "to";
+ print "#$ENV{PWD}\n";
+ Cwd::chdir ".."; rmdir "path";
+ print "#$ENV{PWD}\n";
+ Cwd::chdir ".."; rmdir "pteerslt";
+ print "#$ENV{PWD}\n";
+ if ($^O eq 'VMS') {
+ # This checked out OK on ODS-2 and ODS-5:
+ print +($ENV{PWD} =~ m|\bT\]$| ? "" : "not "), "ok 12\n";
+ }
+ else {
+ print +($ENV{PWD} =~ m|\bt$| ? "" : "not "), "ok 12\n";
+ }
+
+ if ($Config{d_symlink}) {
+ mkdir "pteerslt", 0777;
+ mkdir "pteerslt/path", 0777;
+ mkdir "pteerslt/path/to", 0777;
+ mkdir "pteerslt/path/to/a", 0777;
+ mkdir "pteerslt/path/to/a/dir", 0777;
+ symlink "pteerslt/path/to/a/dir" => "linktest";
+
+ my $abs_path = Cwd::abs_path("linktest");
+ my $fast_abs_path = Cwd::fast_abs_path("linktest");
+ my $want = "t/pteerslt/path/to/a/dir";
+
+ print "# abs_path $abs_path\n";
+ print "# fast_abs_path $fast_abs_path\n";
+ print "# want $want\n";
+ print +($abs_path =~ m|$want$| ? "" : "not "), "ok 13\n";
+ print +($fast_abs_path =~ m|$want$| ? "" : "not "), "ok 14\n";
+
+ rmdir "pteerslt/path/to/a/dir";
+ rmdir "pteerslt/path/to/a";
+ rmdir "pteerslt/path/to";
+ rmdir "pteerslt/path";
+ rmdir "pteerslt";
+ unlink "linktest";
+ } else {
+ print "ok 13 # skipped\n";
+ print "ok 14 # skipped\n";
+ }
diff -c 'perl-5.7.1/ext/Cwd/Cwd.xs' 'perl-5.7.2/ext/Cwd/Cwd.xs'
Index: ./ext/Cwd/Cwd.xs
*** ./ext/Cwd/Cwd.xs Sat Mar 31 01:56:41 2001
--- ./ext/Cwd/Cwd.xs Mon Jul 9 17:09:52 2001
***************
*** 2,134 ****
#include "perl.h"
#include "XSUB.h"
! /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
! * Comments from the orignal:
! * This is a faster version of getcwd. It's also more dangerous
! * because you might chdir out of a directory that you can't chdir
! * back into. */
char *
! _cwdxs_fastcwd(void)
{
! /* XXX Should we just use getcwd(3) if available? */
! struct stat statbuf;
! int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
! int i = 0, j = 0, k = 0, ndirs = 16, pathlen = 0, namelen;
! DIR *dir;
! Direntry_t *dp;
! char **names, *path;
! Newz(0, names, ndirs, char*);
! if (PerlLIO_lstat(".", &statbuf) < 0) {
! Safefree(names);
! return FALSE;
! }
! orig_cdev = statbuf.st_dev;
! orig_cino = statbuf.st_ino;
! cdev = orig_cdev;
! cino = orig_cino;
! for (;;) {
! odev = cdev;
! oino = cino;
! if (PerlDir_chdir("..") < 0) {
! Safefree(names);
! return FALSE;
! }
! if (PerlLIO_stat(".", &statbuf) < 0) {
! Safefree(names);
! return FALSE;
! }
! cdev = statbuf.st_dev;
! cino = statbuf.st_ino;
! if (odev == cdev && oino == cino)
! break;
! if (!(dir = PerlDir_open("."))) {
! Safefree(names);
! return FALSE;
! }
! while ((dp = PerlDir_read(dir)) != NULL) {
! if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
! Safefree(names);
! return FALSE;
! }
! if (strEQ(dp->d_name, "."))
! continue;
! if (strEQ(dp->d_name, ".."))
! continue;
! tdev = statbuf.st_dev;
! tino = statbuf.st_ino;
! if (tino == oino && tdev == odev)
! break;
! }
! if (!dp) {
! Safefree(names);
! return FALSE;
! }
! if (i >= ndirs) {
! ndirs += 16;
! Renew(names, ndirs, char*);
! }
! #ifdef DIRNAMLEN
! namelen = dp->d_namlen;
#else
! namelen = strlen(dp->d_name);
#endif
- Newz(0, *(names + i), namelen + 1, char);
- Copy(dp->d_name, *(names + i), namelen, char);
- *(names[i] + namelen) = '\0';
- pathlen += (namelen + 1);
- ++i;
! if (PerlDir_close(dir) < 0) {
! Safefree(names);
! return FALSE;
! }
! }
! Newz(0, path, pathlen + 1, char);
! for (j = i - 1; j >= 0; j--) {
! *(path + k) = '/';
! Copy(names[j], path + k + 1, strlen(names[j]) + 1, char);
! k = k + strlen(names[j]) + 1;
! Safefree(names[j]);
! }
! if (PerlDir_chdir(path) < 0) {
! Safefree(names);
! Safefree(path);
! return FALSE;
! }
! if (PerlLIO_stat(".", &statbuf) < 0) {
! Safefree(names);
! Safefree(path);
! return FALSE;
! }
! cdev = statbuf.st_dev;
! cino = statbuf.st_ino;
! if (cdev != orig_cdev || cino != orig_cino)
! Perl_croak(aTHX_ "Unstable directory path, current directory changed unexpectedly");
!
! Safefree(names);
! return(path);
}
-
MODULE = Cwd PACKAGE = Cwd
! char *
! _fastcwd()
PPCODE:
! char * buf;
! buf = _cwdxs_fastcwd();
! if (buf) {
! PUSHs(sv_2mortal(newSVpv(buf, 0)));
! Safefree(buf);
}
else
! XSRETURN_UNDEF;
--- 2,247 ----
#include "perl.h"
#include "XSUB.h"
! #ifdef I_UNISTD
! # include <unistd.h>
! #endif
!
! /* The realpath() implementation from OpenBSD 2.9 (realpath.c 1.4)
! * Renamed here to bsd_realpath() to avoid library conflicts.
! * --jhi 2000-06-20 */
!
! /*
! * Copyright (c) 1994
! * The Regents of the University of California. All rights reserved.
! *
! * This code is derived from software contributed to Berkeley by
! * Jan-Simon Pendry.
! *
! * Redistribution and use in source and binary forms, with or without
! * modification, are permitted provided that the following conditions
! * are met:
! * 1. Redistributions of source code must retain the above copyright
! * notice, this list of conditions and the following disclaimer.
! * 2. Redistributions in binary form must reproduce the above copyright
! * notice, this list of conditions and the following disclaimer in the
! * documentation and/or other materials provided with the distribution.
! * 3. All advertising materials mentioning features or use of this software
! * must display the following acknowledgement:
! * This product includes software developed by the University of
! * California, Berkeley and its contributors.
! * 4. Neither the name of the University nor the names of its contributors
! * 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
! * 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
! * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
! * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
! * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
! * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
! * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
! * SUCH DAMAGE.
! */
!
! #if defined(LIBC_SCCS) && !defined(lint)
! static char *rcsid = "$OpenBSD: realpath.c,v 1.4 1998/05/18 09:55:19 deraadt Exp $";
! #endif /* LIBC_SCCS and not lint */
!
! /* OpenBSD system #includes removed since the Perl ones should do. --jhi */
!
! #ifndef MAXSYMLINKS
! #define MAXSYMLINKS 8
! #endif
!
! /*
! * char *realpath(const char *path, char resolved_path[MAXPATHLEN]);
! *
! * Find the real name of path, by removing all ".", ".." and symlink
! * components. Returns (resolved) on success, or (NULL) on failure,
! * in which case the path which caused trouble is left in (resolved).
! */
! static
char *
! bsd_realpath(path, resolved)
! const char *path;
! char *resolved;
{
! #ifdef VMS
! return Perl_rmsexpand((char*)path, resolved, NULL, 0);
! #else
! struct stat sb;
! int n, rootd, serrno;
! char *p, *q, wbuf[MAXPATHLEN];
! int symlinks = 0;
! /* Save the starting point. */
! #ifdef HAS_FCHDIR
! int fd;
! if ((fd = open(".", O_RDONLY)) < 0) {
! (void)strcpy(resolved, ".");
! return (NULL);
! }
! #else
! char wd[MAXPATHLEN];
! if (getcwd(wd, MAXPATHLEN - 1) == NULL) {
! (void)strcpy(resolved, ".");
! return (NULL);
! }
! #endif
! /*
! * Find the dirname and basename from the path to be resolved.
! * Change directory to the dirname component.
! * lstat the basename part.
! * if it is a symlink, read in the value and loop.
! * if it is a directory, then change to that directory.
! * get the current directory name and append the basename.
! */
! (void)strncpy(resolved, path, MAXPATHLEN - 1);
! resolved[MAXPATHLEN - 1] = '\0';
! loop:
! q = strrchr(resolved, '/');
! if (q != NULL) {
! p = q + 1;
! if (q == resolved)
! q = "/";
! else {
! do {
! --q;
! } while (q > resolved && *q == '/');
! q[1] = '\0';
! q = resolved;
! }
! if (chdir(q) < 0)
! goto err1;
! } else
! p = resolved;
! #if defined(HAS_LSTAT) && defined(HAS_READLINK) && defined(HAS_SYMLINK)
! /* Deal with the last component. */
! if (lstat(p, &sb) == 0) {
! if (S_ISLNK(sb.st_mode)) {
! if (++symlinks > MAXSYMLINKS) {
! errno = ELOOP;
! goto err1;
! }
! n = readlink(p, resolved, MAXPATHLEN-1);
! if (n < 0)
! goto err1;
! resolved[n] = '\0';
! goto loop;
! }
! if (S_ISDIR(sb.st_mode)) {
! if (chdir(p) < 0)
! goto err1;
! p = "";
! }
! }
! #endif
! /*
! * Save the last component name and get the full pathname of
! * the current directory.
! */
! (void)strcpy(wbuf, p);
! if (getcwd(resolved, MAXPATHLEN) == 0)
! goto err1;
! /*
! * Join the two strings together, ensuring that the right thing
! * happens if the last component is empty, or the dirname is root.
! */
! if (resolved[0] == '/' && resolved[1] == '\0')
! rootd = 1;
! else
! rootd = 0;
!
! if (*wbuf) {
! if (strlen(resolved) + strlen(wbuf) + rootd + 1 > MAXPATHLEN) {
! errno = ENAMETOOLONG;
! goto err1;
! }
! if (rootd == 0)
! (void)strcat(resolved, "/");
! (void)strcat(resolved, wbuf);
! }
!
! /* Go back to where we came from. */
! #ifdef HAS_FCHDIR
! if (fchdir(fd) < 0) {
! serrno = errno;
! goto err2;
! }
#else
! if (chdir(wd) < 0) {
! serrno = errno;
! goto err2;
! }
#endif
! /* It's okay if the close fails, what's an fd more or less? */
! #ifdef HAS_FCHDIR
! (void)close(fd);
! #endif
! return (resolved);
! err1: serrno = errno;
! #ifdef HAS_FCHDIR
! (void)fchdir(fd);
! #else
! (void)chdir(wd);
! #endif
! err2:
! #ifdef HAS_FCHDIR
! (void)close(fd);
! #endif
! errno = serrno;
! return (NULL);
! #endif
}
MODULE = Cwd PACKAGE = Cwd
! PROTOTYPES: ENABLE
!
! void
! fastcwd()
PPCODE:
! {
! dXSTARG;
! getcwd_sv(TARG);
! XSprePUSH; PUSHTARG;
! }
!
! void
! abs_path(pathsv=Nullsv)
! SV *pathsv
! PPCODE:
! {
! dXSTARG;
! char *path;
! STRLEN len;
! char buf[MAXPATHLEN];
!
! if (pathsv)
! path = SvPV(pathsv, len);
! else {
! path = ".";
! len = 1;
}
+
+ if (bsd_realpath(path, buf)) {
+ sv_setpvn(TARG, buf, strlen(buf));
+ SvPOK_only(TARG);
+ }
else
! sv_setsv(TARG, &PL_sv_undef);
!
! XSprePUSH; PUSHTARG;
! }
diff -c 'perl-5.7.1/ext/Cwd/Makefile.PL' 'perl-5.7.2/ext/Cwd/Makefile.PL'
Index: ./ext/Cwd/Makefile.PL
*** ./ext/Cwd/Makefile.PL Sat Mar 31 01:56:41 2001
--- ./ext/Cwd/Makefile.PL Mon Jul 9 17:09:52 2001
***************
*** 1,5 ****
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'Cwd',
! VERSION => '2.04',
);
--- 1,5 ----
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'Cwd',
! VERSION => '2.05',
);
diff -c 'perl-5.7.1/ext/DB_File/Changes' 'perl-5.7.2/ext/DB_File/Changes'
Index: ./ext/DB_File/Changes
*** ./ext/DB_File/Changes Tue Mar 6 04:04:35 2001
--- ./ext/DB_File/Changes Mon Jul 9 17:09:52 2001
***************
*** 334,336 ****
--- 334,357 ----
* Updated dbinfo to support Berkeley DB 3.2 file format changes.
+ 1.76 15th January 2001
+
+ * Added instructions for using LD_PRELOAD to get Berkeley DB 2.x to work
+ with DB_File on Linux. Thanks to Norbert Bollow for sending details of
+ this approach.
+
+
+ 1.77 26th April 2001
+
+ * AIX is reported to need -lpthreads, so Makefile.PL now checks for AIX and
+ adds it to the link options.
+
+ * Minor documentation updates.
+
+ * Merged Core patch 9176
+
+ * Added a patch from Edward Avis that adds support for splice with
+ recno databases.
+
+ * Modified Makefile.PL to only enable the warnings pragma if using perl
+ 5.6.1 or better.
diff -c 'perl-5.7.1/ext/DB_File/DB_File.pm' 'perl-5.7.2/ext/DB_File/DB_File.pm'
Index: ./ext/DB_File/DB_File.pm
*** ./ext/DB_File/DB_File.pm Fri Mar 16 04:54:46 2001
--- ./ext/DB_File/DB_File.pm Mon Jul 9 17:09:52 2001
***************
*** 1,10 ****
# DB_File.pm -- Perl 5 interface to Berkeley DB
#
# written by Paul Marquess (Paul.Marquess@btinternet.com)
! # last modified 17th December 2000
! # version 1.75
#
! # Copyright (c) 1995-2000 Paul Marquess. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
--- 1,10 ----
# DB_File.pm -- Perl 5 interface to Berkeley DB
#
# written by Paul Marquess (Paul.Marquess@btinternet.com)
! # last modified 26th April 2001
! # version 1.77
#
! # Copyright (c) 1995-2001 Paul Marquess. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
***************
*** 151,157 ****
use Carp;
! $VERSION = "1.75" ;
#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
$DB_BTREE = new DB_File::BTREEINFO ;
--- 151,157 ----
use Carp;
! $VERSION = "1.77" ;
#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
$DB_BTREE = new DB_File::BTREEINFO ;
***************
*** 307,312 ****
--- 307,477 ----
}
}
+
+ sub SPLICE
+ {
+ my $self = shift;
+ my $offset = shift;
+ if (not defined $offset) {
+ carp 'Use of uninitialized value in splice';
+ $offset = 0;
+ }
+
+ my $length = @_ ? shift : 0;
+ # Carping about definedness comes _after_ the OFFSET sanity check.
+ # This is so we get the same error messages as Perl's splice().
+ #
+
+ my @list = @_;
+
+ my $size = $self->FETCHSIZE();
+
+ # 'If OFFSET is negative then it start that far from the end of
+ # the array.'
+ #
+ if ($offset < 0) {
+ my $new_offset = $size + $offset;
+ if ($new_offset < 0) {
+ die "Modification of non-creatable array value attempted, "
+ . "subscript $offset";
+ }
+ $offset = $new_offset;
+ }
+
+ if ($offset > $size) {
+ $offset = $size;
+ }
+
+ if (not defined $length) {
+ carp 'Use of uninitialized value in splice';
+ $length = 0;
+ }
+
+ # 'If LENGTH is omitted, removes everything from OFFSET onward.'
+ if (not defined $length) {
+ $length = $size - $offset;
+ }
+
+ # 'If LENGTH is negative, leave that many elements off the end of
+ # the array.'
+ #
+ if ($length < 0) {
+ $length = $size - $offset + $length;
+
+ if ($length < 0) {
+ # The user must have specified a length bigger than the
+ # length of the array passed in. But perl's splice()
+ # doesn't catch this, it just behaves as for length=0.
+ #
+ $length = 0;
+ }
+ }
+
+ if ($length > $size - $offset) {
+ $length = $size - $offset;
+ }
+
+ # $num_elems holds the current number of elements in the database.
+ my $num_elems = $size;
+
+ # 'Removes the elements designated by OFFSET and LENGTH from an
+ # array,'...
+ #
+ my @removed = ();
+ foreach (0 .. $length - 1) {
+ my $old;
+ my $status = $self->get($offset, $old);
+ if ($status != 0) {
+ my $msg = "error from Berkeley DB on get($offset, \$old)";
+ if ($status == 1) {
+ $msg .= ' (no such element?)';
+ }
+ else {
+ $msg .= ": error status $status";
+ if (defined $! and $! ne '') {
+ $msg .= ", message $!";
+ }
+ }
+ die $msg;
+ }
+ push @removed, $old;
+
+ $status = $self->del($offset);
+ if ($status != 0) {
+ my $msg = "error from Berkeley DB on del($offset)";
+ if ($status == 1) {
+ $msg .= ' (no such element?)';
+ }
+ else {
+ $msg .= ": error status $status";
+ if (defined $! and $! ne '') {
+ $msg .= ", message $!";
+ }
+ }
+ die $msg;
+ }
+
+ -- $num_elems;
+ }
+
+ # ...'and replaces them with the elements of LIST, if any.'
+ my $pos = $offset;
+ while (defined (my $elem = shift @list)) {
+ my $old_pos = $pos;
+ my $status;
+ if ($pos >= $num_elems) {
+ $status = $self->put($pos, $elem);
+ }
+ else {
+ $status = $self->put($pos, $elem, $self->R_IBEFORE);
+ }
+
+ if ($status != 0) {
+ my $msg = "error from Berkeley DB on put($pos, $elem, ...)";
+ if ($status == 1) {
+ $msg .= ' (no such element?)';
+ }
+ else {
+ $msg .= ", error status $status";
+ if (defined $! and $! ne '') {
+ $msg .= ", message $!";
+ }
+ }
+ die $msg;
+ }
+
+ die "pos unexpectedly changed from $old_pos to $pos with R_IBEFORE"
+ if $old_pos != $pos;
+
+ ++ $pos;
+ ++ $num_elems;
+ }
+
+ if (wantarray) {
+ # 'In list context, returns the elements removed from the
+ # array.'
+ #
+ return @removed;
+ }
+ elsif (defined wantarray and not wantarray) {
+ # 'In scalar context, returns the last element removed, or
+ # undef if no elements are removed.'
+ #
+ if (@removed) {
+ my $last = pop @removed;
+ return "$last";
+ }
+ else {
+ return undef;
+ }
+ }
+ elsif (not defined wantarray) {
+ # Void context
+ }
+ else { die }
+ }
+ sub ::DB_File::splice { &SPLICE }
+
sub find_dup
{
croak "Usage: \$db->find_dup(key,value)\n"
***************
*** 414,419 ****
--- 579,585 ----
$X->push(list);
$a = $X->shift;
$X->unshift(list);
+ @r = $X->splice(offset, length, elements);
# DBM Filters
$old_filter = $db->filter_store_key ( sub { ... } ) ;
***************
*** 475,481 ****
=head2 Using DB_File with Berkeley DB version 2 or 3
Although B<DB_File> is intended to be used with Berkeley DB version 1,
! it can also be used with version 2.or 3 In this case the interface is
limited to the functionality provided by Berkeley DB 1.x. Anywhere the
version 2 or 3 interface differs, B<DB_File> arranges for it to work
like version 1. This feature allows B<DB_File> scripts that were built
--- 641,647 ----
=head2 Using DB_File with Berkeley DB version 2 or 3
Although B<DB_File> is intended to be used with Berkeley DB version 1,
! it can also be used with version 2 or 3. In this case the interface is
limited to the functionality provided by Berkeley DB 1.x. Anywhere the
version 2 or 3 interface differs, B<DB_File> arranges for it to work
like version 1. This feature allows B<DB_File> scripts that were built
***************
*** 486,493 ****
B<Note:> The database file format has changed in both Berkeley DB
version 2 and 3. If you cannot recreate your databases, you must dump
! any existing databases with the C<db_dump185> utility that comes with
! Berkeley DB.
Once you have rebuilt DB_File to use Berkeley DB version 2 or 3, your
databases can be recreated using C<db_load>. Refer to the Berkeley DB
documentation for further details.
--- 652,659 ----
B<Note:> The database file format has changed in both Berkeley DB
version 2 and 3. If you cannot recreate your databases, you must dump
! any existing databases with either the C<db_dump> or the C<db_dump185>
! utility that comes with Berkeley DB.
Once you have rebuilt DB_File to use Berkeley DB version 2 or 3, your
databases can be recreated using C<db_load>. Refer to the Berkeley DB
documentation for further details.
***************
*** 675,681 ****
use vars qw( %h $k $v ) ;
unlink "fruit" ;
! tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH
or die "Cannot open file 'fruit': $!\n";
# Add a few key/value pairs to the file
--- 841,847 ----
use vars qw( %h $k $v ) ;
unlink "fruit" ;
! tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0666, $DB_HASH
or die "Cannot open file 'fruit': $!\n";
# Add a few key/value pairs to the file
***************
*** 736,742 ****
$DB_BTREE->{'compare'} = \&Compare ;
unlink "tree" ;
! tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE
or die "Cannot open file 'tree': $!\n" ;
# Add a key/value pair to the file
--- 902,908 ----
$DB_BTREE->{'compare'} = \&Compare ;
unlink "tree" ;
! tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0666, $DB_BTREE
or die "Cannot open file 'tree': $!\n" ;
# Add a key/value pair to the file
***************
*** 801,807 ****
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
! tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
or die "Cannot open $filename: $!\n";
# Add some key/value pairs to the file
--- 967,973 ----
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
! tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
or die "Cannot open $filename: $!\n";
# Add some key/value pairs to the file
***************
*** 856,862 ****
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
! $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
or die "Cannot open $filename: $!\n";
# Add some key/value pairs to the file
--- 1022,1028 ----
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
! $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
or die "Cannot open $filename: $!\n";
# Add some key/value pairs to the file
***************
*** 927,933 ****
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
! $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
or die "Cannot open $filename: $!\n";
my $cnt = $x->get_dup("Wall") ;
--- 1093,1099 ----
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
! $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
or die "Cannot open $filename: $!\n";
my $cnt = $x->get_dup("Wall") ;
***************
*** 977,983 ****
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
! $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
or die "Cannot open $filename: $!\n";
$found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ;
--- 1143,1149 ----
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
! $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
or die "Cannot open $filename: $!\n";
$found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ;
***************
*** 1016,1022 ****
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
! $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
or die "Cannot open $filename: $!\n";
$x->del_dup("Wall", "Larry") ;
--- 1182,1188 ----
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
! $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
or die "Cannot open $filename: $!\n";
$x->del_dup("Wall", "Larry") ;
***************
*** 1069,1075 ****
$filename = "tree" ;
unlink $filename ;
! $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
or die "Cannot open $filename: $!\n";
# Add some key/value pairs to the file
--- 1235,1241 ----
$filename = "tree" ;
unlink $filename ;
! $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
or die "Cannot open $filename: $!\n";
# Add some key/value pairs to the file
***************
*** 1149,1154 ****
--- 1315,1323 ----
still have bval default to C<"\n"> for variable length records, and
space for fixed length records.
+ Also note that the bval option only allows you to specify a single byte
+ as a delimeter.
+
=head2 A Simple Example
Here is a simple example that uses RECNO (if you are using a version
***************
*** 1163,1169 ****
unlink $filename ;
my @h ;
! tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO
or die "Cannot open file 'text': $!\n" ;
# Add a few key/value pairs to the file
--- 1332,1338 ----
unlink $filename ;
my @h ;
! tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_RECNO
or die "Cannot open file 'text': $!\n" ;
# Add a few key/value pairs to the file
***************
*** 1237,1242 ****
--- 1406,1415 ----
Returns the number of elements in the array.
+ =item B<$X-E<gt>splice(offset, length, elements);>
+
+ Returns a splice of the the array.
+
=back
=head2 Another Example
***************
*** 1255,1261 ****
unlink $file ;
! $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO
or die "Cannot open file $file: $!\n" ;
# first create a text file to play with
--- 1428,1434 ----
unlink $file ;
! $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0666, $DB_RECNO
or die "Cannot open file $file: $!\n" ;
# first create a text file to play with
***************
*** 1675,1681 ****
The locking technique went like this.
! $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0644)
|| die "dbcreat /tmp/foo.db $!";
$fd = $db->fd;
open(DB_FH, "+<&=$fd") || die "dup $!";
--- 1848,1854 ----
The locking technique went like this.
! $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0666)
|| die "dbcreat /tmp/foo.db $!";
$fd = $db->fd;
open(DB_FH, "+<&=$fd") || die "dup $!";
***************
*** 2033,2039 ****
=head1 COPYRIGHT
! Copyright (c) 1995-1999 Paul Marquess. All rights reserved. This program
is free software; you can redistribute it and/or modify it under the
same terms as Perl itself.
--- 2206,2212 ----
=head1 COPYRIGHT
! Copyright (c) 1995-2001 Paul Marquess. All rights reserved. This program
is free software; you can redistribute it and/or modify it under the
same terms as Perl itself.
diff -c 'perl-5.7.1/ext/DB_File/DB_File.xs' 'perl-5.7.2/ext/DB_File/DB_File.xs'
Index: ./ext/DB_File/DB_File.xs
*** ./ext/DB_File/DB_File.xs Tue Mar 6 04:04:35 2001
--- ./ext/DB_File/DB_File.xs Mon Jul 9 17:09:53 2001
***************
*** 3,14 ****
DB_File.xs -- Perl 5 interface to Berkeley DB
written by Paul Marquess <Paul.Marquess@btinternet.com>
! last modified 17 December 2000
! version 1.75
All comments/suggestions/problems are welcome
! Copyright (c) 1995-2000 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
--- 3,14 ----
DB_File.xs -- Perl 5 interface to Berkeley DB
written by Paul Marquess <Paul.Marquess@btinternet.com>
! last modified 26th April 2001
! version 1.77
All comments/suggestions/problems are welcome
! Copyright (c) 1995-2001 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
***************
*** 90,98 ****
--- 90,101 ----
Added suppport to allow DB_File to be built with
Berkeley DB 3.2 -- btree_compare, btree_prefix and hash_cb
needed to be changed.
+ 1.76 - No change to DB_File.xs
+ 1.77 - Tidied up a few types used in calling newSVpvn.
*/
+ #define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
***************
*** 116,127 ****
--- 119,154 ----
# define DEFSV GvSV(defgv)
#endif
+ /* Mention DB_VERSION_MAJOR_CFG, DB_VERSION_MINOR_CFG, and
+ DB_VERSION_PATCH_CFG here so that Configure pulls them all in. */
+
/* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be
* shortly #included by the <db.h>) __attribute__ to the possibly
* already defined __attribute__, for example by GNUC or by Perl. */
+ #if DB_VERSION_MAJOR_CFG < 2
+
#undef __attribute__
+ /* Since we dropped the gccish definition of __attribute__ we will want
+ * to redefine dNOOP, however (so that dTHX continues to work). Yes,
+ * all this means that we can't do attribute checking on the DB_File,
+ * boo, hiss. */
+ #undef dNOOP
+ #define dNOOP extern int Perl___notused
+ /* Ditto for dXSARGS. */
+ #undef dXSARGS
+ #define dXSARGS \
+ dSP; dMARK; \
+ I32 ax = mark - PL_stack_base + 1; \
+ I32 items = sp - mark
+
+ #endif
+
+ /* avoid -Wall; DB_File xsubs never make use of `ix' setup for ALIASes */
+ #undef dXSI32
+ #define dXSI32 dNOOP
+
/* If Perl has been compiled with Threads support,the symbol op will
be defined here. This clashes with a field name in db.h, so get rid of it.
*/
***************
*** 517,528 ****
dTHX;
#endif
dSP ;
! void * data1, * data2 ;
int retval ;
int count ;
! data1 = key1->data ;
! data2 = key2->data ;
#ifndef newSVpvn
/* As newSVpv will assume that the data pointer is a null terminated C
--- 544,555 ----
dTHX;
#endif
dSP ;
! char * data1, * data2 ;
int retval ;
int count ;
! data1 = (char *) key1->data ;
! data2 = (char *) key2->data ;
#ifndef newSVpvn
/* As newSVpv will assume that the data pointer is a null terminated C
***************
*** 588,599 ****
dTHX;
#endif
dSP ;
! void * data1, * data2 ;
int retval ;
int count ;
! data1 = key1->data ;
! data2 = key2->data ;
#ifndef newSVpvn
/* As newSVpv will assume that the data pointer is a null terminated C
--- 615,626 ----
dTHX;
#endif
dSP ;
! char * data1, * data2 ;
int retval ;
int count ;
! data1 = (char *) key1->data ;
! data2 = (char *) key2->data ;
#ifndef newSVpvn
/* As newSVpv will assume that the data pointer is a null terminated C
***************
*** 1687,1697 ****
OUTPUT:
RETVAL
! int
db_FETCH(db, key, flags=0)
DB_File db
DBTKEY key
u_int flags
CODE:
{
DBT value ;
--- 1714,1726 ----
OUTPUT:
RETVAL
! void
db_FETCH(db, key, flags=0)
DB_File db
DBTKEY key
u_int flags
+ PREINIT:
+ int RETVAL;
CODE:
{
DBT value ;
***************
*** 1714,1722 ****
CurrentDB = db ;
! int
db_FIRSTKEY(db)
DB_File db
CODE:
{
DBTKEY key ;
--- 1743,1753 ----
CurrentDB = db ;
! void
db_FIRSTKEY(db)
DB_File db
+ PREINIT:
+ int RETVAL;
CODE:
{
DBTKEY key ;
***************
*** 1730,1739 ****
OutputKey(ST(0), key) ;
}
! int
db_NEXTKEY(db, key)
DB_File db
DBTKEY key
CODE:
{
DBT value ;
--- 1761,1772 ----
OutputKey(ST(0), key) ;
}
! void
db_NEXTKEY(db, key)
DB_File db
DBTKEY key
+ PREINIT:
+ int RETVAL;
CODE:
{
DBT value ;
***************
*** 1759,1765 ****
DBT value ;
int i ;
int One ;
- DB * Db = db->dbp ;
STRLEN n_a;
DBT_clear(key) ;
--- 1792,1797 ----
***************
*** 1782,1788 ****
#ifdef DB_VERSION_MAJOR
RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ;
#else
! RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ;
#endif
if (RETVAL != 0)
break;
--- 1814,1820 ----
#ifdef DB_VERSION_MAJOR
RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ;
#else
! RETVAL = (db->dbp->put)(db->dbp, &key, &value, R_IBEFORE) ;
#endif
if (RETVAL != 0)
break;
***************
*** 1791,1800 ****
OUTPUT:
RETVAL
! I32
pop(db)
DB_File db
ALIAS: POP = 1
CODE:
{
DBTKEY key ;
--- 1823,1834 ----
OUTPUT:
RETVAL
! void
pop(db)
DB_File db
ALIAS: POP = 1
+ PREINIT:
+ I32 RETVAL;
CODE:
{
DBTKEY key ;
***************
*** 1818,1827 ****
}
}
! I32
shift(db)
DB_File db
ALIAS: SHIFT = 1
CODE:
{
DBT value ;
--- 1852,1863 ----
}
}
! void
shift(db)
DB_File db
ALIAS: SHIFT = 1
+ PREINIT:
+ I32 RETVAL;
CODE:
{
DBT value ;
***************
*** 1962,1977 ****
int
db_fd(db)
DB_File db
- int status = 0 ;
CODE:
CurrentDB = db ;
#ifdef DB_VERSION_MAJOR
RETVAL = -1 ;
! status = (db->in_memory
! ? -1
! : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ;
! if (status != 0)
! RETVAL = -1 ;
#else
RETVAL = (db->in_memory
? -1
--- 1998,2015 ----
int
db_fd(db)
DB_File db
CODE:
CurrentDB = db ;
#ifdef DB_VERSION_MAJOR
RETVAL = -1 ;
! {
! int status = 0 ;
! status = (db->in_memory
! ? -1
! : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ;
! if (status != 0)
! RETVAL = -1 ;
! }
#else
RETVAL = (db->in_memory
? -1
diff -c /dev/null 'perl-5.7.2/ext/DB_File/t/db-btree.t'
Index: ./ext/DB_File/t/db-btree.t
*** ./ext/DB_File/t/db-btree.t Thu Jan 1 02:00:00 1970
--- ./ext/DB_File/t/db-btree.t Mon Jul 9 17:09:53 2001
***************
*** 0 ****
--- 1,1296 ----
+ #!./perl -w
+
+ BEGIN {
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bDB_File\b/) {
+ print "1..0 # Skip: DB_File was not built\n";
+ exit 0;
+ }
+ }
+
+ use warnings;
+ use strict;
+ use DB_File;
+ use Fcntl;
+
+ print "1..157\n";
+
+ sub ok
+ {
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+ }
+
+ sub lexical
+ {
+ my(@a) = unpack ("C*", $a) ;
+ my(@b) = unpack ("C*", $b) ;
+
+ my $len = (@a > @b ? @b : @a) ;
+ my $i = 0 ;
+
+ foreach $i ( 0 .. $len -1) {
+ return $a[$i] - $b[$i] if $a[$i] != $b[$i] ;
+ }
+
+ return @a - @b ;
+ }
+
+ {
+ package Redirect ;
+ use Symbol ;
+
+ sub new
+ {
+ my $class = shift ;
+ my $filename = shift ;
+ my $fh = gensym ;
+ open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
+ my $real_stdout = select($fh) ;
+ return bless [$fh, $real_stdout ] ;
+
+ }
+ sub DESTROY
+ {
+ my $self = shift ;
+ close $self->[0] ;
+ select($self->[1]) ;
+ }
+ }
+
+ sub docat
+ {
+ my $file = shift;
+ #local $/ = undef unless wantarray ;
+ open(CAT,$file) || die "Cannot open $file: $!";
+ my @result = <CAT>;
+ close(CAT);
+ wantarray ? @result : join("", @result) ;
+ }
+
+ sub docat_del
+ {
+ my $file = shift;
+ #local $/ = undef unless wantarray ;
+ open(CAT,$file) || die "Cannot open $file: $!";
+ my @result = <CAT>;
+ close(CAT);
+ unlink $file ;
+ wantarray ? @result : join("", @result) ;
+ }
+
+
+ my $db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ;
+ my $null_keys_allowed = ($DB_File::db_ver < 2.004010
+ || $DB_File::db_ver >= 3.1 );
+
+ my $Dfile = "dbbtree.tmp";
+ unlink $Dfile;
+
+ umask(0);
+
+ # Check the interface to BTREEINFO
+
+ my $dbh = new DB_File::BTREEINFO ;
+ ok(1, ! defined $dbh->{flags}) ;
+ ok(2, ! defined $dbh->{cachesize}) ;
+ ok(3, ! defined $dbh->{psize}) ;
+ ok(4, ! defined $dbh->{lorder}) ;
+ ok(5, ! defined $dbh->{minkeypage}) ;
+ ok(6, ! defined $dbh->{maxkeypage}) ;
+ ok(7, ! defined $dbh->{compare}) ;
+ ok(8, ! defined $dbh->{prefix}) ;
+
+ $dbh->{flags} = 3000 ;
+ ok(9, $dbh->{flags} == 3000) ;
+
+ $dbh->{cachesize} = 9000 ;
+ ok(10, $dbh->{cachesize} == 9000);
+
+ $dbh->{psize} = 400 ;
+ ok(11, $dbh->{psize} == 400) ;
+
+ $dbh->{lorder} = 65 ;
+ ok(12, $dbh->{lorder} == 65) ;
+
+ $dbh->{minkeypage} = 123 ;
+ ok(13, $dbh->{minkeypage} == 123) ;
+
+ $dbh->{maxkeypage} = 1234 ;
+ ok(14, $dbh->{maxkeypage} == 1234 );
+
+ $dbh->{compare} = 1234 ;
+ ok(15, $dbh->{compare} == 1234) ;
+
+ $dbh->{prefix} = 1234 ;
+ ok(16, $dbh->{prefix} == 1234 );
+
+ # Check that an invalid entry is caught both for store & fetch
+ eval '$dbh->{fred} = 1234' ;
+ ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ;
+ eval 'my $q = $dbh->{fred}' ;
+ ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ;
+
+ # Now check the interface to BTREE
+
+ my ($X, %h) ;
+ ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ;
+
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32' || $^O eq 'NetWare');
+
+ my ($key, $value, $i);
+ while (($key,$value) = each(%h)) {
+ $i++;
+ }
+ ok(21, !$i ) ;
+
+ $h{'goner1'} = 'snork';
+
+ $h{'abc'} = 'ABC';
+ ok(22, $h{'abc'} eq 'ABC' );
+ ok(23, ! defined $h{'jimmy'} ) ;
+ ok(24, ! exists $h{'jimmy'} ) ;
+ ok(25, defined $h{'abc'} ) ;
+
+ $h{'def'} = 'DEF';
+ $h{'jkl','mno'} = "JKL\034MNO";
+ $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+ $h{'a'} = 'A';
+
+ #$h{'b'} = 'B';
+ $X->STORE('b', 'B') ;
+
+ $h{'c'} = 'C';
+
+ #$h{'d'} = 'D';
+ $X->put('d', 'D') ;
+
+ $h{'e'} = 'E';
+ $h{'f'} = 'F';
+ $h{'g'} = 'X';
+ $h{'h'} = 'H';
+ $h{'i'} = 'I';
+
+ $h{'goner2'} = 'snork';
+ delete $h{'goner2'};
+
+
+ # IMPORTANT - $X must be undefined before the untie otherwise the
+ # underlying DB close routine will not get called.
+ undef $X ;
+ untie(%h);
+
+ # tie to the same file again
+ ok(26, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ;
+
+ # Modify an entry from the previous tie
+ $h{'g'} = 'G';
+
+ $h{'j'} = 'J';
+ $h{'k'} = 'K';
+ $h{'l'} = 'L';
+ $h{'m'} = 'M';
+ $h{'n'} = 'N';
+ $h{'o'} = 'O';
+ $h{'p'} = 'P';
+ $h{'q'} = 'Q';
+ $h{'r'} = 'R';
+ $h{'s'} = 'S';
+ $h{'t'} = 'T';
+ $h{'u'} = 'U';
+ $h{'v'} = 'V';
+ $h{'w'} = 'W';
+ $h{'x'} = 'X';
+ $h{'y'} = 'Y';
+ $h{'z'} = 'Z';
+
+ $h{'goner3'} = 'snork';
+
+ delete $h{'goner1'};
+ $X->DELETE('goner3');
+
+ my @keys = keys(%h);
+ my @values = values(%h);
+
+ ok(27, $#keys == 29 && $#values == 29) ;
+
+ $i = 0 ;
+ while (($key,$value) = each(%h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+ }
+
+ ok(28, $i == 30) ;
+
+ @keys = ('blurfl', keys(%h), 'dyick');
+ ok(29, $#keys == 31) ;
+
+ #Check that the keys can be retrieved in order
+ my @b = keys %h ;
+ my @c = sort lexical @b ;
+ ok(30, ArrayCompare(\@b, \@c)) ;
+
+ $h{'foo'} = '';
+ ok(31, $h{'foo'} eq '' ) ;
+
+ # Berkeley DB from version 2.4.10 to 3.0 does not allow null keys.
+ # This feature was reenabled in version 3.1 of Berkeley DB.
+ my $result = 0 ;
+ if ($null_keys_allowed) {
+ $h{''} = 'bar';
+ $result = ( $h{''} eq 'bar' );
+ }
+ else
+ { $result = 1 }
+ ok(32, $result) ;
+
+ # check cache overflow and numeric keys and contents
+ my $ok = 1;
+ for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+ for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+ ok(33, $ok);
+
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ ok(34, $size > 0 );
+
+ @h{0..200} = 200..400;
+ my @foo = @h{0..200};
+ ok(35, join(':',200..400) eq join(':',@foo) );
+
+ # Now check all the non-tie specific stuff
+
+
+ # Check R_NOOVERWRITE flag will make put fail when attempting to overwrite
+ # an existing record.
+
+ my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
+ ok(36, $status == 1 );
+
+ # check that the value of the key 'x' has not been changed by the
+ # previous test
+ ok(37, $h{'x'} eq 'X' );
+
+ # standard put
+ $status = $X->put('key', 'value') ;
+ ok(38, $status == 0 );
+
+ #check that previous put can be retrieved
+ $value = 0 ;
+ $status = $X->get('key', $value) ;
+ ok(39, $status == 0 );
+ ok(40, $value eq 'value' );
+
+ # Attempting to delete an existing key should work
+
+ $status = $X->del('q') ;
+ ok(41, $status == 0 );
+ if ($null_keys_allowed) {
+ $status = $X->del('') ;
+ } else {
+ $status = 0 ;
+ }
+ ok(42, $status == 0 );
+
+ # Make sure that the key deleted, cannot be retrieved
+ ok(43, ! defined $h{'q'}) ;
+ ok(44, ! defined $h{''}) ;
+
+ undef $X ;
+ untie %h ;
+
+ ok(45, $X = tie(%h, 'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE ));
+
+ # Attempting to delete a non-existant key should fail
+
+ $status = $X->del('joe') ;
+ ok(46, $status == 1 );
+
+ # Check the get interface
+
+ # First a non-existing key
+ $status = $X->get('aaaa', $value) ;
+ ok(47, $status == 1 );
+
+ # Next an existing key
+ $status = $X->get('a', $value) ;
+ ok(48, $status == 0 );
+ ok(49, $value eq 'A' );
+
+ # seq
+ # ###
+
+ # use seq to find an approximate match
+ $key = 'ke' ;
+ $value = '' ;
+ $status = $X->seq($key, $value, R_CURSOR) ;
+ ok(50, $status == 0 );
+ ok(51, $key eq 'key' );
+ ok(52, $value eq 'value' );
+
+ # seq when the key does not match
+ $key = 'zzz' ;
+ $value = '' ;
+ $status = $X->seq($key, $value, R_CURSOR) ;
+ ok(53, $status == 1 );
+
+
+ # use seq to set the cursor, then delete the record @ the cursor.
+
+ $key = 'x' ;
+ $value = '' ;
+ $status = $X->seq($key, $value, R_CURSOR) ;
+ ok(54, $status == 0 );
+ ok(55, $key eq 'x' );
+ ok(56, $value eq 'X' );
+ $status = $X->del(0, R_CURSOR) ;
+ ok(57, $status == 0 );
+ $status = $X->get('x', $value) ;
+ ok(58, $status == 1 );
+
+ # ditto, but use put to replace the key/value pair.
+ $key = 'y' ;
+ $value = '' ;
+ $status = $X->seq($key, $value, R_CURSOR) ;
+ ok(59, $status == 0 );
+ ok(60, $key eq 'y' );
+ ok(61, $value eq 'Y' );
+
+ $key = "replace key" ;
+ $value = "replace value" ;
+ $status = $X->put($key, $value, R_CURSOR) ;
+ ok(62, $status == 0 );
+ ok(63, $key eq 'replace key' );
+ ok(64, $value eq 'replace value' );
+ $status = $X->get('y', $value) ;
+ ok(65, 1) ; # hard-wire to always pass. the previous test ($status == 1)
+ # only worked because of a bug in 1.85/6
+
+ # use seq to walk forwards through a file
+
+ $status = $X->seq($key, $value, R_FIRST) ;
+ ok(66, $status == 0 );
+ my $previous = $key ;
+
+ $ok = 1 ;
+ while (($status = $X->seq($key, $value, R_NEXT)) == 0)
+ {
+ ($ok = 0), last if ($previous cmp $key) == 1 ;
+ }
+
+ ok(67, $status == 1 );
+ ok(68, $ok == 1 );
+
+ # use seq to walk backwards through a file
+ $status = $X->seq($key, $value, R_LAST) ;
+ ok(69, $status == 0 );
+ $previous = $key ;
+
+ $ok = 1 ;
+ while (($status = $X->seq($key, $value, R_PREV)) == 0)
+ {
+ ($ok = 0), last if ($previous cmp $key) == -1 ;
+ #print "key = [$key] value = [$value]\n" ;
+ }
+
+ ok(70, $status == 1 );
+ ok(71, $ok == 1 );
+
+
+ # check seq FIRST/LAST
+
+ # sync
+ # ####
+
+ $status = $X->sync ;
+ ok(72, $status == 0 );
+
+
+ # fd
+ # ##
+
+ $status = $X->fd ;
+ ok(73, $status != 0 );
+
+
+ undef $X ;
+ untie %h ;
+
+ unlink $Dfile;
+
+ # Now try an in memory file
+ my $Y;
+ ok(74, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE ));
+
+ # fd with an in memory file should return failure
+ $status = $Y->fd ;
+ ok(75, $status == -1 );
+
+
+ undef $Y ;
+ untie %h ;
+
+ # Duplicate keys
+ my $bt = new DB_File::BTREEINFO ;
+ $bt->{flags} = R_DUP ;
+ my ($YY, %hh);
+ ok(76, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ;
+
+ $hh{'Wall'} = 'Larry' ;
+ $hh{'Wall'} = 'Stone' ; # Note the duplicate key
+ $hh{'Wall'} = 'Brick' ; # Note the duplicate key
+ $hh{'Wall'} = 'Brick' ; # Note the duplicate key and value
+ $hh{'Smith'} = 'John' ;
+ $hh{'mouse'} = 'mickey' ;
+
+ # first work in scalar context
+ ok(77, scalar $YY->get_dup('Unknown') == 0 );
+ ok(78, scalar $YY->get_dup('Smith') == 1 );
+ ok(79, scalar $YY->get_dup('Wall') == 4 );
+
+ # now in list context
+ my @unknown = $YY->get_dup('Unknown') ;
+ ok(80, "@unknown" eq "" );
+
+ my @smith = $YY->get_dup('Smith') ;
+ ok(81, "@smith" eq "John" );
+
+ {
+ my @wall = $YY->get_dup('Wall') ;
+ my %wall ;
+ @wall{@wall} = @wall ;
+ ok(82, (@wall == 4 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) );
+ }
+
+ # hash
+ my %unknown = $YY->get_dup('Unknown', 1) ;
+ ok(83, keys %unknown == 0 );
+
+ my %smith = $YY->get_dup('Smith', 1) ;
+ ok(84, keys %smith == 1 && $smith{'John'}) ;
+
+ my %wall = $YY->get_dup('Wall', 1) ;
+ ok(85, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1
+ && $wall{'Brick'} == 2);
+
+ undef $YY ;
+ untie %hh ;
+ unlink $Dfile;
+
+
+ # test multiple callbacks
+ my $Dfile1 = "btree1" ;
+ my $Dfile2 = "btree2" ;
+ my $Dfile3 = "btree3" ;
+
+ my $dbh1 = new DB_File::BTREEINFO ;
+ $dbh1->{compare} = sub {
+ no warnings 'numeric' ;
+ $_[0] <=> $_[1] } ;
+
+ my $dbh2 = new DB_File::BTREEINFO ;
+ $dbh2->{compare} = sub { $_[0] cmp $_[1] } ;
+
+ my $dbh3 = new DB_File::BTREEINFO ;
+ $dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ;
+
+
+ my (%g, %k);
+ tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ;
+ tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ;
+ tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ;
+
+ my @Keys = qw( 0123 12 -1234 9 987654321 def ) ;
+ my (@srt_1, @srt_2, @srt_3);
+ {
+ no warnings 'numeric' ;
+ @srt_1 = sort { $a <=> $b } @Keys ;
+ }
+ @srt_2 = sort { $a cmp $b } @Keys ;
+ @srt_3 = sort { length $a <=> length $b } @Keys ;
+
+ foreach (@Keys) {
+ $h{$_} = 1 ;
+ $g{$_} = 1 ;
+ $k{$_} = 1 ;
+ }
+
+ sub ArrayCompare
+ {
+ my($a, $b) = @_ ;
+
+ return 0 if @$a != @$b ;
+
+ foreach (1 .. length @$a)
+ {
+ return 0 unless $$a[$_] eq $$b[$_] ;
+ }
+
+ 1 ;
+ }
+
+ ok(86, ArrayCompare (\@srt_1, [keys %h]) );
+ ok(87, ArrayCompare (\@srt_2, [keys %g]) );
+ ok(88, ArrayCompare (\@srt_3, [keys %k]) );
+
+ untie %h ;
+ untie %g ;
+ untie %k ;
+ unlink $Dfile1, $Dfile2, $Dfile3 ;
+
+ # clear
+ # #####
+
+ ok(89, tie(%h, 'DB_File', $Dfile1, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+ foreach (1 .. 10)
+ { $h{$_} = $_ * 100 }
+
+ # check that there are 10 elements in the hash
+ $i = 0 ;
+ while (($key,$value) = each(%h)) {
+ $i++;
+ }
+ ok(90, $i == 10);
+
+ # now clear the hash
+ %h = () ;
+
+ # check it is empty
+ $i = 0 ;
+ while (($key,$value) = each(%h)) {
+ $i++;
+ }
+ ok(91, $i == 0);
+
+ untie %h ;
+ unlink $Dfile1 ;
+
+ {
+ # check that attempting to tie an array to a DB_BTREE will fail
+
+ my $filename = "xyz" ;
+ my @x ;
+ eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE ; } ;
+ ok(92, $@ =~ /^DB_File can only tie an associative array to a DB_BTREE database/) ;
+ unlink $filename ;
+ }
+
+ {
+ # sub-class test
+
+ package Another ;
+
+ use warnings ;
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use warnings ;
+ use strict ;
+ use vars qw( @ISA @EXPORT) ;
+
+ require Exporter ;
+ use DB_File;
+ @ISA=qw(DB_File);
+ @EXPORT = @DB_File::EXPORT ;
+
+ sub STORE {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::STORE($key, $value * 2) ;
+ }
+
+ sub FETCH {
+ my $self = shift ;
+ my $key = shift ;
+ $self->SUPER::FETCH($key) - 1 ;
+ }
+
+ sub put {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::put($key, $value * 3) ;
+ }
+
+ sub get {
+ my $self = shift ;
+ $self->SUPER::get($_[0], $_[1]) ;
+ $_[1] -= 2 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+ EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+ eval 'use SubDB ; ';
+ main::ok(93, $@ eq "") ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE );
+ ' ;
+
+ main::ok(94, $@ eq "") ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ main::ok(95, $@ eq "") ;
+ main::ok(96, $ret == 5) ;
+
+ my $value = 0;
+ $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
+ main::ok(97, $@ eq "") ;
+ main::ok(98, $ret == 10) ;
+
+ $ret = eval ' R_NEXT eq main::R_NEXT ' ;
+ main::ok(99, $@ eq "" ) ;
+ main::ok(100, $ret == 1) ;
+
+ $ret = eval '$X->A_new_method("joe") ' ;
+ main::ok(101, $@ eq "") ;
+ main::ok(102, $ret eq "[[11]]") ;
+
+ undef $X;
+ untie(%h);
+ unlink "SubDB.pm", "dbbtree.tmp" ;
+
+ }
+
+ {
+ # DBM Filter tests
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ unlink $Dfile;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ ok(103, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok(104, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(105, $h{"fred"} eq "joe");
+ # fk sk fv sv
+ ok(106, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(107, $db->FIRSTKEY() eq "fred") ;
+ # fk sk fv sv
+ ok(108, checkOutput( "fred", "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok(109, checkOutput( "", "fred", "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(110, $h{"Fred"} eq "[Jxe]");
+ # fk sk fv sv
+ ok(111, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(112, $db->FIRSTKEY() eq "FRED") ;
+ # fk sk fv sv
+ ok(113, checkOutput( "FRED", "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(114, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(115, $h{"fred"} eq "joe");
+ ok(116, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(117, $db->FIRSTKEY() eq "fred") ;
+ ok(118, checkOutput( "fred", "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(119, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(120, $h{"fred"} eq "joe");
+ ok(121, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(122, $db->FIRSTKEY() eq "fred") ;
+ ok(123, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+ }
+
+ {
+ # DBM Filter with a closure
+
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+
+ unlink $Dfile;
+ ok(124, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(125, $result{"store key"} eq "store key - 1: [fred]");
+ ok(126, $result{"store value"} eq "store value - 1: [joe]");
+ ok(127, ! defined $result{"fetch key"} );
+ ok(128, ! defined $result{"fetch value"} );
+ ok(129, $_ eq "original") ;
+
+ ok(130, $db->FIRSTKEY() eq "fred") ;
+ ok(131, $result{"store key"} eq "store key - 1: [fred]");
+ ok(132, $result{"store value"} eq "store value - 1: [joe]");
+ ok(133, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(134, ! defined $result{"fetch value"} );
+ ok(135, $_ eq "original") ;
+
+ $h{"jim"} = "john" ;
+ ok(136, $result{"store key"} eq "store key - 2: [fred jim]");
+ ok(137, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(138, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(139, ! defined $result{"fetch value"} );
+ ok(140, $_ eq "original") ;
+
+ ok(141, $h{"fred"} eq "joe");
+ ok(142, $result{"store key"} eq "store key - 3: [fred jim fred]");
+ ok(143, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(144, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(145, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(146, $_ eq "original") ;
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+ }
+
+ {
+ # DBM Filter recursion detection
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+ unlink $Dfile;
+
+ ok(147, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok(148, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+ }
+
+
+ {
+ # Examples from the POD
+
+
+ my $file = "xyzt" ;
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 1
+ ###
+
+ use warnings FATAL => qw(all) ;
+ use strict ;
+ use DB_File ;
+
+ my %h ;
+
+ sub Compare
+ {
+ my ($key1, $key2) = @_ ;
+ "\L$key1" cmp "\L$key2" ;
+ }
+
+ # specify the Perl sub that will do the comparison
+ $DB_BTREE->{'compare'} = \&Compare ;
+
+ unlink "tree" ;
+ tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open file 'tree': $!\n" ;
+
+ # Add a key/value pair to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+ $h{'duck'} = 'donald' ;
+
+ # Delete
+ delete $h{"duck"} ;
+
+ # Cycle through the keys printing them in order.
+ # Note it is not necessary to sort the keys as
+ # the btree will have kept them in order automatically.
+ foreach (keys %h)
+ { print "$_\n" }
+
+ untie %h ;
+
+ unlink "tree" ;
+ }
+
+ delete $DB_BTREE->{'compare'} ;
+
+ ok(149, docat_del($file) eq <<'EOM') ;
+ mouse
+ Smith
+ Wall
+ EOM
+
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 2
+ ###
+
+ use warnings FATAL => qw(all) ;
+ use strict ;
+ use DB_File ;
+
+ use vars qw($filename %h ) ;
+
+ $filename = "tree" ;
+ unlink $filename ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ # Add some key/value pairs to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+
+ # iterate through the associative array
+ # and print each key/value pair.
+ foreach (keys %h)
+ { print "$_ -> $h{$_}\n" }
+
+ untie %h ;
+
+ unlink $filename ;
+ }
+
+ ok(150, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ;
+ Smith -> John
+ Wall -> Brick
+ Wall -> Brick
+ Wall -> Brick
+ mouse -> mickey
+ EOM
+ Smith -> John
+ Wall -> Larry
+ Wall -> Larry
+ Wall -> Larry
+ mouse -> mickey
+ EOM
+
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 3
+ ###
+
+ use warnings FATAL => qw(all) ;
+ use strict ;
+ use DB_File ;
+
+ use vars qw($filename $x %h $status $key $value) ;
+
+ $filename = "tree" ;
+ unlink $filename ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ # Add some key/value pairs to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+
+ # iterate through the btree using seq
+ # and print each key/value pair.
+ $key = $value = 0 ;
+ for ($status = $x->seq($key, $value, R_FIRST) ;
+ $status == 0 ;
+ $status = $x->seq($key, $value, R_NEXT) )
+ { print "$key -> $value\n" }
+
+
+ undef $x ;
+ untie %h ;
+ }
+
+ ok(151, docat_del($file) eq ($db185mode == 1 ? <<'EOM' : <<'EOM') ) ;
+ Smith -> John
+ Wall -> Brick
+ Wall -> Brick
+ Wall -> Larry
+ mouse -> mickey
+ EOM
+ Smith -> John
+ Wall -> Larry
+ Wall -> Brick
+ Wall -> Brick
+ mouse -> mickey
+ EOM
+
+
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 4
+ ###
+
+ use warnings FATAL => qw(all) ;
+ use strict ;
+ use DB_File ;
+
+ use vars qw($filename $x %h ) ;
+
+ $filename = "tree" ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ my $cnt = $x->get_dup("Wall") ;
+ print "Wall occurred $cnt times\n" ;
+
+ my %hash = $x->get_dup("Wall", 1) ;
+ print "Larry is there\n" if $hash{'Larry'} ;
+ print "There are $hash{'Brick'} Brick Walls\n" ;
+
+ my @list = sort $x->get_dup("Wall") ;
+ print "Wall => [@list]\n" ;
+
+ @list = $x->get_dup("Smith") ;
+ print "Smith => [@list]\n" ;
+
+ @list = $x->get_dup("Dog") ;
+ print "Dog => [@list]\n" ;
+
+ undef $x ;
+ untie %h ;
+ }
+
+ ok(152, docat_del($file) eq <<'EOM') ;
+ Wall occurred 3 times
+ Larry is there
+ There are 2 Brick Walls
+ Wall => [Brick Brick Larry]
+ Smith => [John]
+ Dog => []
+ EOM
+
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 5
+ ###
+
+ use warnings FATAL => qw(all) ;
+ use strict ;
+ use DB_File ;
+
+ use vars qw($filename $x %h $found) ;
+
+ my $filename = "tree" ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ;
+ print "Larry Wall is $found there\n" ;
+
+ $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ;
+ print "Harry Wall is $found there\n" ;
+
+ undef $x ;
+ untie %h ;
+ }
+
+ ok(153, docat_del($file) eq <<'EOM') ;
+ Larry Wall is there
+ Harry Wall is not there
+ EOM
+
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 6
+ ###
+
+ use warnings FATAL => qw(all) ;
+ use strict ;
+ use DB_File ;
+
+ use vars qw($filename $x %h $found) ;
+
+ my $filename = "tree" ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ $x->del_dup("Wall", "Larry") ;
+
+ $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ;
+ print "Larry Wall is $found there\n" ;
+
+ undef $x ;
+ untie %h ;
+
+ unlink $filename ;
+ }
+
+ ok(154, docat_del($file) eq <<'EOM') ;
+ Larry Wall is not there
+ EOM
+
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 7
+ ###
+
+ use warnings FATAL => qw(all) ;
+ use strict ;
+ use DB_File ;
+ use Fcntl ;
+
+ use vars qw($filename $x %h $st $key $value) ;
+
+ sub match
+ {
+ my $key = shift ;
+ my $value = 0;
+ my $orig_key = $key ;
+ $x->seq($key, $value, R_CURSOR) ;
+ print "$orig_key\t-> $key\t-> $value\n" ;
+ }
+
+ $filename = "tree" ;
+ unlink $filename ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ # Add some key/value pairs to the file
+ $h{'mouse'} = 'mickey' ;
+ $h{'Wall'} = 'Larry' ;
+ $h{'Walls'} = 'Brick' ;
+ $h{'Smith'} = 'John' ;
+
+
+ $key = $value = 0 ;
+ print "IN ORDER\n" ;
+ for ($st = $x->seq($key, $value, R_FIRST) ;
+ $st == 0 ;
+ $st = $x->seq($key, $value, R_NEXT) )
+
+ { print "$key -> $value\n" }
+
+ print "\nPARTIAL MATCH\n" ;
+
+ match "Wa" ;
+ match "A" ;
+ match "a" ;
+
+ undef $x ;
+ untie %h ;
+
+ unlink $filename ;
+
+ }
+
+ ok(155, docat_del($file) eq <<'EOM') ;
+ IN ORDER
+ Smith -> John
+ Wall -> Larry
+ Walls -> Brick
+ mouse -> mickey
+
+ PARTIAL MATCH
+ Wa -> Wall -> Larry
+ A -> Smith -> John
+ a -> mouse -> mickey
+ EOM
+
+ }
+
+ #{
+ # # R_SETCURSOR
+ # use strict ;
+ # my (%h, $db) ;
+ # unlink $Dfile;
+ #
+ # ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+ #
+ # $h{abc} = 33 ;
+ # my $k = "newest" ;
+ # my $v = 44 ;
+ # my $status = $db->put($k, $v, R_SETCURSOR) ;
+ # print "status = [$status]\n" ;
+ # ok(157, $status == 0) ;
+ # $status = $db->del($k, R_CURSOR) ;
+ # print "status = [$status]\n" ;
+ # ok(158, $status == 0) ;
+ # $k = "newest" ;
+ # ok(159, $db->get($k, $v, R_CURSOR)) ;
+ #
+ # ok(160, keys %h == 1) ;
+ #
+ # undef $db ;
+ # untie %h;
+ # unlink $Dfile;
+ #}
+
+ {
+ # Bug ID 20001013.009
+ #
+ # test that $hash{KEY} = undef doesn't produce the warning
+ # Use of uninitialized value in null operation
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ unlink $Dfile;
+ my %h ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE
+ or die "Can't open file: $!\n" ;
+ $h{ABC} = undef;
+ ok(156, $a eq "") ;
+ untie %h ;
+ unlink $Dfile;
+ }
+
+ {
+ # test that %hash = () doesn't produce the warning
+ # Argument "" isn't numeric in entersub
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ unlink $Dfile;
+ my %h ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE
+ or die "Can't open file: $!\n" ;
+ %h = (); ;
+ ok(157, $a eq "") ;
+ untie %h ;
+ unlink $Dfile;
+ }
+
+ exit ;
diff -c /dev/null 'perl-5.7.2/ext/DB_File/t/db-hash.t'
Index: ./ext/DB_File/t/db-hash.t
*** ./ext/DB_File/t/db-hash.t Thu Jan 1 02:00:00 1970
--- ./ext/DB_File/t/db-hash.t Mon Jul 9 17:09:53 2001
***************
*** 0 ****
--- 1,743 ----
+ #!./perl -w
+
+ BEGIN {
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bDB_File\b/) {
+ print "1..0 # Skip: DB_File was not built\n";
+ exit 0;
+ }
+ }
+
+ use strict;
+ use warnings;
+ use DB_File;
+ use Fcntl;
+
+ print "1..111\n";
+
+ sub ok
+ {
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+ }
+
+ {
+ package Redirect ;
+ use Symbol ;
+
+ sub new
+ {
+ my $class = shift ;
+ my $filename = shift ;
+ my $fh = gensym ;
+ open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
+ my $real_stdout = select($fh) ;
+ return bless [$fh, $real_stdout ] ;
+
+ }
+ sub DESTROY
+ {
+ my $self = shift ;
+ close $self->[0] ;
+ select($self->[1]) ;
+ }
+ }
+
+ sub docat_del
+ {
+ my $file = shift;
+ local $/ = undef;
+ open(CAT,$file) || die "Cannot open $file: $!";
+ my $result = <CAT>;
+ close(CAT);
+ unlink $file ;
+ return $result;
+ }
+
+ my $Dfile = "dbhash.tmp";
+ my $null_keys_allowed = ($DB_File::db_ver < 2.004010
+ || $DB_File::db_ver >= 3.1 );
+
+ unlink $Dfile;
+
+ umask(0);
+
+ # Check the interface to HASHINFO
+
+ my $dbh = new DB_File::HASHINFO ;
+
+ ok(1, ! defined $dbh->{bsize}) ;
+ ok(2, ! defined $dbh->{ffactor}) ;
+ ok(3, ! defined $dbh->{nelem}) ;
+ ok(4, ! defined $dbh->{cachesize}) ;
+ ok(5, ! defined $dbh->{hash}) ;
+ ok(6, ! defined $dbh->{lorder}) ;
+
+ $dbh->{bsize} = 3000 ;
+ ok(7, $dbh->{bsize} == 3000 );
+
+ $dbh->{ffactor} = 9000 ;
+ ok(8, $dbh->{ffactor} == 9000 );
+
+ $dbh->{nelem} = 400 ;
+ ok(9, $dbh->{nelem} == 400 );
+
+ $dbh->{cachesize} = 65 ;
+ ok(10, $dbh->{cachesize} == 65 );
+
+ $dbh->{hash} = "abc" ;
+ ok(11, $dbh->{hash} eq "abc" );
+
+ $dbh->{lorder} = 1234 ;
+ ok(12, $dbh->{lorder} == 1234 );
+
+ # Check that an invalid entry is caught both for store & fetch
+ eval '$dbh->{fred} = 1234' ;
+ ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ );
+ eval 'my $q = $dbh->{fred}' ;
+ ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ );
+
+
+ # Now check the interface to HASH
+ my ($X, %h);
+ ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32' || $^O eq 'NetWare');
+
+ my ($key, $value, $i);
+ while (($key,$value) = each(%h)) {
+ $i++;
+ }
+ ok(17, !$i );
+
+ $h{'goner1'} = 'snork';
+
+ $h{'abc'} = 'ABC';
+ ok(18, $h{'abc'} eq 'ABC' );
+ ok(19, !defined $h{'jimmy'} );
+ ok(20, !exists $h{'jimmy'} );
+ ok(21, exists $h{'abc'} );
+
+ $h{'def'} = 'DEF';
+ $h{'jkl','mno'} = "JKL\034MNO";
+ $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+ $h{'a'} = 'A';
+
+ #$h{'b'} = 'B';
+ $X->STORE('b', 'B') ;
+
+ $h{'c'} = 'C';
+
+ #$h{'d'} = 'D';
+ $X->put('d', 'D') ;
+
+ $h{'e'} = 'E';
+ $h{'f'} = 'F';
+ $h{'g'} = 'X';
+ $h{'h'} = 'H';
+ $h{'i'} = 'I';
+
+ $h{'goner2'} = 'snork';
+ delete $h{'goner2'};
+
+
+ # IMPORTANT - $X must be undefined before the untie otherwise the
+ # underlying DB close routine will not get called.
+ undef $X ;
+ untie(%h);
+
+
+ # tie to the same file again, do not supply a type - should default to HASH
+ ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) );
+
+ # Modify an entry from the previous tie
+ $h{'g'} = 'G';
+
+ $h{'j'} = 'J';
+ $h{'k'} = 'K';
+ $h{'l'} = 'L';
+ $h{'m'} = 'M';
+ $h{'n'} = 'N';
+ $h{'o'} = 'O';
+ $h{'p'} = 'P';
+ $h{'q'} = 'Q';
+ $h{'r'} = 'R';
+ $h{'s'} = 'S';
+ $h{'t'} = 'T';
+ $h{'u'} = 'U';
+ $h{'v'} = 'V';
+ $h{'w'} = 'W';
+ $h{'x'} = 'X';
+ $h{'y'} = 'Y';
+ $h{'z'} = 'Z';
+
+ $h{'goner3'} = 'snork';
+
+ delete $h{'goner1'};
+ $X->DELETE('goner3');
+
+ my @keys = keys(%h);
+ my @values = values(%h);
+
+ ok(23, $#keys == 29 && $#values == 29) ;
+
+ $i = 0 ;
+ while (($key,$value) = each(%h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+ }
+
+ ok(24, $i == 30) ;
+
+ @keys = ('blurfl', keys(%h), 'dyick');
+ ok(25, $#keys == 31) ;
+
+ $h{'foo'} = '';
+ ok(26, $h{'foo'} eq '' );
+
+ # Berkeley DB from version 2.4.10 to 3.0 does not allow null keys.
+ # This feature was reenabled in version 3.1 of Berkeley DB.
+ my $result = 0 ;
+ if ($null_keys_allowed) {
+ $h{''} = 'bar';
+ $result = ( $h{''} eq 'bar' );
+ }
+ else
+ { $result = 1 }
+ ok(27, $result) ;
+
+ # check cache overflow and numeric keys and contents
+ my $ok = 1;
+ for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+ for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+ ok(28, $ok );
+
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ ok(29, $size > 0 );
+
+ @h{0..200} = 200..400;
+ my @foo = @h{0..200};
+ ok(30, join(':',200..400) eq join(':',@foo) );
+
+
+ # Now check all the non-tie specific stuff
+
+ # Check NOOVERWRITE will make put fail when attempting to overwrite
+ # an existing record.
+
+ my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
+ ok(31, $status == 1 );
+
+ # check that the value of the key 'x' has not been changed by the
+ # previous test
+ ok(32, $h{'x'} eq 'X' );
+
+ # standard put
+ $status = $X->put('key', 'value') ;
+ ok(33, $status == 0 );
+
+ #check that previous put can be retrieved
+ $value = 0 ;
+ $status = $X->get('key', $value) ;
+ ok(34, $status == 0 );
+ ok(35, $value eq 'value' );
+
+ # Attempting to delete an existing key should work
+
+ $status = $X->del('q') ;
+ ok(36, $status == 0 );
+
+ # Make sure that the key deleted, cannot be retrieved
+ {
+ no warnings 'uninitialized' ;
+ ok(37, $h{'q'} eq undef );
+ }
+
+ # Attempting to delete a non-existant key should fail
+
+ $status = $X->del('joe') ;
+ ok(38, $status == 1 );
+
+ # Check the get interface
+
+ # First a non-existing key
+ $status = $X->get('aaaa', $value) ;
+ ok(39, $status == 1 );
+
+ # Next an existing key
+ $status = $X->get('a', $value) ;
+ ok(40, $status == 0 );
+ ok(41, $value eq 'A' );
+
+ # seq
+ # ###
+
+ # ditto, but use put to replace the key/value pair.
+
+ # use seq to walk backwards through a file - check that this reversed is
+
+ # check seq FIRST/LAST
+
+ # sync
+ # ####
+
+ $status = $X->sync ;
+ ok(42, $status == 0 );
+
+
+ # fd
+ # ##
+
+ $status = $X->fd ;
+ ok(43, $status != 0 );
+
+ undef $X ;
+ untie %h ;
+
+ unlink $Dfile;
+
+ # clear
+ # #####
+
+ ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+ foreach (1 .. 10)
+ { $h{$_} = $_ * 100 }
+
+ # check that there are 10 elements in the hash
+ $i = 0 ;
+ while (($key,$value) = each(%h)) {
+ $i++;
+ }
+ ok(45, $i == 10);
+
+ # now clear the hash
+ %h = () ;
+
+ # check it is empty
+ $i = 0 ;
+ while (($key,$value) = each(%h)) {
+ $i++;
+ }
+ ok(46, $i == 0);
+
+ untie %h ;
+ unlink $Dfile ;
+
+
+ # Now try an in memory file
+ ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+ # fd with an in memory file should return fail
+ $status = $X->fd ;
+ ok(48, $status == -1 );
+
+ undef $X ;
+ untie %h ;
+
+ {
+ # check ability to override the default hashing
+ my %x ;
+ my $filename = "xyz" ;
+ my $hi = new DB_File::HASHINFO ;
+ $::count = 0 ;
+ $hi->{hash} = sub { ++$::count ; length $_[0] } ;
+ ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ;
+ $h{"abc"} = 123 ;
+ ok(50, $h{"abc"} == 123) ;
+ untie %x ;
+ unlink $filename ;
+ ok(51, $::count >0) ;
+ }
+
+ {
+ # check that attempting to tie an array to a DB_HASH will fail
+
+ my $filename = "xyz" ;
+ my @x ;
+ eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ;
+ ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ;
+ unlink $filename ;
+ }
+
+ {
+ # sub-class test
+
+ package Another ;
+
+ use warnings ;
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use warnings ;
+ use strict ;
+ use vars qw( @ISA @EXPORT) ;
+
+ require Exporter ;
+ use DB_File;
+ @ISA=qw(DB_File);
+ @EXPORT = @DB_File::EXPORT ;
+
+ sub STORE {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::STORE($key, $value * 2) ;
+ }
+
+ sub FETCH {
+ my $self = shift ;
+ my $key = shift ;
+ $self->SUPER::FETCH($key) - 1 ;
+ }
+
+ sub put {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::put($key, $value * 3) ;
+ }
+
+ sub get {
+ my $self = shift ;
+ $self->SUPER::get($_[0], $_[1]) ;
+ $_[1] -= 2 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+ EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+ eval 'use SubDB ; ';
+ main::ok(53, $@ eq "") ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH );
+ ' ;
+
+ main::ok(54, $@ eq "") ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ main::ok(55, $@ eq "") ;
+ main::ok(56, $ret == 5) ;
+
+ my $value = 0;
+ $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
+ main::ok(57, $@ eq "") ;
+ main::ok(58, $ret == 10) ;
+
+ $ret = eval ' R_NEXT eq main::R_NEXT ' ;
+ main::ok(59, $@ eq "" ) ;
+ main::ok(60, $ret == 1) ;
+
+ $ret = eval '$X->A_new_method("joe") ' ;
+ main::ok(61, $@ eq "") ;
+ main::ok(62, $ret eq "[[11]]") ;
+
+ undef $X;
+ untie(%h);
+ unlink "SubDB.pm", "dbhash.tmp" ;
+
+ }
+
+ {
+ # DBM Filter tests
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ unlink $Dfile;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok(64, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(65, $h{"fred"} eq "joe");
+ # fk sk fv sv
+ ok(66, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(67, $db->FIRSTKEY() eq "fred") ;
+ # fk sk fv sv
+ ok(68, checkOutput( "fred", "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok(69, checkOutput( "", "fred", "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(70, $h{"Fred"} eq "[Jxe]");
+ # fk sk fv sv
+ ok(71, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(72, $db->FIRSTKEY() eq "FRED") ;
+ # fk sk fv sv
+ ok(73, checkOutput( "FRED", "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(74, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(75, $h{"fred"} eq "joe");
+ ok(76, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(77, $db->FIRSTKEY() eq "fred") ;
+ ok(78, checkOutput( "fred", "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(79, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(80, $h{"fred"} eq "joe");
+ ok(81, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(82, $db->FIRSTKEY() eq "fred") ;
+ ok(83, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+ }
+
+ {
+ # DBM Filter with a closure
+
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+
+ unlink $Dfile;
+ ok(84, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(85, $result{"store key"} eq "store key - 1: [fred]");
+ ok(86, $result{"store value"} eq "store value - 1: [joe]");
+ ok(87, ! defined $result{"fetch key"} );
+ ok(88, ! defined $result{"fetch value"} );
+ ok(89, $_ eq "original") ;
+
+ ok(90, $db->FIRSTKEY() eq "fred") ;
+ ok(91, $result{"store key"} eq "store key - 1: [fred]");
+ ok(92, $result{"store value"} eq "store value - 1: [joe]");
+ ok(93, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(94, ! defined $result{"fetch value"} );
+ ok(95, $_ eq "original") ;
+
+ $h{"jim"} = "john" ;
+ ok(96, $result{"store key"} eq "store key - 2: [fred jim]");
+ ok(97, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(98, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(99, ! defined $result{"fetch value"} );
+ ok(100, $_ eq "original") ;
+
+ ok(101, $h{"fred"} eq "joe");
+ ok(102, $result{"store key"} eq "store key - 3: [fred jim fred]");
+ ok(103, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(104, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(105, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(106, $_ eq "original") ;
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+ }
+
+ {
+ # DBM Filter recursion detection
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+ unlink $Dfile;
+
+ ok(107, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok(108, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+ }
+
+
+ {
+ # Examples from the POD
+
+ my $file = "xyzt" ;
+ {
+ my $redirect = new Redirect $file ;
+
+ use warnings FATAL => qw(all);
+ use strict ;
+ use DB_File ;
+ use vars qw( %h $k $v ) ;
+
+ unlink "fruit" ;
+ tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH
+ or die "Cannot open file 'fruit': $!\n";
+
+ # Add a few key/value pairs to the file
+ $h{"apple"} = "red" ;
+ $h{"orange"} = "orange" ;
+ $h{"banana"} = "yellow" ;
+ $h{"tomato"} = "red" ;
+
+ # Check for existence of a key
+ print "Banana Exists\n\n" if $h{"banana"} ;
+
+ # Delete a key/value pair.
+ delete $h{"apple"} ;
+
+ # print the contents of the file
+ while (($k, $v) = each %h)
+ { print "$k -> $v\n" }
+
+ untie %h ;
+
+ unlink "fruit" ;
+ }
+
+ ok(109, docat_del($file) eq <<'EOM') ;
+ Banana Exists
+
+ orange -> orange
+ tomato -> red
+ banana -> yellow
+ EOM
+
+ }
+
+ {
+ # Bug ID 20001013.009
+ #
+ # test that $hash{KEY} = undef doesn't produce the warning
+ # Use of uninitialized value in null operation
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ unlink $Dfile;
+ my %h ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ;
+ $h{ABC} = undef;
+ ok(110, $a eq "") ;
+ untie %h ;
+ unlink $Dfile;
+ }
+
+ {
+ # test that %hash = () doesn't produce the warning
+ # Argument "" isn't numeric in entersub
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ unlink $Dfile;
+ my %h ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ;
+ %h = (); ;
+ ok(111, $a eq "") ;
+ untie %h ;
+ unlink $Dfile;
+ }
+
+ exit ;
diff -c /dev/null 'perl-5.7.2/ext/DB_File/t/db-recno.t'
Index: ./ext/DB_File/t/db-recno.t
*** ./ext/DB_File/t/db-recno.t Thu Jan 1 02:00:00 1970
--- ./ext/DB_File/t/db-recno.t Mon Jul 9 17:09:53 2001
***************
*** 0 ****
--- 1,889 ----
+ #!./perl -w
+
+ BEGIN {
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bDB_File\b/) {
+ print "1..0 # Skip: DB_File was not built\n";
+ exit 0;
+ }
+ }
+
+ use DB_File;
+ use Fcntl;
+ use strict ;
+ use warnings;
+ use vars qw($dbh $Dfile $bad_ones $FA) ;
+
+ # full tied array support started in Perl 5.004_57
+ # Double check to see if it is available.
+
+ {
+ sub try::TIEARRAY { bless [], "try" }
+ sub try::FETCHSIZE { $FA = 1 }
+ $FA = 0 ;
+ my @a ;
+ tie @a, 'try' ;
+ my $a = @a ;
+ }
+
+
+ sub ok
+ {
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+
+ return $result ;
+ }
+
+ {
+ package Redirect ;
+ use Symbol ;
+
+ sub new
+ {
+ my $class = shift ;
+ my $filename = shift ;
+ my $fh = gensym ;
+ open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
+ my $real_stdout = select($fh) ;
+ return bless [$fh, $real_stdout ] ;
+
+ }
+ sub DESTROY
+ {
+ my $self = shift ;
+ close $self->[0] ;
+ select($self->[1]) ;
+ }
+ }
+
+ sub docat
+ {
+ my $file = shift;
+ local $/ = undef;
+ open(CAT,$file) || die "Cannot open $file:$!";
+ my $result = <CAT>;
+ close(CAT);
+ return $result;
+ }
+
+ sub docat_del
+ {
+ my $file = shift;
+ local $/ = undef;
+ open(CAT,$file) || die "Cannot open $file: $!";
+ my $result = <CAT>;
+ close(CAT);
+ unlink $file ;
+ return $result;
+ }
+
+ sub bad_one
+ {
+ print STDERR <<EOM unless $bad_ones++ ;
+ #
+ # Some older versions of Berkeley DB version 1 will fail tests 51,
+ # 53 and 55.
+ #
+ # You can safely ignore the errors if you're never going to use the
+ # broken functionality (recno databases with a modified bval).
+ # Otherwise you'll have to upgrade your DB library.
+ #
+ # If you want to use Berkeley DB version 1, then 1.85 and 1.86 are the
+ # last versions that were released. Berkeley DB version 2 is continually
+ # being updated -- Check out http://www.sleepycat.com/ for more details.
+ #
+ EOM
+ }
+
+ print "1..128\n";
+
+ my $Dfile = "recno.tmp";
+ unlink $Dfile ;
+
+ umask(0);
+
+ # Check the interface to RECNOINFO
+
+ my $dbh = new DB_File::RECNOINFO ;
+ ok(1, ! defined $dbh->{bval}) ;
+ ok(2, ! defined $dbh->{cachesize}) ;
+ ok(3, ! defined $dbh->{psize}) ;
+ ok(4, ! defined $dbh->{flags}) ;
+ ok(5, ! defined $dbh->{lorder}) ;
+ ok(6, ! defined $dbh->{reclen}) ;
+ ok(7, ! defined $dbh->{bfname}) ;
+
+ $dbh->{bval} = 3000 ;
+ ok(8, $dbh->{bval} == 3000 );
+
+ $dbh->{cachesize} = 9000 ;
+ ok(9, $dbh->{cachesize} == 9000 );
+
+ $dbh->{psize} = 400 ;
+ ok(10, $dbh->{psize} == 400 );
+
+ $dbh->{flags} = 65 ;
+ ok(11, $dbh->{flags} == 65 );
+
+ $dbh->{lorder} = 123 ;
+ ok(12, $dbh->{lorder} == 123 );
+
+ $dbh->{reclen} = 1234 ;
+ ok(13, $dbh->{reclen} == 1234 );
+
+ $dbh->{bfname} = 1234 ;
+ ok(14, $dbh->{bfname} == 1234 );
+
+
+ # Check that an invalid entry is caught both for store & fetch
+ eval '$dbh->{fred} = 1234' ;
+ ok(15, $@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ );
+ eval 'my $q = $dbh->{fred}' ;
+ ok(16, $@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ );
+
+ # Now check the interface to RECNOINFO
+
+ my $X ;
+ my @h ;
+ ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
+
+ ok(18, ((stat($Dfile))[2] & 0777) == ($^O eq 'os2' ? 0666 : 0640)
+ || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'amigaos') ;
+
+ #my $l = @h ;
+ my $l = $X->length ;
+ ok(19, ($FA ? @h == 0 : !$l) );
+
+ my @data = qw( a b c d ever f g h i j k longername m n o p) ;
+
+ $h[0] = shift @data ;
+ ok(20, $h[0] eq 'a' );
+
+ my $ i;
+ foreach (@data)
+ { $h[++$i] = $_ }
+
+ unshift (@data, 'a') ;
+
+ ok(21, defined $h[1] );
+ ok(22, ! defined $h[16] );
+ ok(23, $FA ? @h == @data : $X->length == @data );
+
+
+ # Overwrite an entry & check fetch it
+ $h[3] = 'replaced' ;
+ $data[3] = 'replaced' ;
+ ok(24, $h[3] eq 'replaced' );
+
+ #PUSH
+ my @push_data = qw(added to the end) ;
+ ($FA ? push(@h, @push_data) : $X->push(@push_data)) ;
+ push (@data, @push_data) ;
+ ok(25, $h[++$i] eq 'added' );
+ ok(26, $h[++$i] eq 'to' );
+ ok(27, $h[++$i] eq 'the' );
+ ok(28, $h[++$i] eq 'end' );
+
+ # POP
+ my $popped = pop (@data) ;
+ my $value = ($FA ? pop @h : $X->pop) ;
+ ok(29, $value eq $popped) ;
+
+ # SHIFT
+ $value = ($FA ? shift @h : $X->shift) ;
+ my $shifted = shift @data ;
+ ok(30, $value eq $shifted );
+
+ # UNSHIFT
+
+ # empty list
+ ($FA ? unshift @h,() : $X->unshift) ;
+ ok(31, ($FA ? @h == @data : $X->length == @data ));
+
+ my @new_data = qw(add this to the start of the array) ;
+ $FA ? unshift (@h, @new_data) : $X->unshift (@new_data) ;
+ unshift (@data, @new_data) ;
+ ok(32, $FA ? @h == @data : $X->length == @data );
+ ok(33, $h[0] eq "add") ;
+ ok(34, $h[1] eq "this") ;
+ ok(35, $h[2] eq "to") ;
+ ok(36, $h[3] eq "the") ;
+ ok(37, $h[4] eq "start") ;
+ ok(38, $h[5] eq "of") ;
+ ok(39, $h[6] eq "the") ;
+ ok(40, $h[7] eq "array") ;
+ ok(41, $h[8] eq $data[8]) ;
+
+ # SPLICE
+
+ # Now both arrays should be identical
+
+ my $ok = 1 ;
+ my $j = 0 ;
+ foreach (@data)
+ {
+ $ok = 0, last if $_ ne $h[$j ++] ;
+ }
+ ok(42, $ok );
+
+ # Neagtive subscripts
+
+ # get the last element of the array
+ ok(43, $h[-1] eq $data[-1] );
+ ok(44, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] );
+
+ # get the first element using a negative subscript
+ eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ;
+ ok(45, $@ eq "" );
+ ok(46, $h[0] eq "abcd" );
+
+ # now try to read before the start of the array
+ eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ;
+ ok(47, $@ =~ '^Modification of non-creatable array value attempted' );
+
+ # IMPORTANT - $X must be undefined before the untie otherwise the
+ # underlying DB close routine will not get called.
+ undef $X ;
+ untie(@h);
+
+ unlink $Dfile;
+
+
+ {
+ # Check bval defaults to \n
+
+ my @h = () ;
+ my $dbh = new DB_File::RECNOINFO ;
+ ok(48, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+ $h[0] = "abc" ;
+ $h[1] = "def" ;
+ $h[3] = "ghi" ;
+ untie @h ;
+ my $x = docat($Dfile) ;
+ unlink $Dfile;
+ ok(49, $x eq "abc\ndef\n\nghi\n") ;
+ }
+
+ {
+ # Change bval
+
+ my @h = () ;
+ my $dbh = new DB_File::RECNOINFO ;
+ $dbh->{bval} = "-" ;
+ ok(50, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+ $h[0] = "abc" ;
+ $h[1] = "def" ;
+ $h[3] = "ghi" ;
+ untie @h ;
+ my $x = docat($Dfile) ;
+ unlink $Dfile;
+ my $ok = ($x eq "abc-def--ghi-") ;
+ bad_one() unless $ok ;
+ ok(51, $ok) ;
+ }
+
+ {
+ # Check R_FIXEDLEN with default bval (space)
+
+ my @h = () ;
+ my $dbh = new DB_File::RECNOINFO ;
+ $dbh->{flags} = R_FIXEDLEN ;
+ $dbh->{reclen} = 5 ;
+ ok(52, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+ $h[0] = "abc" ;
+ $h[1] = "def" ;
+ $h[3] = "ghi" ;
+ untie @h ;
+ my $x = docat($Dfile) ;
+ unlink $Dfile;
+ my $ok = ($x eq "abc def ghi ") ;
+ bad_one() unless $ok ;
+ ok(53, $ok) ;
+ }
+
+ {
+ # Check R_FIXEDLEN with user-defined bval
+
+ my @h = () ;
+ my $dbh = new DB_File::RECNOINFO ;
+ $dbh->{flags} = R_FIXEDLEN ;
+ $dbh->{bval} = "-" ;
+ $dbh->{reclen} = 5 ;
+ ok(54, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+ $h[0] = "abc" ;
+ $h[1] = "def" ;
+ $h[3] = "ghi" ;
+ untie @h ;
+ my $x = docat($Dfile) ;
+ unlink $Dfile;
+ my $ok = ($x eq "abc--def-------ghi--") ;
+ bad_one() unless $ok ;
+ ok(55, $ok) ;
+ }
+
+ {
+ # check that attempting to tie an associative array to a DB_RECNO will fail
+
+ my $filename = "xyz" ;
+ my %x ;
+ eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ;
+ ok(56, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ;
+ unlink $filename ;
+ }
+
+ {
+ # sub-class test
+
+ package Another ;
+
+ use warnings ;
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use warnings ;
+ use strict ;
+ use vars qw( @ISA @EXPORT) ;
+
+ require Exporter ;
+ use DB_File;
+ @ISA=qw(DB_File);
+ @EXPORT = @DB_File::EXPORT ;
+
+ sub STORE {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::STORE($key, $value * 2) ;
+ }
+
+ sub FETCH {
+ my $self = shift ;
+ my $key = shift ;
+ $self->SUPER::FETCH($key) - 1 ;
+ }
+
+ sub put {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::put($key, $value * 3) ;
+ }
+
+ sub get {
+ my $self = shift ;
+ $self->SUPER::get($_[0], $_[1]) ;
+ $_[1] -= 2 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+ EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+ eval 'use SubDB ; ';
+ main::ok(57, $@ eq "") ;
+ my @h ;
+ my $X ;
+ eval '
+ $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO );
+ ' ;
+
+ main::ok(58, $@ eq "") ;
+
+ my $ret = eval '$h[3] = 3 ; return $h[3] ' ;
+ main::ok(59, $@ eq "") ;
+ main::ok(60, $ret == 5) ;
+
+ my $value = 0;
+ $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ;
+ main::ok(61, $@ eq "") ;
+ main::ok(62, $ret == 10) ;
+
+ $ret = eval ' R_NEXT eq main::R_NEXT ' ;
+ main::ok(63, $@ eq "" ) ;
+ main::ok(64, $ret == 1) ;
+
+ $ret = eval '$X->A_new_method(1) ' ;
+ main::ok(65, $@ eq "") ;
+ main::ok(66, $ret eq "[[11]]") ;
+
+ undef $X;
+ untie(@h);
+ unlink "SubDB.pm", "recno.tmp" ;
+
+ }
+
+ {
+
+ # test $#
+ my $self ;
+ unlink $Dfile;
+ ok(67, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
+ $h[0] = "abc" ;
+ $h[1] = "def" ;
+ $h[2] = "ghi" ;
+ $h[3] = "jkl" ;
+ ok(68, $FA ? $#h == 3 : $self->length() == 4) ;
+ undef $self ;
+ untie @h ;
+ my $x = docat($Dfile) ;
+ ok(69, $x eq "abc\ndef\nghi\njkl\n") ;
+
+ # $# sets array to same length
+ ok(70, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
+ if ($FA)
+ { $#h = 3 }
+ else
+ { $self->STORESIZE(4) }
+ ok(71, $FA ? $#h == 3 : $self->length() == 4) ;
+ undef $self ;
+ untie @h ;
+ $x = docat($Dfile) ;
+ ok(72, $x eq "abc\ndef\nghi\njkl\n") ;
+
+ # $# sets array to bigger
+ ok(73, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
+ if ($FA)
+ { $#h = 6 }
+ else
+ { $self->STORESIZE(7) }
+ ok(74, $FA ? $#h == 6 : $self->length() == 7) ;
+ undef $self ;
+ untie @h ;
+ $x = docat($Dfile) ;
+ ok(75, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ;
+
+ # $# sets array smaller
+ ok(76, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
+ if ($FA)
+ { $#h = 2 }
+ else
+ { $self->STORESIZE(3) }
+ ok(77, $FA ? $#h == 2 : $self->length() == 3) ;
+ undef $self ;
+ untie @h ;
+ $x = docat($Dfile) ;
+ ok(78, $x eq "abc\ndef\nghi\n") ;
+
+ unlink $Dfile;
+
+
+ }
+
+ {
+ # DBM Filter tests
+ use warnings ;
+ use strict ;
+ my (@h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ unlink $Dfile;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ ok(79, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h[0] = "joe" ;
+ # fk sk fv sv
+ ok(80, checkOutput( "", 0, "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(81, $h[0] eq "joe");
+ # fk sk fv sv
+ ok(82, checkOutput( "", 0, "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(83, $db->FIRSTKEY() == 0) ;
+ # fk sk fv sv
+ ok(84, checkOutput( 0, "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { ++ $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ *= 2 ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h[1] = "Joe" ;
+ # fk sk fv sv
+ ok(85, checkOutput( "", 2, "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(86, $h[1] eq "[Jxe]");
+ # fk sk fv sv
+ ok(87, checkOutput( "", 2, "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(88, $db->FIRSTKEY() == 1) ;
+ # fk sk fv sv
+ ok(89, checkOutput( 1, "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h[0] = "joe" ;
+ ok(90, checkOutput( "", 0, "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(91, $h[0] eq "joe");
+ ok(92, checkOutput( "", 0, "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(93, $db->FIRSTKEY() == 0) ;
+ ok(94, checkOutput( 0, "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h[0] = "joe" ;
+ ok(95, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(96, $h[0] eq "joe");
+ ok(97, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(98, $db->FIRSTKEY() == 0) ;
+ ok(99, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie @h;
+ unlink $Dfile;
+ }
+
+ {
+ # DBM Filter with a closure
+
+ use warnings ;
+ use strict ;
+ my (@h, $db) ;
+
+ unlink $Dfile;
+ ok(100, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h[0] = "joe" ;
+ ok(101, $result{"store key"} eq "store key - 1: [0]");
+ ok(102, $result{"store value"} eq "store value - 1: [joe]");
+ ok(103, ! defined $result{"fetch key"} );
+ ok(104, ! defined $result{"fetch value"} );
+ ok(105, $_ eq "original") ;
+
+ ok(106, $db->FIRSTKEY() == 0 ) ;
+ ok(107, $result{"store key"} eq "store key - 1: [0]");
+ ok(108, $result{"store value"} eq "store value - 1: [joe]");
+ ok(109, $result{"fetch key"} eq "fetch key - 1: [0]");
+ ok(110, ! defined $result{"fetch value"} );
+ ok(111, $_ eq "original") ;
+
+ $h[7] = "john" ;
+ ok(112, $result{"store key"} eq "store key - 2: [0 7]");
+ ok(113, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(114, $result{"fetch key"} eq "fetch key - 1: [0]");
+ ok(115, ! defined $result{"fetch value"} );
+ ok(116, $_ eq "original") ;
+
+ ok(117, $h[0] eq "joe");
+ ok(118, $result{"store key"} eq "store key - 3: [0 7 0]");
+ ok(119, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(120, $result{"fetch key"} eq "fetch key - 1: [0]");
+ ok(121, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(122, $_ eq "original") ;
+
+ undef $db ;
+ untie @h;
+ unlink $Dfile;
+ }
+
+ {
+ # DBM Filter recursion detection
+ use warnings ;
+ use strict ;
+ my (@h, $db) ;
+ unlink $Dfile;
+
+ ok(123, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+
+ $db->filter_store_key (sub { $_ = $h[0] }) ;
+
+ eval '$h[1] = 1234' ;
+ ok(124, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie @h;
+ unlink $Dfile;
+ }
+
+
+ {
+ # Examples from the POD
+
+ my $file = "xyzt" ;
+ {
+ my $redirect = new Redirect $file ;
+
+ use warnings FATAL => qw(all);
+ use strict ;
+ use DB_File ;
+
+ my $filename = "text" ;
+ unlink $filename ;
+
+ my @h ;
+ my $x = tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO
+ or die "Cannot open file 'text': $!\n" ;
+
+ # Add a few key/value pairs to the file
+ $h[0] = "orange" ;
+ $h[1] = "blue" ;
+ $h[2] = "yellow" ;
+
+ $FA ? push @h, "green", "black"
+ : $x->push("green", "black") ;
+
+ my $elements = $FA ? scalar @h : $x->length ;
+ print "The array contains $elements entries\n" ;
+
+ my $last = $FA ? pop @h : $x->pop ;
+ print "popped $last\n" ;
+
+ $FA ? unshift @h, "white"
+ : $x->unshift("white") ;
+ my $first = $FA ? shift @h : $x->shift ;
+ print "shifted $first\n" ;
+
+ # Check for existence of a key
+ print "Element 1 Exists with value $h[1]\n" if $h[1] ;
+
+ # use a negative index
+ print "The last element is $h[-1]\n" ;
+ print "The 2nd last element is $h[-2]\n" ;
+
+ undef $x ;
+ untie @h ;
+
+ unlink $filename ;
+ }
+
+ ok(125, docat_del($file) eq <<'EOM') ;
+ The array contains 5 entries
+ popped black
+ shifted white
+ Element 1 Exists with value blue
+ The last element is green
+ The 2nd last element is yellow
+ EOM
+
+ my $save_output = "xyzt" ;
+ {
+ my $redirect = new Redirect $save_output ;
+
+ use warnings FATAL => qw(all);
+ use strict ;
+ use vars qw(@h $H $file $i) ;
+ use DB_File ;
+ use Fcntl ;
+
+ $file = "text" ;
+
+ unlink $file ;
+
+ $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO
+ or die "Cannot open file $file: $!\n" ;
+
+ # first create a text file to play with
+ $h[0] = "zero" ;
+ $h[1] = "one" ;
+ $h[2] = "two" ;
+ $h[3] = "three" ;
+ $h[4] = "four" ;
+
+
+ # Print the records in order.
+ #
+ # The length method is needed here because evaluating a tied
+ # array in a scalar context does not return the number of
+ # elements in the array.
+
+ print "\nORIGINAL\n" ;
+ foreach $i (0 .. $H->length - 1) {
+ print "$i: $h[$i]\n" ;
+ }
+
+ # use the push & pop methods
+ $a = $H->pop ;
+ $H->push("last") ;
+ print "\nThe last record was [$a]\n" ;
+
+ # and the shift & unshift methods
+ $a = $H->shift ;
+ $H->unshift("first") ;
+ print "The first record was [$a]\n" ;
+
+ # Use the API to add a new record after record 2.
+ $i = 2 ;
+ $H->put($i, "Newbie", R_IAFTER) ;
+
+ # and a new record before record 1.
+ $i = 1 ;
+ $H->put($i, "New One", R_IBEFORE) ;
+
+ # delete record 3
+ $H->del(3) ;
+
+ # now print the records in reverse order
+ print "\nREVERSE\n" ;
+ for ($i = $H->length - 1 ; $i >= 0 ; -- $i)
+ { print "$i: $h[$i]\n" }
+
+ # same again, but use the API functions instead
+ print "\nREVERSE again\n" ;
+ my ($s, $k, $v) = (0, 0, 0) ;
+ for ($s = $H->seq($k, $v, R_LAST) ;
+ $s == 0 ;
+ $s = $H->seq($k, $v, R_PREV))
+ { print "$k: $v\n" }
+
+ undef $H ;
+ untie @h ;
+
+ unlink $file ;
+ }
+
+ ok(126, docat_del($save_output) eq <<'EOM') ;
+
+ ORIGINAL
+ 0: zero
+ 1: one
+ 2: two
+ 3: three
+ 4: four
+
+ The last record was [four]
+ The first record was [zero]
+
+ REVERSE
+ 5: last
+ 4: three
+ 3: Newbie
+ 2: one
+ 1: New One
+ 0: first
+
+ REVERSE again
+ 5: last
+ 4: three
+ 3: Newbie
+ 2: one
+ 1: New One
+ 0: first
+ EOM
+
+ }
+
+ {
+ # Bug ID 20001013.009
+ #
+ # test that $hash{KEY} = undef doesn't produce the warning
+ # Use of uninitialized value in null operation
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ unlink $Dfile;
+ my @h ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO
+ or die "Can't open file: $!\n" ;
+ $h[0] = undef;
+ ok(127, $a eq "") ;
+ untie @h ;
+ unlink $Dfile;
+ }
+
+ {
+ # test that %hash = () doesn't produce the warning
+ # Argument "" isn't numeric in entersub
+ use warnings ;
+ use strict ;
+ use DB_File ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ unlink $Dfile;
+ my @h ;
+
+ tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO
+ or die "Can't open file: $!\n" ;
+ @h = (); ;
+ ok(128, $a eq "") ;
+ untie @h ;
+ unlink $Dfile;
+ }
+
+ exit ;
diff -c 'perl-5.7.1/ext/DB_File/version.c' 'perl-5.7.2/ext/DB_File/version.c'
Index: ./ext/DB_File/version.c
*** ./ext/DB_File/version.c Tue Mar 6 04:04:36 2001
--- ./ext/DB_File/version.c Mon Jul 9 17:09:53 2001
***************
*** 8,14 ****
All comments/suggestions/problems are welcome
! Copyright (c) 1995-2000 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
--- 8,14 ----
All comments/suggestions/problems are welcome
! Copyright (c) 1995-2001 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
***************
*** 22,27 ****
--- 22,28 ----
*/
+ #define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
diff -c 'perl-5.7.1/ext/Data/Dumper/Dumper.xs' 'perl-5.7.2/ext/Data/Dumper/Dumper.xs'
Index: ./ext/Data/Dumper/Dumper.xs
*** ./ext/Data/Dumper/Dumper.xs Thu Mar 29 17:25:11 2001
--- ./ext/Data/Dumper/Dumper.xs Mon Jul 9 17:09:53 2001
***************
*** 190,202 ****
AV *seenentry = Nullav;
char *iname;
STRLEN inamelen, idlen = 0;
- U32 flags;
U32 realtype;
if (!val)
return 0;
- flags = SvFLAGS(val);
realtype = SvTYPE(val);
if (SvGMAGICAL(val))
--- 190,200 ----
***************
*** 221,227 ****
}
ival = SvRV(val);
- flags = SvFLAGS(ival);
realtype = SvTYPE(ival);
(void) sprintf(id, "0x%lx", (unsigned long)ival);
idlen = strlen(id);
--- 219,224 ----
***************
*** 776,784 ****
HV *seenhv = Nullhv;
AV *postav, *todumpav, *namesav;
I32 level = 0;
! I32 indent, terse, useqq, i, imax, postlen;
SV **svp;
! SV *val, *name, *pad, *xpad, *apad, *sep, *tmp, *varname;
SV *freezer, *toaster, *bless;
I32 purity, deepcopy, quotekeys, maxdepth = 0;
char tmpbuf[1024];
--- 773,781 ----
HV *seenhv = Nullhv;
AV *postav, *todumpav, *namesav;
I32 level = 0;
! I32 indent, terse, i, imax, postlen;
SV **svp;
! SV *val, *name, *pad, *xpad, *apad, *sep, *varname;
SV *freezer, *toaster, *bless;
I32 purity, deepcopy, quotekeys, maxdepth = 0;
char tmpbuf[1024];
***************
*** 811,821 ****
todumpav = namesav = Nullav;
seenhv = Nullhv;
! val = pad = xpad = apad = sep = tmp = varname
= freezer = toaster = bless = &PL_sv_undef;
name = sv_newmortal();
indent = 2;
! terse = useqq = purity = deepcopy = 0;
quotekeys = 1;
retval = newSVpvn("", 0);
--- 808,818 ----
todumpav = namesav = Nullav;
seenhv = Nullhv;
! val = pad = xpad = apad = sep = varname
= freezer = toaster = bless = &PL_sv_undef;
name = sv_newmortal();
indent = 2;
! terse = purity = deepcopy = 0;
quotekeys = 1;
retval = newSVpvn("", 0);
***************
*** 835,842 ****
--- 832,841 ----
purity = SvIV(*svp);
if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
terse = SvTRUE(*svp);
+ #if 0 /* useqq currently unused */
if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
useqq = SvTRUE(*svp);
+ #endif
if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
pad = *svp;
if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
diff -c /dev/null 'perl-5.7.2/ext/Data/Dumper/t/dumper.t'
Index: ./ext/Data/Dumper/t/dumper.t
*** ./ext/Data/Dumper/t/dumper.t Thu Jan 1 02:00:00 1970
--- ./ext/Data/Dumper/t/dumper.t Mon Jul 9 17:09:54 2001
***************
*** 0 ****
--- 1,810 ----
+ #!./perl -w
+ #
+ # testsuite for Data::Dumper
+ #
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
+ print "1..0 # Skip: Data::Dumper was not built\n";
+ exit 0;
+ }
+ }
+
+ use Data::Dumper;
+ use Config;
+ my $Is_ebcdic = defined($Config{'ebcdic'}) && $Config{'ebcdic'} eq 'define';
+
+ $Data::Dumper::Pad = "#";
+ my $TMAX;
+ my $XS;
+ my $TNUM = 0;
+ my $WANT = '';
+
+ sub TEST {
+ my $string = shift;
+ my $t = eval $string;
+ ++$TNUM;
+ $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g
+ if ($WANT =~ /deadbeef/);
+ if ($Is_ebcdic) {
+ # these data need massaging with non ascii character sets
+ # because of hashing order differences
+ $WANT = join("\n",sort(split(/\n/,$WANT)));
+ $WANT =~ s/\,$//mg;
+ $t = join("\n",sort(split(/\n/,$t)));
+ $t =~ s/\,$//mg;
+ }
+ print( ($t eq $WANT and not $@) ? "ok $TNUM\n"
+ : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n");
+
+ ++$TNUM;
+ eval "$t";
+ print $@ ? "not ok $TNUM\n# \$@ says: $@\n" : "ok $TNUM\n";
+
+ $t = eval $string;
+ ++$TNUM;
+ $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g
+ if ($WANT =~ /deadbeef/);
+ if ($Is_ebcdic) {
+ # here too there are hashing order differences
+ $WANT = join("\n",sort(split(/\n/,$WANT)));
+ $WANT =~ s/\,$//mg;
+ $t = join("\n",sort(split(/\n/,$t)));
+ $t =~ s/\,$//mg;
+ }
+ print( ($t eq $WANT and not $@) ? "ok $TNUM\n"
+ : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n");
+ }
+
+ if (defined &Data::Dumper::Dumpxs) {
+ print "### XS extension loaded, will run XS tests\n";
+ $TMAX = 186; $XS = 1;
+ }
+ else {
+ print "### XS extensions not loaded, will NOT run XS tests\n";
+ $TMAX = 93; $XS = 0;
+ }
+
+ print "1..$TMAX\n";
+
+ #############
+ #############
+
+ @c = ('c');
+ $c = \@c;
+ $b = {};
+ $a = [1, $b, $c];
+ $b->{a} = $a;
+ $b->{b} = $a->[1];
+ $b->{c} = $a->[2];
+
+ ############# 1
+ ##
+ $WANT = <<'EOT';
+ #$a = [
+ # 1,
+ # {
+ # 'c' => [
+ # 'c'
+ # ],
+ # 'a' => $a,
+ # 'b' => $a->[1]
+ # },
+ # $a->[1]{'c'}
+ # ];
+ #$b = $a->[1];
+ #$c = $a->[1]{'c'};
+ EOT
+
+ TEST q(Data::Dumper->Dump([$a,$b,$c], [qw(a b c)]));
+ TEST q(Data::Dumper->Dumpxs([$a,$b,$c], [qw(a b c)])) if $XS;
+
+
+ ############# 7
+ ##
+ $WANT = <<'EOT';
+ #@a = (
+ # 1,
+ # {
+ # 'c' => [
+ # 'c'
+ # ],
+ # 'a' => [],
+ # 'b' => {}
+ # },
+ # []
+ # );
+ #$a[1]{'a'} = \@a;
+ #$a[1]{'b'} = $a[1];
+ #$a[2] = $a[1]{'c'};
+ #$b = $a[1];
+ EOT
+
+ $Data::Dumper::Purity = 1; # fill in the holes for eval
+ TEST q(Data::Dumper->Dump([$a, $b], [qw(*a b)])); # print as @a
+ TEST q(Data::Dumper->Dumpxs([$a, $b], [qw(*a b)])) if $XS;
+
+ ############# 13
+ ##
+ $WANT = <<'EOT';
+ #%b = (
+ # 'c' => [
+ # 'c'
+ # ],
+ # 'a' => [
+ # 1,
+ # {},
+ # []
+ # ],
+ # 'b' => {}
+ # );
+ #$b{'a'}[1] = \%b;
+ #$b{'a'}[2] = $b{'c'};
+ #$b{'b'} = \%b;
+ #$a = $b{'a'};
+ EOT
+
+ TEST q(Data::Dumper->Dump([$b, $a], [qw(*b a)])); # print as %b
+ TEST q(Data::Dumper->Dumpxs([$b, $a], [qw(*b a)])) if $XS;
+
+ ############# 19
+ ##
+ $WANT = <<'EOT';
+ #$a = [
+ # 1,
+ # {
+ # 'c' => [],
+ # 'a' => [],
+ # 'b' => {}
+ # },
+ # []
+ #];
+ #$a->[1]{'c'} = \@c;
+ #$a->[1]{'a'} = $a;
+ #$a->[1]{'b'} = $a->[1];
+ #$a->[2] = \@c;
+ #$b = $a->[1];
+ EOT
+
+ $Data::Dumper::Indent = 1;
+ TEST q(
+ $d = Data::Dumper->new([$a,$b], [qw(a b)]);
+ $d->Seen({'*c' => $c});
+ $d->Dump;
+ );
+ if ($XS) {
+ TEST q(
+ $d = Data::Dumper->new([$a,$b], [qw(a b)]);
+ $d->Seen({'*c' => $c});
+ $d->Dumpxs;
+ );
+ }
+
+
+ ############# 25
+ ##
+ $WANT = <<'EOT';
+ #$a = [
+ # #0
+ # 1,
+ # #1
+ # {
+ # c => [
+ # #0
+ # 'c'
+ # ],
+ # a => $a,
+ # b => $a->[1]
+ # },
+ # #2
+ # $a->[1]{c}
+ # ];
+ #$b = $a->[1];
+ EOT
+
+ $d->Indent(3);
+ $d->Purity(0)->Quotekeys(0);
+ TEST q( $d->Reset; $d->Dump );
+
+ TEST q( $d->Reset; $d->Dumpxs ) if $XS;
+
+ ############# 31
+ ##
+ $WANT = <<'EOT';
+ #$VAR1 = [
+ # 1,
+ # {
+ # 'c' => [
+ # 'c'
+ # ],
+ # 'a' => [],
+ # 'b' => {}
+ # },
+ # []
+ #];
+ #$VAR1->[1]{'a'} = $VAR1;
+ #$VAR1->[1]{'b'} = $VAR1->[1];
+ #$VAR1->[2] = $VAR1->[1]{'c'};
+ EOT
+
+ TEST q(Dumper($a));
+ TEST q(Data::Dumper::DumperX($a)) if $XS;
+
+ ############# 37
+ ##
+ $WANT = <<'EOT';
+ #[
+ # 1,
+ # {
+ # c => [
+ # 'c'
+ # ],
+ # a => $VAR1,
+ # b => $VAR1->[1]
+ # },
+ # $VAR1->[1]{c}
+ #]
+ EOT
+
+ {
+ local $Data::Dumper::Purity = 0;
+ local $Data::Dumper::Quotekeys = 0;
+ local $Data::Dumper::Terse = 1;
+ TEST q(Dumper($a));
+ TEST q(Data::Dumper::DumperX($a)) if $XS;
+ }
+
+
+ ############# 43
+ ##
+ $WANT = <<'EOT';
+ #$VAR1 = {
+ # "reftest" => \\1,
+ # "abc\0'\efg" => "mno\0"
+ #};
+ EOT
+
+ $foo = { "abc\000\'\efg" => "mno\000",
+ "reftest" => \\1,
+ };
+ {
+ local $Data::Dumper::Useqq = 1;
+ TEST q(Dumper($foo));
+ }
+
+ $WANT = <<"EOT";
+ #\$VAR1 = {
+ # 'reftest' => \\\\1,
+ # 'abc\0\\'\efg' => 'mno\0'
+ #};
+ EOT
+
+ {
+ local $Data::Dumper::Useqq = 1;
+ TEST q(Data::Dumper::DumperX($foo)) if $XS; # cheat
+ }
+
+
+
+ #############
+ #############
+
+ {
+ package main;
+ use Data::Dumper;
+ $foo = 5;
+ @foo = (-10,\*foo);
+ %foo = (a=>1,b=>\$foo,c=>\@foo);
+ $foo{d} = \%foo;
+ $foo[2] = \%foo;
+
+ ############# 49
+ ##
+ $WANT = <<'EOT';
+ #$foo = \*::foo;
+ #*::foo = \5;
+ #*::foo = [
+ # #0
+ # -10,
+ # #1
+ # do{my $o},
+ # #2
+ # {
+ # 'c' => [],
+ # 'a' => 1,
+ # 'b' => do{my $o},
+ # 'd' => {}
+ # }
+ # ];
+ #*::foo{ARRAY}->[1] = $foo;
+ #*::foo{ARRAY}->[2]{'c'} = *::foo{ARRAY};
+ #*::foo{ARRAY}->[2]{'b'} = *::foo{SCALAR};
+ #*::foo{ARRAY}->[2]{'d'} = *::foo{ARRAY}->[2];
+ #*::foo = *::foo{ARRAY}->[2];
+ #@bar = @{*::foo{ARRAY}};
+ #%baz = %{*::foo{ARRAY}->[2]};
+ EOT
+
+ $Data::Dumper::Purity = 1;
+ $Data::Dumper::Indent = 3;
+ TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz']));
+ TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])) if $XS;
+
+ ############# 55
+ ##
+ $WANT = <<'EOT';
+ #$foo = \*::foo;
+ #*::foo = \5;
+ #*::foo = [
+ # -10,
+ # do{my $o},
+ # {
+ # 'c' => [],
+ # 'a' => 1,
+ # 'b' => do{my $o},
+ # 'd' => {}
+ # }
+ #];
+ #*::foo{ARRAY}->[1] = $foo;
+ #*::foo{ARRAY}->[2]{'c'} = *::foo{ARRAY};
+ #*::foo{ARRAY}->[2]{'b'} = *::foo{SCALAR};
+ #*::foo{ARRAY}->[2]{'d'} = *::foo{ARRAY}->[2];
+ #*::foo = *::foo{ARRAY}->[2];
+ #$bar = *::foo{ARRAY};
+ #$baz = *::foo{ARRAY}->[2];
+ EOT
+
+ $Data::Dumper::Indent = 1;
+ TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz']));
+ TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])) if $XS;
+
+ ############# 61
+ ##
+ $WANT = <<'EOT';
+ #@bar = (
+ # -10,
+ # \*::foo,
+ # {}
+ #);
+ #*::foo = \5;
+ #*::foo = \@bar;
+ #*::foo = {
+ # 'c' => [],
+ # 'a' => 1,
+ # 'b' => do{my $o},
+ # 'd' => {}
+ #};
+ #*::foo{HASH}->{'c'} = \@bar;
+ #*::foo{HASH}->{'b'} = *::foo{SCALAR};
+ #*::foo{HASH}->{'d'} = *::foo{HASH};
+ #$bar[2] = *::foo{HASH};
+ #%baz = %{*::foo{HASH}};
+ #$foo = $bar[1];
+ EOT
+
+ TEST q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo']));
+ TEST q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo'])) if $XS;
+
+ ############# 67
+ ##
+ $WANT = <<'EOT';
+ #$bar = [
+ # -10,
+ # \*::foo,
+ # {}
+ #];
+ #*::foo = \5;
+ #*::foo = $bar;
+ #*::foo = {
+ # 'c' => [],
+ # 'a' => 1,
+ # 'b' => do{my $o},
+ # 'd' => {}
+ #};
+ #*::foo{HASH}->{'c'} = $bar;
+ #*::foo{HASH}->{'b'} = *::foo{SCALAR};
+ #*::foo{HASH}->{'d'} = *::foo{HASH};
+ #$bar->[2] = *::foo{HASH};
+ #$baz = *::foo{HASH};
+ #$foo = $bar->[1];
+ EOT
+
+ TEST q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo']));
+ TEST q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo'])) if $XS;
+
+ ############# 73
+ ##
+ $WANT = <<'EOT';
+ #$foo = \*::foo;
+ #@bar = (
+ # -10,
+ # $foo,
+ # {
+ # c => \@bar,
+ # a => 1,
+ # b => \5,
+ # d => $bar[2]
+ # }
+ #);
+ #%baz = %{$bar[2]};
+ EOT
+
+ $Data::Dumper::Purity = 0;
+ $Data::Dumper::Quotekeys = 0;
+ TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz']));
+ TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])) if $XS;
+
+ ############# 79
+ ##
+ $WANT = <<'EOT';
+ #$foo = \*::foo;
+ #$bar = [
+ # -10,
+ # $foo,
+ # {
+ # c => $bar,
+ # a => 1,
+ # b => \5,
+ # d => $bar->[2]
+ # }
+ #];
+ #$baz = $bar->[2];
+ EOT
+
+ TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz']));
+ TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])) if $XS;
+
+ }
+
+ #############
+ #############
+ {
+ package main;
+ @dogs = ( 'Fido', 'Wags' );
+ %kennel = (
+ First => \$dogs[0],
+ Second => \$dogs[1],
+ );
+ $dogs[2] = \%kennel;
+ $mutts = \%kennel;
+ $mutts = $mutts; # avoid warning
+
+ ############# 85
+ ##
+ $WANT = <<'EOT';
+ #%kennels = (
+ # Second => \'Wags',
+ # First => \'Fido'
+ #);
+ #@dogs = (
+ # ${$kennels{First}},
+ # ${$kennels{Second}},
+ # \%kennels
+ #);
+ #%mutts = %kennels;
+ EOT
+
+ TEST q(
+ $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts],
+ [qw(*kennels *dogs *mutts)] );
+ $d->Dump;
+ );
+ if ($XS) {
+ TEST q(
+ $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts],
+ [qw(*kennels *dogs *mutts)] );
+ $d->Dumpxs;
+ );
+ }
+
+ ############# 91
+ ##
+ $WANT = <<'EOT';
+ #%kennels = %kennels;
+ #@dogs = @dogs;
+ #%mutts = %kennels;
+ EOT
+
+ TEST q($d->Dump);
+ TEST q($d->Dumpxs) if $XS;
+
+ ############# 97
+ ##
+ $WANT = <<'EOT';
+ #%kennels = (
+ # Second => \'Wags',
+ # First => \'Fido'
+ #);
+ #@dogs = (
+ # ${$kennels{First}},
+ # ${$kennels{Second}},
+ # \%kennels
+ #);
+ #%mutts = %kennels;
+ EOT
+
+
+ TEST q($d->Reset; $d->Dump);
+ if ($XS) {
+ TEST q($d->Reset; $d->Dumpxs);
+ }
+
+ ############# 103
+ ##
+ $WANT = <<'EOT';
+ #@dogs = (
+ # 'Fido',
+ # 'Wags',
+ # {
+ # Second => \$dogs[1],
+ # First => \$dogs[0]
+ # }
+ #);
+ #%kennels = %{$dogs[2]};
+ #%mutts = %{$dogs[2]};
+ EOT
+
+ TEST q(
+ $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts],
+ [qw(*dogs *kennels *mutts)] );
+ $d->Dump;
+ );
+ if ($XS) {
+ TEST q(
+ $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts],
+ [qw(*dogs *kennels *mutts)] );
+ $d->Dumpxs;
+ );
+ }
+
+ ############# 109
+ ##
+ TEST q($d->Reset->Dump);
+ if ($XS) {
+ TEST q($d->Reset->Dumpxs);
+ }
+
+ ############# 115
+ ##
+ $WANT = <<'EOT';
+ #@dogs = (
+ # 'Fido',
+ # 'Wags',
+ # {
+ # Second => \'Wags',
+ # First => \'Fido'
+ # }
+ #);
+ #%kennels = (
+ # Second => \'Wags',
+ # First => \'Fido'
+ #);
+ EOT
+
+ TEST q(
+ $d = Data::Dumper->new( [\@dogs, \%kennel], [qw(*dogs *kennels)] );
+ $d->Deepcopy(1)->Dump;
+ );
+ if ($XS) {
+ TEST q($d->Reset->Dumpxs);
+ }
+
+ }
+
+ {
+
+ sub z { print "foo\n" }
+ $c = [ \&z ];
+
+ ############# 121
+ ##
+ $WANT = <<'EOT';
+ #$a = $b;
+ #$c = [
+ # $b
+ #];
+ EOT
+
+ TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dump;);
+ TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dumpxs;)
+ if $XS;
+
+ ############# 127
+ ##
+ $WANT = <<'EOT';
+ #$a = \&b;
+ #$c = [
+ # \&b
+ #];
+ EOT
+
+ TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dump;);
+ TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dumpxs;)
+ if $XS;
+
+ ############# 133
+ ##
+ $WANT = <<'EOT';
+ #*a = \&b;
+ #@c = (
+ # \&b
+ #);
+ EOT
+
+ TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dump;);
+ TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dumpxs;)
+ if $XS;
+
+ }
+
+ {
+ $a = [];
+ $a->[1] = \$a->[0];
+
+ ############# 139
+ ##
+ $WANT = <<'EOT';
+ #@a = (
+ # undef,
+ # do{my $o}
+ #);
+ #$a[1] = \$a[0];
+ EOT
+
+ TEST q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dump;);
+ TEST q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dumpxs;)
+ if $XS;
+ }
+
+ {
+ $a = \\\\\'foo';
+ $b = $$$a;
+
+ ############# 145
+ ##
+ $WANT = <<'EOT';
+ #$a = \\\\\'foo';
+ #$b = ${${$a}};
+ EOT
+
+ TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;);
+ TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;)
+ if $XS;
+ }
+
+ {
+ $a = [{ a => \$b }, { b => undef }];
+ $b = [{ c => \$b }, { d => \$a }];
+
+ ############# 151
+ ##
+ $WANT = <<'EOT';
+ #$a = [
+ # {
+ # a => \[
+ # {
+ # c => do{my $o}
+ # },
+ # {
+ # d => \[]
+ # }
+ # ]
+ # },
+ # {
+ # b => undef
+ # }
+ #];
+ #${$a->[0]{a}}->[0]->{c} = $a->[0]{a};
+ #${${$a->[0]{a}}->[1]->{d}} = $a;
+ #$b = ${$a->[0]{a}};
+ EOT
+
+ TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;);
+ TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;)
+ if $XS;
+ }
+
+ {
+ $a = [[[[\\\\\'foo']]]];
+ $b = $a->[0][0];
+ $c = $${$b->[0][0]};
+
+ ############# 157
+ ##
+ $WANT = <<'EOT';
+ #$a = [
+ # [
+ # [
+ # [
+ # \\\\\'foo'
+ # ]
+ # ]
+ # ]
+ #];
+ #$b = $a->[0][0];
+ #$c = ${${$a->[0][0][0][0]}};
+ EOT
+
+ TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dump;);
+ TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dumpxs;)
+ if $XS;
+ }
+
+ {
+ $f = "pearl";
+ $e = [ $f ];
+ $d = { 'e' => $e };
+ $c = [ $d ];
+ $b = { 'c' => $c };
+ $a = { 'b' => $b };
+
+ ############# 163
+ ##
+ $WANT = <<'EOT';
+ #$a = {
+ # b => {
+ # c => [
+ # {
+ # e => 'ARRAY(0xdeadbeef)'
+ # }
+ # ]
+ # }
+ #};
+ #$b = $a->{b};
+ #$c = $a->{b}{c};
+ EOT
+
+ TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dump;);
+ TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dumpxs;)
+ if $XS;
+
+ ############# 169
+ ##
+ $WANT = <<'EOT';
+ #$a = {
+ # b => 'HASH(0xdeadbeef)'
+ #};
+ #$b = $a->{b};
+ #$c = [
+ # 'HASH(0xdeadbeef)'
+ #];
+ EOT
+
+ TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dump;);
+ TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dumpxs;)
+ if $XS;
+ }
+
+ {
+ $a = \$a;
+ $b = [$a];
+
+ ############# 175
+ ##
+ $WANT = <<'EOT';
+ #$b = [
+ # \$b->[0]
+ #];
+ EOT
+
+ TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dump;);
+ TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dumpxs;)
+ if $XS;
+
+ ############# 181
+ ##
+ $WANT = <<'EOT';
+ #$b = [
+ # \do{my $o}
+ #];
+ #${$b->[0]} = $b->[0];
+ EOT
+
+
+ TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dump;);
+ TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dumpxs;)
+ if $XS;
+ }
diff -c /dev/null 'perl-5.7.2/ext/Data/Dumper/t/overload.t'
Index: ./ext/Data/Dumper/t/overload.t
*** ./ext/Data/Dumper/t/overload.t Thu Jan 1 02:00:00 1970
--- ./ext/Data/Dumper/t/overload.t Mon Jul 9 17:09:54 2001
***************
*** 0 ****
--- 1,35 ----
+ #!./perl -w
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
+ print "1..0 # Skip: Data::Dumper was not built\n";
+ exit 0;
+ }
+ }
+
+ use Data::Dumper;
+
+ print "1..1\n";
+
+ package Foo;
+ use overload '""' => 'as_string';
+
+ sub new { bless { foo => "bar" }, shift }
+ sub as_string { "%%%%" }
+
+ package main;
+
+ my $f = Foo->new;
+
+ print "#\$f=$f\n";
+
+ $_ = Dumper($f);
+ s/^/#/mg;
+ print $_;
+
+ print "not " unless /bar/ && /Foo/;
+ print "ok 1\n";
+
diff -c 'perl-5.7.1/ext/Devel/DProf/DProf.xs' 'perl-5.7.2/ext/Devel/DProf/DProf.xs'
Index: ./ext/Devel/DProf/DProf.xs
*** ./ext/Devel/DProf/DProf.xs Tue Mar 6 04:04:36 2001
--- ./ext/Devel/DProf/DProf.xs Mon Jul 9 17:09:54 2001
***************
*** 87,93 ****
U32 total;
U32 lastid;
U32 default_perldb;
! U32 depth;
#ifdef OS2
ULONG frequ;
long long start_cnt;
--- 87,93 ----
U32 total;
U32 lastid;
U32 default_perldb;
! UV depth;
#ifdef OS2
ULONG frequ;
long long start_cnt;
***************
*** 384,390 ****
int i, j, k = 0;
HV *oldstash = PL_curstash;
struct tms t1, t2;
! clock_t realtime1, realtime2;
U32 ototal = g_total;
U32 ostack = g_SAVE_STACK;
U32 operldb = PL_perldb;
--- 384,390 ----
int i, j, k = 0;
HV *oldstash = PL_curstash;
struct tms t1, t2;
! clock_t realtime1 = 0, realtime2 = 0;
U32 ototal = g_total;
U32 ostack = g_SAVE_STACK;
U32 operldb = PL_perldb;
***************
*** 497,503 ****
warn("garbled call depth when profiling");
}
else {
! I32 marks = g_depth - need_depth;
/* warn("Check_depth: got %d, expected %d\n", g_depth, need_depth); */
while (marks--) {
--- 497,503 ----
warn("garbled call depth when profiling");
}
else {
! IV marks = g_depth - need_depth;
/* warn("Check_depth: got %d, expected %d\n", g_depth, need_depth); */
while (marks--) {
***************
*** 513,519 ****
XS(XS_DB_sub)
{
! dXSARGS;
dORIGMARK;
SV *Sub = GvSV(PL_DBsub); /* name of current sub */
--- 513,519 ----
XS(XS_DB_sub)
{
! dMARK;
dORIGMARK;
SV *Sub = GvSV(PL_DBsub); /* name of current sub */
***************
*** 530,536 ****
DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub));
! SAVEDESTRUCTOR_X(check_depth, (void*)g_depth);
g_depth++;
prof_mark(aTHX_ OP_ENTERSUB);
--- 530,536 ----
DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub));
! SAVEDESTRUCTOR_X(check_depth, INT2PTR(void*,g_depth));
g_depth++;
prof_mark(aTHX_ OP_ENTERSUB);
diff -c 'perl-5.7.1/ext/Devel/Peek/Peek.pm' 'perl-5.7.2/ext/Devel/Peek/Peek.pm'
Index: ./ext/Devel/Peek/Peek.pm
*** ./ext/Devel/Peek/Peek.pm Fri Mar 16 04:54:46 2001
--- ./ext/Devel/Peek/Peek.pm Mon Jul 9 17:09:54 2001
***************
*** 4,10 ****
package Devel::Peek;
# Underscore to allow older Perls to access older version from CPAN
! $VERSION = '1.00_01';
require Exporter;
use XSLoader ();
--- 4,10 ----
package Devel::Peek;
# Underscore to allow older Perls to access older version from CPAN
! $VERSION = '1.00_02';
require Exporter;
use XSLoader ();
diff -c /dev/null 'perl-5.7.2/ext/Devel/Peek/Peek.t'
Index: ./ext/Devel/Peek/Peek.t
*** ./ext/Devel/Peek/Peek.t Thu Jan 1 02:00:00 1970
--- ./ext/Devel/Peek/Peek.t Mon Jul 9 17:09:54 2001
***************
*** 0 ****
--- 1,308 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bPeek\b/) {
+ print "1..0 # Skip: Devel::Peek was not built\n";
+ exit 0;
+ }
+ }
+
+ use Devel::Peek;
+
+ print "1..17\n";
+
+ our $DEBUG = 0;
+ open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
+
+ sub do_test {
+ my $pattern = pop;
+ if (open(OUT,">peek$$")) {
+ open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
+ Dump($_[1]);
+ open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
+ close(OUT);
+ if (open(IN, "peek$$")) {
+ local $/;
+ $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g;
+ print $pattern, "\n" if $DEBUG;
+ my $dump = <IN>;
+ print $dump, "\n" if $DEBUG;
+ print "[$dump] vs [$pattern]\nnot " unless $dump =~ /$pattern/ms;
+ print "ok $_[0]\n";
+ close(IN);
+ } else {
+ die "$0: failed to open peek$$: !\n";
+ }
+ } else {
+ die "$0: failed to create peek$$: $!\n";
+ }
+ }
+
+ our $a;
+ our $b;
+ my $c;
+ local $d = 0;
+
+ do_test( 1,
+ $a = "foo",
+ 'SV = PV\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(POK,pPOK\\)
+ PV = $ADDR "foo"\\\0
+ CUR = 3
+ LEN = 4'
+ );
+
+ do_test( 2,
+ "bar",
+ 'SV = PV\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(.*POK,READONLY,pPOK\\)
+ PV = $ADDR "bar"\\\0
+ CUR = 3
+ LEN = 4');
+
+ do_test( 3,
+ $b = 123,
+ 'SV = IV\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(IOK,pIOK\\)
+ IV = 123');
+
+ do_test( 4,
+ 456,
+ 'SV = IV\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(.*IOK,READONLY,pIOK\\)
+ IV = 456');
+
+ do_test( 5,
+ $c = 456,
+ 'SV = IV\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(PADBUSY,PADMY,IOK,pIOK\\)
+ IV = 456');
+
+ do_test( 6,
+ $c + $d,
+ 'SV = IV\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(PADTMP,IOK,pIOK\\)
+ IV = 456');
+
+ ($d = "789") += 0.1;
+
+ do_test( 7,
+ $d,
+ 'SV = PVNV\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(NOK,pNOK\\)
+ IV = 0
+ NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
+ PV = $ADDR "789"\\\0
+ CUR = 3
+ LEN = 4');
+
+ do_test( 8,
+ 0xabcd,
+ 'SV = IV\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(.*IOK,READONLY,pIOK\\)
+ IV = 43981');
+
+ do_test( 9,
+ undef,
+ 'SV = NULL\\(0x0\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(\\)');
+
+ do_test(10,
+ \$a,
+ 'SV = RV\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(ROK\\)
+ RV = $ADDR
+ SV = PV\\($ADDR\\) at $ADDR
+ REFCNT = 2
+ FLAGS = \\(POK,pPOK\\)
+ PV = $ADDR "foo"\\\0
+ CUR = 3
+ LEN = 4');
+
+ do_test(11,
+ [$b,$c],
+ 'SV = RV\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(ROK\\)
+ RV = $ADDR
+ SV = PVAV\\($ADDR\\) at $ADDR
+ REFCNT = 2
+ FLAGS = \\(\\)
+ IV = 0
+ NV = 0
+ ARRAY = $ADDR
+ FILL = 1
+ MAX = 1
+ ARYLEN = 0x0
+ FLAGS = \\(REAL\\)
+ Elt No. 0
+ SV = IV\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(IOK,pIOK\\)
+ IV = 123
+ Elt No. 1
+ SV = IV\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(IOK,pIOK\\)
+ IV = 456');
+
+ do_test(12,
+ {$b=>$c},
+ 'SV = RV\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(ROK\\)
+ RV = $ADDR
+ SV = PVHV\\($ADDR\\) at $ADDR
+ REFCNT = 2
+ FLAGS = \\(SHAREKEYS\\)
+ IV = 1
+ NV = 0
+ ARRAY = $ADDR \\(0:7, 1:1\\)
+ hash quality = 100.0%
+ KEYS = 1
+ FILL = 1
+ MAX = 7
+ RITER = -1
+ EITER = 0x0
+ Elt "123" HASH = $ADDR
+ SV = IV\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(IOK,pIOK\\)
+ IV = 456');
+
+ do_test(13,
+ sub(){@_},
+ 'SV = RV\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(ROK\\)
+ RV = $ADDR
+ SV = PVCV\\($ADDR\\) at $ADDR
+ REFCNT = 2
+ FLAGS = \\(PADBUSY,PADMY,POK,pPOK,ANON\\)
+ IV = 0
+ NV = 0
+ PROTOTYPE = ""
+ COMP_STASH = $ADDR\\t"main"
+ START = $ADDR ===> \\d+
+ ROOT = $ADDR
+ XSUB = 0x0
+ XSUBANY = 0
+ GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
+ FILE = ".*\\b(?i:peek\\.t)"
+ DEPTH = 0
+ (?: MUTEXP = $ADDR
+ OWNER = $ADDR
+ )? FLAGS = 0x4
+ PADLIST = $ADDR
+ OUTSIDE = $ADDR \\(MAIN\\)');
+
+ do_test(14,
+ \&do_test,
+ 'SV = RV\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(ROK\\)
+ RV = $ADDR
+ SV = PVCV\\($ADDR\\) at $ADDR
+ REFCNT = (3|4)
+ FLAGS = \\(\\)
+ IV = 0
+ NV = 0
+ COMP_STASH = $ADDR\\t"main"
+ START = $ADDR ===> \\d+
+ ROOT = $ADDR
+ XSUB = 0x0
+ XSUBANY = 0
+ GVGV::GV = $ADDR\\t"main" :: "do_test"
+ FILE = ".*\\b(?i:peek\\.t)"
+ DEPTH = 1
+ (?: MUTEXP = $ADDR
+ OWNER = $ADDR
+ )? FLAGS = 0x0
+ PADLIST = $ADDR
+ \\d+\\. $ADDR \\("\\$pattern" \\d+-\\d+\\)
+ \\d+\\. $ADDR \\(FAKE "\\$DEBUG" 0-\\d+\\)
+ \\d+\\. $ADDR \\("\\$dump" \\d+-\\d+\\)
+ OUTSIDE = $ADDR \\(MAIN\\)');
+
+ do_test(15,
+ qr(tic),
+ 'SV = RV\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(ROK\\)
+ RV = $ADDR
+ SV = PVMG\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(OBJECT,RMG\\)
+ IV = 0
+ NV = 0
+ PV = 0
+ MAGIC = $ADDR
+ MG_VIRTUAL = $ADDR
+ MG_TYPE = PERL_MAGIC_qr\(r\)
+ MG_OBJ = $ADDR
+ STASH = $ADDR\\t"Regexp"');
+
+ do_test(16,
+ (bless {}, "Tac"),
+ 'SV = RV\\($ADDR\\) at $ADDR
+ REFCNT = 1
+ FLAGS = \\(ROK\\)
+ RV = $ADDR
+ SV = PVHV\\($ADDR\\) at $ADDR
+ REFCNT = 2
+ FLAGS = \\(OBJECT,SHAREKEYS\\)
+ IV = 0
+ NV = 0
+ STASH = $ADDR\\t"Tac"
+ ARRAY = 0x0
+ KEYS = 0
+ FILL = 0
+ MAX = 7
+ RITER = -1
+ EITER = 0x0');
+
+ do_test(17,
+ *a,
+ 'SV = PVGV\\($ADDR\\) at $ADDR
+ REFCNT = 5
+ FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\)
+ IV = 0
+ NV = 0
+ MAGIC = $ADDR
+ MG_VIRTUAL = &PL_vtbl_glob
+ MG_TYPE = PERL_MAGIC_glob\(\*\)
+ MG_OBJ = $ADDR
+ NAME = "a"
+ NAMELEN = 1
+ GvSTASH = $ADDR\\t"main"
+ GP = $ADDR
+ SV = $ADDR
+ REFCNT = 1
+ IO = 0x0
+ FORM = 0x0
+ AV = 0x0
+ HV = 0x0
+ CV = 0x0
+ CVGEN = 0x0
+ GPFLAGS = 0x0
+ LINE = \\d+
+ FILE = ".*\\b(?i:peek\\.t)"
+ FLAGS = $ADDR
+ EGV = $ADDR\\t"a"');
+
+ END {
+ 1 while unlink("peek$$");
+ }
diff -c 'perl-5.7.1/ext/Devel/Peek/Peek.xs' 'perl-5.7.2/ext/Devel/Peek/Peek.xs'
Index: ./ext/Devel/Peek/Peek.xs
*** ./ext/Devel/Peek/Peek.xs Tue Mar 6 04:04:37 2001
--- ./ext/Devel/Peek/Peek.xs Mon Jul 9 17:09:54 2001
***************
*** 10,16 ****
return Nullsv;
#else
SV* sva;
! SV* sv, *dbg;
SV* ret = newRV_noinc((SV*)newAV());
register SV* svend;
int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0;
--- 10,16 ----
return Nullsv;
#else
SV* sva;
! SV* sv;
SV* ret = newRV_noinc((SV*)newAV());
register SV* svend;
int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0;
***************
*** 151,158 ****
fill_mstats(SV *sv, int level)
{
dTHX;
- int nbuckets;
- struct mstats_buffer buf;
if (SvREADONLY(sv))
croak("Cannot modify a readonly value");
--- 151,156 ----
***************
*** 216,222 ****
warn("FIXME: internal mstats buffer too short");
for (type = 0; type < (level ? 4 : 2); type++) {
! UV *p, *p1;
AV *av;
int i;
static const char *types[4] = {
--- 214,220 ----
warn("FIXME: internal mstats buffer too short");
for (type = 0; type < (level ? 4 : 2); type++) {
! UV *p = 0, *p1 = 0;
AV *av;
int i;
static const char *types[4] = {
***************
*** 229,235 ****
croak("Unexpected value for the key '%s' in the mstats hash", types[type]);
if (!SvOK(*svp)) {
av = newAV();
! SvUPGRADE(*svp, SVt_RV);
SvRV(*svp) = (SV*)av;
SvROK_on(*svp);
} else
--- 227,233 ----
croak("Unexpected value for the key '%s' in the mstats hash", types[type]);
if (!SvOK(*svp)) {
av = newAV();
! (void)SvUPGRADE(*svp, SVt_RV);
SvRV(*svp) = (SV*)av;
SvROK_on(*svp);
} else
diff -c 'perl-5.7.1/ext/Digest/MD5/MD5.xs' 'perl-5.7.2/ext/Digest/MD5/MD5.xs'
Index: ./ext/Digest/MD5/MD5.xs
Prereq: 1.26
*** ./ext/Digest/MD5/MD5.xs Fri Mar 23 04:30:39 2001
--- ./ext/Digest/MD5/MD5.xs Mon Jul 9 17:09:54 2001
***************
*** 1,5 ****
- /* $Id: MD5.xs,v 1.26 2000/09/18 14:27:44 gisle Exp $ */
-
/*
* This library is free software; you can redistribute it and/or
* modify it under the same terms as Perl itself.
--- 1,3 ----
***************
*** 44,50 ****
}
#endif
! /*#define MD5_DEBUG /**/
/* Perl does not guarantee that U32 is exactly 32 bits. Some system
* has no integral type with exactly 32 bits. For instance, A Cray has
--- 42,49 ----
}
#endif
! /* Define this to turn on verbose debugging prints */
! #undef MD5_DEBUG
/* Perl does not guarantee that U32 is exactly 32 bits. Some system
* has no integral type with exactly 32 bits. For instance, A Cray has
***************
*** 137,143 ****
/* F, G, H and I are basic MD5 functions.
*/
! #define F(x, y, z) (((x) & ((y) ^ (z)) ^ (z)))
#define G(x, y, z) F(z, x, y)
#define H(x, y, z) ((x) ^ (y) ^ (z))
#define I(x, y, z) ((y) ^ ((x) | (~z)))
--- 136,142 ----
/* F, G, H and I are basic MD5 functions.
*/
! #define F(x, y, z) ((((x) & ((y) ^ (z))) ^ (z)))
#define G(x, y, z) F(z, x, y)
#define H(x, y, z) ((x) ^ (y) ^ (z))
#define I(x, y, z) ((y) ^ ((x) | (~z)))
***************
*** 195,201 ****
--- 194,202 ----
static void
MD5Transform(MD5_CTX* ctx, const U8* buf, STRLEN blocks)
{
+ #ifdef MD5_DEBUG
static int tcount = 0;
+ #endif
U32 A = ctx->A;
U32 B = ctx->B;
***************
*** 553,559 ****
STRLEN len;
PPCODE:
for (i = 1; i < items; i++) {
! data = (unsigned char *)(SvPV(ST(i), len));
MD5Update(context, data, len);
}
XSRETURN(1); /* self */
--- 554,560 ----
STRLEN len;
PPCODE:
for (i = 1; i < items; i++) {
! data = (unsigned char *)(SvPVbyte(ST(i), len));
MD5Update(context, data, len);
}
XSRETURN(1); /* self */
***************
*** 618,624 ****
PPCODE:
MD5Init(&ctx);
for (i = 0; i < items; i++) {
! data = (unsigned char *)(SvPV(ST(i), len));
MD5Update(&ctx, data, len);
}
MD5Final(digeststr, &ctx);
--- 619,625 ----
PPCODE:
MD5Init(&ctx);
for (i = 0; i < items; i++) {
! data = (unsigned char *)(SvPVbyte(ST(i), len));
MD5Update(&ctx, data, len);
}
MD5Final(digeststr, &ctx);
diff -c 'perl-5.7.1/ext/Digest/MD5/Makefile.PL' 'perl-5.7.2/ext/Digest/MD5/Makefile.PL'
Index: ./ext/Digest/MD5/Makefile.PL
*** ./ext/Digest/MD5/Makefile.PL Fri Apr 6 16:41:10 2001
--- ./ext/Digest/MD5/Makefile.PL Mon Jul 9 17:09:54 2001
***************
*** 10,21 ****
--- 10,31 ----
if !($Config{'byteorder'} eq '1234' ||
$Config{'byteorder'} eq '4321');
}
+ my @optimize = ();
+ if ($^O eq 'VMS') {
+ if (defined($Config{ccname})) {
+ if ($Config{ccversion} <= 50390006 && grep(/VMS_VAX/, @INC) && ($Config{ccname} eq 'DEC')) {
+ @optimize = ("OPTIMIZE","/Optimize=(NODISJOINT)");
+ }
+ }
+ }
WriteMakefile(
'NAME' => 'Digest::MD5',
'VERSION_FROM' => 'MD5.pm',
+ MAN3PODS => {}, # Pods will be built by installman.
@extra,
'dist' => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
+ @optimize
);
exit;
diff -c /dev/null 'perl-5.7.2/ext/Digest/MD5/t/aaa.t'
Index: ./ext/Digest/MD5/t/aaa.t
*** ./ext/Digest/MD5/t/aaa.t Thu Jan 1 02:00:00 1970
--- ./ext/Digest/MD5/t/aaa.t Mon Jul 9 17:09:54 2001
***************
*** 0 ****
--- 1,552 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use strict;
+ print "1..256\n";
+
+ use Digest::MD5 qw(md5_hex);
+
+ my $Is_EBCDIC = ord('A') == 193;
+
+ my $testno = 0;
+ while (<DATA>) {
+ if (!$Is_EBCDIC) {
+ next if /^EBCDIC/;
+ }
+ else {
+ next if !/^EBCDIC/;
+ s/^EBCDIC,\w+#//;
+ }
+ my($hexdigest, $message) = split;
+ $message =~ s/\"//g;
+
+ my $failed;
+ $failed++ unless md5_hex($message) eq $hexdigest;
+ $failed++ unless Digest::MD5->new->add(split(//, $message))->digest
+ eq pack("H*", $hexdigest);
+
+ print "not " if $failed;
+ print "ok ", ++$testno, "\n";
+ }
+
+
+
+ # This data was generated with:
+ #
+ # perl -e 'for (1..256) { system("md5sum --string=" . ("a" x $_)); }'
+ #
+ __END__
+ 0cc175b9c0f1b6a831c399e269772661 "a"
+ 4124bc0a9335c27f086f24ba207a4912 "aa"
+ 47bce5c74f589f4867dbd57e9ca9f808 "aaa"
+ 74b87337454200d4d33f80c4663dc5e5 "aaaa"
+ 594f803b380a41396ed63dca39503542 "aaaaa"
+ 0b4e7a0e5fe84ad35fb5f95b9ceeac79 "aaaaaa"
+ 5d793fc5b00a2348c3fb9ab59e5ca98a "aaaaaaa"
+ 3dbe00a167653a1aaee01d93e77e730e "aaaaaaaa"
+ 552e6a97297c53e592208cf97fbb3b60 "aaaaaaaaa"
+ e09c80c42fda55f9d992e59ca6b3307d "aaaaaaaaaa"
+ d57f21e6a273781dbf8b7657940f3b03 "aaaaaaaaaaa"
+ 45e4812014d83dde5666ebdf5a8ed1ed "aaaaaaaaaaaa"
+ c162de19c4c3731ca3428769d0cd593d "aaaaaaaaaaaaa"
+ 451599a5f9afa91a0f2097040a796f3d "aaaaaaaaaaaaaa"
+ 12f9cf6998d52dbe773b06f848bb3608 "aaaaaaaaaaaaaaa"
+ 23ca472302f49b3ea5592b146a312da0 "aaaaaaaaaaaaaaaa"
+ 88e42e96cc71151b6e1938a1699b0a27 "aaaaaaaaaaaaaaaaa"
+ 2c60c24e7087e18e45055a33f9a5be91 "aaaaaaaaaaaaaaaaaa"
+ 639d76897485360b3147e66e0a8a3d6c "aaaaaaaaaaaaaaaaaaa"
+ 22d42eb002cefa81e9ad604ea57bc01d "aaaaaaaaaaaaaaaaaaaa"
+ bd049f221af82804c5a2826809337c9b "aaaaaaaaaaaaaaaaaaaaa"
+ ff49cfac3968dbce26ebe7d4823e58bd "aaaaaaaaaaaaaaaaaaaaaa"
+ d95dbfee231e34cccb8c04444412ed7d "aaaaaaaaaaaaaaaaaaaaaaa"
+ 40edae4bad0e5bf6d6c2dc5615a86afb "aaaaaaaaaaaaaaaaaaaaaaaa"
+ a5a8bfa3962f49330227955e24a2e67c "aaaaaaaaaaaaaaaaaaaaaaaaa"
+ ae791f19bdf77357ff10bb6b0e97e121 "aaaaaaaaaaaaaaaaaaaaaaaaaa"
+ aaab9c59a88bf0bdfcb170546c5459d6 "aaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ b0f0545856af1a340acdedce23c54b97 "aaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ f7ce3d7d44f3342107d884bfa90c966a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 59e794d45697b360e18ba972bada0123 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 3b0845db57c200be6052466f87b2198a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 5eca9bd3eb07c006cd43ae48dfde7fd3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ b4f13cb081e412f44e99742cb128a1a5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 4c660346451b8cf91ef50f4634458d41 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 11db24dc3f6c2145701db08625dd6d76 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 80dad3aad8584778352c68ab06250327 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 1227fe415e79db47285cb2689c93963f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 8e084f489f1bdf08c39f98ff6447ce6d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 08b2f2b0864bac1ba1585043362cbec9 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 4697843037d962f62a5a429e611e0f5f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 10c4da18575c092b486f8ab96c01c02f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ af205d729450b663f48b11d839a1c8df "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 0d3f91798fac6ee279ec2485b25f1124 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 4c3c7c067634daec9716a80ea886d123 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ d1e358e6e3b707282cdd06e919f7e08c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 8c6ded4f0af86e0a7e301f8a716c4363 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 4c2d8bcb02d982d7cb77f649c0a2dea8 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ bdb662f765cd310f2a547cab1cfecef6 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 08ff5f7301d30200ab89169f6afdb7af "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 6eb6a030bcce166534b95bc2ab45d9cf "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 1bb77918e5695c944be02c16ae29b25e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ b6fe77c19f0f0f4946c761d62585bfea "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ e9e7e260dce84ffa6e0e7eb5fd9d37fc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ eced9e0b81ef2bba605cbc5e2e76a1d0 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ ef1772b6dff9a122358552954ad0df65 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 3b0c8ac703f828b04c6c197006d17218 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 652b906d60af96844ebd21b674f35e93 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ dc2f2f2462a0d72358b2f99389458606 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 762fc2665994b217c52c3c2eb7d9f406 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ cc7ed669cf88f201c3297c6a91e1d18d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ cced11f7bbbffea2f718903216643648 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 24612f0ce2c9d2cf2b022ef1e027a54f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ b06521f39153d618550606be297466d5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 014842d480b571495a4a0363793f7367 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ c743a45e0d2e6a95cb859adae0248435 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ def5d97e01e1219fb2fc8da6c4d6ba2f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 92cb737f8687ccb93022fdb411a77cca "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ a0d1395c7fb36247bfe2d49376d9d133 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ ab75504250558b788f99d1ebd219abf2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 0f5c6c4e740bfcc08c3c26ccb2673d46 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ cddd19bec7f310d8c87149ef47a1828f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 96b39b8b95e016c79d104d83395b8133 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ f1fc0b14ff8fa674b02344577e23eeb1 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 0e8d28a1cafa3ffcff22afd480cce7d8 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 448539ffc17e1e81005b65581855cef4 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 61e39aae7c53e6e77db2e4405d9fb157 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 618a426895ee6133a372bebd1129b63e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 046c90690c9e36578b9d4a7e1d249c75 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ aadab38075c43296ee7e12466ebb03e3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ b15af9cdabbaea0516866a33d8fd0f98 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 986e6938ed767a8ae9530eef54bfe5f1 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 7ae25a72b71a42ccbc5477fd989cd512 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 98d34e50d4aa7a893cc7919a91acb0e3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 3fc53fc22ea40f1a0afd78fc2cd9aa0f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 923e37c738b9d7b1526f70b65229cc3d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ b3966b7a08e5d46fd0774b797ba78dc2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ f50c7286b540bb181db1d6e05a51a296 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 4efd6c8826e65a61f82af954d431b59b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ ef1031e79e7a15a4470a5e98b23781b5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 067876bfd0df0f4c5002780ec85e6f8c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 789851dfa4c03563e9cef5f7bc050a7e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ baf934720818ee49477e74fc644faa5e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 9a0ea77ca26d2c121ddcc179edb76308 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 20c825561572e33d026f99ddfd999538 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 464c461455c5a927079a13609c20b637 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ cf37d42f89b6adb0e1a9e99104501b82 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ d266af45e3d06b70d9f52e2df4344186 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ f8b59fa22eb0ba944e2b7aa24d67b681 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 0918d7c2f9062743450a86eae9dde1a3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 36a92cc94a9e0fa21f625f8bfb007adf "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 681d73898dad5685d48b5e8438bc3a66 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 337ccef058459c3c16411381778da0c4 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 6ccdfcc742862036ce07583633c5f77e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ ddfa1adc974649dc5b414be86def7457 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 650ebc28ad85f11aa4b63b6ee565b89d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ e4571793bcaba284017eeabd8df85697 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 4fc040d354ad9ba5e4f62862109d3e17 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 25814274e02aa7cc03d6314eb703e655 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 11378ecaee0089c840d26352704027e3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 86f950bfcd824d5546da01c40576db31 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 089f243d1e831c5879aa375ee364a06e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 9146ef3527c7cfcc66dc615c3986e391 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ d727cfdfc9ed0347e6917a68b982f7bc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ da8f45e1fdc12deecfe56aeb5288796e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 29cfcf52d8250a253a535cf7989c7bd2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 0f6eb555b8e3c35411eebe9348594193 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ a922439f963e7e59040e4756992c6f1b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 81f8453cf3f7e5ee5479c777e5a8d80c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 8a7bd0732ed6a28ce75f6dabc90e1613 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 5f61c0ccad4cac44c75ff505e1f1e537 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ f6acfca2d47c87f2b14ca038234d3614 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 269fc62c517f3d55c368152addca57e7 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 50587cb16413da779b35508018721647 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 5e4a3ecfdaa4636b84a39b6a7be7c047 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ c5339dc2af6bf595580281ffb07353f6 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ e51176a47347e167ed0ed766b6de1a0c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 020406e1d05cdc2aa287641f7ae2cc39 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ e510683b3f5ffe4093d021808bc6ff70 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ b325dc1c6f5e7a2b7cf465b9feab7948 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ e016e4ccc7fdaea56fc377600b58c4cb "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 3870ec709d2fc64b255d65be3123ad69 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ a92bde1f862c3fe797ecd69510bbd266 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 04daa146f3a2256fdcbf015c0f67e168 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 3d13c8bf627421ccc937aa1c9ac87bf1 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 247dc7ffc545e4dda64ae12def481c4e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 2dfd4def392ee9563241b7db7eb7c346 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ d11a18a4743a1a0a699d1704efb74a0d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 55b62fabd9c77d44d86e992eeeb093e6 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 9a72cf7d0bd5ae2907c79f91837e3ced "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ d3828cce1835534475029202ebd799e4 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ b0bebbf0015658d4740679f263a3f01f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 02368ebf1f53bc4634211b1693021666 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 04960f7d18960e348372949e4baa9752 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ c6041e7a86d407e9402b175670519260 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 439fd4c056bec1d14acd393746f6ae59 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 81a855120e04494c5a6c874a2360fd57 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ ef57bd47a964dc3aadd959c4131e64ac "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 0b0ab27b16cbba267c141fe0f4ee9189 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ abccd84f340bfe4ba59095cc3d5ca6ad "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ bc620e8c15265f195c8818e2f3e3c58b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ fdcd84c4143286f6fc70c69208acd18d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 50e05071e773b1e9f3009a4a559ce6b2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 9e69c7a6c1863fbba2532f09ba665bde "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 47a962111aa5187eeef3d17a278d95f2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ c13e57e33526bc713b5a1825f92651bc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 72b392f15593e42404b38e5c889fa75e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 5327acd3278274265d44e22ccfc4042c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 930dcac6da160b2a4c51879da76d3417 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 41292c326f926f1534ead47fe302f0a0 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 2bdecb5cf6b69a00f7832299ef2fb5a5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 8bf93e9e8a3e4396de3f211c788e177e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ eea9cb566e19d6a7f55fbae78d94ef2a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 3b8452700a829dec78397aa5c0458dd3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 7950059f699eaea1e0a1759340d7c153 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 40840c5f1de00f17a8e70d5bd4d00af2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 80f86f6af38be9ca8e40c2dc44491a0a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 7aab2c2e72c77163e7102412dc332125 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ bfd6869ae2ee2fe2675846d341eaa67d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 7e4d976f6d552d1d5bac7e2693dc8759 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 37d9884c32abfc6f372ee899434e64ad "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ e362cd83a4b49d81ac6788b7839a56fd "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 9203cbb93b25d80b9d1b75e3c6c4b0dc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 77441eda11554ec5b915d942605f66ed "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ e0fe0c02b5c9c5afe10ab9d6a3769efe "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ cc7682cf11b214e928f3df899772e789 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ ade0901d347afb25ecf9df4955bb8061 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 987379587cbe8e94b7057269232ff826 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ fd44a60101b04b7ddbc2b4e9b509ca1f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 53107a7f1e6f13a2e63239b6f2bf0ef1 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 0b82cdd562f26aaa2459610a7ba8cd76 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 79f12de7255e9c8c0ec9a9be45ee6210 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 92338d8de02ed7aa8b3adc9120b94e71 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 8fc48efda580fce85b8705d540e8382e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 63642b027ee89938c922722650f2eb9b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ fe54daa473502e9cc2c26dd66d564eab "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ b90f3d4b7dcd8cdd8d96cb14695f4793 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 3e73392e7a03bca45b67650d79a8fc63 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 7fe51f2642dffbabc33eea2fcc2039ba "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ bc33790e52f99718cf920329961ee753 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 54d1e41ebac5db7886f01ab0afb65b17 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 16e2824f7a3f00ef0028994182071953 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 234c07907df5019d5f40f03936939bce "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 8ea3af1d9476fa0b6c04ce4f3a336c03 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ e95b69eae07d498d484afc771d1c45fc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ f22a673abbc4372544ba37b51a5f5a91 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 7e6161eb1be7b06928c536fada91b7f1 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 4dfe3c301e88fff67822e1cfcfece43f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ edda210ac6645fbf5815eb4c58821f6d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 6a514de2bf1926129b08f9234cd0115e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 887f30b43b2867f4a9accceee7d16e6c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 15936442c22dab9b685de350bfe75971 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 281a39e10bab29f1f2dead149a1f3f87 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 04d5f8a53b0eeda82d3c0ccafd02c98e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ a91e6b80fe9d6db74fac76c7a67f065a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 30334486fa9841044afb07f2573107a5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 0183c0cf15a3c2ed97d326f421b6d62c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 4dc2a01b2161653753019b5228f765f8 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 71ef2dbdec7f78005354abebbfec8d8f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ a1d1cd1446c113726ba50cc86d8b6519 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ ed6da79cfd13ece051c4cb7c88e80c2e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ d2047852ce178d4ddb7978da3883f9c5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ d75382e07dd096b618faeeac033eefff "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 3fb48e286d462dcc237c3335aa63ba14 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 55b959972677ea06c4d0e32f7fb2f10a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 0a479c3623cfb9745e54d3376d0b9ae2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 7825ad1ba19db7eec57d88b16936f32f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 833ccf25509cb423a4aa98accb15512d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ cae9609b05a9782610a5a43d7cd4b8ff "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 6c303e1da7f8a3032d13fe995847a722 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 4c47143a568e30ecde86dafe3bcb0558 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 9c48f0592f504b86360cfb6de00203b3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ e1524f5686f170209366f9723880d9b0 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ a96164a43a192543d40e538b9e9e4ece "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ b774a4f788458a60e131d998705e4a06 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 1e97f0a7dfd3fac6ae585acdcf51a549 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ b6364c77b6dd495c2a7f6b0211ac6fce "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 5d22315e78df2bc4146aa66f6c405dbb "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 2a773d5b04e910612543a42deeaaaa62 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 0165449ac66b086accdec3051e0b691e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 54884ba571054eae72b2a5271828a1fc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 520fb61f8625ea916d72a54a37937bc6 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 7717f05d6e424a2c7a20ab7977b21ec8 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ b64e4f62e3e14317e3a90f9ff2cde576 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ a49128259cfe50ba3bed80bbd11add7f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ b10cb153b79c2e4af6a8431c265aa82d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 2e50fee6f574241042bdfabfdd46a153 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 5d5656a09b98c24edd01c530d3aad5e2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 5ac1e1609d82274371c349d5b7875298 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ b7b40d64ffccebd78abcf522376b3aae "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 8619933469d908a2d4a2d890909bea43 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 591a0ee6dccd872b46ae184eb0f9450e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 8cd256a02c8c5c1676e9220e655d9ac4 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ e48c0e2ed3e4e299a6e62e5416eb6d83 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ f30f75dce71e757ee562218c1efa0645 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 06bd7e90c0410dacb155732cf956f520 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 531a0a821a9304c215f1829b880306f1 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 93f4621c0b88499297ec3f8fbb3fb9c4 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 6af3d61e2e3ef8e189cffbea802c7e69 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ df84d21c884f99d6764d9bca4dec26e1 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 1bdbdf1c9087c796394bcda5789f7206 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 21f5b107cda33036590a19419afd7fb6 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 0eae304c738191613302fb6721ea3605 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ abed9cdef66dcec954b87124ba18c1ab "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ dfde09457e2017e31d4ecfaea010db8f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 46bc249a5a8fc5d622cf12c42c463ae0 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ 81109eec5aa1a284fb5327b10e9c16b9 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#cd25041f9f36811b04ab3015805fe816 "a"
+ EBCDIC,1047#762b8b87733ee724b8cb751c3b956ea7 "aa"
+ EBCDIC,1047#f39105ec557abe624399862897a127ed "aaa"
+ EBCDIC,1047#b825cfc3203d45d01156b8e06ae74901 "aaaa"
+ EBCDIC,1047#a497a05975af505878aa98b26bd329dd "aaaaa"
+ EBCDIC,1047#90420f3fc7d64c6cdd7a3bf218b004b1 "aaaaaa"
+ EBCDIC,1047#b3d7a168407b1613f08f186dc3744a72 "aaaaaaa"
+ EBCDIC,1047#b7b4ab251d9cc8dc9fc562272a1c7f44 "aaaaaaaa"
+ EBCDIC,1047#eb974f5cd9b8100dad8e9b82bbdb4a7a "aaaaaaaaa"
+ EBCDIC,1047#cd675880a60d9c2095fe48981959ea5b "aaaaaaaaaa"
+ EBCDIC,1047#8396c227248d77e1ebb478b4c44ee8e8 "aaaaaaaaaaa"
+ EBCDIC,1047#ae59cf65c1c722b8ea6f6e770b20315f "aaaaaaaaaaaa"
+ EBCDIC,1047#d1550adc6c6f2baeb5da9e2acd75eea1 "aaaaaaaaaaaaa"
+ EBCDIC,1047#bddd60dbf174785c39827c71ecb29706 "aaaaaaaaaaaaaa"
+ EBCDIC,1047#d0ef1bc67b2d761513ad8c1f92ca7a2b "aaaaaaaaaaaaaaa"
+ EBCDIC,1047#dd613bdc90e1e71e57e40931cf3803c1 "aaaaaaaaaaaaaaaa"
+ EBCDIC,1047#3810ed84a3fabf136b9f5c2de3c802ca "aaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#a41d584a36ba74526057338e4240b31d "aaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#e361a7b2e6adb9df91ed794f39c31a8f "aaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#dc089d8d25773e879ce759357394f63b "aaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#096bdd77ddd6393b5ff2878813ebc9c3 "aaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#e457d06769e51e7b34314c1fa885534b "aaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#ae3399b847ef9ce11d958a8926afa2a3 "aaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#be65d5ac6ebe81410cca55c2ad70e672 "aaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#108e4c3887db4178e5ea72782fb105d2 "aaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#d6ccc43d376b6ded51af488d1f56a872 "aaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#e208a35fdf88de1da8ec8411888b807e "aaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#bf09c576c720c32342308fae413347ae "aaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#aac629ca1ec1d5908fe85d6eeb352765 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#845a64111840e9db26e8f5032d59187d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#db38d8cf4f7037e6a150cc35e385972c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#2586f6fcb6ffb1578a94f8c9c2944b40 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#cb63decd219ee21068b330d321061434 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#d98cca1ccf230b2619ae6f452ab18325 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#f99e8a5e800a9c1b78b9c7181fa4113d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#c60d314815b0d438fe8cf18a62d8680d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#1256f52d15ab93e69c75d6cc9986fa49 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#7e6b1236d08400ec5723b76f3b883b2a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#bae076b34373156e51196c8170fff549 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#b957a14baa9ab970516e5e3fe30560c5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#8209c722c9d86984bde35f31e64de4c9 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#ad6abdadefb6809ef9db323939dad44e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#91ae6c863369dbfb13c688b9e5290929 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#770e940a6f11de3a3897031c7040573f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#2d07c71e6709d908992a19ee8fcd70c7 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#e748dc11e3b2984e0888782ecc9fa43f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#99573ce268b1f9e32e18319922380b2b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#68951bca944217c5a17d54d9fe296ee9 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#53addd1728c3fd60ba02e29ff7eac4d8 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#7c4abc37772402388c8d792351ae3163 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#a21011fb1a5c1f06dfc23c1b9b921506 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#5ce00db35364620dc75696426b9c7948 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#50a785cbcd6cb70322f32062bcfc8940 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#92e6ad1aa09ecde0becf66dc9f356549 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#bb769fed437ab5471f0453bdf0de6ca2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#49d68b22125368b152dd80773b1053cd "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#8c7ce5f0c7ed40ec25df22b68d1725f3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#344d80c1906e9e728e0cc9703fc60803 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#630a45b11cc72d8e36aca0e180241cb4 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#1c9ba16c5be8d48b5d8fe1a8dd1b6999 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#74bb8337e8e9a3d114eb266437302949 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#134ddd06fa362804c9f8cf02111826bd "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#1ffd548f057ed474c0d3b53ee1f8ce1b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#487823e5089b40d8c66a6a7fc613c26c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#a40e0c6392e974bc6e258fb7530b9ec3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#dccf88078dcb7501156e17b6f5b90bd0 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#9012cdfe170301d3c8d11d9dab87bf96 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#046d4f6709367aa9be3452dc5dd03601 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#237b85d7be428836b0835e3f7411d0d0 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#32022ea076ffe7496da0b64b2482b963 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#c68b3e8c7c88bf10003deaf652549f1c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#e648925002262503def112984215d21d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#192328de11913688d002f01326071abb "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#42f7138b1f7ed2121098f3e418406e7b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#cb64c10607f961b2714a3b104e487838 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#0a8fb4023704d318e53a6047531477f3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#2c9a5487397c8245fe8a52684fa50554 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#26efb364f1da859fbc71744d2c62570e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#3359363d24960feaa2f05ea1b403ddcc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#be9304d0a6297a1a1c7b02cbf177fe0c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#badb0d02141d35349b3b2838cb6450cc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#75261d10ee76bfc016f98a868e535e49 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#d85006031896657b7215ed1f64f002b9 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#2db85d6ffa2287e42c0e55a72900dd4f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#f8ce69fabcf5d5013aaede9c90a7e4c0 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#5749ef4b7f6347c3cf9e8af2dc48093e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#afd1f87f6522f82f7d260909db38f84c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#690a229786930ec741404c83738f0e87 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#a1f02fbe5b1815f5d68ebfa5c5b8cdda "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#4e75faba6d50d6f3341b3623f3457c83 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#af0eed7206c2aba4622b15a826b3cf48 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#984236c86e268a506dda56886d4589aa "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#256f33cc0cd5d0d700b959143f8b81fb "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#a4f4a73bdf53bd03ec2bf406df8c5bf1 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#bac0c7bb84f581a8ca67e49ecb7eabdc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#c1be2bc056a5abfff888f562f7420b8b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#6db1e154a0feeb290d6f9b6ca78b9faa "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#163fa1f68d79b511aa832e4d513c0d75 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#f00e90ba697aa55722c87b51652b515f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#ba925e3f1584bb930da28396334dfb06 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#6a43780f9f36e80e977d31e6ee055ccf "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#f07953ebdb37e911069ab4dc1d11b691 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#0f21a8a924546d121d479c2ae9b22788 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#6c857bf152348cc6a8d63ef4bb3a8b22 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#afc61c11e9730f9221e5b013cb75e36b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#7c762743838df21dbe61883325e4de3e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#a78d17621ef736358cf69909fe1841ae "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#687559a1f8bb2799d3f7e57ceb0f816e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#0a5eb0bcfc8888839b3b4f986e91db7c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#232c4a6355062f36d5b18a18453ba936 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#5ec9bdfb872d07265113dd94eaf7a9ea "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#f3c9f677ab5404ed16b029067a8d632f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#290997df4163f9f37994048b7f750ecb "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#9d482b2d64d165eaf1796bddb15ffc43 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#f7e059c707e4156d59bef9c887731b75 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#dec244a8f0d45814f8968492cae063ae "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#a153d558a8bed15abe61d6de1345200c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#c4c4155e9855435000915b9028af57ad "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#3bf4740880459875fc6625d3e8b9702b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#b73a90ab965e8254aeb1ed8995ccf551 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#143a255cfc206e135b23ed557c6b8c7d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#1600b994bf10eeb85772e0f5811ed661 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#7becfd6e439108f896d34012bc3c879f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#9fb1155e1c1529943d378bc79ce7248a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#210f27a4c085f4c50b119a9f530dbe64 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#c03e534627aec7638f2ef7136a987afb "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#056ff6dcf19eff62af1f7eaf68fdb868 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#78ebdbcbd1cf873ac5bc3317bc333d74 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#379ed8c06d6533b0ae397bd9bcc88727 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#68202ec0f97b3d04145ad8143b36bbec "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#f2e8c8f3ab9832adae73d6694b5aa6b5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#4dd0228d79bab138ae330137ceac9547 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#db509dc0a6d9a43323f200c3944fdd47 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#91e5620a3fbe4a7dbddc6328024f57e6 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#cebbeb507c5b8534898b394c3cb6dbab "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#eaa83adae76b4e5a38361a7943b2fc51 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#cf3fe145cdd9d906dff484591bebb099 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#5ee68f513d294e242dfd84066a489ad4 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#1452349d5b61efaf5f86f6c67ae1e67d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#4a6d9c83bb7f0418977302f41861c674 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#1c82f764bc22e2b43aa64c86152576c5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#94046ff34b09f2d5cd1ecc145f8b67f9 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#2f9b4413a963175dbf6c0e79fbafc13f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#fdcfd05667569a819bd43a32f3f0034c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#977ffabd477e827a170211d989121719 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#eb42e9022bad24209923768cd295da59 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#34daced153754389b0a3dd457aaa580f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#4d4ac318fd2765150cdd3a1fd9046f76 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#5f3779e31d8b4ecc587ef2aa620990cb "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#538a0f0a41a77491368d12d280b67ffc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#2b8bea1be2920657faea5d2f306df93e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#fdb162676ff37cafbb0b37f4a34e1f05 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#79b031eae2e5d593ad9e1765c1b32311 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#9a9d79d611f3f97dac3f1f16aeb95810 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#eca47f4f27f10c6e50bc02e96c1305e0 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#c27a036a378a0c37e551623253de6c86 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#846248b2d8ba9a2845a5b5a6160ea043 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#37f6c0bb5c1c76a018bd92d6267d5f52 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#c71638a87de7d0b7ff178235d368ca87 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#c1769c2dafefeb4400d8aaaad7be13e2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#c2170ff8ba444a468ecc92c68e156876 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#87d372bb84572d2c33e910a8f39a46c3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#e198c2b2ad83adf6d2edb90918afb140 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#dc89c07be1a85973ce4a75fdd70b945f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#8213ffd54a231c594058b572f12ed2ce "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#64a275192c6bbaf330994498212ff235 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#e718b792be6311e0248a537ba6d5e84c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#b7ee2cd790ed748aa3ac632e2c30fe08 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#6a97471085d1e13858f7febbc8762a40 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#d82fa7cf3fe39751e88cc6a4c5ea0a80 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#4d3ea68fdfb845be4aa12eef1868ac54 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#b24417be7632f1db1f37c00f2be59372 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#79f7f0088af39859c26e8dd422102e4a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#8e7c80a85e3a76bb83d81e12122d699c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#ffb596a208a1b81b17cf86e809ea9b15 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#a3e78c5e9bd595ea8457b25b7ae5ee7c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#200b9de7d5ebd0a74deb6d501fa9c273 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#75865e9d3111b6e17ba1e1b586c520e0 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#f13640a7b68db8d2bd853a95c371f4e7 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#4525f0da220d5e730ad91070c819ca6a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#3f9c9eb19f1fd6aefeb3d736d5f37cbb "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#e3344f64ba3436948b3de13081c98eb9 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#18b50889733a1e896e8fd2e460e98d7f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#918a86710bc529f44f022d5f891107a1 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#4aaea2b4f2cfcfef3a5f6be8996b2a3e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#af899efcace3138fea64764015e265f6 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#d472112d115b9bfb34a65cc6683109fc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#f2a42d47b187fc7a250f771ebcda779b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#43442e458f65b5dc6b84181fb70f0e36 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#051771335f34ad905c1af28c429e23e2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#c2c23e86aac60a7d8cb2f2d9a011b525 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#4276f514d2e9b5cf511a01b16d5bd7ad "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#43011a7d9ad322984e3617859eb37ee7 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#9b7e0d04de1c0121bd261a15cf9bb806 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#bc1e0269ae34e27ed0534a8ab5146324 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#85fa07daa4541779d7c8436a737802cf "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#5d1db871938d1dcc8a72509411dada31 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#e679a912e400a1c078e657be492a672c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#b17718a20096befcee63c2b55bbc5399 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#4786015b6aa47e81752f4e2aa59061d5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#7f3793d46edf449ce5800d568ef6e83f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#8f992f2bc222fdc9ecf86eb0c984948b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#aec900f38434e9fb7ded9d33f9a59b66 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#de3fe519c53310d2a8970a4ed2bcc937 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#02bf7d064c621689246886752ddc08bc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#c306bdf0469814bf38b2cadc896489a3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#9f84e151ea29f14871b63454585cbc78 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#cc4fd08ed3768b08646bfa6c332a6156 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#d35126a1dc2ae4b93ac67a442961a752 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#4c2ed17f95f823071289b94c7efe53f2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#63e071ca26135f7e27d76fa57d015dbe "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#4e506bd75c0d1391a0dd36adc18b3485 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#b8a9a5bf97ce5fc88a24c128bb75536e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#97e8bb790b164bc3bdb7189630748841 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#3c7a2d742d599f4fac9231c5264967ee "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#0483a8dc4b24d3d26f0d3bf0402486c5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#86022bc208c5bbded89bbaeae88e6dbf "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#c7a3f500cfe98f8c1959922b381b9438 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#bff3067df4cfff43007bea69f2380d6a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#e34a5c41f51ea6d1f1b187e90d940b59 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#c8468cae7c8a2a999a0a164f68b759eb "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#4bccb2bff1862782004398afff2289b4 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#9710683ca0b5cbf10c3df249bfa85d7a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#5a705ab132807ce9605b98444622abf3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#dd53ab3422160f933f9723cd3cb53b5a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#bad7e8a4aeea40f8642a0ca1cdfcc61b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#4c0df2b1456694b51a5c809f34f959a8 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#f330498cabce39dd03eb02d6c983281f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#915ff5f5c93e0a7833be8cc529108216 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#b8facb5253a2b7e091c0a6c18d48e368 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#8ebdd257c3bc052f9c837f90fb1879cf "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#42d2cf830ee626939580323a824a4099 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#0d364adcb48ee9db07828ce127355a0b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#14d9170b8f9ead33ec4da94d66b6b74a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#0327eff7ae5d6b5966def78e593ff5f7 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#f08ac509f43f8e34008a65c3f47d29aa "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#7dc9cdc33fb9a0d70e1409357b086783 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#5f079c22e843c3426bcf03efbd0fc54d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#8422781e8a9390246920556090a9559d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#0cc485a5c828b2cdc895f38b5c3b386e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#2259886c34c2e8adf2b3552bd47a3d6e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#c96af44682d38aa7e4b86954c883f8dc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#85bfdfeff05f7120bd5821ac6668694e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#b4083c69629ec95f6397cd5844edaf90 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#666550654d7c9e6b8a3118d9dc64bace "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#eef83a6cad3d9a8d963d468cb037ccce "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#c2fd346804a8c9c80a08312d7b9d17f3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#6521b944a119cd1f787ff75c1452db74 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#805638adfdb3bf9591fd28dfadba697a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#e62d07301fd3c0bdb5f7ce0e49e4b5d3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#49b46e007e0c79c047f655b1b46167c2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#8811ec9d3b878d168975ed835b3acaa8 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#9b4e8b089d75d1fe3567bcc97b4379d5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#c279605bdcfee9b4976eb57a9eb0d5fd "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#3e362e6f8c5eb3aa7530ef9722dda11c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ EBCDIC,1047#c54a2d44c8a73ab63d892b8b3d1c336f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
diff -c /dev/null 'perl-5.7.2/ext/Digest/MD5/t/align.t'
Index: ./ext/Digest/MD5/t/align.t
*** ./ext/Digest/MD5/t/align.t Thu Jan 1 02:00:00 1970
--- ./ext/Digest/MD5/t/align.t Mon Jul 9 17:09:54 2001
***************
*** 0 ****
--- 1,20 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # Test that md5 works on unaligned memory blocks
+
+ print "1..1\n";
+
+ use strict;
+ use Digest::MD5 qw(md5_hex);
+
+ my $str = "\100" x 20;
+ substr($str, 0, 1, ""); # chopping off first char makes the string unaligned
+
+ #use Devel::Peek; Dump($str);
+
+ print "not " unless md5_hex($str) eq "c7ebb510e59ee96f404f288d14cc656a";
+ print "ok 1\n";
+
diff -c /dev/null 'perl-5.7.2/ext/Digest/MD5/t/badfile.t'
Index: ./ext/Digest/MD5/t/badfile.t
*** ./ext/Digest/MD5/t/badfile.t Thu Jan 1 02:00:00 1970
--- ./ext/Digest/MD5/t/badfile.t Mon Jul 9 17:09:54 2001
***************
*** 0 ****
--- 1,26 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # Digest::MD5 2.07 and older used to trigger a core dump when
+ # passed an illegal file handle that failed to open.
+
+ print "1..2\n";
+
+ use Digest::MD5 ();
+
+ $md5 = Digest::MD5->new;
+
+ eval {
+ use vars qw(*FOO);
+ $md5->addfile(*FOO);
+ };
+ print "not " unless $@ =~ /^Bad filehandle: FOO/;
+ print "ok 1\n";
+
+ open(BAR, "none-existing-file.$$");
+ $md5->addfile(*BAR);
+
+ print "not " unless $md5->hexdigest eq "d41d8cd98f00b204e9800998ecf8427e";
+ print "ok 2\n";
diff -c /dev/null 'perl-5.7.2/ext/Digest/MD5/t/files.t'
Index: ./ext/Digest/MD5/t/files.t
*** ./ext/Digest/MD5/t/files.t Thu Jan 1 02:00:00 1970
--- ./ext/Digest/MD5/t/files.t Mon Jul 9 17:09:54 2001
***************
*** 0 ****
--- 1,150 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ print "1..2\n";
+
+ use strict;
+ use Digest::MD5 qw(md5 md5_hex md5_base64);
+
+ #
+ # This is the output of: 'md5sum MD5.pm MD5.xs'
+ #
+ my $EXPECT;
+
+ if (ord('A') == 193) { # EBCDIC
+ $EXPECT = <<EOT;
+ 95a81f17a8e6c2273aecac12d8c4cb90 ext/Digest/MD5/MD5.pm
+ 9cecc5dbb27bd64b98f61f558b4db378 ext/Digest/MD5/MD5.xs
+ EOT
+ } else { # ASCII
+ $EXPECT = <<EOT;
+ 3d0146bf194e4fe68733d00fba02a49e ext/Digest/MD5/MD5.pm
+ 5526659171a63f532d990dd73791b60e ext/Digest/MD5/MD5.xs
+ EOT
+ }
+
+ my $B64 = 1;
+ eval { require MIME::Base64; };
+ if ($@) {
+ print $@;
+ print "# Will not test base64 methods\n";
+ $B64 = 0;
+ }
+
+ my $testno = 0;
+
+ use File::Spec;
+
+ for (split /^/, $EXPECT) {
+ my($md5hex, $file) = split ' ';
+ my @path = split(m:/:, $file);
+ my $last = pop @path;
+ my $path = File::Spec->updir;
+ while (@path) {
+ $path = File::Spec->catdir($path, shift @path);
+ }
+ $file = File::Spec->catfile($path, $last);
+ my $md5bin = pack("H*", $md5hex);
+ my $md5b64;
+ if ($B64) {
+ $md5b64 = MIME::Base64::encode($md5bin, "");
+ chop($md5b64); chop($md5b64); # remove padding
+ }
+ my $failed;
+
+ if (digest_file($file, 'digest') ne $md5bin) {
+ print "$file: Bad digest\n";
+ $failed++;
+ }
+
+ if (digest_file($file, 'hexdigest') ne $md5hex) {
+ print "$file: Bad hexdigest\n";
+ $failed++;
+ }
+
+ if ($B64 && digest_file($file, 'b64digest') ne $md5b64) {
+ print "$file: Bad b64digest\n";
+ $failed++;
+ }
+
+ my $data = cat_file($file);
+ if (md5($data) ne $md5bin) {
+ print "$file: md5() failed\n";
+ $failed++;
+ }
+ if (md5_hex($data) ne $md5hex) {
+ print "$file: md5_hex() failed\n";
+ $failed++;
+ }
+ if ($B64 && md5_base64($data) ne $md5b64) {
+ print "$file: md5_base64() failed\n";
+ $failed++;
+ }
+
+ if (Digest::MD5->new->add($data)->digest ne $md5bin) {
+ print "$file: MD5->new->add(...)->digest failed\n";
+ $failed++;
+ }
+ if (Digest::MD5->new->add($data)->hexdigest ne $md5hex) {
+ print "$file: MD5->new->add(...)->hexdigest failed\n";
+ $failed++;
+ }
+ if ($B64 && Digest::MD5->new->add($data)->b64digest ne $md5b64) {
+ print "$file: MD5->new->add(...)->b64digest failed\n";
+ $failed++;
+ }
+
+ my @data = split //, $data;
+ if (md5(@data) ne $md5bin) {
+ print "$file: md5(\@data) failed\n";
+ $failed++;
+ }
+ if (Digest::MD5->new->add(@data)->digest ne $md5bin) {
+ print "$file: MD5->new->add(\@data)->digest failed\n";
+ $failed++;
+ }
+ my $md5 = Digest::MD5->new;
+ for (@data) {
+ $md5->add($_);
+ }
+ if ($md5->digest ne $md5bin) {
+ print "$file: $md5->add()-loop failed\n";
+ $failed++;
+ }
+
+ print "not " if $failed;
+ print "ok ", ++$testno, "\n";
+ }
+
+
+ sub digest_file
+ {
+ my($file, $method) = @_;
+ $method ||= "digest";
+ #print "$file $method\n";
+
+ open(FILE, $file) or die "Can't open $file: $!";
+ # Digests avove are generated on UNIX without CRLF
+ # so leave handles in text mode
+ # binmode(FILE);
+ my $digest = Digest::MD5->new->addfile(*FILE)->$method();
+ close(FILE);
+
+ $digest;
+ }
+
+ sub cat_file
+ {
+ my($file) = @_;
+ local $/; # slurp
+ open(FILE, $file) or die "Can't open $file: $!";
+ # Digests avove are generated on UNIX without CRLF
+ # so leave handles in text mode
+ # binmode(FILE);
+ my $tmp = <FILE>;
+ close(FILE);
+ $tmp;
+ }
+
diff -c 'perl-5.7.1/ext/DynaLoader/DynaLoader_pm.PL' 'perl-5.7.2/ext/DynaLoader/DynaLoader_pm.PL'
Index: ./ext/DynaLoader/DynaLoader_pm.PL
*** ./ext/DynaLoader/DynaLoader_pm.PL Tue Mar 6 04:04:37 2001
--- ./ext/DynaLoader/DynaLoader_pm.PL Mon Jul 9 17:09:55 2001
***************
*** 80,87 ****
@dl_require_symbols = (); # names of symbols we need
@dl_resolve_using = (); # names of files to link with
@dl_library_path = (); # path to look for files
! @dl_librefs = (); # things we have loaded
! @dl_modules = (); # Modules we have loaded
# This is a fix to support DLD's unfortunate desire to relink -lc
@dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs";
--- 80,89 ----
@dl_require_symbols = (); # names of symbols we need
@dl_resolve_using = (); # names of files to link with
@dl_library_path = (); # path to look for files
!
! #XSLoader.pm may have added elements before we were required
! #@dl_librefs = (); # things we have loaded
! #@dl_modules = (); # Modules we have loaded
# This is a fix to support DLD's unfortunate desire to relink -lc
@dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs";
diff -c 'perl-5.7.1/ext/DynaLoader/dl_aix.xs' 'perl-5.7.2/ext/DynaLoader/dl_aix.xs'
Index: ./ext/DynaLoader/dl_aix.xs
Prereq: 1.5
*** ./ext/DynaLoader/dl_aix.xs Wed Mar 28 18:57:46 2001
--- ./ext/DynaLoader/dl_aix.xs Mon Jul 9 17:09:55 2001
***************
*** 14,19 ****
--- 14,34 ----
#define PERLIO_NOT_STDIO 0
/*
+ * On AIX 4.3 and above the emulation layer is not needed any more, and
+ * indeed if perl uses its emulation and perl is linked into apache
+ * which is supposed to use the native dlopen conflicts arise.
+ * Jens-Uwe Mager jum@helios.de
+ */
+ #ifdef USE_NATIVE_DLOPEN
+
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+ #include <dlfcn.h>
+
+ #else
+
+ /*
* @(#)dlfcn.c 1.5 revision of 93/02/14 20:14:17
* This is an unpublished work copyright (c) 1992 Helios Software GmbH
* 3000 Hannover 1, Germany
***************
*** 94,99 ****
--- 109,121 ----
# define FREAD(p,s,n,ldptr) fread(p,s,n,IOPTR(ldptr))
#endif
+ #ifndef RTLD_LAZY
+ # define RTLD_LAZY 0
+ #endif
+ #ifndef RTLD_GLOBAL
+ # define RTLD_GLOBAL 0
+ #endif
+
/*
* We simulate dlopen() et al. through a call to load. Because AIX has
* no call to find an exported symbol we read the loader section of the
***************
*** 632,637 ****
--- 654,660 ----
safefree(buf);
return ret;
}
+ #endif /* USE_NATIVE_DLOPEN */
/* dl_dlopen.xs
*
***************
*** 677,683 ****
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, 1) ;
DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL));
ST(0) = sv_newmortal() ;
if (RETVAL == NULL)
--- 700,706 ----
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));
ST(0) = sv_newmortal() ;
if (RETVAL == NULL)
diff -c 'perl-5.7.1/ext/DynaLoader/dl_dlopen.xs' 'perl-5.7.2/ext/DynaLoader/dl_dlopen.xs'
Index: ./ext/DynaLoader/dl_dlopen.xs
*** ./ext/DynaLoader/dl_dlopen.xs Tue Mar 6 04:04:38 2001
--- ./ext/DynaLoader/dl_dlopen.xs Mon Jul 9 17:09:55 2001
***************
*** 155,166 ****
(void)dl_private_init(aTHX);
! void *
dl_load_file(filename, flags=0)
char * filename
int flags
PREINIT:
int mode = RTLD_LAZY;
CODE:
{
#if defined(DLOPEN_WONT_DO_RELATIVE_PATHS)
--- 155,167 ----
(void)dl_private_init(aTHX);
! void
dl_load_file(filename, flags=0)
char * filename
int flags
PREINIT:
int mode = RTLD_LAZY;
+ void *handle;
CODE:
{
#if defined(DLOPEN_WONT_DO_RELATIVE_PATHS)
***************
*** 184,196 ****
Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
#endif
DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
! RETVAL = dlopen(filename, mode) ;
! DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) RETVAL));
ST(0) = sv_newmortal() ;
! if (RETVAL == NULL)
SaveError(aTHX_ "%s",dlerror()) ;
else
! sv_setiv( ST(0), PTR2IV(RETVAL));
}
--- 185,197 ----
Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
#endif
DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
! handle = dlopen(filename, mode) ;
! DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) handle));
ST(0) = sv_newmortal() ;
! if (handle == NULL)
SaveError(aTHX_ "%s",dlerror()) ;
else
! sv_setiv( ST(0), PTR2IV(handle));
}
***************
*** 207,216 ****
RETVAL
! void *
dl_find_symbol(libhandle, symbolname)
void * libhandle
char * symbolname
CODE:
#ifdef DLSYM_NEEDS_UNDERSCORE
symbolname = Perl_form_nocontext("_%s", symbolname);
--- 208,219 ----
RETVAL
! void
dl_find_symbol(libhandle, symbolname)
void * libhandle
char * symbolname
+ PREINIT:
+ void *sym;
CODE:
#ifdef DLSYM_NEEDS_UNDERSCORE
symbolname = Perl_form_nocontext("_%s", symbolname);
***************
*** 218,236 ****
DLDEBUG(2, PerlIO_printf(Perl_debug_log,
"dl_find_symbol(handle=%lx, symbol=%s)\n",
(unsigned long) libhandle, symbolname));
! RETVAL = dlsym(libhandle, symbolname);
DLDEBUG(2, PerlIO_printf(Perl_debug_log,
! " symbolref = %lx\n", (unsigned long) RETVAL));
ST(0) = sv_newmortal() ;
! if (RETVAL == NULL)
SaveError(aTHX_ "%s",dlerror()) ;
else
! sv_setiv( ST(0), PTR2IV(RETVAL));
void
dl_undef_symbols()
! PPCODE:
--- 221,239 ----
DLDEBUG(2, PerlIO_printf(Perl_debug_log,
"dl_find_symbol(handle=%lx, symbol=%s)\n",
(unsigned long) libhandle, symbolname));
! sym = dlsym(libhandle, symbolname);
DLDEBUG(2, PerlIO_printf(Perl_debug_log,
! " symbolref = %lx\n", (unsigned long) sym));
ST(0) = sv_newmortal() ;
! if (sym == NULL)
SaveError(aTHX_ "%s",dlerror()) ;
else
! sv_setiv( ST(0), PTR2IV(sym));
void
dl_undef_symbols()
! CODE:
diff -c 'perl-5.7.1/ext/DynaLoader/dl_mpeix.xs' 'perl-5.7.2/ext/DynaLoader/dl_mpeix.xs'
Index: ./ext/DynaLoader/dl_mpeix.xs
*** ./ext/DynaLoader/dl_mpeix.xs Tue Mar 6 04:04:38 2001
--- ./ext/DynaLoader/dl_mpeix.xs Mon Jul 9 17:09:55 2001
***************
*** 51,57 ****
PREINIT:
char buf[PATH_MAX + 3];
p_mpe_dld obj = NULL;
! int i;
CODE:
DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,
flags));
--- 51,57 ----
PREINIT:
char buf[PATH_MAX + 3];
p_mpe_dld obj = NULL;
!
CODE:
DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,
flags));
diff -c 'perl-5.7.1/ext/DynaLoader/dlutils.c' 'perl-5.7.2/ext/DynaLoader/dlutils.c'
Index: ./ext/DynaLoader/dlutils.c
*** ./ext/DynaLoader/dlutils.c Tue Mar 6 04:04:39 2001
--- ./ext/DynaLoader/dlutils.c Mon Jul 9 17:09:55 2001
***************
*** 27,33 ****
#define DLDEBUG(level,code)
#endif
!
/* Close all dlopen'd files */
static void
dl_unload_all_files(pTHXo_ void *unused)
--- 27,33 ----
#define DLDEBUG(level,code)
#endif
! #ifdef DL_UNLOAD_ALL_AT_EXIT
/* Close all dlopen'd files */
static void
dl_unload_all_files(pTHXo_ void *unused)
***************
*** 51,57 ****
}
}
}
!
static void
dl_generic_private_init(pTHXo) /* called by dl_*.xs dl_private_init() */
--- 51,57 ----
}
}
}
! #endif
static void
dl_generic_private_init(pTHXo) /* called by dl_*.xs dl_private_init() */
diff -c /dev/null 'perl-5.7.2/ext/Encode.t'
Index: ./ext/Encode.t
*** ./ext/Encode.t Thu Jan 1 02:00:00 1970
--- ./ext/Encode.t Mon Jul 9 17:09:55 2001
***************
*** 0 ****
--- 1,122 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\Encode\b/) {
+ print "1..0 # Skip: Encode was not built\n";
+ exit 0;
+ }
+ }
+ use Test;
+ use Encode qw(from_to encode decode encode_utf8 decode_utf8 find_encoding);
+ use charnames qw(greek);
+ my @encodings = grep(/iso-?8859/,Encode::encodings());
+ my $n = 2;
+ my @character_set = ('0'..'9', 'A'..'Z', 'a'..'z');
+ my @source = qw(ascii iso8859-1 cp1250);
+ my @destiny = qw(cp1047 cp37 posix-bc);
+ my @ebcdic_sets = qw(cp1047 cp37 posix-bc);
+ plan test => 38+$n*@encodings + 2*@source*@destiny*@character_set + 2*@ebcdic_sets*256;
+ my $str = join('',map(chr($_),0x20..0x7E));
+ my $cpy = $str;
+ ok(length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong");
+ ok($cpy,$str,"ASCII mangled by translating from iso8859-1 to Unicode");
+ $cpy = $str;
+ ok(from_to($cpy,'Unicode','iso8859-1'),length($str),"Length wrong");
+ ok($cpy,$str,"ASCII mangled by translating from Unicode to iso8859-1");
+
+ $str = join('',map(chr($_),0xa0..0xff));
+ $cpy = $str;
+ ok(length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong");
+
+ my $sym = Encode->getEncoding('symbol');
+ my $uni = $sym->decode(encode(ascii => 'a'));
+ ok("\N{alpha}",substr($uni,0,1),"alpha does not map to symbol 'a'");
+ $str = $sym->encode("\N{Beta}");
+ ok("B",decode(ascii => substr($str,0,1)),"Symbol 'B' does not map to Beta");
+
+ foreach my $enc (qw(symbol dingbats ascii),@encodings)
+ {
+ my $tab = Encode->getEncoding($enc);
+ ok(1,defined($tab),"Could not load $enc");
+ $str = join('',map(chr($_),0x20..0x7E));
+ $uni = $tab->decode($str);
+ $cpy = $tab->encode($uni);
+ ok($cpy,$str,"$enc mangled translating to Unicode and back");
+ }
+
+ # On ASCII based machines see if we can map several codepoints from
+ # three distinct ASCII sets to three distinct EBCDIC coded character sets.
+ # On EBCDIC machines see if we can map from three EBCDIC sets to three
+ # distinct ASCII sets.
+
+ my @expectation = (240..249, 193..201,209..217,226..233, 129..137,145..153,162..169);
+ if (ord('A') != 65) {
+ my @temp = @destiny;
+ @destiny = @source;
+ @source = @temp;
+ undef(@temp);
+ @expectation = (48..57, 65..90, 97..122);
+ }
+
+ foreach my $to (@destiny)
+ {
+ foreach my $from (@source)
+ {
+ my @expected = @expectation;
+ foreach my $chr (@character_set)
+ {
+ my $native_chr = $chr;
+ my $cpy = $chr;
+ my $rc = from_to($cpy,$from,$to);
+ ok(1,$rc,"Could not translate from $from to $to");
+ ok(ord($cpy),shift(@expected),"mangled translating $native_chr from $from to $to");
+ }
+ }
+ }
+
+ # On either ASCII or EBCDIC machines ensure we can take the full one
+ # byte repetoire to EBCDIC sets and back.
+
+ my $enc_as = 'iso8859-1';
+ foreach my $enc_eb (@ebcdic_sets)
+ {
+ foreach my $ord (0..255)
+ {
+ $str = chr($ord);
+ my $rc = from_to($str,$enc_as,$enc_eb);
+ $rc += from_to($str,$enc_eb,$enc_as);
+ ok($rc,2,"return code for $ord $enc_eb -> $enc_as -> $enc_eb was not obtained");
+ ok($ord,ord($str),"$enc_as mangled translating $ord to $enc_eb and back");
+ }
+ }
+
+ my $mime = find_encoding('iso-8859-2');
+ ok(defined($mime),1,"Cannot find MIME-ish'iso-8859-2'");
+ my $x11 = find_encoding('iso8859-2');
+ ok(defined($x11),1,"Cannot find X11-ish 'iso8859-2'");
+ ok($mime,$x11,"iso8598-2 and iso-8859-2 not same");
+ my $spc = find_encoding('iso 8859-2');
+ ok(defined($spc),1,"Cannot find 'iso 8859-2'");
+ ok($spc,$mime,"iso 8859-2 and iso-8859-2 not same");
+
+ for my $i (256,128,129,256)
+ {
+ my $c = chr($i);
+ my $s = "$c\n".sprintf("%02X",$i);
+ ok(utf8::valid($s),1,"concat of $i botched");
+ utf8::upgrade($s);
+ ok(utf8::valid($s),1,"concat of $i botched");
+ }
+
+ # Spot check a few points in/out of utf8
+ for my $i (0x41,128,256,0x20AC)
+ {
+ my $c = chr($i);
+ my $o = encode_utf8($c);
+ ok(decode_utf8($o),$c,"decode_utf8 not inverse of encode_utf8 for $i");
+ ok(encode('utf8',$c),$o,"utf8 encode by name broken for $i");
+ ok(decode('utf8',$o),$c,"utf8 decode by name broken for $i");
+ }
+
+
diff -c 'perl-5.7.1/ext/Encode/Encode.pm' 'perl-5.7.2/ext/Encode/Encode.pm'
Index: ./ext/Encode/Encode.pm
*** ./ext/Encode/Encode.pm Sat Apr 7 01:59:26 2001
--- ./ext/Encode/Encode.pm Tue Jul 10 07:15:26 2001
***************
*** 42,48 ****
--- 42,51 ----
our %encoding;
my @alias; # ordered matching list
my %alias; # cached known aliases
+ # 0 1 2 3 4 5 6 7 8 9 10
+ our @latin2iso_num = ( 0, 1, 2, 3, 4, 9, 10, 13, 14, 15, 16 );
+
sub encodings
{
my ($class) = @_;
***************
*** 60,66 ****
my $alias = $alias[$i];
my $val = $alias[$i+1];
my $new;
-
if (ref($alias) eq 'Regexp' && $_ =~ $alias)
{
$new = eval $val;
--- 63,68 ----
***************
*** 100,109 ****
# Allow variants of iso-8859-1 etc.
define_alias( qr/^iso[-_]?(\d+)[-_](\d+)$/i => '"iso-$1-$2"' );
# Allow latin-1 style names as well
! # 0 1 2 3 4 5 6 7 8 9 10
! my @latin2iso_num = ( 0, 1, 2, 3, 4, 9, 10, 13, 14, 15, 16 );
! define_alias( qr/^latin[-_]?(\d+)$/i => '"iso-8859-$latin2iso_num[$1]"' );
# Common names for non-latin prefered MIME names
define_alias( 'ascii' => 'US-ascii',
--- 102,117 ----
# Allow variants of iso-8859-1 etc.
define_alias( qr/^iso[-_]?(\d+)[-_](\d+)$/i => '"iso-$1-$2"' );
+ # At least HP-UX has these.
+ define_alias( qr/^iso8859(\d+)$/i => '"iso-8859-$1"' );
+
+ # This is a font issue, not an encoding issue.
+ # (The currency symbol of the Latin 1 upper half
+ # has been redefined as the euro symbol.)
+ define_alias( qr/^(.+)\@euro$/i => '"$1"' );
+
# Allow latin-1 style names as well
! define_alias( qr/^(?:iso[-_]?)?latin[-_]?(\d+)$/i => '"iso-8859-$latin2iso_num[$1]"' );
# Common names for non-latin prefered MIME names
define_alias( 'ascii' => 'US-ascii',
***************
*** 112,119 ****
'greek' => 'iso-8859-7',
'hebrew' => 'iso-8859-8');
! define_alias( 'ibm-1047' => 'cp1047');
# Map white space and _ to '-'
define_alias( qr/^(\S+)[\s_]+(.*)$/i => '"$1-$2"' );
--- 120,137 ----
'greek' => 'iso-8859-7',
'hebrew' => 'iso-8859-8');
! # At least AIX has IBM-NNN (surprisingly...) instead of cpNNN.
! define_alias( qr/^ibm[-_]?(\d\d\d\d?)$/i => '"cp$1"');
+ # Standardize on the dashed versions.
+ define_alias( qr/^utf8$/i => 'utf-8' );
+ define_alias( qr/^koi8r$/i => 'koi8-r' );
+
+ # TODO: the HP-UX '8' encodings: arabic8 greek8 hebrew8 roman8 turkish8
+ # TODO: the Thai Encoding tis620
+ # TODO: the Chinese Encoding gb18030
+ # TODO: what is the Japanese 'ujis' encoding seen in some Linuxes?
+
# Map white space and _ to '-'
define_alias( qr/^(\S+)[\s_]+(.*)$/i => '"$1-$2"' );
***************
*** 136,141 ****
--- 154,163 ----
{
my ($class,$name) = @_;
my $enc;
+ if (ref($name) && $name->can('new_sequence'))
+ {
+ return $name;
+ }
if (exists $encoding{$name})
{
return $encoding{$name};
***************
*** 358,372 ****
=head1 DESCRIPTION
! The C<Encode> module provides the interfaces between perl's strings
! and the rest of the system. Perl strings are sequences of B<characters>.
The repertoire of characters that Perl can represent is at least that
! defined by the Unicode Consortium. On most platforms the ordinal values
! of the characters (as returned by C<ord(ch)>) is the "Unicode codepoint" for
! the character (the exceptions are those platforms where the legacy
! encoding is some variant of EBCDIC rather than a super-set of ASCII
! - see L<perlebcdic>).
Traditionaly computer data has been moved around in 8-bit chunks
often called "bytes". These chunks are also known as "octets" in
--- 380,394 ----
=head1 DESCRIPTION
! The C<Encode> module provides the interfaces between Perl's strings
! and the rest of the system. Perl strings are sequences of B<characters>.
The repertoire of characters that Perl can represent is at least that
! defined by the Unicode Consortium. On most platforms the ordinal
! values of the characters (as returned by C<ord(ch)>) is the "Unicode
! codepoint" for the character (the exceptions are those platforms where
! the legacy encoding is some variant of EBCDIC rather than a super-set
! of ASCII - see L<perlebcdic>).
Traditionaly computer data has been moved around in 8-bit chunks
often called "bytes". These chunks are also known as "octets" in
***************
*** 375,383 ****
computer languages but also "binary" data being the machines representation
of numbers, pixels in an image - or just about anything.
! When perl is processing "binary data" the programmer wants perl to process
! "sequences of bytes". This is not a problem for perl - as a byte has 256
! possible values it easily fits in perl's much larger "logical character".
=head2 TERMINOLOGY
--- 397,405 ----
computer languages but also "binary" data being the machines representation
of numbers, pixels in an image - or just about anything.
! When Perl is processing "binary data" the programmer wants Perl to process
! "sequences of bytes". This is not a problem for Perl - as a byte has 256
! possible values it easily fits in Perl's much larger "logical character".
=head2 TERMINOLOGY
***************
*** 386,402 ****
=item *
I<character>: a character in the range 0..(2**32-1) (or more).
! (What perl's strings are made of.)
=item *
I<byte>: a character in the range 0..255
! (A special case of a perl character.)
=item *
I<octet>: 8 bits of data, with ordinal values 0..255
! (Term for bytes passed to or from a non-perl context, e.g. disk file.)
=back
--- 408,424 ----
=item *
I<character>: a character in the range 0..(2**32-1) (or more).
! (What Perl's strings are made of.)
=item *
I<byte>: a character in the range 0..255
! (A special case of a Perl character.)
=item *
I<octet>: 8 bits of data, with ordinal values 0..255
! (Term for bytes passed to or from a non-Perl context, e.g. disk file.)
=back
***************
*** 426,432 ****
=item * Fixed length 16-bit encodings
Each character is two octets so may have a repertoire of up to
! 65,536 characters. Unicode's UCS-2 is an example. Also used for
encodings for East Asian languages.
=item * Fixed length 32-bit encodings.
--- 448,454 ----
=item * Fixed length 16-bit encodings
Each character is two octets so may have a repertoire of up to
! 65 536 characters. Unicode's UCS-2 is an example. Also used for
encodings for East Asian languages.
=item * Fixed length 32-bit encodings.
***************
*** 456,463 ****
a different "embedded" encoding.
These schemes are very flexible and can handle mixed languages but are
! very complex to process (and have state).
! No escape encodings are implemented for perl yet.
=back
--- 478,485 ----
a different "embedded" encoding.
These schemes are very flexible and can handle mixed languages but are
! very complex to process (and have state). No escape encodings are
! implemented for Perl yet.
=back
***************
*** 469,476 ****
=item 1. By name
! Encoding names are strings with characters taken from a restricted repertoire.
! See L</"Encoding Names">.
=item 2. As an object
--- 491,498 ----
=item 1. By name
! Encoding names are strings with characters taken from a restricted
! repertoire. See L</"Encoding Names">.
=item 2. As an object
***************
*** 481,489 ****
=head2 Encoding Names
Encoding names are case insensitive. White space in names is ignored.
! In addition an encoding may have aliases. Each encoding has one "canonical" name.
! The "canonical" name is chosen from the names of the encoding by picking
! the first in the following sequence:
=over 4
--- 503,511 ----
=head2 Encoding Names
Encoding names are case insensitive. White space in names is ignored.
! In addition an encoding may have aliases. Each encoding has one
! "canonical" name. The "canonical" name is chosen from the names of
! the encoding by picking the first in the following sequence:
=over 4
***************
*** 509,541 ****
$bytes = encode(ENCODING, $string[, CHECK])
! Encodes string from perl's internal form into I<ENCODING> and returns a
! sequence of octets.
! See L</"Handling Malformed Data">.
=item *
$string = decode(ENCODING, $bytes[, CHECK])
! Decode sequence of octets assumed to be in I<ENCODING> into perls internal
! form and returns the resuting string.
! See L</"Handling Malformed Data">.
=back
=head2 Handling Malformed Data
If CHECK is not set, C<undef> is returned. If the data is supposed to
! be UTF-8, an optional lexical warning (category utf8) is given.
! If CHECK is true but not a code reference, dies.
! It would desirable to have a way to indicate that transform should use the
! encodings "replacement character" - no such mechanism is defined yet.
It is also planned to allow I<CHECK> to be a code reference.
! This is not yet implemented as there are design issues with what its arguments
! should be and how it returns its results.
=over 4
--- 531,582 ----
$bytes = encode(ENCODING, $string[, CHECK])
! Encodes string from Perl's internal form into I<ENCODING> and returns
! a sequence of octets. For CHECK see L</"Handling Malformed Data">.
=item *
$string = decode(ENCODING, $bytes[, CHECK])
! Decode sequence of octets assumed to be in I<ENCODING> into Perl's
! internal form and returns the resulting string. For CHECK see
! L</"Handling Malformed Data">.
+ =item *
+
+ from_to($string, FROM_ENCODING, TO_ENCODING[, CHECK])
+
+ Convert B<in-place> the data between two encodings. How did the data
+ in $string originally get to be in FROM_ENCODING? Either using
+ encode() or through PerlIO: See L</"Encoding and IO">. For CHECK
+ see L</"Handling Malformed Data">.
+
+ For example to convert ISO 8859-1 data to UTF-8:
+
+ from_to($data, "iso-8859-1", "utf-8");
+
+ and to convert it back:
+
+ from_to($data, "utf-8", "iso-8859-1");
+
+ Note that because the conversion happens in place, the data to be
+ converted cannot be a string constant, it must be a scalar variable.
+
=back
=head2 Handling Malformed Data
If CHECK is not set, C<undef> is returned. If the data is supposed to
! be UTF-8, an optional lexical warning (category utf8) is given. If
! CHECK is true but not a code reference, dies.
! It would desirable to have a way to indicate that transform should use
! the encodings "replacement character" - no such mechanism is defined yet.
It is also planned to allow I<CHECK> to be a code reference.
! This is not yet implemented as there are design issues with what its
! arguments should be and how it returns its results.
=over 4
***************
*** 556,566 ****
=item Scheme 2
! Passed original string, and an index into it of the problem area,
! and output string so far.
! Appends what it will to output string and returns new index into
! original string.
! e.g.
sub fixup {
# my ($s,$i,$d) = @_;
--- 597,605 ----
=item Scheme 2
! Passed original string, and an index into it of the problem area, and
! output string so far. Appends what it will to output string and
! returns new index into original string. For example:
sub fixup {
# my ($s,$i,$d) = @_;
***************
*** 569,577 ****
return $_[1]+1;
}
! This scheme gives maximal control to the fixup routine but is more complicated
! to code, and may need internals of Encode to be tweaked to keep original
! string intact.
=item Other Schemes
--- 608,616 ----
return $_[1]+1;
}
! This scheme gives maximal control to the fixup routine but is more
! complicated to code, and may need internals of Encode to be tweaked to
! keep original string intact.
=item Other Schemes
***************
*** 586,596 ****
=head2 UTF-8 / utf8
The Unicode consortium defines the UTF-8 standard as a way of encoding
! the entire Unicode repertiore as sequences of octets. This encoding
! is expected to become very widespread. Perl can use this form internaly
! to represent strings, so conversions to and from this form are particularly
! efficient (as octets in memory do not have to change, just the meta-data
! that tells perl how to treat them).
=over 4
--- 625,635 ----
=head2 UTF-8 / utf8
The Unicode consortium defines the UTF-8 standard as a way of encoding
! the entire Unicode repertiore as sequences of octets. This encoding is
! expected to become very widespread. Perl can use this form internaly
! to represent strings, so conversions to and from this form are
! particularly efficient (as octets in memory do not have to change,
! just the meta-data that tells Perl how to treat them).
=over 4
***************
*** 598,604 ****
$bytes = encode_utf8($string);
! The characters that comprise string are encoded in perl's superset of UTF-8
and the resulting octets returned as a sequence of bytes. All possible
characters have a UTF-8 representation so this function cannot fail.
--- 637,643 ----
$bytes = encode_utf8($string);
! The characters that comprise string are encoded in Perl's superset of UTF-8
and the resulting octets returned as a sequence of bytes. All possible
characters have a UTF-8 representation so this function cannot fail.
***************
*** 606,630 ****
$string = decode_utf8($bytes [,CHECK]);
! The sequence of octets represented by $bytes is decoded from UTF-8 into
! a sequence of logical characters. Not all sequences of octets form valid
! UTF-8 encodings, so it is possible for this call to fail.
! See L</"Handling Malformed Data">.
=back
=head2 Other Encodings of Unicode
! UTF-16 is similar to UCS-2, 16 bit or 2-byte chunks.
! UCS-2 can only represent 0..0xFFFF, while UTF-16 has a "surogate pair"
! scheme which allows it to cover the whole Unicode range.
Encode implements big-endian UCS-2 aliased to "iso-10646-1" as that
! happens to be the name used by that representation when used with X11 fonts.
UTF-32 or UCS-4 is 32-bit or 4-byte chunks. Perl's logical characters
can be considered as being in this form without encoding. An encoding
! to transfer strings in this form (e.g. to write them to a file) would need to
pack('L',map(chr($_),split(//,$string))); # native
or
--- 645,671 ----
$string = decode_utf8($bytes [,CHECK]);
! The sequence of octets represented by $bytes is decoded from UTF-8
! into a sequence of logical characters. Not all sequences of octets
! form valid UTF-8 encodings, so it is possible for this call to fail.
! For CHECK see L</"Handling Malformed Data">.
=back
=head2 Other Encodings of Unicode
! UTF-16 is similar to UCS-2, 16 bit or 2-byte chunks. UCS-2 can only
! represent 0..0xFFFF, while UTF-16 has a "surrogate pair" scheme which
! allows it to cover the whole Unicode range.
Encode implements big-endian UCS-2 aliased to "iso-10646-1" as that
! happens to be the name used by that representation when used with X11
! fonts.
UTF-32 or UCS-4 is 32-bit or 4-byte chunks. Perl's logical characters
can be considered as being in this form without encoding. An encoding
! to transfer strings in this form (e.g. to write them to a file) would
! need to
pack('L',map(chr($_),split(//,$string))); # native
or
***************
*** 636,643 ****
No UTF-32 encodings are implemented yet.
! Both UCS-2 and UCS-4 style encodings can have "byte order marks" by representing
! the code point 0xFFFE as the very first thing in a file.
=head2 Listing available encodings
--- 677,684 ----
No UTF-32 encodings are implemented yet.
! Both UCS-2 and UCS-4 style encodings can have "byte order marks" by
! representing the code point 0xFFFE as the very first thing in a file.
=head2 Listing available encodings
***************
*** 651,658 ****
use Encode qw(define_alias);
define_alias( newName => ENCODING);
! Allows newName to be used as am alias for ENCODING. ENCODING may be either the
! name of an encoding or and encoding object (as above).
Currently I<newName> can be specified in the following ways:
--- 692,699 ----
use Encode qw(define_alias);
define_alias( newName => ENCODING);
! Allows newName to be used as am alias for ENCODING. ENCODING may be
! either the name of an encoding or and encoding object (as above).
Currently I<newName> can be specified in the following ways:
***************
*** 664,673 ****
define_alias( qr/^iso8859-(\d+)$/i => '"iso-8859-$1"' );
! In this case if I<ENCODING> is not a reference it is C<eval>-ed to allow
! C<$1> etc. to be subsituted.
! The example is one way to names as used in X11 font names to alias the MIME names for the
! iso-8859-* family.
=item As a code reference, e.g.:
--- 705,714 ----
define_alias( qr/^iso8859-(\d+)$/i => '"iso-8859-$1"' );
! In this case if I<ENCODING> is not a reference it is C<eval>-ed to
! allow C<$1> etc. to be subsituted. The example is one way to names as
! used in X11 font names to alias the MIME names for the iso-8859-*
! family.
=item As a code reference, e.g.:
***************
*** 674,711 ****
define_alias( sub { return /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } , '');
In this case C<$_> will be set to the name that is being looked up and
! I<ENCODING> is passed to the sub as its first argument.
! The example is another way to names as used in X11 font names to alias the MIME names for
! the iso-8859-* family.
=back
=head2 Defining Encodings
! use Encode qw(define_alias);
! define_encoding( $object, 'canonicalName' [,alias...]);
! Causes I<canonicalName> to be associated with I<$object>.
! The object should provide the interface described in L</"IMPLEMENTATION CLASSES"> below.
! If more than two arguments are provided then additional arguments are taken
! as aliases for I<$object> as for C<define_alias>.
=head1 Encoding and IO
It is very common to want to do encoding transformations when
reading or writing files, network connections, pipes etc.
! If perl is configured to use the new 'perlio' IO system then
C<Encode> provides a "layer" (See L<perliol>) which can transform
data as it is read or written.
! open(my $ilyad,'>:encoding(iso-8859-7)','ilyad.greek');
! print $ilyad @epic;
In addition the new IO system can also be configured to read/write
UTF-8 encoded characters (as noted above this is efficient):
! open(my $fh,'>:utf8','anything');
! print $fh "Any \x{0021} string \N{SMILEY FACE}\n";
Either of the above forms of "layer" specifications can be made the default
for a lexical scope with the C<use open ...> pragma. See L<open>.
--- 715,759 ----
define_alias( sub { return /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } , '');
In this case C<$_> will be set to the name that is being looked up and
! I<ENCODING> is passed to the sub as its first argument. The example
! is another way to names as used in X11 font names to alias the MIME
! names for the iso-8859-* family.
=back
=head2 Defining Encodings
! use Encode qw(define_alias);
! define_encoding( $object, 'canonicalName' [,alias...]);
! Causes I<canonicalName> to be associated with I<$object>. The object
! should provide the interface described in L</"IMPLEMENTATION CLASSES">
! below. If more than two arguments are provided then additional
! arguments are taken as aliases for I<$object> as for C<define_alias>.
=head1 Encoding and IO
It is very common to want to do encoding transformations when
reading or writing files, network connections, pipes etc.
! If Perl is configured to use the new 'perlio' IO system then
C<Encode> provides a "layer" (See L<perliol>) which can transform
data as it is read or written.
! Here is how the blind poet would modernise the encoding:
+ use Encode;
+ open(my $iliad,'<:encoding(iso-8859-7)','iliad.greek');
+ open(my $utf8,'>:utf8','iliad.utf8');
+ my @epic = <$iliad>;
+ print $utf8 @epic;
+ close($utf8);
+ close($illiad);
+
In addition the new IO system can also be configured to read/write
UTF-8 encoded characters (as noted above this is efficient):
! open(my $fh,'>:utf8','anything');
! print $fh "Any \x{0021} string \N{SMILEY FACE}\n";
Either of the above forms of "layer" specifications can be made the default
for a lexical scope with the C<use open ...> pragma. See L<open>.
***************
*** 712,732 ****
Once a handle is open is layers can be altered using C<binmode>.
! Without any such configuration, or if perl itself is built using
system's own IO, then write operations assume that file handle accepts
only I<bytes> and will C<die> if a character larger than 255 is
written to the handle. When reading, each octet from the handle
becomes a byte-in-a-character. Note that this default is the same
! behaviour as bytes-only languages (including perl before v5.6) would have,
! and is sufficient to handle native 8-bit encodings e.g. iso-8859-1,
! EBCDIC etc. and any legacy mechanisms for handling other encodings
! and binary data.
! In other cases it is the programs responsibility
! to transform characters into bytes using the API above before
! doing writes, and to transform the bytes read from a handle into characters
! before doing "character operations" (e.g. C<lc>, C</\W+/>, ...).
=head1 Encoding How to ...
To do:
--- 760,799 ----
Once a handle is open is layers can be altered using C<binmode>.
! Without any such configuration, or if Perl itself is built using
system's own IO, then write operations assume that file handle accepts
only I<bytes> and will C<die> if a character larger than 255 is
written to the handle. When reading, each octet from the handle
becomes a byte-in-a-character. Note that this default is the same
! behaviour as bytes-only languages (including Perl before v5.6) would
! have, and is sufficient to handle native 8-bit encodings
! e.g. iso-8859-1, EBCDIC etc. and any legacy mechanisms for handling
! other encodings and binary data.
! In other cases it is the programs responsibility to transform
! characters into bytes using the API above before doing writes, and to
! transform the bytes read from a handle into characters before doing
! "character operations" (e.g. C<lc>, C</\W+/>, ...).
+ You can also use PerlIO to convert larger amounts of data you don't
+ want to bring into memory. For example to convert between ISO 8859-1
+ (Latin 1) and UTF-8 (or UTF-EBCDIC in EBCDIC machines):
+
+ open(F, "<:encoding(iso-8859-1)", "data.txt") or die $!;
+ open(G, ">:utf8", "data.utf") or die $!;
+ while (<F>) { print G }
+
+ # Could also do "print G <F>" but that would pull
+ # the whole file into memory just to write it out again.
+
+ More examples:
+
+ open(my $f, "<:encoding(cp1252)")
+ open(my $g, ">:encoding(iso-8859-2)")
+ open(my $h, ">:encoding(latin9)") # iso-8859-15
+
+ See L<PerlIO> for more information.
+
=head1 Encoding How to ...
To do:
***************
*** 739,752 ****
=item * UTF-8 strings in binary data.
! =item * perl/Encode wrappers on non-Unicode XS modules.
=back
=head1 Messing with Perl's Internals
! The following API uses parts of perl's internals in the current implementation.
! As such they are efficient, but may change.
=over 4
--- 806,819 ----
=item * UTF-8 strings in binary data.
! =item * Perl/Encode wrappers on non-Unicode XS modules.
=back
=head1 Messing with Perl's Internals
! The following API uses parts of Perl's internals in the current
! implementation. As such they are efficient, but may change.
=over 4
***************
*** 753,768 ****
=item * is_utf8(STRING [, CHECK])
[INTERNAL] Test whether the UTF-8 flag is turned on in the STRING.
! If CHECK is true, also checks the data in STRING for being
! well-formed UTF-8. Returns true if successful, false otherwise.
=item * valid_utf8(STRING)
! [INTERNAL] Test whether STRING is in a consistent state.
! Will return true if string is held as bytes, or is well-formed UTF-8
! and has the UTF-8 flag on.
! Main reason for this routine is to allow perl's testsuite to check
! that operations have left strings in a consistent state.
=item *
--- 820,835 ----
=item * is_utf8(STRING [, CHECK])
[INTERNAL] Test whether the UTF-8 flag is turned on in the STRING.
! If CHECK is true, also checks the data in STRING for being well-formed
! UTF-8. Returns true if successful, false otherwise.
=item * valid_utf8(STRING)
! [INTERNAL] Test whether STRING is in a consistent state. Will return
! true if string is held as bytes, or is well-formed UTF-8 and has the
! UTF-8 flag on. Main reason for this routine is to allow Perl's
! testsuite to check that operations have left strings in a consistent
! state.
=item *
***************
*** 795,804 ****
The string form may go away in the future. The string form occurs
when C<encodings()> has scanned C<@INC> for loadable encodings but has
not actually loaded the encoding in question. This is because the
! current "loading" process is all perl and a bit slow.
! Once an encoding is loaded then value of the hash is object which implements
! the encoding. The object should provide the following interface:
=over 4
--- 862,872 ----
The string form may go away in the future. The string form occurs
when C<encodings()> has scanned C<@INC> for loadable encodings but has
not actually loaded the encoding in question. This is because the
! current "loading" process is all Perl and a bit slow.
! Once an encoding is loaded then value of the hash is object which
! implements the encoding. The object should provide the following
! interface:
=over 4
***************
*** 808,862 ****
=item -E<gt>new_sequence
! This is a placeholder for encodings with state. It should return an object
! which implements this interface, all current implementations return the
! original object.
=item -E<gt>encode($string,$check)
! Should return the octet sequence representing I<$string>. If I<$check> is true
! it should modify I<$string> in place to remove the converted part (i.e.
! the whole string unless there is an error).
! If an error occurs it should return the octet sequence for the
! fragment of string that has been converted, and modify $string in-place
! to remove the converted part leaving it starting with the problem fragment.
! If check is is false then C<encode> should make a "best effort" to convert
! the string - for example by using a replacement character.
=item -E<gt>decode($octets,$check)
! Should return the string that I<$octets> represents. If I<$check> is true
! it should modify I<$octets> in place to remove the converted part (i.e.
! the whole sequence unless there is an error).
! If an error occurs it should return the fragment of string
! that has been converted, and modify $octets in-place to remove the converted part
leaving it starting with the problem fragment.
! If check is is false then C<decode> should make a "best effort" to convert
! the string - for example by using Unicode's "\x{FFFD}" as a replacement character.
=back
! It should be noted that the check behaviour is different from the outer
! public API. The logic is that the "unchecked" case is useful when
! encoding is part of a stream which may be reporting errors (e.g. STDERR).
! In such cases it is desirable to get everything through somehow without
! causing additional errors which obscure the original one. Also the encoding
! is best placed to know what the correct replacement character is, so if that
! is the desired behaviour then letting low level code do it is the most efficient.
! In contrast if check is true, the scheme above allows the encoding to do as
! much as it can and tell layer above how much that was. What is lacking
! at present is a mechanism to report what went wrong. The most likely interface
! will be an additional method call to the object, or perhaps
! (to avoid forcing per-stream objects on otherwise stateless encodings)
! and additional parameter.
! It is also highly desirable that encoding classes inherit from C<Encode::Encoding>
! as a base class. This allows that class to define additional behaviour for
! all encoding objects. For example built in Unicode, UCS-2 and UTF-8 classes
! use :
package Encode::MyEncoding;
use base qw(Encode::Encoding);
--- 876,932 ----
=item -E<gt>new_sequence
! This is a placeholder for encodings with state. It should return an
! object which implements this interface, all current implementations
! return the original object.
=item -E<gt>encode($string,$check)
! Should return the octet sequence representing I<$string>. If I<$check>
! is true it should modify I<$string> in place to remove the converted
! part (i.e. the whole string unless there is an error). If an error
! occurs it should return the octet sequence for the fragment of string
! that has been converted, and modify $string in-place to remove the
! converted part leaving it starting with the problem fragment.
! If check is is false then C<encode> should make a "best effort" to
! convert the string - for example by using a replacement character.
=item -E<gt>decode($octets,$check)
! Should return the string that I<$octets> represents. If I<$check> is
! true it should modify I<$octets> in place to remove the converted part
! (i.e. the whole sequence unless there is an error). If an error
! occurs it should return the fragment of string that has been
! converted, and modify $octets in-place to remove the converted part
leaving it starting with the problem fragment.
! If check is is false then C<decode> should make a "best effort" to
! convert the string - for example by using Unicode's "\x{FFFD}" as a
! replacement character.
=back
! It should be noted that the check behaviour is different from the
! outer public API. The logic is that the "unchecked" case is useful
! when encoding is part of a stream which may be reporting errors
! (e.g. STDERR). In such cases it is desirable to get everything
! through somehow without causing additional errors which obscure the
! original one. Also the encoding is best placed to know what the
! correct replacement character is, so if that is the desired behaviour
! then letting low level code do it is the most efficient.
! In contrast if check is true, the scheme above allows the encoding to
! do as much as it can and tell layer above how much that was. What is
! lacking at present is a mechanism to report what went wrong. The most
! likely interface will be an additional method call to the object, or
! perhaps (to avoid forcing per-stream objects on otherwise stateless
! encodings) and additional parameter.
! It is also highly desirable that encoding classes inherit from
! C<Encode::Encoding> as a base class. This allows that class to define
! additional behaviour for all encoding objects. For example built in
! Unicode, UCS-2 and UTF-8 classes use :
package Encode::MyEncoding;
use base qw(Encode::Encoding);
***************
*** 863,889 ****
__PACKAGE__->Define(qw(myCanonical myAlias));
! To create an object with bless {Name => ...},$class, and call define_encoding.
! They inherit their C<name> method from C<Encode::Encoding>.
=head2 Compiled Encodings
! F<Encode.xs> provides a class C<Encode::XS> which provides the interface described
! above. It calls a generic octet-sequence to octet-sequence "engine" that is
! driven by tables (defined in F<encengine.c>). The same engine is used for both
! encode and decode. C<Encode:XS>'s C<encode> forces perl's characters to their UTF-8 form
! and then treats them as just another multibyte encoding. C<Encode:XS>'s C<decode> transforms
! the sequence and then turns the UTF-8-ness flag as that is the form that the tables
! are defined to produce. For details of the engine see the comments in F<encengine.c>.
! The tables are produced by the perl script F<compile> (the name needs to change so
! we can eventually install it somewhere). F<compile> can currently read two formats:
=over 4
=item *.enc
! This is a coined format used by Tcl. It is documented in Encode/EncodeFormat.pod.
=item *.ucm
--- 933,965 ----
__PACKAGE__->Define(qw(myCanonical myAlias));
! To create an object with bless {Name => ...},$class, and call
! define_encoding. They inherit their C<name> method from
! C<Encode::Encoding>.
=head2 Compiled Encodings
! F<Encode.xs> provides a class C<Encode::XS> which provides the
! interface described above. It calls a generic octet-sequence to
! octet-sequence "engine" that is driven by tables (defined in
! F<encengine.c>). The same engine is used for both encode and
! decode. C<Encode:XS>'s C<encode> forces Perl's characters to their
! UTF-8 form and then treats them as just another multibyte
! encoding. C<Encode:XS>'s C<decode> transforms the sequence and then
! turns the UTF-8-ness flag as that is the form that the tables are
! defined to produce. For details of the engine see the comments in
! F<encengine.c>.
! The tables are produced by the Perl script F<compile> (the name needs
! to change so we can eventually install it somewhere). F<compile> can
! currently read two formats:
=over 4
=item *.enc
! This is a coined format used by Tcl. It is documented in
! Encode/EncodeFormat.pod.
=item *.ucm
***************
*** 907,920 ****
=item *.xs
! In theory this allows encodings to be stand-alone loadable perl extensions.
! The process has not yet been tested. The plan is to use this approach
! for large East Asian encodings.
=back
! The set of encodings built-in to F<Encode.so>/F<Encode.dll> is determined by
! F<Makefile.PL>. The current set is as follows:
=over 4
--- 983,996 ----
=item *.xs
! In theory this allows encodings to be stand-alone loadable Perl
! extensions. The process has not yet been tested. The plan is to use
! this approach for large East Asian encodings.
=back
! The set of encodings built-in to F<Encode.so>/F<Encode.dll> is
! determined by F<Makefile.PL>. The current set is as follows:
=over 4
***************
*** 924,946 ****
=item IBM-1047 and two other variants of EBCDIC.
! These are the same variants that are supported by EBCDIC perl as "native" encodings.
! They are included to prove "reversibility" of some constructs in EBCDIC perl.
=item symbol and dingbats as used by Tk on X11.
! (The reason Encode got started was to support perl/Tk.)
=back
! That set is rather ad. hoc. and has been driven by the needs of the tests rather
! than the needs of typical applications. It is likely to be rationalized.
=head1 SEE ALSO
! L<perlunicode>, L<perlebcdic>, L<perlfunc/open>
=cut
-
-
--- 1000,1022 ----
=item IBM-1047 and two other variants of EBCDIC.
! These are the same variants that are supported by EBCDIC Perl as
! "native" encodings. They are included to prove "reversibility" of
! some constructs in EBCDIC Perl.
=item symbol and dingbats as used by Tk on X11.
! (The reason Encode got started was to support Perl/Tk.)
=back
! That set is rather ad hoc and has been driven by the needs of the
! tests rather than the needs of typical applications. It is likely
! to be rationalized.
=head1 SEE ALSO
! L<perlunicode>, L<perlebcdic>, L<perlfunc/open>, L<PerlIO>
=cut
diff -c 'perl-5.7.1/ext/Encode/Encode.xs' 'perl-5.7.2/ext/Encode/Encode.xs'
Index: ./ext/Encode/Encode.xs
*** ./ext/Encode/Encode.xs Fri Mar 30 05:02:58 2001
--- ./ext/Encode/Encode.xs Mon Jul 9 17:09:56 2001
***************
*** 1,3 ****
--- 1,5 ----
+ #define PERL_NO_GET_CONTEXT
+
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
***************
*** 7,13 ****
#include "EBCDIC.h"
#include "Symbols.h"
! #define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) { \
Perl_croak(aTHX_ "panic_unimplemented"); \
return (y)0; /* fool picky compilers */ \
}
--- 9,16 ----
#include "EBCDIC.h"
#include "Symbols.h"
!
! #define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) {dTHX; \
Perl_croak(aTHX_ "panic_unimplemented"); \
return (y)0; /* fool picky compilers */ \
}
***************
*** 51,56 ****
--- 54,60 ----
SV *
PerlIOEncode_getarg(PerlIO *f)
{
+ dTHX;
PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
SV *sv = &PL_sv_undef;
if (e->enc)
***************
*** 534,539 ****
--- 538,544 ----
STRLEN len;
U8 *s = (U8*)SvPV(sv, len);
+ RETVAL = 0;
if (SvTRUE(check)) {
/* Must do things the slow way */
U8 *dest;
diff -c /dev/null 'perl-5.7.2/ext/Encode/Encode/7bit-jis.enc'
Index: ./ext/Encode/Encode/7bit-jis.enc
*** ./ext/Encode/Encode/7bit-jis.enc Thu Jan 1 02:00:00 1970
--- ./ext/Encode/Encode/7bit-jis.enc Mon Jul 9 17:09:56 2001
***************
*** 0 ****
--- 1,12 ----
+ # Encoding file: 7bit-jis, escape-driven
+ E
+ name 7bit-jis
+ init {}
+ final {}
+ ascii \x1b(B
+ ascii \x1b(J
+ 7bit-kana \x1b(I
+ jis0208 \x1b$B
+ jis0208 \x1b$@
+ jis0208 \x1b&@\x1b$B
+ jis0212 \x1b$(D
diff -c /dev/null 'perl-5.7.2/ext/Encode/Encode/7bit-kana.enc'
Index: ./ext/Encode/Encode/7bit-kana.enc
*** ./ext/Encode/Encode/7bit-kana.enc Thu Jan 1 02:00:00 1970
--- ./ext/Encode/Encode/7bit-kana.enc Tue Jul 10 05:00:49 2001
***************
*** 0 ****
--- 1,20 ----
+ # Encoding file: 7bit-kana, single-byte
+ S
+ 0025 0 1
+ 00
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000FF61FF62FF63FF64FF65FF66FF67FF68FF69FF6AFF6BFF6CFF6DFF6EFF6F
+ FF70FF71FF72FF73FF74FF75FF76FF77FF78FF79FF7AFF7BFF7CFF7DFF7EFF7F
+ FF80FF81FF82FF83FF84FF85FF86FF87FF88FF89FF8AFF8BFF8CFF8DFF8EFF8F
+ FF90FF91FF92FF93FF94FF95FF96FF97FF98FF99FF9AFF9BFF9CFF9DFF9EFF9F
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
diff -c /dev/null 'perl-5.7.2/ext/Encode/Encode/7bit-kr.enc'
Index: ./ext/Encode/Encode/7bit-kr.enc
*** ./ext/Encode/Encode/7bit-kr.enc Thu Jan 1 02:00:00 1970
--- ./ext/Encode/Encode/7bit-kr.enc Mon Jul 9 17:09:56 2001
***************
*** 0 ****
--- 1,7 ----
+ # Encoding file: 7bit-kr, escape-driven
+ E
+ name 7bit-kr
+ init \x1b$)C
+ final {}
+ ascii \x0f
+ ksc5601 \x0e
diff -c /dev/null 'perl-5.7.2/ext/Encode/Encode/HZ.enc'
Index: ./ext/Encode/Encode/HZ.enc
*** ./ext/Encode/Encode/HZ.enc Thu Jan 1 02:00:00 1970
--- ./ext/Encode/Encode/HZ.enc Tue Jul 10 05:09:23 2001
***************
*** 0 ****
--- 1,7 ----
+ # Encoding file: HZ, HanZi
+ H
+ name HZ
+ init {}
+ final {}
+ ascii \x7e\x7d
+ gb2312 \x7e\x7b
diff -c 'perl-5.7.1/ext/Encode/Encode/Tcl.pm' 'perl-5.7.2/ext/Encode/Encode/Tcl.pm'
Index: ./ext/Encode/Encode/Tcl.pm
*** ./ext/Encode/Encode/Tcl.pm Fri Mar 9 16:46:09 2001
--- ./ext/Encode/Encode/Tcl.pm Tue Jul 10 05:00:50 2001
***************
*** 78,85 ****
$type = substr($line,0,1);
last unless $type eq '#';
}
! my $class = ref($obj).('::'.(($type eq 'E') ? 'Escape' : 'Table'));
! carp "Loading $file";
bless $obj,$class;
return $obj if $obj->read($fh,$obj->name,$type);
}
--- 78,85 ----
$type = substr($line,0,1);
last unless $type eq '#';
}
! my $class = ref($obj).('::'.(($type eq 'H') ? 'HanZi' : ($type eq 'E') ? 'Escape' : 'Table'));
! # carp "Loading $file";
bless $obj,$class;
return $obj if $obj->read($fh,$obj->name,$type);
}
***************
*** 110,116 ****
sub read
{
my ($obj,$fh,$name,$type) = @_;
! my $rep = $obj->can("rep_$type");
my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
my @touni;
my %fmuni;
--- 110,116 ----
sub read
{
my ($obj,$fh,$name,$type) = @_;
! my($rep, @leading);
my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
my @touni;
my %fmuni;
***************
*** 122,127 ****
--- 122,128 ----
chomp($line);
my $page = hex($line);
my @page;
+ $leading[$page] = 1 if $page;
my $ch = $page * 256;
for (my $i = 0; $i < 16; $i++)
{
***************
*** 131,137 ****
my $val = hex(substr($line,0,4,''));
if ($val || !$ch)
{
! my $uch = chr($val);
push(@page,$uch);
$fmuni{$uch} = $ch;
$count++;
--- 132,138 ----
my $val = hex(substr($line,0,4,''));
if ($val || !$ch)
{
! my $uch = pack('U', $val); # chr($val);
push(@page,$uch);
$fmuni{$uch} = $ch;
$count++;
***************
*** 145,150 ****
--- 146,153 ----
}
$touni[$page] = \@page;
}
+ $rep = $type ne 'M' ? $obj->can("rep_$type") :
+ sub { ($_[0] > 255) || $leading[$_[0]] ? 'n' : 'C'};
$obj->{'Rep'} = $rep;
$obj->{'ToUni'} = \@touni;
$obj->{'FmUni'} = \%fmuni;
***************
*** 157,169 ****
sub rep_D { 'n' }
! sub rep_M { ($_[0] > 255) ? 'n' : 'C' }
sub representation
{
my ($obj,$ch) = @_;
$ch = 0 unless @_ > 1;
! $obj-{'Rep'}->($ch);
}
sub decode
--- 160,172 ----
sub rep_D { 'n' }
! #sub rep_M { ($_[0] > 255) ? 'n' : 'C' }
sub representation
{
my ($obj,$ch) = @_;
$ch = 0 unless @_ > 1;
! $obj->{'Rep'}->($ch);
}
sub decode
***************
*** 171,177 ****
my ($obj,$str,$chk) = @_;
my $rep = $obj->{'Rep'};
my $touni = $obj->{'ToUni'};
! my $uni = '';
while (length($str))
{
my $ch = ord(substr($str,0,1,''));
--- 174,180 ----
my ($obj,$str,$chk) = @_;
my $rep = $obj->{'Rep'};
my $touni = $obj->{'ToUni'};
! my $uni;
while (length($str))
{
my $ch = ord(substr($str,0,1,''));
***************
*** 201,209 ****
{
my ($obj,$uni,$chk) = @_;
my $fmuni = $obj->{'FmUni'};
- my $str = '';
my $def = $obj->{'Def'};
my $rep = $obj->{'Rep'};
while (length($uni))
{
my $ch = substr($uni,0,1,'');
--- 204,212 ----
{
my ($obj,$uni,$chk) = @_;
my $fmuni = $obj->{'FmUni'};
my $def = $obj->{'Def'};
my $rep = $obj->{'Rep'};
+ my $str;
while (length($uni))
{
my $ch = substr($uni,0,1,'');
***************
*** 226,251 ****
sub read
{
! my ($class,$fh,$name) = @_;
! my %self = (Name => $name, Num => 0);
while (<$fh>)
{
my ($key,$val) = /^(\S+)\s+(.*)$/;
$val =~ s/^\{(.*?)\}/$1/g;
$val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
! $self{$key} = $val;
}
! return bless \%self,$class;
}
sub decode
{
! croak("Not implemented yet");
}
sub encode
{
! croak("Not implemented yet");
}
1;
--- 229,473 ----
sub read
{
! my ($obj,$fh,$name) = @_;
! my(%tbl, @seq, $enc, @esc);
while (<$fh>)
{
my ($key,$val) = /^(\S+)\s+(.*)$/;
$val =~ s/^\{(.*?)\}/$1/g;
$val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
! if($enc = Encode->getEncoding($key)){
! $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
! push @seq, $val;
! }else{
! $obj->{$key} = $val;
! }
! if($val =~ /^\e(.*)/){ push(@esc, quotemeta $1) }
}
! $obj->{'Seq'} = \@seq; # escape sequences
! $obj->{'Tbl'} = \%tbl; # encoding tables
! $obj->{'Esc'} = join('|', @esc); # regex of sequences following ESC
! return $obj;
}
sub decode
{
! my ($obj,$str,$chk) = @_;
! my $tbl = $obj->{'Tbl'};
! my $seq = $obj->{'Seq'};
! my $esc = $obj->{'Esc'};
! my $ini = $obj->{'init'};
! my $fin = $obj->{'final'};
! my $std = $seq->[0];
! my $cur = $std;
! my $uni;
! while (length($str)){
! my $uch = substr($str,0,1,'');
! if($uch eq "\e"){
! if($str =~ s/^($esc)//)
! {
! my $esc = "\e$1";
! $cur = $tbl->{$esc} ? $esc :
! ($esc eq $ini || $esc eq $fin) ? $std :
! $cur;
! }
! else
! {
! $str =~ s/^([\x20-\x2F]*[\x30-\x7E])//;
! carp "unknown escape sequence: ESC $1";
! }
! next;
! }
! if($uch eq "\x0e" || $uch eq "\x0f"){
! $cur = $uch and next;
! }
! if(ref($tbl->{$cur}) eq 'Encode::XS'){
! $uni .= $tbl->{$cur}->decode($uch);
! next;
! }
! my $ch = ord($uch);
! my $rep = $tbl->{$cur}->{'Rep'};
! my $touni = $tbl->{$cur}->{'ToUni'};
! my $x;
! if (&$rep($ch) eq 'C')
! {
! $x = $touni->[0][$ch];
! }
! else
! {
! $x = $touni->[$ch][ord(substr($str,0,1,''))];
! }
! unless (defined $x)
! {
! last if $chk;
! # What do we do here ?
! $x = '';
! }
! $uni .= $x;
! }
! $_[1] = $str if $chk;
! return $uni;
}
sub encode
{
! my ($obj,$uni,$chk) = @_;
! my $tbl = $obj->{'Tbl'};
! my $seq = $obj->{'Seq'};
! my $ini = $obj->{'init'};
! my $fin = $obj->{'final'};
! my $std = $seq->[0];
! my $str = $ini;
! my $pre = $std;
! my $cur = $pre;
!
! while (length($uni)){
! my $ch = chr(ord(substr($uni,0,1,'')));
! my $x;
! foreach my $e_seq ($std, $pre, @$seq){
! $x = ref($tbl->{$e_seq}) eq 'Encode::XS'
! ? $tbl->{$e_seq}->encode($ch,1)
! : $tbl->{$e_seq}->{FmUni}->{$ch};
! $cur = $e_seq and last if defined $x;
! }
! if(ref($tbl->{$cur}) ne 'Encode::XS')
! {
! my $def = $tbl->{$cur}->{'Def'};
! my $rep = $tbl->{$cur}->{'Rep'};
! unless (defined $x){
! last if ($chk);
! $x = $def;
! }
! $x = pack(&$rep($x),$x);
! }
! $str .= $cur eq $pre ? $x : ($pre = $cur).$x;
! }
! $str .= $std unless $cur eq $std;
! $str .= $fin;
! $_[1] = $uni if $chk;
! return $str;
! }
!
! package Encode::Tcl::HanZi;
! use base 'Encode::Encoding';
!
! use Carp;
!
! sub read
! {
! my ($obj,$fh,$name) = @_;
! my(%tbl, @seq, $enc);
! while (<$fh>)
! {
! my ($key,$val) = /^(\S+)\s+(.*)$/;
! $val =~ s/^\{(.*?)\}/$1/g;
! $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
! if($enc = Encode->getEncoding($key)){
! $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
! push @seq, $val;
! }else{
! $obj->{$key} = $val;
! }
! }
! $obj->{'Seq'} = \@seq; # escape sequences
! $obj->{'Tbl'} = \%tbl; # encoding tables
! return $obj;
! }
!
! sub decode
! {
! my ($obj,$str,$chk) = @_;
! my $tbl = $obj->{'Tbl'};
! my $seq = $obj->{'Seq'};
! my $std = $seq->[0];
! my $cur = $std;
! my $uni;
! while (length($str)){
! my $uch = substr($str,0,1,'');
! if($uch eq "~"){
! if($str =~ s/^\cJ//)
! {
! next;
! }
! elsif($str =~ s/^\~//)
! {
! 1;
! }
! elsif($str =~ s/^([{}])//)
! {
! $cur = "~$1";
! next;
! }
! else
! {
! $str =~ s/^([^~])//;
! carp "unknown HanZi escape sequence: ~$1";
! next;
! }
! }
! if(ref($tbl->{$cur}) eq 'Encode::XS'){
! $uni .= $tbl->{$cur}->decode($uch);
! next;
! }
! my $ch = ord($uch);
! my $rep = $tbl->{$cur}->{'Rep'};
! my $touni = $tbl->{$cur}->{'ToUni'};
! my $x;
! if (&$rep($ch) eq 'C')
! {
! $x = $touni->[0][$ch];
! }
! else
! {
! $x = $touni->[$ch][ord(substr($str,0,1,''))];
! }
! unless (defined $x)
! {
! last if $chk;
! # What do we do here ?
! $x = '';
! }
! $uni .= $x;
! }
! $_[1] = $str if $chk;
! return $uni;
! }
!
! sub encode
! {
! my ($obj,$uni,$chk) = @_;
! my $tbl = $obj->{'Tbl'};
! my $seq = $obj->{'Seq'};
! my $std = $seq->[0];
! my $str;
! my $pre = $std;
! my $cur = $pre;
!
! while (length($uni)){
! my $ch = chr(ord(substr($uni,0,1,'')));
! my $x;
! foreach my $e_seq (@$seq){
! $x = ref($tbl->{$e_seq}) eq 'Encode::XS'
! ? $tbl->{$e_seq}->encode($ch,1)
! : $tbl->{$e_seq}->{FmUni}->{$ch};
! $cur = $e_seq and last if defined $x;
! }
! if(ref($tbl->{$cur}) ne 'Encode::XS')
! {
! my $def = $tbl->{$cur}->{'Def'};
! my $rep = $tbl->{$cur}->{'Rep'};
! unless (defined $x){
! last if ($chk);
! $x = $def;
! }
! $x = pack(&$rep($x),$x);
! }
! $str .= $cur eq $pre ? $x : ($pre = $cur).$x;
! $str .= '~' if $x eq '~'; # to '~~'
! }
! $str .= $std unless $cur eq $std;
! $_[1] = $uni if $chk;
! return $str;
}
1;
diff -c /dev/null 'perl-5.7.2/ext/Encode/Encode/Tcl.t'
Index: ./ext/Encode/Encode/Tcl.t
*** ./ext/Encode/Encode/Tcl.t Thu Jan 1 02:00:00 1970
--- ./ext/Encode/Encode/Tcl.t Tue Jul 10 05:00:50 2001
***************
*** 0 ****
--- 1,184 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bEncode\b/) {
+ print "1..0 # Skip: Encode was not built\n";
+ exit 0;
+ }
+ }
+ use Test;
+ use Encode qw(encode decode);
+ use Encode::Tcl;
+
+ my @encodings = qw(euc-cn euc-jp euc-kr big5 shiftjis); # CJK
+ my $n = 2;
+
+ my %greek = (
+ 'euc-cn' => [0xA6A1..0xA6B8,0xA6C1..0xA6D8],
+ 'euc-jp' => [0xA6A1..0xA6B8,0xA6C1..0xA6D8],
+ 'euc-kr' => [0xA5C1..0xA5D8,0xA5E1..0xA5F8],
+ 'big5' => [0xA344..0xA35B,0xA35C..0xA373],
+ 'shiftjis' => [0x839F..0x83B6,0x83BF..0x83D6],
+ 'utf8' => [0x0391..0x03A1,0x03A3..0x03A9,0x03B1..0x03C1,0x03C3..0x03C9],
+ );
+ my @greek = qw(
+ ALPHA BETA GAMMA DELTA EPSILON ZETA ETA
+ THETA IOTA KAPPA LAMBDA MU NU XI OMICRON
+ PI RHO SIGMA TAU UPSILON PHI CHI PSI OMEGA
+ alpha beta gamma delta epsilon zeta eta
+ theta iota kappa lambda mu nu xi omicron
+ pi rho sigma tau upsilon phi chi psi omega
+ );
+
+ my %ideodigit = ( # cjk ideograph 'one' to 'ten'
+ 'euc-cn' => [qw(d2bb b6fe c8fd cbc4 cee5 c1f9 c6df b0cb bec5 caae)],
+ 'euc-jp' => [qw(b0ec c6f3 bbb0 bbcd b8de cfbb bcb7 c8ac b6e5 bdbd)],
+ 'euc-kr' => [qw(ece9 eca3 dfb2 decc e7e9 d7bf f6d2 f8a2 cefa e4a8)],
+ 'big5' => [qw(a440 a447 a454 a57c a4ad a4bb a443 a44b a445 a451)],
+ 'shiftjis' => [qw(88ea 93f1 8e4f 8e6c 8cdc 985a 8eb5 94aa 8be3 8f5c)],
+ 'utf8' => [qw(4e00 4e8c 4e09 56db 4e94 516d 4e03 516b 4e5d 5341)],
+ );
+ my @ideodigit = qw(one two three four five six seven eight nine ten);
+
+ my $jis = '7bit-jis';
+ my $kr = 'iso2022-kr';
+ my %esc_str;
+
+ $esc_str{$jis} = {qw(
+ 1b24422422242424262428242a1b2842
+ 3042304430463048304a
+ 1b284931323334355d1b2842
+ ff71ff72ff73ff74ff75ff9d
+ 1b2442467c4b5c1b2842
+ 65e5672c
+ 3132331b244234413b7a1b28425065726c
+ 0031003200336f225b57005000650072006c
+ 546573740a1b24422546253925481b28420a
+ 0054006500730074000a30c630b930c8000a
+ )};
+
+ $esc_str{$kr} = {qw(
+ 1b2429430e2a22213e0f410d0a
+ 304200b10041000d000a
+ 1b2429430e3021332a34593673383639593b673e46405a0f0d0a
+ ac00b098b2e4b77cb9c8bc14c0acc544c790000d000a
+ 1b2429434142430d0a
+ 004100420043000d000a
+ )};
+
+ my $num_esc = $n * keys(%esc_str);
+ foreach (values %esc_str){ $num_esc += $n * keys %$_ }
+
+ my $hz = 'HZ'; # HanZi
+
+ my @hz_txt = (
+ "~~in GB.~{<:Ky2;S{#,NpJ)l6HK!#~}Bye.~~",
+ "~~in GB.~{<:Ky2;S{#,~}~\cJ~{NpJ)l6HK!#~}Bye.~~",
+ "~~in GB.~\cJ~{<:Ky2;S{#,NpJ)l6HK!#~}~\cJBye.~~",
+ );
+
+ my $hz_exp = '007e0069006e002000470042002e5df162404e0d6b32'
+ . 'ff0c52ff65bd65bc4eba3002004200790065002e007e';
+
+ plan test => $n*@encodings + $n*@encodings*@greek
+ + $n*@encodings*@ideodigit + $num_esc + $n + @hz_txt;
+
+ foreach my $enc (@encodings)
+ {
+ my $tab = Encode->getEncoding($enc);
+ ok(1,defined($tab),"Could not load $enc");
+ my $str = join('',map(chr($_),0x20..0x7E));
+ my $uni = $tab->decode($str);
+ my $cpy = $tab->encode($uni);
+ ok($cpy,$str,"$enc mangled translating to Unicode and back");
+ }
+
+ foreach my $enc (@encodings)
+ {
+ my $tab = Encode->getEncoding($enc);
+ foreach my $gk (0..$#greek)
+ {
+ my $uni = unpack 'U', $tab->decode(pack 'n', $greek{$enc}[$gk]);
+ ok($uni,$greek{'utf8'}[$gk],
+ "$enc mangled translating to Unicode GREEK $greek[$gk]");
+ my $cpy = unpack 'n',$tab->encode(pack 'U',$uni);
+ ok($cpy,$greek{$enc}[$gk],
+ "$enc mangled translating from Unicode GREEK $greek[$gk]");
+ }
+ }
+
+ foreach my $enc (@encodings)
+ {
+ my $tab = Encode->getEncoding($enc);
+ foreach my $id (0..$#ideodigit)
+ {
+ my $uni = unpack 'U',$tab->decode(pack 'H*', $ideodigit{$enc}[$id]);
+ ok($uni,hex($ideodigit{'utf8'}[$id]),
+ "$enc mangled translating to Unicode CJK IDEOGRAPH $ideodigit[$id]");
+ my $cpy = lc unpack 'H*', $tab->encode(pack 'U',$uni);
+ ok($cpy,$ideodigit{$enc}[$id],
+ "$enc mangled translating from Unicode CJK IDEOGRAPH $ideodigit[$id]");
+ }
+ }
+
+ {
+ sub to_unicode
+ {
+ my $enc = shift;
+ return unpack('H*', pack 'n*', unpack 'U*',
+ decode $enc, pack 'H*', join '', @_);
+ }
+
+ sub from_unicode
+ {
+ my $enc = shift;
+ return unpack('H*', encode $enc,
+ pack 'U*', unpack 'n*', pack 'H*', join '', @_);
+ }
+
+ foreach my $enc (sort keys %esc_str)
+ {
+ my $tab = Encode->getEncoding($enc);
+ ok(1,defined($tab),"Could not load $enc");
+ my %strings = %{ $esc_str{$enc} };
+ foreach my $estr (sort keys %strings)
+ {
+ my $ustr = to_unicode($enc, $estr);
+ ok($ustr, $strings{$estr},
+ "$enc mangled translating to Unicode");
+ ok(from_unicode($enc, $ustr), $estr,
+ "$enc mangled translating from Unicode");
+ }
+ ok(to_unicode($enc, keys %strings), join('', values %strings),
+ "$enc mangled translating to Unicode");
+ }
+ }
+
+
+ {
+ my $hz_to_unicode = sub
+ {
+ return unpack('H*', pack 'n*', unpack 'U*', decode $hz, shift);
+ };
+
+ my $hz_from_unicode = sub
+ {
+ return encode($hz, pack 'U*', unpack 'n*', pack 'H*', shift);
+ };
+
+ foreach my $enc ($hz)
+ {
+ my $tab = Encode->getEncoding($enc);
+ ok(1,defined($tab),"Could not load $enc");
+
+ ok(&$hz_from_unicode($hz_exp), $hz_txt[0],
+ "$enc mangled translating from Unicode");
+
+ foreach my $str (@hz_txt)
+ {
+ ok(&$hz_to_unicode($str), $hz_exp,
+ "$enc mangled translating to Unicode");
+ }
+ }
+ }
diff -c 'perl-5.7.1/ext/Encode/Encode/iso2022-jp.enc' 'perl-5.7.2/ext/Encode/Encode/iso2022-jp.enc'
Index: ./ext/Encode/Encode/iso2022-jp.enc
*** ./ext/Encode/Encode/iso2022-jp.enc Tue Mar 6 04:04:45 2001
--- ./ext/Encode/Encode/iso2022-jp.enc Tue Jul 10 05:00:50 2001
***************
*** 3,12 ****
name iso2022-jp
init {}
final {}
! iso8859-1 \x1b(B
! jis0201 \x1b(J
! jis0208 \x1b$@
jis0208 \x1b$B
! jis0212 \x1b$(D
! gb2312 \x1b$A
! ksc5601 \x1b$(C
--- 3,9 ----
name iso2022-jp
init {}
final {}
! ascii \x1b(B
! ascii \x1b(J
jis0208 \x1b$B
! jis0208 \x1b$@
diff -c 'perl-5.7.1/ext/Encode/Encode/iso2022-kr.enc' 'perl-5.7.2/ext/Encode/Encode/iso2022-kr.enc'
Index: ./ext/Encode/Encode/iso2022-kr.enc
*** ./ext/Encode/Encode/iso2022-kr.enc Tue Mar 6 04:04:45 2001
--- ./ext/Encode/Encode/iso2022-kr.enc Tue Jul 10 05:00:50 2001
***************
*** 3,7 ****
name iso2022-kr
init \x1b$)C
final {}
! iso8859-1 \x0f
ksc5601 \x0e
--- 3,7 ----
name iso2022-kr
init \x1b$)C
final {}
! ascii \x0f
ksc5601 \x0e
diff -c /dev/null 'perl-5.7.2/ext/Errno/Errno.t'
Index: ./ext/Errno/Errno.t
*** ./ext/Errno/Errno.t Thu Jan 1 02:00:00 1970
--- ./ext/Errno/Errno.t Mon Jul 9 17:10:01 2001
***************
*** 0 ****
--- 1,54 ----
+ #!./perl
+
+ BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ } else {
+ @INC = '../lib';
+ }
+ }
+ }
+
+ use Errno;
+
+ print "1..5\n";
+
+ print "not " unless @Errno::EXPORT_OK;
+ print "ok 1\n";
+ die unless @Errno::EXPORT_OK;
+
+ $err = $Errno::EXPORT_OK[0];
+ $num = &{"Errno::$err"};
+
+ print "not " unless &{"Errno::$err"} == $num;
+ print "ok 2\n";
+
+ $! = $num;
+ print "not " unless $!{$err};
+ print "ok 3\n";
+
+ $! = 0;
+ print "not " if $!{$err};
+ print "ok 4\n";
+
+ $s1 = join(",",sort keys(%!));
+ $s2 = join(",",sort @Errno::EXPORT_OK);
+
+ if($s1 ne $s2) {
+ my @s1 = keys(%!);
+ my @s2 = @Errno::EXPORT_OK;
+ my(%s1,%s2);
+ @s1{@s1} = ();
+ @s2{@s2} = ();
+ delete @s2{@s1};
+ delete @s1{@s2};
+ print "# These are only in \%!\n";
+ print "# ",join(" ",map { "'$_'" } keys %s1),"\n";
+ print "# These are only in \@EXPORT_OK\n";
+ print "# ",join(" ",map { "'$_'" } keys %s2),"\n";
+ print "not ";
+ }
+
+ print "ok 5\n";
diff -c 'perl-5.7.1/ext/Errno/Errno_pm.PL' 'perl-5.7.2/ext/Errno/Errno_pm.PL'
Index: ./ext/Errno/Errno_pm.PL
*** ./ext/Errno/Errno_pm.PL Thu Apr 5 15:58:44 2001
--- ./ext/Errno/Errno_pm.PL Mon Jul 9 17:10:01 2001
***************
*** 2,8 ****
use Config;
use strict;
! our $VERSION = "1.111";
my %err = ();
--- 2,8 ----
use Config;
use strict;
! our $VERSION = "1.09_00";
my %err = ();
***************
*** 27,33 ****
warn "Cannot open '$file'";
return;
}
! } elsif ($Config{gccversion} ne '') {
# With the -dM option, gcc outputs every #define it finds
unless(open(FH,"$Config{cc} -E -dM $Config{cppflags} $file |")) {
warn "Cannot open '$file'";
--- 27,37 ----
warn "Cannot open '$file'";
return;
}
! } elsif ($Config{gccversion} ne ''
! # OpenSTEP has gcc 2.7.2.1 which recognizes but
! # doesn't implement the -dM flag.
! && $^O ne 'openstep' && $^O ne 'next'
! ) {
# With the -dM option, gcc outputs every #define it finds
unless(open(FH,"$Config{cc} -E -dM $Config{cppflags} $file |")) {
warn "Cannot open '$file'";
***************
*** 107,118 ****
open(CPPI,"> errno.c") or
die "Cannot open errno.c";
! print CPPI "#include <errno.h>\n";
close(CPPI);
# invoke CPP and read the output
! if ($^O eq 'MSWin32') {
open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
} else {
--- 111,126 ----
open(CPPI,"> errno.c") or
die "Cannot open errno.c";
! if ($^O eq 'NetWare') {
! print CPPI "#include <nwerrno.h>\n";
! } else {
! print CPPI "#include <errno.h>\n";
! }
close(CPPI);
# invoke CPP and read the output
! if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
} else {
***************
*** 122,128 ****
}
my $pat;
! if ($^O eq 'MSWin32' and $Config{cc} =~ /^bcc/i) {
$pat = '^/\*\s+(.+)\s+\d+\s*:\s+\*/';
}
else {
--- 130,136 ----
}
my $pat;
! if (($^O eq 'MSWin32' || $^O eq 'NetWare') and $Config{cc} =~ /^bcc/i) {
$pat = '^/\*\s+(.+)\s+\d+\s*:\s+\*/';
}
else {
***************
*** 129,135 ****
$pat = '^#\s*(?:line)?\s*\d+\s+"([^"]+)"';
}
while(<CPPO>) {
! if ($^O eq 'os2' or $^O eq 'MSWin32') {
if (/$pat/o) {
my $f = $1;
$f =~ s,\\\\,/,g;
--- 137,143 ----
$pat = '^#\s*(?:line)?\s*\d+\s+"([^"]+)"';
}
while(<CPPO>) {
! if ($^O eq 'os2' or $^O eq 'MSWin32' or $^O eq 'NetWare') {
if (/$pat/o) {
my $f = $1;
$f =~ s,\\\\,/,g;
***************
*** 157,163 ****
open(CPPI,"> errno.c") or
die "Cannot open errno.c";
! print CPPI "#include <errno.h>\n";
foreach $err (keys %err) {
print CPPI '"',$err,'" [[',$err,']]',"\n";
--- 165,175 ----
open(CPPI,"> errno.c") or
die "Cannot open errno.c";
! if ($^O eq 'NetWare') {
! print CPPI "#include <nwerrno.h>\n";
! } else {
! print CPPI "#include <errno.h>\n";
! }
foreach $err (keys %err) {
print CPPI '"',$err,'" [[',$err,']]',"\n";
***************
*** 173,179 ****
$cpp =~ s/sys\$input//i;
open(CPPO,"$cpp errno.c |") or
die "Cannot exec $Config{cppstdin}";
! } elsif ($^O eq 'MSWin32') {
open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
} else {
--- 185,191 ----
$cpp =~ s/sys\$input//i;
open(CPPO,"$cpp errno.c |") or
die "Cannot exec $Config{cppstdin}";
! } elsif ($^O eq 'MSWin32' || $^O eq 'NetWare') {
open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
} else {
diff -c 'perl-5.7.1/ext/Fcntl/Fcntl.pm' 'perl-5.7.2/ext/Fcntl/Fcntl.pm'
Index: ./ext/Fcntl/Fcntl.pm
*** ./ext/Fcntl/Fcntl.pm Tue Mar 6 04:04:50 2001
--- ./ext/Fcntl/Fcntl.pm Mon Jul 9 17:10:01 2001
***************
*** 60,66 ****
require Exporter;
use XSLoader ();
@ISA = qw(Exporter);
! $VERSION = "1.03";
# Items to export into callers namespace by default
# (move infrequently used names to @EXPORT_OK below)
@EXPORT =
--- 60,66 ----
require Exporter;
use XSLoader ();
@ISA = qw(Exporter);
! $VERSION = "1.04";
# Items to export into callers namespace by default
# (move infrequently used names to @EXPORT_OK below)
@EXPORT =
***************
*** 201,217 ****
sub AUTOLOAD {
(my $constname = $AUTOLOAD) =~ s/.*:://;
! my $val = constant($constname);
! if ($! != 0) {
! if ($! =~ /Invalid/ || $!{EINVAL}) {
! $AutoLoader::AUTOLOAD = $AUTOLOAD;
! goto &AutoLoader::AUTOLOAD;
! }
! else {
! my ($pack,$file,$line) = caller;
! die "Your vendor has not defined Fcntl macro $constname, used at $file line $line.
! ";
! }
}
*$AUTOLOAD = sub { $val };
goto &$AUTOLOAD;
--- 201,211 ----
sub AUTOLOAD {
(my $constname = $AUTOLOAD) =~ s/.*:://;
! die "&Fcntl::constant not defined" if $constname eq 'constant';
! my ($error, $val) = constant($constname);
! if ($error) {
! my (undef,$file,$line) = caller;
! die "$error at $file line $line.\n";
}
*$AUTOLOAD = sub { $val };
goto &$AUTOLOAD;
diff -c /dev/null 'perl-5.7.2/ext/Fcntl/Fcntl.t'
Index: ./ext/Fcntl/Fcntl.t
*** ./ext/Fcntl/Fcntl.t Thu Jan 1 02:00:00 1970
--- ./ext/Fcntl/Fcntl.t Mon Jul 9 17:10:01 2001
***************
*** 0 ****
--- 1,46 ----
+ #!./perl
+
+ # A modest test: exercises only O_WRONLY, O_CREAT, and O_RDONLY.
+ # Have to be modest to be portable: could possibly extend testing
+ # also to O_RDWR and O_APPEND, but dunno about the portability of,
+ # say, O_TRUNC and O_EXCL, not to mention O_NONBLOCK.
+
+ use Fcntl;
+
+ print "1..6\n";
+
+ print "ok 1\n";
+
+ if (sysopen(my $wo, "fcntl$$", O_WRONLY|O_CREAT)) {
+ print "ok 2\n";
+ if (syswrite($wo, "foo") == 3) {
+ print "ok 3\n";
+ close($wo);
+ if (sysopen(my $ro, "fcntl$$", O_RDONLY)) {
+ print "ok 4\n";
+ if (sysread($ro, my $read, 3)) {
+ print "ok 5\n";
+ if ($read eq "foo") {
+ print "ok 6\n";
+ } else {
+ print "not ok 6 # content '$read' not ok\n";
+ }
+ } else {
+ print "not ok 5 # sysread failed: $!\n";
+ }
+ } else {
+ print "not ok 4 # sysopen O_RDONLY failed: $!\n";
+ }
+ close($ro);
+ } else {
+ print "not ok 3 # syswrite failed: $!\n";
+ }
+ close($wo);
+ } else {
+ print "not ok 2 # sysopen O_WRONLY failed: $!\n";
+ }
+
+ END {
+ 1 while unlink "fcntl$$";
+ }
+
diff -c 'perl-5.7.1/ext/Fcntl/Fcntl.xs' 'perl-5.7.2/ext/Fcntl/Fcntl.xs'
Index: ./ext/Fcntl/Fcntl.xs
*** ./ext/Fcntl/Fcntl.xs Tue Mar 6 04:04:50 2001
--- ./ext/Fcntl/Fcntl.xs Mon Jul 9 17:10:01 2001
***************
*** 33,782 ****
--AD October 16, 1995
*/
! static IV
! constant(char *name)
! {
! errno = 0;
! switch (*(name++)) {
! case '_':
! if (strEQ(name, "S_IFMT")) /* Yes, on name _S_IFMT return S_IFMT. */
! #ifdef S_IFMT
! return S_IFMT;
! #else
! goto not_there;
! #endif
! break;
! case 'F':
! if (*name == '_') {
! name++;
! if (strEQ(name, "ALLOCSP"))
! #ifdef F_ALLOCSP
! return F_ALLOCSP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ALLOCSP64"))
! #ifdef F_ALLOCSP64
! return F_ALLOCSP64;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "COMPAT"))
! #ifdef F_COMPAT
! return F_COMPAT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "DUP2FD"))
! #ifdef F_DUP2FD
! return F_DUP2FD;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "DUPFD"))
! #ifdef F_DUPFD
! return F_DUPFD;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EXLCK"))
! #ifdef F_EXLCK
! return F_EXLCK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "FREESP"))
! #ifdef F_FREESP
! return F_FREESP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "FREESP64"))
! #ifdef F_FREESP64
! return F_FREESP64;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "FSYNC"))
! #ifdef F_FSYNC
! return F_FSYNC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "FSYNC64"))
! #ifdef F_FSYNC64
! return F_FSYNC64;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GETFD"))
! #ifdef F_GETFD
! return F_GETFD;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GETFL"))
! #ifdef F_GETFL
! return F_GETFL;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GETLK"))
! #ifdef F_GETLK
! return F_GETLK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GETLK64"))
! #ifdef F_GETLK64
! return F_GETLK64;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GETOWN"))
! #ifdef F_GETOWN
! return F_GETOWN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "NODNY"))
! #ifdef F_NODNY
! return F_NODNY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "POSIX"))
! #ifdef F_POSIX
! return F_POSIX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "RDACC"))
! #ifdef F_RDACC
! return F_RDACC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "RDDNY"))
! #ifdef F_RDDNY
! return F_RDDNY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "RDLCK"))
! #ifdef F_RDLCK
! return F_RDLCK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "RWACC"))
! #ifdef F_RWACC
! return F_RWACC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "RWDNY"))
! #ifdef F_RWDNY
! return F_RWDNY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SETFD"))
! #ifdef F_SETFD
! return F_SETFD;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SETFL"))
! #ifdef F_SETFL
! return F_SETFL;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SETLK"))
! #ifdef F_SETLK
! return F_SETLK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SETLK64"))
! #ifdef F_SETLK64
! return F_SETLK64;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SETLKW"))
! #ifdef F_SETLKW
! return F_SETLKW;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SETLKW64"))
! #ifdef F_SETLKW64
! return F_SETLKW64;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SETOWN"))
! #ifdef F_SETOWN
! return F_SETOWN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SHARE"))
! #ifdef F_SHARE
! return F_SHARE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SHLCK"))
! #ifdef F_SHLCK
! return F_SHLCK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "UNLCK"))
! #ifdef F_UNLCK
! return F_UNLCK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "UNSHARE"))
! #ifdef F_UNSHARE
! return F_UNSHARE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "WRACC"))
! #ifdef F_WRACC
! return F_WRACC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "WRDNY"))
! #ifdef F_WRDNY
! return F_WRDNY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "WRLCK"))
! #ifdef F_WRLCK
! return F_WRLCK;
! #else
! goto not_there;
! #endif
! errno = EINVAL;
! return 0;
! }
! if (strEQ(name, "APPEND"))
! #ifdef FAPPEND
! return FAPPEND;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ASYNC"))
! #ifdef FASYNC
! return FASYNC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "CREAT"))
! #ifdef FCREAT
! return FCREAT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "D_CLOEXEC"))
! #ifdef FD_CLOEXEC
! return FD_CLOEXEC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "DEFER"))
! #ifdef FDEFER
! return FDEFER;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "DSYNC"))
! #ifdef FDSYNC
! return FDSYNC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EXCL"))
! #ifdef FEXCL
! return FEXCL;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "LARGEFILE"))
! #ifdef FLARGEFILE
! return FLARGEFILE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "NDELAY"))
! #ifdef FNDELAY
! return FNDELAY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "NONBLOCK"))
! #ifdef FNONBLOCK
! return FNONBLOCK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "RSYNC"))
! #ifdef FRSYNC
! return FRSYNC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SYNC"))
! #ifdef FSYNC
! return FSYNC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TRUNC"))
! #ifdef FTRUNC
! return FTRUNC;
! #else
! goto not_there;
! #endif
! break;
! case 'L':
! if (strnEQ(name, "OCK_", 4)) {
! /* We support flock() on systems which don't have it, so
! always supply the constants. */
! name += 4;
! if (strEQ(name, "SH"))
! #ifdef LOCK_SH
! return LOCK_SH;
! #else
! return 1;
! #endif
! if (strEQ(name, "EX"))
! #ifdef LOCK_EX
! return LOCK_EX;
! #else
! return 2;
! #endif
! if (strEQ(name, "NB"))
! #ifdef LOCK_NB
! return LOCK_NB;
! #else
! return 4;
! #endif
! if (strEQ(name, "UN"))
! #ifdef LOCK_UN
! return LOCK_UN;
! #else
! return 8;
! #endif
! } else
! goto not_there;
! break;
! case 'O':
! if (name[0] == '_') {
! name++;
! if (strEQ(name, "ACCMODE"))
! #ifdef O_ACCMODE
! return O_ACCMODE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "APPEND"))
! #ifdef O_APPEND
! return O_APPEND;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ASYNC"))
! #ifdef O_ASYNC
! return O_ASYNC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "BINARY"))
! #ifdef O_BINARY
! return O_BINARY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "CREAT"))
! #ifdef O_CREAT
! return O_CREAT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "DEFER"))
! #ifdef O_DEFER
! return O_DEFER;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "DIRECT"))
! #ifdef O_DIRECT
! return O_DIRECT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "DIRECTORY"))
! #ifdef O_DIRECTORY
! return O_DIRECTORY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "DSYNC"))
! #ifdef O_DSYNC
! return O_DSYNC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EXCL"))
! #ifdef O_EXCL
! return O_EXCL;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EXLOCK"))
! #ifdef O_EXLOCK
! return O_EXLOCK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "LARGEFILE"))
! #ifdef O_LARGEFILE
! return O_LARGEFILE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "NDELAY"))
! #ifdef O_NDELAY
! return O_NDELAY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "NOCTTY"))
! #ifdef O_NOCTTY
! return O_NOCTTY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "NOFOLLOW"))
! #ifdef O_NOFOLLOW
! return O_NOFOLLOW;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "NOINHERIT"))
! #ifdef O_NOINHERIT
! return O_NOINHERIT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "NONBLOCK"))
! #ifdef O_NONBLOCK
! return O_NONBLOCK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "RANDOM"))
! #ifdef O_RANDOM
! return O_RANDOM;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "RAW"))
! #ifdef O_RAW
! return O_RAW;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "RDONLY"))
! #ifdef O_RDONLY
! return O_RDONLY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "RDWR"))
! #ifdef O_RDWR
! return O_RDWR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "RSYNC"))
! #ifdef O_RSYNC
! return O_RSYNC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SEQUENTIAL"))
! #ifdef O_SEQUENTIAL
! return O_SEQUENTIAL;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SHLOCK"))
! #ifdef O_SHLOCK
! return O_SHLOCK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SYNC"))
! #ifdef O_SYNC
! return O_SYNC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TEMPORARY"))
! #ifdef O_TEMPORARY
! return O_TEMPORARY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TEXT"))
! #ifdef O_TEXT
! return O_TEXT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TRUNC"))
! #ifdef O_TRUNC
! return O_TRUNC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "WRONLY"))
! #ifdef O_WRONLY
! return O_WRONLY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ALIAS"))
! #ifdef O_ALIAS
! return O_ALIAS;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "RSRC"))
! #ifdef O_RSRC
! return O_RSRC;
! #else
! goto not_there;
! #endif
! } else
! goto not_there;
! break;
! case 'S':
! switch (*(name++)) {
! case '_':
! if (strEQ(name, "ISUID"))
! #ifdef S_ISUID
! return S_ISUID;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ISGID"))
! #ifdef S_ISGID
! return S_ISGID;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ISVTX"))
! #ifdef S_ISVTX
! return S_ISVTX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ISTXT"))
! #ifdef S_ISTXT
! return S_ISTXT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IFREG"))
! #ifdef S_IFREG
! return S_IFREG;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IFDIR"))
! #ifdef S_IFDIR
! return S_IFDIR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IFLNK"))
! #ifdef S_IFLNK
! return S_IFLNK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IFSOCK"))
! #ifdef S_IFSOCK
! return S_IFSOCK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IFBLK"))
! #ifdef S_IFBLK
! return S_IFBLK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IFCHR"))
! #ifdef S_IFCHR
! return S_IFCHR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IFIFO"))
! #ifdef S_IFIFO
! return S_IFIFO;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IFWHT"))
! #ifdef S_IFWHT
! return S_IFWHT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENFMT"))
! #ifdef S_ENFMT
! return S_ENFMT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IRUSR"))
! #ifdef S_IRUSR
! return S_IRUSR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IWUSR"))
! #ifdef S_IWUSR
! return S_IWUSR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IXUSR"))
! #ifdef S_IXUSR
! return S_IXUSR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IRWXU"))
! #ifdef S_IRWXU
! return S_IRWXU;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IRGRP"))
! #ifdef S_IRGRP
! return S_IRGRP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IWGRP"))
! #ifdef S_IWGRP
! return S_IWGRP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IXGRP"))
! #ifdef S_IXGRP
! return S_IXGRP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IRWXG"))
! #ifdef S_IRWXG
! return S_IRWXG;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IROTH"))
! #ifdef S_IROTH
! return S_IROTH;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IWOTH"))
! #ifdef S_IWOTH
! return S_IWOTH;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IXOTH"))
! #ifdef S_IXOTH
! return S_IXOTH;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IRWXO"))
! #ifdef S_IRWXO
! return S_IRWXO;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IREAD"))
! #ifdef S_IREAD
! return S_IREAD;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IWRITE"))
! #ifdef S_IWRITE
! return S_IWRITE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IEXEC"))
! #ifdef S_IEXEC
! return S_IEXEC;
! #else
! goto not_there;
! #endif
! break;
! case 'E':
! if (strEQ(name, "EK_CUR"))
! #ifdef SEEK_CUR
! return SEEK_CUR;
! #else
! return 1;
! #endif
! if (strEQ(name, "EK_END"))
! #ifdef SEEK_END
! return SEEK_END;
! #else
! return 2;
! #endif
! if (strEQ(name, "EK_SET"))
! #ifdef SEEK_SET
! return SEEK_SET;
! #else
! return 0;
! #endif
! break;
! }
! }
! errno = EINVAL;
! return 0;
- not_there:
- errno = ENOENT;
- return 0;
- }
-
-
MODULE = Fcntl PACKAGE = Fcntl
! IV
! constant(name)
! char * name
!
--- 33,40 ----
--AD October 16, 1995
*/
! #include "constants.c"
MODULE = Fcntl PACKAGE = Fcntl
! INCLUDE: constants.xs
diff -c 'perl-5.7.1/ext/Fcntl/Makefile.PL' 'perl-5.7.2/ext/Fcntl/Makefile.PL'
Index: ./ext/Fcntl/Makefile.PL
*** ./ext/Fcntl/Makefile.PL Tue Mar 6 04:04:50 2001
--- ./ext/Fcntl/Makefile.PL Mon Jul 9 17:10:01 2001
***************
*** 1,8 ****
--- 1,37 ----
use ExtUtils::MakeMaker;
+ use ExtUtils::Constant 0.07 'WriteConstants';
WriteMakefile(
NAME => 'Fcntl',
MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes', # XXX remove later?
VERSION_FROM => 'Fcntl.pm',
+ realclean => {FILES=> 'constants.c constants.xs'},
);
+ my @names = (qw(FAPPEND FASYNC FCREAT FDEFER FDSYNC FD_CLOEXEC FEXCL FLARGEFILE
+ FNDELAY FNONBLOCK FRSYNC FSYNC FTRUNC F_ALLOCSP F_ALLOCSP64
+ F_COMPAT F_DUP2FD F_DUPFD F_EXLCK F_FREESP F_FREESP64 F_FSYNC
+ F_FSYNC64 F_GETFD F_GETFL F_GETLK F_GETLK64 F_GETOWN F_NODNY
+ F_POSIX F_RDACC F_RDDNY F_RDLCK F_RWACC F_RWDNY F_SETFD F_SETFL
+ F_SETLK F_SETLK64 F_SETLKW F_SETLKW64 F_SETOWN F_SHARE F_SHLCK
+ F_UNLCK F_UNSHARE F_WRACC F_WRDNY F_WRLCK O_ACCMODE O_ALIAS
+ O_APPEND O_ASYNC O_BINARY O_CREAT O_DEFER O_DIRECT O_DIRECTORY
+ O_DSYNC O_EXCL O_EXLOCK O_LARGEFILE O_NDELAY O_NOCTTY O_NOFOLLOW
+ O_NOINHERIT O_NONBLOCK O_RANDOM O_RAW O_RDONLY O_RDWR O_RSRC
+ O_RSYNC O_SEQUENTIAL O_SHLOCK O_SYNC O_TEMPORARY O_TEXT O_TRUNC
+ O_WRONLY S_ENFMT S_IEXEC S_IFBLK S_IFCHR S_IFDIR S_IFIFO S_IFLNK
+ S_IFREG S_IFSOCK S_IFWHT S_IREAD S_IRGRP S_IROTH S_IRUSR S_IRWXG
+ S_IRWXO S_IRWXU S_ISGID S_ISTXT S_ISUID S_ISVTX S_IWGRP S_IWOTH
+ S_IWRITE S_IWUSR S_IXGRP S_IXOTH S_IXUSR),
+ {name=>"LOCK_SH", default=>["IV", "1"]},
+ {name=>"LOCK_EX", default=>["IV", "2"]},
+ {name=>"LOCK_NB", default=>["IV", "4"]},
+ {name=>"LOCK_UN", default=>["IV", "8"]},
+ {name=>"SEEK_SET", default=>["IV", "0"]},
+ {name=>"SEEK_CUR", default=>["IV", "1"]},
+ {name=>"SEEK_END", default=>["IV", "2"]},
+ {name=>"_S_IFMT", macro=>"S_IFMT", value=>"S_IFMT"});
+ WriteConstants(
+ NAME => 'Fcntl',
+ NAMES => \@names,
+ );
diff -c /dev/null 'perl-5.7.2/ext/Fcntl/syslfs.t'
Index: ./ext/Fcntl/syslfs.t
*** ./ext/Fcntl/syslfs.t Thu Jan 1 02:00:00 1970
--- ./ext/Fcntl/syslfs.t Mon Jul 9 17:10:01 2001
***************
*** 0 ****
--- 1,267 ----
+ # NOTE: this file tests how large files (>2GB) work with raw system IO.
+ # stdio: open(), tell(), seek(), print(), read() is tested in t/op/lfs.t.
+ # If you modify/add tests here, remember to update also t/op/lfs.t.
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ # Don't bother if there are no quad offsets.
+ if ($Config{lseeksize} < 8) {
+ print "1..0 # Skip: no 64-bit file offsets\n";
+ exit(0);
+ }
+ require Fcntl; import Fcntl qw(/^O_/ /^SEEK_/);
+ }
+
+ use strict;
+
+ $| = 1;
+
+ our @s;
+ our $fail;
+
+ sub zap {
+ close(BIG);
+ unlink("big");
+ unlink("big1");
+ unlink("big2");
+ }
+
+ sub bye {
+ zap();
+ exit(0);
+ }
+
+ my $explained;
+
+ sub explain {
+ unless ($explained++) {
+ print <<EOM;
+ #
+ # If the lfs (large file support: large meaning larger than two
+ # gigabytes) tests are skipped or fail, it may mean either that your
+ # process (or process group) is not allowed to write large files
+ # (resource limits) or that the file system (the network filesystem?)
+ # you are running the tests on doesn't let your user/group have large
+ # files (quota) or the filesystem simply doesn't support large files.
+ # You may even need to reconfigure your kernel. (This is all very
+ # operating system and site-dependent.)
+ #
+ # Perl may still be able to support large files, once you have
+ # such a process, enough quota, and such a (file) system.
+ # It is just that the test failed now.
+ #
+ EOM
+ }
+ print "1..0 # Skip: @_\n" if @_;
+ }
+
+ print "# checking whether we have sparse files...\n";
+
+ # Known have-nots.
+ if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') {
+ print "1..0 # Skip: no sparse files in $^O\n";
+ bye();
+ }
+
+ # Known haves that have problems running this test
+ # (for example because they do not support sparse files, like UNICOS)
+ if ($^O eq 'unicos') {
+ print "1..0 # Skip: no sparse files in $^0, unable to test large files\n";
+ bye();
+ }
+
+ # Then try heuristically to deduce whether we have sparse files.
+
+ # We'll start off by creating a one megabyte file which has
+ # only three "true" bytes. If we have sparseness, we should
+ # consume less blocks than one megabyte (assuming nobody has
+ # one megabyte blocks...)
+
+ sysopen(BIG, "big1", O_WRONLY|O_CREAT|O_TRUNC) or
+ do { warn "sysopen big1 failed: $!\n"; bye };
+ sysseek(BIG, 1_000_000, SEEK_SET) or
+ do { warn "sysseek big1 failed: $!\n"; bye };
+ syswrite(BIG, "big") or
+ do { warn "syswrite big1 failed; $!\n"; bye };
+ close(BIG) or
+ do { warn "close big1 failed: $!\n"; bye };
+
+ my @s1 = stat("big1");
+
+ print "# s1 = @s1\n";
+
+ sysopen(BIG, "big2", O_WRONLY|O_CREAT|O_TRUNC) or
+ do { warn "sysopen big2 failed: $!\n"; bye };
+ sysseek(BIG, 2_000_000, SEEK_SET) or
+ do { warn "sysseek big2 failed: $!\n"; bye };
+ syswrite(BIG, "big") or
+ do { warn "syswrite big2 failed; $!\n"; bye };
+ close(BIG) or
+ do { warn "close big2 failed: $!\n"; bye };
+
+ my @s2 = stat("big2");
+
+ print "# s2 = @s2\n";
+
+ zap();
+
+ unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 &&
+ $s1[11] == $s2[11] && $s1[12] == $s2[12]) {
+ print "1..0 # Skip: no sparse files?\n";
+ bye;
+ }
+
+ print "# we seem to have sparse files...\n";
+
+ # By now we better be sure that we do have sparse files:
+ # if we are not, the following will hog 5 gigabytes of disk. Ooops.
+ # This may fail by producing some signal; run in a subprocess first for safety
+
+ $ENV{LC_ALL} = "C";
+
+ my $r = system '../perl', '-I../lib', '-e', <<'EOF';
+ use Fcntl qw(/^O_/ /^SEEK_/);
+ sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or die $!;
+ my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET);
+ my $syswrite = syswrite(BIG, "big");
+ exit 0;
+ EOF
+
+ sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or
+ do { warn "sysopen 'big' failed: $!\n"; bye };
+ my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET);
+ unless (! $r && defined $sysseek && $sysseek == 5_000_000_000) {
+ $sysseek = 'undef' unless defined $sysseek;
+ explain("seeking past 2GB failed: ",
+ $r ? 'signal '.($r & 0x7f) : "$! (sysseek returned $sysseek)");
+ bye();
+ }
+
+ # The syswrite will fail if there are are filesize limitations (process or fs).
+ my $syswrite = syswrite(BIG, "big");
+ print "# syswrite failed: $! (syswrite returned ",
+ defined $syswrite ? $syswrite : 'undef', ")\n"
+ unless defined $syswrite && $syswrite == 3;
+ my $close = close BIG;
+ print "# close failed: $!\n" unless $close;
+ unless($syswrite && $close) {
+ if ($! =~/too large/i) {
+ explain("writing past 2GB failed: process limits?");
+ } elsif ($! =~ /quota/i) {
+ explain("filesystem quota limits?");
+ } else {
+ explain("error: $!");
+ }
+ bye();
+ }
+
+ @s = stat("big");
+
+ print "# @s\n";
+
+ unless ($s[7] == 5_000_000_003) {
+ explain("kernel/fs not configured to use large files?");
+ bye();
+ }
+
+ sub fail () {
+ print "not ";
+ $fail++;
+ }
+
+ sub offset ($$) {
+ my ($offset_will_be, $offset_want) = @_;
+ my $offset_is = eval $offset_will_be;
+ unless ($offset_is == $offset_want) {
+ print "# bad offset $offset_is, want $offset_want\n";
+ my ($offset_func) = ($offset_will_be =~ /^(\w+)/);
+ if (unpack("L", pack("L", $offset_want)) == $offset_is) {
+ print "# 32-bit wraparound suspected in $offset_func() since\n";
+ print "# $offset_want cast into 32 bits equals $offset_is.\n";
+ } elsif ($offset_want - unpack("L", pack("L", $offset_want)) - 1
+ == $offset_is) {
+ print "# 32-bit wraparound suspected in $offset_func() since\n";
+ printf "# %s - unpack('L', pack('L', %s)) - 1 equals %s.\n",
+ $offset_want,
+ $offset_want,
+ $offset_is;
+ }
+ fail;
+ }
+ }
+
+ print "1..17\n";
+
+ $fail = 0;
+
+ fail unless $s[7] == 5_000_000_003; # exercizes pp_stat
+ print "ok 1\n";
+
+ fail unless -s "big" == 5_000_000_003; # exercizes pp_ftsize
+ print "ok 2\n";
+
+ fail unless -e "big";
+ print "ok 3\n";
+
+ fail unless -f "big";
+ print "ok 4\n";
+
+ sysopen(BIG, "big", O_RDONLY) or do { warn "sysopen failed: $!\n"; bye };
+
+ offset('sysseek(BIG, 4_500_000_000, SEEK_SET)', 4_500_000_000);
+ print "ok 5\n";
+
+ offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000);
+ print "ok 6\n";
+
+ offset('sysseek(BIG, 1, SEEK_CUR)', 4_500_000_001);
+ print "ok 7\n";
+
+ offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_001);
+ print "ok 8\n";
+
+ offset('sysseek(BIG, -1, SEEK_CUR)', 4_500_000_000);
+ print "ok 9\n";
+
+ offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000);
+ print "ok 10\n";
+
+ offset('sysseek(BIG, -3, SEEK_END)', 5_000_000_000);
+ print "ok 11\n";
+
+ offset('sysseek(BIG, 0, SEEK_CUR)', 5_000_000_000);
+ print "ok 12\n";
+
+ my $big;
+
+ fail unless sysread(BIG, $big, 3) == 3;
+ print "ok 13\n";
+
+ fail unless $big eq "big";
+ print "ok 14\n";
+
+ # 705_032_704 = (I32)5_000_000_000
+ # See that we don't have "big" in the 705_... spot:
+ # that would mean that we have a wraparound.
+ fail unless sysseek(BIG, 705_032_704, SEEK_SET);
+ print "ok 15\n";
+
+ my $zero;
+
+ fail unless read(BIG, $zero, 3) == 3;
+ print "ok 16\n";
+
+ fail unless $zero eq "\0\0\0";
+ print "ok 17\n";
+
+ explain() if $fail;
+
+ bye(); # does the necessary cleanup
+
+ END {
+ unlink "big"; # be paranoid about leaving 5 gig files lying around
+ }
+
+ # eof
diff -c 'perl-5.7.1/ext/File/Glob/Glob.pm' 'perl-5.7.2/ext/File/Glob/Glob.pm'
Index: ./ext/File/Glob/Glob.pm
*** ./ext/File/Glob/Glob.pm Wed Apr 4 17:12:24 2001
--- ./ext/File/Glob/Glob.pm Mon Jul 9 17:10:02 2001
***************
*** 6,12 ****
use XSLoader ();
! @ISA = qw(Exporter AutoLoader);
# NOTE: The glob() export is only here for compatibility with 5.6.0.
# csh_glob() should not be used directly, unless you know what you're doing.
--- 6,12 ----
use XSLoader ();
! @ISA = qw(Exporter);
# NOTE: The glob() export is only here for compatibility with 5.6.0.
# csh_glob() should not be used directly, unless you know what you're doing.
***************
*** 22,27 ****
--- 22,28 ----
GLOB_CSH
GLOB_ERR
GLOB_ERROR
+ GLOB_LIMIT
GLOB_MARK
GLOB_NOCASE
GLOB_NOCHECK
***************
*** 41,46 ****
--- 42,48 ----
GLOB_CSH
GLOB_ERR
GLOB_ERROR
+ GLOB_LIMIT
GLOB_MARK
GLOB_NOCASE
GLOB_NOCHECK
***************
*** 54,60 ****
) ],
);
! $VERSION = '0.991';
sub import {
require Exporter;
--- 56,62 ----
) ],
);
! $VERSION = '1.01';
sub import {
require Exporter;
***************
*** 82,98 ****
my $constname;
($constname = $AUTOLOAD) =~ s/.*:://;
! my $val = constant($constname, @_ ? $_[0] : 0);
! if ($! != 0) {
! if ($! =~ /Invalid/ || $!{EINVAL}) {
! require AutoLoader;
! $AutoLoader::AUTOLOAD = $AUTOLOAD;
! goto &AutoLoader::AUTOLOAD;
! }
! else {
! require Carp;
! Carp::croak("Your vendor has not defined File::Glob macro $constname");
! }
}
eval "sub $AUTOLOAD { $val }";
goto &$AUTOLOAD;
--- 84,93 ----
my $constname;
($constname = $AUTOLOAD) =~ s/.*:://;
! my ($error, $val) = constant($constname);
! if ($error) {
! require Carp;
! Carp::croak($error);
}
eval "sub $AUTOLOAD { $val }";
goto &$AUTOLOAD;
***************
*** 103,109 ****
# Preloaded methods go here.
sub GLOB_ERROR {
! return constant('GLOB_ERROR', 0);
}
sub GLOB_CSH () {
--- 98,104 ----
# Preloaded methods go here.
sub GLOB_ERROR {
! return (constant('GLOB_ERROR'))[1];
}
sub GLOB_CSH () {
***************
*** 241,246 ****
--- 236,250 ----
Force bsd_glob() to return an error when it encounters a directory it
cannot open or read. Ordinarily bsd_glob() continues to find matches.
+
+ =item C<GLOB_LIMIT>
+
+ Make bsd_glob() return an error (GLOB_NOSPACE) when the pattern expands
+ to a size bigger than the system constant C<ARG_MAX> (usually found in
+ limits.h). If your system does not define this constant, bsd_glob() uses
+ C<sysconf(_SC_ARG_MAX)> or C<_POSIX_ARG_MAX> where available (in that
+ order). You can inspect these values using the standard C<POSIX>
+ extension.
=item C<GLOB_MARK>
diff -c 'perl-5.7.1/ext/File/Glob/Glob.xs' 'perl-5.7.2/ext/File/Glob/Glob.xs'
Index: ./ext/File/Glob/Glob.xs
*** ./ext/File/Glob/Glob.xs Wed Mar 21 02:43:04 2001
--- ./ext/File/Glob/Glob.xs Mon Jul 9 17:10:02 2001
***************
*** 7,160 ****
/* XXX: need some thread awareness */
static int GLOB_ERROR = 0;
! static double
! constant(char *name, int arg)
! {
! errno = 0;
! if (strlen(name) <= 5)
! goto not_there;
! switch (*(name+5)) {
! case 'A':
! if (strEQ(name, "GLOB_ABEND"))
! #ifdef GLOB_ABEND
! return GLOB_ABEND;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GLOB_ALPHASORT"))
! #ifdef GLOB_ALPHASORT
! return GLOB_ALPHASORT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GLOB_ALTDIRFUNC"))
! #ifdef GLOB_ALTDIRFUNC
! return GLOB_ALTDIRFUNC;
! #else
! goto not_there;
! #endif
! break;
! case 'B':
! if (strEQ(name, "GLOB_BRACE"))
! #ifdef GLOB_BRACE
! return GLOB_BRACE;
! #else
! goto not_there;
! #endif
! break;
! case 'C':
! break;
! case 'D':
! break;
! case 'E':
! if (strEQ(name, "GLOB_ERR"))
! #ifdef GLOB_ERR
! return GLOB_ERR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GLOB_ERROR"))
! return GLOB_ERROR;
! break;
! case 'F':
! break;
! case 'G':
! break;
! case 'H':
! break;
! case 'I':
! break;
! case 'J':
! break;
! case 'K':
! break;
! case 'L':
! break;
! case 'M':
! if (strEQ(name, "GLOB_MARK"))
! #ifdef GLOB_MARK
! return GLOB_MARK;
! #else
! goto not_there;
! #endif
! break;
! case 'N':
! if (strEQ(name, "GLOB_NOCASE"))
! #ifdef GLOB_NOCASE
! return GLOB_NOCASE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GLOB_NOCHECK"))
! #ifdef GLOB_NOCHECK
! return GLOB_NOCHECK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GLOB_NOMAGIC"))
! #ifdef GLOB_NOMAGIC
! return GLOB_NOMAGIC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GLOB_NOSORT"))
! #ifdef GLOB_NOSORT
! return GLOB_NOSORT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GLOB_NOSPACE"))
! #ifdef GLOB_NOSPACE
! return GLOB_NOSPACE;
! #else
! goto not_there;
! #endif
! break;
! case 'O':
! break;
! case 'P':
! break;
! case 'Q':
! if (strEQ(name, "GLOB_QUOTE"))
! #ifdef GLOB_QUOTE
! return GLOB_QUOTE;
! #else
! goto not_there;
! #endif
! break;
! case 'R':
! break;
! case 'S':
! break;
! case 'T':
! if (strEQ(name, "GLOB_TILDE"))
! #ifdef GLOB_TILDE
! return GLOB_TILDE;
! #else
! goto not_there;
! #endif
! break;
! case 'U':
! break;
! case 'V':
! break;
! case 'W':
! break;
! case 'X':
! break;
! case 'Y':
! break;
! case 'Z':
! break;
! }
! errno = EINVAL;
! return 0;
- not_there:
- errno = ENOENT;
- return 0;
- }
-
#ifdef WIN32
#define errfunc NULL
#else
--- 7,14 ----
/* XXX: need some thread awareness */
static int GLOB_ERROR = 0;
! #include "constants.c"
#ifdef WIN32
#define errfunc NULL
#else
***************
*** 201,208 ****
bsd_globfree(&pglob);
}
! double
! constant(name,arg)
! char *name
! int arg
! PROTOTYPE: $$
--- 55,58 ----
bsd_globfree(&pglob);
}
! INCLUDE: constants.xs
diff -c 'perl-5.7.1/ext/File/Glob/Makefile.PL' 'perl-5.7.2/ext/File/Glob/Makefile.PL'
Index: ./ext/File/Glob/Makefile.PL
*** ./ext/File/Glob/Makefile.PL Tue Mar 6 04:04:50 2001
--- ./ext/File/Glob/Makefile.PL Mon Jul 9 17:10:02 2001
***************
*** 1,9 ****
--- 1,11 ----
use ExtUtils::MakeMaker;
+ use ExtUtils::Constant 0.08 'WriteConstants';
WriteMakefile(
NAME => 'File::Glob',
VERSION_FROM => 'Glob.pm',
MAN3PODS => {}, # Pods will be built by installman.
OBJECT => 'bsd_glob$(OBJ_EXT) Glob$(OBJ_EXT)',
+ realclean => {FILES=> 'constants.c constants.xs'},
## uncomment for glob debugging (will cause make test to fail)
# DEFINE => '-DGLOB_DEBUG',
***************
*** 19,21 ****
--- 21,32 ----
}
$inherited;
}
+
+ WriteConstants(
+ NAME => 'File::Glob',
+ NAMES => [qw(GLOB_ABEND GLOB_ALPHASORT GLOB_ALTDIRFUNC GLOB_BRACE GLOB_ERR
+ GLOB_LIMIT GLOB_MARK GLOB_NOCASE GLOB_NOCHECK GLOB_NOMAGIC
+ GLOB_NOSORT GLOB_NOSPACE GLOB_QUOTE GLOB_TILDE),
+ {name=>"GLOB_ERROR", macro=>1}],
+ BREAKOUT_AT => 8,
+ );
diff -c 'perl-5.7.1/ext/File/Glob/bsd_glob.c' 'perl-5.7.2/ext/File/Glob/bsd_glob.c'
Index: ./ext/File/Glob/bsd_glob.c
Prereq: 8.3
*** ./ext/File/Glob/bsd_glob.c Sun Apr 1 22:53:11 2001
--- ./ext/File/Glob/bsd_glob.c Mon Jul 9 17:10:02 2001
***************
*** 32,37 ****
--- 32,40 ----
#if defined(LIBC_SCCS) && !defined(lint)
static char sccsid[] = "@(#)glob.c 8.3 (Berkeley) 10/13/93";
+ /* most changes between the version above and the one below have been ported:
+ static char sscsid[]= "$OpenBSD: glob.c,v 1.8.10.1 2001/04/10 jason Exp $";
+ */
#endif /* LIBC_SCCS and not lint */
/*
***************
*** 70,76 ****
#ifdef I_PWD
# include <pwd.h>
#else
! #ifdef HAS_PASSWD
struct passwd *getpwnam(char *);
struct passwd *getpwuid(Uid_t);
#endif
--- 73,79 ----
#ifdef I_PWD
# include <pwd.h>
#else
! #if defined(HAS_PASSWD) && !defined(VMS)
struct passwd *getpwnam(char *);
struct passwd *getpwuid(Uid_t);
#endif
***************
*** 87,92 ****
--- 90,119 ----
# endif
#endif
+ #ifdef I_LIMITS
+ #include <limits.h>
+ #endif
+
+ #ifndef ARG_MAX
+ # ifdef MACOS_TRADITIONAL
+ # define ARG_MAX 65536 /* Mac OS is actually unlimited */
+ # else
+ # ifdef _SC_ARG_MAX
+ # define ARG_MAX (sysconf(_SC_ARG_MAX))
+ # else
+ # ifdef _POSIX_ARG_MAX
+ # define ARG_MAX _POSIX_ARG_MAX
+ # else
+ # ifdef WIN32
+ # define ARG_MAX 14500 /* from VC's limits.h */
+ # else
+ # define ARG_MAX 4096 /* from POSIX, be conservative */
+ # endif
+ # endif
+ # endif
+ # endif
+ #endif
+
#define BG_DOLLAR '$'
#define BG_DOT '.'
#define BG_EOS '\0'
***************
*** 146,165 ****
static int compare(const void *, const void *);
static int ci_compare(const void *, const void *);
! static void g_Ctoc(const Char *, char *);
static int g_lstat(Char *, Stat_t *, glob_t *);
static DIR *g_opendir(Char *, glob_t *);
static Char *g_strchr(Char *, int);
- #ifdef notdef
- static Char *g_strcat(Char *, const Char *);
- #endif
static int g_stat(Char *, Stat_t *, glob_t *);
static int glob0(const Char *, glob_t *);
! static int glob1(Char *, glob_t *);
! static int glob2(Char *, Char *, Char *, glob_t *);
! static int glob3(Char *, Char *, Char *, Char *, glob_t *);
! static int globextend(const Char *, glob_t *);
! static const Char * globtilde(const Char *, Char *, glob_t *);
static int globexp1(const Char *, glob_t *);
static int globexp2(const Char *, const Char *, glob_t *, int *);
static int match(Char *, Char *, Char *, int);
--- 173,192 ----
static int compare(const void *, const void *);
static int ci_compare(const void *, const void *);
! static int g_Ctoc(const Char *, char *, STRLEN);
static int g_lstat(Char *, Stat_t *, glob_t *);
static DIR *g_opendir(Char *, glob_t *);
static Char *g_strchr(Char *, int);
static int g_stat(Char *, Stat_t *, glob_t *);
static int glob0(const Char *, glob_t *);
! static int glob1(Char *, Char *, glob_t *, size_t *);
! static int glob2(Char *, Char *, Char *, Char *, Char *, Char *,
! glob_t *, size_t *);
! static int glob3(Char *, Char *, Char *, Char *, Char *, Char *,
! Char *, Char *, glob_t *, size_t *);
! static int globextend(const Char *, glob_t *, size_t *);
! static const Char *
! globtilde(const Char *, Char *, size_t, glob_t *);
static int globexp1(const Char *, glob_t *);
static int globexp2(const Char *, const Char *, glob_t *, int *);
static int match(Char *, Char *, Char *, int);
***************
*** 185,191 ****
{
const U8 *patnext;
int c;
! Char *bufnext, *bufend, patbuf[MAXPATHLEN+1];
patnext = (U8 *) pattern;
if (!(flags & GLOB_APPEND)) {
--- 212,218 ----
{
const U8 *patnext;
int c;
! Char *bufnext, *bufend, patbuf[MAXPATHLEN];
patnext = (U8 *) pattern;
if (!(flags & GLOB_APPEND)) {
***************
*** 199,205 ****
pglob->gl_matchc = 0;
bufnext = patbuf;
! bufend = bufnext + MAXPATHLEN;
#ifdef DOSISH
/* Nasty hack to treat patterns like "C:*" correctly. In this
* case, the * should match any file in the current directory
--- 226,232 ----
pglob->gl_matchc = 0;
bufnext = patbuf;
! bufend = bufnext + MAXPATHLEN - 1;
#ifdef DOSISH
/* Nasty hack to treat patterns like "C:*" correctly. In this
* case, the * should match any file in the current directory
***************
*** 207,213 ****
* colon specially, so it looks for files beginning "C:" in
* the current directory. To fix this, change the pattern to
* add an explicit "./" at the start (just after the drive
! * letter and colon - ie change to "C:./*").
*/
if (isalpha(pattern[0]) && pattern[1] == ':' &&
pattern[2] != BG_SEP && pattern[2] != BG_SEP2 &&
--- 234,240 ----
* colon specially, so it looks for files beginning "C:" in
* the current directory. To fix this, change the pattern to
* add an explicit "./" at the start (just after the drive
! * letter and colon - ie change to "C:./").
*/
if (isalpha(pattern[0]) && pattern[1] == ':' &&
pattern[2] != BG_SEP && pattern[2] != BG_SEP2 &&
***************
*** 239,251 ****
--patnext;
}
*bufnext++ = c | M_PROTECT;
! }
! else
*bufnext++ = c;
! }
! else
! while (bufnext < bufend && (c = *patnext++) != BG_EOS)
! *bufnext++ = c;
*bufnext = BG_EOS;
if (flags & GLOB_BRACE)
--- 266,276 ----
--patnext;
}
*bufnext++ = c | M_PROTECT;
! } else
*bufnext++ = c;
! } else
! while (bufnext < bufend && (c = *patnext++) != BG_EOS)
! *bufnext++ = c;
*bufnext = BG_EOS;
if (flags & GLOB_BRACE)
***************
*** 259,265 ****
* invoke the standard globbing routine to glob the rest of the magic
* characters
*/
! static int globexp1(const Char *pattern, glob_t *pglob)
{
const Char* ptr = pattern;
int rv;
--- 284,291 ----
* invoke the standard globbing routine to glob the rest of the magic
* characters
*/
! static int
! globexp1(const Char *pattern, glob_t *pglob)
{
const Char* ptr = pattern;
int rv;
***************
*** 281,297 ****
* If it succeeds then it invokes globexp1 with the new pattern.
* If it fails then it tries to glob the rest of the pattern and returns.
*/
! static int globexp2(const Char *ptr, const Char *pattern,
! glob_t *pglob, int *rv)
{
int i;
Char *lm, *ls;
const Char *pe, *pm, *pl;
! Char patbuf[MAXPATHLEN + 1];
/* copy part up to the brace */
for (lm = patbuf, pm = pattern; pm != ptr; *lm++ = *pm++)
! continue;
ls = lm;
/* Find the balanced brace */
--- 307,325 ----
* If it succeeds then it invokes globexp1 with the new pattern.
* If it fails then it tries to glob the rest of the pattern and returns.
*/
! static int
! globexp2(const Char *ptr, const Char *pattern,
! glob_t *pglob, int *rv)
{
int i;
Char *lm, *ls;
const Char *pe, *pm, *pl;
! Char patbuf[MAXPATHLEN];
/* copy part up to the brace */
for (lm = patbuf, pm = pattern; pm != ptr; *lm++ = *pm++)
! ;
! *lm = BG_EOS;
ls = lm;
/* Find the balanced brace */
***************
*** 299,305 ****
if (*pe == BG_LBRACKET) {
/* Ignore everything between [] */
for (pm = pe++; *pe != BG_RBRACKET && *pe != BG_EOS; pe++)
! continue;
if (*pe == BG_EOS) {
/*
* We could not find a matching BG_RBRACKET.
--- 327,333 ----
if (*pe == BG_LBRACKET) {
/* Ignore everything between [] */
for (pm = pe++; *pe != BG_RBRACKET && *pe != BG_EOS; pe++)
! ;
if (*pe == BG_EOS) {
/*
* We could not find a matching BG_RBRACKET.
***************
*** 307,314 ****
*/
pe = pm;
}
! }
! else if (*pe == BG_LBRACE)
i++;
else if (*pe == BG_RBRACE) {
if (i == 0)
--- 335,341 ----
*/
pe = pm;
}
! } else if (*pe == BG_LBRACE)
i++;
else if (*pe == BG_RBRACE) {
if (i == 0)
***************
*** 322,333 ****
return 0;
}
! for (i = 0, pl = pm = ptr; pm <= pe; pm++)
switch (*pm) {
case BG_LBRACKET:
/* Ignore everything between [] */
for (pl = pm++; *pm != BG_RBRACKET && *pm != BG_EOS; pm++)
! continue;
if (*pm == BG_EOS) {
/*
* We could not find a matching BG_RBRACKET.
--- 349,360 ----
return 0;
}
! for (i = 0, pl = pm = ptr; pm <= pe; pm++) {
switch (*pm) {
case BG_LBRACKET:
/* Ignore everything between [] */
for (pl = pm++; *pm != BG_RBRACKET && *pm != BG_EOS; pm++)
! ;
if (*pm == BG_EOS) {
/*
* We could not find a matching BG_RBRACKET.
***************
*** 343,350 ****
case BG_RBRACE:
if (i) {
! i--;
! break;
}
/* FALLTHROUGH */
case BG_COMMA:
--- 370,377 ----
case BG_RBRACE:
if (i) {
! i--;
! break;
}
/* FALLTHROUGH */
case BG_COMMA:
***************
*** 353,365 ****
else {
/* Append the current string */
for (lm = ls; (pl < pm); *lm++ = *pl++)
! continue;
/*
* Append the rest of the pattern after the
* closing brace
*/
! for (pl = pe + 1; (*lm++ = *pl++) != BG_EOS;)
! continue;
/* Expand the current pattern */
#ifdef GLOB_DEBUG
--- 380,393 ----
else {
/* Append the current string */
for (lm = ls; (pl < pm); *lm++ = *pl++)
! ;
!
/*
* Append the rest of the pattern after the
* closing brace
*/
! for (pl = pe + 1; (*lm++ = *pl++) != BG_EOS; )
! ;
/* Expand the current pattern */
#ifdef GLOB_DEBUG
***************
*** 375,380 ****
--- 403,409 ----
default:
break;
}
+ }
*rv = 0;
return 0;
}
***************
*** 385,407 ****
* expand tilde from the passwd file.
*/
static const Char *
! globtilde(const Char *pattern, Char *patbuf, glob_t *pglob)
{
struct passwd *pwd;
char *h;
const Char *p;
! Char *b;
if (*pattern != BG_TILDE || !(pglob->gl_flags & GLOB_TILDE))
return pattern;
/* Copy up to the end of the string or / */
! for (p = pattern + 1, h = (char *) patbuf; *p && *p != BG_SLASH;
! *h++ = *p++)
! continue;
*h = BG_EOS;
if (((char *) patbuf)[0] == BG_EOS) {
/*
* handle a plain ~ or ~/ by expanding $HOME
--- 414,442 ----
* expand tilde from the passwd file.
*/
static const Char *
! globtilde(const Char *pattern, Char *patbuf, size_t patbuf_len, glob_t *pglob)
{
struct passwd *pwd;
char *h;
const Char *p;
! Char *b, *eb;
if (*pattern != BG_TILDE || !(pglob->gl_flags & GLOB_TILDE))
return pattern;
/* Copy up to the end of the string or / */
! eb = &patbuf[patbuf_len - 1];
! for (p = pattern + 1, h = (char *) patbuf;
! h < (char*)eb && *p && *p != BG_SLASH; *h++ = *p++)
! ;
*h = BG_EOS;
+ #if 0
+ if (h == (char *)eb)
+ return what;
+ #endif
+
if (((char *) patbuf)[0] == BG_EOS) {
/*
* handle a plain ~ or ~/ by expanding $HOME
***************
*** 417,424 ****
return pattern;
#endif
}
! }
! else {
/*
* Expand a ~user
*/
--- 452,458 ----
return pattern;
#endif
}
! } else {
/*
* Expand a ~user
*/
***************
*** 433,444 ****
}
/* Copy the home directory */
! for (b = patbuf; *h; *b++ = *h++)
! continue;
/* Append the rest of the pattern */
! while ((*b++ = *p++) != BG_EOS)
! continue;
return patbuf;
}
--- 467,479 ----
}
/* Copy the home directory */
! for (b = patbuf; b < eb && *h; *b++ = *h++)
! ;
/* Append the rest of the pattern */
! while (b < eb && (*b++ = *p++) != BG_EOS)
! ;
! *b = BG_EOS;
return patbuf;
}
***************
*** 456,470 ****
{
const Char *qpat, *qpatnext;
int c, err, oldflags, oldpathc;
! Char *bufnext, patbuf[MAXPATHLEN+1];
#ifdef MACOS_TRADITIONAL
if ( (*pattern == BG_TILDE) && (pglob->gl_flags & GLOB_TILDE) ) {
! return(globextend(pattern, pglob));
}
#endif
! qpat = globtilde(pattern, patbuf, pglob);
qpatnext = qpat;
oldflags = pglob->gl_flags;
oldpathc = pglob->gl_pathc;
--- 491,506 ----
{
const Char *qpat, *qpatnext;
int c, err, oldflags, oldpathc;
! Char *bufnext, patbuf[MAXPATHLEN];
! size_t limit = 0;
#ifdef MACOS_TRADITIONAL
if ( (*pattern == BG_TILDE) && (pglob->gl_flags & GLOB_TILDE) ) {
! return(globextend(pattern, pglob, &limit));
}
#endif
! qpat = globtilde(pattern, patbuf, MAXPATHLEN, pglob);
qpatnext = qpat;
oldflags = pglob->gl_flags;
oldpathc = pglob->gl_pathc;
***************
*** 510,516 ****
* to avoid exponential behavior
*/
if (bufnext == patbuf || bufnext[-1] != M_ALL)
! *bufnext++ = M_ALL;
break;
default:
*bufnext++ = CHAR(c);
--- 546,552 ----
* to avoid exponential behavior
*/
if (bufnext == patbuf || bufnext[-1] != M_ALL)
! *bufnext++ = M_ALL;
break;
default:
*bufnext++ = CHAR(c);
***************
*** 522,528 ****
qprintf("glob0:", patbuf);
#endif /* GLOB_DEBUG */
! if ((err = glob1(patbuf, pglob)) != 0) {
pglob->gl_flags = oldflags;
return(err);
}
--- 558,564 ----
qprintf("glob0:", patbuf);
#endif /* GLOB_DEBUG */
! if ((err = glob1(patbuf, patbuf+MAXPATHLEN-1, pglob, &limit)) != 0) {
pglob->gl_flags = oldflags;
return(err);
}
***************
*** 542,548 ****
printf("calling globextend from glob0\n");
#endif /* GLOB_DEBUG */
pglob->gl_flags = oldflags;
! return(globextend(qpat, pglob));
}
else if (!(pglob->gl_flags & GLOB_NOSORT))
qsort(pglob->gl_pathv + pglob->gl_offs + oldpathc,
--- 578,584 ----
printf("calling globextend from glob0\n");
#endif /* GLOB_DEBUG */
pglob->gl_flags = oldflags;
! return(globextend(qpat, pglob, &limit));
}
else if (!(pglob->gl_flags & GLOB_NOSORT))
qsort(pglob->gl_pathv + pglob->gl_offs + oldpathc,
***************
*** 556,574 ****
static int
ci_compare(const void *p, const void *q)
{
! const char *pp = *(const char **)p;
! const char *qq = *(const char **)q;
! int ci;
! while (*pp && *qq) {
! if (tolower(*pp) != tolower(*qq))
! break;
! ++pp;
! ++qq;
! }
! ci = tolower(*pp) - tolower(*qq);
! if (ci == 0)
! return compare(p, q);
! return ci;
}
static int
--- 592,610 ----
static int
ci_compare(const void *p, const void *q)
{
! const char *pp = *(const char **)p;
! const char *qq = *(const char **)q;
! int ci;
! while (*pp && *qq) {
! if (toLOWER(*pp) != toLOWER(*qq))
! break;
! ++pp;
! ++qq;
! }
! ci = toLOWER(*pp) - toLOWER(*qq);
! if (ci == 0)
! return compare(p, q);
! return ci;
}
static int
***************
*** 578,591 ****
}
static int
! glob1(Char *pattern, glob_t *pglob)
{
! Char pathbuf[MAXPATHLEN+1];
/* A null pathname is invalid -- POSIX 1003.1 sect. 2.4. */
if (*pattern == BG_EOS)
return(0);
! return(glob2(pathbuf, pathbuf, pattern, pglob));
}
/*
--- 614,629 ----
}
static int
! glob1(Char *pattern, Char *pattern_last, glob_t *pglob, size_t *limitp)
{
! Char pathbuf[MAXPATHLEN];
/* A null pathname is invalid -- POSIX 1003.1 sect. 2.4. */
if (*pattern == BG_EOS)
return(0);
! return(glob2(pathbuf, pathbuf+MAXPATHLEN-1,
! pathbuf, pathbuf+MAXPATHLEN-1,
! pattern, pattern_last, pglob, limitp));
}
/*
***************
*** 594,600 ****
* meta characters.
*/
static int
! glob2(Char *pathbuf, Char *pathend, Char *pattern, glob_t *pglob)
{
Stat_t sb;
Char *p, *q;
--- 632,639 ----
* meta characters.
*/
static int
! glob2(Char *pathbuf, Char *pathbuf_last, Char *pathend, Char *pathend_last,
! Char *pattern, Char *pattern_last, glob_t *pglob, size_t *limitp)
{
Stat_t sb;
Char *p, *q;
***************
*** 607,613 ****
for (anymeta = 0;;) {
if (*pattern == BG_EOS) { /* End of pattern? */
*pathend = BG_EOS;
-
if (g_lstat(pathbuf, &sb, pglob))
return(0);
--- 646,651 ----
***************
*** 616,625 ****
#ifdef DOSISH
&& pathend[-1] != BG_SEP2
#endif
! ) && (S_ISDIR(sb.st_mode)
! || (S_ISLNK(sb.st_mode) &&
(g_stat(pathbuf, &sb, pglob) == 0) &&
S_ISDIR(sb.st_mode)))) {
*pathend++ = BG_SEP;
*pathend = BG_EOS;
}
--- 654,665 ----
#ifdef DOSISH
&& pathend[-1] != BG_SEP2
#endif
! ) && (S_ISDIR(sb.st_mode) ||
! (S_ISLNK(sb.st_mode) &&
(g_stat(pathbuf, &sb, pglob) == 0) &&
S_ISDIR(sb.st_mode)))) {
+ if (pathend+1 > pathend_last)
+ return (1);
*pathend++ = BG_SEP;
*pathend = BG_EOS;
}
***************
*** 627,633 ****
#ifdef GLOB_DEBUG
printf("calling globextend from glob2\n");
#endif /* GLOB_DEBUG */
! return(globextend(pathbuf, pglob));
}
/* Find end of next segment, copy tentatively to pathend. */
--- 667,673 ----
#ifdef GLOB_DEBUG
printf("calling globextend from glob2\n");
#endif /* GLOB_DEBUG */
! return(globextend(pathbuf, pglob, limitp));
}
/* Find end of next segment, copy tentatively to pathend. */
***************
*** 640,645 ****
--- 680,687 ----
) {
if (ismeta(*p))
anymeta = 1;
+ if (q+1 > pathend_last)
+ return (1);
*q++ = *p++;
}
***************
*** 650,666 ****
#ifdef DOSISH
|| *pattern == BG_SEP2
#endif
! )
*pathend++ = *pattern++;
! } else /* Need expansion, recurse. */
! return(glob3(pathbuf, pathend, pattern, p, pglob));
}
/* NOTREACHED */
}
static int
! glob3(Char *pathbuf, Char *pathend, Char *pattern,
! Char *restpattern, glob_t *pglob)
{
register Direntry_t *dp;
DIR *dirp;
--- 692,715 ----
#ifdef DOSISH
|| *pattern == BG_SEP2
#endif
! ) {
! if (pathend+1 > pathend_last)
! return (1);
*pathend++ = *pattern++;
! }
! } else
! /* Need expansion, recurse. */
! return(glob3(pathbuf, pathbuf_last, pathend,
! pathend_last, pattern, pattern_last,
! p, pattern_last, pglob, limitp));
}
/* NOTREACHED */
}
static int
! glob3(Char *pathbuf, Char *pathbuf_last, Char *pathend, Char *pathend_last,
! Char *pattern, Char *pattern_last,
! Char *restpattern, Char *restpattern_last, glob_t *pglob, size_t *limitp)
{
register Direntry_t *dp;
DIR *dirp;
***************
*** 676,703 ****
*/
Direntry_t *(*readdirfunc)(DIR*);
*pathend = BG_EOS;
errno = 0;
#ifdef VMS
{
! Char *q = pathend;
! if (q - pathbuf > 5) {
! q -= 5;
! if (q[0] == '.' && tolower(q[1]) == 'd' && tolower(q[2]) == 'i'
! && tolower(q[3]) == 'r' && q[4] == '/')
! {
! q[0] = '/';
! q[1] = BG_EOS;
! pathend = q+1;
! }
! }
}
#endif
if ((dirp = g_opendir(pathbuf, pglob)) == NULL) {
/* TODO: don't call for ENOENT or ENOTDIR? */
if (pglob->gl_errfunc) {
! g_Ctoc(pathbuf, buf);
if (pglob->gl_errfunc(buf, errno) ||
(pglob->gl_flags & GLOB_ERR))
return (GLOB_ABEND);
--- 725,756 ----
*/
Direntry_t *(*readdirfunc)(DIR*);
+ if (pathend > pathend_last)
+ return (1);
*pathend = BG_EOS;
errno = 0;
#ifdef VMS
{
! Char *q = pathend;
! if (q - pathbuf > 5) {
! q -= 5;
! if (q[0] == '.' &&
! tolower(q[1]) == 'd' && tolower(q[2]) == 'i' &&
! tolower(q[3]) == 'r' && q[4] == '/')
! {
! q[0] = '/';
! q[1] = BG_EOS;
! pathend = q+1;
! }
! }
}
#endif
if ((dirp = g_opendir(pathbuf, pglob)) == NULL) {
/* TODO: don't call for ENOENT or ENOTDIR? */
if (pglob->gl_errfunc) {
! if (g_Ctoc(pathbuf, buf, sizeof(buf)))
! return (GLOB_ABEND);
if (pglob->gl_errfunc(buf, errno) ||
(pglob->gl_flags & GLOB_ERR))
return (GLOB_ABEND);
***************
*** 710,716 ****
/* Search directory for matching names. */
if (pglob->gl_flags & GLOB_ALTDIRFUNC)
! readdirfunc = (Direntry_t *(*)(DIR *))pglob->gl_readdir;
else
readdirfunc = my_readdir;
while ((dp = (*readdirfunc)(dirp))) {
--- 763,769 ----
/* Search directory for matching names. */
if (pglob->gl_flags & GLOB_ALTDIRFUNC)
! readdirfunc = (Direntry_t *(*)(DIR *))pglob->gl_readdir;
else
readdirfunc = my_readdir;
while ((dp = (*readdirfunc)(dirp))) {
***************
*** 720,733 ****
/* Initial BG_DOT must be matched literally. */
if (dp->d_name[0] == BG_DOT && *pattern != BG_DOT)
continue;
! for (sc = (U8 *) dp->d_name, dc = pathend;
! (*dc++ = *sc++) != BG_EOS;)
! continue;
if (!match(pathend, pattern, restpattern, nocase)) {
*pathend = BG_EOS;
continue;
}
! err = glob2(pathbuf, --dc, restpattern, pglob);
if (err)
break;
}
--- 773,794 ----
/* Initial BG_DOT must be matched literally. */
if (dp->d_name[0] == BG_DOT && *pattern != BG_DOT)
continue;
! dc = pathend;
! sc = (U8 *) dp->d_name;
! while (dc < pathend_last && (*dc++ = *sc++) != BG_EOS)
! ;
! if (dc >= pathend_last) {
! *dc = BG_EOS;
! err = 1;
! break;
! }
!
if (!match(pathend, pattern, restpattern, nocase)) {
*pathend = BG_EOS;
continue;
}
! err = glob2(pathbuf, pathbuf_last, --dc, pathend_last,
! restpattern, restpattern_last, pglob, limitp);
if (err)
break;
}
***************
*** 755,764 ****
* gl_pathv points to (gl_offs + gl_pathc + 1) items.
*/
static int
! globextend(const Char *path, glob_t *pglob)
{
register char **pathv;
register int i;
char *copy;
const Char *p;
--- 816,826 ----
* gl_pathv points to (gl_offs + gl_pathc + 1) items.
*/
static int
! globextend(const Char *path, glob_t *pglob, size_t *limitp)
{
register char **pathv;
register int i;
+ STRLEN newsize, len;
char *copy;
const Char *p;
***************
*** 769,781 ****
printf("\n");
#endif /* GLOB_DEBUG */
if (pglob->gl_pathv)
! pathv = Renew(pglob->gl_pathv,
! (2 + pglob->gl_pathc + pglob->gl_offs),char*);
else
! New(0,pathv,(2 + pglob->gl_pathc + pglob->gl_offs),char*);
! if (pathv == NULL)
return(GLOB_NOSPACE);
if (pglob->gl_pathv == NULL && pglob->gl_offs > 0) {
/* first time around -- clear initial gl_offs items */
--- 831,848 ----
printf("\n");
#endif /* GLOB_DEBUG */
+ newsize = sizeof(*pathv) * (2 + pglob->gl_pathc + pglob->gl_offs);
if (pglob->gl_pathv)
! pathv = Renew(pglob->gl_pathv,newsize,char*);
else
! New(0,pathv,newsize,char*);
! if (pathv == NULL) {
! if (pglob->gl_pathv) {
! Safefree(pglob->gl_pathv);
! pglob->gl_pathv = NULL;
! }
return(GLOB_NOSPACE);
+ }
if (pglob->gl_pathv == NULL && pglob->gl_offs > 0) {
/* first time around -- clear initial gl_offs items */
***************
*** 786,798 ****
pglob->gl_pathv = pathv;
for (p = path; *p++;)
! continue;
New(0, copy, p-path, char);
if (copy != NULL) {
! g_Ctoc(path, copy);
pathv[pglob->gl_offs + pglob->gl_pathc++] = copy;
}
pathv[pglob->gl_offs + pglob->gl_pathc] = NULL;
return(copy == NULL ? GLOB_NOSPACE : 0);
}
--- 853,877 ----
pglob->gl_pathv = pathv;
for (p = path; *p++;)
! ;
! len = (STRLEN)(p - path);
! *limitp += len;
New(0, copy, p-path, char);
if (copy != NULL) {
! if (g_Ctoc(path, copy, len)) {
! Safefree(copy);
! return(GLOB_NOSPACE);
! }
pathv[pglob->gl_offs + pglob->gl_pathc++] = copy;
}
pathv[pglob->gl_offs + pglob->gl_pathc] = NULL;
+
+ if ((pglob->gl_flags & GLOB_LIMIT) &&
+ newsize + *limitp >= ARG_MAX) {
+ errno = 0;
+ return(GLOB_NOSPACE);
+ }
+
return(copy == NULL ? GLOB_NOSPACE : 0);
}
***************
*** 816,822 ****
do
if (match(name, pat, patend, nocase))
return(1);
! while (*name++ != BG_EOS);
return(0);
case M_ONE:
if (*name++ == BG_EOS)
--- 895,902 ----
do
if (match(name, pat, patend, nocase))
return(1);
! while (*name++ != BG_EOS)
! ;
return(0);
case M_ONE:
if (*name++ == BG_EOS)
***************
*** 866,871 ****
--- 946,952 ----
if (*pp)
Safefree(*pp);
Safefree(pglob->gl_pathv);
+ pglob->gl_pathv = NULL;
}
}
***************
*** 881,893 ****
strcpy(buf, ".");
#endif
} else {
! g_Ctoc(str, buf);
}
if (pglob->gl_flags & GLOB_ALTDIRFUNC)
return((*pglob->gl_opendir)(buf));
! else
! return(PerlDir_open(buf));
}
static int
--- 962,975 ----
strcpy(buf, ".");
#endif
} else {
! if (g_Ctoc(str, buf, sizeof(buf)))
! return(NULL);
}
if (pglob->gl_flags & GLOB_ALTDIRFUNC)
return((*pglob->gl_opendir)(buf));
!
! return(PerlDir_open(buf));
}
static int
***************
*** 895,901 ****
{
char buf[MAXPATHLEN];
! g_Ctoc(fn, buf);
if (pglob->gl_flags & GLOB_ALTDIRFUNC)
return((*pglob->gl_lstat)(buf, sb));
#ifdef HAS_LSTAT
--- 977,984 ----
{
char buf[MAXPATHLEN];
! if (g_Ctoc(fn, buf, sizeof(buf)))
! return(-1);
if (pglob->gl_flags & GLOB_ALTDIRFUNC)
return((*pglob->gl_lstat)(buf, sb));
#ifdef HAS_LSTAT
***************
*** 910,916 ****
{
char buf[MAXPATHLEN];
! g_Ctoc(fn, buf);
if (pglob->gl_flags & GLOB_ALTDIRFUNC)
return((*pglob->gl_stat)(buf, sb));
return(PerlLIO_stat(buf, sb));
--- 993,1000 ----
{
char buf[MAXPATHLEN];
! if (g_Ctoc(fn, buf, sizeof(buf)))
! return(-1);
if (pglob->gl_flags & GLOB_ALTDIRFUNC)
return((*pglob->gl_stat)(buf, sb));
return(PerlLIO_stat(buf, sb));
***************
*** 926,954 ****
return (NULL);
}
! #ifdef notdef
! static Char *
! g_strcat(Char *dst, const Char *src)
{
! Char *sdst = dst;
!
! while (*dst++)
! continue;
! --dst;
! while((*dst++ = *src++) != BG_EOS)
! continue;
!
! return (sdst);
! }
! #endif
!
! static void
! g_Ctoc(register const Char *str, char *buf)
! {
! register char *dc;
!
! for (dc = buf; (*dc++ = *str++) != BG_EOS;)
! continue;
}
#ifdef GLOB_DEBUG
--- 1010,1023 ----
return (NULL);
}
! static int
! g_Ctoc(register const Char *str, char *buf, STRLEN len)
{
! while (len--) {
! if ((*buf++ = *str++) == BG_EOS)
! return (0);
! }
! return (1);
}
#ifdef GLOB_DEBUG
diff -c 'perl-5.7.1/ext/File/Glob/bsd_glob.h' 'perl-5.7.2/ext/File/Glob/bsd_glob.h'
Index: ./ext/File/Glob/bsd_glob.h
Prereq: 8.1
*** ./ext/File/Glob/bsd_glob.h Wed Mar 21 02:43:07 2001
--- ./ext/File/Glob/bsd_glob.h Mon Jul 9 17:10:02 2001
***************
*** 30,35 ****
--- 30,36 ----
* SUCH DAMAGE.
*
* @(#)glob.h 8.1 (Berkeley) 6/2/93
+ * [lots of perl-specific changes since then--see bsd_glob.c]
*/
#ifndef _BSD_GLOB_H_
***************
*** 73,78 ****
--- 74,81 ----
#define GLOB_TILDE 0x0800 /* Expand tilde names from the passwd file. */
#define GLOB_NOCASE 0x1000 /* Treat filenames without regard for case. */
#define GLOB_ALPHASORT 0x2000 /* Alphabetic, not ASCII sort, like csh. */
+ #define GLOB_LIMIT 0x4000 /* Limit pattern match output to ARG_MAX
+ (usually from limits.h). */
#define GLOB_NOSPACE (-1) /* Malloc call failed. */
#define GLOB_ABEND (-2) /* Unignored error. */
diff -c /dev/null 'perl-5.7.2/ext/File/Glob/t/basic.t'
Index: ./ext/File/Glob/t/basic.t
*** ./ext/File/Glob/t/basic.t Thu Jan 1 02:00:00 1970
--- ./ext/File/Glob/t/basic.t Tue Jul 10 05:19:21 2001
***************
*** 0 ****
--- 1,175 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ } else {
+ @INC = '.';
+ push @INC, '../lib';
+ }
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) {
+ print "1..0\n";
+ exit 0;
+ }
+ print "1..11\n";
+ }
+ END {
+ print "not ok 1\n" unless $loaded;
+ }
+ use File::Glob ':glob';
+ use Cwd ();
+ $loaded = 1;
+ print "ok 1\n";
+
+ sub array {
+ return '(', join(", ", map {defined $_ ? "\"$_\"" : "undef"} @a), ")\n";
+ }
+
+ # look for the contents of the current directory
+ $ENV{PATH} = "/bin";
+ delete @ENV{BASH_ENV, CDPATH, ENV, IFS};
+ @correct = ();
+ if (opendir(D, $^O eq "MacOS" ? ":" : ".")) {
+ @correct = grep { !/^\./ } sort readdir(D);
+ closedir D;
+ }
+ @a = File::Glob::glob("*", 0);
+ @a = sort @a;
+ if ("@a" ne "@correct" || GLOB_ERROR) {
+ print "# |@a| ne |@correct|\nnot ";
+ }
+ print "ok 2\n";
+
+ # look up the user's home directory
+ # should return a list with one item, and not set ERROR
+ if ($^O ne 'MSWin32' && $^O ne 'NetWare' && $^O ne 'VMS' && $^O ne 'os2') {
+ eval {
+ ($name, $home) = (getpwuid($>))[0,7];
+ 1;
+ } and do {
+ @a = bsd_glob("~$name", GLOB_TILDE);
+ if (scalar(@a) != 1 || $a[0] ne $home || GLOB_ERROR) {
+ print "not ";
+ }
+ };
+ }
+ print "ok 3\n";
+
+ # check backslashing
+ # should return a list with one item, and not set ERROR
+ @a = bsd_glob('TEST', GLOB_QUOTE);
+ if (scalar @a != 1 || $a[0] ne 'TEST' || GLOB_ERROR) {
+ local $/ = "][";
+ print "# [@a]\n";
+ print "not ";
+ }
+ print "ok 4\n";
+
+ # check nonexistent checks
+ # should return an empty list
+ # XXX since errfunc is NULL on win32, this test is not valid there
+ @a = bsd_glob("asdfasdf", 0);
+ if (($^O ne 'MSWin32' && $^O ne 'NetWare') and scalar @a != 0) {
+ print "# |@a|\nnot ";
+ }
+ print "ok 5\n";
+
+ # check bad protections
+ # should return an empty list, and set ERROR
+ if ($^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'NetWare' or $^O eq 'os2' or $^O eq 'VMS'
+ or $^O eq 'cygwin' or Cwd::cwd() =~ m#^$Config{'afsroot'}#s or not $>)
+ {
+ print "ok 6 # skipped\n";
+ }
+ else {
+ $dir = "pteerslo";
+ mkdir $dir, 0;
+ @a = bsd_glob("$dir/*", GLOB_ERR);
+ #print "\@a = ", array(@a);
+ rmdir $dir;
+ if (scalar(@a) != 0 || GLOB_ERROR == 0) {
+ print "not ";
+ }
+ print "ok 6\n";
+ }
+
+ # check for csh style globbing
+ @a = bsd_glob('{a,b}', GLOB_BRACE | GLOB_NOMAGIC);
+ unless (@a == 2 and $a[0] eq 'a' and $a[1] eq 'b') {
+ print "not ";
+ }
+ print "ok 7\n";
+
+ @a = bsd_glob(
+ '{TES*,doesntexist*,a,b}',
+ GLOB_BRACE | GLOB_NOMAGIC | ($^O eq 'VMS' ? GLOB_NOCASE : 0)
+ );
+
+ # Working on t/TEST often causes this test to fail because it sees Emacs temp
+ # and RCS files. Filter them out, and .pm files too, and patch temp files.
+ @a = grep !/(,v$|~$|\.(pm|ori?g|rej)$)/, @a;
+
+ print "# @a\n";
+
+ unless (@a == 3
+ and $a[0] eq ($^O eq 'VMS'? 'test.' : 'TEST')
+ and $a[1] eq 'a'
+ and $a[2] eq 'b')
+ {
+ print "not ok 8 # @a";
+ } else {
+ print "ok 8\n";
+ }
+
+ # "~" should expand to $ENV{HOME}
+ $ENV{HOME} = "sweet home";
+ @a = bsd_glob('~', GLOB_TILDE | GLOB_NOMAGIC);
+ unless ($^O eq "MacOS" || (@a == 1 and $a[0] eq $ENV{HOME})) {
+ print "not ";
+ }
+ print "ok 9\n";
+
+ # GLOB_ALPHASORT (default) should sort alphabetically regardless of case
+ mkdir "pteerslo", 0777;
+ chdir "pteerslo";
+
+ @f_names = qw(Ax.pl Bx.pl Cx.pl aY.pl bY.pl cY.pl);
+ @f_alpha = qw(Ax.pl aY.pl Bx.pl bY.pl Cx.pl cY.pl);
+ if ('a' lt 'A') { # EBCDIC char sets sort lower case before UPPER
+ @f_names = sort(@f_names);
+ }
+ if ($^O eq 'VMS') { # VMS is happily caseignorant
+ @f_alpha = qw(ax.pl ay.pl bx.pl by.pl cx.pl cy.pl);
+ @f_names = @f_alpha;
+ }
+
+ for (@f_names) {
+ open T, "> $_";
+ close T;
+ }
+
+ $pat = "*.pl";
+
+ $ok = 1;
+ @g_names = bsd_glob($pat, 0);
+ print "# f_names = @f_names\n";
+ print "# g_names = @g_names\n";
+ for (@f_names) {
+ $ok = 0 unless $_ eq shift @g_names;
+ }
+ print $ok ? "ok 10\n" : "not ok 10\n";
+
+ $ok = 1;
+ @g_alpha = bsd_glob($pat);
+ print "# f_alpha = @f_alpha\n";
+ print "# g_alpha = @g_alpha\n";
+ for (@f_alpha) {
+ $ok = 0 unless $_ eq shift @g_alpha;
+ }
+ print $ok ? "ok 11\n" : "not ok 11\n";
+
+ unlink @f_names;
+ chdir "..";
+ rmdir "pteerslo";
diff -c /dev/null 'perl-5.7.2/ext/File/Glob/t/case.t'
Index: ./ext/File/Glob/t/case.t
*** ./ext/File/Glob/t/case.t Thu Jan 1 02:00:00 1970
--- ./ext/File/Glob/t/case.t Mon Jul 9 17:10:02 2001
***************
*** 0 ****
--- 1,60 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ } else {
+ @INC = '.';
+ push @INC, '../lib';
+ }
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) {
+ print "1..0\n";
+ exit 0;
+ }
+ print "1..7\n";
+ }
+ END {
+ print "not ok 1\n" unless $loaded;
+ }
+ use File::Glob qw(:glob csh_glob);
+ $loaded = 1;
+ print "ok 1\n";
+
+ my $pat = $^O eq "MacOS" ? ":op:G*.t" : "op/G*.t";
+
+ # Test the actual use of the case sensitivity tags, via csh_glob()
+ import File::Glob ':nocase';
+ @a = csh_glob($pat);
+ print "not " unless @a >= 8;
+ print "ok 2\n";
+
+ # This may fail on systems which are not case-PRESERVING
+ import File::Glob ':case';
+ @a = csh_glob($pat); # None should be uppercase
+ print "not " unless @a == 0;
+ print "ok 3\n";
+
+ # Test the explicit use of the GLOB_NOCASE flag
+ @a = bsd_glob($pat, GLOB_NOCASE);
+ print "not " unless @a >= 3;
+ print "ok 4\n";
+
+ # Test Win32 backslash nastiness...
+ if ($^O ne 'MSWin32' && $^O ne 'NetWare') {
+ print "ok 5\nok 6\nok 7\n";
+ }
+ else {
+ @a = File::Glob::glob("op\\g*.t");
+ print "not " unless @a >= 8;
+ print "ok 5\n";
+ mkdir "[]", 0;
+ @a = File::Glob::glob("\\[\\]", GLOB_QUOTE);
+ rmdir "[]";
+ print "# returned @a\nnot " unless @a == 1;
+ print "ok 6\n";
+ @a = bsd_glob("op\\*", GLOB_QUOTE);
+ print "not " if @a == 0;
+ print "ok 7\n";
+ }
diff -c /dev/null 'perl-5.7.2/ext/File/Glob/t/global.t'
Index: ./ext/File/Glob/t/global.t
*** ./ext/File/Glob/t/global.t Thu Jan 1 02:00:00 1970
--- ./ext/File/Glob/t/global.t Mon Jul 9 17:10:02 2001
***************
*** 0 ****
--- 1,151 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ } else {
+ @INC = '.';
+ push @INC, '../lib';
+ }
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) {
+ print "1..0\n";
+ exit 0;
+ }
+ print "1..10\n";
+ }
+ END {
+ print "not ok 1\n" unless $loaded;
+ }
+
+ BEGIN {
+ *CORE::GLOBAL::glob = sub { "Just another Perl hacker," };
+ }
+
+ BEGIN {
+ if ("Just another Perl hacker," ne (<*>)[0]) {
+ die <<EOMessage;
+ Your version of perl ($]) doesn't seem to allow extensions to override
+ the core glob operator.
+ EOMessage
+ }
+ }
+
+ use File::Glob ':globally';
+ $loaded = 1;
+ print "ok 1\n";
+
+ $_ = $^O eq "MacOS" ? ":op:*.t" : "op/*.t";
+ my @r = glob;
+ print "not " if $_ ne ($^O eq "MacOS" ? ":op:*.t" : "op/*.t");
+ print "ok 2\n";
+
+ print "# |@r|\nnot " if @r < 3;
+ print "ok 3\n";
+
+ # check if <*/*> works
+ if ($^O eq "MacOS") {
+ @r = <:*:*.t>;
+ } else {
+ @r = <*/*.t>;
+ }
+ # at least t/global.t t/basic.t, t/taint.t
+ print "not " if @r < 3;
+ print "ok 4\n";
+ my $r = scalar @r;
+
+ # check if scalar context works
+ @r = ();
+ if ($^O eq "MacOS") {
+ while (defined($_ = <:*:*.t>)) {
+ #print "# $_\n";
+ push @r, $_;
+ }
+ } else {
+ while (defined($_ = <*/*.t>)) {
+ #print "# $_\n";
+ push @r, $_;
+ }
+ }
+ print "not " if @r != $r;
+ print "ok 5\n";
+
+ # check if list context works
+ @r = ();
+ if ($^O eq "MacOS") {
+ for (<:*:*.t>) {
+ #print "# $_\n";
+ push @r, $_;
+ }
+ } else {
+ for (<*/*.t>) {
+ #print "# $_\n";
+ push @r, $_;
+ }
+ }
+ print "not " if @r != $r;
+ print "ok 6\n";
+
+ # test if implicit assign to $_ in while() works
+ @r = ();
+ if ($^O eq "MacOS") {
+ while (<:*:*.t>) {
+ #print "# $_\n";
+ push @r, $_;
+ }
+ } else {
+ while (<*/*.t>) {
+ #print "# $_\n";
+ push @r, $_;
+ }
+ }
+ print "not " if @r != $r;
+ print "ok 7\n";
+
+ # test if explicit glob() gets assign magic too
+ my @s = ();
+ while (glob($^O eq 'MacOS' ? ':*:*.t' : '*/*.t')) {
+ #print "# $_\n";
+ push @s, $_;
+ }
+ print "not " if "@r" ne "@s";
+ print "ok 8\n";
+
+ # how about in a different package, like?
+ package Foo;
+ use File::Glob ':globally';
+ @s = ();
+ while (glob($^O eq 'MacOS' ? ':*:*.t' : '*/*.t')) {
+ #print "# $_\n";
+ push @s, $_;
+ }
+ print "not " if "@r" ne "@s";
+ print "ok 9\n";
+
+ # test if different glob ops maintain independent contexts
+ @s = ();
+ my $i = 0;
+ if ($^O eq "MacOS") {
+ while (<:*:*.t>) {
+ #print "# $_ <";
+ push @s, $_;
+ while (<:bas*:*.t>) {
+ #print " $_";
+ $i++;
+ }
+ #print " >\n";
+ }
+ } else {
+ while (<*/*.t>) {
+ #print "# $_ <";
+ push @s, $_;
+ while (<bas*/*.t>) {
+ #print " $_";
+ $i++;
+ }
+ #print " >\n";
+ }
+ }
+ print "not " if "@r" ne "@s" or not $i;
+ print "ok 10\n";
diff -c /dev/null 'perl-5.7.2/ext/File/Glob/t/taint.t'
Index: ./ext/File/Glob/t/taint.t
*** ./ext/File/Glob/t/taint.t Thu Jan 1 02:00:00 1970
--- ./ext/File/Glob/t/taint.t Mon Jul 9 17:10:02 2001
***************
*** 0 ****
--- 1,31 ----
+ #!./perl -T
+
+ BEGIN {
+ chdir 't' if -d 't';
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ } else {
+ @INC = '.';
+ push @INC, '../lib';
+ }
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) {
+ print "1..0\n";
+ exit 0;
+ }
+ print "1..2\n";
+ }
+ END {
+ print "not ok 1\n" unless $loaded;
+ }
+ use File::Glob;
+ $loaded = 1;
+ print "ok 1\n";
+
+ # all filenames should be tainted
+ @a = File::Glob::bsd_glob("*");
+ eval { $a = join("",@a), kill 0; 1 };
+ unless ($@ =~ /Insecure dependency/) {
+ print "not ";
+ }
+ print "ok 2\n";
diff -c 'perl-5.7.1/ext/Filter/Util/Call/Call.xs' 'perl-5.7.2/ext/Filter/Util/Call/Call.xs'
Index: ./ext/Filter/Util/Call/Call.xs
*** ./ext/Filter/Util/Call/Call.xs Fri Mar 16 05:14:10 2001
--- ./ext/Filter/Util/Call/Call.xs Mon Jul 9 17:10:02 2001
***************
*** 11,16 ****
--- 11,17 ----
*
*/
+ #define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
***************
*** 243,249 ****
void
! unimport(...)
PPCODE:
filter_del(filter_call);
--- 244,251 ----
void
! unimport(package="$Package", ...)
! char *package
PPCODE:
filter_del(filter_call);
diff -c /dev/null 'perl-5.7.2/ext/Filter/t/call.t'
Index: ./ext/Filter/t/call.t
*** ./ext/Filter/t/call.t Thu Jan 1 02:00:00 1970
--- ./ext/Filter/t/call.t Mon Jul 9 17:10:02 2001
***************
*** 0 ****
--- 1,795 ----
+ BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ m{\bFilter/Util/Call\b}) {
+ print "1..0 # Skip: Filter::Util::Call was not built\n";
+ exit 0;
+ }
+ require 'lib/filter-util.pl';
+ }
+
+ use strict;
+ use warnings;
+
+ use vars qw($Inc $Perl);
+
+ print "1..28\n" ;
+
+ $Perl = "$Perl -w" ;
+
+ use Cwd ;
+ my $here = getcwd ;
+
+
+ my $filename = "call.tst" ;
+ my $filenamebin = "call.bin" ;
+ my $module = "MyTest" ;
+ my $module2 = "MyTest2" ;
+ my $module3 = "MyTest3" ;
+ my $module4 = "MyTest4" ;
+ my $module5 = "MyTest5" ;
+ my $nested = "nested" ;
+ my $block = "block" ;
+
+ # Test error cases
+ ##################
+
+ # no filter function in module
+ ###############################
+
+ writeFile("${module}.pm", <<EOM) ;
+ package ${module} ;
+
+ use Filter::Util::Call ;
+
+ sub import { filter_add(bless []) }
+
+ 1 ;
+ EOM
+
+ my $a = `$Perl "-I." $Inc -e "use ${module} ;" 2>&1` ;
+ ok(1, (($? >>8) != 0 or (($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'mpeix') && $? != 0))) ;
+ ok(2, $a =~ /^Can't locate object method "filter" via package "MyTest"/) ;
+
+ # no reference parameter in filter_add
+ ######################################
+
+ writeFile("${module}.pm", <<EOM) ;
+ package ${module} ;
+
+ use Filter::Util::Call ;
+
+ sub import { filter_add() }
+
+ 1 ;
+ EOM
+
+ $a = `$Perl "-I." $Inc -e "use ${module} ;" 2>&1` ;
+ ok(3, (($? >>8) != 0 or (($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'mpeix') && $? != 0))) ;
+ #ok(4, $a =~ /^usage: filter_add\(ref\) at ${module}.pm/) ;
+ ok(4, $a =~ /^Not enough arguments for Filter::Util::Call::filter_add/) ;
+
+
+
+
+ # non-error cases
+ #################
+
+
+ # a simple filter, using a closure
+ #################
+
+ writeFile("${module}.pm", <<EOM, <<'EOM') ;
+ package ${module} ;
+
+ EOM
+ use Filter::Util::Call ;
+ sub import {
+ filter_add(
+ sub {
+
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/ABC/DEF/g
+ }
+ $status ;
+ } ) ;
+ }
+
+ 1 ;
+ EOM
+
+ writeFile($filename, <<EOM, <<'EOM') ;
+
+ use $module ;
+ EOM
+
+ use Cwd ;
+ $here = getcwd ;
+ print "I am $here\n" ;
+ print "some letters ABC\n" ;
+ $y = "ABCDEF" ;
+ print <<EOF ;
+ Alphabetti Spagetti ($y)
+ EOF
+
+ EOM
+
+ $a = `$Perl "-I." $Inc $filename 2>&1` ;
+ ok(5, ($? >>8) == 0) ;
+ ok(6, $a eq <<EOM) ;
+ I am $here
+ some letters DEF
+ Alphabetti Spagetti (DEFDEF)
+ EOM
+
+ # a simple filter, not using a closure
+ #################
+
+ writeFile("${module}.pm", <<EOM, <<'EOM') ;
+ package ${module} ;
+
+ EOM
+ use Filter::Util::Call ;
+ sub import { filter_add(bless []) }
+
+ sub filter
+ {
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/ABC/DEF/g
+ }
+ $status ;
+ }
+
+
+ 1 ;
+ EOM
+
+ writeFile($filename, <<EOM, <<'EOM') ;
+
+ use $module ;
+ EOM
+
+ use Cwd ;
+ $here = getcwd ;
+ print "I am $here\n" ;
+ print "some letters ABC\n" ;
+ $y = "ABCDEF" ;
+ print <<EOF ;
+ Alphabetti Spagetti ($y)
+ EOF
+
+ EOM
+
+ $a = `$Perl "-I." $Inc $filename 2>&1` ;
+ ok(7, ($? >>8) == 0) ;
+ ok(8, $a eq <<EOM) ;
+ I am $here
+ some letters DEF
+ Alphabetti Spagetti (DEFDEF)
+ EOM
+
+
+ # nested filters
+ ################
+
+
+ writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+ package ${module2} ;
+ use Filter::Util::Call ;
+
+ EOM
+ sub import { filter_add(bless []) }
+
+ sub filter
+ {
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/XYZ/PQR/g
+ }
+ $status ;
+ }
+
+ 1 ;
+ EOM
+
+ writeFile("${module3}.pm", <<EOM, <<'EOM') ;
+ package ${module3} ;
+ use Filter::Util::Call ;
+
+ EOM
+ sub import { filter_add(
+
+ sub
+ {
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/Fred/Joe/g
+ }
+ $status ;
+ } ) ;
+ }
+
+ 1 ;
+ EOM
+
+ writeFile("${module4}.pm", <<EOM) ;
+ package ${module4} ;
+
+ use $module5 ;
+
+ print "I'm feeling used!\n" ;
+ print "Fred Joe ABC DEF PQR XYZ\n" ;
+ print "See you Today\n" ;
+ 1;
+ EOM
+
+ writeFile("${module5}.pm", <<EOM, <<'EOM') ;
+ package ${module5} ;
+ use Filter::Util::Call ;
+
+ EOM
+ sub import { filter_add(bless []) }
+
+ sub filter
+ {
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/Today/Tomorrow/g
+ }
+ $status ;
+ }
+
+ 1 ;
+ EOM
+
+ writeFile($filename, <<EOM, <<'EOM') ;
+
+ # two filters for this file
+ use $module ;
+ use $module2 ;
+ require "$nested" ;
+ use $module4 ;
+ EOM
+
+ print "some letters ABCXYZ\n" ;
+ $y = "ABCDEFXYZ" ;
+ print <<EOF ;
+ Fred likes Alphabetti Spagetti ($y)
+ EOF
+
+ EOM
+
+ writeFile($nested, <<EOM, <<'EOM') ;
+ use $module3 ;
+ EOM
+
+ print "This is another file XYZ\n" ;
+ print <<EOF ;
+ Where is Fred?
+ EOF
+
+ EOM
+
+ $a = `$Perl "-I." $Inc $filename 2>&1` ;
+ ok(9, ($? >>8) == 0) ;
+ ok(10, $a eq <<EOM) ;
+ I'm feeling used!
+ Fred Joe ABC DEF PQR XYZ
+ See you Tomorrow
+ This is another file XYZ
+ Where is Joe?
+ some letters DEFPQR
+ Fred likes Alphabetti Spagetti (DEFDEFPQR)
+ EOM
+
+ # using the module context (with a closure)
+ ###########################################
+
+
+ writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+ package ${module2} ;
+ use Filter::Util::Call ;
+
+ EOM
+ sub import
+ {
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add (
+
+ sub
+ {
+ my ($status) ;
+ my ($pattern) ;
+
+ if (($status = filter_read()) > 0) {
+ foreach $pattern (@strings)
+ { s/$pattern/PQR/g }
+ }
+
+ $status ;
+ }
+ )
+
+ }
+ 1 ;
+ EOM
+
+
+ writeFile($filename, <<EOM, <<'EOM') ;
+
+ use $module2 qw( XYZ KLM) ;
+ use $module2 qw( ABC NMO) ;
+ EOM
+
+ print "some letters ABCXYZ KLM NMO\n" ;
+ $y = "ABCDEFXYZKLMNMO" ;
+ print <<EOF ;
+ Alphabetti Spagetti ($y)
+ EOF
+
+ EOM
+
+ $a = `$Perl "-I." $Inc $filename 2>&1` ;
+ ok(11, ($? >>8) == 0) ;
+ ok(12, $a eq <<EOM) ;
+ some letters PQRPQR PQR PQR
+ Alphabetti Spagetti (PQRDEFPQRPQRPQR)
+ EOM
+
+
+
+ # using the module context (without a closure)
+ ##############################################
+
+
+ writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+ package ${module2} ;
+ use Filter::Util::Call ;
+
+ EOM
+ sub import
+ {
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add (bless [@strings])
+ }
+
+ sub filter
+ {
+ my ($self) = @_ ;
+ my ($status) ;
+ my ($pattern) ;
+
+ if (($status = filter_read()) > 0) {
+ foreach $pattern (@$self)
+ { s/$pattern/PQR/g }
+ }
+
+ $status ;
+ }
+
+ 1 ;
+ EOM
+
+
+ writeFile($filename, <<EOM, <<'EOM') ;
+
+ use $module2 qw( XYZ KLM) ;
+ use $module2 qw( ABC NMO) ;
+ EOM
+
+ print "some letters ABCXYZ KLM NMO\n" ;
+ $y = "ABCDEFXYZKLMNMO" ;
+ print <<EOF ;
+ Alphabetti Spagetti ($y)
+ EOF
+
+ EOM
+
+ $a = `$Perl "-I." $Inc $filename 2>&1` ;
+ ok(13, ($? >>8) == 0) ;
+ ok(14, $a eq <<EOM) ;
+ some letters PQRPQR PQR PQR
+ Alphabetti Spagetti (PQRDEFPQRPQRPQR)
+ EOM
+
+ # multi line test
+ #################
+
+
+ writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+ package ${module2} ;
+ use Filter::Util::Call ;
+
+ EOM
+ sub import
+ {
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add(bless [])
+ }
+
+ sub filter
+ {
+ my ($self) = @_ ;
+ my ($status) ;
+
+ # read first line
+ if (($status = filter_read()) > 0) {
+ chop ;
+ s/\r$//;
+ # and now the second line (it will append)
+ $status = filter_read() ;
+ }
+
+ $status ;
+ }
+
+ 1 ;
+ EOM
+
+
+ writeFile($filename, <<EOM, <<'EOM') ;
+
+ use $module2 ;
+ EOM
+ print "don't cut me
+ in half\n" ;
+ print
+ <<EOF ;
+ appen
+ ded
+ EO
+ F
+
+ EOM
+
+ $a = `$Perl "-I." $Inc $filename 2>&1` ;
+ ok(15, ($? >>8) == 0) ;
+ ok(16, $a eq <<EOM) ;
+ don't cut me in half
+ appended
+ EOM
+
+ # Block test
+ #############
+
+ writeFile("${block}.pm", <<EOM, <<'EOM') ;
+ package ${block} ;
+ use Filter::Util::Call ;
+
+ EOM
+ sub import
+ {
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add (bless [@strings] )
+ }
+
+ sub filter
+ {
+ my ($self) = @_ ;
+ my ($status) ;
+ my ($pattern) ;
+
+ filter_read(20) ;
+ }
+
+ 1 ;
+ EOM
+
+ my $string = <<'EOM' ;
+ print "hello mum\n" ;
+ $x = 'me ' x 3 ;
+ print "Who wants it?\n$x\n" ;
+ EOM
+
+
+ writeFile($filename, <<EOM, $string ) ;
+ use $block ;
+ EOM
+
+ $a = `$Perl "-I." $Inc $filename 2>&1` ;
+ ok(17, ($? >>8) == 0) ;
+ ok(18, $a eq <<EOM) ;
+ hello mum
+ Who wants it?
+ me me me
+ EOM
+
+ # use in the filter
+ ####################
+
+ writeFile("${block}.pm", <<EOM, <<'EOM') ;
+ package ${block} ;
+ use Filter::Util::Call ;
+
+ EOM
+ use Cwd ;
+
+ sub import
+ {
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add(bless [@strings] )
+ }
+
+ sub filter
+ {
+ my ($self) = @_ ;
+ my ($status) ;
+ my ($here) = quotemeta getcwd ;
+
+ if (($status = filter_read()) > 0) {
+ s/DIR/$here/g
+ }
+ $status ;
+ }
+
+ 1 ;
+ EOM
+
+ writeFile($filename, <<EOM, <<'EOM') ;
+ use $block ;
+ EOM
+ print "We are in DIR\n" ;
+ EOM
+
+ $a = `$Perl "-I." $Inc $filename 2>&1` ;
+ ok(19, ($? >>8) == 0) ;
+ ok(20, $a eq <<EOM) ;
+ We are in $here
+ EOM
+
+
+ # filter_del
+ #############
+
+ writeFile("${block}.pm", <<EOM, <<'EOM') ;
+ package ${block} ;
+ use Filter::Util::Call ;
+
+ EOM
+
+ sub import
+ {
+ my ($type) = shift ;
+ my ($count) = @_ ;
+
+
+ filter_add(bless \$count )
+ }
+
+ sub filter
+ {
+ my ($self) = @_ ;
+ my ($status) ;
+
+ s/HERE/THERE/g
+ if ($status = filter_read()) > 0 ;
+
+ -- $$self ;
+ filter_del() if $$self <= 0 ;
+
+ $status ;
+ }
+
+ 1 ;
+ EOM
+
+ writeFile($filename, <<EOM, <<'EOM') ;
+ use $block (3) ;
+ EOM
+ print "
+ HERE I am
+ I am HERE
+ HERE today gone tomorrow\n" ;
+ EOM
+
+ $a = `$Perl "-I." $Inc $filename 2>&1` ;
+ ok(21, ($? >>8) == 0) ;
+ ok(22, $a eq <<EOM) ;
+
+ THERE I am
+ I am THERE
+ HERE today gone tomorrow
+ EOM
+
+
+ # filter_read_exact
+ ####################
+
+ writeFile("${block}.pm", <<EOM, <<'EOM') ;
+ package ${block} ;
+ use Filter::Util::Call ;
+
+ EOM
+
+ sub import
+ {
+ my ($type) = shift ;
+
+ filter_add(bless [] )
+ }
+
+ sub filter
+ {
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read_exact(9)) > 0) {
+ s/HERE/THERE/g
+ }
+
+ $status ;
+ }
+
+ 1 ;
+ EOM
+
+ writeFile($filenamebin, <<EOM, <<'EOM') ;
+ use $block ;
+ EOM
+ print "
+ HERE I am
+ I'm HERE
+ HERE today gone tomorrow\n" ;
+ EOM
+
+ $a = `$Perl "-I." $Inc $filenamebin 2>&1` ;
+ ok(23, ($? >>8) == 0) ;
+ ok(24, $a eq <<EOM) ;
+
+ HERE I am
+ I'm THERE
+ THERE today gone tomorrow
+ EOM
+
+ {
+
+ # Check __DATA__
+ ####################
+
+ writeFile("${block}.pm", <<EOM, <<'EOM') ;
+ package ${block} ;
+ use Filter::Util::Call ;
+
+ EOM
+
+ sub import
+ {
+ my ($type) = shift ;
+
+ filter_add(bless [] )
+ }
+
+ sub filter
+ {
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/HERE/THERE/g
+ }
+
+ $status ;
+ }
+
+ 1 ;
+ EOM
+
+ writeFile($filename, <<EOM, <<'EOM') ;
+ use $block ;
+ EOM
+ print "HERE HERE\n";
+ @a = <DATA>;
+ print @a;
+ __DATA__
+ HERE I am
+ I'm HERE
+ HERE today gone tomorrow
+ EOM
+
+ $a = `$Perl "-I." $Inc $filename 2>&1` ;
+ ok(25, ($? >>8) == 0) ;
+ ok(26, $a eq <<EOM) ;
+ THERE THERE
+ HERE I am
+ I'm HERE
+ HERE today gone tomorrow
+ EOM
+
+ }
+
+ {
+
+ # Check __END__
+ ####################
+
+ writeFile("${block}.pm", <<EOM, <<'EOM') ;
+ package ${block} ;
+ use Filter::Util::Call ;
+
+ EOM
+
+ sub import
+ {
+ my ($type) = shift ;
+
+ filter_add(bless [] )
+ }
+
+ sub filter
+ {
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/HERE/THERE/g
+ }
+
+ $status ;
+ }
+
+ 1 ;
+ EOM
+
+ writeFile($filename, <<EOM, <<'EOM') ;
+ use $block ;
+ EOM
+ print "HERE HERE\n";
+ @a = <DATA>;
+ print @a;
+ __END__
+ HERE I am
+ I'm HERE
+ HERE today gone tomorrow
+ EOM
+
+ $a = `$Perl "-I." $Inc $filename 2>&1` ;
+ ok(27, ($? >>8) == 0) ;
+ ok(28, $a eq <<EOM) ;
+ THERE THERE
+ HERE I am
+ I'm HERE
+ HERE today gone tomorrow
+ EOM
+
+ }
+
+ END {
+ 1 while unlink $filename ;
+ 1 while unlink $filenamebin ;
+ 1 while unlink "${module}.pm" ;
+ 1 while unlink "${module2}.pm" ;
+ 1 while unlink "${module3}.pm" ;
+ 1 while unlink "${module4}.pm" ;
+ 1 while unlink "${module5}.pm" ;
+ 1 while unlink $nested ;
+ 1 while unlink "${block}.pm" ;
+ }
+
+
diff -c 'perl-5.7.1/ext/GDBM_File/GDBM_File.pm' 'perl-5.7.2/ext/GDBM_File/GDBM_File.pm'
Index: ./ext/GDBM_File/GDBM_File.pm
*** ./ext/GDBM_File/GDBM_File.pm Fri Mar 16 04:49:04 2001
--- ./ext/GDBM_File/GDBM_File.pm Mon Jul 9 17:10:02 2001
***************
*** 22,31 ****
=head1 AVAILABILITY
! Gdbm is available from any GNU archive. The master site is
! C<prep.ai.mit.edu>, but your are strongly urged to use one of the many
! mirrors. You can obtain a list of mirror sites by issuing the
! command C<finger fsf@prep.ai.mit.edu>.
=head1 BUGS
--- 22,31 ----
=head1 AVAILABILITY
! gdbm is available from any GNU archive. The master site is
! C<ftp.gnu.org>, but you are strongly urged to use one of the many
! mirrors. You can obtain a list of mirror sites from
! http://www.gnu.org/order/ftp.html.
=head1 BUGS
***************
*** 46,52 ****
require Carp;
require Tie::Hash;
require Exporter;
- use AutoLoader;
use XSLoader ();
@ISA = qw(Tie::Hash Exporter);
@EXPORT = qw(
--- 46,51 ----
***************
*** 61,81 ****
GDBM_WRITER
);
! $VERSION = "1.05";
sub AUTOLOAD {
my($constname);
($constname = $AUTOLOAD) =~ s/.*:://;
! my $val = constant($constname, @_ ? $_[0] : 0);
! if ($! != 0) {
! if ($! =~ /Invalid/ || $!{EINVAL}) {
! $AutoLoader::AUTOLOAD = $AUTOLOAD;
! goto &AutoLoader::AUTOLOAD;
! }
! else {
! Carp::croak("Your vendor has not defined GDBM_File macro $constname, used");
! }
! }
eval "sub $AUTOLOAD { $val }";
goto &$AUTOLOAD;
}
--- 60,72 ----
GDBM_WRITER
);
! $VERSION = "1.06";
sub AUTOLOAD {
my($constname);
($constname = $AUTOLOAD) =~ s/.*:://;
! my ($error, $val) = constant($constname);
! Carp::croak $error if $error;
eval "sub $AUTOLOAD { $val }";
goto &$AUTOLOAD;
}
***************
*** 82,89 ****
XSLoader::load 'GDBM_File', $VERSION;
- # Preloaded methods go here. Autoload methods go after __END__, and are
- # processed by the autosplit program.
-
1;
- __END__
--- 73,76 ----
diff -c 'perl-5.7.1/ext/GDBM_File/GDBM_File.xs' 'perl-5.7.2/ext/GDBM_File/GDBM_File.xs'
Index: ./ext/GDBM_File/GDBM_File.xs
*** ./ext/GDBM_File/GDBM_File.xs Fri Mar 16 04:49:52 2001
--- ./ext/GDBM_File/GDBM_File.xs Mon Jul 9 17:10:02 2001
***************
*** 76,214 ****
#define gdbm_setopt(db,optflag,optval,optlen) not_here("gdbm_setopt")
#endif
! static double
! constant(char *name, int arg)
! {
! errno = 0;
! switch (*name) {
! case 'A':
! break;
! case 'B':
! break;
! case 'C':
! break;
! case 'D':
! break;
! case 'E':
! break;
! case 'F':
! break;
! case 'G':
! if (strEQ(name, "GDBM_CACHESIZE"))
! #ifdef GDBM_CACHESIZE
! return GDBM_CACHESIZE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GDBM_FAST"))
! #ifdef GDBM_FAST
! return GDBM_FAST;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GDBM_FASTMODE"))
! #ifdef GDBM_FASTMODE
! return GDBM_FASTMODE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GDBM_INSERT"))
! #ifdef GDBM_INSERT
! return GDBM_INSERT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GDBM_NEWDB"))
! #ifdef GDBM_NEWDB
! return GDBM_NEWDB;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GDBM_NOLOCK"))
! #ifdef GDBM_NOLOCK
! return GDBM_NOLOCK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GDBM_READER"))
! #ifdef GDBM_READER
! return GDBM_READER;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GDBM_REPLACE"))
! #ifdef GDBM_REPLACE
! return GDBM_REPLACE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GDBM_WRCREAT"))
! #ifdef GDBM_WRCREAT
! return GDBM_WRCREAT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "GDBM_WRITER"))
! #ifdef GDBM_WRITER
! return GDBM_WRITER;
! #else
! goto not_there;
! #endif
! break;
! case 'H':
! break;
! case 'I':
! break;
! case 'J':
! break;
! case 'K':
! break;
! case 'L':
! break;
! case 'M':
! break;
! case 'N':
! break;
! case 'O':
! break;
! case 'P':
! break;
! case 'Q':
! break;
! case 'R':
! break;
! case 'S':
! break;
! case 'T':
! break;
! case 'U':
! break;
! case 'V':
! break;
! case 'W':
! break;
! case 'X':
! break;
! case 'Y':
! break;
! case 'Z':
! break;
! }
! errno = EINVAL;
! return 0;
- not_there:
- errno = ENOENT;
- return 0;
- }
-
MODULE = GDBM_File PACKAGE = GDBM_File PREFIX = gdbm_
! double
! constant(name,arg)
! char * name
! int arg
!
GDBM_File
gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak)
--- 76,86 ----
#define gdbm_setopt(db,optflag,optval,optlen) not_here("gdbm_setopt")
#endif
! #include "constants.c"
MODULE = GDBM_File PACKAGE = GDBM_File PREFIX = gdbm_
! INCLUDE: constants.xs
GDBM_File
gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak)
diff -c 'perl-5.7.1/ext/GDBM_File/Makefile.PL' 'perl-5.7.2/ext/GDBM_File/Makefile.PL'
Index: ./ext/GDBM_File/Makefile.PL
*** ./ext/GDBM_File/Makefile.PL Tue Mar 6 04:04:51 2001
--- ./ext/GDBM_File/Makefile.PL Mon Jul 9 17:10:02 2001
***************
*** 1,4 ****
--- 1,5 ----
use ExtUtils::MakeMaker;
+ use ExtUtils::Constant 0.07 'WriteConstants';
WriteMakefile(
NAME => 'GDBM_File',
LIBS => ["-L/usr/local/lib -lgdbm", "-ldbm"],
***************
*** 5,8 ****
--- 6,18 ----
MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes', # XXX remove later?
VERSION_FROM => 'GDBM_File.pm',
+ realclean => {FILES=> 'constants.c constants.xs'},
+ );
+ WriteConstants(
+ NAME => 'GDBM_File',
+ DEFAULT_TYPE => 'IV',
+ BREAKOUT_AT => 8,
+ NAMES => [qw(GDBM_CACHESIZE GDBM_FAST GDBM_FASTMODE GDBM_INSERT GDBM_NEWDB
+ GDBM_NOLOCK GDBM_READER GDBM_REPLACE GDBM_WRCREAT
+ GDBM_WRITER)],
);
diff -c /dev/null 'perl-5.7.2/ext/GDBM_File/gdbm.t'
Index: ./ext/GDBM_File/gdbm.t
*** ./ext/GDBM_File/gdbm.t Thu Jan 1 02:00:00 1970
--- ./ext/GDBM_File/gdbm.t Mon Jul 9 17:10:02 2001
***************
*** 0 ****
--- 1,427 ----
+ #!./perl
+
+ # $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bGDBM_File\b/) {
+ print "1..0 # Skip: GDBM_File was not built\n";
+ exit 0;
+ }
+ }
+
+ use strict;
+ use warnings;
+
+
+ use GDBM_File;
+
+ print "1..68\n";
+
+ unlink <Op.dbmx*>;
+
+ umask(0);
+ my %h ;
+ print (tie(%h,'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 1\n" : "not ok 1\n");
+
+ my $Dfile = "Op.dbmx.pag";
+ if (! -e $Dfile) {
+ ($Dfile) = <Op.dbmx*>;
+ }
+ if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin') {
+ print "ok 2 # Skipped: different file permission semantics\n";
+ }
+ else {
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
+ }
+ my $i = 0;
+ while (my ($key,$value) = each(%h)) {
+ $i++;
+ }
+ print (!$i ? "ok 3\n" : "not ok 3\n");
+
+ $h{'goner1'} = 'snork';
+
+ $h{'abc'} = 'ABC';
+ $h{'def'} = 'DEF';
+ $h{'jkl','mno'} = "JKL\034MNO";
+ $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+ $h{'a'} = 'A';
+ $h{'b'} = 'B';
+ $h{'c'} = 'C';
+ $h{'d'} = 'D';
+ $h{'e'} = 'E';
+ $h{'f'} = 'F';
+ $h{'g'} = 'G';
+ $h{'h'} = 'H';
+ $h{'i'} = 'I';
+
+ $h{'goner2'} = 'snork';
+ delete $h{'goner2'};
+
+ untie(%h);
+ print (tie(%h,'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 4\n" : "not ok 4\n");
+
+ $h{'j'} = 'J';
+ $h{'k'} = 'K';
+ $h{'l'} = 'L';
+ $h{'m'} = 'M';
+ $h{'n'} = 'N';
+ $h{'o'} = 'O';
+ $h{'p'} = 'P';
+ $h{'q'} = 'Q';
+ $h{'r'} = 'R';
+ $h{'s'} = 'S';
+ $h{'t'} = 'T';
+ $h{'u'} = 'U';
+ $h{'v'} = 'V';
+ $h{'w'} = 'W';
+ $h{'x'} = 'X';
+ $h{'y'} = 'Y';
+ $h{'z'} = 'Z';
+
+ $h{'goner3'} = 'snork';
+
+ delete $h{'goner1'};
+ delete $h{'goner3'};
+
+ my @keys = keys(%h);
+ my @values = values(%h);
+
+ if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
+
+ while (my ($key,$value) = each(%h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+ }
+
+ if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
+
+ @keys = ('blurfl', keys(%h), 'dyick');
+ if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
+
+ $h{'foo'} = '';
+ $h{''} = 'bar';
+
+ # check cache overflow and numeric keys and contents
+ my $ok = 1;
+ for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+ for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+ print ($ok ? "ok 8\n" : "not ok 8\n");
+
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ print ($size > 0 ? "ok 9\n" : "not ok 9\n");
+
+ @h{0..200} = 200..400;
+ my @foo = @h{0..200};
+ print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";
+
+ print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
+ print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
+
+ untie %h;
+ unlink 'Op.dbmx.dir', $Dfile;
+
+ sub ok
+ {
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+ }
+
+ {
+ # sub-class test
+
+ package Another ;
+
+ use strict ;
+ use warnings ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use strict ;
+ use vars qw(@ISA @EXPORT) ;
+
+ require Exporter ;
+ use GDBM_File;
+ @ISA=qw(GDBM_File);
+ @EXPORT = @GDBM_File::EXPORT ;
+
+ sub STORE {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::STORE($key, $value * 2) ;
+ }
+
+ sub FETCH {
+ my $self = shift ;
+ my $key = shift ;
+ $self->SUPER::FETCH($key) - 1 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+ EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+ unlink <dbhash.tmp*> ;
+
+ eval 'use SubDB ; ';
+ main::ok(13, $@ eq "") ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB","dbhash.tmp", &GDBM_WRCREAT, 0640 );
+ ' ;
+
+ main::ok(14, $@ eq "") ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ main::ok(15, $@ eq "") ;
+ main::ok(16, $ret == 5) ;
+
+ $ret = eval ' &GDBM_WRCREAT eq &main::GDBM_WRCREAT ' ;
+ main::ok(17, $@ eq "" ) ;
+ main::ok(18, $ret == 1) ;
+
+ $ret = eval '$X->A_new_method("fred") ' ;
+ main::ok(19, $@ eq "") ;
+ main::ok(20, $ret eq "[[5]]") ;
+
+ undef $X;
+ untie(%h);
+ unlink "SubDB.pm", <dbhash.tmp*> ;
+
+ }
+
+ {
+ # DBM Filter tests
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ unlink <Op.dbmx*>;
+ ok(21, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ;
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok(22, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(23, $h{"fred"} eq "joe");
+ # fk sk fv sv
+ ok(24, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(25, $db->FIRSTKEY() eq "fred") ;
+ # fk sk fv sv
+ ok(26, checkOutput( "fred", "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok(27, checkOutput( "", "fred", "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(28, $h{"Fred"} eq "[Jxe]");
+ # fk sk fv sv
+ ok(29, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(30, $db->FIRSTKEY() eq "FRED") ;
+ # fk sk fv sv
+ ok(31, checkOutput( "FRED", "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(32, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(33, $h{"fred"} eq "joe");
+ ok(34, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(35, $db->FIRSTKEY() eq "fred") ;
+ ok(36, checkOutput( "fred", "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(37, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(38, $h{"fred"} eq "joe");
+ ok(39, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(40, $db->FIRSTKEY() eq "fred") ;
+ ok(41, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+ }
+
+ {
+ # DBM Filter with a closure
+
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+
+ unlink <Op.dbmx*>;
+ ok(42, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ;
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(43, $result{"store key"} eq "store key - 1: [fred]");
+ ok(44, $result{"store value"} eq "store value - 1: [joe]");
+ ok(45, !defined $result{"fetch key"} );
+ ok(46, !defined $result{"fetch value"} );
+ ok(47, $_ eq "original") ;
+
+ ok(48, $db->FIRSTKEY() eq "fred") ;
+ ok(49, $result{"store key"} eq "store key - 1: [fred]");
+ ok(50, $result{"store value"} eq "store value - 1: [joe]");
+ ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(52, ! defined $result{"fetch value"} );
+ ok(53, $_ eq "original") ;
+
+ $h{"jim"} = "john" ;
+ ok(54, $result{"store key"} eq "store key - 2: [fred jim]");
+ ok(55, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(57, ! defined $result{"fetch value"} );
+ ok(58, $_ eq "original") ;
+
+ ok(59, $h{"fred"} eq "joe");
+ ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]");
+ ok(61, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(64, $_ eq "original") ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+ }
+
+ {
+ # DBM Filter recursion detection
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+ unlink <Op.dbmx*>;
+
+ ok(65, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ;
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok(66, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+ }
+
+ {
+ # Bug ID 20001013.009
+ #
+ # test that $hash{KEY} = undef doesn't produce the warning
+ # Use of uninitialized value in null operation
+ use warnings ;
+ use strict ;
+ use GDBM_File ;
+
+ unlink <Op.dbmx*>;
+ my %h ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ ok(67, tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640));
+ $h{ABC} = undef;
+ ok(68, $a eq "") ;
+ untie %h;
+ unlink <Op.dbmx*>;
+ }
diff -c /dev/null 'perl-5.7.2/ext/I18N/Langinfo/Langinfo.pm'
Index: ./ext/I18N/Langinfo/Langinfo.pm
*** ./ext/I18N/Langinfo/Langinfo.pm Thu Jan 1 02:00:00 1970
--- ./ext/I18N/Langinfo/Langinfo.pm Mon Jul 9 17:10:02 2001
***************
*** 0 ****
--- 1,199 ----
+ package I18N::Langinfo;
+
+ use 5.006;
+ use strict;
+ use warnings;
+ use Carp;
+
+ require Exporter;
+ require DynaLoader;
+ use AutoLoader;
+
+ our @ISA = qw(Exporter DynaLoader);
+
+ our @EXPORT = qw(langinfo);
+
+ our @EXPORT_OK = qw(
+ ABDAY_1
+ ABDAY_2
+ ABDAY_3
+ ABDAY_4
+ ABDAY_5
+ ABDAY_6
+ ABDAY_7
+ ABMON_1
+ ABMON_10
+ ABMON_11
+ ABMON_12
+ ABMON_2
+ ABMON_3
+ ABMON_4
+ ABMON_5
+ ABMON_6
+ ABMON_7
+ ABMON_8
+ ABMON_9
+ ALT_DIGITS
+ AM_STR
+ CODESET
+ CRNCYSTR
+ DAY_1
+ DAY_2
+ DAY_3
+ DAY_4
+ DAY_5
+ DAY_6
+ DAY_7
+ D_FMT
+ D_T_FMT
+ ERA
+ ERA_D_FMT
+ ERA_D_T_FMT
+ ERA_T_FMT
+ MON_1
+ MON_10
+ MON_11
+ MON_12
+ MON_2
+ MON_3
+ MON_4
+ MON_5
+ MON_6
+ MON_7
+ MON_8
+ MON_9
+ NOEXPR
+ NOSTR
+ PM_STR
+ RADIXCHAR
+ THOUSEP
+ T_FMT
+ T_FMT_AMPM
+ YESEXPR
+ YESSTR
+ );
+
+ our $VERSION = '0.01';
+
+ sub AUTOLOAD {
+ # This AUTOLOAD is used to 'autoload' constants from the constant()
+ # XS function.
+
+ my $constname;
+ our $AUTOLOAD;
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ croak "&I18N::Langinfo::constant not defined" if $constname eq 'constant';
+ my ($error, $val) = constant($constname);
+ if ($error) { croak $error; }
+ {
+ no strict 'refs';
+ # Fixed between 5.005_53 and 5.005_61
+ #XXX if ($] >= 5.00561) {
+ #XXX *$AUTOLOAD = sub () { $val };
+ #XXX }
+ #XXX else {
+ *$AUTOLOAD = sub { $val };
+ #XXX }
+ }
+ goto &$AUTOLOAD;
+ }
+
+ bootstrap I18N::Langinfo $VERSION;
+
+ 1;
+ __END__
+
+ =head1 NAME
+
+ I18N::Langinfo - query locale information
+
+ =head1 SYNOPSIS
+
+ use I18N::Langinfo;
+
+ =head1 DESCRIPTION
+
+ The langinfo() function queries various locale information that can be
+ used to localize output and user interfaces. The langinfo() requires
+ one numeric argument that identifies the locale constant to query:
+ if no argument is supplied, C<$_> is used. The numeric constants
+ appropriate to be used as arguments are exportable from I18N::Langinfo.
+
+ The following example will import the langinfo() function itself and
+ three constants to be used as arguments to langinfo(): a constant for
+ the abbreviated first day of the week (the numbering starts from
+ Sunday = 1) and two more constants for the affirmative and negative
+ answers for a yes/no question in the current locale.
+
+ use I18N::Langinfo qw(langinfo ABDAY_1 YESSTR NOSTR);
+
+ my ($abday_1, $yesstr, $nostr) = map { langinfo } qw(ABDAY_1 YESSTR NOSTR);
+
+ print "$abday_1? [$yesstr/$nostr] ";
+
+ In other words, in the "C" (or English) locale the above will probably
+ print something like:
+
+ Sun? [yes/no]
+
+ The usually available constants are
+
+ ABDAY_1 ABDAY_2 ABDAY_3 ABDAY_4 ABDAY_5 ABDAY_6 ABDAY_7
+ ABMON_1 ABMON_2 ABMON_3 ABMON_4 ABMON_5 ABMON_6
+ ABMON_7 ABMON_8 ABMON_9 ABMON_10 ABMON_11 ABMON_12
+ DAY_1 DAY_2 DAY_3 DAY_4 DAY_5 DAY_6 DAY_7
+ MON_1 MON_2 MON_3 MON_4 MON_5 MON_6
+ MON_7 MON_8 MON_9 MON_10 MON_11 MON_12
+
+ for abbreviated and full length days of the week and months of the year,
+
+ D_T_FMT D_FMT T_FMT
+
+ for the date-time, date, and time formats used by the strftime() function
+ (see L<POSIX>, and also L<Time::Piece>),
+
+ AM_STR PM_STR T_FMT_AMPM
+
+ for the locales for which it makes sense to have ante meridiem and post
+ meridiem time formats,
+
+ CODESET CRNCYSTR RADIXCHAR
+
+ for the character code set being used (such as "ISO8859-1", "cp850",
+ "koi8-r", "sjis", "utf8", etc.), for the currency string, for the
+ radix character (yes, this is redundant with POSIX::localeconv())
+
+ YESSTR YESEXPR NOSTR NOEXPR
+
+ for the affirmative and negative responses and expressions, and
+
+ ERA ERA_D_FMT ERA_D_T_FMT ERA_T_FMT
+
+ for the Japanese Emperor eras (naturally only defined under Japanese locales).
+
+ See your L<langinfo(3)> for more information about the available
+ constants. (Often this means having to look directly at the
+ F<langinfo.h> C header file.)
+
+ =head2 EXPORT
+
+ Nothing is exported by default.
+
+ =head1 SEE ALSO
+
+ L<perllocale>, L<POSIX/localeconv>, L<POSIX/setlocale>, L<nl_langinfo(3)>.
+
+ The langinfo() is just a wrapper for the C nl_langinfo() interface.
+
+ =head1 AUTHOR
+
+ Jarkko Hietaniemi, E<lt>jhi@hut.fiE<gt>
+
+ =head1 COPYRIGHT AND LICENSE
+
+ Copyright 2001 by Jarkko Hietaniemi
+
+ This library is free software; you can redistribute it and/or modify
+ it under the same terms as Perl itself.
+
+ =cut
diff -c /dev/null 'perl-5.7.2/ext/I18N/Langinfo/Langinfo.t'
Index: ./ext/I18N/Langinfo/Langinfo.t
*** ./ext/I18N/Langinfo/Langinfo.t Thu Jan 1 02:00:00 1970
--- ./ext/I18N/Langinfo/Langinfo.t Fri Jul 13 02:58:19 2001
***************
*** 0 ****
--- 1,36 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ m!\bI18N/Langinfo\b! ||
+ $Config{'extensions'} !~ m!\bPOSIX\b!)
+ {
+ print "1..0 # skip: I18N::Langinfo or POSIX unavailable\n";
+ exit 0;
+ }
+ }
+
+ use I18N::Langinfo qw(langinfo ABDAY_1 DAY_1 ABMON_1 MON_1 RADIXCHAR);
+ use POSIX qw(setlocale LC_ALL);
+
+ setlocale(LC_ALL, "C");
+
+ print "1..5\n";
+
+ print "not " unless langinfo(ABDAY_1) eq "Sun";
+ print "ok 1\n";
+
+ print "not " unless langinfo(DAY_1) eq "Sunday";
+ print "ok 2\n";
+
+ print "not " unless langinfo(ABMON_1) eq "Jan";
+ print "ok 3\n";
+
+ print "not " unless langinfo(MON_1) eq "January";
+ print "ok 4\n";
+
+ print "not " unless langinfo(RADIXCHAR) eq ".";
+ print "ok 5\n";
+
diff -c /dev/null 'perl-5.7.2/ext/I18N/Langinfo/Langinfo.xs'
Index: ./ext/I18N/Langinfo/Langinfo.xs
*** ./ext/I18N/Langinfo/Langinfo.xs Thu Jan 1 02:00:00 1970
--- ./ext/I18N/Langinfo/Langinfo.xs Mon Jul 9 17:10:03 2001
***************
*** 0 ****
--- 1,836 ----
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+
+ #ifdef I_LANGINFO
+ # include <langinfo.h>
+ #endif
+
+ #define PERL_constant_NOTFOUND 1
+ #define PERL_constant_NOTDEF 2
+ #define PERL_constant_ISIV 3
+ #define PERL_constant_ISNO 4
+ #define PERL_constant_ISNV 5
+ #define PERL_constant_ISPV 6
+ #define PERL_constant_ISPVN 7
+ #define PERL_constant_ISSV 8
+ #define PERL_constant_ISUNDEF 9
+ #define PERL_constant_ISUV 10
+ #define PERL_constant_ISYES 11
+
+ #ifndef NVTYPE
+ typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
+ #endif
+ static int
+ constant_5 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DAY_1 DAY_2 DAY_3 DAY_4 DAY_5 DAY_6 DAY_7 D_FMT MON_1 MON_2 MON_3 MON_4
+ MON_5 MON_6 MON_7 MON_8 MON_9 NOSTR T_FMT */
+ /* Offset 4 gives the best switch position. */
+ switch (name[4]) {
+ case '1':
+ if (memEQ(name, "DAY_1", 5)) {
+ /* ^ */
+ #ifdef DAY_1
+ *iv_return = DAY_1;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ if (memEQ(name, "MON_1", 5)) {
+ /* ^ */
+ #ifdef MON_1
+ *iv_return = MON_1;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case '2':
+ if (memEQ(name, "DAY_2", 5)) {
+ /* ^ */
+ #ifdef DAY_2
+ *iv_return = DAY_2;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ if (memEQ(name, "MON_2", 5)) {
+ /* ^ */
+ #ifdef MON_2
+ *iv_return = MON_2;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case '3':
+ if (memEQ(name, "DAY_3", 5)) {
+ /* ^ */
+ #ifdef DAY_3
+ *iv_return = DAY_3;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ if (memEQ(name, "MON_3", 5)) {
+ /* ^ */
+ #ifdef MON_3
+ *iv_return = MON_3;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case '4':
+ if (memEQ(name, "DAY_4", 5)) {
+ /* ^ */
+ #ifdef DAY_4
+ *iv_return = DAY_4;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ if (memEQ(name, "MON_4", 5)) {
+ /* ^ */
+ #ifdef MON_4
+ *iv_return = MON_4;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case '5':
+ if (memEQ(name, "DAY_5", 5)) {
+ /* ^ */
+ #ifdef DAY_5
+ *iv_return = DAY_5;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ if (memEQ(name, "MON_5", 5)) {
+ /* ^ */
+ #ifdef MON_5
+ *iv_return = MON_5;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case '6':
+ if (memEQ(name, "DAY_6", 5)) {
+ /* ^ */
+ #ifdef DAY_6
+ *iv_return = DAY_6;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ if (memEQ(name, "MON_6", 5)) {
+ /* ^ */
+ #ifdef MON_6
+ *iv_return = MON_6;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case '7':
+ if (memEQ(name, "DAY_7", 5)) {
+ /* ^ */
+ #ifdef DAY_7
+ *iv_return = DAY_7;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ if (memEQ(name, "MON_7", 5)) {
+ /* ^ */
+ #ifdef MON_7
+ *iv_return = MON_7;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case '8':
+ if (memEQ(name, "MON_8", 5)) {
+ /* ^ */
+ #ifdef MON_8
+ *iv_return = MON_8;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case '9':
+ if (memEQ(name, "MON_9", 5)) {
+ /* ^ */
+ #ifdef MON_9
+ *iv_return = MON_9;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "NOSTR", 5)) {
+ /* ^ */
+ #ifdef NOSTR
+ *iv_return = NOSTR;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "D_FMT", 5)) {
+ /* ^ */
+ #ifdef D_FMT
+ *iv_return = D_FMT;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ if (memEQ(name, "T_FMT", 5)) {
+ /* ^ */
+ #ifdef T_FMT
+ *iv_return = T_FMT;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+ }
+
+ static int
+ constant_6 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ AM_STR MON_10 MON_11 MON_12 NOEXPR PM_STR YESSTR */
+ /* Offset 0 gives the best switch position. */
+ switch (name[0]) {
+ case 'A':
+ if (memEQ(name, "AM_STR", 6)) {
+ /* ^ */
+ #ifdef AM_STR
+ *iv_return = AM_STR;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case 'M':
+ if (memEQ(name, "MON_10", 6)) {
+ /* ^ */
+ #ifdef MON_10
+ *iv_return = MON_10;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ if (memEQ(name, "MON_11", 6)) {
+ /* ^ */
+ #ifdef MON_11
+ *iv_return = MON_11;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ if (memEQ(name, "MON_12", 6)) {
+ /* ^ */
+ #ifdef MON_12
+ *iv_return = MON_12;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "NOEXPR", 6)) {
+ /* ^ */
+ #ifdef NOEXPR
+ *iv_return = NOEXPR;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "PM_STR", 6)) {
+ /* ^ */
+ #ifdef PM_STR
+ *iv_return = PM_STR;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case 'Y':
+ if (memEQ(name, "YESSTR", 6)) {
+ /* ^ */
+ #ifdef YESSTR
+ *iv_return = YESSTR;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+ }
+
+ static int
+ constant_7 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ ABDAY_1 ABDAY_2 ABDAY_3 ABDAY_4 ABDAY_5 ABDAY_6 ABDAY_7 ABMON_1 ABMON_2
+ ABMON_3 ABMON_4 ABMON_5 ABMON_6 ABMON_7 ABMON_8 ABMON_9 CODESET D_T_FMT
+ THOUSEP YESEXPR */
+ /* Offset 6 gives the best switch position. */
+ switch (name[6]) {
+ case '1':
+ if (memEQ(name, "ABDAY_1", 7)) {
+ /* ^ */
+ #ifdef ABDAY_1
+ *iv_return = ABDAY_1;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ if (memEQ(name, "ABMON_1", 7)) {
+ /* ^ */
+ #ifdef ABMON_1
+ *iv_return = ABMON_1;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case '2':
+ if (memEQ(name, "ABDAY_2", 7)) {
+ /* ^ */
+ #ifdef ABDAY_2
+ *iv_return = ABDAY_2;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ if (memEQ(name, "ABMON_2", 7)) {
+ /* ^ */
+ #ifdef ABMON_2
+ *iv_return = ABMON_2;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case '3':
+ if (memEQ(name, "ABDAY_3", 7)) {
+ /* ^ */
+ #ifdef ABDAY_3
+ *iv_return = ABDAY_3;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ if (memEQ(name, "ABMON_3", 7)) {
+ /* ^ */
+ #ifdef ABMON_3
+ *iv_return = ABMON_3;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case '4':
+ if (memEQ(name, "ABDAY_4", 7)) {
+ /* ^ */
+ #ifdef ABDAY_4
+ *iv_return = ABDAY_4;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ if (memEQ(name, "ABMON_4", 7)) {
+ /* ^ */
+ #ifdef ABMON_4
+ *iv_return = ABMON_4;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case '5':
+ if (memEQ(name, "ABDAY_5", 7)) {
+ /* ^ */
+ #ifdef ABDAY_5
+ *iv_return = ABDAY_5;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ if (memEQ(name, "ABMON_5", 7)) {
+ /* ^ */
+ #ifdef ABMON_5
+ *iv_return = ABMON_5;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case '6':
+ if (memEQ(name, "ABDAY_6", 7)) {
+ /* ^ */
+ #ifdef ABDAY_6
+ *iv_return = ABDAY_6;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ if (memEQ(name, "ABMON_6", 7)) {
+ /* ^ */
+ #ifdef ABMON_6
+ *iv_return = ABMON_6;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case '7':
+ if (memEQ(name, "ABDAY_7", 7)) {
+ /* ^ */
+ #ifdef ABDAY_7
+ *iv_return = ABDAY_7;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ if (memEQ(name, "ABMON_7", 7)) {
+ /* ^ */
+ #ifdef ABMON_7
+ *iv_return = ABMON_7;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case '8':
+ if (memEQ(name, "ABMON_8", 7)) {
+ /* ^ */
+ #ifdef ABMON_8
+ *iv_return = ABMON_8;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case '9':
+ if (memEQ(name, "ABMON_9", 7)) {
+ /* ^ */
+ #ifdef ABMON_9
+ *iv_return = ABMON_9;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "THOUSEP", 7)) {
+ /* ^ */
+ #ifdef THOUSEP
+ *iv_return = THOUSEP;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "YESEXPR", 7)) {
+ /* ^ */
+ #ifdef YESEXPR
+ *iv_return = YESEXPR;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "CODESET", 7)) {
+ /* ^ */
+ #ifdef CODESET
+ *iv_return = CODESET;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ if (memEQ(name, "D_T_FMT", 7)) {
+ /* ^ */
+ #ifdef D_T_FMT
+ *iv_return = D_T_FMT;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+ }
+
+ static int
+ constant_8 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ ABMON_10 ABMON_11 ABMON_12 CRNCYSTR */
+ /* Offset 7 gives the best switch position. */
+ switch (name[7]) {
+ case '0':
+ if (memEQ(name, "ABMON_10", 8)) {
+ /* ^ */
+ #ifdef ABMON_10
+ *iv_return = ABMON_10;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case '1':
+ if (memEQ(name, "ABMON_11", 8)) {
+ /* ^ */
+ #ifdef ABMON_11
+ *iv_return = ABMON_11;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case '2':
+ if (memEQ(name, "ABMON_12", 8)) {
+ /* ^ */
+ #ifdef ABMON_12
+ *iv_return = ABMON_12;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "CRNCYSTR", 8)) {
+ /* ^ */
+ #ifdef CRNCYSTR
+ *iv_return = CRNCYSTR;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+ }
+
+ static int
+ constant_9 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ ERA_D_FMT ERA_T_FMT RADIXCHAR */
+ /* Offset 4 gives the best switch position. */
+ switch (name[4]) {
+ case 'D':
+ if (memEQ(name, "ERA_D_FMT", 9)) {
+ /* ^ */
+ #ifdef ERA_D_FMT
+ *iv_return = ERA_D_FMT;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "ERA_T_FMT", 9)) {
+ /* ^ */
+ #ifdef ERA_T_FMT
+ *iv_return = ERA_T_FMT;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case 'X':
+ if (memEQ(name, "RADIXCHAR", 9)) {
+ /* ^ */
+ #ifdef RADIXCHAR
+ *iv_return = RADIXCHAR;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+ }
+
+ static int
+ constant (pTHX_ const char *name, STRLEN len, IV *iv_return) {
+ /* Initially switch on the length of the name. */
+ /* When generated this function returned values for the list of names given
+ in this section of perl code. Rather than manually editing these functions
+ to add or remove constants, which would result in this comment and section
+ of code becoming inaccurate, we recommend that you edit this section of
+ code, and use it to regenerate a new set of constant functions which you
+ then use to replace the originals.
+
+ Regenerate these constant functions by feeding this entire source file to
+ perl -x
+
+ #!../../../perl -w
+ use ExtUtils::Constant qw (constant_types C_constant XS_constant);
+
+ my $types = {map {($_, 1)} qw(IV)};
+ my @names = (qw(ABDAY_1 ABDAY_2 ABDAY_3 ABDAY_4 ABDAY_5 ABDAY_6 ABDAY_7 ABMON_1
+ ABMON_10 ABMON_11 ABMON_12 ABMON_2 ABMON_3 ABMON_4 ABMON_5
+ ABMON_6 ABMON_7 ABMON_8 ABMON_9 ALT_DIGITS AM_STR CODESET
+ CRNCYSTR DAY_1 DAY_2 DAY_3 DAY_4 DAY_5 DAY_6 DAY_7 D_FMT D_T_FMT
+ ERA ERA_D_FMT ERA_D_T_FMT ERA_T_FMT MON_1 MON_10 MON_11 MON_12
+ MON_2 MON_3 MON_4 MON_5 MON_6 MON_7 MON_8 MON_9 NOEXPR NOSTR
+ PM_STR RADIXCHAR THOUSEP T_FMT T_FMT_AMPM YESEXPR YESSTR));
+
+ print constant_types(); # macro defs
+ foreach (C_constant ("I18N::Langinfo", 'constant', 'IV', $types, undef, 3, @names) ) {
+ print $_, "\n"; # C constant subs
+ }
+ print "#### XS Section:\n";
+ print XS_constant ("I18N::Langinfo", $types);
+ __END__
+ */
+
+ switch (len) {
+ case 3:
+ if (memEQ(name, "ERA", 3)) {
+ #ifdef ERA
+ *iv_return = ERA;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case 5:
+ return constant_5 (aTHX_ name, iv_return);
+ break;
+ case 6:
+ return constant_6 (aTHX_ name, iv_return);
+ break;
+ case 7:
+ return constant_7 (aTHX_ name, iv_return);
+ break;
+ case 8:
+ return constant_8 (aTHX_ name, iv_return);
+ break;
+ case 9:
+ return constant_9 (aTHX_ name, iv_return);
+ break;
+ case 10:
+ /* Names all of length 10. */
+ /* ALT_DIGITS T_FMT_AMPM */
+ /* Offset 7 gives the best switch position. */
+ switch (name[7]) {
+ case 'I':
+ if (memEQ(name, "ALT_DIGITS", 10)) {
+ /* ^ */
+ #ifdef ALT_DIGITS
+ *iv_return = ALT_DIGITS;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ case 'M':
+ if (memEQ(name, "T_FMT_AMPM", 10)) {
+ /* ^ */
+ #ifdef T_FMT_AMPM
+ *iv_return = T_FMT_AMPM;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ }
+ break;
+ case 11:
+ if (memEQ(name, "ERA_D_T_FMT", 11)) {
+ #ifdef ERA_D_T_FMT
+ *iv_return = ERA_D_T_FMT;
+ return PERL_constant_ISIV;
+ #else
+ return PERL_constant_NOTDEF;
+ #endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+ }
+
+ MODULE = I18N::Langinfo PACKAGE = I18N::Langinfo
+
+ PROTOTYPES: ENABLE
+
+ void
+ constant(sv)
+ PREINIT:
+ #ifdef dXSTARG
+ dXSTARG; /* Faster if we have it. */
+ #else
+ dTARGET;
+ #endif
+ STRLEN len;
+ int type;
+ IV iv;
+ /* NV nv; Uncomment this if you need to return NVs */
+ /* const char *pv; Uncomment this if you need to return PVs */
+ INPUT:
+ SV * sv;
+ const char * s = SvPV(sv, len);
+ PPCODE:
+ /* Change this to constant(aTHX_ s, len, &iv, &nv);
+ if you need to return both NVs and IVs */
+ type = constant(aTHX_ s, len, &iv);
+ /* Return 1 or 2 items. First is error message, or undef if no error.
+ Second, if present, is found value */
+ switch (type) {
+ case PERL_constant_NOTFOUND:
+ sv = sv_2mortal(newSVpvf("%s is not a valid I18N::Langinfo macro", s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_NOTDEF:
+ sv = sv_2mortal(newSVpvf(
+ "Your vendor has not defined I18N::Langinfo macro %s, used", s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_ISIV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHi(iv);
+ break;
+ /* Uncomment this if you need to return NOs
+ case PERL_constant_ISNO:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_no);
+ break; */
+ /* Uncomment this if you need to return NVs
+ case PERL_constant_ISNV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHn(nv);
+ break; */
+ /* Uncomment this if you need to return PVs
+ case PERL_constant_ISPV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, strlen(pv));
+ break; */
+ /* Uncomment this if you need to return PVNs
+ case PERL_constant_ISPVN:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, iv);
+ break; */
+ /* Uncomment this if you need to return SVs
+ case PERL_constant_ISSV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(sv);
+ break; */
+ /* Uncomment this if you need to return UNDEFs
+ case PERL_constant_ISUNDEF:
+ break; */
+ /* Uncomment this if you need to return UVs
+ case PERL_constant_ISUV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHu((UV)iv);
+ break; */
+ /* Uncomment this if you need to return YESs
+ case PERL_constant_ISYES:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_yes);
+ break; */
+ default:
+ sv = sv_2mortal(newSVpvf(
+ "Unexpected return type %d while processing I18N::Langinfo macro %s, used",
+ type, s));
+ PUSHs(sv);
+ }
+
+ SV*
+ langinfo(code)
+ int code
+ CODE:
+ #ifdef HAS_NL_LANGINFO
+ char *s = nl_langinfo(code);
+ RETVAL = newSVpvn(s, strlen(s));
+ #else
+ croak("nl_langinfo() not implemented on this architecture");
+ #endif
+ OUTPUT:
+ RETVAL
diff -c /dev/null 'perl-5.7.2/ext/I18N/Langinfo/Makefile.PL'
Index: ./ext/I18N/Langinfo/Makefile.PL
*** ./ext/I18N/Langinfo/Makefile.PL Thu Jan 1 02:00:00 1970
--- ./ext/I18N/Langinfo/Makefile.PL Mon Jul 9 17:10:03 2001
***************
*** 0 ****
--- 1,17 ----
+ use ExtUtils::MakeMaker;
+ # See lib/ExtUtils/MakeMaker.pm for details of how to influence
+ # the contents of the Makefile that is written.
+ WriteMakefile(
+ 'NAME' => 'I18N::Langinfo',
+ 'VERSION_FROM' => 'Langinfo.pm', # finds $VERSION
+ 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1
+ ($] >= 5.005 ? ## Add these new keywords supported since 5.005
+ (ABSTRACT_FROM => 'Langinfo.pm', # retrieve abstract from module
+ AUTHOR => 'Jarkko Hietaniemi <jhi@hut.fi>') : ()),
+ 'LIBS' => [''], # e.g., '-lm'
+ 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING'
+ # Insert -I. if you add *.h files later:
+ 'INC' => '', # e.g., '-I/usr/include/other'
+ # Un-comment this if you add C files to link with later:
+ # 'OBJECT' => '$(O_FILES)', # link all the C files too
+ );
diff -c 'perl-5.7.1/ext/IO/IO.xs' 'perl-5.7.2/ext/IO/IO.xs'
Index: ./ext/IO/IO.xs
*** ./ext/IO/IO.xs Sun Apr 8 21:12:20 2001
--- ./ext/IO/IO.xs Mon Jul 9 17:10:03 2001
***************
*** 361,393 ****
RETVAL
void
! setbuf(handle, buf)
OutputStream handle
- char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0;
CODE:
if (handle)
#ifdef PERLIO_IS_STDIO
setbuf(handle, buf);
#else
not_here("IO::Handle::setbuf");
#endif
SysRet
! setvbuf(handle, buf, type, size)
! OutputStream handle
! char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
! int type
! int size
CODE:
#if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF)
if (!handle) /* Try input stream. */
handle = IoIFP(sv_2io(ST(0)));
! if (handle)
RETVAL = setvbuf(handle, buf, type, size);
else {
RETVAL = -1;
errno = EINVAL;
}
#else
RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
#endif
--- 361,407 ----
RETVAL
void
! setbuf(handle, ...)
OutputStream handle
CODE:
if (handle)
#ifdef PERLIO_IS_STDIO
+ {
+ char *buf = items == 2 && SvPOK(ST(1)) ?
+ sv_grow(ST(1), BUFSIZ) : 0;
setbuf(handle, buf);
+ }
#else
not_here("IO::Handle::setbuf");
#endif
SysRet
! setvbuf(...)
CODE:
+ if (items != 4)
+ Perl_croak(aTHX_ "Usage: IO::Handle::setvbuf(handle, buf, type, size)");
#if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF)
+ {
+ OutputStream handle = 0;
+ char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
+ int type;
+ int size;
+
+ if (items == 4) {
+ handle = IoOFP(sv_2io(ST(0)));
+ buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
+ type = (int)SvIV(ST(2));
+ size = (int)SvIV(ST(3));
+ }
if (!handle) /* Try input stream. */
handle = IoIFP(sv_2io(ST(0)));
! if (items == 4 && handle)
RETVAL = setvbuf(handle, buf, type, size);
else {
RETVAL = -1;
errno = EINVAL;
}
+ }
#else
RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
#endif
***************
*** 430,436 ****
{
int flag = 0;
# ifdef SIOCATMARK
! if (ioctl(fd, SIOCATMARK, &flag) != 0)
XSRETURN_UNDEF;
# else
not_here("IO::Socket::atmark");
--- 444,454 ----
{
int flag = 0;
# ifdef SIOCATMARK
! #ifdef NETWARE
! if (ioctl(fd, SIOCATMARK, (void*)&flag) != 0)
! #else
! if (ioctl(fd, SIOCATMARK, &flag) != 0)
! #endif
XSRETURN_UNDEF;
# else
not_here("IO::Socket::atmark");
diff -c 'perl-5.7.1/ext/IO/lib/IO/Dir.pm' 'perl-5.7.2/ext/IO/lib/IO/Dir.pm'
Index: ./ext/IO/lib/IO/Dir.pm
*** ./ext/IO/lib/IO/Dir.pm Tue Mar 6 04:04:51 2001
--- ./ext/IO/lib/IO/Dir.pm Mon Jul 9 17:10:03 2001
***************
*** 6,12 ****
package IO::Dir;
! use 5.003_26;
use strict;
use Carp;
--- 6,12 ----
package IO::Dir;
! use 5.6.0;
use strict;
use Carp;
***************
*** 16,24 ****
our(@ISA, $VERSION, @EXPORT_OK);
use Tie::Hash;
use File::stat;
@ISA = qw(Tie::Hash Exporter);
! $VERSION = "1.03";
@EXPORT_OK = qw(DIR_UNLINK);
sub DIR_UNLINK () { 1 }
--- 16,25 ----
our(@ISA, $VERSION, @EXPORT_OK);
use Tie::Hash;
use File::stat;
+ use File::Spec;
@ISA = qw(Tie::Hash Exporter);
! $VERSION = "1.03_00";
@EXPORT_OK = qw(DIR_UNLINK);
sub DIR_UNLINK () { 1 }
***************
*** 44,49 ****
--- 45,53 ----
my ($dh, $dirname) = @_;
return undef
unless opendir($dh, $dirname);
+ # a dir name should always have a ":" in it; assume dirname is
+ # in current directory
+ $dirname = ':' . $dirname if ( ($^O eq 'MacOS') && ($dirname !~ /:/) );
${*$dh}{io_dir_path} = $dirname;
1;
}
***************
*** 103,120 ****
sub EXISTS {
my($dh,$key) = @_;
! -e ${*$dh}{io_dir_path} . "/" . $key;
}
sub FETCH {
my($dh,$key) = @_;
! &lstat(${*$dh}{io_dir_path} . "/" . $key);
}
sub STORE {
my($dh,$key,$data) = @_;
my($atime,$mtime) = ref($data) ? @$data : ($data,$data);
! my $file = ${*$dh}{io_dir_path} . "/" . $key;
unless(-e $file) {
my $io = IO::File->new($file,O_CREAT | O_RDWR);
$io->close if $io;
--- 107,124 ----
sub EXISTS {
my($dh,$key) = @_;
! -e File::Spec->catfile(${*$dh}{io_dir_path}, $key);
}
sub FETCH {
my($dh,$key) = @_;
! &lstat(File::Spec->catfile(${*$dh}{io_dir_path}, $key));
}
sub STORE {
my($dh,$key,$data) = @_;
my($atime,$mtime) = ref($data) ? @$data : ($data,$data);
! my $file = File::Spec->catfile(${*$dh}{io_dir_path}, $key);
unless(-e $file) {
my $io = IO::File->new($file,O_CREAT | O_RDWR);
$io->close if $io;
***************
*** 125,131 ****
sub DELETE {
my($dh,$key) = @_;
# Only unlink if unlink-ing is enabled
! my $file = ${*$dh}{io_dir_path} . "/" . $key;
return 0
unless ${*$dh}{io_dir_unlink};
--- 129,135 ----
sub DELETE {
my($dh,$key) = @_;
# Only unlink if unlink-ing is enabled
! my $file = File::Spec->catfile(${*$dh}{io_dir_path}, $key);
return 0
unless ${*$dh}{io_dir_unlink};
diff -c 'perl-5.7.1/ext/IO/lib/IO/Handle.pm' 'perl-5.7.2/ext/IO/lib/IO/Handle.pm'
Index: ./ext/IO/lib/IO/Handle.pm
*** ./ext/IO/lib/IO/Handle.pm Fri Mar 16 04:54:47 2001
--- ./ext/IO/lib/IO/Handle.pm Mon Jul 9 17:10:03 2001
***************
*** 258,264 ****
require Exporter;
@ISA = qw(Exporter);
! $VERSION = "1.21";
@EXPORT_OK = qw(
autoflush
--- 258,264 ----
require Exporter;
@ISA = qw(Exporter);
! $VERSION = "1.21_00";
@EXPORT_OK = qw(
autoflush
diff -c 'perl-5.7.1/ext/IO/lib/IO/Seekable.pm' 'perl-5.7.2/ext/IO/lib/IO/Seekable.pm'
Index: ./ext/IO/lib/IO/Seekable.pm
*** ./ext/IO/lib/IO/Seekable.pm Fri Mar 16 04:54:47 2001
--- ./ext/IO/lib/IO/Seekable.pm Mon Jul 9 17:10:03 2001
***************
*** 41,47 ****
=over 4
! =item $io->setpos ( POS, WHENCE )
Seek the IO::File to position POS, relative to WHENCE:
--- 41,47 ----
=over 4
! =item $io->seek ( POS, WHENCE )
Seek the IO::File to position POS, relative to WHENCE:
***************
*** 55,61 ****
POS is an offset from the current position. (Seek relative to current)
! =item WHENCE=1 (SEEK_END)
POS is an offset from the end of the file. (Seek relative to end)
--- 55,61 ----
POS is an offset from the current position. (Seek relative to current)
! =item WHENCE=2 (SEEK_END)
POS is an offset from the end of the file. (Seek relative to end)
***************
*** 107,113 ****
@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END);
@ISA = qw(Exporter);
! $VERSION = "1.08";
sub seek {
@_ == 3 or croak 'usage: $io->seek(POS, WHENCE)';
--- 107,113 ----
@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END);
@ISA = qw(Exporter);
! $VERSION = "1.08_00";
sub seek {
@_ == 3 or croak 'usage: $io->seek(POS, WHENCE)';
diff -c 'perl-5.7.1/ext/IO/lib/IO/Select.pm' 'perl-5.7.2/ext/IO/lib/IO/Select.pm'
Index: ./ext/IO/lib/IO/Select.pm
*** ./ext/IO/lib/IO/Select.pm Tue Mar 6 04:04:52 2001
--- ./ext/IO/lib/IO/Select.pm Mon Jul 9 17:10:03 2001
***************
*** 11,17 ****
use vars qw($VERSION @ISA);
require Exporter;
! $VERSION = "1.14";
@ISA = qw(Exporter); # This is only so we can do version checking
--- 11,17 ----
use vars qw($VERSION @ISA);
require Exporter;
! $VERSION = "1.15";
@ISA = qw(Exporter); # This is only so we can do version checking
diff -c 'perl-5.7.1/ext/IO/lib/IO/Socket.pm' 'perl-5.7.2/ext/IO/lib/IO/Socket.pm'
Index: ./ext/IO/lib/IO/Socket.pm
*** ./ext/IO/lib/IO/Socket.pm Fri Apr 6 02:05:46 2001
--- ./ext/IO/lib/IO/Socket.pm Mon Jul 9 17:10:03 2001
***************
*** 112,118 ****
$blocking = $sock->blocking(0) if $timeout;
if (!connect($sock, $addr)) {
! if ($timeout && $!{EINPROGRESS}) {
require IO::Select;
my $sel = new IO::Select $sock;
--- 112,118 ----
$blocking = $sock->blocking(0) if $timeout;
if (!connect($sock, $addr)) {
! if (defined $timeout && $!{EINPROGRESS}) {
require IO::Select;
my $sel = new IO::Select $sock;
***************
*** 168,174 ****
my $new = $pkg->new(Timeout => $timeout);
my $peer = undef;
! if($timeout) {
require IO::Select;
my $sel = new IO::Select $sock;
--- 168,174 ----
my $new = $pkg->new(Timeout => $timeout);
my $peer = undef;
! if(defined $timeout) {
require IO::Select;
my $sel = new IO::Select $sock;
***************
*** 369,381 ****
=item accept([PKG])
! perform the system call C<accept> on the socket and return a new object. The
! new object will be created in the same class as the listen socket, unless
! C<PKG> is specified. This object can be used to communicate with the client
! that was trying to connect. In a scalar context the new socket is returned,
! or undef upon failure. In a list context a two-element array is returned
! containing the new socket and the peer address; the list will
! be empty upon failure.
=item socketpair(DOMAIN, TYPE, PROTOCOL)
--- 369,389 ----
=item accept([PKG])
! perform the system call C<accept> on the socket and return a new
! object. The new object will be created in the same class as the listen
! socket, unless C<PKG> is specified. This object can be used to
! communicate with the client that was trying to connect.
!
! In a scalar context the new socket is returned, or undef upon
! failure. In a list context a two-element array is returned containing
! the new socket and the peer address; the list will be empty upon
! failure.
!
! The timeout in the [PKG] can be specified as zero to effect a "poll",
! but you shouldn't do that because a new IO::Select object will be
! created behind the scenes just do to the single poll. This is
! horrendously inefficient. Use rather true select() with a zero
! timeout on the handle, or non-blocking IO.
=item socketpair(DOMAIN, TYPE, PROTOCOL)
diff -c 'perl-5.7.1/ext/IO/lib/IO/Socket/INET.pm' 'perl-5.7.2/ext/IO/lib/IO/Socket/INET.pm'
Index: ./ext/IO/lib/IO/Socket/INET.pm
*** ./ext/IO/lib/IO/Socket/INET.pm Tue Mar 6 04:04:52 2001
--- ./ext/IO/lib/IO/Socket/INET.pm Mon Jul 9 17:10:03 2001
***************
*** 15,21 ****
use Errno;
@ISA = qw(IO::Socket);
! $VERSION = "1.25";
my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1;
--- 15,21 ----
use Errno;
@ISA = qw(IO::Socket);
! $VERSION = "1.26";
my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1;
***************
*** 63,69 ****
@serv = getservbyname($port, $proto[0] || "")
if ($port =~ m,\D,);
! $port = $pnum || $serv[2] || $defport || undef;
unless (defined $port) {
$@ = "Bad service '$origport'";
return;
--- 63,69 ----
@serv = getservbyname($port, $proto[0] || "")
if ($port =~ m,\D,);
! $port = $serv[2] || $defport || $pnum;
unless (defined $port) {
$@ = "Bad service '$origport'";
return;
***************
*** 84,90 ****
my $err = shift;
{
local($!);
! $@ = join("",ref($sock),": ",@_);
close($sock)
if(defined fileno($sock));
}
--- 84,91 ----
my $err = shift;
{
local($!);
! my $title = ref($sock).": ";
! $@ = join("", $_[0] =~ /^$title/ ? "" : $title, @_);
close($sock)
if(defined fileno($sock));
}
***************
*** 189,200 ****
# my $timeout = ${*$sock}{'io_socket_timeout'};
# my $before = time() if $timeout;
if ($sock->connect(pack_sockaddr_in($rport, $raddr))) {
# ${*$sock}{'io_socket_timeout'} = $timeout;
return $sock;
}
! return _error($sock, $!, "Timeout")
unless @raddr;
# if ($timeout) {
--- 190,202 ----
# my $timeout = ${*$sock}{'io_socket_timeout'};
# my $before = time() if $timeout;
+ undef $@;
if ($sock->connect(pack_sockaddr_in($rport, $raddr))) {
# ${*$sock}{'io_socket_timeout'} = $timeout;
return $sock;
}
! return _error($sock, $!, $@ || "Timeout")
unless @raddr;
# if ($timeout) {
diff -c 'perl-5.7.1/ext/IO/lib/IO/Socket/UNIX.pm' 'perl-5.7.2/ext/IO/lib/IO/Socket/UNIX.pm'
Index: ./ext/IO/lib/IO/Socket/UNIX.pm
*** ./ext/IO/lib/IO/Socket/UNIX.pm Fri Mar 16 04:54:47 2001
--- ./ext/IO/lib/IO/Socket/UNIX.pm Mon Jul 9 17:10:04 2001
***************
*** 13,19 ****
use Carp;
@ISA = qw(IO::Socket);
! $VERSION = "1.20";
IO::Socket::UNIX->register_domain( AF_UNIX );
--- 13,19 ----
use Carp;
@ISA = qw(IO::Socket);
! $VERSION = "1.20_00";
IO::Socket::UNIX->register_domain( AF_UNIX );
diff -c /dev/null 'perl-5.7.2/ext/IO/lib/IO/t/io_const.t'
Index: ./ext/IO/lib/IO/t/io_const.t
*** ./ext/IO/lib/IO/t/io_const.t Thu Jan 1 02:00:00 1970
--- ./ext/IO/lib/IO/t/io_const.t Mon Jul 9 17:10:04 2001
***************
*** 0 ****
--- 1,33 ----
+
+ BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+
+ use Config;
+
+ BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+ }
+
+ use IO::Handle;
+
+ print "1..6\n";
+ my $i = 1;
+ foreach (qw(SEEK_SET SEEK_CUR SEEK_END _IOFBF _IOLBF _IONBF)) {
+ my $d1 = defined(&{"IO::Handle::" . $_}) ? 1 : 0;
+ my $v1 = $d1 ? &{"IO::Handle::" . $_}() : undef;
+ my $v2 = IO::Handle::constant($_);
+ my $d2 = defined($v2);
+
+ print "not "
+ if($d1 != $d2 || ($d1 && ($v1 != $v2)));
+ print "ok ",$i++,"\n";
+ }
diff -c /dev/null 'perl-5.7.2/ext/IO/lib/IO/t/io_dir.t'
Index: ./ext/IO/lib/IO/t/io_dir.t
*** ./ext/IO/lib/IO/t/io_dir.t Thu Jan 1 02:00:00 1970
--- ./ext/IO/lib/IO/t/io_dir.t Mon Jul 9 17:10:04 2001
***************
*** 0 ****
--- 1,68 ----
+ #!./perl
+
+ BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ require Config; import Config;
+ if ($] < 5.00326 || not $Config{'d_readdir'}) {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ select(STDERR); $| = 1;
+ select(STDOUT); $| = 1;
+
+ use IO::Dir qw(DIR_UNLINK);
+
+ print "1..10\n";
+
+ my $DIR = $^O eq 'MacOS' ? ":" : ".";
+
+ $dot = new IO::Dir $DIR;
+ print defined($dot) ? "ok" : "not ok", " 1\n";
+
+ @a = sort <*>;
+ do { $first = $dot->read } while defined($first) && $first =~ /^\./;
+ print +(grep { $_ eq $first } @a) ? "ok" : "not ok", " 2\n";
+
+ @b = sort($first, (grep {/^[^.]/} $dot->read));
+ print +(join("\0", @a) eq join("\0", @b)) ? "ok" : "not ok", " 3\n";
+
+ $dot->rewind;
+ @c = sort grep {/^[^.]/} $dot->read;
+ print +(join("\0", @b) eq join("\0", @c)) ? "ok" : "not ok", " 4\n";
+
+ $dot->close;
+ $dot->rewind;
+ print defined($dot->read) ? "not ok" : "ok", " 5\n";
+
+ open(FH,'>X') || die "Can't create x";
+ print FH "X";
+ close(FH);
+
+ tie %dir, IO::Dir, $DIR;
+ my @files = keys %dir;
+
+ # I hope we do not have an empty dir :-)
+ print @files ? "ok" : "not ok", " 6\n";
+
+ my $stat = $dir{'X'};
+ print defined($stat) && UNIVERSAL::isa($stat,'File::stat') && $stat->size == 1
+ ? "ok" : "not ok", " 7\n";
+
+ delete $dir{'X'};
+
+ print -f 'X' ? "ok" : "not ok", " 8\n";
+
+ tie %dirx, IO::Dir, $DIR, DIR_UNLINK;
+
+ my $statx = $dirx{'X'};
+ print defined($statx) && UNIVERSAL::isa($statx,'File::stat') && $statx->size == 1
+ ? "ok" : "not ok", " 9\n";
+
+ delete $dirx{'X'};
+
+ print -f 'X' ? "not ok" : "ok", " 10\n";
diff -c /dev/null 'perl-5.7.2/ext/IO/lib/IO/t/io_dup.t'
Index: ./ext/IO/lib/IO/t/io_dup.t
*** ./ext/IO/lib/IO/t/io_dup.t Thu Jan 1 02:00:00 1970
--- ./ext/IO/lib/IO/t/io_dup.t Mon Jul 9 17:10:04 2001
***************
*** 0 ****
--- 1,61 ----
+ #!./perl
+
+ BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+
+ use Config;
+
+ BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+ }
+
+ use IO::Handle;
+ use IO::File;
+
+ select(STDERR); $| = 1;
+ select(STDOUT); $| = 1;
+
+ print "1..6\n";
+
+ print "ok 1\n";
+
+ $dupout = IO::Handle->new->fdopen( \*STDOUT ,"w");
+ $duperr = IO::Handle->new->fdopen( \*STDERR ,"w");
+
+ $stdout = \*STDOUT; bless $stdout, "IO::File"; # "IO::Handle";
+ $stderr = \*STDERR; bless $stderr, "IO::Handle";
+
+ $stdout->open( "Io.dup","w") || die "Can't open stdout";
+ $stderr->fdopen($stdout,"w");
+
+ print $stdout "ok 2\n";
+ print $stderr "ok 3\n";
+ if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
+ print `echo ok 4`;
+ print `echo ok 5 1>&2`; # does this *really* work?
+ }
+ else {
+ system 'echo ok 4';
+ system 'echo ok 5 1>&2';
+ }
+
+ $stderr->close;
+ $stdout->close;
+
+ $stdout->fdopen($dupout,"w");
+ $stderr->fdopen($duperr,"w");
+
+ if ($^O eq 'MSWin32' || $^O eq 'NetWare') { print `type Io.dup` }
+ else { system 'cat Io.dup' }
+ unlink 'Io.dup';
+
+ print STDOUT "ok 6\n";
diff -c /dev/null 'perl-5.7.2/ext/IO/lib/IO/t/io_linenum.t'
Index: ./ext/IO/lib/IO/t/io_linenum.t
*** ./ext/IO/lib/IO/t/io_linenum.t Thu Jan 1 02:00:00 1970
--- ./ext/IO/lib/IO/t/io_linenum.t Mon Jul 9 17:10:04 2001
***************
*** 0 ****
--- 1,80 ----
+ #!./perl
+
+ # test added 29th April 1999 by Paul Johnson (pjcj@transeda.com)
+ # updated 28th May 1999 by Paul Johnson
+
+ my $File;
+
+ BEGIN
+ {
+ $File = __FILE__;
+ if (-d 't')
+ {
+ chdir 't';
+ $File =~ s/^t\W+//; # Remove first directory
+ }
+ @INC = '../lib';
+ require strict; import strict;
+ }
+
+ use Test;
+
+ BEGIN { plan tests => 12 }
+
+ use IO::File;
+
+ sub lineno
+ {
+ my ($f) = @_;
+ my $l;
+ $l .= "$. ";
+ $l .= $f->input_line_number;
+ $l .= " $."; # check $. before and after input_line_number
+ $l;
+ }
+
+ my $t;
+
+ open (F, $File) or die $!;
+ my $io = IO::File->new($File) or die $!;
+
+ <F> for (1 .. 10);
+ ok(lineno($io), "10 0 10");
+
+ $io->getline for (1 .. 5);
+ ok(lineno($io), "5 5 5");
+
+ <F>;
+ ok(lineno($io), "11 5 11");
+
+ $io->getline;
+ ok(lineno($io), "6 6 6");
+
+ $t = tell F; # tell F; provokes a warning
+ ok(lineno($io), "11 6 11");
+
+ <F>;
+ ok(lineno($io), "12 6 12");
+
+ select F;
+ ok(lineno($io), "12 6 12");
+
+ <F> for (1 .. 10);
+ ok(lineno($io), "22 6 22");
+
+ $io->getline for (1 .. 5);
+ ok(lineno($io), "11 11 11");
+
+ $t = tell F;
+ # We used to have problems here before local $. worked.
+ # input_line_number() used to use select and tell. When we did the
+ # same, that mechanism broke. It should work now.
+ ok(lineno($io), "22 11 22");
+
+ {
+ local $.;
+ $io->getline for (1 .. 5);
+ ok(lineno($io), "16 16 16");
+ }
+
+ ok(lineno($io), "22 16 22");
diff -c /dev/null 'perl-5.7.2/ext/IO/lib/IO/t/io_multihomed.t'
Index: ./ext/IO/lib/IO/t/io_multihomed.t
*** ./ext/IO/lib/IO/t/io_multihomed.t Thu Jan 1 02:00:00 1970
--- ./ext/IO/lib/IO/t/io_multihomed.t Mon Jul 9 17:10:04 2001
***************
*** 0 ****
--- 1,128 ----
+ #!./perl
+
+ BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+
+ use Config;
+
+ BEGIN {
+ if(-d "lib" && -f "TEST") {
+ my $reason;
+ if (! $Config{'d_fork'}) {
+ $reason = 'no fork';
+ }
+ elsif ($Config{'extensions'} !~ /\bSocket\b/) {
+ $reason = 'Socket extension unavailable';
+ }
+ elsif ($Config{'extensions'} !~ /\bIO\b/) {
+ $reason = 'IO extension unavailable';
+ }
+ if ($reason) {
+ print "1..0 # Skip: $reason\n";
+ exit 0;
+ }
+ }
+ }
+
+ $| = 1;
+
+ print "1..8\n";
+
+ eval {
+ $SIG{ALRM} = sub { die; };
+ alarm 60;
+ };
+
+ package Multi;
+ require IO::Socket::INET;
+ @ISA=qw(IO::Socket::INET);
+
+ use Socket qw(inet_aton inet_ntoa unpack_sockaddr_in);
+
+ sub _get_addr
+ {
+ my($sock,$addr_str, $multi) = @_;
+ #print "_get_addr($sock, $addr_str, $multi)\n";
+
+ print "not " unless $multi;
+ print "ok 2\n";
+
+ (
+ # private IP-addresses which I hope does not work anywhere :-)
+ inet_aton("10.250.230.10"),
+ inet_aton("10.250.230.12"),
+ inet_aton("127.0.0.1") # loopback
+ )
+ }
+
+ sub connect
+ {
+ my $self = shift;
+ if (@_ == 1) {
+ my($port, $addr) = unpack_sockaddr_in($_[0]);
+ $addr = inet_ntoa($addr);
+ #print "connect($self, $port, $addr)\n";
+ if($addr eq "10.250.230.10") {
+ print "ok 3\n";
+ return 0;
+ }
+ if($addr eq "10.250.230.12") {
+ print "ok 4\n";
+ return 0;
+ }
+ }
+ $self->SUPER::connect(@_);
+ }
+
+
+
+ package main;
+
+ use IO::Socket;
+
+ $listen = IO::Socket::INET->new(Listen => 2,
+ Proto => 'tcp',
+ Timeout => 5,
+ ) or die "$!";
+
+ print "ok 1\n";
+
+ $port = $listen->sockport;
+
+ if($pid = fork()) {
+
+ $sock = $listen->accept() or die "$!";
+ print "ok 5\n";
+
+ print $sock->getline();
+ print $sock "ok 7\n";
+
+ waitpid($pid,0);
+
+ $sock->close;
+
+ print "ok 8\n";
+
+ } elsif(defined $pid) {
+
+ $sock = Multi->new(PeerPort => $port,
+ Proto => 'tcp',
+ PeerAddr => 'localhost',
+ MultiHomed => 1,
+ Timeout => 1,
+ ) or die "$!";
+
+ print $sock "ok 6\n";
+ sleep(1); # race condition
+ print $sock->getline();
+
+ $sock->close;
+
+ exit;
+ } else {
+ die;
+ }
diff -c /dev/null 'perl-5.7.2/ext/IO/lib/IO/t/io_pipe.t'
Index: ./ext/IO/lib/IO/t/io_pipe.t
*** ./ext/IO/lib/IO/t/io_pipe.t Thu Jan 1 02:00:00 1970
--- ./ext/IO/lib/IO/t/io_pipe.t Mon Jul 9 17:10:04 2001
***************
*** 0 ****
--- 1,123 ----
+ #!./perl
+
+ BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+
+ use Config;
+
+ BEGIN {
+ if(-d "lib" && -f "TEST") {
+ my $reason;
+ if (! $Config{'d_fork'}) {
+ $reason = 'no fork';
+ }
+ elsif ($Config{'extensions'} !~ /\bIO\b/) {
+ $reason = 'IO extension unavailable';
+ }
+ undef $reason if $^O eq 'VMS';
+ if ($reason) {
+ print "1..0 # Skip: $reason\n";
+ exit 0;
+ }
+ }
+ }
+
+ use IO::Pipe;
+
+ my $perl = './perl';
+
+ $| = 1;
+ print "1..10\n";
+
+ $pipe = new IO::Pipe->reader($perl, '-e', 'print "not ok 1\n"');
+ while (<$pipe>) {
+ s/^not //;
+ print;
+ }
+ $pipe->close or print "# \$!=$!\nnot ";
+ print "ok 2\n";
+
+ $cmd = 'BEGIN{$SIG{ALRM} = sub {print "not ok 4\n"; exit}; alarm 10} s/not //';
+ $pipe = new IO::Pipe->writer($perl, '-pe', $cmd);
+ print $pipe "not ok 3\n" ;
+ $pipe->close or print "# \$!=$!\nnot ";
+ print "ok 4\n";
+
+ # Check if can fork with dynamic extensions (bug in CRT):
+ if ($^O eq 'os2' and
+ system "$^X -I../lib -MOpcode -e 'defined fork or die' > /dev/null 2>&1") {
+ print "ok $_ # skipped: broken fork\n" for 5..10;
+ exit 0;
+ }
+
+ $pipe = new IO::Pipe;
+
+ $pid = fork();
+
+ if($pid)
+ {
+ $pipe->writer;
+ print $pipe "Xk 5\n";
+ print $pipe "oY 6\n";
+ $pipe->close;
+ wait;
+ }
+ elsif(defined $pid)
+ {
+ $pipe->reader;
+ $stdin = bless \*STDIN, "IO::Handle";
+ $stdin->fdopen($pipe,"r");
+ exec 'tr', 'YX', 'ko';
+ }
+ else
+ {
+ die "# error = $!";
+ }
+
+ $pipe = new IO::Pipe;
+ $pid = fork();
+
+ if($pid)
+ {
+ $pipe->reader;
+ while(<$pipe>) {
+ s/^not //;
+ print;
+ }
+ $pipe->close;
+ wait;
+ }
+ elsif(defined $pid)
+ {
+ $pipe->writer;
+
+ $stdout = bless \*STDOUT, "IO::Handle";
+ $stdout->fdopen($pipe,"w");
+ print STDOUT "not ok 7\n";
+ exec 'echo', 'not ok 8';
+ }
+ else
+ {
+ die;
+ }
+
+ $pipe = new IO::Pipe;
+ $pipe->writer;
+
+ $SIG{'PIPE'} = 'broken_pipe';
+
+ sub broken_pipe {
+ print "ok 9\n";
+ }
+
+ print $pipe "not ok 9\n";
+ $pipe->close;
+
+ sleep 1;
+
+ print "ok 10\n";
+
diff -c /dev/null 'perl-5.7.2/ext/IO/lib/IO/t/io_poll.t'
Index: ./ext/IO/lib/IO/t/io_poll.t
*** ./ext/IO/lib/IO/t/io_poll.t Thu Jan 1 02:00:00 1970
--- ./ext/IO/lib/IO/t/io_poll.t Mon Jul 9 17:10:04 2001
***************
*** 0 ****
--- 1,82 ----
+ #!./perl
+
+ BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+
+ if ($^O eq 'mpeix') {
+ print "1..0 # Skip: broken on MPE/iX\n";
+ exit 0;
+ }
+
+ select(STDERR); $| = 1;
+ select(STDOUT); $| = 1;
+
+ print "1..9\n";
+
+ use IO::Handle;
+ use IO::Poll qw(/POLL/);
+
+ my $poll = new IO::Poll;
+
+ my $stdout = \*STDOUT;
+ my $dupout = IO::Handle->new_from_fd(fileno($stdout),"w");
+
+ $poll->mask($stdout => POLLOUT);
+
+ print "not "
+ unless $poll->mask($stdout) == POLLOUT;
+ print "ok 1\n";
+
+ $poll->mask($dupout => POLLPRI);
+
+ print "not "
+ unless $poll->mask($dupout) == POLLPRI;
+ print "ok 2\n";
+
+ $poll->poll(0.1);
+
+ if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
+ print "ok 3 # skipped, doesn't work on non-socket fds\n";
+ print "ok 4 # skipped, doesn't work on non-socket fds\n";
+ }
+ else {
+ print "not "
+ unless $poll->events($stdout) == POLLOUT;
+ print "ok 3\n";
+
+ print "not "
+ if $poll->events($dupout);
+ print "ok 4\n";
+ }
+
+ my @h = $poll->handles;
+ print "not "
+ unless @h == 2;
+ print "ok 5\n";
+
+ $poll->remove($stdout);
+
+ @h = $poll->handles;
+
+ print "not "
+ unless @h == 1;
+ print "ok 6\n";
+
+ print "not "
+ if $poll->mask($stdout);
+ print "ok 7\n";
+
+ $poll->poll(0.1);
+
+ print "not "
+ if $poll->events($stdout);
+ print "ok 8\n";
+
+ $poll->remove($dupout);
+ print "not "
+ if $poll->handles;
+ print "ok 9\n";
diff -c /dev/null 'perl-5.7.2/ext/IO/lib/IO/t/io_sel.t'
Index: ./ext/IO/lib/IO/t/io_sel.t
*** ./ext/IO/lib/IO/t/io_sel.t Thu Jan 1 02:00:00 1970
--- ./ext/IO/lib/IO/t/io_sel.t Mon Jul 9 17:10:04 2001
***************
*** 0 ****
--- 1,132 ----
+ #!./perl
+
+ BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+
+ select(STDERR); $| = 1;
+ select(STDOUT); $| = 1;
+
+ print "1..23\n";
+
+ use IO::Select 1.09;
+
+ my $sel = new IO::Select(\*STDIN);
+ $sel->add(4, 5) == 2 or print "not ";
+ print "ok 1\n";
+
+ $sel->add([\*STDOUT, 'foo']) == 1 or print "not ";
+ print "ok 2\n";
+
+ @handles = $sel->handles;
+ print "not " unless $sel->count == 4 && @handles == 4;
+ print "ok 3\n";
+ #print $sel->as_string, "\n";
+
+ $sel->remove(\*STDIN) == 1 or print "not ";
+ print "ok 4\n",
+ ;
+ $sel->remove(\*STDIN, 5, 6) == 1 # two of there are not present
+ or print "not ";
+ print "ok 5\n";
+
+ print "not " unless $sel->count == 2;
+ print "ok 6\n";
+ #print $sel->as_string, "\n";
+
+ $sel->remove(1, 4);
+ print "not " unless $sel->count == 0 && !defined($sel->bits);
+ print "ok 7\n";
+
+ $sel = new IO::Select;
+ print "not " unless $sel->count == 0 && !defined($sel->bits);
+ print "ok 8\n";
+
+ $sel->remove([\*STDOUT, 5]);
+ print "not " unless $sel->count == 0 && !defined($sel->bits);
+ print "ok 9\n";
+
+ if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos') { # 4-arg select is only valid on sockets
+ print "# skipping tests 10..15\n";
+ for (10 .. 15) { print "ok $_\n" }
+ $sel->add(\*STDOUT); # update
+ goto POST_SOCKET;
+ }
+
+ @a = $sel->can_read(); # should return imediately
+ print "not " unless @a == 0;
+ print "ok 10\n";
+
+ # we assume that we can write to STDOUT :-)
+ $sel->add([\*STDOUT, "ok 12\n"]);
+
+ @a = $sel->can_write;
+ print "not " unless @a == 1;
+ print "ok 11\n";
+
+ my($fd, $msg) = @{shift @a};
+ print $fd $msg;
+
+ $sel->add(\*STDOUT); # update
+
+ @a = IO::Select::select(undef, $sel, undef, 1);
+ print "not " unless @a == 3;
+ print "ok 13\n";
+
+ ($r, $w, $e) = @a;
+
+ print "not " unless @$r == 0 && @$w == 1 && @$e == 0;
+ print "ok 14\n";
+
+ $fd = $w->[0];
+ print $fd "ok 15\n";
+
+ POST_SOCKET:
+ # Test new exists() method
+ $sel->exists(\*STDIN) and print "not ";
+ print "ok 16\n";
+
+ ($sel->exists(0) || $sel->exists([\*STDERR])) and print "not ";
+ print "ok 17\n";
+
+ $fd = $sel->exists(\*STDOUT);
+ if ($fd) {
+ print $fd "ok 18\n";
+ } else {
+ print "not ok 18\n";
+ }
+
+ $fd = $sel->exists([1, 'foo']);
+ if ($fd) {
+ print $fd "ok 19\n";
+ } else {
+ print "not ok 19\n";
+ }
+
+ # Try self clearing
+ $sel->add(5,6,7,8,9,10);
+ print "not " unless $sel->count == 7;
+ print "ok 20\n";
+
+ $sel->remove($sel->handles);
+ print "not " unless $sel->count == 0 && !defined($sel->bits);
+ print "ok 21\n";
+
+ # check warnings
+ $SIG{__WARN__} = sub {
+ ++ $w
+ if $_[0] =~ /^Call to depreciated method 'has_error', use 'has_exception'/
+ } ;
+ $w = 0 ;
+ IO::Select::has_error();
+ print "not " unless $w == 0 ;
+ $w = 0 ;
+ print "ok 22\n" ;
+ use warnings 'IO::Select' ;
+ IO::Select::has_error();
+ print "not " unless $w == 1 ;
+ $w = 0 ;
+ print "ok 23\n" ;
diff -c /dev/null 'perl-5.7.2/ext/IO/lib/IO/t/io_sock.t'
Index: ./ext/IO/lib/IO/t/io_sock.t
*** ./ext/IO/lib/IO/t/io_sock.t Thu Jan 1 02:00:00 1970
--- ./ext/IO/lib/IO/t/io_sock.t Mon Jul 9 17:10:04 2001
***************
*** 0 ****
--- 1,348 ----
+ #!./perl
+
+ BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+
+ use Config;
+
+ BEGIN {
+ if (-d "lib" && -f "TEST") {
+ my $reason;
+ if (! $Config{'d_fork'}) {
+ $reason = 'no fork';
+ }
+ elsif ($Config{'extensions'} !~ /\bSocket\b/) {
+ $reason = 'Socket extension unavailable';
+ }
+ elsif ($Config{'extensions'} !~ /\bIO\b/) {
+ $reason = 'IO extension unavailable';
+ }
+ undef $reason if $^O eq 'VMS' and $Config{d_socket};
+ if ($reason) {
+ print "1..0 # Skip: $reason\n";
+ exit 0;
+ }
+ }
+ }
+
+ $| = 1;
+ print "1..20\n";
+
+ eval {
+ $SIG{ALRM} = sub { die; };
+ alarm 120;
+ };
+
+ use IO::Socket;
+
+ $listen = IO::Socket::INET->new(Listen => 2,
+ Proto => 'tcp',
+ # some systems seem to need as much as 10,
+ # so be generous with the timeout
+ Timeout => 15,
+ ) or die "$!";
+
+ print "ok 1\n";
+
+ # Check if can fork with dynamic extensions (bug in CRT):
+ if ($^O eq 'os2' and
+ system "$^X -I../lib -MOpcode -e 'defined fork or die' > /dev/null 2>&1") {
+ print "ok $_ # skipped: broken fork\n" for 2..5;
+ exit 0;
+ }
+
+ $port = $listen->sockport;
+
+ if($pid = fork()) {
+
+ $sock = $listen->accept() or die "accept failed: $!";
+ print "ok 2\n";
+
+ $sock->autoflush(1);
+ print $sock->getline();
+
+ print $sock "ok 4\n";
+
+ $sock->close;
+
+ waitpid($pid,0);
+
+ print "ok 5\n";
+
+ } elsif(defined $pid) {
+
+ $sock = IO::Socket::INET->new(PeerPort => $port,
+ Proto => 'tcp',
+ PeerAddr => 'localhost'
+ )
+ || IO::Socket::INET->new(PeerPort => $port,
+ Proto => 'tcp',
+ PeerAddr => '127.0.0.1'
+ )
+ or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
+
+ $sock->autoflush(1);
+
+ print $sock "ok 3\n";
+
+ print $sock->getline();
+
+ $sock->close;
+
+ exit;
+ } else {
+ die;
+ }
+
+ # Test various other ways to create INET sockets that should
+ # also work.
+ $listen = IO::Socket::INET->new(Listen => '', Timeout => 15) or die "$!";
+ $port = $listen->sockport;
+
+ if($pid = fork()) {
+ SERVER_LOOP:
+ while (1) {
+ last SERVER_LOOP unless $sock = $listen->accept;
+ while (<$sock>) {
+ last SERVER_LOOP if /^quit/;
+ last if /^done/;
+ print;
+ }
+ $sock = undef;
+ }
+ $listen->close;
+ } elsif (defined $pid) {
+ # child, try various ways to connect
+ $sock = IO::Socket::INET->new("localhost:$port")
+ || IO::Socket::INET->new("127.0.0.1:$port");
+ if ($sock) {
+ print "not " unless $sock->connected;
+ print "ok 6\n";
+ $sock->print("ok 7\n");
+ sleep(1);
+ print "ok 8\n";
+ $sock->print("ok 9\n");
+ $sock->print("done\n");
+ $sock->close;
+ }
+ else {
+ print "# $@\n";
+ print "not ok 6\n";
+ print "not ok 7\n";
+ print "not ok 8\n";
+ print "not ok 9\n";
+ }
+
+ # some machines seem to suffer from a race condition here
+ sleep(2);
+
+ $sock = IO::Socket::INET->new("127.0.0.1:$port");
+ if ($sock) {
+ $sock->print("ok 10\n");
+ $sock->print("done\n");
+ $sock->close;
+ }
+ else {
+ print "# $@\n";
+ print "not ok 10\n";
+ }
+
+ # some machines seem to suffer from a race condition here
+ sleep(1);
+
+ $sock = IO::Socket->new(Domain => AF_INET,
+ PeerAddr => "localhost:$port")
+ || IO::Socket->new(Domain => AF_INET,
+ PeerAddr => "127.0.0.1:$port");
+ if ($sock) {
+ $sock->print("ok 11\n");
+ $sock->print("quit\n");
+ } else {
+ print "not ok 11\n";
+ }
+ $sock = undef;
+ sleep(1);
+ exit;
+ } else {
+ die;
+ }
+
+ # Then test UDP sockets
+ $server = IO::Socket->new(Domain => AF_INET,
+ Proto => 'udp',
+ LocalAddr => 'localhost')
+ || IO::Socket->new(Domain => AF_INET,
+ Proto => 'udp',
+ LocalAddr => '127.0.0.1');
+ $port = $server->sockport;
+
+ if ($^O eq 'mpeix') {
+ print("ok 12 # skipped\n")
+ } else {
+ if ($pid = fork()) {
+ my $buf;
+ $server->recv($buf, 100);
+ print $buf;
+ } elsif (defined($pid)) {
+ #child
+ $sock = IO::Socket::INET->new(Proto => 'udp',
+ PeerAddr => "localhost:$port")
+ || IO::Socket::INET->new(Proto => 'udp',
+ PeerAddr => "127.0.0.1:$port");
+ $sock->send("ok 12\n");
+ sleep(1);
+ $sock->send("ok 12\n"); # send another one to be sure
+ exit;
+ } else {
+ die;
+ }
+ }
+
+ print "not " unless $server->blocking;
+ print "ok 13\n";
+
+ if ( $^O eq 'qnx' ) {
+ # QNX library bug: Can set non-blocking on socket, but
+ # cannot return that status.
+ print "ok 14 # skipped\n";
+ } else {
+ $server->blocking(0);
+ print "not " if $server->blocking;
+ print "ok 14\n";
+ }
+
+ ### TEST 15
+ ### Set up some data to be transfered between the server and
+ ### the client. We'll use own source code ...
+ #
+ local @data;
+ if( !open( SRC, "< $0")) {
+ print "not ok 15 - $!";
+ } else {
+ @data = <SRC>;
+ close( SRC);
+ }
+ print "ok 15\n";
+
+ ### TEST 16
+ ### Start the server
+ #
+ my $listen = IO::Socket::INET->new( Listen => 2, Proto => 'tcp', Timeout => 15) ||
+ print "not ";
+ print "ok 16\n";
+ die if( !defined( $listen));
+ my $serverport = $listen->sockport;
+
+ my $server_pid = fork();
+ if( $server_pid) {
+
+ ### TEST 17 Client/Server establishment
+ #
+ print "ok 17\n";
+
+ ### TEST 18
+ ### Get data from the server using a single stream
+ #
+ $sock = IO::Socket::INET->new("localhost:$serverport")
+ || IO::Socket::INET->new("127.0.0.1:$serverport");
+
+ if ($sock) {
+ $sock->print("send\n");
+
+ my @array = ();
+ while( <$sock>) {
+ push( @array, $_);
+ }
+
+ $sock->print("done\n");
+ $sock->close;
+
+ print "not " if( @array != @data);
+ } else {
+ print "not ";
+ }
+ print "ok 18\n";
+
+ ### TEST 19
+ ### Get data from the server using a stream, which is
+ ### interrupted by eof calls.
+ ### On perl-5.7.0@7673 this failed in a SOCKS environment, because eof
+ ### did an getc followed by an ungetc in order to check for the streams
+ ### end. getc(3) got replaced by the SOCKS funktion, which ended up in
+ ### a recv(2) call on the socket, while ungetc(3) put back a character
+ ### to an IO buffer, which never again was read.
+ #
+ if ($^O eq 'mpeix') {
+ print "ok 19 # skipped: broken on MPE/iX\n";
+ } else {
+ $sock = IO::Socket::INET->new("localhost:$serverport")
+ || IO::Socket::INET->new("127.0.0.1:$serverport");
+
+ if ($sock) {
+ $sock->print("send\n");
+
+ my @array = ();
+ while( !eof( $sock ) ){
+ while( <$sock>) {
+ push( @array, $_);
+ last;
+ }
+ }
+
+ $sock->print("done\n");
+ $sock->close;
+
+ print "not " if( @array != @data);
+ } else {
+ print "not ";
+ }
+ print "ok 19\n";
+ }
+
+ ### TEST 20
+ ### Stop the server
+ #
+ $sock = IO::Socket::INET->new("localhost:$serverport")
+ || IO::Socket::INET->new("127.0.0.1:$serverport");
+
+ if ($sock) {
+ $sock->print("done\n");
+ $sock->close;
+
+ print "not " if( 1 != kill 0, $server_pid);
+ } else {
+ print "not ";
+ }
+ print "ok 20\n";
+
+ } elsif( defined( $server_pid)) {
+
+ ### Child
+ #
+ SERVER_LOOP: while (1) {
+ last SERVER_LOOP unless $sock = $listen->accept;
+ while (<$sock>) {
+ last SERVER_LOOP if /^quit/;
+ last if /^done/;
+ if( /^send/) {
+ print $sock @data;
+ last;
+ }
+ print;
+ }
+ $sock = undef;
+ }
+ $listen->close;
+
+ } else {
+
+ ### Fork failed
+ #
+ print "not ok 17\n";
+ die;
+ }
+
diff -c /dev/null 'perl-5.7.2/ext/IO/lib/IO/t/io_taint.t'
Index: ./ext/IO/lib/IO/t/io_taint.t
*** ./ext/IO/lib/IO/t/io_taint.t Thu Jan 1 02:00:00 1970
--- ./ext/IO/lib/IO/t/io_taint.t Mon Jul 9 17:10:04 2001
***************
*** 0 ****
--- 1,48 ----
+ #!./perl -T
+
+ BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+
+ use Config;
+
+ BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+ }
+
+ END { unlink "./__taint__$$" }
+
+ print "1..3\n";
+ use IO::File;
+ $x = new IO::File "> ./__taint__$$" || die("Cannot open ./__taint__$$\n");
+ print $x "$$\n";
+ $x->close;
+
+ $x = new IO::File "< ./__taint__$$" || die("Cannot open ./__taint__$$\n");
+ chop($unsafe = <$x>);
+ eval { kill 0 * $unsafe };
+ print "not " if ((($^O ne 'MSWin32') && ($^O ne 'NetWare')) and ($@ !~ /^Insecure/o));
+ print "ok 1\n";
+ $x->close;
+
+ # We could have just done a seek on $x, but technically we haven't tested
+ # seek yet...
+ $x = new IO::File "< ./__taint__$$" || die("Cannot open ./__taint__$$\n");
+ $x->untaint;
+ print "not " if ($?);
+ print "ok 2\n"; # Calling the method worked
+ chop($unsafe = <$x>);
+ eval { kill 0 * $unsafe };
+ print "not " if ($@ =~ /^Insecure/o);
+ print "ok 3\n"; # No Insecure message from using the data
+ $x->close;
+
+ exit 0;
diff -c /dev/null 'perl-5.7.2/ext/IO/lib/IO/t/io_tell.t'
Index: ./ext/IO/lib/IO/t/io_tell.t
*** ./ext/IO/lib/IO/t/io_tell.t Thu Jan 1 02:00:00 1970
--- ./ext/IO/lib/IO/t/io_tell.t Mon Jul 9 17:10:04 2001
***************
*** 0 ****
--- 1,64 ----
+ #!./perl
+
+ BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ $tell_file = "TEST";
+ }
+ else {
+ $tell_file = "Makefile";
+ }
+ }
+
+ use Config;
+
+ BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+ }
+
+ print "1..13\n";
+
+ use IO::File;
+
+ $tst = IO::File->new("$tell_file","r") || die("Can't open $tell_file");
+ binmode $tst; # its a nop unless it matters. Was only if ($^O eq 'MSWin32' or $^O eq 'dos');
+ if ($tst->eof) { print "not ok 1\n"; } else { print "ok 1\n"; }
+
+ $firstline = <$tst>;
+ $secondpos = tell;
+
+ $x = 0;
+ while (<$tst>) {
+ if (eof) {$x++;}
+ }
+ if ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; }
+
+ $lastpos = tell;
+
+ unless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; }
+
+ if ($tst->seek(0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; }
+
+ if (eof) { print "not ok 5\n"; } else { print "ok 5\n"; }
+
+ if ($firstline eq <$tst>) { print "ok 6\n"; } else { print "not ok 6\n"; }
+
+ if ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; }
+
+ if ($tst->seek(0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; }
+
+ if ($tst->eof) { print "not ok 9\n"; } else { print "ok 9\n"; }
+
+ if ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; }
+
+ if ($tst->seek(0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; }
+
+ if ($lastpos == $tst->tell) { print "ok 12\n"; } else { print "not ok 12\n"; }
+
+ unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; }
diff -c /dev/null 'perl-5.7.2/ext/IO/lib/IO/t/io_udp.t'
Index: ./ext/IO/lib/IO/t/io_udp.t
*** ./ext/IO/lib/IO/t/io_udp.t Thu Jan 1 02:00:00 1970
--- ./ext/IO/lib/IO/t/io_udp.t Mon Jul 9 17:10:04 2001
***************
*** 0 ****
--- 1,94 ----
+ #!./perl
+
+ BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+
+ use Config;
+
+ BEGIN {
+ if(-d "lib" && -f "TEST") {
+ my $reason;
+
+ if ($Config{'extensions'} !~ /\bSocket\b/) {
+ $reason = 'Socket was not built';
+ }
+ elsif ($Config{'extensions'} !~ /\bIO\b/) {
+ $reason = 'IO was not built';
+ }
+ elsif ($^O eq 'apollo') {
+ $reason = "unknown *FIXME*";
+ }
+ undef $reason if $^O eq 'VMS' and $Config{d_socket};
+ if ($reason) {
+ print "1..0 # Skip: $reason\n";
+ exit 0;
+ }
+ }
+ }
+
+ sub compare_addr {
+ no utf8;
+ my $a = shift;
+ my $b = shift;
+ if (length($a) != length $b) {
+ my $min = (length($a) < length $b) ? length($a) : length $b;
+ if ($min and substr($a, 0, $min) eq substr($b, 0, $min)) {
+ printf "# Apparently: %d bytes junk at the end of %s\n# %s\n",
+ abs(length($a) - length ($b)),
+ $_[length($a) < length ($b) ? 1 : 0],
+ "consider decreasing bufsize of recfrom.";
+ substr($a, $min) = "";
+ substr($b, $min) = "";
+ }
+ return 0;
+ }
+ my @a = unpack_sockaddr_in($a);
+ my @b = unpack_sockaddr_in($b);
+ "$a[0]$a[1]" eq "$b[0]$b[1]";
+ }
+
+ $| = 1;
+ print "1..7\n";
+
+ use Socket;
+ use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY);
+
+ $udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
+ || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1')
+ or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
+
+ print "ok 1\n";
+
+ $udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
+ || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1')
+ or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
+
+ print "ok 2\n";
+
+ $udpa->send("ok 4\n",0,$udpb->sockname);
+
+ print "not "
+ unless compare_addr($udpa->peername,$udpb->sockname, 'peername', 'sockname');
+ print "ok 3\n";
+
+ my $where = $udpb->recv($buf="",5);
+ print $buf;
+
+ my @xtra = ();
+
+ unless(compare_addr($where,$udpa->sockname, 'recv name', 'sockname')) {
+ print "not ";
+ @xtra = (0,$udpa->sockname);
+ }
+ print "ok 5\n";
+
+ $udpb->send("ok 6\n",@xtra);
+ $udpa->recv($buf="",5);
+ print $buf;
+
+ print "not " if $udpa->connected;
+ print "ok 7\n";
diff -c /dev/null 'perl-5.7.2/ext/IO/lib/IO/t/io_unix.t'
Index: ./ext/IO/lib/IO/t/io_unix.t
*** ./ext/IO/lib/IO/t/io_unix.t Thu Jan 1 02:00:00 1970
--- ./ext/IO/lib/IO/t/io_unix.t Thu Jul 12 20:38:09 2001
***************
*** 0 ****
--- 1,89 ----
+ #!./perl
+
+ BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+
+ use Config;
+
+ BEGIN {
+ if(-d "lib" && -f "TEST") {
+ my $reason;
+ if (! $Config{'d_fork'}) {
+ $reason = 'no fork';
+ }
+ elsif ($Config{'extensions'} !~ /\bSocket\b/) {
+ $reason = 'Socket extension unavailable';
+ }
+ elsif ($Config{'extensions'} !~ /\bIO\b/) {
+ $reason = 'IO extension unavailable';
+ }
+ elsif ($^O eq 'os2') {
+ require IO::Socket;
+
+ eval {IO::Socket::pack_sockaddr_un('/tmp/foo') || 1}
+ or $@ !~ /not implemented/ or
+ $reason = 'compiled without TCP/IP stack v4';
+ } elsif ($^O =~ m/^(?:qnx|nto)$/ ) {
+ $reason = 'Not implemented';
+ }
+ undef $reason if $^O eq 'VMS' and $Config{d_socket};
+ if ($reason) {
+ print "1..0 # Skip: $reason\n";
+ exit 0;
+ }
+ }
+ }
+
+ $PATH = "/tmp/sock-$$";
+
+ # Test if we can create the file within the tmp directory
+ if (-e $PATH or not open(TEST, ">$PATH") and $^O ne 'os2') {
+ print "1..0 # Skip: cannot open '$PATH' for write\n";
+ exit 0;
+ }
+ close(TEST);
+ unlink($PATH) or $^O eq 'os2' or die "Can't unlink $PATH: $!";
+
+ # Start testing
+ $| = 1;
+ print "1..5\n";
+
+ use IO::Socket;
+
+ $listen = IO::Socket::UNIX->new(Local=>$PATH, Listen=>0) || die "$!";
+ print "ok 1\n";
+
+ if($pid = fork()) {
+
+ $sock = $listen->accept();
+ print "ok 2\n";
+
+ print $sock->getline();
+
+ print $sock "ok 4\n";
+
+ $sock->close;
+
+ waitpid($pid,0);
+ unlink($PATH) || $^O eq 'os2' || warn "Can't unlink $PATH: $!";
+
+ print "ok 5\n";
+
+ } elsif(defined $pid) {
+
+ $sock = IO::Socket::UNIX->new(Peer => $PATH) or die "$!";
+
+ print $sock "ok 3\n";
+
+ print $sock->getline();
+
+ $sock->close;
+
+ exit;
+ } else {
+ die;
+ }
diff -c /dev/null 'perl-5.7.2/ext/IO/lib/IO/t/io_xs.t'
Index: ./ext/IO/lib/IO/t/io_xs.t
*** ./ext/IO/lib/IO/t/io_xs.t Thu Jan 1 02:00:00 1970
--- ./ext/IO/lib/IO/t/io_xs.t Mon Jul 9 17:10:04 2001
***************
*** 0 ****
--- 1,43 ----
+ #!./perl
+
+ BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+
+ use Config;
+
+ BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+ }
+
+ use IO::File;
+ use IO::Seekable;
+
+ print "1..4\n";
+
+ $x = new_tmpfile IO::File or print "not ";
+ print "ok 1\n";
+ print $x "ok 2\n";
+ $x->seek(0,SEEK_SET);
+ print <$x>;
+
+ $x->seek(0,SEEK_SET);
+ print $x "not ok 3\n";
+ $p = $x->getpos;
+ print $x "ok 3\n";
+ $x->flush;
+ $x->setpos($p);
+ print scalar <$x>;
+
+ $! = 0;
+ $x->setpos(undef);
+ print $! ? "ok 4 # $!\n" : "not ok 4\n";
+
diff -c 'perl-5.7.1/ext/IPC/SysV/Msg.pm' 'perl-5.7.2/ext/IPC/SysV/Msg.pm'
Index: ./ext/IPC/SysV/Msg.pm
*** ./ext/IPC/SysV/Msg.pm Fri Mar 16 04:54:47 2001
--- ./ext/IPC/SysV/Msg.pm Mon Jul 9 17:10:07 2001
***************
*** 11,17 ****
use vars qw($VERSION);
use Carp;
! $VERSION = "1.00";
{
package IPC::Msg::stat;
--- 11,17 ----
use vars qw($VERSION);
use Carp;
! $VERSION = "1.00_00";
{
package IPC::Msg::stat;
diff -c 'perl-5.7.1/ext/IPC/SysV/Semaphore.pm' 'perl-5.7.2/ext/IPC/SysV/Semaphore.pm'
Index: ./ext/IPC/SysV/Semaphore.pm
*** ./ext/IPC/SysV/Semaphore.pm Fri Mar 16 04:54:47 2001
--- ./ext/IPC/SysV/Semaphore.pm Mon Jul 9 17:10:07 2001
***************
*** 12,18 ****
use vars qw($VERSION);
use Carp;
! $VERSION = "1.00";
{
package IPC::Semaphore::stat;
--- 12,18 ----
use vars qw($VERSION);
use Carp;
! $VERSION = "1.00_00";
{
package IPC::Semaphore::stat;
***************
*** 88,94 ****
@_ >= 4 || croak '$sem->op( OPLIST )';
my $self = shift;
croak 'Bad arg count' if @_ % 3;
! my $data = pack("s*",@_);
semop($$self,$data);
}
--- 88,94 ----
@_ >= 4 || croak '$sem->op( OPLIST )';
my $self = shift;
croak 'Bad arg count' if @_ % 3;
! my $data = pack("s!*",@_);
semop($$self,$data);
}
***************
*** 126,137 ****
my $data = "";
semctl($$self,0,GETALL,$data)
or return ();
! (unpack("s*",$data));
}
sub setall {
my $self = shift;
! my $data = pack("s*",@_);
semctl($$self,0,SETALL,$data);
}
--- 126,137 ----
my $data = "";
semctl($$self,0,GETALL,$data)
or return ();
! (unpack("s!*",$data));
}
sub setall {
my $self = shift;
! my $data = pack("s!*",@_);
semctl($$self,0,SETALL,$data);
}
***************
*** 206,212 ****
=item getncnt ( SEM )
Returns the number of processed waiting for the semaphore C<SEM> to
! become greater than it's current value
=item getpid ( SEM )
--- 206,212 ----
=item getncnt ( SEM )
Returns the number of processed waiting for the semaphore C<SEM> to
! become greater than its current value
=item getpid ( SEM )
diff -c 'perl-5.7.1/ext/IPC/SysV/SysV.pm' 'perl-5.7.2/ext/IPC/SysV/SysV.pm'
Index: ./ext/IPC/SysV/SysV.pm
*** ./ext/IPC/SysV/SysV.pm Fri Mar 16 04:54:47 2001
--- ./ext/IPC/SysV/SysV.pm Mon Jul 9 17:10:07 2001
***************
*** 14,20 ****
require Exporter;
@ISA = qw(Exporter);
! $VERSION = "1.03";
@EXPORT_OK = qw(
GETALL GETNCNT GETPID GETVAL GETZCNT
--- 14,20 ----
require Exporter;
@ISA = qw(Exporter);
! $VERSION = "1.03_00";
@EXPORT_OK = qw(
GETALL GETNCNT GETPID GETVAL GETZCNT
diff -c 'perl-5.7.1/ext/IPC/SysV/SysV.xs' 'perl-5.7.2/ext/IPC/SysV/SysV.xs'
Index: ./ext/IPC/SysV/SysV.xs
*** ./ext/IPC/SysV/SysV.xs Tue Mar 6 04:04:53 2001
--- ./ext/IPC/SysV/SysV.xs Mon Jul 9 17:10:07 2001
***************
*** 163,189 ****
{
#ifdef HAS_SEM
SV **sv_ptr;
- SV *sv;
struct semid_ds ds;
AV *list = (AV*)SvRV(obj);
if(!sv_isa(obj, "IPC::Semaphore::stat"))
croak("method %s not called a %s object",
"pack","IPC::Semaphore::stat");
! if((sv_ptr = av_fetch(list,0,TRUE)) && (sv = *sv_ptr))
ds.sem_perm.uid = SvIV(*sv_ptr);
! if((sv_ptr = av_fetch(list,1,TRUE)) && (sv = *sv_ptr))
ds.sem_perm.gid = SvIV(*sv_ptr);
! if((sv_ptr = av_fetch(list,2,TRUE)) && (sv = *sv_ptr))
ds.sem_perm.cuid = SvIV(*sv_ptr);
! if((sv_ptr = av_fetch(list,3,TRUE)) && (sv = *sv_ptr))
ds.sem_perm.cgid = SvIV(*sv_ptr);
! if((sv_ptr = av_fetch(list,4,TRUE)) && (sv = *sv_ptr))
ds.sem_perm.mode = SvIV(*sv_ptr);
! if((sv_ptr = av_fetch(list,5,TRUE)) && (sv = *sv_ptr))
ds.sem_ctime = SvIV(*sv_ptr);
! if((sv_ptr = av_fetch(list,6,TRUE)) && (sv = *sv_ptr))
ds.sem_otime = SvIV(*sv_ptr);
! if((sv_ptr = av_fetch(list,7,TRUE)) && (sv = *sv_ptr))
ds.sem_nsems = SvIV(*sv_ptr);
ST(0) = sv_2mortal(newSVpvn((char *)&ds,sizeof(ds)));
XSRETURN(1);
--- 163,188 ----
{
#ifdef HAS_SEM
SV **sv_ptr;
struct semid_ds ds;
AV *list = (AV*)SvRV(obj);
if(!sv_isa(obj, "IPC::Semaphore::stat"))
croak("method %s not called a %s object",
"pack","IPC::Semaphore::stat");
! if((sv_ptr = av_fetch(list,0,TRUE)) && *sv_ptr)
ds.sem_perm.uid = SvIV(*sv_ptr);
! if((sv_ptr = av_fetch(list,1,TRUE)) && *sv_ptr)
ds.sem_perm.gid = SvIV(*sv_ptr);
! if((sv_ptr = av_fetch(list,2,TRUE)) && *sv_ptr)
ds.sem_perm.cuid = SvIV(*sv_ptr);
! if((sv_ptr = av_fetch(list,3,TRUE)) && *sv_ptr)
ds.sem_perm.cgid = SvIV(*sv_ptr);
! if((sv_ptr = av_fetch(list,4,TRUE)) && *sv_ptr)
ds.sem_perm.mode = SvIV(*sv_ptr);
! if((sv_ptr = av_fetch(list,5,TRUE)) && *sv_ptr)
ds.sem_ctime = SvIV(*sv_ptr);
! if((sv_ptr = av_fetch(list,6,TRUE)) && *sv_ptr)
ds.sem_otime = SvIV(*sv_ptr);
! if((sv_ptr = av_fetch(list,7,TRUE)) && *sv_ptr)
ds.sem_nsems = SvIV(*sv_ptr);
ST(0) = sv_2mortal(newSVpvn((char *)&ds,sizeof(ds)));
XSRETURN(1);
***************
*** 203,209 ****
key_t k = ftok(path, id);
ST(0) = k == (key_t) -1 ? &PL_sv_undef : sv_2mortal(newSViv(k));
#else
! DIE(aTHX_ PL_no_func, "ftok");
#endif
void
--- 202,208 ----
key_t k = ftok(path, id);
ST(0) = k == (key_t) -1 ? &PL_sv_undef : sv_2mortal(newSViv(k));
#else
! Perl_die(aTHX_ PL_no_func, "ftok"); return;
#endif
void
diff -c /dev/null 'perl-5.7.2/ext/IPC/SysV/ipcsysv.t'
Index: ./ext/IPC/SysV/ipcsysv.t
*** ./ext/IPC/SysV/ipcsysv.t Thu Jan 1 02:00:00 1970
--- ./ext/IPC/SysV/ipcsysv.t Mon Jul 9 17:10:07 2001
***************
*** 0 ****
--- 1,218 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+
+ @INC = '../lib';
+
+ require Config; import Config;
+
+ my $reason;
+
+ if ($Config{'extensions'} !~ /\bIPC\/SysV\b/) {
+ $reason = 'IPC::SysV was not built';
+ } elsif ($Config{'d_sem'} ne 'define') {
+ $reason = '$Config{d_sem} undefined';
+ } elsif ($Config{'d_msg'} ne 'define') {
+ $reason = '$Config{d_msg} undefined';
+ }
+ if ($reason) {
+ print "1..0 # Skip: $reason\n";
+ exit 0;
+ }
+ }
+
+ # These constants are common to all tests.
+ # Later the sem* tests will import more for themselves.
+
+ use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID S_IRWXU);
+ use strict;
+
+ print "1..16\n";
+
+ my $msg;
+ my $sem;
+
+ $SIG{__DIE__} = 'cleanup'; # will cleanup $msg and $sem if needed
+
+ # FreeBSD is known to throw this if there's no SysV IPC in the kernel.
+ $SIG{SYS} = sub {
+ print STDERR <<EOM;
+ SIGSYS caught.
+ It may be that your kernel does not have SysV IPC configured.
+
+ EOM
+ if ($^O eq 'freebsd') {
+ print STDERR <<EOM;
+ You must have following options in your kernel:
+
+ options SYSVSHM
+ options SYSVSEM
+ options SYSVMSG
+
+ See config(8).
+ EOM
+ }
+ exit(1);
+ };
+
+ my $perm = S_IRWXU;
+
+ if ($Config{'d_msgget'} eq 'define' &&
+ $Config{'d_msgctl'} eq 'define' &&
+ $Config{'d_msgsnd'} eq 'define' &&
+ $Config{'d_msgrcv'} eq 'define') {
+
+ $msg = msgget(IPC_PRIVATE, $perm);
+ # Very first time called after machine is booted value may be 0
+ die "msgget failed: $!\n" unless defined($msg) && $msg >= 0;
+
+ print "ok 1\n";
+
+ #Putting a message on the queue
+ my $msgtype = 1;
+ my $msgtext = "hello";
+
+ my $test2bad;
+ my $test5bad;
+ my $test6bad;
+
+ unless (msgsnd($msg,pack("L! a*",$msgtype,$msgtext),IPC_NOWAIT)) {
+ print "not ";
+ $test2bad = 1;
+ }
+ print "ok 2\n";
+ if ($test2bad) {
+ print <<EOM;
+ #
+ # The failure of the subtest #2 may indicate that the message queue
+ # resource limits either of the system or of the testing account
+ # have been reached. Error message "Operating would block" is
+ # usually indicative of this situation. The error message was now:
+ # "$!"
+ #
+ # You can check the message queues with the 'ipcs' command and
+ # you can remove unneeded queues with the 'ipcrm -q id' command.
+ # You may also consider configuring your system or account
+ # to have more message queue resources.
+ #
+ # Because of the subtest #2 failing also the substests #5 and #6 will
+ # very probably also fail.
+ #
+ EOM
+ }
+
+ my $data;
+ msgctl($msg,IPC_STAT,$data) or print "not ";
+ print "ok 3\n";
+
+ print "not " unless length($data);
+ print "ok 4\n";
+
+ my $msgbuf;
+ unless (msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT)) {
+ print "not ";
+ $test5bad = 1;
+ }
+ print "ok 5\n";
+ if ($test5bad && $test2bad) {
+ print <<EOM;
+ #
+ # This failure was to be expected because the subtest #2 failed.
+ #
+ EOM
+ }
+
+ my($rmsgtype,$rmsgtext);
+ ($rmsgtype,$rmsgtext) = unpack("L! a*",$msgbuf);
+ unless ($rmsgtype == $msgtype && $rmsgtext eq $msgtext) {
+ print "not ";
+ $test6bad = 1;
+ }
+ print "ok 6\n";
+ if ($test6bad && $test2bad) {
+ print <<EOM;
+ #
+ # This failure was to be expected because the subtest #2 failed.
+ #
+ EOM
+ }
+ } else {
+ for (1..6) {
+ print "ok $_\n"; # fake it
+ }
+ }
+
+ if($Config{'d_semget'} eq 'define' &&
+ $Config{'d_semctl'} eq 'define') {
+
+ if ($Config{'d_semctl_semid_ds'} eq 'define' ||
+ $Config{'d_semctl_semun'} eq 'define') {
+
+ use IPC::SysV qw(IPC_CREAT GETALL SETALL);
+
+ $sem = semget(IPC_PRIVATE, 10, $perm | IPC_CREAT);
+ # Very first time called after machine is booted value may be 0
+ die "semget: $!\n" unless defined($sem) && $sem >= 0;
+
+ print "ok 7\n";
+
+ my $data;
+ semctl($sem,0,IPC_STAT,$data) or print "not ";
+ print "ok 8\n";
+
+ print "not " unless length($data);
+ print "ok 9\n";
+
+ my $nsem = 10;
+
+ semctl($sem,0,SETALL,pack("s!*",(0) x $nsem)) or print "not ";
+ print "ok 10\n";
+
+ $data = "";
+ semctl($sem,0,GETALL,$data) or print "not ";
+ print "ok 11\n";
+
+ print "not " unless length($data) == length(pack("s!*",(0) x $nsem));
+ print "ok 12\n";
+
+ my @data = unpack("s!*",$data);
+
+ my $adata = "0" x $nsem;
+
+ print "not " unless @data == $nsem and join("",@data) eq $adata;
+ print "ok 13\n";
+
+ my $poke = 2;
+
+ $data[$poke] = 1;
+ semctl($sem,0,SETALL,pack("s!*",@data)) or print "not ";
+ print "ok 14\n";
+
+ $data = "";
+ semctl($sem,0,GETALL,$data) or print "not ";
+ print "ok 15\n";
+
+ @data = unpack("s!*",$data);
+
+ my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1);
+
+ print "not " unless join("",@data) eq $bdata;
+ print "ok 16\n";
+ } else {
+ for (7..16) {
+ print "ok $_ # skipped, no semctl possible\n";
+ }
+ }
+ } else {
+ for (7..16) {
+ print "ok $_\n"; # fake it
+ }
+ }
+
+ sub cleanup {
+ msgctl($msg,IPC_RMID,0) if defined $msg;
+ semctl($sem,0,IPC_RMID,undef) if defined $sem;
+ }
+
+ cleanup;
diff -c 'perl-5.7.1/ext/IPC/SysV/t/msg.t' 'perl-5.7.2/ext/IPC/SysV/t/msg.t'
Index: ./ext/IPC/SysV/t/msg.t
*** ./ext/IPC/SysV/t/msg.t Tue Mar 6 04:04:53 2001
--- ./ext/IPC/SysV/t/msg.t Mon Jul 9 17:10:08 2001
***************
*** 1,3 ****
--- 1,25 ----
+ BEGIN {
+ chdir 't' if -d 't';
+
+ @INC = '../lib';
+
+ require Config; import Config;
+
+ my $reason;
+
+ if ($Config{'extensions'} !~ /\bIPC\/SysV\b/) {
+ $reason = 'IPC::SysV was not built';
+ } elsif ($Config{'d_sem'} ne 'define') {
+ $reason = '$Config{d_sem} undefined';
+ } elsif ($Config{'d_msg'} ne 'define') {
+ $reason = '$Config{d_msg} undefined';
+ }
+ if ($reason) {
+ print "1..0 # Skip: $reason\n";
+ exit 0;
+ }
+ }
+
use IPC::SysV qw(IPC_PRIVATE IPC_RMID IPC_NOWAIT IPC_STAT S_IRWXU S_IRWXG S_IRWXO);
use IPC::Msg;
diff -c 'perl-5.7.1/ext/IPC/SysV/t/sem.t' 'perl-5.7.2/ext/IPC/SysV/t/sem.t'
Index: ./ext/IPC/SysV/t/sem.t
*** ./ext/IPC/SysV/t/sem.t Tue Mar 6 04:04:53 2001
--- ./ext/IPC/SysV/t/sem.t Mon Jul 9 17:10:08 2001
***************
*** 1,3 ****
--- 1,24 ----
+ BEGIN {
+ chdir 't' if -d 't';
+
+ @INC = '../lib';
+
+ require Config; import Config;
+
+ my $reason;
+
+ if ($Config{'extensions'} !~ /\bIPC\/SysV\b/) {
+ $reason = 'IPC::SysV was not built';
+ } elsif ($Config{'d_sem'} ne 'define') {
+ $reason = '$Config{d_sem} undefined';
+ } elsif ($Config{'d_msg'} ne 'define') {
+ $reason = '$Config{d_msg} undefined';
+ }
+ if ($reason) {
+ print "1..0 # Skip: $reason\n";
+ exit 0;
+ }
+ }
use IPC::SysV qw(
SETALL
diff -c /dev/null 'perl-5.7.2/ext/List/Util/ChangeLog'
Index: ./ext/List/Util/ChangeLog
*** ./ext/List/Util/ChangeLog Thu Jan 1 02:00:00 1970
--- ./ext/List/Util/ChangeLog Mon Jul 9 17:10:08 2001
***************
*** 0 ****
--- 1,85 ----
+ Change 482 on 2000/04/10 by <gbarr@pobox.com> (Graham Barr)
+
+ Check for SvMAGICAL on argument for reftype and blessed
+
+ Change 366 on 2000/03/03 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.01
+
+ Change 365 on 2000/03/03 by <gbarr@pobox.com> (Graham Barr)
+
+ - Added auto-detection for a compiler and install the perl version
+ if not found
+ - Better perl implemenation of reftype, should be thread-safe now
+
+ Change 364 on 2000/03/03 by <gbarr@pobox.com> (Graham Barr)
+
+ - Added some examples of simple subs that have been requested
+ but not added
+ - Updated copyright dates
+
+ Change 344 on 1999/11/10 by <gbarr@pobox.com> (Graham Barr)
+
+ - Better testcase for reftype
+
+ Change 343 on 1999/11/10 by <gbarr@pobox.com> (Graham Barr)
+
+ - Modules are now called List::Util & Scalar::Util
+ - Supports non-XS install
+ - perl version of reftype now returns "REF" when it should
+
+ Change 311 on 1999/06/01 by <gbarr@pobox.com> (Graham Barr)
+
+ Updated README
+
+ Change 275 on 1999/03/22 by <gbarr@pobox.com> (Graham Barr)
+
+ Removed forall as it is very broken
+
+ Change 274 on 1999/03/22 by <gbarr@pobox.com> (Graham Barr)
+
+ Added List::Util::forall
+
+ Change 273 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
+
+ Added weaken and isweak to Ref::Util
+
+ Change 272 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
+
+ Add new .pm files to repository
+
+ Change 271 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
+
+ - Split into three packages Ref::Util, List::Util and Scalar::DualVar
+ - readonly and clock were removed in favor of other modules
+
+ Change 270 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
+
+ Rename package
+
+ Change 269 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
+
+ - Added reftype
+ - improved reduce by not doing a sub call
+ - reduce now uses $a and $b
+ - now compiles with 5.005_5x
+
+ Change 178 on 1998/07/26 by <gbarr@pobox.com> (Graham Barr)
+
+ Modified XS code so it will compile with 5.004 and 5.005
+
+ Change 115 on 1998/02/21 by <gbarr@pobox.com> (Graham Barr)
+
+ Fri Feb 20 1998 Graham Barr <gbarr@pobox.com>
+
+ t/min.t, t/max.t
+ - Change sor to do a numerical sort
+
+ Fri Dec 19 1997 Graham Barr <gbarr@pobox.com>
+
+ - Added readonly()
+
+ Wed Nov 19 1997 Graham Barr <gbarr@pobox.com>
+
+ - Initial release
+
diff -c /dev/null 'perl-5.7.2/ext/List/Util/Makefile.PL'
Index: ./ext/List/Util/Makefile.PL
*** ./ext/List/Util/Makefile.PL Thu Jan 1 02:00:00 1970
--- ./ext/List/Util/Makefile.PL Mon Jul 9 17:10:08 2001
***************
*** 0 ****
--- 1,59 ----
+ use ExtUtils::MakeMaker;
+
+ WriteMakefile(
+ VERSION_FROM => "lib/List/Util.pm",
+ MAN3PODS => {}, # Pods will be built by installman.
+ NAME => "List::Util",
+ );
+
+ package MY;
+
+ BEGIN {
+ use Config;
+ unless (defined $Config{usedl}) {
+ eval <<'__EOMM__';
+ sub xs_c {
+ my($self) = shift;
+ return '' unless $self->needs_linking();
+ '
+ .xs.c:
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > List$*.xsc && $(MV) List$*.xsc List$*.c
+ ';
+ }
+
+ sub c_o {
+ my($self) = shift;
+ return '' unless $self->needs_linking();
+ '
+ .c$(OBJ_EXT):
+ $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) List$*.c
+ $(MV) List$*$(OBJ_EXT) $*$(OBJ_EXT)
+ ';
+ }
+
+ sub xs_o { # many makes are too dumb to use xs_c then c_o
+ my($self) = shift;
+ return '' unless $self->needs_linking();
+ '
+ .xs$(OBJ_EXT):
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > List$*.xsc && $(MV) List$*.xsc List$*.c
+ $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) List$*.c
+ $(MV) List$*$(OBJ_EXT) $*$(OBJ_EXT)
+ ';
+ }
+
+ sub top_targets { # many makes are too dumb to use xs_c then c_o
+ my($self) = shift;
+ my $out = $self->SUPER::top_targets(@_);
+ $out .
+ '
+
+ ListUtil.c: Util.c
+ @$(NOOP)
+
+ ';
+ }
+
+ __EOMM__
+ }
+ }
diff -c /dev/null 'perl-5.7.2/ext/List/Util/README'
Index: ./ext/List/Util/README
*** ./ext/List/Util/README Thu Jan 1 02:00:00 1970
--- ./ext/List/Util/README Mon Jul 9 17:10:08 2001
***************
*** 0 ****
--- 1,31 ----
+ This distribution is a replacement for the builtin distribution.
+
+ This package contains a selection of subroutines that people have
+ expressed would be nice to have in the perl core, but the usage would not
+ really be high enough to warrant the use of a keyword, and the size so
+ small such that being individual extensions would be wasteful.
+
+ After unpacking the distribution, to install this module type
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+ This distribution provides
+
+ min
+ max
+ minstr
+ maxstr
+ sum
+ reduce
+ reftype
+ blessed
+ weaken (5.005_57 and later only)
+ isweak (5.005_57 and later only)
+ dualvar
+
+ Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ This library is free software; you can redistribute it and/or
+ modify it under the same terms as Perl itself.
diff -c /dev/null 'perl-5.7.2/ext/List/Util/Util.xs'
Index: ./ext/List/Util/Util.xs
*** ./ext/List/Util/Util.xs Thu Jan 1 02:00:00 1970
--- ./ext/List/Util/Util.xs Mon Jul 9 17:10:08 2001
***************
*** 0 ****
--- 1,340 ----
+ /* Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ * This program is free software; you can redistribute it and/or
+ * modify it under the same terms as Perl itself.
+ */
+
+ #include <EXTERN.h>
+ #include <perl.h>
+ #include <XSUB.h>
+
+ #ifndef PERL_VERSION
+ # include "patchlevel.h"
+ # define PERL_REVISION 5
+ # define PERL_VERSION PATCHLEVEL
+ # define PERL_SUBVERSION SUBVERSION
+ #endif
+
+ #if PERL_VERSION < 5
+ # ifndef gv_stashpvn
+ # define gv_stashpvn(n,l,c) gv_stashpv(n,c)
+ # endif
+ # ifndef SvTAINTED
+
+ static bool
+ sv_tainted(SV *sv)
+ {
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+ MAGIC *mg = mg_find(sv, 't');
+ if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
+ return TRUE;
+ }
+ return FALSE;
+ }
+
+ # define SvTAINTED_on(sv) sv_magic((sv), Nullsv, 't', Nullch, 0)
+ # define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv))
+ # endif
+ # define PL_defgv defgv
+ # define PL_op op
+ # define PL_curpad curpad
+ # define CALLRUNOPS runops
+ # define PL_curpm curpm
+ # define PL_sv_undef sv_undef
+ # define PERL_CONTEXT struct context
+ #endif
+ #if (PERL_VERSION < 5) || (PERL_VERSION == 5 && PERL_SUBVERSION <50)
+ # ifndef PL_tainting
+ # define PL_tainting tainting
+ # endif
+ # ifndef PL_stack_base
+ # define PL_stack_base stack_base
+ # endif
+ # ifndef PL_stack_sp
+ # define PL_stack_sp stack_sp
+ # endif
+ # ifndef PL_ppaddr
+ # define PL_ppaddr ppaddr
+ # endif
+ #endif
+
+ MODULE=List::Util PACKAGE=List::Util
+
+ void
+ min(...)
+ PROTOTYPE: @
+ ALIAS:
+ min = 0
+ max = 1
+ CODE:
+ {
+ int index;
+ NV retval;
+ SV *retsv;
+ if(!items) {
+ XSRETURN_UNDEF;
+ }
+ retsv = ST(0);
+ retval = SvNV(retsv);
+ for(index = 1 ; index < items ; index++) {
+ SV *stacksv = ST(index);
+ NV val = SvNV(stacksv);
+ if(val < retval ? !ix : ix) {
+ retsv = stacksv;
+ retval = val;
+ }
+ }
+ ST(0) = retsv;
+ XSRETURN(1);
+ }
+
+
+
+ NV
+ sum(...)
+ PROTOTYPE: @
+ CODE:
+ {
+ int index;
+ if(!items) {
+ XSRETURN_UNDEF;
+ }
+ RETVAL = SvNV(ST(0));
+ for(index = 1 ; index < items ; index++) {
+ RETVAL += SvNV(ST(index));
+ }
+ }
+ OUTPUT:
+ RETVAL
+
+
+ void
+ minstr(...)
+ PROTOTYPE: @
+ ALIAS:
+ minstr = 2
+ maxstr = 0
+ CODE:
+ {
+ SV *left;
+ int index;
+ if(!items) {
+ XSRETURN_UNDEF;
+ }
+ /*
+ sv_cmp & sv_cmp_locale return 1,0,-1 for gt,eq,lt
+ so we set ix to the value we are looking for
+ xsubpp does not allow -ve values, so we start with 0,2 and subtract 1
+ */
+ ix -= 1;
+ left = ST(0);
+ #ifdef OPpLOCALE
+ if(MAXARG & OPpLOCALE) {
+ for(index = 1 ; index < items ; index++) {
+ SV *right = ST(index);
+ if(sv_cmp_locale(left, right) == ix)
+ left = right;
+ }
+ }
+ else {
+ #endif
+ for(index = 1 ; index < items ; index++) {
+ SV *right = ST(index);
+ if(sv_cmp(left, right) == ix)
+ left = right;
+ }
+ #ifdef OPpLOCALE
+ }
+ #endif
+ ST(0) = left;
+ XSRETURN(1);
+ }
+
+
+
+ void
+ reduce(block,...)
+ SV * block
+ PROTOTYPE: &@
+ CODE:
+ {
+ SV *ret;
+ int index;
+ GV *agv,*bgv,*gv;
+ HV *stash;
+ CV *cv;
+ OP *reducecop;
+ if(items <= 1) {
+ XSRETURN_UNDEF;
+ }
+ agv = gv_fetchpv("a", TRUE, SVt_PV);
+ bgv = gv_fetchpv("b", TRUE, SVt_PV);
+ SAVESPTR(GvSV(agv));
+ SAVESPTR(GvSV(bgv));
+ cv = sv_2cv(block, &stash, &gv, 0);
+ reducecop = CvSTART(cv);
+ SAVESPTR(CvROOT(cv)->op_ppaddr);
+ CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
+ SAVESPTR(PL_curpad);
+ PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+ SAVETMPS;
+ SAVESPTR(PL_op);
+ ret = ST(1);
+ for(index = 2 ; index < items ; index++) {
+ GvSV(agv) = ret;
+ GvSV(bgv) = ST(index);
+ PL_op = reducecop;
+ CALLRUNOPS(aTHX);
+ ret = *PL_stack_sp;
+ }
+ ST(0) = ret;
+ XSRETURN(1);
+ }
+
+ void
+ first(block,...)
+ SV * block
+ PROTOTYPE: &@
+ CODE:
+ {
+ int index;
+ GV *gv;
+ HV *stash;
+ CV *cv;
+ OP *reducecop;
+ if(items <= 1) {
+ XSRETURN_UNDEF;
+ }
+ SAVESPTR(GvSV(PL_defgv));
+ cv = sv_2cv(block, &stash, &gv, 0);
+ reducecop = CvSTART(cv);
+ SAVESPTR(CvROOT(cv)->op_ppaddr);
+ CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
+ SAVESPTR(PL_curpad);
+ PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+ SAVETMPS;
+ SAVESPTR(PL_op);
+ for(index = 1 ; index < items ; index++) {
+ GvSV(PL_defgv) = ST(index);
+ PL_op = reducecop;
+ CALLRUNOPS(aTHX);
+ if (SvTRUE(*PL_stack_sp)) {
+ ST(0) = ST(index);
+ XSRETURN(1);
+ }
+ }
+ XSRETURN_UNDEF;
+ }
+
+ MODULE=List::Util PACKAGE=Scalar::Util
+
+ void
+ dualvar(num,str)
+ SV * num
+ SV * str
+ PROTOTYPE: $$
+ CODE:
+ {
+ STRLEN len;
+ char *ptr = SvPV(str,len);
+ ST(0) = sv_newmortal();
+ (void)SvUPGRADE(ST(0),SVt_PVNV);
+ sv_setpvn(ST(0),ptr,len);
+ if(SvNOKp(num) || !SvIOKp(num)) {
+ SvNVX(ST(0)) = SvNV(num);
+ SvNOK_on(ST(0));
+ }
+ else {
+ SvIVX(ST(0)) = SvIV(num);
+ SvIOK_on(ST(0));
+ }
+ if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
+ SvTAINTED_on(ST(0));
+ XSRETURN(1);
+ }
+
+ char *
+ blessed(sv)
+ SV * sv
+ PROTOTYPE: $
+ CODE:
+ {
+ if (SvMAGICAL(sv))
+ mg_get(sv);
+ if(!sv_isobject(sv)) {
+ XSRETURN_UNDEF;
+ }
+ RETVAL = sv_reftype(SvRV(sv),TRUE);
+ }
+ OUTPUT:
+ RETVAL
+
+ char *
+ reftype(sv)
+ SV * sv
+ PROTOTYPE: $
+ CODE:
+ {
+ if (SvMAGICAL(sv))
+ mg_get(sv);
+ if(!SvROK(sv)) {
+ XSRETURN_UNDEF;
+ }
+ RETVAL = sv_reftype(SvRV(sv),FALSE);
+ }
+ OUTPUT:
+ RETVAL
+
+ void
+ weaken(sv)
+ SV *sv
+ PROTOTYPE: $
+ CODE:
+ #ifdef SvWEAKREF
+ sv_rvweaken(sv);
+ #else
+ croak("weak references are not implemented in this release of perl");
+ #endif
+
+ void
+ isweak(sv)
+ SV *sv
+ PROTOTYPE: $
+ CODE:
+ #ifdef SvWEAKREF
+ ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
+ XSRETURN(1);
+ #else
+ croak("weak references are not implemented in this release of perl");
+ #endif
+
+ int
+ readonly(sv)
+ SV *sv
+ PROTOTYPE: $
+ CODE:
+ RETVAL = SvREADONLY(sv);
+ OUTPUT:
+ RETVAL
+
+ int
+ tainted(sv)
+ SV *sv
+ PROTOTYPE: $
+ CODE:
+ RETVAL = SvTAINTED(sv);
+ OUTPUT:
+ RETVAL
+
+ BOOT:
+ {
+ #ifndef SvWEAKREF
+ HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE);
+ GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE);
+ AV *varav;
+ if (SvTYPE(vargv) != SVt_PVGV)
+ gv_init(vargv, stash, "Scalar::Util", 12, TRUE);
+ varav = GvAVn(vargv);
+ av_push(varav, newSVpv("weaken",6));
+ av_push(varav, newSVpv("isweak",6));
+ #endif
+ }
diff -c /dev/null 'perl-5.7.2/ext/List/Util/lib/List/Util.pm'
Index: ./ext/List/Util/lib/List/Util.pm
*** ./ext/List/Util/lib/List/Util.pm Thu Jan 1 02:00:00 1970
--- ./ext/List/Util/lib/List/Util.pm Mon Jul 9 17:10:08 2001
***************
*** 0 ****
--- 1,180 ----
+ # List::Util.pm
+ #
+ # Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ # This program is free software; you can redistribute it and/or
+ # modify it under the same terms as Perl itself.
+
+ package List::Util;
+
+ require Exporter;
+ require DynaLoader;
+
+ our @ISA = qw(Exporter DynaLoader);
+ our @EXPORT_OK = qw(first min max minstr maxstr reduce sum);
+ our $VERSION = "1.02_00";
+
+ bootstrap List::Util $VERSION;
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ List::Util - A selection of general-utility list subroutines
+
+ =head1 SYNOPSIS
+
+ use List::Util qw(first sum min max minstr maxstr reduce);
+
+ =head1 DESCRIPTION
+
+ C<List::Util> contains a selection of subroutines that people have
+ expressed would be nice to have in the perl core, but the usage would
+ not really be high enough to warrant the use of a keyword, and the size
+ so small such that being individual extensions would be wasteful.
+
+ By default C<List::Util> does not export any subroutines. The
+ subroutines defined are
+
+ =over 4
+
+ =item first BLOCK LIST
+
+ Similar to C<grep> in that it evaluates BLOCK setting C<$_> to each element
+ of LIST in turn. C<first> returns the first element where the result from
+ BLOCK is a true value. If BLOCK never returns true or LIST was empty then
+ C<undef> is returned.
+
+ $foo = first { defined($_) } @list # first defined value in @list
+ $foo = first { $_ > $value } @list # first value in @list which
+ # is greater than $value
+
+ This function could be implemented using C<reduce> like this
+
+ $foo = reduce { defined($a) ? $a : wanted($b) ? $b : undef } undef, @list
+
+ for example wanted() could be defined() which would return the first
+ defined value in @list
+
+ =item max LIST
+
+ Returns the entry in the list with the highest numerical value. If the
+ list is empty then C<undef> is returned.
+
+ $foo = max 1..10 # 10
+ $foo = max 3,9,12 # 12
+ $foo = max @bar, @baz # whatever
+
+ This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a > $b ? $a : $b } 1..10
+
+ =item maxstr LIST
+
+ Similar to C<max>, but treats all the entries in the list as strings
+ and returns the highest string as defined by the C<gt> operator.
+ If the list is empty then C<undef> is returned.
+
+ $foo = maxstr 'A'..'Z' # 'Z'
+ $foo = maxstr "hello","world" # "world"
+ $foo = maxstr @bar, @baz # whatever
+
+ This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a gt $b ? $a : $b } 'A'..'Z'
+
+ =item min LIST
+
+ Similar to C<max> but returns the entry in the list with the lowest
+ numerical value. If the list is empty then C<undef> is returned.
+
+ $foo = min 1..10 # 1
+ $foo = min 3,9,12 # 3
+ $foo = min @bar, @baz # whatever
+
+ This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a < $b ? $a : $b } 1..10
+
+ =item minstr LIST
+
+ Similar to C<min>, but treats all the entries in the list as strings
+ and returns the lowest string as defined by the C<lt> operator.
+ If the list is empty then C<undef> is returned.
+
+ $foo = maxstr 'A'..'Z' # 'A'
+ $foo = maxstr "hello","world" # "hello"
+ $foo = maxstr @bar, @baz # whatever
+
+ This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a lt $b ? $a : $b } 'A'..'Z'
+
+ =item reduce BLOCK LIST
+
+ Reduces LIST by calling BLOCK multiple times, setting C<$a> and C<$b>
+ each time. The first call will be with C<$a> and C<$b> set to the first
+ two elements of the list, subsequent calls will be done by
+ setting C<$a> to the result of the previous call and C<$b> to the next
+ element in the list.
+
+ Returns the result of the last call to BLOCK. If LIST is empty then
+ C<undef> is returned. If LIST only contains one element then that
+ element is returned and BLOCK is not executed.
+
+ $foo = reduce { $a < $b ? $a : $b } 1..10 # min
+ $foo = reduce { $a lt $b ? $a : $b } 'aa'..'zz' # minstr
+ $foo = reduce { $a + $b } 1 .. 10 # sum
+ $foo = reduce { $a . $b } @bar # concat
+
+ =item sum LIST
+
+ Returns the sum of all the elements in LIST.
+
+ $foo = sum 1..10 # 55
+ $foo = sum 3,9,12 # 24
+ $foo = sum @bar, @baz # whatever
+
+ This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a + $b } 1..10
+
+ =back
+
+ =head1 SUGGESTED ADDITIONS
+
+ The following are additions that have been requested, but I have been reluctant
+ to add due to them being very simple to implement in perl
+
+ # One argument is true
+
+ sub any { $_ && return 1 for @_; 0 }
+
+ # All arguments are true
+
+ sub all { $_ || return 0 for @_; 1 }
+
+ # All arguments are false
+
+ sub none { $_ && return 0 for @_; 1 }
+
+ # One argument is false
+
+ sub notall { $_ || return 1 for @_; 0 }
+
+ # How many elements are true
+
+ sub true { scalar grep { $_ } @_ }
+
+ # How many elements are false
+
+ sub false { scalar grep { !$_ } @_ }
+
+ =head1 COPYRIGHT
+
+ Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ This program is free software; you can redistribute it and/or
+ modify it under the same terms as Perl itself.
+
+ =cut
diff -c /dev/null 'perl-5.7.2/ext/List/Util/lib/Scalar/Util.pm'
Index: ./ext/List/Util/lib/Scalar/Util.pm
*** ./ext/List/Util/lib/Scalar/Util.pm Thu Jan 1 02:00:00 1970
--- ./ext/List/Util/lib/Scalar/Util.pm Mon Jul 9 17:10:08 2001
***************
*** 0 ****
--- 1,101 ----
+ # Scalar::Util.pm
+ #
+ # Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ # This program is free software; you can redistribute it and/or
+ # modify it under the same terms as Perl itself.
+
+ package Scalar::Util;
+
+ require Exporter;
+ require List::Util; # List::Util loads the XS
+
+ our @ISA = qw(Exporter);
+ our @EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly);
+ our $VERSION = $List::Util::VERSION;
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ Scalar::Util - A selection of general-utility scalar subroutines
+
+ =head1 SYNOPSIS
+
+ use Scalar::Util qw(blessed dualvar reftype weaken isweak);
+
+ =head1 DESCRIPTION
+
+ C<Scalar::Util> contains a selection of subroutines that people have
+ expressed would be nice to have in the perl core, but the usage would
+ not really be high enough to warrant the use of a keyword, and the size
+ so small such that being individual extensions would be wasteful.
+
+ By default C<Scalar::Util> does not export any subroutines. The
+ subroutines defined are
+
+ =over 4
+
+ =item blessed EXPR
+
+ If EXPR evaluates to a blessed reference the name of the package
+ that it is blessed into is returned. Otherwise C<undef> is returned.
+
+ =item dualvar NUM, STRING
+
+ Returns a scalar that has the value NUM in a numeric context and the
+ value STRING in a string context.
+
+ $foo = dualvar 10, "Hello";
+ $num = $foo + 2; # 12
+ $str = $foo . " world"; # Hello world
+
+ =item isweak EXPR
+
+ If EXPR is a scalar which is a weak reference the result is true.
+
+ =item readonly SCALAR
+
+ Returns true if SCALAR is readonly.
+
+ =item reftype EXPR
+
+ If EXPR evaluates to a reference the type of the variable referenced
+ is returned. Otherwise C<undef> is returned.
+
+ =item tainted EXPR
+
+ Return true if the result of EXPR is tainted
+
+ =item weaken REF
+
+ REF will be turned into a weak reference. This means that it will not
+ hold a reference count on the object it references. Also when the reference
+ count on that object reaches zero, REF will be set to undef.
+
+ This is useful for keeping copies of references , but you don't want to
+ prevent the object being DESTROY-ed at its usual time.
+
+ =back
+
+ =head1 COPYRIGHT
+
+ Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ This program is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
+ except weaken and isweak which are
+
+ Copyright (c) 1999 Tuomas J. Lukka <lukka@iki.fi>. All rights reserved.
+ This program is free software; you can redistribute it and/or modify it
+ under the same terms as perl itself.
+
+ =head1 BLATANT PLUG
+
+ The weaken and isweak subroutines in this module and the patch to the core Perl
+ were written in connection with the APress book `Tuomas J. Lukka's Definitive
+ Guide to Object-Oriented Programming in Perl', to avoid explaining why certain
+ things would have to be done in cumbersome ways.
+
+ =cut
diff -c /dev/null 'perl-5.7.2/ext/List/Util/t/blessed.t'
Index: ./ext/List/Util/t/blessed.t
*** ./ext/List/Util/t/blessed.t Thu Jan 1 02:00:00 1970
--- ./ext/List/Util/t/blessed.t Mon Jul 9 17:10:08 2001
***************
*** 0 ****
--- 1,39 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{extensions} !~ /\bList\/Util\b/) {
+ print "1..0 # Skip: List::Util was not built\n";
+ exit 0;
+ }
+ }
+
+ use Scalar::Util qw(blessed);
+ use vars qw($t $y $x);
+
+ print "1..7\n";
+
+ print "not " if blessed(1);
+ print "ok 1\n";
+
+ print "not " if blessed('A');
+ print "ok 2\n";
+
+ print "not " if blessed({});
+ print "ok 3\n";
+
+ print "not " if blessed([]);
+ print "ok 4\n";
+
+ $y = \$t;
+
+ print "not " if blessed($y);
+ print "ok 5\n";
+
+ $x = bless [], "ABC";
+
+ print "not " unless blessed($x);
+ print "ok 6\n";
+
+ print "not " unless blessed($x) eq 'ABC';
+ print "ok 7\n";
diff -c /dev/null 'perl-5.7.2/ext/List/Util/t/dualvar.t'
Index: ./ext/List/Util/t/dualvar.t
*** ./ext/List/Util/t/dualvar.t Thu Jan 1 02:00:00 1970
--- ./ext/List/Util/t/dualvar.t Mon Jul 9 17:10:08 2001
***************
*** 0 ****
--- 1,46 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{extensions} !~ /\bList\/Util\b/) {
+ print "1..0 # Skip: List::Util was not built\n";
+ exit 0;
+ }
+ }
+
+ BEGIN {
+ require Scalar::Util;
+
+ if (grep { /dualvar/ } @Scalar::Util::EXPORT_FAIL) {
+ print "1..0\n";
+ exit;
+ }
+ }
+
+ use Scalar::Util qw(dualvar);
+
+ print "1..6\n";
+
+ $var = dualvar 2.2,"string";
+
+ print "not " unless $var == 2.2;
+ print "ok 1\n";
+
+ print "not " unless $var eq "string";
+ print "ok 2\n";
+
+ $var2 = $var;
+
+ $var++;
+
+ print "not " unless $var == 3.2;
+ print "ok 3\n";
+
+ print "not " unless $var ne "string";
+ print "ok 4\n";
+
+ print "not " unless $var2 == 2.2;
+ print "ok 5\n";
+
+ print "not " unless $var2 eq "string";
+ print "ok 6\n";
diff -c /dev/null 'perl-5.7.2/ext/List/Util/t/first.t'
Index: ./ext/List/Util/t/first.t
*** ./ext/List/Util/t/first.t Thu Jan 1 02:00:00 1970
--- ./ext/List/Util/t/first.t Mon Jul 9 17:10:08 2001
***************
*** 0 ****
--- 1,25 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{extensions} !~ /\bList\/Util\b/) {
+ print "1..0 # Skip: List::Util was not built\n";
+ exit 0;
+ }
+ }
+
+ use List::Util qw(first);
+
+ print "1..4\n";
+
+ print "not " unless defined &first;
+ print "ok 1\n";
+
+ print "not " unless 9 == first { 8 == ($_ - 1) } 9,4,5,6;
+ print "ok 2\n";
+
+ print "not " if defined(first { 0 } 1,2,3,4);
+ print "ok 3\n";
+
+ print "not " if defined(first { 0 });
+ print "ok 4\n";
diff -c /dev/null 'perl-5.7.2/ext/List/Util/t/max.t'
Index: ./ext/List/Util/t/max.t
*** ./ext/List/Util/t/max.t Thu Jan 1 02:00:00 1970
--- ./ext/List/Util/t/max.t Mon Jul 9 17:10:08 2001
***************
*** 0 ****
--- 1,30 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{extensions} !~ /\bList\/Util\b/) {
+ print "1..0 # Skip: List::Util was not built\n";
+ exit 0;
+ }
+ }
+
+ use List::Util qw(max);
+
+ print "1..5\n";
+
+ print "not " unless defined &max;
+ print "ok 1\n";
+
+ print "not " unless max(1) == 1;
+ print "ok 2\n";
+
+ print "not " unless max(1,2) == 2;
+ print "ok 3\n";
+
+ print "not " unless max(2,1) == 2;
+ print "ok 4\n";
+
+ my @a = map { rand() } 1 .. 20;
+ my @b = sort { $a <=> $b } @a;
+ print "not " unless max(@a) == $b[-1];
+ print "ok 5\n";
diff -c /dev/null 'perl-5.7.2/ext/List/Util/t/maxstr.t'
Index: ./ext/List/Util/t/maxstr.t
*** ./ext/List/Util/t/maxstr.t Thu Jan 1 02:00:00 1970
--- ./ext/List/Util/t/maxstr.t Mon Jul 9 17:10:08 2001
***************
*** 0 ****
--- 1,30 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{extensions} !~ /\bList\/Util\b/) {
+ print "1..0 # Skip: List::Util was not built\n";
+ exit 0;
+ }
+ }
+
+ use List::Util qw(maxstr);
+
+ print "1..5\n";
+
+ print "not " unless defined &maxstr;
+ print "ok 1\n";
+
+ print "not " unless maxstr('a') eq 'a';
+ print "ok 2\n";
+
+ print "not " unless maxstr('a','b') eq 'b';
+ print "ok 3\n";
+
+ print "not " unless maxstr('B','A') eq 'B';
+ print "ok 4\n";
+
+ my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) } 0 .. 20;
+ my @b = sort { $a cmp $b } @a;
+ print "not " unless maxstr(@a) eq $b[-1];
+ print "ok 5\n";
diff -c /dev/null 'perl-5.7.2/ext/List/Util/t/min.t'
Index: ./ext/List/Util/t/min.t
*** ./ext/List/Util/t/min.t Thu Jan 1 02:00:00 1970
--- ./ext/List/Util/t/min.t Mon Jul 9 17:10:08 2001
***************
*** 0 ****
--- 1,30 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{extensions} !~ /\bList\/Util\b/) {
+ print "1..0 # Skip: List::Util was not built\n";
+ exit 0;
+ }
+ }
+
+ use List::Util qw(min);
+
+ print "1..5\n";
+
+ print "not " unless defined &min;
+ print "ok 1\n";
+
+ print "not " unless min(9) == 9;
+ print "ok 2\n";
+
+ print "not " unless min(1,2) == 1;
+ print "ok 3\n";
+
+ print "not " unless min(2,1) == 1;
+ print "ok 4\n";
+
+ my @a = map { rand() } 1 .. 20;
+ my @b = sort { $a <=> $b } @a;
+ print "not " unless min(@a) == $b[0];
+ print "ok 5\n";
diff -c /dev/null 'perl-5.7.2/ext/List/Util/t/minstr.t'
Index: ./ext/List/Util/t/minstr.t
*** ./ext/List/Util/t/minstr.t Thu Jan 1 02:00:00 1970
--- ./ext/List/Util/t/minstr.t Mon Jul 9 17:10:08 2001
***************
*** 0 ****
--- 1,30 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{extensions} !~ /\bList\/Util\b/) {
+ print "1..0 # Skip: List::Util was not built\n";
+ exit 0;
+ }
+ }
+
+ use List::Util qw(minstr);
+
+ print "1..5\n";
+
+ print "not " unless defined &minstr;
+ print "ok 1\n";
+
+ print "not " unless minstr('a') eq 'a';
+ print "ok 2\n";
+
+ print "not " unless minstr('a','b') eq 'a';
+ print "ok 3\n";
+
+ print "not " unless minstr('B','A') eq 'A';
+ print "ok 4\n";
+
+ my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) } 0 .. 20;
+ my @b = sort { $a cmp $b } @a;
+ print "not " unless minstr(@a) eq $b[0];
+ print "ok 5\n";
diff -c /dev/null 'perl-5.7.2/ext/List/Util/t/readonly.t'
Index: ./ext/List/Util/t/readonly.t
*** ./ext/List/Util/t/readonly.t Thu Jan 1 02:00:00 1970
--- ./ext/List/Util/t/readonly.t Mon Jul 9 17:10:08 2001
***************
*** 0 ****
--- 1,46 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{extensions} !~ /\bList\/Util\b/) {
+ print "1..0 # Skip: List::Util was not built\n";
+ exit 0;
+ }
+ }
+
+ use Scalar::Util qw(readonly);
+
+ print "1..9\n";
+
+ print "not " unless readonly(1);
+ print "ok 1\n";
+
+ my $var = 2;
+
+ print "not " if readonly($var);
+ print "ok 2\n";
+
+ print "not " unless $var == 2;
+ print "ok 3\n";
+
+ print "not " unless readonly("fred");
+ print "ok 4\n";
+
+ $var = "fred";
+
+ print "not " if readonly($var);
+ print "ok 5\n";
+
+ print "not " unless $var eq "fred";
+ print "ok 6\n";
+
+ $var = \2;
+
+ print "not " if readonly($var);
+ print "ok 7\n";
+
+ print "not " unless readonly($$var);
+ print "ok 8\n";
+
+ print "not " if readonly(*STDOUT);
+ print "ok 9\n";
diff -c /dev/null 'perl-5.7.2/ext/List/Util/t/reduce.t'
Index: ./ext/List/Util/t/reduce.t
*** ./ext/List/Util/t/reduce.t Thu Jan 1 02:00:00 1970
--- ./ext/List/Util/t/reduce.t Mon Jul 9 17:10:08 2001
***************
*** 0 ****
--- 1,30 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{extensions} !~ /\bList\/Util\b/) {
+ print "1..0 # Skip: List::Util was not built\n";
+ exit 0;
+ }
+ }
+
+ use List::Util qw(reduce min);
+
+ print "1..5\n";
+
+ print "not " if defined reduce {};
+ print "ok 1\n";
+
+ print "not " unless 9 == reduce { $a / $b } 756,3,7,4;
+ print "ok 2\n";
+
+ print "not " unless 9 == reduce { $a / $b } 9;
+ print "ok 3\n";
+
+ @a = map { rand } 0 .. 20;
+ print "not " unless min(@a) == reduce { $a < $b ? $a : $b } @a;
+ print "ok 4\n";
+
+ @a = map { pack("C", int(rand(256))) } 0 .. 20;
+ print "not " unless join("",@a) eq reduce { $a . $b } @a;
+ print "ok 5\n";
diff -c /dev/null 'perl-5.7.2/ext/List/Util/t/reftype.t'
Index: ./ext/List/Util/t/reftype.t
*** ./ext/List/Util/t/reftype.t Thu Jan 1 02:00:00 1970
--- ./ext/List/Util/t/reftype.t Mon Jul 9 17:10:08 2001
***************
*** 0 ****
--- 1,55 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{extensions} !~ /\bList\/Util\b/) {
+ print "1..0 # Skip: List::Util was not built\n";
+ exit 0;
+ }
+ }
+
+ use Scalar::Util qw(reftype);
+ use vars qw($t $y $x *F);
+ use Symbol qw(gensym);
+
+ # Ensure we do not trigger and tied methods
+ tie *F, 'MyTie';
+
+ @test = (
+ [ undef, 1],
+ [ undef, 'A'],
+ [ HASH => {} ],
+ [ ARRAY => [] ],
+ [ SCALAR => \$t ],
+ [ REF => \(\$t) ],
+ [ GLOB => \*F ],
+ [ GLOB => gensym ],
+ [ CODE => sub {} ],
+ # [ IO => *STDIN{IO} ] the internal sv_reftype returns UNKNOWN
+ );
+
+ print "1..", @test*4, "\n";
+
+ my $i = 1;
+ foreach $test (@test) {
+ my($type,$what) = @$test;
+ my $pack;
+ foreach $pack (undef,"ABC","0",undef) {
+ print "# $what\n";
+ my $res = reftype($what);
+ printf "# %s - %s\n", map { defined($_) ? $_ : 'undef' } $type,$res;
+ print "not " if $type ? $res ne $type : defined($res);
+ bless $what, $pack if $type && defined $pack;
+ print "ok ",$i++,"\n";
+ }
+ }
+
+ package MyTie;
+
+ sub TIEHANDLE { bless {} }
+ sub DESTROY {}
+
+ sub AUTOLOAD {
+ warn "$AUTOLOAD called";
+ exit 1; # May be in an eval
+ }
diff -c /dev/null 'perl-5.7.2/ext/List/Util/t/sum.t'
Index: ./ext/List/Util/t/sum.t
*** ./ext/List/Util/t/sum.t Thu Jan 1 02:00:00 1970
--- ./ext/List/Util/t/sum.t Mon Jul 9 17:10:08 2001
***************
*** 0 ****
--- 1,23 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{extensions} !~ /\bList\/Util\b/) {
+ print "1..0 # Skip: List::Util was not built\n";
+ exit 0;
+ }
+ }
+
+ use List::Util qw(sum);
+
+ print "1..3\n";
+
+ print "not " if defined sum;
+ print "ok 1\n";
+
+ print "not " unless sum(9) == 9;
+ print "ok 2\n";
+
+ print "not " unless sum(1,2,3,4) == 10;
+ print "ok 3\n";
+
diff -c /dev/null 'perl-5.7.2/ext/List/Util/t/tainted.t'
Index: ./ext/List/Util/t/tainted.t
*** ./ext/List/Util/t/tainted.t Thu Jan 1 02:00:00 1970
--- ./ext/List/Util/t/tainted.t Mon Jul 9 17:10:08 2001
***************
*** 0 ****
--- 1,38 ----
+ #!./perl -T
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{extensions} !~ /\bList\/Util\b/) {
+ print "1..0 # Skip: List::Util was not built\n";
+ exit 0;
+ }
+ }
+
+ use lib qw(blib/lib blib/arch);
+ use Scalar::Util qw(tainted);
+ use Config;
+
+ print "1..5\n";
+
+ print "not " if tainted(1);
+ print "ok 1\n";
+
+ my $var = 2;
+
+ print "not " if tainted($var);
+ print "ok 2\n";
+
+ my $key = (keys %ENV)[0];
+
+ $var = $ENV{$key};
+
+ print "not " unless tainted($var);
+ print "ok 3\n";
+
+ print "not " unless tainted($ENV{$key});
+ print "ok 4\n";
+
+ print "not " if @ARGV and not tainted($ARGV[0]);
+ print "ok 5\n";
diff -c /dev/null 'perl-5.7.2/ext/List/Util/t/weak.t'
Index: ./ext/List/Util/t/weak.t
*** ./ext/List/Util/t/weak.t Thu Jan 1 02:00:00 1970
--- ./ext/List/Util/t/weak.t Mon Jul 9 17:10:08 2001
***************
*** 0 ****
--- 1,206 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{extensions} !~ /\bList\/Util\b/) {
+ print "1..0 # Skip: List::Util was not built\n";
+ exit 0;
+ }
+ }
+
+ BEGIN {
+ $|=1;
+ require Scalar::Util;
+ if (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) {
+ print("1..0\n");
+ exit;
+ }
+
+ $DEBUG = 0;
+
+ if ($DEBUG && eval { require Devel::Peek } ) {
+ Devel::Peek->import('Dump');
+ }
+ else {
+ *Dump = sub {};
+ }
+ }
+
+ use Scalar::Util qw(weaken isweak);
+ print "1..17\n";
+
+ ######################### End of black magic.
+
+ $cnt = 0;
+
+ sub ok {
+ ++$cnt;
+ if($_[0]) { print "ok $cnt\n"; } else {print "not ok $cnt\n"; }
+ }
+
+ $| = 1;
+
+ if(1) {
+
+ my ($y,$z);
+
+ #
+ # Case 1: two references, one is weakened, the other is then undef'ed.
+ #
+
+ {
+ my $x = "foo";
+ $y = \$x;
+ $z = \$x;
+ }
+ print "# START:\n";
+ Dump($y); Dump($z);
+
+ ok( $y ne "" and $z ne "" );
+ weaken($y);
+
+ print "# WEAK:\n";
+ Dump($y); Dump($z);
+
+ ok( $y ne "" and $z ne "" );
+ undef($z);
+
+ print "# UNDZ:\n";
+ Dump($y); Dump($z);
+
+ ok( not (defined($y) and defined($z)) );
+ undef($y);
+
+ print "# UNDY:\n";
+ Dump($y); Dump($z);
+
+ ok( not (defined($y) and defined($z)) );
+
+ print "# FIN:\n";
+ Dump($y); Dump($z);
+
+ # exit(0);
+
+ # }
+ # {
+
+ #
+ # Case 2: one reference, which is weakened
+ #
+
+ # kill 5,$$;
+
+ print "# CASE 2:\n";
+
+ {
+ my $x = "foo";
+ $y = \$x;
+ }
+
+ ok( $y ne "" );
+ print "# BW: \n";
+ Dump($y);
+ weaken($y);
+ print "# AW: \n";
+ Dump($y);
+ ok( not defined $y );
+
+ print "# EXITBLOCK\n";
+ }
+
+ # exit(0);
+
+ #
+ # Case 3: a circular structure
+ #
+
+ # kill 5, $$;
+
+ $flag = 0;
+ {
+ my $y = bless {}, Dest;
+ Dump($y);
+ print "# 1: $y\n";
+ $y->{Self} = $y;
+ Dump($y);
+ print "# 2: $y\n";
+ $y->{Flag} = \$flag;
+ print "# 3: $y\n";
+ weaken($y->{Self});
+ print "# WKED\n";
+ ok( $y ne "" );
+ print "# VALS: HASH ",$y," SELF ",\$y->{Self}," Y ",\$y,
+ " FLAG: ",\$y->{Flag},"\n";
+ print "# VPRINT\n";
+ }
+ print "# OUT $flag\n";
+ ok( $flag == 1 );
+
+ print "# AFTER\n";
+
+ undef $flag;
+
+ print "# FLAGU\n";
+
+ #
+ # Case 4: a more complicated circular structure
+ #
+
+ $flag = 0;
+ {
+ my $y = bless {}, Dest;
+ my $x = bless {}, Dest;
+ $x->{Ref} = $y;
+ $y->{Ref} = $x;
+ $x->{Flag} = \$flag;
+ $y->{Flag} = \$flag;
+ weaken($x->{Ref});
+ }
+ ok( $flag == 2 );
+
+ #
+ # Case 5: deleting a weakref before the other one
+ #
+
+ {
+ my $x = "foo";
+ $y = \$x;
+ $z = \$x;
+ }
+
+ print "# CASE5\n";
+ Dump($y);
+
+ weaken($y);
+ Dump($y);
+ undef($y);
+
+ ok( not defined $y);
+ ok($z ne "");
+
+
+ #
+ # Case 6: test isweakref
+ #
+
+ $a = 5;
+ ok(!isweak($a));
+ $b = \$a;
+ ok(!isweak($b));
+ weaken($b);
+ ok(isweak($b));
+ $b = \$a;
+ ok(!isweak($b));
+
+ $x = {};
+ weaken($x->{Y} = \$a);
+ ok(isweak($x->{Y}));
+ ok(!isweak($x->{Z}));
+
+
+ package Dest;
+
+ sub DESTROY {
+ print "# INCFLAG\n";
+ ${$_[0]{Flag}} ++;
+ }
diff -c 'perl-5.7.1/ext/MIME/Base64/Base64.xs' 'perl-5.7.2/ext/MIME/Base64/Base64.xs'
Index: ./ext/MIME/Base64/Base64.xs
Prereq: 1.18
*** ./ext/MIME/Base64/Base64.xs Tue Mar 27 23:22:32 2001
--- ./ext/MIME/Base64/Base64.xs Mon Jul 9 17:10:08 2001
***************
*** 1,4 ****
! /* $Id: Base64.xs,v 1.18 2001/02/24 06:27:01 gisle Exp $
Copyright 1997-1999,2001 Gisle Aas
--- 1,4 ----
! /*
Copyright 1997-1999,2001 Gisle Aas
***************
*** 35,44 ****
}
#endif
- #include "patchlevel.h"
- #if PATCHLEVEL <= 4 && !defined(PL_dowarn)
- #define PL_dowarn dowarn
- #endif
#define MAX_LINE 76 /* size of encoded lines */
--- 35,40 ----
***************
*** 89,97 ****
int chunk;
CODE:
- #ifdef sv_utf8_downgrade
sv_utf8_downgrade(sv, FALSE);
- #endif
str = SvPV(sv, rlen); /* SvPV(sv, len) gives warning for signed len */
len = (SSize_t)rlen;
--- 85,91 ----
***************
*** 197,203 ****
if (PL_dowarn) warn("Premature padding of base64 data");
break;
}
! /* printf("c0=%d,c1=%d,c2=%d,c3=%d\n", c[0],c[1],c[2],c[3]);/**/
*r++ = (c[0] << 2) | ((c[1] & 0x30) >> 4);
--- 191,197 ----
if (PL_dowarn) warn("Premature padding of base64 data");
break;
}
! /* printf("c0=%d,c1=%d,c2=%d,c3=%d\n", c[0],c[1],c[2],c[3]);*/
*r++ = (c[0] << 2) | ((c[1] & 0x30) >> 4);
diff -c 'perl-5.7.1/ext/MIME/Base64/Makefile.PL' 'perl-5.7.2/ext/MIME/Base64/Makefile.PL'
Index: ./ext/MIME/Base64/Makefile.PL
*** ./ext/MIME/Base64/Makefile.PL Sun Mar 25 05:56:25 2001
--- ./ext/MIME/Base64/Makefile.PL Mon Jul 9 17:10:08 2001
***************
*** 3,8 ****
--- 3,9 ----
WriteMakefile(
NAME => 'MIME::Base64',
+ MAN3PODS => {}, # Pods will be built by installman.
VERSION_FROM => 'Base64.pm',
dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
);
diff -c 'perl-5.7.1/ext/MIME/Base64/QuotedPrint.pm' 'perl-5.7.2/ext/MIME/Base64/QuotedPrint.pm'
Index: ./ext/MIME/Base64/QuotedPrint.pm
Prereq: 2.3
*** ./ext/MIME/Base64/QuotedPrint.pm Wed Mar 28 18:35:37 2001
--- ./ext/MIME/Base64/QuotedPrint.pm Mon Jul 9 17:10:09 2001
***************
*** 64,69 ****
--- 64,72 ----
use strict;
use vars qw(@ISA @EXPORT $VERSION);
+ if (ord('A') == 193) { # on EBCDIC machines we need translation help
+ require Encode;
+ }
require Exporter;
@ISA = qw(Exporter);
***************
*** 71,86 ****
$VERSION = sprintf("%d.%02d", q$Revision: 2.3 $ =~ /(\d+)\.(\d+)/);
- use re 'asciirange'; # ranges in regular expressions refer to ASCII
-
sub encode_qp ($)
{
my $res = shift;
! $res =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg; # rule #2,#3
! $res =~ s/([ \t]+)$/
! join('', map { sprintf("=%02X", ord($_)) }
! split('', $1)
! )/egm; # rule #3 (encode whitespace at eol)
# rule #5 (lines must be shorter than 76 chars, but we are not allowed
# to break =XX escapes. This makes things complicated :-( )
--- 74,114 ----
$VERSION = sprintf("%d.%02d", q$Revision: 2.3 $ =~ /(\d+)\.(\d+)/);
sub encode_qp ($)
{
my $res = shift;
! # Do not mention ranges such as $res =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg;
! # since that will not even compile on an EBCDIC machine (where ord('!') > ord('<')).
! if (ord('A') == 193) { # EBCDIC style machine
! if (ord('[') == 173) {
! $res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp1047',$1))))/eg; # rule #2,#3
! $res =~ s/([ \t]+)$/
! join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp1047',$_)))) }
! split('', $1)
! )/egm; # rule #3 (encode whitespace at eol)
! }
! elsif (ord('[') == 187) {
! $res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('posix-bc',$1))))/eg; # rule #2,#3
! $res =~ s/([ \t]+)$/
! join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('posix-bc',$_)))) }
! split('', $1)
! )/egm; # rule #3 (encode whitespace at eol)
! }
! elsif (ord('[') == 186) {
! $res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp37',$1))))/eg; # rule #2,#3
! $res =~ s/([ \t]+)$/
! join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp37',$_)))) }
! split('', $1)
! )/egm; # rule #3 (encode whitespace at eol)
! }
! }
! else { # ASCII style machine
! $res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord($1))/eg; # rule #2,#3
! $res =~ s/([ \t]+)$/
! join('', map { sprintf("=%02X", ord($_)) }
! split('', $1)
! )/egm; # rule #3 (encode whitespace at eol)
! }
# rule #5 (lines must be shorter than 76 chars, but we are not allowed
# to break =XX escapes. This makes things complicated :-( )
***************
*** 101,107 ****
my $res = shift;
$res =~ s/[ \t]+?(\r?\n)/$1/g; # rule #3 (trailing space must be deleted)
$res =~ s/=\r?\n//g; # rule #5 (soft line breaks)
! $res =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge;
$res;
}
--- 129,148 ----
my $res = shift;
$res =~ s/[ \t]+?(\r?\n)/$1/g; # rule #3 (trailing space must be deleted)
$res =~ s/=\r?\n//g; # rule #5 (soft line breaks)
! if (ord('A') == 193) { # EBCDIC style machine
! if (ord('[') == 173) {
! $res =~ s/=([\da-fA-F]{2})/Encode::encode('cp1047',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
! }
! elsif (ord('[') == 187) {
! $res =~ s/=([\da-fA-F]{2})/Encode::encode('posix-bc',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
! }
! elsif (ord('[') == 186) {
! $res =~ s/=([\da-fA-F]{2})/Encode::encode('cp37',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
! }
! }
! else { # ASCII style machine
! $res =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge;
! }
$res;
}
diff -c /dev/null 'perl-5.7.2/ext/MIME/Base64/t/base64.t'
Index: ./ext/MIME/Base64/t/base64.t
*** ./ext/MIME/Base64/t/base64.t Thu Jan 1 02:00:00 1970
--- ./ext/MIME/Base64/t/base64.t Mon Jul 9 17:10:09 2001
***************
*** 0 ****
--- 1,383 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use MIME::Base64;
+
+ print "1..283\n";
+
+ print "# Testing MIME::Base64-", $MIME::Base64::VERSION, "\n";
+
+ BEGIN {
+ if (ord('A') == 41) {
+ *ASCII = sub { return $_[0] };
+ }
+ else {
+ require Encode;
+ *ASCII = sub { Encode::encode('ascii',$_[0]) };
+ }
+ }
+
+ $testno = 1;
+
+ encodeTest();
+ decodeTest();
+
+ # This used to generate a warning
+ print "not " unless decode_base64(encode_base64("foo")) eq "foo";
+ print "ok ", $testno++, "\n";
+
+ sub encodeTest
+ {
+ print "# encode test\n";
+
+ my @encode_tests = (
+ # All values
+ ["\000" => "AA=="],
+ ["\001" => "AQ=="],
+ ["\002" => "Ag=="],
+ ["\003" => "Aw=="],
+ ["\004" => "BA=="],
+ ["\005" => "BQ=="],
+ ["\006" => "Bg=="],
+ ["\007" => "Bw=="],
+ ["\010" => "CA=="],
+ ["\011" => "CQ=="],
+ ["\012" => "Cg=="],
+ ["\013" => "Cw=="],
+ ["\014" => "DA=="],
+ ["\015" => "DQ=="],
+ ["\016" => "Dg=="],
+ ["\017" => "Dw=="],
+ ["\020" => "EA=="],
+ ["\021" => "EQ=="],
+ ["\022" => "Eg=="],
+ ["\023" => "Ew=="],
+ ["\024" => "FA=="],
+ ["\025" => "FQ=="],
+ ["\026" => "Fg=="],
+ ["\027" => "Fw=="],
+ ["\030" => "GA=="],
+ ["\031" => "GQ=="],
+ ["\032" => "Gg=="],
+ ["\033" => "Gw=="],
+ ["\034" => "HA=="],
+ ["\035" => "HQ=="],
+ ["\036" => "Hg=="],
+ ["\037" => "Hw=="],
+ ["\040" => "IA=="],
+ ["\041" => "IQ=="],
+ ["\042" => "Ig=="],
+ ["\043" => "Iw=="],
+ ["\044" => "JA=="],
+ ["\045" => "JQ=="],
+ ["\046" => "Jg=="],
+ ["\047" => "Jw=="],
+ ["\050" => "KA=="],
+ ["\051" => "KQ=="],
+ ["\052" => "Kg=="],
+ ["\053" => "Kw=="],
+ ["\054" => "LA=="],
+ ["\055" => "LQ=="],
+ ["\056" => "Lg=="],
+ ["\057" => "Lw=="],
+ ["\060" => "MA=="],
+ ["\061" => "MQ=="],
+ ["\062" => "Mg=="],
+ ["\063" => "Mw=="],
+ ["\064" => "NA=="],
+ ["\065" => "NQ=="],
+ ["\066" => "Ng=="],
+ ["\067" => "Nw=="],
+ ["\070" => "OA=="],
+ ["\071" => "OQ=="],
+ ["\072" => "Og=="],
+ ["\073" => "Ow=="],
+ ["\074" => "PA=="],
+ ["\075" => "PQ=="],
+ ["\076" => "Pg=="],
+ ["\077" => "Pw=="],
+ ["\100" => "QA=="],
+ ["\101" => "QQ=="],
+ ["\102" => "Qg=="],
+ ["\103" => "Qw=="],
+ ["\104" => "RA=="],
+ ["\105" => "RQ=="],
+ ["\106" => "Rg=="],
+ ["\107" => "Rw=="],
+ ["\110" => "SA=="],
+ ["\111" => "SQ=="],
+ ["\112" => "Sg=="],
+ ["\113" => "Sw=="],
+ ["\114" => "TA=="],
+ ["\115" => "TQ=="],
+ ["\116" => "Tg=="],
+ ["\117" => "Tw=="],
+ ["\120" => "UA=="],
+ ["\121" => "UQ=="],
+ ["\122" => "Ug=="],
+ ["\123" => "Uw=="],
+ ["\124" => "VA=="],
+ ["\125" => "VQ=="],
+ ["\126" => "Vg=="],
+ ["\127" => "Vw=="],
+ ["\130" => "WA=="],
+ ["\131" => "WQ=="],
+ ["\132" => "Wg=="],
+ ["\133" => "Ww=="],
+ ["\134" => "XA=="],
+ ["\135" => "XQ=="],
+ ["\136" => "Xg=="],
+ ["\137" => "Xw=="],
+ ["\140" => "YA=="],
+ ["\141" => "YQ=="],
+ ["\142" => "Yg=="],
+ ["\143" => "Yw=="],
+ ["\144" => "ZA=="],
+ ["\145" => "ZQ=="],
+ ["\146" => "Zg=="],
+ ["\147" => "Zw=="],
+ ["\150" => "aA=="],
+ ["\151" => "aQ=="],
+ ["\152" => "ag=="],
+ ["\153" => "aw=="],
+ ["\154" => "bA=="],
+ ["\155" => "bQ=="],
+ ["\156" => "bg=="],
+ ["\157" => "bw=="],
+ ["\160" => "cA=="],
+ ["\161" => "cQ=="],
+ ["\162" => "cg=="],
+ ["\163" => "cw=="],
+ ["\164" => "dA=="],
+ ["\165" => "dQ=="],
+ ["\166" => "dg=="],
+ ["\167" => "dw=="],
+ ["\170" => "eA=="],
+ ["\171" => "eQ=="],
+ ["\172" => "eg=="],
+ ["\173" => "ew=="],
+ ["\174" => "fA=="],
+ ["\175" => "fQ=="],
+ ["\176" => "fg=="],
+ ["\177" => "fw=="],
+ ["\200" => "gA=="],
+ ["\201" => "gQ=="],
+ ["\202" => "gg=="],
+ ["\203" => "gw=="],
+ ["\204" => "hA=="],
+ ["\205" => "hQ=="],
+ ["\206" => "hg=="],
+ ["\207" => "hw=="],
+ ["\210" => "iA=="],
+ ["\211" => "iQ=="],
+ ["\212" => "ig=="],
+ ["\213" => "iw=="],
+ ["\214" => "jA=="],
+ ["\215" => "jQ=="],
+ ["\216" => "jg=="],
+ ["\217" => "jw=="],
+ ["\220" => "kA=="],
+ ["\221" => "kQ=="],
+ ["\222" => "kg=="],
+ ["\223" => "kw=="],
+ ["\224" => "lA=="],
+ ["\225" => "lQ=="],
+ ["\226" => "lg=="],
+ ["\227" => "lw=="],
+ ["\230" => "mA=="],
+ ["\231" => "mQ=="],
+ ["\232" => "mg=="],
+ ["\233" => "mw=="],
+ ["\234" => "nA=="],
+ ["\235" => "nQ=="],
+ ["\236" => "ng=="],
+ ["\237" => "nw=="],
+ ["\240" => "oA=="],
+ ["\241" => "oQ=="],
+ ["\242" => "og=="],
+ ["\243" => "ow=="],
+ ["\244" => "pA=="],
+ ["\245" => "pQ=="],
+ ["\246" => "pg=="],
+ ["\247" => "pw=="],
+ ["\250" => "qA=="],
+ ["\251" => "qQ=="],
+ ["\252" => "qg=="],
+ ["\253" => "qw=="],
+ ["\254" => "rA=="],
+ ["\255" => "rQ=="],
+ ["\256" => "rg=="],
+ ["\257" => "rw=="],
+ ["\260" => "sA=="],
+ ["\261" => "sQ=="],
+ ["\262" => "sg=="],
+ ["\263" => "sw=="],
+ ["\264" => "tA=="],
+ ["\265" => "tQ=="],
+ ["\266" => "tg=="],
+ ["\267" => "tw=="],
+ ["\270" => "uA=="],
+ ["\271" => "uQ=="],
+ ["\272" => "ug=="],
+ ["\273" => "uw=="],
+ ["\274" => "vA=="],
+ ["\275" => "vQ=="],
+ ["\276" => "vg=="],
+ ["\277" => "vw=="],
+ ["\300" => "wA=="],
+ ["\301" => "wQ=="],
+ ["\302" => "wg=="],
+ ["\303" => "ww=="],
+ ["\304" => "xA=="],
+ ["\305" => "xQ=="],
+ ["\306" => "xg=="],
+ ["\307" => "xw=="],
+ ["\310" => "yA=="],
+ ["\311" => "yQ=="],
+ ["\312" => "yg=="],
+ ["\313" => "yw=="],
+ ["\314" => "zA=="],
+ ["\315" => "zQ=="],
+ ["\316" => "zg=="],
+ ["\317" => "zw=="],
+ ["\320" => "0A=="],
+ ["\321" => "0Q=="],
+ ["\322" => "0g=="],
+ ["\323" => "0w=="],
+ ["\324" => "1A=="],
+ ["\325" => "1Q=="],
+ ["\326" => "1g=="],
+ ["\327" => "1w=="],
+ ["\330" => "2A=="],
+ ["\331" => "2Q=="],
+ ["\332" => "2g=="],
+ ["\333" => "2w=="],
+ ["\334" => "3A=="],
+ ["\335" => "3Q=="],
+ ["\336" => "3g=="],
+ ["\337" => "3w=="],
+ ["\340" => "4A=="],
+ ["\341" => "4Q=="],
+ ["\342" => "4g=="],
+ ["\343" => "4w=="],
+ ["\344" => "5A=="],
+ ["\345" => "5Q=="],
+ ["\346" => "5g=="],
+ ["\347" => "5w=="],
+ ["\350" => "6A=="],
+ ["\351" => "6Q=="],
+ ["\352" => "6g=="],
+ ["\353" => "6w=="],
+ ["\354" => "7A=="],
+ ["\355" => "7Q=="],
+ ["\356" => "7g=="],
+ ["\357" => "7w=="],
+ ["\360" => "8A=="],
+ ["\361" => "8Q=="],
+ ["\362" => "8g=="],
+ ["\363" => "8w=="],
+ ["\364" => "9A=="],
+ ["\365" => "9Q=="],
+ ["\366" => "9g=="],
+ ["\367" => "9w=="],
+ ["\370" => "+A=="],
+ ["\371" => "+Q=="],
+ ["\372" => "+g=="],
+ ["\373" => "+w=="],
+ ["\374" => "/A=="],
+ ["\375" => "/Q=="],
+ ["\376" => "/g=="],
+ ["\377" => "/w=="],
+
+ ["\000\377" => "AP8="],
+ ["\377\000" => "/wA="],
+ ["\000\000\000" => "AAAA"],
+
+ ['' => ''],
+ [ASCII('a') => 'YQ=='],
+ [ASCII('aa') => 'YWE='],
+ [ASCII('aaa') => 'YWFh'],
+
+ [ASCII('aaa') => 'YWFh'],
+ [ASCII('aaa') => 'YWFh'],
+ [ASCII('aaa') => 'YWFh'],
+
+
+ # from HTTP spec
+ [ASCII('Aladdin:open sesame') => 'QWxhZGRpbjpvcGVuIHNlc2FtZQ=='],
+
+ [ASCII('a') x 100 => 'YWFh' x 33 . 'YQ=='],
+
+ [ASCII('Multipurpose Internet Mail Extensions: The Base64 Content-Transfer-Encoding is designed to represent sequences of octets in a form that is not humanly readable. ')
+ => "TXVsdGlwdXJwb3NlIEludGVybmV0IE1haWwgRXh0ZW5zaW9uczogVGhlIEJhc2U2NCBDb250ZW50LVRyYW5zZmVyLUVuY29kaW5nIGlzIGRlc2lnbmVkIHRvIHJlcHJlc2VudCBzZXF1ZW5jZXMgb2Ygb2N0ZXRzIGluIGEgZm9ybSB0aGF0IGlzIG5vdCBodW1hbmx5IHJlYWRhYmxlLiA="],
+
+ );
+
+ for $test (@encode_tests) {
+ my($plain, $expected) = ($$test[0], $$test[1]);
+
+ my $encoded = encode_base64($plain, '');
+ if ($encoded ne $expected) {
+ print "test $testno ($plain): expected $expected, got $encoded\n";
+ print "not ";
+ }
+ my $decoded = decode_base64($encoded);
+ if ($decoded ne $plain) {
+ print "test $testno ($encoded): expected $plain, got $decoded\n";
+ print "not ";
+ }
+
+ if (ord('A') != 193) { # perl versions broken on EBCDIC
+ # Try the old Perl versions too
+ if ($encoded ne MIME::Base64::old_encode_base64($plain, '')) {
+ print "old_encode_base64 give different result.\n";
+ print "not ";
+ }
+ if ($plain ne MIME::Base64::old_decode_base64($encoded)) {
+ print "old_decode_base64 give different result.\n";
+ print "not ";
+ }
+ }
+
+ print "ok $testno\n";
+ $testno++;
+ }
+ }
+
+ sub decodeTest
+ {
+ print "# decode test\n";
+
+ local $SIG{__WARN__} = sub { print $_[0] }; # avoid warnings on stderr
+
+ my @decode_tests = (
+ ['YWE=' => ASCII('aa')],
+ [' YWE=' => ASCII('aa')],
+ ['Y WE=' => ASCII('aa')],
+ ['YWE= ' => ASCII('aa')],
+ ["Y\nW\r\nE=" => ASCII('aa')],
+
+ # These will generate some warnings
+ ['YWE=====' => ASCII('aa')], # extra padding
+ ['YWE' => ASCII('aa')], # missing padding
+ ['YWFh====' => ASCII('aaa')],
+ ['YQ' => ASCII('a')],
+ ['Y' => ''],
+ ['x==' => ''],
+ ['' => ''],
+ [undef() => ''],
+ );
+
+ for $test (@decode_tests) {
+ my($encoded, $expected) = ($$test[0], $$test[1]);
+
+ my $decoded = decode_base64($encoded);
+ if ($decoded ne $expected) {
+ die "test $testno ($encoded): expected $expected, got $decoded\n";
+ }
+ print "ok $testno\n";
+ $testno++;
+ }
+ }
diff -c /dev/null 'perl-5.7.2/ext/MIME/Base64/t/qp.t'
Index: ./ext/MIME/Base64/t/qp.t
*** ./ext/MIME/Base64/t/qp.t Thu Jan 1 02:00:00 1970
--- ./ext/MIME/Base64/t/qp.t Mon Jul 9 17:10:09 2001
***************
*** 0 ****
--- 1,113 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use MIME::QuotedPrint;
+
+ $x70 = "x" x 70;
+
+ @tests =
+ (
+ # plain ascii should not be encoded
+ ["quoted printable" =>
+ "quoted printable"],
+
+ # 8-bit chars should be encoded
+ ["v\xe5re kj\xe6re norske tegn b\xf8r \xe6res" =>
+ "v=E5re kj=E6re norske tegn b=F8r =E6res"],
+
+ # trailing space should be encoded
+ [" " => "=20=20"],
+ ["\tt\t" => "\tt=09"],
+ ["test \ntest\n\t \t \n" => "test=20=20\ntest\n=09=20=09=20\n"],
+
+ # "=" is special an should be decoded
+ ["=\n" => "=3D\n"],
+ ["\0\xff" => "=00=FF"],
+
+ # Very long lines should be broken (not more than 76 chars
+ ["The Quoted-Printable encoding is intended to represent data that largly consists of octets that correspond to printable characters in the ASCII character set." =>
+ "The Quoted-Printable encoding is intended to represent data that largly con=
+ sists of octets that correspond to printable characters in the ASCII charac=
+ ter set."
+ ],
+
+ # Long lines after short lines were broken through 2.01.
+ ["short line
+ In America, any boy may become president and I suppose that's just one of the risks he takes. -- Adlai Stevenson" =>
+ "short line
+ In America, any boy may become president and I suppose that's just one of t=
+ he risks he takes. -- Adlai Stevenson"],
+
+ # My (roderick@argon.org) first crack at fixing that bug failed for
+ # multiple long lines.
+ ["College football is a game which would be much more interesting if the faculty played instead of the students, and even more interesting if the
+ trustees played. There would be a great increase in broken arms, legs, and necks, and simultaneously an appreciable diminution in the loss to humanity. -- H. L. Mencken" =>
+ "College football is a game which would be much more interesting if the facu=
+ lty played instead of the students, and even more interesting if the
+ trustees played. There would be a great increase in broken arms, legs, and=
+ necks, and simultaneously an appreciable diminution in the loss to humanit=
+ y. -- H. L. Mencken"],
+
+ # Don't break a line that's near but not over 76 chars.
+ ["$x70!23" => "$x70!23"],
+ ["$x70!234" => "$x70!234"],
+ ["$x70!2345" => "$x70!2345"],
+ ["$x70!23456" => "$x70!23456"],
+ ["$x70!23\n" => "$x70!23\n"],
+ ["$x70!234\n" => "$x70!234\n"],
+ ["$x70!2345\n" => "$x70!2345\n"],
+ ["$x70!23456\n" => "$x70!23456\n"],
+
+ # Not allowed to break =XX escapes using soft line break
+ ["$x70===xxxx" => "$x70=3D=\n=3D=3Dxxxx"],
+ ["$x70!===xxx" => "$x70!=3D=\n=3D=3Dxxx"],
+ ["$x70!!===xx" => "$x70!!=3D=\n=3D=3Dxx"],
+ ["$x70!!!===x" => "$x70!!!=\n=3D=3D=3Dx"],
+ # ^
+ # 70123456|
+ # max
+ # line width
+ );
+
+ $notests = @tests + 2;
+ print "1..$notests\n";
+
+ $testno = 0;
+ for (@tests) {
+ $testno++;
+ ($plain, $encoded) = @$_;
+ if (ord('A') == 193) { # EBCDIC 8 bit chars are different
+ if ($testno == 2) { $plain =~ s/\xe5/\x47/; $plain =~ s/\xe6/\x9c/g; $plain =~ s/\xf8/\x70/; }
+ if ($testno == 7) { $plain =~ s/\xff/\xdf/; }
+ }
+ $x = encode_qp($plain);
+ if ($x ne $encoded) {
+ print "Encode test failed\n";
+ print "Got: '$x'\n";
+ print "Expected: '$encoded'\n";
+ print "not ok $testno\n";
+ next;
+ }
+ $x = decode_qp($encoded);
+ if ($x ne $plain) {
+ print "Decode test failed\n";
+ print "Got: '$x'\n";
+ print "Expected: '$plain'\n";
+ print "not ok $testno\n";
+ next;
+ }
+ print "ok $testno\n";
+ }
+
+ # Some extra testing for a case that was wrong until libwww-perl-5.09
+ print "not " unless decode_qp("foo \n\nfoo =\n\nfoo=20\n\n") eq
+ "foo\n\nfoo \nfoo \n\n";
+ $testno++; print "ok $testno\n";
+
+ # Same test but with "\r\n" terminated lines
+ print "not " unless decode_qp("foo \r\n\r\nfoo =\r\n\r\nfoo=20\r\n\r\n") eq
+ "foo\r\n\r\nfoo \r\nfoo \r\n\r\n";
+ $testno++; print "ok $testno\n";
+
diff -c /dev/null 'perl-5.7.2/ext/MIME/Base64/t/unicode.t'
Index: ./ext/MIME/Base64/t/unicode.t
*** ./ext/MIME/Base64/t/unicode.t Thu Jan 1 02:00:00 1970
--- ./ext/MIME/Base64/t/unicode.t Mon Jul 9 17:10:09 2001
***************
*** 0 ****
--- 1,16 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ print "1..1\n";
+
+ require MIME::Base64;
+
+ eval {
+ MIME::Base64::encode(v300);
+ };
+
+ print "not " unless $@;
+ print "ok 1\n";
+
diff -c 'perl-5.7.1/ext/NDBM_File/NDBM_File.xs' 'perl-5.7.2/ext/NDBM_File/NDBM_File.xs'
Index: ./ext/NDBM_File/NDBM_File.xs
*** ./ext/NDBM_File/NDBM_File.xs Tue Mar 6 04:04:53 2001
--- ./ext/NDBM_File/NDBM_File.xs Mon Jul 9 17:10:09 2001
***************
*** 53,59 ****
DBM * dbp ;
RETVAL = NULL ;
! if (dbp = dbm_open(filename, flags, mode)) {
RETVAL = (NDBM_File)safemalloc(sizeof(NDBM_File_type)) ;
Zero(RETVAL, 1, NDBM_File_type) ;
RETVAL->dbp = dbp ;
--- 53,59 ----
DBM * dbp ;
RETVAL = NULL ;
! if ((dbp = dbm_open(filename, flags, mode))) {
RETVAL = (NDBM_File)safemalloc(sizeof(NDBM_File_type)) ;
Zero(RETVAL, 1, NDBM_File_type) ;
RETVAL->dbp = dbp ;
diff -c /dev/null 'perl-5.7.2/ext/NDBM_File/hints/linux.pl'
Index: ./ext/NDBM_File/hints/linux.pl
*** ./ext/NDBM_File/hints/linux.pl Thu Jan 1 02:00:00 1970
--- ./ext/NDBM_File/hints/linux.pl Mon Jul 9 17:10:09 2001
***************
*** 0 ****
--- 1,6 ----
+ # Some distributions have both gdbm and ndbm
+ # Prefer gdbm to avoid the broken ndbm in some distributions
+ # (no null key support)
+ # Jonathan Stowe <gellyfish@gellyfish.com>
+ use Config;
+ $self->{LIBS} = ['-lgdbm'] if $Config{libs} =~ /(?:^|\s)-lgdbm(?:\s|$)/;
diff -c /dev/null 'perl-5.7.2/ext/NDBM_File/ndbm.t'
Index: ./ext/NDBM_File/ndbm.t
*** ./ext/NDBM_File/ndbm.t Thu Jan 1 02:00:00 1970
--- ./ext/NDBM_File/ndbm.t Mon Jul 9 17:10:09 2001
***************
*** 0 ****
--- 1,420 ----
+ #!./perl
+
+ # $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bNDBM_File\b/) {
+ print "1..0 # Skip: NDBM_File was not built\n";
+ exit 0;
+ }
+ }
+
+ use strict;
+ use warnings;
+
+ sub ok
+ {
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+ }
+
+ require NDBM_File;
+ #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
+ use Fcntl;
+
+ print "1..65\n";
+
+ unlink <Op.dbmx*>;
+
+ umask(0);
+ my %h;
+ ok(1, tie(%h,'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640));
+
+ my $Dfile = "Op.dbmx.pag";
+ if (! -e $Dfile) {
+ ($Dfile) = <Op.dbmx*>;
+ }
+ if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare') {
+ print "ok 2 # Skipped: different file permission semantics\n";
+ }
+ else {
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
+ }
+ my $i = 0;
+ while (my ($key,$value) = each(%h)) {
+ $i++;
+ }
+ print (!$i ? "ok 3\n" : "not ok 3\n");
+
+ $h{'goner1'} = 'snork';
+
+ $h{'abc'} = 'ABC';
+ $h{'def'} = 'DEF';
+ $h{'jkl','mno'} = "JKL\034MNO";
+ $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+ $h{'a'} = 'A';
+ $h{'b'} = 'B';
+ $h{'c'} = 'C';
+ $h{'d'} = 'D';
+ $h{'e'} = 'E';
+ $h{'f'} = 'F';
+ $h{'g'} = 'G';
+ $h{'h'} = 'H';
+ $h{'i'} = 'I';
+
+ $h{'goner2'} = 'snork';
+ delete $h{'goner2'};
+
+ untie(%h);
+ print (tie(%h,'NDBM_File','Op.dbmx', &O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n");
+
+ $h{'j'} = 'J';
+ $h{'k'} = 'K';
+ $h{'l'} = 'L';
+ $h{'m'} = 'M';
+ $h{'n'} = 'N';
+ $h{'o'} = 'O';
+ $h{'p'} = 'P';
+ $h{'q'} = 'Q';
+ $h{'r'} = 'R';
+ $h{'s'} = 'S';
+ $h{'t'} = 'T';
+ $h{'u'} = 'U';
+ $h{'v'} = 'V';
+ $h{'w'} = 'W';
+ $h{'x'} = 'X';
+ $h{'y'} = 'Y';
+ $h{'z'} = 'Z';
+
+ $h{'goner3'} = 'snork';
+
+ delete $h{'goner1'};
+ delete $h{'goner3'};
+
+ my @keys = keys(%h);
+ my @values = values(%h);
+
+ if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
+
+ while (my ($key,$value) = each(%h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+ }
+
+ if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
+
+ @keys = ('blurfl', keys(%h), 'dyick');
+ if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
+
+ $h{'foo'} = '';
+ $h{''} = 'bar';
+
+ # check cache overflow and numeric keys and contents
+ my $ok = 1;
+ for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+ for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+ print ($ok ? "ok 8\n" : "not ok 8\n");
+
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ print ($size > 0 ? "ok 9\n" : "not ok 9\n");
+
+ @h{0..200} = 200..400;
+ my @foo = @h{0..200};
+ print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";
+
+ print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
+ print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
+
+ untie %h;
+ unlink 'Op.dbmx.dir', $Dfile;
+
+ {
+ # sub-class test
+
+ package Another ;
+
+ use strict ;
+ use warnings ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use strict ;
+ use warnings ;
+ use vars qw(@ISA @EXPORT) ;
+
+ require Exporter ;
+ use NDBM_File;
+ @ISA=qw(NDBM_File);
+ @EXPORT = @NDBM_File::EXPORT if defined @NDBM_File::EXPORT ;
+
+ sub STORE {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::STORE($key, $value * 2) ;
+ }
+
+ sub FETCH {
+ my $self = shift ;
+ my $key = shift ;
+ $self->SUPER::FETCH($key) - 1 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+ EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+
+ eval 'use SubDB ; use Fcntl ; ';
+ main::ok(13, $@ eq "") ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 );
+ ' ;
+
+ main::ok(14, $@ eq "") ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ main::ok(15, $@ eq "") ;
+ main::ok(16, $ret == 5) ;
+
+ $ret = eval '$X->A_new_method("fred") ' ;
+ main::ok(17, $@ eq "") ;
+ main::ok(18, $ret eq "[[5]]") ;
+
+ undef $X;
+ untie(%h);
+ unlink "SubDB.pm", <dbhash.tmp*> ;
+
+ }
+
+ {
+ # DBM Filter tests
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ unlink <Op.dbmx*>;
+ ok(19, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok(20, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(21, $h{"fred"} eq "joe");
+ # fk sk fv sv
+ ok(22, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(23, $db->FIRSTKEY() eq "fred") ;
+ # fk sk fv sv
+ ok(24, checkOutput( "fred", "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok(25, checkOutput( "", "fred", "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(26, $h{"Fred"} eq "[Jxe]");
+ # fk sk fv sv
+ ok(27, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(28, $db->FIRSTKEY() eq "FRED") ;
+ # fk sk fv sv
+ ok(29, checkOutput( "FRED", "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(30, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(31, $h{"fred"} eq "joe");
+ ok(32, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(33, $db->FIRSTKEY() eq "fred") ;
+ ok(34, checkOutput( "fred", "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(35, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(36, $h{"fred"} eq "joe");
+ ok(37, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(38, $db->FIRSTKEY() eq "fred") ;
+ ok(39, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+ }
+
+ {
+ # DBM Filter with a closure
+
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+
+ unlink <Op.dbmx*>;
+ ok(40, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(41, $result{"store key"} eq "store key - 1: [fred]");
+ ok(42, $result{"store value"} eq "store value - 1: [joe]");
+ ok(43, !defined $result{"fetch key"} );
+ ok(44, !defined $result{"fetch value"} );
+ ok(45, $_ eq "original") ;
+
+ ok(46, $db->FIRSTKEY() eq "fred") ;
+ ok(47, $result{"store key"} eq "store key - 1: [fred]");
+ ok(48, $result{"store value"} eq "store value - 1: [joe]");
+ ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(50, ! defined $result{"fetch value"} );
+ ok(51, $_ eq "original") ;
+
+ $h{"jim"} = "john" ;
+ ok(52, $result{"store key"} eq "store key - 2: [fred jim]");
+ ok(53, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(55, ! defined $result{"fetch value"} );
+ ok(56, $_ eq "original") ;
+
+ ok(57, $h{"fred"} eq "joe");
+ ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]");
+ ok(59, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(62, $_ eq "original") ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+ }
+
+ {
+ # DBM Filter recursion detection
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+ unlink <Op.dbmx*>;
+
+ ok(63, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok(64, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+ }
+
+ {
+ # Bug ID 20001013.009
+ #
+ # test that $hash{KEY} = undef doesn't produce the warning
+ # Use of uninitialized value in null operation
+ use warnings ;
+ use strict ;
+ use NDBM_File ;
+
+ unlink <Op.dbmx*>;
+ my %h ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ ok(65, tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+ }
diff -c 'perl-5.7.1/ext/ODBM_File/ODBM_File.xs' 'perl-5.7.2/ext/ODBM_File/ODBM_File.xs'
Index: ./ext/ODBM_File/ODBM_File.xs
*** ./ext/ODBM_File/ODBM_File.xs Tue Mar 6 04:04:54 2001
--- ./ext/ODBM_File/ODBM_File.xs Mon Jul 9 17:10:09 2001
***************
*** 15,20 ****
--- 15,30 ----
# endif
#endif
+ #ifndef HAS_DBMINIT_PROTO
+ int dbminit(char* filename);
+ int dbmclose(void);
+ datum fetch(datum key);
+ int store(datum key, datum dat);
+ int delete(datum key);
+ datum firstkey(void);
+ datum nextkey(datum key);
+ #endif
+
#ifdef DBM_BUG_DUPLICATE_FREE
/*
* DBM on at least Ultrix and HPUX call dbmclose() from dbminit(),
diff -c /dev/null 'perl-5.7.2/ext/ODBM_File/odbm.t'
Index: ./ext/ODBM_File/odbm.t
*** ./ext/ODBM_File/odbm.t Thu Jan 1 02:00:00 1970
--- ./ext/ODBM_File/odbm.t Mon Jul 9 17:10:10 2001
***************
*** 0 ****
--- 1,437 ----
+ #!./perl
+
+ # $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bODBM_File\b/) {
+ print "1..0 # Skip: ODBM_File was not built\n";
+ exit 0;
+ }
+ }
+
+ use strict;
+ use warnings;
+
+ sub ok
+ {
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+ }
+
+ require ODBM_File;
+ #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
+ use Fcntl;
+
+ print "1..66\n";
+
+ unlink <Op.dbmx*>;
+
+ umask(0);
+ my %h;
+ ok(1, tie(%h,'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640));
+
+ my $Dfile = "Op.dbmx.pag";
+ if (! -e $Dfile) {
+ ($Dfile) = <Op.dbmx*>;
+ }
+ if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare') {
+ print "ok 2 # Skipped: different file permission semantics\n";
+ }
+ else {
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
+ }
+ my $i = 0;
+ while (my ($key,$value) = each(%h)) {
+ $i++;
+ }
+ print (!$i ? "ok 3\n" : "not ok 3\n");
+
+ $h{'goner1'} = 'snork';
+
+ $h{'abc'} = 'ABC';
+ $h{'def'} = 'DEF';
+ $h{'jkl','mno'} = "JKL\034MNO";
+ $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+ $h{'a'} = 'A';
+ $h{'b'} = 'B';
+ $h{'c'} = 'C';
+ $h{'d'} = 'D';
+ $h{'e'} = 'E';
+ $h{'f'} = 'F';
+ $h{'g'} = 'G';
+ $h{'h'} = 'H';
+ $h{'i'} = 'I';
+
+ $h{'goner2'} = 'snork';
+ delete $h{'goner2'};
+
+ untie(%h);
+ print (tie(%h,'ODBM_File','Op.dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n");
+
+ $h{'j'} = 'J';
+ $h{'k'} = 'K';
+ $h{'l'} = 'L';
+ $h{'m'} = 'M';
+ $h{'n'} = 'N';
+ $h{'o'} = 'O';
+ $h{'p'} = 'P';
+ $h{'q'} = 'Q';
+ $h{'r'} = 'R';
+ $h{'s'} = 'S';
+ $h{'t'} = 'T';
+ $h{'u'} = 'U';
+ $h{'v'} = 'V';
+ $h{'w'} = 'W';
+ $h{'x'} = 'X';
+ $h{'y'} = 'Y';
+ $h{'z'} = 'Z';
+
+ $h{'goner3'} = 'snork';
+
+ delete $h{'goner1'};
+ delete $h{'goner3'};
+
+ my @keys = keys(%h);
+ my @values = values(%h);
+
+ if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
+
+ while (my ($key,$value) = each(%h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+ }
+
+ if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
+
+ @keys = ('blurfl', keys(%h), 'dyick');
+ if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
+
+ $h{'foo'} = '';
+ $h{''} = 'bar';
+
+ # check cache overflow and numeric keys and contents
+ my $ok = 1;
+ for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+ for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+ print ($ok ? "ok 8\n" : "not ok 8\n");
+
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ print ($size > 0 ? "ok 9\n" : "not ok 9\n");
+
+ @h{0..200} = 200..400;
+ my @foo = @h{0..200};
+ print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";
+
+ print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
+ print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
+
+ untie %h;
+ unlink 'Op.dbmx.dir', $Dfile;
+
+ {
+ # sub-class test
+
+ package Another ;
+
+ use strict ;
+ use warnings ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use strict ;
+ use warnings ;
+ use vars qw(@ISA @EXPORT) ;
+
+ require Exporter ;
+ use ODBM_File;
+ @ISA=qw(ODBM_File);
+ @EXPORT = @ODBM_File::EXPORT ;
+
+ sub STORE {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::STORE($key, $value * 2) ;
+ }
+
+ sub FETCH {
+ my $self = shift ;
+ my $key = shift ;
+ $self->SUPER::FETCH($key) - 1 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+ EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+
+ eval 'use SubDB ; use Fcntl ;';
+ main::ok(13, $@ eq "") ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 );
+ ' ;
+
+ main::ok(14, $@ eq "") ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ main::ok(15, $@ eq "") ;
+ main::ok(16, $ret == 5) ;
+
+ $ret = eval '$X->A_new_method("fred") ' ;
+ main::ok(17, $@ eq "") ;
+ main::ok(18, $ret eq "[[5]]") ;
+
+ undef $X;
+ untie(%h);
+ unlink "SubDB.pm", <dbhash.tmp*> ;
+
+ }
+
+ {
+ # DBM Filter tests
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ print "# ", join('|', $fetch_key, $fk, $store_key, $sk,
+ $fetch_value, $fv, $store_value, $sv, $_), "\n";
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ unlink <Op.dbmx*>;
+ ok(19, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok(20, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(21, $h{"fred"} eq "joe");
+ # fk sk fv sv
+ ok(22, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(23, $db->FIRSTKEY() eq "fred") ;
+ # fk sk fv sv
+ ok(24, checkOutput( "fred", "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok(25, checkOutput( "", "fred", "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(26, $h{"Fred"} eq "[Jxe]");
+ # fk sk fv sv
+ ok(27, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(28, $db->FIRSTKEY() eq "FRED") ;
+ # fk sk fv sv
+ ok(29, checkOutput( "FRED", "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(30, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(31, $h{"fred"} eq "joe");
+ ok(32, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(33, $db->FIRSTKEY() eq "fred") ;
+ ok(34, checkOutput( "fred", "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(35, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(36, $h{"fred"} eq "joe");
+ ok(37, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(38, $db->FIRSTKEY() eq "fred") ;
+ ok(39, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+ }
+
+ {
+ # DBM Filter with a closure
+
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+
+ unlink <Op.dbmx*>;
+ ok(40, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(41, $result{"store key"} eq "store key - 1: [fred]");
+ ok(42, $result{"store value"} eq "store value - 1: [joe]");
+ ok(43, !defined $result{"fetch key"} );
+ ok(44, !defined $result{"fetch value"} );
+ ok(45, $_ eq "original") ;
+
+ ok(46, $db->FIRSTKEY() eq "fred") ;
+ ok(47, $result{"store key"} eq "store key - 1: [fred]");
+ ok(48, $result{"store value"} eq "store value - 1: [joe]");
+ ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(50, ! defined $result{"fetch value"} );
+ ok(51, $_ eq "original") ;
+
+ $h{"jim"} = "john" ;
+ ok(52, $result{"store key"} eq "store key - 2: [fred jim]");
+ ok(53, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(55, ! defined $result{"fetch value"} );
+ ok(56, $_ eq "original") ;
+
+ ok(57, $h{"fred"} eq "joe");
+ ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]");
+ ok(59, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(62, $_ eq "original") ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+ }
+
+ {
+ # DBM Filter recursion detection
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+ unlink <Op.dbmx*>;
+
+ ok(63, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok(64, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+ }
+
+ {
+ # Bug ID 20001013.009
+ #
+ # test that $hash{KEY} = undef doesn't produce the warning
+ # Use of uninitialized value in null operation
+ use warnings ;
+ use strict ;
+ use ODBM_File ;
+
+ unlink <Op.dbmx*>;
+ my %h ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ ok(65, tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+ $h{ABC} = undef;
+ ok(66, $a eq "") ;
+ untie %h;
+ unlink <Op.dbmx*>;
+ }
+
+ if ($^O eq 'hpux') {
+ print <<EOM;
+ #
+ # If you experience failures with the odbm test in HP-UX,
+ # this is a well-known bug that's unfortunately very hard to fix.
+ # The suggested course of action is to avoid using the ODBM_File,
+ # but to use instead the NDBM_File extension.
+ #
+ EOM
+ }
diff -c 'perl-5.7.1/ext/Opcode/Opcode.pm' 'perl-5.7.2/ext/Opcode/Opcode.pm'
Index: ./ext/Opcode/Opcode.pm
*** ./ext/Opcode/Opcode.pm Tue Mar 6 04:04:55 2001
--- ./ext/Opcode/Opcode.pm Mon Jul 9 17:10:10 2001
***************
*** 6,12 ****
our($VERSION, $XS_VERSION, @ISA, @EXPORT_OK);
! $VERSION = "1.04";
$XS_VERSION = "1.03";
use Carp;
--- 6,12 ----
our($VERSION, $XS_VERSION, @ISA, @EXPORT_OK);
! $VERSION = "1.05";
$XS_VERSION = "1.03";
use Carp;
diff -c /dev/null 'perl-5.7.2/ext/Opcode/Opcode.t'
Index: ./ext/Opcode/Opcode.t
*** ./ext/Opcode/Opcode.t Thu Jan 1 02:00:00 1970
--- ./ext/Opcode/Opcode.t Mon Jul 9 17:10:10 2001
***************
*** 0 ****
--- 1,115 ----
+ #!./perl -w
+
+ $|=1;
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ use Opcode qw(
+ opcodes opdesc opmask verify_opset
+ opset opset_to_ops opset_to_hex invert_opset
+ opmask_add full_opset empty_opset define_optag
+ );
+
+ use strict;
+
+ my $t = 1;
+ my $last_test; # initalised at end
+ print "1..$last_test\n";
+
+ my($s1, $s2, $s3);
+ my(@o1, @o2, @o3);
+
+ # --- opset_to_ops and opset
+
+ my @empty_l = opset_to_ops(empty_opset);
+ print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ my @full_l1 = opset_to_ops(full_opset);
+ print @full_l1 == opcodes() ? "ok $t\n" : "not ok $t\n"; $t++;
+ my @full_l2 = @full_l1; # = opcodes(); # XXX to be fixed
+ print "@full_l1" eq "@full_l2" ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ @empty_l = opset_to_ops(opset(':none'));
+ print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ my @full_l3 = opset_to_ops(opset(':all'));
+ print @full_l1 == @full_l3 ? "ok $t\n" : "not ok $t\n"; $t++;
+ print "@full_l1" eq "@full_l3" ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ die $t unless $t == 7;
+ $s1 = opset( 'padsv');
+ $s2 = opset($s1, 'padav');
+ $s3 = opset($s2, '!padav');
+ print $s1 eq $s2 ? "not ok $t\n" : "ok $t\n"; ++$t;
+ print $s1 eq $s3 ? "ok $t\n" : "not ok $t\n"; ++$t;
+
+ # --- define_optag
+
+ print eval { opset(':_tst_') } ? "not ok $t\n" : "ok $t\n"; ++$t;
+ define_optag(":_tst_", opset(qw(padsv padav padhv)));
+ print eval { opset(':_tst_') } ? "ok $t\n" : "not ok $t\n"; ++$t;
+
+ # --- opdesc and opcodes
+
+ die $t unless $t == 11;
+ print opdesc("gv") eq "glob value" ? "ok $t\n" : "not ok $t\n"; $t++;
+ my @desc = opdesc(':_tst_','stub');
+ print "@desc" eq "private variable private array private hash stub"
+ ? "ok $t\n" : "not ok $t\n#@desc\n"; $t++;
+ print opcodes() ? "ok $t\n" : "not ok $t\n"; $t++;
+ print "ok $t\n"; ++$t;
+
+ # --- invert_opset
+
+ $s1 = opset(qw(fileno padsv padav));
+ @o2 = opset_to_ops(invert_opset($s1));
+ print @o2 == opcodes-3 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ # --- opmask
+
+ die $t unless $t == 16;
+ print opmask() eq empty_opset() ? "ok $t\n" : "not ok $t\n"; $t++; # work
+ print length opmask() == int((opcodes()+7)/8) ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ # --- verify_opset
+
+ print verify_opset($s1) && !verify_opset(42) ? "ok $t\n":"not ok $t\n"; $t++;
+
+ # --- opmask_add
+
+ opmask_add(opset(qw(fileno))); # add to global op_mask
+ print eval 'fileno STDOUT' ? "not ok $t\n" : "ok $t\n"; $t++; # fail
+ print $@ =~ /fileno trapped/ ? "ok $t\n" : "not ok $t\n# $@\n"; $t++;
+
+ # --- check use of bit vector ops on opsets
+
+ $s1 = opset('padsv');
+ $s2 = opset('padav');
+ $s3 = opset('padsv', 'padav', 'padhv');
+
+ # Non-negated
+ print (($s1 | $s2) eq opset($s1,$s2) ? "ok $t\n":"not ok $t\n"); $t++;
+ print (($s2 & $s3) eq opset($s2) ? "ok $t\n":"not ok $t\n"); $t++;
+ print (($s2 ^ $s3) eq opset('padsv','padhv') ? "ok $t\n":"not ok $t\n"); $t++;
+
+ # Negated, e.g., with possible extra bits in last byte beyond last op bit.
+ # The extra bits mean we can't just say ~mask eq invert_opset(mask).
+
+ @o1 = opset_to_ops( ~ $s3);
+ @o2 = opset_to_ops(invert_opset $s3);
+ print "@o1" eq "@o2" ? "ok $t\n":"not ok $t\n"; $t++;
+
+ # --- finally, check some opname assertions
+
+ foreach(@full_l1) { die "bad opname: $_" if /\W/ or /^\d/ }
+
+ print "ok $last_test\n";
+ BEGIN { $last_test = 25 }
diff -c 'perl-5.7.1/ext/Opcode/Safe.pm' 'perl-5.7.2/ext/Opcode/Safe.pm'
Index: ./ext/Opcode/Safe.pm
*** ./ext/Opcode/Safe.pm Tue Mar 6 04:04:55 2001
--- ./ext/Opcode/Safe.pm Mon Jul 9 17:10:10 2001
***************
*** 3,9 ****
use 5.003_11;
use strict;
! our $VERSION = "2.06";
use Carp;
--- 3,9 ----
use 5.003_11;
use strict;
! our $VERSION = "2.07";
use Carp;
diff -c /dev/null 'perl-5.7.2/ext/Opcode/ops.t'
Index: ./ext/Opcode/ops.t
*** ./ext/Opcode/ops.t Thu Jan 1 02:00:00 1970
--- ./ext/Opcode/ops.t Mon Jul 9 17:10:10 2001
***************
*** 0 ****
--- 1,29 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ print "1..2\n";
+
+ eval <<'EOP';
+ no ops 'fileno'; # equiv to "perl -M-ops=fileno"
+ $a = fileno STDIN;
+ EOP
+
+ print $@ =~ /trapped/ ? "ok 1\n" : "not ok 1\n# $@\n";
+
+ eval <<'EOP';
+ use ops ':default'; # equiv to "perl -M(as above) -Mops=:default"
+ eval 1;
+ EOP
+
+ print $@ =~ /trapped/ ? "ok 2\n" : "not ok 2\n# $@\n";
+
+ 1;
diff -c 'perl-5.7.1/ext/POSIX/Makefile.PL' 'perl-5.7.2/ext/POSIX/Makefile.PL'
Index: ./ext/POSIX/Makefile.PL
*** ./ext/POSIX/Makefile.PL Tue Mar 6 04:04:55 2001
--- ./ext/POSIX/Makefile.PL Mon Jul 9 17:10:10 2001
***************
*** 1,4 ****
--- 1,5 ----
use ExtUtils::MakeMaker;
+ use ExtUtils::Constant 0.07 'WriteConstants';
use Config;
my @libs;
if ($^O ne 'MSWin32') {
***************
*** 10,13 ****
--- 11,101 ----
MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes', # XXX remove later?
VERSION_FROM => 'POSIX.pm',
+ realclean => {FILES=> 'constants.c constants.xs'},
+ );
+
+ my @names =
+ (
+ qw(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 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 FD_CLOEXEC FILENAME_MAX F_DUPFD F_GETFD
+ F_GETFL F_GETLK F_OK F_RDLCK F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK
+ F_WRLCK 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 LINK_MAX LONG_MAX LONG_MIN
+ L_ctermid L_cuserid L_tmpnam MAX_CANON MAX_INPUT MB_CUR_MAX MB_LEN_MAX
+ NAME_MAX NCCS NGROUPS_MAX NOFLSH 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 SCHAR_MAX
+ SCHAR_MIN SEEK_CUR SEEK_END SEEK_SET SHRT_MAX SHRT_MIN SIGABRT SIGALRM
+ SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGQUIT
+ SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2
+ SIG_BLOCK 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_ISGID 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 VEOF VEOL VERASE
+ VINTR VKILL VMIN VQUIT VSTART VSTOP VSUSP VTIME WNOHANG 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
+ _SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL _SC_NGROUPS_MAX
+ _SC_OPEN_MAX _SC_SAVED_IDS _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION),
+ {name=>"EXIT_FAILURE", default=>["IV", "1"]},
+ {name=>"EXIT_SUCCESS", default=>["IV", "0"]},
+ {name=>"SIG_DFL", value=>"(IV)SIG_DFL"},
+ {name=>"SIG_ERR", value=>"(IV)SIG_ERR"},
+ {name=>"SIG_IGN", value=>"(IV)SIG_IGN"},
+ # L_tmpnam[e] was a typo--retained for compatibility
+ {name=>"L_tmpname", value=>"L_tmpnam"},
+ {name=>"NULL", value=>"0"},
+ {name=>"_POSIX_JOB_CONTROL", type=>"YES", default=>["IV", "0"]},
+ {name=>"_POSIX_SAVED_IDS", type=>"YES", default=>["IV", "0"]},
+ {name=>"HUGE_VAL", type=>"NV",
+ macro=>[<<'END', "#endif\n"],
+ #if (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)) || defined(HUGE_VAL)
+ /* HUGE_VALL is admittedly non-POSIX but if we are using long doubles
+ * we might as well use long doubles. --jhi */
+ END
+ value=>'
+ #if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
+ HUGE_VALL
+ #else
+ HUGE_VAL
+ #endif
+ '});
+
+ push @names, {name=>$_, type=>"UV"}
+ foreach (qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND
+ SA_RESTART SA_SIGINFO UCHAR_MAX UINT_MAX ULONG_MAX USHRT_MAX));
+ push @names, {name=>$_, type=>"NV"}
+ foreach (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));
+
+ push @names, {name=>$_, type=>"IV", default=>["IV", "0"]}
+ foreach (qw(_POSIX_ARG_MAX _POSIX_CHILD_MAX _POSIX_CHOWN_RESTRICTED
+ _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_SSIZE_MAX
+ _POSIX_STREAM_MAX _POSIX_TZNAME_MAX _POSIX_VDISABLE _POSIX_VERSION
+ ));
+
+ WriteConstants(
+ NAME => 'POSIX',
+ NAMES => \@names,
);
diff -c 'perl-5.7.1/ext/POSIX/POSIX.pm' 'perl-5.7.2/ext/POSIX/POSIX.pm'
Index: ./ext/POSIX/POSIX.pm
*** ./ext/POSIX/POSIX.pm Wed Mar 21 03:24:12 2001
--- ./ext/POSIX/POSIX.pm Mon Jul 9 17:10:10 2001
***************
*** 23,30 ****
XSLoader::load 'POSIX', $VERSION;
! my $EINVAL = constant("EINVAL", 0);
! my $EAGAIN = constant("EAGAIN", 0);
sub AUTOLOAD {
if ($AUTOLOAD =~ /::(_?[a-z])/) {
--- 23,31 ----
XSLoader::load 'POSIX', $VERSION;
! my %NON_CONSTS = (map {($_,1)}
! qw(S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG WEXITSTATUS
! WIFEXITED WIFSIGNALED WIFSTOPPED WSTOPSIG WTERMSIG));
sub AUTOLOAD {
if ($AUTOLOAD =~ /::(_?[a-z])/) {
***************
*** 35,52 ****
local $! = 0;
my $constname = $AUTOLOAD;
$constname =~ s/.*:://;
! my $val = constant($constname, @_ ? $_[0] : 0);
! if ($! == 0) {
*$AUTOLOAD = sub { $val };
- }
- elsif ($! == $EAGAIN) { # Not really a constant, so always call.
- *$AUTOLOAD = sub { constant($constname, $_[0]) };
- }
- elsif ($! == $EINVAL) {
- croak "$constname is not a valid POSIX macro";
- }
- else {
- croak "Your vendor has not defined POSIX macro $constname, used";
}
goto &$AUTOLOAD;
--- 36,49 ----
local $! = 0;
my $constname = $AUTOLOAD;
$constname =~ s/.*:://;
! if ($NON_CONSTS{$constname}) {
! my ($val, $error) = &int_macro_int($constname, $_[0]);
! croak $error if $error;
! *$AUTOLOAD = sub { &int_macro_int($constname, $_[0]) };
! } else {
! my ($error, $val) = constant($constname);
! croak $error if $error;
*$AUTOLOAD = sub { $val };
}
goto &$AUTOLOAD;
diff -c 'perl-5.7.1/ext/POSIX/POSIX.pod' 'perl-5.7.2/ext/POSIX/POSIX.pod'
Index: ./ext/POSIX/POSIX.pod
*** ./ext/POSIX/POSIX.pod Tue Mar 6 04:04:55 2001
--- ./ext/POSIX/POSIX.pod Mon Jul 9 17:10:10 2001
***************
*** 1230,1235 ****
--- 1230,1237 ----
$str = POSIX::strftime( "%A, %B %d, %Y", 0, 0, 0, 12, 11, 95, 2 );
print "$str\n";
+ See also L<Time::Piece>.
+
=item strlen
strlen() is C-specific, use C<length()> instead, see L<perlfunc/length>.
diff -c /dev/null 'perl-5.7.2/ext/POSIX/POSIX.t'
Index: ./ext/POSIX/POSIX.t
*** ./ext/POSIX/POSIX.t Thu Jan 1 02:00:00 1970
--- ./ext/POSIX/POSIX.t Wed Jul 11 17:18:25 2001
***************
*** 0 ****
--- 1,160 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($^O ne 'VMS' and $Config{'extensions'} !~ /\bPOSIX\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write
+ errno);
+ use strict subs;
+
+ $| = 1;
+ print "1..29\n";
+
+ $Is_W32 = $^O eq 'MSWin32';
+ $Is_NetWare = $^O eq 'NetWare';
+ $Is_Dos = $^O eq 'dos';
+ $Is_MPE = $^O eq 'mpeix';
+
+ $testfd = open("TEST", O_RDONLY, 0) and print "ok 1\n";
+ read($testfd, $buffer, 9) if $testfd > 2;
+ print $buffer eq "#!./perl\n" ? "ok 2\n" : "not ok 2\n";
+
+ write(1,"ok 3\nnot ok 3\n", 5);
+
+ if ($Is_Dos) {
+ for (4..5) {
+ print "ok $_ # skipped, no pipe() support on dos\n";
+ }
+ } else {
+ @fds = POSIX::pipe();
+ print $fds[0] > $testfd ? "ok 4\n" : "not ok 4\n";
+ CORE::open($reader = \*READER, "<&=".$fds[0]);
+ CORE::open($writer = \*WRITER, ">&=".$fds[1]);
+ print $writer "ok 5\n";
+ close $writer;
+ print <$reader>;
+ close $reader;
+ }
+
+ if ($Is_W32 || $Is_Dos) {
+ for (6..11) {
+ print "ok $_ # skipped, no sigaction support on win32/dos\n";
+ }
+ }
+ else {
+ $sigset = new POSIX::SigSet 1,3;
+ delset $sigset 1;
+ if (!ismember $sigset 1) { print "ok 6\n" }
+ if (ismember $sigset 3) { print "ok 7\n" }
+ $mask = new POSIX::SigSet &SIGINT;
+ $action = new POSIX::SigAction 'main::SigHUP', $mask, 0;
+ sigaction(&SIGHUP, $action);
+ $SIG{'INT'} = 'SigINT';
+ kill 'HUP', $$;
+ sleep 1;
+ print "ok 11\n";
+
+ sub SigHUP {
+ print "ok 8\n";
+ kill 'INT', $$;
+ sleep 2;
+ print "ok 9\n";
+ }
+
+ sub SigINT {
+ print "ok 10\n";
+ }
+ }
+
+ if ($Is_MPE) {
+ print "ok 12 # skipped, _POSIX_OPEN_MAX is inaccurate on MPE\n"
+ } else {
+ print &_POSIX_OPEN_MAX > $fds[1] ? "ok 12\n" : "not ok 12\n"
+ }
+
+ print getcwd() =~ m#[/\\]t$# ? "ok 13\n" : "not ok 13\n";
+
+ # Check string conversion functions.
+
+ if ($Config{d_strtod}) {
+ $lc = &POSIX::setlocale(&POSIX::LC_NUMERIC, 'C') if $Config{d_setlocale};
+ ($n, $x) = &POSIX::strtod('3.14159_OR_SO');
+ # we're just checking that strtod works, not how accurate it is
+ print (("3.14159" eq $n + 0) && ($x == 6) ?
+ "ok 14\n" : "not ok 14\n");
+ &POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if $Config{d_setlocale};
+ } else { print "# strtod not present\n", "ok 14\n"; }
+
+ if ($Config{d_strtol}) {
+ ($n, $x) = &POSIX::strtol('21_PENGUINS');
+ print (($n == 21) && ($x == 9) ? "ok 15\n" : "not ok 15\n");
+ } else { print "# strtol not present\n", "ok 15\n"; }
+
+ if ($Config{d_strtoul}) {
+ ($n, $x) = &POSIX::strtoul('88_TEARS');
+ print (($n == 88) && ($x == 6) ? "ok 16\n" : "not ok 16\n");
+ } else { print "# strtoul not present\n", "ok 16\n"; }
+
+ # Pick up whether we're really able to dynamically load everything.
+ print &POSIX::acos(1.0) == 0.0 ? "ok 17\n" : "not ok 17\n";
+
+ # 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 18 # %H:%M, on %D\n", localtime());
+
+ # If that worked, validate the mini_mktime() routine's normalisation of
+ # input fields to strftime().
+ sub try_strftime {
+ my $num = shift;
+ my $expect = shift;
+ my $got = POSIX::strftime("%a %b %d %H:%M:%S %Y %j", @_);
+ if ($got eq $expect) {
+ print "ok $num\n";
+ }
+ else {
+ print "# expected: $expect\n# got: $got\nnot ok $num\n";
+ }
+ }
+
+ $lc = &POSIX::setlocale(&POSIX::LC_TIME, 'C') if $Config{d_setlocale};
+ try_strftime(19, "Wed Feb 28 00:00:00 1996 059", 0,0,0, 28,1,96);
+ try_strftime(20, "Thu Feb 29 00:00:60 1996 060", 60,0,-24, 30,1,96);
+ try_strftime(21, "Fri Mar 01 00:00:00 1996 061", 0,0,-24, 31,1,96);
+ try_strftime(22, "Sun Feb 28 00:00:00 1999 059", 0,0,0, 28,1,99);
+ try_strftime(23, "Mon Mar 01 00:00:00 1999 060", 0,0,24, 28,1,99);
+ try_strftime(24, "Mon Feb 28 00:00:00 2000 059", 0,0,0, 28,1,100);
+ try_strftime(25, "Tue Feb 29 00:00:00 2000 060", 0,0,0, 0,2,100);
+ try_strftime(26, "Wed Mar 01 00:00:00 2000 061", 0,0,0, 1,2,100);
+ try_strftime(27, "Fri Mar 31 00:00:00 2000 091", 0,0,0, 31,2,100);
+ &POSIX::setlocale(&POSIX::LC_TIME, $lc) if $Config{d_setlocale};
+
+ {
+ for my $test (0, 1) {
+ $! = 0;
+ # POSIX::errno is autoloaded.
+ # Autoloading requires many system calls.
+ # errno() looks at $! to generate its result.
+ # Autoloading should not munge the value.
+ my $foo = $!;
+ my $errno = POSIX::errno();
+ print "not " unless $errno == $foo;
+ print "ok ", 28 + $test, "\n";
+ }
+ }
+
+ $| = 0;
+ # The following line assumes buffered output, which may be not true with EMX:
+ print '@#!*$@(!@#$' unless ($^O eq 'os2' || $^O eq 'uwin' || $^O eq 'os390' ||
+ (defined $ENV{PERLIO} &&
+ $ENV{PERLIO} eq 'unix' &&
+ $Config::Config{useperlio}));
+ _exit(0);
diff -c 'perl-5.7.1/ext/POSIX/POSIX.xs' 'perl-5.7.2/ext/POSIX/POSIX.xs'
Index: ./ext/POSIX/POSIX.xs
*** ./ext/POSIX/POSIX.xs Sat Mar 24 17:55:27 2001
--- ./ext/POSIX/POSIX.xs Mon Jul 9 17:10:10 2001
***************
*** 2,7 ****
--- 2,18 ----
#define _POSIX_
#endif
+ #ifdef NETWARE
+ #define _POSIX_
+ /*
+ * Ideally this should be somewhere down in the includes
+ * but putting it in other places is giving compiler errors.
+ * Also here I am unable to check for HAS_UNAME since it wouldn't have
+ * yet come into the file at this stage - sgp 18th Oct 2000
+ */
+ #include <sys/utsname.h>
+ #endif /* NETWARE */
+
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
***************
*** 64,69 ****
--- 75,90 ----
#endif
#include <fcntl.h>
+ #ifdef HAS_TZNAME
+ # if !defined(WIN32) && !defined(__CYGWIN__) && !defined(NETWARE)
+ extern char *tzname[];
+ # endif
+ #else
+ #if !defined(WIN32) || (defined(__MINGW32__) && !defined(tzname))
+ char *tzname[] = { "" , "" };
+ #endif
+ #endif
+
#if defined(__VMS) && !defined(__POSIX_SOURCE)
# include <libdef.h> /* LIB$_INVARG constant */
# include <lib$routines.h> /* prototype for lib$ediv() */
***************
*** 116,122 ****
#if defined (__CYGWIN__)
# define tzname _tzname
#endif
! #if defined (WIN32)
# undef mkfifo
# define mkfifo(a,b) not_here("mkfifo")
# define ttyname(a) (char*)not_here("ttyname")
--- 137,143 ----
#if defined (__CYGWIN__)
# define tzname _tzname
#endif
! #if defined (WIN32) || defined (NETWARE)
# undef mkfifo
# define mkfifo(a,b) not_here("mkfifo")
# define ttyname(a) (char*)not_here("ttyname")
***************
*** 146,151 ****
--- 167,176 ----
# define sigdelset(a,b) not_here("sigdelset")
# define sigfillset(a) not_here("sigfillset")
# define sigismember(a,b) not_here("sigismember")
+ #ifndef NETWARE
+ # define setuid(a) not_here("setuid")
+ # define setgid(a) not_here("setgid")
+ #endif /* NETWARE */
#else
# ifndef HAS_MKFIFO
***************
*** 172,178 ****
# ifdef I_UTIME
# include <utime.h>
# endif
! #endif /* WIN32 */
#endif /* __VMS */
typedef int SysRet;
--- 197,203 ----
# ifdef I_UTIME
# include <utime.h>
# endif
! #endif /* WIN32 || NETWARE */
#endif /* __VMS */
typedef int SysRet;
***************
*** 259,265 ****
--- 284,292 ----
#define tcsetpgrp(a,b) not_here("tcsetpgrp")
#endif
#ifndef HAS_TIMES
+ #ifndef NETWARE
#define times(a) not_here("times")
+ #endif /* NETWARE */
#endif
#ifndef HAS_UNAME
#define uname(a) not_here("uname")
***************
*** 300,545 ****
#define localeconv() not_here("localeconv")
#endif
- #ifdef HAS_TZNAME
- # if !defined(WIN32) && !defined(__CYGWIN__)
- extern char *tzname[];
- # endif
- #else
- #if !defined(WIN32) || (defined(__MINGW32__) && !defined(tzname))
- char *tzname[] = { "" , "" };
- #endif
- #endif
-
- /* XXX struct tm on some systems (SunOS4/BSD) contains extra (non POSIX)
- * fields for which we don't have Configure support yet:
- * char *tm_zone; -- abbreviation of timezone name
- * long tm_gmtoff; -- offset from GMT in seconds
- * To workaround core dumps from the uninitialised tm_zone we get the
- * system to give us a reasonable struct to copy. This fix means that
- * strftime uses the tm_zone and tm_gmtoff values returned by
- * localtime(time()). That should give the desired result most of the
- * time. But probably not always!
- *
- * This is a temporary workaround to be removed once Configure
- * support is added and NETaa14816 is considered in full.
- * It does not address tzname aspects of NETaa14816.
- */
- #ifdef HAS_GNULIBC
- # ifndef STRUCT_TM_HASZONE
- # define STRUCT_TM_HASZONE
- # endif
- #endif
-
- #ifdef STRUCT_TM_HASZONE
- static void
- init_tm(struct tm *ptm) /* see mktime, strftime and asctime */
- {
- Time_t now;
- (void)time(&now);
- Copy(localtime(&now), ptm, 1, struct tm);
- }
-
- #else
- # define init_tm(ptm)
- #endif
-
- /*
- * mini_mktime - normalise struct tm values without the localtime()
- * semantics (and overhead) of mktime().
- */
- static void
- mini_mktime(struct tm *ptm)
- {
- int yearday;
- int secs;
- int month, mday, year, jday;
- int odd_cent, odd_year;
-
- #define DAYS_PER_YEAR 365
- #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
- #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
- #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
- #define SECS_PER_HOUR (60*60)
- #define SECS_PER_DAY (24*SECS_PER_HOUR)
- /* parentheses deliberately absent on these two, otherwise they don't work */
- #define MONTH_TO_DAYS 153/5
- #define DAYS_TO_MONTH 5/153
- /* offset to bias by March (month 4) 1st between month/mday & year finding */
- #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
- /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
- #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
-
- /*
- * Year/day algorithm notes:
- *
- * With a suitable offset for numeric value of the month, one can find
- * an offset into the year by considering months to have 30.6 (153/5) days,
- * using integer arithmetic (i.e., with truncation). To avoid too much
- * messing about with leap days, we consider January and February to be
- * the 13th and 14th month of the previous year. After that transformation,
- * we need the month index we use to be high by 1 from 'normal human' usage,
- * so the month index values we use run from 4 through 15.
- *
- * Given that, and the rules for the Gregorian calendar (leap years are those
- * divisible by 4 unless also divisible by 100, when they must be divisible
- * by 400 instead), we can simply calculate the number of days since some
- * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
- * the days we derive from our month index, and adding in the day of the
- * month. The value used here is not adjusted for the actual origin which
- * it normally would use (1 January A.D. 1), since we're not exposing it.
- * We're only building the value so we can turn around and get the
- * normalised values for the year, month, day-of-month, and day-of-year.
- *
- * For going backward, we need to bias the value we're using so that we find
- * the right year value. (Basically, we don't want the contribution of
- * March 1st to the number to apply while deriving the year). Having done
- * that, we 'count up' the contribution to the year number by accounting for
- * full quadracenturies (400-year periods) with their extra leap days, plus
- * the contribution from full centuries (to avoid counting in the lost leap
- * days), plus the contribution from full quad-years (to count in the normal
- * leap days), plus the leftover contribution from any non-leap years.
- * At this point, if we were working with an actual leap day, we'll have 0
- * days left over. This is also true for March 1st, however. So, we have
- * to special-case that result, and (earlier) keep track of the 'odd'
- * century and year contributions. If we got 4 extra centuries in a qcent,
- * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
- * Otherwise, we add back in the earlier bias we removed (the 123 from
- * figuring in March 1st), find the month index (integer division by 30.6),
- * and the remainder is the day-of-month. We then have to convert back to
- * 'real' months (including fixing January and February from being 14/15 in
- * the previous year to being in the proper year). After that, to get
- * tm_yday, we work with the normalised year and get a new yearday value for
- * January 1st, which we subtract from the yearday value we had earlier,
- * representing the date we've re-built. This is done from January 1
- * because tm_yday is 0-origin.
- *
- * Since POSIX time routines are only guaranteed to work for times since the
- * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
- * applies Gregorian calendar rules even to dates before the 16th century
- * doesn't bother me. Besides, you'd need cultural context for a given
- * date to know whether it was Julian or Gregorian calendar, and that's
- * outside the scope for this routine. Since we convert back based on the
- * same rules we used to build the yearday, you'll only get strange results
- * for input which needed normalising, or for the 'odd' century years which
- * were leap years in the Julian calander but not in the Gregorian one.
- * I can live with that.
- *
- * This algorithm also fails to handle years before A.D. 1 gracefully, but
- * that's still outside the scope for POSIX time manipulation, so I don't
- * care.
- */
-
- year = 1900 + ptm->tm_year;
- month = ptm->tm_mon;
- mday = ptm->tm_mday;
- /* allow given yday with no month & mday to dominate the result */
- if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
- month = 0;
- mday = 0;
- jday = 1 + ptm->tm_yday;
- }
- else {
- jday = 0;
- }
- if (month >= 2)
- month+=2;
- else
- month+=14, year--;
- yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
- yearday += month*MONTH_TO_DAYS + mday + jday;
- /*
- * Note that we don't know when leap-seconds were or will be,
- * so we have to trust the user if we get something which looks
- * like a sensible leap-second. Wild values for seconds will
- * be rationalised, however.
- */
- if ((unsigned) ptm->tm_sec <= 60) {
- secs = 0;
- }
- else {
- secs = ptm->tm_sec;
- ptm->tm_sec = 0;
- }
- secs += 60 * ptm->tm_min;
- secs += SECS_PER_HOUR * ptm->tm_hour;
- if (secs < 0) {
- if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
- /* got negative remainder, but need positive time */
- /* back off an extra day to compensate */
- yearday += (secs/SECS_PER_DAY)-1;
- secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
- }
- else {
- yearday += (secs/SECS_PER_DAY);
- secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
- }
- }
- else if (secs >= SECS_PER_DAY) {
- yearday += (secs/SECS_PER_DAY);
- secs %= SECS_PER_DAY;
- }
- ptm->tm_hour = secs/SECS_PER_HOUR;
- secs %= SECS_PER_HOUR;
- ptm->tm_min = secs/60;
- secs %= 60;
- ptm->tm_sec += secs;
- /* done with time of day effects */
- /*
- * The algorithm for yearday has (so far) left it high by 428.
- * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
- * bias it by 123 while trying to figure out what year it
- * really represents. Even with this tweak, the reverse
- * translation fails for years before A.D. 0001.
- * It would still fail for Feb 29, but we catch that one below.
- */
- jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
- yearday -= YEAR_ADJUST;
- year = (yearday / DAYS_PER_QCENT) * 400;
- yearday %= DAYS_PER_QCENT;
- odd_cent = yearday / DAYS_PER_CENT;
- year += odd_cent * 100;
- yearday %= DAYS_PER_CENT;
- year += (yearday / DAYS_PER_QYEAR) * 4;
- yearday %= DAYS_PER_QYEAR;
- odd_year = yearday / DAYS_PER_YEAR;
- year += odd_year;
- yearday %= DAYS_PER_YEAR;
- if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
- month = 1;
- yearday = 29;
- }
- else {
- yearday += YEAR_ADJUST; /* recover March 1st crock */
- month = yearday*DAYS_TO_MONTH;
- yearday -= month*MONTH_TO_DAYS;
- /* recover other leap-year adjustment */
- if (month > 13) {
- month-=14;
- year++;
- }
- else {
- month-=2;
- }
- }
- ptm->tm_year = year - 1900;
- if (yearday) {
- ptm->tm_mday = yearday;
- ptm->tm_mon = month;
- }
- else {
- ptm->tm_mday = 31;
- ptm->tm_mon = month - 1;
- }
- /* re-build yearday based on Jan 1 to get tm_yday */
- year--;
- yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
- yearday += 14*MONTH_TO_DAYS + 1;
- ptm->tm_yday = jday - yearday;
- /* fix tm_wday if not overridden by caller */
- if ((unsigned)ptm->tm_wday > 6)
- ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
- }
-
#ifdef HAS_LONG_DOUBLE
# if LONG_DOUBLESIZE > NVSIZE
# undef HAS_LONG_DOUBLE /* XXX until we figure out how to use them */
--- 327,332 ----
***************
*** 565,2793 ****
return -1;
}
! static
! NV
! constant(char *name, int arg)
! {
! errno = 0;
! switch (*name) {
! case 'A':
! if (strEQ(name, "ARG_MAX"))
! #ifdef ARG_MAX
! return ARG_MAX;
! #else
! goto not_there;
! #endif
! break;
! case 'B':
! if (strEQ(name, "BUFSIZ"))
! #ifdef BUFSIZ
! return BUFSIZ;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "BRKINT"))
! #ifdef BRKINT
! return BRKINT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "B9600"))
! #ifdef B9600
! return B9600;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "B19200"))
! #ifdef B19200
! return B19200;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "B38400"))
! #ifdef B38400
! return B38400;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "B0"))
! #ifdef B0
! return B0;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "B110"))
! #ifdef B110
! return B110;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "B1200"))
! #ifdef B1200
! return B1200;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "B134"))
! #ifdef B134
! return B134;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "B150"))
! #ifdef B150
! return B150;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "B1800"))
! #ifdef B1800
! return B1800;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "B200"))
! #ifdef B200
! return B200;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "B2400"))
! #ifdef B2400
! return B2400;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "B300"))
! #ifdef B300
! return B300;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "B4800"))
! #ifdef B4800
! return B4800;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "B50"))
! #ifdef B50
! return B50;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "B600"))
! #ifdef B600
! return B600;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "B75"))
! #ifdef B75
! return B75;
! #else
! goto not_there;
! #endif
! break;
! case 'C':
! if (strEQ(name, "CHAR_BIT"))
! #ifdef CHAR_BIT
! return CHAR_BIT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "CHAR_MAX"))
! #ifdef CHAR_MAX
! return CHAR_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "CHAR_MIN"))
! #ifdef CHAR_MIN
! return CHAR_MIN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "CHILD_MAX"))
! #ifdef CHILD_MAX
! return CHILD_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "CLK_TCK"))
! #ifdef CLK_TCK
! return CLK_TCK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "CLOCAL"))
! #ifdef CLOCAL
! return CLOCAL;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "CLOCKS_PER_SEC"))
! #ifdef CLOCKS_PER_SEC
! return CLOCKS_PER_SEC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "CREAD"))
! #ifdef CREAD
! return CREAD;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "CS5"))
! #ifdef CS5
! return CS5;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "CS6"))
! #ifdef CS6
! return CS6;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "CS7"))
! #ifdef CS7
! return CS7;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "CS8"))
! #ifdef CS8
! return CS8;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "CSIZE"))
! #ifdef CSIZE
! return CSIZE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "CSTOPB"))
! #ifdef CSTOPB
! return CSTOPB;
! #else
! goto not_there;
! #endif
! break;
! case 'D':
! if (strEQ(name, "DBL_MAX"))
! #ifdef DBL_MAX
! return DBL_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "DBL_MIN"))
! #ifdef DBL_MIN
! return DBL_MIN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "DBL_DIG"))
! #ifdef DBL_DIG
! return DBL_DIG;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "DBL_EPSILON"))
! #ifdef DBL_EPSILON
! return DBL_EPSILON;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "DBL_MANT_DIG"))
! #ifdef DBL_MANT_DIG
! return DBL_MANT_DIG;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "DBL_MAX_10_EXP"))
! #ifdef DBL_MAX_10_EXP
! return DBL_MAX_10_EXP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "DBL_MAX_EXP"))
! #ifdef DBL_MAX_EXP
! return DBL_MAX_EXP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "DBL_MIN_10_EXP"))
! #ifdef DBL_MIN_10_EXP
! return DBL_MIN_10_EXP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "DBL_MIN_EXP"))
! #ifdef DBL_MIN_EXP
! return DBL_MIN_EXP;
! #else
! goto not_there;
! #endif
! break;
case 'E':
! switch (name[1]) {
! case 'A':
! if (strEQ(name, "EACCES"))
! #ifdef EACCES
! return EACCES;
#else
! goto not_there;
#endif
! if (strEQ(name, "EADDRINUSE"))
! #ifdef EADDRINUSE
! return EADDRINUSE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EADDRNOTAVAIL"))
! #ifdef EADDRNOTAVAIL
! return EADDRNOTAVAIL;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EAFNOSUPPORT"))
! #ifdef EAFNOSUPPORT
! return EAFNOSUPPORT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EAGAIN"))
! #ifdef EAGAIN
! return EAGAIN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EALREADY"))
! #ifdef EALREADY
! return EALREADY;
! #else
! goto not_there;
! #endif
! break;
! case 'B':
! if (strEQ(name, "EBADF"))
! #ifdef EBADF
! return EBADF;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EBUSY"))
! #ifdef EBUSY
! return EBUSY;
! #else
! goto not_there;
! #endif
! break;
! case 'C':
! if (strEQ(name, "ECHILD"))
! #ifdef ECHILD
! return ECHILD;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ECHO"))
! #ifdef ECHO
! return ECHO;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ECHOE"))
! #ifdef ECHOE
! return ECHOE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ECHOK"))
! #ifdef ECHOK
! return ECHOK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ECHONL"))
! #ifdef ECHONL
! return ECHONL;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ECONNABORTED"))
! #ifdef ECONNABORTED
! return ECONNABORTED;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ECONNREFUSED"))
! #ifdef ECONNREFUSED
! return ECONNREFUSED;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ECONNRESET"))
! #ifdef ECONNRESET
! return ECONNRESET;
! #else
! goto not_there;
! #endif
! break;
! case 'D':
! if (strEQ(name, "EDEADLK"))
! #ifdef EDEADLK
! return EDEADLK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EDESTADDRREQ"))
! #ifdef EDESTADDRREQ
! return EDESTADDRREQ;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EDOM"))
! #ifdef EDOM
! return EDOM;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EDQUOT"))
! #ifdef EDQUOT
! return EDQUOT;
! #else
! goto not_there;
! #endif
! break;
! case 'E':
! if (strEQ(name, "EEXIST"))
! #ifdef EEXIST
! return EEXIST;
! #else
! goto not_there;
! #endif
! break;
! case 'F':
! if (strEQ(name, "EFAULT"))
! #ifdef EFAULT
! return EFAULT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EFBIG"))
! #ifdef EFBIG
! return EFBIG;
! #else
! goto not_there;
! #endif
! break;
! case 'H':
! if (strEQ(name, "EHOSTDOWN"))
! #ifdef EHOSTDOWN
! return EHOSTDOWN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EHOSTUNREACH"))
! #ifdef EHOSTUNREACH
! return EHOSTUNREACH;
! #else
! goto not_there;
! #endif
! break;
! case 'I':
! if (strEQ(name, "EINPROGRESS"))
! #ifdef EINPROGRESS
! return EINPROGRESS;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EINTR"))
! #ifdef EINTR
! return EINTR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EINVAL"))
! #ifdef EINVAL
! return EINVAL;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EIO"))
! #ifdef EIO
! return EIO;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EISCONN"))
! #ifdef EISCONN
! return EISCONN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EISDIR"))
! #ifdef EISDIR
! return EISDIR;
! #else
! goto not_there;
! #endif
! break;
! case 'L':
! if (strEQ(name, "ELOOP"))
! #ifdef ELOOP
! return ELOOP;
! #else
! goto not_there;
! #endif
! break;
! case 'M':
! if (strEQ(name, "EMFILE"))
! #ifdef EMFILE
! return EMFILE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EMLINK"))
! #ifdef EMLINK
! return EMLINK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EMSGSIZE"))
! #ifdef EMSGSIZE
! return EMSGSIZE;
! #else
! goto not_there;
! #endif
! break;
! case 'N':
! if (strEQ(name, "ENETDOWN"))
! #ifdef ENETDOWN
! return ENETDOWN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENETRESET"))
! #ifdef ENETRESET
! return ENETRESET;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENETUNREACH"))
! #ifdef ENETUNREACH
! return ENETUNREACH;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENOBUFS"))
! #ifdef ENOBUFS
! return ENOBUFS;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENOEXEC"))
! #ifdef ENOEXEC
! return ENOEXEC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENOMEM"))
! #ifdef ENOMEM
! return ENOMEM;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENOPROTOOPT"))
! #ifdef ENOPROTOOPT
! return ENOPROTOOPT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENOSPC"))
! #ifdef ENOSPC
! return ENOSPC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENOTBLK"))
! #ifdef ENOTBLK
! return ENOTBLK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENOTCONN"))
! #ifdef ENOTCONN
! return ENOTCONN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENOTDIR"))
! #ifdef ENOTDIR
! return ENOTDIR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENOTEMPTY"))
! #ifdef ENOTEMPTY
! return ENOTEMPTY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENOTSOCK"))
! #ifdef ENOTSOCK
! return ENOTSOCK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENOTTY"))
! #ifdef ENOTTY
! return ENOTTY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENFILE"))
! #ifdef ENFILE
! return ENFILE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENODEV"))
! #ifdef ENODEV
! return ENODEV;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENOENT"))
! #ifdef ENOENT
! return ENOENT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENOLCK"))
! #ifdef ENOLCK
! return ENOLCK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENOSYS"))
! #ifdef ENOSYS
! return ENOSYS;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENXIO"))
! #ifdef ENXIO
! return ENXIO;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ENAMETOOLONG"))
! #ifdef ENAMETOOLONG
! return ENAMETOOLONG;
! #else
! goto not_there;
! #endif
! break;
! case 'O':
! if (strEQ(name, "EOF"))
! #ifdef EOF
! return EOF;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EOPNOTSUPP"))
! #ifdef EOPNOTSUPP
! return EOPNOTSUPP;
! #else
! goto not_there;
! #endif
! break;
! case 'P':
! if (strEQ(name, "EPERM"))
! #ifdef EPERM
! return EPERM;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EPFNOSUPPORT"))
! #ifdef EPFNOSUPPORT
! return EPFNOSUPPORT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EPIPE"))
! #ifdef EPIPE
! return EPIPE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EPROCLIM"))
! #ifdef EPROCLIM
! return EPROCLIM;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EPROTONOSUPPORT"))
! #ifdef EPROTONOSUPPORT
! return EPROTONOSUPPORT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EPROTOTYPE"))
! #ifdef EPROTOTYPE
! return EPROTOTYPE;
! #else
! goto not_there;
! #endif
! break;
! case 'R':
! if (strEQ(name, "ERANGE"))
! #ifdef ERANGE
! return ERANGE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EREMOTE"))
! #ifdef EREMOTE
! return EREMOTE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ERESTART"))
! #ifdef ERESTART
! return ERESTART;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "EROFS"))
! #ifdef EROFS
! return EROFS;
! #else
! goto not_there;
! #endif
! break;
! case 'S':
! if (strEQ(name, "ESHUTDOWN"))
! #ifdef ESHUTDOWN
! return ESHUTDOWN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ESOCKTNOSUPPORT"))
! #ifdef ESOCKTNOSUPPORT
! return ESOCKTNOSUPPORT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ESPIPE"))
! #ifdef ESPIPE
! return ESPIPE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ESRCH"))
! #ifdef ESRCH
! return ESRCH;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ESTALE"))
! #ifdef ESTALE
! return ESTALE;
! #else
! goto not_there;
! #endif
! break;
! case 'T':
! if (strEQ(name, "ETIMEDOUT"))
! #ifdef ETIMEDOUT
! return ETIMEDOUT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ETOOMANYREFS"))
! #ifdef ETOOMANYREFS
! return ETOOMANYREFS;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ETXTBSY"))
! #ifdef ETXTBSY
! return ETXTBSY;
! #else
! goto not_there;
! #endif
! break;
! case 'U':
! if (strEQ(name, "EUSERS"))
! #ifdef EUSERS
! return EUSERS;
! #else
! goto not_there;
! #endif
! break;
! case 'W':
! if (strEQ(name, "EWOULDBLOCK"))
! #ifdef EWOULDBLOCK
! return EWOULDBLOCK;
! #else
! goto not_there;
! #endif
! break;
! case 'X':
! if (strEQ(name, "EXIT_FAILURE"))
! #ifdef EXIT_FAILURE
! return EXIT_FAILURE;
! #else
! return 1;
! #endif
! if (strEQ(name, "EXIT_SUCCESS"))
! #ifdef EXIT_SUCCESS
! return EXIT_SUCCESS;
! #else
! return 0;
! #endif
! if (strEQ(name, "EXDEV"))
! #ifdef EXDEV
! return EXDEV;
! #else
! goto not_there;
! #endif
! break;
! }
! if (strEQ(name, "E2BIG"))
! #ifdef E2BIG
! return E2BIG;
! #else
! goto not_there;
! #endif
! break;
! case 'F':
! if (strnEQ(name, "FLT_", 4)) {
! if (strEQ(name, "FLT_MAX"))
! #ifdef FLT_MAX
! return FLT_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "FLT_MIN"))
! #ifdef FLT_MIN
! return FLT_MIN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "FLT_ROUNDS"))
! #ifdef FLT_ROUNDS
! return FLT_ROUNDS;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "FLT_DIG"))
! #ifdef FLT_DIG
! return FLT_DIG;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "FLT_EPSILON"))
! #ifdef FLT_EPSILON
! return FLT_EPSILON;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "FLT_MANT_DIG"))
! #ifdef FLT_MANT_DIG
! return FLT_MANT_DIG;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "FLT_MAX_10_EXP"))
! #ifdef FLT_MAX_10_EXP
! return FLT_MAX_10_EXP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "FLT_MAX_EXP"))
! #ifdef FLT_MAX_EXP
! return FLT_MAX_EXP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "FLT_MIN_10_EXP"))
! #ifdef FLT_MIN_10_EXP
! return FLT_MIN_10_EXP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "FLT_MIN_EXP"))
! #ifdef FLT_MIN_EXP
! return FLT_MIN_EXP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "FLT_RADIX"))
! #ifdef FLT_RADIX
! return FLT_RADIX;
! #else
! goto not_there;
! #endif
! break;
! }
! if (strnEQ(name, "F_", 2)) {
! if (strEQ(name, "F_DUPFD"))
! #ifdef F_DUPFD
! return F_DUPFD;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "F_GETFD"))
! #ifdef F_GETFD
! return F_GETFD;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "F_GETFL"))
! #ifdef F_GETFL
! return F_GETFL;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "F_GETLK"))
! #ifdef F_GETLK
! return F_GETLK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "F_OK"))
! #ifdef F_OK
! return F_OK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "F_RDLCK"))
! #ifdef F_RDLCK
! return F_RDLCK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "F_SETFD"))
! #ifdef F_SETFD
! return F_SETFD;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "F_SETFL"))
! #ifdef F_SETFL
! return F_SETFL;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "F_SETLK"))
! #ifdef F_SETLK
! return F_SETLK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "F_SETLKW"))
! #ifdef F_SETLKW
! return F_SETLKW;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "F_UNLCK"))
! #ifdef F_UNLCK
! return F_UNLCK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "F_WRLCK"))
! #ifdef F_WRLCK
! return F_WRLCK;
! #else
! goto not_there;
! #endif
! break;
! }
! if (strEQ(name, "FD_CLOEXEC"))
! #ifdef FD_CLOEXEC
! return FD_CLOEXEC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "FILENAME_MAX"))
! #ifdef FILENAME_MAX
! return FILENAME_MAX;
! #else
! goto not_there;
! #endif
! break;
case 'H':
! if (strEQ(name, "HUGE_VAL"))
! #if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
! /* HUGE_VALL is admittedly non-POSIX but if we are using long doubles
! * we might as well use long doubles. --jhi */
! return HUGE_VALL;
! #endif
! #ifdef HUGE_VAL
! return HUGE_VAL;
#else
! goto not_there;
#endif
! if (strEQ(name, "HUPCL"))
! #ifdef HUPCL
! return HUPCL;
! #else
! goto not_there;
! #endif
! break;
case 'I':
! if (strEQ(name, "INT_MAX"))
! #ifdef INT_MAX
! return INT_MAX;
#else
! goto not_there;
#endif
! if (strEQ(name, "INT_MIN"))
! #ifdef INT_MIN
! return INT_MIN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ICANON"))
! #ifdef ICANON
! return ICANON;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ICRNL"))
! #ifdef ICRNL
! return ICRNL;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IEXTEN"))
! #ifdef IEXTEN
! return IEXTEN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IGNBRK"))
! #ifdef IGNBRK
! return IGNBRK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IGNCR"))
! #ifdef IGNCR
! return IGNCR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IGNPAR"))
! #ifdef IGNPAR
! return IGNPAR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "INLCR"))
! #ifdef INLCR
! return INLCR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "INPCK"))
! #ifdef INPCK
! return INPCK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ISIG"))
! #ifdef ISIG
! return ISIG;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ISTRIP"))
! #ifdef ISTRIP
! return ISTRIP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IXOFF"))
! #ifdef IXOFF
! return IXOFF;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IXON"))
! #ifdef IXON
! return IXON;
! #else
! goto not_there;
! #endif
! break;
case 'L':
! if (strnEQ(name, "LC_", 3)) {
! if (strEQ(name, "LC_ALL"))
! #ifdef LC_ALL
! return LC_ALL;
#else
! goto not_there;
#endif
! if (strEQ(name, "LC_COLLATE"))
! #ifdef LC_COLLATE
! return LC_COLLATE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "LC_CTYPE"))
! #ifdef LC_CTYPE
! return LC_CTYPE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "LC_MONETARY"))
! #ifdef LC_MONETARY
! return LC_MONETARY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "LC_NUMERIC"))
! #ifdef LC_NUMERIC
! return LC_NUMERIC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "LC_TIME"))
! #ifdef LC_TIME
! return LC_TIME;
! #else
! goto not_there;
! #endif
! break;
! }
! if (strnEQ(name, "LDBL_", 5)) {
! if (strEQ(name, "LDBL_MAX"))
! #ifdef LDBL_MAX
! return LDBL_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "LDBL_MIN"))
! #ifdef LDBL_MIN
! return LDBL_MIN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "LDBL_DIG"))
! #ifdef LDBL_DIG
! return LDBL_DIG;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "LDBL_EPSILON"))
! #ifdef LDBL_EPSILON
! return LDBL_EPSILON;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "LDBL_MANT_DIG"))
! #ifdef LDBL_MANT_DIG
! return LDBL_MANT_DIG;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "LDBL_MAX_10_EXP"))
! #ifdef LDBL_MAX_10_EXP
! return LDBL_MAX_10_EXP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "LDBL_MAX_EXP"))
! #ifdef LDBL_MAX_EXP
! return LDBL_MAX_EXP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "LDBL_MIN_10_EXP"))
! #ifdef LDBL_MIN_10_EXP
! return LDBL_MIN_10_EXP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "LDBL_MIN_EXP"))
! #ifdef LDBL_MIN_EXP
! return LDBL_MIN_EXP;
! #else
! goto not_there;
! #endif
! break;
! }
! if (strnEQ(name, "L_", 2)) {
! if (strEQ(name, "L_ctermid"))
! #ifdef L_ctermid
! return L_ctermid;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "L_cuserid"))
! #ifdef L_cuserid
! return L_cuserid;
! #else
! goto not_there;
! #endif
! /* L_tmpnam[e] was a typo--retained for compatibility */
! if (strEQ(name, "L_tmpname") || strEQ(name, "L_tmpnam"))
! #ifdef L_tmpnam
! return L_tmpnam;
! #else
! goto not_there;
! #endif
! break;
! }
! if (strEQ(name, "LONG_MAX"))
! #ifdef LONG_MAX
! return LONG_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "LONG_MIN"))
! #ifdef LONG_MIN
! return LONG_MIN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "LINK_MAX"))
! #ifdef LINK_MAX
! return LINK_MAX;
! #else
! goto not_there;
! #endif
! break;
! case 'M':
! if (strEQ(name, "MAX_CANON"))
! #ifdef MAX_CANON
! return MAX_CANON;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MAX_INPUT"))
! #ifdef MAX_INPUT
! return MAX_INPUT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MB_CUR_MAX"))
! #ifdef MB_CUR_MAX
! return MB_CUR_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MB_LEN_MAX"))
! #ifdef MB_LEN_MAX
! return MB_LEN_MAX;
! #else
! goto not_there;
! #endif
! break;
! case 'N':
! if (strEQ(name, "NULL")) return 0;
! if (strEQ(name, "NAME_MAX"))
! #ifdef NAME_MAX
! return NAME_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "NCCS"))
! #ifdef NCCS
! return NCCS;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "NGROUPS_MAX"))
! #ifdef NGROUPS_MAX
! return NGROUPS_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "NOFLSH"))
! #ifdef NOFLSH
! return NOFLSH;
! #else
! goto not_there;
! #endif
! break;
case 'O':
! if (strnEQ(name, "O_", 2)) {
! if (strEQ(name, "O_APPEND"))
! #ifdef O_APPEND
! return O_APPEND;
#else
! goto not_there;
#endif
! if (strEQ(name, "O_CREAT"))
! #ifdef O_CREAT
! return O_CREAT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "O_TRUNC"))
! #ifdef O_TRUNC
! return O_TRUNC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "O_RDONLY"))
! #ifdef O_RDONLY
! return O_RDONLY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "O_RDWR"))
! #ifdef O_RDWR
! return O_RDWR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "O_WRONLY"))
! #ifdef O_WRONLY
! return O_WRONLY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "O_EXCL"))
! #ifdef O_EXCL
! return O_EXCL;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "O_NOCTTY"))
! #ifdef O_NOCTTY
! return O_NOCTTY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "O_NONBLOCK"))
! #ifdef O_NONBLOCK
! return O_NONBLOCK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "O_ACCMODE"))
! #ifdef O_ACCMODE
! return O_ACCMODE;
! #else
! goto not_there;
! #endif
! break;
! }
! if (strEQ(name, "OPEN_MAX"))
! #ifdef OPEN_MAX
! return OPEN_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "OPOST"))
! #ifdef OPOST
! return OPOST;
! #else
! goto not_there;
! #endif
! break;
! case 'P':
! if (strEQ(name, "PATH_MAX"))
! #ifdef PATH_MAX
! return PATH_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PARENB"))
! #ifdef PARENB
! return PARENB;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PARMRK"))
! #ifdef PARMRK
! return PARMRK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PARODD"))
! #ifdef PARODD
! return PARODD;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PIPE_BUF"))
! #ifdef PIPE_BUF
! return PIPE_BUF;
! #else
! goto not_there;
! #endif
! break;
case 'R':
! if (strEQ(name, "RAND_MAX"))
! #ifdef RAND_MAX
! return RAND_MAX;
#else
! goto not_there;
#endif
! if (strEQ(name, "R_OK"))
! #ifdef R_OK
! return R_OK;
! #else
! goto not_there;
! #endif
! break;
case 'S':
! if (strnEQ(name, "SIG", 3)) {
! if (name[3] == '_') {
! if (strEQ(name, "SIG_BLOCK"))
! #ifdef SIG_BLOCK
! return SIG_BLOCK;
! #else
! goto not_there;
! #endif
! #ifdef SIG_DFL
! if (strEQ(name, "SIG_DFL")) return (IV)SIG_DFL;
! #endif
! #ifdef SIG_ERR
! if (strEQ(name, "SIG_ERR")) return (IV)SIG_ERR;
! #endif
! #ifdef SIG_IGN
! if (strEQ(name, "SIG_IGN")) return (IV)SIG_IGN;
! #endif
! if (strEQ(name, "SIG_SETMASK"))
! #ifdef SIG_SETMASK
! return SIG_SETMASK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SIG_UNBLOCK"))
! #ifdef SIG_UNBLOCK
! return SIG_UNBLOCK;
! #else
! goto not_there;
! #endif
! break;
! }
! if (strEQ(name, "SIGABRT"))
! #ifdef SIGABRT
! return SIGABRT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SIGALRM"))
! #ifdef SIGALRM
! return SIGALRM;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SIGCHLD"))
! #ifdef SIGCHLD
! return SIGCHLD;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SIGCONT"))
! #ifdef SIGCONT
! return SIGCONT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SIGFPE"))
! #ifdef SIGFPE
! return SIGFPE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SIGHUP"))
! #ifdef SIGHUP
! return SIGHUP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SIGILL"))
! #ifdef SIGILL
! return SIGILL;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SIGINT"))
! #ifdef SIGINT
! return SIGINT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SIGKILL"))
! #ifdef SIGKILL
! return SIGKILL;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SIGPIPE"))
! #ifdef SIGPIPE
! return SIGPIPE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SIGQUIT"))
! #ifdef SIGQUIT
! return SIGQUIT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SIGSEGV"))
! #ifdef SIGSEGV
! return SIGSEGV;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SIGSTOP"))
! #ifdef SIGSTOP
! return SIGSTOP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SIGTERM"))
! #ifdef SIGTERM
! return SIGTERM;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SIGTSTP"))
! #ifdef SIGTSTP
! return SIGTSTP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SIGTTIN"))
! #ifdef SIGTTIN
! return SIGTTIN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SIGTTOU"))
! #ifdef SIGTTOU
! return SIGTTOU;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SIGUSR1"))
! #ifdef SIGUSR1
! return SIGUSR1;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SIGUSR2"))
! #ifdef SIGUSR2
! return SIGUSR2;
! #else
! goto not_there;
! #endif
! break;
! }
! if (name[1] == '_') {
! if (strEQ(name, "S_ISGID"))
! #ifdef S_ISGID
! return S_ISGID;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "S_ISUID"))
! #ifdef S_ISUID
! return S_ISUID;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "S_IRGRP"))
! #ifdef S_IRGRP
! return S_IRGRP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "S_IROTH"))
! #ifdef S_IROTH
! return S_IROTH;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "S_IRUSR"))
! #ifdef S_IRUSR
! return S_IRUSR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "S_IRWXG"))
! #ifdef S_IRWXG
! return S_IRWXG;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "S_IRWXO"))
! #ifdef S_IRWXO
! return S_IRWXO;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "S_IRWXU"))
! #ifdef S_IRWXU
! return S_IRWXU;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "S_IWGRP"))
! #ifdef S_IWGRP
! return S_IWGRP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "S_IWOTH"))
! #ifdef S_IWOTH
! return S_IWOTH;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "S_IWUSR"))
! #ifdef S_IWUSR
! return S_IWUSR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "S_IXGRP"))
! #ifdef S_IXGRP
! return S_IXGRP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "S_IXOTH"))
! #ifdef S_IXOTH
! return S_IXOTH;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "S_IXUSR"))
! #ifdef S_IXUSR
! return S_IXUSR;
! #else
! goto not_there;
! #endif
! errno = EAGAIN; /* the following aren't constants */
! #ifdef S_ISBLK
! if (strEQ(name, "S_ISBLK")) return S_ISBLK(arg);
! #endif
! #ifdef S_ISCHR
! if (strEQ(name, "S_ISCHR")) return S_ISCHR(arg);
! #endif
! #ifdef S_ISDIR
! if (strEQ(name, "S_ISDIR")) return S_ISDIR(arg);
! #endif
#ifdef S_ISFIFO
! if (strEQ(name, "S_ISFIFO")) return S_ISFIFO(arg);
! #endif
! #ifdef S_ISREG
! if (strEQ(name, "S_ISREG")) return S_ISREG(arg);
! #endif
! break;
! }
! if (strEQ(name, "SEEK_CUR"))
! #ifdef SEEK_CUR
! return SEEK_CUR;
#else
! goto not_there;
#endif
! if (strEQ(name, "SEEK_END"))
! #ifdef SEEK_END
! return SEEK_END;
#else
! goto not_there;
#endif
! if (strEQ(name, "SEEK_SET"))
! #ifdef SEEK_SET
! return SEEK_SET;
#else
! goto not_there;
#endif
! if (strEQ(name, "STREAM_MAX"))
! #ifdef STREAM_MAX
! return STREAM_MAX;
#else
! goto not_there;
#endif
! if (strEQ(name, "SHRT_MAX"))
! #ifdef SHRT_MAX
! return SHRT_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SHRT_MIN"))
! #ifdef SHRT_MIN
! return SHRT_MIN;
! #else
! goto not_there;
! #endif
! if (strnEQ(name, "SA_", 3)) {
! if (strEQ(name, "SA_NOCLDSTOP"))
! #ifdef SA_NOCLDSTOP
! return SA_NOCLDSTOP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SA_NOCLDWAIT"))
! #ifdef SA_NOCLDWAIT
! return SA_NOCLDWAIT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SA_NODEFER"))
! #ifdef SA_NODEFER
! return SA_NODEFER;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SA_ONSTACK"))
! #ifdef SA_ONSTACK
! return SA_ONSTACK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SA_RESETHAND"))
! #ifdef SA_RESETHAND
! return SA_RESETHAND;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SA_RESTART"))
! #ifdef SA_RESTART
! return SA_RESTART;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SA_SIGINFO"))
! #ifdef SA_SIGINFO
! return SA_SIGINFO;
! #else
! goto not_there;
! #endif
! break;
! }
! if (strEQ(name, "SCHAR_MAX"))
! #ifdef SCHAR_MAX
! return SCHAR_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SCHAR_MIN"))
! #ifdef SCHAR_MIN
! return SCHAR_MIN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SSIZE_MAX"))
! #ifdef SSIZE_MAX
! return SSIZE_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "STDIN_FILENO"))
! #ifdef STDIN_FILENO
! return STDIN_FILENO;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "STDOUT_FILENO"))
! #ifdef STDOUT_FILENO
! return STDOUT_FILENO;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "STDERR_FILENO"))
! #ifdef STDERR_FILENO
! return STDERR_FILENO;
! #else
! goto not_there;
! #endif
! break;
! case 'T':
! if (strEQ(name, "TCIFLUSH"))
! #ifdef TCIFLUSH
! return TCIFLUSH;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TCIOFF"))
! #ifdef TCIOFF
! return TCIOFF;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TCIOFLUSH"))
! #ifdef TCIOFLUSH
! return TCIOFLUSH;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TCION"))
! #ifdef TCION
! return TCION;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TCOFLUSH"))
! #ifdef TCOFLUSH
! return TCOFLUSH;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TCOOFF"))
! #ifdef TCOOFF
! return TCOOFF;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TCOON"))
! #ifdef TCOON
! return TCOON;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TCSADRAIN"))
! #ifdef TCSADRAIN
! return TCSADRAIN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TCSAFLUSH"))
! #ifdef TCSAFLUSH
! return TCSAFLUSH;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TCSANOW"))
! #ifdef TCSANOW
! return TCSANOW;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TMP_MAX"))
! #ifdef TMP_MAX
! return TMP_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TOSTOP"))
! #ifdef TOSTOP
! return TOSTOP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TZNAME_MAX"))
! #ifdef TZNAME_MAX
! return TZNAME_MAX;
! #else
! goto not_there;
! #endif
! break;
! case 'U':
! if (strEQ(name, "UCHAR_MAX"))
! #ifdef UCHAR_MAX
! return UCHAR_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "UINT_MAX"))
! #ifdef UINT_MAX
! return UINT_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "ULONG_MAX"))
! #ifdef ULONG_MAX
! return ULONG_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "USHRT_MAX"))
! #ifdef USHRT_MAX
! return USHRT_MAX;
! #else
! goto not_there;
! #endif
! break;
! case 'V':
! if (strEQ(name, "VEOF"))
! #ifdef VEOF
! return VEOF;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "VEOL"))
! #ifdef VEOL
! return VEOL;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "VERASE"))
! #ifdef VERASE
! return VERASE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "VINTR"))
! #ifdef VINTR
! return VINTR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "VKILL"))
! #ifdef VKILL
! return VKILL;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "VMIN"))
! #ifdef VMIN
! return VMIN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "VQUIT"))
! #ifdef VQUIT
! return VQUIT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "VSTART"))
! #ifdef VSTART
! return VSTART;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "VSTOP"))
! #ifdef VSTOP
! return VSTOP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "VSUSP"))
! #ifdef VSUSP
! return VSUSP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "VTIME"))
! #ifdef VTIME
! return VTIME;
! #else
! goto not_there;
! #endif
! break;
! case 'W':
! if (strEQ(name, "W_OK"))
! #ifdef W_OK
! return W_OK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "WNOHANG"))
! #ifdef WNOHANG
! return WNOHANG;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "WUNTRACED"))
! #ifdef WUNTRACED
! return WUNTRACED;
! #else
! goto not_there;
! #endif
! errno = EAGAIN; /* the following aren't constants */
! #ifdef WEXITSTATUS
! if (strEQ(name, "WEXITSTATUS")) return WEXITSTATUS(arg);
! #endif
! #ifdef WIFEXITED
! if (strEQ(name, "WIFEXITED")) return WIFEXITED(arg);
! #endif
#ifdef WIFSIGNALED
! if (strEQ(name, "WIFSIGNALED")) return WIFSIGNALED(arg);
! #endif
! #ifdef WIFSTOPPED
! if (strEQ(name, "WIFSTOPPED")) return WIFSTOPPED(arg);
! #endif
! #ifdef WSTOPSIG
! if (strEQ(name, "WSTOPSIG")) return WSTOPSIG(arg);
! #endif
! #ifdef WTERMSIG
! if (strEQ(name, "WTERMSIG")) return WTERMSIG(arg);
! #endif
! break;
! case 'X':
! if (strEQ(name, "X_OK"))
! #ifdef X_OK
! return X_OK;
#else
! goto not_there;
#endif
! break;
! case '_':
! if (strnEQ(name, "_PC_", 4)) {
! if (strEQ(name, "_PC_CHOWN_RESTRICTED"))
! #if defined(_PC_CHOWN_RESTRICTED) || HINT_SC_EXIST
! return _PC_CHOWN_RESTRICTED;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "_PC_LINK_MAX"))
! #if defined(_PC_LINK_MAX) || HINT_SC_EXIST
! return _PC_LINK_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "_PC_MAX_CANON"))
! #if defined(_PC_MAX_CANON) || HINT_SC_EXIST
! return _PC_MAX_CANON;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "_PC_MAX_INPUT"))
! #if defined(_PC_MAX_INPUT) || HINT_SC_EXIST
! return _PC_MAX_INPUT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "_PC_NAME_MAX"))
! #if defined(_PC_NAME_MAX) || HINT_SC_EXIST
! return _PC_NAME_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "_PC_NO_TRUNC"))
! #if defined(_PC_NO_TRUNC) || HINT_SC_EXIST
! return _PC_NO_TRUNC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "_PC_PATH_MAX"))
! #if defined(_PC_PATH_MAX) || HINT_SC_EXIST
! return _PC_PATH_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "_PC_PIPE_BUF"))
! #if defined(_PC_PIPE_BUF) || HINT_SC_EXIST
! return _PC_PIPE_BUF;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "_PC_VDISABLE"))
! #if defined(_PC_VDISABLE) || HINT_SC_EXIST
! return _PC_VDISABLE;
! #else
! goto not_there;
! #endif
! break;
! }
! if (strnEQ(name, "_POSIX_", 7)) {
! if (strEQ(name, "_POSIX_ARG_MAX"))
! #ifdef _POSIX_ARG_MAX
! return _POSIX_ARG_MAX;
! #else
! return 0;
! #endif
! if (strEQ(name, "_POSIX_CHILD_MAX"))
! #ifdef _POSIX_CHILD_MAX
! return _POSIX_CHILD_MAX;
! #else
! return 0;
! #endif
! if (strEQ(name, "_POSIX_CHOWN_RESTRICTED"))
! #ifdef _POSIX_CHOWN_RESTRICTED
! return _POSIX_CHOWN_RESTRICTED;
! #else
! return 0;
! #endif
! if (strEQ(name, "_POSIX_JOB_CONTROL"))
! #ifdef _POSIX_JOB_CONTROL
! return _POSIX_JOB_CONTROL;
! #else
! return 0;
! #endif
! if (strEQ(name, "_POSIX_LINK_MAX"))
! #ifdef _POSIX_LINK_MAX
! return _POSIX_LINK_MAX;
! #else
! return 0;
! #endif
! if (strEQ(name, "_POSIX_MAX_CANON"))
! #ifdef _POSIX_MAX_CANON
! return _POSIX_MAX_CANON;
! #else
! return 0;
! #endif
! if (strEQ(name, "_POSIX_MAX_INPUT"))
! #ifdef _POSIX_MAX_INPUT
! return _POSIX_MAX_INPUT;
! #else
! return 0;
! #endif
! if (strEQ(name, "_POSIX_NAME_MAX"))
! #ifdef _POSIX_NAME_MAX
! return _POSIX_NAME_MAX;
! #else
! return 0;
! #endif
! if (strEQ(name, "_POSIX_NGROUPS_MAX"))
! #ifdef _POSIX_NGROUPS_MAX
! return _POSIX_NGROUPS_MAX;
! #else
! return 0;
! #endif
! if (strEQ(name, "_POSIX_NO_TRUNC"))
! #ifdef _POSIX_NO_TRUNC
! return _POSIX_NO_TRUNC;
! #else
! return 0;
! #endif
! if (strEQ(name, "_POSIX_OPEN_MAX"))
! #ifdef _POSIX_OPEN_MAX
! return _POSIX_OPEN_MAX;
! #else
! return 0;
! #endif
! if (strEQ(name, "_POSIX_PATH_MAX"))
! #ifdef _POSIX_PATH_MAX
! return _POSIX_PATH_MAX;
! #else
! return 0;
! #endif
! if (strEQ(name, "_POSIX_PIPE_BUF"))
! #ifdef _POSIX_PIPE_BUF
! return _POSIX_PIPE_BUF;
! #else
! return 0;
! #endif
! if (strEQ(name, "_POSIX_SAVED_IDS"))
! #ifdef _POSIX_SAVED_IDS
! return _POSIX_SAVED_IDS;
! #else
! return 0;
! #endif
! if (strEQ(name, "_POSIX_SSIZE_MAX"))
! #ifdef _POSIX_SSIZE_MAX
! return _POSIX_SSIZE_MAX;
! #else
! return 0;
! #endif
! if (strEQ(name, "_POSIX_STREAM_MAX"))
! #ifdef _POSIX_STREAM_MAX
! return _POSIX_STREAM_MAX;
! #else
! return 0;
! #endif
! if (strEQ(name, "_POSIX_TZNAME_MAX"))
! #ifdef _POSIX_TZNAME_MAX
! return _POSIX_TZNAME_MAX;
! #else
! return 0;
! #endif
! if (strEQ(name, "_POSIX_VDISABLE"))
! #ifdef _POSIX_VDISABLE
! return _POSIX_VDISABLE;
! #else
! return 0;
! #endif
! if (strEQ(name, "_POSIX_VERSION"))
! #ifdef _POSIX_VERSION
! return _POSIX_VERSION;
! #else
! return 0;
! #endif
! break;
! }
! if (strnEQ(name, "_SC_", 4)) {
! if (strEQ(name, "_SC_ARG_MAX"))
! #if defined(_SC_ARG_MAX) || HINT_SC_EXIST
! return _SC_ARG_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "_SC_CHILD_MAX"))
! #if defined(_SC_CHILD_MAX) || HINT_SC_EXIST
! return _SC_CHILD_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "_SC_CLK_TCK"))
! #if defined(_SC_CLK_TCK) || HINT_SC_EXIST
! return _SC_CLK_TCK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "_SC_JOB_CONTROL"))
! #if defined(_SC_JOB_CONTROL) || HINT_SC_EXIST
! return _SC_JOB_CONTROL;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "_SC_NGROUPS_MAX"))
! #if defined(_SC_NGROUPS_MAX) || HINT_SC_EXIST
! return _SC_NGROUPS_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "_SC_OPEN_MAX"))
! #if defined(_SC_OPEN_MAX) || HINT_SC_EXIST
! return _SC_OPEN_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "_SC_SAVED_IDS"))
! #if defined(_SC_SAVED_IDS) || HINT_SC_EXIST
! return _SC_SAVED_IDS;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "_SC_STREAM_MAX"))
! #if defined(_SC_STREAM_MAX) || HINT_SC_EXIST
! return _SC_STREAM_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "_SC_TZNAME_MAX"))
! #if defined(_SC_TZNAME_MAX) || HINT_SC_EXIST
! return _SC_TZNAME_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "_SC_VERSION"))
! #if defined(_SC_VERSION) || HINT_SC_EXIST
! return _SC_VERSION;
! #else
! goto not_there;
! #endif
! break;
! }
}
! errno = EINVAL;
! return 0;
!
! not_there:
! errno = ENOENT;
! return 0;
}
static void
! restore_sigmask(sigset_t *ossetp)
{
! /* Fortunately, restoring the signal mask can't fail, because
! * there's nothing we can do about it if it does -- we're not
! * supposed to return -1 from sigaction unless the disposition
! * was unaffected.
! */
! (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
}
MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig
--- 352,536 ----
return -1;
}
! #include "constants.c"
!
! /* These were implemented in the old "constant" subroutine. They are actually
! macros that take an integer argument and return an integer result. */
! static int
! int_macro_int (const char *name, STRLEN len, IV *arg_result) {
! /* Initially switch on the length of the name. */
! /* This code has been edited from a "constant" function generated by:
!
! use ExtUtils::Constant qw (constant_types C_constant XS_constant);
!
! my $types = {map {($_, 1)} qw(IV)};
! my @names = (qw(S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG WEXITSTATUS WIFEXITED
! WIFSIGNALED WIFSTOPPED WSTOPSIG WTERMSIG));
!
! print constant_types(); # macro defs
! foreach (C_constant ("POSIX", 'int_macro_int', 'IV', $types, undef, 5, @names) ) {
! print $_, "\n"; # C constant subs
! }
! print "#### XS Section:\n";
! print XS_constant ("POSIX", $types);
! __END__
! */
!
! switch (len) {
! case 7:
! /* Names all of length 7. */
! /* S_ISBLK S_ISCHR S_ISDIR S_ISREG */
! /* Offset 5 gives the best switch position. */
! switch (name[5]) {
case 'E':
! if (memEQ(name, "S_ISREG", 7)) {
! /* ^ */
! #ifdef S_ISREG
! *arg_result = S_ISREG(*arg_result);
! return PERL_constant_ISIV;
#else
! return PERL_constant_NOTDEF;
#endif
! }
! break;
case 'H':
! if (memEQ(name, "S_ISCHR", 7)) {
! /* ^ */
! #ifdef S_ISCHR
! *arg_result = S_ISCHR(*arg_result);
! return PERL_constant_ISIV;
#else
! return PERL_constant_NOTDEF;
#endif
! }
! break;
case 'I':
! if (memEQ(name, "S_ISDIR", 7)) {
! /* ^ */
! #ifdef S_ISDIR
! *arg_result = S_ISDIR(*arg_result);
! return PERL_constant_ISIV;
#else
! return PERL_constant_NOTDEF;
#endif
! }
! break;
case 'L':
! if (memEQ(name, "S_ISBLK", 7)) {
! /* ^ */
! #ifdef S_ISBLK
! *arg_result = S_ISBLK(*arg_result);
! return PERL_constant_ISIV;
#else
! return PERL_constant_NOTDEF;
#endif
! }
! break;
! }
! break;
! case 8:
! /* Names all of length 8. */
! /* S_ISFIFO WSTOPSIG WTERMSIG */
! /* Offset 3 gives the best switch position. */
! switch (name[3]) {
case 'O':
! if (memEQ(name, "WSTOPSIG", 8)) {
! /* ^ */
! #ifdef WSTOPSIG
! *arg_result = WSTOPSIG(*arg_result);
! return PERL_constant_ISIV;
#else
! return PERL_constant_NOTDEF;
#endif
! }
! break;
case 'R':
! if (memEQ(name, "WTERMSIG", 8)) {
! /* ^ */
! #ifdef WTERMSIG
! *arg_result = WTERMSIG(*arg_result);
! return PERL_constant_ISIV;
#else
! return PERL_constant_NOTDEF;
#endif
! }
! break;
case 'S':
! if (memEQ(name, "S_ISFIFO", 8)) {
! /* ^ */
#ifdef S_ISFIFO
! *arg_result = S_ISFIFO(*arg_result);
! return PERL_constant_ISIV;
#else
! return PERL_constant_NOTDEF;
#endif
! }
! break;
! }
! break;
! case 9:
! if (memEQ(name, "WIFEXITED", 9)) {
! #ifdef WIFEXITED
! *arg_result = WIFEXITED(*arg_result);
! return PERL_constant_ISIV;
#else
! return PERL_constant_NOTDEF;
#endif
! }
! break;
! case 10:
! if (memEQ(name, "WIFSTOPPED", 10)) {
! #ifdef WIFSTOPPED
! *arg_result = WIFSTOPPED(*arg_result);
! return PERL_constant_ISIV;
#else
! return PERL_constant_NOTDEF;
#endif
! }
! break;
! case 11:
! /* Names all of length 11. */
! /* WEXITSTATUS WIFSIGNALED */
! /* Offset 1 gives the best switch position. */
! switch (name[1]) {
! case 'E':
! if (memEQ(name, "WEXITSTATUS", 11)) {
! /* ^ */
! #ifdef WEXITSTATUS
! *arg_result = WEXITSTATUS(*arg_result);
! return PERL_constant_ISIV;
#else
! return PERL_constant_NOTDEF;
#endif
! }
! break;
! case 'I':
! if (memEQ(name, "WIFSIGNALED", 11)) {
! /* ^ */
#ifdef WIFSIGNALED
! *arg_result = WIFSIGNALED(*arg_result);
! return PERL_constant_ISIV;
#else
! return PERL_constant_NOTDEF;
#endif
! }
! break;
}
! break;
! }
! return PERL_constant_NOTFOUND;
}
static void
! restore_sigmask(pTHX_ SV *osset_sv)
{
! /* Fortunately, restoring the signal mask can't fail, because
! * there's nothing we can do about it if it does -- we're not
! * supposed to return -1 from sigaction unless the disposition
! * was unaffected.
! */
! sigset_t *ossetp = (sigset_t *) SvPV_nolen( osset_sv );
! (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
}
MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig
***************
*** 3029,3039 ****
MODULE = POSIX PACKAGE = POSIX
! NV
! constant(name,arg)
! char * name
! int arg
int
isalnum(charstring)
unsigned char * charstring
--- 772,821 ----
MODULE = POSIX PACKAGE = POSIX
! INCLUDE: constants.xs
+ void
+ int_macro_int(sv, iv)
+ PREINIT:
+ dXSTARG;
+ STRLEN len;
+ int type;
+ INPUT:
+ SV * sv;
+ const char * s = SvPV(sv, len);
+ IV iv;
+ PPCODE:
+ /* Change this to int_macro_int(s, len, &iv, &nv);
+ if you need to return both NVs and IVs */
+ type = int_macro_int(s, len, &iv);
+ /* Return 1 or 2 items. First is error message, or undef if no error.
+ Second, if present, is found value */
+ switch (type) {
+ case PERL_constant_NOTFOUND:
+ sv = sv_2mortal(newSVpvf("%s is not a valid POSIX macro", s));
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(sv);
+ break;
+ case PERL_constant_NOTDEF:
+ sv = sv_2mortal(newSVpvf(
+ "Your vendor has not defined POSIX macro %s, used", s));
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(sv);
+ break;
+ case PERL_constant_ISIV:
+ PUSHi(iv);
+ break;
+ default:
+ sv = sv_2mortal(newSVpvf(
+ "Unexpected return type %d while processing POSIX macro %s, used",
+ type, s));
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(sv);
+ }
+
int
isalnum(charstring)
unsigned char * charstring
***************
*** 3392,3398 ****
SV * optaction
POSIX::SigAction oldaction
CODE:
! #ifdef WIN32
RETVAL = not_here("sigaction");
#else
# This code is really grody because we're trying to make the signal
--- 1174,1180 ----
SV * optaction
POSIX::SigAction oldaction
CODE:
! #if defined(WIN32) || defined(NETWARE)
RETVAL = not_here("sigaction");
#else
# This code is really grody because we're trying to make the signal
***************
*** 3404,3409 ****
--- 1186,1192 ----
struct sigaction act;
struct sigaction oact;
sigset_t sset;
+ SV *osset_sv;
sigset_t osset;
POSIX__SigSet sigset;
SV** svp;
***************
*** 3411,3417 ****
PL_sig_name[sig],
strlen(PL_sig_name[sig]),
TRUE);
- STRLEN n_a;
/* Check optaction and set action */
if(SvTRUE(optaction)) {
--- 1194,1199 ----
***************
*** 3432,3441 ****
sigfillset(&sset);
RETVAL=sigprocmask(SIG_BLOCK, &sset, &osset);
if(RETVAL == -1)
! XSRETURN(1);
ENTER;
/* Restore signal mask no matter how we exit this block. */
! SAVEDESTRUCTOR(restore_sigmask, &osset);
RETVAL=-1; /* In case both oldaction and action are 0. */
--- 1214,1225 ----
sigfillset(&sset);
RETVAL=sigprocmask(SIG_BLOCK, &sset, &osset);
if(RETVAL == -1)
! XSRETURN_UNDEF;
ENTER;
/* Restore signal mask no matter how we exit this block. */
! osset_sv = newSVpv((char *)(&osset), sizeof(sigset_t));
! SAVEFREESV( osset_sv );
! SAVEDESTRUCTOR_X(restore_sigmask, osset_sv);
RETVAL=-1; /* In case both oldaction and action are 0. */
***************
*** 3452,3458 ****
}
RETVAL = sigaction(sig, (struct sigaction *)0, & oact);
if(RETVAL == -1)
! XSRETURN(1);
/* Get back the mask. */
svp = hv_fetch(oldaction, "MASK", 4, TRUE);
if (sv_isa(*svp, "POSIX::SigSet")) {
--- 1236,1242 ----
}
RETVAL = sigaction(sig, (struct sigaction *)0, & oact);
if(RETVAL == -1)
! XSRETURN_UNDEF;
/* Get back the mask. */
svp = hv_fetch(oldaction, "MASK", 4, TRUE);
if (sv_isa(*svp, "POSIX::SigSet")) {
***************
*** 3514,3519 ****
--- 1298,1305 ----
* essentially meaningless anyway.
*/
RETVAL = sigaction(sig, & act, (struct sigaction *)0);
+ if(RETVAL == -1)
+ XSRETURN_UNDEF;
}
LEAVE;
***************
*** 3905,3968 ****
int isdst
CODE:
{
! char tmpbuf[128];
! struct tm mytm;
! int len;
! 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;
! mini_mktime(&mytm);
! len = strftime(tmpbuf, sizeof tmpbuf, fmt, &mytm);
! /*
! ** The following is needed to handle to the situation where
! ** tmpbuf overflows. Basically we want to allocate a buffer
! ** and try repeatedly. The reason why it is so complicated
! ** is that getting a return value of 0 from strftime can indicate
! ** one of the following:
! ** 1. buffer overflowed,
! ** 2. illegal conversion specifier, or
! ** 3. the format string specifies nothing to be returned(not
! ** an error). This could be because format is an empty string
! ** or it specifies %p that yields an empty string in some locale.
! ** If there is a better way to make it portable, go ahead by
! ** all means.
! */
! if ((len > 0 && len < sizeof(tmpbuf)) || (len == 0 && *fmt == '\0'))
! ST(0) = sv_2mortal(newSVpv(tmpbuf, len));
! else {
! /* Possibly buf overflowed - try again with a bigger buf */
! int fmtlen = strlen(fmt);
! int bufsize = fmtlen + sizeof(tmpbuf);
! char* buf;
! int buflen;
!
! New(0, buf, bufsize, char);
! while (buf) {
! buflen = strftime(buf, bufsize, fmt, &mytm);
! if (buflen > 0 && buflen < bufsize)
! break;
! /* heuristic to prevent out-of-memory errors */
! if (bufsize > 100*fmtlen) {
! Safefree(buf);
! buf = NULL;
! break;
! }
! bufsize *= 2;
! Renew(buf, bufsize, char);
! }
! if (buf) {
! ST(0) = sv_2mortal(newSVpvn(buf, buflen));
! Safefree(buf);
! }
! else
! ST(0) = sv_2mortal(newSVpvn(tmpbuf, len));
}
}
--- 1691,1700 ----
int isdst
CODE:
{
! char *buf = my_strftime(fmt, sec, min, hour, mday, mon, year, wday, yday, isdst);
! if (buf) {
! ST(0) = sv_2mortal(newSVpv(buf, 0));
! Safefree(buf);
}
}
***************
*** 4018,4057 ****
ttyname(fd)
int fd
! char *
getcwd()
! PPCODE:
! #ifdef HAS_GETCWD
! char * buf;
! int buflen = 128;
! int i;
- New(0, buf, buflen, char);
- /* Many getcwd()s know how to automatically allocate memory
- * for the directory if the buffer argument is NULL but...
- * (1) we cannot assume all getcwd()s do that
- * (2) this may interfere with Perl's malloc
- * So let's not. --jhi */
- while ((getcwd(buf, buflen) == NULL) && errno == ERANGE) {
- buflen += 128;
- if (buflen > MAXPATHLEN) {
- Safefree(buf);
- buf = NULL;
- break;
- }
- Renew(buf, buflen, char);
- }
- if (buf) {
- PUSHs(sv_2mortal(newSVpv(buf, 0)));
- Safefree(buf);
- }
- else
- PUSHs(&PL_sv_undef);
- #else
- require_pv("Cwd.pm");
- /* Module require may have grown the stack */
- SPAGAIN;
- PUSHMARK(sp);
- PUTBACK;
- XSRETURN(call_pv("Cwd::cwd", GIMME_V));
- #endif
--- 1750,1761 ----
ttyname(fd)
int fd
! void
getcwd()
! PPCODE:
! {
! dXSTARG;
! getcwd_sv(TARG);
! XSprePUSH; PUSHTARG;
! }
diff -c /dev/null 'perl-5.7.2/ext/POSIX/hints/uts.pl'
Index: ./ext/POSIX/hints/uts.pl
*** ./ext/POSIX/hints/uts.pl Thu Jan 1 02:00:00 1970
--- ./ext/POSIX/hints/uts.pl Mon Jul 9 17:10:11 2001
***************
*** 0 ****
--- 1,9 ----
+ # UTS - Leaving -lm in there results in death of make with the message:
+ # LD_RUN_PATH="/usr/ccs/lib" ld -G -z text POSIX.o \
+ # -o ../../lib/auto/POS IX/POSIX.so -lm
+ # relocations referenced
+ # from file(s)
+ # /usr/ccs/lib/libm.a(acos.o)
+ # ...
+
+ $self->{LIBS} = [''];
diff -c /dev/null 'perl-5.7.2/ext/POSIX/sigaction.t'
Index: ./ext/POSIX/sigaction.t
*** ./ext/POSIX/sigaction.t Thu Jan 1 02:00:00 1970
--- ./ext/POSIX/sigaction.t Mon Jul 9 17:10:11 2001
***************
*** 0 ****
--- 1,133 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ unshift @INC, '../lib';
+ }
+
+ BEGIN{
+ # Don't do anything if POSIX is missing, or sigaction missing.
+ eval { use POSIX; };
+ if($@ || $^O eq 'MSWin32' || $^O eq 'NetWare') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ use strict;
+ use vars qw/$bad7 $ok10 $bad18 $ok/;
+
+ $^W=1;
+
+ print "1..18\n";
+
+ sub IGNORE {
+ $bad7=1;
+ }
+
+ sub DEFAULT {
+ $bad18=1;
+ }
+
+ sub foo {
+ $ok=1;
+ }
+
+ my $newaction=POSIX::SigAction->new('::foo', new POSIX::SigSet(SIGUSR1), 0);
+ my $oldaction=POSIX::SigAction->new('::bar', new POSIX::SigSet(), 0);
+
+ {
+ my $bad;
+ local($SIG{__WARN__})=sub { $bad=1; };
+ sigaction(SIGHUP, $newaction, $oldaction);
+ if($bad) { print "not ok 1\n" } else { print "ok 1\n"}
+ }
+
+ if($oldaction->{HANDLER} eq 'DEFAULT' ||
+ $oldaction->{HANDLER} eq 'IGNORE')
+ { print "ok 2\n" } else { print "not ok 2 # ", $oldaction->{HANDLER}, "\n"}
+ print $SIG{HUP} eq '::foo' ? "ok 3\n" : "not ok 3\n";
+
+ sigaction(SIGHUP, $newaction, $oldaction);
+ if($oldaction->{HANDLER} eq '::foo')
+ { print "ok 4\n" } else { print "not ok 4\n"}
+ if($oldaction->{MASK}->ismember(SIGUSR1))
+ { print "ok 5\n" } else { print "not ok 5\n"}
+ if($oldaction->{FLAGS}) {
+ if ($^O eq 'linux') {
+ print "ok 6 # Skip: sigaction() broken in $^O\n";
+ } else {
+ print "not ok 6\n";
+ }
+ } else {
+ print "ok 6\n";
+ }
+
+ $newaction=POSIX::SigAction->new('IGNORE');
+ sigaction(SIGHUP, $newaction);
+ kill 'HUP', $$;
+ print $bad7 ? "not ok 7\n" : "ok 7\n";
+
+ print $SIG{HUP} eq 'IGNORE' ? "ok 8\n" : "not ok 8\n";
+ sigaction(SIGHUP, POSIX::SigAction->new('DEFAULT'));
+ print $SIG{HUP} eq 'DEFAULT' ? "ok 9\n" : "not ok 9\n";
+
+ $newaction=POSIX::SigAction->new(sub { $ok10=1; });
+ sigaction(SIGHUP, $newaction);
+ {
+ local($^W)=0;
+ kill 'HUP', $$;
+ }
+ print $ok10 ? "ok 10\n" : "not ok 10\n";
+
+ print ref($SIG{HUP}) eq 'CODE' ? "ok 11\n" : "not ok 11\n";
+
+ sigaction(SIGHUP, POSIX::SigAction->new('::foo'));
+ # Make sure the signal mask gets restored after sigaction croak()s.
+ eval {
+ my $act=POSIX::SigAction->new('::foo');
+ delete $act->{HANDLER};
+ sigaction(SIGINT, $act);
+ };
+ kill 'HUP', $$;
+ print $ok ? "ok 12\n" : "not ok 12\n";
+
+ undef $ok;
+ # Make sure the signal mask gets restored after sigaction returns early.
+ my $x=defined sigaction(SIGKILL, $newaction, $oldaction);
+ kill 'HUP', $$;
+ print !$x && $ok ? "ok 13\n" : "not ok 13\n";
+
+ $SIG{HUP}=sub {};
+ sigaction(SIGHUP, $newaction, $oldaction);
+ print ref($oldaction->{HANDLER}) eq 'CODE' ? "ok 14\n" : "not ok 14\n";
+
+ eval {
+ sigaction(SIGHUP, undef, $oldaction);
+ };
+ print $@ ? "not ok 15\n" : "ok 15\n";
+
+ eval {
+ sigaction(SIGHUP, 0, $oldaction);
+ };
+ print $@ ? "not ok 16\n" : "ok 16\n";
+
+ eval {
+ sigaction(SIGHUP, bless({},'Class'), $oldaction);
+ };
+ print $@ ? "ok 17\n" : "not ok 17\n";
+
+ if ($^O eq 'VMS') {
+ print "ok 18 # Skip: SIGCONT not trappable in $^O\n";
+ } else {
+ $newaction=POSIX::SigAction->new(sub { $ok10=1; });
+ if (eval { SIGCONT; 1 }) {
+ sigaction(SIGCONT, POSIX::SigAction->new('DEFAULT'));
+ {
+ local($^W)=0;
+ kill 'CONT', $$;
+ }
+ }
+ print $bad18 ? "not ok 18\n" : "ok 18\n";
+ }
+
diff -c /dev/null 'perl-5.7.2/ext/PerlIO/PerlIO.t'
Index: ./ext/PerlIO/PerlIO.t
*** ./ext/PerlIO/PerlIO.t Thu Jan 1 02:00:00 1970
--- ./ext/PerlIO/PerlIO.t Mon Jul 9 17:10:11 2001
***************
*** 0 ****
--- 1,90 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ unless ($Config{'useperlio'}) {
+ print "1..0 # Skip: PerlIO not used\n";
+ exit 0;
+ }
+ }
+
+ use PerlIO;
+
+ print "1..19\n";
+
+ print "ok 1\n";
+
+ my $txt = "txt$$";
+ my $bin = "bin$$";
+ my $utf = "utf$$";
+
+ my $txtfh;
+ my $binfh;
+ my $utffh;
+
+ print "not " unless open($txtfh, ">:crlf", $txt);
+ print "ok 2\n";
+
+ print "not " unless open($binfh, ">:raw", $bin);
+ print "ok 3\n";
+
+ print "not " unless open($utffh, ">:utf8", $utf);
+ print "ok 4\n";
+
+ print $txtfh "foo\n";
+ print $txtfh "bar\n";
+ print "not " unless close($txtfh);
+ print "ok 5\n";
+
+ print $binfh "foo\n";
+ print $binfh "bar\n";
+ print "not " unless close($binfh);
+ print "ok 6\n";
+
+ print $utffh "foo\x{ff}\n";
+ print $utffh "bar\x{abcd}\n";
+ print "not " unless close($utffh);
+ print "ok 7\n";
+
+ print "not " unless open($txtfh, "<:crlf", $txt);
+ print "ok 8\n";
+
+ print "not " unless open($binfh, "<:raw", $bin);
+ print "ok 9\n";
+
+ print "not " unless open($utffh, "<:utf8", $utf);
+ print "ok 10\n";
+
+ print "not " unless <$txtfh> eq "foo\n" && <$txtfh> eq "bar\n";
+ print "ok 11\n";
+
+ print "not " unless <$binfh> eq "foo\n" && <$binfh> eq "bar\n";
+ print "ok 12\n";
+
+ print "not " unless <$utffh> eq "foo\x{ff}\n" && <$utffh> eq "bar\x{abcd}\n";
+ print "ok 13\n";
+
+ print "not " unless eof($txtfh);
+ print "ok 14\n";
+
+ print "not " unless eof($binfh);
+ print "ok 15\n";
+
+ print "not " unless eof($utffh);
+ print "ok 16\n";
+
+ print "not " unless close($txtfh);
+ print "ok 17\n";
+
+ print "not " unless close($binfh);
+ print "ok 18\n";
+
+ print "not " unless close($utffh);
+ print "ok 19\n";
+
+ END {
+ 1 while unlink $txt;
+ 1 while unlink $bin;
+ 1 while unlink $utf;
+ }
+
diff -c 'perl-5.7.1/ext/PerlIO/Scalar/Makefile.PL' 'perl-5.7.2/ext/PerlIO/Scalar/Makefile.PL'
Index: ./ext/PerlIO/Scalar/Makefile.PL
*** ./ext/PerlIO/Scalar/Makefile.PL Sat Mar 24 17:55:01 2001
--- ./ext/PerlIO/Scalar/Makefile.PL Mon Jul 9 17:10:11 2001
***************
*** 1,6 ****
--- 1,7 ----
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => "PerlIO::Scalar",
+ MAN3PODS => {}, # Pods will be built by installman.
VERSION_FROM => 'Scalar.pm',
);
diff -c 'perl-5.7.1/ext/PerlIO/Scalar/Scalar.pm' 'perl-5.7.2/ext/PerlIO/Scalar/Scalar.pm'
Index: ./ext/PerlIO/Scalar/Scalar.pm
*** ./ext/PerlIO/Scalar/Scalar.pm Wed Mar 28 00:52:30 2001
--- ./ext/PerlIO/Scalar/Scalar.pm Mon Jul 9 17:10:11 2001
***************
*** 18,25 ****
C<PerlIO::Scalar> only exists to use XSLoader to load C code that provides
support for treating a scalar as an "in memory" file.
! All normal file operations can be performed on the handle. The scalar is considered
! a stream of bytes. Currently fileno($fh) returns C<undef>.
=cut
--- 18,25 ----
C<PerlIO::Scalar> only exists to use XSLoader to load C code that provides
support for treating a scalar as an "in memory" file.
! All normal file operations can be performed on the handle. The scalar
! is considered a stream of bytes. Currently fileno($fh) returns C<undef>.
=cut
diff -c 'perl-5.7.1/ext/PerlIO/Scalar/Scalar.xs' 'perl-5.7.2/ext/PerlIO/Scalar/Scalar.xs'
Index: ./ext/PerlIO/Scalar/Scalar.xs
*** ./ext/PerlIO/Scalar/Scalar.xs Mon Mar 26 01:23:43 2001
--- ./ext/PerlIO/Scalar/Scalar.xs Mon Jul 9 17:10:11 2001
***************
*** 16,23 ****
IV
PerlIOScalar_pushed(PerlIO *f, const char *mode, SV *arg)
{
! PerlIOScalar *b = PerlIOSelf(f,PerlIOScalar);
! return PerlIOBase_pushed(f,mode,arg);
}
IV
--- 16,52 ----
IV
PerlIOScalar_pushed(PerlIO *f, const char *mode, SV *arg)
{
! dTHX;
! IV code;
! PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
! /* If called (normally) via open() then arg is ref to scalar we are
! using, otherwise arg (from binmode presumably) is either NULL
! or the _name_ of the scalar
! */
! if (arg)
! {
! if (SvROK(arg))
! {
! s->var = SvREFCNT_inc(SvRV(arg));
! }
! else
! {
! s->var = SvREFCNT_inc(perl_get_sv(SvPV_nolen(arg),GV_ADD|GV_ADDMULTI));
! }
! }
! else
! {
! s->var = newSVpvn("",0);
! }
! sv_upgrade(s->var,SVt_PV);
! code = PerlIOBase_pushed(f,mode,Nullsv);
! if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
! s->posn = SvCUR(SvRV(arg));
! else
! s->posn = 0;
! if ((PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
! SvCUR(SvRV(arg)) = 0;
! return code;
}
IV
***************
*** 36,44 ****
IV
PerlIOScalar_close(PerlIO *f)
{
- dTHX;
IV code = PerlIOBase_close(f);
- PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
return code;
}
--- 65,71 ----
***************
*** 86,92 ****
dTHX;
PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
char *dst = SvGROW(s->var,s->posn+count);
! Move(vbuf,dst,count,char);
s->posn += count;
SvCUR_set(s->var,s->posn);
SvPOK_on(s->var);
--- 113,119 ----
dTHX;
PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
char *dst = SvGROW(s->var,s->posn+count);
! Move(vbuf,dst+s->posn,count,char);
s->posn += count;
SvCUR_set(s->var,s->posn);
SvPOK_on(s->var);
***************
*** 98,106 ****
{
if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
{
! return PerlIOScalar_unread(f,vbuf,count);
}
! return 0;
}
IV
--- 125,158 ----
{
if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
{
! dTHX;
! Off_t offset;
! PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
! SV *sv = s->var;
! char *dst;
! if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
! {
! dst = SvGROW(sv,SvCUR(sv)+count);
! offset = SvCUR(sv);
! s->posn = offset+count;
! }
! else
! {
! if ((s->posn+count) > SvCUR(sv))
! dst = SvGROW(sv,s->posn+count);
! else
! dst = SvPV_nolen(sv);
! offset = s->posn;
! s->posn += count;
! }
! Move(vbuf,dst+offset,count,char);
! if (s->posn > SvCUR(sv))
! SvCUR_set(sv,s->posn);
! SvPOK_on(s->var);
! return count;
}
! else
! return 0;
}
IV
***************
*** 144,150 ****
if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
{
PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
! return SvCUR(s->var) - s->posn;
}
return 0;
}
--- 196,205 ----
if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
{
PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
! if (SvCUR(s->var) > s->posn)
! return SvCUR(s->var) - s->posn;
! else
! return 0;
}
return 0;
}
***************
*** 168,190 ****
}
PerlIO *
! PerlIOScalar_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
{
! PerlIOScalar *s;
! if (narg > 0)
{
! SV *ref = *args;
! if (SvROK(ref))
! {
! SV *var = SvRV(ref);
! sv_upgrade(var,SVt_PV);
! f = PerlIO_allocate(aTHX);
! s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOScalar);
! s->var = SvREFCNT_inc(var);
! s->posn = 0;
! PerlIOBase(f)->flags |= PERLIO_F_OPEN;
! return f;
! }
}
return NULL;
}
--- 223,237 ----
}
PerlIO *
! PerlIOScalar_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
{
! SV *arg = (narg > 0) ? *args : PerlIOArg;
! if (SvROK(arg) || SvPOK(arg))
{
! f = PerlIO_allocate(aTHX);
! (void)PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,arg),PerlIOScalar);
! PerlIOBase(f)->flags |= PERLIO_F_OPEN;
! return f;
}
return NULL;
}
***************
*** 222,227 ****
--- 269,276 ----
#endif /* Layers available */
MODULE = PerlIO::Scalar PACKAGE = PerlIO::Scalar
+
+ PROTOTYPES: ENABLE
BOOT:
{
diff -c 'perl-5.7.1/ext/PerlIO/Via/Makefile.PL' 'perl-5.7.2/ext/PerlIO/Via/Makefile.PL'
Index: ./ext/PerlIO/Via/Makefile.PL
*** ./ext/PerlIO/Via/Makefile.PL Wed Mar 28 00:52:16 2001
--- ./ext/PerlIO/Via/Makefile.PL Mon Jul 9 17:10:11 2001
***************
*** 1,6 ****
--- 1,7 ----
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => "PerlIO::Via",
+ MAN3PODS => {}, # Pods will be built by installman.
VERSION_FROM => 'Via.pm',
);
diff -c 'perl-5.7.1/ext/PerlIO/Via/Via.pm' 'perl-5.7.2/ext/PerlIO/Via/Via.pm'
Index: ./ext/PerlIO/Via/Via.pm
*** ./ext/PerlIO/Via/Via.pm Wed Mar 28 00:52:16 2001
--- ./ext/PerlIO/Via/Via.pm Mon Jul 9 17:10:11 2001
***************
*** 50,63 ****
=item $obj->FILENO($fh)
! Returns a numeric value for Unix-like file descriptor. Return -1
! if there isn't one.
! Optional -default is fileno($fh).
=item $obj->READ($buffer,$len,$fh)
Returns the number of octets placed in $buffer (must be less that $len).
! Optional - default is to use FILL instead.
=item $obj->WRITE($buffer,$fh)
--- 50,62 ----
=item $obj->FILENO($fh)
! Returns a numeric value for Unix-like file descriptor. Return -1 if
! there isn't one. Optional. Default is fileno($fh).
=item $obj->READ($buffer,$len,$fh)
Returns the number of octets placed in $buffer (must be less that $len).
! Optional. Default is to use FILL instead.
=item $obj->WRITE($buffer,$fh)
***************
*** 65,73 ****
=item $obj->FILL($fh)
! Should return a string to be placed in the buffer.
! Optional. If not provided must provide READ or reject handles open for
! reading in PUSHED.
=item $obj->CLOSE($fh)
--- 64,72 ----
=item $obj->FILL($fh)
! Should return a string to be placed in the buffer. Optional. If not
! provided must provide READ or reject handles open for reading in
! PUSHED.
=item $obj->CLOSE($fh)
***************
*** 86,100 ****
=item $obj->UNREAD($buffer,$fh)
! Returns the number of octets from buffer that have been sucessfully saved
! to be returned on future FILL/READ calls.
! Optional. Default is to push data into a temporary layer above this one.
=item $obj->FLUSH($fh)
! Flush any buffered write data.
! May possibly be called on readable handles too.
! Should return 0 on success, -1 on error.
=item $obj->SETLINEBUF($fh)
--- 85,98 ----
=item $obj->UNREAD($buffer,$fh)
! Returns the number of octets from buffer that have been sucessfully
! saved to be returned on future FILL/READ calls. Optional. Default is
! to push data into a temporary layer above this one.
=item $obj->FLUSH($fh)
! Flush any buffered write data. May possibly be called on readable
! handles too. Should return 0 on success, -1 on error.
=item $obj->SETLINEBUF($fh)
***************
*** 111,118 ****
=item $obj->EOF($fh)
! Optional. Returns end-of-file state. Default is function of return value of FILL
! or READ.
=back
--- 109,116 ----
=item $obj->EOF($fh)
! Optional. Returns end-of-file state. Default is function of return
! value of FILL or READ.
=back
diff -c 'perl-5.7.1/ext/PerlIO/Via/Via.xs' 'perl-5.7.2/ext/PerlIO/Via/Via.xs'
Index: ./ext/PerlIO/Via/Via.xs
*** ./ext/PerlIO/Via/Via.xs Sat Apr 7 18:41:34 2001
--- ./ext/PerlIO/Via/Via.xs Mon Jul 9 17:10:11 2001
***************
*** 70,76 ****
IV count;
dSP;
SV *arg;
- int i = 0;
ENTER;
PUSHMARK(sp);
XPUSHs(s->obj);
--- 70,75 ----
***************
*** 165,171 ****
}
PerlIO *
! PerlIOVia_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
{
if (!f)
{
--- 164,170 ----
}
PerlIO *
! PerlIOVia_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
{
if (!f)
{
***************
*** 392,398 ****
{
if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
{
- dTHX;
PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
if (s->var)
{
--- 391,396 ----
***************
*** 410,416 ****
PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
if (s->var)
{
- dTHX;
STDCHAR *p = (STDCHAR *)(SvEND(s->var) - s->cnt);
return p;
}
--- 408,413 ----
diff -c /dev/null 'perl-5.7.2/ext/PerlIO/t/encoding.t'
Index: ./ext/PerlIO/t/encoding.t
*** ./ext/PerlIO/t/encoding.t Thu Jan 1 02:00:00 1970
--- ./ext/PerlIO/t/encoding.t Fri Jul 13 15:48:48 2001
***************
*** 0 ****
--- 1,62 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ unless (find PerlIO::Layer 'perlio') {
+ print "1..0 # Skip: not perlio\n";
+ exit 0;
+ }
+ }
+
+ print "1..8\n";
+
+ my $grk = "grk$$";
+ my $utf = "utf$$";
+
+ if (open(GRK, ">$grk")) {
+ # alpha beta gamma in ISO 8859-7
+ print GRK "\xe1\xe2\xe3";
+ close GRK;
+ }
+
+ {
+ use Encode;
+ open(my $i,'<:encoding(iso-8859-7)',$grk);
+ print "ok 1\n";
+ open(my $o,'>:utf8',$utf);
+ print "ok 2\n";
+ print $o readline($i);
+ print "ok 3\n";
+ close($o);
+ close($i);
+ }
+
+ if (open(UTF, "<$utf")) {
+ # alpha beta gamma in UTF-8 Unicode (0x3b1 0x3b2 0x3b3)
+ print "not " unless <UTF> eq "\xce\xb1\xce\xb2\xce\xb3";
+ print "ok 4\n";
+ close $grk;
+ }
+
+ {
+ use Encode;
+ open(my $i,'<:utf8',$utf);
+ print "ok 5\n";
+ open(my $o,'>:encoding(iso-8859-7)',$grk);
+ print "ok 6\n";
+ print $o readline($i);
+ print "ok 7\n";
+ close($o);
+ close($i);
+ }
+
+ if (open(GRK, "<$grk")) {
+ print "not " unless <GRK> eq "\xe1\xe2\xe3";
+ print "ok 8\n";
+ close $grk;
+ }
+
+ END {
+ unlink($grk, $utf);
+ }
diff -c /dev/null 'perl-5.7.2/ext/PerlIO/t/scalar.t'
Index: ./ext/PerlIO/t/scalar.t
*** ./ext/PerlIO/t/scalar.t Thu Jan 1 02:00:00 1970
--- ./ext/PerlIO/t/scalar.t Mon Jul 9 17:10:11 2001
***************
*** 0 ****
--- 1,101 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ unless (find PerlIO::Layer 'perlio') {
+ print "1..0 # Skip: not perlio\n";
+ exit 0;
+ }
+ }
+
+ $| = 1;
+ print "1..20\n";
+
+ my $fh;
+ my $var = "ok 2\n";
+ open($fh,"+<",\$var) or print "not ";
+ print "ok 1\n";
+ print <$fh>;
+ print "not " unless eof($fh);
+ print "ok 3\n";
+ seek($fh,0,0) or print "not ";
+ print "not " if eof($fh);
+ print "ok 4\n";
+ print "ok 5\n";
+ print $fh "ok 7\n" or print "not ";
+ print "ok 6\n";
+ print $var;
+ $var = "foo\nbar\n";
+ seek($fh,0,0) or print "not ";
+ print "not " if eof($fh);
+ print "ok 8\n";
+ print "not " unless <$fh> eq "foo\n";
+ print "ok 9\n";
+ my $rv = close $fh;
+ if (!$rv) {
+ print "# Close on scalar failed: $!\n";
+ print "not ";
+ }
+ print "ok 10\n";
+
+ # Test that semantics are similar to normal file-based I/O
+ # Check that ">" clobbers the scalar
+ $var = "Something";
+ open $fh, ">", \$var;
+ print "# Got [$var], expect []\n";
+ print "not " unless $var eq "";
+ print "ok 11\n";
+ # Check that file offset set to beginning of scalar
+ my $off = tell($fh);
+ print "# Got $off, expect 0\n";
+ print "not " unless $off == 0;
+ print "ok 12\n";
+ # Check that writes go where they should and update the offset
+ $var = "Something";
+ print $fh "Brea";
+ $off = tell($fh);
+ print "# Got $off, expect 4\n";
+ print "not " unless $off == 4;
+ print "ok 13\n";
+ print "# Got [$var], expect [Breathing]\n";
+ print "not " unless $var eq "Breathing";
+ print "ok 14\n";
+ close $fh;
+
+ # Check that ">>" appends to the scalar
+ $var = "Something ";
+ open $fh, ">>", \$var;
+ $off = tell($fh);
+ print "# Got $off, expect 10\n";
+ print "not " unless $off == 10;
+ print "ok 15\n";
+ print "# Got [$var], expect [Something ]\n";
+ print "not " unless $var eq "Something ";
+ print "ok 16\n";
+ # Check that further writes go to the very end of the scalar
+ $var .= "else ";
+ print "# Got [$var], expect [Something else ]\n";
+ print "not " unless $var eq "Something else ";
+ print "ok 17\n";
+ $off = tell($fh);
+ print "# Got $off, expect 10\n";
+ print "not " unless $off == 10;
+ print "ok 18\n";
+ print $fh "is here";
+ print "# Got [$var], expect [Something else is here]\n";
+ print "not " unless $var eq "Something else is here";
+ print "ok 19\n";
+ close $fh;
+
+ # Check that updates to the scalar from elsewhere do not
+ # cause problems
+ $var = "line one\nline two\line three\n";
+ open $fh, "<", \$var;
+ while (<$fh>) {
+ $var = "foo";
+ }
+ close $fh;
+ print "# Got [$var], expect [foo]\n";
+ print "not " unless $var eq "foo";
+ print "ok 20\n";
diff -c /dev/null 'perl-5.7.2/ext/SDBM_File/sdbm.t'
Index: ./ext/SDBM_File/sdbm.t
*** ./ext/SDBM_File/sdbm.t Thu Jan 1 02:00:00 1970
--- ./ext/SDBM_File/sdbm.t Mon Jul 9 17:10:12 2001
***************
*** 0 ****
--- 1,429 ----
+ #!./perl
+
+ # $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if (($Config{'extensions'} !~ /\bSDBM_File\b/) && ($^O ne 'VMS')){
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ use strict;
+ use warnings;
+
+ sub ok
+ {
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+ }
+
+ require SDBM_File;
+ #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
+ use Fcntl;
+
+ print "1..68\n";
+
+ unlink <Op_dbmx.*>;
+
+ umask(0);
+ my %h ;
+ ok(1, tie %h,'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640);
+
+ my $Dfile = "Op_dbmx.pag";
+ if (! -e $Dfile) {
+ ($Dfile) = <Op_dbmx.*>;
+ }
+ if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin') {
+ print "ok 2 # Skipped: different file permission semantics\n";
+ }
+ else {
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
+ }
+ my $i = 0;
+ while (my ($key,$value) = each(%h)) {
+ $i++;
+ }
+ print (!$i ? "ok 3\n" : "not ok 3\n");
+
+ $h{'goner1'} = 'snork';
+
+ $h{'abc'} = 'ABC';
+ $h{'def'} = 'DEF';
+ $h{'jkl','mno'} = "JKL\034MNO";
+ $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+ $h{'a'} = 'A';
+ $h{'b'} = 'B';
+ $h{'c'} = 'C';
+ $h{'d'} = 'D';
+ $h{'e'} = 'E';
+ $h{'f'} = 'F';
+ $h{'g'} = 'G';
+ $h{'h'} = 'H';
+ $h{'i'} = 'I';
+
+ $h{'goner2'} = 'snork';
+ delete $h{'goner2'};
+
+ untie(%h);
+ print (tie(%h,'SDBM_File','Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n");
+
+ $h{'j'} = 'J';
+ $h{'k'} = 'K';
+ $h{'l'} = 'L';
+ $h{'m'} = 'M';
+ $h{'n'} = 'N';
+ $h{'o'} = 'O';
+ $h{'p'} = 'P';
+ $h{'q'} = 'Q';
+ $h{'r'} = 'R';
+ $h{'s'} = 'S';
+ $h{'t'} = 'T';
+ $h{'u'} = 'U';
+ $h{'v'} = 'V';
+ $h{'w'} = 'W';
+ $h{'x'} = 'X';
+ $h{'y'} = 'Y';
+ $h{'z'} = 'Z';
+
+ $h{'goner3'} = 'snork';
+
+ delete $h{'goner1'};
+ delete $h{'goner3'};
+
+ my @keys = keys(%h);
+ my @values = values(%h);
+
+ if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
+
+ while (my ($key,$value) = each(%h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+ }
+
+ if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
+
+ @keys = ('blurfl', keys(%h), 'dyick');
+ if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
+
+ $h{'foo'} = '';
+ $h{''} = 'bar';
+
+ # check cache overflow and numeric keys and contents
+ my $ok = 1;
+ for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+ for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+ print ($ok ? "ok 8\n" : "not ok 8\n");
+
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ print ($size > 0 ? "ok 9\n" : "not ok 9\n");
+
+ @h{0..200} = 200..400;
+ my @foo = @h{0..200};
+ print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";
+
+ print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
+ print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
+
+
+ {
+ # sub-class test
+
+ package Another ;
+
+ use strict ;
+ use warnings ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use strict ;
+ use warnings ;
+ use vars qw( @ISA @EXPORT) ;
+
+ require Exporter ;
+ use SDBM_File;
+ @ISA=qw(SDBM_File);
+ @EXPORT = @SDBM_File::EXPORT if defined @SDBM_File::EXPORT ;
+
+ sub STORE {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::STORE($key, $value * 2) ;
+ }
+
+ sub FETCH {
+ my $self = shift ;
+ my $key = shift ;
+ $self->SUPER::FETCH($key) - 1 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+ EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+
+ eval 'use SubDB ; use Fcntl ;';
+ main::ok(13, $@ eq "") ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB","dbhash_tmp", O_RDWR|O_CREAT, 0640 );
+ ' ;
+
+ main::ok(14, $@ eq "") ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ main::ok(15, $@ eq "") ;
+ main::ok(16, $ret == 5) ;
+
+ $ret = eval '$X->A_new_method("fred") ' ;
+ main::ok(17, $@ eq "") ;
+ main::ok(18, $ret eq "[[5]]") ;
+
+ undef $X;
+ untie(%h);
+ unlink "SubDB.pm", <dbhash_tmp.*> ;
+
+ }
+
+ ok(19, !exists $h{'goner1'});
+ ok(20, exists $h{'foo'});
+
+ untie %h;
+ unlink <Op_dbmx*>, $Dfile;
+
+ {
+ # DBM Filter tests
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ unlink <Op_dbmx*>;
+ ok(21, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok(22, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(23, $h{"fred"} eq "joe");
+ # fk sk fv sv
+ ok(24, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(25, $db->FIRSTKEY() eq "fred") ;
+ # fk sk fv sv
+ ok(26, checkOutput( "fred", "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok(27, checkOutput( "", "fred", "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(28, $h{"Fred"} eq "[Jxe]");
+ # fk sk fv sv
+ ok(29, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(30, $db->FIRSTKEY() eq "FRED") ;
+ # fk sk fv sv
+ ok(31, checkOutput( "FRED", "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(32, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(33, $h{"fred"} eq "joe");
+ ok(34, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(35, $db->FIRSTKEY() eq "fred") ;
+ ok(36, checkOutput( "fred", "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(37, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(38, $h{"fred"} eq "joe");
+ ok(39, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(40, $db->FIRSTKEY() eq "fred") ;
+ ok(41, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op_dbmx*>;
+ }
+
+ {
+ # DBM Filter with a closure
+
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+
+ unlink <Op_dbmx*>;
+ ok(42, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(43, $result{"store key"} eq "store key - 1: [fred]");
+ ok(44, $result{"store value"} eq "store value - 1: [joe]");
+ ok(45, !defined $result{"fetch key"} );
+ ok(46, !defined $result{"fetch value"} );
+ ok(47, $_ eq "original") ;
+
+ ok(48, $db->FIRSTKEY() eq "fred") ;
+ ok(49, $result{"store key"} eq "store key - 1: [fred]");
+ ok(50, $result{"store value"} eq "store value - 1: [joe]");
+ ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(52, ! defined $result{"fetch value"} );
+ ok(53, $_ eq "original") ;
+
+ $h{"jim"} = "john" ;
+ ok(54, $result{"store key"} eq "store key - 2: [fred jim]");
+ ok(55, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(57, ! defined $result{"fetch value"} );
+ ok(58, $_ eq "original") ;
+
+ ok(59, $h{"fred"} eq "joe");
+ ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]");
+ ok(61, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(64, $_ eq "original") ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op_dbmx*>;
+ }
+
+ {
+ # DBM Filter recursion detection
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+ unlink <Op_dbmx*>;
+
+ ok(65, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok(66, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie %h;
+ unlink <Op_dbmx*>;
+ }
+
+ {
+ # Bug ID 20001013.009
+ #
+ # test that $hash{KEY} = undef doesn't produce the warning
+ # Use of uninitialized value in null operation
+ use warnings ;
+ use strict ;
+ use SDBM_File ;
+
+ unlink <Op_dbmx*>;
+ my %h ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ ok(67, tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ;
+ $h{ABC} = undef;
+ ok(68, $a eq "") ;
+
+ untie %h;
+ unlink <Op_dbmx*>;
+ }
diff -c /dev/null 'perl-5.7.2/ext/Safe/safe1.t'
Index: ./ext/Safe/safe1.t
*** ./ext/Safe/safe1.t Thu Jan 1 02:00:00 1970
--- ./ext/Safe/safe1.t Mon Jul 9 17:10:12 2001
***************
*** 0 ****
--- 1,68 ----
+ #!./perl -w
+ $|=1;
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ # Tests Todo:
+ # 'main' as root
+
+ package test; # test from somewhere other than main
+
+ use vars qw($bar);
+
+ use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
+ opmask_add full_opset empty_opset opcodes opmask define_optag);
+
+ use Safe 1.00;
+
+ my $last_test; # initalised at end
+ print "1..$last_test\n";
+
+ my $t = 1;
+ my $cpt;
+ # create and destroy some automatic Safe compartments first
+ $cpt = new Safe or die;
+ $cpt = new Safe or die;
+ $cpt = new Safe or die;
+
+ $cpt = new Safe "Root" or die;
+
+ foreach(1..3) {
+ $foo = 42;
+
+ $cpt->share(qw($foo));
+
+ print ${$cpt->varglob('foo')} == 42 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ ${$cpt->varglob('foo')} = 9;
+
+ print $foo == 9 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ print $cpt->reval('$foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++;
+ # check 'main' has been changed:
+ print $cpt->reval('$::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++;
+ print $cpt->reval('$main::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++;
+ # check we can't see our test package:
+ print $cpt->reval('$test::foo') ? "not ok $t\n" : "ok $t\n"; $t++;
+ print $cpt->reval('${"test::foo"}') ? "not ok $t\n" : "ok $t\n"; $t++;
+
+ $cpt->erase; # erase the compartment, e.g., delete all variables
+
+ print $cpt->reval('$foo') ? "not ok $t\n" : "ok $t\n"; $t++;
+
+ # Note that we *must* use $cpt->varglob here because if we used
+ # $Root::foo etc we would still see the original values!
+ # This seems to be because the compiler has created an extra ref.
+
+ print ${$cpt->varglob('foo')} ? "not ok $t\n" : "ok $t\n"; $t++;
+ }
+
+ print "ok $last_test\n";
+ BEGIN { $last_test = 28 }
diff -c /dev/null 'perl-5.7.2/ext/Safe/safe2.t'
Index: ./ext/Safe/safe2.t
*** ./ext/Safe/safe2.t Thu Jan 1 02:00:00 1970
--- ./ext/Safe/safe2.t Mon Jul 9 17:10:13 2001
***************
*** 0 ****
--- 1,145 ----
+ #!./perl -w
+ $|=1;
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ # test 30 rather naughtily expects English error messages
+ $ENV{'LC_ALL'} = 'C';
+ $ENV{LANGUAGE} = 'C'; # GNU locale extension
+ }
+
+ # Tests Todo:
+ # 'main' as root
+
+ use vars qw($bar);
+
+ use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
+ opmask_add full_opset empty_opset opcodes opmask define_optag);
+
+ use Safe 1.00;
+
+ my $last_test; # initalised at end
+ print "1..$last_test\n";
+
+ # Set up a package namespace of things to be visible to the unsafe code
+ $Root::foo = "visible";
+ $bar = "invisible";
+
+ # Stop perl from moaning about identifies which are apparently only used once
+ $Root::foo .= "";
+
+ my $cpt;
+ # create and destroy a couple of automatic Safe compartments first
+ $cpt = new Safe or die;
+ $cpt = new Safe or die;
+
+ $cpt = new Safe "Root";
+
+ $cpt->reval(q{ system("echo not ok 1"); });
+ if ($@ =~ /^system trapped by operation mask/) {
+ print "ok 1\n";
+ } else {
+ print "#$@" if $@;
+ print "not ok 1\n";
+ }
+
+ $cpt->reval(q{
+ print $foo eq 'visible' ? "ok 2\n" : "not ok 2\n";
+ print $main::foo eq 'visible' ? "ok 3\n" : "not ok 3\n";
+ print defined($bar) ? "not ok 4\n" : "ok 4\n";
+ print defined($::bar) ? "not ok 5\n" : "ok 5\n";
+ print defined($main::bar) ? "not ok 6\n" : "ok 6\n";
+ });
+ print $@ ? "not ok 7\n#$@" : "ok 7\n";
+
+ $foo = "ok 8\n";
+ %bar = (key => "ok 9\n");
+ @baz = (); push(@baz, "o", "10"); $" = 'k ';
+ $glob = "ok 11\n";
+ @glob = qw(not ok 16);
+
+ sub sayok { print "ok @_\n" }
+
+ $cpt->share(qw($foo %bar @baz *glob sayok));
+ $cpt->share('$"') unless $Config{use5005threads};
+
+ $cpt->reval(q{
+ package other;
+ sub other_sayok { print "ok @_\n" }
+ package main;
+ print $foo ? $foo : "not ok 8\n";
+ print $bar{key} ? $bar{key} : "not ok 9\n";
+ (@baz) ? print "@baz\n" : print "not ok 10\n";
+ print $glob;
+ other::other_sayok(12);
+ $foo =~ s/8/14/;
+ $bar{new} = "ok 15\n";
+ @glob = qw(ok 16);
+ });
+ print $@ ? "not ok 13\n#$@" : "ok 13\n";
+ $" = ' ';
+ print $foo, $bar{new}, "@glob\n";
+
+ $Root::foo = "not ok 17";
+ @{$cpt->varglob('bar')} = qw(not ok 18);
+ ${$cpt->varglob('foo')} = "ok 17";
+ @Root::bar = "ok";
+ push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..."
+
+ print "$Root::foo\n";
+ print "@{$cpt->varglob('bar')}\n";
+
+ use strict;
+
+ print 1 ? "ok 19\n" : "not ok 19\n";
+ print 1 ? "ok 20\n" : "not ok 20\n";
+
+ my $m1 = $cpt->mask;
+ $cpt->trap("negate");
+ my $m2 = $cpt->mask;
+ my @masked = opset_to_ops($m1);
+ print $m2 eq opset("negate", @masked) ? "ok 21\n" : "not ok 21\n";
+
+ print eval { $cpt->mask("a bad mask") } ? "not ok 22\n" : "ok 22\n";
+
+ print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n";
+
+ $cpt->mask(empty_opset);
+ my $t_scalar = $cpt->reval('print wantarray ? "not ok 24\n" : "ok 24\n"');
+ print $cpt->reval('@ary=(6,7,8);@ary') == 3 ? "ok 25\n" : "not ok 25\n";
+ my @t_array = $cpt->reval('print wantarray ? "ok 26\n" : "not ok 26\n"; (2,3,4)');
+ print $t_array[2] == 4 ? "ok 27\n" : "not ok 27\n";
+
+ my $t_scalar2 = $cpt->reval('die "foo bar"; 1');
+ print defined $t_scalar2 ? "not ok 28\n" : "ok 28\n";
+ print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n";
+
+ # --- rdo
+
+ my $t = 30;
+ $cpt->rdo('/non/existant/file.name');
+ # The regexp is getting rather baroque.
+ print $! =~ /cannot find|No such file|file specification syntax error|A file or directory in the path name does not exist|Invalid argument|Device not configured|file not found|File or directory doesn't exist/i ? "ok $t\n" : "not ok $t # $!\n"; $t++;
+ # test #31 is gone.
+ print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++;
+
+ #my $rdo_file = "tmp_rdo.tpl";
+ #if (open X,">$rdo_file") {
+ # print X "999\n";
+ # close X;
+ # $cpt->permit_only('const', 'leaveeval');
+ # print $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++;
+ # unlink $rdo_file;
+ #}
+ #else {
+ # print "# test $t skipped, can't open file: $!\nok $t\n"; $t++;
+ #}
+
+
+ print "ok $last_test\n";
+ BEGIN { $last_test = 32 }
diff -c 'perl-5.7.1/ext/Socket/Makefile.PL' 'perl-5.7.2/ext/Socket/Makefile.PL'
Index: ./ext/Socket/Makefile.PL
*** ./ext/Socket/Makefile.PL Tue Mar 6 04:04:59 2001
--- ./ext/Socket/Makefile.PL Mon Jul 9 17:10:13 2001
***************
*** 1,4 ****
--- 1,5 ----
use ExtUtils::MakeMaker;
+ use ExtUtils::Constant 0.07 'WriteConstants';
use Config;
WriteMakefile(
NAME => 'Socket',
***************
*** 6,9 ****
--- 7,50 ----
($Config{libs} =~ /(-lsocks\S*)/ ? (LIBS => [ "$1" ] ) : ()),
MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes', # XXX remove later?
+ realclean => {FILES=> 'constants.c constants.xs'},
+ );
+ my @names = (qw(AF_802 AF_APPLETALK AF_CCITT AF_CHAOS AF_DATAKIT AF_DECnet
+ AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK AF_INET AF_LAT
+ AF_MAX AF_NBS AF_NIT AF_NS AF_OSI AF_OSINET AF_PUP AF_SNA
+ AF_UNIX AF_UNSPEC AF_X25 IOV_MAX IPPROTO_TCP MSG_BCAST
+ MSG_CTLFLAGS MSG_CTLIGNORE MSG_DONTWAIT MSG_EOF MSG_EOR
+ MSG_ERRQUEUE MSG_FIN MSG_MAXIOVLEN MSG_MCAST MSG_NOSIGNAL
+ MSG_RST MSG_SYN MSG_TRUNC MSG_WAITALL PF_802 PF_APPLETALK
+ PF_CCITT PF_CHAOS PF_DATAKIT PF_DECnet PF_DLI PF_ECMA PF_GOSIP
+ PF_HYLINK PF_IMPLINK PF_INET PF_LAT PF_MAX PF_NBS PF_NIT PF_NS
+ PF_OSI PF_OSINET PF_PUP PF_SNA PF_UNIX PF_UNSPEC PF_X25
+ SCM_CONNECT SCM_CREDENTIALS SCM_CREDS SCM_TIMESTAMP SOCK_DGRAM
+ SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM SOL_SOCKET
+ SOMAXCONN SO_ACCEPTCONN SO_BROADCAST SO_DEBUG SO_DONTLINGER
+ SO_DONTROUTE SO_ERROR SO_KEEPALIVE SO_LINGER SO_OOBINLINE
+ SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO SO_REUSEADDR SO_REUSEPORT
+ SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO SO_TYPE SO_USELOOPBACK
+ TCP_KEEPALIVE TCP_MAXRT TCP_MAXSEG TCP_NODELAY TCP_STDURG
+ UIO_MAXIOV MSG_URG),
+ {name=>"SHUT_RD", type=>"IV", default=>["IV", "0"]},
+ {name=>"SHUT_WR", type=>"IV", default=>["IV", "1"]},
+ {name=>"SHUT_RDWR", type=>"IV", default=>["IV", "2"]},
+ );
+
+ push @names,
+ {name=>$_, type=>"IV",
+ macro=>["#if defined($_) || defined(HAS_$_) /* might be an enum */\n",
+ "#endif\n"]}
+ foreach qw (MSG_CTRUNC MSG_DONTROUTE MSG_OOB MSG_PEEK MSG_PROXY SCM_RIGHTS);
+
+ push @names,
+ {name => $_, type => "SV",
+ pre=>"struct in_addr ip_address; ip_address.s_addr = htonl($_);",
+ value => "sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address ))",}
+ foreach qw(INADDR_ANY INADDR_LOOPBACK INADDR_NONE INADDR_BROADCAST);
+
+ WriteConstants(
+ NAME => 'Socket',
+ NAMES => \@names,
);
diff -c 'perl-5.7.1/ext/Socket/Socket.pm' 'perl-5.7.2/ext/Socket/Socket.pm'
Index: ./ext/Socket/Socket.pm
*** ./ext/Socket/Socket.pm Fri Mar 16 04:54:47 2001
--- ./ext/Socket/Socket.pm Mon Jul 9 17:10:13 2001
***************
*** 1,7 ****
package Socket;
our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
! $VERSION = "1.72";
=head1 NAME
--- 1,7 ----
package Socket;
our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
! $VERSION = "1.74";
=head1 NAME
***************
*** 329,340 ****
sub AUTOLOAD {
my($constname);
($constname = $AUTOLOAD) =~ s/.*:://;
! my $val = constant($constname, @_ ? $_[0] : 0);
! if ($! != 0) {
! my ($pack,$file,$line) = caller;
! croak "Your vendor has not defined Socket macro $constname, used";
}
! eval "sub $AUTOLOAD () { $val }";
goto &$AUTOLOAD;
}
--- 329,340 ----
sub AUTOLOAD {
my($constname);
($constname = $AUTOLOAD) =~ s/.*:://;
! croak "&Socket::constant not defined" if $constname eq 'constant';
! my ($error, $val) = constant($constname);
! if ($error) {
! croak $error;
}
! *$AUTOLOAD = sub { $val };
goto &$AUTOLOAD;
}
diff -c /dev/null 'perl-5.7.2/ext/Socket/Socket.t'
Index: ./ext/Socket/Socket.t
*** ./ext/Socket/Socket.t Thu Jan 1 02:00:00 1970
--- ./ext/Socket/Socket.t Mon Jul 9 17:10:13 2001
***************
*** 0 ****
--- 1,87 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bSocket\b/ &&
+ !(($^O eq 'VMS') && $Config{d_socket})) {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ use Socket;
+
+ print "1..8\n";
+
+ if (socket(T,PF_INET,SOCK_STREAM,6)) {
+ print "ok 1\n";
+
+ if (connect(T,pack_sockaddr_in(7,inet_aton("localhost")))){
+ print "ok 2\n";
+
+ print "# Connected to " .
+ inet_ntoa((unpack_sockaddr_in(getpeername(T)))[1])."\n";
+
+ syswrite(T,"hello",5);
+ $read = sysread(T,$buff,10); # Connection may be granted, then closed!
+ while ($read > 0 && length($buff) < 5) {
+ # adjust for fact that TCP doesn't guarantee size of reads/writes
+ $read = sysread(T,$buff,10,length($buff));
+ }
+ print(($read == 0 || $buff eq "hello") ? "ok 3\n" : "not ok 3\n");
+ }
+ else {
+ print "# You're allowed to fail tests 2 and 3 if.\n";
+ print "# The echo service has been disabled.\n";
+ print "# $!\n";
+ print "ok 2\n";
+ print "ok 3\n";
+ }
+ }
+ else {
+ print "# $!\n";
+ print "not ok 1\n";
+ }
+
+ if( socket(S,PF_INET,SOCK_STREAM,6) ){
+ print "ok 4\n";
+
+ if (connect(S,pack_sockaddr_in(7,INADDR_LOOPBACK))){
+ print "ok 5\n";
+
+ print "# Connected to " .
+ inet_ntoa((unpack_sockaddr_in(getpeername(S)))[1])."\n";
+
+ syswrite(S,"olleh",5);
+ $read = sysread(S,$buff,10); # Connection may be granted, then closed!
+ while ($read > 0 && length($buff) < 5) {
+ # adjust for fact that TCP doesn't guarantee size of reads/writes
+ $read = sysread(S,$buff,10,length($buff));
+ }
+ print(($read == 0 || $buff eq "olleh") ? "ok 6\n" : "not ok 6\n");
+ }
+ else {
+ print "# You're allowed to fail tests 5 and 6 if.\n";
+ print "# The echo service has been disabled.\n";
+ print "# $!\n";
+ print "ok 5\n";
+ print "ok 6\n";
+ }
+ }
+ else {
+ print "# $!\n";
+ print "not ok 4\n";
+ }
+
+ # warnings
+ $SIG{__WARN__} = sub {
+ ++ $w if $_[0] =~ /^6-ARG sockaddr_in call is deprecated/ ;
+ } ;
+ $w = 0 ;
+ sockaddr_in(1,2,3,4,5,6) ;
+ print ($w == 1 ? "not ok 7\n" : "ok 7\n") ;
+ use warnings 'Socket' ;
+ sockaddr_in(1,2,3,4,5,6) ;
+ print ($w == 1 ? "ok 8\n" : "not ok 8\n") ;
diff -c 'perl-5.7.1/ext/Socket/Socket.xs' 'perl-5.7.2/ext/Socket/Socket.xs'
Index: ./ext/Socket/Socket.xs
*** ./ext/Socket/Socket.xs Fri Mar 30 17:39:38 2001
--- ./ext/Socket/Socket.xs Mon Jul 9 17:10:13 2001
***************
*** 10,16 ****
# include <sys/socket.h>
# if defined(USE_SOCKS) && defined(I_SOCKS)
# include <socks.h>
! # endif
# ifdef MPE
# define PF_INET AF_INET
# define PF_UNIX AF_UNIX
--- 10,16 ----
# include <sys/socket.h>
# if defined(USE_SOCKS) && defined(I_SOCKS)
# include <socks.h>
! # endif
# ifdef MPE
# define PF_INET AF_INET
# define PF_UNIX AF_UNIX
***************
*** 39,44 ****
--- 39,49 ----
# include "sockadapt.h"
#endif
+ #ifdef NETWARE
+ NETDB_DEFINE_CONTEXT
+ NETINET_DEFINE_CONTEXT
+ #endif
+
#ifdef I_SYSUIO
# include <sys/uio.h>
#endif
***************
*** 63,69 ****
#ifndef HAS_INET_ATON
! /*
* Check whether "cp" is a valid ascii representation
* of an Internet address and convert to a binary address.
* Returns 1 if the address is valid, 0 if not.
--- 68,74 ----
#ifndef HAS_INET_ATON
! /*
* Check whether "cp" is a valid ascii representation
* of an Internet address and convert to a binary address.
* Returns 1 if the address is valid, 0 if not.
***************
*** 104,110 ****
continue;
}
if (base == 16 && (s=strchr(PL_hexdigit,c))) {
! val = (val << 4) +
((s - PL_hexdigit) & 15);
cp++;
continue;
--- 109,115 ----
continue;
}
if (base == 16 && (s=strchr(PL_hexdigit,c))) {
! val = (val << 4) +
((s - PL_hexdigit) & 15);
cp++;
continue;
***************
*** 174,914 ****
return -1;
}
! static double
! constant(char *name, int arg)
! {
! errno = 0;
! switch (*name) {
! case 'A':
! if (strEQ(name, "AF_802"))
! #ifdef AF_802
! return AF_802;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_APPLETALK"))
! #ifdef AF_APPLETALK
! return AF_APPLETALK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_CCITT"))
! #ifdef AF_CCITT
! return AF_CCITT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_CHAOS"))
! #ifdef AF_CHAOS
! return AF_CHAOS;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_DATAKIT"))
! #ifdef AF_DATAKIT
! return AF_DATAKIT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_DECnet"))
! #ifdef AF_DECnet
! return AF_DECnet;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_DLI"))
! #ifdef AF_DLI
! return AF_DLI;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_ECMA"))
! #ifdef AF_ECMA
! return AF_ECMA;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_GOSIP"))
! #ifdef AF_GOSIP
! return AF_GOSIP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_HYLINK"))
! #ifdef AF_HYLINK
! return AF_HYLINK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_IMPLINK"))
! #ifdef AF_IMPLINK
! return AF_IMPLINK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_INET"))
! #ifdef AF_INET
! return AF_INET;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_LAT"))
! #ifdef AF_LAT
! return AF_LAT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_MAX"))
! #ifdef AF_MAX
! return AF_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_NBS"))
! #ifdef AF_NBS
! return AF_NBS;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_NIT"))
! #ifdef AF_NIT
! return AF_NIT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_NS"))
! #ifdef AF_NS
! return AF_NS;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_OSI"))
! #ifdef AF_OSI
! return AF_OSI;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_OSINET"))
! #ifdef AF_OSINET
! return AF_OSINET;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_PUP"))
! #ifdef AF_PUP
! return AF_PUP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_SNA"))
! #ifdef AF_SNA
! return AF_SNA;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_UNIX"))
! #ifdef AF_UNIX
! return AF_UNIX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_UNSPEC"))
! #ifdef AF_UNSPEC
! return AF_UNSPEC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "AF_X25"))
! #ifdef AF_X25
! return AF_X25;
! #else
! goto not_there;
! #endif
! break;
! case 'B':
! break;
! case 'C':
! break;
! case 'D':
! break;
! case 'E':
! break;
! case 'F':
! break;
! case 'G':
! break;
! case 'H':
! break;
! case 'I':
! if (strEQ(name, "IOV_MAX"))
! #ifdef IOV_MAX
! return IOV_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "IPPROTO_TCP"))
! #ifdef IPPROTO_TCP
! return IPPROTO_TCP;
! #else
! goto not_there;
! #endif
! break;
! case 'J':
! break;
! case 'K':
! break;
! case 'L':
! break;
! case 'M':
! if (strEQ(name, "MSG_BCAST"))
! #ifdef MSG_BCAST
! return MSG_BCAST;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MSG_CTLFLAGS"))
! #ifdef MSG_CTLFLAGS
! return MSG_CTLFLAGS;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MSG_CTLIGNORE"))
! #ifdef MSG_CTLIGNORE
! return MSG_CTLIGNORE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MSG_CTRUNC"))
! #if defined(MSG_TRUNC) || defined(HAS_MSG_CTRUNC) /* might be an enum */
! return MSG_CTRUNC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MSG_DONTROUTE"))
! #if defined(MSG_DONTROUTE) || defined(HAS_MSG_DONTROUTE) /* might be an enum */
! return MSG_DONTROUTE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MSG_DONTWAIT"))
! #ifdef MSG_DONTWAIT
! return MSG_DONTWAIT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MSG_EOF"))
! #ifdef MSG_EOF
! return MSG_EOF;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MSG_EOR"))
! #ifdef MSG_EOR
! return MSG_EOR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MSG_ERRQUEUE"))
! #ifdef MSG_ERRQUEUE
! return MSG_ERRQUEUE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MSG_FIN"))
! #ifdef MSG_FIN
! return MSG_FIN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MSG_MAXIOVLEN"))
! #ifdef MSG_MAXIOVLEN
! return MSG_MAXIOVLEN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MSG_MCAST"))
! #ifdef MSG_MCAST
! return MSG_MCAST;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MSG_NOSIGNAL"))
! #ifdef MSG_NOSIGNAL
! return MSG_NOSIGNAL;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MSG_OOB"))
! #if defined(MSG_OOB) || defined(HAS_MSG_OOB) /* might be an enum */
! return MSG_OOB;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MSG_PEEK"))
! #if defined(MSG_PEEK) || defined(HAS_MSG_PEEK) /* might be an enum */
! return MSG_PEEK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MSG_PROXY"))
! #if defined(MSG_PROXY) || defined(HAS_MSG_PROXY) /* might be an enum */
! return MSG_PROXY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MSG_RST"))
! #ifdef MSG_RST
! return MSG_RST;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MSG_SYN"))
! #ifdef MSG_SYN
! return MSG_SYN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MSG_TRUNC"))
! #ifdef MSG_TRUNC
! return MSG_TRUNC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "MSG_WAITALL"))
! #ifdef MSG_WAITALL
! return MSG_WAITALL;
! #else
! goto not_there;
! #endif
! break;
! case 'N':
! break;
! case 'O':
! break;
! case 'P':
! if (strEQ(name, "PF_802"))
! #ifdef PF_802
! return PF_802;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_APPLETALK"))
! #ifdef PF_APPLETALK
! return PF_APPLETALK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_CCITT"))
! #ifdef PF_CCITT
! return PF_CCITT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_CHAOS"))
! #ifdef PF_CHAOS
! return PF_CHAOS;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_DATAKIT"))
! #ifdef PF_DATAKIT
! return PF_DATAKIT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_DECnet"))
! #ifdef PF_DECnet
! return PF_DECnet;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_DLI"))
! #ifdef PF_DLI
! return PF_DLI;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_ECMA"))
! #ifdef PF_ECMA
! return PF_ECMA;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_GOSIP"))
! #ifdef PF_GOSIP
! return PF_GOSIP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_HYLINK"))
! #ifdef PF_HYLINK
! return PF_HYLINK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_IMPLINK"))
! #ifdef PF_IMPLINK
! return PF_IMPLINK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_INET"))
! #ifdef PF_INET
! return PF_INET;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_LAT"))
! #ifdef PF_LAT
! return PF_LAT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_MAX"))
! #ifdef PF_MAX
! return PF_MAX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_NBS"))
! #ifdef PF_NBS
! return PF_NBS;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_NIT"))
! #ifdef PF_NIT
! return PF_NIT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_NS"))
! #ifdef PF_NS
! return PF_NS;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_OSI"))
! #ifdef PF_OSI
! return PF_OSI;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_OSINET"))
! #ifdef PF_OSINET
! return PF_OSINET;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_PUP"))
! #ifdef PF_PUP
! return PF_PUP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_SNA"))
! #ifdef PF_SNA
! return PF_SNA;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_UNIX"))
! #ifdef PF_UNIX
! return PF_UNIX;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_UNSPEC"))
! #ifdef PF_UNSPEC
! return PF_UNSPEC;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "PF_X25"))
! #ifdef PF_X25
! return PF_X25;
! #else
! goto not_there;
! #endif
! break;
! case 'Q':
! break;
! case 'R':
! break;
! case 'S':
! if (strEQ(name, "SCM_CONNECT"))
! #ifdef SCM_CONNECT
! return SCM_CONNECT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SCM_CREDENTIALS"))
! #ifdef SCM_CREDENTIALS
! return SCM_CREDENTIALS;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SCM_CREDS"))
! #ifdef SCM_CREDS
! return SCM_CREDS;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SCM_RIGHTS"))
! #if defined(SCM_RIGHTS) || defined(HAS_SCM_RIGHTS) /* might be an enum */
! return SCM_RIGHTS;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SCM_TIMESTAMP"))
! #ifdef SCM_TIMESTAMP
! return SCM_TIMESTAMP;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SHUT_RD"))
! #ifdef SHUT_RD
! return SHUT_RD;
! #else
! return 0;
! #endif
! if (strEQ(name, "SHUT_RDWR"))
! #ifdef SHUT_RDWR
! return SHUT_RDWR;
! #else
! return 2;
! #endif
! if (strEQ(name, "SHUT_WR"))
! #ifdef SHUT_WR
! return SHUT_WR;
! #else
! return 1;
! #endif
! if (strEQ(name, "SOCK_DGRAM"))
! #ifdef SOCK_DGRAM
! return SOCK_DGRAM;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SOCK_RAW"))
! #ifdef SOCK_RAW
! return SOCK_RAW;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SOCK_RDM"))
! #ifdef SOCK_RDM
! return SOCK_RDM;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SOCK_SEQPACKET"))
! #ifdef SOCK_SEQPACKET
! return SOCK_SEQPACKET;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SOCK_STREAM"))
! #ifdef SOCK_STREAM
! return SOCK_STREAM;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SOL_SOCKET"))
! #ifdef SOL_SOCKET
! return SOL_SOCKET;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SOMAXCONN"))
! #ifdef SOMAXCONN
! return SOMAXCONN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SO_ACCEPTCONN"))
! #ifdef SO_ACCEPTCONN
! return SO_ACCEPTCONN;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SO_BROADCAST"))
! #ifdef SO_BROADCAST
! return SO_BROADCAST;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SO_DEBUG"))
! #ifdef SO_DEBUG
! return SO_DEBUG;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SO_DONTLINGER"))
! #ifdef SO_DONTLINGER
! return SO_DONTLINGER;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SO_DONTROUTE"))
! #ifdef SO_DONTROUTE
! return SO_DONTROUTE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SO_ERROR"))
! #ifdef SO_ERROR
! return SO_ERROR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SO_KEEPALIVE"))
! #ifdef SO_KEEPALIVE
! return SO_KEEPALIVE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SO_LINGER"))
! #ifdef SO_LINGER
! return SO_LINGER;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SO_OOBINLINE"))
! #ifdef SO_OOBINLINE
! return SO_OOBINLINE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SO_RCVBUF"))
! #ifdef SO_RCVBUF
! return SO_RCVBUF;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SO_RCVLOWAT"))
! #ifdef SO_RCVLOWAT
! return SO_RCVLOWAT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SO_RCVTIMEO"))
! #ifdef SO_RCVTIMEO
! return SO_RCVTIMEO;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SO_REUSEADDR"))
! #ifdef SO_REUSEADDR
! return SO_REUSEADDR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SO_REUSEPORT"))
! #ifdef SO_REUSEPORT
! return SO_REUSEPORT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SO_SNDBUF"))
! #ifdef SO_SNDBUF
! return SO_SNDBUF;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SO_SNDLOWAT"))
! #ifdef SO_SNDLOWAT
! return SO_SNDLOWAT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SO_SNDTIMEO"))
! #ifdef SO_SNDTIMEO
! return SO_SNDTIMEO;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SO_TYPE"))
! #ifdef SO_TYPE
! return SO_TYPE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "SO_USELOOPBACK"))
! #ifdef SO_USELOOPBACK
! return SO_USELOOPBACK;
! #else
! goto not_there;
! #endif
! break;
! case 'T':
! if (strEQ(name, "TCP_KEEPALIVE"))
! #ifdef TCP_KEEPALIVE
! return TCP_KEEPALIVE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TCP_MAXRT"))
! #ifdef TCP_MAXRT
! return TCP_MAXRT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TCP_MAXSEG"))
! #ifdef TCP_MAXSEG
! return TCP_MAXSEG;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TCP_NODELAY"))
! #ifdef TCP_NODELAY
! return TCP_NODELAY;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "TCP_STDURG"))
! #ifdef TCP_STDURG
! return TCP_STDURG;
! #else
! goto not_there;
! #endif
! break;
! case 'U':
! if (strEQ(name, "UIO_MAXIOV"))
! #ifdef UIO_MAXIOV
! return UIO_MAXIOV;
! #else
! goto not_there;
! #endif
! break;
! case 'V':
! break;
! case 'W':
! break;
! case 'X':
! break;
! case 'Y':
! break;
! case 'Z':
! break;
! }
! errno = EINVAL;
! return 0;
- not_there:
- errno = ENOENT;
- return 0;
- }
-
-
MODULE = Socket PACKAGE = Socket
! double
! constant(name,arg)
! char * name
! int arg
-
void
inet_aton(host)
char * host
--- 179,190 ----
return -1;
}
! #include "constants.c"
MODULE = Socket PACKAGE = Socket
! INCLUDE: constants.xs
void
inet_aton(host)
char * host
***************
*** 971,977 ****
if (pathname[0] != '/' && pathname[0] != '\\')
croak("Relative UNIX domain socket name '%s' unsupported", pathname);
! else if (len < 8
|| pathname[7] != '/' && pathname[7] != '\\'
|| !strnicmp(pathname + 1, "socket", 6))
off = 7;
--- 247,253 ----
if (pathname[0] != '/' && pathname[0] != '\\')
croak("Relative UNIX domain socket name '%s' unsupported", pathname);
! else if (len < 8
|| pathname[7] != '/' && pathname[7] != '\\'
|| !strnicmp(pathname + 1, "socket", 6))
off = 7;
***************
*** 986,994 ****
if (*s = '/')
*s = '\\';
}
! # else /* !( defined OS2 ) */
Copy( pathname, sun_ad.sun_path, len, char );
# endif
ST(0) = sv_2mortal(newSVpvn((char *)&sun_ad, sizeof sun_ad));
#else
ST(0) = (SV *) not_here("pack_sockaddr_un");
--- 262,271 ----
if (*s = '/')
*s = '\\';
}
! # else /* !( defined OS2 ) */
Copy( pathname, sun_ad.sun_path, len, char );
# endif
+ if (0) not_here("dummy");
ST(0) = sv_2mortal(newSVpvn((char *)&sun_ad, sizeof sun_ad));
#else
ST(0) = (SV *) not_here("pack_sockaddr_un");
***************
*** 1070,1076 ****
"Socket::unpack_sockaddr_in",
addr.sin_family,
AF_INET);
! }
port = ntohs(addr.sin_port);
ip_address = addr.sin_addr;
--- 347,353 ----
"Socket::unpack_sockaddr_in",
addr.sin_family,
AF_INET);
! }
port = ntohs(addr.sin_port);
ip_address = addr.sin_addr;
***************
*** 1077,1116 ****
EXTEND(SP, 2);
PUSHs(sv_2mortal(newSViv((IV) port)));
PUSHs(sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address)));
- }
-
- void
- INADDR_ANY()
- CODE:
- {
- struct in_addr ip_address;
- ip_address.s_addr = htonl(INADDR_ANY);
- ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address ));
- }
-
- void
- INADDR_LOOPBACK()
- CODE:
- {
- struct in_addr ip_address;
- ip_address.s_addr = htonl(INADDR_LOOPBACK);
- ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address));
- }
-
- void
- INADDR_NONE()
- CODE:
- {
- struct in_addr ip_address;
- ip_address.s_addr = htonl(INADDR_NONE);
- ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address));
- }
-
- void
- INADDR_BROADCAST()
- CODE:
- {
- struct in_addr ip_address;
- ip_address.s_addr = htonl(INADDR_BROADCAST);
- ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address));
}
--- 354,357 ----
diff -c 'perl-5.7.1/ext/Storable/ChangeLog' 'perl-5.7.2/ext/Storable/ChangeLog'
Index: ./ext/Storable/ChangeLog
*** ./ext/Storable/ChangeLog Thu Mar 15 16:14:47 2001
--- ./ext/Storable/ChangeLog Mon Jul 9 17:10:13 2001
***************
*** 1,3 ****
--- 1,21 ----
+ Sun Jul 1 13:27:32 MEST 2001 Raphael Manfredi <Raphael_Manfredi@pobox.com>
+
+ . Description:
+
+ Systematically use "=over 4" for POD linters.
+ Apparently, POD linters are much stricter than would
+ otherwise be needed, but that's OK.
+
+ Fixed memory corruption on croaks during thaw(). Thanks
+ to Claudio Garcia for reproducing this bug and providing the
+ code to exercise it. Added test cases for this bug, adapted
+ from Claudio's code.
+
+ Made code compile cleanly with -Wall (from Jarkko Hietaniemi).
+
+ Changed tagnum and classnum from I32 to IV in context. Also
+ from Jarkko.
+
Thu Mar 15 01:22:32 MET 2001 Raphael Manfredi <Raphael_Manfredi@pobox.com>
. Description:
diff -c 'perl-5.7.1/ext/Storable/Storable.pm' 'perl-5.7.2/ext/Storable/Storable.pm'
Index: ./ext/Storable/Storable.pm
Prereq: 1.0.1.10
*** ./ext/Storable/Storable.pm Fri Mar 16 04:54:48 2001
--- ./ext/Storable/Storable.pm Mon Jul 9 17:10:13 2001
***************
*** 1,4 ****
! ;# $Id: Storable.pm,v 1.0.1.10 2001/03/15 00:20:25 ram Exp $
;#
;# Copyright (c) 1995-2000, Raphael Manfredi
;#
--- 1,4 ----
! ;# $Id: Storable.pm,v 1.0.1.11 2001/07/01 11:22:14 ram Exp $
;#
;# Copyright (c) 1995-2000, Raphael Manfredi
;#
***************
*** 6,11 ****
--- 6,15 ----
;# in the README file that comes with the distribution.
;#
;# $Log: Storable.pm,v $
+ ;# Revision 1.0.1.11 2001/07/01 11:22:14 ram
+ ;# patch12: systematically use "=over 4" for POD linters
+ ;# patch12: updated version number
+ ;#
;# Revision 1.0.1.10 2001/03/15 00:20:25 ram
;# patch11: updated version number
;#
***************
*** 59,65 ****
use AutoLoader;
use vars qw($forgive_me $VERSION);
! $VERSION = '1.011';
*AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr...
#
--- 63,69 ----
use AutoLoader;
use vars qw($forgive_me $VERSION);
! $VERSION = '1.012';
*AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr...
#
diff -c 'perl-5.7.1/ext/Storable/Storable.xs' 'perl-5.7.2/ext/Storable/Storable.xs'
Index: ./ext/Storable/Storable.xs
Prereq: 1.0.1.8
*** ./ext/Storable/Storable.xs Thu Mar 29 17:25:12 2001
--- ./ext/Storable/Storable.xs Mon Jul 9 17:10:13 2001
***************
*** 3,9 ****
*/
/*
! * $Id: Storable.xs,v 1.0.1.8 2001/03/15 00:20:55 ram Exp $
*
* Copyright (c) 1995-2000, Raphael Manfredi
*
--- 3,9 ----
*/
/*
! * $Id: Storable.xs,v 1.0.1.9 2001/07/01 11:25:02 ram Exp $
*
* Copyright (c) 1995-2000, Raphael Manfredi
*
***************
*** 11,16 ****
--- 11,21 ----
* in the README file that comes with the distribution.
*
* $Log: Storable.xs,v $
+ * Revision 1.0.1.9 2001/07/01 11:25:02 ram
+ * patch12: fixed memory corruption on croaks during thaw()
+ * patch12: made code compile cleanly with -Wall (Jarkko Hietaniemi)
+ * patch12: changed tagnum and classnum from I32 to IV in context
+ *
* Revision 1.0.1.8 2001/03/15 00:20:55 ram
* patch11: last version was wrongly compiling with assertions on
*
***************
*** 272,292 ****
typedef struct stcxt {
int entry; /* flags recursion */
int optype; /* type of traversal operation */
! HV *hseen; /* which objects have been seen, store time */
! AV *hook_seen; /* which SVs were returned by STORABLE_freeze() */
! AV *aseen; /* which objects have been seen, retrieve time */
! HV *hclass; /* which classnames have been seen, store time */
! AV *aclass; /* which classnames have been seen, retrieve time */
! HV *hook; /* cache for hook methods per class name */
! I32 tagnum; /* incremented at store time for each seen object */
! I32 classnum; /* incremented at store time for each seen classname */
! int netorder; /* true if network order used */
! int s_tainted; /* true if input source is tainted, at retrieve time */
! int forgive_me; /* whether to be forgiving... */
! int canonical; /* whether to store hashes sorted by key */
int s_dirty; /* context is dirty due to CROAK() -- can be cleaned */
! struct extendable keybuf; /* for hash key retrieval */
! struct extendable membuf; /* for memory store/retrieve operations */
PerlIO *fio; /* where I/O are performed, NULL for memory */
int ver_major; /* major of version for retrieved object */
int ver_minor; /* minor of version for retrieved object */
--- 277,299 ----
typedef struct stcxt {
int entry; /* flags recursion */
int optype; /* type of traversal operation */
! HV *hseen; /* which objects have been seen, store time */
! AV *hook_seen; /* which SVs were returned by STORABLE_freeze() */
! AV *aseen; /* which objects have been seen, retrieve time */
! HV *hclass; /* which classnames have been seen, store time */
! AV *aclass; /* which classnames have been seen, retrieve time */
! HV *hook; /* cache for hook methods per class name */
! IV tagnum; /* incremented at store time for each seen object */
! IV classnum; /* incremented at store time for each seen classname */
! int netorder; /* true if network order used */
! int s_tainted; /* true if input source is tainted, at retrieve time */
! int forgive_me; /* whether to be forgiving... */
! int canonical; /* whether to store hashes sorted by key */
int s_dirty; /* context is dirty due to CROAK() -- can be cleaned */
! int membuf_ro; /* true means membuf is read-only and msaved is rw */
! struct extendable keybuf; /* for hash key retrieval */
! struct extendable membuf; /* for memory store/retrieve operations */
! struct extendable msaved; /* where potentially valid mbuf is saved */
PerlIO *fio; /* where I/O are performed, NULL for memory */
int ver_major; /* major of version for retrieved object */
int ver_minor; /* minor of version for retrieved object */
***************
*** 400,406 ****
} while (0)
#define KBUFCHK(x) do { \
if (x >= ksiz) { \
! TRACEME(("** extending kbuf to %d bytes", x+1)); \
Renew(kbuf, x+1, char); \
ksiz = x+1; \
} \
--- 407,413 ----
} while (0)
#define KBUFCHK(x) do { \
if (x >= ksiz) { \
! TRACEME(("** extending kbuf to %d bytes (had %d)", x+1, ksiz)); \
Renew(kbuf, x+1, char); \
ksiz = x+1; \
} \
***************
*** 441,450 ****
--- 448,481 ----
#define MBUF_SIZE() (mptr - mbase)
/*
+ * MBUF_SAVE_AND_LOAD
+ * MBUF_RESTORE
+ *
+ * Those macros are used in do_retrieve() to save the current memory
+ * buffer into cxt->msaved, before MBUF_LOAD() can be used to retrieve
+ * data from a string.
+ */
+ #define MBUF_SAVE_AND_LOAD(in) do { \
+ ASSERT(!cxt->membuf_ro, ("mbase not already saved")); \
+ cxt->membuf_ro = 1; \
+ TRACEME(("saving mbuf")); \
+ StructCopy(&cxt->membuf, &cxt->msaved, struct extendable); \
+ MBUF_LOAD(in); \
+ } while (0)
+
+ #define MBUF_RESTORE() do { \
+ ASSERT(cxt->membuf_ro, ("mbase is read-only")); \
+ cxt->membuf_ro = 0; \
+ TRACEME(("restoring mbuf")); \
+ StructCopy(&cxt->msaved, &cxt->membuf, struct extendable); \
+ } while (0)
+
+ /*
* Use SvPOKp(), because SvPOK() fails on tainted scalars.
* See store_scalar() for other usage of this workaround.
*/
#define MBUF_LOAD(v) do { \
+ ASSERT(cxt->membuf_ro, ("mbase is read-only")); \
if (!SvPOKp(v)) \
CROAK(("Not a scalar string")); \
mptr = mbase = SvPV(v, msiz); \
***************
*** 454,460 ****
#define MBUF_XTEND(x) do { \
int nsz = (int) round_mgrow((x)+msiz); \
int offset = mptr - mbase; \
! TRACEME(("** extending mbase to %d bytes", nsz)); \
Renew(mbase, nsz, char); \
msiz = nsz; \
mptr = mbase + offset; \
--- 485,493 ----
#define MBUF_XTEND(x) do { \
int nsz = (int) round_mgrow((x)+msiz); \
int offset = mptr - mbase; \
! ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); \
! TRACEME(("** extending mbase from %d to %d bytes (wants %d new)", \
! msiz, nsz, (x))); \
Renew(mbase, nsz, char); \
msiz = nsz; \
mptr = mbase + offset; \
***************
*** 927,932 ****
--- 960,978 ----
}
/*
+ * reset_context
+ *
+ * Called at the end of every context cleaning, to perform common reset
+ * operations.
+ */
+ static void reset_context(stcxt_t *cxt)
+ {
+ cxt->entry = 0;
+ cxt->s_dirty = 0;
+ cxt->optype &= ~(ST_STORE|ST_RETRIEVE); /* Leave ST_CLONE alone */
+ }
+
+ /*
* init_store_context
*
* Initialize a new store context for real recursion.
***************
*** 1036,1048 ****
* Insert real values into hashes where we stored faked pointers.
*/
! hv_iterinit(cxt->hseen);
! while (he = hv_iternext(cxt->hseen))
! HeVAL(he) = &PL_sv_undef;
! hv_iterinit(cxt->hclass);
! while (he = hv_iternext(cxt->hclass))
! HeVAL(he) = &PL_sv_undef;
/*
* And now dispose of them...
--- 1082,1098 ----
* Insert real values into hashes where we stored faked pointers.
*/
! if (cxt->hseen) {
! hv_iterinit(cxt->hseen);
! while ((he = hv_iternext(cxt->hseen))) /* Extra () for -Wall, grr.. */
! HeVAL(he) = &PL_sv_undef;
! }
! if (cxt->hclass) {
! hv_iterinit(cxt->hclass);
! while ((he = hv_iternext(cxt->hclass))) /* Extra () for -Wall, grr.. */
! HeVAL(he) = &PL_sv_undef;
! }
/*
* And now dispose of them...
***************
*** 1082,1089 ****
sv_free((SV *) hook_seen);
}
! cxt->entry = 0;
! cxt->s_dirty = 0;
}
/*
--- 1132,1138 ----
sv_free((SV *) hook_seen);
}
! reset_context(cxt);
}
/*
***************
*** 1163,1170 ****
sv_free((SV *) hseen); /* optional HV, for backward compat. */
}
! cxt->entry = 0;
! cxt->s_dirty = 0;
}
/*
--- 1212,1218 ----
sv_free((SV *) hseen); /* optional HV, for backward compat. */
}
! reset_context(cxt);
}
/*
***************
*** 1172,1190 ****
*
* A workaround for the CROAK bug: cleanup the last context.
*/
! static void clean_context(cxt)
! stcxt_t *cxt;
{
TRACEME(("clean_context"));
ASSERT(cxt->s_dirty, ("dirty context"));
if (cxt->optype & ST_RETRIEVE)
clean_retrieve_context(cxt);
! else
clean_store_context(cxt);
ASSERT(!cxt->s_dirty, ("context is clean"));
}
/*
--- 1220,1245 ----
*
* A workaround for the CROAK bug: cleanup the last context.
*/
! static void clean_context(stcxt_t *cxt)
{
TRACEME(("clean_context"));
ASSERT(cxt->s_dirty, ("dirty context"));
+ if (cxt->membuf_ro)
+ MBUF_RESTORE();
+
+ ASSERT(!cxt->membuf_ro, ("mbase is not read-only"));
+
if (cxt->optype & ST_RETRIEVE)
clean_retrieve_context(cxt);
! else if (cxt->optype & ST_STORE)
clean_store_context(cxt);
+ else
+ reset_context(cxt);
ASSERT(!cxt->s_dirty, ("context is clean"));
+ ASSERT(cxt->entry == 0, ("context is reset"));
}
/*
***************
*** 1206,1211 ****
--- 1261,1271 ----
cxt->prev = parent_cxt;
SET_STCXT(cxt);
+ TRACEME(("kbuf has %d bytes at 0x%x", ksiz, kbuf));
+ TRACEME(("mbuf has %d bytes at 0x%x", msiz, mbase));
+
+ ASSERT(!cxt->s_dirty, ("clean context"));
+
return cxt;
}
***************
*** 1232,1237 ****
--- 1292,1299 ----
Safefree(cxt);
SET_STCXT(prev);
+
+ ASSERT(cxt, ("context not void"));
}
/***
***************
*** 1296,1302 ****
{
GV *gv;
SV *sv;
- SV **svh;
/*
* The following code is the same as the one performed by UNIVERSAL::can
--- 1358,1363 ----
***************
*** 1767,1773 ****
continue;
}
TRACEME(("(#%d) item", i));
! if (ret = store(cxt, *sav))
return ret;
}
--- 1828,1834 ----
continue;
}
TRACEME(("(#%d) item", i));
! if ((ret = store(cxt, *sav))) /* Extra () for -Wall, grr... */
return ret;
}
***************
*** 1875,1881 ****
TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
! if (ret = store(cxt, val))
goto out;
/*
--- 1936,1942 ----
TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
! if ((ret = store(cxt, val))) /* Extra () for -Wall, grr... */
goto out;
/*
***************
*** 1921,1927 ****
TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
! if (ret = store(cxt, val))
goto out;
/*
--- 1982,1988 ----
TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
! if ((ret = store(cxt, val))) /* Extra () for -Wall, grr... */
goto out;
/*
***************
*** 2004,2010 ****
* accesses on the retrieved object will indeed call the magic methods...
*/
! if (ret = store(cxt, mg->mg_obj))
return ret;
TRACEME(("ok (tied)"));
--- 2065,2071 ----
* accesses on the retrieved object will indeed call the magic methods...
*/
! if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
return ret;
TRACEME(("ok (tied)"));
***************
*** 2043,2054 ****
PUTMARK(SX_TIED_KEY);
TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
! if (ret = store(cxt, mg->mg_obj))
return ret;
TRACEME(("store_tied_item: storing PTR 0x%"UVxf, PTR2UV(mg->mg_ptr)));
! if (ret = store(cxt, (SV *) mg->mg_ptr))
return ret;
} else {
I32 idx = mg->mg_len;
--- 2104,2115 ----
PUTMARK(SX_TIED_KEY);
TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
! if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
return ret;
TRACEME(("store_tied_item: storing PTR 0x%"UVxf, PTR2UV(mg->mg_ptr)));
! if ((ret = store(cxt, (SV *) mg->mg_ptr))) /* Idem, for -Wall */
return ret;
} else {
I32 idx = mg->mg_len;
***************
*** 2057,2063 ****
PUTMARK(SX_TIED_IDX);
TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
! if (ret = store(cxt, mg->mg_obj))
return ret;
TRACEME(("store_tied_item: storing IDX %d", idx));
--- 2118,2124 ----
PUTMARK(SX_TIED_IDX);
TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
! if ((ret = store(cxt, mg->mg_obj))) /* Idem, for -Wall */
return ret;
TRACEME(("store_tied_item: storing IDX %d", idx));
***************
*** 2137,2144 ****
I32 classnum;
int ret;
int clone = cxt->optype & ST_CLONE;
! char mtype; /* for blessed ref to tied structures */
! unsigned char eflags; /* used when object type is SHT_EXTRA */
TRACEME(("store_hook, class \"%s\", tagged #%d", HvNAME(pkg), cxt->tagnum));
--- 2198,2205 ----
I32 classnum;
int ret;
int clone = cxt->optype & ST_CLONE;
! char mtype = '\0'; /* for blessed ref to tied structures */
! unsigned char eflags = '\0'; /* used when object type is SHT_EXTRA */
TRACEME(("store_hook, class \"%s\", tagged #%d", HvNAME(pkg), cxt->tagnum));
***************
*** 2279,2285 ****
* Serialize entry if not done already, and get its tag.
*/
! if (svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE))
goto sv_seen; /* Avoid moving code too far to the right */
TRACEME(("listed object %d at 0x%"UVxf" is unknown", i-1, PTR2UV(xsv)));
--- 2340,2346 ----
* Serialize entry if not done already, and get its tag.
*/
! if ((svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE)))
goto sv_seen; /* Avoid moving code too far to the right */
TRACEME(("listed object %d at 0x%"UVxf" is unknown", i-1, PTR2UV(xsv)));
***************
*** 2304,2310 ****
} else
PUTMARK(flags);
! if (ret = store(cxt, xsv)) /* Given by hook for us to store */
return ret;
svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE);
--- 2365,2371 ----
} else
PUTMARK(flags);
! if ((ret = store(cxt, xsv))) /* Given by hook for us to store */
return ret;
svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE);
***************
*** 2481,2487 ****
* [<magic object>]
*/
! if (ret = store(cxt, mg->mg_obj))
return ret;
}
--- 2542,2548 ----
* [<magic object>]
*/
! if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
return ret;
}
***************
*** 2618,2625 ****
* Store placeholder string as a scalar instead...
*/
! (void) sprintf(buf, "You lost %s(0x%"UVxf")\0", sv_reftype(sv, FALSE),
! PTR2UV(sv));
len = strlen(buf);
STORE_SCALAR(buf, len);
--- 2679,2686 ----
* Store placeholder string as a scalar instead...
*/
! (void) sprintf(buf, "You lost %s(0x%"UVxf")%c", sv_reftype(sv, FALSE),
! PTR2UV(sv), (char) 0);
len = strlen(buf);
STORE_SCALAR(buf, len);
***************
*** 2702,2708 ****
{
SV **svh;
int ret;
- SV *tag;
int type;
HV *hseen = cxt->hseen;
--- 2763,2768 ----
***************
*** 3001,3007 ****
*/
SV *mstore(SV *sv)
{
- dSTCXT;
SV *out;
TRACEME(("mstore"));
--- 3061,3066 ----
***************
*** 3020,3026 ****
*/
SV *net_mstore(SV *sv)
{
- dSTCXT;
SV *out;
TRACEME(("net_mstore"));
--- 3079,3084 ----
***************
*** 3086,3093 ****
sva = av_fetch(cxt->aclass, idx, FALSE);
if (!sva)
! CROAK(("Class name #%"IVdf" should have been seen already",
! (IV)idx));
class = SvPVX(*sva); /* We know it's a PV, by construction */
--- 3144,3150 ----
sva = av_fetch(cxt->aclass, idx, FALSE);
if (!sva)
! CROAK(("Class name #%"IVdf" should have been seen already", (IV) idx));
class = SvPVX(*sva); /* We know it's a PV, by construction */
***************
*** 3188,3194 ****
SV *sv;
SV *rv;
int obj_type;
- I32 classname;
int clone = cxt->optype & ST_CLONE;
char mtype = '\0';
unsigned int extra_type = 0;
--- 3245,3250 ----
***************
*** 3282,3289 ****
sva = av_fetch(cxt->aclass, idx, FALSE);
if (!sva)
! CROAK(("Class name #%"IVdf" should have been seen already",
! (IV)idx));
class = SvPVX(*sva); /* We know it's a PV, by construction */
TRACEME(("class ID %d => %s", idx, class));
--- 3338,3345 ----
sva = av_fetch(cxt->aclass, idx, FALSE);
if (!sva)
! CROAK(("Class name #%"IVdf" should have been seen already",
! (IV) idx));
class = SvPVX(*sva); /* We know it's a PV, by construction */
TRACEME(("class ID %d => %s", idx, class));
***************
*** 3384,3390 ****
tag = ntohl(tag);
svh = av_fetch(cxt->aseen, tag, FALSE);
if (!svh)
! CROAK(("Object #%"IVdf" should have been retrieved already", (IV)tag));
xsv = *svh;
ary[i] = SvREFCNT_inc(xsv);
}
--- 3440,3447 ----
tag = ntohl(tag);
svh = av_fetch(cxt->aseen, tag, FALSE);
if (!svh)
! CROAK(("Object #%"IVdf" should have been retrieved already",
! (IV) tag));
xsv = *svh;
ary[i] = SvREFCNT_inc(xsv);
}
***************
*** 4008,4023 ****
{
SV *sv;
int siv;
! signed char tmp; /* must use temp var to work around
! an AIX compiler bug --H.Merijn Brand */
TRACEME(("retrieve_byte (#%d)", cxt->tagnum));
GETMARK(siv);
TRACEME(("small integer read as %d", (unsigned char) siv));
! tmp = ((unsigned char)siv) - 128;
! sv = newSViv (tmp);
!
SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */
TRACEME(("byte %d", tmp));
--- 4065,4078 ----
{
SV *sv;
int siv;
! signed char tmp; /* Workaround for AIX cc bug --H.Merijn Brand */
TRACEME(("retrieve_byte (#%d)", cxt->tagnum));
GETMARK(siv);
TRACEME(("small integer read as %d", (unsigned char) siv));
! tmp = (unsigned char) siv - 128;
! sv = newSViv(tmp);
SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */
TRACEME(("byte %d", tmp));
***************
*** 4155,4161 ****
I32 i;
HV *hv;
SV *sv;
- static SV *sv_h_undef = (SV *) 0; /* hv_store() bug */
TRACEME(("retrieve_hash (#%d)", cxt->tagnum));
--- 4210,4215 ----
***************
*** 4287,4293 ****
I32 size;
I32 i;
HV *hv;
! SV *sv;
int c;
static SV *sv_h_undef = (SV *) 0; /* hv_store() bug */
--- 4341,4347 ----
I32 size;
I32 i;
HV *hv;
! SV *sv = (SV *) 0;
int c;
static SV *sv_h_undef = (SV *) 0; /* hv_store() bug */
***************
*** 4463,4469 ****
* information to check.
*/
! if (cxt->netorder = (use_network_order & 0x1))
return &PL_sv_undef; /* No byte ordering info */
sprintf(byteorder, "%lx", (unsigned long) BYTEORDER);
--- 4517,4523 ----
* information to check.
*/
! if ((cxt->netorder = (use_network_order & 0x1))) /* Extra () for -Wall */
return &PL_sv_undef; /* No byte ordering info */
sprintf(byteorder, "%lx", (unsigned long) BYTEORDER);
***************
*** 4534,4540 ****
I32 tagn;
svh = hv_fetch(cxt->hseen, (char *) &tag, sizeof(tag), FALSE);
if (!svh)
! CROAK(("Old tag 0x%"UVxf" should have been mapped already", (UV)tag));
tagn = SvIV(*svh); /* Mapped tag number computed earlier below */
/*
--- 4588,4595 ----
I32 tagn;
svh = hv_fetch(cxt->hseen, (char *) &tag, sizeof(tag), FALSE);
if (!svh)
! CROAK(("Old tag 0x%"UVxf" should have been mapped already",
! (UV) tag));
tagn = SvIV(*svh); /* Mapped tag number computed earlier below */
/*
***************
*** 4543,4549 ****
svh = av_fetch(cxt->aseen, tagn, FALSE);
if (!svh)
! CROAK(("Object #%"IVdf" should have been retrieved already", (IV)tagn));
sv = *svh;
TRACEME(("has retrieved #%d at 0x%"UVxf, tagn, PTR2UV(sv)));
SvREFCNT_inc(sv); /* One more reference to this same sv */
--- 4598,4605 ----
svh = av_fetch(cxt->aseen, tagn, FALSE);
if (!svh)
! CROAK(("Object #%"IVdf" should have been retrieved already",
! (IV) tagn));
sv = *svh;
TRACEME(("has retrieved #%d at 0x%"UVxf, tagn, PTR2UV(sv)));
SvREFCNT_inc(sv); /* One more reference to this same sv */
***************
*** 4569,4575 ****
* Regular post-0.6 binary format.
*/
- again:
GETMARK(type);
TRACEME(("retrieve type = %d", type));
--- 4625,4630 ----
***************
*** 4584,4591 ****
tag = ntohl(tag);
svh = av_fetch(cxt->aseen, tag, FALSE);
if (!svh)
! CROAK(("Object #%"IVdf" should have been retrieved already",
! (IV)tag));
sv = *svh;
TRACEME(("had retrieved #%d at 0x%"UVxf, tag, PTR2UV(sv)));
SvREFCNT_inc(sv); /* One more reference to this same sv */
--- 4639,4646 ----
tag = ntohl(tag);
svh = av_fetch(cxt->aseen, tag, FALSE);
if (!svh)
! CROAK(("Object #%"IVdf" should have been retrieved already",
! (IV) tag));
sv = *svh;
TRACEME(("had retrieved #%d at 0x%"UVxf, tag, PTR2UV(sv)));
SvREFCNT_inc(sv); /* One more reference to this same sv */
***************
*** 4656,4662 ****
dSTCXT;
SV *sv;
int is_tainted; /* Is input source tainted? */
! struct extendable msave; /* Where potentially valid mbuf is saved */
TRACEME(("do_retrieve (optype = 0x%x)", optype));
--- 4711,4717 ----
dSTCXT;
SV *sv;
int is_tainted; /* Is input source tainted? */
! int pre_06_fmt = 0; /* True with pre Storable 0.6 formats */
TRACEME(("do_retrieve (optype = 0x%x)", optype));
***************
*** 4704,4715 ****
KBUFINIT(); /* Allocate hash key reading pool once */
! if (!f && in) {
! StructCopy(&cxt->membuf, &msave, struct extendable);
! MBUF_LOAD(in);
! }
-
/*
* Magic number verifications.
*
--- 4759,4767 ----
KBUFINIT(); /* Allocate hash key reading pool once */
! if (!f && in)
! MBUF_SAVE_AND_LOAD(in);
/*
* Magic number verifications.
*
***************
*** 4750,4757 ****
*/
if (!f && in)
! StructCopy(&msave, &cxt->membuf, struct extendable);
/*
* The "root" context is never freed.
*/
--- 4802,4811 ----
*/
if (!f && in)
! MBUF_RESTORE();
+ pre_06_fmt = cxt->hseen != NULL; /* Before we clean context */
+
/*
* The "root" context is never freed.
*/
***************
*** 4779,4793 ****
*
* Build a reference to the SV returned by pretrieve even if it is
* already one and not a scalar, for consistency reasons.
- *
- * NB: although context might have been cleaned, the value of `cxt->hseen'
- * remains intact, and can be used as a flag.
*/
! if (cxt->hseen) { /* Was not handling overloading by then */
SV *rv;
! if (sv_type(sv) == svis_REF && (rv = SvRV(sv)) && SvOBJECT(rv))
return sv;
}
/*
--- 4833,4847 ----
*
* Build a reference to the SV returned by pretrieve even if it is
* already one and not a scalar, for consistency reasons.
*/
! if (pre_06_fmt) { /* Was not handling overloading by then */
SV *rv;
! TRACEME(("fixing for old formats -- pre 0.6"));
! if (sv_type(sv) == svis_REF && (rv = SvRV(sv)) && SvOBJECT(rv)) {
! TRACEME(("ended do_retrieve() with an object -- pre 0.6"));
return sv;
+ }
}
/*
***************
*** 4808,4821 ****
*/
if (SvOBJECT(sv)) {
! HV *stash = (HV *) SvSTASH (sv);
SV *rv = newRV_noinc(sv);
if (stash && Gv_AMG(stash)) {
SvAMAGIC_on(rv);
TRACEME(("restored overloading on root reference"));
}
return rv;
}
return newRV_noinc(sv);
}
--- 4862,4878 ----
*/
if (SvOBJECT(sv)) {
! HV *stash = (HV *) SvSTASH(sv);
SV *rv = newRV_noinc(sv);
if (stash && Gv_AMG(stash)) {
SvAMAGIC_on(rv);
TRACEME(("restored overloading on root reference"));
}
+ TRACEME(("ended do_retrieve() with an object"));
return rv;
}
+
+ TRACEME(("regular do_retrieve() end"));
return newRV_noinc(sv);
}
diff -c /dev/null 'perl-5.7.2/ext/Storable/t/blessed.t'
Index: ./ext/Storable/t/blessed.t
*** ./ext/Storable/t/blessed.t Thu Jan 1 02:00:00 1970
--- ./ext/Storable/t/blessed.t Mon Jul 9 17:10:13 2001
***************
*** 0 ****
--- 1,104 ----
+ #!./perl
+
+ # $Id: blessed.t,v 1.0 2000/09/01 19:40:41 ram Exp $
+ #
+ # Copyright (c) 1995-2000, Raphael Manfredi
+ #
+ # You may redistribute only under the same terms as Perl 5, as specified
+ # in the README file that comes with the distribution.
+ #
+ # $Log: blessed.t,v $
+ # Revision 1.0 2000/09/01 19:40:41 ram
+ # Baseline for first official release.
+ #
+
+ sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+ }
+
+ sub ok;
+
+ use Storable qw(freeze thaw);
+
+ print "1..10\n";
+
+ package SHORT_NAME;
+
+ sub make { bless [], shift }
+
+ package SHORT_NAME_WITH_HOOK;
+
+ sub make { bless [], shift }
+
+ sub STORABLE_freeze {
+ my $self = shift;
+ return ("", $self);
+ }
+
+ sub STORABLE_thaw {
+ my $self = shift;
+ my $cloning = shift;
+ my ($x, $obj) = @_;
+ die "STORABLE_thaw" unless $obj eq $self;
+ }
+
+ package main;
+
+ # Still less than 256 bytes, so long classname logic not fully exercised
+ # Wait until Perl removes the restriction on identifier lengths.
+ my $name = "LONG_NAME_" . 'xxxxxxxxxxxxx::' x 14 . "final";
+
+ eval <<EOC;
+ package $name;
+
+ \@ISA = ("SHORT_NAME");
+ EOC
+ die $@ if $@;
+ ok 1, $@ eq '';
+
+ eval <<EOC;
+ package ${name}_WITH_HOOK;
+
+ \@ISA = ("SHORT_NAME_WITH_HOOK");
+ EOC
+ ok 2, $@ eq '';
+
+ # Construct a pool of objects
+ my @pool;
+
+ for (my $i = 0; $i < 10; $i++) {
+ push(@pool, SHORT_NAME->make);
+ push(@pool, SHORT_NAME_WITH_HOOK->make);
+ push(@pool, $name->make);
+ push(@pool, "${name}_WITH_HOOK"->make);
+ }
+
+ my $x = freeze \@pool;
+ ok 3, 1;
+
+ my $y = thaw $x;
+ ok 4, ref $y eq 'ARRAY';
+ ok 5, @{$y} == @pool;
+
+ ok 6, ref $y->[0] eq 'SHORT_NAME';
+ ok 7, ref $y->[1] eq 'SHORT_NAME_WITH_HOOK';
+ ok 8, ref $y->[2] eq $name;
+ ok 9, ref $y->[3] eq "${name}_WITH_HOOK";
+
+ my $good = 1;
+ for (my $i = 0; $i < 10; $i++) {
+ do { $good = 0; last } unless ref $y->[4*$i] eq 'SHORT_NAME';
+ do { $good = 0; last } unless ref $y->[4*$i+1] eq 'SHORT_NAME_WITH_HOOK';
+ do { $good = 0; last } unless ref $y->[4*$i+2] eq $name;
+ do { $good = 0; last } unless ref $y->[4*$i+3] eq "${name}_WITH_HOOK";
+ }
+ ok 10, $good;
+
diff -c /dev/null 'perl-5.7.2/ext/Storable/t/canonical.t'
Index: ./ext/Storable/t/canonical.t
*** ./ext/Storable/t/canonical.t Thu Jan 1 02:00:00 1970
--- ./ext/Storable/t/canonical.t Mon Jul 9 17:10:13 2001
***************
*** 0 ****
--- 1,153 ----
+ #!./perl
+
+ # $Id: canonical.t,v 1.0 2000/09/01 19:40:41 ram Exp $
+ #
+ # Copyright (c) 1995-2000, Raphael Manfredi
+ #
+ # You may redistribute only under the same terms as Perl 5, as specified
+ # in the README file that comes with the distribution.
+ #
+ # $Log: canonical.t,v $
+ # Revision 1.0 2000/09/01 19:40:41 ram
+ # Baseline for first official release.
+ #
+
+ sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ }
+
+
+ use Storable qw(freeze thaw dclone);
+ use vars qw($debugging $verbose);
+
+ print "1..8\n";
+
+ sub ok {
+ my($testno, $ok) = @_;
+ print "not " unless $ok;
+ print "ok $testno\n";
+ }
+
+
+ # Uncomment the folowing line to get a dump of the constructed data structure
+ # (you may want to reduce the size of the hashes too)
+ # $debugging = 1;
+
+ $hashsize = 100;
+ $maxhash2size = 100;
+ $maxarraysize = 100;
+
+ # Use MD5 if its available to make random string keys
+
+ eval { require "MD5.pm" };
+ $gotmd5 = !$@;
+
+ # Use Data::Dumper if debugging and it is available to create an ASCII dump
+
+ if ($debugging) {
+ eval { require "Data/Dumper.pm" };
+ $gotdd = !$@;
+ }
+
+ @fixed_strings = ("January", "February", "March", "April", "May", "June",
+ "July", "August", "September", "October", "November", "December" );
+
+ # Build some arbitrarily complex data structure starting with a top level hash
+ # (deeper levels contain scalars, references to hashes or references to arrays);
+
+ for (my $i = 0; $i < $hashsize; $i++) {
+ my($k) = int(rand(1_000_000));
+ $k = MD5->hexhash($k) if $gotmd5 and int(rand(2));
+ $a1{$k} = { key => "$k", value => $i };
+
+ # A third of the elements are references to further hashes
+
+ if (int(rand(1.5))) {
+ my($hash2) = {};
+ my($hash2size) = int(rand($maxhash2size));
+ while ($hash2size--) {
+ my($k2) = $k . $i . int(rand(100));
+ $hash2->{$k2} = $fixed_strings[rand(int(@fixed_strings))];
+ }
+ $a1{$k}->{value} = $hash2;
+ }
+
+ # A further third are references to arrays
+
+ elsif (int(rand(2))) {
+ my($arr_ref) = [];
+ my($arraysize) = int(rand($maxarraysize));
+ while ($arraysize--) {
+ push(@$arr_ref, $fixed_strings[rand(int(@fixed_strings))]);
+ }
+ $a1{$k}->{value} = $arr_ref;
+ }
+ }
+
+
+ print STDERR Data::Dumper::Dumper(\%a1) if ($verbose and $gotdd);
+
+
+ # Copy the hash, element by element in order of the keys
+
+ foreach $k (sort keys %a1) {
+ $a2{$k} = { key => "$k", value => $a1{$k}->{value} };
+ }
+
+ # Deep clone the hash
+
+ $a3 = dclone(\%a1);
+
+ # In canonical mode the frozen representation of each of the hashes
+ # should be identical
+
+ $Storable::canonical = 1;
+
+ $x1 = freeze(\%a1);
+ $x2 = freeze(\%a2);
+ $x3 = freeze($a3);
+
+ ok 1, (length($x1) > $hashsize); # sanity check
+ ok 2, length($x1) == length($x2); # idem
+ ok 3, $x1 eq $x2;
+ ok 4, $x1 eq $x3;
+
+ # In normal mode it is exceedingly unlikely that the frozen
+ # representaions of all the hashes will be the same (normally the hash
+ # elements are frozen in the order they are stored internally,
+ # i.e. pseudo-randomly).
+
+ $Storable::canonical = 0;
+
+ $x1 = freeze(\%a1);
+ $x2 = freeze(\%a2);
+ $x3 = freeze($a3);
+
+
+ # Two out of three the same may be a coincidence, all three the same
+ # is much, much more unlikely. Still it could happen, so this test
+ # may report a false negative.
+
+ ok 5, ($x1 ne $x2) || ($x1 ne $x3);
+
+
+ # Ensure refs to "undef" values are properly shared
+ # Same test as in t/dclone.t to ensure the "canonical" code is also correct
+
+ my $hash;
+ push @{$$hash{''}}, \$$hash{a};
+ ok 6, $$hash{''}[0] == \$$hash{a};
+
+ my $cloned = dclone(dclone($hash));
+ ok 7, $$cloned{''}[0] == \$$cloned{a};
+
+ $$cloned{a} = "blah";
+ ok 8, $$cloned{''}[0] == \$$cloned{a};
+
diff -c /dev/null 'perl-5.7.2/ext/Storable/t/compat06.t'
Index: ./ext/Storable/t/compat06.t
*** ./ext/Storable/t/compat06.t Thu Jan 1 02:00:00 1970
--- ./ext/Storable/t/compat06.t Mon Jul 9 17:10:13 2001
***************
*** 0 ****
--- 1,157 ----
+ #!./perl
+
+ # $Id: compat-0.6.t,v 1.0.1.1 2001/02/17 12:26:21 ram Exp $
+ #
+ # Copyright (c) 1995-2000, Raphael Manfredi
+ #
+ # You may redistribute only under the same terms as Perl 5, as specified
+ # in the README file that comes with the distribution.
+ #
+ # $Log: compat-0.6.t,v $
+ # Revision 1.0.1.1 2001/02/17 12:26:21 ram
+ # patch8: added EBCDIC version of the test, from Peter Prymmer
+ #
+ # Revision 1.0 2000/09/01 19:40:41 ram
+ # Baseline for first official release.
+ #
+
+ BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+ }
+
+ sub ok;
+
+ print "1..8\n";
+
+ use Storable qw(freeze nfreeze thaw);
+
+ package TIED_HASH;
+
+ sub TIEHASH {
+ my $self = bless {}, shift;
+ return $self;
+ }
+
+ sub FETCH {
+ my $self = shift;
+ my ($key) = @_;
+ $main::hash_fetch++;
+ return $self->{$key};
+ }
+
+ sub STORE {
+ my $self = shift;
+ my ($key, $val) = @_;
+ $self->{$key} = $val;
+ }
+
+ package SIMPLE;
+
+ sub make {
+ my $self = bless [], shift;
+ my ($x) = @_;
+ $self->[0] = $x;
+ return $self;
+ }
+
+ package ROOT;
+
+ sub make {
+ my $self = bless {}, shift;
+ my $h = tie %hash, TIED_HASH;
+ $self->{h} = $h;
+ $self->{ref} = \%hash;
+ my @pool;
+ for (my $i = 0; $i < 5; $i++) {
+ push(@pool, SIMPLE->make($i));
+ }
+ $self->{obj} = \@pool;
+ my @a = ('string', $h, $self);
+ $self->{a} = \@a;
+ $self->{num} = [1, 0, -3, -3.14159, 456, 4.5];
+ $h->{key1} = 'val1';
+ $h->{key2} = 'val2';
+ return $self;
+ };
+
+ sub num { $_[0]->{num} }
+ sub h { $_[0]->{h} }
+ sub ref { $_[0]->{ref} }
+ sub obj { $_[0]->{obj} }
+
+ package main;
+
+ my $is_EBCDIC = (ord('A') == 193) ? 1 : 0;
+
+ my $r = ROOT->make;
+
+ my $data = '';
+ if (!$is_EBCDIC) { # ASCII machine
+ while (<DATA>) {
+ next if /^#/;
+ $data .= unpack("u", $_);
+ }
+ } else {
+ while (<DATA>) {
+ next if /^#$/; # skip comments
+ next if /^#\s+/; # skip comments
+ next if /^[^#]/; # skip uuencoding for ASCII machines
+ s/^#//; # prepare uuencoded data for EBCDIC machines
+ $data .= unpack("u", $_);
+ }
+ }
+
+ my $expected_length = $is_EBCDIC ? 217 : 278;
+ ok 1, length $data == $expected_length;
+
+ my $y = thaw($data);
+ ok 2, 1;
+ ok 3, ref $y eq 'ROOT';
+
+ $Storable::canonical = 1; # Prevent "used once" warning
+ $Storable::canonical = 1;
+ # Allow for long double string conversions.
+ $y->{num}->[3] += 0;
+ $r->{num}->[3] += 0;
+ ok 4, nfreeze($y) eq nfreeze($r);
+
+ ok 5, $y->ref->{key1} eq 'val1';
+ ok 6, $y->ref->{key2} eq 'val2';
+ ok 7, $hash_fetch == 2;
+
+ my $num = $r->num;
+ my $ok = 1;
+ for (my $i = 0; $i < @$num; $i++) {
+ do { $ok = 0; last } unless $num->[$i] == $y->num->[$i];
+ }
+ ok 8, $ok;
+
+ __END__
+ #
+ # using Storable-0.6@11, output of: print pack("u", nfreeze(ROOT->make));
+ # original size: 278 bytes
+ #
+ M`P,````%!`(````&"(%8"(!8"'U8"@@M,RXQ-#$U.5@)```!R%@*`S0N-5A8
+ M6`````-N=6T$`P````(*!'9A;#%8````!&ME>3$*!'9A;#)8````!&ME>3)B
+ M"51)141?2$%32%A8`````6@$`@````,*!G-T<FEN9U@$``````I8!```````
+ M6%A8`````6$$`@````4$`@````$(@%AB!E-)35!,15A8!`(````!"(%88@93
+ M24U03$586`0"`````0B"6&(&4TE-4$Q%6%@$`@````$(@UAB!E-)35!,15A8
+ M!`(````!"(188@9324U03$586%A8`````V]B:@0,!``````*6%A8`````W)E
+ (9F($4D]/5%@`
+ #
+ # using Storable-0.6@11, output of: print '#' . pack("u", nfreeze(ROOT->make));
+ # on OS/390 (cp 1047) original size: 217 bytes
+ #
+ #M!0,1!-G6UN,#````!00,!!$)X\G%Q&W(P>+(`P````(*!*6!D_$````$DH6H
+ #M\0H$I8&3\@````22A:CR`````YF%A@0"````!@B!"(`(?0H(8/-+\?3Q]?D)
+ #M```!R`H#]$OU`````Y6DE`0"````!001!N+)U-?3Q0(````!"(`$$@("````
+ #M`0B!!!("`@````$(@@02`@(````!"(,$$@("`````0B$`````Y:"D00`````
+ #E!`````&(!`(````#"@:BHYF)E8<$``````0$```````````!@0``
diff -c /dev/null 'perl-5.7.2/ext/Storable/t/dclone.t'
Index: ./ext/Storable/t/dclone.t
*** ./ext/Storable/t/dclone.t Thu Jan 1 02:00:00 1970
--- ./ext/Storable/t/dclone.t Mon Jul 9 17:10:13 2001
***************
*** 0 ****
--- 1,82 ----
+ #!./perl
+
+ # $Id: dclone.t,v 1.0 2000/09/01 19:40:41 ram Exp $
+ #
+ # Copyright (c) 1995-2000, Raphael Manfredi
+ #
+ # You may redistribute only under the same terms as Perl 5, as specified
+ # in the README file that comes with the distribution.
+ #
+ # $Log: dclone.t,v $
+ # Revision 1.0 2000/09/01 19:40:41 ram
+ # Baseline for first official release.
+ #
+
+ sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+ }
+
+
+ use Storable qw(dclone);
+
+ print "1..9\n";
+
+ $a = 'toto';
+ $b = \$a;
+ $c = bless {}, CLASS;
+ $c->{attribute} = 'attrval';
+ %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c);
+ @a = ('first', undef, 3, -4, -3.14159, 456, 4.5,
+ $b, \$a, $a, $c, \$c, \%a);
+
+ print "not " unless defined ($aref = dclone(\@a));
+ print "ok 1\n";
+
+ $dumped = &dump(\@a);
+ print "ok 2\n";
+
+ $got = &dump($aref);
+ print "ok 3\n";
+
+ print "not " unless $got eq $dumped;
+ print "ok 4\n";
+
+ package FOO; @ISA = qw(Storable);
+
+ sub make {
+ my $self = bless {};
+ $self->{key} = \%main::a;
+ return $self;
+ };
+
+ package main;
+
+ $foo = FOO->make;
+ print "not " unless defined($r = $foo->dclone);
+ print "ok 5\n";
+
+ print "not " unless &dump($foo) eq &dump($r);
+ print "ok 6\n";
+
+ # Ensure refs to "undef" values are properly shared during cloning
+ my $hash;
+ push @{$$hash{''}}, \$$hash{a};
+ print "not " unless $$hash{''}[0] == \$$hash{a};
+ print "ok 7\n";
+
+ my $cloned = dclone(dclone($hash));
+ print "not " unless $$cloned{''}[0] == \$$cloned{a};
+ print "ok 8\n";
+
+ $$cloned{a} = "blah";
+ print "not " unless $$cloned{''}[0] == \$$cloned{a};
+ print "ok 9\n";
+
diff -c /dev/null 'perl-5.7.2/ext/Storable/t/forgive.t'
Index: ./ext/Storable/t/forgive.t
*** ./ext/Storable/t/forgive.t Thu Jan 1 02:00:00 1970
--- ./ext/Storable/t/forgive.t Mon Jul 9 17:10:13 2001
***************
*** 0 ****
--- 1,67 ----
+ #!./perl
+
+ # $Id: forgive.t,v 1.0.1.1 2000/09/01 19:40:42 ram Exp $
+ #
+ # Copyright (c) 1995-2000, Raphael Manfredi
+ #
+ # You may redistribute only under the same terms as Perl 5, as specified
+ # in the README file that comes with the distribution.
+ #
+ # Original Author: Ulrich Pfeifer
+ # (C) Copyright 1997, Universitat Dortmund, all rights reserved.
+ #
+ # $Log: forgive.t,v $
+ # Revision 1.0.1.1 2000/09/01 19:40:42 ram
+ # Baseline for first official release.
+ #
+ # Revision 1.0 2000/09/01 19:40:41 ram
+ # Baseline for first official release.
+ #
+
+ sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ }
+
+ use Storable qw(store retrieve);
+ use File::Spec;
+
+ print "1..8\n";
+
+ my $test = 1;
+ my $bad = ['foo', sub { 1 }, 'bar'];
+ my $result;
+
+ eval {$result = store ($bad , 'store')};
+ print ((!defined $result)?"ok $test\n":"not ok $test\n"); $test++;
+ print (($@ ne '')?"ok $test\n":"not ok $test\n"); $test++;
+
+ $Storable::forgive_me=1;
+
+ my $devnull = File::Spec->devnull;
+
+ open(SAVEERR, ">&STDERR");
+ open(STDERR, ">$devnull") or
+ ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
+
+ eval {$result = store ($bad , 'store')};
+
+ open(STDERR, ">&SAVEERR");
+
+ print ((defined $result)?"ok $test\n":"not ok $test\n"); $test++;
+ print (($@ eq '')?"ok $test\n":"not ok $test\n"); $test++;
+
+ my $ret = retrieve('store');
+ print ((defined $ret)?"ok $test\n":"not ok $test\n"); $test++;
+ print (($ret->[0] eq 'foo')?"ok $test\n":"not ok $test\n"); $test++;
+ print (($ret->[2] eq 'bar')?"ok $test\n":"not ok $test\n"); $test++;
+ print ((ref $ret->[1] eq 'SCALAR')?"ok $test\n":"not ok $test\n"); $test++;
+
+
+ END { 1 while unlink 'store' }
diff -c /dev/null 'perl-5.7.2/ext/Storable/t/freeze.t'
Index: ./ext/Storable/t/freeze.t
*** ./ext/Storable/t/freeze.t Thu Jan 1 02:00:00 1970
--- ./ext/Storable/t/freeze.t Mon Jul 9 17:10:13 2001
***************
*** 0 ****
--- 1,145 ----
+ #!./perl
+
+ # $Id: freeze.t,v 1.0.1.1 2001/07/01 11:25:16 ram Exp $
+ #
+ # Copyright (c) 1995-2000, Raphael Manfredi
+ #
+ # You may redistribute only under the same terms as Perl 5, as specified
+ # in the README file that comes with the distribution.
+ #
+ # $Log: freeze.t,v $
+ # Revision 1.0.1.1 2001/07/01 11:25:16 ram
+ # patch12: added test cases for mem corruption during thaw()
+ #
+ # Revision 1.0 2000/09/01 19:40:41 ram
+ # Baseline for first official release.
+ #
+
+ sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+ sub ok;
+ }
+
+ use Storable qw(freeze nfreeze thaw);
+
+ print "1..19\n";
+
+ $a = 'toto';
+ $b = \$a;
+ $c = bless {}, CLASS;
+ $c->{attribute} = $b;
+ $d = {};
+ $e = [];
+ $d->{'a'} = $e;
+ $e->[0] = $d;
+ %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c);
+ @a = ('first', undef, 3, -4, -3.14159, 456, 4.5, $d, \$d, \$e, $e,
+ $b, \$a, $a, $c, \$c, \%a);
+
+ print "not " unless defined ($f1 = freeze(\@a));
+ print "ok 1\n";
+
+ $dumped = &dump(\@a);
+ print "ok 2\n";
+
+ $root = thaw($f1);
+ print "not " unless defined $root;
+ print "ok 3\n";
+
+ $got = &dump($root);
+ print "ok 4\n";
+
+ print "not " unless $got eq $dumped;
+ print "ok 5\n";
+
+ package FOO; @ISA = qw(Storable);
+
+ sub make {
+ my $self = bless {};
+ $self->{key} = \%main::a;
+ return $self;
+ };
+
+ package main;
+
+ $foo = FOO->make;
+ print "not " unless $f2 = $foo->freeze;
+ print "ok 6\n";
+
+ print "not " unless $f3 = $foo->nfreeze;
+ print "ok 7\n";
+
+ $root3 = thaw($f3);
+ print "not " unless defined $root3;
+ print "ok 8\n";
+
+ print "not " unless &dump($foo) eq &dump($root3);
+ print "ok 9\n";
+
+ $root = thaw($f2);
+ print "not " unless &dump($foo) eq &dump($root);
+ print "ok 10\n";
+
+ print "not " unless &dump($root3) eq &dump($root);
+ print "ok 11\n";
+
+ $other = freeze($root);
+ print "not " unless length($other) == length($f2);
+ print "ok 12\n";
+
+ $root2 = thaw($other);
+ print "not " unless &dump($root2) eq &dump($root);
+ print "ok 13\n";
+
+ $VAR1 = [
+ 'method',
+ 1,
+ 'prepare',
+ 'SELECT table_name, table_owner, num_rows FROM iitables
+ where table_owner != \'$ingres\' and table_owner != \'DBA\''
+ ];
+
+ $x = nfreeze($VAR1);
+ $VAR2 = thaw($x);
+ print "not " unless $VAR2->[3] eq $VAR1->[3];
+ print "ok 14\n";
+
+ # Test the workaround for LVALUE bug in perl 5.004_04 -- from Gisle Aas
+ sub foo { $_[0] = 1 }
+ $foo = [];
+ foo($foo->[1]);
+ eval { freeze($foo) };
+ print "not " if $@;
+ print "ok 15\n";
+
+ # Test cleanup bug found by Claudio Garcia -- RAM, 08/06/2001
+ my $thaw_me = 'asdasdasdasd';
+
+ eval {
+ my $thawed = thaw $thaw_me;
+ };
+ ok 16, $@;
+
+ my %to_be_frozen = (foo => 'bar');
+ my $frozen;
+ eval {
+ $frozen = freeze \%to_be_frozen;
+ };
+ ok 17, !$@;
+
+ freeze {};
+ eval { thaw $thaw_me };
+ eval { $frozen = freeze { foo => {} } };
+ ok 18, !$@;
+
+ thaw $frozen; # used to segfault here
+ ok 19, 1;
+
diff -c /dev/null 'perl-5.7.2/ext/Storable/t/lock.t'
Index: ./ext/Storable/t/lock.t
*** ./ext/Storable/t/lock.t Thu Jan 1 02:00:00 1970
--- ./ext/Storable/t/lock.t Mon Jul 9 17:10:13 2001
***************
*** 0 ****
--- 1,65 ----
+ #!./perl
+
+ # $Id: lock.t,v 1.0.1.4 2001/01/03 09:41:00 ram Exp $
+ #
+ # @COPYRIGHT@
+ #
+ # $Log: lock.t,v $
+ # Revision 1.0.1.4 2001/01/03 09:41:00 ram
+ # patch7: use new CAN_FLOCK routine to determine whether to run tests
+ #
+ # Revision 1.0.1.3 2000/10/26 17:11:27 ram
+ # patch5: just check $^O, there's no need for the whole Config
+ #
+ # Revision 1.0.1.2 2000/10/23 18:03:07 ram
+ # patch4: protected calls to flock() for dos platform
+ #
+ # Revision 1.0.1.1 2000/09/28 21:44:06 ram
+ # patch2: created.
+ #
+ #
+
+ sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ if ($^O eq 'mpeix') {
+ print "1..0 # Skip: truncate missing on MPE\n";
+ exit 0;
+ }
+
+ require 'lib/st-dump.pl';
+ }
+
+ sub ok;
+
+ use Storable qw(lock_store lock_retrieve);
+
+ unless (&Storable::CAN_FLOCK) {
+ print "1..0 # Skip: fcntl/flock emulation broken on this platform\n";
+ exit 0;
+ }
+
+ print "1..5\n";
+
+ @a = ('first', undef, 3, -4, -3.14159, 456, 4.5);
+
+ #
+ # We're just ensuring things work, we're not validating locking.
+ #
+
+ ok 1, defined lock_store(\@a, 'store');
+ ok 2, $dumped = &dump(\@a);
+
+ $root = lock_retrieve('store');
+ ok 3, ref $root eq 'ARRAY';
+ ok 4, @a == @$root;
+ ok 5, &dump($root) eq $dumped;
+
+ unlink 't/store';
+
diff -c /dev/null 'perl-5.7.2/ext/Storable/t/overload.t'
Index: ./ext/Storable/t/overload.t
*** ./ext/Storable/t/overload.t Thu Jan 1 02:00:00 1970
--- ./ext/Storable/t/overload.t Mon Jul 9 17:10:13 2001
***************
*** 0 ****
--- 1,97 ----
+ #!./perl
+
+ # $Id: overload.t,v 1.0.1.1 2001/02/17 12:27:22 ram Exp $
+ #
+ # Copyright (c) 1995-2000, Raphael Manfredi
+ #
+ # You may redistribute only under the same terms as Perl 5, as specified
+ # in the README file that comes with the distribution.
+ #
+ # $Log: overload.t,v $
+ # Revision 1.0.1.1 2001/02/17 12:27:22 ram
+ # patch8: added test for structures with indirect ref to overloaded
+ #
+ # Revision 1.0 2000/09/01 19:40:42 ram
+ # Baseline for first official release.
+ #
+
+ sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+ }
+
+ sub ok;
+
+ use Storable qw(freeze thaw);
+
+ print "1..12\n";
+
+ package OVERLOADED;
+
+ use overload
+ '""' => sub { $_[0][0] };
+
+ package main;
+
+ $a = bless [77], OVERLOADED;
+
+ $b = thaw freeze $a;
+ ok 1, ref $b eq 'OVERLOADED';
+ ok 2, "$b" eq "77";
+
+ $c = thaw freeze \$a;
+ ok 3, ref $c eq 'REF';
+ ok 4, ref $$c eq 'OVERLOADED';
+ ok 5, "$$c" eq "77";
+
+ $d = thaw freeze [$a, $a];
+ ok 6, "$d->[0]" eq "77";
+ $d->[0][0]++;
+ ok 7, "$d->[1]" eq "78";
+
+ package REF_TO_OVER;
+
+ sub make {
+ my $self = bless {}, shift;
+ my ($over) = @_;
+ $self->{over} = $over;
+ return $self;
+ }
+
+ package OVER;
+
+ use overload
+ '+' => \&plus,
+ '""' => sub { ref $_[0] };
+
+ sub plus {
+ return 314;
+ }
+
+ sub make {
+ my $self = bless {}, shift;
+ my $ref = REF_TO_OVER->make($self);
+ $self->{ref} = $ref;
+ return $self;
+ }
+
+ package main;
+
+ $a = OVER->make();
+ $b = thaw freeze $a;
+
+ ok 8, ref $b eq 'OVER';
+ ok 9, $a + $a == 314;
+ ok 10, ref $b->{ref} eq 'REF_TO_OVER';
+ ok 11, "$b->{ref}->{over}" eq "$b";
+ ok 12, $b + $b == 314;
+
+ 1;
+
diff -c /dev/null 'perl-5.7.2/ext/Storable/t/recurse.t'
Index: ./ext/Storable/t/recurse.t
*** ./ext/Storable/t/recurse.t Thu Jan 1 02:00:00 1970
--- ./ext/Storable/t/recurse.t Mon Jul 9 17:10:13 2001
***************
*** 0 ****
--- 1,300 ----
+ #!./perl
+
+ # $Id: recurse.t,v 1.0.1.3 2001/02/17 12:28:33 ram Exp $
+ #
+ # Copyright (c) 1995-2000, Raphael Manfredi
+ #
+ # You may redistribute only under the same terms as Perl 5, as specified
+ # in the README file that comes with the distribution.
+ #
+ # $Log: recurse.t,v $
+ # Revision 1.0.1.3 2001/02/17 12:28:33 ram
+ # patch8: ensure blessing occurs ASAP, specially designed for hooks
+ #
+ # Revision 1.0.1.2 2000/11/05 17:22:05 ram
+ # patch6: stress hook a little more with refs to lexicals
+ #
+ # $Log: recurse.t,v $
+ # Revision 1.0.1.1 2000/09/17 16:48:05 ram
+ # patch1: added test case for store hook bug
+ #
+ # $Log: recurse.t,v $
+ # Revision 1.0 2000/09/01 19:40:42 ram
+ # Baseline for first official release.
+ #
+
+ sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+ }
+
+ sub ok;
+
+ use Storable qw(freeze thaw dclone);
+
+ print "1..32\n";
+
+ package OBJ_REAL;
+
+ use Storable qw(freeze thaw);
+
+ @x = ('a', 1);
+
+ sub make { bless [], shift }
+
+ sub STORABLE_freeze {
+ my $self = shift;
+ my $cloning = shift;
+ die "STORABLE_freeze" unless Storable::is_storing;
+ return (freeze(\@x), $self);
+ }
+
+ sub STORABLE_thaw {
+ my $self = shift;
+ my $cloning = shift;
+ my ($x, $obj) = @_;
+ die "STORABLE_thaw #1" unless $obj eq $self;
+ my $len = length $x;
+ my $a = thaw $x;
+ die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
+ die "STORABLE_thaw #3" unless @$a == 2 && $a->[0] eq 'a' && $a->[1] == 1;
+ @$self = @$a;
+ die "STORABLE_thaw #4" unless Storable::is_retrieving;
+ }
+
+ package OBJ_SYNC;
+
+ @x = ('a', 1);
+
+ sub make { bless {}, shift }
+
+ sub STORABLE_freeze {
+ my $self = shift;
+ my ($cloning) = @_;
+ return if $cloning;
+ return ("", \@x, $self);
+ }
+
+ sub STORABLE_thaw {
+ my $self = shift;
+ my ($cloning, $undef, $a, $obj) = @_;
+ die "STORABLE_thaw #1" unless $obj eq $self;
+ die "STORABLE_thaw #2" unless ref $a eq 'ARRAY' || @$a != 2;
+ $self->{ok} = $self;
+ }
+
+ package OBJ_SYNC2;
+
+ use Storable qw(dclone);
+
+ sub make {
+ my $self = bless {}, shift;
+ my ($ext) = @_;
+ $self->{sync} = OBJ_SYNC->make;
+ $self->{ext} = $ext;
+ return $self;
+ }
+
+ sub STORABLE_freeze {
+ my $self = shift;
+ my %copy = %$self;
+ my $r = \%copy;
+ my $t = dclone($r->{sync});
+ return ("", [$t, $self->{ext}], $r, $self, $r->{ext});
+ }
+
+ sub STORABLE_thaw {
+ my $self = shift;
+ my ($cloning, $undef, $a, $r, $obj, $ext) = @_;
+ die "STORABLE_thaw #1" unless $obj eq $self;
+ die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
+ die "STORABLE_thaw #3" unless ref $r eq 'HASH';
+ die "STORABLE_thaw #4" unless $a->[1] == $r->{ext};
+ $self->{ok} = $self;
+ ($self->{sync}, $self->{ext}) = @$a;
+ }
+
+ package OBJ_REAL2;
+
+ use Storable qw(freeze thaw);
+
+ $MAX = 20;
+ $recursed = 0;
+ $hook_called = 0;
+
+ sub make { bless [], shift }
+
+ sub STORABLE_freeze {
+ my $self = shift;
+ $hook_called++;
+ return (freeze($self), $self) if ++$recursed < $MAX;
+ return ("no", $self);
+ }
+
+ sub STORABLE_thaw {
+ my $self = shift;
+ my $cloning = shift;
+ my ($x, $obj) = @_;
+ die "STORABLE_thaw #1" unless $obj eq $self;
+ $self->[0] = thaw($x) if $x ne "no";
+ $recursed--;
+ }
+
+ package main;
+
+ my $real = OBJ_REAL->make;
+ my $x = freeze $real;
+ ok 1, 1;
+
+ my $y = thaw $x;
+ ok 2, 1;
+ ok 3, $y->[0] eq 'a';
+ ok 4, $y->[1] == 1;
+
+ my $sync = OBJ_SYNC->make;
+ $x = freeze $sync;
+ ok 5, 1;
+
+ $y = thaw $x;
+ ok 6, 1;
+ ok 7, $y->{ok} == $y;
+
+ my $ext = [1, 2];
+ $sync = OBJ_SYNC2->make($ext);
+ $x = freeze [$sync, $ext];
+ ok 8, 1;
+
+ my $z = thaw $x;
+ $y = $z->[0];
+ ok 9, 1;
+ ok 10, $y->{ok} == $y;
+ ok 11, ref $y->{sync} eq 'OBJ_SYNC';
+ ok 12, $y->{ext} == $z->[1];
+
+ $real = OBJ_REAL2->make;
+ $x = freeze $real;
+ ok 13, 1;
+ ok 14, $OBJ_REAL2::recursed == $OBJ_REAL2::MAX;
+ ok 15, $OBJ_REAL2::hook_called == $OBJ_REAL2::MAX;
+
+ $y = thaw $x;
+ ok 16, 1;
+ ok 17, $OBJ_REAL2::recursed == 0;
+
+ $x = dclone $real;
+ ok 18, 1;
+ ok 19, ref $x eq 'OBJ_REAL2';
+ ok 20, $OBJ_REAL2::recursed == 0;
+ ok 21, $OBJ_REAL2::hook_called == 2 * $OBJ_REAL2::MAX;
+
+ ok 22, !Storable::is_storing;
+ ok 23, !Storable::is_retrieving;
+
+ #
+ # The following was a test-case that Salvador Ortiz Garcia <sog@msg.com.mx>
+ # sent me, along with a proposed fix.
+ #
+
+ package Foo;
+
+ sub new {
+ my $class = shift;
+ my $dat = shift;
+ return bless {dat => $dat}, $class;
+ }
+
+ package Bar;
+ sub new {
+ my $class = shift;
+ return bless {
+ a => 'dummy',
+ b => [
+ Foo->new(1),
+ Foo->new(2), # Second instance of a Foo
+ ]
+ }, $class;
+ }
+
+ sub STORABLE_freeze {
+ my($self,$clonning) = @_;
+ return "$self->{a}", $self->{b};
+ }
+
+ sub STORABLE_thaw {
+ my($self,$clonning,$dummy,$o) = @_;
+ $self->{a} = $dummy;
+ $self->{b} = $o;
+ }
+
+ package main;
+
+ my $bar = new Bar;
+ my $bar2 = thaw freeze $bar;
+
+ ok 24, ref($bar2) eq 'Bar';
+ ok 25, ref($bar->{b}[0]) eq 'Foo';
+ ok 26, ref($bar->{b}[1]) eq 'Foo';
+ ok 27, ref($bar2->{b}[0]) eq 'Foo';
+ ok 28, ref($bar2->{b}[1]) eq 'Foo';
+
+ #
+ # The following attempts to make sure blessed objects are blessed ASAP
+ # at retrieve time.
+ #
+
+ package CLASS_1;
+
+ sub make {
+ my $self = bless {}, shift;
+ return $self;
+ }
+
+ package CLASS_2;
+
+ sub make {
+ my $self = bless {}, shift;
+ my ($o) = @_;
+ $self->{c1} = CLASS_1->make();
+ $self->{o} = $o;
+ $self->{c3} = bless CLASS_1->make(), "CLASS_3";
+ $o->set_c2($self);
+ return $self;
+ }
+
+ sub STORABLE_freeze {
+ my($self, $clonning) = @_;
+ return "", $self->{c1}, $self->{c3}, $self->{o};
+ }
+
+ sub STORABLE_thaw {
+ my($self, $clonning, $frozen, $c1, $c3, $o) = @_;
+ main::ok 29, ref $self eq "CLASS_2";
+ main::ok 30, ref $c1 eq "CLASS_1";
+ main::ok 31, ref $c3 eq "CLASS_3";
+ main::ok 32, ref $o eq "CLASS_OTHER";
+ $self->{c1} = $c1;
+ $self->{c3} = $c3;
+ }
+
+ package CLASS_OTHER;
+
+ sub make {
+ my $self = bless {}, shift;
+ return $self;
+ }
+
+ sub set_c2 { $_[0]->{c2} = $_[1] }
+
+ package main;
+
+ my $o = CLASS_OTHER->make();
+ my $c2 = CLASS_2->make($o);
+ my $so = thaw freeze $o;
+
diff -c /dev/null 'perl-5.7.2/ext/Storable/t/retrieve.t'
Index: ./ext/Storable/t/retrieve.t
*** ./ext/Storable/t/retrieve.t Thu Jan 1 02:00:00 1970
--- ./ext/Storable/t/retrieve.t Mon Jul 9 17:10:13 2001
***************
*** 0 ****
--- 1,78 ----
+ #!./perl
+
+ # $Id: retrieve.t,v 1.0 2000/09/01 19:40:42 ram Exp $
+ #
+ # Copyright (c) 1995-2000, Raphael Manfredi
+ #
+ # You may redistribute only under the same terms as Perl 5, as specified
+ # in the README file that comes with the distribution.
+ #
+ # $Log: retrieve.t,v $
+ # Revision 1.0 2000/09/01 19:40:42 ram
+ # Baseline for first official release.
+ #
+
+ sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+ }
+
+
+ use Storable qw(store retrieve nstore);
+
+ print "1..14\n";
+
+ $a = 'toto';
+ $b = \$a;
+ $c = bless {}, CLASS;
+ $c->{attribute} = 'attrval';
+ %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c);
+ @a = ('first', '', undef, 3, -4, -3.14159, 456, 4.5,
+ $b, \$a, $a, $c, \$c, \%a);
+
+ print "not " unless defined store(\@a, 'store');
+ print "ok 1\n";
+ print "not " if Storable::last_op_in_netorder();
+ print "ok 2\n";
+ print "not " unless defined nstore(\@a, 'nstore');
+ print "ok 3\n";
+ print "not " unless Storable::last_op_in_netorder();
+ print "ok 4\n";
+ print "not " unless Storable::last_op_in_netorder();
+ print "ok 5\n";
+
+ $root = retrieve('store');
+ print "not " unless defined $root;
+ print "ok 6\n";
+ print "not " if Storable::last_op_in_netorder();
+ print "ok 7\n";
+
+ $nroot = retrieve('nstore');
+ print "not " unless defined $nroot;
+ print "ok 8\n";
+ print "not " unless Storable::last_op_in_netorder();
+ print "ok 9\n";
+
+ $d1 = &dump($root);
+ print "ok 10\n";
+ $d2 = &dump($nroot);
+ print "ok 11\n";
+
+ print "not " unless $d1 eq $d2;
+ print "ok 12\n";
+
+ # Make sure empty string is defined at retrieval time
+ print "not " unless defined $root->[1];
+ print "ok 13\n";
+ print "not " if length $root->[1];
+ print "ok 14\n";
+
+ END { 1 while unlink('store', 'nstore') }
+
diff -c /dev/null 'perl-5.7.2/ext/Storable/t/store.t'
Index: ./ext/Storable/t/store.t
*** ./ext/Storable/t/store.t Thu Jan 1 02:00:00 1970
--- ./ext/Storable/t/store.t Mon Jul 9 17:10:13 2001
***************
*** 0 ****
--- 1,119 ----
+ #!./perl
+
+ # $Id: store.t,v 1.0 2000/09/01 19:40:42 ram Exp $
+ #
+ # Copyright (c) 1995-2000, Raphael Manfredi
+ #
+ # You may redistribute only under the same terms as Perl 5, as specified
+ # in the README file that comes with the distribution.
+ #
+ # $Log: store.t,v $
+ # Revision 1.0 2000/09/01 19:40:42 ram
+ # Baseline for first official release.
+ #
+
+ sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+ }
+
+ use Storable qw(store retrieve store_fd nstore_fd fd_retrieve);
+
+ print "1..20\n";
+
+ $a = 'toto';
+ $b = \$a;
+ $c = bless {}, CLASS;
+ $c->{attribute} = 'attrval';
+ %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c);
+ @a = ('first', undef, 3, -4, -3.14159, 456, 4.5,
+ $b, \$a, $a, $c, \$c, \%a);
+
+ print "not " unless defined store(\@a, 'store');
+ print "ok 1\n";
+
+ $dumped = &dump(\@a);
+ print "ok 2\n";
+
+ $root = retrieve('store');
+ print "not " unless defined $root;
+ print "ok 3\n";
+
+ $got = &dump($root);
+ print "ok 4\n";
+
+ print "not " unless $got eq $dumped;
+ print "ok 5\n";
+
+ 1 while unlink 'store';
+
+ package FOO; @ISA = qw(Storable);
+
+ sub make {
+ my $self = bless {};
+ $self->{key} = \%main::a;
+ return $self;
+ };
+
+ package main;
+
+ $foo = FOO->make;
+ print "not " unless $foo->store('store');
+ print "ok 6\n";
+
+ print "not " unless open(OUT, '>>store');
+ print "ok 7\n";
+ binmode OUT;
+
+ print "not " unless defined store_fd(\@a, ::OUT);
+ print "ok 8\n";
+ print "not " unless defined nstore_fd($foo, ::OUT);
+ print "ok 9\n";
+ print "not " unless defined nstore_fd(\%a, ::OUT);
+ print "ok 10\n";
+
+ print "not " unless close(OUT);
+ print "ok 11\n";
+
+ print "not " unless open(OUT, 'store');
+ binmode OUT;
+
+ $r = fd_retrieve(::OUT);
+ print "not " unless defined $r;
+ print "ok 12\n";
+ print "not " unless &dump($foo) eq &dump($r);
+ print "ok 13\n";
+
+ $r = fd_retrieve(::OUT);
+ print "not " unless defined $r;
+ print "ok 14\n";
+ print "not " unless &dump(\@a) eq &dump($r);
+ print "ok 15\n";
+
+ $r = fd_retrieve(main::OUT);
+ print "not " unless defined $r;
+ print "ok 16\n";
+ print "not " unless &dump($foo) eq &dump($r);
+ print "ok 17\n";
+
+ $r = fd_retrieve(::OUT);
+ print "not " unless defined $r;
+ print "ok 18\n";
+ print "not " unless &dump(\%a) eq &dump($r);
+ print "ok 19\n";
+
+ eval { $r = fd_retrieve(::OUT); };
+ print "not " unless $@;
+ print "ok 20\n";
+
+ close OUT;
+ END { 1 while unlink 'store' }
+
+
diff -c /dev/null 'perl-5.7.2/ext/Storable/t/tied.t'
Index: ./ext/Storable/t/tied.t
*** ./ext/Storable/t/tied.t Thu Jan 1 02:00:00 1970
--- ./ext/Storable/t/tied.t Mon Jul 9 17:10:13 2001
***************
*** 0 ****
--- 1,213 ----
+ #!./perl
+
+ # $Id: tied.t,v 1.0 2000/09/01 19:40:42 ram Exp $
+ #
+ # Copyright (c) 1995-2000, Raphael Manfredi
+ #
+ # You may redistribute only under the same terms as Perl 5, as specified
+ # in the README file that comes with the distribution.
+ #
+ # $Log: tied.t,v $
+ # Revision 1.0 2000/09/01 19:40:42 ram
+ # Baseline for first official release.
+ #
+
+ sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+ }
+
+ sub ok;
+
+ use Storable qw(freeze thaw);
+
+ print "1..22\n";
+
+ ($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0);
+
+ package TIED_HASH;
+
+ sub TIEHASH {
+ my $self = bless {}, shift;
+ return $self;
+ }
+
+ sub FETCH {
+ my $self = shift;
+ my ($key) = @_;
+ $main::hash_fetch++;
+ return $self->{$key};
+ }
+
+ sub STORE {
+ my $self = shift;
+ my ($key, $value) = @_;
+ $self->{$key} = $value;
+ }
+
+ sub FIRSTKEY {
+ my $self = shift;
+ scalar keys %{$self};
+ return each %{$self};
+ }
+
+ sub NEXTKEY {
+ my $self = shift;
+ return each %{$self};
+ }
+
+ package TIED_ARRAY;
+
+ sub TIEARRAY {
+ my $self = bless [], shift;
+ return $self;
+ }
+
+ sub FETCH {
+ my $self = shift;
+ my ($idx) = @_;
+ $main::array_fetch++;
+ return $self->[$idx];
+ }
+
+ sub STORE {
+ my $self = shift;
+ my ($idx, $value) = @_;
+ $self->[$idx] = $value;
+ }
+
+ sub FETCHSIZE {
+ my $self = shift;
+ return @{$self};
+ }
+
+ package TIED_SCALAR;
+
+ sub TIESCALAR {
+ my $scalar;
+ my $self = bless \$scalar, shift;
+ return $self;
+ }
+
+ sub FETCH {
+ my $self = shift;
+ $main::scalar_fetch++;
+ return $$self;
+ }
+
+ sub STORE {
+ my $self = shift;
+ my ($value) = @_;
+ $$self = $value;
+ }
+
+ package FAULT;
+
+ $fault = 0;
+
+ sub TIESCALAR {
+ my $pkg = shift;
+ return bless [@_], $pkg;
+ }
+
+ sub FETCH {
+ my $self = shift;
+ my ($href, $key) = @$self;
+ $fault++;
+ untie $href->{$key};
+ return $href->{$key} = 1;
+ }
+
+ package main;
+
+ $a = 'toto';
+ $b = \$a;
+
+ $c = tie %hash, TIED_HASH;
+ $d = tie @array, TIED_ARRAY;
+ tie $scalar, TIED_SCALAR;
+
+ #$scalar = 'foo';
+ #$hash{'attribute'} = \$d;
+ #$array[0] = $c;
+ #$array[1] = \$scalar;
+
+ ### If I say
+ ### $hash{'attribute'} = $d;
+ ### below, then dump() incorectly dumps the hash value as a string the second
+ ### time it is reached. I have not investigated enough to tell whether it's
+ ### a bug in my dump() routine or in the Perl tieing mechanism.
+ $scalar = 'foo';
+ $hash{'attribute'} = 'plain value';
+ $array[0] = \$scalar;
+ $array[1] = $c;
+ $array[2] = \@array;
+
+ @tied = (\$scalar, \@array, \%hash);
+ %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$a, 'scalarref', \$scalar);
+ @a = ('first', 3, -4, -3.14159, 456, 4.5, $d, \$d,
+ $b, \$a, $a, $c, \$c, \%a, \@array, \%hash, \@tied);
+
+ ok 1, defined($f = freeze(\@a));
+
+ $dumped = &dump(\@a);
+ ok 2, 1;
+
+ $root = thaw($f);
+ ok 3, defined $root;
+
+ $got = &dump($root);
+ ok 4, 1;
+
+ ### Used to see the manifestation of the bug documented above.
+ ### print "original: $dumped";
+ ### print "--------\n";
+ ### print "got: $got";
+ ### print "--------\n";
+
+ ok 5, $got eq $dumped;
+
+ $g = freeze($root);
+ ok 6, length($f) == length($g);
+
+ # Ensure the tied items in the retrieved image work
+ @old = ($scalar_fetch, $array_fetch, $hash_fetch);
+ @tied = ($tscalar, $tarray, $thash) = @{$root->[$#{$root}]};
+ @type = qw(SCALAR ARRAY HASH);
+
+ ok 7, tied $$tscalar;
+ ok 8, tied @{$tarray};
+ ok 9, tied %{$thash};
+
+ @new = ($$tscalar, $tarray->[0], $thash->{'attribute'});
+ @new = ($scalar_fetch, $array_fetch, $hash_fetch);
+
+ # Tests 10..15
+ for ($i = 0; $i < @new; $i++) {
+ print "not " unless $new[$i] == $old[$i] + 1;
+ printf "ok %d\n", 10 + 2*$i; # Tests 10,12,14
+ print "not " unless ref $tied[$i] eq $type[$i];
+ printf "ok %d\n", 11 + 2*$i; # Tests 11,13,15
+ }
+
+ # Check undef ties
+ my $h = {};
+ tie $h->{'x'}, 'FAULT', $h, 'x';
+ my $hf = freeze($h);
+ ok 16, defined $hf;
+ ok 17, $FAULT::fault == 0;
+ ok 18, $h->{'x'} == 1;
+ ok 19, $FAULT::fault == 1;
+
+ my $ht = thaw($hf);
+ ok 20, defined $ht;
+ ok 21, $ht->{'x'} == 1;
+ ok 22, $FAULT::fault == 2;
+
diff -c /dev/null 'perl-5.7.2/ext/Storable/t/tied_hook.t'
Index: ./ext/Storable/t/tied_hook.t
*** ./ext/Storable/t/tied_hook.t Thu Jan 1 02:00:00 1970
--- ./ext/Storable/t/tied_hook.t Mon Jul 9 17:10:13 2001
***************
*** 0 ****
--- 1,254 ----
+ #!./perl
+
+ # $Id: tied_hook.t,v 1.0.1.1 2001/02/17 12:29:01 ram Exp $
+ #
+ # Copyright (c) 1995-2000, Raphael Manfredi
+ #
+ # You may redistribute only under the same terms as Perl 5, as specified
+ # in the README file that comes with the distribution.
+ #
+ # $Log: tied_hook.t,v $
+ # Revision 1.0.1.1 2001/02/17 12:29:01 ram
+ # patch8: added test for blessed ref to tied hash
+ #
+ # Revision 1.0 2000/09/01 19:40:42 ram
+ # Baseline for first official release.
+ #
+
+ sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+ }
+
+ sub ok;
+
+ use Storable qw(freeze thaw);
+
+ print "1..25\n";
+
+ ($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0);
+
+ package TIED_HASH;
+
+ sub TIEHASH {
+ my $self = bless {}, shift;
+ return $self;
+ }
+
+ sub FETCH {
+ my $self = shift;
+ my ($key) = @_;
+ $main::hash_fetch++;
+ return $self->{$key};
+ }
+
+ sub STORE {
+ my $self = shift;
+ my ($key, $value) = @_;
+ $self->{$key} = $value;
+ }
+
+ sub FIRSTKEY {
+ my $self = shift;
+ scalar keys %{$self};
+ return each %{$self};
+ }
+
+ sub NEXTKEY {
+ my $self = shift;
+ return each %{$self};
+ }
+
+ sub STORABLE_freeze {
+ my $self = shift;
+ $main::hash_hook1++;
+ return join(":", keys %$self) . ";" . join(":", values %$self);
+ }
+
+ sub STORABLE_thaw {
+ my ($self, $cloning, $frozen) = @_;
+ my ($keys, $values) = split(/;/, $frozen);
+ my @keys = split(/:/, $keys);
+ my @values = split(/:/, $values);
+ for (my $i = 0; $i < @keys; $i++) {
+ $self->{$keys[$i]} = $values[$i];
+ }
+ $main::hash_hook2++;
+ }
+
+ package TIED_ARRAY;
+
+ sub TIEARRAY {
+ my $self = bless [], shift;
+ return $self;
+ }
+
+ sub FETCH {
+ my $self = shift;
+ my ($idx) = @_;
+ $main::array_fetch++;
+ return $self->[$idx];
+ }
+
+ sub STORE {
+ my $self = shift;
+ my ($idx, $value) = @_;
+ $self->[$idx] = $value;
+ }
+
+ sub FETCHSIZE {
+ my $self = shift;
+ return @{$self};
+ }
+
+ sub STORABLE_freeze {
+ my $self = shift;
+ $main::array_hook1++;
+ return join(":", @$self);
+ }
+
+ sub STORABLE_thaw {
+ my ($self, $cloning, $frozen) = @_;
+ @$self = split(/:/, $frozen);
+ $main::array_hook2++;
+ }
+
+ package TIED_SCALAR;
+
+ sub TIESCALAR {
+ my $scalar;
+ my $self = bless \$scalar, shift;
+ return $self;
+ }
+
+ sub FETCH {
+ my $self = shift;
+ $main::scalar_fetch++;
+ return $$self;
+ }
+
+ sub STORE {
+ my $self = shift;
+ my ($value) = @_;
+ $$self = $value;
+ }
+
+ sub STORABLE_freeze {
+ my $self = shift;
+ $main::scalar_hook1++;
+ return $$self;
+ }
+
+ sub STORABLE_thaw {
+ my ($self, $cloning, $frozen) = @_;
+ $$self = $frozen;
+ $main::scalar_hook2++;
+ }
+
+ package main;
+
+ $a = 'toto';
+ $b = \$a;
+
+ $c = tie %hash, TIED_HASH;
+ $d = tie @array, TIED_ARRAY;
+ tie $scalar, TIED_SCALAR;
+
+ $scalar = 'foo';
+ $hash{'attribute'} = 'plain value';
+ $array[0] = \$scalar;
+ $array[1] = $c;
+ $array[2] = \@array;
+ $array[3] = "plaine scalaire";
+
+ @tied = (\$scalar, \@array, \%hash);
+ %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$a, 'scalarref', \$scalar);
+ @a = ('first', 3, -4, -3.14159, 456, 4.5, $d, \$d,
+ $b, \$a, $a, $c, \$c, \%a, \@array, \%hash, \@tied);
+
+ ok 1, defined($f = freeze(\@a));
+
+ $dumped = &dump(\@a);
+ ok 2, 1;
+
+ $root = thaw($f);
+ ok 3, defined $root;
+
+ $got = &dump($root);
+ ok 4, 1;
+
+ ok 5, $got ne $dumped; # our hooks did not handle refs in array
+
+ $g = freeze($root);
+ ok 6, length($f) == length($g);
+
+ # Ensure the tied items in the retrieved image work
+ @old = ($scalar_fetch, $array_fetch, $hash_fetch);
+ @tied = ($tscalar, $tarray, $thash) = @{$root->[$#{$root}]};
+ @type = qw(SCALAR ARRAY HASH);
+
+ ok 7, tied $$tscalar;
+ ok 8, tied @{$tarray};
+ ok 9, tied %{$thash};
+
+ @new = ($$tscalar, $tarray->[0], $thash->{'attribute'});
+ @new = ($scalar_fetch, $array_fetch, $hash_fetch);
+
+ # Tests 10..15
+ for ($i = 0; $i < @new; $i++) {
+ ok 10 + 2*$i, $new[$i] == $old[$i] + 1; # Tests 10,12,14
+ ok 11 + 2*$i, ref $tied[$i] eq $type[$i]; # Tests 11,13,15
+ }
+
+ ok 16, $$tscalar eq 'foo';
+ ok 17, $tarray->[3] eq 'plaine scalaire';
+ ok 18, $thash->{'attribute'} eq 'plain value';
+
+ # Ensure hooks were called
+ ok 19, ($scalar_hook1 && $scalar_hook2);
+ ok 20, ($array_hook1 && $array_hook2);
+ ok 21, ($hash_hook1 && $hash_hook2);
+
+ #
+ # And now for the "blessed ref to tied hash" with "store hook" test...
+ #
+
+ my $bc = bless \%hash, 'FOO'; # FOO does not exist -> no hook
+ my $bx = thaw freeze $bc;
+
+ ok 22, ref $bx eq 'FOO';
+ my $old_hash_fetch = $hash_fetch;
+ my $v = $bx->{attribute};
+ ok 23, $hash_fetch == $old_hash_fetch + 1; # Still tied
+
+ package TIED_HASH_REF;
+
+
+ sub STORABLE_freeze {
+ my ($self, $cloning) = @_;
+ return if $cloning;
+ return('ref lost');
+ }
+
+ sub STORABLE_thaw {
+ my ($self, $cloning, $data) = @_;
+ return if $cloning;
+ }
+
+ package main;
+
+ $bc = bless \%hash, 'TIED_HASH_REF';
+ $bx = thaw freeze $bc;
+
+ ok 24, ref $bx eq 'TIED_HASH_REF';
+ $old_hash_fetch = $hash_fetch;
+ $v = $bx->{attribute};
+ ok 25, $hash_fetch == $old_hash_fetch + 1; # Still tied
+
diff -c /dev/null 'perl-5.7.2/ext/Storable/t/tied_items.t'
Index: ./ext/Storable/t/tied_items.t
*** ./ext/Storable/t/tied_items.t Thu Jan 1 02:00:00 1970
--- ./ext/Storable/t/tied_items.t Mon Jul 9 17:10:14 2001
***************
*** 0 ****
--- 1,68 ----
+ #!./perl
+
+ # $Id: tied_items.t,v 1.0 2000/09/01 19:40:42 ram Exp $
+ #
+ # Copyright (c) 1995-2000, Raphael Manfredi
+ #
+ # You may redistribute only under the same terms as Perl 5, as specified
+ # in the README file that comes with the distribution.
+ #
+ # $Log: tied_items.t,v $
+ # Revision 1.0 2000/09/01 19:40:42 ram
+ # Baseline for first official release.
+ #
+
+ #
+ # Tests ref to items in tied hash/array structures.
+ #
+
+ sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+ }
+
+ sub ok;
+ $^W = 0;
+
+ print "1..8\n";
+
+ use Storable qw(dclone);
+
+ $h_fetches = 0;
+
+ sub H::TIEHASH { bless \(my $x), "H" }
+ sub H::FETCH { $h_fetches++; $_[1] - 70 }
+
+ tie %h, "H";
+
+ $ref = \$h{77};
+ $ref2 = dclone $ref;
+
+ ok 1, $h_fetches == 0;
+ ok 2, $$ref2 eq $$ref;
+ ok 3, $$ref2 == 7;
+ ok 4, $h_fetches == 2;
+
+ $a_fetches = 0;
+
+ sub A::TIEARRAY { bless \(my $x), "A" }
+ sub A::FETCH { $a_fetches++; $_[1] - 70 }
+
+ tie @a, "A";
+
+ $ref = \$a[78];
+ $ref2 = dclone $ref;
+
+ ok 5, $a_fetches == 0;
+ ok 6, $$ref2 eq $$ref;
+ ok 7, $$ref2 == 8;
+ # I don't understand why it's 3 and not 2
+ ok 8, $a_fetches == 3;
+
diff -c /dev/null 'perl-5.7.2/ext/Storable/t/utf8.t'
Index: ./ext/Storable/t/utf8.t
*** ./ext/Storable/t/utf8.t Thu Jan 1 02:00:00 1970
--- ./ext/Storable/t/utf8.t Mon Jul 9 17:10:14 2001
***************
*** 0 ****
--- 1,40 ----
+ #!./perl
+
+ # $Id: utf8.t,v 1.0.1.2 2000/09/28 21:44:17 ram Exp $
+ #
+ # @COPYRIGHT@
+ #
+ # $Log: utf8.t,v $
+ # Revision 1.0.1.2 2000/09/28 21:44:17 ram
+ # patch2: fixed stupid typo
+ #
+ # Revision 1.0.1.1 2000/09/17 16:48:12 ram
+ # patch1: created.
+ #
+ #
+
+ sub BEGIN {
+ if ($] < 5.006) {
+ print "1..0 # Skip: no utf8 support\n";
+ exit 0;
+ }
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+ }
+
+ sub ok;
+
+ use Storable qw(thaw freeze);
+
+ print "1..1\n";
+
+ $x = chr(1234);
+ ok 1, $x eq ${thaw freeze \$x};
+
diff -c /dev/null 'perl-5.7.2/ext/Sys/Hostname/Hostname.t'
Index: ./ext/Sys/Hostname/Hostname.t
*** ./ext/Sys/Hostname/Hostname.t Thu Jan 1 02:00:00 1970
--- ./ext/Sys/Hostname/Hostname.t Mon Jul 9 17:10:14 2001
***************
*** 0 ****
--- 1,25 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bSys\/Hostname\b/) {
+ print "1..0 # Skip: Sys::Hostname was not built\n";
+ exit 0;
+ }
+ }
+
+ use Sys::Hostname;
+
+ eval {
+ $host = hostname;
+ };
+
+ if ($@) {
+ print "1..0\n" if $@ =~ /Cannot get host name/;
+ } else {
+ print "1..1\n";
+ print "# \$host = `$host'\n";
+ print "ok 1\n";
+ }
diff -c 'perl-5.7.1/ext/Sys/Hostname/Hostname.xs' 'perl-5.7.2/ext/Sys/Hostname/Hostname.xs'
Index: ./ext/Sys/Hostname/Hostname.xs
*** ./ext/Sys/Hostname/Hostname.xs Tue Mar 6 04:04:59 2001
--- ./ext/Sys/Hostname/Hostname.xs Mon Jul 9 17:10:14 2001
***************
*** 69,75 ****
--- 69,77 ----
# endif
# endif
#endif
+ #ifndef HAS_GETHOSTNAME
check_out:
+ #endif
if (retval == -1)
XSRETURN_UNDEF;
else
diff -c 'perl-5.7.1/ext/Sys/Syslog/Makefile.PL' 'perl-5.7.2/ext/Sys/Syslog/Makefile.PL'
Index: ./ext/Sys/Syslog/Makefile.PL
*** ./ext/Sys/Syslog/Makefile.PL Tue Mar 6 04:04:59 2001
--- ./ext/Sys/Syslog/Makefile.PL Mon Jul 9 17:10:14 2001
***************
*** 1,4 ****
--- 1,5 ----
use ExtUtils::MakeMaker;
+ use ExtUtils::Constant 0.07 'WriteConstants';
WriteMakefile(
NAME => 'Sys::Syslog',
***************
*** 5,8 ****
--- 6,22 ----
VERSION_FROM => 'Syslog.pm',
MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes',
+ realclean => {FILES=> 'constants.c constants.xs'},
+ );
+ WriteConstants(
+ NAME => 'GDBM_File',
+ NAMES => [qw(LOG_ALERT LOG_AUTH LOG_AUTHPRIV LOG_CONS LOG_CRIT LOG_CRON
+ LOG_DAEMON LOG_DEBUG LOG_EMERG LOG_ERR LOG_FACMASK LOG_FTP
+ LOG_INFO LOG_KERN LOG_LFMT LOG_LOCAL0 LOG_LOCAL1 LOG_LOCAL2
+ LOG_LOCAL3 LOG_LOCAL4 LOG_LOCAL5 LOG_LOCAL6 LOG_LOCAL7 LOG_LPR
+ LOG_MAIL LOG_NDELAY LOG_NEWS LOG_NFACILITIES LOG_NOTICE
+ LOG_NOWAIT LOG_ODELAY LOG_PERROR LOG_PID LOG_PRIMASK LOG_SYSLOG
+ LOG_USER LOG_UUCP LOG_WARNING),
+ {name=>"_PATH_LOG", type=>"PV", default=>["PV", '""']},
+ ],
);
diff -c 'perl-5.7.1/ext/Sys/Syslog/Syslog.pm' 'perl-5.7.2/ext/Sys/Syslog/Syslog.pm'
Index: ./ext/Sys/Syslog/Syslog.pm
*** ./ext/Sys/Syslog/Syslog.pm Fri Mar 16 04:54:48 2001
--- ./ext/Sys/Syslog/Syslog.pm Mon Jul 9 17:10:14 2001
***************
*** 7,13 ****
@ISA = qw(Exporter DynaLoader);
@EXPORT = qw(openlog closelog setlogmask syslog);
@EXPORT_OK = qw(setlogsock);
! $VERSION = '0.01';
use Socket;
use Sys::Hostname;
--- 7,13 ----
@ISA = qw(Exporter DynaLoader);
@EXPORT = qw(openlog closelog setlogmask syslog);
@EXPORT_OK = qw(setlogsock);
! $VERSION = '0.02';
use Socket;
use Sys::Hostname;
***************
*** 119,124 ****
--- 119,126 ----
Dependency on F<syslog.ph> replaced with XS code by Tom Hughes
E<lt>F<tom@compton.nu>E<gt>.
+ Code for constant()s regenerated by Nicholas Clark E<lt>nick@ccl4.orgE<gt>.
+
=cut
sub AUTOLOAD {
***************
*** 128,137 ****
my $constname;
our $AUTOLOAD;
($constname = $AUTOLOAD) =~ s/.*:://;
! croak "& not defined" if $constname eq 'constant';
! my $val = constant($constname);
! if ($! != 0) {
! croak "Your vendor has not defined Sys::Syslog macro $constname";
}
*$AUTOLOAD = sub { $val };
goto &$AUTOLOAD;
--- 130,139 ----
my $constname;
our $AUTOLOAD;
($constname = $AUTOLOAD) =~ s/.*:://;
! croak "&Sys::Syslog::constant not defined" if $constname eq 'constant';
! my ($error, $val) = constant($constname);
! if ($error) {
! croak $error;
}
*$AUTOLOAD = sub { $val };
goto &$AUTOLOAD;
diff -c 'perl-5.7.1/ext/Sys/Syslog/Syslog.xs' 'perl-5.7.2/ext/Sys/Syslog/Syslog.xs'
Index: ./ext/Sys/Syslog/Syslog.xs
*** ./ext/Sys/Syslog/Syslog.xs Tue Mar 6 04:05:00 2001
--- ./ext/Sys/Syslog/Syslog.xs Mon Jul 9 17:10:14 2001
***************
*** 6,559 ****
#include <syslog.h>
#endif
! static double
! constant_LOG_NO(char *name, int len)
! {
! switch (name[6 + 0]) {
! case 'T':
! if (strEQ(name + 6, "TICE")) { /* LOG_NO removed */
! #ifdef LOG_NOTICE
! return LOG_NOTICE;
! #else
! goto not_there;
! #endif
! }
! case 'W':
! if (strEQ(name + 6, "WAIT")) { /* LOG_NO removed */
! #ifdef LOG_NOWAIT
! return LOG_NOWAIT;
! #else
! goto not_there;
! #endif
! }
! }
! errno = EINVAL;
! return 0;
- not_there:
- errno = ENOENT;
- return 0;
- }
-
- static double
- constant_LOG_N(char *name, int len)
- {
- switch (name[5 + 0]) {
- case 'D':
- if (strEQ(name + 5, "DELAY")) { /* LOG_N removed */
- #ifdef LOG_NDELAY
- return LOG_NDELAY;
- #else
- goto not_there;
- #endif
- }
- case 'E':
- if (strEQ(name + 5, "EWS")) { /* LOG_N removed */
- #ifdef LOG_NEWS
- return LOG_NEWS;
- #else
- goto not_there;
- #endif
- }
- case 'F':
- if (strEQ(name + 5, "FACILITIES")) { /* LOG_N removed */
- #ifdef LOG_NFACILITIES
- return LOG_NFACILITIES;
- #else
- goto not_there;
- #endif
- }
- case 'O':
- return constant_LOG_NO(name, len);
- }
- errno = EINVAL;
- return 0;
-
- not_there:
- errno = ENOENT;
- return 0;
- }
-
- static double
- constant_LOG_P(char *name, int len)
- {
- switch (name[5 + 0]) {
- case 'I':
- if (strEQ(name + 5, "ID")) { /* LOG_P removed */
- #ifdef LOG_PID
- return LOG_PID;
- #else
- goto not_there;
- #endif
- }
- case 'R':
- if (strEQ(name + 5, "RIMASK")) { /* LOG_P removed */
- #ifdef LOG_PRIMASK
- return LOG_PRIMASK;
- #else
- goto not_there;
- #endif
- }
- }
- errno = EINVAL;
- return 0;
-
- not_there:
- errno = ENOENT;
- return 0;
- }
-
- static double
- constant_LOG_AU(char *name, int len)
- {
- if (6 + 2 >= len ) {
- errno = EINVAL;
- return 0;
- }
- switch (name[6 + 2]) {
- case '\0':
- if (strEQ(name + 6, "TH")) { /* LOG_AU removed */
- #ifdef LOG_AUTH
- return LOG_AUTH;
- #else
- goto not_there;
- #endif
- }
- case 'P':
- if (strEQ(name + 6, "THPRIV")) { /* LOG_AU removed */
- #ifdef LOG_AUTHPRIV
- return LOG_AUTHPRIV;
- #else
- goto not_there;
- #endif
- }
- }
- errno = EINVAL;
- return 0;
-
- not_there:
- errno = ENOENT;
- return 0;
- }
-
- static double
- constant_LOG_A(char *name, int len)
- {
- switch (name[5 + 0]) {
- case 'L':
- if (strEQ(name + 5, "LERT")) { /* LOG_A removed */
- #ifdef LOG_ALERT
- return LOG_ALERT;
- #else
- goto not_there;
- #endif
- }
- case 'U':
- return constant_LOG_AU(name, len);
- }
- errno = EINVAL;
- return 0;
-
- not_there:
- errno = ENOENT;
- return 0;
- }
-
- static double
- constant_LOG_CR(char *name, int len)
- {
- switch (name[6 + 0]) {
- case 'I':
- if (strEQ(name + 6, "IT")) { /* LOG_CR removed */
- #ifdef LOG_CRIT
- return LOG_CRIT;
- #else
- goto not_there;
- #endif
- }
- case 'O':
- if (strEQ(name + 6, "ON")) { /* LOG_CR removed */
- #ifdef LOG_CRON
- return LOG_CRON;
- #else
- goto not_there;
- #endif
- }
- }
- errno = EINVAL;
- return 0;
-
- not_there:
- errno = ENOENT;
- return 0;
- }
-
- static double
- constant_LOG_C(char *name, int len)
- {
- switch (name[5 + 0]) {
- case 'O':
- if (strEQ(name + 5, "ONS")) { /* LOG_C removed */
- #ifdef LOG_CONS
- return LOG_CONS;
- #else
- goto not_there;
- #endif
- }
- case 'R':
- return constant_LOG_CR(name, len);
- }
- errno = EINVAL;
- return 0;
-
- not_there:
- errno = ENOENT;
- return 0;
- }
-
- static double
- constant_LOG_D(char *name, int len)
- {
- switch (name[5 + 0]) {
- case 'A':
- if (strEQ(name + 5, "AEMON")) { /* LOG_D removed */
- #ifdef LOG_DAEMON
- return LOG_DAEMON;
- #else
- goto not_there;
- #endif
- }
- case 'E':
- if (strEQ(name + 5, "EBUG")) { /* LOG_D removed */
- #ifdef LOG_DEBUG
- return LOG_DEBUG;
- #else
- goto not_there;
- #endif
- }
- }
- errno = EINVAL;
- return 0;
-
- not_there:
- errno = ENOENT;
- return 0;
- }
-
- static double
- constant_LOG_U(char *name, int len)
- {
- switch (name[5 + 0]) {
- case 'S':
- if (strEQ(name + 5, "SER")) { /* LOG_U removed */
- #ifdef LOG_USER
- return LOG_USER;
- #else
- goto not_there;
- #endif
- }
- case 'U':
- if (strEQ(name + 5, "UCP")) { /* LOG_U removed */
- #ifdef LOG_UUCP
- return LOG_UUCP;
- #else
- goto not_there;
- #endif
- }
- }
- errno = EINVAL;
- return 0;
-
- not_there:
- errno = ENOENT;
- return 0;
- }
-
- static double
- constant_LOG_E(char *name, int len)
- {
- switch (name[5 + 0]) {
- case 'M':
- if (strEQ(name + 5, "MERG")) { /* LOG_E removed */
- #ifdef LOG_EMERG
- return LOG_EMERG;
- #else
- goto not_there;
- #endif
- }
- case 'R':
- if (strEQ(name + 5, "RR")) { /* LOG_E removed */
- #ifdef LOG_ERR
- return LOG_ERR;
- #else
- goto not_there;
- #endif
- }
- }
- errno = EINVAL;
- return 0;
-
- not_there:
- errno = ENOENT;
- return 0;
- }
-
- static double
- constant_LOG_F(char *name, int len)
- {
- switch (name[5 + 0]) {
- case 'A':
- if (strEQ(name + 5, "ACMASK")) { /* LOG_F removed */
- #ifdef LOG_FACMASK
- return LOG_FACMASK;
- #else
- goto not_there;
- #endif
- }
- case 'T':
- if (strEQ(name + 5, "TP")) { /* LOG_F removed */
- #ifdef LOG_FTP
- return LOG_FTP;
- #else
- goto not_there;
- #endif
- }
- }
- errno = EINVAL;
- return 0;
-
- not_there:
- errno = ENOENT;
- return 0;
- }
-
- static double
- constant_LOG_LO(char *name, int len)
- {
- if (6 + 3 >= len ) {
- errno = EINVAL;
- return 0;
- }
- switch (name[6 + 3]) {
- case '0':
- if (strEQ(name + 6, "CAL0")) { /* LOG_LO removed */
- #ifdef LOG_LOCAL0
- return LOG_LOCAL0;
- #else
- goto not_there;
- #endif
- }
- case '1':
- if (strEQ(name + 6, "CAL1")) { /* LOG_LO removed */
- #ifdef LOG_LOCAL1
- return LOG_LOCAL1;
- #else
- goto not_there;
- #endif
- }
- case '2':
- if (strEQ(name + 6, "CAL2")) { /* LOG_LO removed */
- #ifdef LOG_LOCAL2
- return LOG_LOCAL2;
- #else
- goto not_there;
- #endif
- }
- case '3':
- if (strEQ(name + 6, "CAL3")) { /* LOG_LO removed */
- #ifdef LOG_LOCAL3
- return LOG_LOCAL3;
- #else
- goto not_there;
- #endif
- }
- case '4':
- if (strEQ(name + 6, "CAL4")) { /* LOG_LO removed */
- #ifdef LOG_LOCAL4
- return LOG_LOCAL4;
- #else
- goto not_there;
- #endif
- }
- case '5':
- if (strEQ(name + 6, "CAL5")) { /* LOG_LO removed */
- #ifdef LOG_LOCAL5
- return LOG_LOCAL5;
- #else
- goto not_there;
- #endif
- }
- case '6':
- if (strEQ(name + 6, "CAL6")) { /* LOG_LO removed */
- #ifdef LOG_LOCAL6
- return LOG_LOCAL6;
- #else
- goto not_there;
- #endif
- }
- case '7':
- if (strEQ(name + 6, "CAL7")) { /* LOG_LO removed */
- #ifdef LOG_LOCAL7
- return LOG_LOCAL7;
- #else
- goto not_there;
- #endif
- }
- }
- errno = EINVAL;
- return 0;
-
- not_there:
- errno = ENOENT;
- return 0;
- }
-
- static double
- constant_LOG_L(char *name, int len)
- {
- switch (name[5 + 0]) {
- case 'F':
- if (strEQ(name + 5, "FMT")) { /* LOG_L removed */
- #ifdef LOG_LFMT
- return LOG_LFMT;
- #else
- goto not_there;
- #endif
- }
- case 'O':
- return constant_LOG_LO(name, len);
- case 'P':
- if (strEQ(name + 5, "PR")) { /* LOG_L removed */
- #ifdef LOG_LPR
- return LOG_LPR;
- #else
- goto not_there;
- #endif
- }
- }
- errno = EINVAL;
- return 0;
-
- not_there:
- errno = ENOENT;
- return 0;
- }
-
- static double
- constant(char *name, int len)
- {
- errno = 0;
- if (0 + 4 >= len ) {
- errno = EINVAL;
- return 0;
- }
- switch (name[0 + 4]) {
- case 'A':
- if (!strnEQ(name + 0,"LOG_", 4))
- break;
- return constant_LOG_A(name, len);
- case 'C':
- if (!strnEQ(name + 0,"LOG_", 4))
- break;
- return constant_LOG_C(name, len);
- case 'D':
- if (!strnEQ(name + 0,"LOG_", 4))
- break;
- return constant_LOG_D(name, len);
- case 'E':
- if (!strnEQ(name + 0,"LOG_", 4))
- break;
- return constant_LOG_E(name, len);
- case 'F':
- if (!strnEQ(name + 0,"LOG_", 4))
- break;
- return constant_LOG_F(name, len);
- case 'I':
- if (strEQ(name + 0, "LOG_INFO")) { /* removed */
- #ifdef LOG_INFO
- return LOG_INFO;
- #else
- goto not_there;
- #endif
- }
- case 'K':
- if (strEQ(name + 0, "LOG_KERN")) { /* removed */
- #ifdef LOG_KERN
- return LOG_KERN;
- #else
- goto not_there;
- #endif
- }
- case 'L':
- if (!strnEQ(name + 0,"LOG_", 4))
- break;
- return constant_LOG_L(name, len);
- case 'M':
- if (strEQ(name + 0, "LOG_MAIL")) { /* removed */
- #ifdef LOG_MAIL
- return LOG_MAIL;
- #else
- goto not_there;
- #endif
- }
- case 'N':
- if (!strnEQ(name + 0,"LOG_", 4))
- break;
- return constant_LOG_N(name, len);
- case 'O':
- if (strEQ(name + 0, "LOG_ODELAY")) { /* removed */
- #ifdef LOG_ODELAY
- return LOG_ODELAY;
- #else
- goto not_there;
- #endif
- }
- case 'P':
- if (!strnEQ(name + 0,"LOG_", 4))
- break;
- return constant_LOG_P(name, len);
- case 'S':
- if (strEQ(name + 0, "LOG_SYSLOG")) { /* removed */
- #ifdef LOG_SYSLOG
- return LOG_SYSLOG;
- #else
- goto not_there;
- #endif
- }
- case 'U':
- if (!strnEQ(name + 0,"LOG_", 4))
- break;
- return constant_LOG_U(name, len);
- case 'W':
- if (strEQ(name + 0, "LOG_WARNING")) { /* removed */
- #ifdef LOG_WARNING
- return LOG_WARNING;
- #else
- goto not_there;
- #endif
- }
- }
- errno = EINVAL;
- return 0;
-
- not_there:
- errno = ENOENT;
- return 0;
- }
-
-
MODULE = Sys::Syslog PACKAGE = Sys::Syslog
! char *
! _PATH_LOG()
! CODE:
! #ifdef _PATH_LOG
! RETVAL = _PATH_LOG;
! #else
! RETVAL = "";
! #endif
! OUTPUT:
! RETVAL
int
LOG_FAC(p)
--- 6,16 ----
#include <syslog.h>
#endif
! #include "constants.c"
MODULE = Sys::Syslog PACKAGE = Sys::Syslog
! INCLUDE: constants.xs
int
LOG_FAC(p)
***************
*** 625,641 ****
#endif
OUTPUT:
RETVAL
-
-
- double
- constant(sv)
- PREINIT:
- STRLEN len;
- INPUT:
- SV * sv
- char * s = SvPV(sv, len);
- CODE:
- RETVAL = constant(s,len);
- OUTPUT:
- RETVAL
-
--- 82,84 ----
diff -c /dev/null 'perl-5.7.2/ext/Sys/Syslog/syslog.t'
Index: ./ext/Sys/Syslog/syslog.t
*** ./ext/Sys/Syslog/syslog.t Thu Jan 1 02:00:00 1970
--- ./ext/Sys/Syslog/syslog.t Mon Jul 9 17:10:14 2001
***************
*** 0 ****
--- 1,74 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bSyslog\b/) {
+ print "1..0 # Skip: Sys::Syslog was not built\n";
+ exit 0;
+ }
+
+ require Socket;
+
+ # This code inspired by Sys::Syslog::connect():
+ require Sys::Hostname;
+ my ($host_uniq) = Sys::Hostname::hostname();
+ my ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/;
+
+ if (! defined Socket::inet_aton($host)) {
+ print "1..0 # Skip: Can't lookup $host\n";
+ exit 0;
+ }
+ }
+
+ BEGIN {
+ eval {require Sys::Syslog} or do {
+ if ($@ =~ /Your vendor has not/) {
+ print "1..0 # Skipped: missing macros\n";
+ exit 0;
+ }
+ }
+ }
+
+ use Sys::Syslog qw(:DEFAULT setlogsock);
+
+ # Test this to 1 if your syslog accepts udp connections.
+ # Most don't (or at least shouldn't)
+ my $Test_Syslog_INET = 0;
+
+ my $test_string = "uid $< is testing perl $] syslog capabilities";
+
+ print "1..6\n";
+
+ if (Sys::Syslog::_PATH_LOG()) {
+ if (-e Sys::Syslog::_PATH_LOG()) {
+ print defined(eval { setlogsock('unix') }) ? "ok 1\n" : "not ok 1\n";
+ print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 2\n" : "not ok 2\n";
+ print defined(eval { syslog('info', $test_string ) }) ? "ok 3\n" : "not ok 3\n";
+ }
+ else {
+ for (1..3) {
+ print
+ "ok $_ # skipping, file ",
+ Sys::Syslog::_PATH_LOG(),
+ " does not exist\n";
+ }
+ }
+ }
+ else {
+ for (1..3) { print "ok $_ # skipping, _PATH_LOG unavailable\n" }
+ }
+
+ if( $Test_Syslog_INET ) {
+ print defined(eval { setlogsock('inet') }) ? "ok 4\n"
+ : "not ok 4\n";
+ print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 5\n"
+ : "not ok 5\n";
+ print defined(eval { syslog('info', $test_string ) }) ? "ok 6\n"
+ : "not ok 6\n";
+ }
+ else {
+ print "ok $_ # skipped(assuming syslog doesn't accept inet connections)\n"
+ foreach (4..6);
+ }
diff -c 'perl-5.7.1/ext/Thread/Thread.pm' 'perl-5.7.2/ext/Thread/Thread.pm'
Index: ./ext/Thread/Thread.pm
*** ./ext/Thread/Thread.pm Mon Apr 9 06:11:56 2001
--- ./ext/Thread/Thread.pm Mon Jul 9 17:10:14 2001
***************
*** 3,9 ****
use XSLoader ();
our($VERSION, @ISA, @EXPORT);
! $VERSION = "1.0";
@ISA = qw(Exporter);
@EXPORT_OK = qw(yield cond_signal cond_broadcast cond_wait async);
--- 3,9 ----
use XSLoader ();
our($VERSION, @ISA, @EXPORT);
! $VERSION = "1.01";
@ISA = qw(Exporter);
@EXPORT_OK = qw(yield cond_signal cond_broadcast cond_wait async);
diff -c 'perl-5.7.1/ext/Thread/Thread.xs' 'perl-5.7.2/ext/Thread/Thread.xs'
Index: ./ext/Thread/Thread.xs
*** ./ext/Thread/Thread.xs Mon Apr 9 06:11:58 2001
--- ./ext/Thread/Thread.xs Mon Jul 9 17:10:14 2001
***************
*** 81,95 ****
return 0;
#else
Thread thr = (Thread) arg;
- LOGOP myop;
dSP;
I32 oldmark = TOPMARK;
- I32 oldscope = PL_scopestack_ix;
I32 retval;
SV *sv;
AV *av;
! int i, ret;
! dJMPENV;
#if defined(MULTIPLICITY)
PERL_SET_INTERP(thr->interp);
--- 81,92 ----
return 0;
#else
Thread thr = (Thread) arg;
dSP;
I32 oldmark = TOPMARK;
I32 retval;
SV *sv;
AV *av;
! int i;
#if defined(MULTIPLICITY)
PERL_SET_INTERP(thr->interp);
***************
*** 150,156 ****
FREETMPS;
LEAVE;
- finishoff:
#if 0
/* removed for debug */
SvREFCNT_dec(PL_curstack);
--- 147,152 ----
***************
*** 279,288 ****
if (!attr_inited) {
attr_inited = 1;
err = pthread_attr_init(&attr);
# ifdef PTHREAD_ATTR_SETDETACHSTATE
if (err == 0)
err = PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
!
# else
croak("panic: can't pthread_attr_setdetachstate");
# endif
--- 275,291 ----
if (!attr_inited) {
attr_inited = 1;
err = pthread_attr_init(&attr);
+ # ifdef THREAD_CREATE_NEEDS_STACK
+ if (err == 0)
+ err = pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK);
+ if (err)
+ croak("panic: pthread_attr_setstacksize failed");
+ # endif
# ifdef PTHREAD_ATTR_SETDETACHSTATE
if (err == 0)
err = PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
! if (err)
! croak("panic: pthread_attr_setdetachstate failed");
# else
croak("panic: can't pthread_attr_setdetachstate");
# endif
***************
*** 338,345 ****
static Signal_t
handle_thread_signal(int sig)
{
- dTHXo;
unsigned char c = (unsigned char) sig;
/*
* We're not really allowed to call fprintf in a signal handler
* so don't be surprised if this isn't robust while debugging
--- 341,348 ----
static Signal_t
handle_thread_signal(int sig)
{
unsigned char c = (unsigned char) sig;
+ dTHX;
/*
* We're not really allowed to call fprintf in a signal handler
* so don't be surprised if this isn't robust while debugging
***************
*** 346,352 ****
* with -DL.
*/
DEBUG_S(PerlIO_printf(Perl_debug_log,
! "handle_thread_signal: got signal %d\n", sig););
write(sig_pipe[1], &c, 1);
}
--- 349,355 ----
* with -DL.
*/
DEBUG_S(PerlIO_printf(Perl_debug_log,
! "handle_thread_signal: got signal %d\n", sig));
write(sig_pipe[1], &c, 1);
}
***************
*** 371,377 ****
if (t == thr)
croak("Attempt to join self");
DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: joining %p (state %u)\n",
! thr, t, ThrSTATE(t)););
MUTEX_LOCK(&t->mutex);
switch (ThrSTATE(t)) {
case THRf_R_JOINABLE:
--- 374,380 ----
if (t == thr)
croak("Attempt to join self");
DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: joining %p (state %u)\n",
! thr, t, ThrSTATE(t)));
MUTEX_LOCK(&t->mutex);
switch (ThrSTATE(t)) {
case THRf_R_JOINABLE:
***************
*** 414,420 ****
CODE:
#ifdef USE_THREADS
DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: detaching %p (state %u)\n",
! thr, t, ThrSTATE(t)););
MUTEX_LOCK(&t->mutex);
switch (ThrSTATE(t)) {
case THRf_R_JOINABLE:
--- 417,423 ----
CODE:
#ifdef USE_THREADS
DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: detaching %p (state %u)\n",
! thr, t, ThrSTATE(t)));
MUTEX_LOCK(&t->mutex);
switch (ThrSTATE(t)) {
case THRf_R_JOINABLE:
***************
*** 492,498 ****
DESTROY(t)
SV * t
PPCODE:
! PUSHs(&PL_sv_yes);
void
yield()
--- 495,501 ----
DESTROY(t)
SV * t
PPCODE:
! PUSHs(t ? &PL_sv_yes : &PL_sv_no);
void
yield()
***************
*** 662,668 ****
if (ret)
sv_setsv(ST(0), c ? PL_psig_ptr[c] : &PL_sv_no);
DEBUG_S(PerlIO_printf(Perl_debug_log,
! "await_signal returning %s\n", SvPEEK(ST(0))););
MODULE = Thread PACKAGE = Thread::Specific
--- 665,671 ----
if (ret)
sv_setsv(ST(0), c ? PL_psig_ptr[c] : &PL_sv_no);
DEBUG_S(PerlIO_printf(Perl_debug_log,
! "await_signal returning %s\n", SvPEEK(ST(0))));
MODULE = Thread PACKAGE = Thread::Specific
diff -c /dev/null 'perl-5.7.2/ext/Thread/create.tx'
Index: ./ext/Thread/create.tx
*** ./ext/Thread/create.tx Thu Jan 1 02:00:00 1970
--- ./ext/Thread/create.tx Mon Jul 9 17:10:15 2001
***************
*** 0 ****
--- 1,38 ----
+ BEGIN {
+ eval { require Config; import Config };
+ if ($@) {
+ print "1..0 # Skip: no Config\n";
+ exit(0);
+ }
+ if ($Config{extensions} !~ /\bThread\b/) {
+ print "1..0 # Skip: no use5005threads\n";
+ exit(0);
+ }
+ }
+
+ use Thread 'async';
+ use Config;
+ use Tie::Hash;
+
+ sub start_here {
+ my $i;
+ print "In start_here with args: @_\n";
+ for ($i = 1; $i <= 5; $i++) {
+ print "start_here: $i\n";
+ sleep 1;
+ }
+ }
+
+ async {
+ tie my(%h), 'Tie::StdHash';
+ %h = %Config;
+ print "running on $h{archname}\n";
+ };
+
+ print "Starting new thread now\n";
+ $t = new Thread \&start_here, qw(foo bar baz);
+ print "Started thread $t\n";
+ for ($count = 1; $count <= 5; $count++) {
+ print "main: $count\n";
+ sleep 1;
+ }
diff -c /dev/null 'perl-5.7.2/ext/Thread/die.tx'
Index: ./ext/Thread/die.tx
*** ./ext/Thread/die.tx Thu Jan 1 02:00:00 1970
--- ./ext/Thread/die.tx Mon Jul 9 17:10:15 2001
***************
*** 0 ****
--- 1,28 ----
+ BEGIN {
+ eval { require Config; import Config };
+ if ($@) {
+ print "1..0 # Skip: no Config\n";
+ exit(0);
+ }
+ if ($Config{extensions} !~ /\bThread\b/) {
+ print "1..0 # Skip: no use5005threads\n";
+ exit(0);
+ }
+ }
+
+ use Thread 'async';
+
+ $t = async {
+ print "here\n";
+ die "success";
+ print "shouldn't get here\n";
+ };
+
+ sleep 1;
+ print "joining...\n";
+ eval { @r = $t->join; };
+ if ($@) {
+ print "thread died with message: $@";
+ } else {
+ print "thread failed to die successfully\n";
+ }
diff -c /dev/null 'perl-5.7.2/ext/Thread/die2.tx'
Index: ./ext/Thread/die2.tx
*** ./ext/Thread/die2.tx Thu Jan 1 02:00:00 1970
--- ./ext/Thread/die2.tx Mon Jul 9 17:10:15 2001
***************
*** 0 ****
--- 1,28 ----
+ BEGIN {
+ eval { require Config; import Config };
+ if ($@) {
+ print "1..0 # Skip: no Config\n";
+ exit(0);
+ }
+ if ($Config{extensions} !~ /\bThread\b/) {
+ print "1..0 # Skip: no use5005threads\n";
+ exit(0);
+ }
+ }
+
+ use Thread 'async';
+
+ $t = async {
+ sleep 1;
+ print "here\n";
+ die "success if preceded by 'thread died...'";
+ print "shouldn't get here\n";
+ };
+
+ print "joining...\n";
+ @r = eval { $t->join; };
+ if ($@) {
+ print "thread died with message: $@";
+ } else {
+ print "thread failed to die successfully\n";
+ }
diff -c /dev/null 'perl-5.7.2/ext/Thread/io.tx'
Index: ./ext/Thread/io.tx
*** ./ext/Thread/io.tx Thu Jan 1 02:00:00 1970
--- ./ext/Thread/io.tx Mon Jul 9 17:10:15 2001
***************
*** 0 ****
--- 1,51 ----
+ BEGIN {
+ eval { require Config; import Config };
+ if ($@) {
+ print "1..0 # Skip: no Config\n";
+ exit(0);
+ }
+ if ($Config{extensions} !~ /\bThread\b/) {
+ print "1..0 # Skip: no use5005threads\n";
+ exit(0);
+ }
+ }
+
+ use Thread;
+
+ sub counter {
+ $count = 10;
+ while ($count--) {
+ sleep 1;
+ print "ping $count\n";
+ }
+ }
+
+ sub reader {
+ my $line;
+ while ($line = <STDIN>) {
+ print "reader: $line";
+ }
+ print "End of input in reader\n";
+ return 0;
+ }
+
+ print <<'EOT';
+ This test starts up a thread to read and echo whatever is typed on
+ the keyboard/stdin, line by line, while the main thread counts down
+ to zero. The test stays running until both the main thread has
+ finished counting down and the I/O thread has seen end-of-file on
+ the terminal/stdin.
+ EOT
+
+ $r = new Thread \&counter;
+
+ &reader;
+
+ __END__
+
+
+ $count = 10;
+ while ($count--) {
+ sleep 1;
+ print "ping $count\n";
+ }
diff -c /dev/null 'perl-5.7.2/ext/Thread/join.tx'
Index: ./ext/Thread/join.tx
*** ./ext/Thread/join.tx Thu Jan 1 02:00:00 1970
--- ./ext/Thread/join.tx Mon Jul 9 17:10:15 2001
***************
*** 0 ****
--- 1,23 ----
+ BEGIN {
+ eval { require Config; import Config };
+ if ($@) {
+ print "1..0 # Skip: no Config\n";
+ exit(0);
+ }
+ if ($Config{extensions} !~ /\bThread\b/) {
+ print "1..0 # Skip: no use5005threads\n";
+ exit(0);
+ }
+ }
+
+ use Thread;
+ sub foo {
+ print "In foo with args: @_\n";
+ return (7, 8, 9);
+ }
+
+ print "Starting thread\n";
+ $t = new Thread \&foo, qw(foo bar baz);
+ print "Joining with $t\n";
+ @results = $t->join();
+ print "Joining returned ", scalar(@results), " values: @results\n";
diff -c /dev/null 'perl-5.7.2/ext/Thread/join2.tx'
Index: ./ext/Thread/join2.tx
*** ./ext/Thread/join2.tx Thu Jan 1 02:00:00 1970
--- ./ext/Thread/join2.tx Mon Jul 9 17:10:15 2001
***************
*** 0 ****
--- 1,24 ----
+ BEGIN {
+ eval { require Config; import Config };
+ if ($@) {
+ print "1..0 # Skip: no Config\n";
+ exit(0);
+ }
+ if ($Config{extensions} !~ /\bThread\b/) {
+ print "1..0 # Skip: no use5005threads\n";
+ exit(0);
+ }
+ }
+
+ use Thread;
+ sub foo {
+ print "In foo with args: @_\n";
+ return (7, 8, 9);
+ }
+
+ print "Starting thread\n";
+ $t = new Thread \&foo, qw(foo bar baz);
+ sleep 2;
+ print "Joining with $t\n";
+ @results = $t->join();
+ print "Joining returned @results\n";
diff -c /dev/null 'perl-5.7.2/ext/Thread/list.tx'
Index: ./ext/Thread/list.tx
*** ./ext/Thread/list.tx Thu Jan 1 02:00:00 1970
--- ./ext/Thread/list.tx Mon Jul 9 17:10:15 2001
***************
*** 0 ****
--- 1,42 ----
+ BEGIN {
+ eval { require Config; import Config };
+ if ($@) {
+ print "1..0 # Skip: no Config\n";
+ exit(0);
+ }
+ if ($Config{extensions} !~ /\bThread\b/) {
+ print "1..0 # Skip: no use5005threads\n";
+ exit(0);
+ }
+ }
+
+ use Thread qw(async);
+ use Thread::Semaphore;
+
+ my $sem = Thread::Semaphore->new(0);
+
+ $nthreads = 4;
+
+ for (my $i = 0; $i < $nthreads; $i++) {
+ async {
+ my $tid = Thread->self->tid;
+ print "thread $tid started...\n";
+ $sem->down;
+ print "thread $tid finishing\n";
+ };
+ }
+
+ print "main: started $nthreads threads\n";
+ sleep 2;
+
+ my @list = Thread->list;
+ printf "main: Thread->list returned %d threads\n", scalar(@list);
+
+ foreach my $t (@list) {
+ print "inspecting thread $t...\n";
+ print "...deref is $$t\n";
+ print "...flags = ", $t->flags, "\n";
+ print "...tid = ", $t->tid, "\n";
+ }
+ print "main thread telling workers to finish off...\n";
+ $sem->up($nthreads);
diff -c /dev/null 'perl-5.7.2/ext/Thread/lock.tx'
Index: ./ext/Thread/lock.tx
*** ./ext/Thread/lock.tx Thu Jan 1 02:00:00 1970
--- ./ext/Thread/lock.tx Mon Jul 9 17:10:15 2001
***************
*** 0 ****
--- 1,39 ----
+ BEGIN {
+ eval { require Config; import Config };
+ if ($@) {
+ print "1..0 # Skip: no Config\n";
+ exit(0);
+ }
+ if ($Config{extensions} !~ /\bThread\b/) {
+ print "1..0 # Skip: no use5005threads\n";
+ exit(0);
+ }
+ }
+
+ use Thread;
+
+ $level = 0;
+
+ sub worker
+ {
+ my $num = shift;
+ my $i;
+ print "thread $num starting\n";
+ for ($i = 1; $i <= 20; $i++) {
+ print "thread $num iteration $i\n";
+ select(undef, undef, undef, rand(10)/100);
+ {
+ lock($lock);
+ warn "thread $num saw non-zero level = $level\n" if $level;
+ $level++;
+ print "thread $num has lock\n";
+ select(undef, undef, undef, rand(10)/100);
+ $level--;
+ }
+ print "thread $num released lock\n";
+ }
+ }
+
+ for ($t = 1; $t <= 5; $t++) {
+ new Thread \&worker, $t;
+ }
diff -c /dev/null 'perl-5.7.2/ext/Thread/queue.tx'
Index: ./ext/Thread/queue.tx
*** ./ext/Thread/queue.tx Thu Jan 1 02:00:00 1970
--- ./ext/Thread/queue.tx Mon Jul 9 17:10:15 2001
***************
*** 0 ****
--- 1,48 ----
+ BEGIN {
+ eval { require Config; import Config };
+ if ($@) {
+ print "1..0 # Skip: no Config\n";
+ exit(0);
+ }
+ if ($Config{extensions} !~ /\bThread\b/) {
+ print "1..0 # Skip: no use5005threads\n";
+ exit(0);
+ }
+ }
+
+ use Thread;
+ use Thread::Queue;
+
+ $q = new Thread::Queue;
+
+ sub reader {
+ my $tid = Thread->self->tid;
+ my $i = 0;
+ while (1) {
+ $i++;
+ print "reader (tid $tid): waiting for element $i...\n";
+ my $el = $q->dequeue;
+ print "reader (tid $tid): dequeued element $i: value $el\n";
+ select(undef, undef, undef, rand(2));
+ if ($el == -1) {
+ # end marker
+ print "reader (tid $tid) returning\n";
+ return;
+ }
+ }
+ }
+
+ my $nthreads = 3;
+
+ for (my $i = 0; $i < $nthreads; $i++) {
+ Thread->new(\&reader, $i);
+ }
+
+ for (my $i = 1; $i <= 10; $i++) {
+ my $el = int(rand(100));
+ select(undef, undef, undef, rand(2));
+ print "writer: enqueuing value $el\n";
+ $q->enqueue($el);
+ }
+
+ $q->enqueue((-1) x $nthreads); # one end marker for each thread
diff -c /dev/null 'perl-5.7.2/ext/Thread/specific.tx'
Index: ./ext/Thread/specific.tx
*** ./ext/Thread/specific.tx Thu Jan 1 02:00:00 1970
--- ./ext/Thread/specific.tx Mon Jul 9 17:10:15 2001
***************
*** 0 ****
--- 1,29 ----
+ BEGIN {
+ eval { require Config; import Config };
+ if ($@) {
+ print "1..0 # Skip: no Config\n";
+ exit(0);
+ }
+ if ($Config{extensions} !~ /\bThread\b/) {
+ print "1..0 # Skip: no use5005threads\n";
+ exit(0);
+ }
+ }
+
+ use Thread;
+
+ use Thread::Specific qw(foo);
+
+ sub count {
+ my $tid = Thread->self->tid;
+ my Thread::Specific $tsd = Thread::Specific::data;
+ for (my $i = 0; $i < 5; $i++) {
+ $tsd->{foo} = $i;
+ print "thread $tid count: $tsd->{foo}\n";
+ select(undef, undef, undef, rand(2));
+ }
+ };
+
+ for(my $t = 0; $t < 5; $t++) {
+ new Thread \&count;
+ }
diff -c /dev/null 'perl-5.7.2/ext/Thread/sync.tx'
Index: ./ext/Thread/sync.tx
*** ./ext/Thread/sync.tx Thu Jan 1 02:00:00 1970
--- ./ext/Thread/sync.tx Mon Jul 9 17:10:15 2001
***************
*** 0 ****
--- 1,72 ----
+ BEGIN {
+ eval { require Config; import Config };
+ if ($@) {
+ print "1..0 # Skip: no Config\n";
+ exit(0);
+ }
+ if ($Config{extensions} !~ /\bThread\b/) {
+ print "1..0 # Skip: no use5005threads\n";
+ exit(0);
+ }
+ }
+
+ use Thread;
+
+ $level = 0;
+
+ sub single_file : locked {
+ my $arg = shift;
+ $level++;
+ print "Level $level for $arg\n";
+ print "(something is wrong)\n" if $level < 0 || $level > 1;
+ sleep 1;
+ $level--;
+ print "Back to level $level\n";
+ }
+
+ sub start_bar {
+ my $i;
+ print "start bar\n";
+ for $i (1..3) {
+ print "bar $i\n";
+ single_file("bar $i");
+ sleep 1 if rand > 0.5;
+ }
+ print "end bar\n";
+ return 1;
+ }
+
+ sub start_foo {
+ my $i;
+ print "start foo\n";
+ for $i (1..3) {
+ print "foo $i\n";
+ single_file("foo $i");
+ sleep 1 if rand > 0.5;
+ }
+ print "end foo\n";
+ return 1;
+ }
+
+ sub start_baz {
+ my $i;
+ print "start baz\n";
+ for $i (1..3) {
+ print "baz $i\n";
+ single_file("baz $i");
+ sleep 1 if rand > 0.5;
+ }
+ print "end baz\n";
+ return 1;
+ }
+
+ $| = 1;
+ srand($$^$^T);
+
+ $foo = new Thread \&start_foo;
+ $bar = new Thread \&start_bar;
+ $baz = new Thread \&start_baz;
+ $foo->join();
+ $bar->join();
+ $baz->join();
+ print "main: threads finished, exiting\n";
diff -c /dev/null 'perl-5.7.2/ext/Thread/sync2.tx'
Index: ./ext/Thread/sync2.tx
*** ./ext/Thread/sync2.tx Thu Jan 1 02:00:00 1970
--- ./ext/Thread/sync2.tx Mon Jul 9 17:10:15 2001
***************
*** 0 ****
--- 1,80 ----
+ BEGIN {
+ eval { require Config; import Config };
+ if ($@) {
+ print "1..0 # Skip: no Config\n";
+ exit(0);
+ }
+ if ($Config{extensions} !~ /\bThread\b/) {
+ print "1..0 # Skip: no use5005threads\n";
+ exit(0);
+ }
+ }
+
+ use Thread;
+
+ $global = undef;
+
+ sub single_file : locked {
+ my $who = shift;
+ my $i;
+
+ print "Uh oh: $who entered while locked by $global\n" if $global;
+ $global = $who;
+ print "[";
+ for ($i = 0; $i < int(10 * rand); $i++) {
+ print $who;
+ select(undef, undef, undef, 0.1);
+ }
+ print "]";
+ $global = undef;
+ }
+
+ sub start_a {
+ my ($i, $j);
+ for ($j = 0; $j < 10; $j++) {
+ single_file("A");
+ for ($i = 0; $i < int(10 * rand); $i++) {
+ print "a";
+ select(undef, undef, undef, 0.1);
+ }
+ }
+ }
+
+ sub start_b {
+ my ($i, $j);
+ for ($j = 0; $j < 10; $j++) {
+ single_file("B");
+ for ($i = 0; $i < int(10 * rand); $i++) {
+ print "b";
+ select(undef, undef, undef, 0.1);
+ }
+ }
+ }
+
+ sub start_c {
+ my ($i, $j);
+ for ($j = 0; $j < 10; $j++) {
+ single_file("C");
+ for ($i = 0; $i < int(10 * rand); $i++) {
+ print "c";
+ select(undef, undef, undef, 0.1);
+ }
+ }
+ }
+
+ $| = 1;
+ srand($$^$^T);
+
+ print <<'EOT';
+ Each pair of square brackets [...] should contain a repeated sequence of
+ a unique upper case letter. Lower case letters may appear randomly both
+ in and out of the brackets.
+ EOT
+ $foo = new Thread \&start_a;
+ $bar = new Thread \&start_b;
+ $baz = new Thread \&start_c;
+ print "\nmain: joining...\n";
+ #$foo->join;
+ #$bar->join;
+ #$baz->join;
+ print "\ndone\n";
diff -c /dev/null 'perl-5.7.2/ext/Thread/thr5005.t'
Index: ./ext/Thread/thr5005.t
*** ./ext/Thread/thr5005.t Thu Jan 1 02:00:00 1970
--- ./ext/Thread/thr5005.t Mon Jul 9 17:10:15 2001
***************
*** 0 ****
--- 1,207 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if (! $Config{'use5005threads'}) {
+ print "1..0 # Skip: no use5005threads\n";
+ exit 0;
+ }
+
+ # XXX known trouble with global destruction
+ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
+ }
+ $| = 1;
+ print "1..74\n";
+ use Thread 'yield';
+ print "ok 1\n";
+
+ sub content
+ {
+ print shift;
+ return shift;
+ }
+
+ # create a thread passing args and immedaietly wait for it.
+ my $t = new Thread \&content,("ok 2\n","ok 3\n", 1..1000);
+ print $t->join;
+
+ # check that lock works ...
+ {lock $foo;
+ $t = new Thread sub { lock $foo; print "ok 5\n" };
+ print "ok 4\n";
+ }
+ $t->join;
+
+ sub dorecurse
+ {
+ my $val = shift;
+ my $ret;
+ print $val;
+ if (@_)
+ {
+ $ret = Thread->new(\&dorecurse, @_);
+ $ret->join;
+ }
+ }
+
+ $t = new Thread \&dorecurse, map { "ok $_\n" } 6..10;
+ $t->join;
+
+ # test that sleep lets other thread run
+ $t = new Thread \&dorecurse,"ok 11\n";
+ sleep 6;
+ print "ok 12\n";
+ $t->join;
+
+ sub islocked : locked {
+ my $val = shift;
+ my $ret;
+ print $val;
+ if (@_)
+ {
+ $ret = Thread->new(\&islocked, shift);
+ }
+ $ret;
+ }
+
+ $t = Thread->new(\&islocked, "ok 13\n", "ok 14\n");
+ $t->join->join;
+
+ {
+ package Loch::Ness;
+ sub new { bless [], shift }
+ sub monster : locked : method {
+ my($s, $m) = @_;
+ print "ok $m\n";
+ }
+ sub gollum { &monster }
+ }
+ Loch::Ness->monster(15);
+ Loch::Ness->new->monster(16);
+ Loch::Ness->gollum(17);
+ Loch::Ness->new->gollum(18);
+
+ my $short = "This is a long string that goes on and on.";
+ my $shorte = " a long string that goes on and on.";
+ my $long = "This is short.";
+ my $longe = " short.";
+ my $thr1 = new Thread \&threaded, $short, $shorte, "19";
+ my $thr2 = new Thread \&threaded, $long, $longe, "20";
+ my $thr3 = new Thread \&testsprintf, "21";
+
+ sub testsprintf {
+ my $testno = shift;
+ # this may coredump if thread vars are not properly initialised
+ my $same = sprintf "%.0f", $testno;
+ if ($testno eq $same) {
+ print "ok $testno\n";
+ } else {
+ print "not ok $testno\t# '$testno' ne '$same'\n";
+ }
+ }
+
+ sub threaded {
+ my ($string, $string_end, $testno) = @_;
+
+ # Do the match, saving the output in appropriate variables
+ $string =~ /(.*)(is)(.*)/;
+ # Yield control, allowing the other thread to fill in the match variables
+ yield();
+ # Examine the match variable contents; on broken perls this fails
+ if ($3 eq $string_end) {
+ print "ok $testno\n";
+ }
+ else {
+ warn <<EOT;
+
+ #
+ # This is a KNOWN FAILURE, and one of the reasons why threading
+ # is still an experimental feature. It is here to stop people
+ # from deploying threads in production. ;-)
+ #
+ EOT
+ print "not ok $testno # other thread filled in match variables\n";
+ }
+ }
+ $thr1->join;
+ $thr2->join;
+ $thr3->join;
+ print "ok 22\n";
+
+ {
+ my $THRf_STATE_MASK = 7;
+ my $THRf_R_JOINABLE = 0;
+ my $THRf_R_JOINED = 1;
+ my $THRf_R_DETACHED = 2;
+ my $THRf_ZOMBIE = 3;
+ my $THRf_DEAD = 4;
+ my $THRf_DID_DIE = 8;
+ sub _test {
+ my($test, $t, $state, $die) = @_;
+ my $flags = $t->flags;
+ if (($flags & $THRf_STATE_MASK) == $state
+ && !($flags & $THRf_DID_DIE) == !$die) {
+ print "ok $test\n";
+ } else {
+ print <<BAD;
+ not ok $test\t# got flags $flags not @{[ $state + ($die ? $THRf_DID_DIE : 0) ]}
+ BAD
+ }
+ }
+
+ my @t;
+ push @t, (
+ Thread->new(sub { sleep 4; die "thread die\n" }),
+ Thread->new(sub { die "thread die\n" }),
+ Thread->new(sub { sleep 4; 1 }),
+ Thread->new(sub { 1 }),
+ ) for 1, 2;
+ $_->detach for @t[grep $_ & 4, 0..$#t];
+
+ sleep 1;
+ my $test = 23;
+ for (0..7) {
+ my $t = $t[$_];
+ my $flags = ($_ & 1)
+ ? ($_ & 4) ? $THRf_DEAD : $THRf_ZOMBIE
+ : ($_ & 4) ? $THRf_R_DETACHED : $THRf_R_JOINABLE;
+ _test($test++, $t, $flags, (($_ & 3) != 1) ? 0 : $THRf_DID_DIE);
+ printf "%sok %s\n", !$t->done == !($_ & 1) ? "" : "not ", $test++;
+ }
+ # $test = 39;
+ for (grep $_ & 1, 0..$#t) {
+ next if $_ & 4; # can't join detached threads
+ $t[$_]->eval;
+ my $die = ($_ & 2) ? "" : "thread die\n";
+ printf "%sok %s\n", $@ eq $die ? "" : "not ", $test++;
+ }
+ # $test = 41;
+ for (0..7) {
+ my $t = $t[$_];
+ my $flags = ($_ & 1)
+ ? ($_ & 4) ? $THRf_DEAD : $THRf_DEAD
+ : ($_ & 4) ? $THRf_R_DETACHED : $THRf_R_JOINABLE;
+ _test($test++, $t, $flags, (($_ & 3) != 1) ? 0 : $THRf_DID_DIE);
+ printf "%sok %s\n", !$t->done == !($_ & 1) ? "" : "not ", $test++;
+ }
+ # $test = 57;
+ for (grep !($_ & 1), 0..$#t) {
+ next if $_ & 4; # can't join detached threads
+ $t[$_]->eval;
+ my $die = ($_ & 2) ? "" : "thread die\n";
+ printf "%sok %s\n", $@ eq $die ? "" : "not ", $test++;
+ }
+ sleep 1; # make sure even the detached threads are done sleeping
+ # $test = 59;
+ for (0..7) {
+ my $t = $t[$_];
+ my $flags = ($_ & 1)
+ ? ($_ & 4) ? $THRf_DEAD : $THRf_DEAD
+ : ($_ & 4) ? $THRf_DEAD : $THRf_DEAD;
+ _test($test++, $t, $flags, ($_ & 2) ? 0 : $THRf_DID_DIE);
+ printf "%sok %s\n", $t->done ? "" : "not ", $test++;
+ }
+ # $test = 75;
+ }
diff -c 'perl-5.7.1/ext/Thread/typemap' 'perl-5.7.2/ext/Thread/typemap'
Index: ./ext/Thread/typemap
*** ./ext/Thread/typemap Tue Mar 6 04:05:03 2001
--- ./ext/Thread/typemap Mon Jul 9 17:10:15 2001
***************
*** 14,20 ****
croak(\"XSUB ${func_name}: $var is a forged ${ntype} object\");
$var = ($type) SvPVX(mg->mg_obj);
DEBUG_S(PerlIO_printf(Perl_debug_log,
! \"XSUB ${func_name}: %p\\n\", $var);)
} STMT_END
T_IVREF
if (SvROK($arg))
--- 14,20 ----
croak(\"XSUB ${func_name}: $var is a forged ${ntype} object\");
$var = ($type) SvPVX(mg->mg_obj);
DEBUG_S(PerlIO_printf(Perl_debug_log,
! \"XSUB ${func_name}: %p\\n\", $var));
} STMT_END
T_IVREF
if (SvROK($arg))
diff -c /dev/null 'perl-5.7.2/ext/Thread/unsync.tx'
Index: ./ext/Thread/unsync.tx
*** ./ext/Thread/unsync.tx Thu Jan 1 02:00:00 1970
--- ./ext/Thread/unsync.tx Mon Jul 9 17:10:15 2001
***************
*** 0 ****
--- 1,49 ----
+ BEGIN {
+ eval { require Config; import Config };
+ if ($@) {
+ print "1..0 # Skip: no Config\n";
+ exit(0);
+ }
+ if ($Config{extensions} !~ /\bThread\b/) {
+ print "1..0 # Skip: no use5005threads\n";
+ exit(0);
+ }
+ }
+
+ use Thread;
+
+ $| = 1;
+
+ if (@ARGV) {
+ srand($ARGV[0]);
+ } else {
+ my $seed = $$ ^ $^T;
+ print "Randomising to $seed\n";
+ srand($seed);
+ }
+
+ sub whoami {
+ my ($depth, $a, $b, $c) = @_;
+ my $i;
+ print "whoami ($depth): $a $b $c\n";
+ sleep 1;
+ whoami($depth - 1, $a, $b, $c) if $depth > 0;
+ }
+
+ sub start_foo {
+ my $r = 3 + int(10 * rand);
+ print "start_foo: r is $r\n";
+ whoami($r, "start_foo", "foo1", "foo2");
+ print "start_foo: finished\n";
+ }
+
+ sub start_bar {
+ my $r = 3 + int(10 * rand);
+ print "start_bar: r is $r\n";
+ whoami($r, "start_bar", "bar1", "bar2");
+ print "start_bar: finished\n";
+ }
+
+ $foo = new Thread \&start_foo;
+ $bar = new Thread \&start_bar;
+ print "main: exiting\n";
diff -c /dev/null 'perl-5.7.2/ext/Thread/unsync2.tx'
Index: ./ext/Thread/unsync2.tx
*** ./ext/Thread/unsync2.tx Thu Jan 1 02:00:00 1970
--- ./ext/Thread/unsync2.tx Mon Jul 9 17:10:15 2001
***************
*** 0 ****
--- 1,48 ----
+ BEGIN {
+ eval { require Config; import Config };
+ if ($@) {
+ print "1..0 # Skip: no Config\n";
+ exit(0);
+ }
+ if ($Config{extensions} !~ /\bThread\b/) {
+ print "1..0 # Skip: no use5005threads\n";
+ exit(0);
+ }
+ }
+
+ use Thread;
+
+ $| = 1;
+
+ srand($$^$^T);
+
+ sub printargs {
+ my $thread = shift;
+ my $arg;
+ my $i;
+ while ($arg = shift) {
+ my $delay = int(rand(500));
+ $i++;
+ print "$thread arg $i is $arg\n";
+ 1 while $delay--;
+ }
+ }
+
+ sub start_thread {
+ my $thread = shift;
+ my $count = 10;
+ while ($count--) {
+ my(@args) = ($thread) x int(rand(10));
+ print "$thread $count calling printargs @args\n";
+ printargs($thread, @args);
+ }
+ }
+
+ new Thread (\&start_thread, "A");
+ new Thread (\&start_thread, "B");
+ #new Thread (\&start_thread, "C");
+ #new Thread (\&start_thread, "D");
+ #new Thread (\&start_thread, "E");
+ #new Thread (\&start_thread, "F");
+
+ print "main: exiting\n";
diff -c /dev/null 'perl-5.7.2/ext/Thread/unsync3.tx'
Index: ./ext/Thread/unsync3.tx
*** ./ext/Thread/unsync3.tx Thu Jan 1 02:00:00 1970
--- ./ext/Thread/unsync3.tx Mon Jul 9 17:10:16 2001
***************
*** 0 ****
--- 1,62 ----
+ BEGIN {
+ eval { require Config; import Config };
+ if ($@) {
+ print "1..0 # Skip: no Config\n";
+ exit(0);
+ }
+ if ($Config{extensions} !~ /\bThread\b/) {
+ print "1..0 # Skip: no use5005threads\n";
+ exit(0);
+ }
+ }
+
+ use Thread;
+
+ $| = 1;
+
+ srand($$^$^T);
+
+ sub whoami {
+ my $thread = shift;
+ print $thread;
+ }
+
+ sub uppercase {
+ my $count = 100;
+ while ($count--) {
+ my $i = int(rand(1000));
+ 1 while $i--;
+ print "A";
+ $i = int(rand(1000));
+ 1 while $i--;
+ whoami("B");
+ }
+ }
+
+ sub lowercase {
+ my $count = 100;
+ while ($count--) {
+ my $i = int(rand(1000));
+ 1 while $i--;
+ print "x";
+ $i = int(rand(1000));
+ 1 while $i--;
+ whoami("y");
+ }
+ }
+
+ sub numbers {
+ my $count = 100;
+ while ($count--) {
+ my $i = int(rand(1000));
+ 1 while $i--;
+ print 1;
+ $i = int(rand(1000));
+ 1 while $i--;
+ whoami(2);
+ }
+ }
+
+ new Thread \&numbers;
+ new Thread \&uppercase;
+ new Thread \&lowercase;
diff -c /dev/null 'perl-5.7.2/ext/Thread/unsync4.tx'
Index: ./ext/Thread/unsync4.tx
*** ./ext/Thread/unsync4.tx Thu Jan 1 02:00:00 1970
--- ./ext/Thread/unsync4.tx Mon Jul 9 17:10:16 2001
***************
*** 0 ****
--- 1,50 ----
+ BEGIN {
+ eval { require Config; import Config };
+ if ($@) {
+ print "1..0 # Skip: no Config\n";
+ exit(0);
+ }
+ if ($Config{extensions} !~ /\bThread\b/) {
+ print "1..0 # Skip: no use5005threads\n";
+ exit(0);
+ }
+ }
+
+ use Thread;
+
+ $| = 1;
+
+ srand($$^$^T);
+
+ sub printargs {
+ my(@copyargs) = @_;
+ my $thread = shift @copyargs;
+ my $arg;
+ my $i;
+ while ($arg = shift @copyargs) {
+ my $delay = int(rand(500));
+ $i++;
+ print "$thread arg $i is $arg\n";
+ 1 while $delay--;
+ }
+ }
+
+ sub start_thread {
+ my(@threadargs) = @_;
+ my $thread = $threadargs[0];
+ my $count = 10;
+ while ($count--) {
+ my(@args) = ($thread) x int(rand(10));
+ print "$thread $count calling printargs @args\n";
+ printargs($thread, @args);
+ }
+ }
+
+ new Thread (\&start_thread, "A");
+ new Thread (\&start_thread, "B");
+ new Thread (\&start_thread, "C");
+ new Thread (\&start_thread, "D");
+ new Thread (\&start_thread, "E");
+ new Thread (\&start_thread, "F");
+
+ print "main: exiting\n";
diff -c /dev/null 'perl-5.7.2/ext/Time/HiRes/Changes'
Index: ./ext/Time/HiRes/Changes
*** ./ext/Time/HiRes/Changes Thu Jan 1 02:00:00 1970
--- ./ext/Time/HiRes/Changes Mon Jul 9 17:10:16 2001
***************
*** 0 ****
--- 1,99 ----
+ Revision history for Perl extension Time::HiRes.
+
+ 1.20 Wed Feb 24 21:30 1999
+ - make our usleep and ualarm substitutes into hrt_usleep
+ and hrt_ualarm. This helps static links of Perl with other
+ packages that also have usleep, etc. From
+ Ilya Zakharevich <ilya@math.ohio-state.edu>
+ - add C API stuff. From Joshua Pritikin
+ <joshua.pritikin@db.com>
+ - VMS Makefile.PL fun. From pvhp@forte.com (Peter Prymmer)
+ - hopefully correct "-lc" fix for SCO.
+ - add PPD stuff
+
+ 1.19 Tue Sep 29 22:30 1998
+ - put VMS gettimeofday() in. Patch is from Sebastian Bazley
+ <seb@stian.demon.co.uk>
+ - change GIMME_V to GIMME to help people with older versions of
+ Perl.
+ - fix Win32 version of gettimeofday(). It didn't affect anything,
+ but it confuses people reading the code when the return value
+ is backwards (0 is success).
+ - fix Makefile.PL (more) so that detection of gettimeofday is
+ more correct.
+
+ 1.18 Mon Jul 6 22:40 1998
+ - add usleep() for Win32.
+ - fix Makefile.PL to fix reported HP/UX feature where unresolved
+ externals still cause an executable to be generated (though no
+ x bit set). Thanks to David Kozinn for report and explanation.
+ Problems with the fix are mine :)
+
+ 1.17 Wed Jul 1 20:10 1998
+ - fix setitimer calls so microseconds is not more than 1000000.
+ Hp/UX 9 doesn't like that. Provided by Roland B Robert, PhD.
+ - make Win32. We only get gettimeofday (the select hack doesn't
+ seem to work on my Win95 system).
+ - fix test 4 on 01test.t. add test to see if time() and
+ Time::HiRes::time() are close.
+
+ 1.16 Wed Nov 12 21:05 1997
+ - add missing EXTEND in new gettimeofday scalar code.
+
+ 1.15 Mon Nov 10 21:30 1997
+ - HiRes.pm: update pod. Provided by Gisle Aas.
+ - HiRes.xs: if gettimeofday() called in scalar context, do
+ something more useful than before. Provided by Gisle Aas.
+ - README: tell of xsubpp '-nolinenumber' woes. thanks to
+ Edward Henigin <ed@texas.net> for pointing out the problem.
+
+ 1.14 Wed Nov 5 9:40 1997
+ - Makefile.PL: look for setitimer
+ - HiRes.xs: if missing ualarm, but we have setitimer, make up
+ our own setitimer. These were provided by Gisle Aas.
+
+ 1.13 Tue Nov 4 23:30 1997
+ - Makefile.PL: fix autodetect mechanism to do try linking in addition
+ to just compiling; should fix Linux build problem. Fix was provided
+ by Gisle Aas.
+
+ 1.12 Sun Oct 12 12:00:00 1997
+ - Makefile.PL: set XSOPT to '-nolinenumbers' to work around xsubpp bug;
+ you may need to comment this back out if you have an older xsubpp.
+ - HiRes.xs: set PROTOTYPES: DISABLE
+
+ 1.11 Fri Sep 05 16:00:00 1997
+ - Makefile.PL:
+ Had some line commented out that shouldn't have been (testing
+ remnants)
+ - README:
+ Previous version was corrupted.
+
+ 1.10 Thu May 22 20:20:00 1997
+ - HiRes.xs, HiRes.pm, t/*:
+ - only compile what we have OS support for (or can
+ fake with select())
+ - only test what we compiled
+ - gross improvement to the test suite
+ - fix EXPORT_FAIL.
+ This work was all done by Roderick Schertler
+ <roderick@argon.org>. If you run Linux or
+ one of the other ualarm-less platoforms, and you like this
+ module, let Roderick know; without him, it still wouldn't
+ be working on those boxes...
+ - Makefile.PL: figure out what routines the OS has and
+ only build what we need. These bits were written by Jarkko
+ Hietaniemi <jhi@iki.fi>. Again, gratitude is due...
+
+ 1.02 Mon Dec 30 08:00:00 1996
+ - HiRes.pm: update documentation to say what to do when missing
+ ualarm() and friends.
+ - README: update to warn that ualarm() and friends need to exist
+
+ 1.01 Fri Oct 17 08:00:00 1996
+ - Makefile.PL: make XSPROTOARGS => '-noprototyopes'
+ - HiRes.pm: put blank line between __END__ and =head1 so that
+ pod2man works.
+
+ 1.00 Tue Sep 03 13:00:00 1996
+ - original version; created by h2xs 1.16
diff -c /dev/null 'perl-5.7.2/ext/Time/HiRes/HiRes.pm'
Index: ./ext/Time/HiRes/HiRes.pm
*** ./ext/Time/HiRes/HiRes.pm Thu Jan 1 02:00:00 1970
--- ./ext/Time/HiRes/HiRes.pm Mon Jul 9 17:10:16 2001
***************
*** 0 ****
--- 1,332 ----
+ package Time::HiRes;
+
+ use strict;
+ use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
+
+ require Exporter;
+ use XSLoader;
+
+ @ISA = qw(Exporter);
+
+ @EXPORT = qw( );
+ @EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval
+ getitimer setitimer ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF);
+
+ $VERSION = '1.20_00';
+
+ sub AUTOLOAD {
+ my $constname;
+ ($constname= $AUTOLOAD) =~ s/.*:://;
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($!) {
+ my ($pack,$file,$line) = caller;
+ die "Your vendor has not defined Time::HiRes macro $constname, used at $file line $line.\n";
+ }
+ {
+ no strict 'refs';
+ *$AUTOLOAD = sub { $val };
+ }
+ goto &$AUTOLOAD;
+ }
+
+ XSLoader::load 'Time::HiRes', $VERSION;
+
+ # Preloaded methods go here.
+
+ sub tv_interval {
+ # probably could have been done in C
+ my ($a, $b) = @_;
+ $b = [gettimeofday()] unless defined($b);
+ (${$b}[0] - ${$a}[0]) + ((${$b}[1] - ${$a}[1]) / 1_000_000);
+ }
+
+ # Autoload methods go after =cut, and are processed by the autosplit program.
+
+ 1;
+ __END__
+
+ =head1 NAME
+
+ Time::HiRes - High resolution ualarm, usleep, and gettimeofday
+
+ =head1 SYNOPSIS
+
+ use Time::HiRes qw( usleep ualarm gettimeofday tv_interval );
+
+ usleep ($microseconds);
+
+ ualarm ($microseconds);
+ ualarm ($microseconds, $interval_microseconds);
+
+ $t0 = [gettimeofday];
+ ($seconds, $microseconds) = gettimeofday;
+
+ $elapsed = tv_interval ( $t0, [$seconds, $microseconds]);
+ $elapsed = tv_interval ( $t0, [gettimeofday]);
+ $elapsed = tv_interval ( $t0 );
+
+ use Time::HiRes qw ( time alarm sleep );
+
+ $now_fractions = time;
+ sleep ($floating_seconds);
+ alarm ($floating_seconds);
+ alarm ($floating_seconds, $floating_interval);
+
+ use Time::HiRes qw( setitimer getitimer
+ ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF );
+
+ setitimer ($which, $floating_seconds, $floating_interval );
+ getitimer ($which);
+
+ =head1 DESCRIPTION
+
+ The C<Time::HiRes> module implements a Perl interface to the usleep, ualarm,
+ and gettimeofday system calls. See the EXAMPLES section below and the test
+ scripts for usage; see your system documentation for the description of
+ the underlying gettimeofday, usleep, and ualarm calls.
+
+ If your system lacks gettimeofday(2) you don't get gettimeofday() or the
+ one-arg form of tv_interval(). If you don't have usleep(3) or select(2)
+ you don't get usleep() or sleep(). If your system don't have ualarm(3)
+ or setitimer(2) you don't get ualarm() or alarm().
+ If you try to import an unimplemented function in the C<use> statement
+ it will fail at compile time.
+
+ The following functions can be imported from this module.
+ No functions are exported by default.
+
+ =over 4
+
+ =item gettimeofday ()
+
+ In array context it returns a 2 element array with the seconds and
+ microseconds since the epoch. In scalar context it returns floating
+ seconds like Time::HiRes::time() (see below).
+
+ =item usleep ( $useconds )
+
+ Issues a usleep for the number of microseconds specified. See also
+ Time::HiRes::sleep() below.
+
+ =item ualarm ( $useconds [, $interval_useconds ] )
+
+ Issues a ualarm call; interval_useconds is optional and will be 0 if
+ unspecified, resulting in alarm-like behaviour.
+
+ =item tv_interval
+
+ S<tv_interval ( $ref_to_gettimeofday [, $ref_to_later_gettimeofday] )>
+
+ Returns the floating seconds between the two times, which should have been
+ returned by gettimeofday(). If the second argument is omitted, then the
+ current time is used.
+
+ =item time ()
+
+ Returns a floating seconds since the epoch. This function can be imported,
+ resulting in a nice drop-in replacement for the C<time> provided with perl,
+ see the EXAMPLES below.
+
+ =item sleep ( $floating_seconds )
+
+ Converts $floating_seconds to microseconds and issues a usleep for the
+ result. This function can be imported, resulting in a nice drop-in
+ replacement for the C<sleep> provided with perl, see the EXAMPLES below.
+
+ =item alarm ( $floating_seconds [, $interval_floating_seconds ] )
+
+ Converts $floating_seconds and $interval_floating_seconds and issues
+ a ualarm for the results. The $interval_floating_seconds argument
+ is optional and will be 0 if unspecified, resulting in alarm-like
+ behaviour. This function can be imported, resulting in a nice drop-in
+ replacement for the C<alarm> provided with perl, see the EXAMPLES below.
+
+ =item setitimer
+
+ S<setitimer ( $which, $floating_seconds [, $interval_floating_seconds ] )>
+
+ Start up an interval timer: after a certain time, a signal is arrives,
+ and more may keep arriving at certain intervals. To disable a timer,
+ use time of zero. If interval is set to zero (or unspecified), the
+ timer is disabled after the next delivered signal.
+
+ Use of interval timers may interfere with alarm(), sleep(), and usleep().
+ In standard-speak the "interaction is unspecified", which means that
+ I<anything> may happen: it may work, it may not.
+
+ In scalar context, the remaining time in the timer is returned.
+
+ In list context, both the remaining time and the interval are returned.
+
+ There are three interval timers: the $which can be ITIMER_REAL,
+ ITIMER_VIRTUAL, or ITIMER_PROF.
+
+ ITIMER_REAL results in alarm()-like behavior. Time is counted in
+ I<real time>, that is, wallclock time. SIGALRM is delivered when
+ the timer expires.
+
+ ITIMER_VIRTUAL counts time in (process) I<virtual time>, that is, only
+ when the process is running. In multiprocessing/user/CPU systems this
+ may be much less than real time. (This time is also known as the
+ I<user time>.) SIGVTALRM is delivered when the timer expires.
+
+ ITIMER_PROF counts time when either the process virtual time or when
+ the operating system is running on behalf of the process (such as
+ I/O). (This time is also known as the I<system time>.) (Collectively
+ these times are also known as the I<CPU time>.) SIGPROF is delivered
+ when the timer expires. SIGPROF can interrupt system calls.
+
+ The semantics of interval timers for multithreaded programs are
+ system-specific, and some systems may support additional interval
+ timers. See your setitimer() documentation.
+
+ =item getitimer ( $which )
+
+ Return the remaining time in the interval timer specified by $which.
+
+ In scalar context, the remaining time is returned.
+
+ In list context, both the remaining time and the interval are returned.
+ The interval is always what you put in using setitimer().
+
+ =back
+
+ =head1 EXAMPLES
+
+ use Time::HiRes qw(usleep ualarm gettimeofday tv_interval);
+
+ $microseconds = 750_000;
+ usleep $microseconds;
+
+ # signal alarm in 2.5s & every .1s thereafter
+ ualarm 2_500_000, 100_000;
+
+ # get seconds and microseconds since the epoch
+ ($s, $usec) = gettimeofday;
+
+ # measure elapsed time
+ # (could also do by subtracting 2 gettimeofday return values)
+ $t0 = [gettimeofday];
+ # do bunch of stuff here
+ $t1 = [gettimeofday];
+ # do more stuff here
+ $t0_t1 = tv_interval $t0, $t1;
+
+ $elapsed = tv_interval ($t0, [gettimeofday]);
+ $elapsed = tv_interval ($t0); # equivalent code
+
+ #
+ # replacements for time, alarm and sleep that know about
+ # floating seconds
+ #
+ use Time::HiRes;
+ $now_fractions = Time::HiRes::time;
+ Time::HiRes::sleep (2.5);
+ Time::HiRes::alarm (10.6666666);
+
+ use Time::HiRes qw ( time alarm sleep );
+ $now_fractions = time;
+ sleep (2.5);
+ alarm (10.6666666);
+
+ # Arm an interval timer to go off first at 10 seconds and
+ # after that every 2.5 seconds, in process virtual time
+
+ use Time::HiRes qw ( setitimer ITIMER_VIRTUAL time );
+
+ $SIG{VTLARM} = sub { print time, "\n" };
+ setitimer(ITIMER_VIRTUAL, 10, 2.5);
+
+ =head1 C API
+
+ In addition to the perl API described above, a C API is available for
+ extension writers. The following C functions are available in the
+ modglobal hash:
+
+ name C prototype
+ --------------- ----------------------
+ Time::NVtime double (*)()
+ Time::U2time void (*)(UV ret[2])
+
+ Both functions return equivalent information (like C<gettimeofday>)
+ but with different representations. The names C<NVtime> and C<U2time>
+ were selected mainly because they are operating system independent.
+ (C<gettimeofday> is Un*x-centric.)
+
+ Here is an example of using NVtime from C:
+
+ double (*myNVtime)();
+ SV **svp = hv_fetch(PL_modglobal, "Time::NVtime", 12, 0);
+ if (!svp) croak("Time::HiRes is required");
+ if (!SvIOK(*svp)) croak("Time::NVtime isn't a function pointer");
+ myNVtime = (double(*)()) SvIV(*svp);
+ printf("The current time is: %f\n", (*myNVtime)());
+
+ =head1 CAVEATS
+
+ Notice that the core time() maybe rounding rather than truncating.
+ What this means that the core time() may be giving time one second
+ later than gettimeofday(), also known as Time::HiRes::time().
+
+ =head1 AUTHORS
+
+ D. Wegscheid <wegscd@whirlpool.com>
+ R. Schertler <roderick@argon.org>
+ J. Hietaniemi <jhi@iki.fi>
+ G. Aas <gisle@aas.no>
+
+ =head1 REVISION
+
+ $Id: HiRes.pm,v 1.20 1999/03/16 02:26:13 wegscd Exp $
+
+ $Log: HiRes.pm,v $
+ Revision 1.20 1999/03/16 02:26:13 wegscd
+ Add documentation for NVTime and U2Time.
+
+ Revision 1.19 1998/09/30 02:34:42 wegscd
+ No changes, bump version.
+
+ Revision 1.18 1998/07/07 02:41:35 wegscd
+ No changes, bump version.
+
+ Revision 1.17 1998/07/02 01:45:13 wegscd
+ Bump version to 1.17
+
+ Revision 1.16 1997/11/13 02:06:36 wegscd
+ version bump to accomodate HiRes.xs fix.
+
+ Revision 1.15 1997/11/11 02:17:59 wegscd
+ POD editing, courtesy of Gisle Aas.
+
+ Revision 1.14 1997/11/06 03:14:35 wegscd
+ Update version # for Makefile.PL and HiRes.xs changes.
+
+ Revision 1.13 1997/11/05 05:36:25 wegscd
+ change version # for Makefile.pl and HiRes.xs changes.
+
+ Revision 1.12 1997/10/13 20:55:33 wegscd
+ Force a new version for Makefile.PL changes.
+
+ Revision 1.11 1997/09/05 19:59:33 wegscd
+ New version to bump version for README and Makefile.PL fixes.
+ Fix bad RCS log.
+
+ Revision 1.10 1997/05/23 01:11:38 wegscd
+ Conditional compilation; EXPORT_FAIL fixes.
+
+ Revision 1.2 1996/12/30 13:28:40 wegscd
+ Update documentation for what to do when missing ualarm() and friends.
+
+ Revision 1.1 1996/10/17 20:53:31 wegscd
+ Fix =head1 being next to __END__ so pod2man works
+
+ Revision 1.0 1996/09/03 18:25:15 wegscd
+ Initial revision
+
+ =head1 COPYRIGHT
+
+ Copyright (c) 1996-1997 Douglas E. Wegscheid.
+ All rights reserved. This program is free software; you can
+ redistribute it and/or modify it under the same terms as Perl itself.
+
+ =cut
diff -c /dev/null 'perl-5.7.2/ext/Time/HiRes/HiRes.t'
Index: ./ext/Time/HiRes/HiRes.t
*** ./ext/Time/HiRes/HiRes.t Thu Jan 1 02:00:00 1970
--- ./ext/Time/HiRes/HiRes.t Mon Jul 9 17:10:16 2001
***************
*** 0 ****
--- 1,219 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ BEGIN { $| = 1; print "1..19\n"; }
+
+ END {print "not ok 1\n" unless $loaded;}
+
+ use Time::HiRes qw(tv_interval);
+
+ $loaded = 1;
+
+ print "ok 1\n";
+
+ use strict;
+
+ my $have_gettimeofday = defined &Time::HiRes::gettimeofday;
+ my $have_usleep = defined &Time::HiRes::usleep;
+ my $have_ualarm = defined &Time::HiRes::ualarm;
+ my $have_time = defined &Time::HiRes::time;
+
+ import Time::HiRes 'gettimeofday' if $have_gettimeofday;
+ import Time::HiRes 'usleep' if $have_usleep;
+ import Time::HiRes 'ualarm' if $have_ualarm;
+
+ use Config;
+
+ sub skip {
+ map { print "ok $_ (skipped)\n" } @_;
+ }
+
+ sub ok {
+ my ($n, $result, @info) = @_;
+ if ($result) {
+ print "ok $n\n";
+ }
+ else {
+ print "not ok $n\n";
+ print "# @info\n" if @info;
+ }
+ }
+
+ if (!$have_gettimeofday) {
+ skip 2..6;
+ }
+ else {
+ my @one = gettimeofday();
+ ok 2, @one == 2, 'gettimeofday returned ', 0+@one, ' args';
+ ok 3, $one[0] > 850_000_000, "@one too small";
+
+ sleep 1;
+
+ my @two = gettimeofday();
+ ok 4, ($two[0] > $one[0] || ($two[0] == $one[0] && $two[1] > $one[1])),
+ "@two is not greater than @one";
+
+ my $f = Time::HiRes::time();
+ ok 5, $f > 850_000_000, "$f too small";
+ ok 6, $f - $two[0] < 2, "$f - @two >= 2";
+ }
+
+ if (!$have_usleep) {
+ skip 7..8;
+ }
+ else {
+ my $one = time;
+ usleep(10_000);
+ my $two = time;
+ usleep(10_000);
+ my $three = time;
+ ok 7, $one == $two || $two == $three, "slept too long, $one $two $three";
+
+ if (!$have_gettimeofday) {
+ skip 8;
+ }
+ else {
+ my $f = Time::HiRes::time();
+ usleep(500_000);
+ my $f2 = Time::HiRes::time();
+ my $d = $f2 - $f;
+ ok 8, $d > 0.4 && $d < 0.8, "slept $d secs $f to $f2";
+ }
+ }
+
+ # Two-arg tv_interval() is always available.
+ {
+ my $f = tv_interval [5, 100_000], [10, 500_000];
+ ok 9, $f == 5.4, $f;
+ }
+
+ if (!$have_gettimeofday) {
+ skip 10;
+ }
+ else {
+ my $r = [gettimeofday()];
+ my $f = tv_interval $r;
+ ok 10, $f < 2, $f;
+ }
+
+ if (!$have_usleep || !$have_gettimeofday) {
+ skip 11;
+ }
+ else {
+ my $r = [gettimeofday()];
+ #jTime::HiRes::sleep 0.5;
+ Time::HiRes::sleep( 0.5 );
+ my $f = tv_interval $r;
+ ok 11, $f > 0.4 && $f < 0.8, "slept $f secs";
+ }
+
+ if (!$have_ualarm) {
+ skip 12..13;
+ }
+ else {
+ my $tick = 0;
+ local $SIG{ALRM} = sub { $tick++ };
+
+ my $one = time; $tick = 0; ualarm(10_000); sleep until $tick;
+ my $two = time; $tick = 0; ualarm(10_000); sleep until $tick;
+ my $three = time;
+ ok 12, $one == $two || $two == $three, "slept too long, $one $two $three";
+
+ $tick = 0;
+ ualarm(10_000, 10_000);
+ sleep until $tick >= 3;
+ ok 13, 1;
+ ualarm(0);
+ }
+
+ # new test: did we even get close?
+
+ if (!$have_time) {
+ skip 14
+ } else {
+ my $t = time();
+ my $tf = Time::HiRes::time();
+ ok 14, (abs($tf - $t) <= 1),
+ "time $t differs from Time::HiRes::time $tf";
+ }
+
+ unless (defined &Time::HiRes::gettimeofday
+ && defined &Time::HiRes::ualarm
+ && defined &Time::HiRes::usleep) {
+ for (15..17) {
+ print "ok $_ # skipped\n";
+ }
+ } else {
+ use Time::HiRes qw (time alarm sleep);
+
+ my ($f, $r, $i);
+
+ print "# time...";
+ $f = time;
+ print "$f\nok 15\n";
+
+ print "# sleep...";
+ $r = [Time::HiRes::gettimeofday()];
+ sleep (0.5);
+ print Time::HiRes::tv_interval($r), "\nok 16\n";
+
+ $r = [Time::HiRes::gettimeofday()];
+ $i = 5;
+ $SIG{ALRM} = "tick";
+ while ($i)
+ {
+ alarm(0.3);
+ select (undef, undef, undef, 10);
+ print "# Select returned! $i ", Time::HiRes::tv_interval ($r), "\n";
+ }
+
+ sub tick
+ {
+ $i--;
+ print "# Tick! $i ", Time::HiRes::tv_interval ($r), "\n";
+ }
+ $SIG{ALRM} = 'DEFAULT';
+
+ print "ok 17\n";
+ }
+
+ unless (defined &Time::HiRes::setitimer
+ && defined &Time::HiRes::getitimer
+ && exists &Time::HiRes::ITIMER_VIRTUAL
+ && $Config{d_select}) {
+ for (18..19) {
+ print "ok $_ # Skip: no virtual interval timers\n";
+ }
+ } else {
+ use Time::HiRes qw (setitimer getitimer ITIMER_VIRTUAL);
+
+ my $i = 3;
+ my $r = [Time::HiRes::gettimeofday()];
+
+ $SIG{VTALRM} = sub {
+ $i ? $i-- : setitimer(ITIMER_VIRTUAL, 0);
+ print "# Tick! $i ", Time::HiRes::tv_interval($r), "\n";
+ };
+
+ print "# setitimer: ", join(" ", setitimer(ITIMER_VIRTUAL, 0.5, 0.4)), "\n";
+
+ # Assume interval timer granularity of 0.05 seconds. Too bold?
+ print "not " unless abs(getitimer(ITIMER_VIRTUAL) / 0.5) - 1 < 0.1;
+ print "ok 18\n";
+
+ print "# getitimer: ", join(" ", getitimer(ITIMER_VIRTUAL)), "\n";
+
+ while (getitimer(ITIMER_VIRTUAL)) {
+ my $j; $j++ for 1..1000; # Can't be unbreakable, must test getitimer().
+ }
+
+ print "# getitimer: ", join(" ", getitimer(ITIMER_VIRTUAL)), "\n";
+
+ print "not " unless getitimer(ITIMER_VIRTUAL) == 0;
+ print "ok 19\n";
+
+ $SIG{VTALRM} = 'DEFAULT';
+ }
+
diff -c /dev/null 'perl-5.7.2/ext/Time/HiRes/HiRes.xs'
Index: ./ext/Time/HiRes/HiRes.xs
*** ./ext/Time/HiRes/HiRes.xs Thu Jan 1 02:00:00 1970
--- ./ext/Time/HiRes/HiRes.xs Mon Jul 9 17:10:16 2001
***************
*** 0 ****
--- 1,423 ----
+ #ifdef __cplusplus
+ extern "C" {
+ #endif
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+ #ifdef WIN32
+ #include <time.h>
+ #else
+ #include <sys/time.h>
+ #endif
+ #ifdef __cplusplus
+ }
+ #endif
+
+ static IV
+ constant(char *name, int arg)
+ {
+ errno = 0;
+ switch (*name) {
+ case 'I':
+ if (strEQ(name, "ITIMER_REAL"))
+ #ifdef ITIMER_REAL
+ return ITIMER_REAL;
+ #else
+ goto not_there;
+ #endif
+ if (strEQ(name, "ITIMER_REALPROF"))
+ #ifdef ITIMER_REALPROF
+ return ITIMER_REALPROF;
+ #else
+ goto not_there;
+ #endif
+ if (strEQ(name, "ITIMER_VIRTUAL"))
+ #ifdef ITIMER_VIRTUAL
+ return ITIMER_VIRTUAL;
+ #else
+ goto not_there;
+ #endif
+ if (strEQ(name, "ITIMER_PROF"))
+ #ifdef ITIMER_PROF
+ return ITIMER_PROF;
+ #else
+ goto not_there;
+ #endif
+ break;
+ }
+ errno = EINVAL;
+ return 0;
+
+ not_there:
+ errno = ENOENT;
+ return 0;
+ }
+
+ #if !defined(HAS_GETTIMEOFDAY) && defined(WIN32)
+ #define HAS_GETTIMEOFDAY
+
+ /* shows up in winsock.h?
+ struct timeval {
+ long tv_sec;
+ long tv_usec;
+ }
+ */
+
+ int
+ gettimeofday (struct timeval *tp, int nothing)
+ {
+ SYSTEMTIME st;
+ time_t tt;
+ struct tm tmtm;
+ /* mktime converts local to UTC */
+ GetLocalTime (&st);
+ tmtm.tm_sec = st.wSecond;
+ tmtm.tm_min = st.wMinute;
+ tmtm.tm_hour = st.wHour;
+ tmtm.tm_mday = st.wDay;
+ tmtm.tm_mon = st.wMonth - 1;
+ tmtm.tm_year = st.wYear - 1900;
+ tmtm.tm_isdst = -1;
+ tt = mktime (&tmtm);
+ tp->tv_sec = tt;
+ tp->tv_usec = st.wMilliseconds * 1000;
+ return 0;
+ }
+ #endif
+
+ #if !defined(HAS_GETTIMEOFDAY) && defined(VMS)
+ #define HAS_GETTIMEOFDAY
+
+ #include <time.h> /* gettimeofday */
+ #include <stdlib.h> /* qdiv */
+ #include <starlet.h> /* sys$gettim */
+ #include <descrip.h>
+ #ifdef __VAX
+ #include <lib$routines.h> /* lib$ediv() */
+ #endif
+
+ /*
+ VMS binary time is expressed in 100 nano-seconds since
+ system base time which is 17-NOV-1858 00:00:00.00
+ */
+
+ #define DIV_100NS_TO_SECS 10000000L
+ #define DIV_100NS_TO_USECS 10L
+
+ /*
+ gettimeofday is supposed to return times since the epoch
+ so need to determine this in terms of VMS base time
+ */
+ static $DESCRIPTOR(dscepoch,"01-JAN-1970 00:00:00.00");
+
+ #ifdef __VAX
+ static long base_adjust[2]={0L,0L};
+ #else
+ static __int64 base_adjust=0;
+ #endif
+
+ int
+ gettimeofday (struct timeval *tp, void *tpz)
+ {
+ long ret;
+ #ifdef __VAX
+ long quad[2];
+ long quad1[2];
+ long div_100ns_to_secs;
+ long div_100ns_to_usecs;
+ long quo,rem;
+ long quo1,rem1;
+ #else
+ __int64 quad;
+ __qdiv_t ans1,ans2;
+ #endif
+ /*
+ In case of error, tv_usec = 0 and tv_sec = VMS condition code.
+ The return from function is also set to -1.
+ This is not exactly as per the manual page.
+ */
+
+ tp->tv_usec = 0;
+
+ #ifdef __VAX
+ if (base_adjust[0]==0 && base_adjust[1]==0) {
+ #else
+ if (base_adjust==0) { /* Need to determine epoch adjustment */
+ #endif
+ ret=sys$bintim(&dscepoch,&base_adjust);
+ if (1 != (ret &&1)) {
+ tp->tv_sec = ret;
+ return -1;
+ }
+ }
+
+ ret=sys$gettim(&quad); /* Get VMS system time */
+ if ((1 && ret) == 1) {
+ #ifdef __VAX
+ quad[0] -= base_adjust[0]; /* convert to epoch offset */
+ quad[1] -= base_adjust[1]; /* convert 2nd half of quadword */
+ div_100ns_to_secs = DIV_100NS_TO_SECS;
+ div_100ns_to_usecs = DIV_100NS_TO_USECS;
+ lib$ediv(&div_100ns_to_secs,&quad,&quo,&rem);
+ quad1[0] = rem;
+ quad1[1] = 0L;
+ lib$ediv(&div_100ns_to_usecs,&quad1,&quo1,&rem1);
+ tp->tv_sec = quo; /* Whole seconds */
+ tp->tv_usec = quo1; /* Micro-seconds */
+ #else
+ quad -= base_adjust; /* convert to epoch offset */
+ ans1=qdiv(quad,DIV_100NS_TO_SECS);
+ ans2=qdiv(ans1.rem,DIV_100NS_TO_USECS);
+ tp->tv_sec = ans1.quot; /* Whole seconds */
+ tp->tv_usec = ans2.quot; /* Micro-seconds */
+ #endif
+ } else {
+ tp->tv_sec = ret;
+ return -1;
+ }
+ return 0;
+ }
+ #endif
+
+ #if !defined(HAS_USLEEP) && defined(HAS_SELECT)
+ #ifndef SELECT_IS_BROKEN
+ #define HAS_USLEEP
+ #define usleep hrt_usleep /* could conflict with ncurses for static build */
+
+ void
+ hrt_usleep(unsigned long usec)
+ {
+ struct timeval tv;
+ tv.tv_sec = 0;
+ tv.tv_usec = usec;
+ select(0, (Select_fd_set_t)NULL, (Select_fd_set_t)NULL,
+ (Select_fd_set_t)NULL, &tv);
+ }
+ #endif
+ #endif
+
+ #if !defined(HAS_USLEEP) && defined(WIN32)
+ #define HAS_USLEEP
+ #define usleep hrt_usleep /* could conflict with ncurses for static build */
+
+ void
+ hrt_usleep(unsigned long usec)
+ {
+ long msec;
+ msec = usec / 1000;
+ Sleep (msec);
+ }
+ #endif
+
+
+ #if !defined(HAS_UALARM) && defined(HAS_SETITIMER)
+ #define HAS_UALARM
+ #define ualarm hrt_ualarm /* could conflict with ncurses for static build */
+
+ int
+ hrt_ualarm(int usec, int interval)
+ {
+ struct itimerval itv;
+ itv.it_value.tv_sec = usec / 1000000;
+ itv.it_value.tv_usec = usec % 1000000;
+ itv.it_interval.tv_sec = interval / 1000000;
+ itv.it_interval.tv_usec = interval % 1000000;
+ return setitimer(ITIMER_REAL, &itv, 0);
+ }
+ #endif
+
+ #ifdef HAS_GETTIMEOFDAY
+
+ static int
+ myU2time(UV *ret)
+ {
+ struct timeval Tp;
+ int status;
+ status = gettimeofday (&Tp, NULL);
+ ret[0] = Tp.tv_sec;
+ ret[1] = Tp.tv_usec;
+ return status;
+ }
+
+ static NV
+ myNVtime()
+ {
+ struct timeval Tp;
+ int status;
+ status = gettimeofday (&Tp, NULL);
+ return status == 0 ? Tp.tv_sec + (Tp.tv_usec / 1000000.) : -1.0;
+ }
+
+ #endif
+
+ MODULE = Time::HiRes PACKAGE = Time::HiRes
+
+ PROTOTYPES: ENABLE
+
+ BOOT:
+ #ifdef HAS_GETTIMEOFDAY
+ {
+ UV auv[2];
+ hv_store(PL_modglobal, "Time::NVtime", 12, newSViv((IV) myNVtime()), 0);
+ if (myU2time(auv) == 0)
+ hv_store(PL_modglobal, "Time::U2time", 12, newSViv((IV) auv[0]), 0);
+ }
+ #endif
+
+ IV
+ constant(name, arg)
+ char * name
+ int arg
+
+ #ifdef HAS_USLEEP
+
+ void
+ usleep(useconds)
+ int useconds
+
+ void
+ sleep(fseconds)
+ NV fseconds
+ CODE:
+ int useconds = fseconds * 1000000;
+ usleep (useconds);
+
+ #endif
+
+ #ifdef HAS_UALARM
+
+ int
+ ualarm(useconds,interval=0)
+ int useconds
+ int interval
+
+ int
+ alarm(fseconds,finterval=0)
+ NV fseconds
+ NV finterval
+ PREINIT:
+ int useconds, uinterval;
+ CODE:
+ useconds = fseconds * 1000000;
+ uinterval = finterval * 1000000;
+ RETVAL = ualarm (useconds, uinterval);
+
+ OUTPUT:
+ RETVAL
+
+ #endif
+
+ #ifdef HAS_GETTIMEOFDAY
+
+ void
+ gettimeofday()
+ PREINIT:
+ struct timeval Tp;
+ PPCODE:
+ int status;
+ status = gettimeofday (&Tp, NULL);
+ if (GIMME == G_ARRAY) {
+ EXTEND(sp, 2);
+ PUSHs(sv_2mortal(newSViv(Tp.tv_sec)));
+ PUSHs(sv_2mortal(newSViv(Tp.tv_usec)));
+ } else {
+ EXTEND(sp, 1);
+ PUSHs(sv_2mortal(newSVnv(Tp.tv_sec + (Tp.tv_usec / 1000000.0))));
+ }
+
+ NV
+ time()
+ PREINIT:
+ struct timeval Tp;
+ CODE:
+ int status;
+ status = gettimeofday (&Tp, NULL);
+ RETVAL = Tp.tv_sec + (Tp.tv_usec / 1000000.);
+ OUTPUT:
+ RETVAL
+
+ #endif
+
+ #if defined(HAS_GETITIMER) && defined(HAS_SETITIMER)
+
+ #define TV2NV(tv) ((NV)((tv).tv_sec) + 0.000001 * (NV)((tv).tv_usec))
+
+ void
+ setitimer(which, seconds, interval = 0)
+ int which
+ NV seconds
+ NV interval
+ PREINIT:
+ struct itimerval newit;
+ struct itimerval oldit;
+ PPCODE:
+ newit.it_value.tv_sec = seconds;
+ newit.it_value.tv_usec =
+ (seconds - (NV)newit.it_value.tv_sec) * 1000000.0;
+ newit.it_interval.tv_sec = interval;
+ newit.it_interval.tv_usec =
+ (interval - (NV)newit.it_interval.tv_sec) * 1000000.0;
+ if (setitimer(which, &newit, &oldit) == 0) {
+ EXTEND(sp, 1);
+ PUSHs(sv_2mortal(newSVnv(TV2NV(oldit.it_value))));
+ if (GIMME == G_ARRAY) {
+ EXTEND(sp, 1);
+ PUSHs(sv_2mortal(newSVnv(TV2NV(oldit.it_interval))));
+ }
+ }
+
+ void
+ getitimer(which)
+ int which
+ PREINIT:
+ struct itimerval nowit;
+ PPCODE:
+ if (getitimer(which, &nowit) == 0) {
+ EXTEND(sp, 1);
+ PUSHs(sv_2mortal(newSVnv(TV2NV(nowit.it_value))));
+ if (GIMME == G_ARRAY) {
+ EXTEND(sp, 1);
+ PUSHs(sv_2mortal(newSVnv(TV2NV(nowit.it_interval))));
+ }
+ }
+
+ #endif
+
+ # $Id: HiRes.xs,v 1.11 1999/03/16 02:27:38 wegscd Exp wegscd $
+
+ # $Log: HiRes.xs,v $
+ # Revision 1.11 1999/03/16 02:27:38 wegscd
+ # Add U2time, NVtime. Fix symbols for static link.
+ #
+ # Revision 1.10 1998/09/30 02:36:25 wegscd
+ # Add VMS changes.
+ #
+ # Revision 1.9 1998/07/07 02:42:06 wegscd
+ # Win32 usleep()
+ #
+ # Revision 1.8 1998/07/02 01:47:26 wegscd
+ # Add Win32 code for gettimeofday.
+ #
+ # Revision 1.7 1997/11/13 02:08:12 wegscd
+ # Add missing EXTEND in gettimeofday() scalar code.
+ #
+ # Revision 1.6 1997/11/11 02:32:35 wegscd
+ # Do something useful when calling gettimeofday() in a scalar context.
+ # The patch is courtesy of Gisle Aas.
+ #
+ # Revision 1.5 1997/11/06 03:10:47 wegscd
+ # Fake ualarm() if we have setitimer.
+ #
+ # Revision 1.4 1997/11/05 05:41:23 wegscd
+ # Turn prototypes ON (suggested by Gisle Aas)
+ #
+ # Revision 1.3 1997/10/13 20:56:15 wegscd
+ # Add PROTOTYPES: DISABLE
+ #
+ # Revision 1.2 1997/05/23 01:01:38 wegscd
+ # Conditional compilation, depending on what the OS gives us.
+ #
+ # Revision 1.1 1996/09/03 18:26:35 wegscd
+ # Initial revision
+ #
+ #
diff -c /dev/null 'perl-5.7.2/ext/Time/HiRes/Makefile.PL'
Index: ./ext/Time/HiRes/Makefile.PL
*** ./ext/Time/HiRes/Makefile.PL Thu Jan 1 02:00:00 1970
--- ./ext/Time/HiRes/Makefile.PL Mon Jul 9 17:10:16 2001
***************
*** 0 ****
--- 1,13 ----
+ # See lib/ExtUtils/MakeMaker.pm for details of how to influence
+ # the contents of the Makefile that is written.
+ #
+
+ use strict;
+ use ExtUtils::MakeMaker;
+
+ WriteMakefile(
+ 'NAME' => 'Time::HiRes',
+ MAN3PODS => {}, # Pods will be built by installman.
+ 'VERSION_FROM' => 'HiRes.pm',
+ );
+
diff -c /dev/null 'perl-5.7.2/ext/Time/HiRes/hints/dynixptx.pl'
Index: ./ext/Time/HiRes/hints/dynixptx.pl
*** ./ext/Time/HiRes/hints/dynixptx.pl Thu Jan 1 02:00:00 1970
--- ./ext/Time/HiRes/hints/dynixptx.pl Wed Jul 11 04:34:34 2001
***************
*** 0 ****
--- 1,5 ----
+ # uname -v
+ # V4.5.2
+ # needs to explicitly link against libc to pull in usleep
+ $self->{LIBS} = ['-lc'];
+
diff -c /dev/null 'perl-5.7.2/ext/Time/HiRes/hints/sco.pl'
Index: ./ext/Time/HiRes/hints/sco.pl
*** ./ext/Time/HiRes/hints/sco.pl Thu Jan 1 02:00:00 1970
--- ./ext/Time/HiRes/hints/sco.pl Mon Jul 9 17:10:16 2001
***************
*** 0 ****
--- 1,3 ----
+ # osr5 needs to explicitly link against libc to pull in usleep
+ $self->{LIBS} = ['-lc'];
+
diff -c /dev/null 'perl-5.7.2/ext/Time/Piece/Makefile.PL'
Index: ./ext/Time/Piece/Makefile.PL
*** ./ext/Time/Piece/Makefile.PL Thu Jan 1 02:00:00 1970
--- ./ext/Time/Piece/Makefile.PL Mon Jul 9 17:10:16 2001
***************
*** 0 ****
--- 1,7 ----
+ use ExtUtils::MakeMaker;
+
+ WriteMakefile(
+ 'NAME' => 'Time::Piece',
+ MAN3PODS => {}, # Pods will be built by installman.
+ 'VERSION_FROM' => 'Piece.pm',
+ );
diff -c /dev/null 'perl-5.7.2/ext/Time/Piece/Piece.pm'
Index: ./ext/Time/Piece/Piece.pm
*** ./ext/Time/Piece/Piece.pm Thu Jan 1 02:00:00 1970
--- ./ext/Time/Piece/Piece.pm Mon Jul 9 17:10:16 2001
***************
*** 0 ****
--- 1,1326 ----
+ package Time::Piece;
+
+ use strict;
+ use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+ require Exporter;
+ require DynaLoader;
+ use Time::Seconds;
+ use Carp;
+
+ @ISA = qw(Exporter DynaLoader);
+
+ @EXPORT = qw(
+ localtime
+ gmtime
+ );
+
+ @EXPORT_OK = qw(
+ strptime
+ );
+
+ %EXPORT_TAGS = (
+ ':override' => 'internal',
+ );
+
+ $VERSION = '0.13';
+
+ bootstrap Time::Piece $VERSION;
+
+ my $DATE_SEP = '-';
+ my $TIME_SEP = ':';
+ my @MON_NAMES = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
+ my @WDAY_NAMES = qw(Sun Mon Tue Wed Thu Fri Sat);
+ my @MONTH_NAMES = qw(January February March April May June
+ July August September October Novemeber December);
+ my @WEEKDAY_NAMES = qw(Sunday Monday Tuesday Wednesday
+ Thursday Friday Saturday);
+
+ use constant 'c_sec' => 0;
+ use constant 'c_min' => 1;
+ use constant 'c_hour' => 2;
+ use constant 'c_mday' => 3;
+ use constant 'c_mon' => 4;
+ use constant 'c_year' => 5;
+ use constant 'c_wday' => 6;
+ use constant 'c_yday' => 7;
+ use constant 'c_isdst' => 8;
+ use constant 'c_epoch' => 9;
+ use constant 'c_islocal' => 10;
+
+ sub localtime {
+ my $time = shift;
+ $time = time if (!defined $time);
+ _mktime($time, 1);
+ }
+
+ sub gmtime {
+ my $time = shift;
+ $time = time if (!defined $time);
+ _mktime($time, 0);
+ }
+
+ sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $time = shift;
+
+ my $self;
+
+ if (defined($time)) {
+ $self = &localtime($time);
+ }
+ elsif (ref($proto) && $proto->isa('Time::Piece')) {
+ $self = _mktime($proto->[c_epoch], $proto->[c_islocal]);
+ }
+ else {
+ $self = &localtime();
+ }
+
+ return bless $self, $class;
+ }
+
+ sub _mktime {
+ my ($time, $islocal) = @_;
+ my @time = $islocal ?
+ CORE::localtime($time)
+ :
+ CORE::gmtime($time);
+ wantarray ? @time : bless [@time, $time, $islocal], 'Time::Piece';
+ }
+
+ sub import {
+ # replace CORE::GLOBAL localtime and gmtime if required
+ my $class = shift;
+ my %params;
+ map($params{$_}++,@_,@EXPORT);
+ if (delete $params{':override'}) {
+ $class->export('CORE::GLOBAL', keys %params);
+ }
+ else {
+ $class->export((caller)[0], keys %params);
+ }
+ }
+
+ ## Methods ##
+
+ sub s {
+ my $time = shift;
+ $time->[c_sec];
+ }
+
+ *sec = \&s;
+ *second = \&s;
+
+ sub min {
+ my $time = shift;
+ $time->[c_min];
+ }
+
+ *minute = \&min;
+
+ sub h {
+ my $time = shift;
+ $time->[c_hour];
+ }
+
+ *hour = \&h;
+
+ sub d {
+ my $time = shift;
+ $time->[c_mday];
+ }
+
+ *mday = \&d;
+ *day_of_month = \&d;
+
+ sub mon {
+ my $time = shift;
+ $time->[c_mon] + 1;
+ }
+
+ sub _mon {
+ my $time = shift;
+ $time->[c_mon];
+ }
+
+ sub has_mon_names {
+ my $time = shift;
+ return 0;
+ }
+
+ sub monname {
+ my $time = shift;
+ if (@_) {
+ return $_[$time->[c_mon]];
+ }
+ elsif ($time->has_mon_names) {
+ return $time->mon_name($time->[c_mon]);
+ }
+ return $MON_NAMES[$time->[c_mon]];
+ }
+
+ sub has_month_names {
+ my $time = shift;
+ return 0;
+ }
+
+ sub monthname {
+ my $time = shift;
+ if (@_) {
+ return $_[$time->[c_mon]];
+ }
+ elsif ($time->has_month_names) {
+ return $time->month_name($time->[c_mon]);
+ }
+ return $MONTH_NAMES[$time->[c_mon]];
+ }
+
+ *month = \&monthname;
+
+ sub y {
+ my $time = shift;
+ $time->[c_year] + 1900;
+ }
+
+ *year = \&y;
+
+ sub _year {
+ my $time = shift;
+ $time->[c_year];
+ }
+
+ sub wday {
+ my $time = shift;
+ $time->[c_wday] + 1;
+ }
+
+ sub _wday {
+ my $time = shift;
+ $time->[c_wday];
+ }
+
+ *day_of_week = \&_wday;
+
+ sub has_wday_names {
+ my $time = shift;
+ return 0;
+ }
+
+ sub wdayname {
+ my $time = shift;
+ if (@_) {
+ return $_[$time->[c_wday]];
+ }
+ elsif ($time->has_wday_names) {
+ return $time->wday_name($time->[c_mon]);
+ }
+ return $WDAY_NAMES[$time->[c_wday]];
+ }
+
+ sub has_weekday_names {
+ my $time = shift;
+ return 0;
+ }
+
+ sub weekdayname {
+ my $time = shift;
+ if (@_) {
+ return $_[$time->[c_wday]];
+ }
+ elsif ($time->has_weekday_names) {
+ return $time->weekday_name($time->[c_mon]);
+ }
+ return $WEEKDAY_NAMES[$time->[c_wday]];
+ }
+
+ *weekdayname = \&weekdayname;
+ *weekday = \&weekdayname;
+
+ sub yday {
+ my $time = shift;
+ $time->[c_yday];
+ }
+
+ *day_of_year = \&yday;
+
+ sub isdst {
+ my $time = shift;
+ $time->[c_isdst];
+ }
+
+ *daylight_savings = \&isdst;
+
+ # Thanks to Tony Olekshy <olekshy@cs.ualberta.ca> for this algorithm
+ sub tzoffset {
+ my $time = shift;
+
+ my $epoch = $time->[c_epoch];
+
+ my $j = sub { # Tweaked Julian day number algorithm.
+
+ my ($s,$n,$h,$d,$m,$y) = @_; $m += 1; $y += 1900;
+
+ # Standard Julian day number algorithm without constant.
+ #
+ my $y1 = $m > 2 ? $y : $y - 1;
+
+ my $m1 = $m > 2 ? $m + 1 : $m + 13;
+
+ my $day = int(365.25 * $y1) + int(30.6001 * $m1) + $d;
+
+ # Modify to include hours/mins/secs in floating portion.
+ #
+ return $day + ($h + ($n + $s / 60) / 60) / 24;
+ };
+
+ # Compute floating offset in hours.
+ #
+ my $delta = 24 * (&$j(CORE::localtime $epoch) - &$j(CORE::gmtime $epoch));
+
+ # Return value in seconds rounded to nearest minute.
+ return Time::Seconds->new( int($delta * 60 + ($delta >= 0 ? 0.5 : -0.5)) * 60);
+ }
+
+ sub epoch {
+ my $time = shift;
+ $time->[c_epoch];
+ }
+
+ sub hms {
+ my $time = shift;
+ my $sep = @_ ? shift(@_) : $TIME_SEP;
+ sprintf("%02d$sep%02d$sep%02d", $time->[c_hour], $time->[c_min], $time->[c_sec]);
+ }
+
+ *time = \&hms;
+
+ sub ymd {
+ my $time = shift;
+ my $sep = @_ ? shift(@_) : $DATE_SEP;
+ sprintf("%d$sep%02d$sep%02d", $time->year, $time->mon, $time->[c_mday]);
+ }
+
+ *date = \&ymd;
+
+ sub mdy {
+ my $time = shift;
+ my $sep = @_ ? shift(@_) : $DATE_SEP;
+ sprintf("%02d$sep%02d$sep%d", $time->mon, $time->[c_mday], $time->year);
+ }
+
+ sub dmy {
+ my $time = shift;
+ my $sep = @_ ? shift(@_) : $DATE_SEP;
+ sprintf("%02d$sep%02d$sep%d", $time->[c_mday], $time->mon, $time->year);
+ }
+
+ sub datetime {
+ my $time = shift;
+ my %seps = (date => $DATE_SEP, T => 'T', time => $TIME_SEP, @_);
+ return join($seps{T}, $time->date($seps{date}), $time->time($seps{time}));
+ }
+
+ # taken from Time::JulianDay
+ sub julian_day {
+ my $time = shift;
+ my ($year, $month, $day) = ($time->year, $time->mon, $time->mday);
+ my ($tmp, $secs);
+
+ $tmp = $day - 32075
+ + 1461 * ( $year + 4800 - ( 14 - $month ) / 12 )/4
+ + 367 * ( $month - 2 + ( ( 14 - $month ) / 12 ) * 12 ) / 12
+ - 3 * ( ( $year + 4900 - ( 14 - $month ) / 12 ) / 100 ) / 4
+ ;
+
+ return $tmp;
+ }
+
+ # Hi Mark-Jason!
+ sub mjd {
+ return shift->julian_day - 2_400_000.5;
+ }
+
+ sub week {
+ # taken from the Calendar FAQ
+ use integer;
+ my $J = shift->julian_day;
+ my $d4 = ((($J + 31741 - ($J % 7)) % 146097) % 36524) % 1461;
+ my $L = $d4 / 1460;
+ my $d1 = (($d4 - $L) % 365) + $L;
+ return $d1 / 7 + 1;
+ }
+
+ sub _is_leap_year {
+ my $year = shift;
+ return (($year %4 == 0) && !($year % 100 == 0)) || ($year % 400 == 0)
+ ? 1 : 0;
+ }
+
+ sub is_leap_year {
+ my $time = shift;
+ my $year = $time->year;
+ return _is_leap_year($year);
+ }
+
+ my @MON_LAST = qw(31 28 31 30 31 30 31 31 30 31 30 31);
+
+ sub month_last_day {
+ my $time = shift;
+ my $year = $time->year;
+ my $_mon = $time->_mon;
+ return $MON_LAST[$_mon] + ($_mon == 1 ? _is_leap_year($year) : 0);
+ }
+
+ use vars qw($_ftime);
+
+ $_ftime =
+ {
+ '%' => sub {
+ return "%";
+ },
+ 'a' => sub {
+ my ($format, $time) = @_;
+ $time->wdayname();
+ },
+ 'A' => sub {
+ my ($format, $time) = @_;
+ $time->weekdayname();
+ },
+ 'b' => sub {
+ my ($format, $time) = @_;
+ $time->monname();
+ },
+ 'B' => sub {
+ my ($format, $time) = @_;
+ $time->monthname();
+ },
+ 'c' => sub {
+ my ($format, $time) = @_;
+ $time->cdate();
+ },
+ 'C' => sub {
+ my ($format, $time) = @_;
+ sprintf("%02d", int($time->y() / 100));
+ },
+ 'd' => sub {
+ my ($format, $time) = @_;
+ sprintf("%02d", $time->d());
+ },
+ 'D' => sub {
+ my ($format, $time) = @_;
+ join("/",
+ $_ftime->{'m'}->('m', $time),
+ $_ftime->{'d'}->('d', $time),
+ $_ftime->{'y'}->('y', $time));
+ },
+ 'e' => sub {
+ my ($format, $time) = @_;
+ sprintf("%2d", $time->d());
+ },
+ 'h' => sub {
+ my ($format, $time, @rest) = @_;
+ $time->monname(@rest);
+ },
+ 'H' => sub {
+ my ($format, $time) = @_;
+ sprintf("%02d", $time->h());
+ },
+ 'I' => sub {
+ my ($format, $time) = @_;
+ my $h = $time->h();
+ sprintf("%02d", $h == 0 ? 12 : ($h < 13 ? $h : $h % 12));
+ },
+ 'j' => sub {
+ my ($format, $time) = @_;
+ sprintf("%03d", $time->yday());
+ },
+ 'm' => sub {
+ my ($format, $time) = @_;
+ sprintf("%02d", $time->mon());
+ },
+ 'M' => sub {
+ my ($format, $time) = @_;
+ sprintf("%02d", $time->min());
+ },
+ 'n' => sub {
+ return "\n";
+ },
+ 'p' => sub {
+ my ($format, $time) = @_;
+ my $h = $time->h();
+ $h == 0 ? 'pm' : ($h < 13 ? 'am' : 'pm');
+ },
+ 'r' => sub {
+ my ($format, $time) = @_;
+ join(":",
+ $_ftime->{'I'}->('I', $time),
+ $_ftime->{'M'}->('M', $time),
+ $_ftime->{'S'}->('S', $time)) .
+ " " . $_ftime->{'p'}->('p', $time);
+ },
+ 'R' => sub {
+ my ($format, $time) = @_;
+ join(":",
+ $_ftime->{'H'}->('H', $time),
+ $_ftime->{'M'}->('M', $time));
+ },
+ 'S' => sub {
+ my ($format, $time) = @_;
+ sprintf("%02d", $time->s());
+ },
+ 't' => sub {
+ return "\t";
+ },
+ 'T' => sub {
+ my ($format, $time) = @_;
+ join(":",
+ $_ftime->{'H'}->('H', $time),
+ $_ftime->{'M'}->('M', $time),
+ $_ftime->{'S'}->('S', $time));
+ },
+ 'u' => sub {
+ my ($format, $time) = @_;
+ ($time->wday() + 5) % 7 + 1;
+ },
+ # U taken care by libc
+ 'V' => sub {
+ my ($format, $time) = @_;
+ sprintf("%02d", $time->week());
+ },
+ 'w' => sub {
+ my ($format, $time) = @_;
+ $time->_wday();
+ },
+ # W taken care by libc
+ 'x' => sub {
+ my ($format, $time) = @_;
+ join("/",
+ $_ftime->{'m'}->('m', $time),
+ $_ftime->{'d'}->('d', $time),
+ $_ftime->{'y'}->('y', $time));
+ },
+ 'y' => sub {
+ my ($format, $time) = @_;
+ sprintf("%02d", $time->y() % 100);
+ },
+ 'Y' => sub {
+ my ($format, $time) = @_;
+ sprintf("%4d", $time->y());
+ },
+ # Z taken care by libc
+ };
+
+ sub has_ftime {
+ my ($format) = @_;
+ exists $_ftime->{$format};
+ }
+
+ sub has_ftimes {
+ keys %$_ftime;
+ }
+
+ sub delete_ftime {
+ delete $_ftime->{@_};
+ }
+
+ sub ftime {
+ my ($format) = $_[0];
+ if (@_ == 1) {
+ return $_ftime->{$format};
+ } elsif (@_ == 2) {
+ if (ref $_[0] eq 'CODE') {
+ $_ftime->{$format} = $_[1];
+ } else {
+ require Carp;
+ Carp::croak "ftime: second argument not a code ref";
+ }
+ } else {
+ require Carp;
+ Carp::croak "ftime: want one or two arguments";
+ }
+ }
+
+ sub _ftime {
+ my ($format, $time, @rest) = @_;
+ if (has_ftime($format)) {
+ # We are passing format to the anonsubs so that
+ # one can share the same sub among several formats.
+ return $_ftime->{$format}->($format, $time, @rest);
+ }
+ # If we don't know it, pass it down to the libc layer.
+ # (In other words, cheat.)
+ # This pays for for '%Z', though, and for all the
+ # locale-specific %Ex and %Oy formats.
+ return $time->_strftime("%$format");
+ }
+
+ sub strftime {
+ my $time = shift;
+ my $format = @_ ? shift(@_) : "%a, %d %b %Y %H:%M:%S %Z";
+ $format =~ s/%(.)/_ftime($1, $time, @_)/ge;
+ return $format;
+ }
+
+ sub _strftime {
+ my $time = shift;
+ my $format = @_ ? shift(@_) : "%a, %d %b %Y %H:%M:%S %Z";
+ return __strftime($format, (@$time)[c_sec..c_isdst]);
+ }
+
+ use vars qw($_ptime);
+
+ $_ptime =
+ {
+ '%' => sub {
+ $_[1] =~ s/^%// && $1;
+ },
+ # a unimplemented
+ # A unimplemented
+ # b unimplemented
+ # B unimplemented
+ # c unimplemented
+ 'C' => sub {
+ $_[1] =~ s/^(0[0-9])// && $1;
+ },
+ 'd' => sub {
+ $_[1] =~ s/^(0[1-9]|2[0-9]|3[01])// && $1;
+ },
+ 'D' => sub {
+ my %D;
+ my $D;
+ if (defined ($D = $_ptime->{'m'}->($_[0], $_[1]))) {
+ $D{m} = $D;
+ } else {
+ return;
+ }
+ $_[1] =~ s:^/:: || return;
+ if (defined ($D = $_ptime->{'d'}->($_[0], $_[1]))) {
+ $D{d} = $D;
+ } else {
+ return;
+ }
+ $_[1] =~ s:^/:: || return;
+ if (defined ($D = $_ptime->{'y'}->($_[0], $_[1]))) {
+ $D{y} = $D;
+ } else {
+ return;
+ }
+ return { %D };
+ },
+ 'e' => sub {
+ $_[1] =~ s/^( [1-9]|2[0-9]|3[01])// && $1;
+ },
+ # h unimplemented
+ 'H' => sub {
+ $_[1] =~ s/^([0-1][0-9]|2[0-3])// && $1;
+ },
+ 'I' => sub {
+ $_[1] =~ s/^(0[1-9]|1[012])// && $1;
+ },
+ 'j' => sub {
+ $_[1] =~ s/^([0-9][0-9][0-9])// && $1 >= 1 && $1 <= 366 && $1;
+ },
+ 'm' => sub {
+ $_[1] =~ s/^(0[1-9]|1[012])// && $1;
+ },
+ 'M' => sub {
+ $_[1] =~ s/^([0-5][0-9])// && $1;
+ },
+ 't' => sub {
+ $_[1] =~ s/^\n// && $1;
+ },
+ 'p' => sub {
+ $_[1] =~ s/^(am|pm)// && $1;
+ },
+ 'r' => sub {
+ my %r;
+ my $r;
+ if (defined ($r = $_ptime->{'I'}->($_[0], $_[1]))) {
+ $r{I} = $r;
+ } else {
+ return;
+ }
+ $_[1] =~ s/^:// || return;
+ if (defined ($r = $_ptime->{'M'}->($_[0], $_[1]))) {
+ $r{M} = $r;
+ } else {
+ return;
+ }
+ $_[1] =~ s/^:// || return;
+ if (defined ($r = $_ptime->{'S'}->($_[0], $_[1]))) {
+ $r{S} = $r;
+ } else {
+ return;
+ }
+ $_[1] =~ s/^ // || return;
+ if (defined ($r = $_ptime->{'p'}->($_[0], $_[1]))) {
+ $r{p} = $r;
+ } else {
+ return;
+ }
+ return { %r };
+ },
+ 'R' => sub {
+ my %R;
+ my $R;
+ if (defined ($R = $_ptime->{'H'}->($_[0], $_[1]))) {
+ $R{H} = $R;
+ } else {
+ return;
+ }
+ $_[1] =~ s/^:// || return;
+ if (defined ($R = $_ptime->{'M'}->($_[0], $_[1]))) {
+ $R{M} = $R;
+ } else {
+ return;
+ }
+ return { %R };
+ },
+ 'S' => sub {
+ $_[1] =~ s/^([0-5][0-9])// && $1;
+ },
+ 't' => sub {
+ $_[1] =~ s/^\t// && $1;
+ },
+ 'T' => sub {
+ my %T;
+ my $T;
+ if (defined ($T = $_ptime->{'H'}->($_[0], $_[1]))) {
+ $T{H} = $T;
+ } else {
+ return;
+ }
+ $_[1] =~ s/^:// || return;
+ if (defined ($T = $_ptime->{'M'}->($_[0], $_[1]))) {
+ $T{M} = $T;
+ } else {
+ return;
+ }
+ $_[1] =~ s/^:// || return;
+ if (defined ($T = $_ptime->{'S'}->($_[0], $_[1]))) {
+ $T{S} = $T;
+ } else {
+ return;
+ }
+ return { %T };
+ },
+ # u unimplemented
+ # U unimplemented
+ # w unimplemented
+ # W unimplemented
+ 'x' => sub {
+ my %x;
+ my $x;
+ if (defined ($x = $_ptime->{'m'}->($_[0], $_[1]))) {
+ $x{m} = $x;
+ } else {
+ return;
+ }
+ $_[1] =~ s:^/:: || return;
+ if (defined ($x = $_ptime->{'d'}->($_[0], $_[1]))) {
+ $x{d} = $x;
+ } else {
+ return;
+ }
+ $_[1] =~ s:^/:: || return;
+ if (defined ($x = $_ptime->{'y'}->($_[0], $_[1]))) {
+ $x{y} = $x;
+ } else {
+ return;
+ }
+ return { %x };
+ },
+ 'y' => sub {
+ $_[1] =~ s/^([0-9][0-9])// && $1;
+ },
+ 'Y' => sub {
+ $_[1] =~ s/^([1-9][0-9][0-9][0-9])// && $1;
+ },
+ # Z too unportable
+ };
+
+ sub has_ptime {
+ my ($format) = @_;
+ exists $_ptime->{$format};
+ }
+
+ sub has_ptimes {
+ keys %$_ptime;
+ }
+
+ sub delete_ptime {
+ delete $_ptime->{@_};
+ }
+
+ sub ptime {
+ my ($format) = $_[0];
+ if (@_ == 1) {
+ return $_ptime->{$format};
+ } elsif (@_ == 2) {
+ if (ref $_[0] eq 'CODE') {
+ $_ptime->{$format} = $_[1];
+ } else {
+ require Carp;
+ Carp::croak "ptime: second argument not a code ref";
+ }
+ } else {
+ require Carp;
+ Carp::croak "ptime: want one or two arguments";
+ }
+ }
+
+ sub _ptime {
+ my ($format, $stime) = @_;
+ if (has_ptime($format)) {
+ # We are passing format to the anonsubs so that
+ # one can share the same sub among several formats.
+ return $_ptime->{$format}->($format, $_[1]);
+ }
+ die "strptime: unknown format %$format (time '$stime')\n";
+ }
+
+ sub strptime {
+ my $format = shift;
+ my $stime = shift;
+ my %ptime;
+
+ while ($format ne '') {
+ if ($format =~ s/^([^%]+)//) {
+ my $skip = $1;
+ last unless $stime =~ s/^\Q$skip//;
+ }
+ while ($format =~ s/^%(.)//) {
+ my $f = $1;
+ my $t = _ptime($f, $stime);
+ if (defined $t) {
+ if (ref $t eq 'HASH') {
+ @ptime{keys %$t} = values %$t;
+ } else {
+ $ptime{$f} = $t;
+ }
+ }
+ }
+ }
+
+ return %ptime;
+ }
+
+ sub wday_names {
+ shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); # strip first if called as a method
+ my @old = @WDAY_NAMES;
+ if (@_) {
+ @WDAY_NAMES = @_;
+ }
+ return @old;
+ }
+
+ sub weekday_names {
+ shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); # strip first if called as a method
+ my @old = @WEEKDAY_NAMES;
+ if (@_) {
+ @WEEKDAY_NAMES = @_;
+ }
+ return @old;
+ }
+
+ sub mon_names {
+ shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); # strip first if called as a method
+ my @old = @MON_NAMES;
+ if (@_) {
+ @MON_NAMES = @_;
+ }
+ return @old;
+ }
+
+ sub month_names {
+ shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); # strip first if called as a method
+ my @old = @MONTH_NAMES;
+ if (@_) {
+ @MONTH_NAMES = @_;
+ }
+ return @old;
+ }
+
+ sub time_separator {
+ shift if ref($_[0]) && $_[0]->isa(__PACKAGE__);
+ my $old = $TIME_SEP;
+ if (@_) {
+ $TIME_SEP = $_[0];
+ }
+ return $old;
+ }
+
+ sub date_separator {
+ shift if ref($_[0]) && $_[0]->isa(__PACKAGE__);
+ my $old = $DATE_SEP;
+ if (@_) {
+ $DATE_SEP = $_[0];
+ }
+ return $old;
+ }
+
+ use overload '""' => \&cdate;
+
+ sub cdate {
+ my $time = shift;
+ if ($time->[c_islocal]) {
+ return scalar(CORE::localtime($time->[c_epoch]));
+ }
+ else {
+ return scalar(CORE::gmtime($time->[c_epoch]));
+ }
+ }
+
+ use overload
+ '-' => \&subtract,
+ '+' => \&add;
+
+ sub subtract {
+ my $time = shift;
+ my $rhs = shift;
+ die "Can't subtract a date from something!" if shift;
+
+ if (ref($rhs) && $rhs->isa('Time::Piece')) {
+ return Time::Seconds->new($time->[c_epoch] - $rhs->epoch);
+ }
+ else {
+ # rhs is seconds.
+ return _mktime(($time->[c_epoch] - $rhs), $time->[c_islocal]);
+ }
+ }
+
+ sub add {
+ warn "add\n";
+ my $time = shift;
+ my $rhs = shift;
+ croak "Invalid rhs of addition: $rhs" if ref($rhs);
+
+ return _mktime(($time->[c_epoch] + $rhs), $time->[c_islocal]);
+ }
+
+ use overload
+ '<=>' => \&compare;
+
+ sub get_epochs {
+ my ($time, $rhs, $reverse) = @_;
+ $time = $time->epoch;
+ if (UNIVERSAL::isa($rhs, 'Time::Piece')) {
+ $rhs = $rhs->epoch;
+ }
+ if ($reverse) {
+ return $rhs, $time;
+ }
+ return $time, $rhs;
+ }
+
+ sub compare {
+ my ($lhs, $rhs) = get_epochs(@_);
+ return $lhs <=> $rhs;
+ }
+
+ 1;
+ __END__
+
+ =head1 NAME
+
+ Time::Piece - Object Oriented time objects
+
+ =head1 SYNOPSIS
+
+ use Time::Piece;
+
+ my $t = localtime;
+ print "Time is $t\n";
+ print "Year is ", $t->year, "\n";
+
+ =head1 DESCRIPTION
+
+ This module replaces the standard localtime and gmtime functions with
+ implementations that return objects. It does so in a backwards
+ compatible manner, so that using localtime/gmtime in the way documented
+ in perlfunc will still return what you expect.
+
+ The module actually implements most of an interface described by
+ Larry Wall on the perl5-porters mailing list here:
+ http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2000-01/msg00241.html
+
+ =head1 USAGE
+
+ After importing this module, when you use localtime(0 or gmtime() in
+ scalar context, rather than getting an ordinary scalar string
+ representing the date and time, you get a Time::Piece object, whose
+ stringification happens to produce the same effect as the localtime()
+ and gmtime(0 functions.
+
+ There is also a new() constructor provided, which is the same as
+ localtime(), except when passed a Time::Piece object, in which case
+ it's a copy constructor.
+
+ The following methods are available on the object:
+
+ $t->s # 0..61
+ # 60 and 61: leap second and double leap second
+ $t->sec # same as $t->s
+ $t->second # same as $t->s
+ $t->min # 0..59
+ $t->h # 0..24
+ $t->hour # same as $t->h
+ $t->d # 1..31
+ $t->mday # same as $t->d
+ $t->mon # 1 = January
+ $t->_mon # 0 = January
+ $t->monname # Feb
+ $t->monthname # February
+ $t->month # same as $t->monthname
+ $t->y # based at 0 (year 0 AD is, of course 1 BC)
+ $t->year # same as $t->y
+ $t->_year # year minus 1900
+ $t->wday # 1 = Sunday
+ $t->day_of_week # 0 = Sunday
+ $t->_wday # 0 = Sunday
+ $t->wdayname # Tue
+ $t->weekdayname # Tuesday
+ $t->weekday # same as weekdayname
+ $t->yday # also available as $t->day_of_year, 0 = Jan 01
+ $t->isdst # also available as $t->daylight_savings
+ $t->daylight_savings # same as $t->isdst
+
+ $t->hms # 12:34:56
+ $t->hms(".") # 12.34.56
+ $t->time # same as $t->hms
+
+ $t->ymd # 2000-02-29
+ $t->date # same as $t->ymd
+ $t->mdy # 02-29-2000
+ $t->mdy("/") # 02/29/2000
+ $t->dmy # 29-02-2000
+ $t->dmy(".") # 29.02.2000
+ $t->datetime # 2000-02-29T12:34:56 (ISO 8601)
+ $t->cdate # Tue Feb 29 12:34:56 2000
+ "$t" # same as $t->cdate
+
+ $t->epoch # seconds since the epoch
+ $t->tzoffset # timezone offset in a Time::Seconds object
+
+ $t->julian_day # number of days since Julian period began
+ $t->mjd # modified Julian day
+
+ $t->week # week number (ISO 8601)
+
+ $t->is_leap_year # true if it its
+ Time::Piece::_is_leap_year($year) # true if it its
+ $t->month_last_day # 28..31
+
+ $t->time_separator($s) # set the default separator (default ":")
+ $t->date_separator($s) # set the default separator (default "-")
+ $t->wday_names(@days) # set the default weekday names, abbreviated
+ $t->weekday_names(@days) # set the default weekday names
+ $t->mon_names(@days) # set the default month names, abbreviated
+ $t->month_names(@days) # set the default month names
+
+ $t->strftime($format) # date and time formatting
+ $t->strftime() # "Tue, 29 Feb 2000 12:34:56 GMT"
+
+ $t->_strftime($format) # same as POSIX::strftime (without the
+ # overhead of the full POSIX extension),
+ # calls the operating system libraries,
+ # as opposed to $t->strftime()
+
+ use Time::Piece 'strptime'; # date parsing
+ my %p = strptime("%H:%M", "12:34"); # $p{H} and ${M} will be set
+
+ =head2 Local Locales
+
+ Both wdayname (day) and monname (month) allow passing in a list to use
+ to index the name of the days against. This can be useful if you need
+ to implement some form of localisation without actually installing or
+ using the locales provided by the operating system.
+
+ my @weekdays = qw( Dimanche Lundi Merdi Mercredi Jeudi Vendredi Samedi );
+
+ my $french_day = localtime->day(@weekdays);
+
+ These settings can be overriden globally too:
+
+ Time::Piece::weekday_names(@weekdays);
+ Time::Piece::wday_names(@wdays);
+
+ Or for months:
+
+ Time::Piece::month_names(@months);
+ Time::Piece::mon_names(@mon);
+
+ And locally for months:
+
+ print localtime->month(@months);
+
+ =head2 Date Calculations
+
+ It's possible to use simple addition and subtraction of objects:
+
+ use Time::Seconds;
+
+ my $seconds = $t1 - $t2;
+ $t1 += ONE_DAY; # add 1 day (constant from Time::Seconds)
+
+ The following are valid ($t1 and $t2 are Time::Piece objects):
+
+ $t1 - $t2; # returns Time::Seconds object
+ $t1 - 42; # returns Time::Piece object
+ $t1 + 533; # returns Time::Piece object
+
+ However adding a Time::Piece object to another Time::Piece object
+ will cause a runtime error.
+
+ Note that the first of the above returns a Time::Seconds object, so
+ while examining the object will print the number of seconds (because
+ of the overloading), you can also get the number of minutes, hours,
+ days, weeks and years in that delta, using the Time::Seconds API.
+
+ =head2 Date Comparisons
+
+ Date comparisons are also possible, using the full suite of "<", ">",
+ "<=", ">=", "<=>", "==" and "!=".
+
+ =head2 YYYY-MM-DDThh:mm:ss
+
+ The ISO 8601 standard defines the date format to be YYYY-MM-DD, and
+ the time format to be hh:mm:ss (24 hour clock), and if combined, they
+ should be concatenated with the date first and with a capital 'T' in
+ front of the time.
+
+ =head2 Week Number
+
+ The I<week number> may be an unknown concept to some readers. The ISO
+ 8601 standard defines that weeks begin on a Monday and week 1 of the
+ year is the week that includes both January the 4th and the first
+ Thursday of the year. In other words, if the first Monday of January
+ is the 2nd, 3rd, or 4th, the preceding days of the January are part of
+ the last week of the preceding year. Week numbers range from 1 to 53.
+
+ =head2 strftime method
+
+ The strftime() method can be used to format Time::Piece objects for output.
+ The argument to strftime() is the format string to be used, for example:
+
+ $t->strftime("%H:%M");
+
+ will output the hours and minutes concatenated with a colon. The
+ available format characters are as in the standard strftime() function
+ (unless otherwise indicated the implementation is in pure Perl,
+ no operating system strftime() is invoked):
+
+ =over 4
+
+ =item %%
+
+ The percentage character "%".
+
+ =item %a
+
+ The abbreviated weekday name, e.g. 'Tue'. Note that the abbreviations
+ are not necessarily three characters wide in all languages.
+
+ =item %A
+
+ The weekday name, e.g. 'Tuesday'.
+
+ =item %b
+
+ The abbreviated month name, e.g. 'Feb'. Note that the abbreviations
+ are not necessarily three characters wide in all languages.
+
+ =item %B
+
+ The month name, e.g. 'February'.
+
+ =item %c
+
+ The ctime format, or the localtime()/gmtime() format: C<%a %b %m %H:%M:%S %Y>.
+
+ (Should be avoided: use $t->timedate instead.)
+
+ =item %C
+
+ The 'centuries' number, e.g. 19 for the year 1999 and 20 for the year 2000.
+
+ =item %d
+
+ The zero-filled right-aligned day of the month, e.g. '09' or '10'.
+
+ =item %D
+
+ C<%m/%d/%d>.
+
+ (Should be avoided: use $t->date instead.)
+
+ =item %e
+
+ The space-filled right-aligned day of the month, e.g. ' 9' or '10'.
+
+ =item %h
+
+ Same as C<%b>, the abbreviated monthname.
+
+ =item %H
+
+ The zero-filled right-aligned hours in 24 hour clock, e.g. '09' or '10'.
+
+ =item %I
+
+ The zero-filled right-aligned hours in 12 hour clock, e.g. '09' or '10'.
+
+ =item %j
+
+ The zero-filled right-aligned day of the year, e.g. '001' or '365'.
+
+ =item %m
+
+ The zero-filled right-aligned month number, e.g. '09' or '10'.
+
+ =item %M
+
+ The zero-filled right-aligned minutes, e.g. '09' or '10'.
+
+ =item %n
+
+ The newline character "\n".
+
+ =item %p
+
+ Notice that this is somewhat meaningless in 24 hour clocks.
+
+ =item %r
+
+ C<%I:%M:%S %p>.
+
+ (Should be avoided: use $t->time instead.)
+
+ =item %R
+
+ C<%H:%M>.
+
+ =item %S
+
+ The zero-filled right-aligned seconds, e.g. '09' or '10'.
+
+ =item %t
+
+ The tabulator character "\t".
+
+ =item %T
+
+ C<%H:%M%S>
+
+ (Should be avoided: use $t->time instead.)
+
+ =item %u
+
+ The day of the week with Monday as 1 (one) and Sunday as 7.
+
+ =item %U
+
+ The zero-filled right-aligned week number of the year, Sunday as the
+ first day of the week, from '00' to '53'.
+
+ (Currently taken care by the operating system strftime().)
+
+ =item %V
+
+ The zero-filled right-aligned week of the year, e.g. '01' or '53'.
+ (ISO 8601)
+
+ =item %w
+
+ The day of the week with Sunday as 0 (zero) and Monday as 1 (one).
+
+ =item %W
+
+ The zero-filled right-aligned week number of the year, Monday as the
+ first day of the week, from '00' to '53'.
+
+ (Currently taken care by the operating system strftime().)
+
+ =item %x
+
+ C<%m/%d/%y>.
+
+ (Should be avoided: use $t->date instead.)
+
+ =item %y
+
+ The zero-filled right-aligned last two numbers of the year, e.g. 99
+ for 1999 and 01 for 2001.
+
+ (Should be avoided: this is the Y2K bug alive and well.)
+
+ =item %Y
+
+ The year, e.g. 1999 or 2001.
+
+ =item %Z
+
+ The timezone name, for example "GMT" or "EET".
+
+ (Taken care by the operating system strftime().)
+
+ =back
+
+ The format C<Z> and any of the C<O*> and C<E*> formats are handled by
+ the operating system, not by Time::Piece, because those formats are
+ usually rather unportable and non-standard. (For example 'MST' can
+ mean almost anything: 'Mountain Standard Time' or 'Moscow Standard Time'.)
+
+ =head2 strptime function
+
+ You can export the strptime() function and use it to parse date and
+ time strings back to numbers. For example the following will return
+ the hours, minutes, and seconds as $parse{H}, $parse{M}, and $parse{S}.
+
+ use Time::Piece 'strptime';
+ my %parse = strptime('%H:%M:S', '12:34:56');
+
+ For 'compound' formats like for example 'T' strptime() will return
+ the 'components'.
+
+ strptime() does not perform overly strict checks on the dates and
+ times, it will be perfectly happy with the 31st day of February,
+ for example. Stricter validation should be performed by other means.
+
+ =head2 Global Overriding
+
+ Finally, it's possible to override localtime and gmtime everywhere, by
+ including the ':override' tag in the import list:
+
+ use Time::Piece ':override';
+
+ =head1 SEE ALSO
+
+ The excellent Calendar FAQ at L<http://www.tondering.dk/claus/calendar.html>
+
+ If you just want an object-oriented interface to the usual time
+ functions see L<Time::localtime> and L<Time::gmtime> which are part
+ of the standard distribution. Beware, though, that their fields are as
+ in the C library: the I<year> is I<year-1900> (like $t->_year in Time::Piece)
+ and I<months> begin from zero (like $t->_mon).
+
+ L<strftime(3)>, L<strftime(3)>
+
+ =head1 AUTHOR
+
+ Matt Sergeant, matt@sergeant.org
+
+ This module is based on Time::Object, with changes suggested by Jarkko
+ Hietaniemi before including in core perl.
+
+ =head2 License
+
+ This module is free software, you may distribute it under the same terms
+ as Perl.
+
+ =head2 Bugs
+
+ The test harness leaves much to be desired. Patches welcome.
+
+ =cut
diff -c /dev/null 'perl-5.7.2/ext/Time/Piece/Piece.t'
Index: ./ext/Time/Piece/Piece.t
*** ./ext/Time/Piece/Piece.t Thu Jan 1 02:00:00 1970
--- ./ext/Time/Piece/Piece.t Mon Jul 9 17:10:16 2001
***************
*** 0 ****
--- 1,330 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ BEGIN {
+ require Config; import Config;
+
+ if ($Config{extensions} !~ m!\bTime/Piece\b!) {
+ print "1..0 # Time::Piece not built\n";
+ exit 0;
+ }
+ }
+
+ print "1..86\n";
+
+ use Time::Piece;
+
+ print "ok 1\n";
+
+ my $t = gmtime(951827696); # 2001-02-29T12:34:56
+
+ print "not " unless $t->sec == 56;
+ print "ok 2\n";
+
+ print "not " unless $t->second == 56;
+ print "ok 3\n";
+
+ print "not " unless $t->min == 34;
+ print "ok 4\n";
+
+ print "not " unless $t->minute == 34;
+ print "ok 5\n";
+
+ print "not " unless $t->hour == 12;
+ print "ok 6\n";
+
+ print "not " unless $t->mday == 29;
+ print "ok 7\n";
+
+ print "not " unless $t->day_of_month == 29;
+ print "ok 8\n";
+
+ print "not " unless $t->mon == 2;
+ print "ok 9\n";
+
+ print "not " unless $t->_mon == 1;
+ print "ok 10\n";
+
+ print "not " unless $t->monname eq 'Feb';
+ print "ok 11\n";
+
+ print "not " unless $t->month eq 'February';
+ print "ok 12\n";
+
+ print "not " unless $t->year == 2000;
+ print "ok 13\n";
+
+ print "not " unless $t->_year == 100;
+ print "ok 14\n";
+
+ print "not " unless $t->wday == 3;
+ print "ok 15\n";
+
+ print "not " unless $t->_wday == 2;
+ print "ok 16\n";
+
+ print "not " unless $t->day_of_week == 2;
+ print "ok 17\n";
+
+ print "not " unless $t->wdayname eq 'Tue';
+ print "ok 18\n";
+
+ print "not " unless $t->weekday eq 'Tuesday';
+ print "ok 19\n";
+
+ print "not " unless $t->yday == 59;
+ print "ok 20\n";
+
+ print "not " unless $t->day_of_year == 59;
+ print "ok 21\n";
+
+ # In GMT there should be no daylight savings ever.
+
+ my $dst = 0;
+ my $dst_mess = '';
+ if ($^O eq 'os2') {
+ # OS/2 EMX bug
+ $dst = (CORE::gmtime(0))[8];
+ $dst_mess = ' # skipped: gmtime(0) thinks DST gmtime 0 == -1';
+ }
+ print "not " unless $t->isdst == $dst;
+ print "ok 22$dst_mess\n";
+
+ print "not " unless $t->daylight_savings == $dst;
+ print "ok 23$dst_mess\n";
+
+ print "not " unless $t->hms eq '12:34:56';
+ print "ok 24\n";
+
+ print "not " unless $t->time eq '12:34:56';
+ print "ok 25\n";
+
+ print "not " unless $t->ymd eq '2000-02-29';
+ print "ok 26\n";
+
+ print "not " unless $t->date eq '2000-02-29';
+ print "ok 27\n";
+
+ print "not " unless $t->mdy eq '02-29-2000';
+ print "ok 28\n";
+
+ print "not " unless $t->dmy eq '29-02-2000';
+ print "ok 29\n";
+
+ print "not " unless $t->cdate eq 'Tue Feb 29 12:34:56 2000';
+ print "ok 30\n";
+
+ print "not " unless "$t" eq 'Tue Feb 29 12:34:56 2000';
+ print "ok 31\n";
+
+ print "not " unless $t->datetime eq '2000-02-29T12:34:56';
+ print "ok 32\n";
+
+ print "not " unless $t->epoch == 951827696;
+ print "ok 33\n";
+
+ # ->tzoffset?
+
+ print "not " unless ($t->julian_day / 2451604.0075) - 1 < 0.001;
+ print "ok 34\n";
+
+ print "not " unless ($t->mjd / 51603.5075) - 1 < 0.001;
+ print "ok 35\n";
+
+ print "not " unless $t->week == 9;
+ print "ok 36\n";
+
+ if ($Config{d_strftime}) {
+
+ print "not " unless $t->strftime('%a') eq 'Tue';
+ print "ok 37\n";
+
+ print "not " unless $t->strftime('%A') eq 'Tuesday';
+ print "ok 38\n";
+
+ print "not " unless $t->strftime('%b') eq 'Feb';
+ print "ok 39\n";
+
+ print "not " unless $t->strftime('%B') eq 'February';
+ print "ok 40\n";
+
+ print "not " unless $t->strftime('%c') eq 'Tue Feb 29 12:34:56 2000';
+ print "ok 41\n";
+
+ print "not " unless $t->strftime('%C') == 20;
+ print "ok 42\n";
+
+ print "not " unless $t->strftime('%d') == 29;
+ print "ok 43\n";
+
+ print "not " unless $t->strftime('%D') eq '02/29/00'; # Yech!
+ print "ok 44\n";
+
+ print "not " unless $t->strftime('%e') eq '29'; # should test with < 10
+ print "ok 45\n";
+
+ print "not " unless $t->strftime('%H') eq '12'; # should test with < 10
+ print "ok 46\n";
+
+ print "not " unless $t->strftime('%b') eq 'Feb';
+ print "ok 47\n";
+
+ print "not " unless $t->strftime('%I') eq '12'; # should test with < 10
+ print "ok 48\n";
+
+ print "not " unless $t->strftime('%j') eq '059';
+ print "ok 49\n";
+
+ print "not " unless $t->strftime('%M') eq '34'; # should test with < 10
+ print "ok 50\n";
+
+ print "not " unless $t->strftime('%p') eq 'am';
+ print "ok 51\n";
+
+ print "not " unless $t->strftime('%r') eq '12:34:56 am';
+ print "ok 52\n";
+
+ print "not " unless $t->strftime('%R') eq '12:34'; # should test with > 12
+ print "ok 53\n";
+
+ print "not " unless $t->strftime('%S') eq '56'; # should test with < 10
+ print "ok 54\n";
+
+ print "not " unless $t->strftime('%T') eq '12:34:56'; # < 12 and > 12
+ print "ok 55\n";
+
+ print "not " unless $t->strftime('%u') == 2;
+ print "ok 56\n";
+
+ print "not " unless $t->strftime('%U') eq '09'; # Sun cmp Mon
+ print "ok 57\n";
+
+ print "not " unless $t->strftime('%V') eq '09'; # Sun cmp Mon
+ print "ok 58\n";
+
+ print "not " unless $t->strftime('%w') == 2;
+ print "ok 59\n";
+
+ print "not " unless $t->strftime('%W') eq '09'; # Sun cmp Mon
+ print "ok 60\n";
+
+ print "not " unless $t->strftime('%x') eq '02/29/00'; # Yech!
+ print "ok 61\n";
+
+ print "not " unless $t->strftime('%y') == 0; # should test with 1999
+ print "ok 62\n";
+
+ print "not " unless $t->strftime('%Y') eq '2000';
+ print "ok 63\n";
+
+ # %Z can't be tested, too unportable
+
+ } else {
+ for (38...63) {
+ print "ok $_ # Skip: no strftime\n";
+ }
+ }
+
+ print "not " unless $t->ymd("") eq '20000229';
+ print "ok 64\n";
+
+ print "not " unless $t->mdy("/") eq '02/29/2000';
+ print "ok 65\n";
+
+ print "not " unless $t->dmy(".") eq '29.02.2000';
+ print "ok 66\n";
+
+ print "not " unless $t->date_separator() eq '-';
+ print "ok 67\n";
+
+ $t->date_separator("/");
+
+ print "not " unless $t->ymd eq '2000/02/29';
+ print "ok 68\n";
+
+ print "not " unless $t->date_separator() eq '/';
+ print "ok 69\n";
+
+ $t->date_separator("-");
+
+ print "not " unless $t->hms(".") eq '12.34.56';
+ print "ok 70\n";
+
+ print "not " unless $t->time_separator() eq ':';
+ print "ok 71\n";
+
+ $t->time_separator(".");
+
+ print "not " unless $t->hms eq '12.34.56';
+ print "ok 72\n";
+
+ print "not " unless $t->time_separator() eq '.';
+ print "ok 73\n";
+
+ $t->time_separator(":");
+
+ my @fidays = qw( sunnuntai maanantai tiistai keskiviikko torstai
+ perjantai lauantai );
+ my @frdays = qw( Dimanche Lundi Merdi Mercredi Jeudi Vendredi Samedi );
+
+ print "not " unless $t->weekday(@fidays) eq "tiistai";
+ print "ok 74\n";
+
+ my @days = $t->weekday_names();
+
+ Time::Piece::weekday_names(@frdays);
+
+ print "not " unless $t->weekday eq "Merdi";
+ print "ok 75\n";
+
+ Time::Piece::weekday_names(@days);
+
+ print "not " unless $t->weekday eq "Tuesday";
+ print "ok 76\n";
+
+ my @months = $t->mon_names();
+
+ my @dumonths = qw(januari februari maart april mei juni
+ juli augustus september oktober november december);
+
+ print "not " unless $t->month(@dumonths) eq "februari";
+ print "ok 77\n";
+
+ Time::Piece::month_names(@dumonths);
+
+ print "not " unless $t->month eq "februari";
+ print "ok 78\n";
+
+ Time::Piece::mon_names(@months);
+
+ print "not " unless $t->monname eq "Feb";
+ print "ok 79\n";
+
+ print "not " unless
+ $t->datetime(date => '/', T => ' ', time => '-') eq "2000/02/29 12-34-56";
+ print "ok 80\n";
+
+ print "not " unless $t->is_leap_year;
+ print "ok 81\n";
+
+ print "not " unless $t->month_last_day == 29; # test more
+ print "ok 82\n";
+
+ print "not " if Time::Piece::_is_leap_year(1900);
+ print "ok 83\n";
+
+ print "not " if Time::Piece::_is_leap_year(1901);
+ print "ok 84\n";
+
+ print "not " unless Time::Piece::_is_leap_year(1904);
+ print "ok 85\n";
+
+ use Time::Piece 'strptime';
+
+ my %T = strptime("%T", "12:34:56");
+
+ print "not " unless keys %T == 3 && $T{H} == 12 && $T{M} == 34 && $T{S} == 56;
+ print "ok 86\n";
+
diff -c /dev/null 'perl-5.7.2/ext/Time/Piece/Piece.xs'
Index: ./ext/Time/Piece/Piece.xs
*** ./ext/Time/Piece/Piece.xs Thu Jan 1 02:00:00 1970
--- ./ext/Time/Piece/Piece.xs Mon Jul 9 17:10:16 2001
***************
*** 0 ****
--- 1,43 ----
+ #ifdef __cplusplus
+ #extern "C" {
+ #endif
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+ #include <time.h>
+ #ifdef __cplusplus
+ }
+ #endif
+
+ MODULE = Time::Piece PACKAGE = Time::Piece
+
+ PROTOTYPES: ENABLE
+
+ char *
+ __strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
+ char * fmt
+ int sec
+ int min
+ int hour
+ int mday
+ int mon
+ int year
+ int wday
+ int yday
+ int isdst
+
+ PREINIT:
+ char *buf = NULL;
+
+ CODE:
+ #XXX: an sv_strftime() that can make use of the TARG would faster
+ buf = my_strftime(fmt, sec, min, hour, mday, mon, year, wday, yday, isdst);
+ RETVAL = buf;
+
+ OUTPUT:
+ RETVAL
+
+ CLEANUP:
+ if (buf) {
+ Safefree(buf);
+ }
diff -c /dev/null 'perl-5.7.2/ext/Time/Piece/README'
Index: ./ext/Time/Piece/README
*** ./ext/Time/Piece/README Thu Jan 1 02:00:00 1970
--- ./ext/Time/Piece/README Mon Jul 9 17:10:16 2001
***************
*** 0 ****
--- 1,111 ----
+ NAME
+ Time::Object - Object Oriented time objects
+
+ SYNOPSIS
+ use Time::Object;
+
+ my $t = localtime;
+ print "Time is $t\n";
+ print "Year is ", $t->year, "\n";
+
+ DESCRIPTION
+ This module replaces the standard localtime and gmtime functions
+ with implementations that return objects. It does so in a
+ backwards compatible manner, so that using localtime/gmtime in
+ the way documented in perlfunc will still return what you
+ expect.
+
+ The module actually implements most of an interface described by
+ Larry Wall on the perl5-porters mailing list here:
+ http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2000-
+ 01/msg00241.html
+
+ USAGE
+ After importing this module, when you use localtime or gmtime in
+ a scalar context, rather than getting an ordinary scalar string
+ representing the date and time, you get a Time::Object object,
+ whose stringification happens to produce the same effect as the
+ localtime and gmtime functions. There is also a new()
+ constructor provided, which is the same as localtime(), except
+ when passed a Time::Object object, in which case it's a copy
+ constructor. The following methods are available on the object:
+
+ $t->sec # also available as $t->second
+ $t->min # also available as $t->minute
+ $t->hour
+ $t->mday # also available as $t->day_of_month
+ $t->mon # based at 1
+ $t->_mon # based at 0
+ $t->monname # February
+ $t->month # same as $t->monname
+ $t->year # based at 0 (year 0 AD is, of course 1 BC).
+ $t->_year # year minus 1900
+ $t->yr # 2 digit year
+ $t->wday # based at 1 = Sunday
+ $t->_wday # based at 0 = Sunday
+ $t->day_of_week # based at 0 = Sunday
+ $t->wdayname # Tuesday
+ $t->day # same as wdayname
+ $t->yday # also available as $t->day_of_year
+ $t->isdst # also available as $t->daylight_savings
+ $t->hms # 01:23:45
+ $t->ymd # 2000/02/29
+ $t->mdy # 02/29/2000
+ $t->dmy # 29/02/2000
+ $t->date # Tue Feb 29 01:23:45 2000
+ "$t" # same as $t->date
+ $t->epoch # seconds since the epoch
+ $t->tzoffset # timezone offset in a Time::Seconds object
+ $t->strftime(FORMAT) # same as POSIX::strftime (without POSIX.pm)
+
+ Date Calculations
+
+ It's possible to use simple addition and subtraction of objects:
+
+ use Time::Seconds;
+
+ my $seconds = $t1 - $t2;
+ $t1 += ONE_DAY; # add 1 day (constant from Time::Seconds)
+
+ The following are valid ($t1 and $t2 are Time::Object objects):
+
+ $t1 - $t2; # returns Time::Seconds object
+ $t1 - 42; # returns Time::Object object
+ $t1 + 533; # returns Time::Object object
+
+ However adding a Time::Object object to another Time::Object
+ object will cause a runtime error.
+
+ Note that the first of the above returns a Time::Seconds object,
+ so while examining the object will print the number of seconds
+ (because of the overloading), you can also get the number of
+ minutes, hours, days, weeks and years in that delta, using the
+ Time::Seconds API.
+
+ Date Comparisons
+
+ Date comparisons are also possible, using the full suite of "<",
+ ">", "<=", ">=", "<=>", "==" and "!=".
+
+ Global Overriding
+
+ Finally, it's possible to override localtime and gmtime
+ everywhere, by including the 'overrideGlobally' tag in the
+ import list:
+
+ use Time::Object 'overrideGlobally';
+
+ I'm not too keen on this name yet - suggestions welcome...
+
+ AUTHOR
+ Matt Sergeant, matt@sergeant.org
+
+ License
+
+ This module is free software, you may distribute it under the
+ same terms as Perl.
+
+ Bugs
+
+ The test harness leaves much to be desired. Patches welcome.
+
diff -c /dev/null 'perl-5.7.2/ext/Time/Piece/Seconds.pm'
Index: ./ext/Time/Piece/Seconds.pm
*** ./ext/Time/Piece/Seconds.pm Thu Jan 1 02:00:00 1970
--- ./ext/Time/Piece/Seconds.pm Mon Jul 9 17:10:16 2001
***************
*** 0 ****
--- 1,217 ----
+ package Time::Seconds;
+ use strict;
+ use vars qw/@EXPORT @ISA/;
+
+ @ISA = 'Exporter';
+
+ @EXPORT = qw(
+ ONE_MINUTE
+ ONE_HOUR
+ ONE_DAY
+ ONE_WEEK
+ ONE_MONTH
+ ONE_YEAR
+ ONE_FINANCIAL_MONTH
+ LEAP_YEAR
+ NON_LEAP_YEAR
+ );
+
+ use constant ONE_MINUTE => 60;
+ use constant ONE_HOUR => 3_600;
+ use constant ONE_DAY => 86_400;
+ use constant ONE_WEEK => 604_800;
+ use constant ONE_MONTH => 2_629_744; # ONE_YEAR / 12
+ use constant ONE_YEAR => 31_556_930; # 365.24225 days
+ use constant ONE_FINANCIAL_MONTH => 2_592_000; # 30 days
+ use constant LEAP_YEAR => 31_622_400; # 366 * ONE_DAY
+ use constant NON_LEAP_YEAR => 31_536_000; # 365 * ONE_DAY
+
+ use overload
+ '0+' => \&seconds,
+ '""' => \&seconds,
+ '<=>' => \&compare,
+ '+' => \&add,
+ '-' => \&subtract,
+ '-=' => \&subtract_from,
+ '+=' => \&add_to,
+ '=' => \©
+
+ sub new {
+ my $class = shift;
+ my ($val) = @_;
+ $val = 0 unless defined $val;
+ bless \$val, $class;
+ }
+
+ sub _get_ovlvals {
+ my ($lhs, $rhs, $reverse) = @_;
+ $lhs = $lhs->seconds;
+
+ if (UNIVERSAL::isa($rhs, 'Time::Seconds')) {
+ $rhs = $rhs->seconds;
+ }
+ elsif (ref($rhs)) {
+ die "Can't use non Seconds object in operator overload";
+ }
+
+ if ($reverse) {
+ return $rhs, $lhs;
+ }
+
+ return $lhs, $rhs;
+ }
+
+ sub compare {
+ my ($lhs, $rhs) = _get_ovlvals(@_);
+ return $lhs <=> $rhs;
+ }
+
+ sub add {
+ my ($lhs, $rhs) = _get_ovlvals(@_);
+ return Time::Seconds->new($lhs + $rhs);
+ }
+
+ sub add_to {
+ my $lhs = shift;
+ my $rhs = shift;
+ $rhs = $rhs->seconds if UNIVERSAL::isa($rhs, 'Time::Seconds');
+ $$lhs += $rhs;
+ return $lhs;
+ }
+
+ sub subtract {
+ my ($lhs, $rhs) = _get_ovlvals(@_);
+ return Time::Seconds->new($lhs - $rhs);
+ }
+
+ sub subtract_from {
+ my $lhs = shift;
+ my $rhs = shift;
+ $rhs = $rhs->seconds if UNIVERSAL::isa($rhs, 'Time::Seconds');
+ $$lhs -= $rhs;
+ return $lhs;
+ }
+
+ sub copy {
+ Time::Seconds->new(${$_[0]});
+ }
+
+ sub seconds {
+ my $s = shift;
+ $$s;
+ }
+
+ sub minutes {
+ my $s = shift;
+ $$s / 60;
+ }
+
+ sub hours {
+ my $s = shift;
+ $s->minutes / 60;
+ }
+
+ sub days {
+ my $s = shift;
+ $s->hours / 24;
+ }
+
+ sub weeks {
+ my $s = shift;
+ $s->days / 7;
+ }
+
+ sub months {
+ my $s = shift;
+ $s->days / 30.4368541;
+ }
+
+ sub financial_months {
+ my $s = shift;
+ $s->days / 30;
+ }
+
+ *f_months = \&financial_months;
+
+ sub years {
+ my $s = shift;
+ $s->days / 365.24225;
+ }
+
+ 1;
+ __END__
+
+ =head1 NAME
+
+ Time::Seconds - a simple API to convert seconds to other date values
+
+ =head1 SYNOPSIS
+
+ use Time::Piece;
+ use Time::Seconds;
+
+ my $t = localtime;
+ $t += ONE_DAY;
+
+ my $t2 = localtime;
+ my $s = $t - $t2;
+
+ print "Difference is: ", $s->days, "\n";
+
+ =head1 DESCRIPTION
+
+ This module is part of the Time::Piece distribution. It allows the user
+ to find out the number of minutes, hours, days, weeks or years in a given
+ number of seconds. It is returned by Time::Piece when you delta two
+ Time::Piece objects.
+
+ Time::Seconds also exports the following constants:
+
+ ONE_DAY
+ ONE_WEEK
+ ONE_HOUR
+ ONE_MINUTE
+ ONE_MONTH
+ ONE_YEAR
+ ONE_FINANCIAL_MONTH
+ LEAP_YEAR
+ NON_LEAP_YEAR
+
+ Since perl does not (yet?) support constant objects, these constants
+ are in seconds only, so you cannot, for example, do this: C<print
+ ONE_WEEK-E<gt>minutes;>
+
+ =head1 METHODS
+
+ The following methods are available:
+
+ my $val = Time::Seconds->new(SECONDS)
+ $val->seconds;
+ $val->minutes;
+ $val->hours;
+ $val->days;
+ $val->weeks;
+ $val->months;
+ $val->financial_months; # 30 days
+ $val->years;
+
+ The methods make the assumption that there are 24 hours in a day, 7 days in
+ a week, 365.24225 days in a year and 12 months in a year.
+ (from The Calendar FAQ at http://www.tondering.dk/claus/calendar.html)
+
+ =head1 AUTHOR
+
+ Matt Sergeant, matt@sergeant.org
+
+ Tobias Brox, tobiasb@tobiasb.funcom.com
+
+ =head1 LICENSE
+
+ Please see Time::Piece for the license.
+
+ =head1 Bugs
+
+ Currently the methods aren't as efficient as they could be, for reasons of
+ clarity. This is probably a bad idea.
+
+ =cut
diff -c 'perl-5.7.1/ext/XS/Typemap/Makefile.PL' 'perl-5.7.2/ext/XS/Typemap/Makefile.PL'
Index: ./ext/XS/Typemap/Makefile.PL
*** ./ext/XS/Typemap/Makefile.PL Tue Mar 27 17:50:35 2001
--- ./ext/XS/Typemap/Makefile.PL Mon Jul 9 17:10:16 2001
***************
*** 2,7 ****
--- 2,8 ----
WriteMakefile(
'NAME' => 'XS::Typemap',
+ MAN3PODS => {}, # Pods will be built by installman.
'VERSION_FROM' => 'Typemap.pm',
'dist' => { COMPRESS => "gzip -9f"},
OBJECT => 'stdio.o Typemap.o',
diff -c 'perl-5.7.1/ext/XS/Typemap/Typemap.pm' 'perl-5.7.2/ext/XS/Typemap/Typemap.pm'
Index: ./ext/XS/Typemap/Typemap.pm
*** ./ext/XS/Typemap/Typemap.pm Wed Mar 28 17:43:01 2001
--- ./ext/XS/Typemap/Typemap.pm Mon Jul 9 17:10:17 2001
***************
*** 66,73 ****
T_REF_IV_REF
T_REF_IV_PTR_IN T_REF_IV_PTR_OUT
T_PTROBJ_IN T_PTROBJ_OUT
! T_OPAQUE_IN T_OPAQUE_array
T_OPAQUEPTR_IN T_OPAQUEPTR_OUT T_OPAQUEPTR_OUT_short
T_ARRAY
T_STDIO_open T_STDIO_close T_STDIO_print
/);
--- 66,74 ----
T_REF_IV_REF
T_REF_IV_PTR_IN T_REF_IV_PTR_OUT
T_PTROBJ_IN T_PTROBJ_OUT
! T_OPAQUE_IN T_OPAQUE_OUT T_OPAQUE_array
T_OPAQUEPTR_IN T_OPAQUEPTR_OUT T_OPAQUEPTR_OUT_short
+ T_OPAQUEPTR_IN_struct T_OPAQUEPTR_OUT_struct
T_ARRAY
T_STDIO_open T_STDIO_close T_STDIO_print
/);
diff -c /dev/null 'perl-5.7.2/ext/XS/Typemap/Typemap.t'
Index: ./ext/XS/Typemap/Typemap.t
*** ./ext/XS/Typemap/Typemap.t Thu Jan 1 02:00:00 1970
--- ./ext/XS/Typemap/Typemap.t Mon Jul 9 17:10:17 2001
***************
*** 0 ****
--- 1,339 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bXS\/Typemap\b/) {
+ print "1..0 # Skip: XS::Typemap was not built\n";
+ exit 0;
+ }
+ }
+
+ use Test;
+ BEGIN { plan tests => 84 }
+
+ use strict;
+ use warnings;
+ use XS::Typemap;
+
+ ok(1);
+
+ # Some inheritance trees to check ISA relationships
+ BEGIN {
+ package intObjPtr::SubClass;
+ use base qw/ intObjPtr /;
+ sub xxx { 1; }
+ }
+
+ BEGIN {
+ package intRefIvPtr::SubClass;
+ use base qw/ intRefIvPtr /;
+ sub xxx { 1 }
+ }
+
+ # T_SV - standard perl scalar value
+ print "# T_SV\n";
+
+ my $sv = "Testing T_SV";
+ ok( T_SV($sv), $sv);
+
+ # T_SVREF - reference to Scalar
+ print "# T_SVREF\n";
+
+ $sv .= "REF";
+ my $svref = \$sv;
+ ok( T_SVREF($svref), $svref );
+
+ # Now test that a non reference is rejected
+ # the typemaps croak
+ eval { T_SVREF( "fail - not ref" ) };
+ ok( $@ );
+
+ # T_AVREF - reference to a perl Array
+ print "# T_AVREF\n";
+
+ my @array;
+ ok( T_AVREF(\@array), \@array);
+
+ # Now test that a non array ref is rejected
+ eval { T_AVREF( \$sv ) };
+ ok( $@ );
+
+ # T_HVREF - reference to a perl Hash
+ print "# T_HVREF\n";
+
+ my %hash;
+ ok( T_HVREF(\%hash), \%hash);
+
+ # Now test that a non hash ref is rejected
+ eval { T_HVREF( \@array ) };
+ ok( $@ );
+
+
+ # T_CVREF - reference to perl subroutine
+ print "# T_CVREF\n";
+ my $sub = sub { 1 };
+ ok( T_CVREF($sub), $sub );
+
+ # Now test that a non code ref is rejected
+ eval { T_CVREF( \@array ) };
+ ok( $@ );
+
+ # T_SYSRET - system return values
+ print "# T_SYSRET\n";
+
+ # first check success
+ ok( T_SYSRET_pass );
+
+ # ... now failure
+ ok( T_SYSRET_fail, undef);
+
+ # T_UV - unsigned integer
+ print "# T_UV\n";
+
+ ok( T_UV(5), 5 ); # pass
+ ok( T_UV(-4) != -4); # fail
+
+ # T_IV - signed integer
+ print "# T_IV\n";
+
+ ok( T_IV(5), 5);
+ ok( T_IV(-4), -4);
+ ok( T_IV(4.1), int(4.1));
+ ok( T_IV("52"), "52");
+ ok( T_IV(4.5) != 4.5); # failure
+
+
+ # Skip T_INT
+
+ # T_ENUM - enum list
+ print "# T_ENUM\n";
+
+ ok( T_ENUM() ); # just hope for a true value
+
+ # T_BOOL - boolean
+ print "# T_BOOL\n";
+
+ ok( T_BOOL(52) );
+ ok( ! T_BOOL(0) );
+ ok( ! T_BOOL('') );
+ ok( ! T_BOOL(undef) );
+
+ # Skip T_U_INT
+
+ # Skip T_SHORT
+
+ # T_U_SHORT aka U16
+
+ print "# T_U_SHORT\n";
+
+ ok( T_U_SHORT(32000), 32000);
+ if ($Config{shortsize} == 2) {
+ ok( T_U_SHORT(65536) != 65536); # probably dont want to test edge cases
+ } else {
+ ok(1); # e.g. Crays have shortsize 4 (T3X) or 8 (CXX and SVX)
+ }
+
+ # T_U_LONG aka U32
+
+ print "# T_U_LONG\n";
+
+ ok( T_U_LONG(65536), 65536);
+ ok( T_U_LONG(-1) != -1);
+
+ # T_CHAR
+
+ print "# T_CHAR\n";
+
+ ok( T_CHAR("a"), "a");
+ ok( T_CHAR("-"), "-");
+ ok( T_CHAR(chr(128)),chr(128));
+ ok( T_CHAR(chr(256)) ne chr(256));
+
+ # T_U_CHAR
+
+ print "# T_U_CHAR\n";
+
+ ok( T_U_CHAR(127), 127);
+ ok( T_U_CHAR(128), 128);
+ ok( T_U_CHAR(-1) != -1);
+ ok( T_U_CHAR(300) != 300);
+
+ # T_FLOAT
+ print "# T_FLOAT\n";
+
+ # limited precision
+ ok( sprintf("%6.3f",T_FLOAT(52.345)), sprintf("%6.3f",52.345));
+
+ # T_NV
+ print "# T_NV\n";
+
+ ok( T_NV(52.345), 52.345);
+
+ # T_DOUBLE
+ print "# T_DOUBLE\n";
+
+ ok( sprintf("%6.3f",T_DOUBLE(52.345)), sprintf("%6.3f",52.345));
+
+ # T_PV
+ print "# T_PV\n";
+
+ ok( T_PV("a string"), "a string");
+ ok( T_PV(52), 52);
+
+ # T_PTR
+ print "# T_PTR\n";
+
+ my $t = 5;
+ my $ptr = T_PTR_OUT($t);
+ ok( T_PTR_IN( $ptr ), $t );
+
+ # T_PTRREF
+ print "# T_PTRREF\n";
+
+ $t = -52;
+ $ptr = T_PTRREF_OUT( $t );
+ ok( ref($ptr), "SCALAR");
+ ok( T_PTRREF_IN( $ptr ), $t );
+
+ # test that a non-scalar ref is rejected
+ eval { T_PTRREF_IN( $t ); };
+ ok( $@ );
+
+ # T_PTROBJ
+ print "# T_PTROBJ\n";
+
+ $t = 256;
+ $ptr = T_PTROBJ_OUT( $t );
+ ok( ref($ptr), "intObjPtr");
+ ok( $ptr->T_PTROBJ_IN, $t );
+
+ # check that normal scalar refs fail
+ eval {intObjPtr::T_PTROBJ_IN( \$t );};
+ ok( $@ );
+
+ # check that inheritance works
+ bless $ptr, "intObjPtr::SubClass";
+ ok( ref($ptr), "intObjPtr::SubClass");
+ ok( $ptr->T_PTROBJ_IN, $t );
+
+ # Skip T_REF_IV_REF
+
+ # T_REF_IV_PTR
+ print "# T_REF_IV_PTR\n";
+
+ $t = -365;
+ $ptr = T_REF_IV_PTR_OUT( $t );
+ ok( ref($ptr), "intRefIvPtr");
+ ok( $ptr->T_REF_IV_PTR_IN(), $t);
+
+ # inheritance should not work
+ bless $ptr, "intRefIvPtr::SubClass";
+ eval { $ptr->T_REF_IV_PTR_IN };
+ ok( $@ );
+
+ # Skip T_PTRDESC
+
+ # Skip T_REFREF
+
+ # Skip T_REFOBJ
+
+ # T_OPAQUEPTR
+ print "# T_OPAQUEPTR\n";
+
+ $t = 22;
+ my $p = T_OPAQUEPTR_IN( $t );
+ ok( T_OPAQUEPTR_OUT($p), $t);
+
+ # T_OPAQUEPTR with a struct
+ print "# T_OPAQUEPTR with a struct\n";
+
+ my @test = (5,6,7);
+ $p = T_OPAQUEPTR_IN_struct(@test);
+ my @result = T_OPAQUEPTR_OUT_struct($p);
+ ok(scalar(@result),scalar(@test));
+ for (0..$#test) {
+ ok($result[$_], $test[$_]);
+ }
+
+ # T_OPAQUE
+ print "# T_OPAQUE\n";
+
+ $t = 48;
+ $p = T_OPAQUE_IN( $t );
+ ok(T_OPAQUEPTR_OUT_short( $p ), $t); # Test using T_OPAQUEPTR
+ ok(T_OPAQUE_OUT( $p ), $t ); # Test using T_OPQAQUE
+
+ # T_OPAQUE_array
+ print "# A packed array\n";
+
+ my @opq = (2,4,8);
+ my $packed = T_OPAQUE_array(@opq);
+ my @uopq = unpack("i*",$packed);
+ ok(scalar(@uopq), scalar(@opq));
+ for (0..$#opq) {
+ ok( $uopq[$_], $opq[$_]);
+ }
+
+ # Skip T_PACKED
+
+ # Skip T_PACKEDARRAY
+
+ # Skip T_DATAUNIT
+
+ # 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 );
+ ok(scalar(@outarr), scalar(@inarr));
+
+ for (0..$#inarr) {
+ ok($outarr[$_], $inarr[$_]);
+ }
+
+
+
+ # T_STDIO
+ print "# T_STDIO\n";
+
+ # open a file in XS for write
+ my $testfile= "stdio.tmp";
+ my $fh = T_STDIO_open( $testfile );
+ ok( $fh );
+
+ # write to it using perl
+ if (defined $fh) {
+
+ my @lines = ("NormalSTDIO\n", "PerlIO\n");
+
+ # print to it using FILE* through XS
+ ok( T_STDIO_print($fh, $lines[0]), length($lines[0]));
+
+ # print to it using normal perl
+ ok(print $fh "$lines[1]");
+
+ # close it using XS
+ # This works fine but causes a segmentation fault during global
+ # destruction when the glob associated with this filehandle is
+ # tidied up.
+ # ok( T_STDIO_close( $fh ) );
+ ok(close($fh)); # using perlio to close the glob works fine
+
+ # open from perl, and check contents
+ open($fh, "< $testfile");
+ ok($fh);
+ my $line = <$fh>;
+ ok($line,$lines[0]);
+ $line = <$fh>;
+ ok($line,$lines[1]);
+
+ ok(close($fh));
+ ok(unlink($testfile));
+
+ } else {
+ for (1..8) {
+ skip("Skip Test not relevant since file was not opened correctly",0);
+ }
+ }
+
diff -c 'perl-5.7.1/ext/XS/Typemap/Typemap.xs' 'perl-5.7.2/ext/XS/Typemap/Typemap.xs'
Index: ./ext/XS/Typemap/Typemap.xs
*** ./ext/XS/Typemap/Typemap.xs Wed Mar 28 17:43:01 2001
--- ./ext/XS/Typemap/Typemap.xs Mon Jul 9 17:10:17 2001
***************
*** 27,38 ****
typedef short shortOPQ; /* T_OPAQUE */
typedef int intOpq; /* T_OPAQUEPTR */
/* Some static memory for the tests */
! I32 anint;
! intRef anintref;
! intObj anintobj;
! intRefIv anintrefiv;
! intOpq anintopq;
/* Helper functions */
--- 27,47 ----
typedef short shortOPQ; /* T_OPAQUE */
typedef int intOpq; /* T_OPAQUEPTR */
+ /* A structure to test T_OPAQUEPTR */
+ struct t_opaqueptr {
+ int a;
+ int b;
+ double c;
+ };
+
+ typedef struct t_opaqueptr astruct;
+
/* Some static memory for the tests */
! static I32 xst_anint;
! static intRef xst_anintref;
! static intObj xst_anintobj;
! static intRefIv xst_anintrefiv;
! static intOpq xst_anintopq;
/* Helper functions */
***************
*** 405,412 ****
T_PTR_OUT( in )
int in;
CODE:
! anint = in;
! RETVAL = &anint;
OUTPUT:
RETVAL
--- 414,421 ----
T_PTR_OUT( in )
int in;
CODE:
! xst_anint = in;
! RETVAL = &xst_anint;
OUTPUT:
RETVAL
***************
*** 439,446 ****
T_PTRREF_OUT( in )
intRef in;
CODE:
! anintref = in;
! RETVAL = &anintref;
OUTPUT:
RETVAL
--- 448,455 ----
T_PTRREF_OUT( in )
intRef in;
CODE:
! xst_anintref = in;
! RETVAL = &xst_anintref;
OUTPUT:
RETVAL
***************
*** 477,484 ****
T_PTROBJ_OUT( in )
intObj in;
CODE:
! anintobj = in;
! RETVAL = &anintobj;
OUTPUT:
RETVAL
--- 486,493 ----
T_PTROBJ_OUT( in )
intObj in;
CODE:
! xst_anintobj = in;
! RETVAL = &xst_anintobj;
OUTPUT:
RETVAL
***************
*** 520,527 ****
T_REF_IV_PTR_OUT( in )
intRefIv in;
CODE:
! anintrefiv = in;
! RETVAL = &anintrefiv;
OUTPUT:
RETVAL
--- 529,536 ----
T_REF_IV_PTR_OUT( in )
intRefIv in;
CODE:
! xst_anintrefiv = in;
! RETVAL = &xst_anintrefiv;
OUTPUT:
RETVAL
***************
*** 554,570 ****
=item T_OPAQUEPTR
! This can be used to store a pointer in the string component of the
! SV. Unlike T_PTR which stores the pointer in an IV that can be
! printed, here the representation of the pointer is irrelevant and the
! bytes themselves are just stored in the SV. If the pointer is
! represented by 4 bytes then those 4 bytes are stored in the SV (and
! length() will report a value of 4). This makes use of the fact that a
! perl scalar can store arbritray data in its PV component.
! In principal the unpack() command can be used to convert the pointer
! to a number.
=cut
intOpq *
--- 563,584 ----
=item 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 *
***************
*** 571,578 ****
T_OPAQUEPTR_IN( val )
intOpq val
CODE:
! anintopq = val;
! RETVAL = &anintopq;
OUTPUT:
RETVAL
--- 585,592 ----
T_OPAQUEPTR_IN( val )
intOpq val
CODE:
! xst_anintopq = val;
! RETVAL = &xst_anintopq;
OUTPUT:
RETVAL
***************
*** 592,610 ****
OUTPUT:
RETVAL
=item T_OPAQUE
! This can be used to store pointers to non-pointer types in an SV. It
! is similar to T_OPAQUEPTR except that the typemap retrieves the
! pointer itself rather than assuming that it is to be given a
! pointer. This approach hides the pointer as a byte stream in the
! string part of the SV rather than making the actual pointer value
! available to Perl.
! There is no reason to use T_OPAQUE to pass the data to C. Use
! T_OPAQUEPTR to do that since once the pointer is stored in the SV
! T_OPAQUE and T_OPAQUEPTR are identical.
=cut
shortOPQ
--- 606,653 ----
OUTPUT:
RETVAL
+ # Test it with a structure
+ astruct *
+ T_OPAQUEPTR_IN_struct( a,b,c )
+ int a
+ int b
+ double c
+ PREINIT:
+ struct t_opaqueptr test;
+ CODE:
+ test.a = a;
+ test.b = b;
+ test.c = c;
+ RETVAL = &test;
+ OUTPUT:
+ RETVAL
+
+ void
+ T_OPAQUEPTR_OUT_struct( test )
+ astruct * test
+ PPCODE:
+ XPUSHs(sv_2mortal(newSViv(test->a)));
+ XPUSHs(sv_2mortal(newSViv(test->b)));
+ XPUSHs(sv_2mortal(newSVnv(test->c)));
+
+
=item 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
***************
*** 615,620 ****
--- 658,671 ----
OUTPUT:
RETVAL
+ IV
+ T_OPAQUE_OUT( val )
+ shortOPQ val
+ CODE:
+ RETVAL = (IV)val;
+ OUTPUT:
+ RETVAL
+
=item Implicit array
xsubpp supports a special syntax for returning
***************
*** 713,723 ****
intArray *
T_ARRAY( dummy, array, ... )
! int dummy = NO_INIT
intArray * array
PREINIT:
U32 size_RETVAL;
CODE:
size_RETVAL = ix_array;
RETVAL = array;
OUTPUT:
--- 764,775 ----
intArray *
T_ARRAY( dummy, array, ... )
! int dummy = 0;
intArray * array
PREINIT:
U32 size_RETVAL;
CODE:
+ dummy += 0; /* Fix -Wall */
size_RETVAL = ix_array;
RETVAL = array;
OUTPUT:
diff -c 'perl-5.7.1/ext/XS/Typemap/typemap' 'perl-5.7.2/ext/XS/Typemap/typemap'
Index: ./ext/XS/Typemap/typemap
*** ./ext/XS/Typemap/typemap Wed Mar 28 17:43:02 2001
--- ./ext/XS/Typemap/typemap Mon Jul 9 17:10:17 2001
***************
*** 16,18 ****
--- 16,19 ----
intOpq * T_OPAQUEPTR
shortOPQ T_OPAQUE
shortOPQ * T_OPAQUEPTR
+ astruct * T_OPAQUEPTR
diff -c /dev/null 'perl-5.7.2/ext/attrs.t'
Index: ./ext/attrs.t
*** ./ext/attrs.t Thu Jan 1 02:00:00 1970
--- ./ext/attrs.t Mon Jul 9 17:10:17 2001
***************
*** 0 ****
--- 1,141 ----
+ #!./perl
+
+ # Regression tests for attrs.pm and the C<sub x : attrs> syntax.
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ eval 'require attrs; 1' or do {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ use warnings;
+ no warnings qw(deprecated); # else attrs cries.
+
+ sub NTESTS () ;
+
+ my ($test, $ntests);
+ BEGIN {$ntests=0}
+ $test=0;
+ my $failed = 0;
+
+ print "1..".NTESTS."\n";
+
+ eval 'sub t1 ($) { use attrs "locked"; $_[0]++ }';
+ (print "not "), $failed=1 if $@;
+ print "ok ",++$test,"\n";
+ BEGIN {++$ntests}
+
+ eval 'sub t2 { use attrs "locked"; $_[0]++ }';
+ (print "not "), $failed=1 if $@;
+ print "ok ",++$test,"\n";
+ BEGIN {++$ntests}
+
+ eval 'sub t3 ($) : locked ;';
+ (print "not "), $failed=1 if $@;
+ print "ok ",++$test,"\n";
+ BEGIN {++$ntests}
+
+ eval 'sub t4 : locked ;';
+ (print "not "), $failed=1 if $@;
+ print "ok ",++$test,"\n";
+ BEGIN {++$ntests}
+
+ my $anon1;
+ eval '$anon1 = sub ($) { use attrs qw(locked method); $_[0]++ }';
+ (print "not "), $failed=1 if $@;
+ print "ok ",++$test,"\n";
+ BEGIN {++$ntests}
+
+ my $anon2;
+ eval '$anon2 = sub { use attrs qw(locked method); $_[0]++ }';
+ (print "not "), $failed=1 if $@;
+ print "ok ",++$test,"\n";
+ BEGIN {++$ntests}
+
+ my $anon3;
+ eval '$anon3 = sub { use attrs "method"; $_[0]->[1] }';
+ (print "not "), $failed=1 if $@;
+ print "ok ",++$test,"\n";
+ BEGIN {++$ntests}
+
+ my @attrs = attrs::get($anon3 ? $anon3 : \&ns);
+ (print "not "), $failed=1 unless "@attrs" eq "method";
+ print "ok ",++$test,"\n";
+ BEGIN {++$ntests}
+
+ @attrs = sort +attrs::get($anon2 ? $anon2 : \&ns);
+ (print "not "), $failed=1 unless "@attrs" eq "locked method";
+ print "ok ",++$test,"\n";
+ BEGIN {++$ntests}
+
+ @attrs = sort +attrs::get($anon1 ? $anon1 : \&ns);
+ (print "not "), $failed=1 unless "@attrs" eq "locked method";
+ print "ok ",++$test,"\n";
+ BEGIN {++$ntests}
+
+ eval 'sub e1 ($) : plugh ;';
+ unless ($@ && $@ =~ m/^Invalid CODE attribute: ["']?plugh["']? at/) {
+ my $x = $@;
+ $x =~ s/\n.*\z//s;
+ print "# $x\n";
+ print "not ";
+ $failed = 1;
+ }
+ print "ok ",++$test,"\n";
+ BEGIN {++$ntests}
+
+ eval 'sub e2 ($) : plugh(0,0) xyzzy ;';
+ unless ($@ && $@ =~ m/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /) {
+ my $x = $@;
+ $x =~ s/\n.*\z//s;
+ print "# $x\n";
+ print "not ";
+ $failed = 1;
+ }
+ print "ok ",++$test,"\n";
+ BEGIN {++$ntests}
+
+ eval 'sub e3 ($) : plugh(0,0 xyzzy ;';
+ unless ($@ && $@ =~ m/Unterminated attribute parameter in attribute list at/) {
+ my $x = $@;
+ $x =~ s/\n.*\z//s;
+ print "# $x\n";
+ print "not ";
+ $failed = 1;
+ }
+ print "ok ",++$test,"\n";
+ BEGIN {++$ntests}
+
+ eval 'sub e4 ($) : plugh + xyzzy ;';
+ unless ($@ && $@ =~ m/Invalid separator character '[+]' in attribute list at/) {
+ my $x = $@;
+ $x =~ s/\n.*\z//s;
+ print "# $x\n";
+ print "not ";
+ $failed = 1;
+ }
+ print "ok ",++$test,"\n";
+ BEGIN {++$ntests}
+
+ {
+ my $w = "" ;
+ local $SIG{__WARN__} = sub {$w = shift} ;
+ eval 'sub w1 ($) { use warnings "deprecated"; use attrs "locked"; $_[0]++ }';
+ (print "not "), $failed=1 if $@;
+ print "ok ",++$test,"\n";
+ BEGIN {++$ntests}
+ (print "not "), $failed=1
+ if $w !~ /^pragma "attrs" is deprecated, use "sub NAME : ATTRS" instead at/;
+ print "ok ",++$test,"\n";
+ BEGIN {++$ntests}
+ }
+
+
+ # Other tests should be added above this line
+
+ sub NTESTS () { $ntests }
+
+ exit $failed;
diff -c 'perl-5.7.1/ext/attrs/attrs.pm' 'perl-5.7.2/ext/attrs/attrs.pm'
Index: ./ext/attrs/attrs.pm
*** ./ext/attrs/attrs.pm Fri Mar 16 04:54:48 2001
--- ./ext/attrs/attrs.pm Mon Jul 9 17:10:17 2001
***************
*** 1,7 ****
package attrs;
use XSLoader ();
! $VERSION = "1.0";
=head1 NAME
--- 1,7 ----
package attrs;
use XSLoader ();
! $VERSION = "1.01";
=head1 NAME
diff -c 'perl-5.7.1/ext/attrs/attrs.xs' 'perl-5.7.2/ext/attrs/attrs.xs'
Index: ./ext/attrs/attrs.xs
*** ./ext/attrs/attrs.xs Tue Mar 6 04:05:04 2001
--- ./ext/attrs/attrs.xs Mon Jul 9 17:10:17 2001
***************
*** 17,30 ****
MODULE = attrs PACKAGE = attrs
void
! import(Class, ...)
! char * Class
ALIAS:
unimport = 1
PREINIT:
int i;
- CV *cv;
PPCODE:
if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv)))
croak("can't set attributes outside a subroutine scope");
if (ckWARN(WARN_DEPRECATED))
--- 17,30 ----
MODULE = attrs PACKAGE = attrs
void
! import(...)
ALIAS:
unimport = 1
PREINIT:
int i;
PPCODE:
+ if (items < 1)
+ Perl_croak(aTHX_ "Usage: %s(Class, ...)", GvNAME(CvGV(cv)));
if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv)))
croak("can't set attributes outside a subroutine scope");
if (ckWARN(WARN_DEPRECATED))
diff -c 'perl-5.7.1/ext/re/Makefile.PL' 'perl-5.7.2/ext/re/Makefile.PL'
Index: ./ext/re/Makefile.PL
*** ./ext/re/Makefile.PL Tue Mar 13 16:14:47 2001
--- ./ext/re/Makefile.PL Mon Jul 9 17:10:17 2001
***************
*** 4,9 ****
--- 4,20 ----
my $object = 're_exec$(OBJ_EXT) re_comp$(OBJ_EXT) re$(OBJ_EXT)';
+ my $defines = '-DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG';
+
+ # We need to pretend that DEBUGGING is in effect even if it's
+ # not but we need to remember that we pretended so we can avoid
+ # linking to things that aren't there.
+
+ if ( (($Config{'ccflags'} !~ /DEBUGGING/) && $^O ne 'VMS') ||
+ (exists($Config{'usedebugging_perl'}) && $Config{'usedebugging_perl'} ne 'Y') ) {
+ $defines .= ' -DDEBUGGING -DWAS_NOT_DEBUGGING';
+ }
+
WriteMakefile(
NAME => 're',
VERSION_FROM => 're.pm',
***************
*** 10,16 ****
MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes',
OBJECT => $object,
! DEFINE => '-DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG',
clean => { FILES => '*$(OBJ_EXT) *.c ../../lib/re.pm' },
);
--- 21,27 ----
MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes',
OBJECT => $object,
! DEFINE => $defines,
clean => { FILES => '*$(OBJ_EXT) *.c ../../lib/re.pm' },
);
diff -c 'perl-5.7.1/ext/re/re.pm' 'perl-5.7.2/ext/re/re.pm'
Index: ./ext/re/re.pm
*** ./ext/re/re.pm Wed Mar 28 18:35:38 2001
--- ./ext/re/re.pm Mon Jul 9 17:10:17 2001
***************
*** 1,6 ****
package re;
! $VERSION = 0.02;
=head1 NAME
--- 1,6 ----
package re;
! our $VERSION = 0.03;
=head1 NAME
***************
*** 79,85 ****
my %bitmask = (
taint => 0x00100000,
eval => 0x00200000,
- asciirange => 0x02000000,
);
sub setcolor {
--- 79,84 ----
***************
*** 99,105 ****
sub bits {
my $on = shift;
my $bits = 0;
! unless(@_) {
require Carp;
Carp::carp("Useless use of \"re\" pragma");
}
--- 98,104 ----
sub bits {
my $on = shift;
my $bits = 0;
! unless (@_) {
require Carp;
Carp::carp("Useless use of \"re\" pragma");
}
***************
*** 112,118 ****
uninstall() unless $on;
next;
}
! $bits |= $bitmask{$s} || 0;
}
$bits;
}
--- 111,122 ----
uninstall() unless $on;
next;
}
! if (exists $bitmask{$s}) {
! $bits |= $bitmask{$s};
! } else {
! require Carp;
! Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: @{[join(', ', map {qq('$_')} sort keys %bitmask)]})");
! }
}
$bits;
}
***************
*** 119,130 ****
sub import {
shift;
! $^H |= bits(1,@_);
}
sub unimport {
shift;
! $^H &= ~ bits(0,@_);
}
1;
--- 123,134 ----
sub import {
shift;
! $^H |= bits(1, @_);
}
sub unimport {
shift;
! $^H &= ~ bits(0, @_);
}
1;
diff -c 'perl-5.7.1/ext/re/re.xs' 'perl-5.7.2/ext/re/re.xs'
Index: ./ext/re/re.xs
*** ./ext/re/re.xs Fri Mar 9 03:19:24 2001
--- ./ext/re/re.xs Mon Jul 9 17:10:17 2001
***************
*** 1,13 ****
- /* We need access to debugger hooks */
- #ifndef DEBUGGING
- # define DEBUGGING
- #endif
-
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
extern regexp* my_regcomp (pTHX_ char* exp, char* xend, PMOP* pm);
extern I32 my_regexec (pTHX_ regexp* prog, char* stringarg, char* strend,
char* strbeg, I32 minend, SV* screamer,
--- 1,12 ----
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
+ #ifdef WAS_NOT_DEBUGGING
+ void Perl_deb(pTHX_ const char* pat, ...) { }
+ #endif
+
extern regexp* my_regcomp (pTHX_ char* exp, char* xend, PMOP* pm);
extern I32 my_regexec (pTHX_ regexp* prog, char* stringarg, char* strend,
char* strbeg, I32 minend, SV* screamer,
***************
*** 43,49 ****
PL_regint_string = &my_re_intuit_string;
PL_regfree = &my_regfree;
oldfl = PL_debug & DEBUG_r_FLAG;
! PL_debug |= ~DEBUG_r_FLAG;
}
MODULE = re PACKAGE = re
--- 42,48 ----
PL_regint_string = &my_re_intuit_string;
PL_regfree = &my_regfree;
oldfl = PL_debug & DEBUG_r_FLAG;
! PL_debug |= DEBUG_r_FLAG;
}
MODULE = re PACKAGE = re
diff -c 'perl-5.7.1/ext/util/make_ext' 'perl-5.7.2/ext/util/make_ext'
Index: ./ext/util/make_ext
*** ./ext/util/make_ext Tue Mar 6 04:05:09 2001
--- ./ext/util/make_ext Mon Jul 9 17:10:17 2001
***************
*** 116,122 ****
esac
if test ! -f $makefile ; then
! test -f Makefile.PL && ../$depth/miniperl -I../$depth/lib Makefile.PL INSTALLDIRS=perl $passthru
fi
if test ! -f $makefile ; then
if test -f Makefile.SH; then
--- 116,122 ----
esac
if test ! -f $makefile ; then
! test -f Makefile.PL && ../$depth/miniperl -I../$depth/lib Makefile.PL INSTALLDIRS=perl PERL_CORE=1 $passthru
fi
if test ! -f $makefile ; then
if test -f Makefile.SH; then
diff -c 'perl-5.7.1/global.sym' 'perl-5.7.2/global.sym'
Index: ./global.sym
*** ./global.sym Fri Apr 6 16:42:02 2001
--- ./global.sym Thu Jul 12 21:34:38 2001
***************
*** 153,158 ****
--- 153,159 ----
Perl_ibcmp
Perl_ibcmp_locale
Perl_init_stacks
+ Perl_init_tm
Perl_instr
Perl_is_uni_alnum
Perl_is_uni_alnumc
***************
*** 206,214 ****
--- 207,218 ----
Perl_is_utf8_xdigit
Perl_is_utf8_mark
Perl_leave_scope
+ Perl_op_null
Perl_load_module
Perl_vload_module
Perl_looks_like_number
+ Perl_grok_number
+ Perl_grok_numeric_radix
Perl_markstack_grow
Perl_mess
Perl_vmess
***************
*** 221,226 ****
--- 225,231 ----
Perl_mg_magical
Perl_mg_set
Perl_mg_size
+ Perl_mini_mktime
Perl_moreswitches
Perl_my_atof
Perl_my_bcopy
***************
*** 236,241 ****
--- 241,247 ----
Perl_my_popen_list
Perl_my_setenv
Perl_my_stat
+ Perl_my_strftime
Perl_my_swap
Perl_my_htonl
Perl_my_ntohl
***************
*** 330,335 ****
--- 336,342 ----
Perl_repeatcpy
Perl_rninstr
Perl_rsignal
+ Perl_rsignal_state
Perl_savepv
Perl_savepvn
Perl_savestack_grow
***************
*** 406,411 ****
--- 413,419 ----
Perl_sv_cmp_locale
Perl_sv_collxfrm
Perl_sv_compile_2op
+ Perl_getcwd_sv
Perl_sv_dec
Perl_sv_dump
Perl_sv_derived_from
***************
*** 567,569 ****
--- 575,584 ----
Perl_ptr_table_free
Perl_sys_intern_clear
Perl_sys_intern_init
+ Perl_sv_setsv_flags
+ Perl_sv_catpvn_flags
+ Perl_sv_catsv_flags
+ Perl_sv_utf8_upgrade_flags
+ Perl_sv_pvn_force_flags
+ Perl_sv_2pv_flags
+ Perl_my_atof2
diff -c 'perl-5.7.1/globals.c' 'perl-5.7.2/globals.c'
Index: ./globals.c
*** ./globals.c Wed Mar 14 22:25:39 2001
--- ./globals.c Mon Jul 9 17:10:18 2001
***************
*** 73,79 ****
int
Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
{
! dTHX;
va_list(arglist);
va_start(arglist, format);
return PerlIO_vprintf(stream, format, arglist);
--- 73,79 ----
int
Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
{
! dTHXs;
va_list(arglist);
va_start(arglist, format);
return PerlIO_vprintf(stream, format, arglist);
***************
*** 82,88 ****
int
Perl_printf_nocontext(const char *format, ...)
{
! dTHX;
va_list(arglist);
va_start(arglist, format);
return PerlIO_vprintf(PerlIO_stdout(), format, arglist);
--- 82,88 ----
int
Perl_printf_nocontext(const char *format, ...)
{
! dTHXs;
va_list(arglist);
va_start(arglist, format);
return PerlIO_vprintf(PerlIO_stdout(), format, arglist);
diff -c 'perl-5.7.1/gv.c' 'perl-5.7.2/gv.c'
Index: ./gv.c
*** ./gv.c Sun Apr 8 18:37:54 2001
--- ./gv.c Mon Jul 9 17:10:18 2001
***************
*** 46,54 ****
if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
Perl_croak(aTHX_ "Bad symbol for filehandle");
if (!GvIOp(gv)) {
! #ifdef GV_SHARED_CHECK
! if (GvSHARED(gv)) {
! Perl_croak(aTHX_ "Bad symbol for filehandle (GV is shared)");
}
#endif
GvIOp(gv) = newIO();
--- 46,54 ----
if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
Perl_croak(aTHX_ "Bad symbol for filehandle");
if (!GvIOp(gv)) {
! #ifdef GV_UNIQUE_CHECK
! if (GvUNIQUE(gv)) {
! Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
}
#endif
GvIOp(gv) = newIO();
***************
*** 80,86 ****
gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
sv_setpv(GvSV(gv), name);
if (PERLDB_LINE)
! hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, 'L');
}
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
--- 80,86 ----
gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
sv_setpv(GvSV(gv), name);
if (PERLDB_LINE)
! hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile);
}
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
***************
*** 110,116 ****
GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
GvCVGEN(gv) = 0;
GvEGV(gv) = gv;
! sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0);
GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
GvNAME(gv) = savepvn(name, len);
GvNAMELEN(gv) = len;
--- 110,116 ----
GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
GvCVGEN(gv) = 0;
GvEGV(gv) = gv;
! sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
GvNAME(gv) = savepvn(name, len);
GvNAMELEN(gv) = len;
***************
*** 126,132 ****
PL_sub_generation++;
CvGV(GvCV(gv)) = gv;
! CvFILE(GvCV(gv)) = CopFILE(PL_curcop);
CvSTASH(GvCV(gv)) = PL_curstash;
#ifdef USE_THREADS
CvOWNER(GvCV(gv)) = 0;
--- 126,132 ----
PL_sub_generation++;
CvGV(GvCV(gv)) = gv;
! CvFILE_set_from_cop(GvCV(gv), PL_curcop);
CvSTASH(GvCV(gv)) = PL_curstash;
#ifdef USE_THREADS
CvOWNER(GvCV(gv)) = 0;
***************
*** 163,169 ****
Returns the glob with the given C<name> and a defined subroutine or
C<NULL>. The glob lives in the given C<stash>, or in the stashes
! accessible via @ISA and @UNIVERSAL.
The argument C<level> should be either 0 or -1. If C<level==0>, as a
side-effect creates a glob with the given C<name> in the given C<stash>
--- 163,169 ----
Returns the glob with the given C<name> and a defined subroutine or
C<NULL>. The glob lives in the given C<stash>, or in the stashes
! accessible via @ISA and UNIVERSAL::.
The argument C<level> should be either 0 or -1. If C<level==0>, as a
side-effect creates a glob with the given C<name> in the given C<stash>
***************
*** 188,195 ****
GV** gvp;
CV* cv;
! if (!stash)
! return 0;
if ((level > 100) || (level < -100))
Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
name, HvNAME(stash));
--- 188,200 ----
GV** gvp;
CV* cv;
! /* UNIVERSAL methods should be callable without a stash */
! if (!stash) {
! level = -1; /* probably appropriate */
! if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE)))
! return 0;
! }
!
if ((level > 100) || (level < -100))
Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
name, HvNAME(stash));
***************
*** 363,374 ****
/* ->SUPER::method should really be looked up in original stash */
SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
CopSTASHPV(PL_curcop)));
stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
origname, HvNAME(stash), name) );
}
else
! stash = gv_stashpvn(origname, nsplit - origname, TRUE);
}
gv = gv_fetchmeth(stash, name, nend - name, 0);
--- 368,381 ----
/* ->SUPER::method should really be looked up in original stash */
SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
CopSTASHPV(PL_curcop)));
+ /* __PACKAGE__::SUPER stash should be autovivified */
stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
origname, HvNAME(stash), name) );
}
else
! /* don't autovifify if ->NoSuchStash::method */
! stash = gv_stashpvn(origname, nsplit - origname, FALSE);
}
gv = gv_fetchmeth(stash, name, nend - name, 0);
***************
*** 412,417 ****
--- 419,426 ----
GV* vargv;
SV* varsv;
+ if (!stash)
+ return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */
if (len == autolen && strnEQ(name, autoload, autolen))
return Nullgv;
if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
***************
*** 438,444 ****
* pass along the same data via some unused fields in the CV
*/
CvSTASH(cv) = stash;
! SvPVX(cv) = (char *)name; /* cast to loose constness warning */
SvCUR(cv) = len;
return gv;
}
--- 447,453 ----
* pass along the same data via some unused fields in the CV
*/
CvSTASH(cv) = stash;
! SvPVX(cv) = (char *)name; /* cast to lose constness warning */
SvCUR(cv) = len;
return gv;
}
***************
*** 750,756 ****
if (strEQ(name, "ISA")) {
AV* av = GvAVn(gv);
GvMULTI_on(gv);
! sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
/* NOTE: No support for tied ISA */
if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
&& AvFILLp(av) == -1)
--- 759,765 ----
if (strEQ(name, "ISA")) {
AV* av = GvAVn(gv);
GvMULTI_on(gv);
! sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
/* NOTE: No support for tied ISA */
if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
&& AvFILLp(av) == -1)
***************
*** 773,779 ****
if (strEQ(name, "OVERLOAD")) {
HV* hv = GvHVn(gv);
GvMULTI_on(gv);
! hv_magic(hv, Nullgv, 'A');
}
break;
case 'S':
--- 782,788 ----
if (strEQ(name, "OVERLOAD")) {
HV* hv = GvHVn(gv);
GvMULTI_on(gv);
! hv_magic(hv, Nullgv, PERL_MAGIC_overload);
}
break;
case 'S':
***************
*** 787,793 ****
}
GvMULTI_on(gv);
hv = GvHVn(gv);
! hv_magic(hv, Nullgv, 'S');
for (i = 1; i < SIG_SIZE; i++) {
SV ** init;
init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
--- 796,802 ----
}
GvMULTI_on(gv);
hv = GvHVn(gv);
! hv_magic(hv, Nullgv, PERL_MAGIC_sig);
for (i = 1; i < SIG_SIZE; i++) {
SV ** init;
init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
***************
*** 846,852 ****
now (rather than going to magicalize)
*/
! sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
if (sv_type == SVt_PVHV)
require_errno(gv);
--- 855,861 ----
now (rather than going to magicalize)
*/
! sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
if (sv_type == SVt_PVHV)
require_errno(gv);
***************
*** 857,863 ****
break;
else {
AV* av = GvAVn(gv);
! sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
SvREADONLY_on(av);
}
goto magicalize;
--- 866,872 ----
break;
else {
AV* av = GvAVn(gv);
! sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
SvREADONLY_on(av);
}
goto magicalize;
***************
*** 886,891 ****
--- 895,901 ----
case '\006': /* $^F */
case '\010': /* $^H */
case '\011': /* $^I, NOT \t in EBCDIC */
+ case '\016': /* $^N */
case '\020': /* $^P */
case '\024': /* $^T */
if (len > 1)
***************
*** 915,921 ****
break;
else {
AV* av = GvAVn(gv);
! sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
SvREADONLY_on(av);
}
/* FALL THROUGH */
--- 925,931 ----
break;
else {
AV* av = GvAVn(gv);
! sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
SvREADONLY_on(av);
}
/* FALL THROUGH */
***************
*** 931,937 ****
ro_magicalize:
SvREADONLY_on(GvSV(gv));
magicalize:
! sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
break;
case '\014': /* $^L */
--- 941,947 ----
ro_magicalize:
SvREADONLY_on(GvSV(gv));
magicalize:
! sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
break;
case '\014': /* $^L */
***************
*** 1066,1072 ****
for (i = 0; i <= (I32) HvMAX(stash); i++) {
for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
! (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
{
if (hv != PL_defstash && hv != stash)
gv_check(hv); /* nested package */
--- 1076,1082 ----
for (i = 0; i <= (I32) HvMAX(stash); i++) {
for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
! (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)))
{
if (hv != PL_defstash && hv != stash)
gv_check(hv); /* nested package */
***************
*** 1081,1087 ****
* module, don't bother warning */
if (file
&& PERL_FILE_IS_ABSOLUTE(file)
! && (instr(file, "/lib/") || instr(file, ".pm")))
{
continue;
}
--- 1091,1102 ----
* module, don't bother warning */
if (file
&& PERL_FILE_IS_ABSOLUTE(file)
! #ifdef MACOS_TRADITIONAL
! && (instr(file, ":lib:")
! #else
! && (instr(file, "/lib/")
! #endif
! || instr(file, ".pm")))
{
continue;
}
***************
*** 1211,1225 ****
{
GV* gv;
CV* cv;
! MAGIC* mg=mg_find((SV*)stash,'c');
AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
AMT amt;
- STRLEN n_a;
if (mg && amtp->was_ok_am == PL_amagic_generation
&& amtp->was_ok_sub == PL_sub_generation)
return AMT_OVERLOADED(amtp);
! sv_unmagic((SV*)stash, 'c');
DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
--- 1226,1239 ----
{
GV* gv;
CV* cv;
! MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
AMT amt;
if (mg && amtp->was_ok_am == PL_amagic_generation
&& amtp->was_ok_sub == PL_sub_generation)
return AMT_OVERLOADED(amtp);
! sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
***************
*** 1268,1274 ****
GV *ngv;
DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
! SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
if (!SvPOK(GvSV(gv))
|| !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
FALSE)))
--- 1282,1288 ----
GV *ngv;
DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
! SvPV_nolen(GvSV(gv)), cp, HvNAME(stash)) );
if (!SvPOK(GvSV(gv))
|| !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
FALSE)))
***************
*** 1298,1304 ****
AMT_AMAGIC_on(&amt);
if (have_ovl)
AMT_OVERLOADED_on(&amt);
! sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
return have_ovl;
}
}
--- 1312,1319 ----
AMT_AMAGIC_on(&amt);
if (have_ovl)
AMT_OVERLOADED_on(&amt);
! sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
! (char*)&amt, sizeof(AMT));
return have_ovl;
}
}
***************
*** 1305,1311 ****
/* Here we have no table: */
/* no_table: */
AMT_AMAGIC_off(&amt);
! sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
return FALSE;
}
--- 1320,1327 ----
/* Here we have no table: */
/* no_table: */
AMT_AMAGIC_off(&amt);
! sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
! (char*)&amt, sizeof(AMTS));
return FALSE;
}
***************
*** 1318,1328 ****
if (!stash)
return Nullcv;
! mg = mg_find((SV*)stash,'c');
if (!mg) {
do_update:
Gv_AMupdate(stash);
! mg = mg_find((SV*)stash,'c');
}
amtp = (AMT*)mg->mg_ptr;
if ( amtp->was_ok_am != PL_amagic_generation
--- 1334,1344 ----
if (!stash)
return Nullcv;
! mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
if (!mg) {
do_update:
Gv_AMupdate(stash);
! mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
}
amtp = (AMT*)mg->mg_ptr;
if ( amtp->was_ok_am != PL_amagic_generation
***************
*** 1338,1351 ****
Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
{
MAGIC *mg;
! CV *cv;
CV **cvp=NULL, **ocvp=NULL;
! AMT *amtp, *oamtp;
! int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
! HV* stash;
if (!(AMGf_noleft & flags) && SvAMAGIC(left)
! && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
&& (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
: (CV **) NULL))
--- 1354,1371 ----
Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
{
MAGIC *mg;
! CV *cv=NULL;
CV **cvp=NULL, **ocvp=NULL;
! AMT *amtp=NULL, *oamtp=NULL;
! int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
! #ifdef DEBUGGING
! int fl=0;
! #endif
! HV* stash=NULL;
if (!(AMGf_noleft & flags) && SvAMAGIC(left)
! && (stash = SvSTASH(SvRV(left)))
! && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
&& (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
: (CV **) NULL))
***************
*** 1352,1358 ****
&& ((cv = cvp[off=method+assignshift])
|| (assign && amtp->fallback > AMGfallNEVER && /* fallback to
* usual method */
! (fl = 1, cv = cvp[off=method])))) {
lr = -1; /* Call method for left argument */
} else {
if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
--- 1372,1382 ----
&& ((cv = cvp[off=method+assignshift])
|| (assign && amtp->fallback > AMGfallNEVER && /* fallback to
* usual method */
! (
! #ifdef DEBUGGING
! fl = 1,
! #endif
! cv = cvp[off=method])))) {
lr = -1; /* Call method for left argument */
} else {
if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
***************
*** 1458,1464 ****
}
if (!cv) goto not_found;
} else if (!(AMGf_noright & flags) && SvAMAGIC(right)
! && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
&& (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
? (amtp = (AMT*)mg->mg_ptr)->table
: (CV **) NULL))
--- 1482,1489 ----
}
if (!cv) goto not_found;
} else if (!(AMGf_noright & flags) && SvAMAGIC(right)
! && (stash = SvSTASH(SvRV(right)))
! && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
&& (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
? (amtp = (AMT*)mg->mg_ptr)->table
: (CV **) NULL))
***************
*** 1544,1564 ****
force_cpy = force_cpy || assign;
}
}
if (!notfound) {
! DEBUG_o( Perl_deb(aTHX_
! "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
! AMG_id2name(off),
! method+assignshift==off? "" :
! " (initially `",
! method+assignshift==off? "" :
! AMG_id2name(method+assignshift),
! method+assignshift==off? "" : "')",
! flags & AMGf_unary? "" :
! lr==1 ? " for right argument": " for left argument",
! flags & AMGf_unary? " for argument" : "",
! HvNAME(stash),
! fl? ",\n\tassignment variant used": "") );
}
/* Since we use shallow copy during assignment, we need
* to dublicate the contents, probably calling user-supplied
* version of copy operator
--- 1569,1591 ----
force_cpy = force_cpy || assign;
}
}
+ #ifdef DEBUGGING
if (!notfound) {
! DEBUG_o(Perl_deb(aTHX_
! "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
! AMG_id2name(off),
! method+assignshift==off? "" :
! " (initially `",
! method+assignshift==off? "" :
! AMG_id2name(method+assignshift),
! method+assignshift==off? "" : "')",
! flags & AMGf_unary? "" :
! lr==1 ? " for right argument": " for left argument",
! flags & AMGf_unary? " for argument" : "",
! stash ? HvNAME(stash) : "null",
! fl? ",\n\tassignment variant used": "") );
}
+ #endif
/* Since we use shallow copy during assignment, we need
* to dublicate the contents, probably calling user-supplied
* version of copy operator
***************
*** 1627,1633 ****
CATCH_SET(oldcatch);
if (postpr) {
! int ans;
switch (method) {
case le_amg:
case sle_amg:
--- 1654,1660 ----
CATCH_SET(oldcatch);
if (postpr) {
! int ans=0;
switch (method) {
case le_amg:
case sle_amg:
***************
*** 1747,1752 ****
--- 1774,1780 ----
case '\010': /* $^H */
case '\011': /* $^I, NOT \t in EBCDIC */
case '\014': /* $^L */
+ case '\016': /* $^N */
case '\020': /* $^P */
case '\023': /* $^S */
case '\024': /* $^T */
diff -c 'perl-5.7.1/gv.h' 'perl-5.7.2/gv.h'
Index: ./gv.h
*** ./gv.h Tue Mar 6 04:05:11 2001
--- ./gv.h Mon Jul 9 17:10:18 2001
***************
*** 133,147 ****
/* XXX: all GvFLAGS options are used, borrowing GvGPFLAGS for the moment */
! #define GVf_SHARED 0x0001
! #define GvSHARED(gv) (GvGP(gv) && (GvGPFLAGS(gv) & GVf_SHARED))
! #define GvSHARED_on(gv) (GvGPFLAGS(gv) |= GVf_SHARED)
! #define GvSHARED_off(gv) (GvGPFLAGS(gv) &= ~GVf_SHARED)
#ifdef USE_ITHREADS
! #define GV_SHARED_CHECK
#else
! #undef GV_SHARED_CHECK
#endif
#define Nullgv Null(GV*)
--- 133,147 ----
/* XXX: all GvFLAGS options are used, borrowing GvGPFLAGS for the moment */
! #define GVf_UNIQUE 0x0001
! #define GvUNIQUE(gv) (GvGP(gv) && (GvGPFLAGS(gv) & GVf_UNIQUE))
! #define GvUNIQUE_on(gv) (GvGPFLAGS(gv) |= GVf_UNIQUE)
! #define GvUNIQUE_off(gv) (GvGPFLAGS(gv) &= ~GVf_UNIQUE)
#ifdef USE_ITHREADS
! #define GV_UNIQUE_CHECK
#else
! #undef GV_UNIQUE_CHECK
#endif
#define Nullgv Null(GV*)
diff -c 'perl-5.7.1/handy.h' 'perl-5.7.2/handy.h'
Index: ./handy.h
*** ./handy.h Sat Mar 10 16:24:22 2001
--- ./handy.h Mon Jul 9 17:10:19 2001
***************
*** 116,121 ****
--- 116,129 ----
#ifdef I_INTTYPES /* e.g. Linux has int64_t without <inttypes.h> */
# include <inttypes.h>
+ # ifdef INT32_MIN_BROKEN
+ # undef INT32_MIN
+ # define INT32_MIN (-2147483647-1)
+ # endif
+ # ifdef INT64_MIN_BROKEN
+ # undef INT64_MIN
+ # define INT64_MIN (-9223372036854775807LL-1)
+ # endif
#endif
typedef I8TYPE I8;
***************
*** 194,199 ****
--- 202,208 ----
#endif
+ /* log(2) is pretty close to 0.30103, just in case anyone is grepping for it */
#define BIT_DIGITS(N) (((N)*146)/485 + 1) /* log2(10) =~ 146/485 */
#define TYPE_DIGITS(T) BIT_DIGITS(sizeof(T) * 8)
#define TYPE_CHARS(T) (TYPE_DIGITS(T) + 2) /* sign, NUL */
***************
*** 334,340 ****
# define isASCII(c) ((c) <= 127)
# define isCNTRL(c) ((c) < ' ')
# define isGRAPH(c) (isALNUM(c) || isPUNCT(c))
! # define isPRINT(c) (((c) > 32 && (c) < 127) || isSPACE(c))
# define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126))
# define isXDIGIT(c) (isdigit(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F'))
# define toUPPER(c) (isLOWER(c) ? (c) - ('a' - 'A') : (c))
--- 343,349 ----
# define isASCII(c) ((c) <= 127)
# define isCNTRL(c) ((c) < ' ')
# define isGRAPH(c) (isALNUM(c) || isPUNCT(c))
! # define isPRINT(c) (((c) > 32 && (c) < 127) || (c) == ' ')
# define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126))
# define isXDIGIT(c) (isdigit(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F'))
# define toUPPER(c) (isLOWER(c) ? (c) - ('a' - 'A') : (c))
diff -c 'perl-5.7.1/hints/aix.sh' 'perl-5.7.2/hints/aix.sh'
Index: ./hints/aix.sh
*** ./hints/aix.sh Fri Mar 23 19:04:20 2001
--- ./hints/aix.sh Thu Jul 12 21:49:40 2001
***************
*** 54,63 ****
# AIX 4.3.* and above default to using nm for symbol extraction
case "$osvers" in
3.*|4.1.*|4.2.*)
! usenm='undef'
;;
*)
! usenm='true'
;;
esac
--- 54,73 ----
# AIX 4.3.* and above default to using nm for symbol extraction
case "$osvers" in
3.*|4.1.*|4.2.*)
! case "$usenm" in
! '') usenm='undef'
! esac
! case "$usenativedlopen" in
! '') usenativedlopen='false'
! esac
;;
*)
! case "$usenm" in
! '') usenm='true'
! esac
! case "$usenativedlopen" in
! '') usenativedlopen='true'
! esac
;;
esac
***************
*** 126,131 ****
--- 136,142 ----
# Changes for dynamic linking by Wayne Scott <wscott@ichips.intel.com>
#
# Tell perl which symbols to export for dynamic linking.
+ cccdlflags='none' # All AIX code is position independent
case "$cc" in
*gcc*) ccdlflags='-Xlinker' ;;
*) ccversion=`lslpp -L | grep 'C for AIX Compiler$' | awk '{print $2}'`
***************
*** 189,195 ****
lddlflags="$lddlflags -H512 -T512 -bhalt:4 -bM:SRE -bI:\$(PERL_INC)/perl.exp -bE:\$(BASEEXT).exp -e _nostart -lc"
;;
*)
! lddlflags="$lddlflags -bhalt:4 -bM:SRE -bI:\$(PERL_INC)/perl.exp -bE:\$(BASEEXT).exp -b noentry -lc"
;;
esac
# AIX 4.2 (using latest patchlevels on 20001130) has a broken bind
--- 200,206 ----
lddlflags="$lddlflags -H512 -T512 -bhalt:4 -bM:SRE -bI:\$(PERL_INC)/perl.exp -bE:\$(BASEEXT).exp -e _nostart -lc"
;;
*)
! lddlflags="$lddlflags -bhalt:4 -bM:SRE -bI:\$(PERL_INC)/perl.exp -bE:\$(BASEEXT).exp -bnoentry -lc"
;;
esac
# AIX 4.2 (using latest patchlevels on 20001130) has a broken bind
***************
*** 196,202 ****
# library (getprotobyname and getprotobynumber are outversioned by
# the same calls in libc, at least for xlc version 3...
case "`oslevel`" in
! 4.2.1.*) # Test for xlc version too, should we?
case "$ccversion" in # Don't know if needed for gcc
3.1.4.*) # libswanted "bind ... c ..." => "... c bind ..."
set `echo X "$libswanted "| sed -e 's/ bind\( .*\) \([cC]\) / \1 \2 bind /'`
--- 207,213 ----
# library (getprotobyname and getprotobynumber are outversioned by
# the same calls in libc, at least for xlc version 3...
case "`oslevel`" in
! 4.2.1.*)
case "$ccversion" in # Don't know if needed for gcc
3.1.4.*) # libswanted "bind ... c ..." => "... c bind ..."
set `echo X "$libswanted "| sed -e 's/ bind\( .*\) \([cC]\) / \1 \2 bind /'`
***************
*** 246,256 ****
lddlflags="$*"
# Insert pthreads to libswanted, before any libc or libC.
! set `echo X "$libswanted "| sed -e 's/ \([cC]\) / pthreads \1 /'`
shift
libswanted="$*"
# Insert pthreads to lddlflags, before any libc or libC.
! set `echo X "$lddlflags " | sed -e 's/ \(-l[cC]\) / -lpthreads \1 /'`
shift
lddlflags="$*"
--- 257,267 ----
lddlflags="$*"
# Insert pthreads to libswanted, before any libc or libC.
! set `echo X "$libswanted "| sed -e 's/ \([cC]_r\) / pthreads \1 /'`
shift
libswanted="$*"
# Insert pthreads to lddlflags, before any libc or libC.
! set `echo X "$lddlflags " | sed -e 's/ \(-l[cC]_r\) / -lpthreads \1 /'`
shift
lddlflags="$*"
***************
*** 263,271 ****
--- 274,290 ----
cat > UU/uselargefiles.cbu <<'EOCBU'
case "$uselargefiles" in
''|$define|true|[yY]*)
+ # Configure should take care of use64bitint and use64bitall being
+ # defined before uselargefiles.cbu is consulted.
+ if test X"$use64bitint:$quadtype" = X"$define:long" -o X"$use64bitall" = Xdefine; then
# Keep these at the left margin.
+ ccflags_uselargefiles="`getconf XBS5_LP64_OFF64_CFLAGS 2>/dev/null`"
+ ldflags_uselargefiles="`getconf XBS5_LP64_OFF64_LDFLAGS 2>/dev/null`"
+ else
+ # Keep these at the left margin.
ccflags_uselargefiles="`getconf XBS5_ILP32_OFFBIG_CFLAGS 2>/dev/null`"
ldflags_uselargefiles="`getconf XBS5_ILP32_OFFBIG_LDFLAGS 2>/dev/null`"
+ fi
# _Somehow_ in AIX 4.3.1.0 the above getconf call manages to
# insert(?) *something* to $ldflags so that later (in Configure) evaluating
# $ldflags causes a newline after the '-b64' (the result of the getconf).
***************
*** 277,284 ****
--- 296,308 ----
# Therefore the line re-evaluating ldflags_uselargefiles: it seems to fix
# the whatever it was that AIX managed to break. --jhi
ldflags_uselargefiles="`echo $ldflags_uselargefiles`"
+ if test X"$use64bitint:$quadtype" = X"$define:long" -o X"$use64bitall" = Xdefine; then
# Keep this at the left margin.
+ libswanted_uselargefiles="`getconf XBS5_LP64_OFF64_LIBS 2>/dev/null|sed -e 's@^-l@@' -e 's@ -l@ @g`"
+ else
+ # Keep this at the left margin.
libswanted_uselargefiles="`getconf XBS5_ILP32_OFFBIG_LIBS 2>/dev/null|sed -e 's@^-l@@' -e 's@ -l@ @g`"
+ fi
case "$ccflags_uselargefiles$ldflags_uselargefiles$libs_uselargefiles" in
'');;
*) ccflags="$ccflags $ccflags_uselargefiles"
***************
*** 299,306 ****
# Remove xlc-spefific -qflags.
ccflags="`echo $ccflags | sed -e 's@ -q[^ ]*@ @g' -e 's@^-q[^ ]* @@g'`"
ldflags="`echo $ldflags | sed -e 's@ -q[^ ]*@ @g' -e 's@^-q[^ ]* @@g'`"
! echo >&4 "(using ccflags $ccflags)"
! echo >&4 "(using ldflags $ldflags)"
;;
esac
;;
--- 323,336 ----
# Remove xlc-spefific -qflags.
ccflags="`echo $ccflags | sed -e 's@ -q[^ ]*@ @g' -e 's@^-q[^ ]* @@g'`"
ldflags="`echo $ldflags | sed -e 's@ -q[^ ]*@ @g' -e 's@^-q[^ ]* @@g'`"
! # Move xld-spefific -bflags.
! ccflags="`echo $ccflags | sed -e 's@ -b@ -Wl,-b@g'`"
! ldflags="`echo ' '$ldflags | sed -e 's@ -b@ -Wl,-b@g'`"
! lddlflags="`echo ' '$lddlflags | sed -e 's@ -b@ -Wl,-b@g'`"
! ld='gcc'
! echo >&4 "(using ccflags $ccflags)"
! echo >&4 "(using ldflags $ldflags)"
! echo >&4 "(using lddlflags $lddlflags)"
;;
esac
;;
***************
*** 430,460 ****
# after it has prompted the user for whether to use long doubles.
case "$uselongdouble" in
$define|true|[yY]*)
! case "$cc" in
! *gcc*) ;;
! *) ccflags="$ccflags -qlongdouble" ;;
! esac
! # The explicit cc128, xlc128, xlC128 are not needed,
! # the -qlongdouble should do the trick. --jhi
! d_Gconvert='sprintf((b),"%.*llg",(n),(x))'
;;
esac
EOCBU
! # If the C++ libraries, libC and libC_r, are available we will prefer them
! # over the vanilla libc, because the libC contain loadAndInit() and
! # terminateAndUnload() which work correctly with C++ statics while libc
! # load() and unload() do not. See ext/DynaLoader/dl_aix.xs.
! # The C-to-C_r switch is done by usethreads.cbu, if needed.
! if test -f /lib/libC.a -a X"`$cc -v 2>&1 | grep gcc`" = X; then
! # Cify libswanted.
! set `echo X "$libswanted "| sed -e 's/ c / C c /'`
! shift
! libswanted="$*"
! # Cify lddlflags.
! set `echo X "$lddlflags "| sed -e 's/ -lc / -lC -lc /'`
! shift
! lddlflags="$*"
fi
# EOF
--- 460,499 ----
# after it has prompted the user for whether to use long doubles.
case "$uselongdouble" in
$define|true|[yY]*)
! # -qlongdouble for cc taken out on 20010522 cause it
! # causes more trouble than it does any good --hmb
! d_Gconvert='sprintf((b),"%.*llg",((int)(n)),(x))'
;;
esac
EOCBU
! if test $usenativedlopen = 'true'
! then
! ccflags="$ccflags -DUSE_NATIVE_DLOPEN"
! case "$cc" in
! *gcc*) ldflags="$ldflags -Wl,-brtl" ;;
! *) ldflags="$ldflags -brtl" ;;
! esac
! else
! case `oslevel` in
! 4.2.*) ;; # libC_r has broke gettimeofday
! *) # If the C++ libraries, libC and libC_r, are available we will
! # prefer them over the vanilla libc, because the libC contain
! # loadAndInit() and terminateAndUnload() which work correctly
! # with C++ statics while libc load() and unload() do not. See
! # ext/DynaLoader/dl_aix.xs. The C-to-C_r switch is done by
! # usethreads.cbu, if needed.
! if test -f /lib/libC.a -a X"`$cc -v 2>&1 | grep gcc`" = X; then
! # Cify libswanted.
! set `echo X "$libswanted "| sed -e 's/ c / C c /'`
! shift
! libswanted="$*"
! # Cify lddlflags.
! set `echo X "$lddlflags "| sed -e 's/ -lc / -lC -lc /'`
! shift
! lddlflags="$*"
! fi
! esac
fi
# EOF
diff -c /dev/null 'perl-5.7.2/hints/atheos.sh'
Index: ./hints/atheos.sh
*** ./hints/atheos.sh Thu Jan 1 02:00:00 1970
--- ./hints/atheos.sh Mon Jul 9 17:10:19 2001
***************
*** 0 ****
--- 1,35 ----
+ # AtheOS hints file ( http://www.atheos.cx/ )
+ # Kurt Skauen, kurt@atheos.cx
+
+ prefix="/usr/perl5"
+
+ libpth='/system/libs /usr/lib'
+ usrinc='/include'
+
+ libs=' '
+
+ d_htonl='define'
+ d_htons='define'
+ d_ntohl='define'
+ d_ntohs='define'
+
+ d_locconv='undef'
+
+ # POSIX and BSD functions are scattered over several non-standard libraries
+ # in AtheOS, so I figured it would be safer to let the linker figure out
+ # which symbols are available.
+
+ usenm='false'
+
+ # Hopefully, the native malloc knows better than perl's.
+ usemymalloc='n'
+
+ # AtheOS native FS does not support hard-links, but link() is defined
+ # (for other FS's).
+
+ d_link='undef'
+ dont_use_nlink='define'
+
+ ld='gcc'
+ cc='gcc'
+
diff -c 'perl-5.7.1/hints/darwin.sh' 'perl-5.7.2/hints/darwin.sh'
Index: ./hints/darwin.sh
*** ./hints/darwin.sh Thu Apr 5 16:01:06 2001
--- ./hints/darwin.sh Mon Jul 9 17:10:19 2001
***************
*** 1,6 ****
##
# Darwin (Mac OS) hints
! # Wilfredo Sanchez <wsanchez@apple.com>
##
##
--- 1,6 ----
##
# Darwin (Mac OS) hints
! # Wilfredo Sanchez <wsanchez@mit.edu>
##
##
***************
*** 8,26 ****
##
# BSD paths
! prefix='/usr';
! siteprefix='/usr/local';
! vendorprefix='/usr/local'; usevendorprefix='define';
! # 4BSD uses /usr/share/man, not /usr/man.
! # Don't put man pages in /usr/lib; that's goofy.
! man1dir='/usr/share/man/man1';
! man3dir='/usr/share/man/man3';
! # Where to put modules.
! privlib='/System/Library/Perl';
! sitelib='/Local/Library/Perl';
! vendorlib='/Network/Library/Perl';
##
# Tool chain settings
--- 8,31 ----
##
# BSD paths
! case "$prefix" in
! '')
! prefix='/usr/local'; # Built-in perl uses /usr
! siteprefix='/usr/local';
! vendorprefix='/usr/local'; usevendorprefix='define';
! # 4BSD uses ${prefix}/share/man, not ${prefix}/man.
! # Don't put man pages in ${prefix}/lib; that's goofy.
! man1dir="${prefix}/share/man/man1";
! man3dir="${prefix}/share/man/man3";
! # Where to put modules.
! # Built-in perl uses /System/Library/Perl
! privlib='/Library/Perl';
! sitelib='/Library/Perl';
! vendorlib='/Network/Library/Perl';
! ;;
! esac
##
# Tool chain settings
***************
*** 33,39 ****
usenm='true';
# Libc is in libsystem.
! libc='/System/Library/Frameworks/System.framework/System';
# Optimize.
optimize='-O3';
--- 38,44 ----
usenm='true';
# Libc is in libsystem.
! #libc='/usr/lib/libSystem.dylib';
# Optimize.
optimize='-O3';
***************
*** 41,47 ****
# We have a prototype for telldir.
ccflags="${ccflags} -pipe -fno-common -DHAS_TELLDIR_PROTOTYPE";
! # For Errno.
cppflags='-traditional-cpp';
# Shared library extension is .dylib.
--- 46,71 ----
# We have a prototype for telldir.
ccflags="${ccflags} -pipe -fno-common -DHAS_TELLDIR_PROTOTYPE";
! # At least on Darwin 1.3.x:
! #
! # # define INT32_MIN -2147483648
! # int main () {
! # double a = INT32_MIN;
! # printf ("INT32_MIN=%g\n", a);
! # return 0;
! # }
! # will output:
! # INT32_MIN=2.14748e+09
! # Note that the INT32_MIN has become positive.
! # INT32_MIN is set in /usr/include/stdint.h by:
! # #define INT32_MIN -2147483648
! # which seems to break the gcc. Defining INT32_MIN as (-2147483647-1)
! # seems to work. INT64_MIN seems to be similarly broken.
! # -- Nicholas Clark, Ken Williams, and Edward Moy
! #
! ccflags="${ccflags} -DINT32_MIN_BROKEN -DINT64_MIN_BROKEN"
!
! # cpp-precomp is problematic.
cppflags='-traditional-cpp';
# Shared library extension is .dylib.
***************
*** 65,67 ****
--- 89,102 ----
# malloc works
usemymalloc='n';
+ ##
+ # Build process
+ ##
+
+ # Locales aren't feeling well.
+ LC_ALL=C; export LC_ALL;
+
+ # Case-insensitive filesystems don't get along with Makefile and
+ # makefile in the same place. Since Darwin uses GNU make, this dodges
+ # the problem.
+ firstmakefile=GNUmakefile;
diff -c 'perl-5.7.1/hints/dec_osf.sh' 'perl-5.7.2/hints/dec_osf.sh'
Index: ./hints/dec_osf.sh
*** ./hints/dec_osf.sh Tue Mar 6 04:05:13 2001
--- ./hints/dec_osf.sh Mon Jul 9 17:10:19 2001
***************
*** 281,289 ****
# This script UU/uselongdouble.cbu will get 'called-back' by Configure
# after it has prompted the user for whether to use long doubles.
case "$uselongdouble" in
! $define|true|[yY]*) d_Gconvert='sprintf((b),"%.*Lg",(n),(x))' ;;
esac
EOCBU
#
# Unset temporary variables no more needed.
--- 281,308 ----
# This script UU/uselongdouble.cbu will get 'called-back' by Configure
# after it has prompted the user for whether to use long doubles.
case "$uselongdouble" in
! $define|true|[yY]*)
! case "`/usr/sbin/sizer -v`" in
! *[1-4].0*) cat >&4 <<EOF
!
! ***
! *** Sorry, you cannot use long doubles in pre-V5.0 releases of Tru64.
! ***
!
! Cannot continue, aborting.
!
! EOF
! exit 1
! ;;
! esac
! d_Gconvert='sprintf((b),"%.*Lg",(n),(x))'
! ;;
esac
EOCBU
+
+ case "`/usr/sbin/sizer -v`" in
+ *[1-4].0*) d_modfl=undef ;; # must wait till 5.0
+ esac
#
# Unset temporary variables no more needed.
diff -c 'perl-5.7.1/hints/dgux.sh' 'perl-5.7.2/hints/dgux.sh'
Index: ./hints/dgux.sh
Prereq: 1.8
*** ./hints/dgux.sh Tue Mar 6 04:05:13 2001
--- ./hints/dgux.sh Mon Jul 9 17:10:19 2001
***************
*** 1,7 ****
! # $Id: dgux.sh,v 1.8 1996-11-29 18:16:43-05 roderick Exp $
! # This is a hints file for DGUX, which is Data General's Unix. It was
! # originally developed with version 5.4.3.10 of the OS, and then was
# later updated running under version 4.11.2 (running on m88k hardware).
# The gross features should work with versions going back to 2.nil but
# some tweaking will probably be necessary.
--- 1,7 ----
! # $Id: dgux.sh,v 1.9 2001-05-07 00:06:00-05 Takis Exp $
! # This is a hints file for DGUX, which is EMC's Data General's Unix. It
! # was originally developed with version 5.4.3.10 of the OS, and then was
# later updated running under version 4.11.2 (running on m88k hardware).
# The gross features should work with versions going back to 2.nil but
# some tweaking will probably be necessary.
***************
*** 16,73 ****
#
# -Roderick Schertler <roderick@argon.org>
- # Here are the things from some old DGUX hints files which are different
- # from what's in here now. I don't know the exact reasons that most of
- # these settings were in the hints files, presumably they can be chalked
- # up to old Configure inadequacies and changes in the OS headers and the
- # like. These settings might make a good place to start looking if you
- # have problems.
- #
- # This was specified the the 4.036 hints file. That hints file didn't
- # say what version of the OS it was developed using.
- #
- # cppstdin='/lib/cpp'
- #
- # The 4.036 and 5.001 hints files both contained these. The 5.001 hints
- # file said it was developed with version 2.01 of DGUX.
- #
- # gidtype='gid_t'
- # groupstype='gid_t'
- # uidtype='uid_t'
- # d_index='define'
- # cc='gcc'
- #
- # These were peculiar to the 5.001 hints file.
- #
- # ccflags='-D_POSIX_SOURCE -D_DGUX_SOURCE'
- #
- # # an ugly hack, since the Configure test for "gcc -P -" hangs.
- # # can't just use 'cppstdin', since our DG has a broken cppstdin :-(
- # cppstdin=`cd ..; pwd`/cppstdin
- # cpprun=`cd ..; pwd`/cppstdin
- #
- # One last note: The 5.001 hints file said "you don't want to use
- # /usr/ucb/cc" in the place at which it set cc to gcc. That in
- # particular baffles me, as I used to have 2.01 loaded and my memory
- # is telling me that even then /usr/ucb was a symlink to /usr/bin.
-
-
# The standard system compiler is gcc, but invoking it as cc changes its
# behavior. I have to pick one name or the other so I can get the
# dynamic loading switches right (they vary depending on this). I'm
# picking gcc because there's no way to get at the optimization options
# and so on when you call it cc.
! case $cc in
! '')
! cc=gcc
! case $optimize in
! '') optimize=-O2;;
! esac
! ;;
esac
! usevfork=true
# DG has this thing set up with symlinks which point to different places
# depending on environment variables (see elink(5)) and the compiler and
# related tools use them to access different development environments
--- 16,92 ----
#
# -Roderick Schertler <roderick@argon.org>
# The standard system compiler is gcc, but invoking it as cc changes its
# behavior. I have to pick one name or the other so I can get the
# dynamic loading switches right (they vary depending on this). I'm
# picking gcc because there's no way to get at the optimization options
# and so on when you call it cc.
!
! ##########################################
! # Modified by Takis Psarogiannakopoulos
! # Universirty of Cambridge
! # Centre for Mathematical Sciences
! # Department of Pure Mathematics
! # Wilberforce road
! # Cambridge CB3 0WB , UK
! # e-mail <takis@xfree86.org>
! # Use GCC-2.95.2/3 rev (DG/UX) for threads
! # This compiler supports the -pthread switch
! # to link correctly DG/UX 's -lthread.
! ###########################################
!
! cc=gcc
! ccflags="-DDGUX -D_DGUX_SOURCE"
! # Debug build with GNU as,ld and -gstabs+
! # ccflags="-DDGUX -D_DGUX_SOURCE -gstabs+"
! # Dummy ; always compile with -O2 on GCC 2.95.2/3 rev (DG/UX)
! optimize="-mno-legend -O2"
!
! archname="ix86-dgux"
! libpth="/usr/lib"
!
! #####################################
! # <takis@xfree86.org>
! # Change this if you want.
! # prefix =/usr/local
! #####################################
!
! prefix=/usr/local
! perlpath="$prefix/bin/perl57"
! startperl="#! $prefix/bin/perl57"
! privlib="$prefix/lib/perl57"
! man1dir="$prefix/man/man1"
! man3dir="$prefix/man/man3"
!
! sitearch="$prefix/lib/perl57/$archname"
! sitelib="$prefix/lib/perl57"
!
! #Do not overwrite by default /usr/bin/perl of DG/UX
! installusrbinperl="$undef"
!
! # Configure may fail to find lstat()
! # function in <sys/stat.h>.
! d_lstat=define
!
! # Internal malloc is needed for correct operation
! # of perl-5.7.x
! # DG/UX native malloc is causing problems.
! # Some perl tests they failing badly.
! # I have no time to investigate more.
! # <takis@xfree86.org>
!
! case "$usemymalloc" in
! '') usemymalloc='y' ;;
esac
! case "$uselongdouble" in
! '') uselongdouble='y' ;;
! esac
+ #### No for threads ???? #####
+ #usevfork=true
+ usevfork=false
+
# DG has this thing set up with symlinks which point to different places
# depending on environment variables (see elink(5)) and the compiler and
# related tools use them to access different development environments
***************
*** 117,136 ****
plibpth="$plibpth $sde_path/$sde/usr/lib"
unset sde_path default_sde sde
# Many functions (eg, gethostent(), killpg(), getpriority(), setruid()
# dbm_*(), and plenty more) are defined in -ldgc. Usually you don't
# need to know this (it seems that libdgc.so is searched automatically
# by ld), but Configure needs to check it otherwise it will report all
# those functions as missing.
- libswanted="dgc $libswanted"
# Dynamic loading works using the dlopen() functions. Note that dlfcn.h
# used to be broken, it declared _dl*() rather than dl*(). This was the
# case up to 3.10, it has been fixed in 4.11. I'm not sure if it was
# fixed in 4.10. If you have the older header just ignore the warnings
# (since pointers and integers have the same format on m88k).
! usedl=true
# For cc rather than gcc the flags would be `-K PIC' for compiling and
# -G for loading. I haven't tested this.
! cccdlflags=-fpic
! lddlflags=-shared
--- 136,234 ----
plibpth="$plibpth $sde_path/$sde/usr/lib"
unset sde_path default_sde sde
+ #####################################
+ # <takis@xfree86.org>
+ #####################################
+
+ libperl="libperl57.so"
+
# Many functions (eg, gethostent(), killpg(), getpriority(), setruid()
# dbm_*(), and plenty more) are defined in -ldgc. Usually you don't
# need to know this (it seems that libdgc.so is searched automatically
# by ld), but Configure needs to check it otherwise it will report all
# those functions as missing.
+ #####################################
+ # <takis@xfree86.org>
+ #####################################
+
+ # libswanted="dgc gdbm $libswanted"
+ #libswanted="dbm posix $libswanted"
+ # Remove malloc since we use the internal perl one.
+ libswanted="dbm posix resolv socket nsl dl m"
+
+ #####################################
+ # <takis@xfree86.org>
+ #####################################
+
+ mydomain='.localhost'
+ cf_by=`(whoami) 2>/dev/null`
+ cf_email="$cf_by@localhost"
+
# Dynamic loading works using the dlopen() functions. Note that dlfcn.h
# used to be broken, it declared _dl*() rather than dl*(). This was the
# case up to 3.10, it has been fixed in 4.11. I'm not sure if it was
# fixed in 4.10. If you have the older header just ignore the warnings
# (since pointers and integers have the same format on m88k).
!
! # usedl=true
! usedl=false
!
# For cc rather than gcc the flags would be `-K PIC' for compiling and
# -G for loading. I haven't tested this.
!
! #####################################
! # <takis@xfree86.org>
! # Use -fPIC instead -fpic
! #####################################
!
! cccdlflags=-fPIC
! #We must use gcc
! ld="gcc"
! lddlflags="-shared"
!
! ############################################################################
! # DGUX Posix 4A Draft 10 Thread support
! # <takis@xfree86.org>
! # use Configure -Dusethreads to enable
! ############################################################################
!
! cat > UU/usethreads.cbu <<'EOCBU'
! case "$usethreads" in
! $define|true|[yY]*)
! ccflags="$ccflags"
! shift
! # DG/UX's sched_yield is in -lrte
! # Remove malloc since we use the internal perl one.
! libswanted="dbm posix resolv socket nsl dl m rte"
! archname="ix86-dgux-thread"
! sitearch="$prefix/lib/perl57/$archname"
! sitelib="$prefix/lib/perl57"
! case "$cc" in
! *gcc*)
! #### Use GCC -2.95.2/3 rev (DG/UX) and -pthread
! #### Otherwise take out the switch -pthread
! #### And add manually the -D_POSIX4A_DRAFT10_SOURCE flag.
! ld="gcc"
! ccflags="$ccflags -D_POSIX4A_DRAFT10_SOURCE"
! # Debug build : use -DS flag on command line perl
! # ccflags="$ccflags -DDEBUGGING -D_POSIX4A_DRAFT10_SOURCE -pthread"
! cccdlflags='-fPIC'
! lddlflags="-shared"
! #### Use GCC -2.95.2/3 rev (DG/UX) and -pthread
! #### Otherwise take out the switch -pthread
! #### And add manually the -lthread library.
! ldflags="$ldflags -pthread"
! ;;
!
! *)
! echo "Not supported DG/UX cc and threads !"
! ;;
! esac
! esac
! EOCBU
!
! # "./Configure -d" can't figure this out easily
! d_suidsafe='define'
!
! ###################################################
diff -c 'perl-5.7.1/hints/dos_djgpp.sh' 'perl-5.7.2/hints/dos_djgpp.sh'
Index: ./hints/dos_djgpp.sh
*** ./hints/dos_djgpp.sh Tue Mar 6 04:05:13 2001
--- ./hints/dos_djgpp.sh Mon Jul 9 17:10:19 2001
***************
*** 71,73 ****
--- 71,75 ----
;;
esac
EOCBU
+
+ useperlio='undef'
diff -c 'perl-5.7.1/hints/dynixptx.sh' 'perl-5.7.2/hints/dynixptx.sh'
Index: ./hints/dynixptx.sh
*** ./hints/dynixptx.sh Tue Mar 6 04:05:13 2001
--- ./hints/dynixptx.sh Wed Jul 11 04:34:34 2001
***************
*** 44,50 ****
# Jarkko Hietaniemi November 1998
case "$osvers" in
! 4.4*) # configure doesn't find sockets, as they're in libsocket, not libc
d_socket='define'
d_oldsock='undef'
d_sockpair='define'
--- 44,50 ----
# Jarkko Hietaniemi November 1998
case "$osvers" in
! 4.[45]*) # configure doesn't find sockets, as they're in libsocket, not libc
d_socket='define'
d_oldsock='undef'
d_sockpair='define'
diff -c 'perl-5.7.1/hints/freebsd.sh' 'perl-5.7.2/hints/freebsd.sh'
Index: ./hints/freebsd.sh
*** ./hints/freebsd.sh Fri Apr 6 01:24:57 2001
--- ./hints/freebsd.sh Mon Jul 9 17:10:20 2001
***************
*** 123,128 ****
--- 123,129 ----
0*|1*|2*|3*) ;;
*)
+ ccflags="${ccflags} -DHAS_FPSETMASK -DHAS_FLOATINGPOINT_H"
if /usr/bin/file -L /usr/lib/libc.so | /usr/bin/grep -vq "not stripped" ; then
usenm=false
fi
diff -c 'perl-5.7.1/hints/hpux.sh' 'perl-5.7.2/hints/hpux.sh'
Index: ./hints/hpux.sh
*** ./hints/hpux.sh Fri Apr 6 20:19:36 2001
--- ./hints/hpux.sh Mon Jul 9 17:10:20 2001
***************
*** 1,243 ****
! #! /bin/sh
! # hints/hpux.sh
! # Perl Configure hints file for Hewlett-Packard's HP-UX 9.x and 10.x
! # (Hopefully, 7.x through 11.x.)
! #
! # This file is based on hints/hpux_9.sh, Perl Configure hints file for
! # Hewlett Packard HP-UX 9.x
! #
! # Use Configure -Dcc=gcc to use gcc.
! #
! # From: Jeff Okamoto <okamoto@corp.hp.com>
! # and
! # hints/hpux_10.sh, Perl Configure hints file for Hewlett Packard HP-UX 10.x
! # From: Giles Lean <giles@nemeton.com.au>
! # and
! # Use #define CPU_* instead of comments for >= 10.x.
! # Support PA1.2 under 10.x.
! # Distinguish between PA2.0, PA2.1, etc.
! # Distinguish between MC68020, MC68030, MC68040
! # Don't assume every OS != 10 is < 10, (e.g., 11).
! # From: Chuck Phillips <cdp@fc.hp.com>
! # HP-UX 10 pthreads hints: Matthew T Harden <mthard@mthard1.monsanto.com>
! # From: Dominic Dunlop <domo@computer.org>
! # Abort and offer advice if bundled (non-ANSI) C compiler selected
! # From: H.Merijn Brand <h.m.brand@hccnet.nl>
! # ccversion detection
! # perl/64/HP-UX wants libdb-3.0 to be shared ELF 64
! # generic pthread support detection for PTH package
! # This version: March 8, 2000
! # Current maintainer: Jeff Okamoto <okamoto@corp.hp.com>
! #--------------------------------------------------------------------
! # Use Configure -Dcc=gcc to use gcc.
! # Use Configure -Dprefix=/usr/local to install in /usr/local.
! #
! # You may have dynamic loading problems if the environment variable
! # LDOPTS='-a archive'. Under >= 10.x, you can instead LDOPTS='-a
! # archive_shared' to prefer archive libraries without requiring them.
! # Regardless of HPUX release, in the "libs" variable or the ext.libs
! # file, you can always give explicit path names to archive libraries
! # that may not exist on the target machine. E.g., /usr/lib/libndbm.a
! # instead of -lndbm. See also note below on ndbm.
! #
! # ALSO, bear in mind that gdbm and Berkely DB contain incompatible
! # replacements for ndbm (and dbm) routines. If you want concurrent
! # access to ndbm files, you need to make sure libndbm is linked in
! # *before* gdbm and Berkely DB. Lastly, remember to check the
! # "ext.libs" file which is *probably* messing up the order. Often,
! # you can replace ext.libs with an empty file to fix the problem.
! #
! # If you get a message about "too much defining", as may happen
! # in HPUX < 10, you might have to append a single entry to your
! # ccflags: '-Wp,-H256000'
! # NOTE: This is a single entry (-W takes the argument 'p,-H256000').
! #--------------------------------------------------------------------
- # Turn on the _HPUX_SOURCE flag to get many of the HP add-ons
- # regardless of compiler. For the HP ANSI C compiler, you may also
- # want to include +e to enable "long long" and "long double".
- #
- # HP compiler flags to include (if at all) *both* as part of ccflags
- # and cc itself so Configure finds (and builds) everything
- # consistently:
- # -Aa -D_HPUX_SOURCE +e
- #
- # Lastly, you may want to include the "-z" HP linker flag so that
- # reading from a NULL pointer causes a SEGV.
- ccflags="$ccflags -D_HPUX_SOURCE"
! # Check if you're using the bundled C compiler. This compiler doesn't support
! # ANSI C (the -Aa flag) and so is not suitable for perl 5.5 and later.
! case "$cc" in
! '') if cc $ccflags -Aa 2>&1 | $contains 'option' >/dev/null
! then
! cat <<'EOM' >&4
! The bundled C compiler is not ANSI-compliant, and so cannot be used to
! build perl. Please see the file README.hpux for advice on alternative
! compilers.
- Cannot continue, aborting.
- EOM
- exit 1
- else
- ccflags="$ccflags -Aa" # The add-on compiler supports ANSI C
- # cppstdin and cpprun need the -Aa option if you use the unbundled
- # ANSI C compiler (*not* the bundled K&R compiler or gcc)
- # [XXX this should be set automatically by Configure, but isn't yet.]
- # [XXX This is reported not to work. You may have to edit config.sh.
- # After running Configure, set cpprun and cppstdin in config.sh,
- # run "Configure -S" and then "make".]
- cpprun="${cc:-cc} -E -Aa"
- cppstdin="$cpprun"
- cppminus='-'
- cpplast='-'
- fi
- case "$optimize" in
- # For HP's ANSI C compiler, up to "+O3" is safe for everything
- # except shared libraries (PIC code). Max safe for PIC is "+O2".
- # Setting both causes innocuous warnings.
- '') optimize='-O'
- #optimize='+O3'
- #cccdlflags='+z +O2'
- ;;
- esac
- cc=cc
- ;;
- esac
-
cc=${cc:-cc}
case `$cc -v 2>&1`"" in
! *gcc*) ccisgcc="$define" ;;
! *) ccisgcc=''
! ccversion=`which cc | xargs what | awk '/Compiler/{print $2}'`
! ;;
! esac
! # Determine the architecture type of this system.
! # Keep leading tab below -- Configure Black Magic -- RAM, 03/02/97
! xxOsRevMajor=`uname -r | sed -e 's/^[^0-9]*//' | cut -d. -f1`;
! #xxOsRevMinor=`uname -r | sed -e 's/^[^0-9]*//' | cut -d. -f2`;
! if [ "$xxOsRevMajor" -ge 10 ]
! then
! # This system is running >= 10.x
! # Tested on 10.01 PA1.x and 10.20 PA[12].x. Idea: Scan
! # /usr/include/sys/unistd.h for matches with "#define CPU_* `getconf
! # CPU_VERSION`" to determine CPU type. Note the part following
! # "CPU_" is used, *NOT* the comment.
! #
! # ASSUMPTIONS: Numbers will continue to be defined in hex -- and in
! # /usr/include/sys/unistd.h -- and the CPU_* #defines will be kept
! # up to date with new CPU/OS releases.
! xxcpu=`getconf CPU_VERSION`; # Get the number.
! xxcpu=`printf '0x%x' $xxcpu`; # convert to hex
! archname=`sed -n -e "s/^#[ \t]*define[ \t]*CPU_//p" /usr/include/sys/unistd.h |
! sed -n -e "s/[ \t]*$xxcpu[ \t].*//p" |
! sed -e s/_RISC/-RISC/ -e s/HP_// -e s/_/./`;
! else
! # This system is running <= 9.x
! # Tested on 9.0[57] PA and [78].0 MC680[23]0. Idea: After removing
! # MC6888[12] from context string, use first CPU identifier.
! #
! # ASSUMPTION: Only CPU identifiers contain no lowercase letters.
! archname=`getcontext | tr ' ' '\012' | grep -v '[a-z]' | grep -v MC688 |
! sed -e 's/HP-//' -e 1q`;
! selecttype='int *'
! fi
! # Do this right now instead of the delayed callback unit approach.
case "$use64bitall" in
! $define|true|[yY]*) use64bitint="$define" ;;
! esac
case "$usemorebits" in
! $define|true|[yY]*) use64bitint="$define"; uselongdouble="$define" ;;
! esac
case "$use64bitint" in
! $define|true|[yY]*)
! if [ "$xxOsRevMajor" -lt 11 ]; then
! cat <<EOM >&4
! 64-bit compilation is not supported on HP-UX $xxOsRevMajor.
! You need at least HP-UX 11.0.
! Cannot continue, aborting.
EOM
! exit 1
! fi
! # Without the 64-bit libc we cannot do much.
! libc='/lib/pa20_64/libc.sl'
! if [ ! -f "$libc" ]; then
! cat <<EOM >&4
! *** You do not seem to have the 64-bit libraries in /lib/pa20_64.
! *** Most importantly, I cannot find the $libc.
*** Cannot continue, aborting.
EOM
! exit 1
! fi
! ccflags="$ccflags +DD64"
! ldflags="$ldflags +DD64"
! test -d /lib/pa20_64 && loclibpth="$loclibpth /lib/pa20_64"
! libswanted="$libswanted pthread"
! libscheck='case "`/usr/bin/file $xxx`" in
! *LP64*|*PA-RISC2.0*) ;;
! *) xxx=/no/64-bit$xxx ;;
! esac'
! if test -n "$ccisgcc" -o -n "$gccversion"; then
! ld="$cc"
! else
! ld=/usr/bin/ld
! fi
! ar=/usr/bin/ar
! full_ar=$ar
! if test -z "$ccisgcc" -a -z "$gccversion"; then
! # The strict ANSI mode (-Aa) doesn't like the LL suffixes.
! ccflags=`echo " $ccflags "|sed 's@ -Aa @ @g'`
! case "$ccflags" in
! *-Ae*) ;;
! *) ccflags="$ccflags -Ae" ;;
! esac
! fi
! set `echo " $libswanted " | sed -e 's@ dl @ @'`
! libswanted="$*"
! ;;
! esac
! case "$ccisgcc" in
! # Even if you use gcc, prefer the HP math library over the GNU one.
! "$define") test -d /lib/pa1.1 && ccflags="$ccflags -L/lib/pa1.1" ;;
! esac
!
! case "$ccisgcc" in
! "$define") ;;
! *) case "`getconf KERNEL_BITS 2>/dev/null`" in
! *64*) ldflags="$ldflags -Wl,+vnocompatwarnings" ;;
esac
- ;;
- esac
- # Remove bad libraries that will cause problems
- # (This doesn't remove libraries that don't actually exist)
- # -lld is unneeded (and I can't figure out what it's used for anyway)
- # -ldbm is obsolete and should not be used
- # -lBSD contains BSD-style duplicates of SVR4 routines that cause confusion
- # -lPW is obsolete and should not be used
- # The libraries crypt, malloc, ndir, and net are empty.
- # Although -lndbm should be included, it will make perl blow up if you should
- # copy the binary to a system without libndbm.sl. See ccdlflags below.
- set `echo " $libswanted " | sed -e 's@ ld @ @' -e 's@ dbm @ @' -e 's@ BSD @ @' -e 's@ PW @ @'`
- libswanted="$*"
-
# By setting the deferred flag below, this means that if you run perl
# on a system that does not have the required shared library that you
# linked it with, it will die when you try to access a symbol in the
--- 1,236 ----
! #!/usr/bin/sh
! ### SYSTEM ARCHITECTURE
+ # Determine the architecture type of this system.
+ # Keep leading tab below -- Configure Black Magic -- RAM, 03/02/97
+ xxOsRevMajor=`uname -r | sed -e 's/^[^0-9]*//' | cut -d. -f1`;
+ if [ "$xxOsRevMajor" -ge 10 ]; then
+ # This system is running >= 10.x
! # Tested on 10.01 PA1.x and 10.20 PA[12].x.
! # Idea: Scan /usr/include/sys/unistd.h for matches with
! # "#define CPU_* `getconf # CPU_VERSION`" to determine CPU type.
! # Note the text following "CPU_" is used, *NOT* the comment.
! #
! # ASSUMPTIONS: Numbers will continue to be defined in hex -- and in
! # /usr/include/sys/unistd.h -- and the CPU_* #defines will be kept
! # up to date with new CPU/OS releases.
! xxcpu=`getconf CPU_VERSION`; # Get the number.
! xxcpu=`printf '0x%x' $xxcpu`; # convert to hex
! archname=`sed -n -e "s/^#[ \t]*define[ \t]*CPU_//p" /usr/include/sys/unistd.h |
! sed -n -e "s/[ \t]*$xxcpu[ \t].*//p" |
! sed -e s/_RISC/-RISC/ -e s/HP_// -e s/_/./`;
! else
! # This system is running <= 9.x
! # Tested on 9.0[57] PA and [78].0 MC680[23]0. Idea: After removing
! # MC6888[12] from context string, use first CPU identifier.
! #
! # ASSUMPTION: Only CPU identifiers contain no lowercase letters.
! archname=`getcontext | tr ' ' '\012' | grep -v '[a-z]' | grep -v MC688 |
! sed -e 's/HP-//' -e 1q`;
! selecttype='int *'
! fi
! echo "Archname is $archname"
! ### HP-UX OS specific behaviour
! # -ldbm is obsolete and should not be used
! # -lBSD contains BSD-style duplicates of SVR4 routines that cause confusion
! # -lPW is obsolete and should not be used
! # The libraries crypt, malloc, ndir, and net are empty.
! set `echo "X $libswanted " | sed -e 's/ ld / /' -e 's/ dbm / /' -e 's/ BSD / /' -e 's/ PW / /'`
! shift
! libswanted="$*"
cc=${cc:-cc}
+ ar=/usr/bin/ar # Yes, truly override. We do not want the GNU ar.
+ full_ar=$ar # I repeat, no GNU ar. arrr.
+ set `echo "X $ccflags " | sed -e 's/ -A[ea] / /' -e 's/ -D_HPUX_SOURCE / /'`
+ shift
+ cc_cppflags="$* -D_HPUX_SOURCE"
+ cppflags="-Aa -D__STDC_EXT__ $cc_cppflags"
+
+ case "$prefix" in
+ "") prefix='/opt/perl5' ;;
+ esac
+
+ gnu_as=no
+ gnu_ld=no
case `$cc -v 2>&1`"" in
! *gcc*) ccisgcc="$define"
! ccflags="$cc_cppflags"
! if [ "X$gccversion" = "X" ]; then
! # Done too late in Configure if hinted
! gccversion=`$cc --version`
! fi
! case "`getconf KERNEL_BITS 2>/dev/null`" in
! *64*)
! case "$gccversion" in
! 3*) ccflags="$ccflags -mpa-risc-2-0"
! ;;
! *) echo "main(){}">try.c
! # gcc with gas will not accept +DA2.0
! case "`$cc -c -Wa,+DA2.0 try.c 2>&1`" in
! *"+DA2.0"*) # gas
! gnu_as=yes
! ;;
! *) # HPas
! ccflags="$ccflags -Wa,+DA2.0"
! ;;
! esac
! ;;
! esac
! # gcc with gld will not accept +vnocompatwarnings
! case "`$cc -o try -Wl,+vnocompatwarnings try.c 2>&1`" in
! *"+vnocompat"*) # gld
! gnu_ld=yes
! ;;
! *) # HPld
! case "$gccversion" in
! [12]*)
! ldflags="$ldflags -Wl,+vnocompatwarnings"
! ccflags="$ccflags -Wl,+vnocompatwarnings"
! ;;
! esac
! ;;
! esac
! ;;
! esac
! ;;
! *) ccisgcc=''
! ccversion=`which cc | xargs what | awk '/Compiler/{print $2}'`
! ccflags="-Ae $cc_cppflags -Wl,+vnocompatwarnings"
! # Needed because cpp does only support -Aa (not -Ae)
! cpplast='-'
! cppminus='-'
! cppstdin='cc -E -Aa -D__STDC_EXT__'
! cpprun=$cppstdin
! case "$d_casti32" in
! "") d_casti32='undef' ;;
! esac
! ;;
! esac
! # When HP-UX runs a script with "#!", it sets argv[0] to the script name.
! toke_cflags='ccflags="$ccflags -DARG_ZERO_IS_SCRIPT"'
! ### 64 BITNESS
! # Some gcc versions do native 64 bit long (e.g. 2.9-hppa-000310 and gcc-3.0)
! # We have to force 64bitness to go search the right libraries
! gcc_64native=no
! case "$ccisgcc" in
! $define|true|[Yy])
! echo 'int main(){long l;printf("%d\\n",sizeof(l));}'>try.c
! $cc -o try $ccflags $ldflags try.c
! if [ "`try`" = "8" ]; then
! cat <<EOM >&4
!
! *** This version of gcc uses 64 bit longs. -Duse64bitall is
! *** implicitly set to enable continuation
! EOM
! use64bitall=$define
! gcc_64native=yes
! fi
! ;;
! esac
!
case "$use64bitall" in
! $define|true|[yY]*) use64bitint="$define" ;;
! esac
!
case "$usemorebits" in
! $define|true|[yY]*) use64bitint="$define"; uselongdouble="$define" ;;
! esac
!
! case "$uselongdouble" in
! $define|true|[yY]*)
! cat <<EOM >&4
!
! *** long doubles are not (yet) supported on HP-UX (any version)
! *** Until it does, we cannot continue, aborting.
! EOM
! exit 1 ;;
! esac
!
case "$use64bitint" in
! $define|true|[Yy])
! if [ "$xxOsRevMajor" -lt 11 ]; then
! cat <<EOM >&4
!
! *** 64-bit compilation is not supported on HP-UX $xxOsRevMajor.
! *** You need at least HP-UX 11.0.
! *** Cannot continue, aborting.
EOM
! exit 1
! fi
! # Set libc and the library paths
! case "$archname" in
! PA-RISC*)
! loclibpth="$loclibpth /lib/pa20_64"
! libc='/lib/pa20_64/libc.sl' ;;
! IA64*)
! loclibpth="$loclibpth /usr/lib/hpux64"
! libc='/usr/lib/hpux64/libc.so' ;;
! esac
! if [ ! -f "$libc" ]; then
! cat <<EOM >&4
! *** You do not seem to have the 64-bit libc.
! *** I cannot find the file $libc.
*** Cannot continue, aborting.
EOM
! exit 1
! fi
! case "$ccisgcc" in
! $define|true|[Yy])
! # For the moment, don't care that it ain't supported (yet)
! # by gcc (up to and including 2.95.3), cause it'll crash
! # anyway. Expect auto-detection of 64-bit enabled gcc on
! # HP-UX soon, including a user-friendly exit
! case $gcc_64native in
! no) case "$gccversion" in
! [12]*) ccflags="$ccflags -mlp64"
! ldflags="$ldflags -Wl,+DD64"
! ;;
! esac
! ;;
! esac
! ;;
! *)
! ccflags="$ccflags +DD64"
! ldflags="$ldflags +DD64"
! ;;
! esac
! # Reset the library checker to make sure libraries
! # are the right type
! libscheck='case "`/usr/bin/file $xxx`" in
! *ELF-64*|*LP64*|*PA-RISC2.0*) ;;
! *) xxx=/no/64-bit$xxx ;;
! esac'
! ;;
! *) # Not in 64-bit mode
! case "$archname" in
! PA-RISC*)
! libc='/lib/libc.sl' ;;
! IA64*)
! loclibpth="$loclibpth /usr/lib/hpux32"
! libc='/usr/lib/hpux32/libc.so' ;;
! esac
! ;;
esac
# By setting the deferred flag below, this means that if you run perl
# on a system that does not have the required shared library that you
# linked it with, it will die when you try to access a symbol in the
***************
*** 249,354 ****
# adding the "nonfatal" option.
# ccdlflags="-Wl,-E -Wl,-B,immediate $ccdlflags"
# ccdlflags="-Wl,-E -Wl,-B,immediate,-B,nonfatal $ccdlflags"
! ccdlflags="-Wl,-E -Wl,-B,deferred $ccdlflags"
- case "$usemymalloc" in
- '') usemymalloc='y' ;;
- esac
! alignbytes=8
! # For native nm, you need "-p" to produce BSD format output.
! nm_opt='-p'
! # When HP-UX runs a script with "#!", it sets argv[0] to the script name.
! toke_cflags='ccflags="$ccflags -DARG_ZERO_IS_SCRIPT"'
! # If your compile complains about FLT_MIN, uncomment the next line
! # POSIX_cflags='ccflags="$ccflags -DFLT_MIN=1.17549435E-38"'
! # Comment this out if you don't want to follow the SVR4 filesystem layout
! # that HP-UX 10.0 uses
! case "$prefix" in
! '') prefix='/opt/perl5' ;;
! esac
! # HP-UX can't do setuid emulation offered by Configure
! case "$d_dosuid" in
! '') d_dosuid="$undef" ;;
! esac
! # HP-UX 11 groks also LD_LIBRARY_PATH but SHLIB_PATH
! # is recommended for compatibility.
! case "$ldlibpthname" in
! '') ldlibpthname=SHLIB_PATH ;;
! esac
! # HP-UX 10.20 and gcc 2.8.1 break UINT32_MAX.
! case "$ccisgcc" in
! "$define") ccflags="$ccflags -DUINT32_MAX_BROKEN" ;;
! esac
! cat > UU/cc.cbu <<'EOSH'
! # XXX This script UU/cc.cbu will get 'called-back' by Configure after it
! # XXX has prompted the user for the C compiler to use.
! # Get gcc to share its secrets.
! echo 'main() { return 0; }' > try.c
! # Indent to avoid propagation to config.sh
! verbose=`${cc:-cc} -v -o try try.c 2>&1`
! if echo "$verbose" | grep '^Reading specs from' >/dev/null 2>&1; then
! # Using gcc.
! : nothing to see here, move on.
! else
! # Using cc.
! ar=${ar:-ar}
! case "`$ar -V 2>&1`" in
! *GNU*)
! if test -x /usr/bin/ar; then
! cat <<END >&2
! *** You are using HP cc(1) but GNU ar(1). This might lead into trouble
! *** later on, I'm switching to HP ar to play safe.
! END
! ar=/usr/bin/ar
fi
;;
esac
! fi
! EOSH
- # Date: Fri, 6 Sep 96 23:15:31 CDT
- # From: "Daniel S. Lewart" <d-lewart@uiuc.edu>
- # I looked through the gcc.info and found this:
- # * GNU CC compiled code sometimes emits warnings from the HP-UX
- # assembler of the form:
- # (warning) Use of GR3 when frame >= 8192 may cause conflict.
- # These warnings are harmless and can be safely ignored.
-
- cat > UU/usethreads.cbu <<'EOCBU'
# This script UU/usethreads.cbu will get 'called-back' by Configure
# after it has prompted the user for whether to use threads.
case "$usethreads" in
! $define|true|[yY]*)
! if [ "$xxOsRevMajor" -lt 10 ]; then
! cat <<EOM >&4
HP-UX $xxOsRevMajor cannot support POSIX threads.
Consider upgrading to at least HP-UX 11.
Cannot continue, aborting.
EOM
! exit 1
! fi
! case "$xxOsRevMajor" in
! 10)
! # Under 10.X, a threaded perl can be built
! if [ -f /usr/include/pthread.h ]; then
if [ -f /usr/lib/libcma.sl ]; then
# DCE (from Core OS CD) is installed
! # It needs # libcma and OLD_PTHREADS_API. Also <pthread.h>
! # needs to be #included before any other includes
! # (in perl.h)
# HP-UX 10.X uses the old pthreads API
d_oldpthreads="$define"
--- 242,403 ----
# adding the "nonfatal" option.
# ccdlflags="-Wl,-E -Wl,-B,immediate $ccdlflags"
# ccdlflags="-Wl,-E -Wl,-B,immediate,-B,nonfatal $ccdlflags"
! if [ "$gnu_ld" = "yes" ]; then
! ccdlflags="-Wl,-E $ccdlflags"
! else
! ccdlflags="-Wl,-E -Wl,-B,deferred $ccdlflags"
! fi
! ### COMPILER SPECIFICS
! ## Local restrictions (point to README.hpux to lift these)
! ## Optimization limits
! cat >try.c <<EOF
! #include <sys/resource.h>
! int main ()
! {
! struct rlimit rl;
! int i = getrlimit (RLIMIT_DATA, &rl);
! printf ("%d\n", rl.rlim_cur / (1024 * 1024));
! } /* main */
! EOF
! $cc -o try $ccflags $ldflags try.c
! maxdsiz=`try`
! if [ $maxdsiz -le 64 ]; then
! # 64 Mb is probably not enough to optimize toke.c
! # and regexp.c with -O2
! cat <<EOM >&4
! Your kernel limits the data section of your programs to $maxdsiz Mb,
! which is (sadly) not enough to fully optimize some parts of the
! perl binary. I'll try to use a lower optimization level for
! those parts. If you are a sysadmin, and you *do* want full
! optimization, raise the 'maxdsiz' kernel configuration parameter
! to at least 0x08000000 (128 Mb) and rebuild your kernel.
! EOM
! regexec_cflags=''
! fi
! case "$ccisgcc" in
! $define|true|[Yy])
!
! case "$optimize" in
! "") optimize="-g -O" ;;
! *O[3456789]*) optimize=`echo "$optimize" | sed -e 's/O[3-9]/O2/'` ;;
! esac
! #ld="$cc"
! ld=/usr/bin/ld
! cccdlflags='-fPIC'
! #lddlflags='-shared'
! lddlflags='-b'
! case "$optimize" in
! *-g*-O*|*-O*-g*)
! # gcc without gas will not accept -g
! echo "main(){}">try.c
! case "`$cc $optimize -c try.c 2>&1`" in
! *"-g option disabled"*)
! set `echo "X $optimize " | sed -e 's/ -g / /'`
! shift
! optimize="$*"
! ;;
! esac
! ;;
! esac
! if [ $maxdsiz -le 64 ]; then
! case "$optimize" in
! *O2*) opt=`echo "$optimize" | sed -e 's/O2/O1/'`
! toke_cflags="$toke_cflags;optimize=\"$opt\""
! regexec_cflags="optimize=\"$opt\""
! ;;
! esac
! fi
! ;;
! *) # HP's compiler cannot combine -g and -O
! case "$optimize" in
! "") optimize="+O2 +Onolimit" ;;
! *O[3456789]*) optimize=`echo "$optimize" | sed -e 's/O[3-9]/O2/'` ;;
! esac
! if [ $maxdsiz -le 64 ]; then
! case "$optimize" in
! *-O*|\
! *O2*) opt=`echo "$optimize" | sed -e 's/-O/+O2/' -e 's/O2/O1/' -e 's/ *+Onolimit//'`
! toke_cflags="$toke_cflags;optimize=\"$opt\""
! regexec_cflags="optimize=\"$opt\""
! ;;
! esac
! fi
! ld=/usr/bin/ld
! cccdlflags='+Z'
! lddlflags='-b +vnocompatwarnings'
! ;;
! esac
! ## LARGEFILES
! #case "$uselargefiles-$ccisgcc" in
! # "$define-$define"|'-define')
! # cat <<EOM >&4
! #
! #*** I'm ignoring large files for this build because
! #*** I don't know how to do use large files in HP-UX using gcc.
! #
! #EOM
! # uselargefiles="$undef"
! # ;;
! # esac
! cat >UU/uselargefiles.cbu <<'EOCBU'
! # This script UU/uselargefiles.cbu will get 'called-back' by Configure
! # after it has prompted the user for whether to use large files.
! case "$uselargefiles" in
! ""|$define|true|[yY]*)
! # there are largefile flags available via getconf(1)
! # but we cheat for now. (Keep that in the left margin.)
! ccflags_uselargefiles="-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64"
! ccflags="$ccflags $ccflags_uselargefiles"
!
! if test -z "$ccisgcc" -a -z "$gccversion"; then
! # The strict ANSI mode (-Aa) doesn't like large files.
! ccflags=`echo " $ccflags "|sed 's@ -Aa @ @g'`
! case "$ccflags" in
! *-Ae*) ;;
! *) ccflags="$ccflags -Ae" ;;
! esac
fi
;;
esac
! EOCBU
! # THREADING
# This script UU/usethreads.cbu will get 'called-back' by Configure
# after it has prompted the user for whether to use threads.
+ cat >UU/usethreads.cbu <<'EOCBU'
case "$usethreads" in
! $define|true|[yY]*)
! if [ "$xxOsRevMajor" -lt 10 ]; then
! cat <<EOM >&4
HP-UX $xxOsRevMajor cannot support POSIX threads.
Consider upgrading to at least HP-UX 11.
Cannot continue, aborting.
EOM
! exit 1
! fi
!
! if [ "$xxOsRevMajor" -eq 10 ]; then
! # Under 10.X, a threaded perl can be built
! if [ -f /usr/include/pthread.h ]; then
if [ -f /usr/lib/libcma.sl ]; then
# DCE (from Core OS CD) is installed
! # It needs # libcma and OLD_PTHREADS_API. Also
! # <pthread.h> needs to be #included before any
! # other includes (in perl.h)
# HP-UX 10.X uses the old pthreads API
d_oldpthreads="$define"
***************
*** 356,366 ****
# include libcma before all the others
libswanted="cma $libswanted"
! # tell perl.h to include <pthread.h> before other include files
ccflags="$ccflags -DPTHREAD_H_FIRST"
! # CMA redefines select to cma_select, and cma_select expects int *
! # instead of fd_set * (just like 9.X)
selecttype='int *'
elif [ -f /usr/lib/libpthread.sl ]; then
--- 405,416 ----
# include libcma before all the others
libswanted="cma $libswanted"
! # tell perl.h to include <pthread.h> before other
! # include files
ccflags="$ccflags -DPTHREAD_H_FIRST"
! # CMA redefines select to cma_select, and cma_select
! # expects int * instead of fd_set * (just like 9.X)
selecttype='int *'
elif [ -f /usr/lib/libpthread.sl ]; then
***************
*** 373,380 ****
libswanted="no_threads_available"
fi
! if [ $libswanted = "no_threads_available" ]; then
! cat <<EOM >&4
In HP-UX 10.X for POSIX threads you need both of the files
/usr/include/pthread.h and either /usr/lib/libcma.sl or /usr/lib/libpthread.sl.
--- 423,430 ----
libswanted="no_threads_available"
fi
! if [ $libswanted = "no_threads_available" ]; then
! cat <<EOM >&4
In HP-UX 10.X for POSIX threads you need both of the files
/usr/include/pthread.h and either /usr/lib/libcma.sl or /usr/lib/libpthread.sl.
***************
*** 384,450 ****
or
! PTH package from http://hpux.tn.tudelft.nl/hppd/hpux/alpha.html
Cannot continue, aborting.
EOM
! exit 1
fi
- ;;
- 11 | 12) # 12 may want upping the _POSIX_C_SOURCE datestamp...
- ccflags=" -D_POSIX_C_SOURCE=199506L $ccflags"
- set `echo X "$libswanted "| sed -e 's/ c / pthread c /'`
- shift
- libswanted="$*"
- ;;
- esac
usemymalloc='n'
;;
! esac
EOCBU
-
- case "$uselargefiles-$ccisgcc" in
- "$define-$define"|'-define')
- cat <<EOM >&4
-
- *** I'm ignoring large files for this build because
- *** I don't know how to do use large files in HP-UX using gcc.
-
- EOM
- uselargefiles="$undef"
- ;;
- esac
-
- cat > UU/uselargefiles.cbu <<'EOCBU'
- # This script UU/uselargefiles.cbu will get 'called-back' by Configure
- # after it has prompted the user for whether to use large files.
- case "$uselargefiles" in
- ''|$define|true|[yY]*)
- # there are largefile flags available via getconf(1)
- # but we cheat for now. (Keep that in the left margin.)
- ccflags_uselargefiles="-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64"
-
- ccflags="$ccflags $ccflags_uselargefiles"
-
- if test -z "$ccisgcc" -a -z "$gccversion"; then
- # The strict ANSI mode (-Aa) doesn't like large files.
- ccflags=`echo " $ccflags "|sed 's@ -Aa @ @g'`
- case "$ccflags" in
- *-Ae*) ;;
- *) ccflags="$ccflags -Ae" ;;
- esac
- fi
-
- ;;
- esac
- EOCBU
-
- # keep that leading tab.
- ccisgcc=''
-
- # Until we figure out what to be probe for in Configure (ditto for irix_6.sh)
- case "$d_casti32" in
- '') d_casti32='undef' ;;
- esac
-
--- 434,454 ----
or
! PTH package from e.g. http://hpux.tn.tudelft.nl/hppd/hpux/alpha.html
Cannot continue, aborting.
EOM
! exit 1
fi
+ else
+ # 12 may want upping the _POSIX_C_SOURCE datestamp...
+ ccflags=" -D_POSIX_C_SOURCE=199506L $ccflags"
+ set `echo X "$libswanted "| sed -e 's/ c / pthread c /'`
+ shift
+ libswanted="$*"
+ fi
usemymalloc='n'
;;
! esac
EOCBU
diff -c 'perl-5.7.1/hints/linux.sh' 'perl-5.7.2/hints/linux.sh'
Index: ./hints/linux.sh
*** ./hints/linux.sh Tue Mar 6 04:05:15 2001
--- ./hints/linux.sh Mon Jul 9 17:10:20 2001
***************
*** 119,125 ****
exit(0); /* succeed (yes, it's ELF) */
}
EOM
! if ${cc:-gcc} try.c >/dev/null 2>&1 && ./a.out; then
cat <<'EOM' >&4
You appear to have ELF support. I'll try to use it for dynamic loading.
--- 119,125 ----
exit(0); /* succeed (yes, it's ELF) */
}
EOM
! if ${cc:-gcc} try.c >/dev/null 2>&1 && $run ./a.out; then
cat <<'EOM' >&4
You appear to have ELF support. I'll try to use it for dynamic loading.
diff -c 'perl-5.7.1/hints/mpeix.sh' 'perl-5.7.2/hints/mpeix.sh'
Index: ./hints/mpeix.sh
*** ./hints/mpeix.sh Tue Mar 6 04:05:15 2001
--- ./hints/mpeix.sh Mon Jul 9 17:10:21 2001
***************
*** 23,28 ****
--- 23,32 ----
nm_opt='-configperl'
usenm='true'
#
+ # Work around the broken inline cat bug that corrupts here docs
+ #
+ alias -x cat=/bin/cat
+ #
# Various directory locations.
#
# Which ones of these does Configure get wrong?
***************
*** 43,49 ****
test -z "$cc" && cc='gcc'
cccdlflags='none'
ccflags="$ccflags -DMPE -D_POSIX_SOURCE -D_SOCKET_SOURCE -D_POSIX_JOB_CONTROL -DIS_SOCKET_CLIB_ITSELF"
! locincpth="$locincpth /usr/local/include /usr/contrib/include /BIND/PUB/include"
test -z "$optimize" && optimize="-O2"
ranlib='/bin/true'
# Special compiling options for certain source files.
--- 47,53 ----
test -z "$cc" && cc='gcc'
cccdlflags='none'
ccflags="$ccflags -DMPE -D_POSIX_SOURCE -D_SOCKET_SOURCE -D_POSIX_JOB_CONTROL -DIS_SOCKET_CLIB_ITSELF"
! locincpth="$locincpth /usr/local/include /usr/contrib/include /BINDFW/CURRENT/include /SYSLOG/PUB"
test -z "$optimize" && optimize="-O2"
ranlib='/bin/true'
# Special compiling options for certain source files.
***************
*** 62,68 ****
libswanted="$*"
done
libswanted="$libswanted bind syslog curses svipc socket str m c"
! loclibpth="$loclibpth /usr/local/lib /usr/contrib/lib /BIND/PUB/lib /SYSLOG/PUB"
#
# External functions and data items.
#
--- 66,72 ----
libswanted="$*"
done
libswanted="$libswanted bind syslog curses svipc socket str m c"
! loclibpth="$loclibpth /usr/local/lib /usr/contrib/lib /BINDFW/CURRENT/lib /SYSLOG/PUB"
#
# External functions and data items.
#
***************
*** 83,97 ****
--- 87,104 ----
# Unix named functions that are really vanilla MPE functions that do something
# completely different than on POSIX or Unix.
d_crypt='define'
+ d_dbmclose='undef'
d_difftime='define'
d_dlerror='undef'
d_dlopen='undef'
d_Gconvert='gcvt((x),(n),(b))'
+ d_gettimeod='undef'
d_inetaton='undef'
d_link='undef'
d_mblen='define'
d_mbstowcs='define'
d_mbtowc='define'
+ d_memchr='define'
d_memcmp='define'
d_memcpy='define'
d_memmove='define'
***************
*** 100,105 ****
--- 107,115 ----
d_pwcomment='undef'
d_pwgecos='undef'
d_pwpasswd='undef'
+ d_setegid='undef'
+ d_seteuid='undef'
+ d_setitimer='undef'
d_setpgid='undef'
d_setsid='undef'
d_setvbuf='define'
***************
*** 119,124 ****
--- 129,135 ----
#
# Include files.
#
+ i_gdbm='undef' # the port is currently incomplete
i_termios='undef' # we have termios, but not the full set (just tcget/setattr)
i_time='define'
i_systime='undef'
diff -c 'perl-5.7.1/hints/next_3.sh' 'perl-5.7.2/hints/next_3.sh'
Index: ./hints/next_3.sh
*** ./hints/next_3.sh Tue Mar 6 04:05:16 2001
--- ./hints/next_3.sh Mon Jul 9 17:10:21 2001
***************
*** 2,8 ****
# Andreas Koenig <k@franz.ww.TU-Berlin.DE> and Gerd Knops <gerti@BITart.com>.
# Comments, questions, and improvements welcome!
#
! # These hints work for NeXT 3.2 and 3.3. 3.0 has it's own
# special hint file.
#
--- 2,8 ----
# Andreas Koenig <k@franz.ww.TU-Berlin.DE> and Gerd Knops <gerti@BITart.com>.
# Comments, questions, and improvements welcome!
#
! # These hints work for NeXT 3.2 and 3.3. 3.0 has its own
# special hint file.
#
diff -c 'perl-5.7.1/hints/os2.sh' 'perl-5.7.2/hints/os2.sh'
Index: ./hints/os2.sh
*** ./hints/os2.sh Tue Mar 6 04:05:16 2001
--- ./hints/os2.sh Mon Jul 9 17:10:21 2001
***************
*** 108,113 ****
--- 108,117 ----
# We provide it
i_dlfcn='define'
+ # -Zomf build has a problem with _exit() *flushing*, so the test
+ # gets confused:
+ fflushNULL="define"
+
aout_d_shrplib='undef'
aout_useshrplib='false'
aout_obj_ext='.o'
***************
*** 131,136 ****
--- 135,142 ----
aout_use_clib='c'
aout_usedl='undef'
aout_archobjs="os2.o dl_os2.o"
+ # Not listed in dynamic_ext, but needed for AOUT static_ext nevertheless
+ aout_extra_static_ext="OS2::DLL"
# variable which have different values for aout compile
used_aout='d_shrplib useshrplib plibext lib_ext obj_ext ar plibext d_fork lddlflags ldflags ccflags use_clib usedl archobjs cppflags'
***************
*** 163,171 ****
else
d_fork='undef'
fi
! lddlflags="-Zdll -Zomf -Zmt -Zcrtdll $ld_dll_optimize"
# Recursive regmatch may eat 2.5M of stack alone.
! ldflags='-Zexe -Zomf -Zmt -Zcrtdll -Zstack 32000'
if [ $emxcrtrev -ge 50 ]; then
ccflags="-Zomf -Zmt -DDOSISH -DOS2=2 -DEMBED -I. $_defemxcrtrev"
else
--- 169,177 ----
else
d_fork='undef'
fi
! lddlflags="-Zdll -Zomf -Zmt -Zcrtdll -Zlinker /e:2"
# Recursive regmatch may eat 2.5M of stack alone.
! ldflags='-Zexe -Zomf -Zmt -Zcrtdll -Zstack 32000 -Zlinker /e:2'
if [ $emxcrtrev -ge 50 ]; then
ccflags="-Zomf -Zmt -DDOSISH -DOS2=2 -DEMBED -I. $_defemxcrtrev"
else
***************
*** 279,314 ****
# Apply patches if needed
case "$0$running_c_cmd" in
*[/\\]Configure|*[/\\]Configure.|Configure|Configure.) # Skip Configure.cmd
! if grep "^libnames" ./Configure > /dev/null; then
# Not patched!
if test -f ./Configure.cmd ; then
! echo "!!!" >&2
! echo "!!! I see that what is running is ./Configure." >&2
! echo "!!! ./Configure is not patched, but ./Configure.cmd exists." >&2
! echo "!!!" >&2
! echo "!!! You are supposed to run Configure.cmd, not Configure" >&2
! echo "!!! after an automagic patching." >&2
! echo "!!!" >&2
! echo "!!! If you insist on running Configure, please" >&2
! echo "!!! patch it manually from ./os2/diff.configure." >&2
! echo "!!!" >&2
exit 2
fi
! echo "!!!" >&2
! echo "!!! You did not patch ./Configure!" >&2
! echo "!!! I create Configure.cmd and patch it from ./os2/diff.configure." >&2
! echo "!!!" >&2
! echo "$gnupatch -b -p1 --output=Configure.cmd <./os2/diff.configure 2>&1 | tee 00_auto_patch" >&2
($gnupatch -b -p1 --output=Configure.cmd <./os2/diff.configure 2>&1 | tee 00_auto_patch) >&2
! echo "!!!" >&2
! echo "!!! The report of patching is copied to 00_auto_patch." >&2
! echo "!!! Now you need to restart Configure.cmd with all the options" >&2
! echo "!!!" >&2
echo "extproc sh" > Configure.ctm
! cat Configure.cmd >> Configure.ctm && mv -f Configure.ctm Configure.cmd
! exit 0
else
! echo "!!! Apparently we are running a patched Configure." >&2
fi
;;
*) echo "!!! Apparently we are running a renamed Configure: '$0'." >&2
--- 285,394 ----
# Apply patches if needed
case "$0$running_c_cmd" in
*[/\\]Configure|*[/\\]Configure.|Configure|Configure.) # Skip Configure.cmd
! if test "Xyes" = "X$configure_cmd_loop"; then
! cat <<EOC >&2
! !!!
! !!! PANIC: Loop of self-invocations detected, aborting!
! !!!
! EOC
! exit 20
! fi
! configure_cmd_loop=yes
! export configure_cmd_loop
!
! configure_needs_patch=''
! if test -s ./os2/diff.configure; then
! if ! grep "^#OS2-PATCH-APPLIED" ./Configure > /dev/null; then
! configure_needs_patch=yes
! fi
! fi
! if test -n "$configure_needs_patch"; then
# Not patched!
+ # Restore the initial command line arguments
if test -f ./Configure.cmd ; then
! cat <<EOC >&2
! !!!
! !!! I see that what is running is ./Configure.
! !!! ./Configure is not patched, but ./Configure.cmd exists.
! !!!
! !!! You are supposed to run Configure.cmd, not Configure
! !!! after an automagic patching.
! !!!
! !!! If you insist on running Configure, you may
! !!! patch it manually from ./os2/diff.configure.
! !!!
! !!! However, I went through incredible hoolahoops, and I expect I can
! !!! auto-restart Configure.cmd myself. I will start it with arguments:
! !!!
! !!! Configure.cmd $args_exp
! !!!
! EOC
! rp='Do you want to auto-restart Configure.cmd?'
! dflt='y'
! . UU/myread
! case "$ans" in
! [yY]) echo >&4 "Okay, continuing." ;;
! *) echo >&4 "Okay, bye."
! exit 2
! ;;
! esac
! eval "set X $args_exp";
! shift;
! # Restore the output
! exec Configure.cmd "$@" 1>&2
exit 2
fi
! cat <<EOC >&2
! !!!
! !!! You did not patch ./Configure!
! !!! I can create Configure.cmd and patch it from ./os2/diff.configure with the command
! !!!
! !!! $gnupatch -b -p1 --output=Configure.cmd <./os2/diff.configure 2>&1 | tee 00_auto_patch
! EOC
! rp='Do you want to auto-patch Configure to Configure.cmd?'
! dflt='y'
! . UU/myread
! case "$ans" in
! [yY]) echo >&4 "Okay, continuing." ;;
! *) echo >&4 "Okay, bye."
! exit 2
! ;;
! esac
($gnupatch -b -p1 --output=Configure.cmd <./os2/diff.configure 2>&1 | tee 00_auto_patch) >&2
! cat <<EOC >&2
! !!!
! !!! The report of patching is copied to 00_auto_patch.
! !!! Now we need to restart Configure.cmd with all the options.
! !!!
! EOC
echo "extproc sh" > Configure.ctm
! ( cat Configure.cmd >> Configure.ctm && mv -f Configure.ctm Configure.cmd ) || (echo "!!! Failure to add extproc-line to Configure.cmd." >&2 ; exit 21)
! cat <<EOC >&2
! !!! I went through incredible hoolahoops, and I expect I can
! !!! auto-restart Configure.cmd myself. I will start it with arguments:
! !!!
! !!! Configure.cmd $args_exp
! !!!
! EOC
! rp='Do you want to auto-restart Configure.cmd?'
! dflt='y'
! . UU/myread
! case "$ans" in
! [yY]) echo >&4 "Okay, continuing." ;;
! *) echo >&4 "Okay, bye."
! exit 2
! ;;
! esac
! eval "set X $args_exp";
! shift;
! exec Configure.cmd "$@" 1>&2
! exit 2
else
! if test -s ./os2/diff.configure; then
! echo "!!! Apparently we are running a patched Configure." >&2
! else
! echo "!!! Apparently there is no need to patch Configure." >&2
! fi
fi
;;
*) echo "!!! Apparently we are running a renamed Configure: '$0'." >&2
***************
*** 329,334 ****
--- 409,430 ----
esac
EOCBU
+ if test -z "$cryptlib"; then
+ cryptlib=`UU/loc crypt$lib_ext "" $libpth`
+ if $test -n "$cryptlib"; then
+ cryptlib=-lcrypt
+ else
+ cryptlib=`UU/loc ufc$lib_ext "" $libpth`
+ if $test -n "$cryptlib"; then
+ cryptlib=-lufc
+ fi
+ fi
+ fi
+ if test -n "$cryptlib"; then
+ libs="$libs $cryptlib"
+ # d_crypt=define
+ fi
+
# Now install the external modules. We are in the ./hints directory.
cd ./os2/OS2
***************
*** 341,346 ****
--- 437,443 ----
# Install tests:
+ cp -uf ../*.t ../../t/lib
for xxx in * ; do
if $test -d $xxx/t; then
cp -uf $xxx/t/*.t ../../t/lib
diff -c 'perl-5.7.1/hints/os390.sh' 'perl-5.7.2/hints/os390.sh'
Index: ./hints/os390.sh
*** ./hints/os390.sh Tue Mar 13 02:34:59 2001
--- ./hints/os390.sh Mon Jul 9 17:10:21 2001
***************
*** 25,30 ****
--- 25,32 ----
esac
# -DMAXSIG=38 maximum signal number
+ # -DPERL_IGNORE_FPUSIG=SIGFPE allows Perl to be cavalier with FP overflow
+ # (particularly in numeric.c:S_mulexp10())
# -DOEMVS is used in place of #ifdef __MVS__ in certain places.
# -D_OE_SOCKETS alters system headers.
# -D_XOPEN_SOURCE_EXTENDEDA alters system headers.
***************
*** 33,40 ****
# -DEBCDIC should come from Configure and need not be mentioned here.
# Prepend your favorites with Configure -Dccflags=your_favorites
case "$ccflags" in
! '') ccflags='-DMAXSIG=38 -DOEMVS -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -DYYDYNAMIC' ;;
! *) ccflags="$ccflags -DMAXSIG=38 -DOEMVS -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -DYYDYNAMIC" ;;
esac
# Turning on optimization breaks perl.
--- 35,42 ----
# -DEBCDIC should come from Configure and need not be mentioned here.
# Prepend your favorites with Configure -Dccflags=your_favorites
case "$ccflags" in
! '') ccflags='-DMAXSIG=38 -DPERL_IGNORE_FPUSIG=SIGFPE -DOEMVS -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -DYYDYNAMIC' ;;
! *) ccflags="$ccflags -DMAXSIG=38 -DPERL_IGNORE_FPUSIG=SIGFPE -DOEMVS -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -DYYDYNAMIC" ;;
esac
# Turning on optimization breaks perl.
diff -c 'perl-5.7.1/hints/posix-bc.sh' 'perl-5.7.2/hints/posix-bc.sh'
Index: ./hints/posix-bc.sh
*** ./hints/posix-bc.sh Thu Mar 8 15:40:08 2001
--- ./hints/posix-bc.sh Mon Jul 9 17:10:21 2001
***************
*** 19,29 ****
# -DPOSIX_BC
# -DUSE_PURE_BISON
# -D_XOPEN_SOURCE_EXTENDED alters system headers.
# Prepend your favorites with Configure -Dccflags=your_favorites
! case "$ccflags" in
! '') ccflags='-K enum_long,llm_case_lower,llm_keep,no_integer_overflow -DPOSIX_BC -DUSE_PURE_BISON -D_XOPEN_SOURCE -D_XOPEN_SOURCE_EXTENDED' ;;
! *) ccflags='$ccflags -Kenum_long,llm_case_lower,llm_keep,no_integer_overflow -DPOSIX_BC -DUSE_PURE_BISON -D_XOPEN_SOURCE -D_XOPEN_SOURCE_EXTENDED' ;;
! esac
# ccdlflags have yet to be determined.
#case "$ccdlflags" in
--- 19,27 ----
# -DPOSIX_BC
# -DUSE_PURE_BISON
# -D_XOPEN_SOURCE_EXTENDED alters system headers.
+ # -DPERL_IGNORE_FPUSIG=SIGFPE
# Prepend your favorites with Configure -Dccflags=your_favorites
! ccflags="$ccflags -Kenum_long,llm_case_lower,llm_keep,no_integer_overflow -DPOSIX_BC -DUSE_PURE_BISON -D_XOPEN_SOURCE_EXTENDED -DPERL_IGNORE_FPUSIG=SIGFPE"
# ccdlflags have yet to be determined.
#case "$ccdlflags" in
diff -c 'perl-5.7.1/hints/qnx.sh' 'perl-5.7.2/hints/qnx.sh'
Index: ./hints/qnx.sh
*** ./hints/qnx.sh Tue Mar 6 04:05:16 2001
--- ./hints/qnx.sh Thu Jul 12 20:36:33 2001
***************
*** 1,16 ****
#----------------------------------------------------------------
# QNX hints
#
! # As of perl5.004_04, all tests pass under:
! # QNX 4.23A
# Watcom 10.6 with Beta/970211.wcc.update.tar.F
# socket3r.lib Nov21 1996.
#
# As with many unix ports, this one depends on a few "standard"
! # unix utilities which are not necessarily standard for QNX.
#
# /bin/sh This is used heavily by Configure and then by
! # perl itself. QNX's version is fine, but Configure
# will choke on the 16-bit version, so if you are
# running QNX 4.22, link /bin/sh to /bin32/ksh
# ar This is the standard unix library builder.
--- 1,19 ----
#----------------------------------------------------------------
# QNX hints
#
! # Most of the hints in this file are for QNX4, which needed
! # more help. The QNX6 hints are located toward the bottom.
! #
! # perl-5.7.2 passes all tests under QNX4.24G
# Watcom 10.6 with Beta/970211.wcc.update.tar.F
# socket3r.lib Nov21 1996.
+ # perl-5.7.2 fails 4 known tests under QNX6.1.0
#
# As with many unix ports, this one depends on a few "standard"
! # unix utilities which are not necessarily standard for QNX4.
#
# /bin/sh This is used heavily by Configure and then by
! # perl itself. QNX4's version is fine, but Configure
# will choke on the 16-bit version, so if you are
# running QNX 4.22, link /bin/sh to /bin32/ksh
# ar This is the standard unix library builder.
***************
*** 24,30 ****
# cpp Configure and perl need a way to invoke a C
# preprocessor. I have created a simple cover
# for cc which does the right thing. Without this,
! # Configure will create it's own wrapper which works,
# but it doesn't handle some of the command line arguments
# that perl will throw at it.
# make You really need GNU make to compile this. GNU make
--- 27,33 ----
# cpp Configure and perl need a way to invoke a C
# preprocessor. I have created a simple cover
# for cc which does the right thing. Without this,
! # Configure will create its own wrapper which works,
# but it doesn't handle some of the command line arguments
# that perl will throw at it.
# make You really need GNU make to compile this. GNU make
***************
*** 31,44 ****
# ships by default with QNX 4.23, but you can get it
# from quics for earlier versions.
#----------------------------------------------------------------
! # Outstanding Issues:
! # lib/posix.t test fails on test 17 because acos(1) != 0.
# Resolved in 970211 Beta
# lib/io_udp.t test hangs because of a bug in getsockname().
# Fixed in latest BETA socket3r.lib
- # There is currently no support for dynamically linked
- # libraries.
#----------------------------------------------------------------
# These hints were submitted by:
# Norton T. Allen
# Harvard University Atmospheric Research Project
--- 34,73 ----
# ships by default with QNX 4.23, but you can get it
# from quics for earlier versions.
#----------------------------------------------------------------
! # Outstanding Issues for QNX4:
! # There is no support for dynamically linked libraries in
! # QNX4.
! #
! # ext/Cwd/Cwd.t will complain if `pwd` and cwd don't give
! # the same results. cwd calls `fullpath -t`, so if you
! # cd `fullpath -t` before running the test, it will
! # pass.
! #
! # lib/File/Find/taint.t will complain if '.' is in your
! # PATH. The PATH test is triggered because cwd calls
! # `fullpath -t`.
! #
! # ext/IO/lib/IO/t/io_sock.t: Subtest 14 is skipped due to
! # the fact that the functionality to read back the non-blocking
! # status of a socket is not implemented in QNX's TCP/IP. This
! # has been reported to QNX and it may work with later versions
! # of TCP/IP.
! #
! # Older issues:
! # lib/posix.t test failed on test 17 because acos(1) != 0.
# Resolved in 970211 Beta
# lib/io_udp.t test hangs because of a bug in getsockname().
# Fixed in latest BETA socket3r.lib
#----------------------------------------------------------------
+ # Outstanding Issues for QNX6:
+ # The following tests are still failing as of 5.7.1:
+ #
+ # op/sprintf.........................FAILED at test 91
+ # lib/1_compile......................FAILED at test 33
+ # ext/IO/lib/IO/t/io_sock............FAILED at test 12
+ # ext/IO/lib/IO/t/io_udp.............FAILED at test 4
+ #
+ #----------------------------------------------------------------
# These hints were submitted by:
# Norton T. Allen
# Harvard University Atmospheric Research Project
***************
*** 52,178 ****
echo ""
#----------------------------------------------------------------
! # At present, all QNX systems are equivalent architectures,
# so it is reasonable to call archname=x86-qnx rather than
# making an unnecessary distinction between AT-qnx and PCI-qnx,
! # for example.
#----------------------------------------------------------------
! archname='x86-qnx'
! #----------------------------------------------------------------
! # QNX doesn't come with a csh and the ports of tcsh I've used
! # don't work reliably:
! #----------------------------------------------------------------
! csh=''
! d_csh='undef'
! full_csh=''
! #----------------------------------------------------------------
! # setuid scripts are secure under QNX.
! # (Basically, the same race conditions apply, but assuming
! # the scripts are located in a secure directory, the methods
! # for exploiting the race condition are defeated because
! # the loader expands the script name fully before executing
! # the interpreter.)
! #----------------------------------------------------------------
! d_suidsafe='define'
! #----------------------------------------------------------------
! # difftime is implemented as a preprocessor macro, so it doesn't show
! # up in the libraries:
! #----------------------------------------------------------------
! d_difftime='define'
! #----------------------------------------------------------------
! # strtod is in the math library, but we can't tell Configure
! # about the math library or it will confuse the linker
! #----------------------------------------------------------------
! d_strtod='define'
! lib_ext='3r.lib'
! libc='/usr/lib/clib3r.lib'
! #----------------------------------------------------------------
! # ccflags:
! # I like to turn the warnings up high, but a few common
! # constructs make a lot of noise, so I turn those warnings off.
! # A few still remain...
! #
! # unix.h is required as a general rule for unixy applications.
! #----------------------------------------------------------------
! ccflags='-mf -w4 -Wc,-wcd=202 -Wc,-wcd=203 -Wc,-wcd=302 -Wc,-fi=unix.h'
! #----------------------------------------------------------------
! # ldflags:
! # If you want debugging information, you must specify -g on the
! # link as well as the compile. If optimize != -g, you should
! # remove this.
! #----------------------------------------------------------------
! ldflags="-g -N1M"
! so='none'
! selecttype='fd_set *'
! #----------------------------------------------------------------
! # Add -lunix to list of libs. This is needed mainly so the nm
! # search will find funcs in the unix lib. Including unix.h should
! # automatically include the library without -l.
! #----------------------------------------------------------------
! libswanted="$libswanted unix"
! if [ -z "`which ar 2>/dev/null`" ]; then
! cat <<-'EOF' >&4
! I don't see an 'ar', so I'm guessing you are running
! Watcom 9.5 or earlier. You may want to install the ar
! cover found in the qnx subdirectory of this distribution.
! It might reasonably be placed in /usr/local/bin.
EOF
! fi
! #----------------------------------------------------------------
! # Here is a nm script which fixes up wlib's output to look
! # something like nm's, at least enough so that Configure can
! # use it.
! #----------------------------------------------------------------
! if [ -z "`which nm 2>/dev/null`" ]; then
! cat <<-EOF
! Creating a quick-and-dirty nm cover for Configure to use:
EOF
! cat >./UU/nm <<-'EOF'
! #! /bin/sh
! #__USAGE
! #%C <lib> [<lib> ...]
! # Designed to mimic Unix's nm utility to list
! # defined symbols in a library
! unset WLIB
! for i in $*; do wlib $i; done |
! awk '
! /^ / {
! for (i = 1; i <= NF; i++) {
! sub("_$", "", $i)
! print "000000 T " $i
! }
! }'
EOF
! chmod +x ./UU/nm
! fi
! cppstdin=`which cpp 2>/dev/null`
! if [ -n "$cppstdin" ]; then
! cat <<-EOF >&4
! I found a cpp at $cppstdin and will assume it is a good
! thing to use. If this proves to be false, there is a
! thin cover for cpp in the qnx subdirectory of this
! distribution which you could move into your path.
EOF
! cpprun="$cppstdin"
! else
! cat <<-EOF >&4
! There is a cpp cover in the qnx subdirectory of this
! distribution which works a little better than the
! Configure default. You may wish to copy it to
! /usr/local/bin or some other suitable location.
EOF
! fi
--- 81,234 ----
echo ""
#----------------------------------------------------------------
! # At present, all QNX4 systems are equivalent architectures,
# so it is reasonable to call archname=x86-qnx rather than
# making an unnecessary distinction between AT-qnx and PCI-qnx,
! # for example. I will use uname's architecture for Neutrino.
#----------------------------------------------------------------
! set X `uname -a`
! shift
! [ "$1" != "QNX" ] && echo "uname doesn't look like QNX!"
! case $4 in
! 42[2-9]) archname='x86-qnx';;
! *) osname='nto'
! osvers=$3
! archname="$5-nto";;
! esac
! if [ "$osname" = "qnx" ]; then
! #----------------------------------------------------------------
! # QNX doesn't come with a csh and the ports of tcsh I've used
! # don't work reliably:
! #----------------------------------------------------------------
! csh=''
! d_csh='undef'
! full_csh=''
! #----------------------------------------------------------------
! # setuid scripts are secure under QNX.
! # (Basically, the same race conditions apply, but assuming
! # the scripts are located in a secure directory, the methods
! # for exploiting the race condition are defeated because
! # the loader expands the script name fully before executing
! # the interpreter.)
! #----------------------------------------------------------------
! d_suidsafe='define'
! #----------------------------------------------------------------
! # difftime is implemented as a preprocessor macro, so it doesn't show
! # up in the libraries:
! #----------------------------------------------------------------
! d_difftime='define'
! #----------------------------------------------------------------
! # strtod is in the math library, but we can't tell Configure
! # about the math library or it will confuse the linker
! #----------------------------------------------------------------
! d_strtod='define'
! lib_ext='3r.lib'
! libc='/usr/lib/clib3r.lib'
! #----------------------------------------------------------------
! # ccflags:
! # I like to turn the warnings up high, but a few common
! # constructs make a lot of noise, so I turn those warnings off.
! # A few still remain...
! #
! # unix.h is required as a general rule for unixy applications.
! #----------------------------------------------------------------
! ccflags='-mf -w4 -Wc,-wcd=202 -Wc,-wcd=203 -Wc,-wcd=302 -Wc,-fi=unix.h'
! #----------------------------------------------------------------
! # ldflags:
! # If you want debugging information, you must specify -g on the
! # link as well as the compile. If optimize != -g, you should
! # remove this.
! #----------------------------------------------------------------
! ldflags="-g -N1M"
! so='none'
! selecttype='fd_set *'
! #----------------------------------------------------------------
! # Add -lunix to list of libs. This is needed mainly so the nm
! # search will find funcs in the unix lib. Including unix.h should
! # automatically include the library without -l.
! #----------------------------------------------------------------
! libswanted="$libswanted unix"
! if [ -z "`which ar 2>/dev/null`" ]; then
! cat <<-'EOF' >&4
! I don't see an 'ar', so I'm guessing you are running
! Watcom 9.5 or earlier. You may want to install the ar
! cover found in the qnx subdirectory of this distribution.
! It might reasonably be placed in /usr/local/bin.
EOF
! fi
! #----------------------------------------------------------------
! # Here is a nm script which fixes up wlib's output to look
! # something like nm's, at least enough so that Configure can
! # use it.
! #----------------------------------------------------------------
! if [ -z "`which nm 2>/dev/null`" ]; then
! cat <<-EOF
! Creating a quick-and-dirty nm cover for Configure to use:
EOF
! cat >./UU/nm <<-'EOF'
! #! /bin/sh
! #__USAGE
! #%C <lib> [<lib> ...]
! # Designed to mimic Unix's nm utility to list
! # defined symbols in a library
! unset WLIB
! for i in $*; do wlib $i; done |
! awk '
! /^ / {
! for (i = 1; i <= NF; i++) {
! sub("_$", "", $i)
! print "000000 T " $i
! }
! }'
EOF
! chmod +x ./UU/nm
! fi
! cppstdin=`which cpp 2>/dev/null`
! if [ -n "$cppstdin" ]; then
! cat <<-EOF >&4
! I found a cpp at $cppstdin and will assume it is a good
! thing to use. If this proves to be false, there is a
! thin cover for cpp in the qnx subdirectory of this
! distribution which you could move into your path.
EOF
! cpprun="$cppstdin"
! else
! cat <<-EOF >&4
! There is a cpp cover in the qnx subdirectory of this
! distribution which works a little better than the
! Configure default. You may wish to copy it to
! /usr/local/bin or some other suitable location.
EOF
! fi
! else
! # $^O eq nto
!
! ccflags='-DDLOPEN_WONT_DO_RELATIVE_PATHS'
!
! # Options required to get dynamic linking to work
! lddlflags='-shared'
! ccdlflags='-Wl,-E'
!
! # Somewhere in the build, something tries to throw a gcc
! # option to $cc if it knows it invokes gcc. Our cc doesn't
! # recognize that option, so we're better off setting cc=gcc.
! cc='gcc'
!
! # If we use perl's malloc, it dies with an invalid sbrk.
! # This is probably worth tracking down someday.
! usemymalloc='false'
! fi
diff -c 'perl-5.7.1/hints/rhapsody.sh' 'perl-5.7.2/hints/rhapsody.sh'
Index: ./hints/rhapsody.sh
*** ./hints/rhapsody.sh Tue Mar 6 04:05:16 2001
--- ./hints/rhapsody.sh Mon Jul 9 17:10:21 2001
***************
*** 1,6 ****
##
# Rhapsody (Mac OS X Server) hints
! # Wilfredo Sanchez <wsanchez@apple.com>
##
##
--- 1,6 ----
##
# Rhapsody (Mac OS X Server) hints
! # Wilfredo Sanchez <wsanchez@mit.edu>
##
##
***************
*** 8,26 ****
##
# BSD paths
! prefix='/usr';
! siteprefix='/usr/local';
! vendorprefix='/usr/local'; usevendorprefix='define';
! # 4BSD uses /usr/share/man, not /usr/man.
! # Don't put man pages in /usr/lib; that's goofy.
! man1dir='/usr/share/man/man1';
! man3dir='/usr/share/man/man3';
! # Where to put modules.
! privlib='/System/Library/Perl';
! sitelib='/Local/Library/Perl';
! vendorlib='/Network/Library/Perl';
##
# Tool chain settings
--- 8,31 ----
##
# BSD paths
! case "$prefix" in
! '')
! prefix='/usr/local'; # Built-in perl uses /usr
! siteprefix='/usr/local';
! vendorprefix='/usr/local'; usevendorprefix='define';
! # 4BSD uses ${prefix}/share/man, not ${prefix}/man.
! # Don't put man pages in ${prefix}/lib; that's goofy.
! man1dir="${prefix}/share/man/man1";
! man3dir="${prefix}/share/man/man3";
! # Where to put modules.
! # Built-in perl uses /System/Library/Perl
! privlib='/Local/Library/Perl';
! sitelib='/Local/Library/Perl';
! vendorlib='/Network/Library/Perl';
! ;;
! esac
##
# Tool chain settings
***************
*** 41,46 ****
--- 46,54 ----
# We have a prototype for telldir.
ccflags="${ccflags} -pipe -fno-common -DHAS_TELLDIR_PROTOTYPE";
+ # cpp-precomp is problematic.
+ cppflags='-traditional-cpp';
+
# Shared library extension is .dylib.
# Bundle extension is .bundle.
ld='cc';
***************
*** 52,58 ****
lddlflags="${ldflags} -bundle -undefined suppress";
ldlibpthname='DYLD_LIBRARY_PATH';
useshrplib='true';
- base_address='0x4be00000';
##
# System libraries
--- 60,65 ----
***************
*** 64,67 ****
# malloc works
usemymalloc='n';
!
--- 71,77 ----
# malloc works
usemymalloc='n';
! # Case-insensitive filesystems don't get along with Makefile and
! # makefile in the same place. Since Darwin uses GNU make, this dodges
! # the problem.
! firstmakefile=GNUmakefile;
diff -c 'perl-5.7.1/hints/sco.sh' 'perl-5.7.2/hints/sco.sh'
Index: ./hints/sco.sh
*** ./hints/sco.sh Tue Mar 6 04:05:16 2001
--- ./hints/sco.sh Mon Jul 9 17:10:21 2001
***************
*** 112,118 ****
else
###############################################################
# Need this in release 5 because of changed fpu exeption rules
! ccflags="$ccflags -D PERL_SCO5"
###############################################################
# In Release 5, always compile ELF objects
--- 112,118 ----
else
###############################################################
# Need this in release 5 because of changed fpu exeption rules
! ccflags="$ccflags -D HAS_FPSETMASK"
###############################################################
# In Release 5, always compile ELF objects
diff -c 'perl-5.7.1/hints/svr5.sh' 'perl-5.7.2/hints/svr5.sh'
Index: ./hints/svr5.sh
*** ./hints/svr5.sh Tue Mar 6 04:05:17 2001
--- ./hints/svr5.sh Mon Jul 9 17:10:22 2001
***************
*** 83,89 ****
# remove /shlib and /lib from library search path as both symlink to /usr/lib
# where runtime shared libc is
! glibpth=`echo " $glibpth " | sed -e 's/ \/shlib / /' -e 's/ \/lib / /`
# Don't use BSD emulation pieces (/usr/ucblib) regardless
# these would probably be autonondetected anyway but ...
--- 83,89 ----
# remove /shlib and /lib from library search path as both symlink to /usr/lib
# where runtime shared libc is
! glibpth=`echo " $glibpth " | sed -e 's/ \/shlib / /' -e 's/ \/lib / /'`
# Don't use BSD emulation pieces (/usr/ucblib) regardless
# these would probably be autonondetected anyway but ...
***************
*** 156,163 ****
# cccdlflags: must tell the compiler to generate relocatable code
# lddlflags : must tell the linker to output a shared library
! # use shared perl lib
! useshrplib='true'
case "$cc" in
*gcc*)
--- 156,165 ----
# cccdlflags: must tell the compiler to generate relocatable code
# lddlflags : must tell the linker to output a shared library
! # use shared perl lib if the user doesn't choose otherwise
! if test "x$useshrplib" = "x"; then
! useshrplib='true'
! fi
case "$cc" in
*gcc*)
diff -c 'perl-5.7.1/hints/unicos.sh' 'perl-5.7.2/hints/unicos.sh'
Index: ./hints/unicos.sh
*** ./hints/unicos.sh Tue Mar 6 04:05:18 2001
--- ./hints/unicos.sh Mon Jul 9 17:10:22 2001
***************
*** 22,29 ****
usemymalloc='n'
;;
esac
! # Configure gets fooled for some reason. There is no getpgid().
d_getpgid='undef'
# These exist but do not really work.
d_setregid='undef'
d_setreuid='undef'
--- 22,30 ----
usemymalloc='n'
;;
esac
! # Configure gets fooled for some reason, these do not exist.
d_getpgid='undef'
+ d_setitimer='undef'
# These exist but do not really work.
d_setregid='undef'
d_setreuid='undef'
diff -c 'perl-5.7.1/hints/uts.sh' 'perl-5.7.2/hints/uts.sh'
Index: ./hints/uts.sh
*** ./hints/uts.sh Sun Mar 25 07:14:14 2001
--- ./hints/uts.sh Thu Jul 12 06:36:46 2001
***************
*** 1,18 ****
archname='s390'
cc='cc -Xa'
cccdlflags='-pic'
! d_bincompat3='undef'
! d_csh='undef'
! d_lstat='define'
! d_suidsafe='define'
dlsrc='dl_dlopen.xs'
! ld='ld'
lddlflags='-G -z text'
libperl='libperl.so'
! libpth='/lib /usr/lib /usr/ccs/lib'
libs='-lsocket -lnsl -ldl -lm'
! optimize='undef'
! prefix='psf_prefix'
! static_ext='none'
! dynamic_ext='Data/Dumper Digest/MD5 Errno Fcntl Filter::Util::Call GDBM_File IO MIME::Base64 Opcode PerlIO::Scalar POSIX Socket Storable attrs re'
! useshrplib='define'
--- 1,32 ----
archname='s390'
+ archobjs='uts/strtol_wrap.o uts/sprintf_wrap.o'
cc='cc -Xa'
+ ccflags='-XTSTRINGS=1500000 -DStrtol=strtol_wrap32 -DStrtoul=strtoul_wrap32 -DPERL_IGNORE_FPUSIG=SIGFPE -DSPRINTF_E_BUG'
cccdlflags='-pic'
! d_bincompat3='undef'
! d_csh='undef'
! d_lstat='define'
! d_suidsafe='define'
dlsrc='dl_dlopen.xs'
! i_ieeefp='undef'
! ld='ld'
lddlflags='-G -z text'
libperl='libperl.so'
! libpth='/lib /usr/lib /usr/ccs/lib'
libs='-lsocket -lnsl -ldl -lm'
! libswanted='m'
! prefix='/usr/local'
! toke_cflags='optimize=""'
! useshrplib='define'
!
! #################################
! # Some less routine stuff:
! #################################
! cc -g -Xa -c -pic -O uts/strtol_wrap.c -o uts/strtol_wrap.o
! cc -g -Xa -c -pic -O uts/sprintf_wrap.c -o uts/sprintf_wrap.o
! # Make POSIX a static extension.
! cat <<'EOSH' > config.over
! static_ext='POSIX B'
! dynamic_ext=`echo " $dynamic_ext " |
! sed -e 's/ POSIX / /' -e 's/ B / /'`
! EOSH
diff -c 'perl-5.7.1/hints/vmesa.sh' 'perl-5.7.2/hints/vmesa.sh'
Index: ./hints/vmesa.sh
*** ./hints/vmesa.sh Sun Mar 25 07:13:52 2001
--- ./hints/vmesa.sh Mon Jul 9 17:10:22 2001
***************
*** 218,224 ****
eagain='EAGAIN'
ebcdic='define'
exe_ext=''
! extensions='Data/Dumper Digest/MD5 Errno Fcntl Filter::Util:Call GDBM_File IO IPC/SysV MIME::Base64 NDBM_File Opcode PerlIO::Scalar POSIX Socket Storable Thread attrs re'
fpostype='fpos_t'
freetype='void'
groupstype='gid_t'
--- 218,224 ----
eagain='EAGAIN'
ebcdic='define'
exe_ext=''
! extensions='Data/Dumper Digest/MD5 Errno Fcntl Filter/Util/Call GDBM_File IO IPC/SysV List/Util MIME/Base64 NDBM_File Opcode PerlIO/Scalar POSIX Socket Storable Time/HiRes Time/Piece Thread attrs re'
fpostype='fpos_t'
freetype='void'
groupstype='gid_t'
***************
*** 317,323 ****
sizetype='size_t'
so='.a'
ssizetype='ssize_t'
! static_ext='Data/Dumper Digest/MD5 Fcntl Filter::Util::Call GDBM_File IO IPC/SysV MIME::Base64 NDBM_File Opcode PerlIO::Scalar POSIX Socket Storable Thread attrs re'
stdchar='char'
stdio_cnt='(fp)->__countIn'
stdio_ptr='(fp)->__bufPtr'
--- 317,323 ----
sizetype='size_t'
so='.a'
ssizetype='ssize_t'
! static_ext='Data/Dumper Digest/MD5 Fcntl Filter/Util/Call GDBM_File IO IPC/SysV List/Util MIME/Base64 NDBM_File Opcode PerlIO/Scalar POSIX Socket Storable Thread Time/HiRes Time/Piece attrs re'
stdchar='char'
stdio_cnt='(fp)->__countIn'
stdio_ptr='(fp)->__bufPtr'
diff -c 'perl-5.7.1/hv.c' 'perl-5.7.2/hv.c'
Index: ./hv.c
*** ./hv.c Fri Mar 9 16:59:40 2001
--- ./hv.c Fri Jul 13 07:33:30 2001
***************
*** 15,21 ****
#define PERL_IN_HV_C
#include "perl.h"
-
STATIC HE*
S_new_he(pTHX)
{
--- 15,20 ----
***************
*** 100,106 ****
#if defined(USE_ITHREADS)
HE *
! Perl_he_dup(pTHX_ HE *e, bool shared)
{
HE *ret;
--- 99,105 ----
#if defined(USE_ITHREADS)
HE *
! Perl_he_dup(pTHX_ HE *e, bool shared, clone_params* param)
{
HE *ret;
***************
*** 115,128 ****
ret = new_HE();
ptr_table_store(PL_ptr_table, e, ret);
! HeNEXT(ret) = he_dup(HeNEXT(e),shared);
if (HeKLEN(e) == HEf_SVKEY)
! HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e)));
else if (shared)
HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
else
HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
! HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e)));
return ret;
}
#endif /* USE_ITHREADS */
--- 114,127 ----
ret = new_HE();
ptr_table_store(PL_ptr_table, e, ret);
! HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
if (HeKLEN(e) == HEf_SVKEY)
! HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
else if (shared)
HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
else
HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
! HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
return ret;
}
#endif /* USE_ITHREADS */
***************
*** 163,169 ****
}
if (SvRMAGICAL(hv)) {
! if (mg_find((SV*)hv,'P')) {
sv = sv_newmortal();
mg_copy((SV*)hv, sv, key, klen);
PL_hv_fetch_sv = sv;
--- 162,168 ----
}
if (SvRMAGICAL(hv)) {
! if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
sv = sv_newmortal();
mg_copy((SV*)hv, sv, key, klen);
PL_hv_fetch_sv = sv;
***************
*** 170,176 ****
return &PL_hv_fetch_sv;
}
#ifdef ENV_IS_CASELESS
! else if (mg_find((SV*)hv,'E')) {
U32 i;
for (i = 0; i < klen; ++i)
if (isLOWER(key[i])) {
--- 169,175 ----
return &PL_hv_fetch_sv;
}
#ifdef ENV_IS_CASELESS
! else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
U32 i;
for (i = 0; i < klen; ++i)
if (isLOWER(key[i])) {
***************
*** 184,203 ****
#endif
}
xhv = (XPVHV*)SvANY(hv);
! if (!xhv->xhv_array) {
if (lval
#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
! || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
#endif
)
! Newz(503, xhv->xhv_array,
! PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
else
return 0;
}
! if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
STRLEN tmplen = klen;
/* Just casting the &klen to (STRLEN) won't work well
* if STRLEN and I32 are of different widths. --jhi */
--- 183,205 ----
#endif
}
+ /* We use xhv->xhv_foo fields directly instead of HvFOO(hv) to
+ avoid unnecessary pointer dereferencing. */
xhv = (XPVHV*)SvANY(hv);
! if (!xhv->xhv_array /* !HvARRAY(hv) */) {
if (lval
#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
! || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
#endif
)
! Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
! PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
! char);
else
return 0;
}
! if (is_utf8) {
STRLEN tmplen = klen;
/* Just casting the &klen to (STRLEN) won't work well
* if STRLEN and I32 are of different widths. --jhi */
***************
*** 207,212 ****
--- 209,215 ----
PERL_HASH(hash, key, klen);
+ /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
for (; entry; entry = HeNEXT(entry)) {
if (HeHASH(entry) != hash) /* strings can't be equal */
***************
*** 222,228 ****
return &HeVAL(entry);
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
! if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
unsigned long len;
char *env = PerlEnv_ENVgetenv_len(key,&len);
if (env) {
--- 225,231 ----
return &HeVAL(entry);
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
! if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
unsigned long len;
char *env = PerlEnv_ENVgetenv_len(key,&len);
if (env) {
***************
*** 283,289 ****
return 0;
if (SvRMAGICAL(hv)) {
! if (mg_find((SV*)hv,'P')) {
sv = sv_newmortal();
keysv = sv_2mortal(newSVsv(keysv));
mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
--- 286,292 ----
return 0;
if (SvRMAGICAL(hv)) {
! if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
sv = sv_newmortal();
keysv = sv_2mortal(newSVsv(keysv));
mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
***************
*** 297,303 ****
return &PL_hv_fetch_ent_mh;
}
#ifdef ENV_IS_CASELESS
! else if (mg_find((SV*)hv,'E')) {
U32 i;
key = SvPV(keysv, klen);
for (i = 0; i < klen; ++i)
--- 300,306 ----
return &PL_hv_fetch_ent_mh;
}
#ifdef ENV_IS_CASELESS
! else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
U32 i;
key = SvPV(keysv, klen);
for (i = 0; i < klen; ++i)
***************
*** 314,327 ****
}
xhv = (XPVHV*)SvANY(hv);
! if (!xhv->xhv_array) {
if (lval
#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
! || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
#endif
)
! Newz(503, xhv->xhv_array,
! PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
else
return 0;
}
--- 317,331 ----
}
xhv = (XPVHV*)SvANY(hv);
! if (!xhv->xhv_array /* !HvARRAY(hv) */) {
if (lval
#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
! || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
#endif
)
! Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
! PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
! char);
else
return 0;
}
***************
*** 329,340 ****
keysave = key = SvPV(keysv, klen);
is_utf8 = (SvUTF8(keysv)!=0);
! if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
if (!hash)
PERL_HASH(hash, key, klen);
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
for (; entry; entry = HeNEXT(entry)) {
if (HeHASH(entry) != hash) /* strings can't be equal */
--- 333,345 ----
keysave = key = SvPV(keysv, klen);
is_utf8 = (SvUTF8(keysv)!=0);
! if (is_utf8)
key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
if (!hash)
PERL_HASH(hash, key, klen);
+ /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
for (; entry; entry = HeNEXT(entry)) {
if (HeHASH(entry) != hash) /* strings can't be equal */
***************
*** 350,356 ****
return entry;
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
! if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
unsigned long len;
char *env = PerlEnv_ENVgetenv_len(key,&len);
if (env) {
--- 355,361 ----
return entry;
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
! if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
unsigned long len;
char *env = PerlEnv_ENVgetenv_len(key,&len);
if (env) {
***************
*** 379,386 ****
if (isUPPER(mg->mg_type)) {
*needs_copy = TRUE;
switch (mg->mg_type) {
! case 'P':
! case 'S':
*needs_store = FALSE;
}
}
--- 384,391 ----
if (isUPPER(mg->mg_type)) {
*needs_copy = TRUE;
switch (mg->mg_type) {
! case PERL_MAGIC_tied:
! case PERL_MAGIC_sig:
*needs_store = FALSE;
}
}
***************
*** 431,448 ****
hv_magic_check (hv, &needs_copy, &needs_store);
if (needs_copy) {
mg_copy((SV*)hv, val, key, klen);
! if (!xhv->xhv_array && !needs_store)
return 0;
#ifdef ENV_IS_CASELESS
! else if (mg_find((SV*)hv,'E')) {
key = savepvn(key,klen);
! key = strupr(key);
hash = 0;
}
#endif
}
}
! if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
STRLEN tmplen = klen;
/* See the note in hv_fetch(). --jhi */
key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
--- 436,453 ----
hv_magic_check (hv, &needs_copy, &needs_store);
if (needs_copy) {
mg_copy((SV*)hv, val, key, klen);
! if (!xhv->xhv_array /* !HvARRAY */ && !needs_store)
return 0;
#ifdef ENV_IS_CASELESS
! else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
key = savepvn(key,klen);
! key = (const char*)strupr((char*)key);
hash = 0;
}
#endif
}
}
! if (is_utf8) {
STRLEN tmplen = klen;
/* See the note in hv_fetch(). --jhi */
key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
***************
*** 452,461 ****
if (!hash)
PERL_HASH(hash, key, klen);
! if (!xhv->xhv_array)
! Newz(505, xhv->xhv_array,
! PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
i = 1;
--- 457,468 ----
if (!hash)
PERL_HASH(hash, key, klen);
! if (!xhv->xhv_array /* !HvARRAY(hv) */)
! Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
! PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
! char);
+ /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
i = 1;
***************
*** 486,495 ****
HeNEXT(entry) = *oentry;
*oentry = entry;
! xhv->xhv_keys++;
if (i) { /* initial entry? */
! ++xhv->xhv_fill;
! if (xhv->xhv_keys > xhv->xhv_max)
hsplit(hv);
}
--- 493,502 ----
HeNEXT(entry) = *oentry;
*oentry = entry;
! xhv->xhv_keys++; /* HvKEYS(hv)++ */
if (i) { /* initial entry? */
! xhv->xhv_fill++; /* HvFILL(hv)++ */
! if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
hsplit(hv);
}
***************
*** 504,510 ****
compute it. The return value is the new hash entry so created. It will be
NULL if the operation failed or if the value did not need to be actually
stored within the hash (as in the case of tied hashes). Otherwise the
! contents of the return value can be accessed using the C<He???> macros
described here. Note that the caller is responsible for suitably
incrementing the reference count of C<val> before the call, and
decrementing it if the function returned NULL.
--- 511,517 ----
compute it. The return value is the new hash entry so created. It will be
NULL if the operation failed or if the value did not need to be actually
stored within the hash (as in the case of tied hashes). Otherwise the
! contents of the return value can be accessed using the C<He?> macros
described here. Note that the caller is responsible for suitably
incrementing the reference count of C<val> before the call, and
decrementing it if the function returned NULL.
***************
*** 542,551 ****
keysv = sv_2mortal(newSVsv(keysv));
mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
TAINT_IF(save_taint);
! if (!xhv->xhv_array && !needs_store)
return Nullhe;
#ifdef ENV_IS_CASELESS
! else if (mg_find((SV*)hv,'E')) {
key = SvPV(keysv, klen);
keysv = sv_2mortal(newSVpvn(key,klen));
(void)strupr(SvPVX(keysv));
--- 549,558 ----
keysv = sv_2mortal(newSVsv(keysv));
mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
TAINT_IF(save_taint);
! if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store)
return Nullhe;
#ifdef ENV_IS_CASELESS
! else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
key = SvPV(keysv, klen);
keysv = sv_2mortal(newSVpvn(key,klen));
(void)strupr(SvPVX(keysv));
***************
*** 558,573 ****
keysave = key = SvPV(keysv, klen);
is_utf8 = (SvUTF8(keysv) != 0);
! if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
if (!hash)
PERL_HASH(hash, key, klen);
! if (!xhv->xhv_array)
! Newz(505, xhv->xhv_array,
! PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
i = 1;
--- 565,582 ----
keysave = key = SvPV(keysv, klen);
is_utf8 = (SvUTF8(keysv) != 0);
! if (is_utf8)
key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
if (!hash)
PERL_HASH(hash, key, klen);
! if (!xhv->xhv_array /* !HvARRAY(hv) */)
! Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
! PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
! char);
+ /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
i = 1;
***************
*** 589,597 ****
entry = new_HE();
if (HvSHAREKEYS(hv))
! HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
else /* gotta do the real thing */
! HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
if (key != keysave)
Safefree(key);
HeVAL(entry) = val;
--- 598,606 ----
entry = new_HE();
if (HvSHAREKEYS(hv))
! HeKEY_hek(entry) = share_hek(key, is_utf8?-(I32)klen:klen, hash);
else /* gotta do the real thing */
! HeKEY_hek(entry) = save_hek(key, is_utf8?-(I32)klen:klen, hash);
if (key != keysave)
Safefree(key);
HeVAL(entry) = val;
***************
*** 598,607 ****
HeNEXT(entry) = *oentry;
*oentry = entry;
! xhv->xhv_keys++;
if (i) { /* initial entry? */
! ++xhv->xhv_fill;
! if (xhv->xhv_keys > xhv->xhv_max)
hsplit(hv);
}
--- 607,616 ----
HeNEXT(entry) = *oentry;
*oentry = entry;
! xhv->xhv_keys++; /* HvKEYS(hv)++ */
if (i) { /* initial entry? */
! xhv->xhv_fill++; /* HvFILL(hv)++ */
! if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
hsplit(hv);
}
***************
*** 647,660 ****
sv = *svp;
mg_clear(sv);
if (!needs_store) {
! if (mg_find(sv, 'p')) {
! sv_unmagic(sv, 'p'); /* No longer an element */
return sv;
}
return Nullsv; /* element cannot be deleted */
}
#ifdef ENV_IS_CASELESS
! else if (mg_find((SV*)hv,'E')) {
sv = sv_2mortal(newSVpvn(key,klen));
key = strupr(SvPVX(sv));
}
--- 656,670 ----
sv = *svp;
mg_clear(sv);
if (!needs_store) {
! if (mg_find(sv, PERL_MAGIC_tiedelem)) {
! /* No longer an element */
! sv_unmagic(sv, PERL_MAGIC_tiedelem);
return sv;
}
return Nullsv; /* element cannot be deleted */
}
#ifdef ENV_IS_CASELESS
! else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
sv = sv_2mortal(newSVpvn(key,klen));
key = strupr(SvPVX(sv));
}
***************
*** 662,671 ****
}
}
xhv = (XPVHV*)SvANY(hv);
! if (!xhv->xhv_array)
return Nullsv;
! if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
STRLEN tmplen = klen;
/* See the note in hv_fetch(). --jhi */
key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
--- 672,681 ----
}
}
xhv = (XPVHV*)SvANY(hv);
! if (!xhv->xhv_array /* !HvARRAY(hv) */)
return Nullsv;
! if (is_utf8) {
STRLEN tmplen = klen;
/* See the note in hv_fetch(). --jhi */
key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
***************
*** 674,679 ****
--- 684,690 ----
PERL_HASH(hash, key, klen);
+ /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
entry = *oentry;
i = 1;
***************
*** 690,696 ****
Safefree(key);
*oentry = HeNEXT(entry);
if (i && !*oentry)
! xhv->xhv_fill--;
if (flags & G_DISCARD)
sv = Nullsv;
else {
--- 701,707 ----
Safefree(key);
*oentry = HeNEXT(entry);
if (i && !*oentry)
! xhv->xhv_fill--; /* HvFILL(hv)-- */
if (flags & G_DISCARD)
sv = Nullsv;
else {
***************
*** 697,707 ****
sv = sv_2mortal(HeVAL(entry));
HeVAL(entry) = &PL_sv_undef;
}
! if (entry == xhv->xhv_eiter)
HvLAZYDEL_on(hv);
else
hv_free_ent(hv, entry);
! --xhv->xhv_keys;
return sv;
}
if (key != keysave)
--- 708,718 ----
sv = sv_2mortal(HeVAL(entry));
HeVAL(entry) = &PL_sv_undef;
}
! if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
HvLAZYDEL_on(hv);
else
hv_free_ent(hv, entry);
! xhv->xhv_keys--; /* HvKEYS(hv)-- */
return sv;
}
if (key != keysave)
***************
*** 744,757 ****
sv = HeVAL(entry);
mg_clear(sv);
if (!needs_store) {
! if (mg_find(sv, 'p')) {
! sv_unmagic(sv, 'p'); /* No longer an element */
return sv;
}
return Nullsv; /* element cannot be deleted */
}
#ifdef ENV_IS_CASELESS
! else if (mg_find((SV*)hv,'E')) {
key = SvPV(keysv, klen);
keysv = sv_2mortal(newSVpvn(key,klen));
(void)strupr(SvPVX(keysv));
--- 755,769 ----
sv = HeVAL(entry);
mg_clear(sv);
if (!needs_store) {
! if (mg_find(sv, PERL_MAGIC_tiedelem)) {
! /* No longer an element */
! sv_unmagic(sv, PERL_MAGIC_tiedelem);
return sv;
}
return Nullsv; /* element cannot be deleted */
}
#ifdef ENV_IS_CASELESS
! else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
key = SvPV(keysv, klen);
keysv = sv_2mortal(newSVpvn(key,klen));
(void)strupr(SvPVX(keysv));
***************
*** 761,778 ****
}
}
xhv = (XPVHV*)SvANY(hv);
! if (!xhv->xhv_array)
return Nullsv;
keysave = key = SvPV(keysv, klen);
is_utf8 = (SvUTF8(keysv) != 0);
! if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
if (!hash)
PERL_HASH(hash, key, klen);
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
entry = *oentry;
i = 1;
--- 773,791 ----
}
}
xhv = (XPVHV*)SvANY(hv);
! if (!xhv->xhv_array /* !HvARRAY(hv) */)
return Nullsv;
keysave = key = SvPV(keysv, klen);
is_utf8 = (SvUTF8(keysv) != 0);
! if (is_utf8)
key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
if (!hash)
PERL_HASH(hash, key, klen);
+ /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
entry = *oentry;
i = 1;
***************
*** 789,795 ****
Safefree(key);
*oentry = HeNEXT(entry);
if (i && !*oentry)
! xhv->xhv_fill--;
if (flags & G_DISCARD)
sv = Nullsv;
else {
--- 802,808 ----
Safefree(key);
*oentry = HeNEXT(entry);
if (i && !*oentry)
! xhv->xhv_fill--; /* HvFILL(hv)-- */
if (flags & G_DISCARD)
sv = Nullsv;
else {
***************
*** 796,806 ****
sv = sv_2mortal(HeVAL(entry));
HeVAL(entry) = &PL_sv_undef;
}
! if (entry == xhv->xhv_eiter)
HvLAZYDEL_on(hv);
else
hv_free_ent(hv, entry);
! --xhv->xhv_keys;
return sv;
}
if (key != keysave)
--- 809,819 ----
sv = sv_2mortal(HeVAL(entry));
HeVAL(entry) = &PL_sv_undef;
}
! if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
HvLAZYDEL_on(hv);
else
hv_free_ent(hv, entry);
! xhv->xhv_keys--; /* HvKEYS(hv)-- */
return sv;
}
if (key != keysave)
***************
*** 836,849 ****
}
if (SvRMAGICAL(hv)) {
! if (mg_find((SV*)hv,'P')) {
sv = sv_newmortal();
mg_copy((SV*)hv, sv, key, klen);
! magic_existspack(sv, mg_find(sv, 'p'));
return SvTRUE(sv);
}
#ifdef ENV_IS_CASELESS
! else if (mg_find((SV*)hv,'E')) {
sv = sv_2mortal(newSVpvn(key,klen));
key = strupr(SvPVX(sv));
}
--- 849,862 ----
}
if (SvRMAGICAL(hv)) {
! if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
sv = sv_newmortal();
mg_copy((SV*)hv, sv, key, klen);
! magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
return SvTRUE(sv);
}
#ifdef ENV_IS_CASELESS
! else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
sv = sv_2mortal(newSVpvn(key,klen));
key = strupr(SvPVX(sv));
}
***************
*** 852,862 ****
xhv = (XPVHV*)SvANY(hv);
#ifndef DYNAMIC_ENV_FETCH
! if (!xhv->xhv_array)
return 0;
#endif
! if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
STRLEN tmplen = klen;
/* See the note in hv_fetch(). --jhi */
key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
--- 865,875 ----
xhv = (XPVHV*)SvANY(hv);
#ifndef DYNAMIC_ENV_FETCH
! if (!xhv->xhv_array /* !HvARRAY(hv) */)
return 0;
#endif
! if (is_utf8) {
STRLEN tmplen = klen;
/* See the note in hv_fetch(). --jhi */
key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
***************
*** 866,874 ****
PERL_HASH(hash, key, klen);
#ifdef DYNAMIC_ENV_FETCH
! if (!xhv->xhv_array) entry = Null(HE*);
else
#endif
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
for (; entry; entry = HeNEXT(entry)) {
if (HeHASH(entry) != hash) /* strings can't be equal */
--- 879,888 ----
PERL_HASH(hash, key, klen);
#ifdef DYNAMIC_ENV_FETCH
! if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
else
#endif
+ /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
for (; entry; entry = HeNEXT(entry)) {
if (HeHASH(entry) != hash) /* strings can't be equal */
***************
*** 884,890 ****
return TRUE;
}
#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
! if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
unsigned long len;
char *env = PerlEnv_ENVgetenv_len(key,&len);
if (env) {
--- 898,904 ----
return TRUE;
}
#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
! if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
unsigned long len;
char *env = PerlEnv_ENVgetenv_len(key,&len);
if (env) {
***************
*** 926,941 ****
return 0;
if (SvRMAGICAL(hv)) {
! if (mg_find((SV*)hv,'P')) {
SV* svret = sv_newmortal();
sv = sv_newmortal();
keysv = sv_2mortal(newSVsv(keysv));
mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
! magic_existspack(svret, mg_find(sv, 'p'));
return SvTRUE(svret);
}
#ifdef ENV_IS_CASELESS
! else if (mg_find((SV*)hv,'E')) {
key = SvPV(keysv, klen);
keysv = sv_2mortal(newSVpvn(key,klen));
(void)strupr(SvPVX(keysv));
--- 940,955 ----
return 0;
if (SvRMAGICAL(hv)) {
! if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
SV* svret = sv_newmortal();
sv = sv_newmortal();
keysv = sv_2mortal(newSVsv(keysv));
mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
! magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
return SvTRUE(svret);
}
#ifdef ENV_IS_CASELESS
! else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
key = SvPV(keysv, klen);
keysv = sv_2mortal(newSVpvn(key,klen));
(void)strupr(SvPVX(keysv));
***************
*** 946,966 ****
xhv = (XPVHV*)SvANY(hv);
#ifndef DYNAMIC_ENV_FETCH
! if (!xhv->xhv_array)
return 0;
#endif
keysave = key = SvPV(keysv, klen);
is_utf8 = (SvUTF8(keysv) != 0);
! if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
if (!hash)
PERL_HASH(hash, key, klen);
#ifdef DYNAMIC_ENV_FETCH
! if (!xhv->xhv_array) entry = Null(HE*);
else
#endif
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
for (; entry; entry = HeNEXT(entry)) {
if (HeHASH(entry) != hash) /* strings can't be equal */
--- 960,981 ----
xhv = (XPVHV*)SvANY(hv);
#ifndef DYNAMIC_ENV_FETCH
! if (!xhv->xhv_array /* !HvARRAY(hv) */)
return 0;
#endif
keysave = key = SvPV(keysv, klen);
is_utf8 = (SvUTF8(keysv) != 0);
! if (is_utf8)
key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
if (!hash)
PERL_HASH(hash, key, klen);
#ifdef DYNAMIC_ENV_FETCH
! if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
else
#endif
+ /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
for (; entry; entry = HeNEXT(entry)) {
if (HeHASH(entry) != hash) /* strings can't be equal */
***************
*** 976,982 ****
return TRUE;
}
#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
! if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
unsigned long len;
char *env = PerlEnv_ENVgetenv_len(key,&len);
if (env) {
--- 991,997 ----
return TRUE;
}
#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
! if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
unsigned long len;
char *env = PerlEnv_ENVgetenv_len(key,&len);
if (env) {
***************
*** 996,1005 ****
S_hsplit(pTHX_ HV *hv)
{
register XPVHV* xhv = (XPVHV*)SvANY(hv);
! I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
register I32 newsize = oldsize * 2;
register I32 i;
! register char *a = xhv->xhv_array;
register HE **aep;
register HE **bep;
register HE *entry;
--- 1011,1020 ----
S_hsplit(pTHX_ HV *hv)
{
register XPVHV* xhv = (XPVHV*)SvANY(hv);
! I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
register I32 newsize = oldsize * 2;
register I32 i;
! register char *a = xhv->xhv_array; /* HvARRAY(hv) */
register HE **aep;
register HE **bep;
register HE *entry;
***************
*** 1013,1036 ****
return;
}
#else
- #define MALLOC_OVERHEAD 16
New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
if (!a) {
PL_nomemok = FALSE;
return;
}
! Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
if (oldsize >= 64) {
! offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
}
else
! Safefree(xhv->xhv_array);
#endif
PL_nomemok = FALSE;
Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
! xhv->xhv_max = --newsize;
! xhv->xhv_array = a;
aep = (HE**)a;
for (i=0; i<oldsize; i++,aep++) {
--- 1028,1051 ----
return;
}
#else
New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
if (!a) {
PL_nomemok = FALSE;
return;
}
! Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
if (oldsize >= 64) {
! offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
! PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
}
else
! Safefree(xhv->xhv_array /* HvARRAY(hv) */);
#endif
PL_nomemok = FALSE;
Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
! xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
! xhv->xhv_array = a; /* HvARRAY(hv) = a */
aep = (HE**)a;
for (i=0; i<oldsize; i++,aep++) {
***************
*** 1042,1048 ****
*oentry = HeNEXT(entry);
HeNEXT(entry) = *bep;
if (!*bep)
! xhv->xhv_fill++;
*bep = entry;
continue;
}
--- 1057,1063 ----
*oentry = HeNEXT(entry);
HeNEXT(entry) = *bep;
if (!*bep)
! xhv->xhv_fill++; /* HvFILL(hv)++ */
*bep = entry;
continue;
}
***************
*** 1050,1056 ****
oentry = &HeNEXT(entry);
}
if (!*aep) /* everything moved */
! xhv->xhv_fill--;
}
}
--- 1065,1071 ----
oentry = &HeNEXT(entry);
}
if (!*aep) /* everything moved */
! xhv->xhv_fill--; /* HvFILL(hv)-- */
}
}
***************
*** 1058,1064 ****
Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
{
register XPVHV* xhv = (XPVHV*)SvANY(hv);
! I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
register I32 newsize;
register I32 i;
register I32 j;
--- 1073,1079 ----
Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
{
register XPVHV* xhv = (XPVHV*)SvANY(hv);
! I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
register I32 newsize;
register I32 i;
register I32 j;
***************
*** 1078,1084 ****
if (newsize < newmax)
return; /* overflow detection */
! a = xhv->xhv_array;
if (a) {
PL_nomemok = TRUE;
#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
--- 1093,1099 ----
if (newsize < newmax)
return; /* overflow detection */
! a = xhv->xhv_array; /* HvARRAY(hv) */
if (a) {
PL_nomemok = TRUE;
#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
***************
*** 1093,1104 ****
PL_nomemok = FALSE;
return;
}
! Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
if (oldsize >= 64) {
! offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
}
else
! Safefree(xhv->xhv_array);
#endif
PL_nomemok = FALSE;
Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
--- 1108,1120 ----
PL_nomemok = FALSE;
return;
}
! Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
if (oldsize >= 64) {
! offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
! PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
}
else
! Safefree(xhv->xhv_array /* HvARRAY(hv) */);
#endif
PL_nomemok = FALSE;
Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
***************
*** 1106,1114 ****
else {
Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
}
! xhv->xhv_max = --newsize;
! xhv->xhv_array = a;
! if (!xhv->xhv_fill) /* skip rest if no entries */
return;
aep = (HE**)a;
--- 1122,1130 ----
else {
Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
}
! xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
! xhv->xhv_array = a; /* HvARRAY(hv) = a */
! if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
return;
aep = (HE**)a;
***************
*** 1120,1126 ****
j -= i;
*oentry = HeNEXT(entry);
if (!(HeNEXT(entry) = aep[j]))
! xhv->xhv_fill++;
aep[j] = entry;
continue;
}
--- 1136,1142 ----
j -= i;
*oentry = HeNEXT(entry);
if (!(HeNEXT(entry) = aep[j]))
! xhv->xhv_fill++; /* HvFILL(hv)++ */
aep[j] = entry;
continue;
}
***************
*** 1128,1134 ****
oentry = &HeNEXT(entry);
}
if (!*aep) /* everything moved */
! xhv->xhv_fill--;
}
}
--- 1144,1150 ----
oentry = &HeNEXT(entry);
}
if (!*aep) /* everything moved */
! xhv->xhv_fill--; /* HvFILL(hv)-- */
}
}
***************
*** 1154,1162 ****
#ifndef NODEFAULT_SHAREKEYS
HvSHAREKEYS_on(hv); /* key-sharing on by default */
#endif
! xhv->xhv_max = 7; /* start with 8 buckets */
! xhv->xhv_fill = 0;
! xhv->xhv_pmroot = 0;
(void)hv_iterinit(hv); /* so each() will start off right */
return hv;
}
--- 1170,1178 ----
#ifndef NODEFAULT_SHAREKEYS
HvSHAREKEYS_on(hv); /* key-sharing on by default */
#endif
! xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
! xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
! xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */
(void)hv_iterinit(hv); /* so each() will start off right */
return hv;
}
***************
*** 1176,1182 ****
return hv;
#if 0
! if (! SvTIED_mg((SV*)ohv, 'P')) {
/* Quick way ???*/
}
else
--- 1192,1198 ----
return hv;
#if 0
! if (! SvTIED_mg((SV*)ohv, PERL_MAGIC_tied)) {
/* Quick way ???*/
}
else
***************
*** 1256,1265 ****
return;
xhv = (XPVHV*)SvANY(hv);
hfreeentries(hv);
! xhv->xhv_fill = 0;
! xhv->xhv_keys = 0;
! if (xhv->xhv_array)
! (void)memzero(xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*));
if (SvRMAGICAL(hv))
mg_clear((SV*)hv);
--- 1272,1282 ----
return;
xhv = (XPVHV*)SvANY(hv);
hfreeentries(hv);
! xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
! xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
! if (xhv->xhv_array /* HvARRAY(hv) */)
! (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
! (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
if (SvRMAGICAL(hv))
mg_clear((SV*)hv);
***************
*** 1314,1328 ****
return;
xhv = (XPVHV*)SvANY(hv);
hfreeentries(hv);
! Safefree(xhv->xhv_array);
if (HvNAME(hv)) {
Safefree(HvNAME(hv));
HvNAME(hv) = 0;
}
! xhv->xhv_array = 0;
! xhv->xhv_max = 7; /* it's a normal hash */
! xhv->xhv_fill = 0;
! xhv->xhv_keys = 0;
if (SvRMAGICAL(hv))
mg_clear((SV*)hv);
--- 1331,1345 ----
return;
xhv = (XPVHV*)SvANY(hv);
hfreeentries(hv);
! Safefree(xhv->xhv_array /* HvARRAY(hv) */);
if (HvNAME(hv)) {
Safefree(HvNAME(hv));
HvNAME(hv) = 0;
}
! xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
! xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
! xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
! xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
if (SvRMAGICAL(hv))
mg_clear((SV*)hv);
***************
*** 1351,1364 ****
if (!hv)
Perl_croak(aTHX_ "Bad hash");
xhv = (XPVHV*)SvANY(hv);
! entry = xhv->xhv_eiter;
if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
HvLAZYDEL_off(hv);
hv_free_ent(hv, entry);
}
! xhv->xhv_riter = -1;
! xhv->xhv_eiter = Null(HE*);
! return xhv->xhv_keys; /* used to be xhv->xhv_fill before 5.004_65 */
}
/*
--- 1368,1382 ----
if (!hv)
Perl_croak(aTHX_ "Bad hash");
xhv = (XPVHV*)SvANY(hv);
! entry = xhv->xhv_eiter; /* HvEITER(hv) */
if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
HvLAZYDEL_off(hv);
hv_free_ent(hv, entry);
}
! xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
! xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
! /* used to be xhv->xhv_fill before 5.004_65 */
! return xhv->xhv_keys; /* HvKEYS(hv) */
}
/*
***************
*** 1380,1388 ****
if (!hv)
Perl_croak(aTHX_ "Bad hash");
xhv = (XPVHV*)SvANY(hv);
! oldentry = entry = xhv->xhv_eiter;
! if ((mg = SvTIED_mg((SV*)hv, 'P'))) {
SV *key = sv_newmortal();
if (entry) {
sv_setsv(key, HeSVKEY_force(entry));
--- 1398,1406 ----
if (!hv)
Perl_croak(aTHX_ "Bad hash");
xhv = (XPVHV*)SvANY(hv);
! oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
! if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
SV *key = sv_newmortal();
if (entry) {
sv_setsv(key, HeSVKEY_force(entry));
***************
*** 1392,1398 ****
char *k;
HEK *hek;
! xhv->xhv_eiter = entry = new_HE(); /* one HE per MAGICAL hash */
Zero(entry, 1, HE);
Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
hek = (HEK*)k;
--- 1410,1417 ----
char *k;
HEK *hek;
! /* one HE per MAGICAL hash */
! xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
Zero(entry, 1, HE);
Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
hek = (HEK*)k;
***************
*** 1409,1433 ****
SvREFCNT_dec(HeVAL(entry));
Safefree(HeKEY_hek(entry));
del_HE(entry);
! xhv->xhv_eiter = Null(HE*);
return Null(HE*);
}
#ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
! if (!entry && HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME))
prime_env_iter();
#endif
! if (!xhv->xhv_array)
! Newz(506, xhv->xhv_array,
! PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
if (entry)
entry = HeNEXT(entry);
while (!entry) {
! ++xhv->xhv_riter;
! if (xhv->xhv_riter > xhv->xhv_max) {
! xhv->xhv_riter = -1;
break;
}
entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
}
--- 1428,1454 ----
SvREFCNT_dec(HeVAL(entry));
Safefree(HeKEY_hek(entry));
del_HE(entry);
! xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
return Null(HE*);
}
#ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
! if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
prime_env_iter();
#endif
! if (!xhv->xhv_array /* !HvARRAY(hv) */)
! Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
! PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
! char);
if (entry)
entry = HeNEXT(entry);
while (!entry) {
! xhv->xhv_riter++; /* HvRITER(hv)++ */
! if (xhv->xhv_riter > xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
! xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
break;
}
+ /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
}
***************
*** 1436,1442 ****
hv_free_ent(hv, oldentry);
}
! xhv->xhv_eiter = entry;
return entry;
}
--- 1457,1463 ----
hv_free_ent(hv, oldentry);
}
! xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
return entry;
}
***************
*** 1498,1504 ****
Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
{
if (SvRMAGICAL(hv)) {
! if (mg_find((SV*)hv,'P')) {
SV* sv = sv_newmortal();
if (HeKLEN(entry) == HEf_SVKEY)
mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
--- 1519,1525 ----
Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
{
if (SvRMAGICAL(hv)) {
! if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
SV* sv = sv_newmortal();
if (HeKLEN(entry) == HEf_SVKEY)
mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
***************
*** 1563,1576 ****
const char *save = str;
if (len < 0) {
! len = -len;
is_utf8 = TRUE;
! if (!(PL_hints & HINT_UTF8_DISTINCT)) {
! STRLEN tmplen = len;
! /* See the note in hv_fetch(). --jhi */
! str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
! len = tmplen;
! }
}
/* what follows is the moral equivalent of:
--- 1584,1594 ----
const char *save = str;
if (len < 0) {
! STRLEN tmplen = -len;
is_utf8 = TRUE;
! /* See the note in hv_fetch(). --jhi */
! str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
! len = tmplen;
}
/* what follows is the moral equivalent of:
***************
*** 1581,1586 ****
--- 1599,1605 ----
xhv = (XPVHV*)SvANY(PL_strtab);
/* assert(xhv_array != 0) */
LOCK_STRTAB_MUTEX;
+ /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
if (HeHASH(entry) != hash) /* strings can't be equal */
***************
*** 1595,1604 ****
if (--HeVAL(entry) == Nullsv) {
*oentry = HeNEXT(entry);
if (i && !*oentry)
! xhv->xhv_fill--;
Safefree(HeKEY_hek(entry));
del_HE(entry);
! --xhv->xhv_keys;
}
break;
}
--- 1614,1623 ----
if (--HeVAL(entry) == Nullsv) {
*oentry = HeNEXT(entry);
if (i && !*oentry)
! xhv->xhv_fill--; /* HvFILL(hv)-- */
Safefree(HeKEY_hek(entry));
del_HE(entry);
! xhv->xhv_keys--; /* HvKEYS(hv)-- */
}
break;
}
***************
*** 1625,1638 ****
const char *save = str;
if (len < 0) {
! len = -len;
is_utf8 = TRUE;
! if (!(PL_hints & HINT_UTF8_DISTINCT)) {
! STRLEN tmplen = len;
! /* See the note in hv_fetch(). --jhi */
! str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
! len = tmplen;
! }
}
/* what follows is the moral equivalent of:
--- 1644,1654 ----
const char *save = str;
if (len < 0) {
! STRLEN tmplen = -len;
is_utf8 = TRUE;
! /* See the note in hv_fetch(). --jhi */
! str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
! len = tmplen;
}
/* what follows is the moral equivalent of:
***************
*** 1643,1648 ****
--- 1659,1665 ----
xhv = (XPVHV*)SvANY(PL_strtab);
/* assert(xhv_array != 0) */
LOCK_STRTAB_MUTEX;
+ /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
if (HeHASH(entry) != hash) /* strings can't be equal */
***************
*** 1662,1671 ****
HeVAL(entry) = Nullsv;
HeNEXT(entry) = *oentry;
*oentry = entry;
! xhv->xhv_keys++;
if (i) { /* initial entry? */
! ++xhv->xhv_fill;
! if (xhv->xhv_keys > xhv->xhv_max)
hsplit(PL_strtab);
}
}
--- 1679,1688 ----
HeVAL(entry) = Nullsv;
HeNEXT(entry) = *oentry;
*oentry = entry;
! xhv->xhv_keys++; /* HvKEYS(hv)++ */
if (i) { /* initial entry? */
! xhv->xhv_fill++; /* HvFILL(hv)++ */
! if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
hsplit(PL_strtab);
}
}
diff -c 'perl-5.7.1/hv.h' 'perl-5.7.2/hv.h'
Index: ./hv.h
*** ./hv.h Tue Apr 3 01:30:10 2001
--- ./hv.h Mon Jul 9 17:10:22 2001
***************
*** 123,129 ****
#define Nullhv Null(HV*)
! #define HvARRAY(hv) ((HE**)((XPVHV*) SvANY(hv))->xhv_array)
#define HvFILL(hv) ((XPVHV*) SvANY(hv))->xhv_fill
#define HvMAX(hv) ((XPVHV*) SvANY(hv))->xhv_max
#define HvKEYS(hv) ((XPVHV*) SvANY(hv))->xhv_keys
--- 123,129 ----
#define Nullhv Null(HV*)
! #define HvARRAY(hv) (*(HE***)&((XPVHV*) SvANY(hv))->xhv_array)
#define HvFILL(hv) ((XPVHV*) SvANY(hv))->xhv_fill
#define HvMAX(hv) ((XPVHV*) SvANY(hv))->xhv_max
#define HvKEYS(hv) ((XPVHV*) SvANY(hv))->xhv_keys
diff -c 'perl-5.7.1/installman' 'perl-5.7.2/installman'
Index: ./installman
*** ./installman Tue Mar 6 04:05:18 2001
--- ./installman Mon Jul 9 17:10:22 2001
***************
*** 11,16 ****
--- 11,20 ----
use vars qw($packlist @modpods);
require Cwd;
+ if ($Config{d_umask}) {
+ umask(022); # umasks like 077 aren't that useful for installations
+ }
+
$ENV{SHELL} = 'sh' if $^O eq 'os2';
my $ver = $Config{version}; # Not used presently.
***************
*** 67,72 ****
--- 71,77 ----
$packlist = ExtUtils::Packlist->new("$Config{installarchlib}/.packlist");
+
# Install the main pod pages.
runpod2man('pod', $opts{man1dir}, $opts{man1ext});
***************
*** 74,92 ****
runpod2man('lib', $opts{man3dir}, $opts{man3ext});
# Install the pods embedded in the installed scripts
! runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'c2ph', 'h2ph', 'h2xs',
! 'perlcc', 'perldoc', 'perlbug', 'pl2pm', 'splain', 'dprofpp');
! runpod2man('x2p', $opts{man1dir}, $opts{man1ext}, 's2p', 'a2p.pod',
! 'find2perl');
! runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2man', 'pod2html',
! 'pod2text', 'pod2usage', 'podchecker', 'podselect');
!
! # It would probably be better to have this page linked
! # to the c2ph man page. Or, this one could say ".so man1/c2ph.1",
! # but then it would have to pay attention to $opts{man1dir} and $opts{man1ext}.
! runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'pstruct');
!
! runpod2man('lib/ExtUtils', $opts{man1dir}, $opts{man1ext}, 'xsubpp');
sub runpod2man {
# @script is scripts names if we are installing manpages embedded
--- 79,95 ----
runpod2man('lib', $opts{man3dir}, $opts{man3ext});
# Install the pods embedded in the installed scripts
! open UTILS, "utils.lst" or die "Can't open 'utils.lst': $!";
! while (<UTILS>) {
! next if /^#/;
! chomp;
! $_ = $1 if /#.*pod\s*=\s*(\S+)/;
! my ($where, $what) = m|^(.*?)/(\S+)|;
! runpod2man($where, $opts{man1dir}, $opts{man1ext}, $what);
! if (($where, $what) = m|#.*link\s*=\s*(\S+)/(\S+)|) {
! runpod2man($where, $opts{man1dir}, $opts{man1ext}, $what);
! }
! }
sub runpod2man {
# @script is scripts names if we are installing manpages embedded
diff -c 'perl-5.7.1/installperl' 'perl-5.7.2/installperl'
Index: ./installperl
*** ./installperl Fri Mar 30 05:03:00 2001
--- ./installperl Mon Jul 9 17:10:22 2001
***************
*** 9,15 ****
use strict;
my ($Is_VMS, $Is_W32, $Is_OS2, $Is_Cygwin, $nonono, $dostrip,
! $versiononly, $silent, $verbose, $otherperls, $archname);
use vars qw /$depth/;
BEGIN {
--- 9,15 ----
use strict;
my ($Is_VMS, $Is_W32, $Is_OS2, $Is_Cygwin, $nonono, $dostrip,
! $versiononly, $silent, $verbose, $otherperls, $archname,$Is_NetWare, $nwinstall);
use vars qw /$depth/;
BEGIN {
***************
*** 30,35 ****
--- 30,45 ----
use Config;
use subs qw(unlink link chmod);
+ if ($Config{d_umask}) {
+ umask(022); # umasks like 077 aren't that useful for installations
+ }
+
+ $Is_NetWare = $Config{osname} eq 'NetWare';
+ if ($Is_NetWare) {
+ $Is_W32 = 0;
+ $scr_ext = '.pl';
+ }
+
# override the ones in the rest of the script
sub mkpath {
File::Path::mkpath(@_) unless $nonono;
***************
*** 59,75 ****
$otherperls = 0 if $ARGV[0] eq '-o';
$verbose = 1 if $ARGV[0] eq '-V' || $ARGV [0] eq '-n';
$archname = 1 if $ARGV[0] eq '-A';
shift;
}
$versiononly = 1 if $Config{versiononly} && !defined $versiononly;
- my @scripts = qw(utils/c2ph utils/h2ph utils/h2xs utils/perlbug utils/perldoc
- utils/pl2pm utils/splain utils/perlcc utils/dprofpp
- x2p/s2p x2p/find2perl
- pod/pod2man pod/pod2html pod/pod2latex pod/pod2text
- pod/pod2usage pod/podchecker pod/podselect);
-
if ($scr_ext) { @scripts = map { "$_$scr_ext" } @scripts; }
my @pods = (<pod/*.pod>);
--- 69,94 ----
$otherperls = 0 if $ARGV[0] eq '-o';
$verbose = 1 if $ARGV[0] eq '-V' || $ARGV [0] eq '-n';
$archname = 1 if $ARGV[0] eq '-A';
+ $nwinstall = 1 if $ARGV[0] eq '-netware';
shift;
}
$versiononly = 1 if $Config{versiononly} && !defined $versiononly;
+ my (@scripts, @tolink);
+ open SCRIPTS, "utils.lst" or die "Can't open utils.lst: $!";
+ while (<SCRIPTS>) {
+ next if /^#/;
+ next if /#\s*pod\s*=/; # Binary programs need separate treatment
+ chomp;
+ if (/(\S*)\s*#\s*link\s*=\s*(\S*)/) {
+ push @scripts, $1;
+ push @tolink, [$1, $2];
+ } else {
+ push @scripts, $_;
+ }
+ }
+ close SCRIPTS;
if ($scr_ext) { @scripts = map { "$_$scr_ext" } @scripts; }
my @pods = (<pod/*.pod>);
***************
*** 149,154 ****
--- 168,181 ----
}
}
+ if ($nwinstall) {
+ # This is required only if we are installing on a NetWare server
+ $installscript = $Config{installnwscripts};
+ $installprivlib = $Config{installnwlib};
+ $installarchlib = $Config{installnwlib};
+ $installsitelib = $Config{installnwlib};
+ }
+
my $d_dosuid = $Config{d_dosuid};
my $binexp = $Config{binexp};
***************
*** 170,175 ****
--- 197,203 ----
-w $installbin || $nonono || die "$installbin is not writable by you\n"
unless $installbin =~ m#^/afs/# || $nonono;
+ if (!$Is_NetWare) {
-x 'perl' . $exe_ext || die "perl isn't executable!\n";
-x 'suidperl' . $exe_ext|| die "suidperl isn't executable!\n" if $d_dosuid;
***************
*** 176,183 ****
-f 't/rantests' || $Is_W32
|| warn "WARNING: You've never run 'make test' or",
" some tests failed! (Installing anyway.)\n";
! if ($Is_W32 or $Is_Cygwin) {
my $perldll;
if ($Is_Cygwin) {
--- 204,212 ----
-f 't/rantests' || $Is_W32
|| warn "WARNING: You've never run 'make test' or",
" some tests failed! (Installing anyway.)\n";
+ } #if (!$Is_NetWare)
! if (($Is_W32 and ! $Is_NetWare) or $Is_Cygwin) {
my $perldll;
if ($Is_Cygwin) {
***************
*** 204,210 ****
copy("$perldll", "$installbin/$perldll");
chmod(0755, "$installbin/$perldll");
! } # if ($Is_W32 or $Is_Cygwin)
# This will be used to store the packlist
my $packlist = ExtUtils::Packlist->new("$installarchlib/.packlist");
--- 233,239 ----
copy("$perldll", "$installbin/$perldll");
chmod(0755, "$installbin/$perldll");
! } # if (($Is_W32 and ! $Is_NetWare) or $Is_Cygwin)
# This will be used to store the packlist
my $packlist = ExtUtils::Packlist->new("$installarchlib/.packlist");
***************
*** 230,239 ****
link($Config{perlpath}, "$installbin/perl$ver$exe_ext");
}
elsif ($^O ne 'dos') {
! safe_unlink("$installbin/$perl_verbase$ver$exe_ext");
! copy("perl$exe_ext", "$installbin/$perl_verbase$ver$exe_ext");
! strip("$installbin/$perl_verbase$ver$exe_ext");
! chmod(0755, "$installbin/$perl_verbase$ver$exe_ext");
}
else {
safe_unlink("$installbin/$perl.exe");
--- 259,284 ----
link($Config{perlpath}, "$installbin/perl$ver$exe_ext");
}
elsif ($^O ne 'dos') {
! if (!$Is_NetWare) {
! safe_unlink("$installbin/$perl_verbase$ver$exe_ext");
! copy("perl$exe_ext", "$installbin/$perl_verbase$ver$exe_ext");
! strip("$installbin/$perl_verbase$ver$exe_ext");
! chmod(0755, "$installbin/$perl_verbase$ver$exe_ext");
! }
! else {
! # If installing onto a NetWare server
! if ($nwinstall) {
! # Copy perl.nlm, echo.nlm, type.nlm, a2p.nlm & cgi2perl.nlm
! mkpath($Config{installnwsystem}, 1, 0777);
! copy("netware\\".$ENV{'MAKE_TYPE'}."\\perl.nlm", $Config{installnwsystem});
! copy("netware\\testnlm\\echo\\echo.nlm", $Config{installnwsystem});
! copy("netware\\testnlm\\type\\type.nlm", $Config{installnwsystem});
! copy("x2p\\a2p.nlm", $Config{installnwsystem});
! chmod(0755, "$Config{installnwsystem}\\perl.nlm");
! mkpath($Config{installnwlcgi}, 1, 0777);
! copy("lib\\auto\\cgi2perl\\cgi2perl.nlm", $Config{installnwlcgi});
! }
! } #if (!$Is_NetWare)
}
else {
safe_unlink("$installbin/$perl.exe");
***************
*** 307,313 ****
# Install main perl executables
# Make links to ordinary names if installbin directory isn't current directory.
! if (! $versiononly && ! samepath($installbin, '.') && ($^O ne 'dos') && ! $Is_VMS) {
safe_unlink("$installbin/$perl$exe_ext", "$installbin/suid$perl$exe_ext");
if ($^O eq 'mpeix') {
# MPE doesn't support hard links, so use a symlink.
--- 352,358 ----
# Install main perl executables
# Make links to ordinary names if installbin directory isn't current directory.
! if (! $versiononly && ! samepath($installbin, '.') && ($^O ne 'dos') && ! $Is_VMS && ! $Is_NetWare) {
safe_unlink("$installbin/$perl$exe_ext", "$installbin/suid$perl$exe_ext");
if ($^O eq 'mpeix') {
# MPE doesn't support hard links, so use a symlink.
***************
*** 342,348 ****
my $mainperl_is_instperl = 0;
if ($Config{installusrbinperl} && $Config{installusrbinperl} eq 'define' &&
! !$versiononly && !$nonono && !$Is_W32 && !$Is_VMS && -t STDIN && -t STDERR
&& -w $mainperldir && ! samepath($mainperldir, $installbin)) {
my($usrbinperl) = "$mainperldir/$perl$exe_ext";
my($instperl) = "$installbin/$perl$exe_ext";
--- 387,393 ----
my $mainperl_is_instperl = 0;
if ($Config{installusrbinperl} && $Config{installusrbinperl} eq 'define' &&
! !$versiononly && !$nonono && !$Is_W32 && !$Is_NetWare && !$Is_VMS && -t STDIN && -t STDERR
&& -w $mainperldir && ! samepath($mainperldir, $installbin)) {
my($usrbinperl) = "$mainperldir/$perl$exe_ext";
my($instperl) = "$installbin/$perl$exe_ext";
***************
*** 376,386 ****
}
# Make links to ordinary names if installbin directory isn't current directory.
!
! if (!$versiononly && ! samepath($installbin, 'x2p')) {
! safe_unlink("$installbin/a2p$exe_ext");
! copy("x2p/a2p$exe_ext", "$installbin/a2p$exe_ext");
! chmod(0755, "$installbin/a2p$exe_ext");
}
# cppstdin is just a script, but it is architecture-dependent, so
--- 421,432 ----
}
# Make links to ordinary names if installbin directory isn't current directory.
! if (!$Is_NetWare) {
! if (!$versiononly && ! samepath($installbin, 'x2p')) {
! safe_unlink("$installbin/a2p$exe_ext");
! copy("x2p/a2p$exe_ext", "$installbin/a2p$exe_ext");
! chmod(0755, "$installbin/a2p$exe_ext");
! }
}
# cppstdin is just a script, but it is architecture-dependent, so
***************
*** 393,417 ****
chmod(0755, "$installbin/cppstdin");
}
! if (! $versiononly) {
! # Install scripts.
! mkpath($installscript, $verbose, 0777);
for (@scripts) {
(my $base = $_) =~ s#.*/##;
copy($_, "$installscript/$base");
chmod(0755, "$installscript/$base");
}
! # pstruct should be a link to c2ph
! safe_unlink("$installscript/pstruct$scr_ext");
! if ($^O eq 'dos' or $Is_VMS or $^O eq 'transit') {
! copy("$installscript/c2ph$scr_ext",
! "$installscript/pstruct$scr_ext");
! } else {
! link("$installscript/c2ph$scr_ext",
! "$installscript/pstruct$scr_ext");
}
}
--- 439,485 ----
chmod(0755, "$installbin/cppstdin");
}
! sub script_alias {
! my ($installscript, $orig, $alias, $scr_ext) = @_;
! safe_unlink("$installscript/$alias$scr_ext");
! if ($^O eq 'dos' or $Is_VMS or $^O eq 'transit') {
! copy("$installscript/$orig$scr_ext",
! "$installscript/$alias$scr_ext");
! } else {
! link("$installscript/$orig$scr_ext",
! "$installscript/$alias$scr_ext");
! }
! }
+ # Install scripts.
+ mkpath($installscript, $verbose, 0777);
+ if ($versiononly) {
for (@scripts) {
(my $base = $_) =~ s#.*/##;
+ $base .= $ver;
+ copy($_, "$installscript/$base");
+ chmod(0755, "$installscript/$base");
+ }
+
+ for (@tolink) {
+ my ($from, $to) = map { "$_$ver" } @$_;
+ (my $frbase = $from) =~ s#.*/##;
+ (my $tobase = $to) =~ s#.*/##;
+ script_alias($installscript, $frbase, $tobase, $scr_ext);
+ }
+ } else {
+ for (@scripts) {
+ (my $base = $_) =~ s#.*/##;
copy($_, "$installscript/$base");
chmod(0755, "$installscript/$base");
}
! for (@tolink) {
! my ($from, $to) = @$_;
! (my $frbase = $from) =~ s#.*/##;
! (my $tobase = $to) =~ s#.*/##;
! script_alias($installscript, $frbase, $tobase, $scr_ext);
}
}
***************
*** 453,459 ****
if (!$versiononly && $otherperls) {
my ($path, @path);
! my $dirsep = ($Is_OS2 || $Is_W32) ? ';' : ':' ;
($path = $ENV{"PATH"}) =~ s:\\:/:g ;
@path = split(/$dirsep/, $path);
if ($Is_VMS) {
--- 521,527 ----
if (!$versiononly && $otherperls) {
my ($path, @path);
! my $dirsep = ($Is_OS2 || $Is_W32 || $Is_NetWare) ? ';' : ':' ;
($path = $ENV{"PATH"}) =~ s:\\:/:g ;
@path = split(/$dirsep/, $path);
if ($Is_VMS) {
***************
*** 498,504 ****
my($prompt) = @_;
my($answer);
my($default) = $prompt =~ m/\[([yn])\]\s*$/i;
! warn $prompt;
chop($answer = <STDIN>);
$answer = $default if $answer =~ m/^\s*$/;
($answer =~ m/^[yY]/);
--- 566,572 ----
my($prompt) = @_;
my($answer);
my($default) = $prompt =~ m/\[([yn])\]\s*$/i;
! print STDERR $prompt;
chop($answer = <STDIN>);
$answer = $default if $answer =~ m/^\s*$/;
($answer =~ m/^[yY]/);
***************
*** 512,518 ****
foreach my $name (@names) {
next unless -e $name;
! chmod 0777, $name if ($Is_OS2 || $Is_W32 || $Is_Cygwin);
print " unlink $name\n" if $verbose;
( CORE::unlink($name) and ++$cnt
or warn "Couldn't unlink $name: $!\n" ) unless $nonono;
--- 580,586 ----
foreach my $name (@names) {
next unless -e $name;
! chmod 0777, $name if ($Is_OS2 || $Is_W32 || $Is_Cygwin || $Is_NetWare);
print " unlink $name\n" if $verbose;
( CORE::unlink($name) and ++$cnt
or warn "Couldn't unlink $name: $!\n" ) unless $nonono;
***************
*** 525,531 ****
my @names = @_;
foreach my $name (@names) {
next unless -e $name;
! chmod 0777, $name if ($Is_OS2 || $Is_W32);
print " unlink $name\n" if $verbose;
next if CORE::unlink($name);
warn "Couldn't unlink $name: $!\n";
--- 593,599 ----
my @names = @_;
foreach my $name (@names) {
next unless -e $name;
! chmod 0777, $name if ($Is_OS2 || $Is_W32 || $Is_NetWare);
print " unlink $name\n" if $verbose;
next if CORE::unlink($name);
warn "Couldn't unlink $name: $!\n";
***************
*** 603,609 ****
sub samepath {
my($p1, $p2) = @_;
! return (lc($p1) eq lc($p2)) if $Is_W32;
if ($p1 ne $p2) {
my($dev1, $ino1, $dev2, $ino2);
--- 671,677 ----
sub samepath {
my($p1, $p2) = @_;
! return (lc($p1) eq lc($p2)) if ($Is_W32 || $Is_NetWare);
if ($p1 ne $p2) {
my($dev1, $ino1, $dev2, $ino2);
***************
*** 630,637 ****
}
# ignore patch backups, RCS files, emacs backup & temp files and the
! # .exists files, and .PL files.
! return if $name =~ m{\.orig$|~$|^#.+#$|,v$|^\.exists|\.PL$};
$name = "$dir/$name" if $dir ne '';
--- 698,705 ----
}
# ignore patch backups, RCS files, emacs backup & temp files and the
! # .exists files, .PL files, and .t files.
! return if $name =~ m{\.orig$|~$|^#.+#$|,v$|^\.exists|\.PL$|\.t$};
$name = "$dir/$name" if $dir ne '';
***************
*** 638,644 ****
my $installlib = $installprivlib;
if ($dir =~ /^auto/ ||
($name =~ /^(.*)\.(?:pm|pod)$/ && $archpms{$1}) ||
! ($name =~ /^(.*)\.(?:h|lib)$/i && $Is_W32)
) {
$installlib = $installarchlib;
return unless $do_installarchlib;
--- 706,712 ----
my $installlib = $installprivlib;
if ($dir =~ /^auto/ ||
($name =~ /^(.*)\.(?:pm|pod)$/ && $archpms{$1}) ||
! ($name =~ /^(.*)\.(?:h|lib)$/i && ($Is_W32 || $Is_NetWare))
) {
$installlib = $installarchlib;
return unless $do_installarchlib;
***************
*** 661,669 ****
mkpath("$installlib/$dir", $verbose, 0777);
# HP-UX (at least) needs to maintain execute permissions
# on dynamically-loaded libraries.
! copy_if_diff($_, "$installlib/$name")
! and chmod($name =~ /\.(so|$dlext)$/o ? 0555 : 0444,
"$installlib/$name");
}
}
}
--- 729,749 ----
mkpath("$installlib/$dir", $verbose, 0777);
# HP-UX (at least) needs to maintain execute permissions
# on dynamically-loaded libraries.
! if ($Is_NetWare && !$nwinstall) {
! # Don't copy .nlp,.nlm files, doesn't make sense on Windows and also
! # if copied will give problems when building new extensions.
! # Has to be copied if we are installing on a NetWare server and hence
! # the check !$nwinstall
! if (!(/\.(?:nlp|nlm|bs)$/)) {
! copy_if_diff($_, "$installlib/$name")
! and chmod($name =~ /\.(so|$dlext)$/o ? 0555 : 0444,
"$installlib/$name");
+ }
+ } else {
+ copy_if_diff($_, "$installlib/$name")
+ and chmod($name =~ /\.(so|$dlext)$/o ? 0555 : 0444,
+ "$installlib/$name");
+ } #if ($Is_NetWare)
}
}
}
diff -c 'perl-5.7.1/intrpvar.h' 'perl-5.7.2/intrpvar.h'
Index: ./intrpvar.h
*** ./intrpvar.h Tue Mar 6 04:05:19 2001
--- ./intrpvar.h Fri Jul 13 16:20:54 2001
***************
*** 362,370 ****
/* Assume simple numerics */
PERLVARI(Inumeric_local, bool, TRUE)
/* Assume local numerics */
- PERLVAR(Inumeric_radix, SV *)
- /* The radix separator if not '.' */
#endif /* !USE_LOCALE_NUMERIC */
/* utf8 character classes */
--- 362,370 ----
/* Assume simple numerics */
PERLVARI(Inumeric_local, bool, TRUE)
/* Assume local numerics */
+ PERLVAR(Inumeric_compat1, char)
+ /* Used to be numeric_radix */
#endif /* !USE_LOCALE_NUMERIC */
/* utf8 character classes */
***************
*** 464,473 ****
--- 464,493 ----
PERLVAR(Ixpvbm_arenaroot,XPVBM*) /* list of allocated xpvbm areas */
PERLVAR(Ihe_arenaroot, XPV*) /* list of allocated he areas */
+ /* 5.6.0 stopped here */
+
PERLVAR(Ipsig_pend, int *) /* per-signal "count" of pending */
PERLVARI(Isig_pending, int,0) /* Number if highest signal pending */
+ #ifdef USE_LOCALE_NUMERIC
+ PERLVAR(Inumeric_radix_sv, SV *) /* The radix separator if not '.' */
+
+ #endif
+
+ #if defined(USE_ITHREADS)
+ PERLVAR(Iregex_pad, SV**) /* All regex objects */
+ PERLVAR(Iregex_padav, AV*) /* All regex objects */
+
+ #ifdef USE_REENTRANT_API
+ PERLVAR(Ireentrant_buffer, REBUF*) /* were we store _r buffers */
+ #endif
+
+ #endif
+
/* New variables must be added to the very end for binary compatibility.
* XSUB.h provides wrapper functions via perlapi.h that make this
* irrelevant, but not all code may be expected to #include XSUB.h. */
+
+
+
diff -c 'perl-5.7.1/iperlsys.h' 'perl-5.7.2/iperlsys.h'
Index: ./iperlsys.h
*** ./iperlsys.h Sat Mar 24 17:55:30 2001
--- ./iperlsys.h Mon Jul 9 17:10:22 2001
***************
*** 285,291 ****
#define PerlSIO_ferror(f) ferror(f)
#define PerlSIO_clearerr(f) clearerr(f)
#define PerlSIO_fgetc(f) fgetc(f)
! #if PerlSIO_has_base
#define PerlSIO_get_base(f) FILE_base(f)
#define PerlSIO_get_bufsiz(f) FILE_bufsiz(f)
#else
--- 285,291 ----
#define PerlSIO_ferror(f) ferror(f)
#define PerlSIO_clearerr(f) clearerr(f)
#define PerlSIO_fgetc(f) fgetc(f)
! #ifdef FILE_base
#define PerlSIO_get_base(f) FILE_base(f)
#define PerlSIO_get_bufsiz(f) FILE_bufsiz(f)
#else
***************
*** 303,309 ****
#define PerlSIO_fputs(f,s) fputs(s,f)
#define PerlSIO_fflush(f) Fflush(f)
#define PerlSIO_fgets(s, n, fp) fgets(s,n,fp)
! #define PerlSIO_ungetc(c,f) ungetc(c,f)
#define PerlSIO_fileno(f) fileno(f)
#define PerlSIO_fdopen(f, s) fdopen(f,s)
#define PerlSIO_freopen(p, m, f) freopen(p,m,f)
--- 303,319 ----
#define PerlSIO_fputs(f,s) fputs(s,f)
#define PerlSIO_fflush(f) Fflush(f)
#define PerlSIO_fgets(s, n, fp) fgets(s,n,fp)
! #if defined(VMS) && defined(__DECC)
! /* Unusual definition of ungetc() here to accomodate fast_sv_gets()'
! * belief that it can mix getc/ungetc with reads from stdio buffer */
! int decc$ungetc(int __c, FILE *__stream);
! # define PerlSIO_ungetc(c,f) ((c) == EOF ? EOF : \
! ((*(f) && !((*(f))->_flag & _IONBF) && \
! ((*(f))->_ptr > (*(f))->_base)) ? \
! ((*(f))->_cnt++, *(--(*(f))->_ptr) = (c)) : decc$ungetc(c,f)))
! #else
! # define PerlSIO_ungetc(c,f) ungetc(c,f)
! #endif
#define PerlSIO_fileno(f) fileno(f)
#define PerlSIO_fdopen(f, s) fdopen(f,s)
#define PerlSIO_freopen(p, m, f) freopen(p,m,f)
***************
*** 594,600 ****
--- 604,614 ----
typedef int (*LPLIORead)(struct IPerlLIO*, int, void*, unsigned int);
typedef int (*LPLIORename)(struct IPerlLIO*, const char*,
const char*);
+ #ifdef NETWARE
+ typedef int (*LPLIOSetmode)(struct IPerlLIO*, FILE*, int);
+ #else
typedef int (*LPLIOSetmode)(struct IPerlLIO*, int, int);
+ #endif /* NETWARE */
typedef int (*LPLIONameStat)(struct IPerlLIO*, const char*,
struct stat*);
typedef char* (*LPLIOTmpnam)(struct IPerlLIO*, char*);
diff -c 'perl-5.7.1/jpl/JNI/JNI.pm' 'perl-5.7.2/jpl/JNI/JNI.pm'
Index: ./jpl/JNI/JNI.pm
*** ./jpl/JNI/JNI.pm Sun Apr 8 23:54:44 2001
--- ./jpl/JNI/JNI.pm Mon Jul 9 17:10:23 2001
***************
*** 198,204 ****
($constname = $AUTOLOAD) =~ s/.*:://;
my $val = constant($constname, @_ ? $_[0] : 0);
if ($! != 0) {
! if ($! =~ /Invalid/ || $!{EINVAL}) {
$AutoLoader::AUTOLOAD = $AUTOLOAD;
goto &AutoLoader::AUTOLOAD;
}
--- 198,204 ----
($constname = $AUTOLOAD) =~ s/.*:://;
my $val = constant($constname, @_ ? $_[0] : 0);
if ($! != 0) {
! if ($! =~ /Invalid/) {
$AutoLoader::AUTOLOAD = $AUTOLOAD;
goto &AutoLoader::AUTOLOAD;
}
***************
*** 317,324 ****
use JNI;
=head1 DESCRIPTION
-
- This module provides an encapsulation in Perl of the Java Native Interface.
=head1 Exported constants
--- 317,322 ----
diff -c 'perl-5.7.1/jpl/JNI/JNI.xs' 'perl-5.7.2/jpl/JNI/JNI.xs'
Index: ./jpl/JNI/JNI.xs
*** ./jpl/JNI/JNI.xs Sun Apr 8 23:54:49 2001
--- ./jpl/JNI/JNI.xs Mon Jul 9 17:10:23 2001
***************
*** 1,3253 ****
! /*
! * Copyright 1997, O'Reilly & Associate, Inc.
! *
! * This package may be copied under the same terms as Perl itself.
! */
!
! #include "EXTERN.h"
! #include "perl.h"
! #include "XSUB.h"
!
! #include <stdio.h>
! #include <jni.h>
!
! #ifndef PERL_VERSION
! # include <patchlevel.h>
! # define PERL_REVISION 5
! # define PERL_VERSION PATCHLEVEL
! # define PERL_SUBVERSION SUBVERSION
! #endif
!
! #if PERL_REVISION == 5 && (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION <= 75))
! # define PL_na na
! # define PL_sv_no sv_no
! # define PL_sv_undef sv_undef
! # define PL_dowarn dowarn
! #endif
!
! #ifndef newSVpvn
! # define newSVpvn(a,b) newSVpv(a,b)
! #endif
!
! #ifndef pTHX
! # define pTHX void
! # define pTHX_
! # define aTHX
! # define aTHX_
! # define dTHX extern int JNI___notused
! #endif
!
! #ifndef WIN32
! # include <dlfcn.h>
! #endif
!
! #ifdef EMBEDDEDPERL
! extern JNIEnv* jplcurenv;
! extern int jpldebug;
! #else
! JNIEnv* jplcurenv;
! int jpldebug = 1;
! #endif
!
! #define SysRet jint
!
! #ifdef WIN32
! static void JNICALL call_my_exit(jint status)
! {
! my_exit(status);
! }
! #else
! static void call_my_exit(jint status)
! {
! my_exit(status);
! }
! #endif
!
! jvalue*
! makeargs(char *sig, SV** svp, int items)
! {
! jvalue* jv = (jvalue*)safemalloc(sizeof(jvalue) * items);
! int ix = 0;
! char *s = sig;
! JNIEnv* env = jplcurenv;
! char *start;
! STRLEN n_a;
!
! if (jpldebug)
! fprintf(stderr, "sig = %s, items = %d\n", sig, items);
! if (*s++ != '(')
! goto cleanup;
!
! while (items--) {
! SV *sv = *svp++;
! start = s;
! switch (*s++) {
! case 'Z':
! jv[ix++].z = (jboolean)(SvIV(sv) != 0);
! break;
! case 'B':
! jv[ix++].b = (jbyte)SvIV(sv);
! break;
! case 'C':
! jv[ix++].c = (jchar)SvIV(sv);
! break;
! case 'S':
! jv[ix++].s = (jshort)SvIV(sv);
! break;
! case 'I':
! jv[ix++].i = (jint)SvIV(sv);
! break;
! case 'J':
! jv[ix++].j = (jlong)SvNV(sv);
! break;
! case 'F':
! jv[ix++].f = (jfloat)SvNV(sv);
! break;
! case 'D':
! jv[ix++].d = (jdouble)SvNV(sv);
! break;
! case '[':
! switch (*s++) {
! case 'Z':
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! jboolean* buf = (jboolean*)malloc(len * sizeof(jboolean));
! int i;
! SV** esv;
!
! jbooleanArray ja = (*env)->NewBooleanArray(env, len);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++)
! buf[i] = (jboolean)SvIV(*esv);
! (*env)->SetBooleanArrayRegion(env, ja, 0, len, buf);
! free((void*)buf);
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else if (SvPOK(sv)) {
! jsize len = sv_len(sv) / sizeof(jboolean);
!
! jbooleanArray ja = (*env)->NewBooleanArray(env, len);
! (*env)->SetBooleanArrayRegion(env, ja, 0, len, (jboolean*)SvPV(sv,n_a));
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! case 'B':
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! jbyte* buf = (jbyte*)malloc(len * sizeof(jbyte));
! int i;
! SV** esv;
!
! jbyteArray ja = (*env)->NewByteArray(env, len);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++)
! buf[i] = (jbyte)SvIV(*esv);
! (*env)->SetByteArrayRegion(env, ja, 0, len, buf);
! free((void*)buf);
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else if (SvPOK(sv)) {
! jsize len = sv_len(sv) / sizeof(jbyte);
!
! jbyteArray ja = (*env)->NewByteArray(env, len);
! (*env)->SetByteArrayRegion(env, ja, 0, len, (jbyte*)SvPV(sv,n_a));
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! case 'C':
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! jchar* buf = (jchar*)malloc(len * sizeof(jchar));
! int i;
! SV** esv;
!
! jcharArray ja = (*env)->NewCharArray(env, len);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++)
! buf[i] = (jchar)SvIV(*esv);
! (*env)->SetCharArrayRegion(env, ja, 0, len, buf);
! free((void*)buf);
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else if (SvPOK(sv)) {
! jsize len = sv_len(sv) / sizeof(jchar);
!
! jcharArray ja = (*env)->NewCharArray(env, len);
! (*env)->SetCharArrayRegion(env, ja, 0, len, (jchar*)SvPV(sv,n_a));
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! case 'S':
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! jshort* buf = (jshort*)malloc(len * sizeof(jshort));
! int i;
! SV** esv;
!
! jshortArray ja = (*env)->NewShortArray(env, len);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++)
! buf[i] = (jshort)SvIV(*esv);
! (*env)->SetShortArrayRegion(env, ja, 0, len, buf);
! free((void*)buf);
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else if (SvPOK(sv)) {
! jsize len = sv_len(sv) / sizeof(jshort);
!
! jshortArray ja = (*env)->NewShortArray(env, len);
! (*env)->SetShortArrayRegion(env, ja, 0, len, (jshort*)SvPV(sv,n_a));
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! case 'I':
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! jint* buf = (jint*)malloc(len * sizeof(jint));
! int i;
! SV** esv;
!
! jintArray ja = (*env)->NewIntArray(env, len);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++)
! buf[i] = (jint)SvIV(*esv);
! (*env)->SetIntArrayRegion(env, ja, 0, len, buf);
! free((void*)buf);
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else if (SvPOK(sv)) {
! jsize len = sv_len(sv) / sizeof(jint);
!
! jintArray ja = (*env)->NewIntArray(env, len);
! (*env)->SetIntArrayRegion(env, ja, 0, len, (jint*)SvPV(sv,n_a));
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! case 'J':
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! jlong* buf = (jlong*)malloc(len * sizeof(jlong));
! int i;
! SV** esv;
!
! jlongArray ja = (*env)->NewLongArray(env, len);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++)
! buf[i] = (jlong)SvNV(*esv);
! (*env)->SetLongArrayRegion(env, ja, 0, len, buf);
! free((void*)buf);
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else if (SvPOK(sv)) {
! jsize len = sv_len(sv) / sizeof(jlong);
!
! jlongArray ja = (*env)->NewLongArray(env, len);
! (*env)->SetLongArrayRegion(env, ja, 0, len, (jlong*)SvPV(sv,n_a));
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! case 'F':
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! jfloat* buf = (jfloat*)malloc(len * sizeof(jfloat));
! int i;
! SV** esv;
!
! jfloatArray ja = (*env)->NewFloatArray(env, len);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++)
! buf[i] = (jfloat)SvNV(*esv);
! (*env)->SetFloatArrayRegion(env, ja, 0, len, buf);
! free((void*)buf);
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else if (SvPOK(sv)) {
! jsize len = sv_len(sv) / sizeof(jfloat);
!
! jfloatArray ja = (*env)->NewFloatArray(env, len);
! (*env)->SetFloatArrayRegion(env, ja, 0, len, (jfloat*)SvPV(sv,n_a));
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! case 'D':
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! jdouble* buf = (jdouble*)malloc(len * sizeof(jdouble));
! int i;
! SV** esv;
!
! jdoubleArray ja = (*env)->NewDoubleArray(env, len);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++)
! buf[i] = (jdouble)SvNV(*esv);
! (*env)->SetDoubleArrayRegion(env, ja, 0, len, buf);
! free((void*)buf);
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else if (SvPOK(sv)) {
! jsize len = sv_len(sv) / sizeof(jdouble);
!
! jdoubleArray ja = (*env)->NewDoubleArray(env, len);
! (*env)->SetDoubleArrayRegion(env, ja, 0, len, (jdouble*)SvPV(sv,n_a));
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! case 'L':
! while (*s != ';') s++;
! s++;
! if (strnEQ(start, "[Ljava/lang/String;", 19)) {
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! int i;
! SV** esv;
! static jclass jcl = 0;
! jobjectArray ja;
!
! if (!jcl)
! jcl = (*env)->FindClass(env, "java/lang/String");
! ja = (*env)->NewObjectArray(env, len, jcl, 0);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) {
! jobject str = (jobject)(*env)->NewStringUTF(env, SvPV(*esv,n_a));
! (*env)->SetObjectArrayElement(env, ja, i, str);
! }
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! }
! /* FALL THROUGH */
! default:
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! int i;
! SV** esv;
! static jclass jcl = 0;
! jobjectArray ja;
!
! if (!jcl)
! jcl = (*env)->FindClass(env, "java/lang/Object");
! ja = (*env)->NewObjectArray(env, len, jcl, 0);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) {
! if (SvROK(*esv) && (rv = SvRV(*esv)) && SvOBJECT(rv)) {
! (*env)->SetObjectArrayElement(env, ja, i, (jobject)(void*)SvIV(rv));
! }
! else {
! jobject str = (jobject)(*env)->NewStringUTF(env, SvPV(*esv,n_a));
! (*env)->SetObjectArrayElement(env, ja, i, str);
! }
! }
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! }
! break;
! case 'L':
! if (!SvROK(sv) || strnEQ(s, "java/lang/String;", 17)) {
! s += 17;
! jv[ix++].l = (jobject)(*env)->NewStringUTF(env, (char*) SvPV(sv,n_a));
! break;
! }
! while (*s != ';') s++;
! s++;
! if (SvROK(sv)) {
! SV* rv = SvRV(sv);
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! }
! break;
! case ')':
! croak("too many arguments, signature: %s", sig);
! goto cleanup;
! default:
! croak("panic: malformed signature: %s", s-1);
! goto cleanup;
! }
!
! }
! if (*s != ')') {
! croak("not enough arguments, signature: %s", sig);
! goto cleanup;
! }
! return jv;
!
! cleanup:
! safefree((char*)jv);
! return 0;
! }
!
! static int
! not_here(char *s)
! {
! croak("%s not implemented on this architecture", s);
! return -1;
! }
!
! static double
! constant(char *name, int arg)
! {
! errno = 0;
! switch (*name) {
! case 'A':
! break;
! case 'B':
! break;
! case 'C':
! break;
! case 'D':
! break;
! case 'E':
! break;
! case 'F':
! break;
! case 'G':
! break;
! case 'H':
! break;
! case 'I':
! break;
! case 'J':
! if (strEQ(name, "JNI_ABORT"))
! #ifdef JNI_ABORT
! return JNI_ABORT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "JNI_COMMIT"))
! #ifdef JNI_COMMIT
! return JNI_COMMIT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "JNI_ERR"))
! #ifdef JNI_ERR
! return JNI_ERR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "JNI_FALSE"))
! #ifdef JNI_FALSE
! return JNI_FALSE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "JNI_H"))
! #ifdef JNI_H
! #ifdef WIN32
! return 1;
! #else
! return JNI_H;
! #endif
! #else
! goto not_there;
! #endif
! if (strEQ(name, "JNI_OK"))
! #ifdef JNI_OK
! return JNI_OK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "JNI_TRUE"))
! #ifdef JNI_TRUE
! return JNI_TRUE;
! #else
! goto not_there;
! #endif
! break;
! case 'K':
! break;
! case 'L':
! break;
! case 'M':
! break;
! case 'N':
! break;
! case 'O':
! break;
! case 'P':
! break;
! case 'Q':
! break;
! case 'R':
! break;
! case 'S':
! break;
! case 'T':
! break;
! case 'U':
! break;
! case 'V':
! break;
! case 'W':
! break;
! case 'X':
! break;
! case 'Y':
! break;
! case 'Z':
! break;
! }
! errno = EINVAL;
! return 0;
!
! not_there:
! errno = ENOENT;
! return 0;
! }
!
! #define FETCHENV jplcurenv
! #define RESTOREENV jplcurenv = env
!
! MODULE = JNI PACKAGE = JNI
!
! PROTOTYPES: ENABLE
!
! double
! constant(name,arg)
! char * name
! int arg
!
! jint
! GetVersion()
! JNIEnv * env = FETCHENV;
! CODE:
! {
! RETVAL = (*env)->GetVersion(env);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jclass
! DefineClass(name, loader, buf)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jsize buf_len_ = NO_INIT;
! const char * name
! jobject loader
! const jbyte * buf
! CODE:
! {
! #ifdef KAFFE
! RETVAL = (*env)->DefineClass(env, loader, buf, (jsize)buf_len_);
! #else
! RETVAL = (*env)->DefineClass(env, name, loader, buf, (jsize)buf_len_);
! #endif
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jclass
! FindClass(name)
! JNIEnv * env = FETCHENV;
! const char * name
! CODE:
! {
! RETVAL = (*env)->FindClass(env, name);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jclass
! GetSuperclass(sub)
! JNIEnv * env = FETCHENV;
! jclass sub
! CODE:
! {
! RETVAL = (*env)->GetSuperclass(env, sub);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! IsAssignableFrom(sub, sup)
! JNIEnv * env = FETCHENV;
! jclass sub
! jclass sup
! CODE:
! {
! RETVAL = (*env)->IsAssignableFrom(env, sub, sup);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! SysRet
! Throw(obj)
! JNIEnv * env = FETCHENV;
! jthrowable obj
! CODE:
! {
! RETVAL = (*env)->Throw(env, obj);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! SysRet
! ThrowNew(clazz, msg)
! JNIEnv * env = FETCHENV;
! jclass clazz
! const char * msg
! CODE:
! {
! RETVAL = (*env)->ThrowNew(env, clazz, msg);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jthrowable
! ExceptionOccurred()
! JNIEnv * env = FETCHENV;
! CODE:
! {
! RETVAL = (*env)->ExceptionOccurred(env);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! void
! ExceptionDescribe()
! JNIEnv * env = FETCHENV;
! CODE:
! {
! (*env)->ExceptionDescribe(env);
! RESTOREENV;
! }
!
! void
! ExceptionClear()
! JNIEnv * env = FETCHENV;
! CODE:
! {
! (*env)->ExceptionClear(env);
! RESTOREENV;
! }
!
! void
! FatalError(msg)
! JNIEnv * env = FETCHENV;
! const char * msg
! CODE:
! {
! (*env)->FatalError(env, msg);
! RESTOREENV;
! }
!
! jobject
! NewGlobalRef(lobj)
! JNIEnv * env = FETCHENV;
! jobject lobj
! CODE:
! {
! RETVAL = (*env)->NewGlobalRef(env, lobj);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! void
! DeleteGlobalRef(gref)
! JNIEnv * env = FETCHENV;
! jobject gref
! CODE:
! {
! (*env)->DeleteGlobalRef(env, gref);
! RESTOREENV;
! }
!
! void
! DeleteLocalRef(obj)
! JNIEnv * env = FETCHENV;
! jobject obj
! CODE:
! {
! (*env)->DeleteLocalRef(env, obj);
! RESTOREENV;
! }
!
! jboolean
! IsSameObject(obj1,obj2)
! JNIEnv * env = FETCHENV;
! jobject obj1
! jobject obj2
! CODE:
! {
! RETVAL = (*env)->IsSameObject(env, obj1,obj2);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! AllocObject(clazz)
! JNIEnv * env = FETCHENV;
! jclass clazz
! CODE:
! {
! RETVAL = (*env)->AllocObject(env, clazz);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! NewObject(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->NewObjectA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! NewObjectA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->NewObjectA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jclass
! GetObjectClass(obj)
! JNIEnv * env = FETCHENV;
! jobject obj
! CODE:
! {
! RETVAL = (*env)->GetObjectClass(env, obj);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! IsInstanceOf(obj,clazz)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! CODE:
! {
! RETVAL = (*env)->IsInstanceOf(env, obj,clazz);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jmethodID
! GetMethodID(clazz,name,sig)
! JNIEnv * env = FETCHENV;
! jclass clazz
! const char * name
! const char * sig
! CODE:
! {
! RETVAL = (*env)->GetMethodID(env, clazz,name,sig);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! CallObjectMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallObjectMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! CallObjectMethodA(obj,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallObjectMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! CallBooleanMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallBooleanMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! CallBooleanMethodA(obj,methodID, args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallBooleanMethodA(env, obj,methodID, args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jbyte
! CallByteMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallByteMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jbyte
! CallByteMethodA(obj,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallByteMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jchar
! CallCharMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallCharMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jchar
! CallCharMethodA(obj,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallCharMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jshort
! CallShortMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallShortMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jshort
! CallShortMethodA(obj,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallShortMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jint
! CallIntMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallIntMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jint
! CallIntMethodA(obj,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallIntMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jlong
! CallLongMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallLongMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jlong
! CallLongMethodA(obj,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallLongMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jfloat
! CallFloatMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallFloatMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jfloat
! CallFloatMethodA(obj,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallFloatMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jdouble
! CallDoubleMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallDoubleMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jdouble
! CallDoubleMethodA(obj,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallDoubleMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! void
! CallVoidMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! (*env)->CallVoidMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
!
! void
! CallVoidMethodA(obj,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! (*env)->CallVoidMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
!
! jobject
! CallNonvirtualObjectMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallNonvirtualObjectMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! CallNonvirtualObjectMethodA(obj,clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallNonvirtualObjectMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! CallNonvirtualBooleanMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallNonvirtualBooleanMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! CallNonvirtualBooleanMethodA(obj,clazz,methodID, args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallNonvirtualBooleanMethodA(env, obj,clazz,methodID, args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jbyte
! CallNonvirtualByteMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallNonvirtualByteMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jbyte
! CallNonvirtualByteMethodA(obj,clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallNonvirtualByteMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jchar
! CallNonvirtualCharMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallNonvirtualCharMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jchar
! CallNonvirtualCharMethodA(obj,clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallNonvirtualCharMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jshort
! CallNonvirtualShortMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallNonvirtualShortMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jshort
! CallNonvirtualShortMethodA(obj,clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallNonvirtualShortMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jint
! CallNonvirtualIntMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallNonvirtualIntMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jint
! CallNonvirtualIntMethodA(obj,clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallNonvirtualIntMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jlong
! CallNonvirtualLongMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallNonvirtualLongMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jlong
! CallNonvirtualLongMethodA(obj,clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallNonvirtualLongMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jfloat
! CallNonvirtualFloatMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallNonvirtualFloatMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jfloat
! CallNonvirtualFloatMethodA(obj,clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallNonvirtualFloatMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jdouble
! CallNonvirtualDoubleMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallNonvirtualDoubleMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jdouble
! CallNonvirtualDoubleMethodA(obj,clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallNonvirtualDoubleMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! void
! CallNonvirtualVoidMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! (*env)->CallNonvirtualVoidMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
!
! void
! CallNonvirtualVoidMethodA(obj,clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! (*env)->CallNonvirtualVoidMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
!
! jfieldID
! GetFieldID(clazz,name,sig)
! JNIEnv * env = FETCHENV;
! jclass clazz
! const char * name
! const char * sig
! CODE:
! {
! RETVAL = (*env)->GetFieldID(env, clazz,name,sig);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! GetObjectField(obj,fieldID)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetObjectField(env, obj,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! GetBooleanField(obj,fieldID)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetBooleanField(env, obj,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jbyte
! GetByteField(obj,fieldID)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetByteField(env, obj,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jchar
! GetCharField(obj,fieldID)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetCharField(env, obj,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jshort
! GetShortField(obj,fieldID)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetShortField(env, obj,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jint
! GetIntField(obj,fieldID)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetIntField(env, obj,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jlong
! GetLongField(obj,fieldID)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetLongField(env, obj,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jfloat
! GetFloatField(obj,fieldID)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetFloatField(env, obj,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jdouble
! GetDoubleField(obj,fieldID)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetDoubleField(env, obj,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! void
! SetObjectField(obj,fieldID,val)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! jobject val
! CODE:
! {
! (*env)->SetObjectField(env, obj,fieldID,val);
! RESTOREENV;
! }
!
! void
! SetBooleanField(obj,fieldID,val)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! jboolean val
! CODE:
! {
! (*env)->SetBooleanField(env, obj,fieldID,val);
! RESTOREENV;
! }
!
! void
! SetByteField(obj,fieldID,val)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! jbyte val
! CODE:
! {
! (*env)->SetByteField(env, obj,fieldID,val);
! RESTOREENV;
! }
!
! void
! SetCharField(obj,fieldID,val)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! jchar val
! CODE:
! {
! (*env)->SetCharField(env, obj,fieldID,val);
! RESTOREENV;
! }
!
! void
! SetShortField(obj,fieldID,val)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! jshort val
! CODE:
! {
! (*env)->SetShortField(env, obj,fieldID,val);
! RESTOREENV;
! }
!
! void
! SetIntField(obj,fieldID,val)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! jint val
! CODE:
! {
! (*env)->SetIntField(env, obj,fieldID,val);
! RESTOREENV;
! }
!
! void
! SetLongField(obj,fieldID,val)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! jlong val
! CODE:
! {
! (*env)->SetLongField(env, obj,fieldID,val);
! RESTOREENV;
! }
!
! void
! SetFloatField(obj,fieldID,val)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! jfloat val
! CODE:
! {
! (*env)->SetFloatField(env, obj,fieldID,val);
! RESTOREENV;
! }
!
! void
! SetDoubleField(obj,fieldID,val)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! jdouble val
! CODE:
! {
! (*env)->SetDoubleField(env, obj,fieldID,val);
! RESTOREENV;
! }
!
! jmethodID
! GetStaticMethodID(clazz,name,sig)
! JNIEnv * env = FETCHENV;
! jclass clazz
! const char * name
! const char * sig
! CODE:
! {
! RETVAL = (*env)->GetStaticMethodID(env, clazz,name,sig);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! CallStaticObjectMethod(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallStaticObjectMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! CallStaticObjectMethodA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallStaticObjectMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! CallStaticBooleanMethod(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallStaticBooleanMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! CallStaticBooleanMethodA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallStaticBooleanMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jbyte
! CallStaticByteMethod(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallStaticByteMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jbyte
! CallStaticByteMethodA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallStaticByteMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jchar
! CallStaticCharMethod(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallStaticCharMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jchar
! CallStaticCharMethodA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallStaticCharMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jshort
! CallStaticShortMethod(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallStaticShortMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jshort
! CallStaticShortMethodA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallStaticShortMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jint
! CallStaticIntMethod(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallStaticIntMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jint
! CallStaticIntMethodA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallStaticIntMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jlong
! CallStaticLongMethod(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallStaticLongMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jlong
! CallStaticLongMethodA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallStaticLongMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jfloat
! CallStaticFloatMethod(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallStaticFloatMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jfloat
! CallStaticFloatMethodA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallStaticFloatMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jdouble
! CallStaticDoubleMethod(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallStaticDoubleMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jdouble
! CallStaticDoubleMethodA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallStaticDoubleMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! void
! CallStaticVoidMethod(cls,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass cls
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! (*env)->CallStaticVoidMethodA(env, cls,methodID,args);
! RESTOREENV;
! }
!
! void
! CallStaticVoidMethodA(cls,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass cls
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! (*env)->CallStaticVoidMethodA(env, cls,methodID,args);
! RESTOREENV;
! }
!
! jfieldID
! GetStaticFieldID(clazz,name,sig)
! JNIEnv * env = FETCHENV;
! jclass clazz
! const char * name
! const char * sig
! CODE:
! {
! RETVAL = (*env)->GetStaticFieldID(env, clazz,name,sig);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! GetStaticObjectField(clazz,fieldID)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetStaticObjectField(env, clazz,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! GetStaticBooleanField(clazz,fieldID)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetStaticBooleanField(env, clazz,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jbyte
! GetStaticByteField(clazz,fieldID)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetStaticByteField(env, clazz,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jchar
! GetStaticCharField(clazz,fieldID)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetStaticCharField(env, clazz,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jshort
! GetStaticShortField(clazz,fieldID)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetStaticShortField(env, clazz,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jint
! GetStaticIntField(clazz,fieldID)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetStaticIntField(env, clazz,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jlong
! GetStaticLongField(clazz,fieldID)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetStaticLongField(env, clazz,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jfloat
! GetStaticFloatField(clazz,fieldID)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetStaticFloatField(env, clazz,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jdouble
! GetStaticDoubleField(clazz,fieldID)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetStaticDoubleField(env, clazz,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! void
! SetStaticObjectField(clazz,fieldID,value)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! jobject value
! CODE:
! {
! (*env)->SetStaticObjectField(env, clazz,fieldID,value);
! RESTOREENV;
! }
!
! void
! SetStaticBooleanField(clazz,fieldID,value)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! jboolean value
! CODE:
! {
! (*env)->SetStaticBooleanField(env, clazz,fieldID,value);
! RESTOREENV;
! }
!
! void
! SetStaticByteField(clazz,fieldID,value)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! jbyte value
! CODE:
! {
! (*env)->SetStaticByteField(env, clazz,fieldID,value);
! RESTOREENV;
! }
!
! void
! SetStaticCharField(clazz,fieldID,value)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! jchar value
! CODE:
! {
! (*env)->SetStaticCharField(env, clazz,fieldID,value);
! RESTOREENV;
! }
!
! void
! SetStaticShortField(clazz,fieldID,value)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! jshort value
! CODE:
! {
! (*env)->SetStaticShortField(env, clazz,fieldID,value);
! RESTOREENV;
! }
!
! void
! SetStaticIntField(clazz,fieldID,value)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! jint value
! CODE:
! {
! (*env)->SetStaticIntField(env, clazz,fieldID,value);
! RESTOREENV;
! }
!
! void
! SetStaticLongField(clazz,fieldID,value)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! jlong value
! CODE:
! {
! (*env)->SetStaticLongField(env, clazz,fieldID,value);
! RESTOREENV;
! }
!
! void
! SetStaticFloatField(clazz,fieldID,value)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! jfloat value
! CODE:
! {
! (*env)->SetStaticFloatField(env, clazz,fieldID,value);
! RESTOREENV;
! }
!
! void
! SetStaticDoubleField(clazz,fieldID,value)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! jdouble value
! CODE:
! {
! (*env)->SetStaticDoubleField(env, clazz,fieldID,value);
! RESTOREENV;
! }
!
! jstring
! NewString(unicode)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jsize unicode_len_ = NO_INIT;
! const jchar * unicode
! CODE:
! {
! RETVAL = (*env)->NewString(env, unicode, unicode_len_);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jsize
! GetStringLength(str)
! JNIEnv * env = FETCHENV;
! jstring str
! CODE:
! {
! RETVAL = (*env)->GetStringLength(env, str);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! const jchar *
! GetStringChars(str)
! JNIEnv * env = FETCHENV;
! jstring str
! jboolean isCopy = NO_INIT;
! jsize RETVAL_len_ = NO_INIT;
! CODE:
! {
! RETVAL = (*env)->GetStringChars(env, str,&isCopy);
! RETVAL_len_ = (*env)->GetStringLength(env, str);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
! CLEANUP:
! (*env)->ReleaseStringChars(env, str,RETVAL);
!
! jstring
! NewStringUTF(utf)
! JNIEnv * env = FETCHENV;
! const char * utf
! CODE:
! {
! RETVAL = (*env)->NewStringUTF(env, utf);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jsize
! GetStringUTFLength(str)
! JNIEnv * env = FETCHENV;
! jstring str
! CODE:
! {
! RETVAL = (*env)->GetStringUTFLength(env, str);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! const char *
! GetStringUTFChars(str)
! JNIEnv * env = FETCHENV;
! jstring str
! jboolean isCopy = NO_INIT;
! CODE:
! {
! RETVAL = (*env)->GetStringUTFChars(env, str,&isCopy);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
! CLEANUP:
! (*env)->ReleaseStringUTFChars(env, str, RETVAL);
!
!
! jsize
! GetArrayLength(array)
! JNIEnv * env = FETCHENV;
! jarray array
! CODE:
! {
! RETVAL = (*env)->GetArrayLength(env, array);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobjectArray
! NewObjectArray(len,clazz,init)
! JNIEnv * env = FETCHENV;
! jsize len
! jclass clazz
! jobject init
! CODE:
! {
! RETVAL = (*env)->NewObjectArray(env, len,clazz,init);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! GetObjectArrayElement(array,index)
! JNIEnv * env = FETCHENV;
! jobjectArray array
! jsize index
! CODE:
! {
! RETVAL = (*env)->GetObjectArrayElement(env, array,index);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! void
! SetObjectArrayElement(array,index,val)
! JNIEnv * env = FETCHENV;
! jobjectArray array
! jsize index
! jobject val
! CODE:
! {
! (*env)->SetObjectArrayElement(env, array,index,val);
! RESTOREENV;
! }
!
! jbooleanArray
! NewBooleanArray(len)
! JNIEnv * env = FETCHENV;
! jsize len
! CODE:
! {
! RETVAL = (*env)->NewBooleanArray(env, len);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jbyteArray
! NewByteArray(len)
! JNIEnv * env = FETCHENV;
! jsize len
! CODE:
! {
! RETVAL = (*env)->NewByteArray(env, len);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jcharArray
! NewCharArray(len)
! JNIEnv * env = FETCHENV;
! jsize len
! CODE:
! {
! RETVAL = (*env)->NewCharArray(env, len);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jshortArray
! NewShortArray(len)
! JNIEnv * env = FETCHENV;
! jsize len
! CODE:
! {
! RETVAL = (*env)->NewShortArray(env, len);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jintArray
! NewIntArray(len)
! JNIEnv * env = FETCHENV;
! jsize len
! CODE:
! {
! RETVAL = (*env)->NewIntArray(env, len);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jlongArray
! NewLongArray(len)
! JNIEnv * env = FETCHENV;
! jsize len
! CODE:
! {
! RETVAL = (*env)->NewLongArray(env, len);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jfloatArray
! NewFloatArray(len)
! JNIEnv * env = FETCHENV;
! jsize len
! CODE:
! {
! RETVAL = (*env)->NewFloatArray(env, len);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jdoubleArray
! NewDoubleArray(len)
! JNIEnv * env = FETCHENV;
! jsize len
! CODE:
! {
! RETVAL = (*env)->NewDoubleArray(env, len);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean *
! GetBooleanArrayElements(array)
! JNIEnv * env = FETCHENV;
! jsize RETVAL_len_ = NO_INIT;
! jbooleanArray array
! jboolean isCopy = NO_INIT;
! PPCODE:
! {
! RETVAL = (*env)->GetBooleanArrayElements(env, array,&isCopy);
! RETVAL_len_ = (*env)->GetArrayLength(env, array);
! if (GIMME == G_ARRAY) {
! int i;
! jboolean* r = RETVAL;
! EXTEND(sp, RETVAL_len_);
! for (i = RETVAL_len_; i; --i) {
! PUSHs(sv_2mortal(newSViv(*r++)));
! }
! }
! else {
! if (RETVAL_len_) {
! PUSHs(sv_2mortal(newSVpvn((char*)RETVAL,
! (STRLEN)RETVAL_len_ * sizeof(jboolean))));
! }
! else
! PUSHs(&PL_sv_no);
! }
! (*env)->ReleaseBooleanArrayElements(env, array,RETVAL,JNI_ABORT);
! RESTOREENV;
! }
!
! jbyte *
! GetByteArrayElements(array)
! JNIEnv * env = FETCHENV;
! jsize RETVAL_len_ = NO_INIT;
! jbyteArray array
! jboolean isCopy = NO_INIT;
! PPCODE:
! {
! RETVAL = (*env)->GetByteArrayElements(env, array,&isCopy);
! RETVAL_len_ = (*env)->GetArrayLength(env, array);
! if (GIMME == G_ARRAY) {
! int i;
! jbyte* r = RETVAL;
! EXTEND(sp, RETVAL_len_);
! for (i = RETVAL_len_; i; --i) {
! PUSHs(sv_2mortal(newSViv(*r++)));
! }
! }
! else {
! if (RETVAL_len_) {
! PUSHs(sv_2mortal(newSVpvn((char*)RETVAL,
! (STRLEN)RETVAL_len_ * sizeof(jbyte))));
! }
! else
! PUSHs(&PL_sv_no);
! }
! (*env)->ReleaseByteArrayElements(env, array,RETVAL,JNI_ABORT);
! RESTOREENV;
! }
!
! jchar *
! GetCharArrayElements(array)
! JNIEnv * env = FETCHENV;
! jsize RETVAL_len_ = NO_INIT;
! jcharArray array
! jboolean isCopy = NO_INIT;
! PPCODE:
! {
! RETVAL = (*env)->GetCharArrayElements(env, array,&isCopy);
! RETVAL_len_ = (*env)->GetArrayLength(env, array);
! if (GIMME == G_ARRAY) {
! int i;
! jchar* r = RETVAL;
! EXTEND(sp, RETVAL_len_);
! for (i = RETVAL_len_; i; --i) {
! PUSHs(sv_2mortal(newSViv(*r++)));
! }
! }
! else {
! if (RETVAL_len_) {
! PUSHs(sv_2mortal(newSVpvn((char*)RETVAL,
! (STRLEN)RETVAL_len_ * sizeof(jchar))));
! }
! else
! PUSHs(&PL_sv_no);
! }
! (*env)->ReleaseCharArrayElements(env, array,RETVAL,JNI_ABORT);
! RESTOREENV;
! }
!
! jshort *
! GetShortArrayElements(array)
! JNIEnv * env = FETCHENV;
! jsize RETVAL_len_ = NO_INIT;
! jshortArray array
! jboolean isCopy = NO_INIT;
! PPCODE:
! {
! RETVAL = (*env)->GetShortArrayElements(env, array,&isCopy);
! RETVAL_len_ = (*env)->GetArrayLength(env, array);
! if (GIMME == G_ARRAY) {
! int i;
! jshort* r = RETVAL;
! EXTEND(sp, RETVAL_len_);
! for (i = RETVAL_len_; i; --i) {
! PUSHs(sv_2mortal(newSViv(*r++)));
! }
! }
! else {
! if (RETVAL_len_) {
! PUSHs(sv_2mortal(newSVpvn((char*)RETVAL,
! (STRLEN)RETVAL_len_ * sizeof(jshort))));
! }
! else
! PUSHs(&PL_sv_no);
! }
! (*env)->ReleaseShortArrayElements(env, array,RETVAL,JNI_ABORT);
! RESTOREENV;
! }
!
! jint *
! GetIntArrayElements(array)
! JNIEnv * env = FETCHENV;
! jsize RETVAL_len_ = NO_INIT;
! jintArray array
! jboolean isCopy = NO_INIT;
! PPCODE:
! {
! RETVAL = (*env)->GetIntArrayElements(env, array,&isCopy);
! RETVAL_len_ = (*env)->GetArrayLength(env, array);
! if (GIMME == G_ARRAY) {
! int i;
! jint* r = RETVAL;
! EXTEND(sp, RETVAL_len_);
! for (i = RETVAL_len_; i; --i) {
! PUSHs(sv_2mortal(newSViv(*r++)));
! }
! }
! else {
! if (RETVAL_len_) {
! PUSHs(sv_2mortal(newSVpvn((char*)RETVAL,
! (STRLEN)RETVAL_len_ * sizeof(jint))));
! }
! else
! PUSHs(&PL_sv_no);
! }
! (*env)->ReleaseIntArrayElements(env, array,RETVAL,JNI_ABORT);
! RESTOREENV;
! }
!
! jlong *
! GetLongArrayElements(array)
! JNIEnv * env = FETCHENV;
! jsize RETVAL_len_ = NO_INIT;
! jlongArray array
! jboolean isCopy = NO_INIT;
! PPCODE:
! {
! RETVAL = (*env)->GetLongArrayElements(env, array,&isCopy);
! RETVAL_len_ = (*env)->GetArrayLength(env, array);
! if (GIMME == G_ARRAY) {
! int i;
! jlong* r = RETVAL;
! EXTEND(sp, RETVAL_len_);
! for (i = RETVAL_len_; i; --i) {
! PUSHs(sv_2mortal(newSViv(*r++)));
! }
! }
! else {
! if (RETVAL_len_) {
! PUSHs(sv_2mortal(newSVpvn((char*)RETVAL,
! (STRLEN)RETVAL_len_ * sizeof(jlong))));
! }
! else
! PUSHs(&PL_sv_no);
! }
! (*env)->ReleaseLongArrayElements(env, array,RETVAL,JNI_ABORT);
! RESTOREENV;
! }
!
! jfloat *
! GetFloatArrayElements(array)
! JNIEnv * env = FETCHENV;
! jsize RETVAL_len_ = NO_INIT;
! jfloatArray array
! jboolean isCopy = NO_INIT;
! PPCODE:
! {
! RETVAL = (*env)->GetFloatArrayElements(env, array,&isCopy);
! RETVAL_len_ = (*env)->GetArrayLength(env, array);
! if (GIMME == G_ARRAY) {
! int i;
! jfloat* r = RETVAL;
! EXTEND(sp, RETVAL_len_);
! for (i = RETVAL_len_; i; --i) {
! PUSHs(sv_2mortal(newSVnv(*r++)));
! }
! }
! else {
! if (RETVAL_len_) {
! PUSHs(sv_2mortal(newSVpvn((char*)RETVAL,
! (STRLEN)RETVAL_len_ * sizeof(jfloat))));
! }
! else
! PUSHs(&PL_sv_no);
! }
! (*env)->ReleaseFloatArrayElements(env, array,RETVAL,JNI_ABORT);
! RESTOREENV;
! }
!
! jdouble *
! GetDoubleArrayElements(array)
! JNIEnv * env = FETCHENV;
! jsize RETVAL_len_ = NO_INIT;
! jdoubleArray array
! jboolean isCopy = NO_INIT;
! PPCODE:
! {
! RETVAL = (*env)->GetDoubleArrayElements(env, array,&isCopy);
! RETVAL_len_ = (*env)->GetArrayLength(env, array);
! if (GIMME == G_ARRAY) {
! int i;
! jdouble* r = RETVAL;
! EXTEND(sp, RETVAL_len_);
! for (i = RETVAL_len_; i; --i) {
! PUSHs(sv_2mortal(newSVnv(*r++)));
! }
! }
! else {
! if (RETVAL_len_) {
! PUSHs(sv_2mortal(newSVpvn((char*)RETVAL,
! (STRLEN)RETVAL_len_ * sizeof(jdouble))));
! }
! else
! PUSHs(&PL_sv_no);
! }
! (*env)->ReleaseDoubleArrayElements(env, array,RETVAL,JNI_ABORT);
! RESTOREENV;
! }
!
! void
! GetBooleanArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! jbooleanArray array
! jsize start
! jsize len
! STRLEN tmplen = len * sizeof(jboolean) + 1;
! char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen);
! jboolean * buf = (jboolean*)sv_grow(ST(3),len * sizeof(jboolean)+1);
! CODE:
! {
! (*env)->GetBooleanArrayRegion(env, array,start,len,buf);
! SvCUR_set(ST(3), len * sizeof(jboolean));
! *SvEND(ST(3)) = '\0';
! RESTOREENV;
! }
!
! void
! GetByteArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! jbyteArray array
! jsize start
! jsize len
! STRLEN tmplen = len * sizeof(jboolean) + 1;
! char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen);
! jbyte * buf = (jbyte*)sv_grow(ST(3),len * sizeof(jbyte)+1);
! CODE:
! {
! (*env)->GetByteArrayRegion(env, array,start,len,buf);
! SvCUR_set(ST(3), len * sizeof(jbyte));
! *SvEND(ST(3)) = '\0';
! RESTOREENV;
! }
!
! void
! GetCharArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! jcharArray array
! jsize start
! jsize len
! STRLEN tmplen = len * sizeof(jboolean) + 1;
! char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen);
! jchar * buf = (jchar*)sv_grow(ST(3),len * sizeof(jchar)+1);
! CODE:
! {
! (*env)->GetCharArrayRegion(env, array,start,len,buf);
! SvCUR_set(ST(3), len * sizeof(jchar));
! *SvEND(ST(3)) = '\0';
! RESTOREENV;
! }
!
! void
! GetShortArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! jshortArray array
! jsize start
! jsize len
! STRLEN tmplen = len * sizeof(jboolean) + 1;
! char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen);
! jshort * buf = (jshort*)sv_grow(ST(3),len * sizeof(jshort)+1);
! CODE:
! {
! (*env)->GetShortArrayRegion(env, array,start,len,buf);
! SvCUR_set(ST(3), len * sizeof(jshort));
! *SvEND(ST(3)) = '\0';
! RESTOREENV;
! }
!
! void
! GetIntArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! jintArray array
! jsize start
! jsize len
! STRLEN tmplen = len * sizeof(jboolean) + 1;
! char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen);
! jint * buf = (jint*)sv_grow(ST(3),len * sizeof(jint)+1);
! CODE:
! {
! (*env)->GetIntArrayRegion(env, array,start,len,buf);
! SvCUR_set(ST(3), len * sizeof(jint));
! *SvEND(ST(3)) = '\0';
! RESTOREENV;
! }
!
! void
! GetLongArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! jlongArray array
! jsize start
! jsize len
! STRLEN tmplen = len * sizeof(jboolean) + 1;
! char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen);
! jlong * buf = (jlong*)sv_grow(ST(3),len * sizeof(jlong)+1);
! CODE:
! {
! (*env)->GetLongArrayRegion(env, array,start,len,buf);
! SvCUR_set(ST(3), len * sizeof(jlong));
! *SvEND(ST(3)) = '\0';
! RESTOREENV;
! }
!
! void
! GetFloatArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! jfloatArray array
! jsize start
! jsize len
! STRLEN tmplen = len * sizeof(jboolean) + 1;
! char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen);
! jfloat * buf = (jfloat*)sv_grow(ST(3),len * sizeof(jfloat)+1);
! CODE:
! {
! (*env)->GetFloatArrayRegion(env, array,start,len,buf);
! SvCUR_set(ST(3), len * sizeof(jfloat));
! *SvEND(ST(3)) = '\0';
! RESTOREENV;
! }
!
! void
! GetDoubleArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! jdoubleArray array
! jsize start
! jsize len
! STRLEN tmplen = len * sizeof(jboolean) + 1;
! char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen);
! jdouble * buf = (jdouble*)sv_grow(ST(3),len * sizeof(jdouble)+1);
! CODE:
! {
! (*env)->GetDoubleArrayRegion(env, array,start,len,buf);
! SvCUR_set(ST(3), len * sizeof(jdouble));
! *SvEND(ST(3)) = '\0';
! RESTOREENV;
! }
!
! void
! SetBooleanArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jbooleanArray array
! jsize start
! jsize len
! jsize buf_len_ = NO_INIT;
! jboolean * buf
! CODE:
! {
! if (buf_len_ < len)
! croak("string is too short");
! else if (buf_len_ > len && PL_dowarn)
! warn("string is too long");
! (*env)->SetBooleanArrayRegion(env, array,start,len,buf);
! RESTOREENV;
! }
!
! void
! SetByteArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jbyteArray array
! jsize start
! jsize len
! jsize buf_len_ = NO_INIT;
! jbyte * buf
! CODE:
! {
! if (buf_len_ < len)
! croak("string is too short");
! else if (buf_len_ > len && PL_dowarn)
! warn("string is too long");
! (*env)->SetByteArrayRegion(env, array,start,len,buf);
! RESTOREENV;
! }
!
! void
! SetCharArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jcharArray array
! jsize start
! jsize len
! jsize buf_len_ = NO_INIT;
! jchar * buf
! CODE:
! {
! if (buf_len_ < len)
! croak("string is too short");
! else if (buf_len_ > len && PL_dowarn)
! warn("string is too long");
! (*env)->SetCharArrayRegion(env, array,start,len,buf);
! RESTOREENV;
! }
!
! void
! SetShortArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jshortArray array
! jsize start
! jsize len
! jsize buf_len_ = NO_INIT;
! jshort * buf
! CODE:
! {
! if (buf_len_ < len)
! croak("string is too short");
! else if (buf_len_ > len && PL_dowarn)
! warn("string is too long");
! (*env)->SetShortArrayRegion(env, array,start,len,buf);
! RESTOREENV;
! }
!
! void
! SetIntArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jintArray array
! jsize start
! jsize len
! jsize buf_len_ = NO_INIT;
! jint * buf
! CODE:
! {
! if (buf_len_ < len)
! croak("string is too short");
! else if (buf_len_ > len && PL_dowarn)
! warn("string is too long");
! (*env)->SetIntArrayRegion(env, array,start,len,buf);
! RESTOREENV;
! }
!
! void
! SetLongArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jlongArray array
! jsize start
! jsize len
! jsize buf_len_ = NO_INIT;
! jlong * buf
! CODE:
! {
! if (buf_len_ < len)
! croak("string is too short");
! else if (buf_len_ > len && PL_dowarn)
! warn("string is too long");
! (*env)->SetLongArrayRegion(env, array,start,len,buf);
! RESTOREENV;
! }
!
! void
! SetFloatArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jfloatArray array
! jsize start
! jsize len
! jsize buf_len_ = NO_INIT;
! jfloat * buf
! CODE:
! {
! if (buf_len_ < len)
! croak("string is too short");
! else if (buf_len_ > len && PL_dowarn)
! warn("string is too long");
! (*env)->SetFloatArrayRegion(env, array,start,len,buf);
! RESTOREENV;
! }
!
! void
! SetDoubleArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jdoubleArray array
! jsize start
! jsize len
! jsize buf_len_ = NO_INIT;
! jdouble * buf
! CODE:
! {
! if (buf_len_ < len)
! croak("string is too short");
! else if (buf_len_ > len && PL_dowarn)
! warn("string is too long");
! (*env)->SetDoubleArrayRegion(env, array,start,len,buf);
! RESTOREENV;
! }
!
! SysRet
! RegisterNatives(clazz,methods,nMethods)
! JNIEnv * env = FETCHENV;
! jclass clazz
! JNINativeMethod * methods
! jint nMethods
! CODE:
! {
! RETVAL = (*env)->RegisterNatives(env, clazz,methods,nMethods);
! }
!
! SysRet
! UnregisterNatives(clazz)
! JNIEnv * env = FETCHENV;
! jclass clazz
! CODE:
! {
! RETVAL = (*env)->UnregisterNatives(env, clazz);
! }
! OUTPUT:
! RETVAL
!
! SysRet
! MonitorEnter(obj)
! JNIEnv * env = FETCHENV;
! jobject obj
! CODE:
! {
! RETVAL = (*env)->MonitorEnter(env, obj);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! SysRet
! MonitorExit(obj)
! JNIEnv * env = FETCHENV;
! jobject obj
! CODE:
! {
! RETVAL = (*env)->MonitorExit(env, obj);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! JavaVM *
! GetJavaVM(...)
! JNIEnv * env = FETCHENV;
! CODE:
! {
! #ifdef JPL_DEBUG
! jpldebug = 1;
! #else
! jpldebug = 0;
! #endif
! if (env) { /* We're embedded. */
! if ((*env)->GetJavaVM(env, &RETVAL) < 0)
! RETVAL = 0;
! }
! else { /* We're embedding. */
! #ifdef KAFFE
! JavaVMInitArgs vm_args;
! #else
! JDK1_1InitArgs vm_args;
! #endif
! char *lib;
! if (jpldebug) {
! fprintf(stderr, "We're embedding Java in Perl.\n");
! }
!
! if (items--) {
! ++mark;
! lib = SvPV(*mark, PL_na);
! }
! else
! lib = 0;
! if (jpldebug) {
! fprintf(stderr, "lib is %s.\n", lib);
! }
! #ifdef WIN32
! if (LoadLibrary("jvm.dll")) {
! if (!LoadLibrary("javai.dll")) {
! warn("Can't load javai.dll");
! }
! } else {
! if (lib && !LoadLibrary(lib))
! croak("Can't load javai.dll");
! }
! #else
! if (jpldebug) {
! fprintf(stderr, "Opening Java shared library.\n");
! }
! #ifdef KAFFE
! if (!dlopen("libkaffevm.so", RTLD_LAZY|RTLD_GLOBAL)) {
! #else
! if (!dlopen("libjava.so", RTLD_LAZY|RTLD_GLOBAL)) {
! #endif
! if (lib && !dlopen(lib, RTLD_LAZY|RTLD_GLOBAL))
! croak("Can't load Java shared library.");
! }
! #endif
! /* Kaffe seems to get very upset if vm_args.version isn't set */
! #ifdef KAFFE
! vm_args.version = JNI_VERSION_1_1;
! #endif
! JNI_GetDefaultJavaVMInitArgs(&vm_args);
! vm_args.exit = &call_my_exit;
! if (jpldebug) {
! fprintf(stderr, "items = %d\n", items);
! fprintf(stderr, "mark = %s\n", SvPV(*mark, PL_na));
! }
! while (items > 1) {
! char *s;
! ++mark;
! s = SvPV(*mark,PL_na);
! ++mark;
! if (jpldebug) {
! fprintf(stderr, "*s = %s\n", s);
! fprintf(stderr, "val = %s\n", SvPV(*mark, PL_na));
! }
! items -= 2;
! if (strEQ(s, "checkSource"))
! vm_args.checkSource = (jint)SvIV(*mark);
! else if (strEQ(s, "nativeStackSize"))
! vm_args.nativeStackSize = (jint)SvIV(*mark);
! else if (strEQ(s, "javaStackSize"))
! vm_args.javaStackSize = (jint)SvIV(*mark);
! else if (strEQ(s, "minHeapSize"))
! vm_args.minHeapSize = (jint)SvIV(*mark);
! else if (strEQ(s, "maxHeapSize"))
! vm_args.maxHeapSize = (jint)SvIV(*mark);
! else if (strEQ(s, "verifyMode"))
! vm_args.verifyMode = (jint)SvIV(*mark);
! else if (strEQ(s, "classpath"))
! vm_args.classpath = savepv(SvPV(*mark,PL_na));
! else if (strEQ(s, "enableClassGC"))
! vm_args.enableClassGC = (jint)SvIV(*mark);
! else if (strEQ(s, "enableVerboseGC"))
! vm_args.enableVerboseGC = (jint)SvIV(*mark);
! else if (strEQ(s, "disableAsyncGC"))
! vm_args.disableAsyncGC = (jint)SvIV(*mark);
! #ifdef KAFFE
! else if (strEQ(s, "libraryhome"))
! vm_args.libraryhome = savepv(SvPV(*mark,PL_na));
! else if (strEQ(s, "classhome"))
! vm_args.classhome = savepv(SvPV(*mark,PL_na));
! else if (strEQ(s, "enableVerboseJIT"))
! vm_args.enableVerboseJIT = (jint)SvIV(*mark);
! else if (strEQ(s, "enableVerboseClassloading"))
! vm_args.enableVerboseClassloading = (jint)SvIV(*mark);
! else if (strEQ(s, "enableVerboseCall"))
! vm_args.enableVerboseCall = (jint)SvIV(*mark);
! else if (strEQ(s, "allocHeapSize"))
! vm_args.allocHeapSize = (jint)SvIV(*mark);
! #else
! else if (strEQ(s, "verbose"))
! vm_args.verbose = (jint)SvIV(*mark);
! else if (strEQ(s, "debugging"))
! vm_args.debugging = (jboolean)SvIV(*mark);
! else if (strEQ(s, "debugPort"))
! vm_args.debugPort = (jint)SvIV(*mark);
! #endif
! else
! croak("unrecognized option: %s", s);
! }
!
! if (jpldebug) {
! fprintf(stderr, "Creating Java VM...\n");
! fprintf(stderr, "Working CLASSPATH: %s\n",
! vm_args.classpath);
! }
! if (JNI_CreateJavaVM(&RETVAL, &jplcurenv, &vm_args) < 0) {
! croak("Unable to create instance of JVM");
! }
! if (jpldebug) {
! fprintf(stderr, "Created Java VM.\n");
! }
!
! }
! }
!
--- 1,3253 ----
! /*
! * Copyright 1997, O'Reilly & Associate, Inc.
! *
! * This package may be copied under the same terms as Perl itself.
! */
!
! #include "EXTERN.h"
! #include "perl.h"
! #include "XSUB.h"
!
! #include <stdio.h>
! #include <jni.h>
!
! #ifndef PERL_VERSION
! # include <patchlevel.h>
! # define PERL_REVISION 5
! # define PERL_VERSION PATCHLEVEL
! # define PERL_SUBVERSION SUBVERSION
! #endif
!
! #if PERL_REVISION == 5 && (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION <= 75))
! # define PL_na na
! # define PL_sv_no sv_no
! # define PL_sv_undef sv_undef
! # define PL_dowarn dowarn
! #endif
!
! #ifndef newSVpvn
! # define newSVpvn(a,b) newSVpv(a,b)
! #endif
!
! #ifndef pTHX
! # define pTHX void
! # define pTHX_
! # define aTHX
! # define aTHX_
! # define dTHX extern int JNI___notused
! #endif
!
! #ifndef WIN32
! # include <dlfcn.h>
! #endif
!
! #ifdef EMBEDDEDPERL
! extern JNIEnv* jplcurenv;
! extern int jpldebug;
! #else
! JNIEnv* jplcurenv;
! int jpldebug = 1;
! #endif
!
! #define SysRet jint
!
! #ifdef WIN32
! static void JNICALL call_my_exit(jint status)
! {
! my_exit(status);
! }
! #else
! static void call_my_exit(jint status)
! {
! my_exit(status);
! }
! #endif
!
! jvalue*
! makeargs(char *sig, SV** svp, int items)
! {
! jvalue* jv = (jvalue*)safemalloc(sizeof(jvalue) * items);
! int ix = 0;
! char *s = sig;
! JNIEnv* env = jplcurenv;
! char *start;
! STRLEN n_a;
!
! if (jpldebug)
! fprintf(stderr, "sig = %s, items = %d\n", sig, items);
! if (*s++ != '(')
! goto cleanup;
!
! while (items--) {
! SV *sv = *svp++;
! start = s;
! switch (*s++) {
! case 'Z':
! jv[ix++].z = (jboolean)(SvIV(sv) != 0);
! break;
! case 'B':
! jv[ix++].b = (jbyte)SvIV(sv);
! break;
! case 'C':
! jv[ix++].c = (jchar)SvIV(sv);
! break;
! case 'S':
! jv[ix++].s = (jshort)SvIV(sv);
! break;
! case 'I':
! jv[ix++].i = (jint)SvIV(sv);
! break;
! case 'J':
! jv[ix++].j = (jlong)SvNV(sv);
! break;
! case 'F':
! jv[ix++].f = (jfloat)SvNV(sv);
! break;
! case 'D':
! jv[ix++].d = (jdouble)SvNV(sv);
! break;
! case '[':
! switch (*s++) {
! case 'Z':
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! jboolean* buf = (jboolean*)malloc(len * sizeof(jboolean));
! int i;
! SV** esv;
!
! jbooleanArray ja = (*env)->NewBooleanArray(env, len);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++)
! buf[i] = (jboolean)SvIV(*esv);
! (*env)->SetBooleanArrayRegion(env, ja, 0, len, buf);
! free((void*)buf);
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else if (SvPOK(sv)) {
! jsize len = sv_len(sv) / sizeof(jboolean);
!
! jbooleanArray ja = (*env)->NewBooleanArray(env, len);
! (*env)->SetBooleanArrayRegion(env, ja, 0, len, (jboolean*)SvPV(sv,n_a));
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! case 'B':
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! jbyte* buf = (jbyte*)malloc(len * sizeof(jbyte));
! int i;
! SV** esv;
!
! jbyteArray ja = (*env)->NewByteArray(env, len);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++)
! buf[i] = (jbyte)SvIV(*esv);
! (*env)->SetByteArrayRegion(env, ja, 0, len, buf);
! free((void*)buf);
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else if (SvPOK(sv)) {
! jsize len = sv_len(sv) / sizeof(jbyte);
!
! jbyteArray ja = (*env)->NewByteArray(env, len);
! (*env)->SetByteArrayRegion(env, ja, 0, len, (jbyte*)SvPV(sv,n_a));
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! case 'C':
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! jchar* buf = (jchar*)malloc(len * sizeof(jchar));
! int i;
! SV** esv;
!
! jcharArray ja = (*env)->NewCharArray(env, len);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++)
! buf[i] = (jchar)SvIV(*esv);
! (*env)->SetCharArrayRegion(env, ja, 0, len, buf);
! free((void*)buf);
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else if (SvPOK(sv)) {
! jsize len = sv_len(sv) / sizeof(jchar);
!
! jcharArray ja = (*env)->NewCharArray(env, len);
! (*env)->SetCharArrayRegion(env, ja, 0, len, (jchar*)SvPV(sv,n_a));
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! case 'S':
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! jshort* buf = (jshort*)malloc(len * sizeof(jshort));
! int i;
! SV** esv;
!
! jshortArray ja = (*env)->NewShortArray(env, len);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++)
! buf[i] = (jshort)SvIV(*esv);
! (*env)->SetShortArrayRegion(env, ja, 0, len, buf);
! free((void*)buf);
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else if (SvPOK(sv)) {
! jsize len = sv_len(sv) / sizeof(jshort);
!
! jshortArray ja = (*env)->NewShortArray(env, len);
! (*env)->SetShortArrayRegion(env, ja, 0, len, (jshort*)SvPV(sv,n_a));
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! case 'I':
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! jint* buf = (jint*)malloc(len * sizeof(jint));
! int i;
! SV** esv;
!
! jintArray ja = (*env)->NewIntArray(env, len);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++)
! buf[i] = (jint)SvIV(*esv);
! (*env)->SetIntArrayRegion(env, ja, 0, len, buf);
! free((void*)buf);
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else if (SvPOK(sv)) {
! jsize len = sv_len(sv) / sizeof(jint);
!
! jintArray ja = (*env)->NewIntArray(env, len);
! (*env)->SetIntArrayRegion(env, ja, 0, len, (jint*)SvPV(sv,n_a));
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! case 'J':
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! jlong* buf = (jlong*)malloc(len * sizeof(jlong));
! int i;
! SV** esv;
!
! jlongArray ja = (*env)->NewLongArray(env, len);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++)
! buf[i] = (jlong)SvNV(*esv);
! (*env)->SetLongArrayRegion(env, ja, 0, len, buf);
! free((void*)buf);
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else if (SvPOK(sv)) {
! jsize len = sv_len(sv) / sizeof(jlong);
!
! jlongArray ja = (*env)->NewLongArray(env, len);
! (*env)->SetLongArrayRegion(env, ja, 0, len, (jlong*)SvPV(sv,n_a));
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! case 'F':
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! jfloat* buf = (jfloat*)malloc(len * sizeof(jfloat));
! int i;
! SV** esv;
!
! jfloatArray ja = (*env)->NewFloatArray(env, len);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++)
! buf[i] = (jfloat)SvNV(*esv);
! (*env)->SetFloatArrayRegion(env, ja, 0, len, buf);
! free((void*)buf);
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else if (SvPOK(sv)) {
! jsize len = sv_len(sv) / sizeof(jfloat);
!
! jfloatArray ja = (*env)->NewFloatArray(env, len);
! (*env)->SetFloatArrayRegion(env, ja, 0, len, (jfloat*)SvPV(sv,n_a));
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! case 'D':
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! jdouble* buf = (jdouble*)malloc(len * sizeof(jdouble));
! int i;
! SV** esv;
!
! jdoubleArray ja = (*env)->NewDoubleArray(env, len);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++)
! buf[i] = (jdouble)SvNV(*esv);
! (*env)->SetDoubleArrayRegion(env, ja, 0, len, buf);
! free((void*)buf);
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else if (SvPOK(sv)) {
! jsize len = sv_len(sv) / sizeof(jdouble);
!
! jdoubleArray ja = (*env)->NewDoubleArray(env, len);
! (*env)->SetDoubleArrayRegion(env, ja, 0, len, (jdouble*)SvPV(sv,n_a));
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! case 'L':
! while (*s != ';') s++;
! s++;
! if (strnEQ(start, "[Ljava/lang/String;", 19)) {
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! int i;
! SV** esv;
! static jclass jcl = 0;
! jobjectArray ja;
!
! if (!jcl)
! jcl = (*env)->FindClass(env, "java/lang/String");
! ja = (*env)->NewObjectArray(env, len, jcl, 0);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) {
! jobject str = (jobject)(*env)->NewStringUTF(env, SvPV(*esv,n_a));
! (*env)->SetObjectArrayElement(env, ja, i, str);
! }
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! }
! /* FALL THROUGH */
! default:
! if (SvROK(sv)) {
! SV* rv = (SV*)SvRV(sv);
! if (SvOBJECT(rv))
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! else if (SvTYPE(rv) == SVt_PVAV) {
! jsize len = av_len((AV*)rv) + 1;
! int i;
! SV** esv;
! static jclass jcl = 0;
! jobjectArray ja;
!
! if (!jcl)
! jcl = (*env)->FindClass(env, "java/lang/Object");
! ja = (*env)->NewObjectArray(env, len, jcl, 0);
! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) {
! if (SvROK(*esv) && (rv = SvRV(*esv)) && SvOBJECT(rv)) {
! (*env)->SetObjectArrayElement(env, ja, i, (jobject)(void*)SvIV(rv));
! }
! else {
! jobject str = (jobject)(*env)->NewStringUTF(env, SvPV(*esv,n_a));
! (*env)->SetObjectArrayElement(env, ja, i, str);
! }
! }
! jv[ix++].l = (jobject)ja;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! }
! else
! jv[ix++].l = (jobject)(void*)0;
! break;
! }
! break;
! case 'L':
! if (!SvROK(sv) || strnEQ(s, "java/lang/String;", 17)) {
! s += 17;
! jv[ix++].l = (jobject)(*env)->NewStringUTF(env, (char*) SvPV(sv,n_a));
! break;
! }
! while (*s != ';') s++;
! s++;
! if (SvROK(sv)) {
! SV* rv = SvRV(sv);
! jv[ix++].l = (jobject)(void*)SvIV(rv);
! }
! break;
! case ')':
! croak("too many arguments, signature: %s", sig);
! goto cleanup;
! default:
! croak("panic: malformed signature: %s", s-1);
! goto cleanup;
! }
!
! }
! if (*s != ')') {
! croak("not enough arguments, signature: %s", sig);
! goto cleanup;
! }
! return jv;
!
! cleanup:
! safefree((char*)jv);
! return 0;
! }
!
! static int
! not_here(char *s)
! {
! croak("%s not implemented on this architecture", s);
! return -1;
! }
!
! static double
! constant(char *name, int arg)
! {
! errno = 0;
! switch (*name) {
! case 'A':
! break;
! case 'B':
! break;
! case 'C':
! break;
! case 'D':
! break;
! case 'E':
! break;
! case 'F':
! break;
! case 'G':
! break;
! case 'H':
! break;
! case 'I':
! break;
! case 'J':
! if (strEQ(name, "JNI_ABORT"))
! #ifdef JNI_ABORT
! return JNI_ABORT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "JNI_COMMIT"))
! #ifdef JNI_COMMIT
! return JNI_COMMIT;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "JNI_ERR"))
! #ifdef JNI_ERR
! return JNI_ERR;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "JNI_FALSE"))
! #ifdef JNI_FALSE
! return JNI_FALSE;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "JNI_H"))
! #ifdef JNI_H
! #ifdef WIN32
! return 1;
! #else
! return JNI_H;
! #endif
! #else
! goto not_there;
! #endif
! if (strEQ(name, "JNI_OK"))
! #ifdef JNI_OK
! return JNI_OK;
! #else
! goto not_there;
! #endif
! if (strEQ(name, "JNI_TRUE"))
! #ifdef JNI_TRUE
! return JNI_TRUE;
! #else
! goto not_there;
! #endif
! break;
! case 'K':
! break;
! case 'L':
! break;
! case 'M':
! break;
! case 'N':
! break;
! case 'O':
! break;
! case 'P':
! break;
! case 'Q':
! break;
! case 'R':
! break;
! case 'S':
! break;
! case 'T':
! break;
! case 'U':
! break;
! case 'V':
! break;
! case 'W':
! break;
! case 'X':
! break;
! case 'Y':
! break;
! case 'Z':
! break;
! }
! errno = EINVAL;
! return 0;
!
! not_there:
! errno = ENOENT;
! return 0;
! }
!
! #define FETCHENV jplcurenv
! #define RESTOREENV jplcurenv = env
!
! MODULE = JNI PACKAGE = JNI
!
! PROTOTYPES: ENABLE
!
! double
! constant(name,arg)
! char * name
! int arg
!
! jint
! GetVersion()
! JNIEnv * env = FETCHENV;
! CODE:
! {
! RETVAL = (*env)->GetVersion(env);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jclass
! DefineClass(name, loader, buf)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jsize buf_len_ = NO_INIT;
! const char * name
! jobject loader
! const jbyte * buf
! CODE:
! {
! #ifdef KAFFE
! RETVAL = (*env)->DefineClass(env, loader, buf, (jsize)buf_len_);
! #else
! RETVAL = (*env)->DefineClass(env, name, loader, buf, (jsize)buf_len_);
! #endif
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jclass
! FindClass(name)
! JNIEnv * env = FETCHENV;
! const char * name
! CODE:
! {
! RETVAL = (*env)->FindClass(env, name);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jclass
! GetSuperclass(sub)
! JNIEnv * env = FETCHENV;
! jclass sub
! CODE:
! {
! RETVAL = (*env)->GetSuperclass(env, sub);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! IsAssignableFrom(sub, sup)
! JNIEnv * env = FETCHENV;
! jclass sub
! jclass sup
! CODE:
! {
! RETVAL = (*env)->IsAssignableFrom(env, sub, sup);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! SysRet
! Throw(obj)
! JNIEnv * env = FETCHENV;
! jthrowable obj
! CODE:
! {
! RETVAL = (*env)->Throw(env, obj);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! SysRet
! ThrowNew(clazz, msg)
! JNIEnv * env = FETCHENV;
! jclass clazz
! const char * msg
! CODE:
! {
! RETVAL = (*env)->ThrowNew(env, clazz, msg);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jthrowable
! ExceptionOccurred()
! JNIEnv * env = FETCHENV;
! CODE:
! {
! RETVAL = (*env)->ExceptionOccurred(env);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! void
! ExceptionDescribe()
! JNIEnv * env = FETCHENV;
! CODE:
! {
! (*env)->ExceptionDescribe(env);
! RESTOREENV;
! }
!
! void
! ExceptionClear()
! JNIEnv * env = FETCHENV;
! CODE:
! {
! (*env)->ExceptionClear(env);
! RESTOREENV;
! }
!
! void
! FatalError(msg)
! JNIEnv * env = FETCHENV;
! const char * msg
! CODE:
! {
! (*env)->FatalError(env, msg);
! RESTOREENV;
! }
!
! jobject
! NewGlobalRef(lobj)
! JNIEnv * env = FETCHENV;
! jobject lobj
! CODE:
! {
! RETVAL = (*env)->NewGlobalRef(env, lobj);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! void
! DeleteGlobalRef(gref)
! JNIEnv * env = FETCHENV;
! jobject gref
! CODE:
! {
! (*env)->DeleteGlobalRef(env, gref);
! RESTOREENV;
! }
!
! void
! DeleteLocalRef(obj)
! JNIEnv * env = FETCHENV;
! jobject obj
! CODE:
! {
! (*env)->DeleteLocalRef(env, obj);
! RESTOREENV;
! }
!
! jboolean
! IsSameObject(obj1,obj2)
! JNIEnv * env = FETCHENV;
! jobject obj1
! jobject obj2
! CODE:
! {
! RETVAL = (*env)->IsSameObject(env, obj1,obj2);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! AllocObject(clazz)
! JNIEnv * env = FETCHENV;
! jclass clazz
! CODE:
! {
! RETVAL = (*env)->AllocObject(env, clazz);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! NewObject(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->NewObjectA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! NewObjectA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->NewObjectA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jclass
! GetObjectClass(obj)
! JNIEnv * env = FETCHENV;
! jobject obj
! CODE:
! {
! RETVAL = (*env)->GetObjectClass(env, obj);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! IsInstanceOf(obj,clazz)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! CODE:
! {
! RETVAL = (*env)->IsInstanceOf(env, obj,clazz);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jmethodID
! GetMethodID(clazz,name,sig)
! JNIEnv * env = FETCHENV;
! jclass clazz
! const char * name
! const char * sig
! CODE:
! {
! RETVAL = (*env)->GetMethodID(env, clazz,name,sig);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! CallObjectMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallObjectMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! CallObjectMethodA(obj,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallObjectMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! CallBooleanMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallBooleanMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! CallBooleanMethodA(obj,methodID, args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallBooleanMethodA(env, obj,methodID, args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jbyte
! CallByteMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallByteMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jbyte
! CallByteMethodA(obj,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallByteMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jchar
! CallCharMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallCharMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jchar
! CallCharMethodA(obj,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallCharMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jshort
! CallShortMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallShortMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jshort
! CallShortMethodA(obj,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallShortMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jint
! CallIntMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallIntMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jint
! CallIntMethodA(obj,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallIntMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jlong
! CallLongMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallLongMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jlong
! CallLongMethodA(obj,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallLongMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jfloat
! CallFloatMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallFloatMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jfloat
! CallFloatMethodA(obj,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallFloatMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jdouble
! CallDoubleMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallDoubleMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jdouble
! CallDoubleMethodA(obj,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallDoubleMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! void
! CallVoidMethod(obj,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! (*env)->CallVoidMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
!
! void
! CallVoidMethodA(obj,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! (*env)->CallVoidMethodA(env, obj,methodID,args);
! RESTOREENV;
! }
!
! jobject
! CallNonvirtualObjectMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallNonvirtualObjectMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! CallNonvirtualObjectMethodA(obj,clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallNonvirtualObjectMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! CallNonvirtualBooleanMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallNonvirtualBooleanMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! CallNonvirtualBooleanMethodA(obj,clazz,methodID, args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallNonvirtualBooleanMethodA(env, obj,clazz,methodID, args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jbyte
! CallNonvirtualByteMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallNonvirtualByteMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jbyte
! CallNonvirtualByteMethodA(obj,clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallNonvirtualByteMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jchar
! CallNonvirtualCharMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallNonvirtualCharMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jchar
! CallNonvirtualCharMethodA(obj,clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallNonvirtualCharMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jshort
! CallNonvirtualShortMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallNonvirtualShortMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jshort
! CallNonvirtualShortMethodA(obj,clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallNonvirtualShortMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jint
! CallNonvirtualIntMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallNonvirtualIntMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jint
! CallNonvirtualIntMethodA(obj,clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallNonvirtualIntMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jlong
! CallNonvirtualLongMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallNonvirtualLongMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jlong
! CallNonvirtualLongMethodA(obj,clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallNonvirtualLongMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jfloat
! CallNonvirtualFloatMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallNonvirtualFloatMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jfloat
! CallNonvirtualFloatMethodA(obj,clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallNonvirtualFloatMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jdouble
! CallNonvirtualDoubleMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallNonvirtualDoubleMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jdouble
! CallNonvirtualDoubleMethodA(obj,clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallNonvirtualDoubleMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! void
! CallNonvirtualVoidMethod(obj,clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! (*env)->CallNonvirtualVoidMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
!
! void
! CallNonvirtualVoidMethodA(obj,clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jobject obj
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! (*env)->CallNonvirtualVoidMethodA(env, obj,clazz,methodID,args);
! RESTOREENV;
! }
!
! jfieldID
! GetFieldID(clazz,name,sig)
! JNIEnv * env = FETCHENV;
! jclass clazz
! const char * name
! const char * sig
! CODE:
! {
! RETVAL = (*env)->GetFieldID(env, clazz,name,sig);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! GetObjectField(obj,fieldID)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetObjectField(env, obj,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! GetBooleanField(obj,fieldID)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetBooleanField(env, obj,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jbyte
! GetByteField(obj,fieldID)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetByteField(env, obj,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jchar
! GetCharField(obj,fieldID)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetCharField(env, obj,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jshort
! GetShortField(obj,fieldID)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetShortField(env, obj,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jint
! GetIntField(obj,fieldID)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetIntField(env, obj,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jlong
! GetLongField(obj,fieldID)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetLongField(env, obj,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jfloat
! GetFloatField(obj,fieldID)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetFloatField(env, obj,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jdouble
! GetDoubleField(obj,fieldID)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetDoubleField(env, obj,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! void
! SetObjectField(obj,fieldID,val)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! jobject val
! CODE:
! {
! (*env)->SetObjectField(env, obj,fieldID,val);
! RESTOREENV;
! }
!
! void
! SetBooleanField(obj,fieldID,val)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! jboolean val
! CODE:
! {
! (*env)->SetBooleanField(env, obj,fieldID,val);
! RESTOREENV;
! }
!
! void
! SetByteField(obj,fieldID,val)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! jbyte val
! CODE:
! {
! (*env)->SetByteField(env, obj,fieldID,val);
! RESTOREENV;
! }
!
! void
! SetCharField(obj,fieldID,val)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! jchar val
! CODE:
! {
! (*env)->SetCharField(env, obj,fieldID,val);
! RESTOREENV;
! }
!
! void
! SetShortField(obj,fieldID,val)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! jshort val
! CODE:
! {
! (*env)->SetShortField(env, obj,fieldID,val);
! RESTOREENV;
! }
!
! void
! SetIntField(obj,fieldID,val)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! jint val
! CODE:
! {
! (*env)->SetIntField(env, obj,fieldID,val);
! RESTOREENV;
! }
!
! void
! SetLongField(obj,fieldID,val)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! jlong val
! CODE:
! {
! (*env)->SetLongField(env, obj,fieldID,val);
! RESTOREENV;
! }
!
! void
! SetFloatField(obj,fieldID,val)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! jfloat val
! CODE:
! {
! (*env)->SetFloatField(env, obj,fieldID,val);
! RESTOREENV;
! }
!
! void
! SetDoubleField(obj,fieldID,val)
! JNIEnv * env = FETCHENV;
! jobject obj
! jfieldID fieldID
! char * sig = 0;
! jdouble val
! CODE:
! {
! (*env)->SetDoubleField(env, obj,fieldID,val);
! RESTOREENV;
! }
!
! jmethodID
! GetStaticMethodID(clazz,name,sig)
! JNIEnv * env = FETCHENV;
! jclass clazz
! const char * name
! const char * sig
! CODE:
! {
! RETVAL = (*env)->GetStaticMethodID(env, clazz,name,sig);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! CallStaticObjectMethod(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallStaticObjectMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! CallStaticObjectMethodA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallStaticObjectMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! CallStaticBooleanMethod(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallStaticBooleanMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! CallStaticBooleanMethodA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallStaticBooleanMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jbyte
! CallStaticByteMethod(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallStaticByteMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jbyte
! CallStaticByteMethodA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallStaticByteMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jchar
! CallStaticCharMethod(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallStaticCharMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jchar
! CallStaticCharMethodA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallStaticCharMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jshort
! CallStaticShortMethod(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallStaticShortMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jshort
! CallStaticShortMethodA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallStaticShortMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jint
! CallStaticIntMethod(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallStaticIntMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jint
! CallStaticIntMethodA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallStaticIntMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jlong
! CallStaticLongMethod(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallStaticLongMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jlong
! CallStaticLongMethodA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallStaticLongMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jfloat
! CallStaticFloatMethod(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallStaticFloatMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jfloat
! CallStaticFloatMethodA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallStaticFloatMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jdouble
! CallStaticDoubleMethod(clazz,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! RETVAL = (*env)->CallStaticDoubleMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jdouble
! CallStaticDoubleMethodA(clazz,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! RETVAL = (*env)->CallStaticDoubleMethodA(env, clazz,methodID,args);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! void
! CallStaticVoidMethod(cls,methodID,...)
! JNIEnv * env = FETCHENV;
! jclass cls
! jmethodID methodID
! char * sig = 0;
! int argoff = $min_args;
! CODE:
! {
! jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
! (*env)->CallStaticVoidMethodA(env, cls,methodID,args);
! RESTOREENV;
! }
!
! void
! CallStaticVoidMethodA(cls,methodID,args)
! JNIEnv * env = FETCHENV;
! jclass cls
! jmethodID methodID
! char * sig = 0;
! jvalue * args
! CODE:
! {
! (*env)->CallStaticVoidMethodA(env, cls,methodID,args);
! RESTOREENV;
! }
!
! jfieldID
! GetStaticFieldID(clazz,name,sig)
! JNIEnv * env = FETCHENV;
! jclass clazz
! const char * name
! const char * sig
! CODE:
! {
! RETVAL = (*env)->GetStaticFieldID(env, clazz,name,sig);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! GetStaticObjectField(clazz,fieldID)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetStaticObjectField(env, clazz,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean
! GetStaticBooleanField(clazz,fieldID)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetStaticBooleanField(env, clazz,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jbyte
! GetStaticByteField(clazz,fieldID)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetStaticByteField(env, clazz,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jchar
! GetStaticCharField(clazz,fieldID)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetStaticCharField(env, clazz,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jshort
! GetStaticShortField(clazz,fieldID)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetStaticShortField(env, clazz,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jint
! GetStaticIntField(clazz,fieldID)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetStaticIntField(env, clazz,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jlong
! GetStaticLongField(clazz,fieldID)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetStaticLongField(env, clazz,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jfloat
! GetStaticFloatField(clazz,fieldID)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetStaticFloatField(env, clazz,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jdouble
! GetStaticDoubleField(clazz,fieldID)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! CODE:
! {
! RETVAL = (*env)->GetStaticDoubleField(env, clazz,fieldID);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! void
! SetStaticObjectField(clazz,fieldID,value)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! jobject value
! CODE:
! {
! (*env)->SetStaticObjectField(env, clazz,fieldID,value);
! RESTOREENV;
! }
!
! void
! SetStaticBooleanField(clazz,fieldID,value)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! jboolean value
! CODE:
! {
! (*env)->SetStaticBooleanField(env, clazz,fieldID,value);
! RESTOREENV;
! }
!
! void
! SetStaticByteField(clazz,fieldID,value)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! jbyte value
! CODE:
! {
! (*env)->SetStaticByteField(env, clazz,fieldID,value);
! RESTOREENV;
! }
!
! void
! SetStaticCharField(clazz,fieldID,value)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! jchar value
! CODE:
! {
! (*env)->SetStaticCharField(env, clazz,fieldID,value);
! RESTOREENV;
! }
!
! void
! SetStaticShortField(clazz,fieldID,value)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! jshort value
! CODE:
! {
! (*env)->SetStaticShortField(env, clazz,fieldID,value);
! RESTOREENV;
! }
!
! void
! SetStaticIntField(clazz,fieldID,value)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! jint value
! CODE:
! {
! (*env)->SetStaticIntField(env, clazz,fieldID,value);
! RESTOREENV;
! }
!
! void
! SetStaticLongField(clazz,fieldID,value)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! jlong value
! CODE:
! {
! (*env)->SetStaticLongField(env, clazz,fieldID,value);
! RESTOREENV;
! }
!
! void
! SetStaticFloatField(clazz,fieldID,value)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! jfloat value
! CODE:
! {
! (*env)->SetStaticFloatField(env, clazz,fieldID,value);
! RESTOREENV;
! }
!
! void
! SetStaticDoubleField(clazz,fieldID,value)
! JNIEnv * env = FETCHENV;
! jclass clazz
! jfieldID fieldID
! char * sig = 0;
! jdouble value
! CODE:
! {
! (*env)->SetStaticDoubleField(env, clazz,fieldID,value);
! RESTOREENV;
! }
!
! jstring
! NewString(unicode)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jsize unicode_len_ = NO_INIT;
! const jchar * unicode
! CODE:
! {
! RETVAL = (*env)->NewString(env, unicode, unicode_len_);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jsize
! GetStringLength(str)
! JNIEnv * env = FETCHENV;
! jstring str
! CODE:
! {
! RETVAL = (*env)->GetStringLength(env, str);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! const jchar *
! GetStringChars(str)
! JNIEnv * env = FETCHENV;
! jstring str
! jboolean isCopy = NO_INIT;
! jsize RETVAL_len_ = NO_INIT;
! CODE:
! {
! RETVAL = (*env)->GetStringChars(env, str,&isCopy);
! RETVAL_len_ = (*env)->GetStringLength(env, str);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
! CLEANUP:
! (*env)->ReleaseStringChars(env, str,RETVAL);
!
! jstring
! NewStringUTF(utf)
! JNIEnv * env = FETCHENV;
! const char * utf
! CODE:
! {
! RETVAL = (*env)->NewStringUTF(env, utf);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jsize
! GetStringUTFLength(str)
! JNIEnv * env = FETCHENV;
! jstring str
! CODE:
! {
! RETVAL = (*env)->GetStringUTFLength(env, str);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! const char *
! GetStringUTFChars(str)
! JNIEnv * env = FETCHENV;
! jstring str
! jboolean isCopy = NO_INIT;
! CODE:
! {
! RETVAL = (*env)->GetStringUTFChars(env, str,&isCopy);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
! CLEANUP:
! (*env)->ReleaseStringUTFChars(env, str, RETVAL);
!
!
! jsize
! GetArrayLength(array)
! JNIEnv * env = FETCHENV;
! jarray array
! CODE:
! {
! RETVAL = (*env)->GetArrayLength(env, array);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobjectArray
! NewObjectArray(len,clazz,init)
! JNIEnv * env = FETCHENV;
! jsize len
! jclass clazz
! jobject init
! CODE:
! {
! RETVAL = (*env)->NewObjectArray(env, len,clazz,init);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jobject
! GetObjectArrayElement(array,index)
! JNIEnv * env = FETCHENV;
! jobjectArray array
! jsize index
! CODE:
! {
! RETVAL = (*env)->GetObjectArrayElement(env, array,index);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! void
! SetObjectArrayElement(array,index,val)
! JNIEnv * env = FETCHENV;
! jobjectArray array
! jsize index
! jobject val
! CODE:
! {
! (*env)->SetObjectArrayElement(env, array,index,val);
! RESTOREENV;
! }
!
! jbooleanArray
! NewBooleanArray(len)
! JNIEnv * env = FETCHENV;
! jsize len
! CODE:
! {
! RETVAL = (*env)->NewBooleanArray(env, len);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jbyteArray
! NewByteArray(len)
! JNIEnv * env = FETCHENV;
! jsize len
! CODE:
! {
! RETVAL = (*env)->NewByteArray(env, len);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jcharArray
! NewCharArray(len)
! JNIEnv * env = FETCHENV;
! jsize len
! CODE:
! {
! RETVAL = (*env)->NewCharArray(env, len);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jshortArray
! NewShortArray(len)
! JNIEnv * env = FETCHENV;
! jsize len
! CODE:
! {
! RETVAL = (*env)->NewShortArray(env, len);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jintArray
! NewIntArray(len)
! JNIEnv * env = FETCHENV;
! jsize len
! CODE:
! {
! RETVAL = (*env)->NewIntArray(env, len);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jlongArray
! NewLongArray(len)
! JNIEnv * env = FETCHENV;
! jsize len
! CODE:
! {
! RETVAL = (*env)->NewLongArray(env, len);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jfloatArray
! NewFloatArray(len)
! JNIEnv * env = FETCHENV;
! jsize len
! CODE:
! {
! RETVAL = (*env)->NewFloatArray(env, len);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jdoubleArray
! NewDoubleArray(len)
! JNIEnv * env = FETCHENV;
! jsize len
! CODE:
! {
! RETVAL = (*env)->NewDoubleArray(env, len);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! jboolean *
! GetBooleanArrayElements(array)
! JNIEnv * env = FETCHENV;
! jsize RETVAL_len_ = NO_INIT;
! jbooleanArray array
! jboolean isCopy = NO_INIT;
! PPCODE:
! {
! RETVAL = (*env)->GetBooleanArrayElements(env, array,&isCopy);
! RETVAL_len_ = (*env)->GetArrayLength(env, array);
! if (GIMME == G_ARRAY) {
! int i;
! jboolean* r = RETVAL;
! EXTEND(sp, RETVAL_len_);
! for (i = RETVAL_len_; i; --i) {
! PUSHs(sv_2mortal(newSViv(*r++)));
! }
! }
! else {
! if (RETVAL_len_) {
! PUSHs(sv_2mortal(newSVpvn((char*)RETVAL,
! (STRLEN)RETVAL_len_ * sizeof(jboolean))));
! }
! else
! PUSHs(&PL_sv_no);
! }
! (*env)->ReleaseBooleanArrayElements(env, array,RETVAL,JNI_ABORT);
! RESTOREENV;
! }
!
! jbyte *
! GetByteArrayElements(array)
! JNIEnv * env = FETCHENV;
! jsize RETVAL_len_ = NO_INIT;
! jbyteArray array
! jboolean isCopy = NO_INIT;
! PPCODE:
! {
! RETVAL = (*env)->GetByteArrayElements(env, array,&isCopy);
! RETVAL_len_ = (*env)->GetArrayLength(env, array);
! if (GIMME == G_ARRAY) {
! int i;
! jbyte* r = RETVAL;
! EXTEND(sp, RETVAL_len_);
! for (i = RETVAL_len_; i; --i) {
! PUSHs(sv_2mortal(newSViv(*r++)));
! }
! }
! else {
! if (RETVAL_len_) {
! PUSHs(sv_2mortal(newSVpvn((char*)RETVAL,
! (STRLEN)RETVAL_len_ * sizeof(jbyte))));
! }
! else
! PUSHs(&PL_sv_no);
! }
! (*env)->ReleaseByteArrayElements(env, array,RETVAL,JNI_ABORT);
! RESTOREENV;
! }
!
! jchar *
! GetCharArrayElements(array)
! JNIEnv * env = FETCHENV;
! jsize RETVAL_len_ = NO_INIT;
! jcharArray array
! jboolean isCopy = NO_INIT;
! PPCODE:
! {
! RETVAL = (*env)->GetCharArrayElements(env, array,&isCopy);
! RETVAL_len_ = (*env)->GetArrayLength(env, array);
! if (GIMME == G_ARRAY) {
! int i;
! jchar* r = RETVAL;
! EXTEND(sp, RETVAL_len_);
! for (i = RETVAL_len_; i; --i) {
! PUSHs(sv_2mortal(newSViv(*r++)));
! }
! }
! else {
! if (RETVAL_len_) {
! PUSHs(sv_2mortal(newSVpvn((char*)RETVAL,
! (STRLEN)RETVAL_len_ * sizeof(jchar))));
! }
! else
! PUSHs(&PL_sv_no);
! }
! (*env)->ReleaseCharArrayElements(env, array,RETVAL,JNI_ABORT);
! RESTOREENV;
! }
!
! jshort *
! GetShortArrayElements(array)
! JNIEnv * env = FETCHENV;
! jsize RETVAL_len_ = NO_INIT;
! jshortArray array
! jboolean isCopy = NO_INIT;
! PPCODE:
! {
! RETVAL = (*env)->GetShortArrayElements(env, array,&isCopy);
! RETVAL_len_ = (*env)->GetArrayLength(env, array);
! if (GIMME == G_ARRAY) {
! int i;
! jshort* r = RETVAL;
! EXTEND(sp, RETVAL_len_);
! for (i = RETVAL_len_; i; --i) {
! PUSHs(sv_2mortal(newSViv(*r++)));
! }
! }
! else {
! if (RETVAL_len_) {
! PUSHs(sv_2mortal(newSVpvn((char*)RETVAL,
! (STRLEN)RETVAL_len_ * sizeof(jshort))));
! }
! else
! PUSHs(&PL_sv_no);
! }
! (*env)->ReleaseShortArrayElements(env, array,RETVAL,JNI_ABORT);
! RESTOREENV;
! }
!
! jint *
! GetIntArrayElements(array)
! JNIEnv * env = FETCHENV;
! jsize RETVAL_len_ = NO_INIT;
! jintArray array
! jboolean isCopy = NO_INIT;
! PPCODE:
! {
! RETVAL = (*env)->GetIntArrayElements(env, array,&isCopy);
! RETVAL_len_ = (*env)->GetArrayLength(env, array);
! if (GIMME == G_ARRAY) {
! int i;
! jint* r = RETVAL;
! EXTEND(sp, RETVAL_len_);
! for (i = RETVAL_len_; i; --i) {
! PUSHs(sv_2mortal(newSViv(*r++)));
! }
! }
! else {
! if (RETVAL_len_) {
! PUSHs(sv_2mortal(newSVpvn((char*)RETVAL,
! (STRLEN)RETVAL_len_ * sizeof(jint))));
! }
! else
! PUSHs(&PL_sv_no);
! }
! (*env)->ReleaseIntArrayElements(env, array,RETVAL,JNI_ABORT);
! RESTOREENV;
! }
!
! jlong *
! GetLongArrayElements(array)
! JNIEnv * env = FETCHENV;
! jsize RETVAL_len_ = NO_INIT;
! jlongArray array
! jboolean isCopy = NO_INIT;
! PPCODE:
! {
! RETVAL = (*env)->GetLongArrayElements(env, array,&isCopy);
! RETVAL_len_ = (*env)->GetArrayLength(env, array);
! if (GIMME == G_ARRAY) {
! int i;
! jlong* r = RETVAL;
! EXTEND(sp, RETVAL_len_);
! for (i = RETVAL_len_; i; --i) {
! PUSHs(sv_2mortal(newSViv(*r++)));
! }
! }
! else {
! if (RETVAL_len_) {
! PUSHs(sv_2mortal(newSVpvn((char*)RETVAL,
! (STRLEN)RETVAL_len_ * sizeof(jlong))));
! }
! else
! PUSHs(&PL_sv_no);
! }
! (*env)->ReleaseLongArrayElements(env, array,RETVAL,JNI_ABORT);
! RESTOREENV;
! }
!
! jfloat *
! GetFloatArrayElements(array)
! JNIEnv * env = FETCHENV;
! jsize RETVAL_len_ = NO_INIT;
! jfloatArray array
! jboolean isCopy = NO_INIT;
! PPCODE:
! {
! RETVAL = (*env)->GetFloatArrayElements(env, array,&isCopy);
! RETVAL_len_ = (*env)->GetArrayLength(env, array);
! if (GIMME == G_ARRAY) {
! int i;
! jfloat* r = RETVAL;
! EXTEND(sp, RETVAL_len_);
! for (i = RETVAL_len_; i; --i) {
! PUSHs(sv_2mortal(newSVnv(*r++)));
! }
! }
! else {
! if (RETVAL_len_) {
! PUSHs(sv_2mortal(newSVpvn((char*)RETVAL,
! (STRLEN)RETVAL_len_ * sizeof(jfloat))));
! }
! else
! PUSHs(&PL_sv_no);
! }
! (*env)->ReleaseFloatArrayElements(env, array,RETVAL,JNI_ABORT);
! RESTOREENV;
! }
!
! jdouble *
! GetDoubleArrayElements(array)
! JNIEnv * env = FETCHENV;
! jsize RETVAL_len_ = NO_INIT;
! jdoubleArray array
! jboolean isCopy = NO_INIT;
! PPCODE:
! {
! RETVAL = (*env)->GetDoubleArrayElements(env, array,&isCopy);
! RETVAL_len_ = (*env)->GetArrayLength(env, array);
! if (GIMME == G_ARRAY) {
! int i;
! jdouble* r = RETVAL;
! EXTEND(sp, RETVAL_len_);
! for (i = RETVAL_len_; i; --i) {
! PUSHs(sv_2mortal(newSVnv(*r++)));
! }
! }
! else {
! if (RETVAL_len_) {
! PUSHs(sv_2mortal(newSVpvn((char*)RETVAL,
! (STRLEN)RETVAL_len_ * sizeof(jdouble))));
! }
! else
! PUSHs(&PL_sv_no);
! }
! (*env)->ReleaseDoubleArrayElements(env, array,RETVAL,JNI_ABORT);
! RESTOREENV;
! }
!
! void
! GetBooleanArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! jbooleanArray array
! jsize start
! jsize len
! STRLEN tmplen = len * sizeof(jboolean) + 1;
! char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen);
! jboolean * buf = (jboolean*)sv_grow(ST(3),len * sizeof(jboolean)+1);
! CODE:
! {
! (*env)->GetBooleanArrayRegion(env, array,start,len,buf);
! SvCUR_set(ST(3), len * sizeof(jboolean));
! *SvEND(ST(3)) = '\0';
! RESTOREENV;
! }
!
! void
! GetByteArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! jbyteArray array
! jsize start
! jsize len
! STRLEN tmplen = len * sizeof(jboolean) + 1;
! char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen);
! jbyte * buf = (jbyte*)sv_grow(ST(3),len * sizeof(jbyte)+1);
! CODE:
! {
! (*env)->GetByteArrayRegion(env, array,start,len,buf);
! SvCUR_set(ST(3), len * sizeof(jbyte));
! *SvEND(ST(3)) = '\0';
! RESTOREENV;
! }
!
! void
! GetCharArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! jcharArray array
! jsize start
! jsize len
! STRLEN tmplen = len * sizeof(jboolean) + 1;
! char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen);
! jchar * buf = (jchar*)sv_grow(ST(3),len * sizeof(jchar)+1);
! CODE:
! {
! (*env)->GetCharArrayRegion(env, array,start,len,buf);
! SvCUR_set(ST(3), len * sizeof(jchar));
! *SvEND(ST(3)) = '\0';
! RESTOREENV;
! }
!
! void
! GetShortArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! jshortArray array
! jsize start
! jsize len
! STRLEN tmplen = len * sizeof(jboolean) + 1;
! char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen);
! jshort * buf = (jshort*)sv_grow(ST(3),len * sizeof(jshort)+1);
! CODE:
! {
! (*env)->GetShortArrayRegion(env, array,start,len,buf);
! SvCUR_set(ST(3), len * sizeof(jshort));
! *SvEND(ST(3)) = '\0';
! RESTOREENV;
! }
!
! void
! GetIntArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! jintArray array
! jsize start
! jsize len
! STRLEN tmplen = len * sizeof(jboolean) + 1;
! char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen);
! jint * buf = (jint*)sv_grow(ST(3),len * sizeof(jint)+1);
! CODE:
! {
! (*env)->GetIntArrayRegion(env, array,start,len,buf);
! SvCUR_set(ST(3), len * sizeof(jint));
! *SvEND(ST(3)) = '\0';
! RESTOREENV;
! }
!
! void
! GetLongArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! jlongArray array
! jsize start
! jsize len
! STRLEN tmplen = len * sizeof(jboolean) + 1;
! char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen);
! jlong * buf = (jlong*)sv_grow(ST(3),len * sizeof(jlong)+1);
! CODE:
! {
! (*env)->GetLongArrayRegion(env, array,start,len,buf);
! SvCUR_set(ST(3), len * sizeof(jlong));
! *SvEND(ST(3)) = '\0';
! RESTOREENV;
! }
!
! void
! GetFloatArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! jfloatArray array
! jsize start
! jsize len
! STRLEN tmplen = len * sizeof(jboolean) + 1;
! char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen);
! jfloat * buf = (jfloat*)sv_grow(ST(3),len * sizeof(jfloat)+1);
! CODE:
! {
! (*env)->GetFloatArrayRegion(env, array,start,len,buf);
! SvCUR_set(ST(3), len * sizeof(jfloat));
! *SvEND(ST(3)) = '\0';
! RESTOREENV;
! }
!
! void
! GetDoubleArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! jdoubleArray array
! jsize start
! jsize len
! STRLEN tmplen = len * sizeof(jboolean) + 1;
! char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen);
! jdouble * buf = (jdouble*)sv_grow(ST(3),len * sizeof(jdouble)+1);
! CODE:
! {
! (*env)->GetDoubleArrayRegion(env, array,start,len,buf);
! SvCUR_set(ST(3), len * sizeof(jdouble));
! *SvEND(ST(3)) = '\0';
! RESTOREENV;
! }
!
! void
! SetBooleanArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jbooleanArray array
! jsize start
! jsize len
! jsize buf_len_ = NO_INIT;
! jboolean * buf
! CODE:
! {
! if (buf_len_ < len)
! croak("string is too short");
! else if (buf_len_ > len && PL_dowarn)
! warn("string is too long");
! (*env)->SetBooleanArrayRegion(env, array,start,len,buf);
! RESTOREENV;
! }
!
! void
! SetByteArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jbyteArray array
! jsize start
! jsize len
! jsize buf_len_ = NO_INIT;
! jbyte * buf
! CODE:
! {
! if (buf_len_ < len)
! croak("string is too short");
! else if (buf_len_ > len && PL_dowarn)
! warn("string is too long");
! (*env)->SetByteArrayRegion(env, array,start,len,buf);
! RESTOREENV;
! }
!
! void
! SetCharArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jcharArray array
! jsize start
! jsize len
! jsize buf_len_ = NO_INIT;
! jchar * buf
! CODE:
! {
! if (buf_len_ < len)
! croak("string is too short");
! else if (buf_len_ > len && PL_dowarn)
! warn("string is too long");
! (*env)->SetCharArrayRegion(env, array,start,len,buf);
! RESTOREENV;
! }
!
! void
! SetShortArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jshortArray array
! jsize start
! jsize len
! jsize buf_len_ = NO_INIT;
! jshort * buf
! CODE:
! {
! if (buf_len_ < len)
! croak("string is too short");
! else if (buf_len_ > len && PL_dowarn)
! warn("string is too long");
! (*env)->SetShortArrayRegion(env, array,start,len,buf);
! RESTOREENV;
! }
!
! void
! SetIntArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jintArray array
! jsize start
! jsize len
! jsize buf_len_ = NO_INIT;
! jint * buf
! CODE:
! {
! if (buf_len_ < len)
! croak("string is too short");
! else if (buf_len_ > len && PL_dowarn)
! warn("string is too long");
! (*env)->SetIntArrayRegion(env, array,start,len,buf);
! RESTOREENV;
! }
!
! void
! SetLongArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jlongArray array
! jsize start
! jsize len
! jsize buf_len_ = NO_INIT;
! jlong * buf
! CODE:
! {
! if (buf_len_ < len)
! croak("string is too short");
! else if (buf_len_ > len && PL_dowarn)
! warn("string is too long");
! (*env)->SetLongArrayRegion(env, array,start,len,buf);
! RESTOREENV;
! }
!
! void
! SetFloatArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jfloatArray array
! jsize start
! jsize len
! jsize buf_len_ = NO_INIT;
! jfloat * buf
! CODE:
! {
! if (buf_len_ < len)
! croak("string is too short");
! else if (buf_len_ > len && PL_dowarn)
! warn("string is too long");
! (*env)->SetFloatArrayRegion(env, array,start,len,buf);
! RESTOREENV;
! }
!
! void
! SetDoubleArrayRegion(array,start,len,buf)
! JNIEnv * env = FETCHENV;
! STRLEN tmplen = NO_INIT;
! jdoubleArray array
! jsize start
! jsize len
! jsize buf_len_ = NO_INIT;
! jdouble * buf
! CODE:
! {
! if (buf_len_ < len)
! croak("string is too short");
! else if (buf_len_ > len && PL_dowarn)
! warn("string is too long");
! (*env)->SetDoubleArrayRegion(env, array,start,len,buf);
! RESTOREENV;
! }
!
! SysRet
! RegisterNatives(clazz,methods,nMethods)
! JNIEnv * env = FETCHENV;
! jclass clazz
! JNINativeMethod * methods
! jint nMethods
! CODE:
! {
! RETVAL = (*env)->RegisterNatives(env, clazz,methods,nMethods);
! }
!
! SysRet
! UnregisterNatives(clazz)
! JNIEnv * env = FETCHENV;
! jclass clazz
! CODE:
! {
! RETVAL = (*env)->UnregisterNatives(env, clazz);
! }
! OUTPUT:
! RETVAL
!
! SysRet
! MonitorEnter(obj)
! JNIEnv * env = FETCHENV;
! jobject obj
! CODE:
! {
! RETVAL = (*env)->MonitorEnter(env, obj);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! SysRet
! MonitorExit(obj)
! JNIEnv * env = FETCHENV;
! jobject obj
! CODE:
! {
! RETVAL = (*env)->MonitorExit(env, obj);
! RESTOREENV;
! }
! OUTPUT:
! RETVAL
!
! JavaVM *
! GetJavaVM(...)
! JNIEnv * env = FETCHENV;
! CODE:
! {
! #ifdef JPL_DEBUG
! jpldebug = 1;
! #else
! jpldebug = 0;
! #endif
! if (env) { /* We're embedded. */
! if ((*env)->GetJavaVM(env, &RETVAL) < 0)
! RETVAL = 0;
! }
! else { /* We're embedding. */
! #ifdef KAFFE
! JavaVMInitArgs vm_args;
! #else
! JDK1_1InitArgs vm_args;
! #endif
! char *lib;
! if (jpldebug) {
! fprintf(stderr, "We're embedding Java in Perl.\n");
! }
!
! if (items--) {
! ++mark;
! lib = SvPV(*mark, PL_na);
! }
! else
! lib = 0;
! if (jpldebug) {
! fprintf(stderr, "lib is %s.\n", lib);
! }
! #ifdef WIN32
! if (LoadLibrary("jvm.dll")) {
! if (!LoadLibrary("javai.dll")) {
! warn("Can't load javai.dll");
! }
! } else {
! if (lib && !LoadLibrary(lib))
! croak("Can't load javai.dll");
! }
! #else
! if (jpldebug) {
! fprintf(stderr, "Opening Java shared library.\n");
! }
! #ifdef KAFFE
! if (!dlopen("libkaffevm.so", RTLD_LAZY|RTLD_GLOBAL)) {
! #else
! if (!dlopen("libjava.so", RTLD_LAZY|RTLD_GLOBAL)) {
! #endif
! if (lib && !dlopen(lib, RTLD_LAZY|RTLD_GLOBAL))
! croak("Can't load Java shared library.");
! }
! #endif
! /* Kaffe seems to get very upset if vm_args.version isn't set */
! #ifdef KAFFE
! vm_args.version = JNI_VERSION_1_1;
! #endif
! JNI_GetDefaultJavaVMInitArgs(&vm_args);
! vm_args.exit = &call_my_exit;
! if (jpldebug) {
! fprintf(stderr, "items = %d\n", items);
! fprintf(stderr, "mark = %s\n", SvPV(*mark, PL_na));
! }
! while (items > 1) {
! char *s;
! ++mark;
! s = SvPV(*mark,PL_na);
! ++mark;
! if (jpldebug) {
! fprintf(stderr, "*s = %s\n", s);
! fprintf(stderr, "val = %s\n", SvPV(*mark, PL_na));
! }
! items -= 2;
! if (strEQ(s, "checkSource"))
! vm_args.checkSource = (jint)SvIV(*mark);
! else if (strEQ(s, "nativeStackSize"))
! vm_args.nativeStackSize = (jint)SvIV(*mark);
! else if (strEQ(s, "javaStackSize"))
! vm_args.javaStackSize = (jint)SvIV(*mark);
! else if (strEQ(s, "minHeapSize"))
! vm_args.minHeapSize = (jint)SvIV(*mark);
! else if (strEQ(s, "maxHeapSize"))
! vm_args.maxHeapSize = (jint)SvIV(*mark);
! else if (strEQ(s, "verifyMode"))
! vm_args.verifyMode = (jint)SvIV(*mark);
! else if (strEQ(s, "classpath"))
! vm_args.classpath = savepv(SvPV(*mark,PL_na));
! else if (strEQ(s, "enableClassGC"))
! vm_args.enableClassGC = (jint)SvIV(*mark);
! else if (strEQ(s, "enableVerboseGC"))
! vm_args.enableVerboseGC = (jint)SvIV(*mark);
! else if (strEQ(s, "disableAsyncGC"))
! vm_args.disableAsyncGC = (jint)SvIV(*mark);
! #ifdef KAFFE
! else if (strEQ(s, "libraryhome"))
! vm_args.libraryhome = savepv(SvPV(*mark,PL_na));
! else if (strEQ(s, "classhome"))
! vm_args.classhome = savepv(SvPV(*mark,PL_na));
! else if (strEQ(s, "enableVerboseJIT"))
! vm_args.enableVerboseJIT = (jint)SvIV(*mark);
! else if (strEQ(s, "enableVerboseClassloading"))
! vm_args.enableVerboseClassloading = (jint)SvIV(*mark);
! else if (strEQ(s, "enableVerboseCall"))
! vm_args.enableVerboseCall = (jint)SvIV(*mark);
! else if (strEQ(s, "allocHeapSize"))
! vm_args.allocHeapSize = (jint)SvIV(*mark);
! #else
! else if (strEQ(s, "verbose"))
! vm_args.verbose = (jint)SvIV(*mark);
! else if (strEQ(s, "debugging"))
! vm_args.debugging = (jboolean)SvIV(*mark);
! else if (strEQ(s, "debugPort"))
! vm_args.debugPort = (jint)SvIV(*mark);
! #endif
! else
! croak("unrecognized option: %s", s);
! }
!
! if (jpldebug) {
! fprintf(stderr, "Creating Java VM...\n");
! fprintf(stderr, "Working CLASSPATH: %s\n",
! vm_args.classpath);
! }
! if (JNI_CreateJavaVM(&RETVAL, &jplcurenv, &vm_args) < 0) {
! croak("Unable to create instance of JVM");
! }
! if (jpldebug) {
! fprintf(stderr, "Created Java VM.\n");
! }
!
! }
! }
!
diff -c 'perl-5.7.1/jpl/JNI/Makefile.PL' 'perl-5.7.2/jpl/JNI/Makefile.PL'
Index: ./jpl/JNI/Makefile.PL
*** ./jpl/JNI/Makefile.PL Sun Apr 8 23:54:51 2001
--- ./jpl/JNI/Makefile.PL Mon Jul 9 17:10:23 2001
***************
*** 1,297 ****
! #!/usr/bin/perl
! use ExtUtils::MakeMaker;
! use Getopt::Std;
! use Config;
! $ARCHNAME = $Config{archname};
! use File::Basename;
!
! getopts('e'); # embedding?
!
! $CCFLAGS .= $ENV{CCFLAGS} if defined $ENV{CCFLAGS};
!
! # $USE_KAFFE is a boolean that tells us whether or not we should use Kaffe.
! # Set by find_includes (it seemed as good a place as any).
!
! # Note that we don't check to see the version of Kaffe is one we support.
! # Currently, the only one we support is the one from CVS.
!
! my $USE_KAFFE = 0;
!
! #require "JNIConfig";
!
! if ($^O eq 'solaris') {
! $LIBPATH = " -R$Config{archlib}/CORE -L$Config{archlib}/CORE";
! } elsif ($^O eq 'MSWin32') {
! $LIBPATH = " -L$Config{archlib}\\CORE";
! # MSR - added MS VC++ default library path
! # bjepson - fixed to support path names w/spaces in them.
! push(@WINLIBS, (split"\;",$ENV{LIB}));
! grep s/\\$//, @WINLIBS; # eliminate trailing \
! grep s/\/$//, @WINLIBS; # eliminate trailing /
! $LIBPATH .= join(" ", "", map { qq["-L$_" ] } @WINLIBS);
! } else {
! $LIBPATH = " -L$Config{archlib}/CORE";
! }
! #$LIBS = " -lperl";
!
! # Figure out where Java might live
! #
! # MSR - added JDK 1.3
! #
!
! my @JAVA_HOME_GUESSES = qw(/usr/local/java /usr/java /usr/local/jdk117_v3
! C:\\JDK1.1.8 C:\\JDK1.2.1 C:\\JDK1.2.2 C:\\JDK1.3 );
!
! my @KAFFE_PREFIX_GUESSES = qw(/usr/local /usr);
!
! if (! defined $ENV{JAVA_HOME}) {
! print "You didn't define JAVA_HOME, so I'm trying a few guesses.\n";
! print "If this fails, you might want to try setting JAVA_HOME and\n";
! print "running me again.\n";
! } else {
! @JAVA_HOME_GUESSES = ( $ENV{JAVA_HOME} );
! }
!
! if (! defined $ENV{KAFFE_PREFIX}) {
! print "\nYou didn't define KAFFE_PREFIX, so I'm trying a few guesses.",
! "\nIf this fails, and you are using Kaffe, you might want to try\n",
! "setting KAFFE_PREFIX and running me again.\n",
! "If you want to ignore any possible Kaffe installation, set the\n",
! "KAFFE_PREFIX to and empty string.\n\n";
! } else {
! @KAFFE_PREFIX_GUESSES = ($ENV{KAFFE_PREFIX} eq "") ? () :
! ( $ENV{KAFFE_PREFIX} );
! }
!
! my(@KAFFE_INCLUDE_GUESSES, @KAFFE_LIB_GUESSES);
! foreach my $kaffePrefix (@KAFFE_PREFIX_GUESSES) {
! push(@KAFFE_INCLUDE_GUESSES, "$kaffePrefix/include/kaffe");
! push(@KAFFE_LIB_GUESSES, "$kaffePrefix/lib");
! push(@KAFFE_LIB_GUESSES, "$kaffePrefix/lib/kaffe");
! }
! $guess .= "/include/kaffe";
!
! # Let's find out where jni.h lives
! #
! my @INCLUDE = find_includes();
!
! if ($^O eq 'MSWin32') {
! # MSR - added MS VC++ default include path
! push(@INCLUDE,(split"\;",$ENV{INCLUDE}));
! grep s/\\$//, @INCLUDE; # remove trailing \
! grep s/\/$//, @INCLUDE; # remove trailing \
! $INC = join("", map { qq["-I$_" ] } @INCLUDE);
!
! } else {
! $INC = join(" -I", ("", @INCLUDE));
! }
!
! # Let's find out the name of the Java shared library
! #
! my @JAVALIBS = find_libs();
!
! # Find out some defines based on the library we are linking to
! #
! foreach (@JAVALIBS) {
! if ( $^O eq 'MSWin32') { # We're on Win32
! $INC =~ s#/#\\#g;
! $INC =~ s#\\$##;
! print $INC, "\n";
! $CCFLAGS .= " -DWIN32 -Z7 -D_DEBUG";
! $MYEXTLIB = "$libjava";
! }
! }
!
! $CCFLAGS .= " -DKAFFE" if ($USE_KAFFE);
!
! # Let's find out the path of the library we need to link against.
! #
! foreach (@JAVALIBS) {
! if ($^O eq 'MSWin32') { # We're on Win32
! $_ =~ s#/#\\\\#g;
! }
! my ($libname, $libpath, $libsuffix) = fileparse($_, ("\.so", "\.lib"));
! $libname =~ s/^lib//;
! if ($^O eq 'solaris') {
! $LIBPATH .= " -R$libpath -L$libpath"
! } else {
! $LIBPATH .= " -L$libpath"
! }
! $LIBS .= " -l$libname";
! }
!
! # Do we need -D_REENTRANT?
! if ($LIBPATH =~ /native/) {
! print "Looks like native threads...\n";
! $CCFLAGS .= " -D_REENTRANT";
! }
!
! if ($opt_e) {
! print "We're embedding Perl in Java via libPerlInterpreter.so.\n";
! eval `../setvars -perl`;
! $CCFLAGS .= " -DEMBEDDEDPERL";
! $LIBPATH .= " -R$ENV{JPL_HOME}/lib/$ARCHNAME -L$ENV{JPL_HOME}/lib/$ARCHNAME";
! $LIBS .= " -lPerlInterpreter";
! }
!
! # Needed for JNI.
! if ($^O eq 'solaris') {
! $LIBS = " -lthread -lc $LIBS"; #-lthread must be first!!!
! $CCFLAGS .= " -D_REENTRANT";
! }
!
! # MSR - clean up LIBS
! $LIBS =~ s/-l$//;
!
! #
! # Next, build JNI/Config.pm. This is a superfluous thing for the SUN and
! # Microsoft JDKs, but absolutely necessary for Kaffe. I think at some
! # point, the Microsoft and SUN implementations should use JNI::Config, too.
! #
!
! if (! -d "JNI") {
! mkdir("JNI", 0755) || die "Unable to make JNI directory: $!";
! }
! open(JNICONFIG, ">JNI/Config.pm") || die "Unable to open JNI/Config.pm: $!";
!
! print JNICONFIG "# DO NOT EDIT! Autogenerated by JNI/Makefile.PL\n\n",
! "package JNI::Config;\nuse strict;\nuse Carp;\n",
! "\nuse vars qw(\$KAFFE \$LIB_JAVA \$CLASS_HOME ",
! "\$LIB_HOME);\n\n",
! "\$KAFFE = $USE_KAFFE;\n\$LIB_JAVA = \"$JAVALIBS[0]\";\n";
! if ($USE_KAFFE) {
! my $path = $JAVALIBS[0];
! $path =~ s%/(kaffe/)?libkaffevm.so$%%;
!
! print JNICONFIG "\$LIB_HOME = \"$path/kaffe\";\n";
! $path =~ s%/lib%%;
! print JNICONFIG "\$CLASS_HOME = \"$path/share/kaffe\";\n";
! }
! print JNICONFIG "\n\n1;\n";
! close JNICONFIG;
!
!
! my %Makefile = (
! NAME => 'JNI',
! VERSION_FROM => 'JNI.pm',
! DEFINE => '',
! LINKTYPE => 'dynamic',
! INC => $INC,
! CCFLAGS => "$Config{ccflags} $CCFLAGS",
! ($Config{archname} =~ /mswin32.*-object/i ? ('CAPI' => 'TRUE') : ()),
!
! clean => {FILES => "JNI/* JNI"}
! );
!
! $Makefile{LIBS} = ["$LIBPATH $LIBS"];
! if ($MYEXTLIB) {
! $Makefile{MYEXTLIB} = $MYEXTLIB;
! }
!
! # See lib/ExtUtils/MakeMaker.pm for details of how to influence
! # the contents of the Makefile that is written.
! #
! WriteMakefile(%Makefile);
!
! if ($USE_KAFFE) {
! my $path = $JAVALIBS[0];
! $path =~ s%/libkaffevm.so$%%;
! print "\n\n***NOTE: be sure to have:\n",
! " LD_LIBRARY_PATH=$path\n",
! " in your enviornment (or installed as a system dynamic\n",
! " library location) when you compile and run this.\n";
! }
!
! # subroutine to find a library
! #
! sub find_stuff {
!
! my ($candidates, $locations) = @_;
! my $lib;
! $wanted = sub {
! foreach my $name (@$candidates) {
! if (/$name$/ and ! /green_threads/ and !/include-old/) {
! $lib = $File::Find::name;
! }
! }
! };
!
! use File::Find;
! foreach my $guess (@$locations) {
! next unless -d $guess;
! find (\&$wanted, $guess);
! }
! if (! $lib) {
! print "Could not find @$candidates\n";
! } else {
! print "Found @$candidates as $lib\n\n";
! }
! return $lib;
! }
!
! # Extra lib for Java 1.2
! #
! # if we want KAFFE, check for it, otherwise search for Java
!
! sub find_libs {
! my($libjava, $libawt, $libjvm);
!
! if ($USE_KAFFE) {
! $libjava = find_stuff(['libkaffevm.so'], \@KAFFE_LIB_GUESSES);
! $libawt = find_stuff(['libawt.so'], \@KAFFE_LIB_GUESSES);
! } else {
! $libjava = find_stuff(['libjava.so', 'javai.lib', 'jvm.lib'],
! \@JAVA_HOME_GUESSES);
! $libjvm = find_stuff(['libjvm.so'], \@JAVA_HOME_GUESSES);
! $libawt = find_stuff(['libawt.so'], \@JAVA_HOME_GUESSES);
! if (defined $libjvm) { # JDK 1.2
! my $libhpi = find_stuff(['libhpi.so'], \@JAVA_HOME_GUESSES);
! return($libjava, $libjvm, $libhpi, $libawt);
! }
! }
! return($libjava, $libawt);
! }
!
! # We need to find jni.h and jni_md.h
! #
!
! # Always do find_includes as the first operation, as it has the side effect
! # of deciding whether or not we are looking for Kaffe. --bkuhn
!
! sub find_includes {
!
! my @CANDIDATES = qw(jni.h jni_md.h);
! my @includes;
!
! sub find_inc {
! foreach my $name (@CANDIDATES) {
! if (/$name$/) {
! my ($hname, $hpath, $hsuffix) =
! fileparse($File::Find::name, ("\.h", "\.H"));
! unless ($hpath =~ /include-old/) {
! print "Found $hname$hsuffix in $hpath\n";
! push @includes, $hpath;
! }
! }
! }
! }
!
! use File::Find;
! foreach my $guess (@KAFFE_INCLUDE_GUESSES) {
! next unless -d $guess;
! find (\&find_inc, $guess);
! }
! # If we have found includes, then we are using Kaffe.
! if (@includes > 0) {
! $USE_KAFFE = 1;
! } else {
! foreach my $guess (@JAVA_HOME_GUESSES) {
! next unless -d $guess;
! find (\&find_inc, $guess);
! }
! }
! die "Could not find Java includes!" unless (@includes);
!
! return @includes;
! }
!
--- 1,297 ----
! #!/usr/bin/perl
! use ExtUtils::MakeMaker;
! use Getopt::Std;
! use Config;
! $ARCHNAME = $Config{archname};
! use File::Basename;
!
! getopts('e'); # embedding?
!
! $CCFLAGS .= $ENV{CCFLAGS} if defined $ENV{CCFLAGS};
!
! # $USE_KAFFE is a boolean that tells us whether or not we should use Kaffe.
! # Set by find_includes (it seemed as good a place as any).
!
! # Note that we don't check to see the version of Kaffe is one we support.
! # Currently, the only one we support is the one from CVS.
!
! my $USE_KAFFE = 0;
!
! #require "JNIConfig";
!
! if ($^O eq 'solaris') {
! $LIBPATH = " -R$Config{archlib}/CORE -L$Config{archlib}/CORE";
! } elsif ($^O eq 'MSWin32') {
! $LIBPATH = " -L$Config{archlib}\\CORE";
! # MSR - added MS VC++ default library path
! # bjepson - fixed to support path names w/spaces in them.
! push(@WINLIBS, (split"\;",$ENV{LIB}));
! grep s/\\$//, @WINLIBS; # eliminate trailing \
! grep s/\/$//, @WINLIBS; # eliminate trailing /
! $LIBPATH .= join(" ", "", map { qq["-L$_" ] } @WINLIBS);
! } else {
! $LIBPATH = " -L$Config{archlib}/CORE";
! }
! #$LIBS = " -lperl";
!
! # Figure out where Java might live
! #
! # MSR - added JDK 1.3
! #
!
! my @JAVA_HOME_GUESSES = qw(/usr/local/java /usr/java /usr/local/jdk117_v3
! C:\\JDK1.1.8 C:\\JDK1.2.1 C:\\JDK1.2.2 C:\\JDK1.3 );
!
! my @KAFFE_PREFIX_GUESSES = qw(/usr/local /usr);
!
! if (! defined $ENV{JAVA_HOME}) {
! print "You didn't define JAVA_HOME, so I'm trying a few guesses.\n";
! print "If this fails, you might want to try setting JAVA_HOME and\n";
! print "running me again.\n";
! } else {
! @JAVA_HOME_GUESSES = ( $ENV{JAVA_HOME} );
! }
!
! if (! defined $ENV{KAFFE_PREFIX}) {
! print "\nYou didn't define KAFFE_PREFIX, so I'm trying a few guesses.",
! "\nIf this fails, and you are using Kaffe, you might want to try\n",
! "setting KAFFE_PREFIX and running me again.\n",
! "If you want to ignore any possible Kaffe installation, set the\n",
! "KAFFE_PREFIX to and empty string.\n\n";
! } else {
! @KAFFE_PREFIX_GUESSES = ($ENV{KAFFE_PREFIX} eq "") ? () :
! ( $ENV{KAFFE_PREFIX} );
! }
!
! my(@KAFFE_INCLUDE_GUESSES, @KAFFE_LIB_GUESSES);
! foreach my $kaffePrefix (@KAFFE_PREFIX_GUESSES) {
! push(@KAFFE_INCLUDE_GUESSES, "$kaffePrefix/include/kaffe");
! push(@KAFFE_LIB_GUESSES, "$kaffePrefix/lib");
! push(@KAFFE_LIB_GUESSES, "$kaffePrefix/lib/kaffe");
! }
! $guess .= "/include/kaffe";
!
! # Let's find out where jni.h lives
! #
! my @INCLUDE = find_includes();
!
! if ($^O eq 'MSWin32') {
! # MSR - added MS VC++ default include path
! push(@INCLUDE,(split"\;",$ENV{INCLUDE}));
! grep s/\\$//, @INCLUDE; # remove trailing \
! grep s/\/$//, @INCLUDE; # remove trailing \
! $INC = join("", map { qq["-I$_" ] } @INCLUDE);
!
! } else {
! $INC = join(" -I", ("", @INCLUDE));
! }
!
! # Let's find out the name of the Java shared library
! #
! my @JAVALIBS = find_libs();
!
! # Find out some defines based on the library we are linking to
! #
! foreach (@JAVALIBS) {
! if ( $^O eq 'MSWin32') { # We're on Win32
! $INC =~ s#/#\\#g;
! $INC =~ s#\\$##;
! print $INC, "\n";
! $CCFLAGS .= " -DWIN32 -Z7 -D_DEBUG";
! $MYEXTLIB = "$libjava";
! }
! }
!
! $CCFLAGS .= " -DKAFFE" if ($USE_KAFFE);
!
! # Let's find out the path of the library we need to link against.
! #
! foreach (@JAVALIBS) {
! if ($^O eq 'MSWin32') { # We're on Win32
! $_ =~ s#/#\\\\#g;
! }
! my ($libname, $libpath, $libsuffix) = fileparse($_, ("\.so", "\.lib"));
! $libname =~ s/^lib//;
! if ($^O eq 'solaris') {
! $LIBPATH .= " -R$libpath -L$libpath"
! } else {
! $LIBPATH .= " -L$libpath"
! }
! $LIBS .= " -l$libname";
! }
!
! # Do we need -D_REENTRANT?
! if ($LIBPATH =~ /native/) {
! print "Looks like native threads...\n";
! $CCFLAGS .= " -D_REENTRANT";
! }
!
! if ($opt_e) {
! print "We're embedding Perl in Java via libPerlInterpreter.so.\n";
! eval `../setvars -perl`;
! $CCFLAGS .= " -DEMBEDDEDPERL";
! $LIBPATH .= " -R$ENV{JPL_HOME}/lib/$ARCHNAME -L$ENV{JPL_HOME}/lib/$ARCHNAME";
! $LIBS .= " -lPerlInterpreter";
! }
!
! # Needed for JNI.
! if ($^O eq 'solaris') {
! $LIBS = " -lthread -lc $LIBS"; #-lthread must be first!!!
! $CCFLAGS .= " -D_REENTRANT";
! }
!
! # MSR - clean up LIBS
! $LIBS =~ s/-l$//;
!
! #
! # Next, build JNI/Config.pm. This is a superfluous thing for the SUN and
! # Microsoft JDKs, but absolutely necessary for Kaffe. I think at some
! # point, the Microsoft and SUN implementations should use JNI::Config, too.
! #
!
! if (! -d "JNI") {
! mkdir("JNI", 0755) || die "Unable to make JNI directory: $!";
! }
! open(JNICONFIG, ">JNI/Config.pm") || die "Unable to open JNI/Config.pm: $!";
!
! print JNICONFIG "# DO NOT EDIT! Autogenerated by JNI/Makefile.PL\n\n",
! "package JNI::Config;\nuse strict;\nuse Carp;\n",
! "\nuse vars qw(\$KAFFE \$LIB_JAVA \$CLASS_HOME ",
! "\$LIB_HOME);\n\n",
! "\$KAFFE = $USE_KAFFE;\n\$LIB_JAVA = \"$JAVALIBS[0]\";\n";
! if ($USE_KAFFE) {
! my $path = $JAVALIBS[0];
! $path =~ s%/(kaffe/)?libkaffevm.so$%%;
!
! print JNICONFIG "\$LIB_HOME = \"$path/kaffe\";\n";
! $path =~ s%/lib%%;
! print JNICONFIG "\$CLASS_HOME = \"$path/share/kaffe\";\n";
! }
! print JNICONFIG "\n\n1;\n";
! close JNICONFIG;
!
!
! my %Makefile = (
! NAME => 'JNI',
! VERSION_FROM => 'JNI.pm',
! DEFINE => '',
! LINKTYPE => 'dynamic',
! INC => $INC,
! CCFLAGS => "$Config{ccflags} $CCFLAGS",
! ($Config{archname} =~ /mswin32.*-object/i ? ('CAPI' => 'TRUE') : ()),
!
! clean => {FILES => "JNI/* JNI"}
! );
!
! $Makefile{LIBS} = ["$LIBPATH $LIBS"];
! if ($MYEXTLIB) {
! $Makefile{MYEXTLIB} = $MYEXTLIB;
! }
!
! # See lib/ExtUtils/MakeMaker.pm for details of how to influence
! # the contents of the Makefile that is written.
! #
! WriteMakefile(%Makefile);
!
! if ($USE_KAFFE) {
! my $path = $JAVALIBS[0];
! $path =~ s%/libkaffevm.so$%%;
! print "\n\n***NOTE: be sure to have:\n",
! " LD_LIBRARY_PATH=$path\n",
! " in your enviornment (or installed as a system dynamic\n",
! " library location) when you compile and run this.\n";
! }
!
! # subroutine to find a library
! #
! sub find_stuff {
!
! my ($candidates, $locations) = @_;
! my $lib;
! $wanted = sub {
! foreach my $name (@$candidates) {
! if (/$name$/ and ! /green_threads/ and !/include-old/) {
! $lib = $File::Find::name;
! }
! }
! };
!
! use File::Find;
! foreach my $guess (@$locations) {
! next unless -d $guess;
! find (\&$wanted, $guess);
! }
! if (! $lib) {
! print "Could not find @$candidates\n";
! } else {
! print "Found @$candidates as $lib\n\n";
! }
! return $lib;
! }
!
! # Extra lib for Java 1.2
! #
! # if we want KAFFE, check for it, otherwise search for Java
!
! sub find_libs {
! my($libjava, $libawt, $libjvm);
!
! if ($USE_KAFFE) {
! $libjava = find_stuff(['libkaffevm.so'], \@KAFFE_LIB_GUESSES);
! $libawt = find_stuff(['libawt.so'], \@KAFFE_LIB_GUESSES);
! } else {
! $libjava = find_stuff(['libjava.so', 'javai.lib', 'jvm.lib'],
! \@JAVA_HOME_GUESSES);
! $libjvm = find_stuff(['libjvm.so'], \@JAVA_HOME_GUESSES);
! $libawt = find_stuff(['libawt.so'], \@JAVA_HOME_GUESSES);
! if (defined $libjvm) { # JDK 1.2
! my $libhpi = find_stuff(['libhpi.so'], \@JAVA_HOME_GUESSES);
! return($libjava, $libjvm, $libhpi, $libawt);
! }
! }
! return($libjava, $libawt);
! }
!
! # We need to find jni.h and jni_md.h
! #
!
! # Always do find_includes as the first operation, as it has the side effect
! # of deciding whether or not we are looking for Kaffe. --bkuhn
!
! sub find_includes {
!
! my @CANDIDATES = qw(jni.h jni_md.h);
! my @includes;
!
! sub find_inc {
! foreach my $name (@CANDIDATES) {
! if (/$name$/) {
! my ($hname, $hpath, $hsuffix) =
! fileparse($File::Find::name, ("\.h", "\.H"));
! unless ($hpath =~ /include-old/) {
! print "Found $hname$hsuffix in $hpath\n";
! push @includes, $hpath;
! }
! }
! }
! }
!
! use File::Find;
! foreach my $guess (@KAFFE_INCLUDE_GUESSES) {
! next unless -d $guess;
! find (\&find_inc, $guess);
! }
! # If we have found includes, then we are using Kaffe.
! if (@includes > 0) {
! $USE_KAFFE = 1;
! } else {
! foreach my $guess (@JAVA_HOME_GUESSES) {
! next unless -d $guess;
! find (\&find_inc, $guess);
! }
! }
! die "Could not find Java includes!" unless (@includes);
!
! return @includes;
! }
!
diff -c 'perl-5.7.1/keywords.h' 'perl-5.7.2/keywords.h'
Index: ./keywords.h
*** ./keywords.h Thu Apr 5 20:48:10 2001
--- ./keywords.h Mon Jul 9 17:10:24 2001
***************
*** 9,253 ****
#define KEY_CORE 8
#define KEY_DESTROY 9
#define KEY_END 10
! #define KEY_EQ 11
! #define KEY_GE 12
! #define KEY_GT 13
! #define KEY_INIT 14
! #define KEY_LE 15
! #define KEY_LT 16
! #define KEY_NE 17
! #define KEY_CHECK 18
! #define KEY_abs 19
! #define KEY_accept 20
! #define KEY_alarm 21
! #define KEY_and 22
! #define KEY_atan2 23
! #define KEY_bind 24
! #define KEY_binmode 25
! #define KEY_bless 26
! #define KEY_caller 27
! #define KEY_chdir 28
! #define KEY_chmod 29
! #define KEY_chomp 30
! #define KEY_chop 31
! #define KEY_chown 32
! #define KEY_chr 33
! #define KEY_chroot 34
! #define KEY_close 35
! #define KEY_closedir 36
! #define KEY_cmp 37
! #define KEY_connect 38
! #define KEY_continue 39
! #define KEY_cos 40
! #define KEY_crypt 41
! #define KEY_dbmclose 42
! #define KEY_dbmopen 43
! #define KEY_defined 44
! #define KEY_delete 45
! #define KEY_die 46
! #define KEY_do 47
! #define KEY_dump 48
! #define KEY_each 49
! #define KEY_else 50
! #define KEY_elsif 51
! #define KEY_endgrent 52
! #define KEY_endhostent 53
! #define KEY_endnetent 54
! #define KEY_endprotoent 55
! #define KEY_endpwent 56
! #define KEY_endservent 57
! #define KEY_eof 58
! #define KEY_eq 59
! #define KEY_eval 60
! #define KEY_exec 61
! #define KEY_exists 62
! #define KEY_exit 63
! #define KEY_exp 64
! #define KEY_fcntl 65
! #define KEY_fileno 66
! #define KEY_flock 67
! #define KEY_for 68
! #define KEY_foreach 69
! #define KEY_fork 70
! #define KEY_format 71
! #define KEY_formline 72
! #define KEY_ge 73
! #define KEY_getc 74
! #define KEY_getgrent 75
! #define KEY_getgrgid 76
! #define KEY_getgrnam 77
! #define KEY_gethostbyaddr 78
! #define KEY_gethostbyname 79
! #define KEY_gethostent 80
! #define KEY_getlogin 81
! #define KEY_getnetbyaddr 82
! #define KEY_getnetbyname 83
! #define KEY_getnetent 84
! #define KEY_getpeername 85
! #define KEY_getpgrp 86
! #define KEY_getppid 87
! #define KEY_getpriority 88
! #define KEY_getprotobyname 89
! #define KEY_getprotobynumber 90
! #define KEY_getprotoent 91
! #define KEY_getpwent 92
! #define KEY_getpwnam 93
! #define KEY_getpwuid 94
! #define KEY_getservbyname 95
! #define KEY_getservbyport 96
! #define KEY_getservent 97
! #define KEY_getsockname 98
! #define KEY_getsockopt 99
! #define KEY_glob 100
! #define KEY_gmtime 101
! #define KEY_goto 102
! #define KEY_grep 103
! #define KEY_gt 104
! #define KEY_hex 105
! #define KEY_if 106
! #define KEY_index 107
! #define KEY_int 108
! #define KEY_ioctl 109
! #define KEY_join 110
! #define KEY_keys 111
! #define KEY_kill 112
! #define KEY_last 113
! #define KEY_lc 114
! #define KEY_lcfirst 115
! #define KEY_le 116
! #define KEY_length 117
! #define KEY_link 118
! #define KEY_listen 119
! #define KEY_local 120
! #define KEY_localtime 121
! #define KEY_lock 122
! #define KEY_log 123
! #define KEY_lstat 124
! #define KEY_lt 125
! #define KEY_m 126
! #define KEY_map 127
! #define KEY_mkdir 128
! #define KEY_msgctl 129
! #define KEY_msgget 130
! #define KEY_msgrcv 131
! #define KEY_msgsnd 132
! #define KEY_my 133
! #define KEY_ne 134
! #define KEY_next 135
! #define KEY_no 136
! #define KEY_not 137
! #define KEY_oct 138
! #define KEY_open 139
! #define KEY_opendir 140
! #define KEY_or 141
! #define KEY_ord 142
! #define KEY_our 143
! #define KEY_pack 144
! #define KEY_package 145
! #define KEY_pipe 146
! #define KEY_pop 147
! #define KEY_pos 148
! #define KEY_print 149
! #define KEY_printf 150
! #define KEY_prototype 151
! #define KEY_push 152
! #define KEY_q 153
! #define KEY_qq 154
! #define KEY_qr 155
! #define KEY_quotemeta 156
! #define KEY_qu 157
! #define KEY_qw 158
! #define KEY_qx 159
! #define KEY_rand 160
! #define KEY_read 161
! #define KEY_readdir 162
! #define KEY_readline 163
! #define KEY_readlink 164
! #define KEY_readpipe 165
! #define KEY_recv 166
! #define KEY_redo 167
! #define KEY_ref 168
! #define KEY_rename 169
! #define KEY_require 170
! #define KEY_reset 171
! #define KEY_return 172
! #define KEY_reverse 173
! #define KEY_rewinddir 174
! #define KEY_rindex 175
! #define KEY_rmdir 176
! #define KEY_s 177
! #define KEY_scalar 178
! #define KEY_seek 179
! #define KEY_seekdir 180
! #define KEY_select 181
! #define KEY_semctl 182
! #define KEY_semget 183
! #define KEY_semop 184
! #define KEY_send 185
! #define KEY_setgrent 186
! #define KEY_sethostent 187
! #define KEY_setnetent 188
! #define KEY_setpgrp 189
! #define KEY_setpriority 190
! #define KEY_setprotoent 191
! #define KEY_setpwent 192
! #define KEY_setservent 193
! #define KEY_setsockopt 194
! #define KEY_shift 195
! #define KEY_shmctl 196
! #define KEY_shmget 197
! #define KEY_shmread 198
! #define KEY_shmwrite 199
! #define KEY_shutdown 200
! #define KEY_sin 201
! #define KEY_sleep 202
! #define KEY_socket 203
! #define KEY_socketpair 204
! #define KEY_sort 205
! #define KEY_splice 206
! #define KEY_split 207
! #define KEY_sprintf 208
! #define KEY_sqrt 209
! #define KEY_srand 210
! #define KEY_stat 211
! #define KEY_study 212
! #define KEY_sub 213
! #define KEY_substr 214
! #define KEY_symlink 215
! #define KEY_syscall 216
! #define KEY_sysopen 217
! #define KEY_sysread 218
! #define KEY_sysseek 219
! #define KEY_system 220
! #define KEY_syswrite 221
! #define KEY_tell 222
! #define KEY_telldir 223
! #define KEY_tie 224
! #define KEY_tied 225
! #define KEY_time 226
! #define KEY_times 227
! #define KEY_tr 228
! #define KEY_truncate 229
! #define KEY_uc 230
! #define KEY_ucfirst 231
! #define KEY_umask 232
! #define KEY_undef 233
! #define KEY_unless 234
! #define KEY_unlink 235
! #define KEY_unpack 236
! #define KEY_unshift 237
! #define KEY_untie 238
! #define KEY_until 239
! #define KEY_use 240
! #define KEY_utime 241
! #define KEY_values 242
! #define KEY_vec 243
! #define KEY_wait 244
! #define KEY_waitpid 245
! #define KEY_wantarray 246
! #define KEY_warn 247
! #define KEY_while 248
! #define KEY_write 249
! #define KEY_x 250
! #define KEY_xor 251
! #define KEY_y 252
--- 9,247 ----
#define KEY_CORE 8
#define KEY_DESTROY 9
#define KEY_END 10
! #define KEY_INIT 11
! #define KEY_CHECK 12
! #define KEY_abs 13
! #define KEY_accept 14
! #define KEY_alarm 15
! #define KEY_and 16
! #define KEY_atan2 17
! #define KEY_bind 18
! #define KEY_binmode 19
! #define KEY_bless 20
! #define KEY_caller 21
! #define KEY_chdir 22
! #define KEY_chmod 23
! #define KEY_chomp 24
! #define KEY_chop 25
! #define KEY_chown 26
! #define KEY_chr 27
! #define KEY_chroot 28
! #define KEY_close 29
! #define KEY_closedir 30
! #define KEY_cmp 31
! #define KEY_connect 32
! #define KEY_continue 33
! #define KEY_cos 34
! #define KEY_crypt 35
! #define KEY_dbmclose 36
! #define KEY_dbmopen 37
! #define KEY_defined 38
! #define KEY_delete 39
! #define KEY_die 40
! #define KEY_do 41
! #define KEY_dump 42
! #define KEY_each 43
! #define KEY_else 44
! #define KEY_elsif 45
! #define KEY_endgrent 46
! #define KEY_endhostent 47
! #define KEY_endnetent 48
! #define KEY_endprotoent 49
! #define KEY_endpwent 50
! #define KEY_endservent 51
! #define KEY_eof 52
! #define KEY_eq 53
! #define KEY_eval 54
! #define KEY_exec 55
! #define KEY_exists 56
! #define KEY_exit 57
! #define KEY_exp 58
! #define KEY_fcntl 59
! #define KEY_fileno 60
! #define KEY_flock 61
! #define KEY_for 62
! #define KEY_foreach 63
! #define KEY_fork 64
! #define KEY_format 65
! #define KEY_formline 66
! #define KEY_ge 67
! #define KEY_getc 68
! #define KEY_getgrent 69
! #define KEY_getgrgid 70
! #define KEY_getgrnam 71
! #define KEY_gethostbyaddr 72
! #define KEY_gethostbyname 73
! #define KEY_gethostent 74
! #define KEY_getlogin 75
! #define KEY_getnetbyaddr 76
! #define KEY_getnetbyname 77
! #define KEY_getnetent 78
! #define KEY_getpeername 79
! #define KEY_getpgrp 80
! #define KEY_getppid 81
! #define KEY_getpriority 82
! #define KEY_getprotobyname 83
! #define KEY_getprotobynumber 84
! #define KEY_getprotoent 85
! #define KEY_getpwent 86
! #define KEY_getpwnam 87
! #define KEY_getpwuid 88
! #define KEY_getservbyname 89
! #define KEY_getservbyport 90
! #define KEY_getservent 91
! #define KEY_getsockname 92
! #define KEY_getsockopt 93
! #define KEY_glob 94
! #define KEY_gmtime 95
! #define KEY_goto 96
! #define KEY_grep 97
! #define KEY_gt 98
! #define KEY_hex 99
! #define KEY_if 100
! #define KEY_index 101
! #define KEY_int 102
! #define KEY_ioctl 103
! #define KEY_join 104
! #define KEY_keys 105
! #define KEY_kill 106
! #define KEY_last 107
! #define KEY_lc 108
! #define KEY_lcfirst 109
! #define KEY_le 110
! #define KEY_length 111
! #define KEY_link 112
! #define KEY_listen 113
! #define KEY_local 114
! #define KEY_localtime 115
! #define KEY_lock 116
! #define KEY_log 117
! #define KEY_lstat 118
! #define KEY_lt 119
! #define KEY_m 120
! #define KEY_map 121
! #define KEY_mkdir 122
! #define KEY_msgctl 123
! #define KEY_msgget 124
! #define KEY_msgrcv 125
! #define KEY_msgsnd 126
! #define KEY_my 127
! #define KEY_ne 128
! #define KEY_next 129
! #define KEY_no 130
! #define KEY_not 131
! #define KEY_oct 132
! #define KEY_open 133
! #define KEY_opendir 134
! #define KEY_or 135
! #define KEY_ord 136
! #define KEY_our 137
! #define KEY_pack 138
! #define KEY_package 139
! #define KEY_pipe 140
! #define KEY_pop 141
! #define KEY_pos 142
! #define KEY_print 143
! #define KEY_printf 144
! #define KEY_prototype 145
! #define KEY_push 146
! #define KEY_q 147
! #define KEY_qq 148
! #define KEY_qr 149
! #define KEY_quotemeta 150
! #define KEY_qu 151
! #define KEY_qw 152
! #define KEY_qx 153
! #define KEY_rand 154
! #define KEY_read 155
! #define KEY_readdir 156
! #define KEY_readline 157
! #define KEY_readlink 158
! #define KEY_readpipe 159
! #define KEY_recv 160
! #define KEY_redo 161
! #define KEY_ref 162
! #define KEY_rename 163
! #define KEY_require 164
! #define KEY_reset 165
! #define KEY_return 166
! #define KEY_reverse 167
! #define KEY_rewinddir 168
! #define KEY_rindex 169
! #define KEY_rmdir 170
! #define KEY_s 171
! #define KEY_scalar 172
! #define KEY_seek 173
! #define KEY_seekdir 174
! #define KEY_select 175
! #define KEY_semctl 176
! #define KEY_semget 177
! #define KEY_semop 178
! #define KEY_send 179
! #define KEY_setgrent 180
! #define KEY_sethostent 181
! #define KEY_setnetent 182
! #define KEY_setpgrp 183
! #define KEY_setpriority 184
! #define KEY_setprotoent 185
! #define KEY_setpwent 186
! #define KEY_setservent 187
! #define KEY_setsockopt 188
! #define KEY_shift 189
! #define KEY_shmctl 190
! #define KEY_shmget 191
! #define KEY_shmread 192
! #define KEY_shmwrite 193
! #define KEY_shutdown 194
! #define KEY_sin 195
! #define KEY_sleep 196
! #define KEY_socket 197
! #define KEY_socketpair 198
! #define KEY_sort 199
! #define KEY_splice 200
! #define KEY_split 201
! #define KEY_sprintf 202
! #define KEY_sqrt 203
! #define KEY_srand 204
! #define KEY_stat 205
! #define KEY_study 206
! #define KEY_sub 207
! #define KEY_substr 208
! #define KEY_symlink 209
! #define KEY_syscall 210
! #define KEY_sysopen 211
! #define KEY_sysread 212
! #define KEY_sysseek 213
! #define KEY_system 214
! #define KEY_syswrite 215
! #define KEY_tell 216
! #define KEY_telldir 217
! #define KEY_tie 218
! #define KEY_tied 219
! #define KEY_time 220
! #define KEY_times 221
! #define KEY_tr 222
! #define KEY_truncate 223
! #define KEY_uc 224
! #define KEY_ucfirst 225
! #define KEY_umask 226
! #define KEY_undef 227
! #define KEY_unless 228
! #define KEY_unlink 229
! #define KEY_unpack 230
! #define KEY_unshift 231
! #define KEY_untie 232
! #define KEY_until 233
! #define KEY_use 234
! #define KEY_utime 235
! #define KEY_values 236
! #define KEY_vec 237
! #define KEY_wait 238
! #define KEY_waitpid 239
! #define KEY_wantarray 240
! #define KEY_warn 241
! #define KEY_while 242
! #define KEY_write 243
! #define KEY_x 244
! #define KEY_xor 245
! #define KEY_y 246
diff -c 'perl-5.7.1/keywords.pl' 'perl-5.7.2/keywords.pl'
Index: ./keywords.pl
*** ./keywords.pl Tue Mar 6 04:05:21 2001
--- ./keywords.pl Mon Jul 9 17:10:24 2001
***************
*** 35,47 ****
CORE
DESTROY
END
- EQ
- GE
- GT
INIT
- LE
- LT
- NE
CHECK
abs
accept
--- 35,41 ----
diff -c /dev/null 'perl-5.7.2/lib/AnyDBM_File.t'
Index: ./lib/AnyDBM_File.t
*** ./lib/AnyDBM_File.t Thu Jan 1 02:00:00 1970
--- ./lib/AnyDBM_File.t Mon Jul 9 17:10:24 2001
***************
*** 0 ****
--- 1,157 ----
+ #!./perl
+
+ # $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if (($Config{'extensions'} !~ /\b(DB|[A-Z]DBM)_File\b/) ){
+ print "1..0 # Skipping (no DB_File or [A-Z]DBM_File)\n";
+ exit 0;
+ }
+ }
+ require AnyDBM_File;
+ use Fcntl;
+
+ print "1..12\n";
+
+ $Is_Dosish = ($^O eq 'amigaos' || $^O eq 'MSWin32' ||
+ $^O eq 'NetWare' || $^O eq 'dos' ||
+ $^O eq 'os2' || $^O eq 'mint' ||
+ $^O eq 'cygwin');
+
+ unlink <Op_dbmx*>;
+
+ umask(0);
+ print (tie(%h,AnyDBM_File,'Op_dbmx', O_RDWR|O_CREAT, 0640)
+ ? "ok 1\n" : "not ok 1\n");
+
+ $Dfile = "Op_dbmx.pag";
+ if (! -e $Dfile) {
+ ($Dfile) = <Op_dbmx*>;
+ }
+ if ($Is_Dosish || $^O eq 'MacOS') {
+ print "ok 2 # Skipped: different file permission semantics\n";
+ }
+ else {
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
+ }
+ while (($key,$value) = each(%h)) {
+ $i++;
+ }
+ print (!$i ? "ok 3\n" : "not ok 3 # i=$i\n\n");
+
+ $h{'goner1'} = 'snork';
+
+ $h{'abc'} = 'ABC';
+ $h{'def'} = 'DEF';
+ $h{'jkl','mno'} = "JKL\034MNO";
+ $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+ $h{'a'} = 'A';
+ $h{'b'} = 'B';
+ $h{'c'} = 'C';
+ $h{'d'} = 'D';
+ $h{'e'} = 'E';
+ $h{'f'} = 'F';
+ $h{'g'} = 'G';
+ $h{'h'} = 'H';
+ $h{'i'} = 'I';
+
+ $h{'goner2'} = 'snork';
+ delete $h{'goner2'};
+
+ untie(%h);
+ print (tie(%h,AnyDBM_File,'Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n");
+
+ $h{'j'} = 'J';
+ $h{'k'} = 'K';
+ $h{'l'} = 'L';
+ $h{'m'} = 'M';
+ $h{'n'} = 'N';
+ $h{'o'} = 'O';
+ $h{'p'} = 'P';
+ $h{'q'} = 'Q';
+ $h{'r'} = 'R';
+ $h{'s'} = 'S';
+ $h{'t'} = 'T';
+ $h{'u'} = 'U';
+ $h{'v'} = 'V';
+ $h{'w'} = 'W';
+ $h{'x'} = 'X';
+ $h{'y'} = 'Y';
+ $h{'z'} = 'Z';
+
+ $h{'goner3'} = 'snork';
+
+ delete $h{'goner1'};
+ delete $h{'goner3'};
+
+ @keys = keys(%h);
+ @values = values(%h);
+
+ if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
+
+ while (($key,$value) = each(%h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+ }
+
+ if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
+
+ @keys = ('blurfl', keys(%h), 'dyick');
+ if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
+
+ $h{'foo'} = '';
+ $h{''} = 'bar';
+
+ # check cache overflow and numeric keys and contents
+ $ok = 1;
+ for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+ for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+ print ($ok ? "ok 8\n" : "not ok 8\n");
+
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ print ($size > 0 ? "ok 9\n" : "not ok 9\n");
+
+ @h{0..200} = 200..400;
+ @foo = @h{0..200};
+ print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";
+
+ print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
+ if ($h{''} eq 'bar') {
+ print "ok 12\n" ;
+ }
+ else {
+ if ($AnyDBM_File::ISA[0] eq 'DB_File' && $DB_File::db_ver >= 2.004010) {
+ ($major, $minor, $patch) = ($DB_File::db_ver =~ /^(\d+)\.(\d\d\d)(\d\d\d)/) ;
+ $major =~ s/^0+// ;
+ $minor =~ s/^0+// ;
+ $patch =~ s/^0+// ;
+ $compact = "$major.$minor.$patch" ;
+ #
+ # anydbm.t test 12 will fail when AnyDBM_File uses the combination of
+ # DB_File and Berkeley DB 2.4.10 (or greater).
+ # You are using DB_File $DB_File::VERSION and Berkeley DB $compact
+ #
+ # Berkeley DB 2 from version 2.4.10 onwards does not allow null keys.
+ # This feature will be reenabled in a future version of Berkeley DB.
+ #
+ print "ok 12 # skipped: db v$compact, no null key support\n" ;
+ }
+ else {
+ print "not ok 12\n" ;
+ }
+ }
+
+ untie %h;
+ if ($^O eq 'VMS') {
+ unlink 'Op_dbmx.sdbm_dir', $Dfile;
+ } else {
+ unlink 'Op_dbmx.dir', $Dfile;
+ }
diff -c /dev/null 'perl-5.7.2/lib/Attribute/Handlers.pm'
Index: ./lib/Attribute/Handlers.pm
*** ./lib/Attribute/Handlers.pm Thu Jan 1 02:00:00 1970
--- ./lib/Attribute/Handlers.pm Mon Jul 9 17:10:24 2001
***************
*** 0 ****
--- 1,756 ----
+ package Attribute::Handlers;
+ use 5.006;
+ use Carp;
+ use warnings;
+ $VERSION = '0.70';
+ $DB::single=1;
+
+ my %symcache;
+ sub findsym {
+ my ($pkg, $ref, $type) = @_;
+ return $symcache{$pkg,$ref} if $symcache{$pkg,$ref};
+ $type ||= ref($ref);
+ my $found;
+ foreach my $sym ( values %{$pkg."::"} ) {
+ return $symcache{$pkg,$ref} = \$sym
+ if *{$sym}{$type} && *{$sym}{$type} == $ref;
+ }
+ }
+
+ my %validtype = (
+ VAR => [qw[SCALAR ARRAY HASH]],
+ ANY => [qw[SCALAR ARRAY HASH CODE]],
+ "" => [qw[SCALAR ARRAY HASH CODE]],
+ SCALAR => [qw[SCALAR]],
+ ARRAY => [qw[ARRAY]],
+ HASH => [qw[HASH]],
+ CODE => [qw[CODE]],
+ );
+ my %lastattr;
+ my @declarations;
+ my %raw;
+ my %phase;
+ my %sigil = (SCALAR=>'$', ARRAY=>'@', HASH=>'%');
+
+ sub _usage_AH_ {
+ croak "Usage: use $_[0] autotie => {AttrName => TieClassName,...}";
+ }
+
+ sub import {
+ my $class = shift @_;
+ return unless $class eq "Attribute::Handlers";
+ while (@_) {
+ my $cmd = shift;
+ if ($cmd eq 'autotie') {
+ my $mapping = shift;
+ _usage_AH_ $class unless ref($mapping) eq 'HASH';
+ while (my($attr, $tieclass) = each %$mapping) {
+ $tieclass =~ s/^([_a-z]\w*(::[_a-z]\w*))(.*)/$1/is;
+ my $args = $3||'()';
+ usage $class unless $attr =~ m/^[_a-z]\w*(::[_a-z]\w*)*$/i
+ && $tieclass =~ m/^[_a-z]\w*(::[_a-z]\w*)/i
+ && eval "use base $tieclass; 1";
+ if ($tieclass->isa('Exporter')) {
+ local $Exporter::ExportLevel = 2;
+ $tieclass->import(eval $args);
+ }
+ $attr =~ s/__CALLER__/caller(1)/e;
+ $attr = caller()."::".$attr unless $attr =~ /::/;
+ eval qq{
+ sub $attr : ATTR(VAR) {
+ my (\$ref, \$data) = \@_[2,4];
+ \$data = [ \$data ] unless ref \$data eq 'ARRAY';
+ # print \$ref, ": ";
+ # use Data::Dumper 'Dumper';
+ # print Dumper [ [\$ref, \$data] ];
+ my \$type = ref(\$ref)||"value (".(\$ref||"<undef>").")";
+ (\$type eq 'SCALAR')? tie \$\$ref,'$tieclass',\@\$data
+ :(\$type eq 'ARRAY') ? tie \@\$ref,'$tieclass',\@\$data
+ :(\$type eq 'HASH') ? tie \%\$ref,'$tieclass',\@\$data
+ : die "Can't autotie a \$type\n"
+ } 1
+ } or die "Internal error: $@";
+ }
+ }
+ else {
+ croak "Can't understand $_";
+ }
+ }
+ }
+ sub _resolve_lastattr {
+ return unless $lastattr{ref};
+ my $sym = findsym @lastattr{'pkg','ref'}
+ or die "Internal error: $lastattr{pkg} symbol went missing";
+ my $name = *{$sym}{NAME};
+ warn "Declaration of $name attribute in package $lastattr{pkg} may clash with future reserved word\n"
+ if $^W and $name !~ /[A-Z]/;
+ foreach ( @{$validtype{$lastattr{type}}} ) {
+ *{"$lastattr{pkg}::_ATTR_${_}_${name}"} = $lastattr{ref};
+ }
+ %lastattr = ();
+ }
+
+ sub AUTOLOAD {
+ my ($class) = @_;
+ $AUTOLOAD =~ /_ATTR_(.*?)_(.*)/ or
+ croak "Can't locate class method '$AUTOLOAD' via package '$class'";
+ croak "Attribute handler '$2' doesn't handle $1 attributes";
+ }
+
+ sub DESTROY {}
+
+ my $builtin = qr/lvalue|method|locked/;
+
+ sub _gen_handler_AH_() {
+ return sub {
+ _resolve_lastattr;
+ my ($pkg, $ref, @attrs) = @_;
+ foreach (@attrs) {
+ my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/i or next;
+ if ($attr eq 'ATTR') {
+ $data ||= "ANY";
+ $raw{$ref} = $data =~ s/\s*,?\s*RAWDATA\s*,?\s*//;
+ $phase{$ref}{BEGIN} = 1
+ if $data =~ s/\s*,?\s*(BEGIN)\s*,?\s*//;
+ $phase{$ref}{INIT} = 1
+ if $data =~ s/\s*,?\s*(INIT)\s*,?\s*//;
+ $phase{$ref}{END} = 1
+ if $data =~ s/\s*,?\s*(END)\s*,?\s*//;
+ $phase{$ref}{CHECK} = 1
+ if $data =~ s/\s*,?\s*(CHECK)\s*,?\s*//
+ || ! keys %{$phase{$ref}};
+ croak "Can't have two ATTR specifiers on one subroutine"
+ if keys %lastattr;
+ croak "Bad attribute type: ATTR($data)"
+ unless $validtype{$data};
+ %lastattr=(pkg=>$pkg,ref=>$ref,type=>$data);
+ }
+ else {
+ my $handler = $pkg->can($attr);
+ next unless $handler;
+ my $decl = [$pkg, $ref, $attr, $data,
+ $raw{$handler}, $phase{$handler}];
+ _apply_handler_AH_($decl,'BEGIN');
+ push @declarations, $decl;
+ }
+ $_ = undef;
+ }
+ return grep {defined && !/$builtin/} @attrs;
+ }
+ }
+
+ *{"MODIFY_${_}_ATTRIBUTES"} = _gen_handler_AH_ foreach @{$validtype{ANY}};
+ push @UNIVERSAL::ISA, 'Attribute::Handlers'
+ unless grep /^Attribute::Handlers$/, @UNIVERSAL::ISA;
+
+ sub _apply_handler_AH_ {
+ my ($declaration, $phase) = @_;
+ my ($pkg, $ref, $attr, $data, $raw, $handlerphase) = @$declaration;
+ return unless $handlerphase->{$phase};
+ # print STDERR "Handling $attr on $ref in $phase with [$data]\n";
+ my $type = ref $ref;
+ my $handler = "_ATTR_${type}_${attr}";
+ my $sym = findsym($pkg, $ref);
+ $sym ||= $type eq 'CODE' ? 'ANON' : 'LEXICAL';
+ no warnings;
+ my $evaled = !$raw && eval("package $pkg; no warnings;
+ local \$SIG{__WARN__}=sub{die}; [$data]");
+ $data = ($evaled && $data =~ /^\s*\[/) ? [$evaled]
+ : ($evaled) ? $evaled
+ : [$data];
+ $pkg->$handler($sym,
+ (ref $sym eq 'GLOB' ? *{$sym}{ref $ref}||$ref : $ref),
+ $attr,
+ (@$data>1? $data : $data->[0]),
+ $phase,
+ );
+ return 1;
+ }
+
+ CHECK {
+ _resolve_lastattr;
+ _apply_handler_AH_($_,'CHECK') foreach @declarations;
+ }
+
+ INIT { _apply_handler_AH_($_,'INIT') foreach @declarations }
+
+ END { _apply_handler_AH_($_,'END') foreach @declarations }
+
+ 1;
+ __END__
+
+ =head1 NAME
+
+ Attribute::Handlers - Simpler definition of attribute handlers
+
+ =head1 VERSION
+
+ This document describes version 0.70 of Attribute::Handlers,
+ released June 3, 2001.
+
+ =head1 SYNOPSIS
+
+ package MyClass;
+ require v5.6.0;
+ use Attribute::Handlers;
+ no warnings 'redefine';
+
+
+ sub Good : ATTR(SCALAR) {
+ my ($package, $symbol, $referent, $attr, $data) = @_;
+
+ # Invoked for any scalar variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+
+ # Do whatever to $referent here (executed in CHECK phase).
+ ...
+ }
+
+ sub Bad : ATTR(SCALAR) {
+ # Invoked for any scalar variable with a :Bad attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ ...
+ }
+
+ sub Good : ATTR(ARRAY) {
+ # Invoked for any array variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ ...
+ }
+
+ sub Good : ATTR(HASH) {
+ # Invoked for any hash variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ ...
+ }
+
+ sub Ugly : ATTR(CODE) {
+ # Invoked for any subroutine declared in MyClass (or a
+ # derived class) with an :Ugly attribute.
+ ...
+ }
+
+ sub Omni : ATTR {
+ # Invoked for any scalar, array, hash, or subroutine
+ # with an :Omni attribute, provided the variable or
+ # subroutine was declared in MyClass (or a derived class)
+ # or the variable was typed to MyClass.
+ # Use ref($_[2]) to determine what kind of referent it was.
+ ...
+ }
+
+
+ use Attribute::Handlers autotie => { Cycle => Tie::Cycle };
+
+ my $next : Cycle(['A'..'Z']);
+
+
+ =head1 DESCRIPTION
+
+ This module, when inherited by a package, allows that package's class to
+ define attribute handler subroutines for specific attributes. Variables
+ and subroutines subsequently defined in that package, or in packages
+ derived from that package may be given attributes with the same names as
+ the attribute handler subroutines, which will then be called in one of
+ the compilation phases (i.e. in a C<BEGIN>, C<CHECK>, C<INIT>, or C<END>
+ block).
+
+ To create a handler, define it as a subroutine with the same name as
+ the desired attribute, and declare the subroutine itself with the
+ attribute C<:ATTR>. For example:
+
+ package LoudDecl;
+ use Attribute::Handlers;
+
+ sub Loud :ATTR {
+ my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
+ print STDERR
+ ref($referent), " ",
+ *{$symbol}{NAME}, " ",
+ "($referent) ", "was just declared ",
+ "and ascribed the ${attr} attribute ",
+ "with data ($data)\n",
+ "in phase $phase\n";
+ }
+
+ This creates an handler for the attribute C<:Loud> in the class LoudDecl.
+ Thereafter, any subroutine declared with a C<:Loud> attribute in the class
+ LoudDecl:
+
+ package LoudDecl;
+
+ sub foo: Loud {...}
+
+ causes the above handler to be invoked, and passed:
+
+ =over
+
+ =item [0]
+
+ the name of the package into which it was declared;
+
+ =item [1]
+
+ a reference to the symbol table entry (typeglob) containing the subroutine;
+
+ =item [2]
+
+ a reference to the subroutine;
+
+ =item [3]
+
+ the name of the attribute;
+
+ =item [4]
+
+ any data associated with that attribute;
+
+ =item [5]
+
+ the name of the phase in which the handler is being invoked.
+
+ =back
+
+ Likewise, declaring any variables with the C<:Loud> attribute within the
+ package:
+
+ package LoudDecl;
+
+ my $foo :Loud;
+ my @foo :Loud;
+ my %foo :Loud;
+
+ will cause the handler to be called with a similar argument list (except,
+ of course, that C<$_[2]> will be a reference to the variable).
+
+ The package name argument will typically be the name of the class into
+ which the subroutine was declared, but it may also be the name of a derived
+ class (since handlers are inherited).
+
+ If a lexical variable is given an attribute, there is no symbol table to
+ which it belongs, so the symbol table argument (C<$_[1]>) is set to the
+ string C<'LEXICAL'> in that case. Likewise, ascribing an attribute to
+ an anonymous subroutine results in a symbol table argument of C<'ANON'>.
+
+ The data argument passes in the value (if any) associated with the
+ attribute. For example, if C<&foo> had been declared:
+
+ sub foo :Loud("turn it up to 11, man!") {...}
+
+ then the string C<"turn it up to 11, man!"> would be passed as the
+ last argument.
+
+ Attribute::Handlers makes strenuous efforts to convert
+ the data argument (C<$_[4]>) to a useable form before passing it to
+ the handler (but see L<"Non-interpretive attribute handlers">).
+ For example, all of these:
+
+ sub foo :Loud(till=>ears=>are=>bleeding) {...}
+ sub foo :Loud(['till','ears','are','bleeding']) {...}
+ sub foo :Loud(qw/till ears are bleeding/) {...}
+ sub foo :Loud(qw/my, ears, are, bleeding/) {...}
+ sub foo :Loud(till,ears,are,bleeding) {...}
+
+ causes it to pass C<['till','ears','are','bleeding']> as the handler's
+ data argument. However, if the data can't be parsed as valid Perl, then
+ it is passed as an uninterpreted string. For example:
+
+ sub foo :Loud(my,ears,are,bleeding) {...}
+ sub foo :Loud(qw/my ears are bleeding) {...}
+
+ cause the strings C<'my,ears,are,bleeding'> and C<'qw/my ears are bleeding'>
+ respectively to be passed as the data argument.
+
+ If the attribute has only a single associated scalar data value, that value is
+ passed as a scalar. If multiple values are associated, they are passed as an
+ array reference. If no value is associated with the attribute, C<undef> is
+ passed.
+
+
+ =head2 Typed lexicals
+
+ Regardless of the package in which it is declared, if a lexical variable is
+ ascribed an attribute, the handler that is invoked is the one belonging to
+ the package to which it is typed. For example, the following declarations:
+
+ package OtherClass;
+
+ my LoudDecl $loudobj : Loud;
+ my LoudDecl @loudobjs : Loud;
+ my LoudDecl %loudobjex : Loud;
+
+ causes the LoudDecl::Loud handler to be invoked (even if OtherClass also
+ defines a handler for C<:Loud> attributes).
+
+
+ =head2 Type-specific attribute handlers
+
+ If an attribute handler is declared and the C<:ATTR> specifier is
+ given the name of a built-in type (C<SCALAR>, C<ARRAY>, C<HASH>, or C<CODE>),
+ the handler is only applied to declarations of that type. For example,
+ the following definition:
+
+ package LoudDecl;
+
+ sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
+
+ creates an attribute handler that applies only to scalars:
+
+
+ package Painful;
+ use base LoudDecl;
+
+ my $metal : RealLoud; # invokes &LoudDecl::RealLoud
+ my @metal : RealLoud; # error: unknown attribute
+ my %metal : RealLoud; # error: unknown attribute
+ sub metal : RealLoud {...} # error: unknown attribute
+
+ You can, of course, declare separate handlers for these types as well
+ (but you'll need to specify C<no warnings 'redefine'> to do it quietly):
+
+ package LoudDecl;
+ use Attribute::Handlers;
+ no warnings 'redefine';
+
+ sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
+ sub RealLoud :ATTR(ARRAY) { print "Urrrrrrrrrr!" }
+ sub RealLoud :ATTR(HASH) { print "Arrrrrgggghhhhhh!" }
+ sub RealLoud :ATTR(CODE) { croak "Real loud sub torpedoed" }
+
+ You can also explicitly indicate that a single handler is meant to be
+ used for all types of referents like so:
+
+ package LoudDecl;
+ use Attribute::Handlers;
+
+ sub SeriousLoud :ATTR(ANY) { warn "Hearing loss imminent" }
+
+ (I.e. C<ATTR(ANY)> is a synonym for C<:ATTR>).
+
+
+ =head2 Non-interpretive attribute handlers
+
+ Occasionally the strenuous efforts Attribute::Handlers makes to convert
+ the data argument (C<$_[4]>) to a useable form before passing it to
+ the handler get in the way.
+
+ You can turn off that eagerness-to-help by declaring
+ an attribute handler with the the keyword C<RAWDATA>. For example:
+
+ sub Raw : ATTR(RAWDATA) {...}
+ sub Nekkid : ATTR(SCALAR,RAWDATA) {...}
+ sub Au::Naturale : ATTR(RAWDATA,ANY) {...}
+
+ Then the handler makes absolutely no attempt to interpret the data it
+ receives and simply passes it as a string:
+
+ my $power : Raw(1..100); # handlers receives "1..100"
+
+ =head2 Phase-specific attribute handlers
+
+ By default, attribute handlers are called at the end of the compilation
+ phase (in a C<CHECK> block). This seems to be optimal in most cases because
+ most things that can be defined are defined by that point but nothing has
+ been executed.
+
+ However, it is possible to set up attribute handlers that are called at
+ other points in the program's compilation or execution, by explicitly
+ stating the phase (or phases) in which you wish the attribute handler to
+ be called. For example:
+
+ sub Early :ATTR(SCALAR,BEGIN) {...}
+ sub Normal :ATTR(SCALAR,CHECK) {...}
+ sub Late :ATTR(SCALAR,INIT) {...}
+ sub Final :ATTR(SCALAR,END) {...}
+ sub Bookends :ATTR(SCALAR,BEGIN,END) {...}
+
+ As the last example indicates, a handler may be set up to be (re)called in
+ two or more phases. The phase name is passed as the handler's final argument.
+
+ Note that attribute handlers that are scheduled for the C<BEGIN> phase
+ are handled as soon as the attribute is detected (i.e. before any
+ subsequently defined C<BEGIN> blocks are executed).
+
+
+ =head2 Attributes as C<tie> interfaces
+
+ Attributes make an excellent and intuitive interface through which to tie
+ variables. For example:
+
+ use Attribute::Handlers;
+ use Tie::Cycle;
+
+ sub UNIVERSAL::Cycle : ATTR(SCALAR) {
+ my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
+ $data = [ $data ] unless ref $data eq 'ARRAY';
+ tie $$referent, 'Tie::Cycle', $data;
+ }
+
+ # and thereafter...
+
+ package main;
+
+ my $next : Cycle('A'..'Z'); # $next is now a tied variable
+
+ while (<>) {
+ print $next;
+ }
+
+ In fact, this pattern is so widely applicable that Attribute::Handlers
+ provides a way to automate it: specifying C<'autotie'> in the
+ C<use Attribute::Handlers> statement. So, the previous example,
+ could also be written:
+
+ use Attribute::Handlers autotie => { Cycle => 'Tie::Cycle' };
+
+ # and thereafter...
+
+ package main;
+
+ my $next : Cycle('A'..'Z'); # $next is now a tied variable
+
+ while (<>) {
+ print $next;
+
+ The argument after C<'autotie'> is a reference to a hash in which each key is
+ the name of an attribute to be created, and each value is the class to which
+ variables ascribed that attribute should be tied.
+
+ Note that there is no longer any need to import the Tie::Cycle module --
+ Attribute::Handlers takes care of that automagically. You can even pass
+ arguments to the module's C<import> subroutine, by appending them to the
+ class name. For example:
+
+ use Attribute::Handlers
+ autotie => { Dir => 'Tie::Dir qw(DIR_UNLINK)' };
+
+ If the attribute name is unqualified, the attribute is installed in the
+ current package. Otherwise it is installed in the qualifier's package:
+
+ package Here;
+
+ use Attribute::Handlers autotie => {
+ Other::Good => Tie::SecureHash, # tie attr installed in Other::
+ Bad => Tie::Taxes, # tie attr installed in Here::
+ UNIVERSAL::Ugly => Software::Patent # tie attr installed everywhere
+ };
+
+ Autoties are most commonly used in the module to which they actually tie,
+ and need to export their attributes to any module that calls them. To
+ facilitiate this, Attribute::Handlers recognizes a special "pseudo-class" --
+ C<__CALLER__>, which may be specified as the qualifier of an attribute:
+
+ package Tie::Me::Kangaroo:Down::Sport;
+
+ use Attribute::Handler autotie => { __CALLER__::Roo => __PACKAGE__ };
+
+ This causes Attribute::Handlers to define the C<Roo> attribute in the package
+ that imports the Tie::Me::Kangaroo:Down::Sport module.
+
+
+ =head1 EXAMPLES
+
+ If the class shown in L<SYNOPSIS> were placed in the MyClass.pm
+ module, then the following code:
+
+ package main;
+ use MyClass;
+
+ my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
+
+ package SomeOtherClass;
+ use base MyClass;
+
+ sub tent { 'acle' }
+
+ sub fn :Ugly(sister) :Omni('po',tent()) {...}
+ my @arr :Good :Omni(s/cie/nt/);
+ my %hsh :Good(q/bye) :Omni(q/bus/);
+
+
+ would cause the following handlers to be invoked:
+
+ # my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
+
+ MyClass::Good:ATTR(SCALAR)( 'MyClass', # class
+ 'LEXICAL', # no typeglob
+ \$slr, # referent
+ 'Good', # attr name
+ undef # no attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Bad:ATTR(SCALAR)( 'MyClass', # class
+ 'LEXICAL', # no typeglob
+ \$slr, # referent
+ 'Bad', # attr name
+ 0 # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(SCALAR)( 'MyClass', # class
+ 'LEXICAL', # no typeglob
+ \$slr, # referent
+ 'Omni', # attr name
+ '-vorous' # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+
+ # sub fn :Ugly(sister) :Omni('po',tent()) {...}
+
+ MyClass::UGLY:ATTR(CODE)( 'SomeOtherClass', # class
+ \*SomeOtherClass::fn, # typeglob
+ \&SomeOtherClass::fn, # referent
+ 'Ugly', # attr name
+ 'sister' # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(CODE)( 'SomeOtherClass', # class
+ \*SomeOtherClass::fn, # typeglob
+ \&SomeOtherClass::fn, # referent
+ 'Omni', # attr name
+ ['po','acle'] # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+
+ # my @arr :Good :Omni(s/cie/nt/);
+
+ MyClass::Good:ATTR(ARRAY)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \@arr, # referent
+ 'Good', # attr name
+ undef # no attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(ARRAY)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \@arr, # referent
+ 'Omni', # attr name
+ "" # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+
+ # my %hsh :Good(q/bye) :Omni(q/bus/);
+
+ MyClass::Good:ATTR(HASH)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \%hsh, # referent
+ 'Good', # attr name
+ 'q/bye' # raw attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(HASH)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \%hsh, # referent
+ 'Omni', # attr name
+ 'bus' # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+
+ Installing handlers into UNIVERSAL, makes them...err..universal.
+ For example:
+
+ package Descriptions;
+ use Attribute::Handlers;
+
+ my %name;
+ sub name { return $name{$_[2]}||*{$_[1]}{NAME} }
+
+ sub UNIVERSAL::Name :ATTR {
+ $name{$_[2]} = $_[4];
+ }
+
+ sub UNIVERSAL::Purpose :ATTR {
+ print STDERR "Purpose of ", &name, " is $_[4]\n";
+ }
+
+ sub UNIVERSAL::Unit :ATTR {
+ print STDERR &name, " measured in $_[4]\n";
+ }
+
+ Let's you write:
+
+ use Descriptions;
+
+ my $capacity : Name(capacity)
+ : Purpose(to store max storage capacity for files)
+ : Unit(Gb);
+
+
+ package Other;
+
+ sub foo : Purpose(to foo all data before barring it) { }
+
+ # etc.
+
+
+ =head1 DIAGNOSTICS
+
+ =over
+
+ =item C<Bad attribute type: ATTR(%s)>
+
+ An attribute handler was specified with an C<:ATTR(I<ref_type>)>, but the
+ type of referent it was defined to handle wasn't one of the five permitted:
+ C<SCALAR>, C<ARRAY>, C<HASH>, C<CODE>, or C<ANY>.
+
+ =item C<Attribute handler %s doesn't handle %s attributes>
+
+ A handler for attributes of the specified name I<was> defined, but not
+ for the specified type of declaration. Typically encountered whe trying
+ to apply a C<VAR> attribute handler to a subroutine, or a C<SCALAR>
+ attribute handler to some other type of variable.
+
+ =item C<Declaration of %s attribute in package %s may clash with future reserved word>
+
+ A handler for an attributes with an all-lowercase name was declared. An
+ attribute with an all-lowercase name might have a meaning to Perl
+ itself some day, even though most don't yet. Use a mixed-case attribute
+ name, instead.
+
+ =item C<Can't have two ATTR specifiers on one subroutine>
+
+ You just can't, okay?
+ Instead, put all the specifications together with commas between them
+ in a single C<ATTR(I<specification>)>.
+
+ =item C<Can't autotie a %s>
+
+ You can only declare autoties for types C<"SCALAR">, C<"ARRAY">, and
+ C<"SCALAR">. They're the only things (apart from typeglobs -- which are
+ not declarable) that Perl can tie.
+
+ =item C<Internal error: %s symbol went missing>
+
+ Something is rotten in the state of the program. An attributed
+ subroutine ceased to exist between the point it was declared and the point
+ at which its attribute handler(s) would have been called.
+
+ =back
+
+ =head1 AUTHOR
+
+ Damian Conway (damian@conway.org)
+
+ =head1 BUGS
+
+ There are undoubtedly serious bugs lurking somewhere in code this funky :-)
+ Bug reports and other feedback are most welcome.
+
+ =head1 COPYRIGHT
+
+ Copyright (c) 2001, Damian Conway. All Rights Reserved.
+ This module is free software. It may be used, redistributed
+ and/or modified under the terms of the Perl Artistic License
+ (see http://www.perl.com/perl/misc/Artistic.html)
diff -c /dev/null 'perl-5.7.2/lib/Attribute/Handlers/Changes'
Index: ./lib/Attribute/Handlers/Changes
*** ./lib/Attribute/Handlers/Changes Thu Jan 1 02:00:00 1970
--- ./lib/Attribute/Handlers/Changes Mon Jul 9 17:10:24 2001
***************
*** 0 ****
--- 1,46 ----
+ Revision history for Perl extension Attribute::Handlers
+
+ 0.50 Sat Apr 21 16:09:31 2001
+ - original version;
+
+ 0.51 Tue May 1 06:33:15 2001
+
+ - Fixed fatal file path error in MANIFEST (thanks Marcel and Jost)
+
+
+ 0.60 Thu May 10 15:46:02 2001
+
+ - Added RAWDATA specifier
+
+ - Cleaned up documentation (thanks Garrett)
+
+ - Added warning for all-lowercase handlers (thanks Garrett)
+
+ - Added autotie functionality
+
+ - Tweaked handling of anon arrays as attribute args
+
+
+ 0.61 Thu May 10 16:28:06 2001
+
+ - Critical doc patch
+
+
+ 0.65 Sun Jun 3 07:40:03 2001
+
+ - Added __CALLER__ pseudo class for 'autotie'
+
+ - Added multi-phasic attribute handlers (thanks Garrett)
+
+ - Fixed nasty $SIG{__WARN__}-induced bug
+
+ - Cached ref/symbol mapping for better performance and more
+ reliable symbol identification under evil typeglob manipulations
+
+ - Added option to pass arguments when autotied classes are imported
+ (thanks Marcel)
+
+ - Fixed bug in handling of lexical SCALAR refs
+
+ - Cleaned up interactions with other class hierarchies
+ (due to being base class of UNIVERSAL)
diff -c /dev/null 'perl-5.7.2/lib/Attribute/Handlers/README'
Index: ./lib/Attribute/Handlers/README
*** ./lib/Attribute/Handlers/README Thu Jan 1 02:00:00 1970
--- ./lib/Attribute/Handlers/README Mon Jul 9 17:10:25 2001
***************
*** 0 ****
--- 1,68 ----
+ ==============================================================================
+ Release of version 0.70 of Attribute::Handlers
+ ==============================================================================
+
+
+ NAME
+ Attribute::Handlers - Simpler definition of attribute handlers
+
+ DESCRIPTION
+ This module, when inherited by a package, allows that package's class to
+ define attribute handler subroutines for specific attributes. Variables
+ and subroutines subsequently defined in that package, or in packages
+ derived from that package may be given attributes with the same names as
+ the attribute handler subroutines, which will then be called at the end
+ of the compilation phase (i.e. in a `CHECK' block).
+
+ EXAMPLE
+
+ package UNIVERSAL;
+ use Attribute::Handlers;
+
+ my %name;
+ sub name { return $name{$_[2]}||*{$_[1]}{NAME} }
+
+ sub Name :ATTR { $name{$_[2]} = $_[4] }
+
+ sub Purpose :ATTR { print STDERR "Purpose of ", &name, " is $_[4]\n" }
+
+ sub Unit :ATTR { print STDERR &name, " measured in $_[4]\n" }
+
+
+ package main;
+
+ my $capacity : Name(capacity)
+ : Purpose(to store max storage capacity for files)
+ : Unit(Gb);
+
+ package Other;
+
+ sub foo : Purpose(to foo all data before barring it) { }
+
+
+ AUTHOR
+ Damian Conway (damian@conway.org)
+
+ COPYRIGHT
+ Copyright (c) 2001, Damian Conway. All Rights Reserved.
+ This module is free software. It may be used, redistributed
+ and/or modified under the terms of the Perl Artistic License
+ (see http://www.perl.com/perl/misc/Artistic.html)
+
+
+ ==============================================================================
+
+ CHANGES IN VERSION 0.70
+
+ (No changes have been documented for this version)
+
+ ==============================================================================
+
+ AVAILABILITY
+
+ Attribute::Handlers has been uploaded to the CPAN
+ and is also available from:
+
+ http://www.csse.monash.edu.au/~damian/CPAN/Attribute-Handlers.tar.gz
+
+ ==============================================================================
diff -c /dev/null 'perl-5.7.2/lib/Attribute/Handlers/demo/Demo.pm'
Index: ./lib/Attribute/Handlers/demo/Demo.pm
*** ./lib/Attribute/Handlers/demo/Demo.pm Thu Jan 1 02:00:00 1970
--- ./lib/Attribute/Handlers/demo/Demo.pm Mon Jul 9 17:10:25 2001
***************
*** 0 ****
--- 1,49 ----
+ $DB::single = 1;
+
+ package Demo;
+ use Attribute::Handlers;
+ no warnings 'redefine';
+
+ sub Demo : ATTR(SCALAR) {
+ my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
+ $data = '<undef>' unless defined $data;
+ print STDERR 'Scalar $', *{$symbol}{NAME},
+ " ($referent) was ascribed ${attr}\n",
+ "with data ($data)\nin phase $phase\n";
+ };
+
+ sub This : ATTR(SCALAR) {
+ print STDERR "This at ",
+ join(":", map { defined() ? $_ : "" } caller(1)),
+ "\n";
+ }
+
+ sub Demo : ATTR(HASH) {
+ my ($package, $symbol, $referent, $attr, $data) = @_;
+ $data = '<undef>' unless defined $data;
+ print STDERR 'Hash %', *{$symbol}{NAME},
+ " ($referent) was ascribed ${attr} with data ($data)\n";
+ };
+
+ sub Demo : ATTR(CODE) {
+ my ($package, $symbol, $referent, $attr, $data) = @_;
+ $data = '<undef>' unless defined $data;
+ print STDERR 'Sub &', *{$symbol}{NAME},
+ " ($referent) was ascribed ${attr} with data ($data)\n";
+ };
+
+ sub Multi : ATTR {
+ my ($package, $symbol, $referent, $attr, $data) = @_;
+ $data = '<undef>' unless defined $data;
+ print STDERR ref($referent), ' ', *{$symbol}{NAME},
+ " ($referent) was ascribed ${attr} with data ($data)\n";
+ };
+
+ sub ExplMulti : ATTR(ANY) {
+ my ($package, $symbol, $referent, $attr, $data) = @_;
+ $data = '<undef>' unless defined $data;
+ print STDERR ref($referent), ' ', *{$symbol}{NAME},
+ " ($referent) was ascribed ${attr} with data ($data)\n";
+ };
+
+ 1;
diff -c /dev/null 'perl-5.7.2/lib/Attribute/Handlers/demo/Descriptions.pm'
Index: ./lib/Attribute/Handlers/demo/Descriptions.pm
*** ./lib/Attribute/Handlers/demo/Descriptions.pm Thu Jan 1 02:00:00 1970
--- ./lib/Attribute/Handlers/demo/Descriptions.pm Mon Jul 9 17:10:25 2001
***************
*** 0 ****
--- 1,24 ----
+ package Descriptions;
+
+ use Attribute::Handlers;
+
+ my %name;
+
+ sub name {
+ return $name{$_[2]}||*{$_[1]}{NAME};
+ }
+
+ sub UNIVERSAL::Name :ATTR {
+ $name{$_[2]} = $_[4];
+ }
+
+ sub UNIVERSAL::Purpose :ATTR {
+ print STDERR "Purpose of ", &name, " is $_[4]\n";
+ }
+
+ sub UNIVERSAL::Unit :ATTR {
+ print STDERR &name, " measured in $_[4]\n";
+ }
+
+
+ 1;
diff -c /dev/null 'perl-5.7.2/lib/Attribute/Handlers/demo/MyClass.pm'
Index: ./lib/Attribute/Handlers/demo/MyClass.pm
*** ./lib/Attribute/Handlers/demo/MyClass.pm Thu Jan 1 02:00:00 1970
--- ./lib/Attribute/Handlers/demo/MyClass.pm Mon Jul 9 17:10:25 2001
***************
*** 0 ****
--- 1,63 ----
+ package MyClass;
+ use v5.6.0;
+ use base Attribute::Handlers;
+ no warnings 'redefine';
+
+
+ sub Good : ATTR(SCALAR) {
+ my ($package, $symbol, $referent, $attr, $data) = @_;
+
+ # Invoked for any scalar variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+
+ # Do whatever to $referent here (executed in CHECK phase).
+ local $" = ", ";
+ print "MyClass::Good:ATTR(SCALAR)(@_);\n";
+ };
+
+ sub Bad : ATTR(SCALAR) {
+ # Invoked for any scalar variable with a :Bad attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ local $" = ", ";
+ print "MyClass::Bad:ATTR(SCALAR)(@_);\n";
+ }
+
+ sub Good : ATTR(ARRAY) {
+ # Invoked for any array variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ local $" = ", ";
+ print "MyClass::Good:ATTR(ARRAY)(@_);\n";
+ };
+
+ sub Good : ATTR(HASH) {
+ # Invoked for any hash variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ local $" = ", ";
+ print "MyClass::Good:ATTR(HASH)(@_);\n";
+ };
+
+ sub Ugly : ATTR(CODE) {
+ # Invoked for any subroutine declared in MyClass (or a
+ # derived class) with an :Ugly attribute.
+ local $" = ", ";
+ print "MyClass::UGLY:ATTR(CODE)(@_);\n";
+ };
+
+ sub Omni : ATTR {
+ # Invoked for any scalar, array, hash, or subroutine
+ # with an :Omni attribute, provided the variable or
+ # subroutine was declared in MyClass (or a derived class)
+ # or the variable was typed to MyClass.
+ # Use ref($_[2]) to determine what kind of referent it was.
+ local $" = ", ";
+ my $type = ref $_[2];
+ print "MyClass::OMNI:ATTR($type)(@_);\n";
+ use Data::Dumper 'Dumper';
+ print Dumper [ \@_ ];
+ };
+
+ 1;
diff -c /dev/null 'perl-5.7.2/lib/Attribute/Handlers/demo/demo.pl'
Index: ./lib/Attribute/Handlers/demo/demo.pl
*** ./lib/Attribute/Handlers/demo/demo.pl Thu Jan 1 02:00:00 1970
--- ./lib/Attribute/Handlers/demo/demo.pl Mon Jul 9 17:10:25 2001
***************
*** 0 ****
--- 1,31 ----
+ #! /usr/local/bin/perl -w
+
+ use v5.6.0;
+ use base Demo;
+
+ my $y : Demo :This($this) = sub : Demo(1,2,3) {};
+ sub x : Demo(4,5,6) :Multi {}
+ my %z : Demo(hash) :Multi(method,maybe);
+ # my %a : NDemo(hash);
+
+ {
+ package Named;
+
+ use base Demo;
+
+ sub Demo :ATTR(SCALAR) { print STDERR "tada\n" }
+
+ my $y : Demo :This($this) = sub : Demo(1,2,3) {};
+ sub x : ExplMulti :Demo(4,5,6) {}
+ my %z : ExplMulti :Demo(hash);
+ my Named $q : Demo;
+ }
+
+ package Other;
+
+ my Demo $dother : Demo :This($this) = "okay";
+ my Named $nother : Demo :This($this) = "okay";
+
+ # my $unnamed : Demo;
+
+ # sub foo : Demo();
diff -c /dev/null 'perl-5.7.2/lib/Attribute/Handlers/demo/demo2.pl'
Index: ./lib/Attribute/Handlers/demo/demo2.pl
*** ./lib/Attribute/Handlers/demo/demo2.pl Thu Jan 1 02:00:00 1970
--- ./lib/Attribute/Handlers/demo/demo2.pl Mon Jul 9 17:10:25 2001
***************
*** 0 ****
--- 1,21 ----
+ #! /usr/local/bin/perl -w
+
+ use v5.6.0;
+ use base Demo;
+ no warnings 'redefine';
+
+ my %z1 :Multi(method?maybe);
+ my %z2 :Multi(method,maybe);
+ my %z3 :Multi(qw(method,maybe));
+ my %z4 :Multi(qw(method maybe));
+ my %z5 :Multi('method','maybe');
+
+ sub foo :Demo(till=>ears=>are=>bleeding) {}
+ sub foo :Demo(['till','ears','are','bleeding']) {}
+ sub foo :Demo(qw/till ears are bleeding/) {}
+ sub foo :Demo(till,ears,are,bleeding) {}
+
+ sub foo :Demo(my,ears,are,bleeding) {}
+ sub foo :Demo(my=>ears=>are=>bleeding) {}
+ sub foo :Demo(qw/my, ears, are, bleeding/) {}
+ sub foo :Demo(qw/my ears are bleeding) {}
diff -c /dev/null 'perl-5.7.2/lib/Attribute/Handlers/demo/demo3.pl'
Index: ./lib/Attribute/Handlers/demo/demo3.pl
*** ./lib/Attribute/Handlers/demo/demo3.pl Thu Jan 1 02:00:00 1970
--- ./lib/Attribute/Handlers/demo/demo3.pl Mon Jul 9 17:10:25 2001
***************
*** 0 ****
--- 1,16 ----
+ package main;
+ use MyClass;
+
+ my MyClass $x :Good :Bad(1**1-1) :Omni(vorous);
+
+ package SomeOtherClass;
+ use base MyClass;
+
+ sub tent { 'acle' }
+
+ sub w :Ugly(sister) :Omni('po',tent()) {}
+
+ my @y :Good :Omni(s/cie/nt/);
+
+ my %y :Good(q/bye) :Omni(q/bus/);
+
diff -c /dev/null 'perl-5.7.2/lib/Attribute/Handlers/demo/demo4.pl'
Index: ./lib/Attribute/Handlers/demo/demo4.pl
*** ./lib/Attribute/Handlers/demo/demo4.pl Thu Jan 1 02:00:00 1970
--- ./lib/Attribute/Handlers/demo/demo4.pl Mon Jul 9 17:10:25 2001
***************
*** 0 ****
--- 1,9 ----
+ use Descriptions;
+
+ my $capacity : Name(capacity)
+ : Purpose(to store max storage capacity for files)
+ : Unit(Gb);
+
+ package Other;
+
+ sub foo : Purpose(to foo all data before barring it) { }
diff -c /dev/null 'perl-5.7.2/lib/Attribute/Handlers/demo/demo_call.pl'
Index: ./lib/Attribute/Handlers/demo/demo_call.pl
*** ./lib/Attribute/Handlers/demo/demo_call.pl Thu Jan 1 02:00:00 1970
--- ./lib/Attribute/Handlers/demo/demo_call.pl Mon Jul 9 17:10:25 2001
***************
*** 0 ****
--- 1,11 ----
+ #! /usr/local/bin/perl -w
+
+ use Attribute::Handlers;
+
+ sub Call : ATTR {
+ use Data::Dumper 'Dumper';
+ print Dumper [ @_ ];
+ }
+
+
+ sub x : Call(some,data) { };
diff -c /dev/null 'perl-5.7.2/lib/Attribute/Handlers/demo/demo_chain.pl'
Index: ./lib/Attribute/Handlers/demo/demo_chain.pl
*** ./lib/Attribute/Handlers/demo/demo_chain.pl Thu Jan 1 02:00:00 1970
--- ./lib/Attribute/Handlers/demo/demo_chain.pl Mon Jul 9 17:10:25 2001
***************
*** 0 ****
--- 1,27 ----
+ #! /usr/local/bin/perl -w
+
+ use Attribute::Handlers;
+
+ sub Prefix : ATTR {
+ my ($glob, $sub) = @_[1,2];
+ no warnings 'redefine';
+ *$glob = sub {
+ print "This happens first\n";
+ $sub->(@_);
+ };
+ }
+
+ sub Postfix : ATTR {
+ my ($glob, $sub) = @_[1,2];
+ no warnings 'redefine';
+ *$glob = sub {
+ $sub->(@_);
+ print "This happens last\n";
+ };
+ }
+
+ sub test : Postfix Prefix {
+ print "Hello World\n";
+ }
+
+ test();
diff -c /dev/null 'perl-5.7.2/lib/Attribute/Handlers/demo/demo_cycle.pl'
Index: ./lib/Attribute/Handlers/demo/demo_cycle.pl
*** ./lib/Attribute/Handlers/demo/demo_cycle.pl Thu Jan 1 02:00:00 1970
--- ./lib/Attribute/Handlers/demo/demo_cycle.pl Mon Jul 9 17:10:25 2001
***************
*** 0 ****
--- 1,9 ----
+ use Attribute::Handlers autotie => { Cycle => Tie::Cycle };
+
+ my $next : Cycle(['A'..'Z']);
+
+ print tied $next, "\n";
+
+ while (<>) {
+ print $next, "\n";
+ }
diff -c /dev/null 'perl-5.7.2/lib/Attribute/Handlers/demo/demo_hashdir.pl'
Index: ./lib/Attribute/Handlers/demo/demo_hashdir.pl
*** ./lib/Attribute/Handlers/demo/demo_hashdir.pl Thu Jan 1 02:00:00 1970
--- ./lib/Attribute/Handlers/demo/demo_hashdir.pl Mon Jul 9 17:10:25 2001
***************
*** 0 ****
--- 1,7 ----
+ use Attribute::Handlers autotie => { Dir => 'Tie::Dir qw(DIR_UNLINK)' };
+
+ my %dot : Dir('.', DIR_UNLINK);
+
+ print join "\n", keys %dot;
+
+ delete $dot{killme};
diff -c /dev/null 'perl-5.7.2/lib/Attribute/Handlers/demo/demo_phases.pl'
Index: ./lib/Attribute/Handlers/demo/demo_phases.pl
*** ./lib/Attribute/Handlers/demo/demo_phases.pl Thu Jan 1 02:00:00 1970
--- ./lib/Attribute/Handlers/demo/demo_phases.pl Mon Jul 9 17:10:25 2001
***************
*** 0 ****
--- 1,18 ----
+ #! /usr/local/bin/perl -w
+
+ use Attribute::Handlers;
+ use Data::Dumper 'Dumper';
+
+ sub UNIVERSAL::Beginner : ATTR(SCALAR,BEGIN,END)
+ { print STDERR "Beginner: ", Dumper \@_}
+
+ sub UNIVERSAL::Checker : ATTR(CHECK,SCALAR)
+ { print STDERR "Checker: ", Dumper \@_}
+
+ sub UNIVERSAL::Initer : ATTR(SCALAR,INIT)
+ { print STDERR "Initer: ", Dumper \@_}
+
+ package Other;
+
+ my $x :Initer(1) :Checker(2) :Beginner(3);
+ my $y :Initer(4) :Checker(5) :Beginner(6);
diff -c /dev/null 'perl-5.7.2/lib/Attribute/Handlers/demo/demo_range.pl'
Index: ./lib/Attribute/Handlers/demo/demo_range.pl
*** ./lib/Attribute/Handlers/demo/demo_range.pl Thu Jan 1 02:00:00 1970
--- ./lib/Attribute/Handlers/demo/demo_range.pl Mon Jul 9 17:10:25 2001
***************
*** 0 ****
--- 1,21 ----
+ package UNIVERSAL;
+ use Attribute::Handlers;
+ use Tie::RangeHash;
+
+ sub Ranged : ATTR(HASH) {
+ my ($package, $symbol, $referent, $attr, $data) = @_;
+ tie %$referent, 'Tie::RangeHash';
+ }
+
+ package main;
+
+ my %next : Ranged;
+
+ $next{'cat,dog'} = "animal";
+ $next{'fish,fowl'} = "meal";
+ $next{'heaven,hell'} = "reward";
+
+ while (<>) {
+ chomp;
+ print $next{$_}||"???", "\n";
+ }
diff -c /dev/null 'perl-5.7.2/lib/Attribute/Handlers/demo/demo_rawdata.pl'
Index: ./lib/Attribute/Handlers/demo/demo_rawdata.pl
*** ./lib/Attribute/Handlers/demo/demo_rawdata.pl Thu Jan 1 02:00:00 1970
--- ./lib/Attribute/Handlers/demo/demo_rawdata.pl Mon Jul 9 17:10:25 2001
***************
*** 0 ****
--- 1,12 ----
+ package UNIVERSAL;
+ use Attribute::Handlers;
+
+ sub Cooked : ATTR(SCALAR) { print pop, "\n" }
+ sub PostRaw : ATTR(SCALAR,RAWDATA) { print pop, "\n" }
+ sub PreRaw : ATTR(SCALAR,RAWDATA) { print pop, "\n" }
+
+ package main;
+
+ my $x : Cooked(1..5);
+ my $y : PreRaw(1..5);
+ my $z : PostRaw(1..5);
diff -c /dev/null 'perl-5.7.2/lib/Attribute/Handlers/test.pl'
Index: ./lib/Attribute/Handlers/test.pl
*** ./lib/Attribute/Handlers/test.pl Thu Jan 1 02:00:00 1970
--- ./lib/Attribute/Handlers/test.pl Mon Jul 9 17:10:25 2001
***************
*** 0 ****
--- 1,130 ----
+ # Before `make install' is performed this script should be runnable with
+ # `make test'. After `make install' it should work as `perl test.pl'
+
+ ######################### We start with some black magic to print on failure.
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # Change 1..1 below to 1..last_test_to_print .
+ # (It may become useful if the test is moved to ./t subdirectory.)
+
+ END {print "not ok 1\n" unless $loaded;}
+ use v5.6.0;
+ use Attribute::Handlers;
+ $loaded = 1;
+
+ ######################### End of black magic.
+
+ # Insert your test code below (better if it prints "ok 13"
+ # (correspondingly "not ok 13") depending on the success of chunk 13
+ # of the test code):
+
+ sub ok { $::count++; push @::results, [$_[1], $_[0]?"":"not "]; }
+
+ END { print "1..$::count\n";
+ print map "$_->[1]ok $_->[0]\n", sort {$a->[0]<=>$b->[0]} @::results }
+
+ package Test;
+ use warnings;
+ no warnings 'redefine';
+
+ sub UNIVERSAL::Okay :ATTR { ::ok @{$_[4]} }
+
+ sub Dokay :ATTR(SCALAR) { ::ok @{$_[4]} }
+ sub Dokay :ATTR(HASH) { ::ok @{$_[4]} }
+ sub Dokay :ATTR(ARRAY) { ::ok @{$_[4]} }
+ sub Dokay :ATTR(CODE) { ::ok @{$_[4]} }
+
+ sub Vokay :ATTR(VAR) { ::ok @{$_[4]} }
+
+ sub Aokay :ATTR(ANY) { ::ok @{$_[4]} }
+
+ package main;
+ use warnings;
+
+ my $x1 :Okay(1,1);
+ my @x1 :Okay(1=>2);
+ my %x1 :Okay(1,3);
+ sub x1 :Okay(1,4) {}
+
+ my Test $x2 :Dokay(1,5);
+
+ package Test;
+ my $x3 :Dokay(1,6);
+ my Test $x4 :Dokay(1,7);
+ sub x3 :Dokay(1,8) {}
+
+ my $y1 :Okay(1,9);
+ my @y1 :Okay(1,10);
+ my %y1 :Okay(1,11);
+ sub y1 :Okay(1,12) {}
+
+ my $y2 :Vokay(1,13);
+ my @y2 :Vokay(1,14);
+ my %y2 :Vokay(1,15);
+ # BEGIN {eval 'sub y2 :Vokay(0,16) {}; 1' or
+ ::ok(1,16);
+ # }
+
+ my $z :Aokay(1,17);
+ my @z :Aokay(1,18);
+ my %z :Aokay(1,19);
+ sub z :Aokay(1,20) {};
+
+ package DerTest;
+ use base 'Test';
+ use warnings;
+
+ my $x5 :Dokay(1,21);
+ my Test $x6 :Dokay(1,22);
+ sub x5 :Dokay(1,23);
+
+ my $y3 :Okay(1,24);
+ my @y3 :Okay(1,25);
+ my %y3 :Okay(1,26);
+ sub y3 :Okay(1,27) {}
+
+ package Unrelated;
+
+ BEGIN { eval 'my $x7 :Dokay(0,28)' or ::ok(1,28); }
+ my Test $x8 :Dokay(1,29);
+ eval 'sub x7 :Dokay(0,30) {}' or ::ok(1,30);
+
+
+ package Tie::Loud;
+
+ sub TIESCALAR { ::ok(1,31); bless {}, $_[0] }
+ sub FETCH { ::ok(1,32); return 1 }
+ sub STORE { ::ok(1,33); return 1 }
+
+ package Tie::Noisy;
+
+ sub TIEARRAY { ::ok(1,$_[1]); bless {}, $_[0] }
+ sub FETCH { ::ok(1,35); return 1 }
+ sub STORE { ::ok(1,36); return 1 }
+ sub FETCHSIZE { 100 }
+
+ package Tie::Rowdy;
+
+ sub TIEHASH { ::ok(1,$_[1]); bless {}, $_[0] }
+ sub FETCH { ::ok(1,38); return 1 }
+ sub STORE { ::ok(1,39); return 1 }
+
+ package main;
+
+ use Attribute::Handlers autotie => { Other::Loud => Tie::Loud,
+ Noisy => Tie::Noisy,
+ UNIVERSAL::Rowdy => Tie::Rowdy,
+ };
+
+ my Other $loud : Loud;
+ $loud++;
+
+ my @noisy : Noisy(34);
+ $noisy[0]++;
+
+ my %rowdy : Rowdy(37);
+ $rowdy{key}++;
diff -c 'perl-5.7.1/lib/AutoLoader.pm' 'perl-5.7.2/lib/AutoLoader.pm'
Index: ./lib/AutoLoader.pm
*** ./lib/AutoLoader.pm Tue Mar 6 04:05:22 2001
--- ./lib/AutoLoader.pm Mon Jul 9 17:10:25 2001
***************
*** 1,6 ****
package AutoLoader;
! use 5.005_64;
our(@EXPORT, @EXPORT_OK, $VERSION);
my $is_dosish;
--- 1,6 ----
package AutoLoader;
! use 5.6.0;
our(@EXPORT, @EXPORT_OK, $VERSION);
my $is_dosish;
***************
*** 12,18 ****
require Exporter;
@EXPORT = @EXPORT = ();
@EXPORT_OK = @EXPORT_OK = qw(AUTOLOAD);
! $is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32';
$is_epoc = $^O eq 'epoc';
$is_vms = $^O eq 'VMS';
$is_macos = $^O eq 'MacOS';
--- 12,18 ----
require Exporter;
@EXPORT = @EXPORT = ();
@EXPORT_OK = @EXPORT_OK = qw(AUTOLOAD);
! $is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare';
$is_epoc = $^O eq 'epoc';
$is_vms = $^O eq 'VMS';
$is_macos = $^O eq 'MacOS';
***************
*** 57,63 ****
unless ($filename =~ m|^/|s) {
if ($is_dosish) {
unless ($filename =~ m{^([a-z]:)?[\\/]}is) {
! $filename = "./$filename";
}
}
elsif ($is_epoc) {
--- 57,67 ----
unless ($filename =~ m|^/|s) {
if ($is_dosish) {
unless ($filename =~ m{^([a-z]:)?[\\/]}is) {
! if ($^O ne 'NetWare') {
! $filename = "./$filename";
! } else {
! $filename = "$filename";
! }
}
}
elsif ($is_epoc) {
***************
*** 64,70 ****
unless ($filename =~ m{^([a-z?]:)?[\\/]}is) {
$filename = "./$filename";
}
! }elsif ($is_vms) {
# XXX todo by VMSmiths
$filename = "./$filename";
}
--- 68,75 ----
unless ($filename =~ m{^([a-z?]:)?[\\/]}is) {
$filename = "./$filename";
}
! }
! elsif ($is_vms) {
# XXX todo by VMSmiths
$filename = "./$filename";
}
***************
*** 84,89 ****
--- 89,95 ----
}
}
my $save = $@;
+ local $!; # Do not munge the value.
eval { local $SIG{__DIE__}; require $filename };
if ($@) {
if (substr($sub,-9) eq '::DESTROY') {
***************
*** 138,144 ****
my $path = $INC{$calldir . '.pm'};
if (defined($path)) {
# Try absolute path name.
! $path =~ s#^(.*)$calldir\.pm$#$1auto/$calldir/autosplit.ix#;
eval { require $path; };
# If that failed, try relative path with normal @INC searching.
if ($@) {
--- 144,156 ----
my $path = $INC{$calldir . '.pm'};
if (defined($path)) {
# Try absolute path name.
! if ($is_macos) {
! (my $malldir = $calldir) =~ tr#/#:#;
! $path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:autosplit.ix#s;
! } else {
! $path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/autosplit.ix#;
! }
!
eval { require $path; };
# If that failed, try relative path with normal @INC searching.
if ($@) {
diff -c /dev/null 'perl-5.7.2/lib/AutoLoader.t'
Index: ./lib/AutoLoader.t
*** ./lib/AutoLoader.t Thu Jan 1 02:00:00 1970
--- ./lib/AutoLoader.t Mon Jul 9 17:10:25 2001
***************
*** 0 ****
--- 1,128 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ if ($^O eq 'MacOS') {
+ $dir = ":auto-$$";
+ $sep = ":";
+ } else {
+ $dir = "auto-$$";
+ $sep = "/";
+ }
+ @INC = $dir;
+ push @INC, '../lib';
+ }
+
+ print "1..11\n";
+
+ # First we must set up some autoloader files
+ mkdir $dir, 0755 or die "Can't mkdir $dir: $!";
+ mkdir "$dir${sep}auto", 0755 or die "Can't mkdir: $!";
+ mkdir "$dir${sep}auto${sep}Foo", 0755 or die "Can't mkdir: $!";
+
+ open(FOO, ">$dir${sep}auto${sep}Foo${sep}foo.al") or die;
+ print FOO <<'EOT';
+ package Foo;
+ sub foo { shift; shift || "foo" }
+ 1;
+ EOT
+ close(FOO);
+
+ open(BAR, ">$dir${sep}auto${sep}Foo${sep}bar.al") or die;
+ print BAR <<'EOT';
+ package Foo;
+ sub bar { shift; shift || "bar" }
+ 1;
+ EOT
+ close(BAR);
+
+ open(BAZ, ">$dir${sep}auto${sep}Foo${sep}bazmarkhian.al") or die;
+ print BAZ <<'EOT';
+ package Foo;
+ sub bazmarkhianish { shift; shift || "baz" }
+ 1;
+ EOT
+ close(BAZ);
+
+ # Let's define the package
+ package Foo;
+ require AutoLoader;
+ @ISA=qw(AutoLoader);
+
+ sub new { bless {}, shift };
+
+ package main;
+
+ $foo = new Foo;
+
+ print "not " unless $foo->foo eq 'foo'; # autoloaded first time
+ print "ok 1\n";
+
+ print "not " unless $foo->foo eq 'foo'; # regular call
+ print "ok 2\n";
+
+ # Try an undefined method
+ eval {
+ $foo->will_fail;
+ };
+ print "not " unless $@ =~ /^Can't locate/;
+ print "ok 3\n";
+
+ # Used to be trouble with this
+ eval {
+ my $foo = new Foo;
+ die "oops";
+ };
+ print "not " unless $@ =~ /oops/;
+ print "ok 4\n";
+
+ # Pass regular expression variable to autoloaded function. This used
+ # to go wrong because AutoLoader used regular expressions to generate
+ # autoloaded filename.
+ "foo" =~ /(\w+)/;
+ print "not " unless $1 eq 'foo';
+ print "ok 5\n";
+
+ print "not " unless $foo->bar($1) eq 'foo';
+ print "ok 6\n";
+
+ print "not " unless $foo->bar($1) eq 'foo';
+ print "ok 7\n";
+
+ print "not " unless $foo->bazmarkhianish($1) eq 'foo';
+ print "ok 8\n";
+
+ print "not " unless $foo->bazmarkhianish($1) eq 'foo';
+ print "ok 9\n";
+
+ # test recursive autoloads
+ open(F, ">$dir${sep}auto${sep}Foo${sep}a.al") or die;
+ print F <<'EOT';
+ package Foo;
+ BEGIN { b() }
+ sub a { print "ok 11\n"; }
+ 1;
+ EOT
+ close(F);
+
+ open(F, ">$dir${sep}auto${sep}Foo${sep}b.al") or die;
+ print F <<'EOT';
+ package Foo;
+ sub b { print "ok 10\n"; }
+ 1;
+ EOT
+ close(F);
+ Foo::a();
+
+ # cleanup
+ END {
+ return unless $dir && -d $dir;
+ unlink "$dir${sep}auto${sep}Foo${sep}foo.al";
+ unlink "$dir${sep}auto${sep}Foo${sep}bar.al";
+ unlink "$dir${sep}auto${sep}Foo${sep}bazmarkhian.al";
+ unlink "$dir${sep}auto${sep}Foo${sep}a.al";
+ unlink "$dir${sep}auto${sep}Foo${sep}b.al";
+ rmdir "$dir${sep}auto${sep}Foo";
+ rmdir "$dir${sep}auto";
+ rmdir "$dir";
+ }
diff -c 'perl-5.7.1/lib/AutoSplit.pm' 'perl-5.7.2/lib/AutoSplit.pm'
Index: ./lib/AutoSplit.pm
*** ./lib/AutoSplit.pm Tue Mar 6 04:05:22 2001
--- ./lib/AutoSplit.pm Mon Jul 9 17:10:25 2001
***************
*** 11,17 ****
our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen,
$CheckForAutoloader, $CheckModTime);
! $VERSION = "1.0305";
@ISA = qw(Exporter);
@EXPORT = qw(&autosplit &autosplit_lib_modules);
@EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime);
--- 11,17 ----
our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen,
$CheckForAutoloader, $CheckModTime);
! $VERSION = "1.0306";
@ISA = qw(Exporter);
@EXPORT = qw(&autosplit &autosplit_lib_modules);
@EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime);
***************
*** 54,60 ****
The
fourth argument, I<$check>, instructs C<autosplit> to check the module
! currently being split to ensure that it does include a C<use>
specification for the AutoLoader module, and skips the module if
AutoLoader is not detected.
$check defaults to 1.
--- 54,60 ----
The
fourth argument, I<$check>, instructs C<autosplit> to check the module
! currently being split to ensure that it includes a C<use>
specification for the AutoLoader module, and skips the module if
AutoLoader is not detected.
$check defaults to 1.
***************
*** 199,204 ****
--- 199,206 ----
# private functions
+ my $self_mod_time = (stat __FILE__)[9];
+
sub autosplit_file {
my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time)
= @_;
***************
*** 261,267 ****
die "Package $def_package ($modpname.pm) does not ".
"match filename $filename"
unless ($filename =~ m/\Q$modpname.pm\E$/ or
! ($^O eq 'dos') or ($^O eq 'MSWin32') or
$Is_VMS && $filename =~ m/$modpname.pm/i);
my($al_idx_file) = catfile($autodir, $modpname, $IndexFile);
--- 263,269 ----
die "Package $def_package ($modpname.pm) does not ".
"match filename $filename"
unless ($filename =~ m/\Q$modpname.pm\E$/ or
! ($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'NetWare') or
$Is_VMS && $filename =~ m/$modpname.pm/i);
my($al_idx_file) = catfile($autodir, $modpname, $IndexFile);
***************
*** 268,274 ****
if ($check_mod_time){
my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
! if ($al_ts_time >= $pm_mod_time){
print "AutoSplit skipped ($al_idx_file newer than $filename)\n"
if ($Verbose >= 2);
return undef; # one undef, not a list
--- 270,277 ----
if ($check_mod_time){
my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
! if ($al_ts_time >= $pm_mod_time and
! $al_ts_time >= $self_mod_time){
print "AutoSplit skipped ($al_idx_file newer than $filename)\n"
if ($Verbose >= 2);
return undef; # one undef, not a list
***************
*** 338,350 ****
if ($Verbose>=1);
}
push(@outfiles, $path);
print OUT <<EOT;
# NOTE: Derived from $filename.
! # Changes made here will be lost when autosplit again.
# See AutoSplit.pm.
package $this_package;
! #line $fnr "$filename (autosplit into $path)"
EOT
print OUT @cache;
@cache = ();
--- 341,354 ----
if ($Verbose>=1);
}
push(@outfiles, $path);
+ my $lineno = $fnr - @cache;
print OUT <<EOT;
# NOTE: Derived from $filename.
! # Changes made here will be lost when autosplit is run again.
# See AutoSplit.pm.
package $this_package;
! #line $lineno "$filename (autosplit into $path)"
EOT
print OUT @cache;
@cache = ();
diff -c 'perl-5.7.1/lib/Benchmark.pm' 'perl-5.7.2/lib/Benchmark.pm'
Index: ./lib/Benchmark.pm
*** ./lib/Benchmark.pm Tue Mar 6 04:05:22 2001
--- ./lib/Benchmark.pm Mon Jul 9 17:10:25 2001
***************
*** 362,368 ****
@EXPORT_OK=qw(timesum cmpthese countit
clearcache clearallcache disablecache enablecache);
! $VERSION = 1.00;
&init;
--- 362,368 ----
@EXPORT_OK=qw(timesum cmpthese countit
clearcache clearallcache disablecache enablecache);
! $VERSION = 1.01;
&init;
diff -c /dev/null 'perl-5.7.2/lib/Benchmark.t'
Index: ./lib/Benchmark.t
*** ./lib/Benchmark.t Thu Jan 1 02:00:00 1970
--- ./lib/Benchmark.t Mon Jul 9 17:10:25 2001
***************
*** 0 ****
--- 1,88 ----
+ #!perl
+
+ BEGIN {
+ chdir( 't' ) if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bDevel\/DProf\b/){
+ print "1..0 # Skip: Devel::DProf was not built\n";
+ exit 0;
+ }
+ }
+
+ END {
+ while(-e 'tmon.out' && unlink 'tmon.out') {}
+ while(-e 'err' && unlink 'err') {}
+ }
+
+ use Benchmark qw( timediff timestr );
+ use Getopt::Std 'getopts';
+ getopts('vI:p:');
+
+ # -v Verbose
+ # -I Add to @INC
+ # -p Name of perl binary
+
+ @tests = @ARGV ? @ARGV : sort (<lib/dprof/*_t>, <lib/dprof/*_v>); # glob-sort, for OS/2
+
+ $path_sep = $Config{path_sep} || ':';
+ $perl5lib = $opt_I || join( $path_sep, @INC );
+ $perl = $opt_p || $^X;
+
+ if( $opt_v ){
+ print "tests: @tests\n";
+ print "perl: $perl\n";
+ print "perl5lib: $perl5lib\n";
+ }
+ if( $perl =~ m|^\./| ){
+ # turn ./perl into ../perl, because of chdir(t) above.
+ $perl = ".$perl";
+ }
+ if( ! -f $perl ){ die "Where's Perl?" }
+
+ sub profile {
+ my $test = shift;
+ my @results;
+ local $ENV{PERL5LIB} = $perl5lib;
+ my $opt_d = '-d:DProf';
+
+ my $t_start = new Benchmark;
+ open( R, "$perl \"$opt_d\" $test |" ) || warn "$0: Can't run. $!\n";
+ @results = <R>;
+ close R;
+ my $t_total = timediff( new Benchmark, $t_start );
+
+ if( $opt_v ){
+ print "\n";
+ print @results
+ }
+
+ print '# ',timestr( $t_total, 'nop' ), "\n";
+ }
+
+
+ sub verify {
+ my $test = shift;
+
+ my $command = $perl.' "-I../lib" "-I./lib/dprof" '.$test;
+ $command .= ' -v' if $opt_v;
+ $command .= ' -p '. $perl;
+ system $command;
+ }
+
+
+ $| = 1;
+ print "1..18\n";
+ while( @tests ){
+ $test = shift @tests;
+ $test =~ s/\.$// if $^O eq 'VMS';
+ if( $test =~ /_t$/i ){
+ print "# $test" . '.' x (20 - length $test);
+ profile $test;
+ }
+ else{
+ verify $test;
+ }
+ }
+
+ unlink("tmon.out");
diff -c 'perl-5.7.1/lib/CGI/Pretty.pm' 'perl-5.7.2/lib/CGI/Pretty.pm'
Index: ./lib/CGI/Pretty.pm
*** ./lib/CGI/Pretty.pm Tue Mar 6 04:05:23 2001
--- ./lib/CGI/Pretty.pm Mon Jul 9 17:10:26 2001
***************
*** 10,16 ****
use strict;
use CGI ();
! $CGI::Pretty::VERSION = '1.05';
$CGI::DefaultClass = __PACKAGE__;
$CGI::Pretty::AutoloadClass = 'CGI';
@CGI::Pretty::ISA = qw( CGI );
--- 10,16 ----
use strict;
use CGI ();
! $CGI::Pretty::VERSION = '1.05_00';
$CGI::DefaultClass = __PACKAGE__;
$CGI::Pretty::AutoloadClass = 'CGI';
@CGI::Pretty::ISA = qw( CGI );
diff -c /dev/null 'perl-5.7.2/lib/CGI/t/form.t'
Index: ./lib/CGI/t/form.t
*** ./lib/CGI/t/form.t Thu Jan 1 02:00:00 1970
--- ./lib/CGI/t/form.t Mon Jul 9 17:10:27 2001
***************
*** 0 ****
--- 1,90 ----
+ #!/usr/local/bin/perl -w
+
+ BEGIN {
+ chdir('t') if -d 't';
+ @INC = '../lib';
+ }
+
+ # Test ability to retrieve HTTP request info
+ ######################### We start with some black magic to print on failure.
+ use lib '../blib/lib','../blib/arch';
+
+ BEGIN {$| = 1; print "1..17\n"; }
+ END {print "not ok 1\n" unless $loaded;}
+ use CGI (':standard','-no_debug');
+ $loaded = 1;
+ print "ok 1\n";
+
+ ######################### End of black magic.
+
+ # util
+ sub test {
+ local($^W) = 0;
+ my($num, $true,$msg) = @_;
+ print($true ? "ok $num\n" : "not ok $num $msg\n");
+ }
+
+ my $CRLF = "\015\012";
+ if ($^O eq 'VMS') {
+ $CRLF = "\n"; # via web server carriage is inserted automatically
+ }
+ if (ord("\t") != 9) { # EBCDIC?
+ $CRLF = "\r\n";
+ }
+
+
+ # Set up a CGI environment
+ $ENV{REQUEST_METHOD}='GET';
+ $ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull';
+ $ENV{PATH_INFO} ='/somewhere/else';
+ $ENV{PATH_TRANSLATED} ='/usr/local/somewhere/else';
+ $ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi';
+ $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
+ $ENV{SERVER_PORT} = 8080;
+ $ENV{SERVER_NAME} = 'the.good.ship.lollypop.com';
+
+ test(2,start_form(-action=>'foobar',-method=>'get') eq
+ qq(<form method="get" action="foobar" enctype="application/x-www-form-urlencoded">\n),
+ "start_form()");
+
+ test(3,submit() eq qq(<input type="submit" name=".submit" />),"submit()");
+ test(4,submit(-name=>'foo',-value=>'bar') eq qq(<input type="submit" name="foo" value="bar" />),"submit(-name,-value)");
+ test(5,submit({-name=>'foo',-value=>'bar'}) eq qq(<input type="submit" name="foo" value="bar" />),"submit({-name,-value})");
+ test(6,textfield(-name=>'weather') eq qq(<input type="text" name="weather" value="dull" />),"textfield({-name})");
+ test(7,textfield(-name=>'weather',-value=>'nice') eq qq(<input type="text" name="weather" value="dull" />),"textfield({-name,-value})");
+ test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(<input type="text" name="weather" value="nice" />),
+ "textfield({-name,-value,-override})");
+ test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(<input type="checkbox" name="weather" value="nice" />weather),
+ "checkbox()");
+ test(10,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast') eq
+ qq(<input type="checkbox" name="weather" value="nice" />forecast),
+ "checkbox()");
+ test(11,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast',-checked=>1,-override=>1) eq
+ qq(<input type="checkbox" name="weather" value="nice" checked />forecast),
+ "checkbox()");
+ test(12,checkbox(-name=>'weather',-value=>'dull',-label=>'forecast') eq
+ qq(<input type="checkbox" name="weather" value="dull" checked />forecast),
+ "checkbox()");
+
+ test(13,radio_group(-name=>'game') eq
+ qq(<input type="radio" name="game" value="chess" checked />chess <input type="radio" name="game" value="checkers" />checkers),
+ 'radio_group()');
+ test(14,radio_group(-name=>'game',-labels=>{'chess'=>'ping pong'}) eq
+ qq(<input type="radio" name="game" value="chess" checked />ping pong <input type="radio" name="game" value="checkers" />checkers),
+ 'radio_group()');
+
+ test(15, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/]) eq
+ qq(<input type="checkbox" name="game" value="checkers" checked />checkers <input type="checkbox" name="game" value="chess" checked />chess <input type="checkbox" name="game" value="cribbage" />cribbage),
+ 'checkbox_group()');
+
+ test(16, checkbox_group(-name=>'game',-values=>[qw/checkers chess cribbage/],-defaults=>['cribbage'],-override=>1) eq
+ qq(<input type="checkbox" name="game" value="checkers" />checkers <input type="checkbox" name="game" value="chess" />chess <input type="checkbox" name="game" value="cribbage" checked />cribbage),
+ 'checkbox_group()');
+ test(17, popup_menu(-name=>'game',-values=>[qw/checkers chess cribbage/],-default=>'cribbage',-override=>1) eq <<END,'checkbox_group()');
+ <select name="game">
+ <option value="checkers">checkers</option>
+ <option value="chess">chess</option>
+ <option selected value="cribbage">cribbage</option>
+ </select>
+ END
+
diff -c /dev/null 'perl-5.7.2/lib/CGI/t/function.t'
Index: ./lib/CGI/t/function.t
*** ./lib/CGI/t/function.t Thu Jan 1 02:00:00 1970
--- ./lib/CGI/t/function.t Mon Jul 9 17:10:27 2001
***************
*** 0 ****
--- 1,111 ----
+ #!/usr/local/bin/perl -w
+
+ BEGIN {
+ chdir('t') if -d 't';
+ @INC = '../lib';
+ }
+
+ # Test ability to retrieve HTTP request info
+ ######################### We start with some black magic to print on failure.
+ use lib '../blib/lib','../blib/arch';
+
+ BEGIN {$| = 1; print "1..27\n"; }
+ END {print "not ok 1\n" unless $loaded;}
+ use Config;
+ use CGI (':standard','keywords');
+ $loaded = 1;
+ print "ok 1\n";
+
+ ######################### End of black magic.
+
+ # util
+ sub test {
+ local($^W) = 0;
+ my($num, $true,$msg) = @_;
+ print($true ? "ok $num\n" : "not ok $num $msg\n");
+ }
+
+ my $CRLF = "\015\012";
+
+ # A peculiarity of sending "\n" through MBX|Socket|web-server on VMS
+ # is that a CR character gets inserted automatically in the web server
+ # case but not internal to perl's double quoted strings "\n". This
+ # test would need to be modified to use the "\015\012" on VMS if it
+ # were actually run through a web server.
+ # Thanks to Peter Prymmer for this
+
+ if ($^O eq 'VMS') { $CRLF = "\n"; }
+
+ # Web servers on EBCDIC hosts are typically set up to do an EBCDIC -> ASCII
+ # translation hence CRLF is used as \r\n within CGI.pm on such machines.
+
+ if (ord("\t") != 9) { $CRLF = "\r\n"; }
+
+ # Web servers on EBCDIC hosts are typically set up to do an EBCDIC -> ASCII
+ # translation hence CRLF is used as \r\n within CGI.pm on such machines.
+
+ if (ord("\t") != 9) { $CRLF = "\r\n"; }
+
+ # Set up a CGI environment
+ $ENV{REQUEST_METHOD}='GET';
+ $ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull';
+ $ENV{PATH_INFO} ='/somewhere/else';
+ $ENV{PATH_TRANSLATED} ='/usr/local/somewhere/else';
+ $ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi';
+ $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
+ $ENV{SERVER_PORT} = 8080;
+ $ENV{SERVER_NAME} = 'the.good.ship.lollypop.com';
+ $ENV{HTTP_LOVE} = 'true';
+
+ test(2,request_method() eq 'GET',"CGI::request_method()");
+ test(3,query_string() eq 'game=chess;game=checkers;weather=dull',"CGI::query_string()");
+ test(4,param() == 2,"CGI::param()");
+ test(5,join(' ',sort {$a cmp $b} param()) eq 'game weather',"CGI::param()");
+ test(6,param('game') eq 'chess',"CGI::param()");
+ test(7,param('weather') eq 'dull',"CGI::param()");
+ test(8,join(' ',param('game')) eq 'chess checkers',"CGI::param()");
+ test(9,param(-name=>'foo',-value=>'bar'),'CGI::param() put');
+ test(10,param(-name=>'foo') eq 'bar','CGI::param() get');
+ test(11,query_string() eq 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux");
+ test(12,http('love') eq 'true',"CGI::http()");
+ test(13,script_name() eq '/cgi-bin/foo.cgi',"CGI::script_name()");
+ test(14,url() eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()");
+ test(15,self_url() eq
+ 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar',
+ "CGI::url()");
+ test(16,url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)');
+ test(17,url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)');
+ test(18,url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)');
+ test(19,url(-relative=>1,-path=>1,-query=>1) eq
+ 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar',
+ 'CGI::url(-relative=>1,-path=>1,-query=>1)');
+ Delete('foo');
+ test(20,!param('foo'),'CGI::delete()');
+
+ CGI::_reset_globals();
+ $ENV{QUERY_STRING}='mary+had+a+little+lamb';
+ test(21,join(' ',keywords()) eq 'mary had a little lamb','CGI::keywords');
+ test(22,join(' ',param('keywords')) eq 'mary had a little lamb','CGI::keywords');
+
+ CGI::_reset_globals;
+ if ($Config{d_fork}) {
+ $test_string = 'game=soccer&game=baseball&weather=nice';
+ $ENV{REQUEST_METHOD}='POST';
+ $ENV{CONTENT_LENGTH}=length($test_string);
+ $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf';
+ if (open(CHILD,"|-")) { # cparent
+ print CHILD $test_string;
+ close CHILD;
+ exit 0;
+ }
+ # at this point, we're in a new (child) process
+ test(23,param('weather') eq 'nice',"CGI::param() from POST");
+ test(24,(url_param('big_balls') eq 'basketball'),"CGI::url_param()");
+ } else {
+ print "ok 23 # Skip\n";
+ print "ok 24 # Skip\n";
+ }
+ test(25,redirect('http://somewhere.else') eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}${CRLF}","CGI::redirect() 1");
+ my $h = redirect(-Location=>'http://somewhere.else',-Type=>'text/html');
+ test(26,$h eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2");
+ test(27,redirect(-Location=>'http://somewhere.else/bin/foo&bar',-Type=>'text/html') eq "Status: 302 Moved${CRLF}location: http://somewhere.else/bin/foo&bar${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2");
diff -c /dev/null 'perl-5.7.2/lib/CGI/t/html.t'
Index: ./lib/CGI/t/html.t
*** ./lib/CGI/t/html.t Thu Jan 1 02:00:00 1970
--- ./lib/CGI/t/html.t Mon Jul 9 17:10:27 2001
***************
*** 0 ****
--- 1,95 ----
+ #!/usr/local/bin/perl -w
+
+ BEGIN {
+ chdir('t') if -d 't';
+ @INC = '../lib';
+ }
+
+ # Test ability to retrieve HTTP request info
+ ######################### We start with some black magic to print on failure.
+ use lib '../blib/lib','../blib/arch';
+
+ BEGIN {$| = 1; print "1..24\n"; }
+ END {print "not ok 1\n" unless $loaded;}
+ use CGI (':standard','-no_debug','*h3','start_table');
+ $loaded = 1;
+ print "ok 1\n";
+
+ ######################### End of black magic.
+
+ my $CRLF = "\015\012";
+ if ($^O eq 'VMS') {
+ $CRLF = "\n"; # via web server carriage is inserted automatically
+ }
+ if (ord("\t") != 9) { # EBCDIC?
+ $CRLF = "\r\n";
+ }
+
+
+ # util
+ sub test {
+ local($^W) = 0;
+ my($num, $true,$msg) = @_;
+ print($true ? "ok $num\n" : "not ok $num $msg\n");
+ }
+
+ # all the automatic tags
+ test(2,h1() eq '<h1 />',"single tag");
+ test(3,h1('fred') eq '<h1>fred</h1>',"open/close tag");
+ test(4,h1('fred','agnes','maura') eq '<h1>fred agnes maura</h1>',"open/close tag multiple");
+ test(5,h1({-align=>'CENTER'},'fred') eq '<h1 align="CENTER">fred</h1>',"open/close tag with attribute");
+ test(6,h1({-align=>undef},'fred') eq '<h1 align>fred</h1>',"open/close tag with orphan attribute");
+ test(7,h1({-align=>'CENTER'},['fred','agnes']) eq
+ '<h1 align="CENTER">fred</h1> <h1 align="CENTER">agnes</h1>',
+ "distributive tag with attribute");
+ {
+ local($") = '-';
+ test(8,h1('fred','agnes','maura') eq '<h1>fred-agnes-maura</h1>',"open/close tag \$\" interpolation");
+ }
+ test(9,header() eq "Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","header()");
+ test(10,header(-type=>'image/gif') eq "Content-Type: image/gif${CRLF}${CRLF}","header()");
+ test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${CRLF}Content-Type: image/gif${CRLF}${CRLF}","header()");
+ test(12,header(-nph=>1) =~ m!HTTP/1.0 200 OK${CRLF}Server: cmdline${CRLF}Date:.+${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!,"header()");
+ test(13,start_html() ."\n" eq <<END,"start_html()");
+ <?xml version="1.0" encoding="utf-8"?>
+ <!DOCTYPE html
+ PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN"
+ "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd">
+ <html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title>
+ </head><body>
+ END
+ ;
+ test(14,start_html(-dtd=>"-//IETF//DTD HTML 3.2//FR") ."\n" eq <<END,"start_html()");
+ <!DOCTYPE html
+ PUBLIC "-//IETF//DTD HTML 3.2//FR">
+ <html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title>
+ </head><body>
+ END
+ ;
+ test(15,start_html(-Title=>'The world of foo') ."\n" eq <<END,"start_html()");
+ <?xml version="1.0" encoding="utf-8"?>
+ <!DOCTYPE html
+ PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN"
+ "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd">
+ <html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>The world of foo</title>
+ </head><body>
+ END
+ ;
+ test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) eq 'fred=chocolate&chip; path=/',"cookie()");
+ my $h = header(-Cookie=>$cookie);
+ test(17,$h =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${CRLF}Date:.*${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!s,
+ "header(-cookie)");
+ test(18,start_h3 eq '<h3>');
+ test(19,end_h3 eq '</h3>');
+ test(20,start_table({-border=>undef}) eq '<table border>');
+ test(21,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> ‹right›</h1>');
+ charset('utf-8');
+ if (ord("\t") == 9) {
+ test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> �right�</h1>');
+ }
+ else {
+ test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> �right�</h1>');
+ }
+ test(23,i(p('hello there')) eq '<i><p>hello there</p></i>');
+ my $q = new CGI;
+ test(24,$q->h1('hi') eq '<h1>hi</h1>');
diff -c /dev/null 'perl-5.7.2/lib/CGI/t/pretty.t'
Index: ./lib/CGI/t/pretty.t
*** ./lib/CGI/t/pretty.t Thu Jan 1 02:00:00 1970
--- ./lib/CGI/t/pretty.t Mon Jul 9 17:10:27 2001
***************
*** 0 ****
--- 1,41 ----
+ #!/usr/local/bin/perl -w
+
+ BEGIN {
+ chdir('t') if -d 't';
+ @INC = '../lib';
+ }
+
+ # Test ability to retrieve HTTP request info
+ ######################### We start with some black magic to print on failure.
+ use lib '../blib/lib','../blib/arch';
+
+ BEGIN {$| = 1; print "1..5\n"; }
+ END {print "not ok 1\n" unless $loaded;}
+ use CGI::Pretty (':standard','-no_debug','*h3','start_table');
+ $loaded = 1;
+ print "ok 1\n";
+
+ ######################### End of black magic.
+
+ # util
+ sub test {
+ local($^W) = 0;
+ my($num, $true,$msg) = @_;
+ print($true ? "ok $num\n" : "not ok $num $msg\n");
+ }
+
+ # all the automatic tags
+ test(2,h1() eq '<h1>',"single tag");
+ test(3,ol(li('fred'),li('ethel')) eq "<ol>\n\t<li>\n\t\tfred\n\t</li>\n\t <li>\n\t\tethel\n\t</li>\n</ol>\n","basic indentation");
+ test(4,p('hi',pre('there'),'frog') eq
+ '<p>
+ hi <pre>there</pre>
+ frog
+ </p>
+ ',"<pre> tags");
+ test(5,p('hi',a({-href=>'frog'},'there'),'frog') eq
+ '<p>
+ hi <a href="frog">there</a>
+ frog
+ </p>
+ ',"as-is");
diff -c /dev/null 'perl-5.7.2/lib/CGI/t/request.t'
Index: ./lib/CGI/t/request.t
*** ./lib/CGI/t/request.t Thu Jan 1 02:00:00 1970
--- ./lib/CGI/t/request.t Mon Jul 9 17:10:27 2001
***************
*** 0 ****
--- 1,103 ----
+ #!/usr/local/bin/perl -w
+
+ BEGIN {
+ chdir('t') if -d 't';
+ @INC = '../lib';
+ }
+
+ # Test ability to retrieve HTTP request info
+ ######################### We start with some black magic to print on failure.
+ use lib '../blib/lib','../blib/arch';
+
+ BEGIN {$| = 1; print "1..33\n"; }
+ END {print "not ok 1\n" unless $loaded;}
+ use CGI ();
+ use Config;
+ $loaded = 1;
+ print "ok 1\n";
+
+ ######################### End of black magic.
+
+ # util
+ sub test {
+ local($^W) = 0;
+ my($num, $true,$msg) = @_;
+ print($true ? "ok $num\n" : "not ok $num $msg\n");
+ }
+
+ # Set up a CGI environment
+ $ENV{REQUEST_METHOD} = 'GET';
+ $ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull';
+ $ENV{PATH_INFO} = '/somewhere/else';
+ $ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else';
+ $ENV{SCRIPT_NAME} = '/cgi-bin/foo.cgi';
+ $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
+ $ENV{SERVER_PORT} = 8080;
+ $ENV{SERVER_NAME} = 'the.good.ship.lollypop.com';
+ $ENV{REQUEST_URI} = "$ENV{SCRIPT_NAME}$ENV{PATH_INFO}?$ENV{QUERY_STRING}";
+ $ENV{HTTP_LOVE} = 'true';
+
+ $q = new CGI;
+ test(2,$q,"CGI::new()");
+ test(3,$q->request_method eq 'GET',"CGI::request_method()");
+ test(4,$q->query_string eq 'game=chess;game=checkers;weather=dull',"CGI::query_string()");
+ test(5,$q->param() == 2,"CGI::param()");
+ test(6,join(' ',sort $q->param()) eq 'game weather',"CGI::param()");
+ test(7,$q->param('game') eq 'chess',"CGI::param()");
+ test(8,$q->param('weather') eq 'dull',"CGI::param()");
+ test(9,join(' ',$q->param('game')) eq 'chess checkers',"CGI::param()");
+ test(10,$q->param(-name=>'foo',-value=>'bar'),'CGI::param() put');
+ test(11,$q->param(-name=>'foo') eq 'bar','CGI::param() get');
+ test(12,$q->query_string eq 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux");
+ test(13,$q->http('love') eq 'true',"CGI::http()");
+ test(14,$q->script_name eq '/cgi-bin/foo.cgi',"CGI::script_name()");
+ test(15,$q->url eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()");
+ test(16,$q->self_url eq
+ 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar',
+ "CGI::url()");
+ test(17,$q->url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)');
+ test(18,$q->url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)');
+ test(19,$q->url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)');
+ test(20,$q->url(-relative=>1,-path=>1,-query=>1) eq
+ 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar',
+ 'CGI::url(-relative=>1,-path=>1,-query=>1)');
+ $q->delete('foo');
+ test(21,!$q->param('foo'),'CGI::delete()');
+
+ $q->_reset_globals;
+ $ENV{QUERY_STRING}='mary+had+a+little+lamb';
+ test(22,$q=new CGI,"CGI::new() redux");
+ test(23,join(' ',$q->keywords) eq 'mary had a little lamb','CGI::keywords');
+ test(24,join(' ',$q->param('keywords')) eq 'mary had a little lamb','CGI::keywords');
+ test(25,$q=new CGI('foo=bar&foo=baz'),"CGI::new() redux");
+ test(26,$q->param('foo') eq 'bar','CGI::param() redux');
+ test(27,$q=new CGI({'foo'=>'bar','bar'=>'froz'}),"CGI::new() redux 2");
+ test(28,$q->param('bar') eq 'froz',"CGI::param() redux 2");
+
+ # test tied interface
+ my $p = $q->Vars;
+ test(29,$p->{bar} eq 'froz',"tied interface fetch");
+ $p->{bar} = join("\0",qw(foo bar baz));
+ test(30,join(' ',$q->param('bar')) eq 'foo bar baz','tied interface store');
+
+ # test posting
+ $q->_reset_globals;
+ if ($Config{d_fork}) {
+ $test_string = 'game=soccer&game=baseball&weather=nice';
+ $ENV{REQUEST_METHOD}='POST';
+ $ENV{CONTENT_LENGTH}=length($test_string);
+ $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf';
+ if (open(CHILD,"|-")) { # cparent
+ print CHILD $test_string;
+ close CHILD;
+ exit 0;
+ }
+ # at this point, we're in a new (child) process
+ test(31,$q=new CGI,"CGI::new() from POST");
+ test(32,$q->param('weather') eq 'nice',"CGI::param() from POST");
+ test(33,$q->url_param('big_balls') eq 'basketball',"CGI::url_param()");
+ } else {
+ print "ok 31 # Skip\n";
+ print "ok 32 # Skip\n";
+ print "ok 33 # Skip\n";
+ }
diff -c /dev/null 'perl-5.7.2/lib/CGI/t/util.t'
Index: ./lib/CGI/t/util.t
*** ./lib/CGI/t/util.t Thu Jan 1 02:00:00 1970
--- ./lib/CGI/t/util.t Mon Jul 9 17:10:27 2001
***************
*** 0 ****
--- 1,56 ----
+ #!/usr/local/bin/perl -w
+
+ BEGIN {
+ chdir('t') if -d 't';
+ @INC = '../lib';
+ }
+
+ # Test ability to escape() and unescape() punctuation characters
+ # except for qw(- . _).
+ ######################### We start with some black magic to print on failure.
+ use lib '../blib/lib','../blib/arch';
+
+ BEGIN {$| = 1; print "1..59\n"; }
+ END {print "not ok 1\n" unless $loaded;}
+ use Config;
+ use CGI::Util qw(escape unescape);
+ $loaded = 1;
+ print "ok 1\n";
+
+ ######################### End of black magic.
+
+ # util
+ sub test {
+ local($^W) = 0;
+ my($num, $true,$msg) = @_;
+ print($true ? "ok $num\n" : "not ok $num $msg\n");
+ }
+
+ # ASCII order, ASCII codepoints, ASCII repertoire
+
+ my %punct = (
+ ' ' => '20', '!' => '21', '"' => '22', '#' => '23',
+ '$' => '24', '%' => '25', '&' => '26', '\'' => '27',
+ '(' => '28', ')' => '29', '*' => '2A', '+' => '2B',
+ ',' => '2C', '/' => '2F', # '-' => '2D', '.' => '2E'
+ ':' => '3A', ';' => '3B', '<' => '3C', '=' => '3D',
+ '>' => '3E', '?' => '3F', '[' => '5B', '\\' => '5C',
+ ']' => '5D', '^' => '5E', '`' => '60', # '_' => '5F',
+ '{' => '7B', '|' => '7C', '}' => '7D', '~' => '7E',
+ );
+
+ # The sort order may not be ASCII on EBCDIC machines:
+
+ my $i = 1;
+
+ foreach(sort(keys(%punct))) {
+ $i++;
+ my $escape = "AbC\%$punct{$_}dEF";
+ my $cgi_escape = escape("AbC$_" . "dEF");
+ test($i, $escape eq $cgi_escape , "# $escape ne $cgi_escape");
+ $i++;
+ my $unescape = "AbC$_" . "dEF";
+ my $cgi_unescape = unescape("AbC\%$punct{$_}dEF");
+ test($i, $unescape eq $cgi_unescape , "# $unescape ne $cgi_unescape");
+ }
+
diff -c 'perl-5.7.1/lib/CPAN.pm' 'perl-5.7.2/lib/CPAN.pm'
Index: ./lib/CPAN.pm
Prereq: 1.385
*** ./lib/CPAN.pm Fri Mar 16 04:54:48 2001
--- ./lib/CPAN.pm Mon Jul 9 17:10:27 2001
***************
*** 3360,3366 ****
# does initialize to some protocol
$LAST_TIME = $cache->{last_time};
$DATE_OF_02 = $cache->{DATE_OF_02};
! $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n");
return;
}
--- 3360,3367 ----
# does initialize to some protocol
$LAST_TIME = $cache->{last_time};
$DATE_OF_02 = $cache->{DATE_OF_02};
! $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
! if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
return;
}
***************
*** 4417,4423 ****
} else {
$self->{writemakefile} =
qq{NO Makefile.PL refused to write a Makefile.};
! # It's probably worth to record the reason, so let's retry
# local $/;
# my $fh = IO::File->new("$system |"); # STDERR? STDIN?
# $self->{writemakefile} .= <$fh>;
--- 4418,4424 ----
} else {
$self->{writemakefile} =
qq{NO Makefile.PL refused to write a Makefile.};
! # It's probably worth it to record the reason, so let's retry
# local $/;
# my $fh = IO::File->new("$system |"); # STDERR? STDIN?
# $self->{writemakefile} .= <$fh>;
***************
*** 6063,6072 ****
Modules know their associated Distribution objects. They always refer
to the most recent official release. Developers may mark their releases
as unstable development versions (by inserting an underbar into the
! visible version number), so the really hottest and newest distribution
! file is not always the default. If a module Foo circulates on CPAN in
! both version 1.23 and 1.23_90, CPAN.pm offers a convenient way to
! install version 1.23 by saying
install Foo
--- 6064,6074 ----
Modules know their associated Distribution objects. They always refer
to the most recent official release. Developers may mark their releases
as unstable development versions (by inserting an underbar into the
! module version number which will also be reflected in the distribution
! name when you run 'make dist'), so the really hottest and newest
! distribution is not always the default. If a module Foo circulates
! on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
! way to install version 1.23 by saying
install Foo
diff -c 'perl-5.7.1/lib/CPAN/Nox.pm' 'perl-5.7.2/lib/CPAN/Nox.pm'
Index: ./lib/CPAN/Nox.pm
*** ./lib/CPAN/Nox.pm Tue Mar 6 04:05:25 2001
--- ./lib/CPAN/Nox.pm Mon Jul 9 17:10:27 2001
***************
*** 9,15 ****
use base 'Exporter';
use CPAN;
! $VERSION = "1.00";
$CPAN::META->has_inst('MD5','no');
$CPAN::META->has_inst('LWP','no');
$CPAN::META->has_inst('Compress::Zlib','no');
--- 9,15 ----
use base 'Exporter';
use CPAN;
! $VERSION = "1.00_00";
$CPAN::META->has_inst('MD5','no');
$CPAN::META->has_inst('LWP','no');
$CPAN::META->has_inst('Compress::Zlib','no');
***************
*** 32,39 ****
=head1 DESCRIPTION
This package has the same functionality as CPAN.pm, but tries to
! prevent the usage of compiled extensions during it's own
! execution. It's primary purpose is a rescue in case you upgraded perl
and broke binary compatibility somehow.
=head1 SEE ALSO
--- 32,39 ----
=head1 DESCRIPTION
This package has the same functionality as CPAN.pm, but tries to
! prevent the usage of compiled extensions during its own
! execution. Its primary purpose is a rescue in case you upgraded perl
and broke binary compatibility somehow.
=head1 SEE ALSO
diff -c /dev/null 'perl-5.7.2/lib/CPAN/t/loadme.t'
Index: ./lib/CPAN/t/loadme.t
*** ./lib/CPAN/t/loadme.t Thu Jan 1 02:00:00 1970
--- ./lib/CPAN/t/loadme.t Mon Jul 9 17:10:28 2001
***************
*** 0 ****
--- 1,16 ----
+ #!/usr/bin/perl -w
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ BEGIN {
+ print "1..1\n";
+ }
+ use strict;
+ use CPAN;
+ use CPAN::FirstTime;
+
+ print "ok 1\n";
+
diff -c /dev/null 'perl-5.7.2/lib/CPAN/t/vcmp.t'
Index: ./lib/CPAN/t/vcmp.t
*** ./lib/CPAN/t/vcmp.t Thu Jan 1 02:00:00 1970
--- ./lib/CPAN/t/vcmp.t Mon Jul 9 17:10:28 2001
***************
*** 0 ****
--- 1,62 ----
+ # -*- Mode: cperl; coding: utf-8; -*-
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use strict;
+ use CPAN;
+ use vars qw($D $N);
+
+ while (<DATA>) {
+ next if /^v/ && $]<5.006; # v-string tests are not for pre-5.6.0
+ chomp;
+ s/\s*#.*//;
+ push @$D, [ split ];
+ }
+
+ $N = scalar @$D;
+ print "1..$N\n";
+
+ while (@$D) {
+ my($l,$r,$exp) = @{shift @$D};
+ my $res = CPAN::Version->vcmp($l,$r);
+ if ($res != $exp){
+ print "# l[$l]r[$r]exp[$exp]res[$res]\n";
+ print "not ";
+ }
+ print "ok ", $N-@$D, "\n";
+ }
+
+ __END__
+ 0 0 0
+ 1 0 1
+ 0 1 -1
+ 1 1 0
+ 1.1 0.0a 1
+ 1.1a 0.0 1
+ 1.2.3 1.1.1 1
+ v1.2.3 v1.1.1 1
+ v1.2.3 v1.2.1 1
+ v1.2.3 v1.2.11 -1
+ 1.2.3 1.2.11 1 # not what they wanted
+ 1.9 1.10 1
+ VERSION VERSION 0
+ 0.02 undef 1
+ 1.57_00 1.57 1
+ 1.5700 1.57 1
+ 1.57_01 1.57 1
+ 0.2.10 0.2 1
+ 20000000.00 19990108 1
+ 1.00 0.96 1
+ 0.7.02 0.7 1
+ 1.3a5 1.3 1
+ undef 1.00 -1
+ v1.0 undef 1
+ v0.2.4 0.24 -1
+ v1.0.22 122 -1
+ 5.00556 v5.5.560 0
+ 5.005056 v5.5.56 0
+ 5.00557 v5.5.560 1
+ 5.00056 v5.0.561 -1
diff -c 'perl-5.7.1/lib/Carp.pm' 'perl-5.7.2/lib/Carp.pm'
Index: ./lib/Carp.pm
*** ./lib/Carp.pm Tue Mar 6 04:05:25 2001
--- ./lib/Carp.pm Mon Jul 9 17:10:28 2001
***************
*** 21,26 ****
--- 21,29 ----
use Carp qw(cluck);
cluck "This is how we got here!";
+ print FH Carp::shortmess("This will have caller's details added");
+ print FH Carp::longmess("This will have stack backtrace added");
+
=head1 DESCRIPTION
The Carp routines are useful in your own modules because
***************
*** 30,35 ****
--- 33,43 ----
will report the error as occurring where Foo() was called,
not where carp() was called.
+ The routine shortmess() can be used to generate the string that
+ carp/croak would have produced. The routine longmess() can be
+ used to generate the backtrace that cluck/confess would have
+ produced.
+
=head2 Forcing a Stack Trace
As a debugging aid, you can force Carp to treat a croak as a confess
***************
*** 75,81 ****
require Exporter;
@ISA = ('Exporter');
@EXPORT = qw(confess croak carp);
! @EXPORT_OK = qw(cluck verbose);
@EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
--- 83,89 ----
require Exporter;
@ISA = ('Exporter');
@EXPORT = qw(confess croak carp);
! @EXPORT_OK = qw(cluck verbose longmess shortmess);
@EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
diff -c /dev/null 'perl-5.7.2/lib/Carp.t'
Index: ./lib/Carp.t
*** ./lib/Carp.t Thu Jan 1 02:00:00 1970
--- ./lib/Carp.t Mon Jul 9 17:10:28 2001
***************
*** 0 ****
--- 1,53 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use Carp qw(carp cluck croak confess);
+
+ print "1..7\n";
+
+ print "ok 1\n";
+
+ $SIG{__WARN__} = sub {
+ print "ok $1\n"
+ if $_[0] =~ m!ok (\d+)$! };
+
+ carp "ok 2\n";
+
+ $SIG{__WARN__} = sub {
+ print "ok $1\n"
+ if $_[0] =~ m!(\d+) at .+\b(?i:carp\.t) line \d+$! };
+
+ carp 3;
+
+ sub sub_4 {
+
+ $SIG{__WARN__} = sub {
+ print "ok $1\n"
+ if $_[0] =~ m!^(\d+) at .+\b(?i:carp\.t) line \d+\n\tmain::sub_4\(\) called at .+\b(?i:carp\.t) line \d+$! };
+
+ cluck 4;
+
+ }
+
+ sub_4;
+
+ $SIG{__DIE__} = sub {
+ print "ok $1\n"
+ if $_[0] =~ m!^(\d+) at .+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at .+\b(?i:carp\.t) line \d+$! };
+
+ eval { croak 5 };
+
+ sub sub_6 {
+ $SIG{__DIE__} = sub {
+ print "ok $1\n"
+ if $_[0] =~ m!^(\d+) at .+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at .+\b(?i:carp\.t) line \d+\n\tmain::sub_6\(\) called at .+\b(?i:carp\.t) line \d+$! };
+
+ eval { confess 6 };
+ }
+
+ sub_6;
+
+ print "ok 7\n";
+
diff -c 'perl-5.7.1/lib/Carp/Heavy.pm' 'perl-5.7.2/lib/Carp/Heavy.pm'
Index: ./lib/Carp/Heavy.pm
*** ./lib/Carp/Heavy.pm Fri Mar 9 03:25:56 2001
--- ./lib/Carp/Heavy.pm Mon Jul 9 17:10:28 2001
***************
*** 28,35 ****
my $sub_name = Carp::get_subname(\%call_info);
if ($call_info{has_args}) {
! # Reuse the @args array to avoid warnings. :-)
! local @args = map {Carp::format_arg($_)} @args;
if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
$#args = $MaxArgNums;
push @args, '...';
--- 28,34 ----
my $sub_name = Carp::get_subname(\%call_info);
if ($call_info{has_args}) {
! my @args = map {Carp::format_arg($_)} @args;
if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
$#args = $MaxArgNums;
push @args, '...';
***************
*** 59,65 ****
# The following handling of "control chars" is direct from
# the original code - I think it is broken on Unicode though.
# Suggestions?
! $arg =~ s/([[:cntrl:]]|[[^:ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
return $arg;
}
--- 58,64 ----
# The following handling of "control chars" is direct from
# the original code - I think it is broken on Unicode though.
# Suggestions?
! $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
return $arg;
}
***************
*** 120,126 ****
sub longmess_heavy {
! return @_ if ref($_[0]); # WHAT IS THIS FOR???
my $i = long_error_loc();
return ret_backtrace($i, @_);
}
--- 119,125 ----
sub longmess_heavy {
! return @_ if ref($_[0]); # don't break references as exceptions
my $i = long_error_loc();
return ret_backtrace($i, @_);
}
***************
*** 139,157 ****
$tid_msg = " thread $tid" if $tid;
}
! if ($err =~ /\n$/) {
$mess = $err;
}
else {
my %i = caller_info($i);
$mess = "$err at $i{file} line $i{line}$tid_msg\n";
! }
while (my %i = caller_info(++$i)) {
$mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
}
! return $mess || $err;
}
sub ret_summary {
--- 138,156 ----
$tid_msg = " thread $tid" if $tid;
}
! { if ($err =~ /\n$/) { # extra block to localise $1 etc
$mess = $err;
}
else {
my %i = caller_info($i);
$mess = "$err at $i{file} line $i{line}$tid_msg\n";
! }}
while (my %i = caller_info(++$i)) {
$mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
}
! return $mess;
}
sub ret_summary {
***************
*** 190,196 ****
sub shortmess_heavy {
return longmess_heavy(@_) if $Verbose;
! return @_ if ref($_[0]); # WHAT IS THIS FOR???
my $i = short_error_loc();
if ($i) {
ret_summary($i, @_);
--- 189,195 ----
sub shortmess_heavy {
return longmess_heavy(@_) if $Verbose;
! return @_ if ref($_[0]); # don't break references as exceptions
my $i = short_error_loc();
if ($i) {
ret_summary($i, @_);
diff -c /dev/null 'perl-5.7.2/lib/Class/ISA/test.pl'
Index: ./lib/Class/ISA/test.pl
*** ./lib/Class/ISA/test.pl Thu Jan 1 02:00:00 1970
--- ./lib/Class/ISA/test.pl Mon Jul 9 17:10:28 2001
***************
*** 0 ****
--- 1,40 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # Before `make install' is performed this script should be runnable with
+ # `make test'. After `make install' it should work as `perl test.pl'
+
+ ######################### We start with some black magic to print on failure.
+
+ # Change 1..1 below to 1..last_test_to_print .
+ # (It may become useful if the test is moved to ./t subdirectory.)
+
+ BEGIN { $| = 1; print "1..2\n"; }
+ END {print "not ok 1\n" unless $loaded;}
+ use Class::ISA;
+ $loaded = 1;
+ print "ok 1\n";
+
+ ######################### End of black magic.
+
+ # Insert your test code below (better if it prints "ok 13"
+ # (correspondingly "not ok 13") depending on the success of chunk 13
+ # of the test code):
+
+ @Food::Fishstick::ISA = qw(Food::Fish Life::Fungus Chemicals);
+ @Food::Fish::ISA = qw(Food);
+ @Food::ISA = qw(Matter);
+ @Life::Fungus::ISA = qw(Life);
+ @Chemicals::ISA = qw(Matter);
+ @Life::ISA = qw(Matter);
+ @Matter::ISA = qw();
+
+ use Class::ISA;
+ my @path = Class::ISA::super_path('Food::Fishstick');
+ my $flat_path = join ' ', @path;
+ print "# Food::Fishstick path is:\n# $flat_path\n";
+ print "not " unless
+ "Food::Fish Food Matter Life::Fungus Life Chemicals" eq $flat_path;
+ print "ok 2\n";
diff -c 'perl-5.7.1/lib/Class/Struct.pm' 'perl-5.7.2/lib/Class/Struct.pm'
Index: ./lib/Class/Struct.pm
*** ./lib/Class/Struct.pm Fri Mar 16 04:54:48 2001
--- ./lib/Class/Struct.pm Mon Jul 9 17:10:28 2001
***************
*** 14,20 ****
@ISA = qw(Exporter);
@EXPORT = qw(struct);
! $VERSION = '0.59';
## Tested on 5.002 and 5.003 without class membership tests:
my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95);
--- 14,20 ----
@ISA = qw(Exporter);
@EXPORT = qw(struct);
! $VERSION = '0.60';
## Tested on 5.002 and 5.003 without class membership tests:
my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95);
***************
*** 203,213 ****
if( defined $arrays{$name} ){
$out .= " my \$i;\n";
$out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
$sel = "->[\$i]";
}
elsif( defined $hashes{$name} ){
$out .= " my \$i;\n";
! $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
$sel = "->{\$i}";
}
elsif( defined $classes{$name} ){
--- 203,215 ----
if( defined $arrays{$name} ){
$out .= " my \$i;\n";
$out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
+ $out .= " if (ref(\$i) eq 'ARRAY' && !\@_) { \$r->$elem = \$i; return \$r }\n";
$sel = "->[\$i]";
}
elsif( defined $hashes{$name} ){
$out .= " my \$i;\n";
! $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
! $out .= " if (ref(\$i) eq 'HASH' && !\@_) { \$r->$elem = \$i; return \$r }\n";
$sel = "->{\$i}";
}
elsif( defined $classes{$name} ){
***************
*** 389,394 ****
--- 391,400 ----
element type is C<'*@'>, a reference to the array element is
returned.
+ As a special case, when the accessor is called with an array reference
+ as the sole argument, this causes an assignment of the whole array element.
+ The object reference is returned.
+
=item Hash (C<'%'> or C<'*%'>)
The element is a hash, initialized by default to C<()>.
***************
*** 403,408 ****
--- 409,418 ----
accessor returns the hash element value. If the element type is
C<'*%'>, a reference to the hash element is returned.
+ As a special case, when the accessor is called with a hash reference
+ as the sole argument, this causes an assignment of the whole hash element.
+ The object reference is returned.
+
=item Class (C<'Class_Name'> or C<'*Class_Name'>)
The element's value must be a reference blessed to the named
***************
*** 546,552 ****
=head1 Author and Modification History
! Modified by Casey Tweten, 2000-11-08, v0.59.
Added the ability for compile time class creation.
--- 556,562 ----
=head1 Author and Modification History
! Modified by Casey West, 2000-11-08, v0.59.
Added the ability for compile time class creation.
diff -c /dev/null 'perl-5.7.2/lib/Class/Struct.t'
Index: ./lib/Class/Struct.t
*** ./lib/Class/Struct.t Thu Jan 1 02:00:00 1970
--- ./lib/Class/Struct.t Mon Jul 9 17:10:28 2001
***************
*** 0 ****
--- 1,76 ----
+ #!./perl -w
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ print "1..10\n";
+
+ package aClass;
+
+ sub new { bless {}, shift }
+
+ sub meth { 42 }
+
+ package MyObj;
+
+ use Class::Struct;
+ use Class::Struct 'struct'; # test out both forms
+
+ use Class::Struct SomeClass => { SomeElem => '$' };
+
+ struct( s => '$', a => '@', h => '%', c => 'aClass' );
+
+ my $obj = MyObj->new;
+
+ $obj->s('foo');
+
+ print "not " unless $obj->s() eq 'foo';
+ print "ok 1\n";
+
+ my $arf = $obj->a;
+
+ print "not " unless ref $arf eq 'ARRAY';
+ print "ok 2\n";
+
+ $obj->a(2, 'secundus');
+
+ print "not " unless $obj->a(2) eq 'secundus';
+ print "ok 3\n";
+
+ my $hrf = $obj->h;
+
+ print "not " unless ref $hrf eq 'HASH';
+ print "ok 4\n";
+
+ $obj->h('x', 10);
+
+ print "not " unless $obj->h('x') == 10;
+ print "ok 5\n";
+
+ my $orf = $obj->c;
+
+ print "not " unless ref $orf eq 'aClass';
+ print "ok 6\n";
+
+ print "not " unless $obj->c->meth() == 42;
+ print "ok 7\n";
+
+ my $obk = SomeClass->new();
+
+ $obk->SomeElem(123);
+
+ print "not " unless $obk->SomeElem() == 123;
+ print "ok 8\n";
+
+ $obj->a([4,5,6]);
+
+ print "not " unless $obj->a(1) == 5;
+ print "ok 9\n";
+
+ $obj->h({h=>7,r=>8,f=>9});
+
+ print "not " unless $obj->h('r') == 8;
+ print "ok 10\n";
+
diff -c 'perl-5.7.1/lib/Cwd.pm' 'perl-5.7.2/lib/Cwd.pm'
Index: ./lib/Cwd.pm
*** ./lib/Cwd.pm Sat Mar 31 21:35:30 2001
--- ./lib/Cwd.pm Mon Jul 9 17:10:28 2001
***************
*** 1,5 ****
package Cwd;
! require 5.000;
=head1 NAME
--- 1,5 ----
package Cwd;
! require 5.6.0;
=head1 NAME
***************
*** 73,78 ****
--- 73,100 ----
L<perlsub/Overriding Builtin Functions>.) Note that it will only be
kept up to date if all packages which use chdir import it from Cwd.
+ =head1 NOTES
+
+ =over 4
+
+ =item *
+
+ On Mac OS (Classic), the path separator is ':', not '/', and the
+ current directory is denoted as ':', not '.'. To move up the directory
+ tree, you will use '::' to move up one level, but ':::' and so on to
+ move up the tree two or more levels (i.e. the equivalent to '../../..'
+ is '::::'). Generally, you 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.
+
+ Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
+ functions are all aliases for the C<cwd()> function, which, on Mac OS,
+ calls `pwd`. Likewise, the C<abs_path()> function is an alias for
+ C<fast_abs_path()>.
+
+ =back
+
=cut
use strict;
***************
*** 79,91 ****
use Carp;
! our $VERSION = '2.04';
use base qw/ Exporter /;
our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
# The 'natural and safe form' for UNIX (pwd may be setuid root)
sub _backtick_pwd {
--- 101,136 ----
use Carp;
! our $VERSION = '2.05';
use base qw/ Exporter /;
our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
+ # sys_cwd may keep the builtin command
+ # All the functionality of this module may provided by builtins,
+ # there is no sense to process the rest of the file.
+ # The best choice may be to have this in BEGIN, but how to return from BEGIN?
+
+ if ($^O eq 'os2' && defined &sys_cwd && defined &sys_abspath) {
+ local $^W = 0;
+ *cwd = \&sys_cwd;
+ *getcwd = \&cwd;
+ *fastgetcwd = \&cwd;
+ *fastcwd = \&cwd;
+ *abs_path = \&sys_abspath;
+ *fast_abs_path = \&abs_path;
+ *realpath = \&abs_path;
+ *fast_realpath = \&abs_path;
+ return 1;
+ }
+
+ eval {
+ require XSLoader;
+ XSLoader::load('Cwd');
+ };
+
# The 'natural and safe form' for UNIX (pwd may be setuid root)
sub _backtick_pwd {
***************
*** 121,140 ****
abs_path('.');
}
- # Now a callout to an XSUB. We have to delay booting of the XSUB
- # until the first time fastcwd is called since Cwd::cwd is needed in the
- # building of perl when dynamic loading may be unavailable
- my $booted = 0;
- sub fastcwd {
- unless ($booted) {
- require XSLoader;
- XSLoader::load("Cwd");
- ++$booted;
- }
- return &Cwd::_fastcwd;
- }
-
-
# Keeps track of current working directory in PWD environment var
# Usage:
# use Cwd 'chdir';
--- 166,171 ----
***************
*** 205,267 ****
1;
}
- # Taken from Cwd.pm It is really getcwd with an optional
- # parameter instead of '.'
- #
-
- sub abs_path
- {
- my $start = @_ ? shift : '.';
- my($dotdots, $cwd, @pst, @cst, $dir, @tst);
-
- unless (@cst = stat( $start ))
- {
- carp "stat($start): $!";
- return '';
- }
- $cwd = '';
- $dotdots = $start;
- do
- {
- $dotdots .= '/..';
- @pst = @cst;
- unless (opendir(PARENT, $dotdots))
- {
- carp "opendir($dotdots): $!";
- return '';
- }
- unless (@cst = stat($dotdots))
- {
- carp "stat($dotdots): $!";
- closedir(PARENT);
- return '';
- }
- if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
- {
- $dir = undef;
- }
- else
- {
- do
- {
- unless (defined ($dir = readdir(PARENT)))
- {
- carp "readdir($dotdots): $!";
- closedir(PARENT);
- return '';
- }
- $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
- }
- while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
- $tst[1] != $pst[1]);
- }
- $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
- closedir(PARENT);
- } while (defined $dir);
- chop($cwd) unless $cwd eq '/'; # drop the trailing /
- $cwd;
- }
-
# added function alias for those of us more
# used to the libc function. --tchrist 27-Jan-00
*realpath = \&abs_path;
--- 236,241 ----
***************
*** 268,274 ****
sub fast_abs_path {
my $cwd = getcwd();
! my $path = @_ ? shift : '.';
CORE::chdir($path) || croak "Cannot chdir to $path:$!";
my $realpath = getcwd();
CORE::chdir($cwd) || croak "Cannot chdir back to $cwd:$!";
--- 242,249 ----
sub fast_abs_path {
my $cwd = getcwd();
! require File::Spec;
! my $path = @_ ? shift : File::Spec->curdir;
CORE::chdir($path) || croak "Cannot chdir to $path:$!";
my $realpath = getcwd();
CORE::chdir($cwd) || croak "Cannot chdir back to $cwd:$!";
***************
*** 382,388 ****
*fastcwd = \&_dos_cwd;
*abs_path = \&fast_abs_path;
}
! elsif ($^O eq 'qnx') {
*cwd = \&_qnx_cwd;
*getcwd = \&_qnx_cwd;
*fastgetcwd = \&_qnx_cwd;
--- 357,363 ----
*fastcwd = \&_dos_cwd;
*abs_path = \&fast_abs_path;
}
! elsif ($^O =~ m/^(?:qnx|nto)$/ ) {
*cwd = \&_qnx_cwd;
*getcwd = \&_qnx_cwd;
*fastgetcwd = \&_qnx_cwd;
diff -c 'perl-5.7.1/lib/Devel/SelfStubber.pm' 'perl-5.7.2/lib/Devel/SelfStubber.pm'
Index: ./lib/Devel/SelfStubber.pm
*** ./lib/Devel/SelfStubber.pm Tue Mar 6 04:05:26 2001
--- ./lib/Devel/SelfStubber.pm Mon Jul 9 17:10:28 2001
***************
*** 3,9 ****
@ISA = qw(SelfLoader);
@EXPORT = 'AUTOLOAD';
$JUST_STUBS = 1;
! $VERSION = 1.01; sub Version {$VERSION}
# Use as
# perl -e 'use Devel::SelfStubber;Devel::SelfStubber->stub(MODULE_NAME,LIB)'
--- 3,10 ----
@ISA = qw(SelfLoader);
@EXPORT = 'AUTOLOAD';
$JUST_STUBS = 1;
! $VERSION = 1.03;
! sub Version {$VERSION}
# Use as
# perl -e 'use Devel::SelfStubber;Devel::SelfStubber->stub(MODULE_NAME,LIB)'
***************
*** 27,54 ****
sub stub {
my($self,$module,$lib) = @_;
! my($line,$end,$fh,$mod_file,$found_selfloader);
$lib ||= '.';
($mod_file = $module) =~ s,::,/,g;
$mod_file = "$lib/$mod_file.pm";
$fh = "${module}::DATA";
open($fh,$mod_file) || die "Unable to open $mod_file";
while(defined ($line = <$fh>) and $line !~ m/^__DATA__/) {
push(@BEFORE_DATA,$line);
$line =~ /use\s+SelfLoader/ && $found_selfloader++;
}
! $line =~ m/^__DATA__/ || die "$mod_file doesn't contain a __DATA__ token";
$found_selfloader ||
print 'die "\'use SelfLoader;\' statement NOT FOUND!!\n"',"\n";
! $self->_load_stubs($module);
if ( fileno($fh) ) {
! $end = 1;
while(defined($line = <$fh>)) {
push(@AFTER_DATA,$line);
}
}
unless ($JUST_STUBS) {
print @BEFORE_DATA;
}
--- 28,64 ----
sub stub {
my($self,$module,$lib) = @_;
! my($line,$end_data,$fh,$mod_file,$found_selfloader);
$lib ||= '.';
($mod_file = $module) =~ s,::,/,g;
$mod_file = "$lib/$mod_file.pm";
$fh = "${module}::DATA";
+ my (@BEFORE_DATA, @AFTER_DATA, @AFTER_END);
+ @DATA = @STUBS = ();
open($fh,$mod_file) || die "Unable to open $mod_file";
+ local $/ = "\n";
while(defined ($line = <$fh>) and $line !~ m/^__DATA__/) {
push(@BEFORE_DATA,$line);
$line =~ /use\s+SelfLoader/ && $found_selfloader++;
}
! (defined ($line) && $line =~ m/^__DATA__/)
! || die "$mod_file doesn't contain a __DATA__ token";
$found_selfloader ||
print 'die "\'use SelfLoader;\' statement NOT FOUND!!\n"',"\n";
! if ($JUST_STUBS) {
! $self->_load_stubs($module);
! } else {
! $self->_load_stubs($module, \@AFTER_END);
! }
if ( fileno($fh) ) {
! $end_data = 1;
while(defined($line = <$fh>)) {
push(@AFTER_DATA,$line);
}
}
+ close($fh);
unless ($JUST_STUBS) {
print @BEFORE_DATA;
}
***************
*** 55,61 ****
print @STUBS;
unless ($JUST_STUBS) {
print "1;\n__DATA__\n",@DATA;
! if($end) { print "__END__\n",@AFTER_DATA; }
}
}
--- 65,72 ----
print @STUBS;
unless ($JUST_STUBS) {
print "1;\n__DATA__\n",@DATA;
! if($end_data) { print "__END__ DATA\n",@AFTER_DATA; }
! if(@AFTER_END) { print "__END__\n",@AFTER_END; }
}
}
diff -c /dev/null 'perl-5.7.2/lib/Devel/SelfStubber.t'
Index: ./lib/Devel/SelfStubber.t
*** ./lib/Devel/SelfStubber.t Thu Jan 1 02:00:00 1970
--- ./lib/Devel/SelfStubber.t Mon Jul 9 17:10:28 2001
***************
*** 0 ****
--- 1,285 ----
+ #!./perl -w
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use strict;
+ use Devel::SelfStubber;
+
+ my $runperl = "$^X \"-I../lib\"";
+
+ # ensure correct output ordering for system() calls
+
+ select STDERR; $| = 1; select STDOUT; $| = 1;
+
+ print "1..12\n";
+
+ my @cleanup;
+
+ END {
+ foreach my $file (reverse @cleanup) {
+ unlink $file or warn "unlink $file failed: $!" while -f $file;
+ rmdir $file or warn "rmdir $file failed: $!" if -d $file;
+ }
+ }
+
+ my $inlib = "SSI-$$";
+ mkdir $inlib, 0777 or die $!;
+ push @cleanup, $inlib;
+
+ while (<DATA>) {
+ if (/^\#{16,}\s+(.*)/) {
+ my $file = "$inlib/$1";
+ push @cleanup, $file;
+ open FH, ">$file" or die $!;
+ } else {
+ print FH;
+ }
+ }
+ close FH;
+
+ {
+ my $file = "A-$$";
+ push @cleanup, $file;
+ open FH, ">$file" or die $!;
+ select FH;
+ Devel::SelfStubber->stub('Child', $inlib);
+ select STDOUT;
+ print "ok 1\n";
+ close FH or die $!;
+
+ open FH, $file or die $!;
+ my @A = <FH>;
+
+ if (@A == 1 && $A[0] =~ /^\s*sub\s+Child::foo\s*;\s*$/) {
+ print "ok 2\n";
+ } else {
+ print "not ok 2\n";
+ print "# $_" foreach (@A);
+ }
+ }
+
+ {
+ my $file = "B-$$";
+ push @cleanup, $file;
+ open FH, ">$file" or die $!;
+ select FH;
+ Devel::SelfStubber->stub('Proto', $inlib);
+ select STDOUT;
+ print "ok 3\n"; # Checking that we did not die horribly.
+ close FH or die $!;
+
+ open FH, $file or die $!;
+ my @B = <FH>;
+
+ if (@B == 1 && $B[0] =~ /^\s*sub\s+Proto::bar\s*\(\$\$\);\s*$/) {
+ print "ok 4\n";
+ } else {
+ print "not ok 4\n";
+ print "# $_" foreach (@B);
+ }
+
+ close FH or die $!;
+ }
+
+ {
+ my $file = "C-$$";
+ push @cleanup, $file;
+ open FH, ">$file" or die $!;
+ select FH;
+ Devel::SelfStubber->stub('Attribs', $inlib);
+ select STDOUT;
+ print "ok 5\n"; # Checking that we did not die horribly.
+ close FH or die $!;
+
+ open FH, $file or die $!;
+ my @C = <FH>;
+
+ if (@C == 2 && $C[0] =~ /^\s*sub\s+Attribs::baz\s+:\s*locked\s*;\s*$/
+ && $C[1] =~ /^\s*sub\s+Attribs::lv\s+:\s*lvalue\s*:\s*method\s*;\s*$/) {
+ print "ok 6\n";
+ } else {
+ print "not ok 6\n";
+ print "# $_" foreach (@C);
+ }
+
+ close FH or die $!;
+ }
+
+ # "wrong" and "right" may change if SelfLoader is changed.
+ my %wrong = ( Parent => 'Parent', Child => 'Parent' );
+ my %right = ( Parent => 'Parent', Child => 'Child' );
+ if ($^O eq 'VMS') {
+ # extra line feeds for MBX IPC
+ %wrong = ( Parent => "Parent\n", Child => "Parent\n" );
+ %right = ( Parent => "Parent\n", Child => "Child\n" );
+ }
+ my @module = qw(Parent Child)
+ ;
+ sub fail {
+ my ($left, $right) = @_;
+ while (my ($key, $val) = each %$left) {
+ # warn "$key $val $$right{$key}";
+ return 1
+ unless $val eq $$right{$key};
+ }
+ return;
+ }
+
+ sub faildump {
+ my ($expect, $got) = @_;
+ foreach (sort keys %$expect) {
+ print "# $_ expect '$$expect{$_}' got '$$got{$_}'\n";
+ }
+ }
+
+ # Now test that the module tree behaves "wrongly" as expected
+
+ foreach my $module (@module) {
+ my $file = "$module--$$";
+ push @cleanup, $file;
+ open FH, ">$file" or die $!;
+ print FH "use $module;
+ print ${module}->foo;
+ ";
+ close FH or die $!;
+ }
+
+ {
+ my %output;
+ foreach my $module (@module) {
+ print "# $runperl \"-I$inlib\" $module--$$\n";
+ ($output{$module} = `$runperl "-I$inlib" $module--$$`)
+ =~ s/\'s foo//;
+ }
+
+ if (&fail (\%wrong, \%output)) {
+ print "not ok 7\n", &faildump (\%wrong, \%output);
+ } else {
+ print "ok 7\n";
+ }
+ }
+
+ my $lib="SSO-$$";
+ mkdir $lib, 0777 or die $!;
+ push @cleanup, $lib;
+ $Devel::SelfStubber::JUST_STUBS=0;
+
+ undef $/;
+ foreach my $module (@module, 'Data', 'End') {
+ my $file = "$lib/$module.pm";
+ open FH, "$inlib/$module.pm" or die $!;
+ my $contents = <FH>;
+ close FH or die $!;
+ push @cleanup, $file;
+ open FH, ">$file" or die $!;
+ select FH;
+ if ($contents =~ /__DATA__/) {
+ # This will die for any module with no __DATA__
+ Devel::SelfStubber->stub($module, $inlib);
+ } else {
+ print $contents;
+ }
+ select STDOUT;
+ close FH or die $!;
+ }
+ print "ok 8\n";
+
+ {
+ my %output;
+ foreach my $module (@module) {
+ print "# $runperl \"-I$lib\" $module--$$\n";
+ ($output{$module} = `$runperl "-I$lib" $module--$$`)
+ =~ s/\'s foo//;
+ }
+
+ if (&fail (\%right, \%output)) {
+ print "not ok 9\n", &faildump (\%right, \%output);
+ } else {
+ print "ok 9\n";
+ }
+ }
+
+ # Check that the DATA handle stays open
+ system "$runperl -w \"-I$lib\" \"-MData\" -e \"Data::ok\"";
+
+ # Possibly a pointless test as this doesn't really verify that it's been
+ # stubbed.
+ system "$runperl -w \"-I$lib\" \"-MEnd\" -e \"End::lime\"";
+
+ # But check that the documentation after the __END__ survived.
+ open FH, "$lib/End.pm" or die $!;
+ $_ = <FH>;
+ close FH or die $!;
+
+ if (/Did the documentation here survive\?/) {
+ print "ok 12\n";
+ } else {
+ print "not ok 12 # information after an __END__ token seems to be lost\n";
+ }
+
+ __DATA__
+ ################ Parent.pm
+ package Parent;
+
+ sub foo {
+ return __PACKAGE__;
+ }
+ 1;
+ __END__
+ ################ Child.pm
+ package Child;
+ require Parent;
+ @ISA = 'Parent';
+ use SelfLoader;
+
+ 1;
+ __DATA__
+ sub foo {
+ return __PACKAGE__;
+ }
+ __END__
+ ################ Proto.pm
+ package Proto;
+ use SelfLoader;
+
+ 1;
+ __DATA__
+ sub bar ($$) {
+ }
+ ################ Attribs.pm
+ package Attribs;
+ use SelfLoader;
+
+ 1;
+ __DATA__
+ sub baz : locked {
+ }
+ sub lv : lvalue : method {
+ my $a;
+ \$a;
+ }
+ ################ Data.pm
+ package Data;
+ use SelfLoader;
+
+ 1;
+ __DATA__
+ sub ok {
+ print <DATA>;
+ }
+ __END__ DATA
+ ok 10
+ ################ End.pm
+ package End;
+ use SelfLoader;
+
+ 1;
+ __DATA__
+ sub lime {
+ print "ok 11\n";
+ }
+ __END__
+ Did the documentation here survive?
diff -c /dev/null 'perl-5.7.2/lib/Digest.t'
Index: ./lib/Digest.t
*** ./lib/Digest.t Thu Jan 1 02:00:00 1970
--- ./lib/Digest.t Mon Jul 9 17:10:28 2001
***************
*** 0 ****
--- 1,26 ----
+ print "1..3\n";
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use Digest;
+
+ my $hexdigest = "900150983cd24fb0d6963f7d28e17f72";
+ if (ord('A') == 193) { # EBCDIC
+ $hexdigest = "fe4ea0d98f9cd8d1d27f102a93cb0bb0"; # IBM-1047
+ }
+
+ print "not " unless Digest->MD5->add("abc")->hexdigest eq $hexdigest;
+ print "ok 1\n";
+
+ print "not " unless Digest->MD5->add("abc")->hexdigest eq $hexdigest;
+ print "ok 2\n";
+
+ eval {
+ print "not " unless Digest->new("HMAC-MD5" => "Jefe")->add("what do ya want for nothing?")->hexdigest eq "750c783e6ab0b503eaa86e310a5db738";
+ print "ok 3\n";
+ };
+ print "ok 3\n" if $@ && $@ =~ /^Can't locate/;
+
diff -c 'perl-5.7.1/lib/DirHandle.pm' 'perl-5.7.2/lib/DirHandle.pm'
Index: ./lib/DirHandle.pm
*** ./lib/DirHandle.pm Tue Mar 6 04:05:26 2001
--- ./lib/DirHandle.pm Mon Jul 9 17:10:28 2001
***************
*** 25,30 ****
--- 25,44 ----
The only objective benefit to using C<DirHandle> is that it avoids
namespace pollution by creating globs to hold directory handles.
+ =head1 NOTES
+
+ =over 4
+
+ =item *
+
+ On Mac OS (Classic), the path separator is ':', not '/', and the
+ current directory is denoted as ':', not '.'. You 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.
+
+ =back
+
=cut
require 5.000;
diff -c /dev/null 'perl-5.7.2/lib/DirHandle.t'
Index: ./lib/DirHandle.t
*** ./lib/DirHandle.t Thu Jan 1 02:00:00 1970
--- ./lib/DirHandle.t Mon Jul 9 17:10:28 2001
***************
*** 0 ****
--- 1,34 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if (not $Config{'d_readdir'}) {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ use DirHandle;
+
+ print "1..5\n";
+
+ $dot = new DirHandle ($^O eq 'MacOS' ? ':' : '.');
+
+ print defined($dot) ? "ok" : "not ok", " 1\n";
+
+ @a = sort <*>;
+ do { $first = $dot->read } while defined($first) && $first =~ /^\./;
+ print +(grep { $_ eq $first } @a) ? "ok" : "not ok", " 2\n";
+
+ @b = sort($first, (grep {/^[^.]/} $dot->read));
+ print +(join("\0", @a) eq join("\0", @b)) ? "ok" : "not ok", " 3\n";
+
+ $dot->rewind;
+ @c = sort grep {/^[^.]/} $dot->read;
+ print +(join("\0", @b) eq join("\0", @c)) ? "ok" : "not ok", " 4\n";
+
+ $dot->close;
+ $dot->rewind;
+ print defined($dot->read) ? "not ok" : "ok", " 5\n";
diff -c /dev/null 'perl-5.7.2/lib/English.t'
Index: ./lib/English.t
*** ./lib/English.t Thu Jan 1 02:00:00 1970
--- ./lib/English.t Mon Jul 9 17:10:28 2001
***************
*** 0 ****
--- 1,65 ----
+ #!./perl
+
+ print "1..22\n";
+
+ BEGIN { @INC = '../lib' }
+ use English qw( -no_match_vars ) ;
+ use Config;
+ my $threads = $Config{'use5005threads'} || 0;
+
+ print $PID == $$ ? "ok 1\n" : "not ok 1\n";
+
+ $_ = 1;
+ print $ARG == $_ || $threads ? "ok 2\n" : "not ok 2\n";
+
+ sub foo {
+ print $ARG[0] == $_[0] || $threads ? "ok 3\n" : "not ok 3\n";
+ }
+ &foo(1);
+
+ "abc" =~ /b/;
+
+ print ! $PREMATCH ? "" : "not ", "ok 4\n" ;
+ print ! $MATCH ? "" : "not ", "ok 5\n" ;
+ print ! $POSTMATCH ? "" : "not ", "ok 6\n" ;
+
+ $OFS = " ";
+ $ORS = "\n";
+ print 'ok',7;
+ undef $OUTPUT_FIELD_SEPARATOR;
+
+ if ($threads) { $" = "\n" } else { $LIST_SEPARATOR = "\n" };
+ @foo = ("ok 8", "ok 9");
+ print "@foo";
+ undef $OUTPUT_RECORD_SEPARATOR;
+
+ eval 'NO SUCH FUNCTION';
+ print "ok 10\n" if $EVAL_ERROR =~ /method/ || $threads;
+
+ print $UID == $< ? "ok 11\n" : "not ok 11\n";
+ print $GID == $( ? "ok 12\n" : "not ok 12\n";
+ print $EUID == $> ? "ok 13\n" : "not ok 13\n";
+ print $EGID == $) ? "ok 14\n" : "not ok 14\n";
+
+ print $PROGRAM_NAME eq $0 ? "ok 15\n" : "not ok 15\n";
+ print $BASETIME == $^T ? "ok 16\n" : "not ok 16\n";
+
+ package B ;
+
+ use English ;
+
+ "abc" =~ /b/;
+
+ print $PREMATCH ? "" : "not ", "ok 17\n" ;
+ print $MATCH ? "" : "not ", "ok 18\n" ;
+ print $POSTMATCH ? "" : "not ", "ok 19\n" ;
+
+ package C ;
+
+ use English qw( -no_match_vars ) ;
+
+ "abc" =~ /b/;
+
+ print ! $PREMATCH ? "" : "not ", "ok 20\n" ;
+ print ! $MATCH ? "" : "not ", "ok 21\n" ;
+ print ! $POSTMATCH ? "" : "not ", "ok 22\n" ;
diff -c /dev/null 'perl-5.7.2/lib/Env/array.t'
Index: ./lib/Env/array.t
*** ./lib/Env/array.t Thu Jan 1 02:00:00 1970
--- ./lib/Env/array.t Mon Jul 9 17:10:29 2001
***************
*** 0 ****
--- 1,25 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ BEGIN {
+ $ENV{FOO} = "foo";
+ $ENV{BAR} = "bar";
+ }
+
+ use Env qw(FOO $BAR);
+
+ $FOO .= "/bar";
+ $BAR .= "/baz";
+
+ print "1..2\n";
+
+ print "not " if $FOO ne 'foo/bar';
+ print "ok 1\n";
+
+ print "not " if $BAR ne 'bar/baz';
+ print "ok 2\n";
+
diff -c /dev/null 'perl-5.7.2/lib/Env/env.t'
Index: ./lib/Env/env.t
*** ./lib/Env/env.t Thu Jan 1 02:00:00 1970
--- ./lib/Env/env.t Mon Jul 9 17:10:29 2001
***************
*** 0 ****
--- 1,100 ----
+ #!./perl
+
+ $| = 1;
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ if ($^O eq 'VMS') {
+ print "1..11\n";
+ foreach (1..11) { print "ok $_ # skipped for VMS\n"; }
+ exit 0;
+ }
+
+ use Env qw(@FOO);
+ use vars qw(@BAR);
+
+ sub array_equal
+ {
+ my ($a, $b) = @_;
+ return 0 unless scalar(@$a) == scalar(@$b);
+ for my $i (0..scalar(@$a) - 1) {
+ return 0 unless $a->[$i] eq $b->[$i];
+ }
+ return 1;
+ }
+
+ sub test
+ {
+ my ($desc, $code) = @_;
+
+ &$code;
+
+ print "# $desc...\n";
+ print "# FOO = (", join(", ", @FOO), ")\n";
+ print "# BAR = (", join(", ", @BAR), ")\n";
+
+ if (defined $check) { print "not " unless &$check; }
+ else { print "not " unless array_equal(\@FOO, \@BAR); }
+
+ print "ok ", ++$i, "\n";
+ }
+
+ print "1..11\n";
+
+ test "Assignment", sub {
+ @FOO = qw(a B c);
+ @BAR = qw(a B c);
+ };
+
+ test "Storing", sub {
+ $FOO[1] = 'b';
+ $BAR[1] = 'b';
+ };
+
+ test "Truncation", sub {
+ $#FOO = 0;
+ $#BAR = 0;
+ };
+
+ test "Push", sub {
+ push @FOO, 'b', 'c';
+ push @BAR, 'b', 'c';
+ };
+
+ test "Pop", sub {
+ pop @FOO;
+ pop @BAR;
+ };
+
+ test "Shift", sub {
+ shift @FOO;
+ shift @BAR;
+ };
+
+ test "Push", sub {
+ push @FOO, 'c';
+ push @BAR, 'c';
+ };
+
+ test "Unshift", sub {
+ unshift @FOO, 'a';
+ unshift @BAR, 'a';
+ };
+
+ test "Reverse", sub {
+ @FOO = reverse @FOO;
+ @BAR = reverse @BAR;
+ };
+
+ test "Sort", sub {
+ @FOO = sort @FOO;
+ @BAR = sort @BAR;
+ };
+
+ test "Splice", sub {
+ splice @FOO, 1, 1, 'B';
+ splice @BAR, 1, 1, 'B';
+ };
diff -c 'perl-5.7.1/lib/Exporter.pm' 'perl-5.7.2/lib/Exporter.pm'
Index: ./lib/Exporter.pm
*** ./lib/Exporter.pm Tue Mar 6 04:05:26 2001
--- ./lib/Exporter.pm Mon Jul 9 17:10:29 2001
***************
*** 8,14 ****
our $Debug = 0;
our $ExportLevel = 0;
our $Verbose ||= 0;
! our $VERSION = '5.562';
sub export_to_level {
require Exporter::Heavy;
--- 8,14 ----
our $Debug = 0;
our $ExportLevel = 0;
our $Verbose ||= 0;
! our $VERSION = '5.563';
sub export_to_level {
require Exporter::Heavy;
diff -c /dev/null 'perl-5.7.2/lib/Exporter.t'
Index: ./lib/Exporter.t
*** ./lib/Exporter.t Thu Jan 1 02:00:00 1970
--- ./lib/Exporter.t Mon Jul 9 17:10:29 2001
***************
*** 0 ****
--- 1,145 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # Utility testing functions.
+ my $test_num = 1;
+ sub ok ($;$) {
+ my($test, $name) = @_;
+ print "not " unless $test;
+ print "ok $test_num";
+ print " - $name" if (defined $name && ! $^O eq 'VMS');
+ print "\n";
+ $test_num++;
+ }
+
+
+ my $loaded;
+ BEGIN { $| = 1; $^W = 1; }
+ END {print "not ok $test_num\n" unless $loaded;}
+ print "1..$Total_tests\n";
+ use Exporter;
+ $loaded = 1;
+ ok(1, 'compile');
+
+
+ BEGIN {
+ # Methods which Exporter says it implements.
+ @Exporter_Methods = qw(import
+ export_to_level
+ require_version
+ export_fail
+ );
+ }
+
+ BEGIN { $Total_tests = 14 + @Exporter_Methods }
+
+ package Testing;
+ require Exporter;
+ @ISA = qw(Exporter);
+
+ # Make sure Testing can do everything its supposed to.
+ foreach my $meth (@::Exporter_Methods) {
+ ::ok( Testing->can($meth), "subclass can $meth()" );
+ }
+
+ %EXPORT_TAGS = (
+ This => [qw(stuff %left)],
+ That => [qw(Above the @wailing)],
+ tray => [qw(Fasten $seatbelt)],
+ );
+ @EXPORT = qw(lifejacket);
+ @EXPORT_OK = qw(under &your $seat);
+ $VERSION = '1.05';
+
+ ::ok( Testing->require_version(1.05), 'require_version()' );
+ eval { Testing->require_version(1.11); 1 };
+ ::ok( $@, 'require_version() fail' );
+ ::ok( Testing->require_version(0), 'require_version(0)' );
+
+ sub lifejacket { 'lifejacket' }
+ sub stuff { 'stuff' }
+ sub Above { 'Above' }
+ sub the { 'the' }
+ sub Fasten { 'Fasten' }
+ sub your { 'your' }
+ sub under { 'under' }
+ use vars qw($seatbelt $seat @wailing %left);
+ $seatbelt = 'seatbelt';
+ $seat = 'seat';
+ @wailing = qw(AHHHHHH);
+ %left = ( left => "right" );
+
+
+ Exporter::export_ok_tags;
+
+ my %tags = map { $_ => 1 } map { @$_ } values %EXPORT_TAGS;
+ my %exportok = map { $_ => 1 } @EXPORT_OK;
+ my $ok = 1;
+ foreach my $tag (keys %tags) {
+ $ok = exists $exportok{$tag};
+ }
+ ::ok( $ok, 'export_ok_tags()' );
+
+
+ package Foo;
+ Testing->import;
+
+ ::ok( defined &lifejacket, 'simple import' );
+
+
+ package Bar;
+ my @imports = qw($seatbelt &Above stuff @wailing %left);
+ Testing->import(@imports);
+
+ ::ok( (!grep { eval "!defined $_" } map({ /^\w/ ? "&$_" : $_ } @imports)),
+ 'import by symbols' );
+
+
+ package Yar;
+ my @tags = qw(:This :tray);
+ Testing->import(@tags);
+
+ ::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ }
+ map { @$_ } @{$Testing::EXPORT_TAGS{@tags}}),
+ 'import by tags' );
+
+
+ package Arrr;
+ Testing->import(qw(!lifejacket));
+
+ ::ok( !defined &lifejacket, 'deny import by !' );
+
+
+ package Mars;
+ Testing->import('/e/');
+
+ ::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ }
+ grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK),
+ 'import by regex');
+
+
+ package Venus;
+ Testing->import('!/e/');
+
+ ::ok( (!grep { eval "defined $_" } map { /^\w/ ? "&$_" : $_ }
+ grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK),
+ 'deny import by regex');
+ ::ok( !defined &lifejacket, 'further denial' );
+
+
+ package More::Testing;
+ @ISA = qw(Exporter);
+ $VERSION = 0;
+ eval { More::Testing->require_version(0); 1 };
+ ::ok(!$@, 'require_version(0) and $VERSION = 0');
+
+
+ package Yet::More::Testing;
+ @ISA = qw(Exporter);
+ $VERSION = 0;
+ eval { Yet::More::Testing->require_version(10); 1 };
+ ::ok($@ !~ /\(undef\)/, 'require_version(10) and $VERSION = 0');
diff -c 'perl-5.7.1/lib/Exporter/Heavy.pm' 'perl-5.7.2/lib/Exporter/Heavy.pm'
Index: ./lib/Exporter/Heavy.pm
*** ./lib/Exporter/Heavy.pm Tue Mar 6 04:05:26 2001
--- ./lib/Exporter/Heavy.pm Mon Jul 9 17:10:29 2001
***************
*** 218,228 ****
my($self, $wanted) = @_;
my $pkg = ref $self || $self;
my $version = ${"${pkg}::VERSION"};
! if (!$version or $version < $wanted) {
! $version ||= "(undef)";
# %INC contains slashes, but $pkg contains double-colons.
my $file = (map {s,::,/,g; $INC{$_}} "$pkg.pm")[0];
! $file &&= " ($file)";
require Carp;
Carp::croak("$pkg $wanted required--this is only version $version$file")
}
--- 218,228 ----
my($self, $wanted) = @_;
my $pkg = ref $self || $self;
my $version = ${"${pkg}::VERSION"};
! if (!defined $version or $version < $wanted) {
! $version = defined $version ? $version : "(undef)";
# %INC contains slashes, but $pkg contains double-colons.
my $file = (map {s,::,/,g; $INC{$_}} "$pkg.pm")[0];
! $file = defined $file ? " ($file)" : '';
require Carp;
Carp::croak("$pkg $wanted required--this is only version $version$file")
}
diff -c /dev/null 'perl-5.7.2/lib/ExtUtils.t'
Index: ./lib/ExtUtils.t
*** ./lib/ExtUtils.t Thu Jan 1 02:00:00 1970
--- ./lib/ExtUtils.t Wed Jul 11 04:45:58 2001
***************
*** 0 ****
--- 1,501 ----
+ #!./perl -w
+
+ print "1..27\n";
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # use warnings;
+ use strict;
+ use ExtUtils::MakeMaker;
+ use ExtUtils::Constant qw (constant_types C_constant XS_constant autoload);
+ use Config;
+ use File::Spec::Functions qw(catfile rel2abs);
+ # Because were are going to be changing directory before running Makefile.PL
+ my $perl;
+ $perl = rel2abs( $^X ) unless $] < 5.006; # Hack. Until 5.00503 has rel2abs
+ # ExtUtils::Constant::C_constant uses $^X inside a comment, and we want to
+ # compare output to ensure that it is the same. We were probably run as ./perl
+ # whereas we will run the child with the full path in $perl. So make $^X for
+ # us the same as our child will see.
+ $^X = $perl;
+
+ print "# perl=$perl\n";
+ my $runperl = "$perl -x \"-I../../lib\"";
+
+ $| = 1;
+
+ my $dir = "ext-$$";
+ my @files;
+
+ print "# $dir being created...\n";
+ mkdir $dir, 0777 or die "mkdir: $!\n";
+
+ my $output = "output";
+
+ END {
+ use File::Path;
+ print "# $dir being removed...\n";
+ rmtree($dir);
+ }
+
+ my $package = "ExtTest";
+
+ # Test the code that generates 1 and 2 letter name comparisons.
+ my %compass = (
+ N => 0, 'NE' => 45, E => 90, SE => 135, S => 180, SW => 225, W => 270, NW => 315
+ );
+
+ my $parent_rfc1149 =
+ 'A Standard for the Transmission of IP Datagrams on Avian Carriers';
+
+ my @names = ("FIVE", {name=>"OK6", type=>"PV",},
+ {name=>"OK7", type=>"PVN",
+ value=>['"not ok 7\\n\\0ok 7\\n"', 15]},
+ {name => "FARTHING", type=>"NV"},
+ {name => "NOT_ZERO", type=>"UV", value=>"~(UV)0"},
+ {name => "OPEN", type=>"PV", value=>'"/*"', macro=>1},
+ {name => "CLOSE", type=>"PV", value=>'"*/"',
+ macro=>["#if 1\n", "#endif\n"]},
+ {name => "ANSWER", default=>["UV", 42]}, "NOTDEF",
+ {name => "Yes", type=>"YES"},
+ {name => "No", type=>"NO"},
+ {name => "Undef", type=>"UNDEF"},
+ # OK. It wasn't really designed to allow the creation of dual valued constants.
+ # It was more for INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE
+ {name=>"RFC1149", type=>"SV", value=>"sv_2mortal(temp_sv)",
+ pre=>"SV *temp_sv = newSVpv(RFC1149, 0); "
+ . "(void) SvUPGRADE(temp_sv,SVt_PVIV); SvIOK_on(temp_sv); "
+ . "SvIVX(temp_sv) = 1149;"},
+ );
+
+ push @names, $_ foreach keys %compass;
+
+ my @names_only = map {(ref $_) ? $_->{name} : $_} @names;
+
+ my $types = {};
+ my $constant_types = constant_types(); # macro defs
+ my $C_constant = join "\n",
+ C_constant ($package, undef, "IV", $types, undef, undef, @names);
+ my $XS_constant = XS_constant ($package, $types); # XS for ExtTest::constant
+
+ ################ Header
+ my $header = catfile($dir, "test.h");
+ push @files, "test.h";
+ open FH, ">$header" or die "open >$header: $!\n";
+ print FH <<"EOT";
+ #define FIVE 5
+ #define OK6 "ok 6\\n"
+ #define OK7 1
+ #define FARTHING 0.25
+ #define NOT_ZERO 1
+ #define Yes 0
+ #define No 1
+ #define Undef 1
+ #define RFC1149 "$parent_rfc1149"
+ #undef NOTDEF
+
+ EOT
+
+ while (my ($point, $bearing) = each %compass) {
+ print FH "#define $point $bearing\n"
+ }
+ close FH or die "close $header: $!\n";
+
+ ################ XS
+ my $xs = catfile($dir, "$package.xs");
+ push @files, "$package.xs";
+ open FH, ">$xs" or die "open >$xs: $!\n";
+
+ print FH <<'EOT';
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+ EOT
+
+ print FH "#include \"test.h\"\n\n";
+ print FH $constant_types;
+ print FH $C_constant, "\n";
+ print FH "MODULE = $package PACKAGE = $package\n";
+ print FH "PROTOTYPES: ENABLE\n";
+ print FH $XS_constant;
+ close FH or die "close $xs: $!\n";
+
+ ################ PM
+ my $pm = catfile($dir, "$package.pm");
+ push @files, "$package.pm";
+ open FH, ">$pm" or die "open >$pm: $!\n";
+ print FH "package $package;\n";
+ print FH "use $];\n";
+
+ print FH <<'EOT';
+
+ use strict;
+ EOT
+ printf FH "use warnings;\n" unless $] < 5.006;
+ print FH <<'EOT';
+ use Carp;
+
+ require Exporter;
+ require DynaLoader;
+ use vars qw ($VERSION @ISA @EXPORT_OK $AUTOLOAD);
+
+ $VERSION = '0.01';
+ @ISA = qw(Exporter DynaLoader);
+ @EXPORT_OK = qw(
+ EOT
+
+ print FH "\t$_\n" foreach (@names_only);
+ print FH ");\n";
+ print FH autoload ($package, $]);
+ print FH "bootstrap $package \$VERSION;\n1;\n__END__\n";
+ close FH or die "close $pm: $!\n";
+
+ ################ test.pl
+ my $testpl = catfile($dir, "test.pl");
+ push @files, "test.pl";
+ open FH, ">$testpl" or die "open >$testpl: $!\n";
+
+ print FH "use strict;\n";
+ print FH "use $package qw(@names_only);\n";
+ print FH <<"EOT";
+
+ print "1..1\n";
+ if (open OUTPUT, ">$output") {
+ print "ok 1\n";
+ select OUTPUT;
+ } else {
+ print "not ok 1 # Failed to open '$output': $!\n";
+ exit 1;
+ }
+ EOT
+
+ print FH << 'EOT';
+
+ # What follows goes to the temporary file.
+ # IV
+ my $five = FIVE;
+ if ($five == 5) {
+ print "ok 5\n";
+ } else {
+ print "not ok 5 # $five\n";
+ }
+
+ # PV
+ print OK6;
+
+ # PVN containing embedded \0s
+ $_ = OK7;
+ s/.*\0//s;
+ print;
+
+ # NV
+ my $farthing = FARTHING;
+ if ($farthing == 0.25) {
+ print "ok 8\n";
+ } else {
+ print "not ok 8 # $farthing\n";
+ }
+
+ # UV
+ my $not_zero = NOT_ZERO;
+ if ($not_zero > 0 && $not_zero == ~0) {
+ print "ok 9\n";
+ } else {
+ print "not ok 9 # \$not_zero=$not_zero ~0=" . (~0) . "\n";
+ }
+
+ # Value includes a "*/" in an attempt to bust out of a C comment.
+ # Also tests custom cpp #if clauses
+ my $close = CLOSE;
+ if ($close eq '*/') {
+ print "ok 10\n";
+ } else {
+ print "not ok 10 # \$close='$close'\n";
+ }
+
+ # Default values if macro not defined.
+ my $answer = ANSWER;
+ if ($answer == 42) {
+ print "ok 11\n";
+ } else {
+ print "not ok 11 # What do you get if you multiply six by nine? '$answer'\n";
+ }
+
+ # not defined macro
+ my $notdef = eval { NOTDEF; };
+ if (defined $notdef) {
+ print "not ok 12 # \$notdef='$notdef'\n";
+ } elsif ($@ !~ /Your vendor has not defined ExtTest macro NOTDEF/) {
+ print "not ok 12 # \$@='$@'\n";
+ } else {
+ print "ok 12\n";
+ }
+
+ # not a macro
+ my $notthere = eval { &ExtTest::NOTTHERE; };
+ if (defined $notthere) {
+ print "not ok 13 # \$notthere='$notthere'\n";
+ } elsif ($@ !~ /NOTTHERE is not a valid ExtTest macro/) {
+ chomp $@;
+ print "not ok 13 # \$@='$@'\n";
+ } else {
+ print "ok 13\n";
+ }
+
+ # Truth
+ my $yes = Yes;
+ if ($yes) {
+ print "ok 14\n";
+ } else {
+ print "not ok 14 # $yes='\$yes'\n";
+ }
+
+ # Falsehood
+ my $no = No;
+ if (defined $no and !$no) {
+ print "ok 15\n";
+ } else {
+ print "not ok 15 # \$no=" . defined ($no) ? "'$no'\n" : "undef\n";
+ }
+
+ # Undef
+ my $undef = Undef;
+ unless (defined $undef) {
+ print "ok 16\n";
+ } else {
+ print "not ok 16 # \$undef='$undef'\n";
+ }
+
+
+ # invalid macro (chosen to look like a mix up between No and SW)
+ $notdef = eval { &ExtTest::So };
+ if (defined $notdef) {
+ print "not ok 17 # \$notdef='$notdef'\n";
+ } elsif ($@ !~ /^So is not a valid ExtTest macro/) {
+ print "not ok 17 # \$@='$@'\n";
+ } else {
+ print "ok 17\n";
+ }
+
+ # invalid defined macro
+ $notdef = eval { &ExtTest::EW };
+ if (defined $notdef) {
+ print "not ok 18 # \$notdef='$notdef'\n";
+ } elsif ($@ !~ /^EW is not a valid ExtTest macro/) {
+ print "not ok 18 # \$@='$@'\n";
+ } else {
+ print "ok 18\n";
+ }
+
+ my %compass = (
+ EOT
+
+ while (my ($point, $bearing) = each %compass) {
+ print FH "'$point' => $bearing, "
+ }
+
+ print FH <<'EOT';
+
+ );
+
+ my $fail;
+ while (my ($point, $bearing) = each %compass) {
+ my $val = eval $point;
+ if ($@) {
+ print "# $point: \$@='$@'\n";
+ $fail = 1;
+ } elsif (!defined $bearing) {
+ print "# $point: \$val=undef\n";
+ $fail = 1;
+ } elsif ($val != $bearing) {
+ print "# $point: \$val=$val, not $bearing\n";
+ $fail = 1;
+ }
+ }
+ if ($fail) {
+ print "not ok 19\n";
+ } else {
+ print "ok 19\n";
+ }
+
+ EOT
+
+ print FH <<"EOT";
+ my \$rfc1149 = RFC1149;
+ if (\$rfc1149 ne "$parent_rfc1149") {
+ print "not ok 20 # '\$rfc1149' ne '$parent_rfc1149'\n";
+ } else {
+ print "ok 20\n";
+ }
+
+ if (\$rfc1149 != 1149) {
+ printf "not ok 21 # %d != 1149\n", \$rfc1149;
+ } else {
+ print "ok 21\n";
+ }
+
+ EOT
+
+ print FH <<'EOT';
+ # test macro=>1
+ my $open = OPEN;
+ if ($open eq '/*') {
+ print "ok 22\n";
+ } else {
+ print "not ok 22 # \$open='$open'\n";
+ }
+ EOT
+ close FH or die "close $testpl: $!\n";
+
+ ################ Makefile.PL
+ # We really need a Makefile.PL because make test for a no dynamic linking perl
+ # will run Makefile.PL again as part of the "make perl" target.
+ my $makefilePL = catfile($dir, "Makefile.PL");
+ push @files, "Makefile.PL";
+ open FH, ">$makefilePL" or die "open >$makefilePL: $!\n";
+ print FH <<"EOT";
+ #!$perl -w
+ use ExtUtils::MakeMaker;
+ WriteMakefile(
+ 'NAME' => "$package",
+ 'VERSION_FROM' => "$package.pm", # finds \$VERSION
+ (\$] >= 5.005 ?
+ (#ABSTRACT_FROM => "$package.pm", # XXX add this
+ AUTHOR => "$0") : ())
+ );
+ EOT
+
+ close FH or die "close $makefilePL: $!\n";
+
+ chdir $dir or die $!; push @INC, '../../lib';
+ END {chdir ".." or warn $!};
+
+ my @perlout = `$runperl Makefile.PL PERL_CORE=1`;
+ if ($?) {
+ print "not ok 1 # $runperl Makefile.PL failed: $?\n";
+ print "# $_" foreach @perlout;
+ exit($?);
+ } else {
+ print "ok 1\n";
+ }
+
+
+ my $makefile = ($^O eq 'VMS' ? 'descrip' : 'Makefile');
+ my $makefile_ext = ($^O eq 'VMS' ? '.mms' : '');
+ if (-f "$makefile$makefile_ext") {
+ print "ok 2\n";
+ } else {
+ print "not ok 2\n";
+ }
+ my $makefile_rename = ($^O eq 'VMS' ? '.mms' : '.old');
+ push @files, "$makefile$makefile_rename"; # Renamed by make clean
+
+ my $make = $Config{make};
+
+ $make = $ENV{MAKE} if exists $ENV{MAKE};
+
+ if ($^O eq 'MSWin32' && $make eq 'nmake') { $make .= " -nologo"; }
+
+ my @makeout;
+
+ print "# make = '$make'\n";
+ @makeout = `$make`;
+ if ($?) {
+ print "not ok 3 # $make failed: $?\n";
+ print "# $_" foreach @makeout;
+ exit($?);
+ } else {
+ print "ok 3\n";
+ }
+
+ if ($Config{usedl}) {
+ print "ok 4\n";
+ } else {
+ my $makeperl = "$make perl";
+ print "# make = '$makeperl'\n";
+ @makeout = `$makeperl`;
+ if ($?) {
+ print "not ok 4 # $makeperl failed: $?\n";
+ print "# $_" foreach @makeout;
+ exit($?);
+ } else {
+ print "ok 4\n";
+ }
+ }
+
+ push @files, $output;
+
+ my $maketest = "$make test";
+ print "# make = '$maketest'\n";
+
+ @makeout = `$maketest`;
+
+ if (open OUTPUT, "<$output") {
+ print while <OUTPUT>;
+ close OUTPUT or print "# Close $output failed: $!\n";
+ } else {
+ # Harness will report missing test results at this point.
+ print "# Open <$output failed: $!\n";
+ }
+
+ my $test = 23;
+
+ if ($?) {
+ print "not ok $test # $maketest failed: $?\n";
+ print "# $_" foreach @makeout;
+ } else {
+ print "ok $test\n";
+ }
+ $test++;
+
+ my $regen = `$runperl $package.xs`;
+ if ($?) {
+ print "not ok $test # $runperl $package.xs failed: $?\n";
+ } else {
+ print "ok $test\n";
+ }
+ $test++;
+
+ my $expect = $constant_types . $C_constant .
+ "\n#### XS Section:\n" . $XS_constant;
+
+ if ($expect eq $regen) {
+ print "ok $test\n";
+ } else {
+ print "not ok $test\n";
+ # open FOO, ">expect"; print FOO $expect;
+ # open FOO, ">regen"; print FOO $regen; close FOO;
+ }
+ $test++;
+
+ my $makeclean = "$make clean";
+ print "# make = '$makeclean'\n";
+ @makeout = `$makeclean`;
+ if ($?) {
+ print "not ok $test # $make failed: $?\n";
+ print "# $_" foreach @makeout;
+ } else {
+ print "ok $test\n";
+ }
+ $test++;
+
+ foreach (@files) {
+ unlink $_ or warn "unlink $_: $!";
+ }
+
+ my $fail;
+ opendir DIR, "." or die "opendir '.': $!";
+ while (defined (my $entry = readdir DIR)) {
+ next if $entry =~ /^\.\.?$/;
+ print "# Extra file '$entry'\n";
+ $fail = 1;
+ }
+ closedir DIR or warn "closedir '.': $!";
+ if ($fail) {
+ print "not ok $test\n";
+ } else {
+ print "ok $test\n";
+ }
diff -c 'perl-5.7.1/lib/ExtUtils/Command.pm' 'perl-5.7.2/lib/ExtUtils/Command.pm'
Index: ./lib/ExtUtils/Command.pm
*** ./lib/ExtUtils/Command.pm Tue Mar 6 04:05:27 2001
--- ./lib/ExtUtils/Command.pm Mon Jul 9 17:10:29 2001
***************
*** 12,18 ****
our(@ISA, @EXPORT, $VERSION);
@ISA = qw(Exporter);
@EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f);
! $VERSION = '1.01';
=head1 NAME
--- 12,18 ----
our(@ISA, @EXPORT, $VERSION);
@ISA = qw(Exporter);
@EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f);
! $VERSION = '1.02';
=head1 NAME
diff -c /dev/null 'perl-5.7.2/lib/ExtUtils/Constant.pm'
Index: ./lib/ExtUtils/Constant.pm
*** ./lib/ExtUtils/Constant.pm Thu Jan 1 02:00:00 1970
--- ./lib/ExtUtils/Constant.pm Wed Jul 11 04:33:18 2001
***************
*** 0 ****
--- 1,1102 ----
+ package ExtUtils::Constant;
+ use vars qw (@ISA $VERSION %XS_Constant %XS_TypeSet @EXPORT_OK %EXPORT_TAGS);
+ $VERSION = '0.09';
+
+ =head1 NAME
+
+ ExtUtils::Constant - generate XS code to import C header constants
+
+ =head1 SYNOPSIS
+
+ use ExtUtils::Constant qw (WriteConstants);
+ WriteConstants(
+ NAME => 'Foo',
+ NAMES => [qw(FOO BAR BAZ)],
+ C_FILE => 'constants.c',
+ XS_FILE => 'constants.xs',
+ );
+ # Generates wrapper code to make the values of the constants FOO BAR BAZ
+ # available to perl
+
+ =head1 DESCRIPTION
+
+ ExtUtils::Constant facilitates generating C and XS wrapper code to allow
+ perl modules to AUTOLOAD constants defined in C library header files.
+ It is principally used by the C<h2xs> utility, on which this code is based.
+ It doesn't contain the routines to scan header files to extract these
+ constants.
+
+ =head1 USAGE
+
+ Generally one only needs to call the C<WriteConstants> function, and then
+
+ #include "constants.c"
+
+ in the C section of C<Foo.xs>
+
+ INCLUDE constants.xs
+
+ in the XS section of C<Foo.xs>.
+
+ For greater flexibility use C<constant_types()>, C<C_constant> and
+ C<XS_constant>, with which C<WriteConstants> is implemented.
+
+ Currently this module understands the following types. h2xs may only know
+ a subset. The sizes of the numeric types are chosen by the C<Configure>
+ script at compile time.
+
+ =over 4
+
+ =item IV
+
+ signed integer, at least 32 bits.
+
+ =item UV
+
+ unsigned integer, the same size as I<IV>
+
+ =item NV
+
+ floating point type, probably C<double>, possibly C<long double>
+
+ =item PV
+
+ NUL terminated string, length will be determined with C<strlen>
+
+ =item PVN
+
+ A fixed length thing, given as a [pointer, length] pair. If you know the
+ length of a string at compile time you may use this instead of I<PV>
+
+ =item PVN
+
+ A B<mortal> SV.
+
+ =item YES
+
+ Truth. (C<PL_sv_yes>) The value is not needed (and ignored).
+
+ =item NO
+
+ Defined Falsehood. (C<PL_sv_no>) The value is not needed (and ignored).
+
+ =item UNDEF
+
+ C<undef>. The value of the macro is not needed.
+
+ =back
+
+ =head1 FUNCTIONS
+
+ =over 4
+
+ =cut
+
+ if ($] >= 5.006) {
+ eval "use warnings; 1" or die $@;
+ }
+ use strict;
+ use Carp;
+
+ use Exporter;
+ use Text::Wrap;
+ $Text::Wrap::huge = 'overflow';
+ $Text::Wrap::columns = 80;
+
+ @ISA = 'Exporter';
+
+ %EXPORT_TAGS = ( 'all' => [ qw(
+ XS_constant constant_types return_clause memEQ_clause C_stringify
+ C_constant autoload WriteConstants
+ ) ] );
+
+ @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
+
+ %XS_Constant = (
+ IV => 'PUSHi(iv)',
+ UV => 'PUSHu((UV)iv)',
+ NV => 'PUSHn(nv)',
+ PV => 'PUSHp(pv, strlen(pv))',
+ PVN => 'PUSHp(pv, iv)',
+ SV => 'PUSHs(sv)',
+ YES => 'PUSHs(&PL_sv_yes)',
+ NO => 'PUSHs(&PL_sv_no)',
+ UNDEF => '', # implicit undef
+ );
+
+ %XS_TypeSet = (
+ IV => '*iv_return =',
+ UV => '*iv_return = (IV)',
+ NV => '*nv_return =',
+ PV => '*pv_return =',
+ PVN => ['*pv_return =', '*iv_return = (IV)'],
+ SV => '*sv_return = ',
+ YES => undef,
+ NO => undef,
+ UNDEF => undef,
+ );
+
+
+ =item C_stringify NAME
+
+ A function which returns a correctly \ escaped version of the string passed
+ suitable for C's "" or ''. It will also be valid as a perl "" string.
+
+ =cut
+
+ # Hopefully make a happy C identifier.
+ sub C_stringify {
+ local $_ = shift;
+ return unless defined $_;
+ s/\\/\\\\/g;
+ s/([\"\'])/\\$1/g; # Grr. fix perl mode.
+ s/\n/\\n/g; # Ensure newlines don't end up in octal
+ s/\r/\\r/g;
+ s/\t/\\t/g;
+ s/\f/\\f/g;
+ s/\a/\\a/g;
+ unless ($] < 5.006) {
+ # This will elict a warning on 5.005_03 about [: :] being reserved unless
+ # I cheat
+ my $cheat = '([[:^print:]])';
+ s/$cheat/sprintf "\\%03o", ord $1/ge;
+ } else {
+ require POSIX;
+ s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
+ }
+ $_;
+ }
+
+ =item constant_types
+
+ A function returning a single scalar with C<#define> definitions for the
+ constants used internally between the generated C and XS functions.
+
+ =cut
+
+ sub constant_types () {
+ my $start = 1;
+ my @lines;
+ push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++;
+ push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++;
+ foreach (sort keys %XS_Constant) {
+ push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++;
+ }
+ push @lines, << 'EOT';
+
+ #ifndef NVTYPE
+ typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
+ #endif
+ #ifndef aTHX_
+ #define aTHX_ /* 5.6 or later define this for threading support. */
+ #endif
+ #ifndef pTHX_
+ #define pTHX_ /* 5.6 or later define this for threading support. */
+ #endif
+ EOT
+
+ return join '', @lines;
+ }
+
+ =item memEQ_clause NAME, CHECKED_AT, INDENT
+
+ A function to return a suitable C C<if> statement to check whether I<NAME>
+ is equal to the C variable C<name>. If I<CHECKED_AT> is defined, then it
+ is used to avoid C<memEQ> for short names, or to generate a comment to
+ highlight the position of the character in the C<switch> statement.
+
+ =cut
+
+ sub memEQ_clause {
+ # if (memEQ(name, "thingy", 6)) {
+ # Which could actually be a character comparison or even ""
+ my ($name, $checked_at, $indent) = @_;
+ $indent = ' ' x ($indent || 4);
+ my $len = length $name;
+
+ if ($len < 2) {
+ return $indent . "{\n" if (defined $checked_at and $checked_at == 0);
+ # We didn't switch, drop through to the code for the 2 character string
+ $checked_at = 1;
+ }
+ if ($len < 3 and defined $checked_at) {
+ my $check;
+ if ($checked_at == 1) {
+ $check = 0;
+ } elsif ($checked_at == 0) {
+ $check = 1;
+ }
+ if (defined $check) {
+ my $char = C_stringify (substr $name, $check, 1);
+ return $indent . "if (name[$check] == '$char') {\n";
+ }
+ }
+ # Could optimise a memEQ on 3 to 2 single character checks here
+ $name = C_stringify ($name);
+ my $body = $indent . "if (memEQ(name, \"$name\", $len)) {\n";
+ $body .= $indent . "/* ". (' ' x $checked_at) . '^'
+ . (' ' x ($len - $checked_at + length $len)) . " */\n"
+ if defined $checked_at;
+ return $body;
+ }
+
+ =item assign INDENT, TYPE, PRE, POST, VALUE...
+
+ A function to return a suitable assignment clause. If I<TYPE> is aggregate
+ (eg I<PVN> expects both pointer and length) then there should be multiple
+ I<VALUE>s for the components. I<PRE> and I<POST> if defined give snippets
+ of C code to preceed and follow the assignment. I<PRE> will be at the start
+ of a block, so variables may be defined in it.
+
+ =cut
+
+ # Hmm. value undef to to NOTDEF? value () to do NOTFOUND?
+
+ sub assign {
+ my $indent = shift;
+ my $type = shift;
+ my $pre = shift;
+ my $post = shift || '';
+ my $clause;
+ my $close;
+ if ($pre) {
+ chomp $pre;
+ $clause = $indent . "{\n$pre";
+ $clause .= ";" unless $pre =~ /;$/;
+ $clause .= "\n";
+ $close = "$indent}\n";
+ $indent .= " ";
+ }
+ die "Can't generate code for type $type" unless exists $XS_TypeSet{$type};
+ my $typeset = $XS_TypeSet{$type};
+ if (ref $typeset) {
+ die "Type $type is aggregate, but only single value given"
+ if @_ == 1;
+ foreach (0 .. $#$typeset) {
+ $clause .= $indent . "$typeset->[$_] $_[$_];\n";
+ }
+ } elsif (defined $typeset) {
+ die "Aggregate value given for type $type"
+ if @_ > 1;
+ $clause .= $indent . "$typeset $_[0];\n";
+ }
+ chomp $post;
+ if (length $post) {
+ $clause .= "$post";
+ $clause .= ";" unless $post =~ /;$/;
+ $clause .= "\n";
+ }
+ $clause .= "${indent}return PERL_constant_IS$type;\n";
+ $clause .= $close if $close;
+ return $clause;
+ }
+
+ =item return_clause
+
+ return_clause VALUE, TYPE, INDENT, MACRO, DEFAULT, PRE, POST, PRE, POST
+
+ A function to return a suitable C<#ifdef> clause. I<MACRO> defaults to
+ I<VALUE> when not defined. If I<TYPE> is aggregate (eg I<PVN> expects both
+ pointer and length) then I<VALUE> should be a reference to an array of
+ values in the order expected by the type. C<C_constant> will always call
+ this function with I<MACRO> defined, defaulting to the constant's name.
+ I<DEFAULT> if defined is an array reference giving default type and and
+ value(s) if the clause generated by I<MACRO> doesn't evaluate to true.
+ The two pairs I<PRE> and I<POST> if defined give C code snippets to proceed
+ and follow the value, and the default value.
+
+ =cut
+
+ sub return_clause ($$$$$$$$$) {
+ ##ifdef thingy
+ # *iv_return = thingy;
+ # return PERL_constant_ISIV;
+ ##else
+ # return PERL_constant_NOTDEF;
+ ##endif
+ my ($value, $type, $indent, $macro, $default, $pre, $post,
+ $def_pre, $def_post) = @_;
+ $macro = $value unless defined $macro;
+ $indent = ' ' x ($indent || 6);
+
+ my $clause;
+
+ ##ifdef thingy
+ if (ref $macro) {
+ $clause = $macro->[0];
+ } elsif ($macro ne "1") {
+ $clause = "#ifdef $macro\n";
+ }
+
+ # *iv_return = thingy;
+ # return PERL_constant_ISIV;
+ $clause .= assign ($indent, $type, $pre, $post,
+ ref $value ? @$value : $value);
+
+ if (ref $macro or $macro ne "1") {
+ ##else
+ $clause .= "#else\n";
+
+ # return PERL_constant_NOTDEF;
+ if (!defined $default) {
+ $clause .= "${indent}return PERL_constant_NOTDEF;\n";
+ } else {
+ my @default = ref $default ? @$default : $default;
+ $type = shift @default;
+ $clause .= assign ($indent, $type, $def_pre, $def_post, @default);
+ }
+
+ ##endif
+ if (ref $macro) {
+ $clause .= $macro->[1];
+ } else {
+ $clause .= "#endif\n";
+ }
+ }
+ return $clause
+ }
+
+ =item switch_clause INDENT, NAMELEN, ITEMHASH, ITEM...
+
+ An internal function to generate a suitable C<switch> clause, called by
+ C<C_constant> I<ITEM>s are in the hash ref format as given in the description
+ of C<C_constant>, and must all have the names of the same length, given by
+ I<NAMELEN> (This is not checked). I<ITEMHASH> is a reference to a hash,
+ keyed by name, values being the hashrefs in the I<ITEM> list.
+ (No parameters are modified, and there can be keys in the I<ITEMHASH> that
+ are not in the list of I<ITEM>s without causing problems).
+
+ =cut
+
+ sub switch_clause {
+ my ($indent, $comment, $namelen, $items, @items) = @_;
+ $indent = ' ' x ($indent || 2);
+
+ my @names = sort map {$_->{name}} @items;
+ my $leader = $indent . '/* ';
+ my $follower = ' ' x length $leader;
+ my $body = $indent . "/* Names all of length $namelen. */\n";
+ if ($comment) {
+ $body = wrap ($leader, $follower, $comment) . "\n";
+ $leader = $follower;
+ }
+ $body .= wrap ($leader, $follower, join (" ", @names) . " */") . "\n";
+ # Figure out what to switch on.
+ # (RMS, Spread of jump table, Position, Hashref)
+ my @best = (1e38, ~0);
+ foreach my $i (0 .. ($namelen - 1)) {
+ my ($min, $max) = (~0, 0);
+ my %spread;
+ foreach (@names) {
+ my $char = substr $_, $i, 1;
+ my $ord = ord $char;
+ $max = $ord if $ord > $max;
+ $min = $ord if $ord < $min;
+ push @{$spread{$char}}, $_;
+ # warn "$_ $char";
+ }
+ # I'm going to pick the character to split on that minimises the root
+ # mean square of the number of names in each case. Normally this should
+ # be the one with the most keys, but it may pick a 7 where the 8 has
+ # one long linear search. I'm not sure if RMS or just sum of squares is
+ # actually better.
+ # $max and $min are for the tie-breaker if the root mean squares match.
+ # Assuming that the compiler may be building a jump table for the
+ # switch() then try to minimise the size of that jump table.
+ # Finally use < not <= so that if it still ties the earliest part of
+ # the string wins. Because if that passes but the memEQ fails, it may
+ # only need the start of the string to bin the choice.
+ # I think. But I'm micro-optimising. :-)
+ my $ss;
+ $ss += @$_ * @$_ foreach values %spread;
+ my $rms = sqrt ($ss / keys %spread);
+ if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
+ @best = ($rms, $max - $min, $i, \%spread);
+ }
+ }
+ die "Internal error. Failed to pick a switch point for @names"
+ unless defined $best[2];
+ # use Data::Dumper; print Dumper (@best);
+ my ($offset, $best) = @best[2,3];
+ $body .= $indent . "/* Offset $offset gives the best switch position. */\n";
+ $body .= $indent . "switch (name[$offset]) {\n";
+ foreach my $char (sort keys %$best) {
+ $body .= $indent . "case '" . C_stringify ($char) . "':\n";
+ foreach my $name (sort @{$best->{$char}}) {
+ my $thisone = $items->{$name};
+ my ($value, $macro, $default, $pre, $post, $def_pre, $def_post)
+ = @$thisone{qw (value macro default pre post def_pre def_post)};
+ $value = $name unless defined $value;
+ $macro = $name unless defined $macro;
+
+ # We have checked this offset.
+ $body .= memEQ_clause ($name, $offset, 2 + length $indent);
+ $body .= return_clause ($value, $thisone->{type}, 4 + length $indent,
+ $macro, $default, $pre, $post,
+ $def_pre, $def_post);
+ $body .= $indent . " }\n";
+ }
+ $body .= $indent . " break;\n";
+ }
+ $body .= $indent . "}\n";
+ return $body;
+ }
+
+ =item params WHAT
+
+ An internal function. I<WHAT> should be a hashref of types the constant
+ function will return. I<params> returns a hashref keyed IV NV PV SV to show
+ which combination of pointers will be needed in the C argument list.
+
+ =cut
+
+ sub params {
+ my $what = shift;
+ foreach (sort keys %$what) {
+ warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
+ }
+ my $params = {};
+ $params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN};
+ $params->{NV} = 1 if $what->{NV};
+ $params->{PV} = 1 if $what->{PV} || $what->{PVN};
+ $params->{SV} = 1 if $what->{SV};
+ return $params;
+ }
+
+ =item dump_names
+
+ dump_names PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
+
+ An internal function to generate the embedded perl code that will regenerate
+ the constant subroutines. Parameters are the same as for C_constant.
+
+ =cut
+
+ sub dump_names {
+ my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
+ = @_;
+ my (@simple, @complex);
+ foreach (@items) {
+ my $type = $_->{type} || $default_type;
+ if ($type eq $default_type and 0 == ($_->{name} =~ tr/A-Za-z0-9_//c)
+ and !defined ($_->{macro}) and !defined ($_->{value})
+ and !defined ($_->{default}) and !defined ($_->{pre})
+ and !defined ($_->{post}) and !defined ($_->{def_pre})
+ and !defined ($_->{def_post})) {
+ # It's the default type, and the name consists only of A-Za-z0-9_
+ push @simple, $_->{name};
+ } else {
+ push @complex, $_;
+ }
+ }
+ my $result = <<"EOT";
+ /* When generated this function returned values for the list of names given
+ in this section of perl code. Rather than manually editing these functions
+ to add or remove constants, which would result in this comment and section
+ of code becoming inaccurate, we recommend that you edit this section of
+ code, and use it to regenerate a new set of constant functions which you
+ then use to replace the originals.
+
+ Regenerate these constant functions by feeding this entire source file to
+ perl -x
+
+ #!$^X -w
+ use ExtUtils::Constant qw (constant_types C_constant XS_constant);
+
+ EOT
+ $result .= 'my $types = {map {($_, 1)} qw(' . join (" ", sort keys %$what)
+ . ")};\n";
+ $result .= wrap ("my \@names = (qw(",
+ " ", join (" ", sort @simple) . ")");
+ if (@complex) {
+ foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
+ my $name = C_stringify $item->{name};
+ my $line = ",\n {name=>\"$name\"";
+ $line .= ", type=>\"$item->{type}\"" if defined $item->{type};
+ foreach my $thing (qw (macro value default pre post def_pre def_post)) {
+ my $value = $item->{$thing};
+ if (defined $value) {
+ if (ref $value) {
+ $line .= ", $thing=>[\""
+ . join ('", "', map {C_stringify $_} @$value) . '"]';
+ } else {
+ $line .= ", $thing=>\"" . C_stringify($value) . "\"";
+ }
+ }
+ }
+ $line .= "}";
+ # Ensure that the enclosing C comment doesn't end
+ # by turning */ into *" . "/
+ $line =~ s!\*\/!\*" . "/!gs;
+ # gcc -Wall doesn't like finding /* inside a comment
+ $line =~ s!\/\*!/" . "\*!gs;
+ $result .= $line;
+ }
+ }
+ $result .= ");\n";
+
+ $result .= <<'EOT';
+
+ print constant_types(); # macro defs
+ EOT
+ $package = C_stringify($package);
+ $result .=
+ "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
+ # The form of the indent parameter isn't defined. (Yet)
+ if (defined $indent) {
+ require Data::Dumper;
+ $Data::Dumper::Terse=1;
+ $Data::Dumper::Terse=1; # Not used once. :-)
+ chomp ($indent = Data::Dumper::Dumper ($indent));
+ $result .= $indent;
+ } else {
+ $result .= 'undef';
+ }
+ $result .= ", $breakout" . ', @names) ) {
+ print $_, "\n"; # C constant subs
+ }
+ print "#### XS Section:\n";
+ print XS_constant ("' . $package . '", $types);
+ __END__
+ */
+
+ ';
+
+ $result;
+ }
+
+ =item C_constant
+
+ C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
+
+ A function that returns a B<list> of C subroutine definitions that return
+ the value and type of constants when passed the name by the XS wrapper.
+ I<ITEM...> gives a list of constant names. Each can either be a string,
+ which is taken as a C macro name, or a reference to a hash with the following
+ keys
+
+ =over 8
+
+ =item name
+
+ The name of the constant, as seen by the perl code.
+
+ =item type
+
+ The type of the constant (I<IV>, I<NV> etc)
+
+ =item value
+
+ A C expression for the value of the constant, or a list of C expressions if
+ the type is aggregate. This defaults to the I<name> if not given.
+
+ =item macro
+
+ The C pre-processor macro to use in the C<#ifdef>. This defaults to the
+ I<name>, and is mainly used if I<value> is an C<enum>. If a reference an
+ array is passed then the first element is used in place of the C<#ifdef>
+ line, and the second element in place of the C<#endif>. This allows
+ pre-processor constructions such as
+
+ #if defined (foo)
+ #if !defined (bar)
+ ...
+ #endif
+ #endif
+
+ to be used to determine if a constant is to be defined.
+
+ A "macro" 1 signals that the constant is always defined, so the C<#if>/C<#endif>
+ test is omitted.
+
+ =item default
+
+ Default value to use (instead of C<croak>ing with "your vendor has not
+ defined...") to return if the macro isn't defined. Specify a reference to
+ an array with type followed by value(s).
+
+ =item pre
+
+ C code to use before the assignment of the value of the constant. This allows
+ you to use temporary variables to extract a value from part of a C<struct>
+ and return this as I<value>. This C code is places at the start of a block,
+ so you can declare variables in it.
+
+ =item post
+
+ C code to place between the assignment of value (to a temporary) and the
+ return from the function. This allows you to clear up anything in I<pre>.
+ Rarely needed.
+
+ =item def_pre
+ =item def_post
+
+ Equivalents of I<pre> and I<post> for the default value.
+
+ =back
+
+ I<PACKAGE> is the name of the package, and is only used in comments inside the
+ generated C code.
+
+ The next 5 arguments can safely be given as C<undef>, and are mainly used
+ for recursion. I<SUBNAME> defaults to C<constant> if undefined.
+
+ I<DEFAULT_TYPE> is the type returned by C<ITEM>s that don't specify their
+ type. In turn it defaults to I<IV>. I<TYPES> should be given either as a comma
+ separated list of types that the C subroutine C<constant> will generate or as
+ a reference to a hash. I<DEFAULT_TYPE> will be added to the list if not
+ present, as will any types given in the list of I<ITEM>s. The resultant list
+ should be the same list of types that C<XS_constant> is given. [Otherwise
+ C<XS_constant> and C<C_constant> may differ in the number of parameters to the
+ constant function. I<INDENT> is currently unused and ignored. In future it may
+ be used to pass in information used to change the C indentation style used.]
+ The best way to maintain consistency is to pass in a hash reference and let
+ this function update it.
+
+ I<BREAKOUT> governs when child functions of I<SUBNAME> are generated. If there
+ are I<BREAKOUT> or more I<ITEM>s with the same length of name, then the code
+ to switch between them is placed into a function named I<SUBNAME>_I<LEN>, for
+ example C<constant_5> for names 5 characters long. The default I<BREAKOUT> is
+ 3. A single C<ITEM> is always inlined.
+
+ =cut
+
+ # The parameter now BREAKOUT was previously documented as:
+ #
+ # I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
+ # this length, and that the constant name passed in by perl is checked and
+ # also of this length. It is used during recursion, and should be C<undef>
+ # unless the caller has checked all the lengths during code generation, and
+ # the generated subroutine is only to be called with a name of this length.
+ #
+ # As you can see it now performs this function during recursion by being a
+ # scalar reference.
+
+ sub C_constant {
+ my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
+ = @_;
+ $package ||= 'Foo';
+ $subname ||= 'constant';
+ # I'm not using this. But a hashref could be used for full formatting without
+ # breaking this API
+ # $indent ||= 0;
+
+ my ($namelen, $items);
+ if (ref $breakout) {
+ # We are called recursively. We trust @items to be normalised, $what to
+ # be a hashref, and pinch %$items from our parent to save recalculation.
+ ($namelen, $items) = @$breakout;
+ } else {
+ $breakout ||= 3;
+ $default_type ||= 'IV';
+ if (!ref $what) {
+ # Convert line of the form IV,UV,NV to hash
+ $what = {map {$_ => 1} split /,\s*/, ($what || '')};
+ # Figure out what types we're dealing with, and assign all unknowns to the
+ # default type
+ }
+ foreach (@items) {
+ my $name;
+ if (ref $_) {
+ my $orig = $_;
+ # Make a copy which is a normalised version of the ref passed in.
+ $name = $_->{name};
+ my ($type, $macro, $value) = @$_{qw (type macro value)};
+ $type ||= $default_type;
+ $what->{$type} = 1;
+ $_ = {name=>$name, type=>$type};
+
+ undef $macro if defined $macro and $macro eq $name;
+ $_->{macro} = $macro if defined $macro;
+ undef $value if defined $value and $value eq $name;
+ $_->{value} = $value if defined $value;
+ foreach my $key (qw(default pre post def_pre def_post)) {
+ my $value = $orig->{$key};
+ $_->{$key} = $value if defined $value;
+ # warn "$key $value";
+ }
+ } else {
+ $name = $_;
+ $_ = {name=>$_, type=>$default_type};
+ $what->{$default_type} = 1;
+ }
+ warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$_->{type}};
+ if (exists $items->{$name}) {
+ die "Multiple definitions for macro $name";
+ }
+ $items->{$name} = $_;
+ }
+ }
+ my $params = params ($what);
+
+ my ($body, @subs) = "static int\n$subname (pTHX_ const char *name";
+ $body .= ", STRLEN len" unless defined $namelen;
+ $body .= ", IV *iv_return" if $params->{IV};
+ $body .= ", NV *nv_return" if $params->{NV};
+ $body .= ", const char **pv_return" if $params->{PV};
+ $body .= ", SV **sv_return" if $params->{SV};
+ $body .= ") {\n";
+
+ if (defined $namelen) {
+ # We are a child subroutine. Print the simple description
+ my $comment = 'When generated this function returned values for the list'
+ . ' of names given here. However, subsequent manual editing may have'
+ . ' added or removed some.';
+ $body .= switch_clause (2, $comment, $namelen, $items, @items);
+ } else {
+ # We are the top level.
+ $body .= " /* Initially switch on the length of the name. */\n";
+ $body .= dump_names ($package, $subname, $default_type, $what, $indent,
+ $breakout, @items);
+ $body .= " switch (len) {\n";
+ # Need to group names of the same length
+ my @by_length;
+ foreach (@items) {
+ push @{$by_length[length $_->{name}]}, $_;
+ }
+ foreach my $i (0 .. $#by_length) {
+ next unless $by_length[$i]; # None of this length
+ $body .= " case $i:\n";
+ if (@{$by_length[$i]} == 1) {
+ my $thisone = $by_length[$i]->[0];
+ my ($name, $value, $macro, $default, $pre, $post, $def_pre, $def_post)
+ = @$thisone{qw (name value macro default pre post def_pre def_post)};
+ $value = $name unless defined $value;
+ $macro = $name unless defined $macro;
+
+ $body .= memEQ_clause ($name);
+ $body .= return_clause ($value, $thisone->{type}, undef, $macro,
+ $default, $pre, $post, $def_pre, $def_post);
+ $body .= " }\n";
+ } elsif (@{$by_length[$i]} < $breakout) {
+ $body .= switch_clause (4, '', $i, $items, @{$by_length[$i]});
+ } else {
+ # Only use the minimal set of parameters actually needed by the types
+ # of the names of this length.
+ my $what = {};
+ foreach (@{$by_length[$i]}) {
+ $what->{$_->{type}} = 1;
+ }
+ $params = params ($what);
+ push @subs, C_constant ($package, "${subname}_$i", $default_type, $what,
+ $indent, [$i, $items], @{$by_length[$i]});
+ $body .= " return ${subname}_$i (aTHX_ name";
+ $body .= ", iv_return" if $params->{IV};
+ $body .= ", nv_return" if $params->{NV};
+ $body .= ", pv_return" if $params->{PV};
+ $body .= ", sv_return" if $params->{SV};
+ $body .= ");\n";
+ }
+ $body .= " break;\n";
+ }
+ $body .= " }\n";
+ }
+ $body .= " return PERL_constant_NOTFOUND;\n}\n";
+ return (@subs, $body);
+ }
+
+ =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME
+
+ A function to generate the XS code to implement the perl subroutine
+ I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
+ This XS code is a wrapper around a C subroutine usually generated by
+ C<C_constant>, and usually named C<constant>.
+
+ I<TYPES> should be given either as a comma separated list of types that the
+ C subroutine C<constant> will generate or as a reference to a hash. It should
+ be the same list of types as C<C_constant> was given.
+ [Otherwise C<XS_constant> and C<C_constant> may have different ideas about
+ the number of parameters passed to the C function C<constant>]
+
+ You can call the perl visible subroutine something other than C<constant> if
+ you give the parameter I<SUBNAME>. The C subroutine it calls defaults to the
+ the name of the perl visible subroutine, unless you give the parameter
+ I<C_SUBNAME>.
+
+ =cut
+
+ sub XS_constant {
+ my $package = shift;
+ my $what = shift;
+ my $subname = shift;
+ my $C_subname = shift;
+ $subname ||= 'constant';
+ $C_subname ||= $subname;
+
+ if (!ref $what) {
+ # Convert line of the form IV,UV,NV to hash
+ $what = {map {$_ => 1} split /,\s*/, ($what)};
+ }
+ my $params = params ($what);
+ my $type;
+
+ my $xs = <<"EOT";
+ void
+ $subname(sv)
+ PREINIT:
+ #ifdef dXSTARG
+ dXSTARG; /* Faster if we have it. */
+ #else
+ dTARGET;
+ #endif
+ STRLEN len;
+ int type;
+ EOT
+
+ if ($params->{IV}) {
+ $xs .= " IV iv;\n";
+ } else {
+ $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
+ }
+ if ($params->{NV}) {
+ $xs .= " NV nv;\n";
+ } else {
+ $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
+ }
+ if ($params->{PV}) {
+ $xs .= " const char *pv;\n";
+ } else {
+ $xs .=
+ " /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
+ }
+
+ $xs .= << 'EOT';
+ INPUT:
+ SV * sv;
+ const char * s = SvPV(sv, len);
+ PPCODE:
+ EOT
+
+ if ($params->{IV} xor $params->{NV}) {
+ $xs .= << "EOT";
+ /* Change this to $C_subname(aTHX_ s, len, &iv, &nv);
+ if you need to return both NVs and IVs */
+ EOT
+ }
+ $xs .= " type = $C_subname(aTHX_ s, len";
+ $xs .= ', &iv' if $params->{IV};
+ $xs .= ', &nv' if $params->{NV};
+ $xs .= ', &pv' if $params->{PV};
+ $xs .= ', &sv' if $params->{SV};
+ $xs .= ");\n";
+
+ $xs .= << "EOT";
+ /* Return 1 or 2 items. First is error message, or undef if no error.
+ Second, if present, is found value */
+ switch (type) {
+ case PERL_constant_NOTFOUND:
+ sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_NOTDEF:
+ sv = sv_2mortal(newSVpvf(
+ "Your vendor has not defined $package macro %s, used", s));
+ PUSHs(sv);
+ break;
+ EOT
+
+ foreach $type (sort keys %XS_Constant) {
+ $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
+ unless $what->{$type};
+ $xs .= " case PERL_constant_IS$type:\n";
+ if (length $XS_Constant{$type}) {
+ $xs .= << "EOT";
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ $XS_Constant{$type};
+ EOT
+ } else {
+ # Do nothing. return (), which will be correctly interpreted as
+ # (undef, undef)
+ }
+ $xs .= " break;\n";
+ unless ($what->{$type}) {
+ chop $xs; # Yes, another need for chop not chomp.
+ $xs .= " */\n";
+ }
+ }
+ $xs .= << "EOT";
+ default:
+ sv = sv_2mortal(newSVpvf(
+ "Unexpected return type %d while processing $package macro %s, used",
+ type, s));
+ PUSHs(sv);
+ }
+ EOT
+
+ return $xs;
+ }
+
+
+ =item autoload PACKAGE, VERSION, AUTOLOADER
+
+ A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
+ I<VERSION> is the perl version the code should be backwards compatible with.
+ It defaults to the version of perl running the subroutine. If I<AUTOLOADER>
+ is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
+ names that the constant() routine doesn't recognise.
+
+ =cut
+
+ # ' # Grr. syntax highlighters that don't grok pod.
+
+ sub autoload {
+ my ($module, $compat_version, $autoloader) = @_;
+ $compat_version ||= $];
+ croak "Can't maintain compatibility back as far as version $compat_version"
+ if $compat_version < 5;
+ my $func = "sub AUTOLOAD {\n"
+ . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n"
+ . " # XS function.";
+ $func .= " If a constant is not found then control is passed\n"
+ . " # to the AUTOLOAD in AutoLoader." if $autoloader;
+
+
+ $func .= "\n\n"
+ . " my \$constname;\n";
+ $func .=
+ " our \$AUTOLOAD;\n" if ($compat_version >= 5.006);
+
+ $func .= <<"EOT";
+ (\$constname = \$AUTOLOAD) =~ s/.*:://;
+ croak "&${module}::constant not defined" if \$constname eq 'constant';
+ my (\$error, \$val) = constant(\$constname);
+ EOT
+
+ if ($autoloader) {
+ $func .= <<'EOT';
+ if ($error) {
+ if ($error =~ /is not a valid/) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD;
+ } else {
+ croak $error;
+ }
+ }
+ EOT
+ } else {
+ $func .=
+ " if (\$error) { croak \$error; }\n";
+ }
+
+ $func .= <<'END';
+ {
+ no strict 'refs';
+ # Fixed between 5.005_53 and 5.005_61
+ #XXX if ($] >= 5.00561) {
+ #XXX *$AUTOLOAD = sub () { $val };
+ #XXX }
+ #XXX else {
+ *$AUTOLOAD = sub { $val };
+ #XXX }
+ }
+ goto &$AUTOLOAD;
+ }
+
+ END
+
+ return $func;
+ }
+
+
+ =item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...]
+
+ Writes a file of C code and a file of XS code which you should C<#include>
+ and C<INCLUDE> in the C and XS sections respectively of your module's XS
+ code. You probaby want to do this in your C<Makefile.PL>, so that you can
+ easily edit the list of constants without touching the rest of your module.
+ The attributes supported are
+
+ =over 4
+
+ =item NAME
+
+ Name of the module. This must be specified
+
+ =item DEFAULT_TYPE
+
+ The default type for the constants. If not specified C<IV> is assumed.
+
+ =item BREAKOUT_AT
+
+ The names of the constants are grouped by length. Generate child subroutines
+ for each group with this number or more names in.
+
+ =item NAMES
+
+ An array of constants' names, either scalars containing names, or hashrefs
+ as detailed in L<"C_constant">.
+
+ =item C_FILE
+
+ The name of the file to write containing the C code. The default is
+ C<constants.c>.
+
+ =item XS_FILE
+
+ The name of the file to write containing the XS code. The default is
+ C<constants.xs>.
+
+ =item SUBNAME
+
+ The perl visible name of the XS subroutine generated which will return the
+ constants. The default is C<constant>.
+
+ =item C_SUBNAME
+
+ The name of the C subroutine generated which will return the constants.
+ The default is I<SUBNAME>. Child subroutines have C<_> and the name
+ length appended, so constants with 10 character names would be in
+ C<constant_10> with the default I<XS_SUBNAME>.
+
+ =back
+
+ =cut
+
+ sub WriteConstants {
+ my %ARGS =
+ ( # defaults
+ C_FILE => 'constants.c',
+ XS_FILE => 'constants.xs',
+ SUBNAME => 'constant',
+ DEFAULT_TYPE => 'IV',
+ @_);
+
+ $ARGS{C_SUBNAME} ||= $ARGS{SUBNAME}; # No-one sane will have C_SUBNAME eq '0'
+
+ croak "Module name not specified" unless length $ARGS{NAME};
+
+ open my $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
+ open my $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
+
+ # As this subroutine is intended to make code that isn't edited, there's no
+ # need for the user to specify any types that aren't found in the list of
+ # names.
+ my $types = {};
+
+ print $c_fh constant_types(); # macro defs
+ print $c_fh "\n";
+
+ # indent is still undef. Until anyone implents indent style rules with it.
+ foreach (C_constant ($ARGS{NAME}, $ARGS{C_SUBNAME}, $ARGS{DEFAULT_TYPE},
+ $types, undef, $ARGS{BREAKOUT_AT}, @{$ARGS{NAMES}})) {
+ print $c_fh $_, "\n"; # C constant subs
+ }
+ print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME},
+ $ARGS{C_SUBNAME});
+
+ close $c_fh or warn "Error closing $ARGS{C_FILE}: $!";
+ close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!";
+ }
+
+ 1;
+ __END__
+
+ =back
+
+ =head1 AUTHOR
+
+ Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
+ others
+
+ =cut
diff -c 'perl-5.7.1/lib/ExtUtils/Embed.pm' 'perl-5.7.2/lib/ExtUtils/Embed.pm'
Index: ./lib/ExtUtils/Embed.pm
Prereq: 1.2501
*** ./lib/ExtUtils/Embed.pm Sun Apr 1 20:17:47 2001
--- ./lib/ExtUtils/Embed.pm Mon Jul 9 17:10:29 2001
***************
*** 18,24 ****
);
use strict;
! $VERSION = sprintf("%d.%02d", q$Revision: 1.2505 $ =~ /(\d+)\.(\d+)/);
@ISA = qw(Exporter);
@EXPORT = qw(&xsinit &ldopts
--- 18,24 ----
);
use strict;
! $VERSION = sprintf("%d.%02d", q$Revision: 1.2505_00 $ =~ /(\d+)\.(\d+)/);
@ISA = qw(Exporter);
@EXPORT = qw(&xsinit &ldopts
***************
*** 466,472 ****
This function returns a string of calls to B<newXS()> that glue the module B<bootstrap>
function to B<boot_ModuleName> for each @modules.
! B<xsinit()> uses the xsi_* functions to generate most of it's code.
=back
--- 466,472 ----
This function returns a string of calls to B<newXS()> that glue the module B<bootstrap>
function to B<boot_ModuleName> for each @modules.
! B<xsinit()> uses the xsi_* functions to generate most of its code.
=back
diff -c 'perl-5.7.1/lib/ExtUtils/Install.pm' 'perl-5.7.2/lib/ExtUtils/Install.pm'
Index: ./lib/ExtUtils/Install.pm
*** ./lib/ExtUtils/Install.pm Tue Mar 6 04:05:27 2001
--- ./lib/ExtUtils/Install.pm Mon Jul 9 17:10:29 2001
***************
*** 120,126 ****
return unless -f _;
return if $_ eq ".exists";
my $targetdir = MY->catdir($targetroot, $File::Find::dir);
- my $origfile = $_;
my $targetfile = MY->catfile($targetdir, $_);
my $diff = 0;
--- 120,125 ----
***************
*** 156,162 ****
} else {
inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0
}
! $packlist->{$origfile}++;
}, ".");
chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
--- 155,161 ----
} else {
inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0
}
! $packlist->{$targetfile}++;
}, ".");
chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
diff -c 'perl-5.7.1/lib/ExtUtils/Installed.pm' 'perl-5.7.2/lib/ExtUtils/Installed.pm'
Index: ./lib/ExtUtils/Installed.pm
*** ./lib/ExtUtils/Installed.pm Fri Mar 16 04:54:49 2001
--- ./lib/ExtUtils/Installed.pm Mon Jul 9 17:10:29 2001
***************
*** 8,15 ****
use Config;
use File::Find;
use File::Basename;
! our $VERSION = '0.02';
sub _is_type($$$)
{
my ($self, $path, $type) = @_;
--- 8,36 ----
use Config;
use File::Find;
use File::Basename;
! our $VERSION = '0.03';
+ my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/);
+
+ sub _is_prefix
+ {
+ my ($self, $path, $prefix) = @_;
+ if (substr($path, 0, length($prefix)) eq $prefix)
+ {
+ return(1);
+ }
+ if ($DOSISH)
+ {
+ $path =~ s|\\|/|g;
+ $prefix =~ s|\\|/|g;
+ if ($path =~ m{^\Q$prefix\E}i)
+ {
+ return(1);
+ }
+ }
+ return(0);
+ }
+
sub _is_type($$$)
{
my ($self, $path, $type) = @_;
***************
*** 16,37 ****
return(1) if ($type eq "all");
if ($type eq "doc")
{
! return(substr($path, 0, length($Config{installman1dir}))
! eq $Config{installman1dir}
||
! substr($path, 0, length($Config{installman3dir}))
! eq $Config{installman3dir}
? 1 : 0)
}
if ($type eq "prog")
{
! return(substr($path, 0, length($Config{prefix})) eq $Config{prefix}
&&
! substr($path, 0, length($Config{installman1dir}))
! ne $Config{installman1dir}
&&
! substr($path, 0, length($Config{installman3dir}))
! ne $Config{installman3dir}
? 1 : 0);
}
return(0);
--- 37,54 ----
return(1) if ($type eq "all");
if ($type eq "doc")
{
! return($self->_is_prefix($path, $Config{installman1dir})
||
! $self->_is_prefix($path, $Config{installman3dir})
? 1 : 0)
}
if ($type eq "prog")
{
! return($self->_is_prefix($path, $Config{prefix})
&&
! !$self->_is_prefix($path, $Config{installman1dir})
&&
! !$self->_is_prefix($path, $Config{installman3dir})
? 1 : 0);
}
return(0);
***************
*** 43,49 ****
$under[0] = "" if (! @under);
foreach my $dir (@under)
{
! return(1) if (substr($path, 0, length($dir)) eq $dir);
}
return(0);
}
--- 60,66 ----
$under[0] = "" if (! @under);
foreach my $dir (@under)
{
! return(1) if ($self->_is_prefix($path, $dir));
}
return(0);
}
***************
*** 54,62 ****
$class = ref($class) || $class;
my $self = {};
# Read the core packlist
$self->{Perl}{packlist} =
! ExtUtils::Packlist->new("$Config{installarchlib}/.packlist");
$self->{Perl}{version} = $Config{version};
# Read the module packlists
--- 71,90 ----
$class = ref($class) || $class;
my $self = {};
+ my $installarchlib = $Config{installarchlib};
+ my $archlib = $Config{archlib};
+ my $sitearch = $Config{sitearch};
+
+ if ($DOSISH)
+ {
+ $installarchlib =~ s|\\|/|g;
+ $archlib =~ s|\\|/|g;
+ $sitearch =~ s|\\|/|g;
+ }
+
# Read the core packlist
$self->{Perl}{packlist} =
! ExtUtils::Packlist->new("$installarchlib/.packlist");
$self->{Perl}{version} = $Config{version};
# Read the module packlists
***************
*** 63,74 ****
my $sub = sub
{
# Only process module .packlists
! return if ($_) ne ".packlist" || $File::Find::dir eq $Config{installarchlib};
# Hack of the leading bits of the paths & convert to a module name
my $module = $File::Find::name;
! $module =~ s!$Config{archlib}/auto/(.*)/.packlist!$1!s;
! $module =~ s!$Config{sitearch}/auto/(.*)/.packlist!$1!s;
my $modfile = "$module.pm";
$module =~ s!/!::!g;
--- 91,102 ----
my $sub = sub
{
# Only process module .packlists
! return if ($_) ne ".packlist" || $File::Find::dir eq $installarchlib;
# Hack of the leading bits of the paths & convert to a module name
my $module = $File::Find::name;
! $module =~ s!\Q$archlib\E/auto/(.*)/.packlist!$1!s;
! $module =~ s!\Q$sitearch\E/auto/(.*)/.packlist!$1!s;
my $modfile = "$module.pm";
$module =~ s!/!::!g;
***************
*** 87,93 ****
# Read the .packlist
$self->{$module}{packlist} = ExtUtils::Packlist->new($File::Find::name);
};
! find($sub, $Config{archlib}, $Config{sitearch});
return(bless($self, $class));
}
--- 115,121 ----
# Read the .packlist
$self->{$module}{packlist} = ExtUtils::Packlist->new($File::Find::name);
};
! find($sub, $archlib, $sitearch);
return(bless($self, $class));
}
diff -c 'perl-5.7.1/lib/ExtUtils/Liblist.pm' 'perl-5.7.2/lib/ExtUtils/Liblist.pm'
Index: ./lib/ExtUtils/Liblist.pm
*** ./lib/ExtUtils/Liblist.pm Tue Mar 6 04:05:27 2001
--- ./lib/ExtUtils/Liblist.pm Mon Jul 9 17:10:29 2001
***************
*** 24,30 ****
use 5.005_64;
# Broken out of MakeMaker from version 4.11
! our $VERSION = substr q$Revision: 1.26 $, 10;
use Config;
use Cwd 'cwd';
--- 24,30 ----
use 5.005_64;
# Broken out of MakeMaker from version 4.11
! our $VERSION = substr q$Revision: 1.27 $, 10;
use Config;
use Cwd 'cwd';
diff -c /dev/null 'perl-5.7.2/lib/ExtUtils/MM_NW5.pm'
Index: ./lib/ExtUtils/MM_NW5.pm
*** ./lib/ExtUtils/MM_NW5.pm Thu Jan 1 02:00:00 1970
--- ./lib/ExtUtils/MM_NW5.pm Mon Jul 9 17:10:29 2001
***************
*** 0 ****
--- 1,1057 ----
+ package ExtUtils::MM_NW5;
+
+ =head1 NAME
+
+ ExtUtils::MM_NW5 - methods to override UN*X behaviour in ExtUtils::MakeMaker
+
+ =head1 SYNOPSIS
+
+ use ExtUtils::MM_NW5; # Done internally by ExtUtils::MakeMaker if needed
+
+ =head1 DESCRIPTION
+
+ See ExtUtils::MM_Unix for a documentation of the methods provided
+ there. This package overrides the implementation of these methods, not
+ the semantics.
+
+ =over
+
+ =cut
+
+ use Config;
+ #use Cwd;
+ use File::Basename;
+ require Exporter;
+
+ Exporter::import('ExtUtils::MakeMaker',
+ qw( $Verbose &neatvalue));
+
+ $ENV{EMXSHELL} = 'sh'; # to run `commands`
+ unshift @MM::ISA, 'ExtUtils::MM_NW5';
+
+ $BORLAND = 1 if $Config{'cc'} =~ /^bcc/i;
+ $GCC = 1 if $Config{'cc'} =~ /^gcc/i;
+ $DMAKE = 1 if $Config{'make'} =~ /^dmake/i;
+ $NMAKE = 1 if $Config{'make'} =~ /^nmake/i;
+ $PERLMAKE = 1 if $Config{'make'} =~ /^pmake/i;
+ $OBJ = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i;
+
+ # a few workarounds for command.com (very basic)
+ {
+ package ExtUtils::MM_Win95;
+
+ # the $^O test may be overkill, but we want to be sure Win32::IsWin95()
+ # exists before we try it
+
+ unshift @MM::ISA, 'ExtUtils::MM_Win95'
+ if ($^O =~ /Win32/ && Win32::IsWin95());
+
+ sub xs_c {
+ my($self) = shift;
+ return '' unless $self->needs_linking();
+ '
+ .xs.c:
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) \\
+ $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.c
+ '
+ }
+
+ sub xs_cpp {
+ my($self) = shift;
+ return '' unless $self->needs_linking();
+ '
+ .xs.cpp:
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) \\
+ $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.cpp
+ ';
+ }
+
+ # many makes are too dumb to use xs_c then c_o
+ sub xs_o {
+ my($self) = shift;
+ return '' unless $self->needs_linking();
+ '
+ .xs$(OBJ_EXT):
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) \\
+ $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.c
+ $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
+ ';
+ }
+ } # end of command.com workarounds
+
+ sub dlsyms {
+ my($self,%attribs) = @_;
+
+ my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
+ my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
+ my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || [];
+ my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {};
+ my(@m);
+ (my $boot = $self->{NAME}) =~ s/:/_/g;
+
+ if (not $self->{SKIPHASH}{'dynamic'}) {
+ push(@m,"
+ $self->{BASEEXT}.def: Makefile.PL
+ ",
+ q! $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Mksymlists \\
+ -e "Mksymlists('NAME' => '!, $self->{NAME},
+ q!', 'DLBASE' => '!,$self->{DLBASE},
+ q!', 'DL_FUNCS' => !,neatvalue($funcs),
+ q!, 'FUNCLIST' => !,neatvalue($funclist),
+ q!, 'IMPORTS' => !,neatvalue($imports),
+ q!, 'DL_VARS' => !, neatvalue($vars), q!);"
+ !);
+ }
+ join('',@m);
+ }
+
+ sub replace_manpage_separator {
+ my($self,$man) = @_;
+ $man =~ s,/+,.,g;
+ $man;
+ }
+
+ sub maybe_command {
+ my($self,$file) = @_;
+ my @e = exists($ENV{'PATHEXT'})
+ ? split(/;/, $ENV{PATHEXT})
+ : qw(.com .exe .bat .cmd);
+ my $e = '';
+ for (@e) { $e .= "\Q$_\E|" }
+ chop $e;
+ # see if file ends in one of the known extensions
+ if ($file =~ /($e)$/i) {
+ return $file if -e $file;
+ }
+ else {
+ for (@e) {
+ return "$file$_" if -e "$file$_";
+ }
+ }
+ return;
+ }
+
+ sub file_name_is_absolute {
+ my($self,$file) = @_;
+ $file =~ m{^([a-z]:)?[\\/]}i ;
+ }
+
+ sub find_perl {
+ my($self, $ver, $names, $dirs, $trace) = @_;
+ my($name, $dir);
+ if ($trace >= 2){
+ print "Looking for perl $ver by these names:
+ @$names
+ in these dirs:
+ @$dirs
+ ";
+ }
+ foreach $dir (@$dirs){
+ next unless defined $dir; # $self->{PERL_SRC} may be undefined
+ foreach $name (@$names){
+ my ($abs, $val);
+ if ($self->file_name_is_absolute($name)) { # /foo/bar
+ $abs = $name;
+ } elsif ($self->canonpath($name) eq $self->canonpath(basename($name))) { # foo
+ $abs = $self->catfile($dir, $name);
+ } else { # foo/bar
+ $abs = $self->canonpath($self->catfile($self->curdir, $name));
+ }
+ print "Checking $abs\n" if ($trace >= 2);
+ next unless $self->maybe_command($abs);
+ print "Executing $abs\n" if ($trace >= 2);
+ $val = `$abs -e "require $ver;" 2>&1`;
+ if ($? == 0) {
+ print "Using PERL=$abs\n" if $trace;
+ return $abs;
+ } elsif ($trace >= 2) {
+ print "Result: `$val'\n";
+ }
+ }
+ }
+ print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
+ 0; # false and not empty
+ }
+
+ sub catdir {
+ my $self = shift;
+ my @args = @_;
+ for (@args) {
+ # append a slash to each argument unless it has one there
+ $_ .= "\\" if $_ eq '' or substr($_,-1) ne "\\";
+ }
+ my $result = $self->canonpath(join('', @args));
+ $result;
+ }
+
+ =item catfile
+
+ Concatenate one or more directory names and a filename to form a
+ complete path ending with a filename
+
+ =cut
+
+ sub catfile {
+ my $self = shift @_;
+ my $file = pop @_;
+ return $file unless @_;
+ my $dir = $self->catdir(@_);
+ $dir =~ s/(\\\.)$//;
+ $dir .= "\\" unless substr($dir,length($dir)-1,1) eq "\\";
+ return $dir.$file;
+ }
+
+ sub init_others
+ {
+ my ($self) = @_;
+ &ExtUtils::MM_Unix::init_others;
+ $self->{'TOUCH'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e touch';
+ $self->{'CHMOD'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e chmod';
+ $self->{'CP'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e cp';
+ $self->{'RM_F'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f';
+ $self->{'RM_RF'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_rf';
+ $self->{'MV'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e mv';
+ $self->{'NOOP'} = 'rem';
+ $self->{'TEST_F'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e test_f';
+ $self->{'LD'} = $Config{'ld'} || 'link';
+ $self->{'AR'} = $Config{'ar'} || 'lib';
+ $self->{'LDLOADLIBS'} ||= $Config{'libs'};
+ # -Lfoo must come first for Borland, so we put it in LDDLFLAGS
+ if ($BORLAND) {
+ my $libs = $self->{'LDLOADLIBS'};
+ my $libpath = '';
+ while ($libs =~ s/(?:^|\s)(("?)-L.+?\2)(?:\s|$)/ /) {
+ $libpath .= ' ' if length $libpath;
+ $libpath .= $1;
+ }
+ $self->{'LDLOADLIBS'} = $libs;
+ $self->{'LDDLFLAGS'} ||= $Config{'lddlflags'};
+ $self->{'LDDLFLAGS'} .= " $libpath";
+ }
+ $self->{'DEV_NULL'} = '> NUL';
+ # $self->{'NOECHO'} = ''; # till we have it working
+
+ # incpath is copied to makefile var INCLUDE in constants sub, here just make it empty
+ my $libpth = $Config{'libpth'};
+ $libpth =~ s( )(;);
+ $self->{'LIBPTH'} = $libpth;
+ $self->{'BASE_IMPORT'} = $Config{'base_import'};
+
+ # Additional import file specified from Makefile.pl
+ if($self->{'base_import'}) {
+ $self->{'BASE_IMPORT'} .= ',' . $self->{'base_import'};
+ }
+
+ $self->{'NLM_VERSION'} = $Config{'nlm_version'};
+ $self->{'MPKTOOL'} = $Config{'mpktool'};
+ $self->{'TOOLPATH'} = $Config{'toolpath'};
+ }
+
+
+ =item constants (o)
+
+ Initializes lots of constants and .SUFFIXES and .PHONY
+
+ =cut
+ # NetWare override
+ sub const_cccmd {
+ my($self,$libperl)=@_;
+ return $self->{CONST_CCCMD} if $self->{CONST_CCCMD};
+ return '' unless $self->needs_linking();
+ return $self->{CONST_CCCMD} =
+ q{CCCMD = $(CC) $(INC) $(CCFLAGS) $(OPTIMIZE) \\
+ $(PERLTYPE) $(LARGE) $(SPLIT) $(MPOLLUTE) \\
+ -DVERSION="$(VERSION)" -DXS_VERSION="$(XS_VERSION)"};
+ }
+
+ sub constants {
+ my($self) = @_;
+ my(@m,$tmp);
+
+ # Added LIBPTH, BASE_IMPORT, ABSTRACT, NLM_VERSION BOOT_SYMBOL, NLM_SHORT_NAME
+ # for NETWARE
+
+ for $tmp (qw/
+
+ AR_STATIC_ARGS NAME DISTNAME NAME_SYM VERSION
+ VERSION_SYM XS_VERSION INST_BIN INST_EXE INST_LIB
+ INST_ARCHLIB INST_SCRIPT PREFIX INSTALLDIRS
+ INSTALLPRIVLIB INSTALLARCHLIB INSTALLSITELIB
+ INSTALLSITEARCH INSTALLBIN INSTALLSCRIPT PERL_LIB
+ PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB
+ FIRST_MAKEFILE MAKE_APERL_FILE PERLMAINCC PERL_SRC
+ PERL_INC PERL FULLPERL LIBPTH BASE_IMPORT PERLRUN
+ PERLRUNINST TEST_LIBS FULL_AR PERL_CORE
+ NLM_VERSION MPKTOOL TOOLPATH
+
+ / ) {
+ next unless defined $self->{$tmp};
+ push @m, "$tmp = $self->{$tmp}\n";
+ }
+
+ (my $boot = $self->{'NAME'}) =~ s/:/_/g;
+ $self->{'BOOT_SYMBOL'}=$boot;
+ push @m, "BOOT_SYMBOL = $self->{'BOOT_SYMBOL'}\n";
+
+ # If the final binary name is greater than 8 chars,
+ # truncate it here and rename it after creation
+ # otherwise, Watcom Linker fails
+ if(length($self->{'BASEEXT'}) > 8) {
+ $self->{'NLM_SHORT_NAME'} = substr($self->{'NAME'},0,8);
+ push @m, "NLM_SHORT_NAME = $self->{'NLM_SHORT_NAME'}\n";
+ }
+
+ push @m, qq{
+ VERSION_MACRO = VERSION
+ DEFINE_VERSION = -D\$(VERSION_MACRO)=\\\"\$(VERSION)\\\"
+ XS_VERSION_MACRO = XS_VERSION
+ XS_DEFINE_VERSION = -D\$(XS_VERSION_MACRO)=\\\"\$(XS_VERSION)\\\"
+ };
+
+ # Get the include path and replace the spaces with ;
+ # Copy this to makefile as INCLUDE = d:\...;d:\;
+ (my $inc = $Config{'incpath'}) =~ s/ /;/g;
+
+ # Get the additional include path and append to INCLUDE, keep it in
+ # INC will give problems during compilation, hence reset it after getting
+ # the value
+ (my $add_inc = $self->{'INC'}) =~ s/ -I/;/g;
+ $self->{'INC'} = '';
+ push @m, qq{
+ INCLUDE = $inc;$add_inc;
+ };
+
+ # Set the path to Watcom binaries which might not have been set in
+ # any other place
+ push @m, qq{
+ PATH = \$(PATH);\$(TOOLPATH)
+ };
+
+ push @m, qq{
+ MAKEMAKER = $INC{'ExtUtils\MakeMaker.pm'}
+ MM_VERSION = $ExtUtils::MakeMaker::VERSION
+ };
+
+ push @m, q{
+ # FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle).
+ # BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle)
+ # ROOTEXT = Directory part of FULLEXT with leading slash (eg /DBD) !!! Deprecated from MM 5.32 !!!
+ # PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar)
+ # DLBASE = Basename part of dynamic library. May be just equal BASEEXT.
+ };
+
+ for $tmp (qw/
+ FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT
+ LDFROM LINKTYPE
+ / ) {
+ next unless defined $self->{$tmp};
+ push @m, "$tmp = $self->{$tmp}\n";
+ }
+
+ push @m, "
+ # Handy lists of source code files:
+ XS_FILES= ".join(" \\\n\t", sort keys %{$self->{XS}})."
+ C_FILES = ".join(" \\\n\t", @{$self->{C}})."
+ O_FILES = ".join(" \\\n\t", @{$self->{O_FILES}})."
+ H_FILES = ".join(" \\\n\t", @{$self->{H}})."
+ HTMLLIBPODS = ".join(" \\\n\t", sort keys %{$self->{HTMLLIBPODS}})."
+ HTMLSCRIPTPODS = ".join(" \\\n\t", sort keys %{$self->{HTMLSCRIPTPODS}})."
+ MAN1PODS = ".join(" \\\n\t", sort keys %{$self->{MAN1PODS}})."
+ MAN3PODS = ".join(" \\\n\t", sort keys %{$self->{MAN3PODS}})."
+ ";
+
+ for $tmp (qw/
+ INST_HTMLPRIVLIBDIR INSTALLHTMLPRIVLIBDIR
+ INST_HTMLSITELIBDIR INSTALLHTMLSITELIBDIR
+ INST_HTMLSCRIPTDIR INSTALLHTMLSCRIPTDIR
+ INST_HTMLLIBDIR HTMLEXT
+ INST_MAN1DIR INSTALLMAN1DIR MAN1EXT
+ INST_MAN3DIR INSTALLMAN3DIR MAN3EXT
+ /) {
+ next unless defined $self->{$tmp};
+ push @m, "$tmp = $self->{$tmp}\n";
+ }
+
+ push @m, qq{
+ .USESHELL :
+ } if $DMAKE;
+
+ push @m, q{
+ .NO_CONFIG_REC: Makefile
+ } if $ENV{CLEARCASE_ROOT};
+
+ # why not q{} ? -- emacs
+ push @m, qq{
+ # work around a famous dec-osf make(1) feature(?):
+ makemakerdflt: all
+
+ .SUFFIXES: .xs .c .C .cpp .cxx .cc \$(OBJ_EXT)
+
+ # Nick wanted to get rid of .PRECIOUS. I don't remember why. I seem to recall, that
+ # some make implementations will delete the Makefile when we rebuild it. Because
+ # we call false(1) when we rebuild it. So make(1) is not completely wrong when it
+ # does so. Our milage may vary.
+ # .PRECIOUS: Makefile # seems to be not necessary anymore
+
+ .PHONY: all config static dynamic test linkext manifest
+
+ # Where is the Config information that we are using/depend on
+ CONFIGDEP = \$(PERL_ARCHLIB)\\Config.pm \$(PERL_INC)\\config.h
+ };
+
+ my @parentdir = split(/::/, $self->{PARENT_NAME});
+ push @m, q{
+ # Where to put things:
+ INST_LIBDIR = }. $self->catdir('$(INST_LIB)',@parentdir) .q{
+ INST_ARCHLIBDIR = }. $self->catdir('$(INST_ARCHLIB)',@parentdir) .q{
+
+ INST_AUTODIR = }. $self->catdir('$(INST_LIB)','auto','$(FULLEXT)') .q{
+ INST_ARCHAUTODIR = }. $self->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)') .q{
+ };
+
+ if ($self->has_link_code()) {
+ push @m, '
+ INST_STATIC = $(INST_ARCHAUTODIR)\$(BASEEXT)$(LIB_EXT)
+ INST_DYNAMIC = $(INST_ARCHAUTODIR)\$(DLBASE).$(DLEXT)
+ INST_BOOT = $(INST_ARCHAUTODIR)\$(BASEEXT).bs
+ ';
+ } else {
+ push @m, '
+ INST_STATIC =
+ INST_DYNAMIC =
+ INST_BOOT =
+ ';
+ }
+
+ $tmp = $self->export_list;
+ push @m, "
+ EXPORT_LIST = $tmp
+ ";
+ $tmp = $self->perl_archive;
+ push @m, "
+ PERL_ARCHIVE = $tmp
+ ";
+
+ # push @m, q{
+ #INST_PM = }.join(" \\\n\t", sort values %{$self->{PM}}).q{
+ #
+ #PM_TO_BLIB = }.join(" \\\n\t", %{$self->{PM}}).q{
+ #};
+
+ push @m, q{
+ TO_INST_PM = }.join(" \\\n\t", sort keys %{$self->{PM}}).q{
+
+ PM_TO_BLIB = }.join(" \\\n\t", %{$self->{PM}}).q{
+ };
+
+ join('',@m);
+ }
+
+
+ sub path {
+ my($self) = @_;
+ my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
+ my @path = split(';',$path);
+ foreach(@path) { $_ = '.' if $_ eq '' }
+ @path;
+ }
+
+ =item static_lib (o)
+
+ Defines how to produce the *.a (or equivalent) files.
+
+ =cut
+
+ sub static_lib {
+ my($self) = @_;
+ # Come to think of it, if there are subdirs with linkcode, we still have no INST_STATIC
+ # return '' unless $self->needs_linking(); #might be because of a subdir
+
+ return '' unless $self->has_link_code;
+
+ my(@m);
+ push(@m, <<'END');
+ $(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)\.exists
+ $(RM_RF) $@
+ END
+
+ # If this extension has its own library (eg SDBM_File)
+ # then copy that to $(INST_STATIC) and add $(OBJECT) into it.
+ push(@m, "\t$self->{CP} \$(MYEXTLIB) \$\@\n") if $self->{MYEXTLIB};
+
+ push @m,
+ q{ $(AR) }.($BORLAND ? '$@ $(OBJECT:^"+")'
+ : ($GCC ? '-ru $@ $(OBJECT)'
+ : '-out:$@ $(OBJECT)')).q{
+ }.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)\extralibs.ld
+ $(CHMOD) 755 $@
+ };
+
+ # Old mechanism - still available:
+
+ push @m, "\t$self->{NOECHO}".q{echo "$(EXTRALIBS)" >> $(PERL_SRC)\ext.libs}."\n\n"
+ if $self->{PERL_SRC};
+
+ push @m, $self->dir_target('$(INST_ARCHAUTODIR)');
+ join('', "\n",@m);
+ }
+
+ =item dynamic_bs (o)
+
+ Defines targets for bootstrap files.
+
+ =cut
+
+ sub dynamic_bs {
+ my($self, %attribs) = @_;
+ return '
+ BOOTSTRAP =
+ ' unless $self->has_link_code();
+
+ return '
+ BOOTSTRAP = '."$self->{BASEEXT}.bs".'
+
+ # As Mkbootstrap might not write a file (if none is required)
+ # we use touch to prevent make continually trying to remake it.
+ # The DynaLoader only reads a non-empty file.
+ $(BOOTSTRAP): '."$self->{MAKEFILE} $self->{BOOTDEP}".' $(INST_ARCHAUTODIR)\.exists
+ '.$self->{NOECHO}.'echo "Running Mkbootstrap for $(NAME) ($(BSLOADLIBS))"
+ '.$self->{NOECHO}.'$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" \
+ -MExtUtils::Mkbootstrap \
+ -e "Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');"
+ '.$self->{NOECHO}.'$(TOUCH) $(BOOTSTRAP)
+ $(CHMOD) 644 $@
+
+ $(INST_BOOT): $(BOOTSTRAP) $(INST_ARCHAUTODIR)\.exists
+ '."$self->{NOECHO}$self->{RM_RF}".' $(INST_BOOT)
+ -'.$self->{CP}.' $(BOOTSTRAP) $(INST_BOOT)
+ $(CHMOD) 644 $@
+ ';
+ }
+
+ =item dynamic_lib (o)
+
+ Defines how to produce the *.so (or equivalent) files.
+
+ =cut
+
+ sub dynamic_lib {
+ my($self, %attribs) = @_;
+ return '' unless $self->needs_linking(); #might be because of a subdir
+
+ return '' unless $self->has_link_code;
+
+ my($otherldflags) = $attribs{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': '');
+ my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
+ my($ldfrom) = '$(LDFROM)';
+ my(@m);
+ (my $boot = $self->{NAME}) =~ s/:/_/g;
+ my ($mpk);
+ push(@m,'
+ # This section creates the dynamically loadable $(INST_DYNAMIC)
+ # from $(OBJECT) and possibly $(MYEXTLIB).
+ OTHERLDFLAGS = '.$otherldflags.'
+ INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
+
+ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP)
+ ');
+ # push(@m,
+ # q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) }
+ # .q{$(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)});
+
+ # Create xdc data for an MT safe NLM in case of mpk build
+ if ( $self->{CCFLAGS} =~ m/ -DMPK_ON /) {
+ $mpk=1;
+ push @m, ' $(MPKTOOL) $(BASEEXT).xdc
+ ';
+ } else {
+ $mpk=0;
+ }
+
+ push(@m,
+ q{ $(LD) Form Novell NLM '$(DISTNAME) Extension, XS_VERSION=$(XS_VERSION)'}
+ );
+
+ # Taking care of long names like FileHandle, ByteLoader, SDBM_File etc
+ if($self->{NLM_SHORT_NAME}) {
+ # In case of nlms with names exceeding 8 chars, build nlm in the
+ # current dir, rename and move to auto\lib. If we create in auto\lib
+ # in the first place, we can't rename afterwards.
+ push(@m,
+ q{ Name $(NLM_SHORT_NAME).$(DLEXT)}
+ );
+ } else {
+ push(@m,
+ q{ Name $(INST_AUTODIR)\\$(BASEEXT).$(DLEXT)}
+ );
+ }
+
+ push(@m,
+ q{ Option Quiet Option Version = $(NLM_VERSION) Option Caseexact Option NoDefaultLibs Option screenname 'none' Option Synchronize }
+ );
+
+ if ($mpk) {
+ push (@m,
+ q{ Option XDCDATA=$(BASEEXT).xdc }
+ );
+ }
+
+ # Add additional lib files if any (SDBM_File)
+ if($self->{MYEXTLIB}) {
+ push(@m,
+ q{ Library $(MYEXTLIB) }
+ );
+ }
+
+ #For now lets comment all the Watcom lib calls
+ #q{ LibPath $(LIBPTH) Library plib3s.lib Library math3s.lib Library clib3s.lib Library emu387.lib Library $(PERL_ARCHIVE) Library $(PERL_INC)\Main.lib}
+
+ push(@m,
+ q{ Library $(PERL_ARCHIVE) Library $(PERL_INC)\Main.lib}
+ .q{ Export boot_$(BOOT_SYMBOL) $(BASE_IMPORT) }
+ .q{ FILE $(OBJECT:.obj=,)}
+ );
+
+ # If it is having a short name, rename it
+ if($self->{NLM_SHORT_NAME}) {
+ push @m, '
+ if exist $(INST_AUTODIR)\\$(BASEEXT).$(DLEXT) del $(INST_AUTODIR)\\$(BASEEXT).$(DLEXT)';
+ push @m, '
+ rename $(NLM_SHORT_NAME).$(DLEXT) $(BASEEXT).$(DLEXT)';
+ push @m, '
+ move $(BASEEXT).$(DLEXT) $(INST_AUTODIR)';
+ }
+
+ push @m, '
+ $(CHMOD) 755 $@
+ ';
+
+ push @m, $self->dir_target('$(INST_ARCHAUTODIR)');
+ join('',@m);
+ }
+
+ sub perl_archive
+ {
+ my ($self) = @_;
+ return '$(PERL_INC)\\'.$Config{'libperl'};
+ }
+
+ sub export_list
+ {
+ my ($self) = @_;
+ return "$self->{BASEEXT}.def";
+ }
+
+ =item canonpath
+
+ No physical check on the filesystem, but a logical cleanup of a
+ path. On UNIX eliminated successive slashes and successive "/.".
+
+ =cut
+
+ sub canonpath {
+ my($self,$path) = @_;
+ $path =~ s/^([a-z]:)/\u$1/;
+ $path =~ s|/|\\|g;
+ $path =~ s|(.)\\+|$1\\|g ; # xx////xx -> xx/xx
+ $path =~ s|(\\\.)+\\|\\|g ; # xx/././xx -> xx/xx
+ $path =~ s|^(\.\\)+|| unless $path eq ".\\"; # ./xx -> xx
+ $path =~ s|\\$||
+ unless $path =~ m#^([a-z]:)?\\#; # xx/ -> xx
+ $path .= '.' if $path =~ m#\\$#;
+ $path;
+ }
+
+ =item perl_script
+
+ Takes one argument, a file name, and returns the file name, if the
+ argument is likely to be a perl script. On MM_Unix this is true for
+ any ordinary, readable file.
+
+ =cut
+
+ sub perl_script {
+ my($self,$file) = @_;
+ return $file if -r $file && -f _;
+ return "$file.pl" if -r "$file.pl" && -f _;
+ return "$file.bat" if -r "$file.bat" && -f _;
+ return;
+ }
+
+ =item pm_to_blib
+
+ Defines target that copies all files in the hash PM to their
+ destination and autosplits them. See L<ExtUtils::Install/DESCRIPTION>
+
+ =cut
+
+ sub pm_to_blib {
+ my $self = shift;
+ my($autodir) = $self->catdir('$(INST_LIB)','auto');
+ return q{
+ pm_to_blib: $(TO_INST_PM)
+ }.$self->{NOECHO}.q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \
+ "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Install \
+ -e "pm_to_blib(}.
+ ($NMAKE ? 'qw[ <<pmfiles.dat ],'
+ : $DMAKE ? 'qw[ $(mktmp,pmfiles.dat $(PM_TO_BLIB:s,\\,\\\\,)\n) ],'
+ : '{ qw[$(PM_TO_BLIB)] },'
+ ).q{'}.$autodir.q{')"
+ }. ($NMAKE ? q{
+ $(PM_TO_BLIB)
+ <<
+ } : '') . $self->{NOECHO}.q{$(TOUCH) $@
+ };
+ }
+
+ =item test_via_harness (o)
+
+ Helper method to write the test targets
+
+ =cut
+
+ sub test_via_harness {
+ my($self, $perl, $tests) = @_;
+ "\t$perl".q! -Mblib -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e "use Test::Harness qw(&runtests $$verbose); $$verbose=$(TEST_VERBOSE); runtests @ARGV;" !."$tests\n";
+ }
+
+
+ =item tool_autosplit (override)
+
+ Use Win32 quoting on command line.
+
+ =cut
+
+ sub tool_autosplit{
+ my($self, %attribs) = @_;
+ my($asl) = "";
+ $asl = "\$AutoSplit::Maxlen=$attribs{MAXLEN};" if $attribs{MAXLEN};
+ q{
+ # Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto
+ AUTOSPLITFILE = $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MAutoSplit }.$asl.q{ -e "autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1);"
+ };
+ }
+
+ =item tools_other (o)
+
+ Win32 overrides.
+
+ Defines SHELL, LD, TOUCH, CP, MV, RM_F, RM_RF, CHMOD, UMASK_NULL in
+ the Makefile. Also defines the perl programs MKPATH,
+ WARN_IF_OLD_PACKLIST, MOD_INSTALL. DOC_INSTALL, and UNINSTALL.
+
+ =cut
+
+ sub tools_other {
+ my($self) = shift;
+ my @m;
+ my $bin_sh = $Config{sh} || 'cmd /c';
+ push @m, qq{
+ SHELL = $bin_sh
+ } unless $DMAKE; # dmake determines its own shell
+
+ for (qw/ CHMOD CP LD MV NOOP RM_F RM_RF TEST_F TOUCH UMASK_NULL DEV_NULL/ ) {
+ push @m, "$_ = $self->{$_}\n";
+ }
+
+ push @m, q{
+ # The following is a portable way to say mkdir -p
+ # To see which directories are created, change the if 0 to if 1
+ MKPATH = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e mkpath
+
+ # This helps us to minimize the effect of the .exists files A yet
+ # better solution would be to have a stable file in the perl
+ # distribution with a timestamp of zero. But this solution doesn't
+ # need any changes to the core distribution and works with older perls
+ EQUALIZE_TIMESTAMP = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e eqtime
+ };
+
+
+ return join "", @m if $self->{PARENT};
+
+ push @m, q{
+ # Here we warn users that an old packlist file was found somewhere,
+ # and that they should call some uninstall routine
+ WARN_IF_OLD_PACKLIST = $(PERL) -lwe "exit unless -f $$ARGV[0];" \\
+ -e "print 'WARNING: I have found an old package in';" \\
+ -e "print ' ', $$ARGV[0], '.';" \\
+ -e "print 'Please make sure the two installations are not conflicting';"
+
+ UNINST=0
+ VERBINST=1
+
+ MOD_INSTALL = $(PERL) -I$(INST_LIB) -I$(PERL_LIB) -MExtUtils::Install \
+ -e "install({ @ARGV },'$(VERBINST)',0,'$(UNINST)');"
+
+ DOC_INSTALL = $(PERL) -e "$$\=\"\n\n\";" \
+ -e "print '=head2 ', scalar(localtime), ': C<', shift, '>', ' L<', shift, '>';" \
+ -e "print '=over 4';" \
+ -e "while (defined($$key = shift) and defined($$val = shift)) { print '=item *';print 'C<', \"$$key: $$val\", '>'; }" \
+ -e "print '=back';"
+
+ UNINSTALL = $(PERL) -MExtUtils::Install \
+ -e "uninstall($$ARGV[0],1,1); print \"\nUninstall is deprecated. Please check the";" \
+ -e "print \" packlist above carefully.\n There may be errors. Remove the\";" \
+ -e "print \" appropriate files manually.\n Sorry for the inconveniences.\n\""
+ };
+
+ return join "", @m;
+ }
+
+ =item xs_o (o)
+
+ Defines suffix rules to go from XS to object files directly. This is
+ only intended for broken make implementations.
+
+ =cut
+
+ sub xs_o { # many makes are too dumb to use xs_c then c_o
+ my($self) = shift;
+ return ''
+ }
+
+ =item top_targets (o)
+
+ Defines the targets all, subdirs, config, and O_FILES
+
+ =cut
+
+ sub top_targets {
+ # --- Target Sections ---
+
+ my($self) = shift;
+ my(@m);
+ push @m, '
+ #all :: config $(INST_PM) subdirs linkext manifypods
+ ';
+
+ push @m, '
+ all :: pure_all htmlifypods manifypods
+ '.$self->{NOECHO}.'$(NOOP)
+ '
+ unless $self->{SKIPHASH}{'all'};
+
+ push @m, '
+ pure_all :: config pm_to_blib subdirs linkext
+ '.$self->{NOECHO}.'$(NOOP)
+
+ subdirs :: $(MYEXTLIB)
+ '.$self->{NOECHO}.'$(NOOP)
+
+ config :: '.$self->{MAKEFILE}.' $(INST_LIBDIR)\.exists
+ '.$self->{NOECHO}.'$(NOOP)
+
+ config :: $(INST_ARCHAUTODIR)\.exists
+ '.$self->{NOECHO}.'$(NOOP)
+
+ config :: $(INST_AUTODIR)\.exists
+ '.$self->{NOECHO}.'$(NOOP)
+ ';
+
+ push @m, $self->dir_target(qw[$(INST_AUTODIR) $(INST_LIBDIR) $(INST_ARCHAUTODIR)]);
+
+ if (%{$self->{HTMLLIBPODS}}) {
+ push @m, qq[
+ config :: \$(INST_HTMLLIBDIR)/.exists
+ $self->{NOECHO}\$(NOOP)
+
+ ];
+ push @m, $self->dir_target(qw[$(INST_HTMLLIBDIR)]);
+ }
+
+ if (%{$self->{HTMLSCRIPTPODS}}) {
+ push @m, qq[
+ config :: \$(INST_HTMLSCRIPTDIR)/.exists
+ $self->{NOECHO}\$(NOOP)
+
+ ];
+ push @m, $self->dir_target(qw[$(INST_HTMLSCRIPTDIR)]);
+ }
+
+ if (%{$self->{MAN1PODS}}) {
+ push @m, qq[
+ config :: \$(INST_MAN1DIR)\\.exists
+ $self->{NOECHO}\$(NOOP)
+
+ ];
+ push @m, $self->dir_target(qw[$(INST_MAN1DIR)]);
+ }
+ if (%{$self->{MAN3PODS}}) {
+ push @m, qq[
+ config :: \$(INST_MAN3DIR)\\.exists
+ $self->{NOECHO}\$(NOOP)
+
+ ];
+ push @m, $self->dir_target(qw[$(INST_MAN3DIR)]);
+ }
+
+ push @m, '
+ $(O_FILES): $(H_FILES)
+ ' if @{$self->{O_FILES} || []} && @{$self->{H} || []};
+
+ push @m, q{
+ help:
+ perldoc ExtUtils::MakeMaker
+ };
+
+ push @m, q{
+ Version_check:
+ }.$self->{NOECHO}.q{$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \
+ -MExtUtils::MakeMaker=Version_check \
+ -e "Version_check('$(MM_VERSION)')"
+ };
+
+ join('',@m);
+ }
+
+ =item htmlifypods (o)
+
+ Defines targets and routines to translate the pods into HTML manpages
+ and put them into the INST_HTMLLIBDIR and INST_HTMLSCRIPTDIR
+ directories.
+
+ Same as MM_Unix version (changes command-line quoting).
+
+ =cut
+
+ sub htmlifypods {
+ my($self, %attribs) = @_;
+ return "\nhtmlifypods : pure_all\n\t$self->{NOECHO}\$(NOOP)\n" unless
+ %{$self->{HTMLLIBPODS}} || %{$self->{HTMLSCRIPTPODS}};
+ my($dist);
+ my($pod2html_exe);
+ if (defined $self->{PERL_SRC}) {
+ $pod2html_exe = $self->catfile($self->{PERL_SRC},'pod','pod2html');
+ } else {
+ $pod2html_exe = $self->catfile($Config{scriptdirexp},'pod2html');
+ }
+ unless ($pod2html_exe = $self->perl_script($pod2html_exe)) {
+ # No pod2html but some HTMLxxxPODS to be installed
+ print <<END;
+
+ Warning: I could not locate your pod2html program. Please make sure,
+ your pod2html program is in your PATH before you execute 'make'
+
+ END
+ $pod2html_exe = "-S pod2html";
+ }
+ my(@m);
+ push @m,
+ qq[POD2HTML_EXE = $pod2html_exe\n],
+ qq[POD2HTML = \$(PERL) -we "use File::Basename; use File::Path qw(mkpath); %m=\@ARGV;for (keys %m){" \\\n],
+ q[-e "next if -e $$m{$$_} && -M $$m{$$_} < -M $$_ && -M $$m{$$_} < -M '],
+ $self->{MAKEFILE}, q[';" \\
+ -e "print qq(Htmlifying $$m{$$_}\n);" \\
+ -e "$$dir = dirname($$m{$$_}); mkpath($$dir) unless -d $$dir;" \\
+ -e "system(qq[$$^X ].q["-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" $(POD2HTML_EXE) ].qq[$$_>$$m{$$_}])==0 or warn qq(Couldn\\047t install $$m{$$_}\n);" \\
+ -e "chmod(oct($(PERM_RW))), $$m{$$_} or warn qq(chmod $(PERM_RW) $$m{$$_}: $$!\n);}"
+ ];
+ push @m, "\nhtmlifypods : pure_all ";
+ push @m, join " \\\n\t", keys %{$self->{HTMLLIBPODS}}, keys %{$self->{HTMLSCRIPTPODS}};
+
+ push(@m,"\n");
+ if (%{$self->{HTMLLIBPODS}} || %{$self->{HTMLSCRIPTPODS}}) {
+ push @m, "\t$self->{NOECHO}\$(POD2HTML) \\\n\t";
+ push @m, join " \\\n\t", %{$self->{HTMLLIBPODS}}, %{$self->{HTMLSCRIPTPODS}};
+ }
+ join('', @m);
+ }
+
+ =item manifypods (o)
+
+ We don't want manpage process.
+
+ =cut
+
+ sub manifypods {
+ my($self) = shift;
+ return "\nmanifypods :\n\t$self->{NOECHO}\$(NOOP)\n";
+ }
+
+ =item dist_ci (o)
+
+ Same as MM_Unix version (changes command-line quoting).
+
+ =cut
+
+ sub dist_ci {
+ my($self) = shift;
+ my @m;
+ push @m, q{
+ ci :
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=maniread \\
+ -e "@all = keys %{ maniread() };" \\
+ -e "print(\"Executing $(CI) @all\n\"); system(\"$(CI) @all\");" \\
+ -e "print(\"Executing $(RCS_LABEL) ...\n\"); system(\"$(RCS_LABEL) @all\");"
+ };
+ join "", @m;
+ }
+
+ =item dist_core (o)
+
+ Same as MM_Unix version (changes command-line quoting).
+
+ =cut
+
+ sub dist_core {
+ my($self) = shift;
+ my @m;
+ push @m, q{
+ dist : $(DIST_DEFAULT)
+ }.$self->{NOECHO}.q{$(PERL) -le "print \"Warning: Makefile possibly out of date with $$vf\" if " \
+ -e "-e ($$vf=\"$(VERSION_FROM)\") and -M $$vf < -M \"}.$self->{MAKEFILE}.q{\";"
+
+ tardist : $(DISTVNAME).tar$(SUFFIX)
+
+ zipdist : $(DISTVNAME).zip
+
+ $(DISTVNAME).tar$(SUFFIX) : distdir
+ $(PREOP)
+ $(TO_UNIX)
+ $(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME)
+ $(RM_RF) $(DISTVNAME)
+ $(COMPRESS) $(DISTVNAME).tar
+ $(POSTOP)
+
+ $(DISTVNAME).zip : distdir
+ $(PREOP)
+ $(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME)
+ $(RM_RF) $(DISTVNAME)
+ $(POSTOP)
+
+ uutardist : $(DISTVNAME).tar$(SUFFIX)
+ uuencode $(DISTVNAME).tar$(SUFFIX) \\
+ $(DISTVNAME).tar$(SUFFIX) > \\
+ $(DISTVNAME).tar$(SUFFIX)_uu
+
+ shdist : distdir
+ $(PREOP)
+ $(SHAR) $(DISTVNAME) > $(DISTVNAME).shar
+ $(RM_RF) $(DISTVNAME)
+ $(POSTOP)
+ };
+ join "", @m;
+ }
+
+ =item pasthru (o)
+
+ Defines the string that is passed to recursive make calls in
+ subdirectories.
+
+ =cut
+
+ sub pasthru {
+ my($self) = shift;
+ return "PASTHRU = " . ($NMAKE ? "-nologo" : "");
+ }
+
+
+
+ 1;
+ __END__
+
+ =back
+
+ =cut
+
+
diff -c 'perl-5.7.1/lib/ExtUtils/MM_Unix.pm' 'perl-5.7.2/lib/ExtUtils/MM_Unix.pm'
Index: ./lib/ExtUtils/MM_Unix.pm
*** ./lib/ExtUtils/MM_Unix.pm Wed Mar 7 16:47:09 2001
--- ./lib/ExtUtils/MM_Unix.pm Mon Jul 9 17:10:29 2001
***************
*** 81,88 ****
sub canonpath {
my($self,$path) = @_;
my $node = '';
! if ( $^O eq 'qnx' && $path =~ s|^(//\d+)/|/|s ) {
$node = $1;
}
$path =~ s|(?<=[^/])/+|/|g ; # xx////xx -> xx/xx
--- 81,90 ----
sub canonpath {
my($self,$path) = @_;
+
+ # Handle POSIX-style node names beginning with double slash
my $node = '';
! if ( $^O =~ m/^(?:qnx|nto)$/ && $path =~ s:^(//[^/]+)(/|\z):/:s ) {
$node = $1;
}
$path =~ s|(?<=[^/])/+|/|g ; # xx////xx -> xx/xx
***************
*** 89,95 ****
$path =~ s|(/\.)+/|/|g ; # xx/././xx -> xx/xx
$path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx
$path =~ s|(?<=[^/])/\z|| ; # xx/ -> xx
! "$node$path";
}
=item catdir
--- 91,97 ----
$path =~ s|(/\.)+/|/|g ; # xx/././xx -> xx/xx
$path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx
$path =~ s|(?<=[^/])/\z|| ; # xx/ -> xx
! return "$node$path";
}
=item catdir
***************
*** 276,281 ****
--- 278,287 ----
';
}
push @m, '
+ .c.s:
+ $(CCCMD) -S $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
+ ';
+ push @m, '
.c$(OBJ_EXT):
$(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
';
***************
*** 458,469 ****
}
my(@otherfiles) = values %{$self->{XS}}; # .c files from *.xs files
push(@otherfiles, $attribs{FILES}) if $attribs{FILES};
push(@otherfiles, qw[./blib $(MAKE_APERL_FILE) $(INST_ARCHAUTODIR)/extralibs.all
! perlmain.c mon.out core core.*perl.*.?
*perl.core so_locations pm_to_blib
! *$(OBJ_EXT) *$(LIB_EXT) perl.exe
! $(BOOTSTRAP) $(BASEEXT).bso $(BASEEXT).def
$(BASEEXT).exp
]);
push @m, "\t-$self->{RM_RF} @otherfiles\n";
--- 464,483 ----
}
my(@otherfiles) = values %{$self->{XS}}; # .c files from *.xs files
+ if ( $^O eq 'qnx' ) {
+ my @errfiles = @{$self->{C}};
+ for ( @errfiles ) {
+ s/.c$/.err/;
+ }
+ push( @otherfiles, @errfiles, 'perlmain.err' );
+ }
push(@otherfiles, $attribs{FILES}) if $attribs{FILES};
push(@otherfiles, qw[./blib $(MAKE_APERL_FILE) $(INST_ARCHAUTODIR)/extralibs.all
! perlmain.c tmon.out mon.out core core.*perl.*.?
*perl.core so_locations pm_to_blib
! *$(OBJ_EXT) *$(LIB_EXT) perl.exe perl perl$(EXE_EXT)
! $(BOOTSTRAP) $(BASEEXT).bso
! $(BASEEXT).def lib$(BASEEXT).def
$(BASEEXT).exp
]);
push @m, "\t-$self->{RM_RF} @otherfiles\n";
***************
*** 561,567 ****
INSTALLSITEARCH INSTALLBIN INSTALLSCRIPT PERL_LIB
PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB
FIRST_MAKEFILE MAKE_APERL_FILE PERLMAINCC PERL_SRC
! PERL_INC PERL FULLPERL FULL_AR
/ ) {
next unless defined $self->{$tmp};
--- 575,582 ----
INSTALLSITEARCH INSTALLBIN INSTALLSCRIPT PERL_LIB
PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB
FIRST_MAKEFILE MAKE_APERL_FILE PERLMAINCC PERL_SRC
! PERL_INC PERL FULLPERL PERLRUN PERLRUNINST TEST_LIBS
! FULL_AR PERL_CORE
/ ) {
next unless defined $self->{$tmp};
***************
*** 639,645 ****
# work around a famous dec-osf make(1) feature(?):
makemakerdflt: all
! .SUFFIXES: .xs .c .C .cpp .i .cxx .cc \$(OBJ_EXT)
# Nick wanted to get rid of .PRECIOUS. I don't remember why. I seem to recall, that
# some make implementations will delete the Makefile when we rebuild it. Because
--- 654,660 ----
# work around a famous dec-osf make(1) feature(?):
makemakerdflt: all
! .SUFFIXES: .xs .c .C .cpp .i .s .cxx .cc \$(OBJ_EXT)
# Nick wanted to get rid of .PRECIOUS. I don't remember why. I seem to recall, that
# some make implementations will delete the Makefile when we rebuild it. Because
***************
*** 834,852 ****
push @m, q{
distcheck :
! $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=fullcheck \\
-e fullcheck
};
push @m, q{
skipcheck :
! $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=skipcheck \\
-e skipcheck
};
push @m, q{
manifest :
! $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=mkmanifest \\
-e mkmanifest
};
--- 849,867 ----
push @m, q{
distcheck :
! $(PERLRUN) -MExtUtils::Manifest=fullcheck \\
-e fullcheck
};
push @m, q{
skipcheck :
! $(PERLRUN) -MExtUtils::Manifest=skipcheck \\
-e skipcheck
};
push @m, q{
manifest :
! $(PERLRUN) -MExtUtils::Manifest=mkmanifest \\
-e mkmanifest
};
***************
*** 868,874 ****
my @m;
push @m, q{
ci :
! $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=maniread \\
-e "@all = keys %{ maniread() };" \\
-e 'print("Executing $(CI) @all\n"); system("$(CI) @all");' \\
-e 'print("Executing $(RCS_LABEL) ...\n"); system("$(RCS_LABEL) @all");'
--- 883,889 ----
my @m;
push @m, q{
ci :
! $(PERLRUN) -MExtUtils::Manifest=maniread \\
-e "@all = keys %{ maniread() };" \\
-e 'print("Executing $(CI) @all\n"); system("$(CI) @all");' \\
-e 'print("Executing $(RCS_LABEL) ...\n"); system("$(RCS_LABEL) @all");'
***************
*** 935,941 ****
push @m, q{
distdir :
$(RM_RF) $(DISTVNAME)
! $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=manicopy,maniread \\
-e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');"
};
join "", @m;
--- 950,956 ----
push @m, q{
distdir :
$(RM_RF) $(DISTVNAME)
! $(PERLRUN) -MExtUtils::Manifest=manicopy,maniread \\
-e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');"
};
join "", @m;
***************
*** 954,960 ****
my @m;
push @m, q{
disttest : distdir
! cd $(DISTVNAME) && $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) Makefile.PL
cd $(DISTVNAME) && $(MAKE)
cd $(DISTVNAME) && $(MAKE) test
};
--- 969,975 ----
my @m;
push @m, q{
disttest : distdir
! cd $(DISTVNAME) && $(PERLRUN) Makefile.PL
cd $(DISTVNAME) && $(MAKE)
cd $(DISTVNAME) && $(MAKE) test
};
***************
*** 990,996 ****
push(@m,"
$self->{BASEEXT}.exp: Makefile.PL
! ",' $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e \'use ExtUtils::Mksymlists; \\
Mksymlists("NAME" => "',$self->{NAME},'", "DL_FUNCS" => ',
neatvalue($funcs), ', "FUNCLIST" => ', neatvalue($funclist),
', "DL_VARS" => ', neatvalue($vars), ');\'
--- 1005,1011 ----
push(@m,"
$self->{BASEEXT}.exp: Makefile.PL
! ",' $(PERLRUN) -e \'use ExtUtils::Mksymlists; \\
Mksymlists("NAME" => "',$self->{NAME},'", "DL_FUNCS" => ',
neatvalue($funcs), ', "FUNCLIST" => ', neatvalue($funclist),
', "DL_VARS" => ', neatvalue($vars), ');\'
***************
*** 1038,1044 ****
# The DynaLoader only reads a non-empty file.
$(BOOTSTRAP): '."$self->{MAKEFILE} $self->{BOOTDEP}".' $(INST_ARCHAUTODIR)/.exists
'.$self->{NOECHO}.'echo "Running Mkbootstrap for $(NAME) ($(BSLOADLIBS))"
! '.$self->{NOECHO}.'$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" \
-MExtUtils::Mkbootstrap \
-e "Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');"
'.$self->{NOECHO}.'$(TOUCH) $(BOOTSTRAP)
--- 1053,1059 ----
# The DynaLoader only reads a non-empty file.
$(BOOTSTRAP): '."$self->{MAKEFILE} $self->{BOOTDEP}".' $(INST_ARCHAUTODIR)/.exists
'.$self->{NOECHO}.'echo "Running Mkbootstrap for $(NAME) ($(BSLOADLIBS))"
! '.$self->{NOECHO}.'$(PERLRUN) \
-MExtUtils::Mkbootstrap \
-e "Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');"
'.$self->{NOECHO}.'$(TOUCH) $(BOOTSTRAP)
***************
*** 1069,1079 ****
my($ldfrom) = '$(LDFROM)';
$armaybe = 'ar' if ($^O eq 'dec_osf' and $armaybe eq ':');
my(@m);
push(@m,'
# This section creates the dynamically loadable $(INST_DYNAMIC)
# from $(OBJECT) and possibly $(MYEXTLIB).
ARMAYBE = '.$armaybe.'
! OTHERLDFLAGS = '.$otherldflags.'
INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP)
--- 1084,1095 ----
my($ldfrom) = '$(LDFROM)';
$armaybe = 'ar' if ($^O eq 'dec_osf' and $armaybe eq ':');
my(@m);
+ my $ld_opt = $Is_OS2 ? '$(OPTIMIZE) ' : ''; # Useful on other systems too?
push(@m,'
# This section creates the dynamically loadable $(INST_DYNAMIC)
# from $(OBJECT) and possibly $(MYEXTLIB).
ARMAYBE = '.$armaybe.'
! OTHERLDFLAGS = '.$ld_opt.$otherldflags.'
INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP)
***************
*** 1392,1398 ****
$self->{MAKEFILE}, q[";' \\
-e 'print "Htmlifying $$m{$$_}\n";' \\
-e '$$dir = dirname($$m{$$_}); mkpath($$dir) unless -d $$dir;' \\
! -e 'system(qq[$$^X ].q["-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" $(POD2HTML_EXE) ].qq[$$_>$$m{$$_}])==0 or warn "Couldn\\047t install $$m{$$_}\n";' \\
-e 'chmod(oct($(PERM_RW))), $$m{$$_} or warn "chmod $(PERM_RW) $$m{$$_}: $$!\n";}'
];
push @m, "\nhtmlifypods : pure_all ";
--- 1408,1414 ----
$self->{MAKEFILE}, q[";' \\
-e 'print "Htmlifying $$m{$$_}\n";' \\
-e '$$dir = dirname($$m{$$_}); mkpath($$dir) unless -d $$dir;' \\
! -e 'system(q[$(PERLRUN) $(POD2HTML_EXE) ].qq[$$_>$$m{$$_}])==0 or warn "Couldn\\047t install $$m{$$_}\n";' \\
-e 'chmod(oct($(PERM_RW))), $$m{$$_} or warn "chmod $(PERM_RW) $$m{$$_}: $$!\n";}'
];
push @m, "\nhtmlifypods : pure_all ";
***************
*** 2035,2040 ****
--- 2051,2075 ----
# Define 'FULLPERL' to be a non-miniperl (used in test: target)
($self->{FULLPERL} = $self->{PERL}) =~ s/miniperl/perl/i
unless ($self->{FULLPERL});
+
+ # Are we building the core?
+ $self->{PERL_CORE} = 0 unless exists $self->{PERL_CORE};
+
+ # How do we run perl?
+ $self->{PERLRUN} = $self->{PERL};
+
+ # How do we run perl when installing libraries?
+ $self->{PERLRUNINST} .= $self->{PERL}. ' -I$(INST_ARCHLIB) -I$(INST_LIB)';
+
+ # What extra library dirs do we need when running the tests?
+ $self->{TEST_LIBS} .= ' -I$(INST_ARCHLIB) -I$(INST_LIB)';
+
+ # When building the core, we need to add some helper libs since
+ # perl's @INC won't work (we're not installed yet).
+ foreach my $targ (qw(PERLRUN PERLRUNINST TEST_LIBS)) {
+ $self->{$targ} .= ' -I$(PERL_ARCHLIB) -I$(PERL_LIB)'
+ if $self->{PERL_CORE};
+ }
}
=item init_others
***************
*** 2230,2238 ****
EXE_FILES = @{$self->{EXE_FILES}}
} . ($Is_Win32
! ? q{FIXIN = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \
-e "system qq[pl2bat.bat ].shift"
! } : q{FIXIN = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::MakeMaker \
-e "MY->fixin(shift)"
}).qq{
pure_all :: @to
--- 2265,2273 ----
EXE_FILES = @{$self->{EXE_FILES}}
} . ($Is_Win32
! ? q{FIXIN = $(PERLRUN) \
-e "system qq[pl2bat.bat ].shift"
! } : q{FIXIN = $(PERLRUN) -MExtUtils::MakeMaker \
-e "MY->fixin(shift)"
}).qq{
pure_all :: @to
***************
*** 2357,2363 ****
$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
}.$self->{NOECHO}.q{echo Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET)
! }.$self->{NOECHO}.q{$(PERL) -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \
Makefile.PL DIR=}, $dir, q{ \
MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
MAKEAPERL=1 NORECURS=1 CCCDLFLAGS=};
--- 2392,2398 ----
$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
}.$self->{NOECHO}.q{echo Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET)
! }.$self->{NOECHO}.q{$(PERLRUNINST) \
Makefile.PL DIR=}, $dir, q{ \
MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
MAKEAPERL=1 NORECURS=1 CCCDLFLAGS=};
***************
*** 2593,2599 ****
-}.$self->{NOECHO}.q{$(RM_F) }."$self->{MAKEFILE}.old".q{
-}.$self->{NOECHO}.q{$(MV) }."$self->{MAKEFILE} $self->{MAKEFILE}.old".q{
-$(MAKE) -f }.$self->{MAKEFILE}.q{.old clean $(DEV_NULL) || $(NOOP)
! $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" Makefile.PL }.join(" ",map(qq["$_"],@ARGV)).q{
}.$self->{NOECHO}.q{echo "==> Your Makefile has been rebuilt. <=="
}.$self->{NOECHO}.q{echo "==> Please rerun the make command. <=="
false
--- 2628,2634 ----
-}.$self->{NOECHO}.q{$(RM_F) }."$self->{MAKEFILE}.old".q{
-}.$self->{NOECHO}.q{$(MV) }."$self->{MAKEFILE} $self->{MAKEFILE}.old".q{
-$(MAKE) -f }.$self->{MAKEFILE}.q{.old clean $(DEV_NULL) || $(NOOP)
! $(PERLRUN) Makefile.PL }.join(" ",map(qq["$_"],@ARGV)).q{
}.$self->{NOECHO}.q{echo "==> Your Makefile has been rebuilt. <=="
}.$self->{NOECHO}.q{echo "==> Please rerun the make command. <=="
false
***************
*** 2646,2652 ****
q[-e 'next if -e $$m{$$_} && -M $$m{$$_} < -M $$_ && -M $$m{$$_} < -M "],
$self->{MAKEFILE}, q[";' \\
-e 'print "Manifying $$m{$$_}\n";' \\
! -e 'system(qq[$$^X ].q["-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" $(POD2MAN_EXE) ].qq[$$_>$$m{$$_}])==0 or warn "Couldn\\047t install $$m{$$_}\n";' \\
-e 'chmod(oct($(PERM_RW))), $$m{$$_} or warn "chmod $(PERM_RW) $$m{$$_}: $$!\n";}'
];
push @m, "\nmanifypods : pure_all ";
--- 2681,2687 ----
q[-e 'next if -e $$m{$$_} && -M $$m{$$_} < -M $$_ && -M $$m{$$_} < -M "],
$self->{MAKEFILE}, q[";' \\
-e 'print "Manifying $$m{$$_}\n";' \\
! -e 'system(q[$(PERLRUN) $(POD2MAN_EXE) ].qq[$$_>$$m{$$_}])==0 or warn "Couldn\\047t install $$m{$$_}\n";' \\
-e 'chmod(oct($(PERM_RW))), $$m{$$_} or warn "chmod $(PERM_RW) $$m{$$_}: $$!\n";}'
];
push @m, "\nmanifypods : pure_all ";
***************
*** 3053,3060 ****
my($autodir) = $self->catdir('$(INST_LIB)','auto');
return q{
pm_to_blib: $(TO_INST_PM)
! }.$self->{NOECHO}.q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \
! "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Install \
-e "pm_to_blib({qw{$(PM_TO_BLIB)}},'}.$autodir.q{','$(PM_FILTER)')"
}.$self->{NOECHO}.q{$(TOUCH) $@
};
--- 3088,3094 ----
my($autodir) = $self->catdir('$(INST_LIB)','auto');
return q{
pm_to_blib: $(TO_INST_PM)
! }.$self->{NOECHO}.q{$(PERLRUNINST) -MExtUtils::Install \
-e "pm_to_blib({qw{$(PM_TO_BLIB)}},'}.$autodir.q{','$(PM_FILTER)')"
}.$self->{NOECHO}.q{$(TOUCH) $@
};
***************
*** 3110,3116 ****
my($self,$var,$sprefix,$rprefix) = @_;
$self->{uc $var} ||= $Config{lc $var};
$self->{uc $var} = VMS::Filespec::unixpath($self->{uc $var}) if $Is_VMS;
! $self->{uc $var} =~ s/\Q$sprefix\E/$rprefix/s;
}
=item processPL (o)
--- 3144,3150 ----
my($self,$var,$sprefix,$rprefix) = @_;
$self->{uc $var} ||= $Config{lc $var};
$self->{uc $var} = VMS::Filespec::unixpath($self->{uc $var}) if $Is_VMS;
! $self->{uc $var} =~ s,^\Q$sprefix\E(?=/|\z),$rprefix,s;
}
=item processPL (o)
***************
*** 3134,3140 ****
$self->{NOECHO}\$(NOOP)
$target :: $plfile
! \$(PERL) -I\$(INST_ARCHLIB) -I\$(INST_LIB) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) $plfile $target
";
}
}
--- 3168,3174 ----
$self->{NOECHO}\$(NOOP)
$target :: $plfile
! \$(PERLRUNINST) $plfile $target
";
}
}
***************
*** 3247,3253 ****
$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)/.exists
$(RM_RF) $@
END
! # If this extension has it's own library (eg SDBM_File)
# then copy that to $(INST_STATIC) and add $(OBJECT) into it.
push(@m, "\t$self->{CP} \$(MYEXTLIB) \$\@\n") if $self->{MYEXTLIB};
--- 3281,3287 ----
$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)/.exists
$(RM_RF) $@
END
! # If this extension has its own library (eg SDBM_File)
# then copy that to $(INST_STATIC) and add $(OBJECT) into it.
push(@m, "\t$self->{CP} \$(MYEXTLIB) \$\@\n") if $self->{MYEXTLIB};
***************
*** 3454,3460 ****
sub test_via_harness {
my($self, $perl, $tests) = @_;
$perl = "PERL_DL_NONLAZY=1 $perl" unless $Is_Win32;
! "\t$perl".q! -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use Test::Harness qw(&runtests $$verbose); $$verbose=$(TEST_VERBOSE); runtests @ARGV;' !."$tests\n";
}
=item test_via_script (o)
--- 3488,3494 ----
sub test_via_harness {
my($self, $perl, $tests) = @_;
$perl = "PERL_DL_NONLAZY=1 $perl" unless $Is_Win32;
! "\t$perl".q! $(TEST_LIBS) -e 'use Test::Harness qw(&runtests $$verbose); $$verbose=$(TEST_VERBOSE); runtests @ARGV;' !."$tests\n";
}
=item test_via_script (o)
***************
*** 3466,3472 ****
sub test_via_script {
my($self, $perl, $script) = @_;
$perl = "PERL_DL_NONLAZY=1 $perl" unless $Is_Win32;
! qq{\t$perl}.q{ -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) }.qq{$script
};
}
--- 3500,3506 ----
sub test_via_script {
my($self, $perl, $script) = @_;
$perl = "PERL_DL_NONLAZY=1 $perl" unless $Is_Win32;
! qq{\t$perl}.q{ $(TEST_LIBS) }.qq{$script
};
}
***************
*** 3485,3491 ****
$asl = "\$AutoSplit::Maxlen=$attribs{MAXLEN};" if $attribs{MAXLEN};
q{
# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto
! AUTOSPLITFILE = $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e 'use AutoSplit;}.$asl.q{autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1) ;'
};
}
--- 3519,3525 ----
$asl = "\$AutoSplit::Maxlen=$attribs{MAXLEN};" if $attribs{MAXLEN};
q{
# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto
! AUTOSPLITFILE = $(PERLRUN) -e 'use AutoSplit;}.$asl.q{autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1) ;'
};
}
***************
*** 3512,3524 ****
push @m, q{
# The following is a portable way to say mkdir -p
# To see which directories are created, change the if 0 to if 1
! MKPATH = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e mkpath
# This helps us to minimize the effect of the .exists files A yet
# better solution would be to have a stable file in the perl
# distribution with a timestamp of zero. But this solution doesn't
# need any changes to the core distribution and works with older perls
! EQUALIZE_TIMESTAMP = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e eqtime
};
--- 3546,3558 ----
push @m, q{
# The following is a portable way to say mkdir -p
# To see which directories are created, change the if 0 to if 1
! MKPATH = $(PERLRUN) -MExtUtils::Command -e mkpath
# This helps us to minimize the effect of the .exists files A yet
# better solution would be to have a stable file in the perl
# distribution with a timestamp of zero. But this solution doesn't
# need any changes to the core distribution and works with older perls
! EQUALIZE_TIMESTAMP = $(PERLRUN) -MExtUtils::Command -e eqtime
};
***************
*** 3606,3611 ****
--- 3640,3646 ----
XSPROTOARG = $self->{XSPROTOARG}
XSUBPPDEPS = @tmdeps \$(XSUBPP)
XSUBPPARGS = @tmargs
+ XSUBPP_EXTRA_ARGS =
};
};
***************
*** 3750,3756 ****
push @m, q{
Version_check:
! }.$self->{NOECHO}.q{$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \
-MExtUtils::MakeMaker=Version_check \
-e "Version_check('$(MM_VERSION)')"
};
--- 3785,3791 ----
push @m, q{
Version_check:
! }.$self->{NOECHO}.q{$(PERLRUN) \
-MExtUtils::MakeMaker=Version_check \
-e "Version_check('$(MM_VERSION)')"
};
***************
*** 3784,3790 ****
return '' unless $self->needs_linking();
'
.xs.c:
! $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.c
';
}
--- 3819,3825 ----
return '' unless $self->needs_linking();
'
.xs.c:
! $(PERLRUN) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $(XSUBPP_EXTRA_ARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.c
';
}
***************
*** 3799,3805 ****
return '' unless $self->needs_linking();
'
.xs.cpp:
! $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.cpp
';
}
--- 3834,3840 ----
return '' unless $self->needs_linking();
'
.xs.cpp:
! $(PERLRUN) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.cpp
';
}
***************
*** 3815,3821 ****
return '' unless $self->needs_linking();
'
.xs$(OBJ_EXT):
! $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.c
$(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
';
}
--- 3850,3856 ----
return '' unless $self->needs_linking();
'
.xs$(OBJ_EXT):
! $(PERLRUN) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.c
$(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
';
}
diff -c 'perl-5.7.1/lib/ExtUtils/MM_VMS.pm' 'perl-5.7.2/lib/ExtUtils/MM_VMS.pm'
Index: ./lib/ExtUtils/MM_VMS.pm
*** ./lib/ExtUtils/MM_VMS.pm Fri Mar 30 05:15:30 2001
--- ./lib/ExtUtils/MM_VMS.pm Tue Jul 10 05:20:53 2001
***************
*** 538,544 ****
INSTALLSITEARCH INSTALLBIN INSTALLSCRIPT PERL_LIB
PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB
FIRST_MAKEFILE MAKE_APERL_FILE PERLMAINCC PERL_SRC PERL_VMS
! PERL_INC PERL FULLPERL
/ ) {
next unless defined $self->{$macro};
push @m, "$macro = $self->{$macro}\n";
--- 538,545 ----
INSTALLSITEARCH INSTALLBIN INSTALLSCRIPT PERL_LIB
PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB
FIRST_MAKEFILE MAKE_APERL_FILE PERLMAINCC PERL_SRC PERL_VMS
! PERL_INC PERL FULLPERL PERLRUN PERLRUNINST TEST_LIBS
! PERL_CORE
/ ) {
next unless defined $self->{$macro};
push @m, "$macro = $self->{$macro}\n";
***************
*** 1332,1338 ****
$(INST_STATIC) : $(OBJECT) $(MYEXTLIB)
';
! # If this extension has it's own library (eg SDBM_File)
# then copy that to $(INST_STATIC) and add $(OBJECT) into it.
push(@m, "\t",'$(CP) $(MYEXTLIB) $(MMS$TARGET)',"\n") if $self->{MYEXTLIB};
--- 1333,1339 ----
$(INST_STATIC) : $(OBJECT) $(MYEXTLIB)
';
! # If this extension has its own library (eg SDBM_File)
# then copy that to $(INST_STATIC) and add $(OBJECT) into it.
push(@m, "\t",'$(CP) $(MYEXTLIB) $(MMS$TARGET)',"\n") if $self->{MYEXTLIB};
diff -c 'perl-5.7.1/lib/ExtUtils/MM_Win32.pm' 'perl-5.7.2/lib/ExtUtils/MM_Win32.pm'
Index: ./lib/ExtUtils/MM_Win32.pm
*** ./lib/ExtUtils/MM_Win32.pm Fri Mar 16 04:54:49 2001
--- ./lib/ExtUtils/MM_Win32.pm Mon Jul 9 17:10:29 2001
***************
*** 254,260 ****
INSTALLSITEARCH INSTALLBIN INSTALLSCRIPT PERL_LIB
PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB
FIRST_MAKEFILE MAKE_APERL_FILE PERLMAINCC PERL_SRC
! PERL_INC PERL FULLPERL
/ ) {
next unless defined $self->{$tmp};
--- 254,261 ----
INSTALLSITEARCH INSTALLBIN INSTALLSCRIPT PERL_LIB
PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB
FIRST_MAKEFILE MAKE_APERL_FILE PERLMAINCC PERL_SRC
! PERL_INC PERL FULLPERL PERLRUN PERLRUNINST TEST_LIBS
! FULL_AR PERL_CORE
/ ) {
next unless defined $self->{$tmp};
***************
*** 415,421 ****
$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)\.exists
$(RM_RF) $@
END
! # If this extension has it's own library (eg SDBM_File)
# then copy that to $(INST_STATIC) and add $(OBJECT) into it.
push(@m, "\t$self->{CP} \$(MYEXTLIB) \$\@\n") if $self->{MYEXTLIB};
--- 416,422 ----
$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)\.exists
$(RM_RF) $@
END
! # If this extension has its own library (eg SDBM_File)
# then copy that to $(INST_STATIC) and add $(OBJECT) into it.
push(@m, "\t$self->{CP} \$(MYEXTLIB) \$\@\n") if $self->{MYEXTLIB};
***************
*** 531,536 ****
--- 532,552 ----
push @m, $self->dir_target('$(INST_ARCHAUTODIR)');
join('',@m);
}
+
+ sub clean
+ {
+ my ($self) = @_;
+ my $s = &ExtUtils::MM_Unix::clean;
+ my $clean = $GCC ? 'dll.base dll.exp' : '*.pdb';
+ $s .= <<END;
+ clean ::
+ -\$(RM_F) $clean
+
+ END
+ return $s;
+ }
+
+
sub perl_archive
{
diff -c 'perl-5.7.1/lib/ExtUtils/MakeMaker.pm' 'perl-5.7.2/lib/ExtUtils/MakeMaker.pm'
Index: ./lib/ExtUtils/MakeMaker.pm
*** ./lib/ExtUtils/MakeMaker.pm Tue Mar 6 04:05:29 2001
--- ./lib/ExtUtils/MakeMaker.pm Mon Jul 9 17:10:30 2001
***************
*** 2,8 ****
package ExtUtils::MakeMaker;
! $VERSION = "5.45";
$Version_OK = "5.17"; # Makefiles older than $Version_OK will die
# (Will be checked from MakeMaker version 4.13 onwards)
($Revision = substr(q$Revision: 1.222 $, 10)) =~ s/\s+$//;
--- 2,8 ----
package ExtUtils::MakeMaker;
! $VERSION = "5.46";
$Version_OK = "5.17"; # Makefiles older than $Version_OK will die
# (Will be checked from MakeMaker version 4.13 onwards)
($Revision = substr(q$Revision: 1.222 $, 10)) =~ s/\s+$//;
***************
*** 71,76 ****
--- 71,77 ----
$Is_Mac = $^O eq 'MacOS';
$Is_Win32 = $^O eq 'MSWin32';
$Is_Cygwin= $^O eq 'cygwin';
+ $Is_NetWare = $Config{'osname'} eq 'NetWare';
require ExtUtils::MM_Unix;
***************
*** 84,89 ****
--- 85,95 ----
if ($Is_Mac) {
require ExtUtils::MM_MacOS;
}
+ if ($Is_NetWare) {
+ $^O = 'NetWare';
+ require ExtUtils::MM_NW5;
+ $Is_Win32=0;
+ }
if ($Is_Win32) {
require ExtUtils::MM_Win32;
}
***************
*** 199,211 ****
LINKTYPE MAKEAPERL MAKEFILE MAN1PODS MAN3PODS MAP_TARGET MYEXTLIB
PERL_MALLOC_OK
NAME NEEDS_LINKING NOECHO NORECURS NO_VC OBJECT OPTIMIZE PERL PERLMAINCC
! PERL_ARCHLIB PERL_LIB PERL_SRC PERM_RW PERM_RWX
PL_FILES PM PM_FILTER PMLIBDIRS POLLUTE PPM_INSTALL_EXEC
! PPM_INSTALL_SCRIPT PREFIX
! PREREQ_PM SKIP TYPEMAPS VERSION VERSION_FROM XS XSOPT XSPROTOARG
XS_VERSION clean depend dist dynamic_lib linkext macro realclean
tool_autosplit
-
MACPERL_SRC MACPERL_LIB MACLIBS_68K MACLIBS_PPC MACLIBS_SC MACLIBS_MRC
MACLIBS_ALL_68K MACLIBS_ALL_PPC MACLIBS_SHARED
/;
--- 205,217 ----
LINKTYPE MAKEAPERL MAKEFILE MAN1PODS MAN3PODS MAP_TARGET MYEXTLIB
PERL_MALLOC_OK
NAME NEEDS_LINKING NOECHO NORECURS NO_VC OBJECT OPTIMIZE PERL PERLMAINCC
! PERLRUN PERLRUNINST PERL_ARCHLIB PERL_CORE
! PERL_LIB PERL_SRC PERM_RW PERM_RWX
PL_FILES PM PM_FILTER PMLIBDIRS POLLUTE PPM_INSTALL_EXEC
! PPM_INSTALL_SCRIPT PREFIX
! PREREQ_PM SKIP TEST_LIBS TYPEMAPS VERSION VERSION_FROM XS XSOPT XSPROTOARG
XS_VERSION clean depend dist dynamic_lib linkext macro realclean
tool_autosplit
MACPERL_SRC MACPERL_LIB MACLIBS_68K MACLIBS_PPC MACLIBS_SC MACLIBS_MRC
MACLIBS_ALL_68K MACLIBS_ALL_PPC MACLIBS_SHARED
/;
***************
*** 405,411 ****
}
if ($self->{PARENT}) {
$self->{PARENT}->{CHILDREN}->{$newclass} = $self;
! foreach my $opt (qw(CAPI POLLUTE)) {
if (exists $self->{PARENT}->{$opt}
and not exists $self->{$opt})
{
--- 411,417 ----
}
if ($self->{PARENT}) {
$self->{PARENT}->{CHILDREN}->{$newclass} = $self;
! foreach my $opt (qw(CAPI POLLUTE PERL_CORE)) {
if (exists $self->{PARENT}->{$opt}
and not exists $self->{$opt})
{
***************
*** 1054,1060 ****
make perl
That produces a new perl binary in the current directory with all
! extensions linked in that can be found in INST_ARCHLIB , SITELIBEXP,
and PERL_ARCHLIB. To do that, MakeMaker writes a new Makefile, on
UNIX, this is called Makefile.aperl (may be system dependent). If you
want to force the creation of a new perl, it is recommended, that you
--- 1060,1066 ----
make perl
That produces a new perl binary in the current directory with all
! extensions linked in that can be found in INST_ARCHLIB, SITELIBEXP,
and PERL_ARCHLIB. To do that, MakeMaker writes a new Makefile, on
UNIX, this is called Makefile.aperl (may be system dependent). If you
want to force the creation of a new perl, it is recommended, that you
***************
*** 1585,1590 ****
--- 1591,1601 ----
Perl binary for tasks that can be done by miniperl
+ =item PERL_CORE
+
+ Set only when MakeMaker is building the extensions of the Perl core
+ distribution.
+
=item PERLMAINCC
The call to the program that is able to compile perlmain.c. Defaults
***************
*** 1592,1603 ****
=item PERL_ARCHLIB
! Same as below, but for architecture dependent files.
=item PERL_LIB
Directory containing the Perl library to use.
=item PERL_MALLOC_OK
defaults to 0. Should be set to TRUE if the extension can work with
--- 1603,1622 ----
=item PERL_ARCHLIB
! Same as for PERL_LIB, but for architecture dependent files.
+ Used only when MakeMaker is building the extensions of the Perl core
+ distribution (because normally $(PERL_ARCHLIB) is automatically in @INC,
+ and adding it would get in the way of PERL5LIB).
+
=item PERL_LIB
Directory containing the Perl library to use.
+ Used only when MakeMaker is building the extensions of the Perl core
+ distribution (because normally $(PERL_LIB) is automatically in @INC,
+ and adding it would get in the way of PERL5LIB).
+
=item PERL_MALLOC_OK
defaults to 0. Should be set to TRUE if the extension can work with
***************
*** 1626,1631 ****
--- 1645,1661 ----
system resources, error detection, memory usage reporting, catchable failure
of memory allocations, etc.
+ =item PERLRUN
+
+ Use this instead of $(PERL) or $(FULLPERL) when you wish to run perl.
+ It will set up extra necessary flags for you.
+
+ =item PERLRUNINST
+
+ Use this instead of $(PERL) or $(FULLPERL) when you wish to run
+ perl to work with modules. It will add things like -I$(INST_ARCH)
+ and other necessary flags.
+
=item PERL_SRC
Directory containing the Perl source code (use of this should be
***************
*** 1738,1748 ****
=item SKIP
! Arryref. E.g. [qw(name1 name2)] skip (do not write) sections of the
Makefile. Caution! Do not use the SKIP attribute for the negligible
speedup. It may seriously damage the resulting Makefile. Only use it
if you really need it.
=item TYPEMAPS
Ref to array of typemap file names. Use this when the typemaps are
--- 1768,1783 ----
=item SKIP
! Arrayref. E.g. [qw(name1 name2)] skip (do not write) sections of the
Makefile. Caution! Do not use the SKIP attribute for the negligible
speedup. It may seriously damage the resulting Makefile. Only use it
if you really need it.
+ =item TEST_LIBS
+
+ The set of -I's necessary to run a "make test". Use as:
+ $(PERL) $(TEST_LIBS) -e '...' for example.
+
=item TYPEMAPS
Ref to array of typemap file names. Use this when the typemaps are
diff -c 'perl-5.7.1/lib/ExtUtils/Manifest.pm' 'perl-5.7.2/lib/ExtUtils/Manifest.pm'
Index: ./lib/ExtUtils/Manifest.pm
*** ./lib/ExtUtils/Manifest.pm Fri Mar 16 04:54:49 2001
--- ./lib/ExtUtils/Manifest.pm Mon Jul 9 17:10:30 2001
***************
*** 12,18 ****
$Is_MacOS,$Is_VMS,
$Debug,$Verbose,$Quiet,$MANIFEST,$found,$DEFAULT_MSKIP);
! $VERSION = substr(q$Revision: 1.33 $, 10);
@ISA=('Exporter');
@EXPORT_OK = ('mkmanifest', 'manicheck', 'fullcheck', 'filecheck',
'skipcheck', 'maniread', 'manicopy');
--- 12,18 ----
$Is_MacOS,$Is_VMS,
$Debug,$Verbose,$Quiet,$MANIFEST,$found,$DEFAULT_MSKIP);
! $VERSION = substr(q$Revision: 1.34 $, 10);
@ISA=('Exporter');
@EXPORT_OK = ('mkmanifest', 'manicheck', 'fullcheck', 'filecheck',
'skipcheck', 'maniread', 'manicopy');
***************
*** 121,127 ****
}
warn "Debug: manicheck checking from disk $file\n" if $Debug;
unless ( exists $read->{$file} ) {
! my $canon = "\t" . _unmacify($file) if $Is_MacOS;
warn "Not in $MANIFEST: $file$canon\n" unless $Quiet;
push @missentry, $file;
}
--- 121,127 ----
}
warn "Debug: manicheck checking from disk $file\n" if $Debug;
unless ( exists $read->{$file} ) {
! my $canon = $Is_MacOS ? "\t" . _unmacify($file) : '';
warn "Not in $MANIFEST: $file$canon\n" unless $Quiet;
push @missentry, $file;
}
diff -c 'perl-5.7.1/lib/ExtUtils/Mksymlists.pm' 'perl-5.7.2/lib/ExtUtils/Mksymlists.pm'
Index: ./lib/ExtUtils/Mksymlists.pm
*** ./lib/ExtUtils/Mksymlists.pm Fri Mar 16 04:54:49 2001
--- ./lib/ExtUtils/Mksymlists.pm Mon Jul 9 17:10:30 2001
***************
*** 6,15 ****
use Carp;
use Exporter;
our(@ISA, @EXPORT, $VERSION);
@ISA = 'Exporter';
@EXPORT = '&Mksymlists';
! $VERSION = substr q$Revision: 1.17 $, 10;
sub Mksymlists {
my(%spec) = @_;
--- 6,16 ----
use Carp;
use Exporter;
+ use Config;
our(@ISA, @EXPORT, $VERSION);
@ISA = 'Exporter';
@EXPORT = '&Mksymlists';
! $VERSION = substr q$Revision: 1.18 $, 10;
sub Mksymlists {
my(%spec) = @_;
***************
*** 86,91 ****
--- 87,94 ----
$distname = 'perl5-porters@perl.org';
$comment = "Core $comment";
}
+ $comment = "$comment (Perl-config: $Config{config_args})";
+ $comment = substr($comment, 0, 200) . "...)" if length $comment > 203;
rename "$data->{FILE}.def", "$data->{FILE}_def.old";
open(DEF,">$data->{FILE}.def")
diff -c 'perl-5.7.1/lib/ExtUtils/Packlist.pm' 'perl-5.7.2/lib/ExtUtils/Packlist.pm'
Index: ./lib/ExtUtils/Packlist.pm
*** ./lib/ExtUtils/Packlist.pm Fri Mar 16 04:54:49 2001
--- ./lib/ExtUtils/Packlist.pm Mon Jul 9 17:10:31 2001
***************
*** 3,9 ****
use 5.005_64;
use strict;
use Carp qw();
! our $VERSION = '0.03';
# Used for generating filehandle globs. IO::File might not be available!
my $fhname = "FH1";
--- 3,9 ----
use 5.005_64;
use strict;
use Carp qw();
! our $VERSION = '0.04';
# Used for generating filehandle globs. IO::File might not be available!
my $fhname = "FH1";
diff -c 'perl-5.7.1/lib/ExtUtils/typemap' 'perl-5.7.2/lib/ExtUtils/typemap'
Index: ./lib/ExtUtils/typemap
*** ./lib/ExtUtils/typemap Thu Apr 5 06:53:51 2001
--- ./lib/ExtUtils/typemap Mon Jul 9 17:10:33 2001
***************
*** 19,25 ****
ssize_t T_IV
time_t T_NV
unsigned long * T_OPAQUEPTR
! char ** T_PACKED
void * T_PTR
Time_t * T_PV
SV * T_SV
--- 19,25 ----
ssize_t T_IV
time_t T_NV
unsigned long * T_OPAQUEPTR
! char ** T_PACKEDARRAY
void * T_PTR
Time_t * T_PV
SV * T_SV
***************
*** 120,126 ****
else
Perl_croak(aTHX_ \"$var is not a reference\")
T_REF_IV_REF
! if (sv_isa($arg, \"${type}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = *INT2PTR($type *, tmp);
}
--- 120,126 ----
else
Perl_croak(aTHX_ \"$var is not a reference\")
T_REF_IV_REF
! if (sv_isa($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = *INT2PTR($type *, tmp);
}
***************
*** 163,169 ****
else
Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
T_OPAQUE
! $var NOT IMPLEMENTED
T_OPAQUEPTR
$var = ($type)SvPV($arg,PL_na)
T_PACKED
--- 163,169 ----
else
Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
T_OPAQUE
! $var = *($type *)SvPV($arg,PL_na)
T_OPAQUEPTR
$var = ($type)SvPV($arg,PL_na)
T_PACKED
diff -c 'perl-5.7.1/lib/ExtUtils/xsubpp' 'perl-5.7.2/lib/ExtUtils/xsubpp'
Index: ./lib/ExtUtils/xsubpp
*** ./lib/ExtUtils/xsubpp Sun Apr 8 21:14:00 2001
--- ./lib/ExtUtils/xsubpp Mon Jul 9 17:10:33 2001
***************
*** 1220,1225 ****
--- 1220,1234 ----
# Perl_croak(aTHX_ "Usage: $pname($report_args)");
EOF
+ #gcc -Wall: if an xsub has no arguments and PPCODE is used
+ #it is likely none of ST, XSRETURN or XSprePUSH macros are used
+ #hence `ax' (setup by dXSARGS) is unused
+ #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
+ #but such a move could break third-party extensions
+ print Q<<"EOF" if $PPCODE and $num_args == 0;
+ # PERL_UNUSED_VAR(ax); /* -Wall */
+ EOF
+
print Q<<"EOF" if $PPCODE;
# SP -= items;
EOF
***************
*** 1510,1518 ****
print Q<<"EOF";
#[[
# dXSARGS;
# char* file = __FILE__;
- #
EOF
print Q<<"EOF" if $WantVersionChk ;
# XS_VERSION_BOOTCHECK ;
--- 1519,1533 ----
print Q<<"EOF";
#[[
# dXSARGS;
+ EOF
+
+ #-Wall: if there is no $Full_func_name there are no xsubs in this .xs
+ #so `file' is unused
+ print Q<<"EOF" if $Full_func_name;
# char* file = __FILE__;
EOF
+
+ print Q "#\n";
print Q<<"EOF" if $WantVersionChk ;
# XS_VERSION_BOOTCHECK ;
diff -c /dev/null 'perl-5.7.2/lib/Fatal.t'
Index: ./lib/Fatal.t
*** ./lib/Fatal.t Thu Jan 1 02:00:00 1970
--- ./lib/Fatal.t Mon Jul 9 17:10:34 2001
***************
*** 0 ****
--- 1,36 ----
+ #!./perl -w
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ print "1..15\n";
+ }
+
+ use strict;
+ use Fatal qw(open close :void opendir);
+
+ my $i = 1;
+ eval { open FOO, '<lkjqweriuapofukndajsdlfjnvcvn' };
+ print "not " unless $@ =~ /^Can't open/;
+ print "ok $i\n"; ++$i;
+
+ my $foo = 'FOO';
+ for ('$foo', "'$foo'", "*$foo", "\\*$foo") {
+ eval qq{ open $_, '<$0' };
+ print "not " if $@;
+ print "ok $i\n"; ++$i;
+
+ print "not " if $@ or scalar(<$foo>) !~ m|^#!./perl|;
+ print "ok $i\n"; ++$i;
+ eval qq{ close FOO };
+ print "not " if $@;
+ print "ok $i\n"; ++$i;
+ }
+
+ eval { opendir FOO, 'lkjqweriuapofukndajsdlfjnvcvn' };
+ print "not " unless $@ =~ /^Can't open/;
+ print "ok $i\n"; ++$i;
+
+ eval { my $a = opendir FOO, 'lkjqweriuapofukndajsdlfjnvcvn' };
+ print "not " if $@ =~ /^Can't open/;
+ print "ok $i\n"; ++$i;
diff -c 'perl-5.7.1/lib/File/Basename.pm' 'perl-5.7.2/lib/File/Basename.pm'
Index: ./lib/File/Basename.pm
*** ./lib/File/Basename.pm Thu Mar 29 04:26:31 2001
--- ./lib/File/Basename.pm Mon Jul 9 17:10:34 2001
***************
*** 95,101 ****
$dir eq 'Doc_Root:[Help]'
$type eq '.Rnh'
! =over 4
=item C<basename>
--- 95,101 ----
$dir eq 'Doc_Root:[Help]'
$type eq '.Rnh'
! =over
=item C<basename>
***************
*** 141,147 ****
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
! $VERSION = "2.6";
# fileparse_set_fstype() - specify OS-based rules used in future
--- 141,147 ----
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
! $VERSION = "2.7";
# fileparse_set_fstype() - specify OS-based rules used in future
***************
*** 183,188 ****
--- 183,189 ----
}
elsif ($fstype =~ /^MacOS/si) {
($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s);
+ $dirpath = ':' unless $dirpath;
}
elsif ($fstype =~ /^AmigaOS/i) {
($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s);
***************
*** 213,220 ****
}
$tail .= $taint if defined $tail; # avoid warning if $tail == undef
! wantarray ? ($basename . $taint, $dirpath . $taint, $tail)
! : $basename . $taint;
}
--- 214,221 ----
}
$tail .= $taint if defined $tail; # avoid warning if $tail == undef
! wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail)
! : $basename .= $taint;
}
diff -c /dev/null 'perl-5.7.2/lib/File/Basename.t'
Index: ./lib/File/Basename.t
*** ./lib/File/Basename.t Thu Jan 1 02:00:00 1970
--- ./lib/File/Basename.t Mon Jul 9 17:10:34 2001
***************
*** 0 ****
--- 1,144 ----
+ #!./perl -T
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use File::Basename qw(fileparse basename dirname);
+
+ print "1..41\n";
+
+ # import correctly?
+ print +(defined(&basename) && !defined(&fileparse_set_fstype) ?
+ '' : 'not '),"ok 1\n";
+
+ # set fstype -- should replace non-null default
+ print +(length(File::Basename::fileparse_set_fstype('unix')) ?
+ '' : 'not '),"ok 2\n";
+
+ # Unix syntax tests
+ ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7','\.book\d+');
+ if ($base eq 'draft' and $path eq '/virgil/aeneid/' and $type eq '.book7') {
+ print "ok 3\n";
+ }
+ else {
+ print "not ok 3 |$base|$path|$type|\n";
+ }
+ print +(basename('/arma/virumque.cano') eq 'virumque.cano' ?
+ '' : 'not '),"ok 4\n";
+ print +(dirname('/arma/virumque.cano') eq '/arma' ? '' : 'not '),"ok 5\n";
+ print +(dirname('arma/') eq '.' ? '' : 'not '),"ok 6\n";
+ print +(dirname('/') eq '/' ? '' : 'not '),"ok 7\n";
+
+
+ # set fstype -- should replace non-null default
+ print +(File::Basename::fileparse_set_fstype('VMS') eq 'unix' ?
+ '' : 'not '),"ok 8\n";
+
+ # VMS syntax tests
+ ($base,$path,$type) = fileparse('virgil:[aeneid]draft.book7','\.book\d+');
+ if ($base eq 'draft' and $path eq 'virgil:[aeneid]' and $type eq '.book7') {
+ print "ok 9\n";
+ }
+ else {
+ print "not ok 9 |$base|$path|$type|\n";
+ }
+ print +(basename('arma:[virumque]cano.trojae') eq 'cano.trojae' ?
+ '' : 'not '),"ok 10\n";
+ print +(dirname('arma:[virumque]cano.trojae') eq 'arma:[virumque]' ?
+ '' : 'not '),"ok 11\n";
+ print +(dirname('arma:<virumque>cano.trojae') eq 'arma:<virumque>' ?
+ '' : 'not '),"ok 12\n";
+ print +(dirname('arma:virumque.cano') eq 'arma:' ? '' : 'not '),"ok 13\n";
+ $ENV{DEFAULT} = '' unless exists $ENV{DEFAULT};
+ print +(dirname('virumque.cano') eq $ENV{DEFAULT} ? '' : 'not '),"ok 14\n";
+ print +(dirname('arma/') eq '.' ? '' : 'not '),"ok 15\n";
+
+ # set fstype -- should replace non-null default
+ print +(File::Basename::fileparse_set_fstype('MSDOS') eq 'VMS' ?
+ '' : 'not '),"ok 16\n";
+
+ # MSDOS syntax tests
+ ($base,$path,$type) = fileparse('C:\\virgil\\aeneid\\draft.book7','\.book\d+');
+ if ($base eq 'draft' and $path eq 'C:\\virgil\\aeneid\\' and $type eq '.book7') {
+ print "ok 17\n";
+ }
+ else {
+ print "not ok 17 |$base|$path|$type|\n";
+ }
+ print +(basename('A:virumque\\cano.trojae') eq 'cano.trojae' ?
+ '' : 'not '),"ok 18\n";
+ print +(dirname('A:\\virumque\\cano.trojae') eq 'A:\\virumque' ?
+ '' : 'not '),"ok 19\n";
+ print +(dirname('A:\\') eq 'A:\\' ? '' : 'not '),"ok 20\n";
+ print +(dirname('arma\\') eq '.' ? '' : 'not '),"ok 21\n";
+
+ # Yes "/" is a legal path separator under MSDOS
+ basename("lib/File/Basename.pm") eq "Basename.pm" or print "not ";
+ print "ok 22\n";
+
+
+
+ # set fstype -- should replace non-null default
+ print +(File::Basename::fileparse_set_fstype('MacOS') eq 'MSDOS' ?
+ '' : 'not '),"ok 23\n";
+
+ # MacOS syntax tests
+ ($base,$path,$type) = fileparse('virgil:aeneid:draft.book7','\.book\d+');
+ if ($base eq 'draft' and $path eq 'virgil:aeneid:' and $type eq '.book7') {
+ print "ok 24\n";
+ }
+ else {
+ print "not ok 24 |$base|$path|$type|\n";
+ }
+ print +(basename(':arma:virumque:cano.trojae') eq 'cano.trojae' ?
+ '' : 'not '),"ok 25\n";
+ print +(dirname(':arma:virumque:cano.trojae') eq ':arma:virumque:' ?
+ '' : 'not '),"ok 26\n";
+ print +(dirname(':arma:virumque:') eq ':arma:' ? '' : 'not '),"ok 27\n";
+ print +(dirname(':arma:virumque') eq ':arma:' ? '' : 'not '),"ok 28\n";
+ print +(dirname(':arma:') eq ':' ? '' : 'not '),"ok 29\n";
+ print +(dirname(':arma') eq ':' ? '' : 'not '),"ok 30\n";
+ print +(dirname('arma:') eq 'arma:' ? '' : 'not '),"ok 31\n";
+ print +(dirname('arma') eq ':' ? '' : 'not '),"ok 32\n";
+ print +(dirname(':') eq ':' ? '' : 'not '),"ok 33\n";
+
+
+ # Check quoting of metacharacters in suffix arg by basename()
+ print +(basename(':arma:virumque:cano.trojae','.trojae') eq 'cano' ?
+ '' : 'not '),"ok 34\n";
+ print +(basename(':arma:virumque:cano_trojae','.trojae') eq 'cano_trojae' ?
+ '' : 'not '),"ok 35\n";
+
+ # extra tests for a few specific bugs
+
+ File::Basename::fileparse_set_fstype 'MSDOS';
+ # perl5.003_18 gives C:/perl/.\
+ print +((fileparse 'C:/perl/lib')[1] eq 'C:/perl/' ? '' : 'not '), "ok 36\n";
+ # perl5.003_18 gives C:\perl\
+ print +(dirname('C:\\perl\\lib\\') eq 'C:\\perl' ? '' : 'not '), "ok 37\n";
+
+ File::Basename::fileparse_set_fstype 'UNIX';
+ # perl5.003_18 gives '.'
+ print +(dirname('/perl/') eq '/' ? '' : 'not '), "ok 38\n";
+ # perl5.003_18 gives '/perl/lib'
+ print +(dirname('/perl/lib//') eq '/perl' ? '' : 'not '), "ok 39\n";
+
+ # The empty tainted value, for tainting strings
+ my $TAINT = substr($^X, 0, 0);
+ # How to identify taint when you see it
+ sub any_tainted (@) {
+ not eval { join("",@_), kill 0; 1 };
+ }
+ sub tainted ($) {
+ any_tainted @_;
+ }
+ sub all_tainted (@) {
+ for (@_) { return 0 unless tainted $_ }
+ 1;
+ }
+
+ print +(tainted(dirname($TAINT.'/perl/lib//')) ? '' : 'not '), "ok 40\n";
+ print +(all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+'))
+ ? '' : 'not '), "ok 41\n";
diff -c /dev/null 'perl-5.7.2/lib/File/CheckTree.t'
Index: ./lib/File/CheckTree.t
*** ./lib/File/CheckTree.t Thu Jan 1 02:00:00 1970
--- ./lib/File/CheckTree.t Mon Jul 9 17:10:34 2001
***************
*** 0 ****
--- 1,19 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ print "1..1\n";
+
+ use File::CheckTree;
+
+ # We assume that we run from the perl "t" directory.
+
+ validate q{
+ lib -d || die
+ TEST -f || die
+ };
+
+ print "ok 1\n";
diff -c 'perl-5.7.1/lib/File/Compare.pm' 'perl-5.7.2/lib/File/Compare.pm'
Index: ./lib/File/Compare.pm
*** ./lib/File/Compare.pm Thu Mar 29 04:26:31 2001
--- ./lib/File/Compare.pm Mon Jul 9 17:10:34 2001
***************
*** 8,14 ****
require Exporter;
use Carp;
! $VERSION = '1.1002';
@ISA = qw(Exporter);
@EXPORT = qw(compare);
@EXPORT_OK = qw(cmp compare_text);
--- 8,14 ----
require Exporter;
use Carp;
! $VERSION = '1.1003';
@ISA = qw(Exporter);
@EXPORT = qw(compare);
@EXPORT_OK = qw(cmp compare_text);
diff -c /dev/null 'perl-5.7.2/lib/File/Compare.t'
Index: ./lib/File/Compare.t
*** ./lib/File/Compare.t Thu Jan 1 02:00:00 1970
--- ./lib/File/Compare.t Mon Jul 9 17:10:34 2001
***************
*** 0 ****
--- 1,114 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ BEGIN {
+ our @TEST = stat "TEST";
+ our @README = stat "README";
+ unless (@TEST && @README) {
+ print "1..0 # Skip: no file TEST or README\n";
+ exit 0;
+ }
+ }
+
+ print "1..12\n";
+
+ use File::Compare qw(compare compare_text);
+
+ print "ok 1\n";
+
+ # named files, same, existing but different, cause an error
+ print "not " unless compare("README","README") == 0;
+ print "ok 2\n";
+
+ print "not " unless compare("TEST","README") == 1;
+ print "ok 3\n";
+
+ print "not " unless compare("README","HLAGHLAG") == -1;
+ # a file which doesn't exist
+ print "ok 4\n";
+
+ # compare_text, the same file, different but existing files
+ # cause error, test sub form.
+ print "not " unless compare_text("README","README") == 0;
+ print "ok 5\n";
+
+ print "not " unless compare_text("TEST","README") == 1;
+ print "ok 6\n";
+
+ print "not " unless compare_text("TEST","HLAGHLAG") == -1;
+ print "ok 7\n";
+
+ print "not " unless
+ compare_text("README","README",sub {$_[0] ne $_[1]}) == 0;
+ print "ok 8\n";
+
+ # filehandle and same file
+ {
+ my $fh;
+ open ($fh, "<README") or print "not ";
+ binmode($fh);
+ print "not " unless compare($fh,"README") == 0;
+ print "ok 9\n";
+ close $fh;
+ }
+
+ # filehandle and different (but existing) file.
+ {
+ my $fh;
+ open ($fh, "<README") or print "not ";
+ binmode($fh);
+ print "not " unless compare_text($fh,"TEST") == 1;
+ print "ok 10\n";
+ close $fh;
+ }
+
+ # Different file with contents of known file,
+ # will use File::Temp to do this, skip rest of
+ # tests if this doesn't seem to work
+
+ my @donetests;
+ eval {
+ require File::Spec; import File::Spec;
+ require File::Path; import File::Path;
+ require File::Temp; import File::Temp qw/ :mktemp unlink0 /;
+
+ my $template = File::Spec->catfile(File::Spec->tmpdir, 'fcmpXXXX');
+ my($tfh,$filename) = mkstemp($template);
+ {
+ local $/; #slurp
+ my $fh;
+ open($fh,'README');
+ binmode($fh);
+ my $data = <$fh>;
+ print $tfh $data;
+ close($fh);
+ }
+ seek($tfh,0,0);
+ $donetests[0] = compare($tfh, 'README');
+ $donetests[1] = compare($filename, 'README');
+ unlink0($tfh,$filename);
+ };
+ print "# problems when testing with a tempory file\n" if $@;
+
+ if (@donetests == 2) {
+ print "not " unless $donetests[0] == 0;
+ print "ok 11\n";
+ if ($^O eq 'VMS') {
+ # The open attempt on FROM in File::Compare::compare should fail
+ # on this OS since files are not shared by default.
+ print "not " unless $donetests[1] == -1;
+ print "ok 12\n";
+ }
+ else {
+ print "not " unless $donetests[1] == 0;
+ print "ok 12\n";
+ }
+ }
+ else {
+ print "ok 11# Skip\nok 12 # Skip Likely due to File::Temp\n";
+ }
+
diff -c 'perl-5.7.1/lib/File/Copy.pm' 'perl-5.7.2/lib/File/Copy.pm'
Index: ./lib/File/Copy.pm
*** ./lib/File/Copy.pm Thu Mar 29 04:26:31 2001
--- ./lib/File/Copy.pm Fri Jul 13 02:59:48 2001
***************
*** 11,16 ****
--- 11,17 ----
use strict;
use warnings;
use Carp;
+ use File::Spec;
our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
sub copy;
sub syscopy;
***************
*** 22,28 ****
# package has not yet been updated to work with Perl 5.004, and so it
# would be a Bad Thing for the CPAN module to grab it and replace this
# module. Therefore, we set this module's version higher than 2.0.
! $VERSION = '2.03';
require Exporter;
@ISA = qw(Exporter);
--- 23,29 ----
# package has not yet been updated to work with Perl 5.004, and so it
# would be a Bad Thing for the CPAN module to grab it and replace this
# module. Therefore, we set this module's version higher than 2.0.
! $VERSION = '2.04';
require Exporter;
@ISA = qw(Exporter);
***************
*** 31,46 ****
$Too_Big = 1024 * 1024 * 2;
! sub _catname { # Will be replaced by File::Spec when it arrives
my($from, $to) = @_;
if (not defined &basename) {
require File::Basename;
import File::Basename 'basename';
}
! if ($^O eq 'VMS') { $to = VMS::Filespec::vmspath($to) . basename($from); }
! elsif ($^O eq 'MacOS') { $to =~ s/^([^:]+)$/:$1/; $to .= ':' . basename($from); }
! elsif ($to =~ m|\\|) { $to .= '\\' . basename($from); }
! else { $to .= '/' . basename($from); }
}
sub copy {
--- 32,50 ----
$Too_Big = 1024 * 1024 * 2;
! sub _catname {
my($from, $to) = @_;
if (not defined &basename) {
require File::Basename;
import File::Basename 'basename';
}
!
! if ($^O eq 'MacOS') {
! # a partial dir name that's valid only in the cwd (e.g. 'tmp')
! $to = ':' . $to if $to !~ /:/;
! }
!
! return File::Spec->catfile($to, basename($from));
}
sub copy {
***************
*** 71,76 ****
--- 75,81 ----
&& !($from_a_handle && $^O eq 'mpeix') # and neither can MPE/iX.
&& !($from_a_handle && $^O eq 'MSWin32')
&& !($from_a_handle && $^O eq 'MacOS')
+ && !($from_a_handle && $^O eq 'NetWare')
)
{
return syscopy($from, $to);
***************
*** 79,102 ****
my $closefrom = 0;
my $closeto = 0;
my ($size, $status, $r, $buf);
- local(*FROM, *TO);
local($\) = '';
if ($from_a_handle) {
! *FROM = *$from{FILEHANDLE};
} else {
$from = _protect($from) if $from =~ /^\s/s;
! open(FROM, "< $from\0") or goto fail_open1;
! binmode FROM or die "($!,$^E)";
$closefrom = 1;
}
if ($to_a_handle) {
! *TO = *$to{FILEHANDLE};
} else {
$to = _protect($to) if $to =~ /^\s/s;
! open(TO,"> $to\0") or goto fail_open2;
! binmode TO or die "($!,$^E)";
$closeto = 1;
}
--- 84,110 ----
my $closefrom = 0;
my $closeto = 0;
my ($size, $status, $r, $buf);
local($\) = '';
+ my $from_h;
if ($from_a_handle) {
! $from_h = $from;
} else {
$from = _protect($from) if $from =~ /^\s/s;
! $from_h = \do { local *FH };
! open($from_h, "< $from\0") or goto fail_open1;
! binmode $from_h or die "($!,$^E)";
$closefrom = 1;
}
+ my $to_h;
if ($to_a_handle) {
! $to_h = $to;
} else {
$to = _protect($to) if $to =~ /^\s/s;
! $to_h = \do { local *FH };
! open($to_h,"> $to\0") or goto fail_open2;
! binmode $to_h or die "($!,$^E)";
$closeto = 1;
}
***************
*** 104,110 ****
$size = shift(@_) + 0;
croak("Bad buffer size for copy: $size\n") unless ($size > 0);
} else {
! $size = -s FROM;
$size = 1024 if ($size < 512);
$size = $Too_Big if ($size > $Too_Big);
}
--- 112,119 ----
$size = shift(@_) + 0;
croak("Bad buffer size for copy: $size\n") unless ($size > 0);
} else {
! no warnings 'uninitialized';
! $size = -s $from_h;
$size = 1024 if ($size < 512);
$size = $Too_Big if ($size > $Too_Big);
}
***************
*** 112,128 ****
$! = 0;
for (;;) {
my ($r, $w, $t);
! defined($r = sysread(FROM, $buf, $size))
or goto fail_inner;
last unless $r;
for ($w = 0; $w < $r; $w += $t) {
! $t = syswrite(TO, $buf, $r - $w, $w)
or goto fail_inner;
}
}
! close(TO) || goto fail_open2 if $closeto;
! close(FROM) || goto fail_open1 if $closefrom;
# Use this idiom to avoid uninitialized value warning.
return 1;
--- 121,137 ----
$! = 0;
for (;;) {
my ($r, $w, $t);
! defined($r = sysread($from_h, $buf, $size))
or goto fail_inner;
last unless $r;
for ($w = 0; $w < $r; $w += $t) {
! $t = syswrite($to_h, $buf, $r - $w, $w)
or goto fail_inner;
}
}
! close($to_h) || goto fail_open2 if $closeto;
! close($from_h) || goto fail_open1 if $closefrom;
# Use this idiom to avoid uninitialized value warning.
return 1;
***************
*** 132,138 ****
if ($closeto) {
$status = $!;
$! = 0;
! close TO;
$! = $status unless $!;
}
fail_open2:
--- 141,147 ----
if ($closeto) {
$status = $!;
$! = 0;
! close $to_h;
$! = $status unless $!;
}
fail_open2:
***************
*** 139,145 ****
if ($closefrom) {
$status = $!;
$! = 0;
! close FROM;
$! = $status unless $!;
}
fail_open1:
--- 148,154 ----
if ($closefrom) {
$status = $!;
$! = 0;
! close $from_h;
$! = $status unless $!;
}
fail_open1:
***************
*** 369,374 ****
--- 378,411 ----
All functions return 1 on success, 0 on failure.
$! will be set if an error was encountered.
+
+ =head1 NOTES
+
+ =over 4
+
+ =item *
+
+ On Mac OS (Classic), the path separator is ':', not '/', and the
+ current directory is denoted as ':', not '.'. You 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.
+
+ E.g.
+
+ copy("file1", "tmp"); # creates the file 'tmp' in the current directory
+ copy("file1", ":tmp:"); # creates :tmp:file1
+ copy("file1", ":tmp"); # same as above
+ copy("file1", "tmp"); # same as above, if 'tmp' is a directory (but don't do
+ # that, since it may cause confusion, see example #1)
+ copy("file1", "tmp:file1"); # error, since 'tmp:' is not a volume
+ copy("file1", ":tmp:file1"); # ok, partial path
+ copy("file1", "DataHD:"); # creates DataHD:file1
+
+ move("MacintoshHD:fileA", "DataHD:fileB"); # moves (don't copies) files from one
+ # volume to another
+
+ =back
=head1 AUTHOR
diff -c /dev/null 'perl-5.7.2/lib/File/Copy.t'
Index: ./lib/File/Copy.t
*** ./lib/File/Copy.t Thu Jan 1 02:00:00 1970
--- ./lib/File/Copy.t Fri Jul 13 03:03:17 2001
***************
*** 0 ****
--- 1,147 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ push @INC, "::lib:$MacPerl::Architecture" if $^O eq 'MacOS';
+ }
+
+ $| = 1;
+
+ my @pass = (0,1);
+ my $tests = $^O eq 'MacOS' ? 14 : 11;
+ printf "1..%d\n", $tests * scalar(@pass);
+
+ use File::Copy;
+
+ for my $pass (@pass) {
+
+ my $loopconst = $pass*$tests;
+
+ # First we create a file
+ open(F, ">file-$$") or die;
+ binmode F; # for DOSISH platforms, because test 3 copies to stdout
+ printf F "ok %d\n", 3 + $loopconst;
+ close F;
+
+ copy "file-$$", "copy-$$";
+
+ open(F, "copy-$$") or die;
+ $foo = <F>;
+ close(F);
+
+ print "not " if -s "file-$$" != -s "copy-$$";
+ printf "ok %d\n", 1 + $loopconst;
+
+ print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst;
+ printf "ok %d\n", 2+$loopconst;
+
+ binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode
+ copy "copy-$$", \*STDOUT;
+ unlink "copy-$$" or die "unlink: $!";
+
+ open(F,"file-$$");
+ copy(*F, "copy-$$");
+ open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R);
+ print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst;
+ printf "ok %d\n", 4+$loopconst;
+ unlink "copy-$$" or die "unlink: $!";
+ open(F,"file-$$");
+ copy(\*F, "copy-$$");
+ close(F) or die "close: $!";
+ open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!";
+ print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst;
+ printf "ok %d\n", 5+$loopconst;
+ unlink "copy-$$" or die "unlink: $!";
+
+ require IO::File;
+ $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!";
+ binmode $fh or die;
+ copy("file-$$",$fh);
+ $fh->close or die "close: $!";
+ open(R, "copy-$$") or die; $foo = <R>; close(R);
+ print "# foo=`$foo'\nnot " unless $foo eq sprintf "ok %d\n", 3+$loopconst;
+ printf "ok %d\n", 6+$loopconst;
+ unlink "copy-$$" or die "unlink: $!";
+ require FileHandle;
+ my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!";
+ binmode $fh or die;
+ copy("file-$$",$fh);
+ $fh->close;
+ open(R, "copy-$$") or die; $foo = <R>; close(R);
+ print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst;
+ printf "ok %d\n", 7+$loopconst;
+ unlink "file-$$" or die "unlink: $!";
+
+ print "# moved missing file.\nnot " if move("file-$$", "copy-$$");
+ print "# target disappeared.\nnot " if not -e "copy-$$";
+ printf "ok %d\n", 8+$loopconst;
+
+ move "copy-$$", "file-$$" or print "# move did not succeed.\n";
+ print "# not moved: $!\nnot " unless -e "file-$$" and not -e "copy-$$";
+ open(R, "file-$$") or die; $foo = <R>; close(R);
+ print "# foo=`$foo'\nnot " unless $foo eq sprintf "ok %d\n", 3+$loopconst;
+ printf "ok %d\n", 9+$loopconst;
+
+ if ($^O eq 'MacOS') {
+
+ copy "file-$$", "lib";
+ open(R, ":lib:file-$$") or die; $foo = <R>; close(R);
+ print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst;
+ printf "ok %d\n", 10+$loopconst;
+ unlink ":lib:file-$$" or die "unlink: $!";
+
+ copy "file-$$", ":lib";
+ open(R, ":lib:file-$$") or die; $foo = <R>; close(R);
+ print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst;
+ printf "ok %d\n", 11+$loopconst;
+ unlink ":lib:file-$$" or die "unlink: $!";
+
+ copy "file-$$", ":lib:";
+ open(R, ":lib:file-$$") or die; $foo = <R>; close(R);
+ print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst;
+ printf "ok %d\n", 12+$loopconst;
+ unlink ":lib:file-$$" or die "unlink: $!";
+
+ unless (-e 'lib:') { # make sure there's no volume called 'lib'
+ undef $@;
+ eval { (copy "file-$$", "lib:") || die "'lib:' is not a volume name"; };
+ print "# Died: $@";
+ print "not " unless ( $@ =~ m|'lib:' is not a volume name| );
+ }
+ printf "ok %d\n", 13+$loopconst;
+
+ move "file-$$", ":lib:";
+ open(R, ":lib:file-$$") or die "open :lib:file-$$: $!"; $foo = <R>; close(R);
+ print "not " unless $foo eq sprintf("ok %d\n", 3+$loopconst)
+ and not -e "file-$$";;
+ printf "ok %d\n", 14+$loopconst;
+ unlink ":lib:file-$$" or die "unlink: $!";
+
+ } else {
+
+ copy "file-$$", "lib";
+ open(R, "lib/file-$$") or die; $foo = <R>; close(R);
+ print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst;
+ printf "ok %d\n", 10+$loopconst;
+ unlink "lib/file-$$" or die "unlink: $!";
+
+ move "file-$$", "lib";
+ open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R);
+ print "not " unless $foo eq sprintf("ok %d\n", 3+$loopconst)
+ and not -e "file-$$";;
+ printf "ok %d\n", 11+$loopconst;
+ unlink "lib/file-$$" or die "unlink: $!";
+
+ }
+ }
+
+
+ END {
+ 1 while unlink "file-$$";
+ if ($^O eq 'MacOS') {
+ 1 while unlink ":lib:file-$$";
+ } else {
+ 1 while unlink "lib/file-$$";
+ }
+ }
diff -c /dev/null 'perl-5.7.2/lib/File/DosGlob.t'
Index: ./lib/File/DosGlob.t
*** ./lib/File/DosGlob.t Thu Jan 1 02:00:00 1970
--- ./lib/File/DosGlob.t Mon Jul 9 17:10:34 2001
***************
*** 0 ****
--- 1,111 ----
+ #!./perl
+
+ #
+ # test glob() in File::DosGlob
+ #
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ print "1..10\n";
+
+ # override it in main::
+ use File::DosGlob 'glob';
+
+ # test if $_ takes as the default
+ $_ = "op/a*.t";
+ my @r = glob;
+ print "not " if $_ ne 'op/a*.t';
+ print "ok 1\n";
+ print "# |@r|\nnot " if @r < 9;
+ print "ok 2\n";
+
+ # check if <*/*> works
+ @r = <*/a*.t>;
+ # atleast {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t
+ print "not " if @r < 9;
+ print "ok 3\n";
+ my $r = scalar @r;
+
+ # check if scalar context works
+ @r = ();
+ while (defined($_ = <*/a*.t>)) {
+ print "# $_\n";
+ push @r, $_;
+ }
+ print "not " if @r != $r;
+ print "ok 4\n";
+
+ # check if list context works
+ @r = ();
+ for (<*/a*.t>) {
+ print "# $_\n";
+ push @r, $_;
+ }
+ print "not " if @r != $r;
+ print "ok 5\n";
+
+ # test if implicit assign to $_ in while() works
+ @r = ();
+ while (<*/a*.t>) {
+ print "# $_\n";
+ push @r, $_;
+ }
+ print "not " if @r != $r;
+ print "ok 6\n";
+
+ # test if explicit glob() gets assign magic too
+ my @s = ();
+ while (glob '*/a*.t') {
+ print "# $_\n";
+ push @s, $_;
+ }
+ print "not " if "@r" ne "@s";
+ print "ok 7\n";
+
+ # how about in a different package, like?
+ package Foo;
+ use File::DosGlob 'glob';
+ @s = ();
+ while (glob '*/a*.t') {
+ print "# $_\n";
+ push @s, $_;
+ }
+ print "not " if "@r" ne "@s";
+ print "ok 8\n";
+
+ # test if different glob ops maintain independent contexts
+ @s = ();
+ while (<*/a*.t>) {
+ my $i = 0;
+ print "# $_ <";
+ push @s, $_;
+ while (<*/b*.t>) {
+ print " $_";
+ $i++;
+ }
+ print " >\n";
+ }
+ print "not " if "@r" ne "@s";
+ print "ok 9\n";
+
+ # how about a global override, hm?
+ eval <<'EOT';
+ use File::DosGlob 'GLOBAL_glob';
+ package Bar;
+ @s = ();
+ while (<*/a*.t>) {
+ my $i = 0;
+ print "# $_ <";
+ push @s, $_;
+ while (glob '*/b*.t') {
+ print " $_";
+ $i++;
+ }
+ print " >\n";
+ }
+ print "not " if "@r" ne "@s";
+ print "ok 10\n";
+ EOT
diff -c 'perl-5.7.1/lib/File/Find.pm' 'perl-5.7.2/lib/File/Find.pm'
Index: ./lib/File/Find.pm
*** ./lib/File/Find.pm Thu Mar 29 04:26:31 2001
--- ./lib/File/Find.pm Mon Jul 9 17:10:34 2001
***************
*** 2,8 ****
use strict;
use warnings;
use 5.6.0;
! our $VERSION = '1.00';
require Exporter;
require Cwd;
--- 2,8 ----
use strict;
use warnings;
use 5.6.0;
! our $VERSION = '1.01';
require Exporter;
require Cwd;
***************
*** 47,65 ****
=item C<preprocess>
! The value should be a code reference. This code reference is used to
! preprocess a directory; it is called after readdir() but before the loop that
! calls the wanted() function. It is called with a list of strings and is
! expected to return a list of strings. The code can be used to sort the
! strings alphabetically, numerically, or to filter out directory entries based
! on their name alone.
=item C<postprocess>
! The value should be a code reference. It is invoked just before leaving the
! current directory. It is called in void context with no arguments. The name
! of the current directory is in $File::Find::dir. This hook is handy for
! summarizing a directory, such as calculating its disk usage.
=item C<follow>
--- 47,70 ----
=item C<preprocess>
! The value should be a code reference. This code reference is used to
! preprocess the current directory. The name of currently processed
! directory is in $File::Find::dir. Your preprocessing function is
! called after readdir() but before the loop that calls the wanted()
! function. It is called with a list of strings (actually file/directory
! names) and is expected to return a list of strings. The code can be
! used to sort the file/directory names alphabetically, numerically,
! or to filter out directory entries based on their name alone. When
! I<follow> or I<follow_fast> are in effect, C<preprocess> is a no-op.
=item C<postprocess>
! The value should be a code reference. It is invoked just before leaving
! the currently processed directory. It is called in void context with no
! arguments. The name of the current directory is in $File::Find::dir. This
! hook is handy for summarizing a directory, such as calculating its disk
! usage. When I<follow> or I<follow_fast> are in effect, C<postprocess> is a
! no-op.
=item C<follow>
***************
*** 101,109 ****
C<follow_skip==0> causes File::Find to die if any file is about to be
processed a second time.
C<follow_skip==2> causes File::Find to ignore any duplicate files and
! dirctories but to proceed normally otherwise.
=item C<no_chdir>
Does not C<chdir()> to each directory as it recurses. The wanted()
--- 106,121 ----
C<follow_skip==0> causes File::Find to die if any file is about to be
processed a second time.
C<follow_skip==2> causes File::Find to ignore any duplicate files and
! directories but to proceed normally otherwise.
+ =item C<dangling_symlinks>
+ If true and a code reference, will be called with the symbolic link
+ name and the directory it lives in as arguments. Otherwise, if true
+ and warnings are on, warning "symbolic_link_name is a dangling
+ symbolic link\n" will be issued. If false, the dangling symbolic link
+ will be silently ignored.
+
=item C<no_chdir>
Does not C<chdir()> to each directory as it recurses. The wanted()
***************
*** 114,122 ****
If find is used in taint-mode (-T command line switch or if EUID != UID
or if EGID != GID) then internally directory names have to be untainted
! before they can be cd'ed to. Therefore they are checked against a regular
! expression I<untaint_pattern>. Note that all names passed to the
! user's I<wanted()> function are still tainted.
=item C<untaint_pattern>
--- 126,135 ----
If find is used in taint-mode (-T command line switch or if EUID != UID
or if EGID != GID) then internally directory names have to be untainted
! before they can be chdir'ed to. Therefore they are checked against a regular
! expression I<untaint_pattern>. Note that all names passed to the user's
! I<wanted()> function are still tainted. If this option is used while
! not in taint-mode, C<untaint> is a no-op.
=item C<untaint_pattern>
***************
*** 126,133 ****
=item C<untaint_skip>
! If set, directories (subtrees) which fail the I<untaint_pattern>
! are skipped. The default is to 'die' in such a case.
=back
--- 139,146 ----
=item C<untaint_skip>
! If set, a directory which fails the I<untaint_pattern> is skipped,
! including all its sub-directories. The default is to 'die' in such a case.
=back
***************
*** 136,142 ****
current filename within that directory. C<$File::Find::name> contains
the complete pathname to the file. You are chdir()'d to
C<$File::Find::dir> when the function is called, unless C<no_chdir>
! was specified. When <follow> or <follow_fast> are in effect, there is
also a C<$File::Find::fullname>. The function may set
C<$File::Find::prune> to prune the tree unless C<bydepth> was
specified. Unless C<follow> or C<follow_fast> is specified, for
--- 149,155 ----
current filename within that directory. C<$File::Find::name> contains
the complete pathname to the file. You are chdir()'d to
C<$File::Find::dir> when the function is called, unless C<no_chdir>
! was specified. When C<follow> or C<follow_fast> are in effect, there is
also a C<$File::Find::fullname>. The function may set
C<$File::Find::prune> to prune the tree unless C<bydepth> was
specified. Unless C<follow> or C<follow_fast> is specified, for
***************
*** 187,193 ****
--- 200,286 ----
might cause very unpleasant surprises, since you delete or change files
in an unknown directory.
+ =head1 NOTES
+ =over 4
+
+ =item *
+
+ Mac OS (Classic) users should note a few differences:
+
+ =over 4
+
+ =item *
+
+ The path separator is ':', not '/', and the current directory is denoted
+ as ':', not '.'. You 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.
+
+ =item *
+
+ C<$File::Find::dir> is guaranteed to end with a ':'. If C<$_>
+ contains the name of a directory, that name may or may not end with a
+ ':'. Likewise, C<$File::Find::name>, which contains the complete
+ pathname to that directory, and C<$File::Find::fullname>, which holds
+ the absolute pathname of that directory with all symbolic links resolved,
+ may or may not end with a ':'.
+
+ =item *
+
+ The default C<untaint_pattern> (see above) on Mac OS is set to
+ C<qr|^(.+)$|>. Note that the parentheses are vital.
+
+ =item *
+
+ The invisible system file "Icon\015" is ignored. While this file may
+ appear in every directory, there are some more invisible system files
+ on every volume, which are all located at the volume root level (i.e.
+ "MacintoshHD:"). These system files are B<not> excluded automatically.
+ Your filter may use the following code to recognize invisible files or
+ directories (requires Mac::Files):
+
+ use Mac::Files;
+
+ # invisible() -- returns 1 if file/directory is invisible,
+ # 0 if it's visible or undef if an error occured
+
+ sub invisible($) {
+ my $file = shift;
+ my ($fileCat, $fileInfo);
+ my $invisible_flag = 1 << 14;
+
+ if ( $fileCat = FSpGetCatInfo($file) ) {
+ if ($fileInfo = $fileCat->ioFlFndrInfo() ) {
+ return (($fileInfo->fdFlags & $invisible_flag) && 1);
+ }
+ }
+ return undef;
+ }
+
+ Generally, invisible files are system files, unless an odd application
+ decides to use invisible files for its own purposes. To distinguish
+ such files from system files, you have to look at the B<type> and B<creator>
+ file attributes. The MacPerl built-in functions C<GetFileInfo(FILE)> and
+ C<SetFileInfo(CREATOR, TYPE, FILES)> offer access to these attributes
+ (see MacPerl.pm for details).
+
+ Files that appear on the desktop actually reside in an (hidden) directory
+ named "Desktop Folder" on the particular disk volume. Note that, although
+ all desktop files appear to be on the same "virtual" desktop, each disk
+ volume actually maintains its own "Desktop Folder" directory.
+
+ =back
+
+ =back
+
+ =head1 HISTORY
+
+ File::Find used to produce incorrect results if called recursively.
+ During the development of perl 5.8 this bug was fixed.
+ The first fixed version of File::Find was 1.01.
+
=cut
our @ISA = qw(Exporter);
***************
*** 196,213 ****
use strict;
my $Is_VMS;
require File::Basename;
! my %SLnkSeen;
! my ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
$follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat,
! $pre_process, $post_process);
sub contract_name {
my ($cdir,$fn) = @_;
! return substr($cdir,0,rindex($cdir,'/')) if $fn eq '.';
$cdir = substr($cdir,0,rindex($cdir,'/')+1);
--- 289,311 ----
use strict;
my $Is_VMS;
+ my $Is_MacOS;
require File::Basename;
+ require File::Spec;
! # Should ideally be my() not our() but local() currently
! # refuses to operate on lexicals
!
! our %SLnkSeen;
! our ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
$follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat,
! $pre_process, $post_process, $dangling_symlinks);
sub contract_name {
my ($cdir,$fn) = @_;
! return substr($cdir,0,rindex($cdir,'/')) if $fn eq $File::Find::current_dir;
$cdir = substr($cdir,0,rindex($cdir,'/')+1);
***************
*** 216,246 ****
my $abs_name= $cdir . $fn;
if (substr($fn,0,3) eq '../') {
! do 1 while ($abs_name=~ s|/(?>[^/]+)/\.\./|/|);
}
return $abs_name;
}
sub PathCombine($$) {
my ($Base,$Name) = @_;
my $AbsName;
! if (substr($Name,0,1) eq '/') {
! $AbsName= $Name;
}
else {
! $AbsName= contract_name($Base,$Name);
! }
! # (simple) check for recursion
! my $newlen= length($AbsName);
! if ($newlen <= length($Base)) {
! if (($newlen == length($Base) || substr($Base,$newlen,1) eq '/')
! && $AbsName eq substr($Base,0,$newlen))
! {
! return undef;
}
}
return $AbsName;
--- 314,402 ----
my $abs_name= $cdir . $fn;
if (substr($fn,0,3) eq '../') {
! 1 while $abs_name =~ s!/[^/]*/\.\./!/!;
}
return $abs_name;
}
+ # return the absolute name of a directory or file
+ sub contract_name_Mac {
+ my ($cdir,$fn) = @_;
+ my $abs_name;
+ if ($fn =~ /^(:+)(.*)$/) { # valid pathname starting with a ':'
+
+ my $colon_count = length ($1);
+ if ($colon_count == 1) {
+ $abs_name = $cdir . $2;
+ return $abs_name;
+ }
+ else {
+ # need to move up the tree, but
+ # only if it's not a volume name
+ for (my $i=1; $i<$colon_count; $i++) {
+ unless ($cdir =~ /^[^:]+:$/) { # volume name
+ $cdir =~ s/[^:]+:$//;
+ }
+ else {
+ return undef;
+ }
+ }
+ $abs_name = $cdir . $2;
+ return $abs_name;
+ }
+
+ }
+ else {
+
+ # $fn may be a valid path to a directory or file or (dangling)
+ # symlink, without a leading ':'
+ if ( (-e $fn) || (-l $fn) ) {
+ if ($fn =~ /^[^:]+:/) { # a volume name like DataHD:*
+ return $fn; # $fn is already an absolute path
+ }
+ else {
+ $abs_name = $cdir . $fn;
+ return $abs_name;
+ }
+ }
+ else { # argh!, $fn is not a valid directory/file
+ return undef;
+ }
+ }
+ }
+
sub PathCombine($$) {
my ($Base,$Name) = @_;
my $AbsName;
! if ($Is_MacOS) {
! # $Name is the resolved symlink (always a full path on MacOS),
! # i.e. there's no need to call contract_name_Mac()
! $AbsName = $Name;
!
! # (simple) check for recursion
! if ( ( $Base =~ /^$AbsName/) && (-d $AbsName) ) { # recursion
! return undef;
! }
}
else {
! if (substr($Name,0,1) eq '/') {
! $AbsName= $Name;
! }
! else {
! $AbsName= contract_name($Base,$Name);
! }
! # (simple) check for recursion
! my $newlen= length($AbsName);
! if ($newlen <= length($Base)) {
! if (($newlen == length($Base) || substr($Base,$newlen,1) eq '/')
! && $AbsName eq substr($Base,0,$newlen))
! {
! return undef;
! }
}
}
return $AbsName;
***************
*** 278,284 ****
}
if ($full_check && $SLnkSeen{$DEV, $INO}++) {
! if ($follow_skip < 1) {
die "$AbsName encountered a second time";
}
else {
--- 434,440 ----
}
if ($full_check && $SLnkSeen{$DEV, $INO}++) {
! if ( ($follow_skip < 1) || ((-d _) && ($follow_skip < 2)) ) {
die "$AbsName encountered a second time";
}
else {
***************
*** 293,404 ****
sub _find_dir_symlnk($$$);
sub _find_dir($$$);
sub _find_opt {
my $wanted = shift;
die "invalid top directory" unless defined $_[0];
! my $cwd = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::cwd();
! my $cwd_untainted = $cwd;
! $wanted_callback = $wanted->{wanted};
! $bydepth = $wanted->{bydepth};
! $pre_process = $wanted->{preprocess};
! $post_process = $wanted->{postprocess};
! $no_chdir = $wanted->{no_chdir};
! $full_check = $wanted->{follow};
! $follow = $full_check || $wanted->{follow_fast};
! $follow_skip = $wanted->{follow_skip};
! $untaint = $wanted->{untaint};
! $untaint_pat = $wanted->{untaint_pattern};
! $untaint_skip = $wanted->{untaint_skip};
# for compatability reasons (find.pl, find2perl)
! our ($topdir, $topdev, $topino, $topmode, $topnlink);
# a symbolic link to a directory doesn't increase the link count
$avoid_nlink = $follow || $File::Find::dont_use_nlink;
- if ( $untaint ) {
- $cwd_untainted= $1 if $cwd_untainted =~ m|$untaint_pat|;
- die "insecure cwd in find(depth)" unless defined($cwd_untainted);
- }
-
my ($abs_dir, $Is_Dir);
Proc_Top_Item:
foreach my $TOP (@_) {
! my $top_item = $TOP;
! $top_item =~ s|/\z|| unless $top_item eq '/';
! $Is_Dir= 0;
!
! ($topdev,$topino,$topmode,$topnlink) = stat $top_item;
! if ($follow) {
! if (substr($top_item,0,1) eq '/') {
! $abs_dir = $top_item;
! }
! elsif ($top_item eq '.') {
! $abs_dir = $cwd;
}
! else { # care about any ../
! $abs_dir = contract_name("$cwd/",$top_item);
! }
! $abs_dir= Follow_SymLink($abs_dir);
! unless (defined $abs_dir) {
! warn "$top_item is a dangling symbolic link\n";
next Proc_Top_Item;
! }
! if (-d _) {
_find_dir_symlnk($wanted, $abs_dir, $top_item);
$Is_Dir= 1;
! }
! }
else { # no follow
! $topdir = $top_item;
! unless (defined $topnlink) {
! warn "Can't stat $top_item: $!\n";
! next Proc_Top_Item;
! }
! if (-d _) {
$top_item =~ s/\.dir\z// if $Is_VMS;
_find_dir($wanted, $top_item, $topnlink);
$Is_Dir= 1;
! }
else {
$abs_dir= $top_item;
! }
! }
! unless ($Is_Dir) {
unless (($_,$dir) = File::Basename::fileparse($abs_dir)) {
! ($dir,$_) = ('./', $top_item);
}
! $abs_dir = $dir;
! if ($untaint) {
! my $abs_dir_save = $abs_dir;
! $abs_dir = $1 if $abs_dir =~ m|$untaint_pat|;
unless (defined $abs_dir) {
if ($untaint_skip == 0) {
! die "directory $abs_dir_save is still tainted";
}
else {
next Proc_Top_Item;
}
}
! }
! unless ($no_chdir or chdir $abs_dir) {
! warn "Couldn't chdir $abs_dir: $!\n";
! next Proc_Top_Item;
! }
! $name = $abs_dir . $_;
! { &$wanted_callback }; # protect against wild "next"
! }
! $no_chdir or chdir $cwd_untainted;
}
}
--- 449,624 ----
sub _find_dir_symlnk($$$);
sub _find_dir($$$);
+ # check whether or not a scalar variable is tainted
+ # (code straight from the Camel, 3rd ed., page 561)
+ sub is_tainted_pp {
+ my $arg = shift;
+ my $nada = substr($arg, 0, 0); # zero-length
+ local $@;
+ eval { eval "# $nada" };
+ return length($@) != 0;
+ }
+
sub _find_opt {
my $wanted = shift;
die "invalid top directory" unless defined $_[0];
! # This function must local()ize everything because callbacks may
! # call find() or finddepth()
+ local %SLnkSeen;
+ local ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
+ $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat,
+ $pre_process, $post_process, $dangling_symlinks);
+ local($dir, $name, $fullname, $prune);
+
+ my $cwd = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::cwd();
+ my $cwd_untainted = $cwd;
+ my $check_t_cwd = 1;
+ $wanted_callback = $wanted->{wanted};
+ $bydepth = $wanted->{bydepth};
+ $pre_process = $wanted->{preprocess};
+ $post_process = $wanted->{postprocess};
+ $no_chdir = $wanted->{no_chdir};
+ $full_check = $wanted->{follow};
+ $follow = $full_check || $wanted->{follow_fast};
+ $follow_skip = $wanted->{follow_skip};
+ $untaint = $wanted->{untaint};
+ $untaint_pat = $wanted->{untaint_pattern};
+ $untaint_skip = $wanted->{untaint_skip};
+ $dangling_symlinks = $wanted->{dangling_symlinks};
+
# for compatability reasons (find.pl, find2perl)
! local our ($topdir, $topdev, $topino, $topmode, $topnlink);
# a symbolic link to a directory doesn't increase the link count
$avoid_nlink = $follow || $File::Find::dont_use_nlink;
my ($abs_dir, $Is_Dir);
Proc_Top_Item:
foreach my $TOP (@_) {
! my $top_item = $TOP;
! if ($Is_MacOS) {
! ($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat $top_item;
! $top_item = ":$top_item"
! if ( (-d _) && ( $top_item !~ /:/ ) );
! }
! else {
! $top_item =~ s|/\z|| unless $top_item eq '/';
! ($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat $top_item;
! }
!
! $Is_Dir= 0;
!
! if ($follow) {
!
! if ($Is_MacOS) {
! $cwd = "$cwd:" unless ($cwd =~ /:$/); # for safety
!
! if ($top_item eq $File::Find::current_dir) {
! $abs_dir = $cwd;
! }
! else {
! $abs_dir = contract_name_Mac($cwd, $top_item);
! unless (defined $abs_dir) {
! warn "Can't determine absolute path for $top_item (No such file or directory)\n" if $^W;
! next Proc_Top_Item;
! }
! }
!
}
! else {
! if (substr($top_item,0,1) eq '/') {
! $abs_dir = $top_item;
! }
! elsif ($top_item eq $File::Find::current_dir) {
! $abs_dir = $cwd;
! }
! else { # care about any ../
! $abs_dir = contract_name("$cwd/",$top_item);
! }
! }
! $abs_dir= Follow_SymLink($abs_dir);
! unless (defined $abs_dir) {
! if ($dangling_symlinks) {
! if (ref $dangling_symlinks eq 'CODE') {
! $dangling_symlinks->($top_item, $cwd);
! } else {
! warn "$top_item is a dangling symbolic link\n" if $^W;
! }
! }
next Proc_Top_Item;
! }
!
! if (-d _) {
_find_dir_symlnk($wanted, $abs_dir, $top_item);
$Is_Dir= 1;
! }
! }
else { # no follow
! $topdir = $top_item;
! unless (defined $topnlink) {
! warn "Can't stat $top_item: $!\n" if $^W;
! next Proc_Top_Item;
! }
! if (-d _) {
$top_item =~ s/\.dir\z// if $Is_VMS;
_find_dir($wanted, $top_item, $topnlink);
$Is_Dir= 1;
! }
else {
$abs_dir= $top_item;
! }
! }
! unless ($Is_Dir) {
unless (($_,$dir) = File::Basename::fileparse($abs_dir)) {
! if ($Is_MacOS) {
! ($dir,$_) = (':', $top_item); # $File::Find::dir, $_
! }
! else {
! ($dir,$_) = ('./', $top_item);
! }
}
! $abs_dir = $dir;
! if (( $untaint ) && (is_tainted($dir) )) {
! ( $abs_dir ) = $dir =~ m|$untaint_pat|;
unless (defined $abs_dir) {
if ($untaint_skip == 0) {
! die "directory $dir is still tainted";
}
else {
next Proc_Top_Item;
}
}
! }
! unless ($no_chdir || chdir $abs_dir) {
! warn "Couldn't chdir $abs_dir: $!\n" if $^W;
! next Proc_Top_Item;
! }
! $name = $abs_dir . $_; # $File::Find::name
! { &$wanted_callback }; # protect against wild "next"
! }
! unless ( $no_chdir ) {
! if ( ($check_t_cwd) && (($untaint) && (is_tainted($cwd) )) ) {
! ( $cwd_untainted ) = $cwd =~ m|$untaint_pat|;
! unless (defined $cwd_untainted) {
! die "insecure cwd in find(depth)";
! }
! $check_t_cwd = 0;
! }
! unless (chdir $cwd_untainted) {
! die "Can't cd to $cwd: $!\n";
! }
! }
}
}
***************
*** 417,431 ****
my ($subcount,$sub_nlink);
my $SE= [];
my $dir_name= $p_dir;
! my $dir_pref= ( $p_dir eq '/' ? '/' : "$p_dir/" );
! my $dir_rel= '.'; # directory name relative to current directory
local ($dir, $name, $prune, *DIR);
!
! unless ($no_chdir or $p_dir eq '.') {
my $udir = $p_dir;
! if ($untaint) {
! $udir = $1 if $p_dir =~ m|$untaint_pat|;
unless (defined $udir) {
if ($untaint_skip == 0) {
die "directory $p_dir is still tainted";
--- 637,661 ----
my ($subcount,$sub_nlink);
my $SE= [];
my $dir_name= $p_dir;
! my $dir_pref;
! my $dir_rel;
! my $tainted = 0;
+ if ($Is_MacOS) {
+ $dir_pref= ($p_dir =~ /:$/) ? $p_dir : "$p_dir:"; # preface
+ $dir_rel= ':'; # directory name relative to current directory
+ }
+ else {
+ $dir_pref= ( $p_dir eq '/' ? '/' : "$p_dir/" );
+ $dir_rel= '.'; # directory name relative to current directory
+ }
+
local ($dir, $name, $prune, *DIR);
!
! unless ( $no_chdir || ($p_dir eq $File::Find::current_dir)) {
my $udir = $p_dir;
! if (( $untaint ) && (is_tainted($p_dir) )) {
! ( $udir ) = $p_dir =~ m|$untaint_pat|;
unless (defined $udir) {
if ($untaint_skip == 0) {
die "directory $p_dir is still tainted";
***************
*** 436,486 ****
}
}
unless (chdir $udir) {
! warn "Can't cd to $udir: $!\n";
return;
}
}
!
push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth;
while (defined $SE) {
unless ($bydepth) {
! $dir= $p_dir;
! $name= $dir_name;
! $_= ($no_chdir ? $dir_name : $dir_rel );
# prune may happen here
! $prune= 0;
! { &$wanted_callback }; # protect against wild "next"
! next if $prune;
}
!
# change to that directory
! unless ($no_chdir or $dir_rel eq '.') {
my $udir= $dir_rel;
! if ($untaint) {
! $udir = $1 if $dir_rel =~ m|$untaint_pat|;
unless (defined $udir) {
if ($untaint_skip == 0) {
! die "directory ("
! . ($p_dir ne '/' ? $p_dir : '')
! . "/) $dir_rel is still tainted";
}
}
}
unless (chdir $udir) {
! warn "Can't cd to ("
! . ($p_dir ne '/' ? $p_dir : '')
! . "/) $udir : $!\n";
next;
}
$CdLvl++;
}
! $dir= $dir_name;
# Get the list of files in the current directory.
! unless (opendir DIR, ($no_chdir ? $dir_name : '.')) {
! warn "Can't opendir($dir_name): $!\n";
next;
}
@filenames = readdir DIR;
--- 666,733 ----
}
}
unless (chdir $udir) {
! warn "Can't cd to $udir: $!\n" if $^W;
return;
}
}
!
! # push the starting directory
push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth;
+ if ($Is_MacOS) {
+ $p_dir = $dir_pref; # ensure trailing ':'
+ }
+
while (defined $SE) {
unless ($bydepth) {
! $dir= $p_dir; # $File::Find::dir
! $name= $dir_name; # $File::Find::name
! $_= ($no_chdir ? $dir_name : $dir_rel ); # $_
# prune may happen here
! $prune= 0;
! { &$wanted_callback }; # protect against wild "next"
! next if $prune;
}
!
# change to that directory
! unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) {
my $udir= $dir_rel;
! if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_rel) )) ) {
! ( $udir ) = $dir_rel =~ m|$untaint_pat|;
unless (defined $udir) {
if ($untaint_skip == 0) {
! if ($Is_MacOS) {
! die "directory ($p_dir) $dir_rel is still tainted";
! }
! else {
! die "directory (" . ($p_dir ne '/' ? $p_dir : '') . "/) $dir_rel is still tainted";
! }
! } else { # $untaint_skip == 1
! next;
}
}
}
unless (chdir $udir) {
! if ($Is_MacOS) {
! warn "Can't cd to ($p_dir) $udir: $!\n" if $^W;
! }
! else {
! warn "Can't cd to (" . ($p_dir ne '/' ? $p_dir : '') . "/) $udir: $!\n" if $^W;
! }
next;
}
$CdLvl++;
}
! if ($Is_MacOS) {
! $dir_name = "$dir_name:" unless ($dir_name =~ /:$/);
! }
+ $dir= $dir_name; # $File::Find::dir
+
# Get the list of files in the current directory.
! unless (opendir DIR, ($no_chdir ? $dir_name : $File::Find::current_dir)) {
! warn "Can't opendir($dir_name): $!\n" if $^W;
next;
}
@filenames = readdir DIR;
***************
*** 491,500 ****
if ($nlink == 2 && !$avoid_nlink) {
# This dir has no subdirectories.
for my $FN (@filenames) {
! next if $FN =~ /^\.{1,2}\z/;
! $name = $dir_pref . $FN;
! $_ = ($no_chdir ? $name : $FN);
{ &$wanted_callback }; # protect against wild "next"
}
--- 738,747 ----
if ($nlink == 2 && !$avoid_nlink) {
# This dir has no subdirectories.
for my $FN (@filenames) {
! next if $FN =~ $File::Find::skip_pattern;
! $name = $dir_pref . $FN; # $File::Find::name
! $_ = ($no_chdir ? $name : $FN); # $_
{ &$wanted_callback }; # protect against wild "next"
}
***************
*** 504,510 ****
$subcount = $nlink - 2;
for my $FN (@filenames) {
! next if $FN =~ /^\.{1,2}\z/;
if ($subcount > 0 || $avoid_nlink) {
# Seen all the subdirs?
# check for directoriness.
--- 751,757 ----
$subcount = $nlink - 2;
for my $FN (@filenames) {
! next if $FN =~ $File::Find::skip_pattern;
if ($subcount > 0 || $avoid_nlink) {
# Seen all the subdirs?
# check for directoriness.
***************
*** 517,530 ****
push @Stack,[$CdLvl,$dir_name,$FN,$sub_nlink];
}
else {
! $name = $dir_pref . $FN;
! $_= ($no_chdir ? $name : $FN);
{ &$wanted_callback }; # protect against wild "next"
}
}
else {
! $name = $dir_pref . $FN;
! $_= ($no_chdir ? $name : $FN);
{ &$wanted_callback }; # protect against wild "next"
}
}
--- 764,777 ----
push @Stack,[$CdLvl,$dir_name,$FN,$sub_nlink];
}
else {
! $name = $dir_pref . $FN; # $File::Find::name
! $_= ($no_chdir ? $name : $FN); # $_
{ &$wanted_callback }; # protect against wild "next"
}
}
else {
! $name = $dir_pref . $FN; # $File::Find::name
! $_= ($no_chdir ? $name : $FN); # $_
{ &$wanted_callback }; # protect against wild "next"
}
}
***************
*** 534,565 ****
while ( defined ($SE = pop @Stack) ) {
($Level, $p_dir, $dir_rel, $nlink) = @$SE;
if ($CdLvl > $Level && !$no_chdir) {
! my $tmp = join('/',('..') x ($CdLvl-$Level));
! die "Can't cd to $dir_name" . $tmp
! unless chdir ($tmp);
$CdLvl = $Level;
}
! $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
! $dir_pref = "$dir_name/";
if ( $nlink == -2 ) {
! $name = $dir = $p_dir;
! $_ = ".";
&$post_process; # End-of-directory processing
! } elsif ( $nlink < 0 ) { # must be finddepth, report dirname now
! $name = $dir_name;
! if ( substr($name,-2) eq '/.' ) {
! $name =~ s|/\.$||;
! }
! $dir = $p_dir;
! $_ = ($no_chdir ? $dir_name : $dir_rel );
! if ( substr($_,-2) eq '/.' ) {
! s|/\.$||;
! }
! { &$wanted_callback }; # protect against wild "next"
! } else {
! push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth;
! last;
! }
}
}
}
--- 781,845 ----
while ( defined ($SE = pop @Stack) ) {
($Level, $p_dir, $dir_rel, $nlink) = @$SE;
if ($CdLvl > $Level && !$no_chdir) {
! my $tmp;
! if ($Is_MacOS) {
! $tmp = (':' x ($CdLvl-$Level)) . ':';
! }
! else {
! $tmp = join('/',('..') x ($CdLvl-$Level));
! }
! die "Can't cd to $dir_name" . $tmp
! unless chdir ($tmp);
$CdLvl = $Level;
}
!
! if ($Is_MacOS) {
! # $pdir always has a trailing ':', except for the starting dir,
! # where $dir_rel eq ':'
! $dir_name = "$p_dir$dir_rel";
! $dir_pref = "$dir_name:";
! }
! else {
! $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
! $dir_pref = "$dir_name/";
! }
!
if ( $nlink == -2 ) {
! $name = $dir = $p_dir; # $File::Find::name / dir
! if ($Is_MacOS) {
! $_ = ':'; # $_
! }
! else {
! $_ = '.';
! }
&$post_process; # End-of-directory processing
! }
! elsif ( $nlink < 0 ) { # must be finddepth, report dirname now
! $name = $dir_name;
! if ($Is_MacOS) {
! if ($dir_rel eq ':') { # must be the top dir, where we started
! $name =~ s|:$||; # $File::Find::name
! $p_dir = "$p_dir:" unless ($p_dir =~ /:$/);
! }
! $dir = $p_dir; # $File::Find::dir
! $_ = ($no_chdir ? $name : $dir_rel); # $_
! }
! else {
! if ( substr($name,-2) eq '/.' ) {
! $name =~ s|/\.$||;
! }
! $dir = $p_dir;
! $_ = ($no_chdir ? $dir_name : $dir_rel );
! if ( substr($_,-2) eq '/.' ) {
! s|/\.$||;
! }
! }
! { &$wanted_callback }; # protect against wild "next"
! }
! else {
! push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth;
! last;
! }
}
}
}
***************
*** 573,597 ****
# chdir (if not no_chdir) to dir
sub _find_dir_symlnk($$$) {
! my ($wanted, $dir_loc, $p_dir) = @_;
my @Stack;
my @filenames;
my $new_loc;
! my $pdir_loc = $dir_loc;
my $SE = [];
my $dir_name = $p_dir;
! my $dir_pref = ( $p_dir eq '/' ? '/' : "$p_dir/" );
! my $loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" );
! my $dir_rel = '.'; # directory name relative to current directory
! my $byd_flag; # flag for pending stack entry if $bydepth
local ($dir, $name, $fullname, $prune, *DIR);
!
! unless ($no_chdir or $p_dir eq '.') {
! my $udir = $dir_loc;
! if ($untaint) {
! $udir = $1 if $dir_loc =~ m|$untaint_pat|;
! unless (defined $udir) {
if ($untaint_skip == 0) {
die "directory $dir_loc is still tainted";
}
--- 853,892 ----
# chdir (if not no_chdir) to dir
sub _find_dir_symlnk($$$) {
! my ($wanted, $dir_loc, $p_dir) = @_; # $dir_loc is the absolute directory
my @Stack;
my @filenames;
my $new_loc;
! my $updir_loc = $dir_loc; # untainted parent directory
my $SE = [];
my $dir_name = $p_dir;
! my $dir_pref;
! my $loc_pref;
! my $dir_rel;
! my $byd_flag; # flag for pending stack entry if $bydepth
! my $tainted = 0;
! my $ok = 1;
+ if ($Is_MacOS) {
+ $dir_pref = ($p_dir =~ /:$/) ? "$p_dir" : "$p_dir:";
+ $loc_pref = ($dir_loc =~ /:$/) ? "$dir_loc" : "$dir_loc:";
+ $dir_rel = ':'; # directory name relative to current directory
+ } else {
+ $dir_pref = ( $p_dir eq '/' ? '/' : "$p_dir/" );
+ $loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" );
+ $dir_rel = '.'; # directory name relative to current directory
+ }
+
local ($dir, $name, $fullname, $prune, *DIR);
!
! unless ($no_chdir) {
! # untaint the topdir
! if (( $untaint ) && (is_tainted($dir_loc) )) {
! ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|; # parent dir, now untainted
! # once untainted, $updir_loc is pushed on the stack (as parent directory);
! # hence, we don't need to untaint the parent directory every time we chdir
! # to it later
! unless (defined $updir_loc) {
if ($untaint_skip == 0) {
die "directory $dir_loc is still tainted";
}
***************
*** 600,644 ****
}
}
}
! unless (chdir $udir) {
! warn "Can't cd to $udir: $!\n";
return;
}
}
! push @Stack,[$dir_loc,$pdir_loc,$p_dir,$dir_rel,-1] if $bydepth;
while (defined $SE) {
unless ($bydepth) {
! # change to parent directory
unless ($no_chdir) {
! my $udir = $pdir_loc;
! if ($untaint) {
! $udir = $1 if $pdir_loc =~ m|$untaint_pat|;
! }
! unless (chdir $udir) {
! warn "Can't cd to $udir: $!\n";
next;
}
}
! $dir= $p_dir;
! $name= $dir_name;
! $_= ($no_chdir ? $dir_name : $dir_rel );
! $fullname= $dir_loc;
# prune may happen here
! $prune= 0;
lstat($_); # make sure file tests with '_' work
! { &$wanted_callback }; # protect against wild "next"
! next if $prune;
}
# change to that directory
! unless ($no_chdir or $dir_rel eq '.') {
! my $udir = $dir_loc;
! if ($untaint) {
! $udir = $1 if $dir_loc =~ m|$untaint_pat|;
! unless (defined $udir ) {
if ($untaint_skip == 0) {
die "directory $dir_loc is still tainted";
}
--- 895,941 ----
}
}
}
! $ok = chdir($updir_loc) unless ($p_dir eq $File::Find::current_dir);
! unless ($ok) {
! warn "Can't cd to $updir_loc: $!\n" if $^W;
return;
}
}
! push @Stack,[$dir_loc,$updir_loc,$p_dir,$dir_rel,-1] if $bydepth;
+ if ($Is_MacOS) {
+ $p_dir = $dir_pref; # ensure trailing ':'
+ }
+
while (defined $SE) {
unless ($bydepth) {
! # change (back) to parent directory (always untainted)
unless ($no_chdir) {
! unless (chdir $updir_loc) {
! warn "Can't cd to $updir_loc: $!\n" if $^W;
next;
}
}
! $dir= $p_dir; # $File::Find::dir
! $name= $dir_name; # $File::Find::name
! $_= ($no_chdir ? $dir_name : $dir_rel ); # $_
! $fullname= $dir_loc; # $File::Find::fullname
# prune may happen here
! $prune= 0;
lstat($_); # make sure file tests with '_' work
! { &$wanted_callback }; # protect against wild "next"
! next if $prune;
}
# change to that directory
! unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) {
! $updir_loc = $dir_loc;
! if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_loc) )) ) {
! # untaint $dir_loc, what will be pushed on the stack as (untainted) parent dir
! ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|;
! unless (defined $updir_loc) {
if ($untaint_skip == 0) {
die "directory $dir_loc is still tainted";
}
***************
*** 647,663 ****
}
}
}
! unless (chdir $udir) {
! warn "Can't cd to $udir: $!\n";
next;
}
}
! $dir = $dir_name;
# Get the list of files in the current directory.
! unless (opendir DIR, ($no_chdir ? $dir_loc : '.')) {
! warn "Can't opendir($dir_loc): $!\n";
next;
}
@filenames = readdir DIR;
--- 944,964 ----
}
}
}
! unless (chdir $updir_loc) {
! warn "Can't cd to $updir_loc: $!\n" if $^W;
next;
}
}
! if ($Is_MacOS) {
! $dir_name = "$dir_name:" unless ($dir_name =~ /:$/);
! }
+ $dir = $dir_name; # $File::Find::dir
+
# Get the list of files in the current directory.
! unless (opendir DIR, ($no_chdir ? $dir_loc : $File::Find::current_dir)) {
! warn "Can't opendir($dir_loc): $!\n" if $^W;
next;
}
@filenames = readdir DIR;
***************
*** 664,670 ****
closedir(DIR);
for my $FN (@filenames) {
! next if $FN =~ /^\.{1,2}\z/;
# follow symbolic links / do an lstat
$new_loc = Follow_SymLink($loc_pref.$FN);
--- 965,971 ----
closedir(DIR);
for my $FN (@filenames) {
! next if $FN =~ $File::Find::skip_pattern;
# follow symbolic links / do an lstat
$new_loc = Follow_SymLink($loc_pref.$FN);
***************
*** 671,684 ****
# ignore if invalid symlink
next unless defined $new_loc;
!
if (-d _) {
! push @Stack,[$new_loc,$dir_loc,$dir_name,$FN,1];
}
else {
! $fullname = $new_loc;
! $name = $dir_pref . $FN;
! $_ = ($no_chdir ? $name : $FN);
{ &$wanted_callback }; # protect against wild "next"
}
}
--- 972,985 ----
# ignore if invalid symlink
next unless defined $new_loc;
!
if (-d _) {
! push @Stack,[$new_loc,$updir_loc,$dir_name,$FN,1];
}
else {
! $fullname = $new_loc; # $File::Find::fullname
! $name = $dir_pref . $FN; # $File::Find::name
! $_ = ($no_chdir ? $name : $FN); # $_
{ &$wanted_callback }; # protect against wild "next"
}
}
***************
*** 686,723 ****
}
continue {
while (defined($SE = pop @Stack)) {
! ($dir_loc, $pdir_loc, $p_dir, $dir_rel, $byd_flag) = @$SE;
! $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
! $dir_pref = "$dir_name/";
! $loc_pref = "$dir_loc/";
! if ( $byd_flag < 0 ) { # must be finddepth, report dirname now
! unless ($no_chdir or $dir_rel eq '.') {
! my $udir = $pdir_loc;
! if ($untaint) {
! $udir = $1 if $dir_loc =~ m|$untaint_pat|;
! }
! unless (chdir $udir) {
! warn "Can't cd to $udir: $!\n";
! next;
! }
! }
! $fullname = $dir_loc;
! $name = $dir_name;
! if ( substr($name,-2) eq '/.' ) {
! $name =~ s|/\.$||;
! }
! $dir = $p_dir;
! $_ = ($no_chdir ? $dir_name : $dir_rel);
! if ( substr($_,-2) eq '/.' ) {
! s|/\.$||;
! }
! lstat($_); # make sure file tests with '_' work
! { &$wanted_callback }; # protect against wild "next"
! } else {
! push @Stack,[$dir_loc, $pdir_loc, $p_dir, $dir_rel,-1] if $bydepth;
! last;
! }
}
}
}
--- 987,1040 ----
}
continue {
while (defined($SE = pop @Stack)) {
! ($dir_loc, $updir_loc, $p_dir, $dir_rel, $byd_flag) = @$SE;
! if ($Is_MacOS) {
! # $p_dir always has a trailing ':', except for the starting dir,
! # where $dir_rel eq ':'
! $dir_name = "$p_dir$dir_rel";
! $dir_pref = "$dir_name:";
! $loc_pref = ($dir_loc =~ /:$/) ? $dir_loc : "$dir_loc:";
! }
! else {
! $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
! $dir_pref = "$dir_name/";
! $loc_pref = "$dir_loc/";
! }
! if ( $byd_flag < 0 ) { # must be finddepth, report dirname now
! unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) {
! unless (chdir $updir_loc) { # $updir_loc (parent dir) is always untainted
! warn "Can't cd to $updir_loc: $!\n" if $^W;
! next;
! }
! }
! $fullname = $dir_loc; # $File::Find::fullname
! $name = $dir_name; # $File::Find::name
! if ($Is_MacOS) {
! if ($dir_rel eq ':') { # must be the top dir, where we started
! $name =~ s|:$||; # $File::Find::name
! $p_dir = "$p_dir:" unless ($p_dir =~ /:$/);
! }
! $dir = $p_dir; # $File::Find::dir
! $_ = ($no_chdir ? $name : $dir_rel); # $_
! }
! else {
! if ( substr($name,-2) eq '/.' ) {
! $name =~ s|/\.$||; # $File::Find::name
! }
! $dir = $p_dir; # $File::Find::dir
! $_ = ($no_chdir ? $dir_name : $dir_rel); # $_
! if ( substr($_,-2) eq '/.' ) {
! s|/\.$||;
! }
! }
! lstat($_); # make sure file tests with '_' work
! { &$wanted_callback }; # protect against wild "next"
! }
! else {
! push @Stack,[$dir_loc, $updir_loc, $p_dir, $dir_rel,-1] if $bydepth;
! last;
! }
}
}
}
***************
*** 730,736 ****
$wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip};
}
if ( $wanted->{untaint} ) {
! $wanted->{untaint_pattern} = qr|^([-+@\w./]+)$|
unless defined $wanted->{untaint_pattern};
$wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip};
}
--- 1047,1053 ----
$wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip};
}
if ( $wanted->{untaint} ) {
! $wanted->{untaint_pattern} = $File::Find::untaint_pattern
unless defined $wanted->{untaint_pattern};
$wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip};
}
***************
*** 744,750 ****
sub find {
my $wanted = shift;
_find_opt(wrap_wanted($wanted), @_);
- %SLnkSeen= (); # free memory
}
sub finddepth {
--- 1061,1066 ----
***************
*** 751,768 ****
my $wanted = wrap_wanted(shift);
$wanted->{bydepth} = 1;
_find_opt($wanted, @_);
- %SLnkSeen= (); # free memory
}
# These are hard-coded for now, but may move to hint files.
if ($^O eq 'VMS') {
$Is_VMS = 1;
! $File::Find::dont_use_nlink = 1;
}
$File::Find::dont_use_nlink = 1
if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32' ||
! $^O eq 'cygwin' || $^O eq 'epoc';
# Set dont_use_nlink in your hint file if your system's stat doesn't
# report the number of links in a directory as an indication
--- 1067,1097 ----
my $wanted = wrap_wanted(shift);
$wanted->{bydepth} = 1;
_find_opt($wanted, @_);
}
+ # default
+ $File::Find::skip_pattern = qr/^\.{1,2}\z/;
+ $File::Find::untaint_pattern = qr|^([-+@\w./]+)$|;
+
# These are hard-coded for now, but may move to hint files.
if ($^O eq 'VMS') {
$Is_VMS = 1;
! $File::Find::dont_use_nlink = 1;
}
+ elsif ($^O eq 'MacOS') {
+ $Is_MacOS = 1;
+ $File::Find::dont_use_nlink = 1;
+ $File::Find::skip_pattern = qr/^Icon\015\z/;
+ $File::Find::untaint_pattern = qr|^(.+)$|;
+ }
+ # this _should_ work properly on all platforms
+ # where File::Find can be expected to work
+ $File::Find::current_dir = File::Spec->curdir || '.';
+
$File::Find::dont_use_nlink = 1
if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32' ||
! $^O eq 'cygwin' || $^O eq 'epoc' || $^O eq 'NetWare';
# Set dont_use_nlink in your hint file if your system's stat doesn't
# report the number of links in a directory as an indication
***************
*** 771,776 ****
--- 1100,1114 ----
unless ($File::Find::dont_use_nlink) {
require Config;
$File::Find::dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'});
+ }
+
+ # We need a function that checks if a scalar is tainted. Either use the
+ # Scalar::Util module's tainted() function or our (slower) pure Perl
+ # fallback is_tainted_pp()
+ {
+ local $@;
+ eval { require Scalar::Util };
+ *is_tainted = $@ ? \&is_tainted_pp : \&Scalar::Util::tainted;
}
1;
diff -c /dev/null 'perl-5.7.2/lib/File/Find/find.t'
Index: ./lib/File/Find/find.t
*** ./lib/File/Find/find.t Thu Jan 1 02:00:00 1970
--- ./lib/File/Find/find.t Mon Jul 9 17:10:34 2001
***************
*** 0 ****
--- 1,742 ----
+ #!./perl
+
+
+ my %Expect_File = (); # what we expect for $_
+ my %Expect_Name = (); # what we expect for $File::Find::name/fullname
+ my %Expect_Dir = (); # what we expect for $File::Find::dir
+ my $symlink_exists = eval { symlink("",""); 1 };
+ my $warn_msg;
+
+
+ BEGIN {
+ chdir 't' if -d 't';
+ unshift @INC => '../lib';
+
+ $SIG{'__WARN__'} = sub { $warn_msg = $_[0]; warn "# $_[0]"; }
+ }
+
+ if ( $symlink_exists ) { print "1..188\n"; }
+ else { print "1..78\n"; }
+
+ use File::Find;
+ use File::Spec;
+ if ($^O eq 'MSWin32' || $^O eq 'cygwin' || $^O eq 'VMS')
+ {
+ # This is a hack - at present File::Find does not produce native names on
+ # Win32 or VMS, so force File::Spec to use Unix names.
+ require File::Spec::Unix;
+ @File::Spec::ISA = 'File::Spec::Unix';
+ }
+
+ cleanup();
+
+ find({wanted => sub { print "ok 1\n" if $_ eq 'commonsense.t'; } },
+ File::Spec->curdir);
+
+ finddepth({wanted => sub { print "ok 2\n" if $_ eq 'commonsense.t'; } },
+ File::Spec->curdir);
+
+ my $case = 2;
+ my $FastFileTests_OK = 0;
+
+ sub cleanup {
+ if (-d dir_path('for_find')) {
+ chdir(dir_path('for_find'));
+ }
+ if (-d dir_path('fa')) {
+ unlink file_path('fa', 'fa_ord'),
+ file_path('fa', 'fsl'),
+ file_path('fa', 'faa', 'faa_ord'),
+ file_path('fa', 'fab', 'fab_ord'),
+ file_path('fa', 'fab', 'faba', 'faba_ord'),
+ file_path('fb', 'fb_ord'),
+ file_path('fb', 'fba', 'fba_ord');
+ rmdir dir_path('fa', 'faa');
+ rmdir dir_path('fa', 'fab', 'faba');
+ rmdir dir_path('fa', 'fab');
+ rmdir dir_path('fa');
+ rmdir dir_path('fb', 'fba');
+ rmdir dir_path('fb');
+ chdir File::Spec->updir;
+ rmdir dir_path('for_find');
+ }
+ }
+
+ END {
+ cleanup();
+ }
+
+ sub Check($) {
+ $case++;
+ if ($_[0]) { print "ok $case\n"; }
+ else { print "not ok $case\n"; }
+ }
+
+ sub CheckDie($) {
+ $case++;
+ if ($_[0]) { print "ok $case\n"; }
+ else { print "not ok $case\n $!\n"; exit 0; }
+ }
+
+ sub touch {
+ CheckDie( open(my $T,'>',$_[0]) );
+ }
+
+ sub MkDir($$) {
+ CheckDie( mkdir($_[0],$_[1]) );
+ }
+
+ sub wanted_File_Dir {
+ print "# \$File::Find::dir => '$File::Find::dir'\n";
+ print "# \$_ => '$_'\n";
+ s#\.$## if ($^O eq 'VMS' && $_ ne '.');
+ Check( $Expect_File{$_} );
+ if ( $FastFileTests_OK ) {
+ delete $Expect_File{ $_}
+ unless ( $Expect_Dir{$_} && ! -d _ );
+ } else {
+ delete $Expect_File{$_}
+ unless ( $Expect_Dir{$_} && ! -d $_ );
+ }
+ }
+
+ sub wanted_File_Dir_prune {
+ &wanted_File_Dir;
+ $File::Find::prune=1 if $_ eq 'faba';
+ }
+
+ sub wanted_Name {
+ my $n = $File::Find::name;
+ $n =~ s#\.$## if ($^O eq 'VMS' && $n ne '.');
+ print "# \$File::Find::name => '$n'\n";
+ my $i = rindex($n,'/');
+ my $OK = exists($Expect_Name{$n});
+ unless ($^O eq 'MacOS') {
+ if ( $OK ) {
+ $OK= exists($Expect_Name{substr($n,0,$i)}) if $i >= 0;
+ }
+ }
+ Check($OK);
+ delete $Expect_Name{$n};
+ }
+
+ sub wanted_File {
+ print "# \$_ => '$_'\n";
+ s#\.$## if ($^O eq 'VMS' && $_ ne '.');
+ my $i = rindex($_,'/');
+ my $OK = exists($Expect_File{ $_});
+ unless ($^O eq 'MacOS') {
+ if ( $OK ) {
+ $OK= exists($Expect_File{ substr($_,0,$i)}) if $i >= 0;
+ }
+ }
+ Check($OK);
+ delete $Expect_File{ $_};
+ }
+
+ sub simple_wanted {
+ print "# \$File::Find::dir => '$File::Find::dir'\n";
+ print "# \$_ => '$_'\n";
+ }
+
+ sub noop_wanted {}
+
+ sub my_preprocess {
+ @files = @_;
+ print "# --preprocess--\n";
+ print "# \$File::Find::dir => '$File::Find::dir' \n";
+ foreach $file (@files) {
+ $file =~ s/\.(dir)?$// if $^O eq 'VMS';
+ print "# $file \n";
+ delete $Expect_Dir{ $File::Find::dir }->{$file};
+ }
+ print "# --end preprocess--\n";
+ Check(scalar(keys %{$Expect_Dir{ $File::Find::dir }}) == 0);
+ if (scalar(keys %{$Expect_Dir{ $File::Find::dir }}) == 0) {
+ delete $Expect_Dir{ $File::Find::dir }
+ }
+ return @files;
+ }
+
+ sub my_postprocess {
+ print "# postprocess: \$File::Find::dir => '$File::Find::dir' \n";
+ delete $Expect_Dir{ $File::Find::dir};
+ }
+
+
+ # Use dir_path() to specify a directory path that's expected for
+ # $File::Find::dir (%Expect_Dir). Also use it in file operations like
+ # chdir, rmdir etc.
+ #
+ # dir_path() concatenates directory names to form a _relative_
+ # directory path, independent from the platform it's run on, although
+ # there are limitations. Don't try to create an absolute path,
+ # because that may fail on operating systems that have the concept of
+ # volume names (e.g. Mac OS). Be careful when you want to create an
+ # updir path like ../fa (Unix) or ::fa: (Mac OS). Plain directory
+ # names will work best. As a special case, you can pass it a "." as
+ # first argument, to create a directory path like "./fa/dir" on
+ # operating systems other than Mac OS (actually, Mac OS will ignore
+ # the ".", if it's the first argument). If there's no second argument,
+ # this function will return the empty string on Mac OS and the string
+ # "./" otherwise.
+
+ sub dir_path {
+ my $first_item = shift @_;
+
+ if ($first_item eq '.') {
+ if ($^O eq 'MacOS') {
+ return '' unless @_;
+ # ignore first argument; return a relative path
+ # with leading ":" and with trailing ":"
+ return File::Spec->catdir("", @_);
+ } else { # other OS
+ return './' unless @_;
+ my $path = File::Spec->catdir(@_);
+ # add leading "./"
+ $path = "./$path";
+ return $path;
+ }
+
+ } else { # $first_item ne '.'
+ return $first_item unless @_; # return plain filename
+ if ($^O eq 'MacOS') {
+ # relative path with leading ":" and with trailing ":"
+ return File::Spec->catdir("", $first_item, @_);
+ } else { # other OS
+ return File::Spec->catdir($first_item, @_);
+ }
+ }
+ }
+
+
+ # Use topdir() to specify a directory path that you want to pass to
+ #find/finddepth Basically, topdir() does the same as dir_path() (see
+ #above), except that there's no trailing ":" on Mac OS.
+
+ sub topdir {
+ my $path = dir_path(@_);
+ $path =~ s/:$// if ($^O eq 'MacOS');
+ return $path;
+ }
+
+
+ # Use file_path() to specify a file path that's expected for $_
+ # (%Expect_File). Also suitable for file operations like unlink etc.
+ #
+ # file_path() concatenates directory names (if any) and a filename to
+ # form a _relative_ file path (the last argument is assumed to be a
+ # file). It's independent from the platform it's run on, although
+ # there are limitations (see the warnings for dir_path() above). As a
+ # special case, you can pass it a "." as first argument, to create a
+ # file path like "./fa/file" on operating systems other than Mac OS
+ # (actually, Mac OS will ignore the ".", if it's the first
+ # argument). If there's no second argument, this function will return
+ # the empty string on Mac OS and the string "./" otherwise.
+
+ sub file_path {
+ my $first_item = shift @_;
+
+ if ($first_item eq '.') {
+ if ($^O eq 'MacOS') {
+ return '' unless @_;
+ # ignore first argument; return a relative path
+ # with leading ":", but without trailing ":"
+ return File::Spec->catfile("", @_);
+ } else { # other OS
+ return './' unless @_;
+ my $path = File::Spec->catfile(@_);
+ # add leading "./"
+ $path = "./$path";
+ return $path;
+ }
+
+ } else { # $first_item ne '.'
+ return $first_item unless @_; # return plain filename
+ if ($^O eq 'MacOS') {
+ # relative path with leading ":", but without trailing ":"
+ return File::Spec->catfile("", $first_item, @_);
+ } else { # other OS
+ return File::Spec->catfile($first_item, @_);
+ }
+ }
+ }
+
+
+ # Use file_path_name() to specify a file path that's expected for
+ # $File::Find::Name (%Expect_Name). Note: When the no_chdir => 1
+ # option is in effect, $_ is the same as $File::Find::Name. In that
+ # case, also use this function to specify a file path that's expected
+ # for $_.
+ #
+ # Basically, file_path_name() does the same as file_path() (see
+ # above), except that there's always a leading ":" on Mac OS, even for
+ # plain file/directory names.
+
+ sub file_path_name {
+ my $path = file_path(@_);
+ $path = ":$path" if (($^O eq 'MacOS') && ($path !~ /:/));
+ return $path;
+ }
+
+
+
+ MkDir( dir_path('for_find'), 0770 );
+ CheckDie(chdir( dir_path('for_find')));
+ MkDir( dir_path('fa'), 0770 );
+ MkDir( dir_path('fb'), 0770 );
+ touch( file_path('fb', 'fb_ord') );
+ MkDir( dir_path('fb', 'fba'), 0770 );
+ touch( file_path('fb', 'fba', 'fba_ord') );
+ if ($^O eq 'MacOS') {
+ CheckDie( symlink(':fb',':fa:fsl') ) if $symlink_exists;
+ } else {
+ CheckDie( symlink('../fb','fa/fsl') ) if $symlink_exists;
+ }
+ touch( file_path('fa', 'fa_ord') );
+
+ MkDir( dir_path('fa', 'faa'), 0770 );
+ touch( file_path('fa', 'faa', 'faa_ord') );
+ MkDir( dir_path('fa', 'fab'), 0770 );
+ touch( file_path('fa', 'fab', 'fab_ord') );
+ MkDir( dir_path('fa', 'fab', 'faba'), 0770 );
+ touch( file_path('fa', 'fab', 'faba', 'faba_ord') );
+
+
+ %Expect_File = (File::Spec->curdir => 1, file_path('fsl') => 1,
+ file_path('fa_ord') => 1, file_path('fab') => 1,
+ file_path('fab_ord') => 1, file_path('faba') => 1,
+ file_path('faa') => 1, file_path('faa_ord') => 1);
+
+ delete $Expect_File{ file_path('fsl') } unless $symlink_exists;
+ %Expect_Name = ();
+
+ %Expect_Dir = ( dir_path('fa') => 1, dir_path('faa') => 1,
+ dir_path('fab') => 1, dir_path('faba') => 1,
+ dir_path('fb') => 1, dir_path('fba') => 1);
+
+ delete @Expect_Dir{ dir_path('fb'), dir_path('fba') } unless $symlink_exists;
+ File::Find::find( {wanted => \&wanted_File_Dir_prune}, topdir('fa') );
+ Check( scalar(keys %Expect_File) == 0 );
+
+
+ print "# check re-entrancy\n";
+
+ %Expect_File = (File::Spec->curdir => 1, file_path('fsl') => 1,
+ file_path('fa_ord') => 1, file_path('fab') => 1,
+ file_path('fab_ord') => 1, file_path('faba') => 1,
+ file_path('faa') => 1, file_path('faa_ord') => 1);
+
+ delete $Expect_File{ file_path('fsl') } unless $symlink_exists;
+ %Expect_Name = ();
+
+ %Expect_Dir = ( dir_path('fa') => 1, dir_path('faa') => 1,
+ dir_path('fab') => 1, dir_path('faba') => 1,
+ dir_path('fb') => 1, dir_path('fba') => 1);
+
+ delete @Expect_Dir{ dir_path('fb'), dir_path('fba') } unless $symlink_exists;
+
+ File::Find::find( {wanted => sub { wanted_File_Dir_prune();
+ File::Find::find( {wanted => sub
+ {} }, File::Spec->curdir ); } },
+ topdir('fa') );
+
+ Check( scalar(keys %Expect_File) == 0 );
+
+
+ # no_chdir is in effect, hence we use file_path_name to specify the expected paths for %Expect_File
+
+ %Expect_File = (file_path_name('fa') => 1,
+ file_path_name('fa', 'fsl') => 1,
+ file_path_name('fa', 'fa_ord') => 1,
+ file_path_name('fa', 'fab') => 1,
+ file_path_name('fa', 'fab', 'fab_ord') => 1,
+ file_path_name('fa', 'fab', 'faba') => 1,
+ file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1,
+ file_path_name('fa', 'faa') => 1,
+ file_path_name('fa', 'faa', 'faa_ord') => 1,);
+
+ delete $Expect_File{ file_path_name('fa', 'fsl') } unless $symlink_exists;
+ %Expect_Name = ();
+
+ %Expect_Dir = (dir_path('fa') => 1,
+ dir_path('fa', 'faa') => 1,
+ dir_path('fa', 'fab') => 1,
+ dir_path('fa', 'fab', 'faba') => 1,
+ dir_path('fb') => 1,
+ dir_path('fb', 'fba') => 1);
+
+ delete @Expect_Dir{ dir_path('fb'), dir_path('fb', 'fba') }
+ unless $symlink_exists;
+
+ File::Find::find( {wanted => \&wanted_File_Dir, no_chdir => 1},
+ topdir('fa') ); Check( scalar(keys %Expect_File) == 0 );
+
+
+ %Expect_File = ();
+
+ %Expect_Name = (File::Spec->curdir => 1,
+ file_path_name('.', 'fa') => 1,
+ file_path_name('.', 'fa', 'fsl') => 1,
+ file_path_name('.', 'fa', 'fa_ord') => 1,
+ file_path_name('.', 'fa', 'fab') => 1,
+ file_path_name('.', 'fa', 'fab', 'fab_ord') => 1,
+ file_path_name('.', 'fa', 'fab', 'faba') => 1,
+ file_path_name('.', 'fa', 'fab', 'faba', 'faba_ord') => 1,
+ file_path_name('.', 'fa', 'faa') => 1,
+ file_path_name('.', 'fa', 'faa', 'faa_ord') => 1,
+ file_path_name('.', 'fb') => 1,
+ file_path_name('.', 'fb', 'fba') => 1,
+ file_path_name('.', 'fb', 'fba', 'fba_ord') => 1,
+ file_path_name('.', 'fb', 'fb_ord') => 1);
+
+ delete $Expect_Name{ file_path('.', 'fa', 'fsl') } unless $symlink_exists;
+ %Expect_Dir = ();
+ File::Find::finddepth( {wanted => \&wanted_Name}, File::Spec->curdir );
+ Check( scalar(keys %Expect_Name) == 0 );
+
+
+ # no_chdir is in effect, hence we use file_path_name to specify the
+ # expected paths for %Expect_File
+
+ %Expect_File = (File::Spec->curdir => 1,
+ file_path_name('.', 'fa') => 1,
+ file_path_name('.', 'fa', 'fsl') => 1,
+ file_path_name('.', 'fa', 'fa_ord') => 1,
+ file_path_name('.', 'fa', 'fab') => 1,
+ file_path_name('.', 'fa', 'fab', 'fab_ord') => 1,
+ file_path_name('.', 'fa', 'fab', 'faba') => 1,
+ file_path_name('.', 'fa', 'fab', 'faba', 'faba_ord') => 1,
+ file_path_name('.', 'fa', 'faa') => 1,
+ file_path_name('.', 'fa', 'faa', 'faa_ord') => 1,
+ file_path_name('.', 'fb') => 1,
+ file_path_name('.', 'fb', 'fba') => 1,
+ file_path_name('.', 'fb', 'fba', 'fba_ord') => 1,
+ file_path_name('.', 'fb', 'fb_ord') => 1);
+
+ delete $Expect_File{ file_path_name('.', 'fa', 'fsl') } unless $symlink_exists;
+ %Expect_Name = ();
+ %Expect_Dir = ();
+
+ File::Find::finddepth( {wanted => \&wanted_File, no_chdir => 1},
+ File::Spec->curdir );
+
+ Check( scalar(keys %Expect_File) == 0 );
+
+
+ print "# check preprocess\n";
+ %Expect_File = ();
+ %Expect_Name = ();
+ %Expect_Dir = (
+ File::Spec->curdir => {fa => 1, fb => 1},
+ dir_path('.', 'fa') => {faa => 1, fab => 1, fa_ord => 1},
+ dir_path('.', 'fa', 'faa') => {faa_ord => 1},
+ dir_path('.', 'fa', 'fab') => {faba => 1, fab_ord => 1},
+ dir_path('.', 'fa', 'fab', 'faba') => {faba_ord => 1},
+ dir_path('.', 'fb') => {fba => 1, fb_ord => 1},
+ dir_path('.', 'fb', 'fba') => {fba_ord => 1}
+ );
+
+ File::Find::find( {wanted => \&noop_wanted,
+ preprocess => \&my_preprocess}, File::Spec->curdir );
+
+ Check( scalar(keys %Expect_Dir) == 0 );
+
+
+ print "# check postprocess\n";
+ %Expect_File = ();
+ %Expect_Name = ();
+ %Expect_Dir = (
+ File::Spec->curdir => 1,
+ dir_path('.', 'fa') => 1,
+ dir_path('.', 'fa', 'faa') => 1,
+ dir_path('.', 'fa', 'fab') => 1,
+ dir_path('.', 'fa', 'fab', 'faba') => 1,
+ dir_path('.', 'fb') => 1,
+ dir_path('.', 'fb', 'fba') => 1
+ );
+
+ File::Find::find( {wanted => \&noop_wanted,
+ postprocess => \&my_postprocess}, File::Spec->curdir );
+
+ Check( scalar(keys %Expect_Dir) == 0 );
+
+
+ if ( $symlink_exists ) {
+ print "# --- symbolic link tests --- \n";
+ $FastFileTests_OK= 1;
+
+
+ # Verify that File::Find::find will call wanted even if the topdir of
+ # is a symlink to a directory, and it shouldn't follow the link
+ # unless follow is set, which it isn't in this case
+ %Expect_File = ( file_path('fsl') => 1 );
+ %Expect_Name = ();
+ %Expect_Dir = ();
+ File::Find::find( {wanted => \&wanted_File_Dir}, topdir('fa', 'fsl') );
+ Check( scalar(keys %Expect_File) == 0 );
+
+
+ %Expect_File = (File::Spec->curdir => 1, file_path('fa_ord') => 1,
+ file_path('fsl') => 1, file_path('fb_ord') => 1,
+ file_path('fba') => 1, file_path('fba_ord') => 1,
+ file_path('fab') => 1, file_path('fab_ord') => 1,
+ file_path('faba') => 1, file_path('faa') => 1,
+ file_path('faa_ord') => 1);
+
+ %Expect_Name = ();
+
+ %Expect_Dir = (File::Spec->curdir => 1, dir_path('fa') => 1,
+ dir_path('faa') => 1, dir_path('fab') => 1,
+ dir_path('faba') => 1, dir_path('fb') => 1,
+ dir_path('fba') => 1);
+
+ File::Find::find( {wanted => \&wanted_File_Dir_prune,
+ follow_fast => 1}, topdir('fa') );
+
+ Check( scalar(keys %Expect_File) == 0 );
+
+
+ # no_chdir is in effect, hence we use file_path_name to specify
+ # the expected paths for %Expect_File
+
+ %Expect_File = (file_path_name('fa') => 1,
+ file_path_name('fa', 'fa_ord') => 1,
+ file_path_name('fa', 'fsl') => 1,
+ file_path_name('fa', 'fsl', 'fb_ord') => 1,
+ file_path_name('fa', 'fsl', 'fba') => 1,
+ file_path_name('fa', 'fsl', 'fba', 'fba_ord') => 1,
+ file_path_name('fa', 'fab') => 1,
+ file_path_name('fa', 'fab', 'fab_ord') => 1,
+ file_path_name('fa', 'fab', 'faba') => 1,
+ file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1,
+ file_path_name('fa', 'faa') => 1,
+ file_path_name('fa', 'faa', 'faa_ord') => 1);
+
+ %Expect_Name = ();
+
+ %Expect_Dir = (dir_path('fa') => 1,
+ dir_path('fa', 'faa') => 1,
+ dir_path('fa', 'fab') => 1,
+ dir_path('fa', 'fab', 'faba') => 1,
+ dir_path('fb') => 1,
+ dir_path('fb', 'fba') => 1);
+
+ File::Find::find( {wanted => \&wanted_File_Dir, follow_fast => 1,
+ no_chdir => 1}, topdir('fa') );
+
+ Check( scalar(keys %Expect_File) == 0 );
+
+ %Expect_File = ();
+
+ %Expect_Name = (file_path_name('fa') => 1,
+ file_path_name('fa', 'fa_ord') => 1,
+ file_path_name('fa', 'fsl') => 1,
+ file_path_name('fa', 'fsl', 'fb_ord') => 1,
+ file_path_name('fa', 'fsl', 'fba') => 1,
+ file_path_name('fa', 'fsl', 'fba', 'fba_ord') => 1,
+ file_path_name('fa', 'fab') => 1,
+ file_path_name('fa', 'fab', 'fab_ord') => 1,
+ file_path_name('fa', 'fab', 'faba') => 1,
+ file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1,
+ file_path_name('fa', 'faa') => 1,
+ file_path_name('fa', 'faa', 'faa_ord') => 1);
+
+ %Expect_Dir = ();
+
+ File::Find::finddepth( {wanted => \&wanted_Name,
+ follow_fast => 1}, topdir('fa') );
+
+ Check( scalar(keys %Expect_Name) == 0 );
+
+ # no_chdir is in effect, hence we use file_path_name to specify
+ # the expected paths for %Expect_File
+
+ %Expect_File = (file_path_name('fa') => 1,
+ file_path_name('fa', 'fa_ord') => 1,
+ file_path_name('fa', 'fsl') => 1,
+ file_path_name('fa', 'fsl', 'fb_ord') => 1,
+ file_path_name('fa', 'fsl', 'fba') => 1,
+ file_path_name('fa', 'fsl', 'fba', 'fba_ord') => 1,
+ file_path_name('fa', 'fab') => 1,
+ file_path_name('fa', 'fab', 'fab_ord') => 1,
+ file_path_name('fa', 'fab', 'faba') => 1,
+ file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1,
+ file_path_name('fa', 'faa') => 1,
+ file_path_name('fa', 'faa', 'faa_ord') => 1);
+
+ %Expect_Name = ();
+ %Expect_Dir = ();
+
+ File::Find::finddepth( {wanted => \&wanted_File, follow_fast => 1,
+ no_chdir => 1}, topdir('fa') );
+
+ Check( scalar(keys %Expect_File) == 0 );
+
+
+ print "# check dangling symbolic links\n";
+ MkDir( dir_path('dangling_dir'), 0770 );
+ CheckDie( symlink( dir_path('dangling_dir'),
+ file_path('dangling_dir_sl') ) );
+ rmdir dir_path('dangling_dir');
+ touch(file_path('dangling_file'));
+ if ($^O eq 'MacOS') {
+ CheckDie( symlink('dangling_file', ':fa:dangling_file_sl') );
+ } else {
+ CheckDie( symlink('../dangling_file','fa/dangling_file_sl') );
+ }
+ unlink file_path('dangling_file');
+
+ {
+ # these tests should also emit a warning
+ use warnings;
+
+ %Expect_File = (File::Spec->curdir => 1,
+ file_path('fa_ord') => 1,
+ file_path('fsl') => 1,
+ file_path('fb_ord') => 1,
+ file_path('fba') => 1,
+ file_path('fba_ord') => 1,
+ file_path('fab') => 1,
+ file_path('fab_ord') => 1,
+ file_path('faba') => 1,
+ file_path('faba_ord') => 1,
+ file_path('faa') => 1,
+ file_path('faa_ord') => 1);
+
+ %Expect_Name = ();
+ %Expect_Dir = ();
+ undef $warn_msg;
+
+ File::Find::find( {wanted => \&wanted_File, follow => 1,
+ dangling_symlinks =>
+ sub { $warn_msg = "$_[0] is a dangling symbolic link" }
+ },
+ topdir('dangling_dir_sl'), topdir('fa') );
+
+ Check( scalar(keys %Expect_File) == 0 );
+ Check( $warn_msg =~ m|dangling_dir_sl is a dangling symbolic link| );
+ unlink file_path('fa', 'dangling_file_sl'),
+ file_path('dangling_dir_sl');
+
+ }
+
+
+ print "# check recursion\n";
+ if ($^O eq 'MacOS') {
+ CheckDie( symlink(':fa:faa',':fa:faa:faa_sl') );
+ } else {
+ CheckDie( symlink('../faa','fa/faa/faa_sl') );
+ }
+ undef $@;
+ eval {File::Find::find( {wanted => \&simple_wanted, follow => 1,
+ no_chdir => 1}, topdir('fa') ); };
+ Check( $@ =~ m|for_find[:/]fa[:/]faa[:/]faa_sl is a recursive symbolic link| );
+ unlink file_path('fa', 'faa', 'faa_sl');
+
+
+ print "# check follow_skip (file)\n";
+ if ($^O eq 'MacOS') {
+ CheckDie( symlink(':fa:fa_ord',':fa:fa_ord_sl') ); # symlink to a file
+ } else {
+ CheckDie( symlink('./fa_ord','fa/fa_ord_sl') ); # symlink to a file
+ }
+ undef $@;
+
+ eval {File::Find::finddepth( {wanted => \&simple_wanted,
+ follow => 1,
+ follow_skip => 0, no_chdir => 1},
+ topdir('fa') );};
+
+ Check( $@ =~ m|for_find[:/]fa[:/]fa_ord encountered a second time| );
+
+
+ # no_chdir is in effect, hence we use file_path_name to specify
+ # the expected paths for %Expect_File
+
+ %Expect_File = (file_path_name('fa') => 1,
+ file_path_name('fa', 'fa_ord') => 1,
+ file_path_name('fa', 'fsl') => 1,
+ file_path_name('fa', 'fsl', 'fb_ord') => 1,
+ file_path_name('fa', 'fsl', 'fba') => 1,
+ file_path_name('fa', 'fsl', 'fba', 'fba_ord') => 1,
+ file_path_name('fa', 'fab') => 1,
+ file_path_name('fa', 'fab', 'fab_ord') => 1,
+ file_path_name('fa', 'fab', 'faba') => 1,
+ file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1,
+ file_path_name('fa', 'faa') => 1,
+ file_path_name('fa', 'faa', 'faa_ord') => 1);
+
+ %Expect_Name = ();
+
+ %Expect_Dir = (dir_path('fa') => 1,
+ dir_path('fa', 'faa') => 1,
+ dir_path('fa', 'fab') => 1,
+ dir_path('fa', 'fab', 'faba') => 1,
+ dir_path('fb') => 1,
+ dir_path('fb','fba') => 1);
+
+ File::Find::finddepth( {wanted => \&wanted_File_Dir, follow => 1,
+ follow_skip => 1, no_chdir => 1},
+ topdir('fa') );
+
+ Check( scalar(keys %Expect_File) == 0 );
+ unlink file_path('fa', 'fa_ord_sl');
+
+
+ print "# check follow_skip (directory)\n";
+ if ($^O eq 'MacOS') {
+ CheckDie( symlink(':fa:faa',':fa:faa_sl') ); # symlink to a directory
+ } else {
+ CheckDie( symlink('./faa','fa/faa_sl') ); # symlink to a directory
+ }
+ undef $@;
+
+ eval {File::Find::find( {wanted => \&simple_wanted, follow => 1,
+ follow_skip => 0, no_chdir => 1},
+ topdir('fa') );};
+
+ Check( $@ =~ m|for_find[:/]fa[:/]faa[:/]? encountered a second time| );
+
+
+ undef $@;
+
+ eval {File::Find::find( {wanted => \&simple_wanted, follow => 1,
+ follow_skip => 1, no_chdir => 1},
+ topdir('fa') );};
+
+ Check( $@ =~ m|for_find[:/]fa[:/]faa[:/]? encountered a second time| );
+
+ # no_chdir is in effect, hence we use file_path_name to specify
+ # the expected paths for %Expect_File
+
+ %Expect_File = (file_path_name('fa') => 1,
+ file_path_name('fa', 'fa_ord') => 1,
+ file_path_name('fa', 'fsl') => 1,
+ file_path_name('fa', 'fsl', 'fb_ord') => 1,
+ file_path_name('fa', 'fsl', 'fba') => 1,
+ file_path_name('fa', 'fsl', 'fba', 'fba_ord') => 1,
+ file_path_name('fa', 'fab') => 1,
+ file_path_name('fa', 'fab', 'fab_ord') => 1,
+ file_path_name('fa', 'fab', 'faba') => 1,
+ file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1,
+ file_path_name('fa', 'faa') => 1,
+ file_path_name('fa', 'faa', 'faa_ord') => 1);
+
+ %Expect_Name = ();
+
+ %Expect_Dir = (dir_path('fa') => 1,
+ dir_path('fa', 'faa') => 1,
+ dir_path('fa', 'fab') => 1,
+ dir_path('fa', 'fab', 'faba') => 1,
+ dir_path('fb') => 1,
+ dir_path('fb', 'fba') => 1);
+
+ File::Find::find( {wanted => \&wanted_File_Dir, follow => 1,
+ follow_skip => 2, no_chdir => 1}, topdir('fa') );
+
+ Check( scalar(keys %Expect_File) == 0 );
+ unlink file_path('fa', 'faa_sl');
+
+ }
+
diff -c /dev/null 'perl-5.7.2/lib/File/Find/taint.t'
Index: ./lib/File/Find/taint.t
*** ./lib/File/Find/taint.t Thu Jan 1 02:00:00 1970
--- ./lib/File/Find/taint.t Mon Jul 9 17:10:34 2001
***************
*** 0 ****
--- 1,417 ----
+ #!./perl -T
+
+
+ my %Expect_File = (); # what we expect for $_
+ my %Expect_Name = (); # what we expect for $File::Find::name/fullname
+ my %Expect_Dir = (); # what we expect for $File::Find::dir
+ my $symlink_exists = eval { symlink("",""); 1 };
+ my $cwd;
+ my $cwd_untainted;
+
+ use Config;
+
+ BEGIN {
+ chdir 't' if -d 't';
+ unshift @INC => '../lib';
+
+ for (keys %ENV) { # untaint ENV
+ ($ENV{$_}) = $ENV{$_} =~ /(.*)/;
+ }
+
+ # Remove insecure directories from PATH
+ my @path;
+ my $sep = $Config{path_sep};
+ foreach my $dir (split(/\Q$sep/,$ENV{'PATH'}))
+ {
+ ##
+ ## Match the directory taint tests in mg.c::Perl_magic_setenv()
+ ##
+ push(@path,$dir) unless (length($dir) >= 256
+ or
+ substr($dir,0,1) ne "/"
+ or
+ (stat $dir)[2] & 002);
+ }
+ $ENV{'PATH'} = join($sep,@path);
+ }
+
+
+ if ( $symlink_exists ) { print "1..45\n"; }
+ else { print "1..27\n"; }
+
+ use File::Find;
+ use File::Spec;
+ use Cwd;
+
+
+ my $NonTaintedCwd = $^O eq 'MSWin32' || $^O eq 'cygwin' || $^O eq 'os2';
+
+ cleanup();
+
+ find({wanted => sub { print "ok 1\n" if $_ eq 'commonsense.t'; },
+ untaint => 1, untaint_pattern => qr|^(.+)$|}, File::Spec->curdir);
+
+ finddepth({wanted => sub { print "ok 2\n" if $_ eq 'commonsense.t'; },
+ untaint => 1, untaint_pattern => qr|^(.+)$|},
+ File::Spec->curdir);
+
+ my $case = 2;
+ my $FastFileTests_OK = 0;
+
+ sub cleanup {
+ if (-d dir_path('for_find')) {
+ chdir(dir_path('for_find'));
+ }
+ if (-d dir_path('fa')) {
+ unlink file_path('fa', 'fa_ord'),
+ file_path('fa', 'fsl'),
+ file_path('fa', 'faa', 'faa_ord'),
+ file_path('fa', 'fab', 'fab_ord'),
+ file_path('fa', 'fab', 'faba', 'faba_ord'),
+ file_path('fb', 'fb_ord'),
+ file_path('fb', 'fba', 'fba_ord');
+ rmdir dir_path('fa', 'faa');
+ rmdir dir_path('fa', 'fab', 'faba');
+ rmdir dir_path('fa', 'fab');
+ rmdir dir_path('fa');
+ rmdir dir_path('fb', 'fba');
+ rmdir dir_path('fb');
+ chdir File::Spec->updir;
+ rmdir dir_path('for_find');
+ }
+ }
+
+ END {
+ cleanup();
+ }
+
+ sub Check($) {
+ $case++;
+ if ($_[0]) { print "ok $case\n"; }
+ else { print "not ok $case\n"; }
+
+ }
+
+ sub CheckDie($) {
+ $case++;
+ if ($_[0]) { print "ok $case\n"; }
+ else { print "not ok $case\n"; exit 0; }
+ }
+
+ sub Skip($) {
+ $case++;
+ print "ok $case # skipped: ",$_[0],"\n";
+ }
+
+ sub touch {
+ CheckDie( open(my $T,'>',$_[0]) );
+ }
+
+ sub MkDir($$) {
+ CheckDie( mkdir($_[0],$_[1]) );
+ }
+
+ sub wanted_File_Dir {
+ print "# \$File::Find::dir => '$File::Find::dir'\n";
+ print "# \$_ => '$_'\n";
+ s#\.$## if ($^O eq 'VMS' && $_ ne '.');
+ Check( $Expect_File{$_} );
+ if ( $FastFileTests_OK ) {
+ delete $Expect_File{ $_}
+ unless ( $Expect_Dir{$_} && ! -d _ );
+ } else {
+ delete $Expect_File{$_}
+ unless ( $Expect_Dir{$_} && ! -d $_ );
+ }
+ }
+
+ sub wanted_File_Dir_prune {
+ &wanted_File_Dir;
+ $File::Find::prune=1 if $_ eq 'faba';
+ }
+
+
+ sub simple_wanted {
+ print "# \$File::Find::dir => '$File::Find::dir'\n";
+ print "# \$_ => '$_'\n";
+ }
+
+
+ # Use dir_path() to specify a directory path that's expected for
+ # $File::Find::dir (%Expect_Dir). Also use it in file operations like
+ # chdir, rmdir etc.
+ #
+ # dir_path() concatenates directory names to form a _relative_
+ # directory path, independant from the platform it's run on, although
+ # there are limitations. Don't try to create an absolute path,
+ # because that may fail on operating systems that have the concept of
+ # volume names (e.g. Mac OS). Be careful when you want to create an
+ # updir path like ../fa (Unix) or ::fa: (Mac OS). Plain directory
+ # names will work best. As a special case, you can pass it a "." as
+ # first argument, to create a directory path like "./fa/dir" on
+ # operating systems other than Mac OS (actually, Mac OS will ignore
+ # the ".", if it's the first argument). If there's no second argument,
+ # this function will return the empty string on Mac OS and the string
+ # "./" otherwise.
+
+ sub dir_path {
+ my $first_item = shift @_;
+
+ if ($first_item eq '.') {
+ if ($^O eq 'MacOS') {
+ return '' unless @_;
+ # ignore first argument; return a relative path
+ # with leading ":" and with trailing ":"
+ return File::Spec->catdir("", @_);
+ } else { # other OS
+ return './' unless @_;
+ my $path = File::Spec->catdir(@_);
+ # add leading "./"
+ $path = "./$path";
+ return $path;
+ }
+
+ } else { # $first_item ne '.'
+ return $first_item unless @_; # return plain filename
+ if ($^O eq 'MacOS') {
+ # relative path with leading ":" and with trailing ":"
+ return File::Spec->catdir("", $first_item, @_);
+ } else { # other OS
+ return File::Spec->catdir($first_item, @_);
+ }
+ }
+ }
+
+
+ # Use topdir() to specify a directory path that you want to pass to
+ #find/finddepth Basically, topdir() does the same as dir_path() (see
+ #above), except that there's no trailing ":" on Mac OS.
+
+ sub topdir {
+ my $path = dir_path(@_);
+ $path =~ s/:$// if ($^O eq 'MacOS');
+ return $path;
+ }
+
+
+ # Use file_path() to specify a file path that's expected for $_ (%Expect_File).
+ # Also suitable for file operations like unlink etc.
+
+ # file_path() concatenates directory names (if any) and a filename to
+ # form a _relative_ file path (the last argument is assumed to be a
+ # file). It's independant from the platform it's run on, although
+ # there are limitations (see the warnings for dir_path() above). As a
+ # special case, you can pass it a "." as first argument, to create a
+ # file path like "./fa/file" on operating systems other than Mac OS
+ # (actually, Mac OS will ignore the ".", if it's the first
+ # argument). If there's no second argument, this function will return
+ # the empty string on Mac OS and the string "./" otherwise.
+
+ sub file_path {
+ my $first_item = shift @_;
+
+ if ($first_item eq '.') {
+ if ($^O eq 'MacOS') {
+ return '' unless @_;
+ # ignore first argument; return a relative path
+ # with leading ":", but without trailing ":"
+ return File::Spec->catfile("", @_);
+ } else { # other OS
+ return './' unless @_;
+ my $path = File::Spec->catfile(@_);
+ # add leading "./"
+ $path = "./$path";
+ return $path;
+ }
+
+ } else { # $first_item ne '.'
+ return $first_item unless @_; # return plain filename
+ if ($^O eq 'MacOS') {
+ # relative path with leading ":", but without trailing ":"
+ return File::Spec->catfile("", $first_item, @_);
+ } else { # other OS
+ return File::Spec->catfile($first_item, @_);
+ }
+ }
+ }
+
+
+ # Use file_path_name() to specify a file path that's expected for
+ # $File::Find::Name (%Expect_Name). Note: When the no_chdir => 1
+ # option is in effect, $_ is the same as $File::Find::Name. In that
+ # case, also use this function to specify a file path that's expected
+ # for $_.
+ #
+ # Basically, file_path_name() does the same as file_path() (see
+ # above), except that there's always a leading ":" on Mac OS, even for
+ # plain file/directory names.
+
+ sub file_path_name {
+ my $path = file_path(@_);
+ $path = ":$path" if (($^O eq 'MacOS') && ($path !~ /:/));
+ return $path;
+ }
+
+
+
+ MkDir( dir_path('for_find'), 0770 );
+ CheckDie(chdir( dir_path('for_find')));
+
+ $cwd = cwd(); # save cwd
+ ( $cwd_untainted ) = $cwd =~ m|^(.+)$|; # untaint it
+
+ MkDir( dir_path('fa'), 0770 );
+ MkDir( dir_path('fb'), 0770 );
+ touch( file_path('fb', 'fb_ord') );
+ MkDir( dir_path('fb', 'fba'), 0770 );
+ touch( file_path('fb', 'fba', 'fba_ord') );
+ if ($^O eq 'MacOS') {
+ CheckDie( symlink(':fb',':fa:fsl') ) if $symlink_exists;
+ } else {
+ CheckDie( symlink('../fb','fa/fsl') ) if $symlink_exists;
+ }
+ touch( file_path('fa', 'fa_ord') );
+
+ MkDir( dir_path('fa', 'faa'), 0770 );
+ touch( file_path('fa', 'faa', 'faa_ord') );
+ MkDir( dir_path('fa', 'fab'), 0770 );
+ touch( file_path('fa', 'fab', 'fab_ord') );
+ MkDir( dir_path('fa', 'fab', 'faba'), 0770 );
+ touch( file_path('fa', 'fab', 'faba', 'faba_ord') );
+
+ print "# check untainting (no follow)\n";
+
+ # untainting here should work correctly
+
+ %Expect_File = (File::Spec->curdir => 1, file_path('fsl') =>
+ 1,file_path('fa_ord') => 1, file_path('fab') => 1,
+ file_path('fab_ord') => 1, file_path('faba') => 1,
+ file_path('faa') => 1, file_path('faa_ord') => 1);
+ delete $Expect_File{ file_path('fsl') } unless $symlink_exists;
+ %Expect_Name = ();
+
+ %Expect_Dir = ( dir_path('fa') => 1, dir_path('faa') => 1,
+ dir_path('fab') => 1, dir_path('faba') => 1,
+ dir_path('fb') => 1, dir_path('fba') => 1);
+
+ delete @Expect_Dir{ dir_path('fb'), dir_path('fba') } unless $symlink_exists;
+
+ File::Find::find( {wanted => \&wanted_File_Dir_prune, untaint => 1,
+ untaint_pattern => qr|^(.+)$|}, topdir('fa') );
+
+ Check( scalar(keys %Expect_File) == 0 );
+
+
+ # don't untaint at all, should die
+ %Expect_File = ();
+ %Expect_Name = ();
+ %Expect_Dir = ();
+ undef $@;
+ eval {File::Find::find( {wanted => \&simple_wanted}, topdir('fa') );};
+ Check( $@ =~ m|Insecure dependency| );
+ chdir($cwd_untainted);
+
+
+ # untaint pattern doesn't match, should die
+ undef $@;
+
+ eval {File::Find::find( {wanted => \&simple_wanted, untaint => 1,
+ untaint_pattern => qr|^(NO_MATCH)$|},
+ topdir('fa') );};
+
+ Check( $@ =~ m|is still tainted| );
+ chdir($cwd_untainted);
+
+
+ # untaint pattern doesn't match, should die when we chdir to cwd
+ print "# check untaint_skip (No follow)\n";
+ undef $@;
+
+ eval {File::Find::find( {wanted => \&simple_wanted, untaint => 1,
+ untaint_skip => 1, untaint_pattern =>
+ qr|^(NO_MATCH)$|}, topdir('fa') );};
+
+ print "# $@" if $@;
+ #$^D = 8;
+ if ($NonTaintedCwd) {
+ Skip("$^O does not taint cwd");
+ }
+ else {
+ Check( $@ =~ m|insecure cwd| );
+ }
+ chdir($cwd_untainted);
+
+
+ if ( $symlink_exists ) {
+ print "# --- symbolic link tests --- \n";
+ $FastFileTests_OK= 1;
+
+ print "# check untainting (follow)\n";
+
+ # untainting here should work correctly
+ # no_chdir is in effect, hence we use file_path_name to specify the expected paths for %Expect_File
+
+ %Expect_File = (file_path_name('fa') => 1,
+ file_path_name('fa','fa_ord') => 1,
+ file_path_name('fa', 'fsl') => 1,
+ file_path_name('fa', 'fsl', 'fb_ord') => 1,
+ file_path_name('fa', 'fsl', 'fba') => 1,
+ file_path_name('fa', 'fsl', 'fba', 'fba_ord') => 1,
+ file_path_name('fa', 'fab') => 1,
+ file_path_name('fa', 'fab', 'fab_ord') => 1,
+ file_path_name('fa', 'fab', 'faba') => 1,
+ file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1,
+ file_path_name('fa', 'faa') => 1,
+ file_path_name('fa', 'faa', 'faa_ord') => 1);
+
+ %Expect_Name = ();
+
+ %Expect_Dir = (dir_path('fa') => 1,
+ dir_path('fa', 'faa') => 1,
+ dir_path('fa', 'fab') => 1,
+ dir_path('fa', 'fab', 'faba') => 1,
+ dir_path('fb') => 1,
+ dir_path('fb', 'fba') => 1);
+
+ File::Find::find( {wanted => \&wanted_File_Dir, follow_fast => 1,
+ no_chdir => 1, untaint => 1, untaint_pattern =>
+ qr|^(.+)$| }, topdir('fa') );
+
+ Check( scalar(keys %Expect_File) == 0 );
+
+
+ # don't untaint at all, should die
+ undef $@;
+
+ eval {File::Find::find( {wanted => \&simple_wanted, follow => 1},
+ topdir('fa') );};
+
+ Check( $@ =~ m|Insecure dependency| );
+ chdir($cwd_untainted);
+
+ # untaint pattern doesn't match, should die
+ undef $@;
+
+ eval {File::Find::find( {wanted => \&simple_wanted, follow => 1,
+ untaint => 1, untaint_pattern =>
+ qr|^(NO_MATCH)$|}, topdir('fa') );};
+
+ Check( $@ =~ m|is still tainted| );
+ chdir($cwd_untainted);
+
+ # untaint pattern doesn't match, should die when we chdir to cwd
+ print "# check untaint_skip (Follow)\n";
+ undef $@;
+
+ eval {File::Find::find( {wanted => \&simple_wanted, untaint => 1,
+ untaint_skip => 1, untaint_pattern =>
+ qr|^(NO_MATCH)$|}, topdir('fa') );};
+ if ($NonTaintedCwd) {
+ Skip("$^O does not taint cwd");
+ }
+ else {
+ Check( $@ =~ m|insecure cwd| );
+ }
+ chdir($cwd_untainted);
+ }
+
diff -c /dev/null 'perl-5.7.2/lib/File/Path.t'
Index: ./lib/File/Path.t
*** ./lib/File/Path.t Thu Jan 1 02:00:00 1970
--- ./lib/File/Path.t Mon Jul 9 17:10:34 2001
***************
*** 0 ****
--- 1,28 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use File::Path;
+ use strict;
+
+ my $count = 0;
+ use warnings;
+
+ print "1..4\n";
+
+ # first check for stupid permissions second for full, so we clean up
+ # behind ourselves
+ for my $perm (0111,0777) {
+ mkpath("foo/bar");
+ chmod $perm, "foo", "foo/bar";
+
+ print "not " unless -d "foo" && -d "foo/bar";
+ print "ok ", ++$count, "\n";
+
+ rmtree("foo");
+ print "not " if -e "foo";
+ print "ok ", ++$count, "\n";
+ }
diff -c /dev/null 'perl-5.7.2/lib/File/Spec.t'
Index: ./lib/File/Spec.t
*** ./lib/File/Spec.t Thu Jan 1 02:00:00 1970
--- ./lib/File/Spec.t Mon Jul 9 17:10:34 2001
***************
*** 0 ****
--- 1,379 ----
+ #!./perl
+
+ BEGIN {
+ $^O = '';
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # Each element in this array is a single test. Storing them this way makes
+ # maintenance easy, and should be OK since perl should be pretty functional
+ # before these tests are run.
+
+ @tests = (
+ # Function Expected
+ [ "Unix->catfile('a','b','c')", 'a/b/c' ],
+
+ [ "Unix->splitpath('file')", ',,file' ],
+ [ "Unix->splitpath('/d1/d2/d3/')", ',/d1/d2/d3/,' ],
+ [ "Unix->splitpath('d1/d2/d3/')", ',d1/d2/d3/,' ],
+ [ "Unix->splitpath('/d1/d2/d3/.')", ',/d1/d2/d3/.,' ],
+ [ "Unix->splitpath('/d1/d2/d3/..')", ',/d1/d2/d3/..,' ],
+ [ "Unix->splitpath('/d1/d2/d3/.file')", ',/d1/d2/d3/,.file' ],
+ [ "Unix->splitpath('d1/d2/d3/file')", ',d1/d2/d3/,file' ],
+ [ "Unix->splitpath('/../../d1/')", ',/../../d1/,' ],
+ [ "Unix->splitpath('/././d1/')", ',/././d1/,' ],
+
+ [ "Unix->catpath('','','file')", 'file' ],
+ [ "Unix->catpath('','/d1/d2/d3/','')", '/d1/d2/d3/' ],
+ [ "Unix->catpath('','d1/d2/d3/','')", 'd1/d2/d3/' ],
+ [ "Unix->catpath('','/d1/d2/d3/.','')", '/d1/d2/d3/.' ],
+ [ "Unix->catpath('','/d1/d2/d3/..','')", '/d1/d2/d3/..' ],
+ [ "Unix->catpath('','/d1/d2/d3/','.file')", '/d1/d2/d3/.file' ],
+ [ "Unix->catpath('','d1/d2/d3/','file')", 'd1/d2/d3/file' ],
+ [ "Unix->catpath('','/../../d1/','')", '/../../d1/' ],
+ [ "Unix->catpath('','/././d1/','')", '/././d1/' ],
+ [ "Unix->catpath('d1','d2/d3/','')", 'd2/d3/' ],
+ [ "Unix->catpath('d1','d2','d3/')", 'd2/d3/' ],
+
+ [ "Unix->splitdir('')", '' ],
+ [ "Unix->splitdir('/d1/d2/d3/')", ',d1,d2,d3,' ],
+ [ "Unix->splitdir('d1/d2/d3/')", 'd1,d2,d3,' ],
+ [ "Unix->splitdir('/d1/d2/d3')", ',d1,d2,d3' ],
+ [ "Unix->splitdir('d1/d2/d3')", 'd1,d2,d3' ],
+
+ [ "Unix->catdir()", '' ],
+ [ "Unix->catdir('/')", '/' ],
+ [ "Unix->catdir('','d1','d2','d3','')", '/d1/d2/d3' ],
+ [ "Unix->catdir('d1','d2','d3','')", 'd1/d2/d3' ],
+ [ "Unix->catdir('','d1','d2','d3')", '/d1/d2/d3' ],
+ [ "Unix->catdir('d1','d2','d3')", 'd1/d2/d3' ],
+
+ [ "Unix->catfile('a','b','c')", 'a/b/c' ],
+
+ [ "Unix->canonpath('')", '' ],
+ [ "Unix->canonpath('///../../..//./././a//b/.././c/././')", '/a/b/../c' ],
+ [ "Unix->canonpath('/.')", '/.' ],
+
+ [ "Unix->abs2rel('/t1/t2/t3','/t1/t2/t3')", '' ],
+ [ "Unix->abs2rel('/t1/t2/t4','/t1/t2/t3')", '../t4' ],
+ [ "Unix->abs2rel('/t1/t2','/t1/t2/t3')", '..' ],
+ [ "Unix->abs2rel('/t1/t2/t3/t4','/t1/t2/t3')", 't4' ],
+ [ "Unix->abs2rel('/t4/t5/t6','/t1/t2/t3')", '../../../t4/t5/t6' ],
+ #[ "Unix->abs2rel('../t4','/t1/t2/t3')", '../t4' ],
+ [ "Unix->abs2rel('/','/t1/t2/t3')", '../../..' ],
+ [ "Unix->abs2rel('///','/t1/t2/t3')", '../../..' ],
+ [ "Unix->abs2rel('/.','/t1/t2/t3')", '../../../.' ],
+ [ "Unix->abs2rel('/./','/t1/t2/t3')", '../../..' ],
+ #[ "Unix->abs2rel('../t4','/t1/t2/t3')", '../t4' ],
+
+ [ "Unix->rel2abs('t4','/t1/t2/t3')", '/t1/t2/t3/t4' ],
+ [ "Unix->rel2abs('t4/t5','/t1/t2/t3')", '/t1/t2/t3/t4/t5' ],
+ [ "Unix->rel2abs('.','/t1/t2/t3')", '/t1/t2/t3' ],
+ [ "Unix->rel2abs('..','/t1/t2/t3')", '/t1/t2/t3/..' ],
+ [ "Unix->rel2abs('../t4','/t1/t2/t3')", '/t1/t2/t3/../t4' ],
+ [ "Unix->rel2abs('/t1','/t1/t2/t3')", '/t1' ],
+
+ [ "Win32->splitpath('file')", ',,file' ],
+ [ "Win32->splitpath('\\d1/d2\\d3/')", ',\\d1/d2\\d3/,' ],
+ [ "Win32->splitpath('d1/d2\\d3/')", ',d1/d2\\d3/,' ],
+ [ "Win32->splitpath('\\d1/d2\\d3/.')", ',\\d1/d2\\d3/.,' ],
+ [ "Win32->splitpath('\\d1/d2\\d3/..')", ',\\d1/d2\\d3/..,' ],
+ [ "Win32->splitpath('\\d1/d2\\d3/.file')", ',\\d1/d2\\d3/,.file' ],
+ [ "Win32->splitpath('\\d1/d2\\d3/file')", ',\\d1/d2\\d3/,file' ],
+ [ "Win32->splitpath('d1/d2\\d3/file')", ',d1/d2\\d3/,file' ],
+ [ "Win32->splitpath('C:\\d1/d2\\d3/')", 'C:,\\d1/d2\\d3/,' ],
+ [ "Win32->splitpath('C:d1/d2\\d3/')", 'C:,d1/d2\\d3/,' ],
+ [ "Win32->splitpath('C:\\d1/d2\\d3/file')", 'C:,\\d1/d2\\d3/,file' ],
+ [ "Win32->splitpath('C:d1/d2\\d3/file')", 'C:,d1/d2\\d3/,file' ],
+ [ "Win32->splitpath('C:\\../d2\\d3/file')", 'C:,\\../d2\\d3/,file' ],
+ [ "Win32->splitpath('C:../d2\\d3/file')", 'C:,../d2\\d3/,file' ],
+ [ "Win32->splitpath('\\../..\\d1/')", ',\\../..\\d1/,' ],
+ [ "Win32->splitpath('\\./.\\d1/')", ',\\./.\\d1/,' ],
+ [ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/')", '\\\\node\\share,\\d1/d2\\d3/,' ],
+ [ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/file')", '\\\\node\\share,\\d1/d2\\d3/,file' ],
+ [ "Win32->splitpath('\\\\node\\share\\d1/d2\\file')", '\\\\node\\share,\\d1/d2\\,file' ],
+ [ "Win32->splitpath('file',1)", ',file,' ],
+ [ "Win32->splitpath('\\d1/d2\\d3/',1)", ',\\d1/d2\\d3/,' ],
+ [ "Win32->splitpath('d1/d2\\d3/',1)", ',d1/d2\\d3/,' ],
+ [ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/',1)", '\\\\node\\share,\\d1/d2\\d3/,' ],
+
+ [ "Win32->catpath('','','file')", 'file' ],
+ [ "Win32->catpath('','\\d1/d2\\d3/','')", '\\d1/d2\\d3/' ],
+ [ "Win32->catpath('','d1/d2\\d3/','')", 'd1/d2\\d3/' ],
+ [ "Win32->catpath('','\\d1/d2\\d3/.','')", '\\d1/d2\\d3/.' ],
+ [ "Win32->catpath('','\\d1/d2\\d3/..','')", '\\d1/d2\\d3/..' ],
+ [ "Win32->catpath('','\\d1/d2\\d3/','.file')", '\\d1/d2\\d3/.file' ],
+ [ "Win32->catpath('','\\d1/d2\\d3/','file')", '\\d1/d2\\d3/file' ],
+ [ "Win32->catpath('','d1/d2\\d3/','file')", 'd1/d2\\d3/file' ],
+ [ "Win32->catpath('C:','\\d1/d2\\d3/','')", 'C:\\d1/d2\\d3/' ],
+ [ "Win32->catpath('C:','d1/d2\\d3/','')", 'C:d1/d2\\d3/' ],
+ [ "Win32->catpath('C:','\\d1/d2\\d3/','file')", 'C:\\d1/d2\\d3/file' ],
+ [ "Win32->catpath('C:','d1/d2\\d3/','file')", 'C:d1/d2\\d3/file' ],
+ [ "Win32->catpath('C:','\\../d2\\d3/','file')", 'C:\\../d2\\d3/file' ],
+ [ "Win32->catpath('C:','../d2\\d3/','file')", 'C:../d2\\d3/file' ],
+ [ "Win32->catpath('','\\../..\\d1/','')", '\\../..\\d1/' ],
+ [ "Win32->catpath('','\\./.\\d1/','')", '\\./.\\d1/' ],
+ [ "Win32->catpath('\\\\node\\share','\\d1/d2\\d3/','')", '\\\\node\\share\\d1/d2\\d3/' ],
+ [ "Win32->catpath('\\\\node\\share','\\d1/d2\\d3/','file')", '\\\\node\\share\\d1/d2\\d3/file' ],
+ [ "Win32->catpath('\\\\node\\share','\\d1/d2\\','file')", '\\\\node\\share\\d1/d2\\file' ],
+
+ [ "Win32->splitdir('')", '' ],
+ [ "Win32->splitdir('\\d1/d2\\d3/')", ',d1,d2,d3,' ],
+ [ "Win32->splitdir('d1/d2\\d3/')", 'd1,d2,d3,' ],
+ [ "Win32->splitdir('\\d1/d2\\d3')", ',d1,d2,d3' ],
+ [ "Win32->splitdir('d1/d2\\d3')", 'd1,d2,d3' ],
+
+ [ "Win32->catdir()", '' ],
+ [ "Win32->catdir('')", '\\' ],
+ [ "Win32->catdir('/')", '\\' ],
+ [ "Win32->catdir('//d1','d2')", '\\\\d1\\d2' ],
+ [ "Win32->catdir('','/d1','d2')", '\\\\d1\\d2' ],
+ [ "Win32->catdir('','','/d1','d2')", '\\\\\\d1\\d2' ],
+ [ "Win32->catdir('','//d1','d2')", '\\\\\\d1\\d2' ],
+ [ "Win32->catdir('','','//d1','d2')", '\\\\\\\\d1\\d2' ],
+ [ "Win32->catdir('','d1','','d2','')", '\\d1\\d2' ],
+ [ "Win32->catdir('','d1','d2','d3','')", '\\d1\\d2\\d3' ],
+ [ "Win32->catdir('d1','d2','d3','')", 'd1\\d2\\d3' ],
+ [ "Win32->catdir('','d1','d2','d3')", '\\d1\\d2\\d3' ],
+ [ "Win32->catdir('d1','d2','d3')", 'd1\\d2\\d3' ],
+ [ "Win32->catdir('A:/d1','d2','d3')", 'A:\\d1\\d2\\d3' ],
+ [ "Win32->catdir('A:/d1','d2','d3','')", 'A:\\d1\\d2\\d3' ],
+ #[ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\d2\\d3' ],
+ [ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\B:\\d2\\d3' ],
+ [ "Win32->catdir('A:/')", 'A:\\' ],
+
+ [ "Win32->catfile('a','b','c')", 'a\\b\\c' ],
+
+ [ "Win32->canonpath('')", '' ],
+ [ "Win32->canonpath('a:')", 'A:' ],
+ [ "Win32->canonpath('A:f')", 'A:f' ],
+ [ "Win32->canonpath('//a\\b//c')", '\\\\a\\b\\c' ],
+ [ "Win32->canonpath('/a/..../c')", '\\a\\....\\c' ],
+ [ "Win32->canonpath('//a/b\\c')", '\\\\a\\b\\c' ],
+ [ "Win32->canonpath('////')", '\\\\\\' ],
+ [ "Win32->canonpath('//')", '\\' ],
+ [ "Win32->canonpath('/.')", '\\.' ],
+ [ "Win32->canonpath('//a/b/../../c')", '\\\\a\\b\\..\\..\\c' ],
+ [ "Win32->canonpath('//a/../../c')", '\\\\a\\..\\..\\c' ],
+
+ [ "Win32->abs2rel('/t1/t2/t3','/t1/t2/t3')", '' ],
+ [ "Win32->abs2rel('/t1/t2/t4','/t1/t2/t3')", '..\\t4' ],
+ [ "Win32->abs2rel('/t1/t2','/t1/t2/t3')", '..' ],
+ [ "Win32->abs2rel('/t1/t2/t3/t4','/t1/t2/t3')", 't4' ],
+ [ "Win32->abs2rel('/t4/t5/t6','/t1/t2/t3')", '..\\..\\..\\t4\\t5\\t6' ],
+ #[ "Win32->abs2rel('../t4','/t1/t2/t3')", '\\t1\\t2\\t3\\..\\t4' ],
+ [ "Win32->abs2rel('/','/t1/t2/t3')", '..\\..\\..' ],
+ [ "Win32->abs2rel('///','/t1/t2/t3')", '..\\..\\..' ],
+ [ "Win32->abs2rel('/.','/t1/t2/t3')", '..\\..\\..\\.' ],
+ [ "Win32->abs2rel('/./','/t1/t2/t3')", '..\\..\\..' ],
+ [ "Win32->abs2rel('\\\\a/t1/t2/t4','/t2/t3')", '..\\t4' ],
+ [ "Win32->abs2rel('//a/t1/t2/t4','/t2/t3')", '..\\t4' ],
+
+ [ "Win32->rel2abs('temp','C:/')", 'C:\\temp' ],
+ [ "Win32->rel2abs('temp','C:/a')", 'C:\\a\\temp' ],
+ [ "Win32->rel2abs('temp','C:/a/')", 'C:\\a\\temp' ],
+ [ "Win32->rel2abs('../','C:/')", 'C:\\..' ],
+ [ "Win32->rel2abs('../','C:/a')", 'C:\\a\\..' ],
+ [ "Win32->rel2abs('temp','//prague_main/work/')", '\\\\prague_main\\work\\temp' ],
+ [ "Win32->rel2abs('../temp','//prague_main/work/')", '\\\\prague_main\\work\\..\\temp' ],
+ [ "Win32->rel2abs('temp','//prague_main/work')", '\\\\prague_main\\work\\temp' ],
+ [ "Win32->rel2abs('../','//prague_main/work')", '\\\\prague_main\\work\\..' ],
+
+ [ "VMS->splitpath('file')", ',,file' ],
+ [ "VMS->splitpath('[d1.d2.d3]')", ',[d1.d2.d3],' ],
+ [ "VMS->splitpath('[.d1.d2.d3]')", ',[.d1.d2.d3],' ],
+ [ "VMS->splitpath('[d1.d2.d3]file')", ',[d1.d2.d3],file' ],
+ [ "VMS->splitpath('d1/d2/d3/file')", ',[.d1.d2.d3],file' ],
+ [ "VMS->splitpath('/d1/d2/d3/file')", 'd1:,[d2.d3],file' ],
+ [ "VMS->splitpath('[.d1.d2.d3]file')", ',[.d1.d2.d3],file' ],
+ [ "VMS->splitpath('node::volume:[d1.d2.d3]')", 'node::volume:,[d1.d2.d3],' ],
+ [ "VMS->splitpath('node::volume:[d1.d2.d3]file')", 'node::volume:,[d1.d2.d3],file' ],
+ [ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]')", 'node"access_spec"::volume:,[d1.d2.d3],' ],
+ [ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]file')", 'node"access_spec"::volume:,[d1.d2.d3],file' ],
+
+ [ "VMS->catpath('','','file')", 'file' ],
+ [ "VMS->catpath('','[d1.d2.d3]','')", '[d1.d2.d3]' ],
+ [ "VMS->catpath('','[.d1.d2.d3]','')", '[.d1.d2.d3]' ],
+ [ "VMS->catpath('','[d1.d2.d3]','file')", '[d1.d2.d3]file' ],
+ [ "VMS->catpath('','[.d1.d2.d3]','file')", '[.d1.d2.d3]file' ],
+ [ "VMS->catpath('','d1/d2/d3','file')", '[.d1.d2.d3]file' ],
+ [ "VMS->catpath('v','d1/d2/d3','file')", 'v:[.d1.d2.d3]file' ],
+ [ "VMS->catpath('node::volume:','[d1.d2.d3]','')", 'node::volume:[d1.d2.d3]' ],
+ [ "VMS->catpath('node::volume:','[d1.d2.d3]','file')", 'node::volume:[d1.d2.d3]file' ],
+ [ "VMS->catpath('node\"access_spec\"::volume:','[d1.d2.d3]','')", 'node"access_spec"::volume:[d1.d2.d3]' ],
+ [ "VMS->catpath('node\"access_spec\"::volume:','[d1.d2.d3]','file')", 'node"access_spec"::volume:[d1.d2.d3]file' ],
+
+ [ "VMS->canonpath('')", '' ],
+ [ "VMS->canonpath('volume:[d1]file')", 'volume:[d1]file' ],
+ [ "VMS->canonpath('volume:[d1.-.d2.][d3.d4.-]')", 'volume:[d2.d3]' ],
+ [ "VMS->canonpath('volume:[000000.d1]d2.dir;1')", 'volume:[d1]d2.dir;1' ],
+
+ [ "VMS->splitdir('')", '' ],
+ [ "VMS->splitdir('[]')", '' ],
+ [ "VMS->splitdir('d1.d2.d3')", 'd1,d2,d3' ],
+ [ "VMS->splitdir('[d1.d2.d3]')", 'd1,d2,d3' ],
+ [ "VMS->splitdir('.d1.d2.d3')", ',d1,d2,d3' ],
+ [ "VMS->splitdir('[.d1.d2.d3]')", ',d1,d2,d3' ],
+ [ "VMS->splitdir('.-.d2.d3')", ',-,d2,d3' ],
+ [ "VMS->splitdir('[.-.d2.d3]')", ',-,d2,d3' ],
+
+ [ "VMS->catdir('')", '' ],
+ [ "VMS->catdir('d1','d2','d3')", '[.d1.d2.d3]' ],
+ [ "VMS->catdir('d1','d2/','d3')", '[.d1.d2.d3]' ],
+ [ "VMS->catdir('','d1','d2','d3')", '[.d1.d2.d3]' ],
+ [ "VMS->catdir('','-','d2','d3')", '[-.d2.d3]' ],
+ [ "VMS->catdir('','-','','d3')", '[-.d3]' ],
+ [ "VMS->catdir('dir.dir','d2.dir','d3.dir')", '[.dir.d2.d3]' ],
+ [ "VMS->catdir('[.name]')", '[.name]' ],
+ [ "VMS->catdir('[.name]','[.name]')", '[.name.name]'],
+
+ [ "VMS->abs2rel('node::volume:[t1.t2.t3]','[t1.t2.t3]')", '' ],
+ [ "VMS->abs2rel('node::volume:[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ],
+ [ "VMS->abs2rel('[t1.t2.t3]','[t1.t2.t3]')", '' ],
+ [ "VMS->abs2rel('[t1.t2.t3]file','[t1.t2.t3]')", 'file' ],
+ [ "VMS->abs2rel('[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ],
+ [ "VMS->abs2rel('[t1.t2]file','[t1.t2.t3]')", '[-]file' ],
+ [ "VMS->abs2rel('[t1.t2.t3.t4]','[t1.t2.t3]')", '[t4]' ],
+ [ "VMS->abs2rel('[t4.t5.t6]','[t1.t2.t3]')", '[---.t4.t5.t6]' ],
+ [ "VMS->abs2rel('[000000]','[t1.t2.t3]')", '[---.000000]' ],
+ [ "VMS->abs2rel('a:[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ],
+ [ "VMS->abs2rel('[a.-.b.c.-]','[t1.t2.t3]')", '[---.b]' ],
+
+ [ "VMS->rel2abs('[.t4]','[t1.t2.t3]')", '[t1.t2.t3.t4]' ],
+ [ "VMS->rel2abs('[.t4.t5]','[t1.t2.t3]')", '[t1.t2.t3.t4.t5]' ],
+ [ "VMS->rel2abs('[]','[t1.t2.t3]')", '[t1.t2.t3]' ],
+ [ "VMS->rel2abs('[-]','[t1.t2.t3]')", '[t1.t2]' ],
+ [ "VMS->rel2abs('[-.t4]','[t1.t2.t3]')", '[t1.t2.t4]' ],
+ [ "VMS->rel2abs('[t1]','[t1.t2.t3]')", '[t1]' ],
+
+ [ "OS2->catdir('A:/d1','B:/d2','d3','')", 'A:/d1/B:/d2/d3' ],
+ [ "OS2->catfile('a','b','c')", 'a/b/c' ],
+
+ [ "Mac->splitpath('file')", ',,file' ],
+ [ "Mac->splitpath(':file')", ',:,file' ],
+ [ "Mac->splitpath(':d1',1)", ',:d1:,' ],
+ [ "Mac->splitpath('d1',1)", 'd1:,,' ],
+ [ "Mac->splitpath('d1:d2:d3:')", 'd1:,d2:d3:,' ],
+ [ "Mac->splitpath('d1:d2:d3',1)", 'd1:,d2:d3:,' ],
+ [ "Mac->splitpath(':d1:d2:d3:')", ',:d1:d2:d3:,' ],
+ [ "Mac->splitpath(':d1:d2:d3:',1)", ',:d1:d2:d3:,' ],
+ [ "Mac->splitpath('d1:d2:d3:file')", 'd1:,d2:d3:,file' ],
+ [ "Mac->splitpath('d1:d2:d3',1)", 'd1:,d2:d3:,' ],
+
+ [ "Mac->catdir('')", ':' ],
+ [ "Mac->catdir('d1','d2','d3')", 'd1:d2:d3:' ],
+ [ "Mac->catdir('d1','d2/','d3')", 'd1:d2/:d3:' ],
+ [ "Mac->catdir('','d1','d2','d3')", ':d1:d2:d3:' ],
+ [ "Mac->catdir('','','d2','d3')", '::d2:d3:' ],
+ [ "Mac->catdir('','','','d3')", ':::d3:' ],
+ [ "Mac->catdir(':name')", ':name:' ],
+ [ "Mac->catdir(':name',':name')", ':name:name:' ],
+
+ [ "Mac->catfile('a','b','c')", 'a:b:c' ],
+
+ [ "Mac->canonpath('')", '' ],
+ [ "Mac->canonpath(':')", ':' ],
+ [ "Mac->canonpath('::')", '::' ],
+ [ "Mac->canonpath('a::')", 'a::' ],
+ [ "Mac->canonpath(':a::')", ':a::' ],
+
+ [ "Mac->abs2rel('t1:t2:t3','t1:t2:t3')", ':' ],
+ [ "Mac->abs2rel('t1:t2','t1:t2:t3')", '::' ],
+ [ "Mac->abs2rel('t1:t4','t1:t2:t3')", ':::t4' ],
+ [ "Mac->abs2rel('t1:t2:t4','t1:t2:t3')", '::t4' ],
+ [ "Mac->abs2rel('t1:t2:t3:t4','t1:t2:t3')", ':t4' ],
+ [ "Mac->abs2rel('t4:t5:t6','t1:t2:t3')", '::::t4:t5:t6' ],
+ [ "Mac->abs2rel('t1','t1:t2:t3')", ':::' ],
+
+ [ "Mac->rel2abs(':t4','t1:t2:t3')", 't1:t2:t3:t4' ],
+ [ "Mac->rel2abs(':t4:t5','t1:t2:t3')", 't1:t2:t3:t4:t5' ],
+ [ "Mac->rel2abs('','t1:t2:t3')", '' ],
+ [ "Mac->rel2abs('::','t1:t2:t3')", 't1:t2:t3::' ],
+ [ "Mac->rel2abs('::t4','t1:t2:t3')", 't1:t2:t3::t4' ],
+ [ "Mac->rel2abs('t1','t1:t2:t3')", 't1' ],
+ ) ;
+
+ # Grab all of the plain routines from File::Spec
+ use File::Spec @File::Spec::EXPORT_OK ;
+
+ require File::Spec::Unix ;
+ require File::Spec::Win32 ;
+
+ eval {
+ require VMS::Filespec ;
+ } ;
+
+ my $skip_exception = "Install VMS::Filespec (from vms/ext)" ;
+
+ if ( $@ ) {
+ # Not pretty, but it allows testing of things not implemented soley
+ # on VMS. It might be better to change File::Spec::VMS to do this,
+ # making it more usable when running on (say) Unix but working with
+ # VMS paths.
+ eval qq-
+ sub File::Spec::VMS::vmsify { die "$skip_exception" }
+ sub File::Spec::VMS::unixify { die "$skip_exception" }
+ sub File::Spec::VMS::vmspath { die "$skip_exception" }
+ - ;
+ $INC{"VMS/Filespec.pm"} = 1 ;
+ }
+ require File::Spec::VMS ;
+
+ require File::Spec::OS2 ;
+ require File::Spec::Mac ;
+
+ print "1..", scalar( @tests ), "\n" ;
+
+ my $current_test= 1 ;
+
+ # Test out the class methods
+ for ( @tests ) {
+ tryfunc( @$_ ) ;
+ }
+
+
+
+ #
+ # Tries a named function with the given args and compares the result against
+ # an expected result. Works with functions that return scalars or arrays.
+ #
+ sub tryfunc {
+ my $function = shift ;
+ my $expected = shift ;
+ my $platform = shift ;
+
+ if ($platform && $^O ne $platform) {
+ print "ok $current_test # skipped: $function\n" ;
+ ++$current_test ;
+ return;
+ }
+
+ $function =~ s#\\#\\\\#g ;
+
+ my $got ;
+ if ( $function =~ /^[^\$].*->/ ) {
+ $got = eval( "join( ',', File::Spec::$function )" ) ;
+ }
+ else {
+ $got = eval( "join( ',', $function )" ) ;
+ }
+
+ if ( $@ ) {
+ if ( substr( $@, 0, length $skip_exception ) eq $skip_exception ) {
+ chomp $@ ;
+ print "ok $current_test # skip $function: $@\n" ;
+ }
+ else {
+ chomp $@ ;
+ print "not ok $current_test # $function: $@\n" ;
+ }
+ }
+ elsif ( !defined( $got ) || $got ne $expected ) {
+ print "not ok $current_test # $function: got '$got', expected '$expected'\n" ;
+ }
+ else {
+ print "ok $current_test # $function\n" ;
+ }
+ ++$current_test ;
+ }
diff -c /dev/null 'perl-5.7.2/lib/File/Spec/Functions.t'
Index: ./lib/File/Spec/Functions.t
*** ./lib/File/Spec/Functions.t Thu Jan 1 02:00:00 1970
--- ./lib/File/Spec/Functions.t Mon Jul 9 17:10:34 2001
***************
*** 0 ****
--- 1,17 ----
+ #!./perl
+
+ BEGIN {
+ $^O = '';
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ print "1..1\n";
+
+ use File::Spec::Functions;
+
+ if (catfile('a','b','c') eq 'a/b/c') {
+ print "ok 1\n";
+ } else {
+ print "not ok 1\n";
+ }
diff -c 'perl-5.7.1/lib/File/Spec/Unix.pm' 'perl-5.7.2/lib/File/Spec/Unix.pm'
Index: ./lib/File/Spec/Unix.pm
*** ./lib/File/Spec/Unix.pm Tue Mar 6 04:05:30 2001
--- ./lib/File/Spec/Unix.pm Mon Jul 9 17:10:34 2001
***************
*** 34,45 ****
sub canonpath {
my ($self,$path) = @_;
$path =~ s|/+|/|g unless($^O eq 'cygwin'); # xx////xx -> xx/xx
$path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx
$path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx
$path =~ s|^/(\.\./)+|/|s; # /../../xx -> xx
$path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx
! return $path;
}
=item catdir
--- 34,51 ----
sub canonpath {
my ($self,$path) = @_;
+
+ # Handle POSIX-style node names beginning with double slash
+ my $node = '';
+ if ( $^O =~ m/^(?:qnx|nto)$/ && $path =~ s:^(//[^/]+)(/|\z):/:s ) {
+ $node = $1;
+ }
$path =~ s|/+|/|g unless($^O eq 'cygwin'); # xx////xx -> xx/xx
$path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx
$path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx
$path =~ s|^/(\.\./)+|/|s; # /../../xx -> xx
$path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx
! return "$node$path";
}
=item catdir
diff -c 'perl-5.7.1/lib/File/Spec/VMS.pm' 'perl-5.7.2/lib/File/Spec/VMS.pm'
Index: ./lib/File/Spec/VMS.pm
*** ./lib/File/Spec/VMS.pm Fri Mar 16 04:54:49 2001
--- ./lib/File/Spec/VMS.pm Mon Jul 9 17:10:34 2001
***************
*** 157,163 ****
}
else {
$path =~ s-\]\[--g; $path =~ s/><//g; # foo.][bar ==> foo.bar
! $path =~ s/([\[<])000000\./$1/; # [000000.foo ==> foo
1 while $path =~ s{([\[<-])\.-}{$1-}; # [.-.- ==> [--
$path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/; # bar.foo.-] ==> bar]
$path =~ s/([\[<])(-+)/$1 . "\cx" x length($2)/e; # encode leading '-'s
--- 157,164 ----
}
else {
$path =~ s-\]\[--g; $path =~ s/><//g; # foo.][bar ==> foo.bar
! $path =~ s/([\[<])000000\./$1/; # [000000.foo ==> [foo
! $path =~ s/([^-]+)\.000000([\]\>])/$1$2/; # foo.000000] ==> foo]
1 while $path =~ s{([\[<-])\.-}{$1-}; # [.-.- ==> [--
$path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/; # bar.foo.-] ==> bar]
$path =~ s/([\[<])(-+)/$1 . "\cx" x length($2)/e; # encode leading '-'s
diff -c /dev/null 'perl-5.7.2/lib/File/Temp/t/mktemp.t'
Index: ./lib/File/Temp/t/mktemp.t
*** ./lib/File/Temp/t/mktemp.t Thu Jan 1 02:00:00 1970
--- ./lib/File/Temp/t/mktemp.t Mon Jul 9 17:10:35 2001
***************
*** 0 ****
--- 1,115 ----
+ #!/usr/bin/perl -w
+
+ # Test for mktemp family of commands in File::Temp
+ # Use STANDARD safe level for these tests
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Test; import Test;
+ plan(tests => 9);
+ }
+
+ use strict;
+
+ use File::Spec;
+ use File::Path;
+ use File::Temp qw/ :mktemp unlink0 /;
+ use FileHandle;
+
+ ok(1);
+
+ # MKSTEMP - test
+
+ # Create file in temp directory
+ my $template = File::Spec->catfile(File::Spec->tmpdir, 'wowserXXXX');
+
+ (my $fh, $template) = mkstemp($template);
+
+ print "# MKSTEMP: FH is $fh File is $template fileno=".fileno($fh)."\n";
+ # Check if the file exists
+ ok( (-e $template) );
+
+ # Autoflush
+ $fh->autoflush(1) if $] >= 5.006;
+
+ # Try printing something to the file
+ my $string = "woohoo\n";
+ print $fh $string;
+
+ # rewind the file
+ ok(seek( $fh, 0, 0));
+
+ # Read from the file
+ my $line = <$fh>;
+
+ # compare with previous string
+ ok($string, $line);
+
+ # Tidy up
+ # This test fails on Windows NT since it seems that the size returned by
+ # stat(filehandle) does not always equal the size of the stat(filename)
+ # This must be due to caching. In particular this test writes 7 bytes
+ # to the file which are not recognised by stat(filename)
+ # Simply waiting 3 seconds seems to be enough for the system to update
+
+ if ($^O eq 'MSWin32') {
+ sleep 3;
+ }
+ my $status = unlink0($fh, $template);
+ if ($status) {
+ ok( $status );
+ } else {
+ skip("Skip test failed probably due to \$TMPDIR being on NFS",1);
+ }
+
+ # MKSTEMPS
+ # File with suffix. This is created in the current directory so
+ # may be problematic on NFS
+
+ $template = "suffixXXXXXX";
+ my $suffix = ".dat";
+
+ ($fh, my $fname) = mkstemps($template, $suffix);
+
+ print "# MKSTEMPS: File is $template -> $fname fileno=".fileno($fh)."\n";
+ # Check if the file exists
+ ok( (-e $fname) );
+
+ # This fails if you are running on NFS
+ # If this test fails simply skip it rather than doing a hard failure
+ $status = unlink0($fh, $fname);
+
+ if ($status) {
+ ok($status);
+ } else {
+ skip("Skip test failed probably due to cwd being on NFS",1)
+ }
+
+ # MKDTEMP
+ # Temp directory
+
+ $template = File::Spec->catdir(File::Spec->tmpdir, 'tmpdirXXXXXX');
+
+ my $tmpdir = mkdtemp($template);
+
+ print "# MKDTEMP: Name is $tmpdir from template $template\n";
+
+ ok( (-d $tmpdir ) );
+
+ # Need to tidy up after myself
+ rmtree($tmpdir);
+
+ # MKTEMP
+ # Just a filename, not opened
+
+ $template = File::Spec->catfile(File::Spec->tmpdir, 'mytestXXXXXX');
+
+ my $tmpfile = mktemp($template);
+
+ print "# MKTEMP: Tempfile is $template -> $tmpfile\n";
+
+ # Okay if template no longer has XXXXX in
+
+
+ ok( ($tmpfile !~ /XXXXX$/) );
diff -c /dev/null 'perl-5.7.2/lib/File/Temp/t/posix.t'
Index: ./lib/File/Temp/t/posix.t
*** ./lib/File/Temp/t/posix.t Thu Jan 1 02:00:00 1970
--- ./lib/File/Temp/t/posix.t Mon Jul 9 17:10:35 2001
***************
*** 0 ****
--- 1,83 ----
+ #!/usr/bin/perl -w
+ # Test for File::Temp - POSIX functions
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Test; import Test;
+ plan(tests => 7);
+ }
+
+ use strict;
+
+ use File::Temp qw/ :POSIX unlink0 /;
+ use FileHandle;
+
+ ok(1);
+
+ # TMPNAM - scalar
+
+ print "# TMPNAM: in a scalar context: \n";
+ my $tmpnam = tmpnam();
+
+ # simply check that the file does not exist
+ # Not a 100% water tight test though if another program
+ # has managed to create one in the meantime.
+ ok( !(-e $tmpnam ));
+
+ print "# TMPNAM file name: $tmpnam\n";
+
+ # TMPNAM list context
+ # Not strict posix behaviour
+ (my $fh, $tmpnam) = tmpnam();
+
+ print "# TMPNAM: in list context: $fh $tmpnam\n";
+
+ # File is opened - make sure it exists
+ ok( (-e $tmpnam ));
+
+ # Unlink it - a possible NFS issue again if TMPDIR is not a local disk
+ my $status = unlink0($fh, $tmpnam);
+ if ($status) {
+ ok( $status );
+ } else {
+ skip("Skip test failed probably due to \$TMPDIR being on NFS",1);
+ }
+
+ # TMPFILE
+
+ $fh = tmpfile();
+
+ if (defined $fh) {
+ ok( $fh );
+ print "# TMPFILE: tmpfile got FH $fh\n";
+
+ $fh->autoflush(1) if $] >= 5.006;
+
+ # print something to it
+ my $original = "Hello a test\n";
+ print "# TMPFILE: Wrote line: $original";
+ print $fh $original
+ or die "Error printing to tempfile\n";
+
+ # rewind it
+ ok( seek($fh,0,0) );
+
+ # Read from it
+ my $line = <$fh>;
+
+ print "# TMPFILE: Read line: $line";
+ ok( $original, $line);
+
+ close($fh);
+
+ } else {
+ # Skip all the remaining tests
+ foreach (1..3) {
+ skip("Skip test failed probably due to \$TMPDIR being on NFS",1);
+ }
+ }
+
+
+
+
diff -c /dev/null 'perl-5.7.2/lib/File/Temp/t/security.t'
Index: ./lib/File/Temp/t/security.t
*** ./lib/File/Temp/t/security.t Thu Jan 1 02:00:00 1970
--- ./lib/File/Temp/t/security.t Mon Jul 9 17:10:35 2001
***************
*** 0 ****
--- 1,140 ----
+ #!/usr/bin/perl -w
+ # Test for File::Temp - Security levels
+
+ # Some of the security checking will not work on all platforms
+ # Test a simple open in the cwd and tmpdir foreach of the
+ # security levels
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Test; import Test;
+ plan(tests => 13);
+ }
+
+ use strict;
+ use File::Spec;
+
+ # Set up END block - this needs to happen before we load
+ # File::Temp since this END block must be evaluated after the
+ # END block configured by File::Temp
+ my @files; # list of files to remove
+ END { foreach (@files) { ok( !(-e $_) )} }
+
+ use File::Temp qw/ tempfile unlink0 /;
+ ok(1);
+
+ # The high security tests must currently be skipped on some platforms
+ my $skipplat = ( (
+ # No sticky bits.
+ $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'os2' || $^O eq 'dos' || $^O eq 'mpeix'
+ ) ? 1 : 0 );
+
+ # Can not run high security tests in perls before 5.6.0
+ my $skipperl = ($] < 5.006 ? 1 : 0 );
+
+ # Determine whether we need to skip things and why
+ my $skip = 0;
+ if ($skipplat) {
+ $skip = "Skip Not supported on this platform";
+ } elsif ($skipperl) {
+ $skip = "Skip Perl version must be v5.6.0 for these tests";
+
+ }
+
+ print "# We will be skipping some tests : $skip\n" if $skip;
+
+ # start off with basic checking
+
+ File::Temp->safe_level( File::Temp::STANDARD );
+
+ print "# Testing with STANDARD security...\n";
+
+ &test_security(0);
+
+ # Try medium
+
+ File::Temp->safe_level( File::Temp::MEDIUM )
+ unless $skip;
+
+ print "# Testing with MEDIUM security...\n";
+
+ # Now we need to start skipping tests
+ &test_security($skip);
+
+ # Try HIGH
+
+ File::Temp->safe_level( File::Temp::HIGH )
+ unless $skip;
+
+ print "# Testing with HIGH security...\n";
+
+ &test_security($skip);
+
+ exit;
+
+ # Subroutine to open two temporary files.
+ # one is opened in the current dir and the other in the temp dir
+
+ sub test_security {
+
+ # Read in the skip flag
+ my $skip = shift;
+
+ # If we are skipping we need to simply fake the correct number
+ # of tests -- we dont use skip since the tempfile() commands will
+ # fail with MEDIUM/HIGH security before the skip() command would be run
+ if ($skip) {
+
+ skip($skip,1);
+ skip($skip,1);
+
+ # plus we need an end block so the tests come out in the right order
+ eval q{ END { skip($skip,1); skip($skip,1) } 1; } || die;
+
+ return;
+ }
+
+ # Create the tempfile
+ my $template = "tmpXXXXX";
+ my ($fh1, $fname1) = eval { tempfile ( $template,
+ DIR => File::Spec->tmpdir,
+ UNLINK => 1,
+ );
+ };
+
+ if (defined $fname1) {
+ print "# fname1 = $fname1\n";
+ ok( (-e $fname1) );
+ push(@files, $fname1); # store for end block
+ } elsif (File::Temp->safe_level() != File::Temp::STANDARD) {
+ my $skip2 = "Skip system possibly insecure, see INSTALL, section 'make test'";
+ skip($skip2, 1);
+ # plus we need an end block so the tests come out in the right order
+ eval q{ END { skip($skip2,1); } 1; } || die;
+ } else {
+ ok(0);
+ }
+
+ # Explicitly
+ if ( $< < File::Temp->top_system_uid() ){
+ skip("Skip Test inappropriate for root", 1);
+ eval q{ END { skip($skip,1); } 1; } || die;
+ return;
+ }
+ my ($fh2, $fname2) = eval { tempfile ($template, UNLINK => 1 ); };
+ if (defined $fname2) {
+ print "# fname2 = $fname2\n";
+ ok( (-e $fname2) );
+ push(@files, $fname2); # store for end block
+ close($fh2);
+ } elsif (File::Temp->safe_level() != File::Temp::STANDARD) {
+ my $skip2 = "Skip system possibly insecure, see INSTALL, section 'make test'";
+ skip($skip2, 1);
+ # plus we need an end block so the tests come out in the right order
+ eval q{ END { skip($skip2,1); } 1; } || die;
+ } else {
+ ok(0);
+ }
+
+ }
diff -c /dev/null 'perl-5.7.2/lib/File/Temp/t/tempfile.t'
Index: ./lib/File/Temp/t/tempfile.t
*** ./lib/File/Temp/t/tempfile.t Thu Jan 1 02:00:00 1970
--- ./lib/File/Temp/t/tempfile.t Mon Jul 9 17:10:35 2001
***************
*** 0 ****
--- 1,145 ----
+ #!/usr/local/bin/perl -w
+ # Test for File::Temp - tempfile function
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Test; import Test;
+ plan(tests => 20);
+ }
+
+ use strict;
+ use File::Spec;
+
+ # Will need to check that all files were unlinked correctly
+ # Set up an END block here to do it
+
+ # Arrays containing list of dirs/files to test
+ my (@files, @dirs, @still_there);
+
+ # And a test for files that should still be around
+ # These are tidied up
+ END {
+ foreach (@still_there) {
+ ok( -f $_ );
+ ok( unlink( $_ ) );
+ ok( !(-f $_) );
+ }
+ }
+
+ # Loop over an array hoping that the files dont exist
+ END { foreach (@files) { ok( !(-e $_) )} }
+
+ # And a test for directories
+ END { foreach (@dirs) { ok( !(-d $_) )} }
+
+ # Need to make sure that the END blocks are setup before
+ # the ones that File::Temp configures since END blocks are evaluated
+ # in revers order and we need to check the files *after* File::Temp
+ # removes them
+ use File::Temp qw/ tempfile tempdir/;
+
+ # Now we start the tests properly
+ ok(1);
+
+
+ # Tempfile
+ # Open tempfile in some directory, unlink at end
+ my ($fh, $tempfile) = tempfile(
+ UNLINK => 1,
+ SUFFIX => '.txt',
+ );
+
+ ok( (-f $tempfile) );
+ # Should still be around after closing
+ ok( close( $fh ) );
+ ok( (-f $tempfile) );
+ # Check again at exit
+ push(@files, $tempfile);
+
+ # TEMPDIR test
+ # Create temp directory in current dir
+ my $template = 'tmpdirXXXXXX';
+ print "# Template: $template\n";
+ my $tempdir = tempdir( $template ,
+ DIR => File::Spec->curdir,
+ CLEANUP => 1,
+ );
+
+ print "# TEMPDIR: $tempdir\n";
+
+ ok( (-d $tempdir) );
+ push(@dirs, $tempdir);
+
+ # Create file in the temp dir
+ ($fh, $tempfile) = tempfile(
+ DIR => $tempdir,
+ UNLINK => 1,
+ SUFFIX => '.dat',
+ );
+
+ print "# TEMPFILE: Created $tempfile\n";
+
+ ok( (-f $tempfile));
+ push(@files, $tempfile);
+
+ # Test tempfile
+ # ..and again
+ ($fh, $tempfile) = tempfile(
+ DIR => $tempdir,
+ );
+
+
+ ok( (-f $tempfile ));
+ push(@files, $tempfile);
+
+ print "# TEMPFILE: Created $tempfile\n";
+
+ # and another (with template)
+
+ ($fh, $tempfile) = tempfile( 'helloXXXXXXX',
+ DIR => $tempdir,
+ UNLINK => 1,
+ SUFFIX => '.dat',
+ );
+
+ print "# TEMPFILE: Created $tempfile\n";
+
+ ok( (-f $tempfile) );
+ push(@files, $tempfile);
+
+
+ # Create a temporary file that should stay around after
+ # it has been closed
+ ($fh, $tempfile) = tempfile( 'permXXXXXXX', UNLINK => 0 );
+ print "# TEMPFILE: Created $tempfile\n";
+ ok( -f $tempfile );
+ ok( close( $fh ) );
+ push( @still_there, $tempfile); # check at END
+
+ # Would like to create a temp file and just retrieve the handle
+ # but the test is problematic since:
+ # - We dont know the filename so we cant check that it is tidied
+ # correctly
+ # - The unlink0 required on unix for tempfile creation will fail
+ # on NFS
+ # Try to do what we can.
+ # Tempfile croaks on error so we need an eval
+ $fh = eval { tempfile( 'ftmpXXXXX', DIR => File::Spec->tmpdir ) };
+
+ if ($fh) {
+
+ # print something to it to make sure something is there
+ ok( print $fh "Test\n" );
+
+ # Close it - can not check it is gone since we dont know the name
+ ok( close($fh) );
+
+ } else {
+ skip "Skip Failed probably due to NFS", 1;
+ skip "Skip Failed probably due to NFS", 1;
+ }
+
+ # Now END block will execute to test the removal of directories
+ print "# End of tests. Execute END blocks\n";
+
diff -c /dev/null 'perl-5.7.2/lib/File/stat.t'
Index: ./lib/File/stat.t
*** ./lib/File/stat.t Thu Jan 1 02:00:00 1970
--- ./lib/File/stat.t Mon Jul 9 17:10:35 2001
***************
*** 0 ****
--- 1,72 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ BEGIN {
+ our $hasst;
+ eval { my @n = stat "TEST" };
+ $hasst = 1 unless $@ && $@ =~ /unimplemented/;
+ unless ($hasst) { print "1..0 # Skip: no stat\n"; exit 0 }
+ use Config;
+ $hasst = 0 unless $Config{'i_sysstat'} eq 'define';
+ unless ($hasst) { print "1..0 # Skip: no sys/stat.h\n"; exit 0 }
+ }
+
+ BEGIN {
+ our @stat = stat "TEST"; # This is the function stat.
+ unless (@stat) { print "1..0 # Skip: no file TEST\n"; exit 0 }
+ }
+
+ print "1..14\n";
+
+ use File::stat;
+
+ print "ok 1\n";
+
+ my $stat = stat "TEST"; # This is the OO stat.
+
+ print "not " unless $stat->dev == $stat[ 0];
+ print "ok 2\n";
+
+ # On OS/2 (fake) ino is not constant, it is incremented each time
+ print "# ino=>@{[$stat->ino]}, 1=>$stat[ 1]\nnot "
+ unless $stat->ino == $stat[ 1] or $^O eq 'os2';
+ print "ok 3\n";
+
+ print "not " unless $stat->mode == $stat[ 2];
+ print "ok 4\n";
+
+ print "not " unless $stat->nlink == $stat[ 3];
+ print "ok 5\n";
+
+ print "not " unless $stat->uid == $stat[ 4];
+ print "ok 6\n";
+
+ print "not " unless $stat->gid == $stat[ 5];
+ print "ok 7\n";
+
+ print "not " unless $stat->rdev == $stat[ 6];
+ print "ok 8\n";
+
+ print "not " unless $stat->size == $stat[ 7];
+ print "ok 9\n";
+
+ print "not " unless $stat->atime == $stat[ 8];
+ print "ok 10\n";
+
+ print "not " unless $stat->mtime == $stat[ 9];
+ print "ok 11\n";
+
+ print "not " unless $stat->ctime == $stat[10];
+ print "ok 12\n";
+
+ print "not " unless $stat->blksize == $stat[11];
+ print "ok 13\n";
+
+ print "not " unless $stat->blocks == $stat[12];
+ print "ok 14\n";
+
+ # Testing pretty much anything else is unportable.
diff -c /dev/null 'perl-5.7.2/lib/FileCache.t'
Index: ./lib/FileCache.t
*** ./lib/FileCache.t Thu Jan 1 02:00:00 1970
--- ./lib/FileCache.t Mon Jul 9 17:10:35 2001
***************
*** 0 ****
--- 1,25 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ print "1..1\n";
+
+ use FileCache;
+
+ # This is really not a complete test as I don't bother to open enough
+ # files to make real swapping of open filedescriptor happen.
+
+ $path = "foo";
+ cacheout $path;
+
+ print $path "\n";
+
+ close $path;
+
+ print "not " unless -f $path;
+ print "ok 1\n";
+
+ unlink $path;
diff -c 'perl-5.7.1/lib/FileHandle.pm' 'perl-5.7.2/lib/FileHandle.pm'
Index: ./lib/FileHandle.pm
*** ./lib/FileHandle.pm Fri Mar 16 04:54:50 2001
--- ./lib/FileHandle.pm Mon Jul 9 17:10:35 2001
***************
*** 4,10 ****
use strict;
our($VERSION, @ISA, @EXPORT, @EXPORT_OK);
! $VERSION = "2.00";
require IO::File;
@ISA = qw(IO::File);
--- 4,10 ----
use strict;
our($VERSION, @ISA, @EXPORT, @EXPORT_OK);
! $VERSION = "2.01";
require IO::File;
@ISA = qw(IO::File);
diff -c /dev/null 'perl-5.7.2/lib/FileHandle.t'
Index: ./lib/FileHandle.t
*** ./lib/FileHandle.t Thu Jan 1 02:00:00 1970
--- ./lib/FileHandle.t Mon Jul 9 17:10:35 2001
***************
*** 0 ****
--- 1,95 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ if ($^O eq 'mpeix') {
+ print "1..0 # Skip: broken on MPE/iX\n";
+ exit 0;
+ }
+ }
+
+ use FileHandle;
+ use strict subs;
+
+ autoflush STDOUT 1;
+
+ $mystdout = new_from_fd FileHandle 1,"w";
+ $| = 1;
+ autoflush $mystdout;
+ print "1..11\n";
+
+ print $mystdout "ok ".fileno($mystdout)."\n";
+
+ $fh = (new FileHandle "./TEST", O_RDONLY
+ or new FileHandle "TEST", O_RDONLY)
+ and print "ok 2\n";
+
+
+ $buffer = <$fh>;
+ print $buffer eq "#!./perl\n" ? "ok 3\n" : "not ok 3\n";
+
+
+ ungetc $fh ord 'A';
+ CORE::read($fh, $buf,1);
+ print $buf eq 'A' ? "ok 4\n" : "not ok 4\n";
+
+ close $fh;
+
+ $fh = new FileHandle;
+
+ print "not " unless ($fh->open("< TEST") && <$fh> eq $buffer);
+ print "ok 5\n";
+
+ $fh->seek(0,0);
+ print "#possible mixed CRLF/LF in t/TEST\nnot " unless (<$fh> eq $buffer);
+ print "ok 6\n";
+
+ $fh->seek(0,2);
+ $line = <$fh>;
+ print "not " if (defined($line) || !$fh->eof);
+ print "ok 7\n";
+
+ print "not " unless ($fh->open("TEST","r") && !$fh->tell && $fh->close);
+ print "ok 8\n";
+
+ autoflush STDOUT 0;
+
+ print "not " if ($|);
+ print "ok 9\n";
+
+ autoflush STDOUT 1;
+
+ print "not " unless ($|);
+ print "ok 10\n";
+
+ if ($^O eq 'dos')
+ {
+ printf("ok %d\n",11);
+ exit(0);
+ }
+
+ ($rd,$wr) = FileHandle::pipe;
+
+ if ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'amigaos' || $^O eq 'MSWin32' || $^O eq 'NetWare' ||
+ $Config{d_fork} ne 'define') {
+ $wr->autoflush;
+ $wr->printf("ok %d\n",11);
+ print $rd->getline;
+ }
+ else {
+ if (fork) {
+ $wr->close;
+ print $rd->getline;
+ }
+ else {
+ $rd->close;
+ $wr->printf("ok %d\n",11);
+ exit(0);
+ }
+ }
diff -c 'perl-5.7.1/lib/Filter/Simple.pm' 'perl-5.7.2/lib/Filter/Simple.pm'
Index: ./lib/Filter/Simple.pm
*** ./lib/Filter/Simple.pm Sun Apr 8 23:18:33 2001
--- ./lib/Filter/Simple.pm Mon Jul 9 17:10:35 2001
***************
*** 2,40 ****
use vars qw{ $VERSION };
! $VERSION = '0.50';
use Filter::Util::Call;
use Carp;
sub import {
my $caller = caller;
! my ($class, $filter) = @_;
! croak "Usage: use Filter::Simple sub {...}" unless ref $filter eq CODE;
! *{"${caller}::import"} = gen_filter_import($caller, $filter);
*{"${caller}::unimport"} = \*filter_unimport;
}
sub gen_filter_import {
! my ($class, $filter) = @_;
return sub {
my ($imported_class, @args) = @_;
filter_add(
sub {
my ($status, $off);
my $data = "";
while ($status = filter_read()) {
! if (m/^\s*no\s+$class\s*;\s*$/) {
$off=1;
last;
}
$data .= $_;
$_ = "";
}
$_ = $data;
$filter->(@args) unless $status < 0;
! $_ .= "no $class;\n" if $off;
! return length;
}
);
}
--- 2,51 ----
use vars qw{ $VERSION };
! $VERSION = '0.60';
use Filter::Util::Call;
use Carp;
sub import {
+ if (@_>1) { shift; goto &FILTER }
+ else { *{caller()."::FILTER"} = \&FILTER }
+ }
+
+ sub FILTER (&;$) {
my $caller = caller;
! my ($filter, $terminator) = @_;
! croak "Usage: use Filter::Simple sub {...}, $terminator_opt;"
! unless ref $filter eq CODE;
! *{"${caller}::import"} = gen_filter_import($caller,$filter,$terminator);
*{"${caller}::unimport"} = \*filter_unimport;
}
sub gen_filter_import {
! my ($class, $filter, $terminator) = @_;
return sub {
my ($imported_class, @args) = @_;
+ $terminator = qr/^\s*no\s+$imported_class\s*;\s*$/
+ unless defined $terminator;
filter_add(
sub {
my ($status, $off);
+ my $count = 0;
my $data = "";
while ($status = filter_read()) {
! return $status if $status < 0;
! if ($terminator && m/$terminator/) {
$off=1;
last;
}
$data .= $_;
+ $count++;
$_ = "";
}
$_ = $data;
$filter->(@args) unless $status < 0;
! $_ .= "no $imported_class;\n" if $off;
! return $count;
}
);
}
***************
*** 52,57 ****
--- 63,69 ----
Filter::Simple - Simplified source filtering
+
=head1 SYNOPSIS
# in MyFilter.pm:
***************
*** 58,65 ****
package MyFilter;
! use Filter::Simple sub { ... };
# in user's code:
--- 70,82 ----
package MyFilter;
! use Filter::Simple;
!
! FILTER { ... };
+ # or just:
+ #
+ # use Filter::Simple sub { ... };
# in user's code:
***************
*** 93,99 ****
=item 1.
Download, build, and install the Filter::Util::Call module.
! (If you are using Perl 5.7.1 or later, you already have Filter::Util::Call.)
=item 2.
--- 110,116 ----
=item 1.
Download, build, and install the Filter::Util::Call module.
! (If you have Perl 5.7.1 or later you already have Filter::Util::Call.)
=item 2.
***************
*** 141,147 ****
C<use BANG;> statement (until the next C<no BANG;> statement, if any):
package BANG;
!
use Filter::Util::Call ;
sub import {
--- 158,164 ----
C<use BANG;> statement (until the next C<no BANG;> statement, if any):
package BANG;
!
use Filter::Util::Call ;
sub import {
***************
*** 149,155 ****
my $caller = caller;
my ($status, $no_seen, $data);
while ($status = filter_read()) {
! if (/^\s*no\s+$caller\s*;\s*$/) {
$no_seen=1;
last;
}
--- 166,172 ----
my $caller = caller;
my ($status, $no_seen, $data);
while ($status = filter_read()) {
! if (/^\s*no\s+$caller\s*;\s*?$/) {
$no_seen=1;
last;
}
***************
*** 186,197 ****
=item 1.
! Set up a module that does a C<use Filter::Simple sub { ... }>.
=item 2.
! Within the anonymous subroutine passed to C<use Filter::Simple>, process the
! contents of $_ to change the source code in the desired manner.
=back
--- 203,216 ----
=item 1.
! Set up a module that does a C<use Filter::Simple> and then
! calls C<FILTER { ... }>.
=item 2.
! Within the anonymous subroutine or block that is passed to
! C<FILTER>, process the contents of $_ to change the source code in
! the desired manner.
=back
***************
*** 198,205 ****
In other words, the previous example, would become:
package BANG;
!
! use Filter::Simple sub {
s/BANG\s+BANG/die 'BANG' if \$BANG/g;
};
--- 217,225 ----
In other words, the previous example, would become:
package BANG;
! use Filter::Simple;
!
! FILTER {
s/BANG\s+BANG/die 'BANG' if \$BANG/g;
};
***************
*** 206,215 ****
1 ;
=head2 How it works
! The Filter::Simple module exports into the package that C<use>s it (e.g.
! package "BANG" in the above example) two automagically constructed
subroutines -- C<import> and C<unimport> -- which take care of all the
nasty details.
--- 226,309 ----
1 ;
+ =head2 Disabling or changing <no> behaviour
+
+ By default, the installed filter only filters to a line of the form:
+
+ no ModuleName;
+
+ but this can be altered by passing a second argument to C<use Filter::Simple>.
+
+ That second argument may be either a C<qr>'d regular expression (which is then
+ used to match the terminator line), or a defined false value (which indicates
+ that no terminator line should be looked for).
+
+ For example, to cause the previous filter to filter only up to a line of the
+ form:
+
+ GNAB esu;
+
+ you would write:
+
+ package BANG;
+ use Filter::Simple;
+
+ FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ }
+ => qr/^\s*GNAB\s+esu\s*;\s*?$/;
+
+ and to prevent the filter's being turned off in any way:
+
+ package BANG;
+ use Filter::Simple;
+
+ FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ }
+ => "";
+ # or: => 0;
+
+
+ =head2 All-in-one interface
+
+ Separating the loading of Filter::Simple:
+
+ use Filter::Simple;
+
+ from the setting up of the filtering:
+
+ FILTER { ... };
+
+ is useful because it allows other code (typically parser support code
+ or caching variables) to be defined before the filter is invoked.
+ However, there is often no need for such a separation.
+
+ In those cases, it is easier to just append the filtering subroutine and
+ any terminator specification directly to the C<use> statement that loads
+ Filter::Simple, like so:
+
+ use Filter::Simple sub {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ };
+
+ This is exactly the same as:
+
+ use Filter::Simple;
+ BEGIN {
+ Filter::Simple::FILTER {
+ s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+ };
+ }
+
+ except that the C<FILTER> subroutine is not exported by Filter::Simple.
+
+
=head2 How it works
! The Filter::Simple module exports into the package that calls C<FILTER>
! (or C<use>s it directly) -- such as package "BANG" in the above example --
! two automagically constructed
subroutines -- C<import> and C<unimport> -- which take care of all the
nasty details.
***************
*** 218,225 ****
be made parametric:
package BANG;
!
! use Filter::Simple sub {
my ($die_msg, $var_name) = @_;
s/BANG\s+BANG/die '$die_msg' if \${$var_name}/g;
};
--- 312,321 ----
be made parametric:
package BANG;
!
! use Filter::Simple;
!
! FILTER {
my ($die_msg, $var_name) = @_;
s/BANG\s+BANG/die '$die_msg' if \${$var_name}/g;
};
***************
*** 226,239 ****
# and in some user code:
! use BANG "BOOM", "BAM; # "BANG BANG" becomes: die 'BOOM' if $BAM
! The specified filtering subroutine is called every time a C<use BANG>
! is encountered, and passed all the source code following that call,
! up to either the next C<no BANG;> call or the end of the source file
! (whichever occurs first). Currently, any C<no BANG;> call must appear
! by itself on a separate line, or it is ignored.
=head1 AUTHOR
--- 322,335 ----
# and in some user code:
! use BANG "BOOM", "BAM"; # "BANG BANG" becomes: die 'BOOM' if $BAM
! The specified filtering subroutine is called every time a C<use BANG> is
! encountered, and passed all the source code following that call, up to
! either the next C<no BANG;> (or whatever terminator you've set) or the
! end of the source file, whichever occurs first. By default, any C<no
! BANG;> call must appear by itself on a separate line, or it is ignored.
=head1 AUTHOR
***************
*** 243,247 ****
=head1 COPYRIGHT
Copyright (c) 2000, Damian Conway. All Rights Reserved.
! This module is free software; you can redistribute it and/or
! modify it under the same terms as Perl itself.
--- 339,344 ----
=head1 COPYRIGHT
Copyright (c) 2000, Damian Conway. All Rights Reserved.
! This module is free software. It may be used, redistributed
! and/or modified under the terms of the Perl Artistic License
! (see http://www.perl.com/perl/misc/Artistic.html)
diff -c /dev/null 'perl-5.7.2/lib/Filter/Simple/test.pl'
Index: ./lib/Filter/Simple/test.pl
*** ./lib/Filter/Simple/test.pl Thu Jan 1 02:00:00 1970
--- ./lib/Filter/Simple/test.pl Mon Jul 9 17:10:35 2001
***************
*** 0 ****
--- 1,27 ----
+ #!./perl
+
+ BEGIN {
+ chdir('t') if -d 't';
+ @INC = 'lib';
+ }
+
+ print "1..6\n";
+
+ use MyFilter qr/not ok/ => "ok", fail => "ok";
+
+ sub fail { print "fail ", $_[0], "\n" }
+
+ print "not ok 1\n";
+ print "fail 2\n";
+
+ fail(3);
+ &fail(4);
+
+ print "not " unless "whatnot okapi" eq "whatokapi";
+ print "ok 5\n";
+
+ no MyFilter;
+
+ print "not " unless "not ok" =~ /^not /;
+ print "ok 6\n";
+
diff -c 'perl-5.7.1/lib/FindBin.pm' 'perl-5.7.2/lib/FindBin.pm'
Index: ./lib/FindBin.pm
*** ./lib/FindBin.pm Tue Mar 6 04:05:31 2001
--- ./lib/FindBin.pm Mon Jul 9 17:10:35 2001
***************
*** 107,114 ****
}
else
{
! my $IsWin32 = $^O eq 'MSWin32';
! unless(($script =~ m#/# || ($IsWin32 && $script =~ m#\\#))
&& -f $script)
{
my $dir;
--- 107,114 ----
}
else
{
! my $dosish = ($^O eq 'MSWin32' or $^O eq 'os2');
! unless(($script =~ m#/# || ($dosish && $script =~ m#\\#))
&& -f $script)
{
my $dir;
***************
*** 115,121 ****
foreach $dir (File::Spec->path)
{
my $scr = File::Spec->catfile($dir, $script);
! if(-r $scr && (!$IsWin32 || -x _))
{
$script = $scr;
--- 115,121 ----
foreach $dir (File::Spec->path)
{
my $scr = File::Spec->catfile($dir, $script);
! if(-r $scr && (!$dosish || -x _))
{
$script = $scr;
diff -c /dev/null 'perl-5.7.2/lib/FindBin.t'
Index: ./lib/FindBin.t
*** ./lib/FindBin.t Thu Jan 1 02:00:00 1970
--- ./lib/FindBin.t Mon Jul 9 17:10:35 2001
***************
*** 0 ****
--- 1,15 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ print "1..1\n";
+
+ use FindBin qw($Bin);
+
+ print "# $Bin\n";
+
+ print "not " unless $Bin =~ m,[/.]lib\]?$,;
+ print "ok 1\n";
diff -c /dev/null 'perl-5.7.2/lib/Getopt/Long/t/basic.t'
Index: ./lib/Getopt/Long/t/basic.t
*** ./lib/Getopt/Long/t/basic.t Thu Jan 1 02:00:00 1970
--- ./lib/Getopt/Long/t/basic.t Mon Jul 9 17:10:35 2001
***************
*** 0 ****
--- 1,26 ----
+ #!./perl -w
+
+ BEGIN {
+ chdir('t') if -d 't';
+ @INC = '../lib';
+ }
+
+ use Getopt::Long qw(:config no_ignore_case);
+ die("Getopt::Long version 2.24 required--this is only version ".
+ $Getopt::Long::VERSION)
+ unless $Getopt::Long::VERSION >= 2.24;
+
+ print "1..9\n";
+
+ @ARGV = qw(-Foo -baR --foo bar);
+ undef $opt_baR;
+ undef $opt_bar;
+ print "ok 1\n" if GetOptions ("foo", "Foo=s");
+ print ((defined $opt_foo) ? "" : "not ", "ok 2\n");
+ print (($opt_foo == 1) ? "" : "not ", "ok 3\n");
+ print ((defined $opt_Foo) ? "" : "not ", "ok 4\n");
+ print (($opt_Foo eq "-baR") ? "" : "not ", "ok 5\n");
+ print ((@ARGV == 1) ? "" : "not ", "ok 6\n");
+ print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n");
+ print (!(defined $opt_baR) ? "" : "not ", "ok 8\n");
+ print (!(defined $opt_bar) ? "" : "not ", "ok 9\n");
diff -c /dev/null 'perl-5.7.2/lib/Getopt/Long/t/compat.t'
Index: ./lib/Getopt/Long/t/compat.t
*** ./lib/Getopt/Long/t/compat.t Thu Jan 1 02:00:00 1970
--- ./lib/Getopt/Long/t/compat.t Mon Jul 9 17:10:35 2001
***************
*** 0 ****
--- 1,25 ----
+ #!./perl -w
+
+ BEGIN {
+ chdir('t') if -d 't';
+ @INC = '../lib';
+ }
+
+ require "newgetopt.pl";
+
+ print "1..9\n";
+
+ @ARGV = qw(-Foo -baR --foo bar);
+ $newgetopt::ignorecase = 0;
+ $newgetopt::ignorecase = 0;
+ undef $opt_baR;
+ undef $opt_bar;
+ print "ok 1\n" if NGetOpt ("foo", "Foo=s");
+ print ((defined $opt_foo) ? "" : "not ", "ok 2\n");
+ print (($opt_foo == 1) ? "" : "not ", "ok 3\n");
+ print ((defined $opt_Foo) ? "" : "not ", "ok 4\n");
+ print (($opt_Foo eq "-baR") ? "" : "not ", "ok 5\n");
+ print ((@ARGV == 1) ? "" : "not ", "ok 6\n");
+ print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n");
+ print (!(defined $opt_baR) ? "" : "not ", "ok 8\n");
+ print (!(defined $opt_bar) ? "" : "not ", "ok 9\n");
diff -c /dev/null 'perl-5.7.2/lib/Getopt/Long/t/linkage.t'
Index: ./lib/Getopt/Long/t/linkage.t
*** ./lib/Getopt/Long/t/linkage.t Thu Jan 1 02:00:00 1970
--- ./lib/Getopt/Long/t/linkage.t Mon Jul 9 17:10:35 2001
***************
*** 0 ****
--- 1,37 ----
+ #!./perl -w
+
+ BEGIN {
+ chdir('t') if -d 't';
+ @INC = '../lib';
+ }
+
+ use Getopt::Long;
+
+ print "1..18\n";
+
+ @ARGV = qw(-Foo -baR --foo bar);
+ Getopt::Long::Configure ("no_ignore_case");
+ %lnk = ();
+ print "ok 1\n" if GetOptions (\%lnk, "foo", "Foo=s");
+ print ((defined $lnk{foo}) ? "" : "not ", "ok 2\n");
+ print (($lnk{foo} == 1) ? "" : "not ", "ok 3\n");
+ print ((defined $lnk{Foo}) ? "" : "not ", "ok 4\n");
+ print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 5\n");
+ print ((@ARGV == 1) ? "" : "not ", "ok 6\n");
+ print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n");
+ print (!(exists $lnk{baR}) ? "" : "not ", "ok 8\n");
+
+ @ARGV = qw(-Foo -baR --foo bar);
+ Getopt::Long::Configure ("default","no_ignore_case");
+ %lnk = ();
+ my $foo;
+ print "ok 9\n" if GetOptions (\%lnk, "foo" => \$foo, "Foo=s");
+ print ((defined $foo) ? "" : "not ", "ok 10\n");
+ print (($foo == 1) ? "" : "not ", "ok 11\n");
+ print ((defined $lnk{Foo}) ? "" : "not ", "ok 12\n");
+ print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 13\n");
+ print ((@ARGV == 1) ? "" : "not ", "ok 14\n");
+ print (($ARGV[0] eq "bar") ? "" : "not ", "ok 15\n");
+ print (!(exists $lnk{foo}) ? "" : "not ", "ok 16\n");
+ print (!(exists $lnk{baR}) ? "" : "not ", "ok 17\n");
+ print (!(exists $lnk{bar}) ? "" : "not ", "ok 18\n");
diff -c /dev/null 'perl-5.7.2/lib/Getopt/Long/t/oo.t'
Index: ./lib/Getopt/Long/t/oo.t
*** ./lib/Getopt/Long/t/oo.t Thu Jan 1 02:00:00 1970
--- ./lib/Getopt/Long/t/oo.t Mon Jul 9 17:10:35 2001
***************
*** 0 ****
--- 1,26 ----
+ #!./perl -w
+
+ BEGIN {
+ chdir('t') if -d 't';
+ @INC = '../lib';
+ }
+
+ use Getopt::Long;
+ die("Getopt::Long version 2.24 required--this is only version ".
+ $Getopt::Long::VERSION)
+ unless $Getopt::Long::VERSION >= 2.24;
+ print "1..9\n";
+
+ @ARGV = qw(-Foo -baR --foo bar);
+ my $p = new Getopt::Long::Parser (config => ["no_ignore_case"]);
+ undef $opt_baR;
+ undef $opt_bar;
+ print "ok 1\n" if $p->getoptions ("foo", "Foo=s");
+ print ((defined $opt_foo) ? "" : "not ", "ok 2\n");
+ print (($opt_foo == 1) ? "" : "not ", "ok 3\n");
+ print ((defined $opt_Foo) ? "" : "not ", "ok 4\n");
+ print (($opt_Foo eq "-baR") ? "" : "not ", "ok 5\n");
+ print ((@ARGV == 1) ? "" : "not ", "ok 6\n");
+ print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n");
+ print (!(defined $opt_baR) ? "" : "not ", "ok 8\n");
+ print (!(defined $opt_bar) ? "" : "not ", "ok 9\n");
diff -c /dev/null 'perl-5.7.2/lib/Getopt/Std.t'
Index: ./lib/Getopt/Std.t
*** ./lib/Getopt/Std.t Thu Jan 1 02:00:00 1970
--- ./lib/Getopt/Std.t Mon Jul 9 17:10:35 2001
***************
*** 0 ****
--- 1,73 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ print "1..11\n";
+
+ use Getopt::Std;
+
+ # First we test the getopt function
+ @ARGV = qw(-xo -f foo -y file);
+ getopt('f');
+
+ print "not " if "@ARGV" ne 'file';
+ print "ok 1\n";
+
+ print "not " unless $opt_x && $opt_o && opt_y;
+ print "ok 2\n";
+
+ print "not " unless $opt_f eq 'foo';
+ print "ok 3\n";
+
+
+ # Then we try the getopts
+ $opt_o = $opt_i = $opt_f = undef;
+ @ARGV = qw(-foi -i file);
+ getopts('oif:') or print "not ";
+ print "ok 4\n";
+
+ print "not " unless "@ARGV" eq 'file';
+ print "ok 5\n";
+
+ print "not " unless $opt_i and $opt_f eq 'oi';
+ print "ok 6\n";
+
+ print "not " if $opt_o;
+ print "ok 7\n";
+
+ # Try illegal options, but avoid printing of the error message
+
+ open(STDERR, ">stderr") || die;
+
+ @ARGV = qw(-h help);
+
+ !getopts("xf:y") or print "not ";
+ print "ok 8\n";
+
+
+ # Then try the Getopt::Long module
+
+ use Getopt::Long;
+
+ @ARGV = qw(--help --file foo --foo --nobar --num=5 -- file);
+
+ GetOptions(
+ 'help' => \$HELP,
+ 'file:s' => \$FILE,
+ 'foo!' => \$FOO,
+ 'bar!' => \$BAR,
+ 'num:i' => \$NO,
+ ) || print "not ";
+ print "ok 9\n";
+
+ print "not " unless $HELP && $FOO && !$BAR && $FILE eq 'foo' && $NO == 5;
+ print "ok 10\n";
+
+ print "not " unless "@ARGV" eq "file";
+ print "ok 11\n";
+
+ close STDERR;
+ unlink "stderr";
diff -c /dev/null 'perl-5.7.2/lib/I18N/Collate.t'
Index: ./lib/I18N/Collate.t
*** ./lib/I18N/Collate.t Thu Jan 1 02:00:00 1970
--- ./lib/I18N/Collate.t Mon Jul 9 17:10:35 2001
***************
*** 0 ****
--- 1,44 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) {
+ print "1..0\n";
+ exit;
+ }
+ }
+
+ print "1..7\n";
+
+ use I18N::Collate;
+
+ print "ok 1\n";
+
+ $a = I18N::Collate->new("foo");
+
+ print "ok 2\n";
+
+ {
+ use warnings;
+ local $SIG{__WARN__} = sub { $@ = $_[0] };
+ $b = I18N::Collate->new("foo");
+ print "not " unless $@ =~ /\bHAS BEEN DEPRECATED\b/;
+ print "ok 3\n";
+ $@ = '';
+ }
+
+ print "not " unless $a eq $b;
+ print "ok 4\n";
+
+ $b = I18N::Collate->new("bar");
+ print "not " if $@ =~ /\bHAS BEEN DEPRECATED\b/;
+ print "ok 5\n";
+
+ print "not " if $a eq $b;
+ print "ok 6\n";
+
+ print "not " if $a lt $b == $a gt $b;
+ print "ok 7\n";
+
diff -c /dev/null 'perl-5.7.2/lib/I18N/LangTags.pm'
Index: ./lib/I18N/LangTags.pm
*** ./lib/I18N/LangTags.pm Thu Jan 1 02:00:00 1970
--- ./lib/I18N/LangTags.pm Mon Jul 9 17:10:36 2001
***************
*** 0 ****
--- 1,800 ----
+
+ # Time-stamp: "2001-06-21 22:50:34 MDT"
+ # Sean M. Burke <sburke@cpan.org>
+
+ require 5.000;
+ package I18N::LangTags;
+ use strict;
+ use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION %Panic);
+ require Exporter;
+ @ISA = qw(Exporter);
+ @EXPORT = qw();
+ @EXPORT_OK = qw(is_language_tag same_language_tag
+ extract_language_tags super_languages
+ similarity_language_tag is_dialect_of
+ locale2language_tag alternate_language_tags
+ encode_language_tag panic_languages
+ );
+ %EXPORT_TAGS = ('ALL' => \@EXPORT_OK);
+
+ $VERSION = "0.26";
+
+ =head1 NAME
+
+ I18N::LangTags - functions for dealing with RFC3066-style language tags
+
+ =head1 SYNOPSIS
+
+ use I18N::LangTags qw(is_language_tag same_language_tag
+ extract_language_tags super_languages
+ similarity_language_tag is_dialect_of
+ locale2language_tag alternate_language_tags
+ encode_language_tag panic_languages
+ );
+
+ ...or whatever of those functions you want to import. Those are
+ all the exportable functions -- you're free to import only some,
+ or none at all. By default, none are imported. If you say:
+
+ use I18N::LangTags qw(:ALL)
+
+ ...then all are exported. (This saves you from having to use
+ something less obvious like C<use I18N::LangTags qw(/./)>.)
+
+ If you don't import any of these functions, assume a C<&I18N::LangTags::>
+ in front of all the function names in the following examples.
+
+ =head1 DESCRIPTION
+
+ Language tags are a formalism, described in RFC 3066 (obsoleting
+ 1766), for declaring what language form (language and possibly
+ dialect) a given chunk of information is in.
+
+ This library provides functions for common tasks involving language
+ tags as they are needed in a variety of protocols and applications.
+
+ Please see the "See Also" references for a thorough explanation
+ of how to correctly use language tags.
+
+ =over
+
+ =cut
+
+ ###########################################################################
+
+ =item * the function is_language_tag($lang1)
+
+ Returns true iff $lang1 is a formally valid language tag.
+
+ is_language_tag("fr") is TRUE
+ is_language_tag("x-jicarilla") is FALSE
+ (Subtags can be 8 chars long at most -- 'jicarilla' is 9)
+
+ is_language_tag("sgn-US") is TRUE
+ (That's American Sign Language)
+
+ is_language_tag("i-Klikitat") is TRUE
+ (True without regard to the fact noone has actually
+ registered Klikitat -- it's a formally valid tag)
+
+ is_language_tag("fr-patois") is TRUE
+ (Formally valid -- altho descriptively weak!)
+
+ is_language_tag("Spanish") is FALSE
+ is_language_tag("french-patois") is FALSE
+ (No good -- first subtag has to match
+ /^([xXiI]|[a-zA-Z]{2,3})$/ -- see RFC3066)
+
+ is_language_tag("x-borg-prot2532") is TRUE
+ (Yes, subtags can contain digits, as of RFC3066)
+
+ =cut
+
+ sub is_language_tag {
+
+ ## Changes in the language tagging standards may have to be reflected here.
+
+ my($tag) = lc($_[0]);
+
+ return 0 if $tag eq "i" or $tag eq "x";
+ # Bad degenerate cases that the following
+ # regexp would erroneously let pass
+
+ return $tag =~
+ /^(?: # First subtag
+ [xi] | [a-z]{2,3}
+ )
+ (?: # Subtags thereafter
+ - # separator
+ [a-z0-9]{1,8} # subtag
+ )*
+ $/xs ? 1 : 0;
+ }
+
+ ###########################################################################
+
+ =item * the function extract_language_tags($whatever)
+
+ Returns a list of whatever looks like formally valid language tags
+ in $whatever. Not very smart, so don't get too creative with
+ what you want to feed it.
+
+ extract_language_tags("fr, fr-ca, i-mingo")
+ returns: ('fr', 'fr-ca', 'i-mingo')
+
+ extract_language_tags("It's like this: I'm in fr -- French!")
+ returns: ('It', 'in', 'fr')
+ (So don't just feed it any old thing.)
+
+ The output is untainted. If you don't know what tainting is,
+ don't worry about it.
+
+ =cut
+
+ sub extract_language_tags {
+
+ ## Changes in the language tagging standards may have to be reflected here.
+
+ my($text) =
+ $_[0] =~ m/(.+)/ # to make for an untainted result
+ ? $1 : ''
+ ;
+
+ return grep(!m/^[ixIX]$/s, # 'i' and 'x' aren't good tags
+ $text =~
+ m/
+ \b
+ (?: # First subtag
+ [iIxX] | [a-zA-Z]{2,3}
+ )
+ (?: # Subtags thereafter
+ - # separator
+ [a-zA-Z0-9]{1,8} # subtag
+ )*
+ \b
+ /xsg
+ );
+ }
+
+ ###########################################################################
+
+ =item * the function same_language_tag($lang1, $lang2)
+
+ Returns true iff $lang1 and $lang2 are acceptable variant tags
+ representing the same language-form.
+
+ same_language_tag('x-kadara', 'i-kadara') is TRUE
+ (The x/i- alternation doesn't matter)
+ same_language_tag('X-KADARA', 'i-kadara') is TRUE
+ (...and neither does case)
+ same_language_tag('en', 'en-US') is FALSE
+ (all-English is not the SAME as US English)
+ same_language_tag('x-kadara', 'x-kadar') is FALSE
+ (these are totally unrelated tags)
+ same_language_tag('no-bok', 'nb') is TRUE
+ (no-bok is a legacy tag for nb (Norwegian Bokmal))
+
+ C<same_language_tag> works by just seeing whether
+ C<encode_language_tag($lang1)> is the same as
+ C<encode_language_tag($lang2)>.
+
+ (Yes, I know this function is named a bit oddly. Call it historic
+ reasons.)
+
+ =cut
+
+ sub same_language_tag {
+ my $el1 = &encode_language_tag($_[0]);
+ return 0 unless defined $el1;
+ # this avoids the problem of
+ # encode_language_tag($lang1) eq and encode_language_tag($lang2)
+ # being true if $lang1 and $lang2 are both undef
+
+ return $el1 eq &encode_language_tag($_[1]) ? 1 : 0;
+ }
+
+ ###########################################################################
+
+ =item * the function similarity_language_tag($lang1, $lang2)
+
+ Returns an integer representing the degree of similarity between
+ tags $lang1 and $lang2 (the order of which does not matter), where
+ similarity is the number of common elements on the left,
+ without regard to case and to x/i- alternation.
+
+ similarity_language_tag('fr', 'fr-ca') is 1
+ (one element in common)
+ similarity_language_tag('fr-ca', 'fr-FR') is 1
+ (one element in common)
+
+ similarity_language_tag('fr-CA-joual',
+ 'fr-CA-PEI') is 2
+ similarity_language_tag('fr-CA-joual', 'fr-CA') is 2
+ (two elements in common)
+
+ similarity_language_tag('x-kadara', 'i-kadara') is 1
+ (x/i- doesn't matter)
+
+ similarity_language_tag('en', 'x-kadar') is 0
+ similarity_language_tag('x-kadara', 'x-kadar') is 0
+ (unrelated tags -- no similarity)
+
+ similarity_language_tag('i-cree-syllabic',
+ 'i-cherokee-syllabic') is 0
+ (no B<leftmost> elements in common!)
+
+ =cut
+
+ sub similarity_language_tag {
+ my $lang1 = &encode_language_tag($_[0]);
+ my $lang2 = &encode_language_tag($_[1]);
+ # And encode_language_tag takes care of the whole
+ # no-nyn==nn, i-hakka==zh-hakka, etc, things
+
+ # NB: (i-sil-...)? (i-sgn-...)?
+
+ return undef if !defined($lang1) and !defined($lang2);
+ return 0 if !defined($lang1) or !defined($lang2);
+
+ my @l1_subtags = split('-', $lang1);
+ my @l2_subtags = split('-', $lang2);
+ my $similarity = 0;
+
+ while(@l1_subtags and @l2_subtags) {
+ if(shift(@l1_subtags) eq shift(@l2_subtags)) {
+ ++$similarity;
+ } else {
+ last;
+ }
+ }
+ return $similarity;
+ }
+
+ ###########################################################################
+
+ =item * the function is_dialect_of($lang1, $lang2)
+
+ Returns true iff language tag $lang1 represents a subform of
+ language tag $lang2.
+
+ B<Get the order right! It doesn't work the other way around!>
+
+ is_dialect_of('en-US', 'en') is TRUE
+ (American English IS a dialect of all-English)
+
+ is_dialect_of('fr-CA-joual', 'fr-CA') is TRUE
+ is_dialect_of('fr-CA-joual', 'fr') is TRUE
+ (Joual is a dialect of (a dialect of) French)
+
+ is_dialect_of('en', 'en-US') is FALSE
+ (all-English is a NOT dialect of American English)
+
+ is_dialect_of('fr', 'en-CA') is FALSE
+
+ is_dialect_of('en', 'en' ) is TRUE
+ is_dialect_of('en-US', 'en-US') is TRUE
+ (B<Note:> these are degenerate cases)
+
+ is_dialect_of('i-mingo-tom', 'x-Mingo') is TRUE
+ (the x/i thing doesn't matter, nor does case)
+
+ is_dialect_of('nn', 'no') is TRUE
+ (because 'nn' (New Norse) is aliased to 'no-nyn',
+ as a special legacy case, and 'no-nyn' is a
+ subform of 'no' (Norwegian))
+
+ =cut
+
+ sub is_dialect_of {
+
+ my $lang1 = &encode_language_tag($_[0]);
+ my $lang2 = &encode_language_tag($_[1]);
+
+ return undef if !defined($lang1) and !defined($lang2);
+ return 0 if !defined($lang1) or !defined($lang2);
+
+ return 1 if $lang1 eq $lang2;
+ return 0 if length($lang1) < length($lang2);
+
+ $lang1 .= '-';
+ $lang2 .= '-';
+ return
+ (substr($lang1, 0, length($lang2)) eq $lang2) ? 1 : 0;
+ }
+
+ ###########################################################################
+
+ =item * the function super_languages($lang1)
+
+ Returns a list of language tags that are superordinate tags to $lang1
+ -- it gets this by removing subtags from the end of $lang1 until
+ nothing (or just "i" or "x") is left.
+
+ super_languages("fr-CA-joual") is ("fr-CA", "fr")
+
+ super_languages("en-AU") is ("en")
+
+ super_languages("en") is empty-list, ()
+
+ super_languages("i-cherokee") is empty-list, ()
+ ...not ("i"), which would be illegal as well as pointless.
+
+ If $lang1 is not a valid language tag, returns empty-list in
+ a list context, undef in a scalar context.
+
+ A notable and rather unavoidable problem with this method:
+ "x-mingo-tom" has an "x" because the whole tag isn't an
+ IANA-registered tag -- but super_languages('x-mingo-tom') is
+ ('x-mingo') -- which isn't really right, since 'i-mingo' is
+ registered. But this module has no way of knowing that. (But note
+ that same_language_tag('x-mingo', 'i-mingo') is TRUE.)
+
+ More importantly, you assume I<at your peril> that superordinates of
+ $lang1 are mutually intelligible with $lang1. Consider this
+ carefully.
+
+ =cut
+
+ sub super_languages {
+ my $lang1 = $_[0];
+ return() unless defined($lang1) && &is_language_tag($lang1);
+
+ # a hack for those annoying new (2001) tags:
+ $lang1 =~ s/^nb\b/no-bok/i; # yes, backwards
+ $lang1 =~ s/^nn\b/no-nyn/i; # yes, backwards
+ $lang1 =~ s/^[ix](-hakka\b)/zh$1/i; # goes the right way
+ # i-hakka-bork-bjork-bjark => zh-hakka-bork-bjork-bjark
+
+ my @l1_subtags = split('-', $lang1);
+
+ ## Changes in the language tagging standards may have to be reflected here.
+
+ # NB: (i-sil-...)?
+
+ my @supers = ();
+ foreach my $bit (@l1_subtags) {
+ push @supers,
+ scalar(@supers) ? ($supers[-1] . '-' . $bit) : $bit;
+ }
+ pop @supers if @supers;
+ shift @supers if @supers && $supers[0] =~ m<^[iIxX]$>s;
+ return reverse @supers;
+ }
+
+ ###########################################################################
+
+ =item * the function locale2language_tag($locale_identifier)
+
+ This takes a locale name (like "en", "en_US", or "en_US.ISO8859-1")
+ and maps it to a language tag. If it's not mappable (as with,
+ notably, "C" and "POSIX"), this returns empty-list in a list context,
+ or undef in a scalar context.
+
+ locale2language_tag("en") is "en"
+
+ locale2language_tag("en_US") is "en-US"
+
+ locale2language_tag("en_US.ISO8859-1") is "en-US"
+
+ locale2language_tag("C") is undef or ()
+
+ locale2language_tag("POSIX") is undef or ()
+
+ locale2language_tag("POSIX") is undef or ()
+
+ I'm not totally sure that locale names map satisfactorily to language
+ tags. Think REAL hard about how you use this. YOU HAVE BEEN WARNED.
+
+ The output is untainted. If you don't know what tainting is,
+ don't worry about it.
+
+ =cut
+
+ sub locale2language_tag {
+ my $lang =
+ $_[0] =~ m/(.+)/ # to make for an untainted result
+ ? $1 : ''
+ ;
+
+ return $lang if &is_language_tag($lang); # like "en"
+
+ $lang =~ tr<_><->; # "en_US" -> en-US
+ $lang =~ s<\.[-_a-zA-Z0-9\.]*><>s; # "en_US.ISO8859-1" -> en-US
+
+ return $lang if &is_language_tag($lang);
+
+ return;
+ }
+
+ ###########################################################################
+
+ =item * the function encode_language_tag($lang1)
+
+ This function, if given a language tag, returns an encoding of it such
+ that:
+
+ * tags representing different languages never get the same encoding.
+
+ * tags representing the same language always get the same encoding.
+
+ * an encoding of a formally valid language tag always is a string
+ value that is defined, has length, and is true if considered as a
+ boolean.
+
+ Note that the encoding itself is B<not> a formally valid language tag.
+ Note also that you cannot, currently, go from an encoding back to a
+ language tag that it's an encoding of.
+
+ Note also that you B<must> consider the encoded value as atomic; i.e.,
+ you should not consider it as anything but an opaque, unanalysable
+ string value. (The internals of the encoding method may change in
+ future versions, as the language tagging standard changes over time.)
+
+ C<encode_language_tag> returns undef if given anything other than a
+ formally valid language tag.
+
+ The reason C<encode_language_tag> exists is because different language
+ tags may represent the same language; this is normally treatable with
+ C<same_language_tag>, but consider this situation:
+
+ You have a data file that expresses greetings in different languages.
+ Its format is "[language tag]=[how to say 'Hello']", like:
+
+ en-US=Hiho
+ fr=Bonjour
+ i-mingo=Hau'
+
+ And suppose you write a program that reads that file and then runs as
+ a daemon, answering client requests that specify a language tag and
+ then expect the string that says how to greet in that language. So an
+ interaction looks like:
+
+ greeting-client asks: fr
+ greeting-server answers: Bonjour
+
+ So far so good. But suppose the way you're implementing this is:
+
+ my %greetings;
+ die unless open(IN, "<in.dat");
+ while(<IN>) {
+ chomp;
+ next unless /^([^=]+)=(.+)/s;
+ my($lang, $expr) = ($1, $2);
+ $greetings{$lang} = $expr;
+ }
+ close(IN);
+
+ at which point %greetings has the contents:
+
+ "en-US" => "Hiho"
+ "fr" => "Bonjour"
+ "i-mingo" => "Hau'"
+
+ And suppose then that you answer client requests for language $wanted
+ by just looking up $greetings{$wanted}.
+
+ If the client asks for "fr", that will look up successfully in
+ %greetings, to the value "Bonjour". And if the client asks for
+ "i-mingo", that will look up successfully in %greetings, to the value
+ "Hau'".
+
+ But if the client asks for "i-Mingo" or "x-mingo", or "Fr", then the
+ lookup in %greetings fails. That's the Wrong Thing.
+
+ You could instead do lookups on $wanted with:
+
+ use I18N::LangTags qw(same_language_tag);
+ my $repsonse = '';
+ foreach my $l2 (keys %greetings) {
+ if(same_language_tag($wanted, $l2)) {
+ $response = $greetings{$l2};
+ last;
+ }
+ }
+
+ But that's rather inefficient. A better way to do it is to start your
+ program with:
+
+ use I18N::LangTags qw(encode_language_tag);
+ my %greetings;
+ die unless open(IN, "<in.dat");
+ while(<IN>) {
+ chomp;
+ next unless /^([^=]+)=(.+)/s;
+ my($lang, $expr) = ($1, $2);
+ $greetings{
+ encode_language_tag($lang)
+ } = $expr;
+ }
+ close(IN);
+
+ and then just answer client requests for language $wanted by just
+ looking up
+
+ $greetings{encode_language_tag($wanted)}
+
+ And that does the Right Thing.
+
+ =cut
+
+ sub encode_language_tag {
+ # Only similarity_language_tag() is allowed to analyse encodings!
+
+ ## Changes in the language tagging standards may have to be reflected here.
+
+ my($tag) = $_[0] || return undef;
+ return undef unless &is_language_tag($tag);
+
+ # For the moment, these legacy variances are few enough that
+ # we can just handle them here with regexps.
+ $tag =~ s/^iw\b/he/i; # Hebrew
+ $tag =~ s/^in\b/id/i; # Indonesian
+ $tag =~ s/^[ix]-lux\b/lb/i; # Luxemburger
+ $tag =~ s/^[ix]-navajo\b/nv/i; # Navajo
+ $tag =~ s/^ji\b/yi/i; # Yiddish
+ #
+ # These go FROM the simplex to complex form, to get
+ # similarity-comparison right. And that's okay, since
+ # similarity_language_tag is the only thing that
+ # analyzes our output.
+ $tag =~ s/^[ix]-hakka\b/zh-hakka/i; # Hakka
+ $tag =~ s/^nb\b/no-bok/i; # BACKWARDS for Bokmal
+ $tag =~ s/^nn\b/no-nyn/i; # BACKWARDS for Nynorsk
+
+ $tag =~ s/^[xiXI]-//s;
+ # Just lop off any leading "x/i-"
+
+ return "~" . uc($tag);
+ }
+
+ #--------------------------------------------------------------------------
+
+ =item * the function alternate_language_tags($lang1)
+
+ This function, if given a language tag, returns all language tags that
+ are alternate forms of this language tag. (I.e., tags which refer to
+ the same language.) This is meant to handle legacy tags caused by
+ the minor changes in language tag standards over the years; and
+ the x-/i- alternation is also dealt with.
+
+ Note that this function does I<not> try to equate new (and never-used,
+ and unusable)
+ ISO639-2 three-letter tags to old (and still in use) ISO639-1
+ two-letter equivalents -- like "ara" -> "ar" -- because
+ "ara" has I<never> been in use as an Internet language tag,
+ and RFC 3066 stipulates that it never should be, since a shorter
+ tag ("ar") exists.
+
+ Examples:
+
+ alternate_language_tags('no-bok') is ('nb')
+ alternate_language_tags('nb') is ('no-bok')
+ alternate_language_tags('he') is ('iw')
+ alternate_language_tags('iw') is ('he')
+ alternate_language_tags('i-hakka') is ('zh-hakka', 'x-hakka')
+ alternate_language_tags('zh-hakka') is ('i-hakka', 'x-hakka')
+ alternate_language_tags('en') is ()
+ alternate_language_tags('x-mingo-tom') is ('i-mingo-tom')
+ alternate_language_tags('x-klikitat') is ('i-klikitat')
+ alternate_language_tags('i-klikitat') is ('x-klikitat')
+
+ This function returns empty-list if given anything other than a formally
+ valid language tag.
+
+ =cut
+
+ my %alt = qw( i x x i I X X I );
+ sub alternate_language_tags {
+ my $tag = $_[0];
+ return() unless &is_language_tag($tag);
+
+ my @em; # push 'em real goood!
+
+ # For the moment, these legacy variances are few enough that
+ # we can just handle them here with regexps.
+
+ if( $tag =~ m/^[ix]-hakka\b(.*)/i) {push @em, "zh-hakka$1";
+ } elsif($tag =~ m/^zh-hakka\b(.*)/i) { push @em, "x-hakka$1", "i-hakka$1";
+
+ } elsif($tag =~ m/^he\b(.*)/i) { push @em, "iw$1";
+ } elsif($tag =~ m/^iw\b(.*)/i) { push @em, "he$1";
+
+ } elsif($tag =~ m/^in\b(.*)/i) { push @em, "id$1";
+ } elsif($tag =~ m/^id\b(.*)/i) { push @em, "in$1";
+
+ } elsif($tag =~ m/^[ix]-lux\b(.*)/i) { push @em, "lb$1";
+ } elsif($tag =~ m/^lb\b(.*)/i) { push @em, "i-lux$1", "x-lux$1";
+
+ } elsif($tag =~ m/^[ix]-navajo\b(.*)/i) { push @em, "nv$1";
+ } elsif($tag =~ m/^nv\b(.*)/i) { push @em, "i-navajo$1", "x-navajo$1";
+
+ } elsif($tag =~ m/^yi\b(.*)/i) { push @em, "ji$1";
+ } elsif($tag =~ m/^ji\b(.*)/i) { push @em, "yi$1";
+
+ } elsif($tag =~ m/^nb\b(.*)/i) { push @em, "no-bok$1";
+ } elsif($tag =~ m/^no-bok\b(.*)/i) { push @em, "nb$1";
+
+ } elsif($tag =~ m/^nn\b(.*)/i) { push @em, "no-nyn$1";
+ } elsif($tag =~ m/^no-nyn\b(.*)/i) { push @em, "nn$1";
+ }
+
+ push @em, $alt{$1} . $2 if $tag =~ /^([XIxi])(-.+)/;
+ return @em;
+ }
+
+ ###########################################################################
+
+ {
+ # Init %Panic...
+
+ my @panic = ( # MUST all be lowercase!
+ # Only large ("national") languages make it in this list.
+ # If you, as a user, are so bizarre that the /only/ language
+ # you claim to accept is Galician, then no, we won't do you
+ # the favor of providing Catalan as a panic-fallback for
+ # you. Because if I start trying to add "little languages" in
+ # here, I'll just go crazy.
+
+ # Scandinavian lgs. All based on opinion and hearsay.
+ 'sv' => [qw(nb no da nn)],
+ 'da' => [qw(nb no sv nn)], # I guess
+ [qw(no nn nb)], [qw(no nn nb sv da)],
+ 'is' => [qw(da sv no nb nn)],
+ 'fo' => [qw(da is no nb nn sv)], # I guess
+
+ # I think this is about the extent of tolerable intelligibility
+ # among large modern Romance languages.
+ 'pt' => [qw(es ca it fr)], # Portuguese, Spanish, Catalan, Italian, French
+ 'ca' => [qw(es pt it fr)],
+ 'es' => [qw(ca it fr pt)],
+ 'it' => [qw(es fr ca pt)],
+ 'fr' => [qw(es it ca pt)],
+
+ # Also assume that speakers of the main Indian languages prefer
+ # to read/hear Hindi over English
+ [qw(
+ as bn gu kn ks kok ml mni mr ne or pa sa sd te ta ur
+ )] => 'hi',
+ # Assamese, Bengali, Gujarati, [Hindi,] Kannada (Kanarese), Kashmiri,
+ # Konkani, Malayalam, Meithei (Manipuri), Marathi, Nepali, Oriya,
+ # Punjabi, Sanskrit, Sindhi, Telugu, Tamil, and Urdu.
+ 'hi' => [qw(bn pa as or)],
+ # I welcome finer data for the other Indian languages.
+ # E.g., what should Oriya's list be, besides just Hindi?
+
+ # And the panic languages for English is, of course, nil!
+
+ # My guesses at Slavic intelligibility:
+ ([qw(ru be uk)]) x 2, # Russian, Belarusian, Ukranian
+ 'sr' => 'hr', 'hr' => 'sr', # Serb + Croat
+ 'cs' => 'sk', 'sk' => 'cs', # Czech + Slovak
+
+ 'ms' => 'id', 'id' => 'ms', # Malay + Indonesian
+
+ 'et' => 'fi', 'fi' => 'et', # Estonian + Finnish
+
+ #?? 'lo' => 'th', 'th' => 'lo', # Lao + Thai
+
+ );
+ my($k,$v);
+ while(@panic) {
+ ($k,$v) = splice(@panic,0,2);
+ foreach my $k (ref($k) ? @$k : $k) {
+ foreach my $v (ref($v) ? @$v : $v) {
+ push @{$Panic{$k} ||= []}, $v unless $k eq $v;
+ }
+ }
+ }
+ }
+
+ =item * the function @langs = panic_languages(@accept_languages)
+
+ This function takes a list of 0 or more language
+ tags that constitute a given user's Accept-Language list, and
+ returns a list of tags for I<other> (non-super)
+ languages that are probably acceptable to the user, to be
+ used I<if all else fails>.
+
+ For example, if a user accepts only 'ca' (Catalan) and
+ 'es' (Spanish), and the documents/interfaces you have
+ available are just in German, Italian, and Chinese, then
+ the user will most likely want the Italian one (and not
+ the Chinese or German one!), instead of getting
+ nothing. So C<panic_languages('ca', 'es')> returns
+ a list containing 'it' (Italian).
+
+ English ('en') is I<always> in the return list, but
+ whether it's at the very end or not depends
+ on the input languages. This function works by consulting
+ an internal table that stipulates what common
+ languages are "close" to each other.
+
+ A useful construct you might consider using is:
+
+ @fallbacks = super_languages(@accept_languages);
+ push @fallbacks, panic_languages(
+ @accept_languages, @fallbacks,
+ );
+
+ =cut
+
+ sub panic_languages {
+ # When in panic or in doubt, run in circles, scream, and shout!
+ my(@out, %seen);
+ foreach my $t (@_) {
+ next unless $t;
+ next if $seen{$t}++; # so we don't return it or hit it again
+ # push @out, super_languages($t); # nah, keep that separate
+ push @out, @{ $Panic{lc $t} || next };
+ }
+ return grep !$seen{$_}++, @out, 'en';
+ }
+
+ ###########################################################################
+ 1;
+ __END__
+
+ =back
+
+ =head1 ABOUT LOWERCASING
+
+ I've considered making all the above functions that output language
+ tags return all those tags strictly in lowercase. Having all your
+ language tags in lowercase does make some things easier. But you
+ might as well just lowercase as you like, or call
+ C<encode_language_tag($lang1)> where appropriate.
+
+ =head1 ABOUT UNICODE PLAINTEXT LANGUAGE TAGS
+
+ In some future version of I18N::LangTags, I plan to include support
+ for RFC2482-style language tags -- which are basically just normal
+ language tags with their ASCII characters shifted into Plane 14.
+
+ =head1 SEE ALSO
+
+ * L<I18N::LangTags::List|I18N::LangTags::List>
+
+ * RFC 3066, C<ftp://ftp.isi.edu/in-notes/rfc3066.txt>, "Tags for the
+ Identification of Languages". (Obsoletes RFC 1766)
+
+ * RFC 2277, C<ftp://ftp.isi.edu/in-notes/rfc2277.txt>, "IETF Policy on
+ Character Sets and Languages".
+
+ * RFC 2231, C<ftp://ftp.isi.edu/in-notes/rfc2231.txt>, "MIME Parameter
+ Value and Encoded Word Extensions: Character Sets, Languages, and
+ Continuations".
+
+ * RFC 2482, C<ftp://ftp.isi.edu/in-notes/rfc2482.txt>,
+ "Language Tagging in Unicode Plain Text".
+
+ * Locale::Codes, in
+ C<http://www.perl.com/CPAN/modules/by-module/Locale/>
+
+ * ISO 639, "Code for the representation of names of languages",
+ C<http://www.indigo.ie/egt/standards/iso639/iso639-1-en.html>
+
+ * ISO 639-2, "Codes for the representation of names of languages",
+ including three-letter codes,
+ C<http://lcweb.loc.gov/standards/iso639-2/bibcodes.html>
+
+ * The IANA list of registered languages (hopefully up-to-date),
+ C<ftp://ftp.isi.edu/in-notes/iana/assignments/languages/>
+
+ =head1 COPYRIGHT
+
+ Copyright (c) 1998-2001 Sean M. Burke. All rights reserved.
+
+ This library is free software; you can redistribute it and/or
+ modify it under the same terms as Perl itself.
+
+ The programs and documentation in this dist are distributed in
+ the hope that they will be useful, but without any warranty; without
+ even the implied warranty of merchantability or fitness for a
+ particular purpose.
+
+ =head1 AUTHOR
+
+ Sean M. Burke C<sburke@cpan.org>
+
+ =cut
+
diff -c /dev/null 'perl-5.7.2/lib/I18N/LangTags/ChangeLog'
Index: ./lib/I18N/LangTags/ChangeLog
*** ./lib/I18N/LangTags/ChangeLog Thu Jan 1 02:00:00 1970
--- ./lib/I18N/LangTags/ChangeLog Mon Jul 9 17:10:36 2001
***************
*** 0 ****
--- 1,101 ----
+ Revision history for Perl module I18N::LangTags.
+ Time-stamp: "2001-06-21 23:04:08 MDT"
+
+ 2001-06-21 Sean M. Burke sburke@cpan.org
+
+ * Release 0.26 -- just making cosmetic changes
+ to test.pl, at Jarkko's request.
+
+ 2001-06-20 Sean M. Burke sburke@cpan.org
+
+ * Release 0.25 -- just tweaking panic_languages behavior
+ for Scandinavian languages. Much better now.
+ Slight tweak to ::List's entries for Greek.
+
+ 2001-06-20 Sean M. Burke sburke@cpan.org
+
+ * Release 0.24
+
+ * I18N::LangTags -- some elaborate hacks to make us
+ recognize legacy aliases like no-nyn == nn.
+ Added panic_languages().
+ Added :ALL export tag.
+ Minor docs fixes, and spiffing up test.pl.
+
+ * I18N::LangTags::List -- minor corrections; added
+ a few aliases.
+
+ 2001-05-29 Sean M. Burke sburke@cpan.org
+
+ * Release 0.23
+
+ * I18N::LangTags::List -- minor corrections. And is now
+ a module, not just documentation.
+
+ 2001-05-27 Sean M. Burke sburke@cpan.org
+
+ * Release 0.22
+
+ * Now bundling I18N::LangTags::List, a reference for lang tags,
+ replacing generate_language_table.plx and language_codes.txt
+
+ 2001-05-25 Sean M. Burke sburke@cpan.org
+
+ * Release 0.21
+
+ * extract_language_tags and locale2langauge_tag now
+ return untainted output. Useful if you feed tainted
+ things, like $ENV{'LANG'}.
+
+ 2001-03-13 Sean M. Burke sburke@cpan.org
+
+ * Release 0.20
+
+ * Added support for RFC 3066 tags: allowing three-letter primary
+ tags ("nav"), and allowing digits in subtags ("x-borg-prot3252").
+
+ * Changed all references from RFC 1766 to RFC 3066.
+
+ * Now bundling fulltext of RFC 3066 in the dist.
+
+ * Now bundling generate_language_table.plx and language_codes.txt
+
+ * Added some nice tests to test.pl
+
+ * Inverting order of listings in this ChangeLog file.
+
+ 2000-05-13 Sean M. Burke sburke@cpan.org
+
+ * Release 0.13
+
+ * Just noting my new email address.
+
+ 1999-03-06 Sean M. Burke sburke@netadventure.net
+
+ * Release 0.11
+
+ * Added functions
+ similarity_language_tag, is_dialect_of,
+ locale2language_tag, alternate_language_tags, and
+ encode_language_tag
+
+ 1998-12-14 Sean M. Burke sburke@netadventure.net
+
+ * Release 0.09
+
+ * Added function super_languages()
+
+ 1998-10-31 Sean M. Burke sburke@netadventure.net
+
+ * Release 0.08
+
+ * Just changes in the docs and bundle -- no change
+ in functionality.
+
+ 1998-04-02 Sean M. Burke sburke@netadventure.net
+
+ * Release 0.07
+
+ * First public release.
+
+ [END OF CHANGELOG]
diff -c /dev/null 'perl-5.7.2/lib/I18N/LangTags/List.pm'
Index: ./lib/I18N/LangTags/List.pm
*** ./lib/I18N/LangTags/List.pm Thu Jan 1 02:00:00 1970
--- ./lib/I18N/LangTags/List.pm Mon Jul 9 17:10:36 2001
***************
*** 0 ****
--- 1,1622 ----
+
+ require 5;
+ package I18N::LangTags::List;
+ # Time-stamp: "2001-06-20 12:01:15 MDT"
+ use strict;
+ use vars qw(%Name $Debug $VERSION);
+ $VERSION = '0.24';
+ # POD at the end.
+
+ #----------------------------------------------------------------------
+ {
+ # read the table out of our own POD!
+ my $seeking = 1;
+ my $count = 0;
+ my($tag,$name);
+ while(<I18N::LangTags::List::DATA>) {
+ if($seeking) {
+ $seeking = 0 if m/=for woohah/;
+ } else {
+ next unless ($tag, $name) =
+ m/\{([-0-9a-zA-Z]+)\}(?:\s*:)?\s*([^\[\]]+)/;
+ $name =~ s/\s*[;\.]*\s*$//g;
+ next unless $name;
+ ++$count;
+ print "<$tag> <$name>\n" if $Debug;
+ $Name{$tag} = $name;
+ }
+ }
+ die "No tags read??" unless $count;
+ }
+ #----------------------------------------------------------------------
+
+ sub name {
+ my $tag = lc($_[0] || return);
+ $tag =~ s/^\s+//s;
+ $tag =~ s/\s+$//s;
+
+ my $alt;
+ if($tag =~ m/^x-(.+)/) {
+ $alt = "i-$1";
+ } elsif($tag =~ m/^i-(.+)/) {
+ $alt = "x-$1";
+ } else {
+ $alt = '';
+ }
+
+ my $subform = '';
+ my $name = '';
+ print "Input: {$tag}\n" if $Debug;
+ while(length $tag) {
+ last if $name = $Name{$tag};
+ last if $name = $Name{$alt};
+ if($tag =~ s/(-[a-z0-9]+)$//s) {
+ print "Shaving off: $1 leaving $tag\n" if $Debug;
+ $subform = "$1$subform";
+ # and loop around again
+
+ $alt =~ s/(-[a-z0-9]+)$//s && $Debug && print " alt -> $alt\n";
+ } else {
+ # we're trying to pull a subform off a primary tag. TILT!
+ print "Aborting on: {$name}{$subform}\n" if $Debug;
+ last;
+ }
+ }
+ print "Output: {$name}{$subform}\n" if $Debug;
+
+ return unless $name; # Failure
+ return $name unless $subform; # Exact match
+ $subform =~ s/^-//s;
+ $subform =~ s/-$//s;
+ return "$name (Subform \"$subform\")";
+ }
+
+ 1;
+
+ __DATA__
+
+ =head1 NAME
+
+ I18N::LangTags::List -- tags and names for human languages
+
+ =head1 SYNOPSIS
+
+ use I18N::LangTags::List;
+ print "Parlez-vous... ", join(', ',
+ I18N::LangTags::List::name('elx') || 'unknown_language',
+ I18N::LangTags::List::name('ar-Kw') || 'unknown_language',
+ I18N::LangTags::List::name('en') || 'unknown_language',
+ I18N::LangTags::List::name('en-CA') || 'unknown_language',
+ ), "?\n";
+
+ prints:
+
+ Parlez-vous... Elamite, Kuwait Arabic, English, Canadian English?
+
+ =head1 DESCRIPTION
+
+ This module provides a function
+ C<I18N::LangTags::List::name( I<langtag> ) > that takes
+ a language tag (see L<I18N::LangTags|I18N::LangTags>)
+ and returns the best attempt at an English name for it, or
+ undef if it can't make sense of the tag.
+
+ The function I18N::LangTags::List::name(...) is not exported.
+
+ The map of tags-to-names that it uses is accessable as
+ %I18N::LangTags::List::Name, and it's the same as the list
+ that follows in this documentation, which should be useful
+ to you even if you don't use this module.
+
+ =head1 ABOUT LANGUAGE TAGS
+
+ Internet language tags, as defined in RFC 3066, are a formalism
+ for denoting human languages. The two-letter ISO 639-1 language
+ codes are well known (as "en" for English), as are their forms
+ when qualified by a country code ("en-US"). Less well-known are the
+ arbitrary-length non-ISO codes (like "i-mingo"), and the
+ recently (in 2001) introduced three-letter ISO-639-2 codes.
+
+ Remember this important facts:
+
+ =over
+
+ =item *
+
+ Language tags are not locale IDs. A locale ID is written with a "_"
+ instead of a "-", (almost?) always matches C<m/^\w\w_\w\w\b/>, and
+ I<means> something different than a language tag. A language tag
+ denotes a language. A locale ID denotes a language I<as used in>
+ a particular place, in combination with non-linguistic
+ location-specific information such as what currency in used
+ there. Locales I<also> often denote character set information,
+ as in "en_US.ISO8859-1".
+
+ =item *
+
+ Language tags are not for computer languages.
+
+ =item *
+
+ "Dialect" is not a useful term, since there is no objective
+ criterion for establishing when two languages are
+ dialects of eachother, or are separate languages.
+
+ =item *
+
+ Language tags are not case-sensitive. en-US, en-us, En-Us, etc.,
+ are all the same tag, and denote the same language.
+
+ =item *
+
+ Not every language tag really refers to a single language. Some
+ language tags refer to conditions: i-default (system-message text
+ in English plus maybe other languages), und (undetermined
+ language). Others (notably lots of the three-letter codes) are
+ bibliographic tags that classify whole groups of languages, as
+ with cus "Cushitic (Other)" (i.e., a
+ language that has been classed as Cushtic, but which has no more
+ specific code) or the even less linguistically coherent
+ sai for "South American Indian (Other)". While useful in
+ bibliography, B<SUCH TAGS ARE NOT
+ FOR GENERAL USE>. For further guidance, email me.
+
+ =item *
+
+ Language tags are not country codes. In fact, they are often
+ distinct codes, as with language tag ja for Japanese, and
+ ISO 3166 country code C<.jp> for Japan.
+
+ =back
+
+ =head1 LIST OF LANGUAGES
+
+ The first part of each item is the language tag, between
+ {...}. It
+ is followed by an English name for the language or language-group.
+ Language tags that I judge to be not for general use, are bracketed.
+
+ This list is in alphabetical order by English name of the language.
+
+ =for reminder
+ The name in the =item line MUST NOT have E<...>'s in it!!
+
+ =for woohah START
+
+ =over
+
+ =item {ab} : Abkhazian
+
+ eq Abkhaz
+
+ =item {ace} : Achinese
+
+ =item {ach} : Acoli
+
+ =item {ada} : Adangme
+
+ =item {aa} : Afar
+
+ =item {afh} : Afrihili
+
+ (Artificial)
+
+ =item {af} : Afrikaans
+
+ =item [{afa} : Afro-Asiatic (Other)]
+
+ =item {aka} : Akan
+
+ =item {akk} : Akkadian
+
+ (Historical)
+
+ =item {sq} : Albanian
+
+ =item {ale} : Aleut
+
+ =item [{alg} : Algonquian languages]
+
+ NOT Algonquin!
+
+ =item [{tut} : Altaic (Other)]
+
+ =item {am} : Amharic
+
+ NOT Aramaic!
+
+ =item {i-ami} : Ami
+
+ eq Amis. eq 'Amis. eq Pangca.
+
+ =item [{apa} : Apache languages]
+
+ =item {ar} : Arabic
+
+ Many forms are mutually un-intelligible in spoken media.
+ Notable forms:
+ {ar-ae} UAE Arabic;
+ {ar-bh} Bahrain Arabic;
+ {ar-dz} Algerian Arabic;
+ {ar-eg} Egyptian Arabic;
+ {ar-iq} Iraqi Arabic;
+ {ar-jo} Jordanian Arabic;
+ {ar-kw} Kuwait Arabic;
+ {ar-lb} Lebanese Arabic;
+ {ar-ly} Libyan Arabic;
+ {ar-ma} Moroccan Arabic;
+ {ar-om} Omani Arabic;
+ {ar-qa} Qatari Arabic;
+ {ar-sa} Sauda Arabic;
+ {ar-sy} Syrian Arabic;
+ {ar-tn} Tunisian Arabic;
+ {ar-ye} Yemen Arabic.
+
+ =item {arc} : Aramaic
+
+ NOT Amharic! NOT Samaritan Aramaic!
+
+ =item {arp} : Arapaho
+
+ =item {arn} : Araucanian
+
+ =item {arw} : Arawak
+
+ =item {hy} : Armenian
+
+ =item [{art} : Artificial (Other)]
+
+ =item {as} : Assamese
+
+ =item [{ath} : Athapascan languages]
+
+ eq Athabaskan. eq Athapaskan. eq Athabascan.
+
+ =item [{aus} : Australian languages]
+
+ =item [{map} : Austronesian (Other)]
+
+ =item {ava} : Avaric
+
+ =item {ae} : Avestan
+
+ eq Zend
+
+ =item {awa} : Awadhi
+
+ =item {ay} : Aymara
+
+ =item {az} : Azerbaijani
+
+ eq Azeri
+
+ =item {ban} : Balinese
+
+ =item [{bat} : Baltic (Other)]
+
+ =item {bal} : Baluchi
+
+ =item {bam} : Bambara
+
+ =item [{bai} : Bamileke languages]
+
+ =item {bad} : Banda
+
+ =item [{bnt} : Bantu (Other)]
+
+ =item {bas} : Basa
+
+ =item {ba} : Bashkir
+
+ =item {eu} : Basque
+
+ =item {btk} : Batak (Indonesia)
+
+ =item {bej} : Beja
+
+ =item {be} : Belarusian
+
+ eq Belarussian. eq Byelarussian.
+ eq Belorussian. eq Byelorussian.
+ eq White Russian. eq White Ruthenian.
+ NOT Ruthenian!
+
+ =item {bem} : Bemba
+
+ =item {bn} : Bengali
+
+ eq Bangla.
+
+ =item [{ber} : Berber (Other)]
+
+ =item {bho} : Bhojpuri
+
+ =item {bh} : Bihari
+
+ =item {bik} : Bikol
+
+ =item {bin} : Bini
+
+ =item {bi} : Bislama
+
+ eq Bichelamar.
+
+ =item {bs} : Bosnian
+
+ =item {bra} : Braj
+
+ =item {br} : Breton
+
+ =item {bug} : Buginese
+
+ =item {bg} : Bulgarian
+
+ =item {i-bnn} : Bunun
+
+ =item {bua} : Buriat
+
+ =item {my} : Burmese
+
+ =item {cad} : Caddo
+
+ =item {car} : Carib
+
+ =item {ca} : Catalan
+
+ eq CatalE<aacute>n. eq Catalonian.
+
+ =item [{cau} : Caucasian (Other)]
+
+ =item {ceb} : Cebuano
+
+ =item [{cel} : Celtic (Other)]
+
+ Notable forms:
+ {cel-gaulish} Gaulish (Historical)
+
+ =item [{cai} : Central American Indian (Other)]
+
+ =item {chg} : Chagatai
+
+ (Historical?)
+
+ =item [{cmc} : Chamic languages]
+
+ =item {ch} : Chamorro
+
+ =item {ce} : Chechen
+
+ =item {chr} : Cherokee
+
+ eq Tsalagi
+
+ =item {chy} : Cheyenne
+
+ =item {chb} : Chibcha
+
+ (Historical) NOT Chibchan (which is a language family).
+
+ =item {ny} : Chichewa
+
+ eq Nyanja. eq Chinyanja.
+
+ =item {zh} : Chinese
+
+ Many forms are mutually un-intelligible in spoken media.
+ Notable subforms:
+ {zh-cn} PRC Chinese;
+ {zh-hk} Hong Kong Chinese;
+ {zh-mo} Macau Chinese;
+ {zh-sg} Singapore Chinese;
+ {zh-tw} Taiwan Chinese;
+ {zh-guoyu} Mandarin [Putonghua/Guoyu];
+ {zh-hakka} Hakka [formerly i-hakka];
+ {zh-min} Hokkien;
+ {zh-min-nan} Southern Hokkien;
+ {zh-wuu} Shanghaiese;
+ {zh-xiang} Hunanese;
+ {zh-gan} Gan;
+ {zh-yue} Cantonese.
+
+ =for etc
+ {i-hakka} Hakka (old tag)
+
+ =item {chn} : Chinook Jargon
+
+ eq Chinook Wawa.
+
+ =item {chp} : Chipewyan
+
+ =item {cho} : Choctaw
+
+ =item {cu} : Church Slavic
+
+ eq Old Church Slavonic.
+
+ =item {chk} : Chuukese
+
+ eq Trukese. eq Chuuk. eq Truk. eq Ruk.
+
+ =item {cv} : Chuvash
+
+ =item {cop} : Coptic
+
+ =item {kw} : Cornish
+
+ =item {co} : Corsican
+
+ eq Corse.
+
+ =item {cre} : Cree
+
+ NOT Creek!
+
+ =item {mus} : Creek
+
+ NOT Cree!
+
+ =item [{cpe} : English-based Creoles and pidgins (Other)]
+
+ =item [{cpf} : French-based Creoles and pidgins (Other)]
+
+ =item [{cpp} : Portuguese-based Creoles and pidgins (Other)]
+
+ =item [{crp} : Creoles and pidgins (Other)]
+
+ =item {hr} : Croatian
+
+ eq Croat.
+
+ =item [{cus} : Cushitic (Other)]
+
+ =item {cs} : Czech
+
+ =item {dak} : Dakota
+
+ eq Nakota. eq Latoka.
+
+ =item {da} : Danish
+
+ =item {day} : Dayak
+
+ =item {i-default} : Default (Fallthru) Language
+
+ Defined in RFC 2277, this is for tagging text
+ (which must include English text, and might/should include text
+ in other appropriate languages) that is emitted in a context
+ where language-negotiation wasn't possible -- in SMTP mail failure
+ messages, for example.
+
+ =item {del} : Delaware
+
+ =item {din} : Dinka
+
+ =item {div} : Divehi
+
+ =item {doi} : Dogri
+
+ NOT Dogrib!
+
+ =item {dgr} : Dogrib
+
+ NOT Dogri!
+
+ =item [{dra} : Dravidian (Other)]
+
+ =item {dua} : Duala
+
+ =item {nl} : Dutch
+
+ eq Netherlander. Notable forms:
+ {nl-nl} Netherlands Dutch;
+ {nl-be} Belgian Dutch.
+
+ =item {dum} : Middle Dutch (ca.1050-1350)
+
+ (Historical)
+
+ =item {dyu} : Dyula
+
+ =item {dz} : Dzongkha
+
+ =item {efi} : Efik
+
+ =item {egy} : Ancient Egyptian
+
+ (Historical)
+
+ =item {eka} : Ekajuk
+
+ =item {elx} : Elamite
+
+ (Historical)
+
+ =item {en} : English
+
+ Notable forms:
+ {en-au} Australian English;
+ {en-bz} Belize English;
+ {en-ca} Canadian English;
+ {en-gb} UK English;
+ {en-ie} Irish English;
+ {en-jm} Jamaican English;
+ {en-nz} New Zealand English;
+ {en-ph} Philippine English;
+ {en-tt} Trinidad English;
+ {en-us} US English;
+ {en-za} South African English;
+ {en-zw} Zimbabwe English.
+
+ =item {enm} : Old English (1100-1500)
+
+ (Historical)
+
+ =item {ang} : Old English (ca.450-1100)
+
+ eq Anglo-Saxon. (Historical)
+
+ =item {eo} : Esperanto
+
+ (Artificial)
+
+ =item {et} : Estonian
+
+ =item {ewe} : Ewe
+
+ =item {ewo} : Ewondo
+
+ =item {fan} : Fang
+
+ =item {fat} : Fanti
+
+ =item {fo} : Faroese
+
+ =item {fj} : Fijian
+
+ =item {fi} : Finnish
+
+ =item [{fiu} : Finno-Ugrian (Other)]
+
+ eq Finno-Ugric. NOT Ugaritic!
+
+ =item {fon} : Fon
+
+ =item {fr} : French
+
+ Notable forms:
+ {fr-fr} France French;
+ {fr-be} Belgian French;
+ {fr-ca} Canadian French;
+ {fr-ch} Swiss French;
+ {fr-lu} Luxembourg French;
+ {fr-mc} Monaco French.
+
+ =item {frm} : Middle French (ca.1400-1600)
+
+ (Historical)
+
+ =item {fro} : Old French (842-ca.1400)
+
+ (Historical)
+
+ =item {fy} : Frisian
+
+ =item {fur} : Friulian
+
+ =item {ful} : Fulah
+
+ =item {gaa} : Ga
+
+ =item {gd} : Scots Gaelic
+
+ NOT Scots!
+
+ =item {gl} : Gallegan
+
+ eq Galician
+
+ =item {lug} : Ganda
+
+ =item {gay} : Gayo
+
+ =item {gba} : Gbaya
+
+ =item {gez} : Geez
+
+ eq Ge'ez
+
+ =item {ka} : Georgian
+
+ =item {de} : German
+
+ Notable forms:
+ {de-at} Austrian German;
+ {de-be} Belgian German;
+ {de-ch} Swiss German;
+ {de-de} Germany German;
+ {de-li} Liechtenstein German;
+ {de-lu} Luxembourg German.
+
+ =item {gmh} : Middle High German (ca.1050-1500)
+
+ (Historical)
+
+ =item {goh} : Old High German (ca.750-1050)
+
+ (Historical)
+
+ =item [{gem} : Germanic (Other)]
+
+ =item {gil} : Gilbertese
+
+ =item {gon} : Gondi
+
+ =item {gor} : Gorontalo
+
+ =item {got} : Gothic
+
+ (Historical)
+
+ =item {grb} : Grebo
+
+ =item {grc} : Ancient Greek
+
+ (Historical) (Until 15th century or so.)
+
+ =item {el} : Modern Greek
+
+ (Since 15th century or so.)
+
+ =item {gn} : Guarani
+
+ GuaranE<iacute>
+
+ =item {gu} : Gujarati
+
+ =item {gwi} : Gwich'in
+
+ eq Gwichin
+
+ =item {hai} : Haida
+
+ =item {ha} : Hausa
+
+ =item {haw} : Hawaiian
+
+ Hawai'ian
+
+ =item {he} : Hebrew
+
+ (Formerly "iw".)
+
+ =for etc
+ {iw} Hebrew (old tag)
+
+ =item {hz} : Herero
+
+ =item {hil} : Hiligaynon
+
+ =item {him} : Himachali
+
+ =item {hi} : Hindi
+
+ =item {ho} : Hiri Motu
+
+ =item {hit} : Hittite
+
+ (Historical)
+
+ =item {hmn} : Hmong
+
+ =item {hu} : Hungarian
+
+ =item {hup} : Hupa
+
+ =item {iba} : Iban
+
+ =item {is} : Icelandic
+
+ =item {ibo} : Igbo
+
+ =item {ijo} : Ijo
+
+ =item {ilo} : Iloko
+
+ =item [{inc} : Indic (Other)]
+
+ =item [{ine} : Indo-European (Other)]
+
+ =item {id} : Indonesian
+
+ (Formerly "in".)
+
+ =for etc
+ {in} Indonesian (old tag)
+
+ =item {ia} : Interlingua (International Auxiliary Language Association)
+
+ (Artificial) NOT Interlingue!
+
+ =item {ie} : Interlingue
+
+ (Artificial) NOT Interlingua!
+
+ =item {iu} : Inuktitut
+
+ A subform of "Eskimo".
+
+ =item {ik} : Inupiaq
+
+ A subform of "Eskimo".
+
+ =item [{ira} : Iranian (Other)]
+
+ =item {ga} : Irish
+
+ =item {mga} : Middle Irish (900-1200)
+
+ (Historical)
+
+ =item {sga} : Old Irish (to 900)
+
+ (Historical)
+
+ =item [{iro} : Iroquoian languages]
+
+ =item {it} : Italian
+
+ Notable forms:
+ {it-it} Italy Italian;
+ {it-ch} Swiss Italian.
+
+ =item {ja} : Japanese
+
+ (NOT "jp"!)
+
+ =item {jw} : Javanese
+
+ =item {jrb} : Judeo-Arabic
+
+ =item {jpr} : Judeo-Persian
+
+ =item {kab} : Kabyle
+
+ =item {kac} : Kachin
+
+ =item {kl} : Kalaallisut
+
+ eq Greenlandic "Eskimo"
+
+ =item {kam} : Kamba
+
+ =item {kn} : Kannada
+
+ eq Kanarese. NOT Canadian!
+
+ =item {kau} : Kanuri
+
+ =item {kaa} : Kara-Kalpak
+
+ =item {kar} : Karen
+
+ =item {ks} : Kashmiri
+
+ =item {kaw} : Kawi
+
+ =item {kk} : Kazakh
+
+ =item {kha} : Khasi
+
+ =item {km} : Khmer
+
+ eq Cambodian. eq Kampuchean.
+
+ =item [{khi} : Khoisan (Other)]
+
+ =item {kho} : Khotanese
+
+ =item {ki} : Kikuyu
+
+ eq Gikuyu.
+
+ =item {kmb} : Kimbundu
+
+ =item {rw} : Kinyarwanda
+
+ =item {ky} : Kirghiz
+
+ =item {i-klingon} : Klingon
+
+ =item {kv} : Komi
+
+ =item {kon} : Kongo
+
+ =item {kok} : Konkani
+
+ =item {ko} : Korean
+
+ =item {kos} : Kosraean
+
+ =item {kpe} : Kpelle
+
+ =item {kro} : Kru
+
+ =item {kj} : Kuanyama
+
+ =item {kum} : Kumyk
+
+ =item {ku} : Kurdish
+
+ =item {kru} : Kurukh
+
+ =item {kut} : Kutenai
+
+ =item {lad} : Ladino
+
+ eq Judeo-Spanish. NOT Ladin (a minority language in Italy).
+
+ =item {lah} : Lahnda
+
+ NOT Lamba!
+
+ =item {lam} : Lamba
+
+ NOT Lahnda!
+
+ =item {lo} : Lao
+
+ eq Laotian.
+
+ =item {la} : Latin
+
+ (Historical) NOT Ladin! NOT Ladino!
+
+ =item {lv} : Latvian
+
+ eq Lettish.
+
+ =item {lb} : Letzeburgesch
+
+ eq Luxemburgian, eq Luxemburger. (Formerly i-lux.)
+
+ =for etc
+ {i-lux} Letzeburgesch (old tag)
+
+ =item {lez} : Lezghian
+
+ =item {ln} : Lingala
+
+ =item {lt} : Lithuanian
+
+ =item {nds} : Low German
+
+ eq Low Saxon. eq Low German. eq Low Saxon.
+
+ =item {loz} : Lozi
+
+ =item {lub} : Luba-Katanga
+
+ =item {lua} : Luba-Lulua
+
+ =item {lui} : Luiseno
+
+ eq LuiseE<ntilde>o.
+
+ =item {lun} : Lunda
+
+ =item {luo} : Luo (Kenya and Tanzania)
+
+ =item {lus} : Lushai
+
+ =item {mk} : Macedonian
+
+ eq the modern Slavic language spoken in what was Yugoslavia.
+ NOT the form of Greek spoken in Greek Macedonia!
+
+ =item {mad} : Madurese
+
+ =item {mag} : Magahi
+
+ =item {mai} : Maithili
+
+ =item {mak} : Makasar
+
+ =item {mg} : Malagasy
+
+ =item {ms} : Malay
+
+ NOT Malayalam!
+
+ =item {ml} : Malayalam
+
+ NOT Malay!
+
+ =item {mt} : Maltese
+
+ =item {mnc} : Manchu
+
+ =item {mdr} : Mandar
+
+ NOT Mandarin!
+
+ =item {man} : Mandingo
+
+ =item {mni} : Manipuri
+
+ eq Meithei.
+
+ =item [{mno} : Manobo languages]
+
+ =item {gv} : Manx
+
+ =item {mi} : Maori
+
+ NOT Mari!
+
+ =item {mr} : Marathi
+
+ =item {chm} : Mari
+
+ NOT Maori!
+
+ =item {mh} : Marshall
+
+ eq Marshallese.
+
+ =item {mwr} : Marwari
+
+ =item {mas} : Masai
+
+ =item [{myn} : Mayan languages]
+
+ =item {men} : Mende
+
+ =item {mic} : Micmac
+
+ =item {min} : Minangkabau
+
+ =item {i-mingo} : Mingo
+
+ eq the Irquoian language West Virginia Seneca. NOT New York Seneca!
+
+ =item [{mis} : Miscellaneous languages]
+
+ Don't use this.
+
+ =item {moh} : Mohawk
+
+ =item {mo} : Moldavian
+
+ eq Moldovan.
+
+ =item [{mkh} : Mon-Khmer (Other)]
+
+ =item {lol} : Mongo
+
+ =item {mn} : Mongolian
+
+ eq Mongol.
+
+ =item {mos} : Mossi
+
+ =item [{mul} : Multiple languages]
+
+ Not for normal use.
+
+ =item [{mun} : Munda languages]
+
+ =item {nah} : Nahuatl
+
+ =item {na} : Nauru
+
+ =item {nv} : Navajo
+
+ eq Navaho. (Formerly i-navajo.)
+
+ =for etc
+ {i-navajo} Navajo (old tag)
+
+ =item {nd} : North Ndebele
+
+ =item {nr} : South Ndebele
+
+ =item {ng} : Ndonga
+
+ =item {ne} : Nepali
+
+ eq Nepalese. Notable forms:
+ {ne-np} Nepal Nepali;
+ {ne-in} India Nepali.
+
+ =item {new} : Newari
+
+ =item {nia} : Nias
+
+ =item [{nic} : Niger-Kordofanian (Other)]
+
+ =item [{ssa} : Nilo-Saharan (Other)]
+
+ =item {niu} : Niuean
+
+ =item {non} : Old Norse
+
+ (Historical)
+
+ =item [{nai} : North American Indian]
+
+ Do not use this.
+
+ =item {se} : Northern Sami
+
+ eq Lappish. eq Lapp. eq (Northern) Saami.
+
+ =item {no} : Norwegian
+
+ Note the two following forms:
+
+ =item {nb} : Norwegian Bokmal
+
+ eq BokmE<aring>l, (A form of Norwegian.) (Formerly no-bok.)
+
+ =for etc
+ {no-bok} Norwegian Bokmal (old tag)
+
+ =item {nn} : Norwegian Nynorsk
+
+ (A form of Norwegian.) (Formerly no-nyn.)
+
+ =for etc
+ {no-nyn} Norwegian Nynorsk (old tag)
+
+ =item [{nub} : Nubian languages]
+
+ =item {nym} : Nyamwezi
+
+ =item {nyn} : Nyankole
+
+ =item {nyo} : Nyoro
+
+ =item {nzi} : Nzima
+
+ =item {oc} : Occitan (post 1500)
+
+ eq ProvenE<ccedil>al, eq Provencal
+
+ =item {oji} : Ojibwa
+
+ eq Ojibwe.
+
+ =item {or} : Oriya
+
+ =item {om} : Oromo
+
+ =item {osa} : Osage
+
+ =item {os} : Ossetian; Ossetic
+
+ =item [{oto} : Otomian languages]
+
+ Group of languages collectively called "OtomE<iacute>".
+
+ =item {pal} : Pahlavi
+
+ eq Pahlevi
+
+ =item {i-pwn} : Paiwan
+
+ eq Pariwan
+
+ =item {pau} : Palauan
+
+ =item {pi} : Pali
+
+ (Historical?)
+
+ =item {pam} : Pampanga
+
+ =item {pag} : Pangasinan
+
+ =item {pa} : Panjabi
+
+ eq Punjabi
+
+ =item {pap} : Papiamento
+
+ eq Papiamentu.
+
+ =item [{paa} : Papuan (Other)]
+
+ =item {fa} : Persian
+
+ eq Farsi. eq Iranian.
+
+ =item {peo} : Old Persian (ca.600-400 B.C.)
+
+ =item [{phi} : Philippine (Other)]
+
+ =item {phn} : Phoenician
+
+ (Historical)
+
+ =item {pon} : Pohnpeian
+
+ NOT Pompeiian!
+
+ =item {pl} : Polish
+
+ =item {pt} : Portuguese
+
+ eq Portugese. Notable forms:
+ {pt-pt} Portugal Portuguese;
+ {pt-br} Brazilian Portuguese.
+
+ =item [{pra} : Prakrit languages]
+
+ =item {pro} : Old Provencal (to 1500)
+
+ eq Old ProvenE<ccedil>al. (Historical.)
+
+ =item {ps} : Pushto
+
+ eq Pashto. eq Pushtu.
+
+ =item {qu} : Quechua
+
+ eq Quecha.
+
+ =item {rm} : Raeto-Romance
+
+ eq Romansh.
+
+ =item {raj} : Rajasthani
+
+ =item {rap} : Rapanui
+
+ =item {rar} : Rarotongan
+
+ =item [{qaa - qtz} : Reserved for local use.]
+
+ =item [{roa} : Romance (Other)]
+
+ NOT Romanian! NOT Romany! NOT Romansh!
+
+ =item {ro} : Romanian
+
+ eq Rumanian. NOT Romany!
+
+ =item {rom} : Romany
+
+ eq Rom. NOT Romanian!
+
+ =item {rn} : Rundi
+
+ =item {ru} : Russian
+
+ NOT White Russian! NOT Rusyn!
+
+ =item [{sal} : Salishan languages]
+
+ Large language group.
+
+ =item {sam} : Samaritan Aramaic
+
+ NOT Aramaic!
+
+ =item [{smi} : Sami languages (Other)]
+
+ =item {sm} : Samoan
+
+ =item {sad} : Sandawe
+
+ =item {sg} : Sango
+
+ =item {sa} : Sanskrit
+
+ (Historical)
+
+ =item {sat} : Santali
+
+ =item {sc} : Sardinian
+
+ eq Sard.
+
+ =item {sas} : Sasak
+
+ =item {sco} : Scots
+
+ NOT Scots Gaelic!
+
+ =item {sel} : Selkup
+
+ =item [{sem} : Semitic (Other)]
+
+ =item {sr} : Serbian
+
+ eq Serb. NOT Sorbian.
+
+ =item {srr} : Serer
+
+ =item {shn} : Shan
+
+ =item {sn} : Shona
+
+ =item {sid} : Sidamo
+
+ =item {sgn-...} : Sign Languages
+
+ Always use with a subtag. Notable forms:
+ {sgn-gb} British Sign Language (BSL);
+ {sgn-ie} Irish Sign Language (ESL);
+ {sgn-ni} Nicaraguan Sign Language (ISN);
+ {sgn-us} American Sign Language (ASL).
+
+ =item {bla} : Siksika
+
+ eq Blackfoot. eq Pikanii.
+
+ =item {sd} : Sindhi
+
+ =item {si} : Sinhalese
+
+ eq Sinhala.
+
+ =item [{sit} : Sino-Tibetan (Other)]
+
+ =item [{sio} : Siouan languages]
+
+ =item {den} : Slave (Athapascan)
+
+ ("Slavey" is a subform.)
+
+ =item [{sla} : Slavic (Other)]
+
+ =item {sk} : Slovak
+
+ eq Slovakian.
+
+ =item {sl} : Slovenian
+
+ eq Slovene.
+
+ =item {sog} : Sogdian
+
+ =item {so} : Somali
+
+ =item {son} : Songhai
+
+ =item {snk} : Soninke
+
+ =item {wen} : Sorbian languages
+
+ eq Wendish. eq Sorb. eq Lusatian. eq Wend. NOT Venda! NOT Serbian!
+
+ =item {nso} : Northern Sotho
+
+ =item {st} : Southern Sotho
+
+ eq Sutu. eq Sesotho.
+
+ =item [{sai} : South American Indian (Other)]
+
+ =item {es} : Spanish
+
+ Notable forms:
+ {es-ar} Argentine Spanish;
+ {es-bo} Bolivian Spanish;
+ {es-cl} Chilean Spanish;
+ {es-co} Colombian Spanish;
+ {es-do} Dominican Spanish;
+ {es-ec} Ecuadorian Spanish;
+ {es-es} Spain Spanish;
+ {es-gt} Guatemalan Spanish;
+ {es-hn} Honduran Spanish;
+ {es-mx} Mexican Spanish;
+ {es-pa} Panamanian Spanish;
+ {es-pe} Peruvian Spanish;
+ {es-pr} Puerto Rican Spanish;
+ {es-py} Paraguay Spanish;
+ {es-sv} Salvadoran Spanish;
+ {es-us} US Spanish;
+ {es-uy} Uruguayan Spanish;
+ {es-ve} Venezuelan Spanish.
+
+ =item {suk} : Sukuma
+
+ =item {sux} : Sumerian
+
+ (Historical)
+
+ =item {su} : Sundanese
+
+ =item {sus} : Susu
+
+ =item {sw} : Swahili
+
+ eq Kiswahili
+
+ =item {ss} : Swati
+
+ =item {sv} : Swedish
+
+ Notable forms:
+ sv-se {Sweden Swedish};
+ sv-fi {Finland Swedish}.
+
+ =item {syr} : Syriac
+
+ =item {tl} : Tagalog
+
+ =item {ty} : Tahitian
+
+ =item [{tai} : Tai (Other)]
+
+ NOT Thai!
+
+ =item {tg} : Tajik
+
+ =item {tmh} : Tamashek
+
+ =item {ta} : Tamil
+
+ =item {i-tao} : Tao
+
+ eq Yami.
+
+ =item {tt} : Tatar
+
+ =item {i-tay} : Tayal
+
+ eq Atayal. eq Atayan.
+
+ =item {te} : Telugu
+
+ =item {ter} : Tereno
+
+ =item {tet} : Tetum
+
+ =item {th} : Thai
+
+ NOT Tai!
+
+ =item {bo} : Tibetan
+
+ =item {tig} : Tigre
+
+ =item {ti} : Tigrinya
+
+ =item {tem} : Timne
+
+ eq Themne. eq Timene.
+
+ =item {tiv} : Tiv
+
+ =item {tli} : Tlingit
+
+ =item {tpi} : Tok Pisin
+
+ =item {tkl} : Tokelau
+
+ =item {tog} : Tonga (Nyasa)
+
+ NOT Tsonga!
+
+ =item {to} : Tonga (Tonga Islands)
+
+ (Pronounced "Tong-a", not "Tong-ga")
+
+ NOT Tsonga!
+
+ =item {tsi} : Tsimshian
+
+ eq Sm'algyax
+
+ =item {ts} : Tsonga
+
+ NOT Tonga!
+
+ =item {i-tsu} : Tsou
+
+ =item {tn} : Tswana
+
+ Same as Setswana.
+
+ =item {tum} : Tumbuka
+
+ =item {tr} : Turkish
+
+ (Typically in Roman script)
+
+ =item {ota} : Ottoman Turkish (1500-1928)
+
+ (Typically in Arabic script) (Historical)
+
+ =item {tk} : Turkmen
+
+ eq Turkmeni.
+
+ =item {tvl} : Tuvalu
+
+ =item {tyv} : Tuvinian
+
+ eq Tuvan. eq Tuvin.
+
+ =item {tw} : Twi
+
+ =item {uga} : Ugaritic
+
+ NOT Ugric!
+
+ =item {ug} : Uighur
+
+ =item {uk} : Ukrainian
+
+ =item {umb} : Umbundu
+
+ =item {und} : Undetermined
+
+ Not a tag for normal use.
+
+ =item {ur} : Urdu
+
+ =item {uz} : Uzbek
+
+ eq E<Ouml>zbek
+
+ =item {vai} : Vai
+
+ =item {ven} : Venda
+
+ NOT Wendish! NOT Wend! NOT Avestan!
+
+ =item {vi} : Vietnamese
+
+ eq Viet.
+
+ =item {vo} : Volapuk
+
+ eq VolapE<uuml>k. (Artificial)
+
+ =item {vot} : Votic
+
+ eq Votian. eq Vod.
+
+ =item [{wak} : Wakashan languages]
+
+ =item {wal} : Walamo
+
+ eq Wolaytta.
+
+ =item {war} : Waray
+
+ Presumably the Philippine language Waray-Waray (SamareE<ntilde>o),
+ not the smaller Philippine language Waray Sorsogon, nor the extinct
+ Australian language Waray.
+
+ =item {was} : Washo
+
+ eq Washoe
+
+ =item {cy} : Welsh
+
+ =item {wo} : Wolof
+
+ =item {x-...} : Unregistered (Semi-Private Use)
+
+ "x-" is a prefix for language tags that are not registered with ISO
+ or IANA. Example, x-double-dutch
+
+ =item {xh} : Xhosa
+
+ =item {sah} : Yakut
+
+ =item {yao} : Yao
+
+ (The Yao in Malawi?)
+
+ =item {yap} : Yapese
+
+ eq Yap
+
+ =item {yi} : Yiddish
+
+ Formerly "ji". Sometimes in Roman script, sometimes in Hebrew script.
+
+ =for etc
+ {ji} Yiddish (old tag)
+
+ =item {yo} : Yoruba
+
+ =item [{ypk} : Yupik languages]
+
+ Several "Eskimo" languages.
+
+ =item {znd} : Zande
+
+ =item [{zap} : Zapotec]
+
+ (A group of languages.)
+
+ =item {zen} : Zenaga
+
+ NOT Zend.
+
+ =item {za} : Zhuang
+
+ =item {zu} : Zulu
+
+ =item {zun} : Zuni
+
+ eq ZuE<ntilde>i
+
+ =back
+
+ =for woohah END
+
+ =head1 SEE ALSO
+
+ L<I18N::LangTags|I18N::LangTags> and its "See Also" section.
+
+ =head1 COPYRIGHT AND DISCLAIMER
+
+ Copyright (c) 2001 Sean M. Burke. All rights reserved.
+
+ You can redistribute and/or
+ modify this document under the same terms as Perl itself.
+
+ This document is provided in the the hope that it will be
+ useful, but without any warranty;
+ without even the implied warranty of accuracy, authoritativeness,
+ completeness, merchantability, or fitness for a particular purpose.
+
+ Email any corrections or questions to me.
+
+ =head1 AUTHOR
+
+ Sean M. Burke, sburkeE<64>cpan.org
+
+ =cut
+
+
+ # To generate a list of just the two and three-letter codes:
+
+ #!/usr/local/bin/perl -w
+
+ require 5; # Time-stamp: "2001-03-13 21:53:39 MST"
+ # Sean M. Burke, sburke@cpan.org
+ # This program is for generating the language_codes.txt file
+ use strict;
+ use LWP::Simple;
+ use HTML::TreeBuilder 3.10;
+ my $root = HTML::TreeBuilder->new();
+ my $url = 'http://lcweb.loc.gov/standards/iso639-2/bibcodes.html';
+ $root->parse(get($url) || die "Can't get $url");
+ $root->eof();
+
+ my @codes;
+
+ foreach my $tr ($root->find_by_tag_name('tr')) {
+ my @f = map $_->as_text(), $tr->content_list();
+ #print map("<$_> ", @f), "\n";
+ next unless @f == 5;
+ pop @f; # nix the French name
+ next if $f[-1] eq 'Language Name (English)'; # it's a header line
+ my $xx = splice(@f, 2,1); # pull out the two-letter code
+ $f[-1] =~ s/^\s+//;
+ $f[-1] =~ s/\s+$//;
+ if($xx =~ m/[a-zA-Z]/) { # there's a two-letter code for it
+ push @codes, [ lc($f[-1]), "$xx\t$f[-1]\n" ];
+ } else { # print the three-letter codes.
+ if($f[0] eq $f[1]) {
+ push @codes, [ lc($f[-1]), "$f[1]\t$f[2]\n" ];
+ } else { # shouldn't happen
+ push @codes, [ lc($f[-1]), "@f !!!!!!!!!!\n" ];
+ }
+ }
+ }
+
+ print map $_->[1], sort {; $a->[0] cmp $b->[0] } @codes;
+ print "[ based on $url\n at ", scalar(localtime), "]\n",
+ "[Note: doesn't include IANA-registered codes.]\n";
+ exit;
+ __END__
+
diff -c /dev/null 'perl-5.7.2/lib/I18N/LangTags/README'
Index: ./lib/I18N/LangTags/README
*** ./lib/I18N/LangTags/README Thu Jan 1 02:00:00 1970
--- ./lib/I18N/LangTags/README Mon Jul 9 17:10:36 2001
***************
*** 0 ****
--- 1,78 ----
+ README for I18N::LangTags
+ Time-stamp: "2001-05-29 21:52:15 MDT"
+
+ I18N::LangTags
+
+ I18N::LangTags - functions for dealing with RFC3066-style language
+ tags
+
+ Language tags are a formalism, described in RFC 3066 (obsoleting
+ 1766), for declaring what language form (language and possibly
+ dialect) a given chunk of information is in.
+
+ This library provides functions for common tasks involving language
+ tags (notably the extraction of them, comparing them, and testing the
+ formal validity of them) as is needed in a variety of protocols and
+ applications.
+
+
+ I18N::LangTags::List -- tags and names for human languages. This
+ module goes from known language tag names ("fr-CA") to their English
+ names ("Canadian French"). Its documentation also lists the several
+ hundred known tags and some common subforms. You may find this useful
+ as a reference.
+
+
+ See the POD for more information.
+
+
+ INSTALLATION
+
+ You install I18N::LangTags and I18N::LangTags::List, as you would
+ install any perl module library, by running these commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+ If you want to install a private copy of I18N::LangTags in your home
+ directory, then you should try to produce the initial Makefile with
+ something like this command:
+
+ perl Makefile.PL LIB=~/perl
+
+ See perldoc perlmodinstall for more information on installing modules.
+
+
+ DOCUMENTATION
+
+ POD-format documentation is included in LangTags.pm. POD is readable
+ with the 'perldoc' utility. See ChangeLog for recent changes.
+
+
+ SUPPORT
+
+ Questions, bug reports, useful code bits, and suggestions for
+ I18N::LangTags should just be sent to me at sburke@cpan.org
+
+
+ AVAILABILITY
+
+ The latest version of I18N::LangTags is available from the
+ Comprehensive Perl Archive Network (CPAN). Visit
+ <http://www.perl.com/CPAN/> to find a CPAN site near you.
+
+
+ COPYRIGHT
+
+ Copyright 1998-2001, Sean M. Burke <sburke@cpan.org>, all rights
+ reserved.
+
+ The programs and documentation in this dist are distributed in
+ the hope that they will be useful, but without any warranty; without
+ even the implied warranty of merchantability or fitness for a
+ particular purpose.
+
+ This library is free software; you can redistribute it and/or modify
+ it under the same terms as Perl itself.
diff -c /dev/null 'perl-5.7.2/lib/I18N/LangTags/test.pl'
Index: ./lib/I18N/LangTags/test.pl
*** ./lib/I18N/LangTags/test.pl Thu Jan 1 02:00:00 1970
--- ./lib/I18N/LangTags/test.pl Mon Jul 9 17:10:36 2001
***************
*** 0 ****
--- 1,79 ----
+ # Before `make install' is performed this script should be runnable with
+ # `make test'. After `make install' it should work as `perl test.pl'
+
+ ######################### We start with some black magic to print on failure.
+ require 5;
+ # Time-stamp: "2001-06-21 22:59:38 MDT"
+ use strict;
+ use Test;
+ BEGIN { plan tests => 46 };
+ BEGIN { ok 1 }
+ use I18N::LangTags (':ALL');
+
+ print "# Perl v$], I18N::LangTags v$I18N::LangTags::VERSION\n";
+
+ ok !is_language_tag('');
+ ok is_language_tag('fr');
+ ok is_language_tag('fr-ca');
+ ok is_language_tag('fr-CA');
+ ok !is_language_tag('fr-CA-');
+ ok !is_language_tag('fr_CA');
+ ok is_language_tag('fr-ca-joual');
+ ok !is_language_tag('frca');
+ ok is_language_tag('nav');
+ ok is_language_tag('nav-shiprock');
+ ok !is_language_tag('nav-ceremonial'); # subtag too long
+ ok !is_language_tag('x');
+ ok !is_language_tag('i');
+ ok is_language_tag('i-borg'); # NB: fictitious tag
+ ok is_language_tag('x-borg');
+ ok is_language_tag('x-borg-prot5123');
+ ok same_language_tag('x-borg-prot5123', 'i-BORG-Prot5123' );
+ ok !same_language_tag('en', 'en-us' );
+
+ ok 0 == similarity_language_tag('en-ca', 'fr-ca');
+ ok 1 == similarity_language_tag('en-ca', 'en-us');
+ ok 2 == similarity_language_tag('en-us-southern', 'en-us-western');
+ ok 2 == similarity_language_tag('en-us-southern', 'en-us');
+
+ ok grep $_ eq 'hi', panic_languages('kok');
+ ok grep $_ eq 'en', panic_languages('x-woozle-wuzzle');
+ ok ! grep $_ eq 'mr', panic_languages('it');
+ ok grep $_ eq 'es', panic_languages('it');
+ ok grep $_ eq 'it', panic_languages('es');
+
+
+ print "# Now the ::List tests...\n";
+ use I18N::LangTags::List;
+ foreach my $lt (qw(
+ en
+ en-us
+ en-kr
+ el
+ elx
+ i-mingo
+ i-mingo-tom
+ x-mingo-tom
+ it
+ it-it
+ it-IT
+ it-FR
+ yi
+ ji
+ cre-syllabic
+ cre-syllabic-western
+ cre-western
+ cre-latin
+ )) {
+ my $name = I18N::LangTags::List::name($lt);
+ if($name) {
+ ok(1);
+ print "# $lt -> $name\n";
+ } else {
+ ok(0);
+ print "# Failed lookup on $lt\n";
+ }
+ }
+
+ print "# So there!\n";
+
diff -c /dev/null 'perl-5.7.2/lib/IPC/Open2.t'
Index: ./lib/IPC/Open2.t
*** ./lib/IPC/Open2.t Thu Jan 1 02:00:00 1970
--- ./lib/IPC/Open2.t Mon Jul 9 17:10:36 2001
***************
*** 0 ****
--- 1,59 ----
+ #!./perl -w
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ 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))
+ {
+ print "1..0\n";
+ exit 0;
+ }
+ # make warnings fatal
+ $SIG{__WARN__} = sub { die @_ };
+ }
+
+ use strict;
+ use IO::Handle;
+ use IPC::Open2;
+ #require 'open2.pl'; use subs 'open2';
+
+ my $perl = './perl';
+
+ sub ok {
+ my ($n, $result, $info) = @_;
+ if ($result) {
+ print "ok $n\n";
+ }
+ else {
+ print "not ok $n\n";
+ print "# $info\n" if $info;
+ }
+ }
+
+ sub cmd_line {
+ if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
+ return qq/"$_[0]"/;
+ }
+ else {
+ return $_[0];
+ }
+ }
+
+ my ($pid, $reaped_pid);
+ STDOUT->autoflush;
+ STDERR->autoflush;
+
+ print "1..7\n";
+
+ ok 1, $pid = open2 'READ', 'WRITE', $perl, '-e',
+ cmd_line('print scalar <STDIN>');
+ ok 2, print WRITE "hi kid\n";
+ ok 3, <READ> =~ /^hi kid\r?\n$/;
+ ok 4, close(WRITE), $!;
+ ok 5, close(READ), $!;
+ $reaped_pid = waitpid $pid, 0;
+ ok 6, $reaped_pid == $pid, $reaped_pid;
+ ok 7, $? == 0, $?;
diff -c 'perl-5.7.1/lib/IPC/Open3.pm' 'perl-5.7.2/lib/IPC/Open3.pm'
Index: ./lib/IPC/Open3.pm
Prereq: 1.1
*** ./lib/IPC/Open3.pm Tue Mar 6 04:05:32 2001
--- ./lib/IPC/Open3.pm Mon Jul 9 17:10:36 2001
***************
*** 9,15 ****
use Carp;
use Symbol qw(gensym qualify);
! $VERSION = 1.0103;
@ISA = qw(Exporter);
@EXPORT = qw(open3);
--- 9,15 ----
use Carp;
use Symbol qw(gensym qualify);
! $VERSION = 1.0104;
@ISA = qw(Exporter);
@EXPORT = qw(open3);
diff -c /dev/null 'perl-5.7.2/lib/IPC/Open3.t'
Index: ./lib/IPC/Open3.t
*** ./lib/IPC/Open3.t Thu Jan 1 02:00:00 1970
--- ./lib/IPC/Open3.t Mon Jul 9 17:10:36 2001
***************
*** 0 ****
--- 1,150 ----
+ #!./perl -w
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ 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))
+ {
+ print "1..0\n";
+ exit 0;
+ }
+ # make warnings fatal
+ $SIG{__WARN__} = sub { die @_ };
+ }
+
+ use strict;
+ use IO::Handle;
+ use IPC::Open3;
+ #require 'open3.pl'; use subs 'open3';
+
+ my $perl = $^X;
+
+ sub ok {
+ my ($n, $result, $info) = @_;
+ if ($result) {
+ print "ok $n\n";
+ }
+ else {
+ print "not ok $n\n";
+ print "# $info\n" if $info;
+ }
+ }
+
+ sub cmd_line {
+ if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
+ my $cmd = shift;
+ $cmd =~ tr/\r\n//d;
+ $cmd =~ s/"/\\"/g;
+ return qq/"$cmd"/;
+ }
+ else {
+ return $_[0];
+ }
+ }
+
+ my ($pid, $reaped_pid);
+ STDOUT->autoflush;
+ STDERR->autoflush;
+
+ print "1..22\n";
+
+ # basic
+ ok 1, $pid = open3 'WRITE', 'READ', 'ERROR', $perl, '-e', cmd_line(<<'EOF');
+ $| = 1;
+ print scalar <STDIN>;
+ print STDERR "hi error\n";
+ EOF
+ ok 2, print WRITE "hi kid\n";
+ ok 3, <READ> =~ /^hi kid\r?\n$/;
+ ok 4, <ERROR> =~ /^hi error\r?\n$/;
+ ok 5, close(WRITE), $!;
+ ok 6, close(READ), $!;
+ ok 7, close(ERROR), $!;
+ $reaped_pid = waitpid $pid, 0;
+ ok 8, $reaped_pid == $pid, $reaped_pid;
+ ok 9, $? == 0, $?;
+
+ # read and error together, both named
+ $pid = open3 'WRITE', 'READ', 'READ', $perl, '-e', cmd_line(<<'EOF');
+ $| = 1;
+ print scalar <STDIN>;
+ print STDERR scalar <STDIN>;
+ EOF
+ print WRITE "ok 10\n";
+ print scalar <READ>;
+ print WRITE "ok 11\n";
+ print scalar <READ>;
+ waitpid $pid, 0;
+
+ # read and error together, error empty
+ $pid = open3 'WRITE', 'READ', '', $perl, '-e', cmd_line(<<'EOF');
+ $| = 1;
+ print scalar <STDIN>;
+ print STDERR scalar <STDIN>;
+ EOF
+ print WRITE "ok 12\n";
+ print scalar <READ>;
+ print WRITE "ok 13\n";
+ print scalar <READ>;
+ waitpid $pid, 0;
+
+ # dup writer
+ ok 14, pipe PIPE_READ, PIPE_WRITE;
+ $pid = open3 '<&PIPE_READ', 'READ', '',
+ $perl, '-e', cmd_line('print scalar <STDIN>');
+ close PIPE_READ;
+ print PIPE_WRITE "ok 15\n";
+ close PIPE_WRITE;
+ print scalar <READ>;
+ waitpid $pid, 0;
+
+ # dup reader
+ $pid = open3 'WRITE', '>&STDOUT', 'ERROR',
+ $perl, '-e', cmd_line('print scalar <STDIN>');
+ print WRITE "ok 16\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.
+ $pid = open3 'WRITE', 'READ', '>&STDOUT',
+ $perl, '-e', cmd_line('print STDERR scalar <STDIN>');
+ print WRITE "ok 17\n";
+ waitpid $pid, 0;
+
+ # dup reader and error together, both named
+ $pid = open3 'WRITE', '>&STDOUT', '>&STDOUT', $perl, '-e', cmd_line(<<'EOF');
+ $| = 1;
+ print STDOUT scalar <STDIN>;
+ print STDERR scalar <STDIN>;
+ EOF
+ print WRITE "ok 18\n";
+ print WRITE "ok 19\n";
+ 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
+ print WRITE "ok 20\n";
+ print WRITE "ok 21\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; };
+ if ($@) {
+ print "error $@\n";
+ print "not ok 22\n";
+ }
+ else {
+ print WRITE "ok 22\n";
+ waitpid $pid, 0;
+ }
diff -c /dev/null 'perl-5.7.2/lib/IPC/SysV.t'
Index: ./lib/IPC/SysV.t
*** ./lib/IPC/SysV.t Thu Jan 1 02:00:00 1970
--- ./lib/IPC/SysV.t Mon Jul 9 17:10:36 2001
***************
*** 0 ****
--- 1,218 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+
+ @INC = '../lib';
+
+ require Config; import Config;
+
+ my $reason;
+
+ if ($Config{'extensions'} !~ /\bIPC\/SysV\b/) {
+ $reason = 'IPC::SysV was not built';
+ } elsif ($Config{'d_sem'} ne 'define') {
+ $reason = '$Config{d_sem} undefined';
+ } elsif ($Config{'d_msg'} ne 'define') {
+ $reason = '$Config{d_msg} undefined';
+ }
+ if ($reason) {
+ print "1..0 # Skip: $reason\n";
+ exit 0;
+ }
+ }
+
+ # These constants are common to all tests.
+ # Later the sem* tests will import more for themselves.
+
+ use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID S_IRWXU);
+ use strict;
+
+ print "1..16\n";
+
+ my $msg;
+ my $sem;
+
+ $SIG{__DIE__} = 'cleanup'; # will cleanup $msg and $sem if needed
+
+ # FreeBSD is known to throw this if there's no SysV IPC in the kernel.
+ $SIG{SYS} = sub {
+ print STDERR <<EOM;
+ SIGSYS caught.
+ It may be that your kernel does not have SysV IPC configured.
+
+ EOM
+ if ($^O eq 'freebsd') {
+ print STDERR <<EOM;
+ You must have following options in your kernel:
+
+ options SYSVSHM
+ options SYSVSEM
+ options SYSVMSG
+
+ See config(8).
+ EOM
+ }
+ exit(1);
+ };
+
+ my $perm = S_IRWXU;
+
+ if ($Config{'d_msgget'} eq 'define' &&
+ $Config{'d_msgctl'} eq 'define' &&
+ $Config{'d_msgsnd'} eq 'define' &&
+ $Config{'d_msgrcv'} eq 'define') {
+
+ $msg = msgget(IPC_PRIVATE, $perm);
+ # Very first time called after machine is booted value may be 0
+ die "msgget failed: $!\n" unless defined($msg) && $msg >= 0;
+
+ print "ok 1\n";
+
+ #Putting a message on the queue
+ my $msgtype = 1;
+ my $msgtext = "hello";
+
+ my $test2bad;
+ my $test5bad;
+ my $test6bad;
+
+ unless (msgsnd($msg,pack("L! a*",$msgtype,$msgtext),IPC_NOWAIT)) {
+ print "not ";
+ $test2bad = 1;
+ }
+ print "ok 2\n";
+ if ($test2bad) {
+ print <<EOM;
+ #
+ # The failure of the subtest #2 may indicate that the message queue
+ # resource limits either of the system or of the testing account
+ # have been reached. Error message "Operating would block" is
+ # usually indicative of this situation. The error message was now:
+ # "$!"
+ #
+ # You can check the message queues with the 'ipcs' command and
+ # you can remove unneeded queues with the 'ipcrm -q id' command.
+ # You may also consider configuring your system or account
+ # to have more message queue resources.
+ #
+ # Because of the subtest #2 failing also the substests #5 and #6 will
+ # very probably also fail.
+ #
+ EOM
+ }
+
+ my $data;
+ msgctl($msg,IPC_STAT,$data) or print "not ";
+ print "ok 3\n";
+
+ print "not " unless length($data);
+ print "ok 4\n";
+
+ my $msgbuf;
+ unless (msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT)) {
+ print "not ";
+ $test5bad = 1;
+ }
+ print "ok 5\n";
+ if ($test5bad && $test2bad) {
+ print <<EOM;
+ #
+ # This failure was to be expected because the subtest #2 failed.
+ #
+ EOM
+ }
+
+ my($rmsgtype,$rmsgtext);
+ ($rmsgtype,$rmsgtext) = unpack("L! a*",$msgbuf);
+ unless ($rmsgtype == $msgtype && $rmsgtext eq $msgtext) {
+ print "not ";
+ $test6bad = 1;
+ }
+ print "ok 6\n";
+ if ($test6bad && $test2bad) {
+ print <<EOM;
+ #
+ # This failure was to be expected because the subtest #2 failed.
+ #
+ EOM
+ }
+ } else {
+ for (1..6) {
+ print "ok $_\n"; # fake it
+ }
+ }
+
+ if($Config{'d_semget'} eq 'define' &&
+ $Config{'d_semctl'} eq 'define') {
+
+ if ($Config{'d_semctl_semid_ds'} eq 'define' ||
+ $Config{'d_semctl_semun'} eq 'define') {
+
+ use IPC::SysV qw(IPC_CREAT GETALL SETALL);
+
+ $sem = semget(IPC_PRIVATE, 10, $perm | IPC_CREAT);
+ # Very first time called after machine is booted value may be 0
+ die "semget: $!\n" unless defined($sem) && $sem >= 0;
+
+ print "ok 7\n";
+
+ my $data;
+ semctl($sem,0,IPC_STAT,$data) or print "not ";
+ print "ok 8\n";
+
+ print "not " unless length($data);
+ print "ok 9\n";
+
+ my $nsem = 10;
+
+ semctl($sem,0,SETALL,pack("s!*",(0) x $nsem)) or print "not ";
+ print "ok 10\n";
+
+ $data = "";
+ semctl($sem,0,GETALL,$data) or print "not ";
+ print "ok 11\n";
+
+ print "not " unless length($data) == length(pack("s!*",(0) x $nsem));
+ print "ok 12\n";
+
+ my @data = unpack("s!*",$data);
+
+ my $adata = "0" x $nsem;
+
+ print "not " unless @data == $nsem and join("",@data) eq $adata;
+ print "ok 13\n";
+
+ my $poke = 2;
+
+ $data[$poke] = 1;
+ semctl($sem,0,SETALL,pack("s!*",@data)) or print "not ";
+ print "ok 14\n";
+
+ $data = "";
+ semctl($sem,0,GETALL,$data) or print "not ";
+ print "ok 15\n";
+
+ @data = unpack("s!*",$data);
+
+ my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1);
+
+ print "not " unless join("",@data) eq $bdata;
+ print "ok 16\n";
+ } else {
+ for (7..16) {
+ print "ok $_ # skipped, no semctl possible\n";
+ }
+ }
+ } else {
+ for (7..16) {
+ print "ok $_\n"; # fake it
+ }
+ }
+
+ sub cleanup {
+ msgctl($msg,IPC_RMID,0) if defined $msg;
+ semctl($sem,0,IPC_RMID,undef) if defined $sem;
+ }
+
+ cleanup;
diff -c /dev/null 'perl-5.7.2/lib/Locale/Codes/t/all.t'
Index: ./lib/Locale/Codes/t/all.t
*** ./lib/Locale/Codes/t/all.t Thu Jan 1 02:00:00 1970
--- ./lib/Locale/Codes/t/all.t Mon Jul 9 17:10:36 2001
***************
*** 0 ****
--- 1,366 ----
+ #!./perl
+ #
+ # all.t - tests for all_* routines in
+ # Locale::Country
+ # Locale::Language
+ # Locale::Currency
+ #
+ # There are four tests. We get a list of all codes, convert to
+ # language/country/currency, # convert back to code,
+ # and check that they're the same. Then we do the same,
+ # starting with list of languages/countries/currencies.
+ #
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use Locale::Country;
+ use Locale::Language;
+ use Locale::Currency;
+
+ print "1..12\n";
+
+ my $code;
+ my $language;
+ my $country;
+ my $ok;
+ my $reverse;
+ my $currency;
+
+
+ #-----------------------------------------------------------------------
+ # Old API - without codeset specified, default to ALPHA_2
+ #-----------------------------------------------------------------------
+ $ok = 1;
+ foreach $code (all_country_codes())
+ {
+ $country = code2country($code);
+ if (!defined $country)
+ {
+ $ok = 0;
+ last;
+ }
+ $reverse = country2code($country);
+ if (!defined $reverse)
+ {
+ $ok = 0;
+ last;
+ }
+ if ($reverse ne $code)
+ {
+ $ok = 0;
+ last;
+ }
+ }
+ print ($ok ? "ok 1\n" : "not ok 1\n");
+
+ #-----------------------------------------------------------------------
+ # code to country, back to code, for ALPHA2
+ #-----------------------------------------------------------------------
+ $ok = 1;
+ foreach $code (all_country_codes(LOCALE_CODE_ALPHA_2))
+ {
+ $country = code2country($code, LOCALE_CODE_ALPHA_2);
+ if (!defined $country)
+ {
+ $ok = 0;
+ last;
+ }
+ $reverse = country2code($country, LOCALE_CODE_ALPHA_2);
+ if (!defined $reverse)
+ {
+ $ok = 0;
+ last;
+ }
+ if ($reverse ne $code)
+ {
+ $ok = 0;
+ last;
+ }
+ }
+ print ($ok ? "ok 2\n" : "not ok 2\n");
+
+ #-----------------------------------------------------------------------
+ # code to country, back to code, for ALPHA3
+ #-----------------------------------------------------------------------
+ $ok = 1;
+ foreach $code (all_country_codes(LOCALE_CODE_ALPHA_3))
+ {
+ $country = code2country($code, LOCALE_CODE_ALPHA_3);
+ if (!defined $country)
+ {
+ $ok = 0;
+ last;
+ }
+ $reverse = country2code($country, LOCALE_CODE_ALPHA_3);
+ if (!defined $reverse)
+ {
+ $ok = 0;
+ last;
+ }
+ if ($reverse ne $code)
+ {
+ $ok = 0;
+ last;
+ }
+ }
+ print ($ok ? "ok 3\n" : "not ok 3\n");
+
+ #-----------------------------------------------------------------------
+ # code to country, back to code, for NUMERIC
+ #-----------------------------------------------------------------------
+ $ok = 1;
+ foreach $code (all_country_codes(LOCALE_CODE_NUMERIC))
+ {
+ $country = code2country($code, LOCALE_CODE_NUMERIC);
+ if (!defined $country)
+ {
+ $ok = 0;
+ last;
+ }
+ $reverse = country2code($country, LOCALE_CODE_NUMERIC);
+ if (!defined $reverse)
+ {
+ $ok = 0;
+ last;
+ }
+ if ($reverse ne $code)
+ {
+ $ok = 0;
+ last;
+ }
+ }
+ print ($ok ? "ok 4\n" : "not ok 4\n");
+
+
+ #-----------------------------------------------------------------------
+ # Old API - country to code, back to country, using default of ALPHA_2
+ #-----------------------------------------------------------------------
+ $ok = 1;
+ foreach $country (all_country_names())
+ {
+ $code = country2code($country);
+ if (!defined $code)
+ {
+ $ok = 0;
+ last;
+ }
+ $reverse = code2country($code);
+ if (!defined $reverse)
+ {
+ $ok = 0;
+ last;
+ }
+ if ($reverse ne $country)
+ {
+ $ok = 0;
+ last;
+ }
+ }
+ print ($ok ? "ok 5\n" : "not ok 5\n");
+
+ #-----------------------------------------------------------------------
+ # country to code, back to country, using LOCALE_CODE_ALPHA_2
+ #-----------------------------------------------------------------------
+ $ok = 1;
+ foreach $country (all_country_names())
+ {
+ $code = country2code($country, LOCALE_CODE_ALPHA_2);
+ if (!defined $code)
+ {
+ $ok = 0;
+ last;
+ }
+ $reverse = code2country($code, LOCALE_CODE_ALPHA_2);
+ if (!defined $reverse)
+ {
+ $ok = 0;
+ last;
+ }
+ if ($reverse ne $country)
+ {
+ $ok = 0;
+ last;
+ }
+ }
+ print ($ok ? "ok 6\n" : "not ok 6\n");
+
+ #-----------------------------------------------------------------------
+ # country to code, back to country, using LOCALE_CODE_ALPHA_3
+ #-----------------------------------------------------------------------
+ $ok = 1;
+ foreach $country (all_country_names())
+ {
+ $code = country2code($country, LOCALE_CODE_ALPHA_3);
+ if (!defined $code)
+ {
+ next if ($country eq 'Antarctica'
+ || $country eq 'Bouvet Island'
+ || $country eq 'Cocos (Keeling) Islands'
+ || $country eq 'Christmas Island'
+ || $country eq 'France, Metropolitan'
+ || $country eq 'South Georgia and the South Sandwich Islands'
+ || $country eq 'Heard Island and McDonald Islands'
+ || $country eq 'British Indian Ocean Territory'
+ || $country eq 'French Southern Territories'
+ || $country eq 'United States Minor Outlying Islands'
+ || $country eq 'Mayotte'
+ || $country eq 'Zaire');
+ $ok = 0;
+ last;
+ }
+ $reverse = code2country($code, LOCALE_CODE_ALPHA_3);
+ if (!defined $reverse)
+ {
+ $ok = 0;
+ last;
+ }
+ if ($reverse ne $country)
+ {
+ $ok = 0;
+ last;
+ }
+ }
+ print ($ok ? "ok 7\n" : "not ok 7\n");
+
+ #-----------------------------------------------------------------------
+ # country to code, back to country, using LOCALE_CODE_NUMERIC
+ #-----------------------------------------------------------------------
+ $ok = 1;
+ foreach $country (all_country_names())
+ {
+ $code = country2code($country, LOCALE_CODE_NUMERIC);
+ if (!defined $code)
+ {
+ next if ($country eq 'Antarctica'
+ || $country eq 'Bouvet Island'
+ || $country eq 'Cocos (Keeling) Islands'
+ || $country eq 'Christmas Island'
+ || $country eq 'France, Metropolitan'
+ || $country eq 'South Georgia and the South Sandwich Islands'
+ || $country eq 'Heard Island and McDonald Islands'
+ || $country eq 'British Indian Ocean Territory'
+ || $country eq 'French Southern Territories'
+ || $country eq 'United States Minor Outlying Islands'
+ || $country eq 'Mayotte'
+ || $country eq 'Zaire');
+ $ok = 0;
+ last;
+ }
+ $reverse = code2country($code, LOCALE_CODE_NUMERIC);
+ if (!defined $reverse)
+ {
+ $ok = 0;
+ last;
+ }
+ if ($reverse ne $country)
+ {
+ $ok = 0;
+ last;
+ }
+ }
+ print ($ok ? "ok 8\n" : "not ok 8\n");
+
+
+ $ok = 1;
+ foreach $code (all_language_codes())
+ {
+ $language = code2language($code);
+ if (!defined $language)
+ {
+ $ok = 0;
+ last;
+ }
+ $reverse = language2code($language);
+ if (!defined $reverse)
+ {
+ $ok = 0;
+ last;
+ }
+ if ($reverse ne $code)
+ {
+ $ok = 0;
+ last;
+ }
+ }
+ print ($ok ? "ok 9\n" : "not ok 9\n");
+
+
+ $ok = 1;
+ foreach $language (all_language_names())
+ {
+ $code = language2code($language);
+ if (!defined $code)
+ {
+ $ok = 0;
+ last;
+ }
+ $reverse = code2language($code);
+ if (!defined $reverse)
+ {
+ $ok = 0;
+ last;
+ }
+ if ($reverse ne $language)
+ {
+ $ok = 0;
+ last;
+ }
+ }
+ print ($ok ? "ok 10\n" : "not ok 10\n");
+
+ $ok = 1;
+ foreach $code (all_currency_codes())
+ {
+ $currency = code2currency($code);
+ if (!defined $currency)
+ {
+ $ok = 0;
+ last;
+ }
+ $reverse = currency2code($currency);
+ if (!defined $reverse)
+ {
+ $ok = 0;
+ last;
+ }
+ #
+ # three special cases:
+ # The Kwacha has two codes - used in Zambia and Malawi
+ # The Russian Ruble has two codes - rub and rur
+ # The Belarussian Ruble has two codes - byb and byr
+ if ($reverse ne $code
+ && $code ne 'mwk' && $code ne 'zmk'
+ && $code ne 'byr' && $code ne 'byb'
+ && $code ne 'rub' && $code ne 'rur')
+ {
+ $ok = 0;
+ last;
+ }
+ }
+ print ($ok ? "ok 11\n" : "not ok 11\n");
+
+ $ok = 1;
+ foreach $currency (all_currency_names())
+ {
+ $code = currency2code($currency);
+ if (!defined $code)
+ {
+ $ok = 0;
+ last;
+ }
+ $reverse = code2currency($code);
+ if (!defined $reverse)
+ {
+ $ok = 0;
+ last;
+ }
+ if ($reverse ne $currency)
+ {
+ $ok = 0;
+ last;
+ }
+ }
+ print ($ok ? "ok 12\n" : "not ok 12\n");
diff -c /dev/null 'perl-5.7.2/lib/Locale/Codes/t/constants.t'
Index: ./lib/Locale/Codes/t/constants.t
*** ./lib/Locale/Codes/t/constants.t Thu Jan 1 02:00:00 1970
--- ./lib/Locale/Codes/t/constants.t Mon Jul 9 17:10:36 2001
***************
*** 0 ****
--- 1,49 ----
+ #!./perl
+ #
+ # constants.t - tests for Locale::Constants
+ #
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use Locale::Constants;
+
+ print "1..3\n";
+
+ if (defined LOCALE_CODE_ALPHA_2
+ && defined LOCALE_CODE_ALPHA_3
+ && defined LOCALE_CODE_NUMERIC)
+ {
+ print "ok 1\n";
+ }
+ else
+ {
+ print "not ok 1\n";
+ }
+
+ if (LOCALE_CODE_ALPHA_2 != LOCALE_CODE_ALPHA_3
+ && LOCALE_CODE_ALPHA_2 != LOCALE_CODE_NUMERIC
+ && LOCALE_CODE_ALPHA_3 != LOCALE_CODE_NUMERIC)
+ {
+ print "ok 2\n";
+ }
+ else
+ {
+ print "not ok 2\n";
+ }
+
+ if (defined LOCALE_CODE_DEFAULT
+ && (LOCALE_CODE_DEFAULT == LOCALE_CODE_ALPHA_2
+ || LOCALE_CODE_DEFAULT == LOCALE_CODE_ALPHA_3
+ || LOCALE_CODE_DEFAULT == LOCALE_CODE_NUMERIC))
+ {
+ print "ok 3\n";
+ }
+ else
+ {
+ print "not ok 3\n";
+ }
+
+ exit 0;
diff -c /dev/null 'perl-5.7.2/lib/Locale/Codes/t/country.t'
Index: ./lib/Locale/Codes/t/country.t
*** ./lib/Locale/Codes/t/country.t Thu Jan 1 02:00:00 1970
--- ./lib/Locale/Codes/t/country.t Mon Jul 9 17:10:36 2001
***************
*** 0 ****
--- 1,114 ----
+ #!./perl
+ #
+ # country.t - tests for Locale::Country
+ #
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use Locale::Country;
+
+ #-----------------------------------------------------------------------
+ # This is an array of tests specs. Each spec is [TEST, OK_TO_DIE]
+ # Each TEST is eval'd as an expression.
+ # If it evaluates to FALSE, then "not ok N" is printed for the test,
+ # otherwise "ok N". If the eval dies, then the OK_TO_DIE flag is checked.
+ # If it is true (1), the test is treated as passing, otherwise it failed.
+ #-----------------------------------------------------------------------
+ @TESTS =
+ (
+ #================================================
+ # TESTS FOR code2country
+ #================================================
+
+ #---- selection of examples which should all result in undef -----------
+ ['!defined code2country()', 0], # no argument
+ ['!defined code2country(undef)', 0], # undef argument
+ ['!defined code2country("zz")', 0], # illegal code
+ ['!defined code2country("zz", LOCALE_CODE_ALPHA_2)', 0], # illegal code
+ ['!defined code2country("zz", LOCALE_CODE_ALPHA_3)', 0], # illegal code
+ ['!defined code2country("zz", LOCALE_CODE_NUMERIC)', 0], # illegal code
+ ['!defined code2country("ja")', 0], # should be jp for country
+ ['!defined code2country("uk")', 0], # should be jp for country
+
+ #---- some successful examples -----------------------------------------
+ ['code2country("BO") eq "Bolivia"', 0],
+ ['code2country("BO", LOCALE_CODE_ALPHA_2) eq "Bolivia"', 0],
+ ['code2country("bol", LOCALE_CODE_ALPHA_3) eq "Bolivia"', 0],
+ ['code2country("pk") eq "Pakistan"', 0],
+ ['code2country("sn") eq "Senegal"', 0],
+ ['code2country("us") eq "United States"', 0],
+ ['code2country("ad") eq "Andorra"', 0], # first in DATA segment
+ ['code2country("ad", LOCALE_CODE_ALPHA_2) eq "Andorra"', 0],
+ ['code2country("and", LOCALE_CODE_ALPHA_3) eq "Andorra"', 0],
+ ['code2country("020", LOCALE_CODE_NUMERIC) eq "Andorra"', 0],
+ ['code2country(48, LOCALE_CODE_NUMERIC) eq "Bahrain"', 0],
+ ['code2country("zw") eq "Zimbabwe"', 0], # last in DATA segment
+ ['code2country("gb") eq "United Kingdom"', 0], # United Kingdom is "gb", not "uk"
+
+ #================================================
+ # TESTS FOR country2code
+ #================================================
+
+ #---- selection of examples which should all result in undef -----------
+ ['!defined code2country("BO", LOCALE_CODE_ALPHA_3)', 0],
+ ['!defined code2country("BO", LOCALE_CODE_NUMERIC)', 0],
+ ['!defined country2code()', 0], # no argument
+ ['!defined country2code(undef)', 0], # undef argument
+ ['!defined country2code("Banana")', 0], # illegal country name
+
+ #---- some successful examples -----------------------------------------
+ ['country2code("japan") eq "jp"', 0],
+ ['country2code("japan") ne "ja"', 0],
+ ['country2code("Japan") eq "jp"', 0],
+ ['country2code("United States") eq "us"', 0],
+ ['country2code("United Kingdom") eq "gb"', 0],
+ ['country2code("Andorra") eq "ad"', 0], # first in DATA segment
+ ['country2code("Zimbabwe") eq "zw"', 0], # last in DATA segment
+
+ #================================================
+ # TESTS FOR country_code2code
+ #================================================
+
+ #---- selection of examples which should all result in undef -----------
+ ['!defined country_code2code("bo", LOCALE_CODE_ALPHA_3, LOCALE_CODE_ALPHA_3)', 0],
+ ['!defined country_code2code("zz", LOCALE_CODE_ALPHA_2, LOCALE_CODE_ALPHA_3)', 0],
+ ['!defined country_code2code("zz", LOCALE_CODE_ALPHA_3, LOCALE_CODE_ALPHA_3)', 0],
+ ['!defined country_code2code("zz", LOCALE_CODE_ALPHA_2)', 1],
+ ['!defined country_code2code("bo", LOCALE_CODE_ALPHA_2)', 1],
+ ['!defined country_code2code()', 1], # no argument
+ ['!defined country_code2code(undef)', 1], # undef argument
+
+ #---- some successful examples -----------------------------------------
+ ['country_code2code("BO", LOCALE_CODE_ALPHA_2, LOCALE_CODE_ALPHA_3) eq "bol"', 0],
+ ['country_code2code("bol", LOCALE_CODE_ALPHA_3, LOCALE_CODE_ALPHA_2) eq "bo"', 0],
+ ['country_code2code("zwe", LOCALE_CODE_ALPHA_3, LOCALE_CODE_ALPHA_2) eq "zw"', 0],
+ ['country_code2code("858", LOCALE_CODE_NUMERIC, LOCALE_CODE_ALPHA_3) eq "ury"', 0],
+ ['country_code2code(858, LOCALE_CODE_NUMERIC, LOCALE_CODE_ALPHA_3) eq "ury"', 0],
+ ['country_code2code("tr", LOCALE_CODE_ALPHA_2, LOCALE_CODE_NUMERIC) eq "792"', 0],
+
+ );
+
+ print "1..", int(@TESTS), "\n";
+
+ $testid = 1;
+ foreach $test (@TESTS)
+ {
+ eval "print (($test->[0]) ? \"ok $testid\\n\" : \"not ok $testid\\n\" )";
+ if ($@)
+ {
+ if (!$test->[1])
+ {
+ print "not ok $testid\n";
+ }
+ else
+ {
+ print "ok $testid\n";
+ }
+ }
+ ++$testid;
+ }
+
+ exit 0;
diff -c /dev/null 'perl-5.7.2/lib/Locale/Codes/t/currency.t'
Index: ./lib/Locale/Codes/t/currency.t
*** ./lib/Locale/Codes/t/currency.t Thu Jan 1 02:00:00 1970
--- ./lib/Locale/Codes/t/currency.t Mon Jul 9 17:10:36 2001
***************
*** 0 ****
--- 1,85 ----
+ #!./perl
+ #
+ # currency.t - tests for Locale::Currency
+ #
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use Locale::Currency;
+
+ #-----------------------------------------------------------------------
+ # This is an array of tests. Each test is eval'd as an expression.
+ # If it evaluates to FALSE, then "not ok N" is printed for the test,
+ # otherwise "ok N".
+ #-----------------------------------------------------------------------
+ @TESTS =
+ (
+ #================================================
+ # TESTS FOR code2currency
+ #================================================
+
+ #---- selection of examples which should all result in undef -----------
+ '!defined code2currency()', # no argument => undef returned
+ '!defined code2currency(undef)', # undef arg => undef returned
+ '!defined code2currency("zz")', # illegal code => undef
+ '!defined code2currency("zzzz")', # illegal code => undef
+ '!defined code2currency("zzz")', # illegal code => undef
+ '!defined code2currency("ukp")', # gbp for sterling, not ukp
+
+ #---- misc tests -------------------------------------------------------
+ 'code2currency("all") eq "Lek"',
+ 'code2currency("ats") eq "Schilling"',
+ 'code2currency("bob") eq "Boliviano"',
+ 'code2currency("bnd") eq "Brunei Dollar"',
+ 'code2currency("cop") eq "Colombian Peso"',
+ 'code2currency("dkk") eq "Danish Krone"',
+ 'code2currency("fjd") eq "Fiji Dollar"',
+ 'code2currency("idr") eq "Rupiah"',
+ 'code2currency("chf") eq "Swiss Franc"',
+ 'code2currency("mvr") eq "Rufiyaa"',
+ 'code2currency("mmk") eq "Kyat"',
+ 'code2currency("mwk") eq "Kwacha"', # two different codes for Kwacha
+ 'code2currency("zmk") eq "Kwacha"', # used in Zambia and Malawi
+ 'code2currency("byr") eq "Belarussian Ruble"', # 2 codes for belarussian ruble
+ 'code2currency("byb") eq "Belarussian Ruble"', #
+ 'code2currency("rub") eq "Russian Ruble"', # 2 codes for russian ruble
+ 'code2currency("rur") eq "Russian Ruble"', #
+
+ #---- some successful examples -----------------------------------------
+ 'code2currency("BOB") eq "Boliviano"',
+ 'code2currency("adp") eq "Andorran Peseta"', # first in DATA segment
+ 'code2currency("zwd") eq "Zimbabwe Dollar"', # last in DATA segment
+
+ #================================================
+ # TESTS FOR currency2code
+ #================================================
+
+ #---- selection of examples which should all result in undef -----------
+ '!defined currency2code()', # no argument => undef returned
+ '!defined currency2code(undef)', # undef arg => undef returned
+ '!defined currency2code("")', # empty string => undef returned
+ '!defined currency2code("Banana")', # illegal curr name => undef
+
+ #---- some successful examples -----------------------------------------
+ 'currency2code("Kroon") eq "eek"',
+ 'currency2code("Markka") eq "fim"',
+ 'currency2code("Riel") eq "khr"',
+ 'currency2code("PULA") eq "bwp"',
+ 'currency2code("Andorran Peseta") eq "adp"', # first in DATA segment
+ 'currency2code("Zimbabwe Dollar") eq "zwd"', # last in DATA segment
+ );
+
+ print "1..", int(@TESTS), "\n";
+
+ $testid = 1;
+ foreach $test (@TESTS)
+ {
+ eval "print (($test) ? \"ok $testid\\n\" : \"not ok $testid\\n\" )";
+ print "not ok $testid\n" if $@;
+ ++$testid;
+ }
+
+ exit 0;
diff -c /dev/null 'perl-5.7.2/lib/Locale/Codes/t/languages.t'
Index: ./lib/Locale/Codes/t/languages.t
*** ./lib/Locale/Codes/t/languages.t Thu Jan 1 02:00:00 1970
--- ./lib/Locale/Codes/t/languages.t Mon Jul 9 17:10:36 2001
***************
*** 0 ****
--- 1,110 ----
+ #!./perl
+ #
+ # language.t - tests for Locale::Language
+ #
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use Locale::Language;
+
+ no utf8; # so that the naked 8-bit characters won't gripe under use utf8
+
+ #-----------------------------------------------------------------------
+ # This is an array of tests. Each test is eval'd as an expression.
+ # If it evaluates to FALSE, then "not ok N" is printed for the test,
+ # otherwise "ok N".
+ #-----------------------------------------------------------------------
+ @TESTS =
+ (
+ #================================================
+ # TESTS FOR code2language
+ #================================================
+
+ #---- selection of examples which should all result in undef -----------
+ '!defined code2language()', # no argument => undef returned
+ '!defined code2language(undef)', # undef arg => undef returned
+ '!defined code2language("zz")', # illegal code => undef
+ '!defined code2language("jp")', # ja for lang, jp for country
+
+ #---- test recent changes ----------------------------------------------
+ 'code2language("ae") eq "Avestan"',
+ 'code2language("bs") eq "Bosnian"',
+ 'code2language("ch") eq "Chamorro"',
+ 'code2language("ce") eq "Chechen"',
+ 'code2language("cu") eq "Church Slavic"',
+ 'code2language("cv") eq "Chuvash"',
+ 'code2language("hz") eq "Herero"',
+ 'code2language("ho") eq "Hiri Motu"',
+ 'code2language("ki") eq "Kikuyu"',
+ 'code2language("kj") eq "Kuanyama"',
+ 'code2language("kv") eq "Komi"',
+ 'code2language("mh") eq "Marshall"',
+ 'code2language("nv") eq "Navajo"',
+ 'code2language("nr") eq "Ndebele, South"',
+ 'code2language("nd") eq "Ndebele, North"',
+ 'code2language("ng") eq "Ndonga"',
+ 'code2language("nn") eq "Norwegian Nynorsk"',
+ 'code2language("nb") eq "Norwegian Bokm�l"',
+ 'code2language("ny") eq "Chichewa; Nyanja"',
+ 'code2language("oc") eq "Occitan (post 1500)"',
+ 'code2language("os") eq "Ossetian; Ossetic"',
+ 'code2language("pi") eq "Pali"',
+ '!defined code2language("sh")', # Serbo-Croatian withdrawn
+ 'code2language("se") eq "Sami"',
+ 'code2language("sc") eq "Sardinian"',
+ 'code2language("kw") eq "Cornish"',
+ 'code2language("gv") eq "Manx"',
+ 'code2language("lb") eq "Letzeburgesch"',
+ 'code2language("he") eq "Hebrew"',
+ '!defined code2language("iw")', # Hebrew withdrawn
+ 'code2language("id") eq "Indonesian"',
+ '!defined code2language("in")', # Indonesian withdrawn
+ 'code2language("iu") eq "Inuktitut"',
+ 'code2language("ug") eq "Uighur"',
+ '!defined code2language("ji")', # Yiddish withdrawn
+ 'code2language("yi") eq "Yiddish"',
+ 'code2language("za") eq "Zhuang"',
+
+ #---- some successful examples -----------------------------------------
+ 'code2language("DA") eq "Danish"',
+ 'code2language("eo") eq "Esperanto"',
+ 'code2language("fi") eq "Finnish"',
+ 'code2language("en") eq "English"',
+ 'code2language("aa") eq "Afar"', # first in DATA segment
+ 'code2language("zu") eq "Zulu"', # last in DATA segment
+
+ #================================================
+ # TESTS FOR language2code
+ #================================================
+
+ #---- selection of examples which should all result in undef -----------
+ '!defined language2code()', # no argument => undef returned
+ '!defined language2code(undef)', # undef arg => undef returned
+ '!defined language2code("Banana")', # illegal lang name => undef
+
+ #---- some successful examples -----------------------------------------
+ 'language2code("Japanese") eq "ja"',
+ 'language2code("japanese") eq "ja"',
+ 'language2code("japanese") ne "jp"',
+ 'language2code("French") eq "fr"',
+ 'language2code("Greek") eq "el"',
+ 'language2code("english") eq "en"',
+ 'language2code("ESTONIAN") eq "et"',
+ 'language2code("Afar") eq "aa"', # first in DATA segment
+ 'language2code("Zulu") eq "zu"', # last in DATA segment
+ );
+
+ print "1..", int(@TESTS), "\n";
+
+ $testid = 1;
+ foreach $test (@TESTS)
+ {
+ eval "print (($test) ? \"ok $testid\\n\" : \"not ok $testid\\n\" )";
+ print "not ok $testid\n" if $@;
+ ++$testid;
+ }
+
+ exit 0;
diff -c /dev/null 'perl-5.7.2/lib/Locale/Codes/t/uk.t'
Index: ./lib/Locale/Codes/t/uk.t
*** ./lib/Locale/Codes/t/uk.t Thu Jan 1 02:00:00 1970
--- ./lib/Locale/Codes/t/uk.t Mon Jul 9 17:10:36 2001
***************
*** 0 ****
--- 1,70 ----
+ #!./perl
+ #
+ # uk.t - tests for Locale::Country with "uk" aliases to "gb"
+ #
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use Locale::Country;
+
+ Locale::Country::_alias_code('uk' => 'gb');
+
+ #-----------------------------------------------------------------------
+ # This is an array of tests. Each test is eval'd as an expression.
+ # If it evaluates to FALSE, then "not ok N" is printed for the test,
+ # otherwise "ok N".
+ #-----------------------------------------------------------------------
+ @TESTS =
+ (
+ #================================================
+ # TESTS FOR code2country
+ #================================================
+
+ #---- selection of examples which should all result in undef -----------
+ '!defined code2country()', # no argument
+ '!defined code2country(undef)', # undef argument
+ '!defined code2country("zz")', # illegal code
+ '!defined code2country("ja")', # should be jp for country
+
+ #---- some successful examples -----------------------------------------
+ 'code2country("BO") eq "Bolivia"',
+ 'code2country("pk") eq "Pakistan"',
+ 'code2country("sn") eq "Senegal"',
+ 'code2country("us") eq "United States"',
+ 'code2country("ad") eq "Andorra"', # first in DATA segment
+ 'code2country("zw") eq "Zimbabwe"', # last in DATA segment
+ 'code2country("uk") eq "United Kingdom"', # normally "gb"
+
+ #================================================
+ # TESTS FOR country2code
+ #================================================
+
+ #---- selection of examples which should all result in undef -----------
+ '!defined country2code()', # no argument
+ '!defined country2code(undef)', # undef argument
+ '!defined country2code("Banana")', # illegal country name
+
+ #---- some successful examples -----------------------------------------
+ 'country2code("japan") eq "jp"',
+ 'country2code("japan") ne "ja"',
+ 'country2code("Japan") eq "jp"',
+ 'country2code("United States") eq "us"',
+ 'country2code("United Kingdom") eq "uk"',
+ 'country2code("Andorra") eq "ad"', # first in DATA segment
+ 'country2code("Zimbabwe") eq "zw"', # last in DATA segment
+ );
+
+ print "1..", int(@TESTS), "\n";
+
+ $testid = 1;
+ foreach $test (@TESTS)
+ {
+ eval "print (($test) ? \"ok $testid\\n\" : \"not ok $testid\\n\" )";
+ print "not ok $testid\n" if $@;
+ ++$testid;
+ }
+
+ exit 0;
diff -c /dev/null 'perl-5.7.2/lib/Locale/Maketext.pm'
Index: ./lib/Locale/Maketext.pm
*** ./lib/Locale/Maketext.pm Thu Jan 1 02:00:00 1970
--- ./lib/Locale/Maketext.pm Mon Jul 9 17:10:36 2001
***************
*** 0 ****
--- 1,675 ----
+
+ # Time-stamp: "2001-06-21 23:09:33 MDT"
+
+ require 5;
+ package Locale::Maketext;
+ use strict;
+ use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
+ $USE_LITERALS);
+ use Carp ();
+ use I18N::LangTags 0.21 ();
+
+ #--------------------------------------------------------------------------
+
+ BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
+ # define the constant 'DEBUG' at compile-time
+
+ $VERSION = "1.03";
+ @ISA = ();
+
+ $MATCH_SUPERS = 1;
+ $USING_LANGUAGE_TAGS = 1;
+ # Turning this off is somewhat of a security risk in that little or no
+ # checking will be done on the legality of tokens passed to the
+ # eval("use $module_name") in _try_use. If you turn this off, you have
+ # to do your own taint checking.
+
+ $USE_LITERALS = 1 unless defined $USE_LITERALS;
+ # a hint for compiling bracket-notation things.
+
+ my %isa_scan = ();
+
+ ###########################################################################
+
+ sub quant {
+ my($handle, $num, @forms) = @_;
+
+ return $num if @forms == 0; # what should this mean?
+ return $forms[2] if @forms > 2 and $num == 0; # special zeroth case
+
+ # Normal case:
+ # Note that the formatting of $num is preserved.
+ return( $handle->numf($num) . ' ' . $handle->numerate($num, @forms) );
+ # Most human languages put the number phrase before the qualified phrase.
+ }
+
+
+ sub numerate {
+ # return this lexical item in a form appropriate to this number
+ my($handle, $num, @forms) = @_;
+ my $s = ($num == 1);
+
+ return '' unless @forms;
+ if(@forms == 1) { # only the headword form specified
+ return $s ? $forms[0] : ($forms[0] . 's'); # very cheap hack.
+ } else { # sing and plural were specified
+ return $s ? $forms[0] : $forms[1];
+ }
+ }
+
+ #--------------------------------------------------------------------------
+
+ sub numf {
+ my($handle, $num) = @_[0,1];
+ if($num < 10_000_000_000 and $num > -10_000_000_000 and $num == int($num)) {
+ $num += 0; # Just use normal integer stringification.
+ # Specifically, don't let %G turn ten million into 1E+007
+ } else {
+ $num = CORE::sprintf("%G", $num);
+ # "CORE::" is there to avoid confusion with the above sub sprintf.
+ }
+ while( $num =~ s/^([-+]?\d+)(\d{3})/$1,$2/s ) {1} # right from perlfaq5
+ # The initial \d+ gobbles as many digits as it can, and then we
+ # backtrack so it un-eats the rightmost three, and then we
+ # insert the comma there.
+
+ $num =~ tr<.,><,.> if ref($handle) and $handle->{'numf_comma'};
+ # This is just a lame hack instead of using Number::Format
+ return $num;
+ }
+
+ sub sprintf {
+ no integer;
+ my($handle, $format, @params) = @_;
+ return CORE::sprintf($format, @params);
+ # "CORE::" is there to avoid confusion with myself!
+ }
+
+ #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#
+
+ use integer; # vroom vroom... applies to the whole rest of the module
+
+ sub language_tag {
+ my $it = ref($_[0]) || $_[0];
+ return undef unless $it =~ m/([^':]+)(?:::)?$/s;
+ $it = lc($1);
+ $it =~ tr<_><->;
+ return $it;
+ }
+
+ sub encoding {
+ my $it = $_[0];
+ return(
+ (ref($it) && $it->{'encoding'})
+ || "iso-8859-1" # Latin-1
+ );
+ }
+
+ #--------------------------------------------------------------------------
+
+ sub fallback_languages { return('i-default', 'en', 'en-US') }
+
+ sub fallback_language_classes { return () }
+
+ #--------------------------------------------------------------------------
+
+ sub fail_with { # an actual attribute method!
+ my($handle, @params) = @_;
+ return unless ref($handle);
+ $handle->{'fail'} = $params[0] if @params;
+ return $handle->{'fail'};
+ }
+
+ #--------------------------------------------------------------------------
+
+ sub failure_handler_auto {
+ # Meant to be used like:
+ # $handle->fail_with('failure_handler_auto')
+
+ my($handle, $phrase, @params) = @_;
+ $handle->{'failure_lex'} ||= {};
+ my $lex = $handle->{'failure_lex'};
+
+ my $value;
+ $lex->{$phrase} ||= ($value = $handle->_compile($phrase));
+
+ # Dumbly copied from sub maketext:
+ {
+ local $SIG{'__DIE__'};
+ eval { $value = &$value($handle, @_) };
+ }
+ # If we make it here, there was an exception thrown in the
+ # call to $value, and so scream:
+ if($@) {
+ my $err = $@;
+ # pretty up the error message
+ $err =~ s<\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?>
+ <\n in bracket code [compiled line $1],>s;
+ #$err =~ s/\n?$/\n/s;
+ Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
+ # Rather unexpected, but suppose that the sub tried calling
+ # a method that didn't exist.
+ } else {
+ return $value;
+ }
+ }
+
+ #==========================================================================
+
+ sub new {
+ # Nothing fancy!
+ my $class = ref($_[0]) || $_[0];
+ my $handle = bless {}, $class;
+ $handle->init;
+ return $handle;
+ }
+
+ sub init { return } # no-op
+
+ ###########################################################################
+
+ sub maketext {
+ # Remember, this can fail. Failure is controllable many ways.
+ Carp::croak "maketext requires at least one parameter" unless @_ > 1;
+
+ my($handle, $phrase) = splice(@_,0,2);
+
+ # Look up the value:
+
+ my $value;
+ foreach my $h_r (
+ @{ $isa_scan{ref($handle) || $handle} || $handle->_lex_refs }
+ ) {
+ print "* Looking up \"$phrase\" in $h_r\n" if DEBUG;
+ if(exists $h_r->{$phrase}) {
+ print " Found \"$phrase\" in $h_r\n" if DEBUG;
+ unless(ref($value = $h_r->{$phrase})) {
+ # Nonref means it's not yet compiled. Compile and replace.
+ $value = $h_r->{$phrase} = $handle->_compile($value);
+ }
+ last;
+ } elsif($phrase !~ m/^_/s and $h_r->{'_AUTO'}) {
+ # it's an auto lex, and this is an autoable key!
+ print " Automaking \"$phrase\" into $h_r\n" if DEBUG;
+
+ $value = $h_r->{$phrase} = $handle->_compile($phrase);
+ last;
+ }
+ print " Not found in $h_r, nor automakable\n" if DEBUG > 1;
+ # else keep looking
+ }
+
+ unless(defined($value)) {
+ print "! Lookup of \"$phrase\" in/under ", ref($handle) || $handle,
+ " fails.\n" if DEBUG;
+ if(ref($handle) and $handle->{'fail'}) {
+ print "WARNING0: maketext fails looking for <$phrase>\n" if DEBUG;
+ my $fail;
+ if(ref($fail = $handle->{'fail'}) eq 'CODE') { # it's a sub reference
+ return &{$fail}($handle, $phrase, @_);
+ # If it ever returns, it should return a good value.
+ } else { # It's a method name
+ return $handle->$fail($phrase, @_);
+ # If it ever returns, it should return a good value.
+ }
+ } else {
+ # All we know how to do is this;
+ Carp::croak("maketext doesn't know how to say:\n$phrase\nas needed");
+ }
+ }
+
+ return $$value if ref($value) eq 'SCALAR';
+ return $value unless ref($value) eq 'CODE';
+
+ {
+ local $SIG{'__DIE__'};
+ eval { $value = &$value($handle, @_) };
+ }
+ # If we make it here, there was an exception thrown in the
+ # call to $value, and so scream:
+ if($@) {
+ my $err = $@;
+ # pretty up the error message
+ $err =~ s<\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?>
+ <\n in bracket code [compiled line $1],>s;
+ #$err =~ s/\n?$/\n/s;
+ Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
+ # Rather unexpected, but suppose that the sub tried calling
+ # a method that didn't exist.
+ } else {
+ return $value;
+ }
+ }
+
+ ###########################################################################
+
+ sub get_handle { # This is a constructor and, yes, it CAN FAIL.
+ # Its class argument has to be the base class for the current
+ # application's l10n files.
+ my($base_class, @languages) = @_;
+ $base_class = ref($base_class) || $base_class;
+ # Complain if they use __PACKAGE__ as a project base class?
+
+ unless(@languages) { # Calling with no args is magical! wooo, magic!
+ if(length( $ENV{'REQUEST_METHOD'} || '' )) { # I'm a CGI
+ my $in = $ENV{'HTTP_ACCEPT_LANGUAGE'} || '';
+ # supposedly that works under mod_perl, too.
+ $in =~ s<\([\)]*\)><>g; # Kill parens'd things -- just a hack.
+ @languages = &I18N::LangTags::extract_language_tags($in) if length $in;
+ # ...which untaints, incidentally.
+
+ } else { # Not running as a CGI: try to puzzle out from the environment
+ if(length( $ENV{'LANG'} || '' )) {
+ push @languages, split m/[,:]/, $ENV{'LANG'};
+ # LANG can be only /one/ locale as far as I know, but what the hey.
+ }
+ if(length( $ENV{'LANGUAGE'} || '' )) {
+ push @languages, split m/[,:]/, $ENV{'LANGUAGE'};
+ }
+ print "Noting ENV LANG ", join(',', @languages),"\n" if DEBUG;
+ # Those are really locale IDs, but they get xlated a few lines down.
+
+ if(&_try_use('Win32::Locale')) {
+ # If we have that module installed...
+ push @languages, Win32::Locale::get_language()
+ if defined &Win32::Locale::get_language;
+ }
+ }
+ }
+
+ #------------------------------------------------------------------------
+ print "Lgs1: ", map("<$_>", @languages), "\n" if DEBUG;
+
+ if($USING_LANGUAGE_TAGS) {
+ @languages = map &I18N::LangTags::locale2language_tag($_), @languages;
+ # if it's a lg tag, fine, pass thru (untainted)
+ # if it's a locale ID, try converting to a lg tag (untainted),
+ # otherwise nix it.
+
+ push @languages, map I18N::LangTags::super_languages($_), @languages
+ if $MATCH_SUPERS;
+
+ @languages = map { $_, I18N::LangTags::alternate_language_tags($_) }
+ @languages; # catch alternation
+
+ push @languages, I18N::LangTags::panic_languages(@languages)
+ if defined &I18N::LangTags::panic_languages;
+
+ push @languages, $base_class->fallback_languages;
+ # You are free to override fallback_languages to return empty-list!
+
+ @languages = # final bit of processing:
+ map {
+ my $it = $_; # copy
+ $it =~ tr<-A-Z><_a-z>; # lc, and turn - to _
+ $it =~ tr<_a-z0-9><>cd; # remove all but a-z0-9_
+ $it;
+ } @languages
+ ;
+ }
+ print "Lgs2: ", map("<$_>", @languages), "\n" if DEBUG > 1;
+
+ push @languages, $base_class->fallback_language_classes;
+ # You are free to override that to return whatever.
+
+
+ my %seen = ();
+ foreach my $module_name ( map { $base_class . "::" . $_ } @languages )
+ {
+ next unless length $module_name; # sanity
+ next if $seen{$module_name}++ # Already been here, and it was no-go
+ || !&_try_use($module_name); # Try to use() it, but can't it.
+ return($module_name->new); # Make it!
+ }
+
+ return undef; # Fail!
+ }
+
+ ###########################################################################
+ #
+ # This is where most people should stop reading.
+ #
+ ###########################################################################
+
+ sub _compile {
+ # This big scarp routine compiles an entry.
+ # It returns either a coderef if there's brackety bits in this, or
+ # otherwise a ref to a scalar.
+
+ my $target = ref($_[0]) || $_[0];
+
+ my(@code);
+ my(@c) = (''); # "chunks" -- scratch.
+ my $call_count = 0;
+ my $big_pile = '';
+ {
+ my $in_group = 0; # start out outside a group
+ my($m, @params); # scratch
+
+ while($_[1] =~ # Iterate over chunks.
+ m<\G(
+ [^\~\[\]]+ # non-~[] stuff
+ |
+ ~. # ~[, ~], ~~, ~other
+ |
+ \[ # [ presumably opening a group
+ |
+ \] # ] presumably closing a group
+ |
+ ~ # terminal ~ ?
+ |
+ $
+ )>xgs
+ ) {
+ print " \"$1\"\n" if DEBUG > 2;
+
+ if($1 eq '[' or $1 eq '') { # "[" or end
+ # Whether this is "[" or end, force processing of any
+ # preceding literal.
+ if($in_group) {
+ if($1 eq '') {
+ $target->_die_pointing($_[1], "Unterminated bracket group");
+ } else {
+ $target->_die_pointing($_[1], "You can't nest bracket groups");
+ }
+ } else {
+ if($1 eq '') {
+ print " [end-string]\n" if DEBUG > 2;
+ } else {
+ $in_group = 1;
+ }
+ die "How come \@c is empty?? in <$_[1]>" unless @c; # sanity
+ if(length $c[-1]) {
+ # Now actually processing the preceding literal
+ $big_pile .= $c[-1];
+ if($USE_LITERALS and (
+ (ord('A') == 65)
+ ? $c[-1] !~ m<[^\x20-\x7E]>s
+ # ASCII very safe chars
+ : $c[-1] !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
+ # EBCDIC very safe chars
+ )) {
+ # normal case -- all very safe chars
+ $c[-1] =~ s/'/\\'/g;
+ push @code, q{ '} . $c[-1] . "',\n";
+ $c[-1] = ''; # reuse this slot
+ } else {
+ push @code, ' $c[' . $#c . "],\n";
+ push @c, ''; # new chunk
+ }
+ }
+ # else just ignore the empty string.
+ }
+
+ } elsif($1 eq ']') { # "]"
+ # close group -- go back in-band
+ if($in_group) {
+ $in_group = 0;
+
+ print " --Closing group [$c[-1]]\n" if DEBUG > 2;
+
+ # And now process the group...
+
+ if(!length($c[-1]) or $c[-1] =~ m/^\s+$/s) {
+ DEBUG > 2 and print " -- (Ignoring)\n";
+ $c[-1] = ''; # reset out chink
+ next;
+ }
+
+ #$c[-1] =~ s/^\s+//s;
+ #$c[-1] =~ s/\s+$//s;
+ ($m,@params) = split(",", $c[-1], -1); # was /\s*,\s*/
+
+ # A bit of a hack -- we've turned "~,"'s into DELs, so turn
+ # 'em into real commas here.
+ if (ord('A') == 65) { # ASCII, etc
+ foreach($m, @params) { tr/\x7F/,/ }
+ } else { # EBCDIC (1047, 0037, POSIX-BC)
+ # Thanks to Peter Prymmer for the EBCDIC handling
+ foreach($m, @params) { tr/\x07/,/ }
+ }
+
+ # Special-case handling of some method names:
+ if($m eq '_*' or $m =~ m<^_(-?\d+)$>s) {
+ # Treat [_1,...] as [,_1,...], etc.
+ unshift @params, $m;
+ $m = '';
+ } elsif($m eq '*') {
+ $m = 'quant'; # "*" for "times": "4 cars" is 4 times "cars"
+ } elsif($m eq '#') {
+ $m = 'numf'; # "#" for "number": [#,_1] for "the number _1"
+ }
+
+ # Most common case: a simple, legal-looking method name
+ if($m eq '') {
+ # 0-length method name means to just interpolate:
+ push @code, ' (';
+ } elsif($m =~ m<^\w+(?:\:\:\w+)*$>s
+ and $m !~ m<(?:^|\:)\d>s
+ # exclude starting a (sub)package or symbol with a digit
+ ) {
+ # Yes, it even supports the demented (and undocumented?)
+ # $obj->Foo::bar(...) syntax.
+ $target->_die_pointing(
+ $_[1], "Can't (yet?) use \"SUPER::\" in a bracket-group method",
+ 2 + length($c[-1])
+ )
+ if $m =~ m/^SUPER::/s;
+ # Because for SUPER:: to work, we'd have to compile this into
+ # the right package, and that seems just not worth the bother,
+ # unless someone convinces me otherwise.
+
+ push @code, ' $_[0]->' . $m . '(';
+ } else {
+ # TODO: implement something? or just too icky to consider?
+ $target->_die_pointing(
+ $_[1],
+ "Can't use \"$m\" as a method name in bracket group",
+ 2 + length($c[-1])
+ );
+ }
+
+ pop @c; # we don't need that chunk anymore
+ ++$call_count;
+
+ foreach my $p (@params) {
+ if($p eq '_*') {
+ # Meaning: all parameters except $_[0]
+ $code[-1] .= ' @_[1 .. $#_], ';
+ # and yes, that does the right thing for all @_ < 3
+ } elsif($p =~ m<^_(-?\d+)$>s) {
+ # _3 meaning $_[3]
+ $code[-1] .= '$_[' . (0 + $1) . '], ';
+ } elsif($USE_LITERALS and (
+ (ord('A') == 65)
+ ? $p !~ m<[^\x20-\x7E]>s
+ # ASCII very safe chars
+ : $p !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
+ # EBCDIC very safe chars
+ )) {
+ # Normal case: a literal containing only safe characters
+ $p =~ s/'/\\'/g;
+ $code[-1] .= q{'} . $p . q{', };
+ } else {
+ # Stow it on the chunk-stack, and just refer to that.
+ push @c, $p;
+ push @code, ' $c[' . $#c . "], ";
+ }
+ }
+ $code[-1] .= "),\n";
+
+ push @c, '';
+ } else {
+ $target->_die_pointing($_[1], "Unbalanced ']'");
+ }
+
+ } elsif(substr($1,0,1) ne '~') {
+ # it's stuff not containing "~" or "[" or "]"
+ # i.e., a literal blob
+ $c[-1] .= $1;
+
+ } elsif($1 eq '~~') { # "~~"
+ $c[-1] .= '~';
+
+ } elsif($1 eq '~[') { # "~["
+ $c[-1] .= '[';
+
+ } elsif($1 eq '~]') { # "~]"
+ $c[-1] .= ']';
+
+ } elsif($1 eq '~,') { # "~,"
+ if($in_group) {
+ # This is a hack, based on the assumption that no-one will actually
+ # want a DEL inside a bracket group. Let's hope that's it's true.
+ if (ord('A') == 65) { # ASCII etc
+ $c[-1] .= "\x7F";
+ } else { # EBCDIC (cp 1047, 0037, POSIX-BC)
+ $c[-1] .= "\x07";
+ }
+ } else {
+ $c[-1] .= '~,';
+ }
+
+ } elsif($1 eq '~') { # possible only at string-end, it seems.
+ $c[-1] .= '~';
+
+ } else {
+ # It's a "~X" where X is not a special character.
+ # Consider it a literal ~ and X.
+ $c[-1] .= $1;
+ }
+ }
+ }
+
+ if($call_count) {
+ undef $big_pile; # Well, nevermind that.
+ } else {
+ # It's all literals! Ahwell, that can happen.
+ # So don't bother with the eval. Return a SCALAR reference.
+ return \$big_pile;
+ }
+
+ die "Last chunk isn't null??" if @c and length $c[-1]; # sanity
+ print scalar(@c), " chunks under closure\n" if DEBUG;
+ if(@code == 0) { # not possible?
+ print "Empty code\n" if DEBUG;
+ return \'';
+ } elsif(@code > 1) { # most cases, presumably!
+ unshift @code, "join '',\n";
+ }
+ unshift @code, "use strict; sub {\n";
+ push @code, "}\n";
+
+ print @code if DEBUG;
+ my $sub = eval(join '', @code);
+ die "$@ while evalling" . join('', @code) if $@; # Should be impossible.
+ return $sub;
+ }
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ sub _die_pointing {
+ # This is used by _compile to throw a fatal error
+ my $target = shift; # class name
+ # ...leaving $_[0] the error-causing text, and $_[1] the error message
+
+ my $i = index($_[0], "\n");
+
+ my $pointy;
+ my $pos = pos($_[0]) - (defined($_[2]) ? $_[2] : 0) - 1;
+ if($pos < 1) {
+ $pointy = "^=== near there\n";
+ } else { # we need to space over
+ my $first_tab = index($_[0], "\t");
+ if($pos > 2 and ( -1 == $first_tab or $first_tab > pos($_[0]))) {
+ # No tabs, or the first tab is harmlessly after where we will point to,
+ # AND we're far enough from the margin that we can draw a proper arrow.
+ $pointy = ('=' x $pos) . "^ near there\n";
+ } else {
+ # tabs screw everything up!
+ $pointy = substr($_[0],0,$pos);
+ $pointy =~ tr/\t //cd;
+ # make everything into whitespace, but preseving tabs
+ $pointy .= "^=== near there\n";
+ }
+ }
+
+ my $errmsg = "$_[1], in\:\n$_[0]";
+
+ if($i == -1) {
+ # No newline.
+ $errmsg .= "\n" . $pointy;
+ } elsif($i == (length($_[0]) - 1) ) {
+ # Already has a newline at end.
+ $errmsg .= $pointy;
+ } else {
+ # don't bother with the pointy bit, I guess.
+ }
+ Carp::croak( "$errmsg via $target, as used" );
+ }
+
+ ###########################################################################
+
+ my %tried = ();
+ # memoization of whether we've used this module, or found it unusable.
+
+ sub _try_use { # Basically a wrapper around "require Modulename"
+ # "Many men have tried..." "They tried and failed?" "They tried and died."
+ return $tried{$_[0]} if exists $tried{$_[0]}; # memoization
+
+ my $module = $_[0]; # ASSUME sane module name!
+ { no strict 'refs';
+ return($tried{$module} = 1)
+ if defined(%{$module . "::Lexicon"}) or defined(@{$module . "::ISA"});
+ # weird case: we never use'd it, but there it is!
+ }
+
+ print " About to use $module ...\n" if DEBUG;
+ {
+ local $SIG{'__DIE__'};
+ eval "require $module"; # used to be "use $module", but no point in that.
+ }
+ if($@) {
+ print "Error using $module \: $@\n" if DEBUG > 1;
+ return $tried{$module} = 0;
+ } else {
+ print " OK, $module is used\n" if DEBUG;
+ return $tried{$module} = 1;
+ }
+ }
+
+ #--------------------------------------------------------------------------
+
+ sub _lex_refs { # report the lexicon references for this handle's class
+ # returns an arrayREF!
+ no strict 'refs';
+ my $class = ref($_[0]) || $_[0];
+ print "Lex refs lookup on $class\n" if DEBUG > 1;
+ return $isa_scan{$class} if exists $isa_scan{$class}; # memoization!
+
+ my @lex_refs;
+ my $seen_r = ref($_[1]) ? $_[1] : {};
+
+ if( defined( *{$class . '::Lexicon'}{'HASH'} )) {
+ push @lex_refs, *{$class . '::Lexicon'}{'HASH'};
+ print "%" . $class . "::Lexicon contains ",
+ scalar(keys %{$class . '::Lexicon'}), " entries\n" if DEBUG;
+ }
+
+ # Implements depth(height?)-first recursive searching of superclasses.
+ # In hindsight, I suppose I could have just used Class::ISA!
+ foreach my $superclass (@{$class . "::ISA"}) {
+ print " Super-class search into $superclass\n" if DEBUG;
+ next if $seen_r->{$superclass}++;
+ push @lex_refs, @{&_lex_refs($superclass, $seen_r)}; # call myself
+ }
+
+ $isa_scan{$class} = \@lex_refs; # save for next time
+ return \@lex_refs;
+ }
+
+ sub clear_isa_scan { %isa_scan = (); return; } # end on a note of simplicity!
+
+ ###########################################################################
+ 1;
+
diff -c /dev/null 'perl-5.7.2/lib/Locale/Maketext.pod'
Index: ./lib/Locale/Maketext.pod
*** ./lib/Locale/Maketext.pod Thu Jan 1 02:00:00 1970
--- ./lib/Locale/Maketext.pod Mon Jul 9 17:10:36 2001
***************
*** 0 ****
--- 1,1321 ----
+
+ # Time-stamp: "2001-06-21 23:12:39 MDT"
+
+ =head1 NAME
+
+ Locale::Maketext -- framework for localization
+
+ =head1 SYNOPSIS
+
+ package MyProgram;
+ use strict;
+ use MyProgram::L10N;
+ # ...which inherits from Locale::Maketext
+ my $lh = MyProgram::L10N->get_handle() || die "What language?";
+ ...
+ # And then any messages your program emits, like:
+ warn $lh->maketext( "Can't open file [_1]: [_2]\n", $f, $! );
+ ...
+
+ =head1 DESCRIPTION
+
+ It is a common feature of applications (whether run directly,
+ or via the Web) for them to be "localized" -- i.e., for them
+ to a present an English interface to an English-speaker, a German
+ interface to a German-speaker, and so on for all languages it's
+ programmed with. Locale::Maketext
+ is a framework for software localization; it provides you with the
+ tools for organizing and accessing the bits of text and text-processing
+ code that you need for producing localized applications.
+
+ In order to make sense of Maketext and how all its
+ components fit together, you should probably
+ go read L<Locale::Maketext::TPJ13|Locale::Maketext::TPJ13>, and
+ I<then> read the following documentation.
+
+ You may also want to read over the source for C<File::Findgrep>
+ and its constituent modules -- they are a complete (if small)
+ example application that uses Maketext.
+
+ =head1 QUICK OVERVIEW
+
+ The basic design of Locale::Maketext is object-oriented, and
+ Locale::Maketext is an abstract base class, from which you
+ derive a "project class".
+ The project class (with a name like "TkBocciBall::Localize",
+ which you then use in your module) is in turn the base class
+ for all the "language classes" for your project
+ (with names "TkBocciBall::Localize::it",
+ "TkBocciBall::Localize::en",
+ "TkBocciBall::Localize::fr", etc.).
+
+ A language class is
+ a class containing a lexicon of phrases as class data,
+ and possibly also some methods that are of use in interpreting
+ phrases in the lexicon, or otherwise dealing with text in that
+ language.
+
+ An object belonging to a language class is called a "language
+ handle"; it's typically a flyweight object.
+
+ The normal course of action is to call:
+
+ use TkBocciBall::Localize; # the localization project class
+ $lh = TkBocciBall::Localize->get_handle();
+ # Depending on the user's locale, etc., this will
+ # make a language handle from among the classes available,
+ # and any defaults that you declare.
+ die "Couldn't make a language handle??" unless $lh;
+
+ From then on, you use the C<maketext> function to access
+ entries in whatever lexicon(s) belong to the language handle
+ you got. So, this:
+
+ print $lh->maketext("You won!"), "\n";
+
+ ...emits the right text for this language. If the object
+ in C<$lh> belongs to class "TkBocciBall::Localize::fr" and
+ %TkBocciBall::Localize::fr::Lexicon contains C<("You won!"
+ =E<gt> "Tu as gagnE<eacute>!")>, then the above
+ code happily tells the user "Tu as gagnE<eacute>!".
+
+ =head1 METHODS
+
+ Locale::Maketext offers a variety of methods, which fall
+ into three categories:
+
+ =over
+
+ =item *
+
+ Methods to do with constructing language handles.
+
+ =item *
+
+ C<maketext> and other methods to do with accessing %Lexicon data
+ for a given language handle.
+
+ =item *
+
+ Methods that you may find it handy to use, from routines of
+ yours that you put in %Lexicon entries.
+
+ =back
+
+ These are covered in the following section.
+
+ =head2 Construction Methods
+
+ These are to do with constructing a language handle:
+
+ =over
+
+ =item *
+
+ $lh = YourProjClass->get_handle( ...langtags... ) || die "lg-handle?";
+
+ This tries loading classes based on the language-tags you give (like
+ C<("en-US", "sk", "kon", "es-MX", "ja", "i-klingon")>, and for the first class
+ that succeeds, returns YourProjClass::I<language>->new().
+
+ It runs thru the entire given list of language-tags, and finds no classes
+ for those exact terms, it then tries "superordinate" language classes.
+ So if no "en-US" class (i.e., YourProjClass::en_us)
+ was found, nor classes for anything else in that list, we then try
+ its superordinate, "en" (i.e., YourProjClass::en), and so on thru
+ the other language-tags in the given list: "es".
+ (The other language-tags in our example list:
+ happen to have no superordinates.)
+
+ If none of those language-tags leads to loadable classes, we then
+ try classes derived from YourProjClass->fallback_languages() and
+ then if nothing comes of that, we use classes named by
+ YourProjClass->fallback_language_classes(). Then in the (probably
+ quite unlikely) event that that fails, we just return undef.
+
+ =item *
+
+ $lh = YourProjClass->get_handleB<()> || die "lg-handle?";
+
+ When C<get_handle> is called with an empty parameter list, magic happens:
+
+ If C<get_handle> senses that it's running in program that was
+ invoked as a CGI, then it tries to get language-tags out of the
+ environment variable "HTTP_ACCEPT_LANGUAGE", and it pretends that
+ those were the languages passed as parameters to C<get_handle>.
+
+ Otherwise (i.e., if not a CGI), this tries various OS-specific ways
+ to get the language-tags for the current locale/language, and then
+ pretends that those were the value(s) passed to C<cet_handle>.
+
+ Currently this OS-specific stuff consists of looking in the environment
+ variables "LANG" and "LANGUAGE"; and on MSWin machines (where those
+ variables are typically unused), this also tries using
+ the module Win32::Locale to get a language-tag for whatever language/locale
+ is currently selected in the "Regional Settings" (or "International"?)
+ Control Panel. I welcome further
+ suggestions for making this do the Right Thing under other operating
+ systems that support localization.
+
+ If you're using localization in an application that keeps a configuration
+ file, you might consider something like this in your project class:
+
+ sub get_handle_via_config {
+ my $class = $_[0];
+ my $preferred_language = $Config_settings{'language'};
+ my $lh;
+ if($preferred_language) {
+ $lh = $class->get_handle($chosen_language)
+ || die "No language handle for \"$chosen_language\" or the like";
+ } else {
+ # Config file missing, maybe?
+ $lh = $class->get_handle()
+ || die "Can't get a language handle";
+ }
+ return $lh;
+ }
+
+ =item *
+
+ $lh = YourProjClass::langname->new();
+
+ This constructs a language handle. You usually B<don't> call this
+ directly, but instead let C<get_handle> find a language class to C<use>
+ and to then call ->new on.
+
+ =item *
+
+ $lh->init();
+
+ This is called by ->new to initialize newly-constructed language handles.
+ If you define an init method in your class, remember that it's usually
+ considered a good idea to call $lh->SUPER::init in it (presumably at the
+ beginning), so that all classes get a chance to initialize a new object
+ however they see fit.
+
+ =item *
+
+ YourProjClass->fallback_languages()
+
+ C<get_handle> appends the return value of this to the end of
+ whatever list of languages you pass C<get_handle>. Unless
+ you override this method, your project class
+ will inherit Locale::Maketext's C<fallback_languages>, which
+ currently returns C<('i-default', 'en', 'en-US')>.
+ ("i-default" is defined in RFC 2277).
+
+ This method (by having it return the name
+ of a language-tag that has an existing language class)
+ can be used for making sure that
+ C<get_handle> will always manage to construct a language
+ handle (assuming your language classes are in an appropriate
+ @INC directory). Or you can use the next method:
+
+ =item *
+
+ YourProjClass->fallback_language_classes()
+
+ C<get_handle> appends the return value of this to the end
+ of the list of classes it will try using. Unless
+ you override this method, your project class
+ will inherit Locale::Maketext's C<fallback_language_classes>,
+ which currently returns an empty list, C<()>.
+ By setting this to some value (namely, the name of a loadable
+ language class), you can be sure that
+ C<get_handle> will always manage to construct a language
+ handle.
+
+ =back
+
+ =head2 The "maketext" Method
+
+ This is the most important method in Locale::Maketext:
+
+ $text = $lh->maketext(I<key>, ...parameters for this phrase...);
+
+ This looks in the %Lexicon of the language handle
+ $lh and all its superclasses, looking
+ for an entry whose key is the string I<key>. Assuming such
+ an entry is found, various things then happen, depending on the
+ value found:
+
+ If the value is a scalarref, the scalar is dereferenced and returned
+ (and any parameters are ignored).
+ If the value is a coderef, we return &$value($lh, ...parameters...).
+ If the value is a string that I<doesn't> look like it's in Bracket Notation,
+ we return it (after replacing it with a scalarref, in its %Lexicon).
+ If the value I<does> look like it's in Bracket Notation, then we compile
+ it into a sub, replace the string in the %Lexicon with the new coderef,
+ and then we return &$new_sub($lh, ...parameters...).
+
+ Bracket Notation is discussed in a later section. Note
+ that trying to compile a string into Bracket Notation can throw
+ an exception if the string is not syntactically valid (say, by not
+ balancing brackets right.)
+
+ Also, calling &$coderef($lh, ...parameters...) can throw any sort of
+ exception (if, say, code in that sub tries to divide by zero). But
+ a very common exception occurs when you have Bracket
+ Notation text that says to call a method "foo", but there is no such
+ method. (E.g., "You have [quaB<tn>,_1,ball]." will throw an exception
+ on trying to call $lh->quaB<tn>($_[1],'ball') -- you presumably meant
+ "quant".) C<maketext> catches these exceptions, but only to make the
+ error message more readable, at which point it rethrows the exception.
+
+ An exception I<may> be thrown if I<key> is not found in any
+ of $lh's %Lexicon hashes. What happens if a key is not found,
+ is discussed in a later section, "Controlling Lookup Failure".
+
+ Note that you might find it useful in some cases to override
+ the C<maketext> method with an "after method", if you want to
+ translate encodings, or even scripts:
+
+ package YrProj::zh_cn; # Chinese with PRC-style glyphs
+ use base ('YrProj::zh_tw'); # Taiwan-style
+ sub maketext {
+ my $self = shift(@_);
+ my $value = $self->maketext(@_);
+ return Chineeze::taiwan2mainland($value);
+ }
+
+ Or you may want to override it with something that traps
+ any exceptions, if that's critical to your program:
+
+ sub maketext {
+ my($lh, @stuff) = @_;
+ my $out;
+ eval { $out = $lh->SUPER::maketext(@stuff) };
+ return $out unless $@;
+ ...otherwise deal with the exception...
+ }
+
+ Other than those two situations, I don't imagine that
+ it's useful to override the C<maketext> method. (If
+ you run into a situation where it is useful, I'd be
+ interested in hearing about it.)
+
+ =over
+
+ =item $lh->fail_with I<or> $lh->fail_with(I<PARAM>)
+
+ =item $lh->failure_handler_auto
+
+ These two methods are discussed in the section "Controlling
+ Lookup Failure".
+
+ =back
+
+ =head2 Utility Methods
+
+ These are methods that you may find it handy to use, generally
+ from %Lexicon routines of yours (whether expressed as
+ Bracket Notation or not).
+
+ =over
+
+ =item $language->quant($number, $singular)
+
+ =item $language->quant($number, $singular, $plural)
+
+ =item $language->quant($number, $singular, $plural, $negative)
+
+ This is generally meant to be called from inside Bracket Notation
+ (which is discussed later), as in
+
+ "Your search matched [quant,_1,document]!"
+
+ It's for I<quantifying> a noun (i.e., saying how much of it there is,
+ while giving the currect form of it). The behavior of this method is
+ handy for English and a few other Western European languages, and you
+ should override it for languages where it's not suitable. You can feel
+ free to read the source, but the current implementation is basically
+ as this pseudocode describes:
+
+ if $number is 0 and there's a $negative,
+ return $negative;
+ elsif $number is 1,
+ return "1 $singular";
+ elsif there's a $plural,
+ return "$number $plural";
+ else
+ return "$number " . $singular . "s";
+ #
+ # ...except that we actually call numf to
+ # stringify $number before returning it.
+
+ So for English (with Bracket Notation)
+ C<"...[quant,_1,file]..."> is fine (for 0 it returns "0 files",
+ for 1 it returns "1 file", and for more it returns "2 files", etc.)
+
+ But for "directory", you'd want C<"[quant,_1,direcory,directories]">
+ so that our elementary C<quant> method doesn't think that the
+ plural of "directory" is "directorys". And you might find that the
+ output may sound better if you specify a negative form, as in:
+
+ "[quant,_1,file,files,No files] matched your query.\n"
+
+ Remember to keep in mind verb agreement (or adjectives too, in
+ other languages), as in:
+
+ "[quant,_1,document] were matched.\n"
+
+ Because if _1 is one, you get "1 document B<were> matched".
+ An acceptable hack here is to do something like this:
+
+ "[quant,_1,document was, documents were] matched.\n"
+
+ =item $language->numf($number)
+
+ This returns the given number formatted nicely according to
+ this language's conventions. Maketext's default method is
+ mostly to just take the normal string form of the number
+ (applying sprintf "%G" for only very large numbers), and then
+ to add commas as necessary. (Except that
+ we apply C<tr/,./.,/> if $language->{'numf_comma'} is true;
+ that's a bit of a hack that's useful for languages that express
+ two million as "2.000.000" and not as "2,000,000").
+
+ If you want anything fancier, consider overriding this with something
+ that uses L<Number::Format|Number::Format>, or does something else
+ entirely.
+
+ Note that numf is called by quant for stringifying all quantifying
+ numbers.
+
+ =item $language->sprintf($format, @items)
+
+ This is just a wrapper around Perl's normal C<sprintf> function.
+ It's provided so that you can use "sprintf" in Bracket Notation:
+
+ "Couldn't access datanode [sprintf,%10x=~[%s~],_1,_2]!\n"
+
+ returning...
+
+ Couldn't access datanode Stuff=[thangamabob]!
+
+ =item $language->language_tag()
+
+ Currently this just takes the last bit of C<ref($language)>, turns
+ underscores to dashes, and returns it. So if $language is
+ an object of class Hee::HOO::Haw::en_us, $language->language_tag()
+ returns "en-us". (Yes, the usual representation for that language
+ tag is "en-US", but case is I<never> considered meaningful in
+ language-tag comparison.)
+
+ You may override this as you like; Maketext doesn't use it for
+ anything.
+
+ =item $language->encoding()
+
+ Currently this isn't used for anything, but it's provided
+ (with default value of
+ C<(ref($language) && $language-E<gt>{'encoding'})) or "iso-8859-1">
+ ) as a sort of suggestion that it may be useful/necessary to
+ associate encodings with your language handles (whether on a
+ per-class or even per-handle basis.)
+
+ =back
+
+ =head2 Language Handle Attributes and Internals
+
+ A language handle is a flyweight object -- i.e., it doesn't (necessarily)
+ carry any data of interest, other than just being a member of
+ whatever class it belongs to.
+
+ A language handle is implemented as a blessed hash. Subclasses of yours
+ can store whatever data you want in the hash. Currently the only hash
+ entry used by any crucial Maketext method is "fail", so feel free to
+ use anything else as you like.
+
+ B<Remember: Don't be afraid to read the Maketext source if there's
+ any point on which this documentation is unclear.> This documentation
+ is vastly longer than the module source itself.
+
+ =over
+
+ =back
+
+ =head1 LANGUAGE CLASS HIERARCHIES
+
+ These are Locale::Maketext's assumptions about the class
+ hierarchy formed by all your language classes:
+
+ =over
+
+ =item *
+
+ You must have a project base class, which you load, and
+ which you then use as the first argument in
+ the call to YourProjClass->get_handle(...). It should derive
+ (whether directly or indirectly) from Locale::Maketext.
+ It B<doesn't matter> how you name this class, altho assuming this
+ is the localization component of your Super Mega Program,
+ good names for your project class might be
+ SuperMegaProgram::Localization, SuperMegaProgram::L10N,
+ SuperMegaProgram::I18N, SuperMegaProgram::International,
+ or even SuperMegaProgram::Languages or SuperMegaProgram::Messages.
+
+ =item *
+
+ Language classes are what YourProjClass->get_handle will try to load.
+ It will look for them by taking each language-tag (B<skipping> it
+ if it doesn't look like a language-tag or locale-tag!), turning it to
+ all lowercase, turning and dashes to underscores, and appending it
+ to YourProjClass . "::". So this:
+
+ $lh = YourProjClass->get_handle(
+ 'en-US', 'fr', 'kon', 'i-klingon', 'i-klingon-romanized'
+ );
+
+ will try loading the classes
+ YourProjClass::en_us (note lowercase!), YourProjClass::fr,
+ YourProjClass::kon,
+ YourProjClass::i_klingon
+ and YourProjClass::i_klingon_romanized. (And it'll stop at the
+ first one that actually loads.)
+
+ =item *
+
+ I assume that each language class derives (directly or indirectly)
+ from your project class, and also defines its @ISA, its %Lexicon,
+ or both. But I anticipate no dire consequences if these assumptions
+ do not hold.
+
+ =item *
+
+ Language classes may derive from other language classes (altho they
+ should have "use I<Thatclassname>" or "use base qw(I<...classes...>)").
+ They may derive from the project
+ class. They may derive from some other class altogether. Or via
+ multiple inheritance, it may derive from any mixture of these.
+
+ =item *
+
+ I foresee no problems with having multiple inheritance in
+ your hierarchy of language classes. (As usual, however, Perl will
+ complain bitterly if you have a cycle in the hierarchy: i.e., if
+ any class is its own ancestor.)
+
+ =back
+
+ =head1 ENTRIES IN EACH LEXICON
+
+ A typical %Lexicon entry is meant to signify a phrase,
+ taking some number (0 or more) of parameters. An entry
+ is meant to be accessed by via
+ a string I<key> in $lh->maketext(I<key>, ...parameters...),
+ which should return a string that is generally meant for
+ be used for "output" to the user -- regardless of whether
+ this actually means printing to STDOUT, writing to a file,
+ or putting into a GUI widget.
+
+ While the key must be a string value (since that's a basic
+ restriction that Perl places on hash keys), the value in
+ the lexicon can currenly be of several types:
+ a defined scalar, scalarref, or coderef. The use of these is
+ explained above, in the section 'The "maketext" Method', and
+ Bracket Notation for strings is discussed in the next section.
+
+ While you can use arbitrary unique IDs for lexicon keys
+ (like "_min_larger_max_error"), it is often
+ useful for if an entry's key is itself a valid value, like
+ this example error message:
+
+ "Minimum ([_1]) is larger than maximum ([_2])!\n",
+
+ Compare this code that uses an arbitrary ID...
+
+ die $lh->maketext( "_min_larger_max_error", $min, $max )
+ if $min > $max;
+
+ ...to this code that uses a key-as-value:
+
+ die $lh->maketext(
+ "Minimum ([_1]) is larger than maximum ([_2])!\n",
+ $min, $max
+ ) if $min > $max;
+
+ The second is, in short, more readable. In particular, it's obvious
+ that the number of parameters you're feeding to that phrase (two) is
+ the number of parameters that it I<wants> to be fed. (Since you see
+ _1 and a _2 being used in the key there.)
+
+ Also, once a project is otherwise
+ complete and you start to localize it, you can scrape together
+ all the various keys you use, and pass it to a translator; and then
+ the translator's work will go faster if what he's presented is this:
+
+ "Minimum ([_1]) is larger than maximum ([_2])!\n",
+ => "", # fill in something here, Jacques!
+
+ rather than this more cryptic mess:
+
+ "_min_larger_max_error"
+ => "", # fill in something here, Jacques
+
+ I think that keys as lexicon values makes the completed lexicon
+ entries more readable:
+
+ "Minimum ([_1]) is larger than maximum ([_2])!\n",
+ => "Le minimum ([_1]) est plus grand que le maximum ([_2])!\n",
+
+ Also, having valid values as keys becomes very useful if you set
+ up an _AUTO lexicon. _AUTO lexicons are discussed in a later
+ section.
+
+ I almost always use keys that are themselves
+ valid lexicon values. One notable exception is when the value is
+ quite long. For example, to get the screenful of data that
+ a command-line program might returns when given an unknown switch,
+ I often just use a key "_USAGE_MESSAGE". At that point I then go
+ and immediately to define that lexicon entry in the
+ ProjectClass::L10N::en lexicon (since English is always my "project
+ lanuage"):
+
+ '_USAGE_MESSAGE' => <<'EOSTUFF',
+ ...long long message...
+ EOSTUFF
+
+ and then I can use it as:
+
+ getopt('oDI', \%opts) or die $lh->maketext('_USAGE_MESSAGE');
+
+ Incidentally,
+ note that each class's C<%Lexicon> inherits-and-extends
+ the lexicons in its superclasses. This is not because these are
+ special hashes I<per se>, but because you access them via the
+ C<maketext> method, which looks for entries across all the
+ C<%Lexicon>'s in a language class I<and> all its ancestor classes.
+ (This is because the idea of "class data" isn't directly implemented
+ in Perl, but is instead left to individual class-systems to implement
+ as they see fit..)
+
+ Note that you may have things stored in a lexicon
+ besides just phrases for output: for example, if your program
+ takes input from the keyboard, asking a "(Y/N)" question,
+ you probably need to know what equivalent of "Y[es]/N[o]" is
+ in whatever language. You probably also need to know what
+ the equivalents of the answers "y" and "n" are. You can
+ store that information in the lexicon (say, under the keys
+ "~answer_y" and "~answer_n", and the long forms as
+ "~answer_yes" and "~answer_no", where "~" is just an ad-hoc
+ character meant to indicate to programmers/translators that
+ these are not phrases for output).
+
+ Or instead of storing this in the language class's lexicon,
+ you can (and, in some cases, really should) represent the same bit
+ of knowledge as code is a method in the language class. (That
+ leaves a tidy distinction between the lexicon as the things we
+ know how to I<say>, and the rest of the things in the lexicon class
+ as things that we know how to I<do>.) Consider
+ this example of a processor for responses to French "oui/non"
+ questions:
+
+ sub y_or_n {
+ return undef unless defined $_[1] and length $_[1];
+ my $answer = lc $_[1]; # smash case
+ return 1 if $answer eq 'o' or $answer eq 'oui';
+ return 0 if $answer eq 'n' or $answer eq 'non';
+ return undef;
+ }
+
+ ...which you'd then call in a construct like this:
+
+ my $response;
+ until(defined $response) {
+ print $lh->maketext("Open the pod bay door (y/n)? ");
+ $response = $lh->y_or_n( get_input_from_keyboard_somehow() );
+ }
+ if($response) { $pod_bay_door->open() }
+ else { $pod_bay_door->leave_closed() }
+
+ Other data worth storing in a lexicon might be things like
+ filenames for language-targetted resources:
+
+ ...
+ "_main_splash_png"
+ => "/styles/en_us/main_splash.png",
+ "_main_splash_imagemap"
+ => "/styles/en_us/main_splash.incl",
+ "_general_graphics_path"
+ => "/styles/en_us/",
+ "_alert_sound"
+ => "/styles/en_us/hey_there.wav",
+ "_forward_icon"
+ => "left_arrow.png",
+ "_backward_icon"
+ => "right_arrow.png",
+ # In some other languages, left equals
+ # BACKwards, and right is FOREwards.
+ ...
+
+ You might want to do the same thing for expressing key bindings
+ or the like (since hardwiring "q" as the binding for the function
+ that quits a screen/menu/program is useful only if your language
+ happens to associate "q" with "quit"!)
+
+ =head1 BRACKET NOTATION
+
+ Bracket Notation is a crucial feature of Locale::Maketext. I mean
+ Bracket Notation to provide a replacement for sprintf formatting.
+ Everything you do with Bracket Notation could be done with a sub block,
+ but bracket notation is meant to be much more concise.
+
+ Bracket Notation is a like a miniature "template" system (in the sense
+ of L<Text::Template|Text::Template>, not in the sense of C++ templates),
+ where normal text is passed thru basically as is, but text is special
+ regions is specially interpreted. In Bracket Notation, you use brackets
+ ("[...]" -- not "{...}"!) to note sections that are specially interpreted.
+
+ For example, here all the areas that are taken literally are underlined with
+ a "^", and all the in-bracket special regions are underlined with an X:
+
+ "Minimum ([_1]) is larger than maximum ([_2])!\n",
+ ^^^^^^^^^ XX ^^^^^^^^^^^^^^^^^^^^^^^^^^ XX ^^^^
+
+ When that string is compiled from bracket notation into a real Perl sub,
+ it's basically turned into:
+
+ sub {
+ my $lh = $_[0];
+ my @params = @_;
+ return join '',
+ "Minimum (",
+ ...some code here...
+ ") is larger than maximum (",
+ ...some code here...
+ ")!\n",
+ }
+ # to be called by $lh->maketext(KEY, params...)
+
+ In other words, text outside bracket groups is turned into string
+ literals. Text in brackets is rather more complex, and currently follows
+ these rules:
+
+ =over
+
+ =item *
+
+ Bracket groups that are empty, or which consist only of whitespace,
+ are ignored. (Examples: "[]", "[ ]", or a [ and a ] with returns
+ and/or tabs and/or spaces between them.
+
+ Otherwise, each group is taken to be a comma-separated group of items,
+ and each item is interpreted as follows:
+
+ =item *
+
+ An item that is "_I<digits>" or "_-I<digits>" is interpreted as
+ $_[I<value>]. I.e., "_1" is becomes with $_[1], and "_-3" is interpreted
+ as $_[-3] (in which case @_ should have at least three elements in it).
+ Note that $_[0] is the language handle, and is typically not named
+ directly.
+
+ =item *
+
+ An item "_*" is interpreted to mean "all of @_ except $_[0]".
+ I.e., C<@_[1..$#_]>. Note that this is an empty list in the case
+ of calls like $lh->maketext(I<key>) where there are no
+ parameters (except $_[0], the language handle).
+
+ =item *
+
+ Otherwise, each item is interpreted as a string literal.
+
+ =back
+
+ The group as a whole is interpreted as follows:
+
+ =over
+
+ =item *
+
+ If the first item in a bracket group looks like a method name,
+ then that group is interpreted like this:
+
+ $lh->that_method_name(
+ ...rest of items in this group...
+ ),
+
+ =item *
+
+ If the first item in a bracket group is "*", it's taken as shorthand
+ for the so commonly called "quant" method. Similarly, if the first
+ item in a bracket group is "#", it's taken to be shorthand for
+ "numf".
+
+ =item *
+
+ If the first item in a bracket group is empty-string, or "_*"
+ or "_I<digits>" or "_-I<digits>", then that group is interpreted
+ as just the interpolation of all its items:
+
+ join('',
+ ...rest of items in this group...
+ ),
+
+ Examples: "[_1]" and "[,_1]", which are synonymous; and
+ "[,ID-(,_4,-,_2,)]", which compiles as
+ C<join "", "ID-(", $_[4], "-", $_[2], ")">.
+
+ =item *
+
+ Otherwise this bracket group is invalid. For example, in the group
+ "[!@#,whatever]", the first item C<"!@#"> is neither empty-string,
+ "_I<number>", "_-I<number>", "_*", nor a valid method name; and so
+ Locale::Maketext will throw an exception of you try compiling an
+ expression containing this bracket group.
+
+ =back
+
+ Note, incidentally, that items in each group are comma-separated,
+ not C</\s*,\s*/>-separated. That is, you might expect that this
+ bracket group:
+
+ "Hoohah [foo, _1 , bar ,baz]!"
+
+ would compile to this:
+
+ sub {
+ my $lh = $_[0];
+ return join '',
+ "Hoohah ",
+ $lh->foo( $_[1], "bar", "baz"),
+ "!",
+ }
+
+ But it actually compiles as this:
+
+ sub {
+ my $lh = $_[0];
+ return join '',
+ "Hoohah ",
+ $lh->foo(" _1 ", " bar ", "baz"), #!!!
+ "!",
+ }
+
+ In the notation discussed so far, the characters "[" and "]" are given
+ special meaning, for opening and closing bracket groups, and "," has
+ a special meaning inside bracket groups, where it separates items in the
+ group. This begs the question of how you'd express a literal "[" or
+ "]" in a Bracket Notation string, and how you'd express a literal
+ comma inside a bracket group. For this purpose I've adopted "~" (tilde)
+ as an escape character: "~[" means a literal '[' character anywhere
+ in Bracket Notation (i.e., regardless of whether you're in a bracket
+ group or not), and ditto for "~]" meaning a literal ']', and "~," meaning
+ a literal comma. (Altho "," means a literal comma outside of
+ bracket groups -- it's only inside bracket groups that commas are special.)
+
+ And on the off chance you need a literal tilde in a bracket expression,
+ you get it with "~~".
+
+ Currently, an unescaped "~" before a character
+ other than a bracket or a comma is taken to mean just a "~" and that
+ charecter. I.e., "~X" means the same as "~~X" -- i.e., one literal tilde,
+ and then one literal "X". However, by using "~X", you are assuming that
+ no future version of Maketext will use "~X" as a magic escape sequence.
+ In practice this is not a great problem, since first off you can just
+ write "~~X" and not worry about it; second off, I doubt I'll add lots
+ of new magic characters to bracket notation; and third off, you
+ aren't likely to want literal "~" characters in your messages anyway,
+ since it's not a character with wide use in natural language text.
+
+ Brackets must be balanced -- every openbracket must have
+ one matching closebracket, and vice versa. So these are all B<invalid>:
+
+ "I ate [quant,_1,rhubarb pie."
+ "I ate [quant,_1,rhubarb pie[."
+ "I ate quant,_1,rhubarb pie]."
+ "I ate quant,_1,rhubarb pie[."
+
+ Currently, bracket groups do not nest. That is, you B<cannot> say:
+
+ "Foo [bar,baz,[quux,quuux]]\n";
+
+ If you need a notation that's that powerful, use normal Perl:
+
+ %Lexicon = (
+ ...
+ "some_key" => sub {
+ my $lh = $_[0];
+ join '',
+ "Foo ",
+ $lh->bar('baz', $lh->quux('quuux')),
+ "\n",
+ },
+ ...
+ );
+
+ Or write the "bar" method so you don't need to pass it the
+ output from calling quux.
+
+ I do not anticipate that you will need (or particularly want)
+ to nest bracket groups, but you are welcome to email me with
+ convincing (real-life) arguments to the contrary.
+
+ =head1 AUTO LEXICONS
+
+ If maketext goes to look in an individual %Lexicon for an entry
+ for I<key> (where I<key> does not start with an underscore), and
+ sees none, B<but does see> an entry of "_AUTO" => I<some_true_value>,
+ then we actually define $Lexicon{I<key>} = I<key> right then and there,
+ and then use that value as if it had been there all
+ along. This happens before we even look in any superclass %Lexicons!
+
+ (This is meant to be somewhat like the AUTOLOAD mechanism in
+ Perl's function call system -- or, looked at another way,
+ like the L<AutoLoader|AutoLoader> module.)
+
+ I can picture all sorts of circumstances where you just
+ do not want lookup to be able to fail (since failing
+ normally means that maketext throws a C<die>, altho
+ see the next section for greater control over that). But
+ here's one circumstance where _AUTO lexicons are meant to
+ be I<especially> useful:
+
+ As you're writing an application, you decide as you go what messages
+ you need to emit. Normally you'd go to write this:
+
+ if(-e $filename) {
+ go_process_file($filename)
+ } else {
+ print "Couldn't find file \"$filename\"!\n";
+ }
+
+ but since you anticipate localizing this, you write:
+
+ use ThisProject::I18N;
+ my $lh = ThisProject::I18N->get_handle();
+ # For the moment, assume that things are set up so
+ # that we load class ThisProject::I18N::en
+ # and that that's the class that $lh belongs to.
+ ...
+ if(-e $filename) {
+ go_process_file($filename)
+ } else {
+ print $lh->maketext(
+ "Couldn't find file \"[_1]\"!\n", $filename
+ );
+ }
+
+ Now, right after you've just written the above lines, you'd
+ normally have to go open the file
+ ThisProject/I18N/en.pm, and immediately add an entry:
+
+ "Couldn't find file \"[_1]\"!\n"
+ => "Couldn't find file \"[_1]\"!\n",
+
+ But I consider that somewhat of a distraction from the work
+ of getting the main code working -- to say nothing of the fact
+ that I often have to play with the program a few times before
+ I can decide exactly what wording I want in the messages (which
+ in this case would require me to go changing three lines of code:
+ the call to maketext with that key, and then the two lines in
+ ThisProject/I18N/en.pm).
+
+ However, if you set "_AUTO => 1" in the %Lexicon in,
+ ThisProject/I18N/en.pm (assuming that English (en) is
+ the language that all your programmers will be using for this
+ project's internal message keys), then you don't ever have to
+ go adding lines like this
+
+ "Couldn't find file \"[_1]\"!\n"
+ => "Couldn't find file \"[_1]\"!\n",
+
+ to ThisProject/I18N/en.pm, because if _AUTO is true there,
+ then just looking for an entry with the key "Couldn't find
+ file \"[_1]\"!\n" in that lexicon will cause it to be added,
+ with that value!
+
+ Note that the reason that keys that start with "_"
+ are immune to _AUTO isn't anything generally magical about
+ the underscore character -- I just wanted a way to have most
+ lexicon keys be autoable, except for possibly a few, and I
+ arbitrarily decided to use a leading underscore as a signal
+ to distinguish those few.
+
+ =head1 CONTROLLING LOOKUP FAILURE
+
+ If you call $lh->maketext(I<key>, ...parameters...),
+ and there's no entry I<key> in $lh's class's %Lexicon, nor
+ in the superclass %Lexicon hash, I<and> if we can't auto-make
+ I<key> (because either it starts with a "_", or because none
+ of its lexicons have C<_AUTO =E<gt> 1,>), then we have
+ failed to find a normal way to maketext I<key>. What then
+ happens in these failure conditions, depends on the $lh object
+ "fail" attribute.
+
+ If the language handle has no "fail" attribute, maketext
+ will simply throw an exception (i.e., it calls C<die>, mentioning
+ the I<key> whose lookup failed, and naming the line number where
+ the calling $lh->maketext(I<key>,...) was.
+
+ If the language handle has a "fail" attribute whose value is a
+ coderef, then $lh->maketext(I<key>,...params...) gives up and calls:
+
+ return &{$that_subref}($lh, $key, @params);
+
+ Otherwise, the "fail" attribute's value should be a string denoting
+ a method name, so that $lh->maketext(I<key>,...params...) can
+ give up with:
+
+ return $lh->$that_method_name($phrase, @params);
+
+ The "fail" attribute can be accessed with the C<fail_with> method:
+
+ # Set to a coderef:
+ $lh->fail_with( \&failure_handler );
+
+ # Set to a method name:
+ $lh->fail_with( 'failure_method' );
+
+ # Set to nothing (i.e., so failure throws a plain exception)
+ $lh->fail_with( undef );
+
+ # Simply read:
+ $handler = $lh->fail_with();
+
+ Now, as to what you may want to do with these handlers: Maybe you'd
+ want to log what key failed for what class, and then die. Maybe
+ you don't like C<die> and instead you want to send the error message
+ to STDOUT (or wherever) and then merely C<exit()>.
+
+ Or maybe you don't want to C<die> at all! Maybe you could use a
+ handler like this:
+
+ # Make all lookups fall back onto an English value,
+ # but after we log it for later fingerpointing.
+ my $lh_backup = ThisProject->get_handle('en');
+ open(LEX_FAIL_LOG, ">>wherever/lex.log") || die "GNAARGH $!";
+ sub lex_fail {
+ my($failing_lh, $key, $params) = @_;
+ print LEX_FAIL_LOG scalar(localtime), "\t",
+ ref($failing_lh), "\t", $key, "\n";
+ return $lh_backup->maketext($key,@params);
+ }
+
+ Some users have expressed that they think this whole mechanism of
+ having a "fail" attribute at all, seems a rather pointless complication.
+ But I want Locale::Maketext to be usable for software projects of I<any>
+ scale and type; and different software projects have different ideas
+ of what the right thing is to do in failure conditions. I could simply
+ say that failure always throws an exception, and that if you want to be
+ careful, you'll just have to wrap every call to $lh->maketext in an
+ S<eval { }>. However, I want programmers to reserve the right (via
+ the "fail" attribute) to treat lookup failure as something other than
+ an exception of the same level of severity as a config file being
+ unreadable, or some essential resource being inaccessable.
+
+ One possibly useful value for the "fail" attribute is the method name
+ "failure_handler_auto". This is a method defined in class
+ Locale::Maketext itself. You set it with:
+
+ $lh->fail_with('failure_handler_auto');
+
+ Then when you call $lh->maketext(I<key>, ...parameters...) and
+ there's no I<key> in any of those lexicons, maketext gives up with
+
+ return $lh->failure_handler_auto($key, @params);
+
+ But failure_handler_auto, instead of dying or anything, compiles
+ $key, caching it in $lh->{'failure_lex'}{$key} = $complied,
+ and then calls the compiled value, and returns that. (I.e., if
+ $key looks like bracket notation, $compiled is a sub, and we return
+ &{$compiled}(@params); but if $key is just a plain string, we just
+ return that.)
+
+ The effect of using "failure_auto_handler"
+ is like an AUTO lexicon, except that it 1) compiles $key even if
+ it starts with "_", and 2) you have a record in the new hashref
+ $lh->{'failure_lex'} of all the keys that have failed for
+ this object. This should avoid your program dying -- as long
+ as your keys aren't actually invalid as bracket code, and as
+ long as they don't try calling methods that don't exist.
+
+ "failure_auto_handler" may not be exactly what you want, but I
+ hope it at least shows you that maketext failure can be mitigated
+ in any number of very flexible ways. If you can formalize exactly
+ what you want, you should be able to express that as a failure
+ handler. You can even make it default for every object of a given
+ class, by setting it in that class's init:
+
+ sub init {
+ my $lh = $_[0]; # a newborn handle
+ $lh->SUPER::init();
+ $lh->fail_with('my_clever_failure_handler');
+ return;
+ }
+ sub my_clever_failure_handler {
+ ...you clever things here...
+ }
+
+ =head1 HOW TO USE MAKETEXT
+
+ Here is a brief checklist on how to use Maketext to localize
+ applications:
+
+ =over
+
+ =item *
+
+ Decide what system you'll use for lexicon keys. If you insist,
+ you can use opaque IDs (if you're nostalgic for C<catgets>),
+ but I have better suggestions in the
+ section "Entries in Each Lexicon", above. Assuming you opt for
+ meaningful keys that double as values (like "Minimum ([_1]) is
+ larger than maximum ([_2])!\n"), you'll have to settle on what
+ language those should be in. For the sake of argument, I'll
+ call this English, specifically American English, "en-US".
+
+ =item *
+
+ Create a class for your localization project. This is
+ the name of the class that you'll use in the idiom:
+
+ use Projname::L10N;
+ my $lh = Projname::L10N->get_handle(...) || die "Language?";
+
+ Assuming your call your class Projname::L10N, create a class
+ consisting minimally of:
+
+ package Projname::L10N;
+ use base qw(Locale::Maketext);
+ ...any methods you might want all your languages to share...
+
+ # And, assuming you want the base class to be an _AUTO lexicon,
+ # as is discussed a few sections up:
+
+ 1;
+
+ =item *
+
+ Create a class for the language your internal keys are in. Name
+ the class after the language-tag for that language, in lowercase,
+ with dashes changed to underscores. Assuming your project's first
+ language is US English, you should call this Projname::L10N::en_us.
+ It should consist minimally of:
+
+ package Projname::L10N::en_us;
+ use base qw(Projname::L10N);
+ %Lexicon = (
+ '_AUTO' => 1,
+ );
+ 1;
+
+ (For the rest of this section, I'll assume that this "first
+ language class" of Projname::L10N::en_us has
+ _AUTO lexicon.)
+
+ =item *
+
+ Go and write your program. Everywhere in your program where
+ you would say:
+
+ print "Foobar $thing stuff\n";
+
+ instead do it thru maketext, using no variable interpolation in
+ the key:
+
+ print $lh->maketext("Foobar [_1] stuff\n", $thing);
+
+ If you get tired of constantly saying C<print $lh-E<gt>maketext>,
+ consider making a functional wrapper for it, like so:
+
+ use Projname::L10N;
+ use vars qw($lh);
+ $lh = Projname::L10N->get_handle(...) || die "Language?";
+ sub pmt (@) { print( $lh->maketext(@_)) }
+ # "pmt" is short for "Print MakeText"
+ $Carp::Verbose = 1;
+ # so if maketext fails, we see made the call to pmt
+
+ Besides whole phrases meant for output, anything language-dependent
+ should be put into the class Projname::L10N::en_us,
+ whether as methods, or as lexicon entries -- this is discussed
+ in the section "Entries in Each Lexicon", above.
+
+ =item *
+
+ Once the program is otherwise done, and once its localization for
+ the first language works right (via the data and methods in
+ Projname::L10N::en_us), you can get together the data for translation.
+ If your first language lexicon isn't an _AUTO lexicon, then you already
+ have all the messages explicitly in the lexicon (or else you'd be
+ getting exceptions thrown when you call $lh->maketext to get
+ messages that aren't in there). But if you were (advisedly) lazy and are
+ using an _AUTO lexicon, then you've got to make a list of all the phrases
+ that you've so far been letting _AUTO generate for you. There are very
+ many ways to assemble such a list. The most straightforward is to simply
+ grep the source for every occurrence of "maketext" (or calls
+ to wrappers around it, like the above C<pmt> function), and to log the
+ following phrase.
+
+ =item *
+
+ You may at this point want to consider whether the your base class
+ (Projname::L10N) that all lexicons inherit from (Projname::L10N::en,
+ Projname::L10N::es, etc.) should be an _AUTO lexicon. It may be true
+ that in theory, all needed messages will be in each language class;
+ but in the presumably unlikely or "impossible" case of lookup failure,
+ you should consider whether your program should throw an exception,
+ emit text in English (or whatever your project's first language is),
+ or some more complex solution as described in the section
+ "Controlling Lookup Failure", above.
+
+ =item *
+
+ Submit all messages/phrases/etc. to translators.
+
+ (You may, in fact, want to start with localizing to I<one> other language
+ at first, if you're not sure that you've property abstracted the
+ language-dependent parts of your code.)
+
+ Translators may request clarification of the situation in which a
+ particular phrase is found. For example, in English we are entirely happy
+ saying "I<n> files found", regardless of whether we mean "I looked for files,
+ and found I<n> of them" or the rather distinct situation of "I looked for
+ something else (like lines in files), and along the way I saw I<n>
+ files." This may involve rethinking things that you thought quite clear:
+ should "Edit" on a toolbar be a noun ("editing") or a verb ("to edit")? Is
+ there already a conventionalized way to express that menu option, separate
+ from the target language's normal word for "to edit"?
+
+ In all cases where the very common phenomenon of quantification
+ (saying "I<N> files", for B<any> value of N)
+ is involved, each translator should make clear what dependencies the
+ number causes in the sentence. In many cases, dependency is
+ limited to words adjacent to the number, in places where you might
+ expect them ("I found the-?PLURAL I<N>
+ empty-?PLURAL directory-?PLURAL"), but in some cases there are
+ unexpected dependencies ("I found-?PLURAL ..."!) as well as long-distance
+ dependencies "The I<N> directory-?PLURAL could not be deleted-?PLURAL"!).
+
+ Remind the translators to consider the case where N is 0:
+ "0 files found" isn't exactly natural-sounding in any language, but it
+ may be unacceptable in many -- or it may condition special
+ kinds of agreement (similar to English "I didN'T find ANY files").
+
+ Remember to ask your translators about numeral formatting in their
+ language, so that you can override the C<numf> method as
+ appropriate. Typical variables in number formatting are: what to
+ use as a decimal point (comma? period?); what to use as a thousands
+ separator (space? nonbreakinng space? comma? period? small
+ middot? prime? apostrophe?); and even whether the so-called "thousands
+ separator" is actually for every third digit -- I've heard reports of
+ two hundred thousand being expressable as "2,00,000" for some Indian
+ (Subcontinental) languages, besides the less surprising "S<200 000>",
+ "200.000", "200,000", and "200'000". Also, using a set of numeral
+ glyphs other than the usual ASCII "0"-"9" might be appreciated, as via
+ C<tr/0-9/\x{0966}-\x{096F}/> for getting digits in Devanagari script
+ (for Hindi, Konkani, others).
+
+ The basic C<quant> method that Locale::Maketext provides should be
+ good for many languages. For some languages, it might be useful
+ to modify it (or its constituent C<numerate> method)
+ to take a plural form in the two-argument call to C<quant>
+ (as in "[quant,_1,files]") if
+ it's all-around easier to infer the singular form from the plural, than
+ to infer the plural form from the singular.
+
+ But for other languages (as is discussed at length
+ in L<Locale::Maketext::TPJ13|Locale::Maketext::TPJ13>), simple
+ C<quant>/C<numerify> is not enough. For the particularly problematic
+ Slavic languages, what you may need is a method which you provide
+ with the number, the citation form of the noun to quantify, and
+ the case and gender that the sentence's syntax projects onto that
+ noun slot. The method would then be responsible for determining
+ what grammatical number that numeral projects onto its noun phrase,
+ and what case and gender it may override the normal case and gender
+ with; and then it would look up the noun in a lexicon providing
+ all needed inflected forms.
+
+ =item *
+
+ You may also wish to discuss with the translators the question of
+ how to relate different subforms of the same language tag,
+ considering how this reacts with C<get_handle>'s treatment of
+ these. For example, if a user accepts interfaces in "en, fr", and
+ you have interfaces available in "en-US" and "fr", what should
+ they get? You may wish to resolve this by establishing that "en"
+ and "en-US" are effectively synonymous, by having one class
+ zero-derive from the other.
+
+ For some languages this issue may never come up (Danish is rarely
+ expressed as "da-DK", but instead is just "da"). And for other
+ languages, the whole concept of a "generic" form may verge on
+ being uselessly vague, particularly for interfaces involving voice
+ media in forms of Arabic or Chinese.
+
+ =item *
+
+ Once you've localized your program/site/etc. for all desired
+ languages, be sure to show the result (whether live, or via
+ screenshots) to the translators. Once they approve, make every
+ effort to have it then checked by at least one other speaker of
+ that language. This holds true even when (or especially when) the
+ translation is done by one of your own programmers. Some
+ kinds of systems may be harder to find testers for than others,
+ depending on the amount of domain-specific jargon and concepts
+ involved -- it's easier to find people who can tell you whether
+ they approve of your translation for "delete this message" in an
+ email-via-Web interface, than to find people who can give you
+ an informed opinion on your translation for "attribute value"
+ in an XML query tool's interface.
+
+ =back
+
+ =head1 SEE ALSO
+
+ I recommend reading all of these:
+
+ L<Locale::Maketext::TPJ13|Locale::Maketext::TPJ13> -- my I<The Perl
+ Journal> article about Maketext. It explains many important concepts
+ underlying Locale::Maketext's design, and some insight into why
+ Maketext is better than the plain old approach of just having
+ message catalogs that are just databases of sprintf formats.
+
+ L<File::Findgrep|File::Findgrep> is a sample application/module
+ that uses Locale::Maketext to localize its messages.
+
+ L<I18N::LangTags|I18N::LangTags>.
+
+ L<Win32::Locale|Win32::Locale>.
+
+ RFC 3066, I<Tags for the Identification of Languages>,
+ as at http://sunsite.dk/RFC/rfc/rfc3066.html
+
+ RFC 2277, I<IETF Policy on Character Sets and Languages>
+ is at http://sunsite.dk/RFC/rfc/rfc2277.html -- much of it is
+ just things of interest to protocol designers, but it explains
+ some basic concepts, like the distinction between locales and
+ language-tags.
+
+ The manual for GNU C<gettext>. The gettext dist is available in
+ C<ftp://prep.ai.mit.edu/pub/gnu/> -- get
+ a recent gettext tarball and look in its "doc/" directory, there's
+ an easily browsable HTML version in there. The
+ gettext documentation asks lots of questions worth thinking
+ about, even if some of their answers are sometimes wonky,
+ particularly where they start talking about pluralization.
+
+ The Locale/Maketext.pm source. Obverse that the module is much
+ shorter than its documentation!
+
+ =head1 COPYRIGHT AND DISCLAIMER
+
+ Copyright (c) 1999-2001 Sean M. Burke. All rights reserved.
+
+ This library is free software; you can redistribute it and/or modify
+ it under the same terms as Perl itself.
+
+ 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.
+
+ =head1 AUTHOR
+
+ Sean M. Burke C<sburke@cpan.org>
+
+ =cut
+
+ # Zing!
diff -c /dev/null 'perl-5.7.2/lib/Locale/Maketext/ChangeLog'
Index: ./lib/Locale/Maketext/ChangeLog
*** ./lib/Locale/Maketext/ChangeLog Thu Jan 1 02:00:00 1970
--- ./lib/Locale/Maketext/ChangeLog Mon Jul 9 17:10:36 2001
***************
*** 0 ****
--- 1,25 ----
+ Revision history for Perl suite Locale::Maketext
+ Time-stamp: "2001-06-21 23:18:31 MDT"
+
+ 2001-06-21 Sean M. Burke sburke@cpan.org
+ * Release 1.03: basically cosmetic tweaks to the docs and the
+ test.pl.
+
+ 2001-06-20 Sean M. Burke sburke@cpan.org
+ * Release 1.02: EBCDIC-compatability changes courtesy of Peter
+ Prymmer. Added [*,...] as alias for [quant,...] and [#,...] as an
+ alias for [numf,...]. Added some more things to test.pl
+
+ 2001-05-25 Sean M. Burke sburke@cpan.org
+ * Release 1.01: total rewrite. Docs are massive now.
+ Including TPJ13 article now.
+
+ 2000-05-14 Sean M. Burke sburke@cpan.org
+
+ * Release 0.18: only change, regrettably, is a better makefile,
+ and it my email address has changed.
+
+ 1999-03-15 Sean M. Burke sburke@netadventure.net
+
+ * Release 0.17: Public alpha release
+ Underdocumented.
diff -c /dev/null 'perl-5.7.2/lib/Locale/Maketext/README'
Index: ./lib/Locale/Maketext/README
*** ./lib/Locale/Maketext/README Thu Jan 1 02:00:00 1970
--- ./lib/Locale/Maketext/README Mon Jul 9 17:10:36 2001
***************
*** 0 ****
--- 1,70 ----
+ README for Locale::Maketext
+ Time-stamp: "2001-05-25 08:15:55 MDT"
+
+ Locale::Maketext
+
+ Locale::Maketext is a base class providing a framework for
+ localization and inheritance-based lexicons, as described in my
+ article in The Perl Journal #13 (a corrected version of which appears
+ in this dist).
+
+ This is a complete rewrite from the basically undocumented 0.x
+ versions.
+
+
+
+ PREREQUISITES
+
+ This suite requires Perl 5. It also requires a recent version
+ of I18N::LangTags. MSWin users should also get Win32::Locale.
+ File::Findgrep is also useful example code.
+
+
+ INSTALLATION
+
+ You install Locale::Maketext, as you would install any Perl module
+ distribution, by running these commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+ If you want to install a private copy of Maketext in your home directory,
+ then you should try to produce the initial Makefile with something
+ like this command:
+
+ perl Makefile.PL LIB=~/perl
+
+ See perldoc perlmodinstall for more information.
+
+
+ DOCUMENTATION
+
+ See the pod in Locale::Maketext and Locale::Maketext::TPJ13,
+ and see also File::Findgrep.
+
+
+ SUPPORT
+
+ Questions, bug reports, useful code bits, and suggestions for
+ Worms should be sent to me at sburke@cpan.org
+
+
+ AVAILABILITY
+
+ The latest version of Locale::Maketext is available from the
+ Comprehensive Perl Archive Network (CPAN). Visit
+ <http://www.perl.com/CPAN/> to find a CPAN site near you.
+
+
+ COPYRIGHT
+
+ Copyright 1999-2001, Sean M. Burke <sburke@cpan.org>, all rights
+ reserved. This program is free software; you can redistribute it
+ and/or modify it under the same terms as Perl itself.
+
+
+ AUTHOR
+
+ Sean M. Burke <sburke@cpan.org>
diff -c /dev/null 'perl-5.7.2/lib/Locale/Maketext/TPJ13.pod'
Index: ./lib/Locale/Maketext/TPJ13.pod
*** ./lib/Locale/Maketext/TPJ13.pod Thu Jan 1 02:00:00 1970
--- ./lib/Locale/Maketext/TPJ13.pod Mon Jul 9 17:10:36 2001
***************
*** 0 ****
--- 1,776 ----
+
+ # This document contains text in Perl "POD" format.
+ # Use a POD viewer like perldoc or perlman to render it.
+
+ =head1 NAME
+
+ Locale::Maketext::TPJ13 -- article about software localization
+
+ =head1 SYNOPSIS
+
+ # This an article, not a module.
+
+ =head1 DESCRIPTION
+
+ The following article by Sean M. Burke and Jordan Lachler
+ first appeared in I<The Perl
+ Journal> #13 and is copyright 1999 The Perl Journal. It appears
+ courtesy of Jon Orwant and The Perl Journal. This document may be
+ distributed under the same terms as Perl itself.
+
+ =head1 Localization and Perl: gettext breaks, Maketext fixes
+
+ by Sean M. Burke and Jordan Lachler
+
+ This article points out cases where gettext (a common system for
+ localizing software interfaces -- i.e., making them work in the user's
+ language of choice) fails because of basic differences between human
+ languages. This article then describes Maketext, a new system capable
+ of correctly treating these differences.
+
+ =head2 A Localization Horror Story: It Could Happen To You
+
+ =over
+
+ "There are a number of languages spoken by human beings in this
+ world."
+
+ -- Harald Tveit Alvestrand, in RFC 1766, "Tags for the
+ Identification of Languages"
+
+ =back
+
+ Imagine that your task for the day is to localize a piece of software
+ -- and luckily for you, the only output the program emits is two
+ messages, like this:
+
+ I scanned 12 directories.
+
+ Your query matched 10 files in 4 directories.
+
+ So how hard could that be? You look at the code that produces
+ produces the first item, and it reads:
+
+ printf("I scanned %g directories.",
+ $directory_count);
+
+ You think about that, and realize that it doesn't even work right for
+ English, as it can produce this output:
+
+ I scanned 1 directories.
+
+ So you rewrite it to read:
+
+ printf("I scanned %g %s.",
+ $directory_count,
+ $directory_count == 1 ?
+ "directory" : "directories",
+ );
+
+ ...which does the Right Thing. (In case you don't recall, "%g" is for
+ locale-specific number interpolation, and "%s" is for string
+ interpolation.)
+
+ But you still have to localize it for all the languages you're
+ producing this software for, so you pull Locale::gettext off of CPAN
+ so you can access the C<gettext> C functions you've heard are standard
+ for localization tasks.
+
+ And you write:
+
+ printf(gettext("I scanned %g %s."),
+ $dir_scan_count,
+ $dir_scan_count == 1 ?
+ gettext("directory") : gettext("directory"),
+ );
+
+ But you then read in the gettext manual (Drepper, Miller, and Pinard 1995)
+ that this is not a good idea, since how a single word like "directory"
+ or "directories" is translated may depend on context -- and this is
+ true, since in a case language like German or Russian, you'd may need
+ these words with a different case ending in the first instance (where the
+ word is the object of a verb) than in the second instance, which you haven't even
+ gotten to yet (where the word is the object of a preposition, "in %g
+ directories") -- assuming these keep the same syntax when translated
+ into those languages.
+
+ So, on the advice of the gettext manual, you rewrite:
+
+ printf( $dir_scan_count == 1 ?
+ gettext("I scanned %g directory.") :
+ gettext("I scanned %g directories."),
+ $dir_scan_count );
+
+ So, you email your various translators (the boss decides that the
+ languages du jour are Chinese, Arabic, Russian, and Italian, so you
+ have one translator for each), asking for translations for "I scanned
+ %g directory." and "I scanned %g directories.". When they reply,
+ you'll put that in the lexicons for gettext to use when it localizes
+ your software, so that when the user is running under the "zh"
+ (Chinese) locale, gettext("I scanned %g directory.") will return the
+ appropriate Chinese text, with a "%g" in there where printf can then
+ interpolate $dir_scan.
+
+ Your Chinese translator emails right back -- he says both of these
+ phrases translate to the same thing in Chinese, because, in linguistic
+ jargon, Chinese "doesn't have number as a grammatical category" --
+ whereas English does. That is, English has grammatical rules that
+ refer to "number", i.e., whether something is grammatically singular
+ or plural; and one of these rules is the one that forces nouns to take
+ a plural suffix (generally "s") when in a plural context, as they are when
+ they follow a number other than "one" (including, oddly enough, "zero").
+ Chinese has no such rules, and so has just the one phrase where English
+ has two. But, no problem, you can have this one Chinese phrase appear
+ as the translation for the two English phrases in the "zh" gettext
+ lexicon for your program.
+
+ Emboldened by this, you dive into the second phrase that your software
+ needs to output: "Your query matched 10 files in 4 directories.". You notice
+ that if you want to treat phrases as indivisible, as the gettext
+ manual wisely advises, you need four cases now, instead of two, to
+ cover the permutations of singular and plural on the two items,
+ $dir_count and $file_count. So you try this:
+
+ printf( $file_count == 1 ?
+ ( $directory_count == 1 ?
+ gettext("Your query matched %g file in %g directory.") :
+ gettext("Your query matched %g file in %g directories.") ) :
+ ( $directory_count == 1 ?
+ gettext("Your query matched %g files in %g directory.") :
+ gettext("Your query matched %g files in %g directories.") ),
+ $file_count, $directory_count,
+ );
+
+ (The case of "1 file in 2 [or more] directories" could, I suppose,
+ occur in the case of symlinking or something of the sort.)
+
+ It occurs to you that this is not the prettiest code you've ever
+ written, but this seems the way to go. You mail off to the
+ translators asking for translations for these four cases. The
+ Chinese guy replies with the one phrase that these all translate to in
+ Chinese, and that phrase has two "%g"s in it, as it should -- but
+ there's a problem. He translates it word-for-word back: "To your
+ question, in %g directories you would find %g answers." The "%g"
+ slots are in an order reverse to what they are in English. You wonder
+ how you'll get gettext to handle that.
+
+ But you put it aside for the moment, and optimistically hope that the
+ other translators won't have this problem, and that their languages
+ will be better behaved -- i.e., that they will be just like English.
+
+ But the Arabic translator is the next to write back. First off, your
+ code for "I scanned %g directory." or "I scanned %g directories."
+ assumes there's only singular or plural. But, to use linguistic
+ jargon again, Arabic has grammatical number, like English (but unlike
+ Chinese), but it's a three-term category: singular, dual, and plural.
+ In other words, the way you say "directory" depends on whether there's
+ one directory, or I<two> of them, or I<more than two> of them. Your
+ test of C<($directory == 1)> no longer does the job. And it means
+ that where English's grammatical category of number necessitates
+ only the two permutations of the first sentence based on "directory
+ [singular]" and "directories [plural]", Arabic has three -- and,
+ worse, in the second sentence ("Your query matched %g file in %g
+ directory."), where English has four, Arabic has nine. You sense
+ an unwelcome, exponential trend taking shape.
+
+ Your Italian translator emails you back and says that "I searched 0
+ directories" (a possible English output of your program) is stilted,
+ and if you think that's fine English, that's your problem, but that
+ I<just will not do> in the language of Dante. He insists that where
+ $directory_count is 0, your program should produce the Italian text
+ for "I I<didn't> scan I<any> directories.". And ditto for "I didn't
+ match any files in any directories", although he says the last part
+ about "in any directories" should probably just be left off.
+
+ You wonder how you'll get gettext to handle this; to accomodate the
+ ways Arabic, Chinese, and Italian deal with numbers in just these few
+ very simple phrases, you need to write code that will ask gettext for
+ different queries depending on whether the numerical values in
+ question are 1, 2, more than 2, or in some cases 0, and you still haven't
+ figured out the problem with the different word order in Chinese.
+
+ Then your Russian translator calls on the phone, to I<personally> tell
+ you the bad news about how really unpleasant your life is about to
+ become:
+
+ Russian, like German or Latin, is an inflectional language; that is, nouns
+ and adjectives have to take endings that depend on their case
+ (i.e., nominative, accusative, genitive, etc...) -- which is roughly a matter of
+ what role they have in syntax of the sentence --
+ as well as on the grammatical gender (i.e., masculine, feminine, neuter)
+ and number (i.e., singular or plural) of the noun, as well as on the
+ declension class of the noun. But unlike with most other inflected languages,
+ putting a number-phrase (like "ten" or "forty-three", or their Arabic
+ numeral equivalents) in front of noun in Russian can change the case and
+ number that noun is, and therefore the endings you have to put on it.
+
+ He elaborates: In "I scanned %g directories", you'd I<expect>
+ "directories" to be in the accusative case (since it is the direct
+ object in the sentnce) and the plural number,
+ except where $directory_count is 1, then you'd expect the singular, of
+ course. Just like Latin or German. I<But!> Where $directory_count %
+ 10 is 1 ("%" for modulo, remember), assuming $directory count is an
+ integer, and except where $directory_count % 100 is 11, "directories"
+ is forced to become grammatically singular, which means it gets the
+ ending for the accusative singular... You begin to visualize the code
+ it'd take to test for the problem so far, I<and still work for Chinese
+ and Arabic and Italian>, and how many gettext items that'd take, but
+ he keeps going... But where $directory_count % 10 is 2, 3, or 4
+ (except where $directory_count % 100 is 12, 13, or 14), the word for
+ "directories" is forced to be genitive singular -- which means another
+ ending... The room begins to spin around you, slowly at first... But
+ with I<all other> integer values, since "directory" is an inanimate
+ noun, when preceded by a number and in the nominative or accusative
+ cases (as it is here, just your luck!), it does stay plural, but it is
+ forced into the genitive case -- yet another another ending... And
+ you never hear him get to the part about how you're going to run into
+ similar (but maybe subtly different) problems with other Slavic
+ languages like Polish, because the floor comes up to meet you, and you
+ fade into unconsciousness.
+
+
+ The above cautionary tale relates how an attempt at localization can
+ lead from programmer consternation, to program obfuscation, to a need
+ for sedation. But careful evaluation shows that your choice of tools
+ merely needed further consideration.
+
+ =head2 The Linguistic View
+
+ =over
+
+ "It is more complicated than you think."
+
+ -- The Eighth Networking Truth, from RFC 1925
+
+ =back
+
+ The field of Linguistics has expended a great deal of effort over the
+ past century trying to find grammatical patterns which hold across
+ languages; it's been a constant process
+ of people making generalizations that should apply to all languages,
+ only to find out that, all too often, these generalizations fail --
+ sometimes failing for just a few languages, sometimes whole classes of
+ languages, and sometimes nearly every language in the world except
+ English. Broad statistical trends are evident in what the "average
+ language" is like as far as what its rules can look like, must look
+ like, and cannot look like. But the "average language" is just as
+ unreal a concept as the "average person" -- it runs up against the
+ fact no language (or person) is, in fact, average. The wisdom of past
+ experience leads us to believe that any given language can do whatever
+ it wants, in any order, with appeal to any kind of grammatical
+ categories wants -- case, number, tense, real or metaphoric
+ characteristics of the things that words refer to, arbitrary or
+ predictable classifications of words based on what endings or prefixes
+ they can take, degree or means of certainty about the truth of
+ statements expressed, and so on, ad infinitum.
+
+ Mercifully, most localization tasks are a matter of finding ways to
+ translate whole phrases, generally sentences, where the context is
+ relatively set, and where the only variation in content is I<usually>
+ in a number being expressed -- as in the example sentences above.
+ Translating specific, fully-formed sentences is, in practice, fairly
+ foolproof -- which is good, because that's what's in the phrasebooks
+ that so many tourists rely on. Now, a given phrase (whether in a
+ phrasebook or in a gettext lexicon) in one language I<might> have a
+ greater or lesser applicability than that phrase's translation into
+ another language -- for example, strictly speaking, in Arabic, the
+ "your" in "Your query matched..." would take a different form
+ depending on whether the user is male or female; so the Arabic
+ translation "your[feminine] query" is applicable in fewer cases than
+ the corresponding English phrase, which doesn't distinguish the user's
+ gender. (In practice, it's not feasable to have a program know the
+ user's gender, so the masculine "you" in Arabic is usually used, by
+ default.)
+
+ But in general, such surprises are rare when entire sentences are
+ being translated, especially when the functional context is restricted
+ to that of a computer interacting with a user either to convey a fact
+ or to prompt for a piece of information. So, for purposes of
+ localization, translation by phrase (generally by sentence) is both the
+ simplest and the least problematic.
+
+ =head2 Breaking gettext
+
+ =over
+
+ "It Has To Work."
+
+ -- First Networking Truth, RFC 1925
+
+ =back
+
+ Consider that sentences in a tourist phrasebook are of two types: ones
+ like "How do I get to the marketplace?" that don't have any blanks to
+ fill in, and ones like "How much do these ___ cost?", where there's
+ one or more blanks to fill in (and these are usually linked to a
+ list of words that you can put in that blank: "fish", "potatoes",
+ "tomatoes", etc.) The ones with no blanks are no problem, but the
+ fill-in-the-blank ones may not be really straightforward. If it's a
+ Swahili phrasebook, for example, the authors probably didn't bother to
+ tell you the complicated ways that the verb "cost" changes its
+ inflectional prefix depending on the noun you're putting in the blank.
+ The trader in the marketplace will still understand what you're saying if
+ you say "how much do these potatoes cost?" with the wrong
+ inflectional prefix on "cost". After all, I<you> can't speak proper Swahili,
+ I<you're> just a tourist. But while tourists can be stupid, computers
+ are supposed to be smart; the computer should be able to fill in the
+ blank, and still have the results be grammatical.
+
+ In other words, a phrasebook entry takes some values as parameters
+ (the things that you fill in the blank or blanks), and provides a value
+ based on these parameters, where the way you get that final value from
+ the given values can, properly speaking, involve an arbitrarily
+ complex series of operations. (In the case of Chinese, it'd be not at
+ all complex, at least in cases like the examples at the beginning of
+ this article; whereas in the case of Russian it'd be a rather complex
+ series of operations. And in some languages, the
+ complexity could be spread around differently: while the act of
+ putting a number-expression in front of a noun phrase might not be
+ complex by itself, it may change how you have to, for example, inflect
+ a verb elsewhere in the sentence. This is what in syntax is called
+ "long-distance dependencies".)
+
+ This talk of parameters and arbitrary complexity is just another way
+ to say that an entry in a phrasebook is what in a programming language
+ would be called a "function". Just so you don't miss it, this is the
+ crux of this article: I<A phrase is a function; a phrasebook is a
+ bunch of functions.>
+
+ The reason that using gettext runs into walls (as in the above
+ second-person horror story) is that you're trying to use a string (or
+ worse, a choice among a bunch of strings) to do what you really need a
+ function for -- which is futile. Preforming (s)printf interpolation
+ on the strings which you get back from gettext does allow you to do I<some>
+ common things passably well... sometimes... sort of; but, to paraphrase
+ what some people say about C<csh> script programming, "it fools you
+ into thinking you can use it for real things, but you can't, and you
+ don't discover this until you've already spent too much time trying,
+ and by then it's too late."
+
+ =head2 Replacing gettext
+
+ So, what needs to replace gettext is a system that supports lexicons
+ of functions instead of lexicons of strings. An entry in a lexicon
+ from such a system should I<not> look like this:
+
+ "J'ai trouv\xE9 %g fichiers dans %g r\xE9pertoires"
+
+ [\xE9 is e-acute in Latin-1. Some pod renderers would
+ scream if I used the actual character here. -- SB]
+
+ but instead like this, bearing in mind that this is just a first stab:
+
+ sub I_found_X1_files_in_X2_directories {
+ my( $files, $dirs ) = @_[0,1];
+ $files = sprintf("%g %s", $files,
+ $files == 1 ? 'fichier' : 'fichiers');
+ $dirs = sprintf("%g %s", $dirs,
+ $dirs == 1 ? "r\xE9pertoire" : "r\xE9pertoires");
+ return "J'ai trouv\xE9 $files dans $dirs.";
+ }
+
+ Now, there's no particularly obvious way to store anything but strings
+ in a gettext lexicon; so it looks like we just have to start over and
+ make something better, from scratch. I call my shot at a
+ gettext-replacement system "Maketext", or, in CPAN terms,
+ Locale::Maketext.
+
+ When designing Maketext, I chose to plan its main features in terms of
+ "buzzword compliance". And here are the buzzwords:
+
+ =head2 Buzzwords: Abstraction and Encapsulation
+
+ The complexity of the language you're trying to output a phrase in is
+ entirely abstracted inside (and encapsulated within) the Maketext module
+ for that interface. When you call:
+
+ print $lang->maketext("You have [quant,_1,piece] of new mail.",
+ scalar(@messages));
+
+ you don't know (and in fact can't easily find out) whether this will
+ involve lots of figuring, as in Russian (if $lang is a handle to the
+ Russian module), or relatively little, as in Chinese. That kind of
+ abstraction and encapsulation may encourage other pleasant buzzwords
+ like modularization and stratification, depending on what design
+ decisions you make.
+
+ =head2 Buzzword: Isomorphism
+
+ "Isomorphism" means "having the same structure or form"; in discussions
+ of program design, the word takes on the special, specific meaning that
+ your implementation of a solution to a problem I<has the same
+ structure> as, say, an informal verbal description of the solution, or
+ maybe of the problem itself. Isomorphism is, all things considered,
+ a good thing -- it's what problem-solving (and solution-implementing)
+ should look like.
+
+ What's wrong the with gettext-using code like this...
+
+ printf( $file_count == 1 ?
+ ( $directory_count == 1 ?
+ "Your query matched %g file in %g directory." :
+ "Your query matched %g file in %g directories." ) :
+ ( $directory_count == 1 ?
+ "Your query matched %g files in %g directory." :
+ "Your query matched %g files in %g directories." ),
+ $file_count, $directory_count,
+ );
+
+ is first off that it's not well abstracted -- these ways of testing
+ for grammatical number (as in the expressions like C<foo == 1 ?
+ singular_form : plural_form>) should be abstracted to each language
+ module, since how you get grammatical number is language-specific.
+
+ But second off, it's not isomorphic -- the "solution" (i.e., the
+ phrasebook entries) for Chinese maps from these four English phrases to
+ the one Chinese phrase that fits for all of them. In other words, the
+ informal solution would be "The way to say what you want in Chinese is
+ with the one phrase 'For your question, in Y directories you would
+ find X files'" -- and so the implemented solution should be,
+ isomorphically, just a straightforward way to spit out that one
+ phrase, with numerals properly interpolated. It shouldn't have to map
+ from the complexity of other languages to the simplicity of this one.
+
+ =head2 Buzzword: Inheritance
+
+ There's a great deal of reuse possible for sharing of phrases between
+ modules for related dialects, or for sharing of auxiliary functions
+ between related languages. (By "auxiliary functions", I mean
+ functions that don't produce phrase-text, but which, say, return an
+ answer to "does this number require a plural noun after it?". Such
+ auxiliary functions would be used in the internal logic of functions
+ that actually do produce phrase-text.)
+
+ In the case of sharing phrases, consider that you have an interface
+ already localized for American English (probably by having been
+ written with that as the native locale, but that's incidental).
+ Localizing it for UK English should, in practical terms, be just a
+ matter of running it past a British person with the instructions to
+ indicate what few phrases would benefit from a change in spelling or
+ possibly minor rewording. In that case, you should be able to put in
+ the UK English localization module I<only> those phrases that are
+ UK-specific, and for all the rest, I<inherit> from the American
+ English module. (And I expect this same situation would apply with
+ Brazilian and Continental Portugese, possbily with some I<very>
+ closely related languages like Czech and Slovak, and possibly with the
+ slightly different "versions" of written Mandarin Chinese, as I hear exist in
+ Taiwan and mainland China.)
+
+ As to sharing of auxiliary functions, consider the problem of Russian
+ numbers from the beginning of this article; obviously, you'd want to
+ write only once the hairy code that, given a numeric value, would
+ return some specification of which case and number a given quanitified
+ noun should use. But suppose that you discover, while localizing an
+ interface for, say, Ukranian (a Slavic language related to Russian,
+ spoken by several million people, many of whom would be relieved to
+ find that your Web site's or software's interface is available in
+ their language), that the rules in Ukranian are the same as in Russian
+ for quantification, and probably for many other grammatical functions.
+ While there may well be no phrases in common between Russian and
+ Ukranian, you could still choose to have the Ukranian module inherit
+ from the Russian module, just for the sake of inheriting all the
+ various grammatical methods. Or, probably better organizationally,
+ you could move those functions to a module called C<_E_Slavic> or
+ something, which Russian and Ukranian could inherit useful functions
+ from, but which would (presumably) provide no lexicon.
+
+ =head2 Buzzword: Concision
+
+ Okay, concision isn't a buzzword. But it should be, so I decree that
+ as a new buzzword, "concision" means that simple common things should
+ be expressible in very few lines (or maybe even just a few characters)
+ of code -- call it a special case of "making simple things easy and
+ hard things possible", and see also the role it played in the
+ MIDI::Simple language, discussed elsewhere in this issue [TPJ#13].
+
+ Consider our first stab at an entry in our "phrasebook of functions":
+
+ sub I_found_X1_files_in_X2_directories {
+ my( $files, $dirs ) = @_[0,1];
+ $files = sprintf("%g %s", $files,
+ $files == 1 ? 'fichier' : 'fichiers');
+ $dirs = sprintf("%g %s", $dirs,
+ $dirs == 1 ? "r\xE9pertoire" : "r\xE9pertoires");
+ return "J'ai trouv\xE9 $files dans $dirs.";
+ }
+
+ You may sense that a lexicon (to use a non-committal catch-all term for a
+ collection of things you know how to say, regardless of whether they're
+ phrases or words) consisting of functions I<expressed> as above would
+ make for rather long-winded and repetitive code -- even if you wisely
+ rewrote this to have quantification (as we call adding a number
+ expression to a noun phrase) be a function called like:
+
+ sub I_found_X1_files_in_X2_directories {
+ my( $files, $dirs ) = @_[0,1];
+ $files = quant($files, "fichier");
+ $dirs = quant($dirs, "r\xE9pertoire");
+ return "J'ai trouv\xE9 $files dans $dirs.";
+ }
+
+ And you may also sense that you do not want to bother your translators
+ with having to write Perl code -- you'd much rather that they spend
+ their I<very costly time> on just translation. And this is to say
+ nothing of the near impossibility of finding a commercial translator
+ who would know even simple Perl.
+
+ In a first-hack implementation of Maketext, each language-module's
+ lexicon looked like this:
+
+ %Lexicon = (
+ "I found %g files in %g directories"
+ => sub {
+ my( $files, $dirs ) = @_[0,1];
+ $files = quant($files, "fichier");
+ $dirs = quant($dirs, "r\xE9pertoire");
+ return "J'ai trouv\xE9 $files dans $dirs.";
+ },
+ ... and so on with other phrase => sub mappings ...
+ );
+
+ but I immediately went looking for some more concise way to basically
+ denote the same phrase-function -- a way that would also serve to
+ concisely denote I<most> phrase-functions in the lexicon for I<most>
+ languages. After much time and even some actual thought, I decided on
+ this system:
+
+ * Where a value in a %Lexicon hash is a contentful string instead of
+ an anonymous sub (or, conceivably, a coderef), it would be interpreted
+ as a sort of shorthand expression of what the sub does. When accessed
+ for the first time in a session, it is parsed, turned into Perl code,
+ and then eval'd into an anonymous sub; then that sub replaces the
+ original string in that lexicon. (That way, the work of parsing and
+ evaling the shorthand form for a given phrase is done no more than
+ once per session.)
+
+ * Calls to C<maketext> (as Maketext's main function is called) happen
+ thru a "language session handle", notionally very much like an IO
+ handle, in that you open one at the start of the session, and use it
+ for "sending signals" to an object in order to have it return the text
+ you want.
+
+ So, this:
+
+ $lang->maketext("You have [quant,_1,piece] of new mail.",
+ scalar(@messages));
+
+ basically means this: look in the lexicon for $lang (which may inherit
+ from any number of other lexicons), and find the function that we
+ happen to associate with the string "You have [quant,_1,piece] of new
+ mail" (which is, and should be, a functioning "shorthand" for this
+ function in the native locale -- English in this case). If you find
+ such a function, call it with $lang as its first parameter (as if it
+ were a method), and then a copy of scalar(@messages) as its second,
+ and then return that value. If that function was found, but was in
+ string shorthand instead of being a fully specified function, parse it
+ and make it into a function before calling it the first time.
+
+ * The shorthand uses code in brackets to indicate method calls that
+ should be performed. A full explanation is not in order here, but a
+ few examples will suffice:
+
+ "You have [quant,_1,piece] of new mail."
+
+ The above code is shorthand for, and will be interpreted as,
+ this:
+
+ sub {
+ my $handle = $_[0];
+ my(@params) = @_;
+ return join '',
+ "You have ",
+ $handle->quant($params[1], 'piece'),
+ "of new mail.";
+ }
+
+ where "quant" is the name of a method you're using to quantify the
+ noun "piece" with the number $params[0].
+
+ A string with no brackety calls, like this:
+
+ "Your search expression was malformed."
+
+ is somewhat of a degerate case, and just gets turned into:
+
+ sub { return "Your search expression was malformed." }
+
+ However, not everything you can write in Perl code can be written in
+ the above shorthand system -- not by a long shot. For example, consider
+ the Italian translator from the beginning of this article, who wanted
+ the Italian for "I didn't find any files" as a special case, instead
+ of "I found 0 files". That couldn't be specified (at least not easily
+ or simply) in our shorthand system, and it would have to be written
+ out in full, like this:
+
+ sub { # pretend the English strings are in Italian
+ my($handle, $files, $dirs) = @_[0,1,2];
+ return "I didn't find any files" unless $files;
+ return join '',
+ "I found ",
+ $handle->quant($files, 'file'),
+ " in ",
+ $handle->quant($dirs, 'directory'),
+ ".";
+ }
+
+ Next to a lexicon full of shorthand code, that sort of sticks out like a
+ sore thumb -- but this I<is> a special case, after all; and at least
+ it's possible, if not as concise as usual.
+
+ As to how you'd implement the Russian example from the beginning of
+ the article, well, There's More Than One Way To Do It, but it could be
+ something like this (using English words for Russian, just so you know
+ what's going on):
+
+ "I [quant,_1,directory,accusative] scanned."
+
+ This shifts the burden of complexity off to the quant method. That
+ method's parameters are: the numeric value it's going to use to
+ quantify something; the Russian word it's going to quantify; and the
+ parameter "accusative", which you're using to mean that this
+ sentence's syntax wants a noun in the accusative case there, although
+ that quantification method may have to overrule, for grammatical
+ reasons you may recall from the beginning of this article.
+
+ Now, the Russian quant method here is responsible not only for
+ implementing the strange logic necessary for figuring out how Russian
+ number-phrases impose case and number on their noun-phrases, but also
+ for inflecting the Russian word for "directory". How that inflection
+ is to be carried out is no small issue, and among the solutions I've
+ seen, some (like variations on a simple lookup in a hash where all
+ possible forms are provided for all necessary words) are
+ straightforward but I<can> become cumbersome when you need to inflect
+ more than a few dozen words; and other solutions (like using
+ algorithms to model the inflections, storing only root forms and
+ irregularities) I<can> involve more overhead than is justifiable for
+ all but the largest lexicons.
+
+ Mercifully, this design decision becomes crucial only in the hairiest
+ of inflected languages, of which Russian is by no means the I<worst> case
+ scenario, but is worse than most. Most languages have simpler
+ inflection systems; for example, in English or Swahili, there are
+ generally no more than two possible inflected forms for a given noun
+ ("error/errors"; "kosa/makosa"), and the
+ rules for producing these forms are fairly simple -- or at least,
+ simple rules can be formulated that work for most words, and you can
+ then treat the exceptions as just "irregular", at least relative to
+ your ad hoc rules. A simpler inflection system (simpler rules, fewer
+ forms) means that design decisions are less crucial to maintaining
+ sanity, whereas the same decisions could incur
+ overhead-versus-scalability problems in languages like Russian. It
+ may I<also> be likely that code (possibly in Perl, as with
+ Lingua::EN::Inflect, for English nouns) has already
+ been written for the language in question, whether simple or complex.
+
+ Moreover, a third possibility may even be simpler than anything
+ discussed above: "Just require that all possible (or at least
+ applicable) forms be provided in the call to the given language's quant
+ method, as in:"
+
+ "I found [quant,_1,file,files]."
+
+ That way, quant just has to chose which form it needs, without having
+ to look up or generate anything. While possibly not optimal for
+ Russian, this should work well for most other languages, where
+ quantification is not as complicated an operation.
+
+ =head2 The Devil in the Details
+
+ There's plenty more to Maketext than described above -- for example,
+ there's the details of how language tags ("en-US", "i-pwn", "fi",
+ etc.) or locale IDs ("en_US") interact with actual module naming
+ ("BogoQuery/Locale/en_us.pm"), and what magic can ensue; there's the
+ details of how to record (and possibly negotiate) what character
+ encoding Maketext will return text in (UTF8? Latin-1? KOI8?). There's
+ the interesting fact that Maketext is for localization, but nowhere
+ actually has a "C<use locale;>" anywhere in it. For the curious,
+ there's the somewhat frightening details of how I actually
+ implement something like data inheritance so that searches across
+ modules' %Lexicon hashes can parallel how Perl implements method
+ inheritance.
+
+ And, most importantly, there's all the practical details of how to
+ actually go about deriving from Maketext so you can use it for your
+ interfaces, and the various tools and conventions for starting out and
+ maintaining individual language modules.
+
+ That is all covered in the documentation for Locale::Maketext and the
+ modules that come with it, available in CPAN. After having read this
+ article, which covers the why's of Maketext, the documentation,
+ which covers the how's of it, should be quite straightfoward.
+
+ =head2 The Proof in the Pudding: Localizing Web Sites
+
+ Maketext and gettext have a notable difference: gettext is in C,
+ accessible thru C library calls, whereas Maketext is in Perl, and
+ really can't work without a Perl interpreter (although I suppose
+ something like it could be written for C). Accidents of history (and
+ not necessarily lucky ones) have made C++ the most common language for
+ the implementation of applications like word processors, Web browsers,
+ and even many in-house applications like custom query systems. Current
+ conditions make it somewhat unlikely that the next one of any of these
+ kinds of applications will be written in Perl, albeit clearly more for
+ reasons of custom and inertia than out of consideration of what is the
+ right tool for the job.
+
+ However, other accidents of history have made Perl a well-accepted
+ language for design of server-side programs (generally in CGI form)
+ for Web site interfaces. Localization of static pages in Web sites is
+ trivial, feasable either with simple language-negotiation features in
+ servers like Apache, or with some kind of server-side inclusions of
+ language-appropriate text into layout templates. However, I think
+ that the localization of Perl-based search systems (or other kinds of
+ dynamic content) in Web sites, be they public or access-restricted,
+ is where Maketext will see the greatest use.
+
+ I presume that it would be only the exceptional Web site that gets
+ localized for English I<and> Chinese I<and> Italian I<and> Arabic
+ I<and> Russian, to recall the languages from the beginning of this
+ article -- to say nothing of German, Spanish, French, Japanese,
+ Finnish, and Hindi, to name a few languages that benefit from large
+ numbers of programmers or Web viewers or both.
+
+ However, the ever-increasing internationalization of the Web (whether
+ measured in terms of amount of content, of numbers of content writers
+ or programmers, or of size of content audiences) makes it increasingly
+ likely that the interface to the average Web-based dynamic content
+ service will be localized for two or maybe three languages. It is my
+ hope that Maketext will make that task as simple as possible, and will
+ remove previous barriers to localization for languages dissimilar to
+ English.
+
+ __END__
+
+ Sean M. Burke (sburkeE<64>cpan.org) has a Master's in linguistics
+ from Northwestern University; he specializes in language technology.
+ Jordan Lachler (lachlerE<64>unm.edu) is a PhD student in the Department of
+ Linguistics at the University of New Mexico; he specializes in
+ morphology and pedagogy of North American native languages.
+
+ =head2 References
+
+ Alvestrand, Harald Tveit. 1995. I<RFC 1766: Tags for the
+ Identification of Languages.>
+ C<ftp://ftp.isi.edu/in-notes/rfc1766.txt>
+ [Now see RFC 3066.]
+
+ Callon, Ross, editor. 1996. I<RFC 1925: The Twelve
+ Networking Truths.>
+ C<ftp://ftp.isi.edu/in-notes/rfc1925.txt>
+
+ Drepper, Ulrich, Peter Miller,
+ and FranE<ccedil>ois Pinard. 1995-2001. GNU
+ C<gettext>. Available in C<ftp://prep.ai.mit.edu/pub/gnu/>, with
+ extensive docs in the distribution tarball. [Since
+ I wrote this article in 1998, I now see that the
+ gettext docs are now trying more to come to terms with
+ plurality. Whether useful conclusions have come from it
+ is another question altogether. -- SMB, May 2001]
+
+ Forbes, Nevill. 1964. I<Russian Grammar.> Third Edition, revised
+ by J. C. Dumbreck. Oxford University Press.
+
+ =cut
+
+ #End
+
diff -c /dev/null 'perl-5.7.2/lib/Locale/Maketext/test.pl'
Index: ./lib/Locale/Maketext/test.pl
*** ./lib/Locale/Maketext/test.pl Thu Jan 1 02:00:00 1970
--- ./lib/Locale/Maketext/test.pl Mon Jul 9 17:10:37 2001
***************
*** 0 ****
--- 1,61 ----
+ # Before `make install' is performed this script should be runnable with
+ # `make test'. After `make install' it should work as `perl test.pl'
+ # Time-stamp: "2001-06-20 02:12:53 MDT"
+ ######################### We start with some black magic to print on failure.
+
+ # (It may become useful if the test is moved to ./t subdirectory.)
+
+ BEGIN { $| = 1; print "1..5\n"; }
+ END {print "fail 1\n" unless $loaded;}
+ use Locale::Maketext 1.01;
+ print "# Perl v$], Locale::Maketext v$Locale::Maketext::VERSION\n";
+ $loaded = 1;
+ print "ok 1\n";
+ {
+ package Woozle;
+ @ISA = ('Locale::Maketext');
+ sub dubbil { return $_[1] * 2 }
+ sub numerate { return $_[2] . 'en' }
+ }
+ {
+ package Woozle::elx;
+ @ISA = ('Woozle');
+ %Lexicon = (
+ 'd2' => 'hum [dubbil,_1]',
+ 'd3' => 'hoo [quant,_1,zaz]',
+ 'd4' => 'hoo [*,_1,zaz]',
+ );
+ }
+
+ $lh = Woozle->get_handle('elx');
+ if($lh) {
+ print "ok 2\n";
+
+ my $x;
+
+ $x = $lh->maketext('d2', 7);
+ if($x eq "hum 14") {
+ print "ok 3\n";
+ } else {
+ print "fail 3 # (got \"$x\")\n";
+ }
+
+ $x = $lh->maketext('d3', 7);
+ if($x eq "hoo 7 zazen") {
+ print "ok 4\n";
+ } else {
+ print "fail 4 # (got \"$x\")\n";
+ }
+
+ $x = $lh->maketext('d4', 7);
+ if($x eq "hoo 7 zazen") {
+ print "ok 5\n";
+ } else {
+ print "fail 5 # (got \"$x\")\n";
+ }
+
+
+ } else {
+ print "fail 2\n";
+ }
+ #Shazam!
diff -c 'perl-5.7.1/lib/Math/BigFloat.pm' 'perl-5.7.2/lib/Math/BigFloat.pm'
Index: ./lib/Math/BigFloat.pm
*** ./lib/Math/BigFloat.pm Fri Apr 6 16:43:06 2001
--- ./lib/Math/BigFloat.pm Tue Jul 10 17:50:05 2001
***************
*** 1,426 ****
package Math::BigFloat;
! use Math::BigInt;
! use Exporter; # just for use to be happy
! @ISA = (Exporter);
! $VERSION = '0.03';
use overload
! '+' => sub {new Math::BigFloat &fadd},
! '-' => sub {new Math::BigFloat
! $_[2]? fsub($_[1],${$_[0]}) : fsub(${$_[0]},$_[1])},
! '<=>' => sub {$_[2]? fcmp($_[1],${$_[0]}) : fcmp(${$_[0]},$_[1])},
! 'cmp' => sub {$_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])},
! '*' => sub {new Math::BigFloat &fmul},
! '/' => sub {new Math::BigFloat
! $_[2]? scalar fdiv($_[1],${$_[0]}) :
! scalar fdiv(${$_[0]},$_[1])},
! '%' => sub {new Math::BigFloat
! $_[2]? scalar fmod($_[1],${$_[0]}) :
! scalar fmod(${$_[0]},$_[1])},
! 'neg' => sub {new Math::BigFloat &fneg},
! 'abs' => sub {new Math::BigFloat &fabs},
! 'int' => sub {new Math::BigInt &f2int},
!
! qw(
! "" stringify
! 0+ numify) # Order of arguments unsignificant
;
! sub new {
! my ($class) = shift;
! my ($foo) = fnorm(shift);
! bless \$foo, $class;
}
! sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead
! # comparing to direct compilation based on
! # stringify
! sub stringify {
! my $n = ${$_[0]};
! my $minus = ($n =~ s/^([+-])// && $1 eq '-');
! $n =~ s/E//;
! $n =~ s/([-+]\d+)$//;
! my $e = $1;
! my $ln = length($n);
! if ( defined $e )
{
! if ($e > 0) {
! $n .= "0" x $e . '.';
! } elsif (abs($e) < $ln) {
! substr($n, $ln + $e, 0) = '.';
! } else {
! $n = '.' . ("0" x (abs($e) - $ln)) . $n;
! }
}
! $n = "-$n" if $minus;
! # 1 while $n =~ s/(.*\d)(\d\d\d)/$1,$2/;
! return $n;
! }
! sub import {
! shift;
! return unless @_;
! die "unknown import: @_" unless @_ == 1 and $_[0] eq ':constant';
! overload::constant float => sub {Math::BigFloat->new(shift)};
! }
! $div_scale = 40;
! # Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'.
! $rnd_mode = 'even';
! sub fadd; sub fsub; sub fmul; sub fdiv;
! sub fneg; sub fabs; sub fcmp;
! sub fround; sub ffround;
! sub fnorm; sub fsqrt;
! # Convert a number to canonical string form.
! # Takes something that looks like a number and converts it to
! # the form /^[+-]\d+E[+-]\d+$/.
! sub fnorm { #(string) return fnum_str
! local($_) = @_;
! s/\s+//g; # strip white space
! no warnings; # $4 and $5 below might legitimately be undefined
! if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/ && "$2$4" ne '') {
! &norm(($1 ? "$1$2$4" : "+$2$4"),(($4 ne '') ? $6-length($4) : $6));
! } else {
! 'NaN';
}
- }
! # normalize number -- for internal use
! sub norm { #(mantissa, exponent) return fnum_str
! local($_, $exp) = @_;
! $exp = 0 unless defined $exp;
! if ($_ eq 'NaN') {
! 'NaN';
! } else {
! s/^([+-])0+/$1/; # strip leading zeros
! if (length($_) == 1) {
! '+0E+0';
! } else {
! $exp += length($1) if (s/(0+)$//); # strip trailing zeros
! sprintf("%sE%+ld", $_, $exp);
! }
}
! }
! # negation
! sub fneg { #(fnum_str) return fnum_str
! local($_) = fnorm($_[$[]);
! vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign
! s/^H/N/;
! $_;
! }
! # absolute value
! sub fabs { #(fnum_str) return fnum_str
! local($_) = fnorm($_[$[]);
! s/^-/+/; # mash sign
! $_;
! }
! # multiplication
! sub fmul { #(fnum_str, fnum_str) return fnum_str
! local($x,$y) = (fnorm($_[$[]),fnorm($_[$[+1]));
! if ($x eq 'NaN' || $y eq 'NaN') {
! 'NaN';
! } else {
! local($xm,$xe) = split('E',$x);
! local($ym,$ye) = split('E',$y);
! &norm(Math::BigInt::bmul($xm,$ym),$xe+$ye);
}
! }
! # addition
! sub fadd { #(fnum_str, fnum_str) return fnum_str
! local($x,$y) = (fnorm($_[$[]),fnorm($_[$[+1]));
! if ($x eq 'NaN' || $y eq 'NaN') {
! 'NaN';
! } else {
! local($xm,$xe) = split('E',$x);
! local($ym,$ye) = split('E',$y);
! ($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye);
! &norm(Math::BigInt::badd($ym,$xm.('0' x ($xe-$ye))),$ye);
}
- }
! # subtraction
! sub fsub { #(fnum_str, fnum_str) return fnum_str
! fadd($_[$[],fneg($_[$[+1]));
! }
! # division
! # args are dividend, divisor, scale (optional)
! # result has at most max(scale, length(dividend), length(divisor)) digits
! sub fdiv #(fnum_str, fnum_str[,scale]) return fnum_str
! {
! local($x,$y,$scale) = (fnorm($_[$[]),fnorm($_[$[+1]),$_[$[+2]);
! if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') {
! 'NaN';
! } else {
! local($xm,$xe) = split('E',$x);
! local($ym,$ye) = split('E',$y);
! $scale = $div_scale if (!$scale);
! $scale = length($xm)-1 if (length($xm)-1 > $scale);
! $scale = length($ym)-1 if (length($ym)-1 > $scale);
! $scale = $scale + length($ym) - length($xm);
! &norm(&round(Math::BigInt::bdiv($xm.('0' x $scale),$ym),
! Math::BigInt::babs($ym)),
! $xe-$ye-$scale);
}
! }
! # modular division
! # args are dividend, divisor
! sub fmod #(fnum_str, fnum_str) return fnum_str
! {
! local($x,$y) = (fnorm($_[$[]),fnorm($_[$[+1]));
! if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') {
! 'NaN';
! } else {
! local($xm,$xe) = split('E',$x);
! local($ym,$ye) = split('E',$y);
! if ( $xe < $ye )
! {
! $ym .= ('0' x ($ye-$xe));
! }
! else
! {
! $xm .= ('0' x ($xe-$ye));
! }
! &norm(Math::BigInt::bmod($xm,$ym));
}
! }
! # round int $q based on fraction $r/$base using $rnd_mode
! sub round { #(int_str, int_str, int_str) return int_str
! local($q,$r,$base) = @_;
! if ($q eq 'NaN' || $r eq 'NaN') {
! 'NaN';
! } elsif ($rnd_mode eq 'trunc') {
! $q; # just truncate
! } else {
! local($cmp) = Math::BigInt::bcmp(Math::BigInt::bmul($r,'+2'),$base);
! if ( $cmp < 0 ||
! ($cmp == 0 && (
! ($rnd_mode eq 'zero' ) ||
! ($rnd_mode eq '-inf' && (substr($q,$[,1) eq '+')) ||
! ($rnd_mode eq '+inf' && (substr($q,$[,1) eq '-')) ||
! ($rnd_mode eq 'even' && $q =~ /[24680]$/ ) ||
! ($rnd_mode eq 'odd' && $q =~ /[13579]$/ ) )
! )
! ) {
! $q; # round down
! } else {
! Math::BigInt::badd($q, ((substr($q,$[,1) eq '-') ? '-1' : '+1'));
! # round up
! }
}
! }
! # round the mantissa of $x to $scale digits
! sub fround { #(fnum_str, scale) return fnum_str
! local($x,$scale) = (fnorm($_[$[]),$_[$[+1]);
! if ($x eq 'NaN' || $scale <= 0) {
! $x;
! } else {
! local($xm,$xe) = split('E',$x);
! if (length($xm)-1 <= $scale) {
! $x;
! } else {
! &norm(&round(substr($xm,$[,$scale+1),
! "+0".substr($xm,$[+$scale+1),"+1"."0" x length(substr($xm,$[+$scale+1))),
! $xe+length($xm)-$scale-1);
! }
}
! }
! # round $x at the 10 to the $scale digit place
! sub ffround { #(fnum_str, scale) return fnum_str
! local($x,$scale) = (fnorm($_[$[]),$_[$[+1]);
! if ($x eq 'NaN') {
! 'NaN';
! } else {
! local($xm,$xe) = split('E',$x);
! if ($xe >= $scale) {
! $x;
! } else {
! $xe = length($xm)+$xe-$scale;
! if ($xe < 1) {
! '+0E+0';
! } elsif ($xe == 1) {
! # The first substr preserves the sign, passing a non-
! # normalized "-0" to &round when rounding -0.006 (for
! # example), purely so &round won't lose the sign.
! &norm(&round(substr($xm,$[,1).'0',
! "+0".substr($xm,$[+1),
! "+1"."0" x length(substr($xm,$[+1))), $scale);
! } else {
! &norm(&round(substr($xm,$[,$xe),
! "+0".substr($xm,$[+$xe),
! "+1"."0" x length(substr($xm,$[+$xe))), $scale);
! }
! }
}
! }
! # Calculate the integer part of $x
! sub f2int { #(fnum_str) return inum_str
! local($x) = ${$_[$[]};
! if ($x eq 'NaN') {
! die "Attempt to take int(NaN)";
! } else {
! local($xm,$xe) = split('E',$x);
! if ($xe >= 0) {
! $xm . '0' x $xe;
! } else {
! $xe = length($xm)+$xe;
! if ($xe <= 1) {
! '+0';
! } else {
! substr($xm,$[,$xe);
! }
! }
}
! }
! # compare 2 values returns one of undef, <0, =0, >0
! # returns undef if either or both input value are not numbers
! sub fcmp #(fnum_str, fnum_str) return cond_code
! {
! local($x, $y) = (fnorm($_[$[]),fnorm($_[$[+1]));
! if ($x eq "NaN" || $y eq "NaN") {
! undef;
! } else {
! local($xm,$xe,$ym,$ye) = split('E', $x."E$y");
! if ($xm eq '+0' || $ym eq '+0') {
! return $xm <=> $ym;
! }
! if ( $xe < $ye ) # adjust the exponents to be equal
! {
! $ym .= '0' x ($ye - $xe);
! $ye = $xe;
! }
! elsif ( $ye < $xe ) # same here
! {
! $xm .= '0' x ($xe - $ye);
! $xe = $ye;
! }
! return Math::BigInt::cmp($xm,$ym);
}
! }
! # square root by Newtons method.
! sub fsqrt { #(fnum_str[, scale]) return fnum_str
! local($x, $scale) = (fnorm($_[$[]), $_[$[+1]);
! if ($x eq 'NaN' || $x =~ /^-/) {
! 'NaN';
! } elsif ($x eq '+0E+0') {
! '+0E+0';
! } else {
! local($xm, $xe) = split('E',$x);
! $scale = $div_scale if (!$scale);
! $scale = length($xm)-1 if ($scale < length($xm)-1);
! local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2));
! while ($gs < 2*$scale) {
! $guess = fmul(fadd($guess,fdiv($x,$guess,$gs*2)),".5");
! $gs *= 2;
! }
! new Math::BigFloat &fround($guess, $scale);
}
! }
1;
__END__
=head1 NAME
! Math::BigFloat - Arbitrary length float math package
=head1 SYNOPSIS
use Math::BigFloat;
- $f = Math::BigFloat->new($string);
! $f->fadd(NSTR) return NSTR addition
! $f->fsub(NSTR) return NSTR subtraction
! $f->fmul(NSTR) return NSTR multiplication
! $f->fdiv(NSTR[,SCALE]) returns NSTR division to SCALE places
! $f->fmod(NSTR) returns NSTR modular remainder
! $f->fneg() return NSTR negation
! $f->fabs() return NSTR absolute value
! $f->fcmp(NSTR) return CODE compare undef,<0,=0,>0
! $f->fround(SCALE) return NSTR round to SCALE digits
! $f->ffround(SCALE) return NSTR round at SCALEth place
! $f->fnorm() return (NSTR) normalize
! $f->fsqrt([SCALE]) return NSTR sqrt to SCALE places
=head1 DESCRIPTION
! All basic math operations are overloaded if you declare your big
! floats as
! $float = new Math::BigFloat "2.123123123123123123123123123123123";
=over 2
! =item number format
! canonical strings have the form /[+-]\d+E[+-]\d+/ . Input values can
! have embedded whitespace.
! =item Error returns 'NaN'
! An input parameter was "Not a Number" or divide by zero or sqrt of
! negative number.
! =item Division is computed to
! C<max($Math::BigFloat::div_scale,length(dividend)+length(divisor))>
! digits by default.
! Also used for default sqrt scale.
! =item Rounding is performed
! according to the value of
! C<$Math::BigFloat::rnd_mode>:
! trunc truncate the value
! zero round towards 0
! +inf round towards +infinity (round up)
! -inf round towards -infinity (round down)
! even round to the nearest, .5 to the even digit
! odd round to the nearest, .5 to the odd digit
! The default is C<even> rounding.
=back
=head1 BUGS
! The current version of this module is a preliminary version of the
! real thing that is currently (as of perl5.002) under development.
! The printf subroutine does not use the value of
! C<$Math::BigFloat::rnd_mode> when rounding values for printing.
! Consequently, the way to print rounded values is
! to specify the number of digits both as an
! argument to C<ffround> and in the C<%f> printf string,
! as follows:
! printf "%.3f\n", $bigfloat->ffround(-3);
! =head1 AUTHOR
! Mark Biggar
! Patches by John Peacock Apr 2001
=cut
--- 1,1367 ----
+ #!/usr/bin/perl -w
+
+ # The following hash values are internally used:
+ # _e: exponent (BigInt)
+ # _m: mantissa (absolute BigInt)
+ # sign: +,-,"NaN" if not a number
+ # _a: accuracy
+ # _p: precision
+ # _f: flags, used to signal MBI not to touch our private parts
+ # _cow: Copy-On-Write (NRY)
+
package Math::BigFloat;
! $VERSION = 1.16;
! require 5.005;
! use Exporter;
! use Math::BigInt qw/objectify/;
! @ISA = qw( Exporter Math::BigInt);
! # can not export bneg/babs since the are only in MBI
! @EXPORT_OK = qw(
! bcmp
! badd bmul bdiv bmod bnorm bsub
! bgcd blcm bround bfround
! bpow bnan bzero bfloor bceil
! bacmp bstr binc bdec bint binf
! is_odd is_even is_nan is_inf is_positive is_negative
! is_zero is_one sign
! );
! #@EXPORT = qw( );
! use strict;
! use vars qw/$AUTOLOAD $accuracy $precision $div_scale $rnd_mode/;
! my $class = "Math::BigFloat";
use overload
! '<=>' => sub {
! $_[2] ?
! $class->bcmp($_[1],$_[0]) :
! $class->bcmp($_[0],$_[1])},
! 'int' => sub { $_[0]->as_number() }, # 'trunc' to bigint
;
! ##############################################################################
! # global constants, flags and accessory
!
! use constant MB_NEVER_ROUND => 0x0001;
!
! # are NaNs ok?
! my $NaNOK=1;
! # constant for easier life
! my $nan = 'NaN';
! my $ten = Math::BigInt->new(10); # shortcut for speed
!
! # Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'
! $rnd_mode = 'even';
! $accuracy = undef;
! $precision = undef;
! $div_scale = 40;
!
! {
! # checks for AUTOLOAD
! my %methods = map { $_ => 1 }
! qw / fadd fsub fmul fdiv fround ffround fsqrt fmod fstr fsstr fpow fnorm
! fabs fneg fint fcmp fzero fnan finc fdec
! /;
!
! sub method_valid { return exists $methods{$_[0]||''}; }
}
! ##############################################################################
! # constructors
! sub new
! {
! # create a new BigFloat object from a string or another bigfloat object.
! # _e: exponent
! # _m: mantissa
! # sign => sign (+/-), or "NaN"
! my $class = shift;
!
! my $wanted = shift; # avoid numify call by not using || here
! return $class->bzero() if !defined $wanted; # default to 0
! return $wanted->copy() if ref($wanted) eq $class;
! my $round = shift; $round = 0 if !defined $round; # no rounding as default
! my $self = {}; bless $self, $class;
! # shortcut for bigints and its subclasses
! if ((ref($wanted)) && (ref($wanted) ne $class))
! {
! $self->{_m} = $wanted->as_number(); # get us a bigint copy
! $self->{_e} = Math::BigInt->new(0);
! $self->{_m}->babs();
! $self->{sign} = $wanted->sign();
! return $self->bnorm();
! }
! # got string
! # handle '+inf', '-inf' first
! if ($wanted =~ /^[+-]inf$/)
! {
! $self->{_e} = Math::BigInt->new(0);
! $self->{_m} = Math::BigInt->new(0);
! $self->{sign} = $wanted;
! return $self->bnorm();
! }
! #print "new string '$wanted'\n";
! my ($mis,$miv,$mfv,$es,$ev) = Math::BigInt::_split(\$wanted);
! if (!ref $mis)
! {
! die "$wanted is not a number initialized to $class" if !$NaNOK;
! $self->{_e} = Math::BigInt->new(0);
! $self->{_m} = Math::BigInt->new(0);
! $self->{sign} = $nan;
! }
! else
! {
! # make integer from mantissa by adjusting exp, then convert to bigint
! $self->{_e} = Math::BigInt->new("$$es$$ev"); # exponent
! $self->{_m} = Math::BigInt->new("$$mis$$miv$$mfv"); # create mantissa
! # 3.123E0 = 3123E-3, and 3.123E-2 => 3123E-5
! $self->{_e} -= CORE::length($$mfv);
! $self->{sign} = $self->{_m}->sign(); $self->{_m}->babs();
! }
! #print "$wanted => $self->{sign} $self->{value}\n";
! $self->bnorm(); # first normalize
! # if any of the globals is set, round to them and thus store them insid $self
! $self->round($accuracy,$precision,$rnd_mode)
! if defined $accuracy || defined $precision;
! return $self;
! }
! # some shortcuts for easier life
! sub bfloat
! {
! # exportable version of new
! return $class->new(@_);
! }
!
! sub bint
! {
! # exportable version of new
! return $class->new(@_,0)->bround(0,'trunc');
! }
!
! sub bnan
! {
! # create a bigfloat 'NaN', if given a BigFloat, set it to 'NaN'
! my $self = shift;
! $self = $class if !defined $self;
! if (!ref($self))
{
! my $c = $self; $self = {}; bless $self, $c;
}
! $self->{_e} = new Math::BigInt 0;
! $self->{_m} = new Math::BigInt 0;
! $self->{sign} = $nan;
! return $self;
! }
! sub binf
! {
! # create a bigfloat '+-inf', if given a BigFloat, set it to '+-inf'
! my $self = shift;
! my $sign = shift; $sign = '+' if !defined $sign || $sign ne '-';
! $self = $class if !defined $self;
! if (!ref($self))
! {
! my $c = $self; $self = {}; bless $self, $c;
! }
! $self->{_e} = new Math::BigInt 0;
! $self->{_m} = new Math::BigInt 0;
! $self->{sign} = $sign.'inf';
! return $self;
! }
! sub bzero
! {
! # create a bigfloat '+0', if given a BigFloat, set it to 0
! my $self = shift;
! $self = $class if !defined $self;
! if (!ref($self))
! {
! my $c = $self; $self = {}; bless $self, $c;
! }
! $self->{_m} = new Math::BigInt 0;
! $self->{_e} = new Math::BigInt 1;
! $self->{sign} = '+';
! return $self;
! }
! ##############################################################################
! # string conversation
! sub bstr
! {
! # (ref to BFLOAT or num_str ) return num_str
! # Convert number from internal format to (non-scientific) string format.
! # internal format is always normalized (no leading zeros, "-0" => "+0")
! my ($self,$x) = objectify(1,@_);
! #return "Oups! e was $nan" if $x->{_e}->{sign} eq $nan;
! #return "Oups! m was $nan" if $x->{_m}->{sign} eq $nan;
! return $x->{sign} if $x->{sign} !~ /^[+-]$/;
! return '0' if $x->is_zero();
! my $es = $x->{_m}->bstr();
! if ($x->{_e}->is_zero())
! {
! $es = $x->{sign}.$es if $x->{sign} eq '-';
! return $es;
! }
!
! if ($x->{_e}->sign() eq '-')
! {
! if ($x->{_e} <= -CORE::length($es))
! {
! # print "style: 0.xxxx\n";
! my $r = $x->{_e}->copy(); $r->babs()->bsub( CORE::length($es) );
! $es = '0.'. ('0' x $r) . $es;
! }
! else
! {
! # print "insert '.' at $x->{_e} in '$es'\n";
! substr($es,$x->{_e},0) = '.';
! }
! }
! else
! {
! # expand with zeros
! $es .= '0' x $x->{_e};
! }
! $es = $x->{sign}.$es if $x->{sign} eq '-';
! return $es;
! }
! sub bsstr
! {
! # (ref to BFLOAT or num_str ) return num_str
! # Convert number from internal format to scientific string format.
! # internal format is always normalized (no leading zeros, "-0E0" => "+0E0")
! my ($self,$x) = objectify(1,@_);
!
! return "Oups! e was $nan" if $x->{_e}->{sign} eq $nan;
! return "Oups! m was $nan" if $x->{_m}->{sign} eq $nan;
! return $x->{sign} if $x->{sign} !~ /^[+-]$/;
! my $sign = $x->{_e}->{sign}; $sign = '' if $sign eq '-';
! my $sep = 'e'.$sign;
! return $x->{_m}->bstr().$sep.$x->{_e}->bstr();
! }
!
! sub numify
! {
! # Make a number from a BigFloat object
! # simple return string and let Perl's atoi() handle the rest
! my ($self,$x) = objectify(1,@_);
! return $x->bsstr();
! }
!
! ##############################################################################
! # public stuff (usually prefixed with "b")
!
! # really? Just for exporting them is not what I had in mind
! #sub babs
! # {
! # $class->SUPER::babs($class,@_);
! # }
! #sub bneg
! # {
! # $class->SUPER::bneg($class,@_);
! # }
! #sub bnot
! # {
! # $class->SUPER::bnot($class,@_);
! # }
!
! sub bcmp
! {
! # Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort)
! # (BFLOAT or num_str, BFLOAT or num_str) return cond_code
! my ($self,$x,$y) = objectify(2,@_);
!
! if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
! {
! # handle +-inf and NaN
! return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
! return 0 if ($x->{sign} eq $y->{sign}) && ($x->{sign} =~ /^[+-]inf$/);
! return +1 if $x->{sign} eq '+inf';
! return -1 if $x->{sign} eq '-inf';
! return -1 if $y->{sign} eq '+inf';
! return +1 if $y->{sign} eq '-inf';
}
! # check sign for speed first
! return 1 if $x->{sign} eq '+' && $y->{sign} eq '-';
! return -1 if $x->{sign} eq '-' && $y->{sign} eq '+'; # does also -x <=> 0
!
! return 0 if $x->is_zero() && $y->is_zero(); # 0 <=> 0
! return -1 if $x->is_zero() && $y->{sign} eq '+'; # 0 <=> +y
! return 1 if $y->is_zero() && $x->{sign} eq '+'; # +x <=> 0
!
! # adjust so that exponents are equal
! my $lx = $x->{_m}->length() + $x->{_e};
! my $ly = $y->{_m}->length() + $y->{_e};
! # print "x $x y $y lx $lx ly $ly\n";
! my $l = $lx - $ly; $l = -$l if $x->{sign} eq '-';
! # print "$l $x->{sign}\n";
! return $l if $l != 0;
!
! # lengths are equal, so compare mantissa, if equal, compare exponents
! # this assumes normalized numbers (no trailing zeros etc!)
! my $rc = $x->{_m} <=> $y->{_m} || $x->{_e} <=> $y->{_e};
! $rc = -$rc if $x->{sign} eq '-'; # -124 < -123
! return $rc;
! }
!
! sub bacmp
! {
! # Compares 2 values, ignoring their signs.
! # Returns one of undef, <0, =0, >0. (suitable for sort)
! # (BFLOAT or num_str, BFLOAT or num_str) return cond_code
! my ($self,$x,$y) = objectify(2,@_);
! return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
!
! # signs are ignored, so check length
! # length(x) is length(m)+e aka length of non-fraction part
! # the longer one is bigger
! my $l = $x->length() - $y->length();
! #print "$l\n";
! return $l if $l != 0;
! #print "equal lengths\n";
!
! # if both are equal long, make full compare
! # first compare only the mantissa
! # if mantissa are equal, compare fractions
!
! return $x->{_m} <=> $y->{_m} || $x->{_e} <=> $y->{_e};
! }
!
! sub badd
! {
! # add second arg (BFLOAT or string) to first (BFLOAT) (modifies first)
! # return result as BFLOAT
! my ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
!
! return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
!
! # speed: no add for 0+y or x+0
! return $x if $y->is_zero(); # x+0
! if ($x->is_zero()) # 0+y
! {
! # make copy, clobbering up x (modify in place!)
! $x->{_e} = $y->{_e}->copy();
! $x->{_m} = $y->{_m}->copy();
! $x->{sign} = $y->{sign} || $nan;
! return $x->round($a,$p,$r,$y);
}
!
! # take lower of the two e's and adapt m1 to it to match m2
! my $e = $y->{_e}; $e = Math::BigInt::bzero() if !defined $e; # if no BFLOAT
! $e = $e - $x->{_e};
! my $add = $y->{_m}->copy();
! if ($e < 0)
! {
! # print "e < 0\n";
! #print "\$x->{_m}: $x->{_m} ";
! #print "\$x->{_e}: $x->{_e}\n";
! my $e1 = $e->copy()->babs();
! $x->{_m} *= (10 ** $e1);
! $x->{_e} += $e; # need the sign of e
! #$x->{_m} += $y->{_m};
! #print "\$x->{_m}: $x->{_m} ";
! #print "\$x->{_e}: $x->{_e}\n";
! }
! elsif ($e > 0)
! {
! # print "e > 0\n";
! #print "\$x->{_m}: $x->{_m} \$y->{_m}: $y->{_m} \$e: $e ",ref($e),"\n";
! $add *= (10 ** $e);
! #$x->{_m} += $y->{_m} * (10 ** $e);
! #print "\$x->{_m}: $x->{_m}\n";
! }
! # else: both e are same, so leave them
! #print "badd $x->{sign}$x->{_m} + $y->{sign}$add\n";
! # fiddle with signs
! $x->{_m}->{sign} = $x->{sign};
! $add->{sign} = $y->{sign};
! # finally do add/sub
! $x->{_m} += $add;
! # re-adjust signs
! $x->{sign} = $x->{_m}->{sign};
! $x->{_m}->{sign} = '+';
! #$x->bnorm(); # delete trailing zeros
! return $x->round($a,$p,$r,$y);
! }
! sub bsub
! {
! # (BigFloat or num_str, BigFloat or num_str) return BigFloat
! # subtract second arg from first, modify first
! my ($self,$x,$y) = objectify(2,@_);
! $x->badd($y->bneg()); # badd does not leave internal zeros
! $y->bneg(); # refix y, assumes no one reads $y in between
! return $x; # badd() already normalized and rounded
! }
! sub binc
! {
! # increment arg by one
! my ($self,$x,$a,$p,$r) = objectify(1,@_);
! $x->badd($self->_one())->round($a,$p,$r);
! }
!
! sub bdec
! {
! # decrement arg by one
! my ($self,$x,$a,$p,$r) = objectify(1,@_);
! $x->badd($self->_one('-'))->round($a,$p,$r);
! }
!
! sub blcm
! {
! # (BINT or num_str, BINT or num_str) return BINT
! # does not modify arguments, but returns new object
! # Lowest Common Multiplicator
!
! my ($self,@arg) = objectify(0,@_);
! my $x = $self->new(shift @arg);
! while (@arg) { $x = _lcm($x,shift @arg); }
! $x;
! }
!
! sub bgcd
! {
! # (BINT or num_str, BINT or num_str) return BINT
! # does not modify arguments, but returns new object
! # GCD -- Euclids algorithm Knuth Vol 2 pg 296
!
! my ($self,@arg) = objectify(0,@_);
! my $x = $self->new(shift @arg);
! while (@arg) { $x = _gcd($x,shift @arg); }
! $x;
! }
!
! sub is_zero
! {
! # return true if arg (BINT or num_str) is zero (array '+', '0')
! my $x = shift; $x = $class->new($x) unless ref $x;
! #my ($self,$x) = objectify(1,@_);
! return ($x->{sign} ne $nan && $x->{_m}->is_zero());
! }
!
! sub is_one
! {
! # return true if arg (BINT or num_str) is +1 (array '+', '1')
! # or -1 if signis given
! my $x = shift; $x = $class->new($x) unless ref $x;
! #my ($self,$x) = objectify(1,@_);
! my $sign = $_[2] || '+';
! return ($x->{sign} eq $sign && $x->{_e}->is_zero() && $x->{_m}->is_one());
! }
!
! sub is_odd
! {
! # return true if arg (BINT or num_str) is odd or false if even
! my $x = shift; $x = $class->new($x) unless ref $x;
! #my ($self,$x) = objectify(1,@_);
!
! return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't
! return ($x->{_e}->is_zero() && $x->{_m}->is_odd());
! }
!
! sub is_even
! {
! # return true if arg (BINT or num_str) is even or false if odd
! my $x = shift; $x = $class->new($x) unless ref $x;
! #my ($self,$x) = objectify(1,@_);
!
! return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't
! return 1 if $x->{_m}->is_zero(); # 0e1 is even
! return ($x->{_e}->is_zero() && $x->{_m}->is_even()); # 123.45 is never
! }
!
! sub bmul
! {
! # multiply two numbers -- stolen from Knuth Vol 2 pg 233
! # (BINT or num_str, BINT or num_str) return BINT
! my ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
!
! # print "mbf bmul $x->{_m}e$x->{_e} $y->{_m}e$y->{_e}\n";
! return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
!
! # aEb * cEd = (a*c)E(b+d)
! $x->{_m} = $x->{_m} * $y->{_m};
! #print "m: $x->{_m}\n";
! $x->{_e} = $x->{_e} + $y->{_e};
! #print "e: $x->{_m}\n";
! # adjust sign:
! $x->{sign} = $x->{sign} ne $y->{sign} ? '-' : '+';
! #print "s: $x->{sign}\n";
! $x->bnorm();
! return $x->round($a,$p,$r,$y);
! }
!
! sub bdiv
! {
! # (dividend: BFLOAT or num_str, divisor: BFLOAT or num_str) return
! # (BFLOAT,BFLOAT) (quo,rem) or BINT (only rem)
! my ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
!
! return wantarray ? ($x->bnan(),bnan()) : $x->bnan()
! if ($x->{sign} eq $nan || $y->is_nan() || $y->is_zero());
!
! $y = $class->new($y) if ref($y) ne $class; # promote bigints
!
! # print "mbf bdiv $x ",ref($x)," ",$y," ",ref($y),"\n";
! # we need to limit the accuracy to protect against overflow
! my ($scale) = $x->_scale_a($accuracy,$rnd_mode,$a,$r); # ignore $p
! if (!defined $scale)
! {
! # simulate old behaviour
! $scale = $div_scale+1; # one more for proper riund
! $a = $div_scale; # and round to it
}
! my $lx = $x->{_m}->length(); my $ly = $y->{_m}->length();
! $scale = $lx if $lx > $scale;
! $scale = $ly if $ly > $scale;
! #print "scale $scale $lx $ly\n";
! my $diff = $ly - $lx;
! $scale += $diff if $diff > 0; # if lx << ly, but not if ly << lx!
! return wantarray ? ($x,$self->bzero()) : $x if $x->is_zero();
!
! $x->{sign} = $x->{sign} ne $y->sign() ? '-' : '+';
!
! # check for / +-1 ( +/- 1E0)
! if ($y->is_one())
! {
! return wantarray ? ($x,$self->bzero()) : $x;
}
! # a * 10 ** b / c * 10 ** d => a/c * 10 ** (b-d)
! #print "self: $self x: $x ref(x) ", ref($x)," m: $x->{_m}\n";
! # my $scale_10 = 10 ** $scale; $x->{_m}->bmul($scale_10);
! $x->{_m}->blsft($scale,10);
! #print "m: $x->{_m} $y->{_m}\n";
! $x->{_m}->bdiv( $y->{_m} ); # a/c
! #print "m: $x->{_m}\n";
! #print "e: $x->{_e} $y->{_e}",$scale,"\n";
! $x->{_e}->bsub($y->{_e}); # b-d
! #print "e: $x->{_e}\n";
! $x->{_e}->bsub($scale); # correct for 10**scale
! #print "after div: m: $x->{_m} e: $x->{_e}\n";
! $x->bnorm(); # remove trailing 0's
! #print "after div: m: $x->{_m} e: $x->{_e}\n";
! $x->round($a,$p,$r); # then round accordingly
!
! if (wantarray)
! {
! my $rem = $x->copy();
! $rem->bmod($y,$a,$p,$r);
! return ($x,$rem);
! }
! return $x;
! }
! sub bmod
! {
! # (dividend: BFLOAT or num_str, divisor: BFLOAT or num_str) return reminder
! my ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
!
! return $x->bnan() if ($x->{sign} eq $nan || $y->is_nan() || $y->is_zero());
! return $x->bzero() if $y->is_one();
!
! # XXX tels: not done yet
! return $x->round($a,$p,$r,$y);
! }
!
! sub bsqrt
! {
! # calculate square root; this should probably
! # use a different test to see whether the accuracy we want is...
! my ($self,$x,$a,$p,$r) = objectify(1,@_);
!
! return $x->bnan() if $x->{sign} eq 'NaN' || $x->{sign} =~ /^-/; # <0, NaN
! return $x if $x->{sign} eq '+inf'; # +inf
! return $x if $x->is_zero() || $x == 1;
!
! # we need to limit the accuracy to protect against overflow
! my ($scale) = $x->_scale_a($accuracy,$rnd_mode,$a,$r); # ignore $p
! if (!defined $scale)
! {
! # simulate old behaviour
! $scale = $div_scale+1; # one more for proper riund
! $a = $div_scale; # and round to it
}
! my $lx = $x->{_m}->length();
! $scale = $lx if $scale < $lx;
! my $e = Math::BigFloat->new("1E-$scale"); # make test variable
! return $x->bnan() if $e->sign() eq 'NaN';
! # start with some reasonable guess
! #$x *= 10 ** ($len - $org->{_e}); $x /= 2; # !?!?
! $lx = 1 if $lx < 1;
! my $gs = Math::BigFloat->new('1'. ('0' x $lx));
!
! # print "first guess: $gs (x $x) scale $scale\n";
!
! my $diff = $e;
! my $y = $x->copy();
! my $two = Math::BigFloat->new(2);
! $x = Math::BigFloat->new($x) if ref($x) ne $class; # promote BigInts
! # $scale = 2;
! while ($diff >= $e)
! {
! return $x->bnan() if $gs->is_zero();
! $r = $y->copy(); $r->bdiv($gs,$scale);
! $x = ($r + $gs);
! $x->bdiv($two,$scale);
! $diff = $x->copy()->bsub($gs)->babs();
! $gs = $x->copy();
}
! $x->round($a,$p,$r);
! }
!
! sub bpow
! {
! # (BFLOAT or num_str, BFLOAT or num_str) return BFLOAT
! # compute power of two numbers, second arg is used as integer
! # modifies first argument
!
! my ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
!
! return $x if $x->{sign} =~ /^[+-]inf$/;
! return $x->bnan() if $x->{sign} eq $nan || $y->{sign} eq $nan;
! return $x->bzero()->binc() if $y->is_zero();
! return $x if $x->is_one() || $y->is_one();
! my $y1 = $y->as_number(); # make bigint
! if ($x == -1)
! {
! # if $x == -1 and odd/even y => +1/-1 because +-1 ^ (+-1) => +-1
! return $y1->is_odd() ? $x : $x->babs(1);
}
! return $x if $x->is_zero() && $y->{sign} eq '+'; # 0**y => 0 (if not y <= 0)
! # 0 ** -y => 1 / (0 ** y) => / 0!
! return $x->bnan() if $x->is_zero() && $y->{sign} eq '-';
! # calculate $x->{_m} ** $y and $x->{_e} * $y separately (faster)
! $y1->babs();
! $x->{_m}->bpow($y1);
! $x->{_e}->bmul($y1);
! $x->{sign} = $nan if $x->{_m}->{sign} eq $nan || $x->{_e}->{sign} eq $nan;
! $x->bnorm();
! if ($y->{sign} eq '-')
! {
! # modify $x in place!
! my $z = $x->copy(); $x->bzero()->binc();
! return $x->bdiv($z,$a,$p,$r); # round in one go (might ignore y's A!)
}
! return $x->round($a,$p,$r,$y);
! }
! ###############################################################################
! # rounding functions
!
! sub bfround
! {
! # precision: round to the $Nth digit left (+$n) or right (-$n) from the '.'
! # $n == 0 means round to integer
! # expects and returns normalized numbers!
! my $x = shift; $x = $class->new($x) unless ref $x;
!
! return $x if $x->modify('bfround');
!
! my ($scale,$mode) = $x->_scale_p($precision,$rnd_mode,@_);
! return $x if !defined $scale; # no-op
!
! # print "MBF bfround $x to scale $scale mode $mode\n";
! return $x if $x->is_nan() or $x->is_zero();
!
! if ($scale < 0)
! {
! # print "bfround scale $scale e $x->{_e}\n";
! # round right from the '.'
! return $x if $x->{_e} >= 0; # nothing to round
! $scale = -$scale; # positive for simplicity
! my $len = $x->{_m}->length(); # length of mantissa
! my $dad = -$x->{_e}; # digits after dot
! my $zad = 0; # zeros after dot
! $zad = -$len-$x->{_e} if ($x->{_e} < -$len);# for 0.00..00xxx style
! # print "scale $scale dad $dad zad $zad len $len\n";
!
! # number bsstr len zad dad
! # 0.123 123e-3 3 0 3
! # 0.0123 123e-4 3 1 4
! # 0.001 1e-3 1 2 3
! # 1.23 123e-2 3 0 2
! # 1.2345 12345e-4 5 0 4
!
! # do not round after/right of the $dad
! return $x if $scale > $dad; # 0.123, scale >= 3 => exit
!
! # round to zero if rounding inside the $zad, but not for last zero like:
! # 0.0065, scale -2, round last '0' with following '65' (scale == zad case)
! if ($scale < $zad)
! {
! $x->{_m} = Math::BigInt->new(0);
! $x->{_e} = Math::BigInt->new(1);
! $x->{sign} = '+';
! return $x;
! }
! if ($scale == $zad) # for 0.006, scale -2 and trunc
! {
! $scale = -$len;
! }
! else
! {
! # adjust round-point to be inside mantissa
! if ($zad != 0)
! {
! $scale = $scale-$zad;
! }
! else
! {
! my $dbd = $len - $dad; $dbd = 0 if $dbd < 0; # digits before dot
! $scale = $dbd+$scale;
! }
! }
! # print "round to $x->{_m} to $scale\n";
}
! else
! {
! # 123 => 100 means length(123) = 3 - $scale (2) => 1
! # calculate digits before dot
! my $dbt = $x->{_m}->length(); $dbt += $x->{_e} if $x->{_e}->sign() eq '-';
! if (($scale > $dbt) && ($dbt < 0))
! {
! # if not enough digits before dot, round to zero
! $x->{_m} = Math::BigInt->new(0);
! $x->{_e} = Math::BigInt->new(1);
! $x->{sign} = '+';
! return $x;
! }
! if (($scale >= 0) && ($dbt == 0))
! {
! # 0.49->bfround(1): scale == 1, dbt == 0: => 0.0
! # 0.51->bfround(0): scale == 0, dbt == 0: => 1.0
! # 0.5->bfround(0): scale == 0, dbt == 0: => 0
! # 0.05->bfround(0): scale == 0, dbt == 0: => 0
! # print "$scale $dbt $x->{_m}\n";
! $scale = -$x->{_m}->length();
! }
! elsif ($dbt > 0)
! {
! # correct by subtracting scale
! $scale = $dbt - $scale;
! }
! else
! {
! $scale = $x->{_m}->length() - $scale;
! }
}
! #print "using $scale for $x->{_m} with '$mode'\n";
! # pass sign to bround for '+inf' and '-inf' rounding modes
! $x->{_m}->{sign} = $x->{sign};
! $x->{_m}->bround($scale,$mode);
! $x->{_m}->{sign} = '+'; # fix sign back
! $x->bnorm();
! }
! sub bround
! {
! # accuracy: preserve $N digits, and overwrite the rest with 0's
! my $x = shift; $x = $class->new($x) unless ref $x;
! my ($scale,$mode) = $x->_scale_a($accuracy,$rnd_mode,@_);
! return $x if !defined $scale; # no-op
!
! return $x if $x->modify('bround');
!
! # print "bround $scale $mode\n";
! # 0 => return all digits, scale < 0 makes no sense
! return $x if ($scale <= 0);
! return $x if $x->is_nan() or $x->is_zero(); # never round a 0
!
! # if $e longer than $m, we have 0.0000xxxyyy style number, and must
! # subtract the delta from scale, to simulate keeping the zeros
! # -5 +5 => 1; -10 +5 => -4
! my $delta = $x->{_e} + $x->{_m}->length() + 1;
! # removed by tlr, since causes problems with fraction tests:
! # $scale += $delta if $delta < 0;
!
! # if we should keep more digits than the mantissa has, do nothing
! return $x if $x->{_m}->length() <= $scale;
!
! # pass sign to bround for '+inf' and '-inf' rounding modes
! $x->{_m}->{sign} = $x->{sign};
! $x->{_m}->bround($scale,$mode); # round mantissa
! $x->{_m}->{sign} = '+'; # fix sign back
! return $x->bnorm(); # del trailing zeros gen. by bround()
! }
!
! sub bfloor
! {
! # return integer less or equal then $x
! my ($self,$x,$a,$p,$r) = objectify(1,@_);
!
! return $x if $x->modify('bfloor');
!
! return $x if $x->{sign} !~ /^[+-]$/; # nan, +inf, -inf
!
! # if $x has digits after dot
! if ($x->{_e}->{sign} eq '-')
! {
! $x->{_m}->brsft(-$x->{_e},10);
! $x->{_e}->bzero();
! $x-- if $x->{sign} eq '-';
}
! return $x->round($a,$p,$r);
! }
! sub bceil
! {
! # return integer greater or equal then $x
! my ($self,$x,$a,$p,$r) = objectify(1,@_);
!
! return $x if $x->modify('bceil');
! return $x if $x->{sign} !~ /^[+-]$/; # nan, +inf, -inf
!
! # if $x has digits after dot
! if ($x->{_e}->{sign} eq '-')
! {
! $x->{_m}->brsft(-$x->{_e},10);
! $x->{_e}->bzero();
! $x++ if $x->{sign} eq '+';
}
! return $x->round($a,$p,$r);
! }
+ ###############################################################################
+
+ sub DESTROY
+ {
+ # going trough AUTOLOAD for every DESTROY is costly, so avoid it by empty sub
+ }
+
+ sub AUTOLOAD
+ {
+ # make fxxx and bxxx work
+ # my $self = $_[0];
+ my $name = $AUTOLOAD;
+
+ $name =~ s/.*:://; # split package
+ #print "$name\n";
+ if (!method_valid($name))
+ {
+ #no strict 'refs';
+ ## try one level up
+ #&{$class."::SUPER->$name"}(@_);
+ # delayed load of Carp and avoid recursion
+ require Carp;
+ Carp::croak ("Can't call $class\-\>$name, not a valid method");
+ }
+ no strict 'refs';
+ my $bname = $name; $bname =~ s/^f/b/;
+ *{$class."\:\:$name"} = \&$bname;
+ &$bname; # uses @_
+ }
+
+ sub exponent
+ {
+ # return a copy of the exponent
+ my $self = shift;
+ $self = $class->new($self) unless ref $self;
+
+ return bnan() if $self->is_nan();
+ return $self->{_e}->copy();
+ }
+
+ sub mantissa
+ {
+ # return a copy of the mantissa
+ my $self = shift;
+ $self = $class->new($self) unless ref $self;
+
+ return bnan() if $self->is_nan();
+ my $m = $self->{_m}->copy(); # faster than going via bstr()
+ $m->bneg() if $self->{sign} eq '-';
+
+ return $m;
+ }
+
+ sub parts
+ {
+ # return a copy of both the exponent and the mantissa
+ my $self = shift;
+ $self = $class->new($self) unless ref $self;
+
+ return (bnan(),bnan()) if $self->is_nan();
+ my $m = $self->{_m}->copy(); # faster than going via bstr()
+ $m->bneg() if $self->{sign} eq '-';
+ return ($m,$self->{_e}->copy());
+ }
+
+ ##############################################################################
+ # private stuff (internal use only)
+
+ sub _one
+ {
+ # internal speedup, set argument to 1, or create a +/- 1
+ my $self = shift; $self = ref($self) if ref($self);
+ my $x = {}; bless $x, $self;
+ $x->{_m} = Math::BigInt->new(1);
+ $x->{_e} = Math::BigInt->new(0);
+ $x->{sign} = shift || '+';
+ return $x;
+ }
+
+ sub import
+ {
+ my $self = shift;
+ #print "import $self\n";
+ for ( my $i = 0; $i < @_ ; $i++ )
+ {
+ if ( $_[$i] eq ':constant' )
+ {
+ # this rest causes overlord er load to step in
+ # print "overload @_\n";
+ overload::constant float => sub { $self->new(shift); };
+ splice @_, $i, 1; last;
+ }
+ }
+ # any non :constant stuff is handled by our parent, Exporter
+ # even if @_ is empty, to give it a chance
+ #$self->SUPER::import(@_); # does not work (would call MBI)
+ $self->export_to_level(1,$self,@_); # need this instead
+ }
+
+ sub bnorm
+ {
+ # adjust m and e so that m is smallest possible
+ # round number according to accuracy and precision settings
+ my $x = shift;
+
+ return $x if $x->{sign} !~ /^[+-]$/; # inf, nan etc
+
+ my $zeros = $x->{_m}->_trailing_zeros(); # correct for trailing zeros
+ if ($zeros != 0)
+ {
+ $x->{_m}->brsft($zeros,10); $x->{_e} += $zeros;
+ }
+ # for something like 0Ey, set y to 1
+ $x->{_e}->bzero()->binc() if $x->{_m}->is_zero();
+ $x->{_m}->{_f} = MB_NEVER_ROUND;
+ $x->{_e}->{_f} = MB_NEVER_ROUND;
+ return $x; # MBI bnorm is no-op
+ }
+
+ ##############################################################################
+ # internal calculation routines
+
+ sub as_number
+ {
+ # return a bigint representation of this BigFloat number
+ my ($self,$x) = objectify(1,@_);
+
+ my $z;
+ if ($x->{_e}->is_zero())
+ {
+ $z = $x->{_m}->copy();
+ $z->{sign} = $x->{sign};
+ return $z;
+ }
+ $z = $x->{_m}->copy();
+ if ($x->{_e} < 0)
+ {
+ $z->brsft(-$x->{_e},10);
+ }
+ else
+ {
+ $z->blsft($x->{_e},10);
+ }
+ $z->{sign} = $x->{sign};
+ return $z;
+ }
+
+ sub length
+ {
+ my $x = shift; $x = $class->new($x) unless ref $x;
+
+ my $len = $x->{_m}->length();
+ $len += $x->{_e} if $x->{_e}->sign() eq '+';
+ if (wantarray())
+ {
+ my $t = Math::BigInt::bzero();
+ $t = $x->{_e}->copy()->babs() if $x->{_e}->sign() eq '-';
+ return ($len,$t);
+ }
+ return $len;
+ }
+
1;
__END__
=head1 NAME
! Math::BigFloat - Arbitrary size floating point math package
=head1 SYNOPSIS
use Math::BigFloat;
! # Number creation
! $x = Math::BigInt->new($str); # defaults to 0
! $nan = Math::BigInt->bnan(); # create a NotANumber
! $zero = Math::BigInt->bzero();# create a "+0"
+ # Testing
+ $x->is_zero(); # return whether arg is zero or not
+ $x->is_nan(); # return whether arg is NaN or not
+ $x->is_one(); # true if arg is +1
+ $x->is_one('-'); # true if arg is -1
+ $x->is_odd(); # true if odd, false for even
+ $x->is_even(); # true if even, false for odd
+ $x->is_positive(); # true if >= 0
+ $x->is_negative(); # true if < 0
+ $x->is_inf(sign) # true if +inf or -inf (sign default '+')
+ $x->bcmp($y); # compare numbers (undef,<0,=0,>0)
+ $x->bacmp($y); # compare absolutely (undef,<0,=0,>0)
+ $x->sign(); # return the sign, either +,- or NaN
+
+ # The following all modify their first argument:
+
+ # set
+ $x->bzero(); # set $i to 0
+ $x->bnan(); # set $i to NaN
+
+ $x->bneg(); # negation
+ $x->babs(); # absolute value
+ $x->bnorm(); # normalize (no-op)
+ $x->bnot(); # two's complement (bit wise not)
+ $x->binc(); # increment x by 1
+ $x->bdec(); # decrement x by 1
+
+ $x->badd($y); # addition (add $y to $x)
+ $x->bsub($y); # subtraction (subtract $y from $x)
+ $x->bmul($y); # multiplication (multiply $x by $y)
+ $x->bdiv($y); # divide, set $i to quotient
+ # return (quo,rem) or quo if scalar
+
+ $x->bmod($y); # modulus
+ $x->bpow($y); # power of arguments (a**b)
+ $x->blsft($y); # left shift
+ $x->brsft($y); # right shift
+ # return (quo,rem) or quo if scalar
+
+ $x->band($y); # bit-wise and
+ $x->bior($y); # bit-wise inclusive or
+ $x->bxor($y); # bit-wise exclusive or
+ $x->bnot(); # bit-wise not (two's complement)
+
+ $x->bround($N); # accuracy: preserver $N digits
+ $x->bfround($N); # precision: round to the $Nth digit
+
+ # The following do not modify their arguments:
+
+ bgcd(@values); # greatest common divisor
+ blcm(@values); # lowest common multiplicator
+
+ $x->bstr(); # return string
+ $x->bsstr(); # return string in scientific notation
+
+ $x->exponent(); # return exponent as BigInt
+ $x->mantissa(); # return mantissa as BigInt
+ $x->parts(); # return (mantissa,exponent) as BigInt
+
+ $x->length(); # number of digits (w/o sign and '.')
+ ($l,$f) = $x->length(); # number of digits, and length of fraction
+
=head1 DESCRIPTION
! All operators (inlcuding basic math operations) are overloaded if you
! declare your big floating point numbers as
! $i = new Math::BigFloat '12_3.456_789_123_456_789E-2';
+ Operations with overloaded operators preserve the arguments, which is
+ exactly what you expect.
+
+ =head2 Canonical notation
+
+ Input to these routines are either BigFloat objects, or strings of the
+ following four forms:
+
=over 2
! =item *
! C</^[+-]\d+$/>
! =item *
! C</^[+-]\d+\.\d*$/>
! =item *
! C</^[+-]\d+E[+-]?\d+$/>
! =item *
! C</^[+-]\d*\.\d+E[+-]?\d+$/>
! =back
! all with optional leading and trailing zeros and/or spaces. Additonally,
! numbers are allowed to have an underscore between any two digits.
+ Empty strings as well as other illegal numbers results in 'NaN'.
+
+ bnorm() on a BigFloat object is now effectively a no-op, since the numbers
+ are always stored in normalized form. On a string, it creates a BigFloat
+ object.
+
+ =head2 Output
+
+ Output values are BigFloat objects (normalized), except for bstr() and bsstr().
+
+ The string output will always have leading and trailing zeros stripped and drop
+ a plus sign. C<bstr()> will give you always the form with a decimal point,
+ while C<bsstr()> (for scientific) gives you the scientific notation.
+
+ Input bstr() bsstr()
+ '-0' '0' '0E1'
+ ' -123 123 123' '-123123123' '-123123123E0'
+ '00.0123' '0.0123' '123E-4'
+ '123.45E-2' '1.2345' '12345E-4'
+ '10E+3' '10000' '1E4'
+
+ Some routines (C<is_odd()>, C<is_even()>, C<is_zero()>, C<is_one()>,
+ C<is_nan()>) return true or false, while others (C<bcmp()>, C<bacmp()>)
+ return either undef, <0, 0 or >0 and are suited for sort.
+
+ Actual math is done by using BigInts to represent the mantissa and exponent.
+ The sign C</^[+-]$/> is stored separately. The string 'NaN' is used to
+ represent the result when input arguments are not numbers, as well as
+ the result of dividing by zero.
+
+ =head2 C<mantissa()>, C<exponent()> and C<parts()>
+
+ C<mantissa()> and C<exponent()> return the said parts of the BigFloat
+ as BigInts such that:
+
+ $m = $x->mantissa();
+ $e = $x->exponent();
+ $y = $m * ( 10 ** $e );
+ print "ok\n" if $x == $y;
+
+ C<< ($m,$e) = $x->parts(); >> is just a shortcut giving you both of them.
+
+ A zero is represented and returned as C<0E1>, B<not> C<0E0> (after Knuth).
+
+ Currently the mantissa is reduced as much as possible, favouring higher
+ exponents over lower ones (e.g. returning 1e7 instead of 10e6 or 10000000e0).
+ This might change in the future, so do not depend on it.
+
+ =head2 Accuracy vs. Precision
+
+ See also: L<Rounding|Rounding>.
+
+ Math::BigFloat supports both precision and accuracy. (here should follow
+ a short description of both).
+
+ Precision: digits after the '.', laber, schwad
+ Accuracy: Significant digits blah blah
+
+ Since things like sqrt(2) or 1/3 must presented with a limited precision lest
+ a operation consumes all resources, each operation produces no more than
+ C<Math::BigFloat::precision()> digits.
+
+ In case the result of one operation has more precision than specified,
+ it is rounded. The rounding mode taken is either the default mode, or the one
+ supplied to the operation after the I<scale>:
+
+ $x = Math::BigFloat->new(2);
+ Math::BigFloat::precision(5); # 5 digits max
+ $y = $x->copy()->bdiv(3); # will give 0.66666
+ $y = $x->copy()->bdiv(3,6); # will give 0.666666
+ $y = $x->copy()->bdiv(3,6,'odd'); # will give 0.666667
+ Math::BigFloat::round_mode('zero');
+ $y = $x->copy()->bdiv(3,6); # will give 0.666666
+
+ =head2 Rounding
+
+ =over 2
+
+ =item ffround ( +$scale )
+
+ Rounds to the $scale'th place left from the '.', counting from the dot.
+ The first digit is numbered 1.
+
+ =item ffround ( -$scale )
+
+ Rounds to the $scale'th place right from the '.', counting from the dot.
+
+ =item ffround ( 0 )
+
+ Rounds to an integer.
+
+ =item fround ( +$scale )
+
+ Preserves accuracy to $scale digits from the left (aka significant digits)
+ and pads the rest with zeros. If the number is between 1 and -1, the
+ significant digits count from the first non-zero after the '.'
+
+ =item fround ( -$scale ) and fround ( 0 )
+
+ These are effetively no-ops.
+
=back
+ All rounding functions take as a second parameter a rounding mode from one of
+ the following: 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'.
+
+ The default rounding mode is 'even'. By using
+ C<< Math::BigFloat::round_mode($rnd_mode); >> you can get and set the default
+ mode for subsequent rounding. The usage of C<$Math::BigFloat::$rnd_mode> is
+ no longer supported.
+ The second parameter to the round functions then overrides the default
+ temporarily.
+
+ The C<< as_number() >> function returns a BigInt from a Math::BigFloat. It uses
+ 'trunc' as rounding mode to make it equivalent to:
+
+ $x = 2.5;
+ $y = int($x) + 2;
+
+ You can override this by passing the desired rounding mode as parameter to
+ C<as_number()>:
+
+ $x = Math::BigFloat->new(2.5);
+ $y = $x->as_number('odd'); # $y = 3
+
+ =head1 EXAMPLES
+
+ use Math::BigFloat qw(bstr bint);
+ # not ready yet
+ $x = bstr("1234") # string "1234"
+ $x = "$x"; # same as bstr()
+ $x = bneg("1234") # BigFloat "-1234"
+ $x = Math::BigFloat->bneg("1234"); # BigFloat "1234"
+ $x = Math::BigFloat->babs("-12345"); # BigFloat "12345"
+ $x = Math::BigFloat->bnorm("-0 00"); # BigFloat "0"
+ $x = bint(1) + bint(2); # BigFloat "3"
+ $x = bint(1) + "2"; # ditto (auto-BigFloatify of "2")
+ $x = bint(1); # BigFloat "1"
+ $x = $x + 5 / 2; # BigFloat "3"
+ $x = $x ** 3; # BigFloat "27"
+ $x *= 2; # BigFloat "54"
+ $x = new Math::BigFloat; # BigFloat "0"
+ $x--; # BigFloat "-1"
+
+ =head1 Autocreating constants
+
+ After C<use Math::BigFloat ':constant'> all the floating point constants
+ in the given scope are converted to C<Math::BigFloat>. This conversion
+ happens at compile time.
+
+ In particular
+
+ perl -MMath::BigFloat=:constant -e 'print 2E-100,"\n"'
+
+ prints the value of C<2E-100>. Note that without conversion of
+ constants the expression 2E-100 will be calculated as normal floating point
+ number.
+
+ =head1 PERFORMANCE
+
+ Greatly enhanced ;o)
+ SectionNotReadyYet.
+
=head1 BUGS
! =over 2
! =item *
! The following does not work yet:
! $m = $x->mantissa();
! $e = $x->exponent();
! $y = $m * ( 10 ** $e );
! print "ok\n" if $x == $y;
! =item *
!
! There is no fmod() function yet.
!
! =back
!
! =head1 CAVEAT
!
! =over 1
!
! =item stringify, bstr()
!
! Both stringify and bstr() now drop the leading '+'. The old code would return
! '+1.23', the new returns '1.23'. See the documentation in L<Math::BigInt> for
! reasoning and details.
!
! =item bdiv
!
! The following will probably not do what you expect:
!
! print $c->bdiv(123.456),"\n";
!
! It prints both quotient and reminder since print works in list context. Also,
! bdiv() will modify $c, so be carefull. You probably want to use
!
! print $c / 123.456,"\n";
! print scalar $c->bdiv(123.456),"\n"; # or if you want to modify $c
!
! instead.
!
! =item Modifying and =
!
! Beware of:
!
! $x = Math::BigFloat->new(5);
! $y = $x;
!
! It will not do what you think, e.g. making a copy of $x. Instead it just makes
! a second reference to the B<same> object and stores it in $y. Thus anything
! that modifies $x will modify $y, and vice versa.
!
! $x->bmul(2);
! print "$x, $y\n"; # prints '10, 10'
!
! If you want a true copy of $x, use:
!
! $y = $x->copy();
!
! See also the documentation in L<overload> regarding C<=>.
!
! =item bpow
!
! C<bpow()> now modifies the first argument, unlike the old code which left
! it alone and only returned the result. This is to be consistent with
! C<badd()> etc. The first will modify $x, the second one won't:
!
! print bpow($x,$i),"\n"; # modify $x
! print $x->bpow($i),"\n"; # ditto
! print $x ** $i,"\n"; # leave $x alone
!
! =back
!
! =head1 LICENSE
!
! This program is free software; you may redistribute it and/or modify it under
! the same terms as Perl itself.
!
! =head1 AUTHORS
!
! Mark Biggar, overloaded interface by Ilya Zakharevich.
! Completely rewritten by Tels http://bloodgate.com in 2001.
!
=cut
diff -c 'perl-5.7.1/lib/Math/BigInt.pm' 'perl-5.7.2/lib/Math/BigInt.pm'
Index: ./lib/Math/BigInt.pm
*** ./lib/Math/BigInt.pm Tue Mar 6 04:05:32 2001
--- ./lib/Math/BigInt.pm Tue Jul 10 17:50:56 2001
***************
*** 1,432 ****
package Math::BigInt;
! $VERSION='0.01';
use overload
! '+' => sub {new Math::BigInt &badd},
! '-' => sub {new Math::BigInt
! $_[2]? bsub($_[1],${$_[0]}) : bsub(${$_[0]},$_[1])},
! '<=>' => sub {$_[2]? bcmp($_[1],${$_[0]}) : bcmp(${$_[0]},$_[1])},
! 'cmp' => sub {$_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])},
! '*' => sub {new Math::BigInt &bmul},
! '/' => sub {new Math::BigInt
! $_[2]? scalar bdiv($_[1],${$_[0]}) :
! scalar bdiv(${$_[0]},$_[1])},
! '%' => sub {new Math::BigInt
! $_[2]? bmod($_[1],${$_[0]}) : bmod(${$_[0]},$_[1])},
! '**' => sub {new Math::BigInt
! $_[2]? bpow($_[1],${$_[0]}) : bpow(${$_[0]},$_[1])},
! 'neg' => sub {new Math::BigInt &bneg},
! 'abs' => sub {new Math::BigInt &babs},
! '<<' => sub {new Math::BigInt
! $_[2]? blsft($_[1],${$_[0]}) : blsft(${$_[0]},$_[1])},
! '>>' => sub {new Math::BigInt
! $_[2]? brsft($_[1],${$_[0]}) : brsft(${$_[0]},$_[1])},
! '&' => sub {new Math::BigInt &band},
! '|' => sub {new Math::BigInt &bior},
! '^' => sub {new Math::BigInt &bxor},
! '~' => sub {new Math::BigInt &bnot},
! 'int' => sub { shift },
qw(
! "" stringify
! 0+ numify) # Order of arguments unsignificant
;
! $NaNOK=1;
! sub new {
! my($class) = shift;
! my($foo) = bnorm(shift);
! die "Not a number initialized to Math::BigInt" if !$NaNOK && $foo eq "NaN";
! bless \$foo, $class;
! }
! sub stringify { "${$_[0]}" }
! sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead
! # comparing to direct compilation based on
! # stringify
! sub import {
! shift;
! return unless @_;
! die "unknown import: @_" unless @_ == 1 and $_[0] eq ':constant';
! overload::constant integer => sub {Math::BigInt->new(shift)};
! }
! $zero = 0;
! # overcome a floating point problem on certain osnames (posix-bc, os390)
! BEGIN {
! my $x = 100000.0;
! my $use_mult = int($x*1e-5)*1e5 == $x ? 1 : 0;
! }
! # normalize string form of number. Strip leading zeros. Strip any
! # white space and add a sign, if missing.
! # Strings that are not numbers result the value 'NaN'.
! sub bnorm { #(num_str) return num_str
! local($_) = @_;
! s/\s+//g; # strip white space
! if (s/^([+-]?)0*(\d+)$/$1$2/) { # test if number
! substr($_,$[,0) = '+' unless $1; # Add missing sign
! s/^-0/+0/;
! $_;
! } else {
! 'NaN';
}
! }
! # Convert a number from string format to internal base 100000 format.
! # Assumes normalized value as input.
! sub internal { #(num_str) return int_num_array
! local($d) = @_;
! ($is,$il) = (substr($d,$[,1),length($d)-2);
! substr($d,$[,1) = '';
! ($is, reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $d)));
! }
! # Convert a number from internal base 100000 format to string format.
! # This routine scribbles all over input array.
! sub external { #(int_num_array) return num_str
! $es = shift;
! grep($_ > 9999 || ($_ = substr('0000'.$_,-5)), @_); # zero pad
! &bnorm(join('', $es, reverse(@_))); # reverse concat and normalize
! }
! # Negate input value.
! sub bneg { #(num_str) return num_str
! local($_) = &bnorm(@_);
! return $_ if $_ eq '+0' or $_ eq 'NaN';
! vec($_,0,8) ^= ord('+') ^ ord('-');
! $_;
! }
! # Returns the absolute value of the input.
! sub babs { #(num_str) return num_str
! &abs(&bnorm(@_));
! }
! sub abs { # post-normalized abs for internal use
! local($_) = @_;
! s/^-/+/;
! $_;
! }
! # Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort)
! sub bcmp { #(num_str, num_str) return cond_code
! local($x,$y) = (&bnorm($_[$[]),&bnorm($_[$[+1]));
! if ($x eq 'NaN') {
! undef;
! } elsif ($y eq 'NaN') {
! undef;
! } else {
! &cmp($x,$y) <=> 0;
}
! }
! sub cmp { # post-normalized compare for internal use
! local($cx, $cy) = @_;
!
! return 0 if ($cx eq $cy);
! local($sx, $sy) = (substr($cx, 0, 1), substr($cy, 0, 1));
! local($ld);
! if ($sx eq '+') {
! return 1 if ($sy eq '-' || $cy eq '+0');
! $ld = length($cx) - length($cy);
! return $ld if ($ld);
! return $cx cmp $cy;
! } else { # $sx eq '-'
! return -1 if ($sy eq '+');
! $ld = length($cy) - length($cx);
! return $ld if ($ld);
! return $cy cmp $cx;
}
! }
! sub badd { #(num_str, num_str) return num_str
! local(*x, *y); ($x, $y) = (&bnorm($_[$[]),&bnorm($_[$[+1]));
! if ($x eq 'NaN') {
! 'NaN';
! } elsif ($y eq 'NaN') {
! 'NaN';
! } else {
! @x = &internal($x); # convert to internal form
! @y = &internal($y);
! local($sx, $sy) = (shift @x, shift @y); # get signs
! if ($sx eq $sy) {
! &external($sx, &add(*x, *y)); # if same sign add
! } else {
! ($x, $y) = (&abs($x),&abs($y)); # make abs
! if (&cmp($y,$x) > 0) {
! &external($sy, &sub(*y, *x));
! } else {
! &external($sx, &sub(*x, *y));
! }
! }
}
! }
! sub bsub { #(num_str, num_str) return num_str
! &badd($_[$[],&bneg($_[$[+1]));
! }
! # GCD -- Euclids algorithm Knuth Vol 2 pg 296
! sub bgcd { #(num_str, num_str) return num_str
! local($x,$y) = (&bnorm($_[$[]),&bnorm($_[$[+1]));
! if ($x eq 'NaN' || $y eq 'NaN') {
! 'NaN';
! } else {
! ($x, $y) = ($y,&bmod($x,$y)) while $y ne '+0';
! $x;
! }
! }
! # routine to add two base 1e5 numbers
! # stolen from Knuth Vol 2 Algorithm A pg 231
! # there are separate routines to add and sub as per Kunth pg 233
! sub add { #(int_num_array, int_num_array) return int_num_array
! local(*x, *y) = @_;
! $car = 0;
! for $x (@x) {
! last unless @y || $car;
! $x -= 1e5 if $car = (($x += (@y ? shift(@y) : 0) + $car) >= 1e5) ? 1 : 0;
}
! for $y (@y) {
! last unless $car;
! $y -= 1e5 if $car = (($y += $car) >= 1e5) ? 1 : 0;
}
! (@x, @y, $car);
! }
! # subtract base 1e5 numbers -- stolen from Knuth Vol 2 pg 232, $x > $y
! sub sub { #(int_num_array, int_num_array) return int_num_array
! local(*sx, *sy) = @_;
! $bar = 0;
! for $sx (@sx) {
! last unless @sy || $bar;
! $sx += 1e5 if $bar = (($sx -= (@sy ? shift(@sy) : 0) + $bar) < 0);
}
! @sx;
! }
! # multiply two numbers -- stolen from Knuth Vol 2 pg 233
! sub bmul { #(num_str, num_str) return num_str
! local(*x, *y); ($x, $y) = (&bnorm($_[$[]), &bnorm($_[$[+1]));
! if ($x eq 'NaN') {
! 'NaN';
! } elsif ($y eq 'NaN') {
! 'NaN';
! } else {
! @x = &internal($x);
! @y = &internal($y);
! &external(&mul(*x,*y));
}
! }
! # multiply two numbers in internal representation
! # destroys the arguments, supposes that two arguments are different
! sub mul { #(*int_num_array, *int_num_array) return int_num_array
! local(*x, *y) = (shift, shift);
! local($signr) = (shift @x ne shift @y) ? '-' : '+';
! @prod = ();
! for $x (@x) {
! ($car, $cty) = (0, $[);
! for $y (@y) {
! $prod = $x * $y + ($prod[$cty] || 0) + $car;
! if ($use_mult) {
! $prod[$cty++] =
! $prod - ($car = int($prod * 1e-5)) * 1e5;
}
! else {
! $prod[$cty++] =
! $prod - ($car = int($prod / 1e5)) * 1e5;
}
}
! $prod[$cty] += $car if $car;
! $x = shift @prod;
}
! ($signr, @x, @prod);
! }
! # modulus
! sub bmod { #(num_str, num_str) return num_str
! (&bdiv(@_))[$[+1];
! }
! sub bdiv { #(dividend: num_str, divisor: num_str) return num_str
! local (*x, *y); ($x, $y) = (&bnorm($_[$[]), &bnorm($_[$[+1]));
! return wantarray ? ('NaN','NaN') : 'NaN'
! if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0');
! return wantarray ? ('+0',$x) : '+0' if (&cmp(&abs($x),&abs($y)) < 0);
! @x = &internal($x); @y = &internal($y);
! $srem = $y[$[];
! $sr = (shift @x ne shift @y) ? '-' : '+';
! $car = $bar = $prd = 0;
! if (($dd = int(1e5/($y[$#y]+1))) != 1) {
! for $x (@x) {
! $x = $x * $dd + $car;
! if ($use_mult) {
! $x -= ($car = int($x * 1e-5)) * 1e5;
! }
! else {
! $x -= ($car = int($x / 1e5)) * 1e5;
! }
! }
! push(@x, $car); $car = 0;
! for $y (@y) {
! $y = $y * $dd + $car;
! if ($use_mult) {
! $y -= ($car = int($y * 1e-5)) * 1e5;
! }
! else {
! $y -= ($car = int($y / 1e5)) * 1e5;
! }
! }
}
! else {
! push(@x, 0);
}
! @q = (); ($v2,$v1) = @y[-2,-1];
! $v2 = 0 unless $v2;
! while ($#x > $#y) {
! ($u2,$u1,$u0) = @x[-3..-1];
! $u2 = 0 unless $u2;
! $q = (($u0 == $v1) ? 99999 : int(($u0*1e5+$u1)/$v1));
! --$q while ($v2*$q > ($u0*1e5+$u1-$q*$v1)*1e5+$u2);
! if ($q) {
! ($car, $bar) = (0,0);
! for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) {
! $prd = $q * $y[$y] + $car;
! if ($use_mult) {
! $prd -= ($car = int($prd * 1e-5)) * 1e5;
! }
! else {
! $prd -= ($car = int($prd / 1e5)) * 1e5;
! }
! $x[$x] += 1e5 if ($bar = (($x[$x] -= $prd + $bar) < 0));
! }
! if ($x[$#x] < $car + $bar) {
! $car = 0; --$q;
! for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) {
! $x[$x] -= 1e5
! if ($car = (($x[$x] += $y[$y] + $car) > 1e5));
! }
! }
}
! pop(@x); unshift(@q, $q);
}
! if (wantarray) {
! @d = ();
! if ($dd != 1) {
! $car = 0;
! for $x (reverse @x) {
! $prd = $car * 1e5 + $x;
! $car = $prd - ($tmp = int($prd / $dd)) * $dd;
! unshift(@d, $tmp);
! }
}
! else {
! @d = @x;
! }
! (&external($sr, @q), &external($srem, @d, $zero));
! } else {
! &external($sr, @q);
}
! }
! # compute power of two numbers -- stolen from Knuth Vol 2 pg 233
! sub bpow { #(num_str, num_str) return num_str
! local(*x, *y); ($x, $y) = (&bnorm($_[$[]), &bnorm($_[$[+1]));
! if ($x eq 'NaN') {
! 'NaN';
! } elsif ($y eq 'NaN') {
! 'NaN';
! } elsif ($x eq '+1') {
! '+1';
! } elsif ($x eq '-1') {
! &bmod($x,2) ? '-1': '+1';
! } elsif ($y =~ /^-/) {
! 'NaN';
! } elsif ($x eq '+0' && $y eq '+0') {
! 'NaN';
! } else {
! @x = &internal($x);
! local(@pow2)=@x;
! local(@pow)=&internal("+1");
! local($y1,$res,@tmp1,@tmp2)=(1); # need tmp to send to mul
! while ($y ne '+0') {
! ($y,$res)=&bdiv($y,2);
! if ($res ne '+0') {@tmp=@pow2; @pow=&mul(*pow,*tmp);}
! if ($y ne '+0') {@tmp=@pow2;@pow2=&mul(*pow2,*tmp);}
! }
! &external(@pow);
}
! }
! # compute x << y, y >= 0
! sub blsft { #(num_str, num_str) return num_str
! &bmul($_[$[], &bpow(2, $_[$[+1]));
! }
! # compute x >> y, y >= 0
! sub brsft { #(num_str, num_str) return num_str
! &bdiv($_[$[], &bpow(2, $_[$[+1]));
! }
! # compute x & y
! sub band { #(num_str, num_str) return num_str
! local($x,$y,$r,$m,$xr,$yr) = (&bnorm($_[$[]),&bnorm($_[$[+1]),0,1);
! if ($x eq 'NaN' || $y eq 'NaN') {
! 'NaN';
! } else {
! while ($x ne '+0' && $y ne '+0') {
! ($x, $xr) = &bdiv($x, 0x10000);
! ($y, $yr) = &bdiv($y, 0x10000);
! $r = &badd(&bmul(int $xr & $yr, $m), $r);
! $m = &bmul($m, 0x10000);
! }
! $r;
}
! }
! # compute x | y
! sub bior { #(num_str, num_str) return num_str
! local($x,$y,$r,$m,$xr,$yr) = (&bnorm($_[$[]),&bnorm($_[$[+1]),0,1);
! if ($x eq 'NaN' || $y eq 'NaN') {
! 'NaN';
! } else {
! while ($x ne '+0' || $y ne '+0') {
! ($x, $xr) = &bdiv($x, 0x10000);
! ($y, $yr) = &bdiv($y, 0x10000);
! $r = &badd(&bmul(int $xr | $yr, $m), $r);
! $m = &bmul($m, 0x10000);
! }
! $r;
}
! }
! # compute x ^ y
! sub bxor { #(num_str, num_str) return num_str
! local($x,$y,$r,$m,$xr,$yr) = (&bnorm($_[$[]),&bnorm($_[$[+1]),0,1);
! if ($x eq 'NaN' || $y eq 'NaN') {
! 'NaN';
! } else {
! while ($x ne '+0' || $y ne '+0') {
! ($x, $xr) = &bdiv($x, 0x10000);
! ($y, $yr) = &bdiv($y, 0x10000);
! $r = &badd(&bmul(int $xr ^ $yr, $m), $r);
! $m = &bmul($m, 0x10000);
! }
! $r;
}
! }
! # represent ~x as twos-complement number
! sub bnot { #(num_str) return num_str
! &bsub(-1,$_[$[]);
! }
1;
__END__
--- 1,1837 ----
+ #!/usr/bin/perl -w
+
+ # Qs: what exactly happens on numify of HUGE numbers? overflow?
+ # $a = -$a is much slower (making copy of $a) than $a->bneg(), hm!?
+ # (copy_on_write will help there, but that is not yet implemented)
+
+ # The following hash values are used:
+ # value: unsigned int with actual value (as a Math::BigInt::Calc or similiar)
+ # sign : +,-,NaN,+inf,-inf
+ # _a : accuracy
+ # _p : precision
+ # _f : flags, used by MBF to flag parts of a float as untouchable
+ # _cow : copy on write: number of objects that share the data (NRY)
+
package Math::BigInt;
! my $class = "Math::BigInt";
! require 5.005;
+ $VERSION = 1.36;
+ use Exporter;
+ @ISA = qw( Exporter );
+ @EXPORT_OK = qw( bneg babs bcmp badd bmul bdiv bmod bnorm bsub
+ bgcd blcm
+ bround
+ blsft brsft band bior bxor bnot bpow bnan bzero
+ bacmp bstr bsstr binc bdec bint binf bfloor bceil
+ is_odd is_even is_zero is_one is_nan is_inf sign
+ is_positive is_negative
+ length as_number
+ objectify _swap
+ );
+
+ #@EXPORT = qw( );
+ use vars qw/$rnd_mode $accuracy $precision $div_scale/;
+ use strict;
+
+ # Inside overload, the first arg is always an object. If the original code had
+ # it reversed (like $x = 2 * $y), then the third paramater indicates this
+ # swapping. To make it work, we use a helper routine which not only reswaps the
+ # params, but also makes a new object in this case. See _swap() for details,
+ # especially the cases of operators with different classes.
+
+ # For overloaded ops with only one argument we simple use $_[0]->copy() to
+ # preserve the argument.
+
+ # Thus inheritance of overload operators becomes possible and transparent for
+ # our subclasses without the need to repeat the entire overload section there.
+
use overload
! '=' => sub { $_[0]->copy(); },
+ # '+' and '-' do not use _swap, since it is a triffle slower. If you want to
+ # override _swap (if ever), then override overload of '+' and '-', too!
+ # for sub it is a bit tricky to keep b: b-a => -a+b
+ '-' => sub { my $c = $_[0]->copy; $_[2] ?
+ $c->bneg()->badd($_[1]) :
+ $c->bsub( $_[1]) },
+ '+' => sub { $_[0]->copy()->badd($_[1]); },
+
+ # some shortcuts for speed (assumes that reversed order of arguments is routed
+ # to normal '+' and we thus can always modify first arg. If this is changed,
+ # this breaks and must be adjusted.)
+ '+=' => sub { $_[0]->badd($_[1]); },
+ '-=' => sub { $_[0]->bsub($_[1]); },
+ '*=' => sub { $_[0]->bmul($_[1]); },
+ '/=' => sub { scalar $_[0]->bdiv($_[1]); },
+ '**=' => sub { $_[0]->bpow($_[1]); },
+
+ '<=>' => sub { $_[2] ?
+ $class->bcmp($_[1],$_[0]) :
+ $class->bcmp($_[0],$_[1])},
+ 'cmp' => sub {
+ $_[2] ?
+ $_[1] cmp $_[0]->bstr() :
+ $_[0]->bstr() cmp $_[1] },
+
+ 'int' => sub { $_[0]->copy(); },
+ 'neg' => sub { $_[0]->copy()->bneg(); },
+ 'abs' => sub { $_[0]->copy()->babs(); },
+ '~' => sub { $_[0]->copy()->bnot(); },
+
+ '*' => sub { my @a = ref($_[0])->_swap(@_); $a[0]->bmul($a[1]); },
+ '/' => sub { my @a = ref($_[0])->_swap(@_);scalar $a[0]->bdiv($a[1]);},
+ '%' => sub { my @a = ref($_[0])->_swap(@_); $a[0]->bmod($a[1]); },
+ '**' => sub { my @a = ref($_[0])->_swap(@_); $a[0]->bpow($a[1]); },
+ '<<' => sub { my @a = ref($_[0])->_swap(@_); $a[0]->blsft($a[1]); },
+ '>>' => sub { my @a = ref($_[0])->_swap(@_); $a[0]->brsft($a[1]); },
+
+ '&' => sub { my @a = ref($_[0])->_swap(@_); $a[0]->band($a[1]); },
+ '|' => sub { my @a = ref($_[0])->_swap(@_); $a[0]->bior($a[1]); },
+ '^' => sub { my @a = ref($_[0])->_swap(@_); $a[0]->bxor($a[1]); },
+
+ # can modify arg of ++ and --, so avoid a new-copy for speed, but don't
+ # use $_[0]->_one(), it modifies $_[0] to be 1!
+ '++' => sub { $_[0]->binc() },
+ '--' => sub { $_[0]->bdec() },
+
+ # if overloaded, O(1) instead of O(N) and twice as fast for small numbers
+ 'bool' => sub {
+ # this kludge is needed for perl prior 5.6.0 since returning 0 here fails :-/
+ # v5.6.1 dumps on that: return !$_[0]->is_zero() || undef; :-(
+ my $t = !$_[0]->is_zero();
+ undef $t if $t == 0;
+ return $t;
+ },
+
qw(
! "" bstr
! 0+ numify), # Order of arguments unsignificant
;
! ##############################################################################
! # global constants, flags and accessory
! use constant MB_NEVER_ROUND => 0x0001;
! my $NaNOK=1; # are NaNs ok?
! my $nan = 'NaN'; # constants for easier life
! my $CALC = 'Math::BigInt::Calc'; # module to do low level math
! sub _core_lib () { return $CALC; } # for test suite
! # Rounding modes, one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'
! $rnd_mode = 'even';
! $accuracy = undef;
! $precision = undef;
! $div_scale = 40;
! sub round_mode
! {
! # make Class->round_mode() work
! my $self = shift || $class;
! # shift @_ if defined $_[0] && $_[0] eq $class;
! if (defined $_[0])
! {
! my $m = shift;
! die "Unknown round mode $m"
! if $m !~ /^(even|odd|\+inf|\-inf|zero|trunc)$/;
! $rnd_mode = $m; return;
}
! return $rnd_mode;
! }
! sub accuracy
! {
! # $x->accuracy($a); ref($x) a
! # $x->accuracy(); ref($x);
! # Class::accuracy(); # not supported
! #print "MBI @_ ($class)\n";
! my $x = shift;
! die ("accuracy() needs reference to object as first parameter.")
! if !ref $x;
! if (@_ > 0)
! {
! $x->{_a} = shift;
! $x->round() if defined $x->{_a};
! }
! return $x->{_a};
! }
! sub precision
! {
! my $x = shift;
! die ("precision() needs reference to object as first parameter.")
! unless ref $x;
! if (@_ > 0)
! {
! $x->{_p} = shift;
! $x->round() if defined $x->{_p};
}
! return $x->{_p};
! }
! sub _scale_a
! {
! # select accuracy parameter based on precedence,
! # used by bround() and bfround(), may return undef for scale (means no op)
! my ($x,$s,$m,$scale,$mode) = @_;
! $scale = $x->{_a} if !defined $scale;
! $scale = $s if (!defined $scale);
! $mode = $m if !defined $mode;
! return ($scale,$mode);
! }
! sub _scale_p
! {
! # select precision parameter based on precedence,
! # used by bround() and bfround(), may return undef for scale (means no op)
! my ($x,$s,$m,$scale,$mode) = @_;
! $scale = $x->{_p} if !defined $scale;
! $scale = $s if (!defined $scale);
! $mode = $m if !defined $mode;
! return ($scale,$mode);
! }
! ##############################################################################
! # constructors
!
! sub copy
! {
! my ($c,$x);
! if (@_ > 1)
! {
! # if two arguments, the first one is the class to "swallow" subclasses
! ($c,$x) = @_;
}
! else
! {
! $x = shift;
! $c = ref($x);
! }
! return unless ref($x); # only for objects
! my $self = {}; bless $self,$c;
! foreach my $k (keys %$x)
! {
! if ($k eq 'value')
! {
! $self->{$k} = $CALC->_copy($x->{$k});
! }
! elsif (ref($x->{$k}) eq 'SCALAR')
! {
! $self->{$k} = \${$x->{$k}};
! }
! elsif (ref($x->{$k}) eq 'ARRAY')
! {
! $self->{$k} = [ @{$x->{$k}} ];
! }
! elsif (ref($x->{$k}) eq 'HASH')
! {
! # only one level deep!
! foreach my $h (keys %{$x->{$k}})
! {
! $self->{$k}->{$h} = $x->{$k}->{$h};
! }
! }
! elsif (ref($x->{$k}))
! {
! my $c = ref($x->{$k});
! $self->{$k} = $c->new($x->{$k}); # no copy() due to deep rec
! }
! else
! {
! $self->{$k} = $x->{$k};
! }
}
! $self;
! }
! sub new
! {
! # create a new BigInt object from a string or another BigInt object.
! # see hash keys documented at top
! # the argument could be an object, so avoid ||, && etc on it, this would
! # cause costly overloaded code to be called. The only allowed ops are
! # ref() and defined.
! my $class = shift;
!
! my $wanted = shift; # avoid numify call by not using || here
! return $class->bzero() if !defined $wanted; # default to 0
! return $class->copy($wanted) if ref($wanted);
!
! my $self = {}; bless $self, $class;
! # handle '+inf', '-inf' first
! if ($wanted =~ /^[+-]inf$/)
! {
! $self->{value} = $CALC->_zero();
! $self->{sign} = $wanted;
! return $self;
}
! # split str in m mantissa, e exponent, i integer, f fraction, v value, s sign
! my ($mis,$miv,$mfv,$es,$ev) = _split(\$wanted);
! if (ref $mis && !ref $miv)
! {
! # _from_hex or _from_bin
! $self->{value} = $mis->{value};
! $self->{sign} = $mis->{sign};
! return $self; # throw away $mis
}
! if (!ref $mis)
! {
! die "$wanted is not a number initialized to $class" if !$NaNOK;
! #print "NaN 1\n";
! $self->{value} = $CALC->_zero();
! $self->{sign} = $nan;
! return $self;
! }
! # make integer from mantissa by adjusting exp, then convert to bigint
! $self->{sign} = $$mis; # store sign
! $self->{value} = $CALC->_zero(); # for all the NaN cases
! my $e = int("$$es$$ev"); # exponent (avoid recursion)
! if ($e > 0)
! {
! my $diff = $e - CORE::length($$mfv);
! if ($diff < 0) # Not integer
! {
! #print "NOI 1\n";
! $self->{sign} = $nan;
! }
! else # diff >= 0
! {
! # adjust fraction and add it to value
! # print "diff > 0 $$miv\n";
! $$miv = $$miv . ($$mfv . '0' x $diff);
! }
! }
! else
! {
! if ($$mfv ne '') # e <= 0
! {
! # fraction and negative/zero E => NOI
! #print "NOI 2 \$\$mfv '$$mfv'\n";
! $self->{sign} = $nan;
! }
! elsif ($e < 0)
! {
! # xE-y, and empty mfv
! #print "xE-y\n";
! $e = abs($e);
! if ($$miv !~ s/0{$e}$//) # can strip so many zero's?
! {
! #print "NOI 3\n";
! $self->{sign} = $nan;
! }
! }
! }
! $self->{sign} = '+' if $$miv eq '0'; # normalize -0 => +0
! $self->{value} = $CALC->_new($miv) if $self->{sign} =~ /^[+-]$/;
! #print "$wanted => $self->{sign}\n";
! # if any of the globals is set, use them to round and store them inside $self
! $self->round($accuracy,$precision,$rnd_mode)
! if defined $accuracy || defined $precision;
! return $self;
! }
! # some shortcuts for easier life
! sub bint
! {
! # exportable version of new
! return $class->new(@_);
! }
!
! sub bnan
! {
! # create a bigint 'NaN', if given a BigInt, set it to 'NaN'
! my $self = shift;
! $self = $class if !defined $self;
! if (!ref($self))
! {
! my $c = $self; $self = {}; bless $self, $c;
}
! return if $self->modify('bnan');
! $self->{value} = $CALC->_zero();
! $self->{sign} = $nan;
! return $self;
! }
! sub binf
! {
! # create a bigint '+-inf', if given a BigInt, set it to '+-inf'
! # the sign is either '+', or if given, used from there
! my $self = shift;
! my $sign = shift; $sign = '+' if !defined $sign || $sign ne '-';
! $self = $class if !defined $self;
! if (!ref($self))
! {
! my $c = $self; $self = {}; bless $self, $c;
}
! return if $self->modify('binf');
! $self->{value} = $CALC->_zero();
! $self->{sign} = $sign.'inf';
! return $self;
! }
! sub bzero
! {
! # create a bigint '+0', if given a BigInt, set it to 0
! my $self = shift;
! $self = $class if !defined $self;
! #print "bzero $self\n";
!
! if (!ref($self))
! {
! my $c = $self; $self = {}; bless $self, $c;
! }
! return if $self->modify('bzero');
! $self->{value} = $CALC->_zero();
! $self->{sign} = '+';
! #print "result: $self\n";
! return $self;
! }
!
! ##############################################################################
! # string conversation
!
! sub bsstr
! {
! # (ref to BFLOAT or num_str ) return num_str
! # Convert number from internal format to scientific string format.
! # internal format is always normalized (no leading zeros, "-0E0" => "+0E0")
! my ($self,$x) = objectify(1,@_);
!
! return $x->{sign} if $x->{sign} !~ /^[+-]$/;
! my ($m,$e) = $x->parts();
! # can be only '+', so
! my $sign = 'e+';
! # MBF: my $s = $e->{sign}; $s = '' if $s eq '-'; my $sep = 'e'.$s;
! return $m->bstr().$sign.$e->bstr();
! }
!
! sub bstr
! {
! # make a string from bigint object
! my $x = shift; $x = $class->new($x) unless ref $x;
! return $x->{sign} if $x->{sign} !~ /^[+-]$/;
! my $es = ''; $es = $x->{sign} if $x->{sign} eq '-';
! return $es.${$CALC->_str($x->{value})};
! }
!
! sub numify
! {
! # Make a number from a BigInt object
! my $x = shift; $x = $class->new($x) unless ref $x;
! return $x->{sign} if $x->{sign} !~ /^[+-]$/;
! my $num = $CALC->_num($x->{value});
! return -$num if $x->{sign} eq '-';
! return $num;
! }
!
! ##############################################################################
! # public stuff (usually prefixed with "b")
!
! sub sign
! {
! # return the sign of the number: +/-/NaN
! my ($self,$x) = objectify(1,@_);
! return $x->{sign};
! }
!
! sub round
! {
! # After any operation or when calling round(), the result is rounded by
! # regarding the A & P from arguments, local parameters, or globals.
! # The result's A or P are set by the rounding, but not inspected beforehand
! # (aka only the arguments enter into it). This works because the given
! # 'first' argument is both the result and true first argument with unchanged
! # A and P settings.
! # This does not yet handle $x with A, and $y with P (which should be an
! # error).
! my $self = shift;
! my $a = shift; # accuracy, if given by caller
! my $p = shift; # precision, if given by caller
! my $r = shift; # round_mode, if given by caller
! my @args = @_; # all 'other' arguments (0 for unary, 1 for binary ops)
!
! # leave bigfloat parts alone
! return $self if exists $self->{_f} && $self->{_f} & MB_NEVER_ROUND != 0;
!
! unshift @args,$self; # add 'first' argument
!
! $self = new($self) unless ref($self); # if not object, make one
!
! # find out class of argument to round
! my $c = ref($args[0]);
!
! # now pick $a or $p, but only if we have got "arguments"
! if ((!defined $a) && (!defined $p) && (@args > 0))
! {
! foreach (@args)
! {
! # take the defined one, or if both defined, the one that is smaller
! $a = $_->{_a} if (defined $_->{_a}) && (!defined $a || $_->{_a} < $a);
! }
! if (!defined $a) # if it still is not defined, take p
! {
! foreach (@args)
! {
! # take the defined one, or if both defined, the one that is smaller
! $p = $_->{_p} if (defined $_->{_p}) && (!defined $p || $_->{_p} < $p);
}
! # if none defined, use globals (#2)
! if (!defined $p)
! {
! no strict 'refs';
! my $z = "$c\::accuracy"; $a = $$z;
! if (!defined $a)
! {
! $z = "$c\::precision"; $p = $$z;
! }
}
+ } # endif !$a
+ } # endif !$a || !$P && args > 0
+ # for clearity, this is not merged at place (#2)
+ # now round, by calling fround or ffround:
+ if (defined $a)
+ {
+ $self->{_a} = $a; $self->bround($a,$r);
+ }
+ elsif (defined $p)
+ {
+ $self->{_p} = $p; $self->bfround($p,$r);
+ }
+ return $self->bnorm();
+ }
+
+ sub bnorm
+ {
+ # (num_str or BINT) return BINT
+ # Normalize number -- no-op here
+ my $self = shift;
+
+ return $self;
+ }
+
+ sub babs
+ {
+ # (BINT or num_str) return BINT
+ # make number absolute, or return absolute BINT from string
+ #my ($self,$x) = objectify(1,@_);
+ my $x = shift; $x = $class->new($x) unless ref $x;
+ return $x if $x->modify('babs');
+ # post-normalized abs for internal use (does nothing for NaN)
+ $x->{sign} =~ s/^-/+/;
+ $x;
+ }
+
+ sub bneg
+ {
+ # (BINT or num_str) return BINT
+ # negate number or make a negated number from string
+ my ($self,$x,$a,$p,$r) = objectify(1,@_);
+ return $x if $x->modify('bneg');
+ # for +0 dont negate (to have always normalized)
+ return $x if $x->is_zero();
+ $x->{sign} =~ tr/+\-/-+/; # does nothing for NaN
+ # $x->round($a,$p,$r); # changing this makes $x - $y modify $y!!
+ $x;
+ }
+
+ sub bcmp
+ {
+ # Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort)
+ # (BINT or num_str, BINT or num_str) return cond_code
+ my ($self,$x,$y) = objectify(2,@_);
+
+ if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
+ {
+ # handle +-inf and NaN
+ return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+ return 0 if ($x->{sign} eq $y->{sign}) && ($x->{sign} =~ /^[+-]inf$/);
+ return +1 if $x->{sign} eq '+inf';
+ return -1 if $x->{sign} eq '-inf';
+ return -1 if $y->{sign} eq '+inf';
+ return +1 if $y->{sign} eq '-inf';
+ }
+ # normal compare now
+ &cmp($x->{value},$y->{value},$x->{sign},$y->{sign}) <=> 0;
+ }
+
+ sub bacmp
+ {
+ # Compares 2 values, ignoring their signs.
+ # Returns one of undef, <0, =0, >0. (suitable for sort)
+ # (BINT, BINT) return cond_code
+ my ($self,$x,$y) = objectify(2,@_);
+ return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
+ #acmp($x->{value},$y->{value}) <=> 0;
+ $CALC->_acmp($x->{value},$y->{value}) <=> 0;
+ }
+
+ sub badd
+ {
+ # add second arg (BINT or string) to first (BINT) (modifies first)
+ # return result as BINT
+ my ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
+
+ return $x if $x->modify('badd');
+ return $x->bnan() if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/));
+
+ my @bn = ($a,$p,$r,$y); # make array for round calls
+ # speed: no add for 0+y or x+0
+ return $x->round(@bn) if $y->is_zero(); # x+0
+ if ($x->is_zero()) # 0+y
+ {
+ # make copy, clobbering up x
+ $x->{value} = $CALC->_copy($y->{value});
+ #$x->{value} = [ @{$y->{value}} ];
+ $x->{sign} = $y->{sign} || $nan;
+ return $x->round(@bn);
+ }
+
+ # shortcuts
+ my $xv = $x->{value};
+ my $yv = $y->{value};
+ my ($sx, $sy) = ( $x->{sign}, $y->{sign} ); # get signs
+
+ if ($sx eq $sy)
+ {
+ $CALC->_add($xv,$yv); # if same sign, absolute add
+ $x->{sign} = $sx;
+ }
+ else
+ {
+ my $a = $CALC->_acmp ($yv,$xv); # absolute compare
+ if ($a > 0)
+ {
+ #print "swapped sub (a=$a)\n";
+ $CALC->_sub($yv,$xv,1); # absolute sub w/ swapped params
+ $x->{sign} = $sy;
+ }
+ elsif ($a == 0)
+ {
+ # speedup, if equal, set result to 0
+ #print "equal sub, result = 0\n";
+ $x->{value} = $CALC->_zero();
+ $x->{sign} = '+';
}
! else # a < 0
! {
! #print "unswapped sub (a=$a)\n";
! $CALC->_sub($xv, $yv); # absolute sub
! $x->{sign} = $sx;
! }
}
! return $x->round(@bn);
! }
! sub bsub
! {
! # (BINT or num_str, BINT or num_str) return num_str
! # subtract second arg from first, modify first
! my ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
! return $x if $x->modify('bsub');
! $x->badd($y->bneg()); # badd does not leave internal zeros
! $y->bneg(); # refix y, assumes no one reads $y in between
! return $x->round($a,$p,$r,$y);
! }
!
! sub binc
! {
! # increment arg by one
! my ($self,$x,$a,$p,$r) = objectify(1,@_);
! # my $x = shift; $x = $class->new($x) unless ref $x; my $self = ref($x);
! return $x if $x->modify('binc');
! $x->badd($self->_one())->round($a,$p,$r);
! }
!
! sub bdec
! {
! # decrement arg by one
! my ($self,$x,$a,$p,$r) = objectify(1,@_);
! return $x if $x->modify('bdec');
! $x->badd($self->_one('-'))->round($a,$p,$r);
! }
!
! sub blcm
! {
! # (BINT or num_str, BINT or num_str) return BINT
! # does not modify arguments, but returns new object
! # Lowest Common Multiplicator
!
! my $y = shift; my ($x);
! if (ref($y))
! {
! $x = $y->copy();
}
! else
! {
! $x = $class->new($y);
}
! while (@_) { $x = _lcm($x,shift); }
! $x;
! }
!
! sub bgcd
! {
! # (BINT or num_str, BINT or num_str) return BINT
! # does not modify arguments, but returns new object
! # GCD -- Euclids algorithm, variant C (Knuth Vol 3, pg 341 ff)
!
! my $y = shift; my ($x);
! if (ref($y))
! {
! $x = $y->copy();
! }
! else
! {
! $x = $class->new($y);
! }
!
! if ($CALC->can('_gcd'))
! {
! while (@_)
! {
! $y = shift; $y = $class->new($y) if !ref($y);
! next if $y->is_zero();
! return $x->bnan() if $y->{sign} !~ /^[+-]$/; # y NaN?
! $x->{value} = $CALC->_gcd($x->{value},$y->{value}); last if $x->is_one();
! }
! }
! else
! {
! while (@_)
! {
! $x = _gcd($x,shift); last if $x->is_one(); # _gcd handles NaN
! }
! }
! $x->babs();
! }
!
! sub bmod
! {
! # modulus
! # (BINT or num_str, BINT or num_str) return BINT
! my ($self,$x,$y) = objectify(2,@_);
!
! return $x if $x->modify('bmod');
! (&bdiv($self,$x,$y))[1];
! }
!
! sub bnot
! {
! # (num_str or BINT) return BINT
! # represent ~x as twos-complement number
! my ($self,$x) = objectify(1,@_);
! return $x if $x->modify('bnot');
! $x->bneg(); $x->bdec(); # was: bsub(-1,$x);, time it someday
! $x;
! }
!
! sub is_zero
! {
! # return true if arg (BINT or num_str) is zero (array '+', '0')
! #my ($self,$x) = objectify(1,@_);
! my $x = shift; $x = $class->new($x) unless ref $x;
!
! return 0 if $x->{sign} !~ /^[+-]$/;
! return $CALC->_is_zero($x->{value});
! #return (@{$x->{value}} == 1) && ($x->{sign} eq '+')
! # && ($x->{value}->[0] == 0);
! }
!
! sub is_nan
! {
! # return true if arg (BINT or num_str) is NaN
! #my ($self,$x) = objectify(1,@_);
! my $x = shift; $x = $class->new($x) unless ref $x;
! return ($x->{sign} eq $nan);
! }
!
! sub is_inf
! {
! # return true if arg (BINT or num_str) is +-inf
! #my ($self,$x) = objectify(1,@_);
! my $x = shift; $x = $class->new($x) unless ref $x;
! my $sign = shift || '';
!
! return $x->{sign} =~ /^[+-]inf$/ if $sign eq '';
! return $x->{sign} =~ /^[$sign]inf$/;
! }
!
! sub is_one
! {
! # return true if arg (BINT or num_str) is +1
! # or -1 if sign is given
! #my ($self,$x) = objectify(1,@_);
! my $x = shift; $x = $class->new($x) unless ref $x;
! my $sign = shift || '+';
!
! # catch also NaN, +inf, -inf
! return 0 if $x->{sign} ne $sign || $x->{sign} !~ /^[+-]$/;
! return $CALC->_is_one($x->{value});
! #return (@{$x->{value}} == 1) && ($x->{sign} eq $sign)
! # && ($x->{value}->[0] == 1);
! }
!
! sub is_odd
! {
! # return true when arg (BINT or num_str) is odd, false for even
! my $x = shift; $x = $class->new($x) unless ref $x;
! #my ($self,$x) = objectify(1,@_);
!
! return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't
! return $CALC->_is_odd($x->{value});
! #return (($x->{sign} ne $nan) && ($x->{value}->[0] & 1));
! }
!
! sub is_even
! {
! # return true when arg (BINT or num_str) is even, false for odd
! my $x = shift; $x = $class->new($x) unless ref $x;
! #my ($self,$x) = objectify(1,@_);
!
! return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't
! return $CALC->_is_even($x->{value});
! #return (($x->{sign} ne $nan) && (!($x->{value}->[0] & 1)));
! #return (($x->{sign} !~ /^[+-]$/) && ($CALC->_is_even($x->{value})));
! }
!
! sub is_positive
! {
! # return true when arg (BINT or num_str) is positive (>= 0)
! my $x = shift; $x = $class->new($x) unless ref $x;
! return ($x->{sign} =~ /^\+/);
! }
!
! sub is_negative
! {
! # return true when arg (BINT or num_str) is negative (< 0)
! my $x = shift; $x = $class->new($x) unless ref $x;
! return ($x->{sign} =~ /^-/);
! }
!
! ###############################################################################
!
! sub bmul
! {
! # multiply two numbers -- stolen from Knuth Vol 2 pg 233
! # (BINT or num_str, BINT or num_str) return BINT
! my ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
!
! return $x if $x->modify('bmul');
! return $x->bnan() if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/));
!
! return $x->bzero() if $x->is_zero() || $y->is_zero(); # handle result = 0
! $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-'; # +1 * +1 or -1 * -1 => +
! $CALC->_mul($x->{value},$y->{value}); # do actual math
! return $x->round($a,$p,$r,$y);
! }
!
! sub bdiv
! {
! # (dividend: BINT or num_str, divisor: BINT or num_str) return
! # (BINT,BINT) (quo,rem) or BINT (only rem)
! my ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
!
! return $x if $x->modify('bdiv');
!
! # 5 / 0 => +inf, -6 / 0 => -inf (0 / 0 => 1 or +inf or NaN?)
! #return wantarray
! # ? ($x->binf($x->{sign}),binf($x->{sign})) : $x->binf($x->{sign})
! # if ($x->{sign} =~ /^[+-]$/ && $y->is_zero());
!
! # NaN?
! return wantarray ? ($x->bnan(),bnan()) : $x->bnan()
! if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/ || $y->is_zero());
!
! # 0 / something
! return wantarray ? ($x,$self->bzero()) : $x if $x->is_zero();
!
! # Is $x in the interval [0, $y) ?
! my $cmp = $CALC->_acmp($x->{value},$y->{value});
! if (($cmp < 0) and ($x->{sign} eq $y->{sign}))
! {
! return $x->bzero() unless wantarray;
! my $t = $x->copy(); # make copy first, because $x->bzero() clobbers $x
! return ($x->bzero(),$t);
! }
! elsif ($cmp == 0)
! {
! # shortcut, both are the same, so set to +/- 1
! $x->_one( ($x->{sign} ne $y->{sign} ? '-' : '+') );
! return $x unless wantarray;
! return ($x,$self->bzero());
! }
!
! # calc new sign and in case $y == +/- 1, return $x
! $x->{sign} = ($x->{sign} ne $y->{sign} ? '-' : '+');
! # check for / +-1 (cant use $y->is_one due to '-'
! if (($y == 1) || ($y == -1)) # slow!
! #if ((@{$y->{value}} == 1) && ($y->{value}->[0] == 1))
! {
! return wantarray ? ($x,$self->bzero()) : $x;
! }
!
! # call div here
! my $rem = $self->bzero();
! $rem->{sign} = $y->{sign};
! #($x->{value},$rem->{value}) = div($x->{value},$y->{value});
! ($x->{value},$rem->{value}) = $CALC->_div($x->{value},$y->{value});
! # do not leave rest "-0";
! # $rem->{sign} = '+' if (@{$rem->{value}} == 1) && ($rem->{value}->[0] == 0);
! $rem->{sign} = '+' if $CALC->_is_zero($rem->{value});
! if (($x->{sign} eq '-') and (!$rem->is_zero()))
! {
! $x->bdec();
! }
! $x->round($a,$p,$r,$y);
! if (wantarray)
! {
! $rem->round($a,$p,$r,$x,$y);
! return ($x,$y-$rem) if $x->{sign} eq '-'; # was $x,$rem
! return ($x,$rem);
! }
! return $x;
! }
!
! sub bpow
! {
! # (BINT or num_str, BINT or num_str) return BINT
! # compute power of two numbers -- stolen from Knuth Vol 2 pg 233
! # modifies first argument
! my ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
!
! return $x if $x->modify('bpow');
!
! return $x if $x->{sign} =~ /^[+-]inf$/; # -inf/+inf ** x
! return $x->bnan() if $x->{sign} eq $nan || $y->{sign} eq $nan;
! return $x->_one() if $y->is_zero();
! return $x if $x->is_one() || $y->is_one();
! #if ($x->{sign} eq '-' && @{$x->{value}} == 1 && $x->{value}->[0] == 1)
! if ($x->{sign} eq '-' && $CALC->_is_one($x->{value}))
! {
! # if $x == -1 and odd/even y => +1/-1
! return $y->is_odd() ? $x : $x->babs();
! # my Casio FX-5500L has a bug here: -1 ** 2 is -1, but -1 * -1 is 1; LOL
! }
! # 1 ** -y => 1 / (1**y), so do test for negative $y after above's clause
! return $x->bnan() if $y->{sign} eq '-';
! return $x if $x->is_zero(); # 0**y => 0 (if not y <= 0)
!
! if ($CALC->can('_pow'))
! {
! $CALC->_pow($x->{value},$y->{value});
! return $x->round($a,$p,$r);
! }
! # based on the assumption that shifting in base 10 is fast, and that mul
! # works faster if numbers are small: we count trailing zeros (this step is
! # O(1)..O(N), but in case of O(N) we save much more time due to this),
! # stripping them out of the multiplication, and add $count * $y zeros
! # afterwards like this:
! # 300 ** 3 == 300*300*300 == 3*3*3 . '0' x 2 * 3 == 27 . '0' x 6
! # creates deep recursion?
! #my $zeros = $x->_trailing_zeros();
! #if ($zeros > 0)
! # {
! # $x->brsft($zeros,10); # remove zeros
! # $x->bpow($y); # recursion (will not branch into here again)
! # $zeros = $y * $zeros; # real number of zeros to add
! # $x->blsft($zeros,10);
! # return $x->round($a,$p,$r);
! # }
!
! my $pow2 = $self->_one();
! my $y1 = $class->new($y);
! my ($res);
! while (!$y1->is_one())
! {
! #print "bpow: p2: $pow2 x: $x y: $y1 r: $res\n";
! #print "len ",$x->length(),"\n";
! ($y1,$res)=&bdiv($y1,2);
! if (!$res->is_zero()) { &bmul($pow2,$x); }
! if (!$y1->is_zero()) { &bmul($x,$x); }
! #print "$x $y\n";
! }
! #print "bpow: e p2: $pow2 x: $x y: $y1 r: $res\n";
! &bmul($x,$pow2) if (!$pow2->is_one());
! #print "bpow: e p2: $pow2 x: $x y: $y1 r: $res\n";
! return $x->round($a,$p,$r);
! }
!
! sub blsft
! {
! # (BINT or num_str, BINT or num_str) return BINT
! # compute x << y, base n, y >= 0
! my ($self,$x,$y,$n) = objectify(2,@_);
!
! return $x if $x->modify('blsft');
! return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
!
! $n = 2 if !defined $n; return $x if $n == 0;
! return $x->bnan() if $n < 0 || $y->{sign} eq '-';
! #if ($n != 10)
! # {
! $x->bmul( $self->bpow($n, $y) );
! # }
! #else
! # {
! # # shortcut (faster) for shifting by 10) since we are in base 10eX
! # # multiples of 5:
! # my $src = scalar @{$x->{value}}; # source
! # my $len = $y->numify(); # shift-len as normal int
! # my $rem = $len % 5; # reminder to shift
! # my $dst = $src + int($len/5); # destination
! #
! # my $v = $x->{value}; # speed-up
! # my $vd; # further speedup
! # #print "src $src:",$v->[$src]||0," dst $dst:",$v->[$dst]||0," rem $rem\n";
! # $v->[$src] = 0; # avoid first ||0 for speed
! # while ($src >= 0)
! # {
! # $vd = $v->[$src]; $vd = '00000'.$vd;
! # #print "s $src d $dst '$vd' ";
! # $vd = substr($vd,-5+$rem,5-$rem);
! # #print "'$vd' ";
! # $vd .= $src > 0 ? substr('00000'.$v->[$src-1],-5,$rem) : '0' x $rem;
! # #print "'$vd' ";
! # $vd = substr($vd,-5,5) if length($vd) > 5;
! # #print "'$vd'\n";
! # $v->[$dst] = int($vd);
! # $dst--; $src--;
! # }
! # # set lowest parts to 0
! # while ($dst >= 0) { $v->[$dst--] = 0; }
! # # fix spurios last zero element
! # splice @$v,-1 if $v->[-1] == 0;
! # #print "elems: "; my $i = 0;
! # #foreach (reverse @$v) { print "$i $_ "; $i++; } print "\n";
! # # old way: $x->bmul( $self->bpow($n, $y) );
! # }
! return $x;
! }
!
! sub brsft
! {
! # (BINT or num_str, BINT or num_str) return BINT
! # compute x >> y, base n, y >= 0
! my ($self,$x,$y,$n) = objectify(2,@_);
!
! return $x if $x->modify('brsft');
! return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
!
! $n = 2 if !defined $n; return $x->bnan() if $n <= 0 || $y->{sign} eq '-';
! #if ($n != 10)
! # {
! scalar bdiv($x, $self->bpow($n, $y));
! # }
! #else
! # {
! # # shortcut (faster) for shifting by 10)
! # # multiples of 5:
! # my $dst = 0; # destination
! # my $src = $y->numify(); # as normal int
! # my $rem = $src % 5; # reminder to shift
! # $src = int($src / 5); # source
! # my $len = scalar @{$x->{value}} - $src; # elems to go
! # my $v = $x->{value}; # speed-up
! # if ($rem == 0)
! # {
! # splice (@$v,0,$src); # even faster, 38.4 => 39.3
! # }
! # else
! # {
! # my $vd;
! # $v->[scalar @$v] = 0; # avoid || 0 test inside loop
! # while ($dst < $len)
! # {
! # $vd = '00000'.$v->[$src];
! # #print "$dst $src '$vd' ";
! # $vd = substr($vd,-5,5-$rem);
! # #print "'$vd' ";
! # $src++;
! # $vd = substr('00000'.$v->[$src],-$rem,$rem) . $vd;
! # #print "'$vd1' ";
! # #print "'$vd'\n";
! # $vd = substr($vd,-5,5) if length($vd) > 5;
! # $v->[$dst] = int($vd);
! # $dst++;
! # }
! # splice (@$v,$dst) if $dst > 0; # kill left-over array elems
! # pop @$v if $v->[-1] == 0; # kill last element
! # } # else rem == 0
! # # old way: scalar bdiv($x, $self->bpow($n, $y));
! # }
! return $x;
! }
!
! sub band
! {
! #(BINT or num_str, BINT or num_str) return BINT
! # compute x & y
! my ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
!
! return $x if $x->modify('band');
!
! return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
! return $x->bzero() if $y->is_zero();
!
! if ($CALC->can('_and'))
! {
! $CALC->_and($x->{value},$y->{value});
! return $x->round($a,$p,$r);
! }
!
! my $m = new Math::BigInt 1; my ($xr,$yr);
! my $x10000 = new Math::BigInt (0x10000);
! my $y1 = copy(ref($x),$y); # make copy
! my $x1 = $x->copy(); $x->bzero(); # modify x in place!
! while (!$x1->is_zero() && !$y1->is_zero())
! {
! ($x1, $xr) = bdiv($x1, $x10000);
! ($y1, $yr) = bdiv($y1, $x10000);
! #print ref($xr), " $xr ", $xr->numify(),"\n";
! #print ref($yr), " $yr ", $yr->numify(),"\n";
! #print "res: ",$yr->numify() & $xr->numify(),"\n";
! my $u = bmul( $class->new( $xr->numify() & $yr->numify() ), $m);
! #print "res: $u\n";
! $x->badd( bmul( $class->new( $xr->numify() & $yr->numify() ), $m));
! $m->bmul($x10000);
! }
! return $x->round($a,$p,$r);
! }
!
! sub bior
! {
! #(BINT or num_str, BINT or num_str) return BINT
! # compute x | y
! my ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
!
! return $x if $x->modify('bior');
!
! return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
! return $x if $y->is_zero();
! if ($CALC->can('_or'))
! {
! $CALC->_or($x->{value},$y->{value});
! return $x->round($a,$p,$r);
! }
!
! my $m = new Math::BigInt 1; my ($xr,$yr);
! my $x10000 = new Math::BigInt (0x10000);
! my $y1 = copy(ref($x),$y); # make copy
! my $x1 = $x->copy(); $x->bzero(); # modify x in place!
! while (!$x1->is_zero() || !$y1->is_zero())
! {
! ($x1, $xr) = bdiv($x1,$x10000);
! ($y1, $yr) = bdiv($y1,$x10000);
! $x->badd( bmul( $class->new( $xr->numify() | $yr->numify() ), $m));
! $m->bmul($x10000);
! }
! return $x->round($a,$p,$r);
! }
!
! sub bxor
! {
! #(BINT or num_str, BINT or num_str) return BINT
! # compute x ^ y
! my ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
!
! return $x if $x->modify('bxor');
!
! return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
! return $x if $y->is_zero();
! return $x->bzero() if $x == $y; # shortcut
!
! if ($CALC->can('_xor'))
! {
! $CALC->_xor($x->{value},$y->{value});
! return $x->round($a,$p,$r);
! }
!
! my $m = new Math::BigInt 1; my ($xr,$yr);
! my $x10000 = new Math::BigInt (0x10000);
! my $y1 = copy(ref($x),$y); # make copy
! my $x1 = $x->copy(); $x->bzero(); # modify x in place!
! while (!$x1->is_zero() || !$y1->is_zero())
! {
! ($x1, $xr) = bdiv($x1, $x10000);
! ($y1, $yr) = bdiv($y1, $x10000);
! $x->badd( bmul( $class->new( $xr->numify() ^ $yr->numify() ), $m));
! $m->bmul($x10000);
! }
! return $x->round($a,$p,$r);
! }
!
! sub length
! {
! my ($self,$x) = objectify(1,@_);
!
! my $e = $CALC->_len($x->{value});
! # # fallback, since we do not know the underlying representation
! #my $es = "$x"; my $c = 0; $c = 1 if $es =~ /^[+-]/; # if lib returns '+123'
! #my $e = CORE::length($es)-$c;
! return wantarray ? ($e,0) : $e;
! }
!
! sub digit
! {
! # return the nth decimal digit, negative values count backward, 0 is right
! my $x = shift;
! my $n = shift || 0;
!
! return $CALC->_digit($x->{value},$n);
! }
!
! sub _trailing_zeros
! {
! # return the amount of trailing zeros in $x
! my $x = shift;
! $x = $class->new($x) unless ref $x;
!
! return 0 if $x->is_zero() || $x->is_nan() || $x->is_inf();
!
! return $CALC->_zeros($x->{value}) if $CALC->can('_zeros');
!
! # if not: since we do not know underlying internal representation:
! my $es = "$x"; $es =~ /([0]*)$/;
!
! return 0 if !defined $1; # no zeros
! return CORE::length("$1"); # as string, not as +0!
! }
!
! sub bsqrt
! {
! my ($self,$x) = objectify(1,@_);
!
! return $x->bnan() if $x->{sign} =~ /\-|$nan/; # -x or NaN => NaN
! return $x->bzero() if $x->is_zero(); # 0 => 0
! return $x if $x == 1; # 1 => 1
!
! my $y = $x->copy(); # give us one more digit accur.
! my $l = int($x->length()/2);
!
! $x->bzero();
! $x->binc(); # keep ref($x), but modify it
! $x *= 10 ** $l;
!
! # print "x: $y guess $x\n";
!
! my $last = $self->bzero();
! while ($last != $x)
! {
! $last = $x;
! $x += $y / $x;
! $x /= 2;
! }
! return $x;
! }
!
! sub exponent
! {
! # return a copy of the exponent (here always 0, NaN or 1 for $m == 0)
! my ($self,$x) = objectify(1,@_);
!
! return bnan() if $x->is_nan();
! my $e = $class->bzero();
! return $e->binc() if $x->is_zero();
! $e += $x->_trailing_zeros();
! return $e;
! }
!
! sub mantissa
! {
! # return a copy of the mantissa (here always $self)
! my ($self,$x) = objectify(1,@_);
!
! return bnan() if $x->is_nan();
! my $m = $x->copy();
! # that's inefficient
! my $zeros = $m->_trailing_zeros();
! $m /= 10 ** $zeros if $zeros != 0;
! return $m;
! }
!
! sub parts
! {
! # return a copy of both the exponent and the mantissa (here 0 and self)
! my $self = shift;
! $self = $class->new($self) unless ref $self;
!
! return ($self->mantissa(),$self->exponent());
! }
!
! ##############################################################################
! # rounding functions
!
! sub bfround
! {
! # precision: round to the $Nth digit left (+$n) or right (-$n) from the '.'
! # $n == 0 => round to integer
! my $x = shift; $x = $class->new($x) unless ref $x;
! my ($scale,$mode) = $x->_scale_p($precision,$rnd_mode,@_);
! return $x if !defined $scale; # no-op
!
! # no-op for BigInts if $n <= 0
! return $x if $scale <= 0;
!
! $x->bround( $x->length()-$scale, $mode);
! }
!
! sub _scan_for_nonzero
! {
! my $x = shift;
! my $pad = shift;
! my $xs = shift;
!
! my $len = $x->length();
! return 0 if $len == 1; # '5' is trailed by invisible zeros
! my $follow = $pad - 1;
! return 0 if $follow > $len || $follow < 1;
! #print "checking $x $r\n";
!
! # since we do not know underlying represention of $x, use decimal string
! #my $r = substr ($$xs,-$follow);
! my $r = substr ("$x",-$follow);
! return 1 if $r =~ /[^0]/; return 0;
! }
!
! sub fround
! {
! # to make life easier for switch between MBF and MBI (autoload fxxx()
! # like MBF does for bxxx()?)
! my $x = shift;
! return $x->bround(@_);
! }
!
! sub bround
! {
! # accuracy: +$n preserve $n digits from left,
! # -$n preserve $n digits from right (f.i. for 0.1234 style in MBF)
! # no-op for $n == 0
! # and overwrite the rest with 0's, return normalized number
! # do not return $x->bnorm(), but $x
! my $x = shift; $x = $class->new($x) unless ref $x;
! my ($scale,$mode) = $x->_scale_a($accuracy,$rnd_mode,@_);
! return $x if !defined $scale; # no-op
!
! # print "MBI round: $x to $scale $mode\n";
! # -scale means what? tom? hullo? -$scale needed by MBF round, but what for?
! return $x if $x->is_nan() || $x->is_zero() || $scale == 0;
!
! # we have fewer digits than we want to scale to
! my $len = $x->length();
! # print "$len $scale\n";
! return $x if $len < abs($scale);
!
! # count of 0's to pad, from left (+) or right (-): 9 - +6 => 3, or |-6| => 6
! my ($pad,$digit_round,$digit_after);
! $pad = $len - $scale;
! $pad = abs($scale)+1 if $scale < 0;
! # do not use digit(), it is costly for binary => decimal
! #$digit_round = '0'; $digit_round = $x->digit($pad) if $pad < $len;
! #$digit_after = '0'; $digit_after = $x->digit($pad-1) if $pad > 0;
! my $xs = $CALC->_str($x->{value});
! my $pl = -$pad-1;
! # pad: 123: 0 => -1, at 1 => -2, at 2 => -3, at 3 => -4
! # pad+1: 123: 0 => 0, at 1 => -1, at 2 => -2, at 3 => -3
! $digit_round = '0'; $digit_round = substr($$xs,$pl,1) if $pad <= $len;
! $pl++; $pl ++ if $pad >= $len;
! $digit_after = '0'; $digit_after = substr($$xs,$pl,1)
! if $pad > 0;
!
! #my $d_round = '0'; $d_round = $x->digit($pad) if $pad < $len;
! #my $d_after = '0'; $d_after = $x->digit($pad-1) if $pad > 0;
! # print "$pad $pl $$xs $digit_round:$d_round $digit_after:$d_after\n";
!
! # in case of 01234 we round down, for 6789 up, and only in case 5 we look
! # closer at the remaining digits of the original $x, remember decision
! my $round_up = 1; # default round up
! $round_up -- if
! ($mode eq 'trunc') || # trunc by round down
! ($digit_after =~ /[01234]/) || # round down anyway,
! # 6789 => round up
! ($digit_after eq '5') && # not 5000...0000
! ($x->_scan_for_nonzero($pad,$xs) == 0) &&
! (
! ($mode eq 'even') && ($digit_round =~ /[24680]/) ||
! ($mode eq 'odd') && ($digit_round =~ /[13579]/) ||
! ($mode eq '+inf') && ($x->{sign} eq '-') ||
! ($mode eq '-inf') && ($x->{sign} eq '+') ||
! ($mode eq 'zero') # round down if zero, sign adjusted below
! );
! # allow rounding one place left of mantissa
! #print "$pad $len $scale\n";
! # this is triggering warnings, and buggy for $scale < 0
! #if (-$scale != $len)
! {
! # old code, depend on internal representation
! # split mantissa at $pad and then pad with zeros
! #my $s5 = int($pad / 5);
! #my $i = 0;
! #while ($i < $s5)
! # {
! # $x->{value}->[$i++] = 0; # replace with 5 x 0
! # }
! #$x->{value}->[$s5] = '00000'.$x->{value}->[$s5]; # pad with 0
! #my $rem = $pad % 5; # so much left over
! #if ($rem > 0)
! # {
! # #print "remainder $rem\n";
! ## #print "elem $x->{value}->[$s5]\n";
! # substr($x->{value}->[$s5],-$rem,$rem) = '0' x $rem; # stamp w/ '0'
! # }
! #$x->{value}->[$s5] = int ($x->{value}->[$s5]); # str '05' => int '5'
! #print ${$CALC->_str($pad->{value})}," $len\n";
! if (($pad > 0) && ($pad <= $len))
! {
! substr($$xs,-$pad,$pad) = '0' x $pad;
! $x->{value} = $CALC->_new($xs); # put back in
! }
! elsif ($pad > $len)
! {
! $x->{value} = $CALC->_zero(); # round to '0'
! }
! #print "res $$xs\n";
! }
! # move this later on after the inc of the string
! #$x->{value} = $CALC->_new($xs); # put back in
! if ($round_up) # what gave test above?
! {
! $pad = $len if $scale < 0; # tlr: whack 0.51=>1.0
! # modify $x in place, undef, undef to avoid rounding
! # str creation much faster than 10 ** something
! $x->badd( Math::BigInt->new($x->{sign}.'1'.'0'x$pad) );
! # increment string in place, to avoid dec=>hex for the '1000...000'
! # $xs ...blah foo
! }
! # to here:
! #$x->{value} = $CALC->_new($xs); # put back in
! $x;
! }
!
! sub bfloor
! {
! # return integer less or equal then number, since it is already integer,
! # always returns $self
! my ($self,$x,$a,$p,$r) = objectify(1,@_);
!
! # not needed: return $x if $x->modify('bfloor');
!
! return $x->round($a,$p,$r);
! }
!
! sub bceil
! {
! # return integer greater or equal then number, since it is already integer,
! # always returns $self
! my ($self,$x,$a,$p,$r) = objectify(1,@_);
!
! # not needed: return $x if $x->modify('bceil');
!
! return $x->round($a,$p,$r);
! }
!
! ##############################################################################
! # private stuff (internal use only)
!
! sub _one
! {
! # internal speedup, set argument to 1, or create a +/- 1
! my $self = shift;
! #my $x = $self->bzero(); $x->{value} = [ 1 ]; $x->{sign} = shift || '+'; $x;
! my $x = $self->bzero(); $x->{value} = $CALC->_one();
! $x->{sign} = shift || '+';
! return $x;
! }
!
! sub _swap
! {
! # Overload will swap params if first one is no object ref so that the first
! # one is always an object ref. In this case, third param is true.
! # This routine is to overcome the effect of scalar,$object creating an object
! # of the class of this package, instead of the second param $object. This
! # happens inside overload, when the overload section of this package is
! # inherited by sub classes.
! # For overload cases (and this is used only there), we need to preserve the
! # args, hence the copy().
! # You can override this method in a subclass, the overload section will call
! # $object->_swap() to make sure it arrives at the proper subclass, with some
! # exceptions like '+' and '-'.
!
! # object, (object|scalar) => preserve first and make copy
! # scalar, object => swapped, re-swap and create new from first
! # (using class of second object, not $class!!)
! my $self = shift; # for override in subclass
! #print "swap $self 0:$_[0] 1:$_[1] 2:$_[2]\n";
! if ($_[2])
! {
! my $c = ref ($_[0]) || $class; # fallback $class should not happen
! return ( $c->new($_[1]), $_[0] );
! }
! else
! {
! return ( $_[0]->copy(), $_[1] );
! }
! }
!
! sub objectify
! {
! # check for strings, if yes, return objects instead
!
! # the first argument is number of args objectify() should look at it will
! # return $count+1 elements, the first will be a classname. This is because
! # overloaded '""' calls bstr($object,undef,undef) and this would result in
! # useless objects beeing created and thrown away. So we cannot simple loop
! # over @_. If the given count is 0, all arguments will be used.
!
! # If the second arg is a ref, use it as class.
! # If not, try to use it as classname, unless undef, then use $class
! # (aka Math::BigInt). The latter shouldn't happen,though.
!
! # caller: gives us:
! # $x->badd(1); => ref x, scalar y
! # Class->badd(1,2); => classname x (scalar), scalar x, scalar y
! # Class->badd( Class->(1),2); => classname x (scalar), ref x, scalar y
! # Math::BigInt::badd(1,2); => scalar x, scalar y
! # In the last case we check number of arguments to turn it silently into
! # $class,1,2. (We cannot take '1' as class ;o)
! # badd($class,1) is not supported (it should, eventually, try to add undef)
! # currently it tries 'Math::BigInt' + 1, which will not work.
!
! my $count = abs(shift || 0);
!
! #print caller(),"\n";
!
! my @a; # resulting array
! if (ref $_[0])
! {
! # okay, got object as first
! $a[0] = ref $_[0];
! }
! else
! {
! # nope, got 1,2 (Class->xxx(1) => Class,1 and not supported)
! $a[0] = $class;
! #print "@_\n"; sleep(1);
! $a[0] = shift if $_[0] =~ /^[A-Z].*::/; # classname as first?
! }
! #print caller(),"\n";
! # print "Now in objectify, my class is today $a[0]\n";
! my $k;
! if ($count == 0)
! {
! while (@_)
! {
! $k = shift;
! if (!ref($k))
! {
! $k = $a[0]->new($k);
! }
! elsif (ref($k) ne $a[0])
! {
! # foreign object, try to convert to integer
! $k->can('as_number') ? $k = $k->as_number() : $k = $a[0]->new($k);
}
! push @a,$k;
! }
}
! else
! {
! while ($count > 0)
! {
! #print "$count\n";
! $count--;
! $k = shift;
! if (!ref($k))
! {
! $k = $a[0]->new($k);
! }
! elsif (ref($k) ne $a[0])
! {
! # foreign object, try to convert to integer
! $k->can('as_number') ? $k = $k->as_number() : $k = $a[0]->new($k);
}
! push @a,$k;
! }
! push @a,@_; # return other params, too
}
! #my $i = 0;
! #foreach (@a)
! # {
! # print "o $i $a[0]\n" if $i == 0;
! # print "o $i ",ref($_),"\n" if $i != 0; $i++;
! # }
! #print "objectify done: would return ",scalar @a," values\n";
! #print caller(1),"\n" unless wantarray;
! die "$class objectify needs list context" unless wantarray;
! @a;
! }
! sub import
! {
! my $self = shift;
! #print "import $self @_\n";
! my @a = @_; my $l = scalar @_; my $j = 0;
! for ( my $i = 0; $i < $l ; $i++,$j++ )
! {
! if ($_[$i] eq ':constant')
! {
! # this causes overlord er load to step in
! overload::constant integer => sub { $self->new(shift) };
! splice @a, $j, 1; $j --;
! }
! elsif ($_[$i] =~ /^lib$/i)
! {
! # this causes a different low lib to take care...
! $CALC = $_[$i+1] || $CALC;
! my $s = 2; $s = 1 if @a-$j < 2; # avoid "cannot modify non-existant..."
! splice @a, $j, $s; $j -= $s;
! }
}
! # any non :constant stuff is handled by our parent, Exporter
! # even if @_ is empty, to give it a chance
! #$self->SUPER::import(@a); # does not work
! $self->export_to_level(1,$self,@a); # need this instead
! # load core math lib
! $CALC = 'Math::BigInt::'.$CALC if $CALC !~ /^Math::BigInt/i;
! my $c = $CALC;
! $c =~ s!::!/!g; # XXX portability, e.g. MacOS?
! $c .= '.pm' if $c !~ /\.pm$/;
! require $c;
! }
! sub _strip_zeros
! {
! # internal normalization function that strips leading zeros from the array
! # args: ref to array
! my $s = shift;
!
! my $cnt = scalar @$s; # get count of parts
! my $i = $cnt-1;
! #print "strip: cnt $cnt i $i\n";
! # '0', '3', '4', '0', '0',
! # 0 1 2 3 4
! # cnt = 5, i = 4
! # i = 4
! # i = 3
! # => fcnt = cnt - i (5-2 => 3, cnt => 5-1 = 4, throw away from 4th pos)
! # >= 1: skip first part (this can be zero)
! while ($i > 0) { last if $s->[$i] != 0; $i--; }
! $i++; splice @$s,$i if ($i < $cnt); # $i cant be 0
! return $s;
! }
! sub _from_hex
! {
! # convert a (ref to) big hex string to BigInt, return undef for error
! my $hs = shift;
!
! my $x = Math::BigInt->bzero();
! return $x->bnan() if $$hs !~ /^[\-\+]?0x[0-9A-Fa-f]+$/;
!
! my $sign = '+'; $sign = '-' if ($$hs =~ /^-/);
!
! $$hs =~ s/^[+-]//; # strip sign
! if ($CALC->can('_from_hex'))
! {
! $x->{value} = $CALC->_from_hex($hs);
}
! else
! {
! # fallback to pure perl
! my $mul = Math::BigInt->bzero(); $mul++;
! my $x65536 = Math::BigInt->new(65536);
! my $len = CORE::length($$hs)-2;
! $len = int($len/4); # 4-digit parts, w/o '0x'
! my $val; my $i = -4;
! while ($len >= 0)
! {
! $val = substr($$hs,$i,4);
! $val =~ s/^[+-]?0x// if $len == 0; # for last part only because
! $val = hex($val); # hex does not like wrong chars
! # print "$val ",substr($$hs,$i,4),"\n";
! $i -= 4; $len --;
! $x += $mul * $val if $val != 0;
! $mul *= $x65536 if $len >= 0; # skip last mul
! }
! }
! $x->{sign} = $sign if !$x->is_zero(); # no '-0'
! return $x;
! }
! sub _from_bin
! {
! # convert a (ref to) big binary string to BigInt, return undef for error
! my $bs = shift;
!
! my $x = Math::BigInt->bzero();
! return $x->bnan() if $$bs !~ /^[+-]?0b[01]+$/;
!
! my $mul = Math::BigInt->bzero(); $mul++;
! my $x256 = Math::BigInt->new(256);
!
! my $sign = '+'; $sign = '-' if ($$bs =~ /^\-/);
! $$bs =~ s/^[+-]//; # strip sign
! if ($CALC->can('_from_bin'))
! {
! $x->{value} = $CALC->_from_bin($bs);
}
! else
! {
! my $len = CORE::length($$bs)-2;
! $len = int($len/8); # 8-digit parts, w/o '0b'
! my $val; my $i = -8;
! while ($len >= 0)
! {
! $val = substr($$bs,$i,8);
! $val =~ s/^[+-]?0b// if $len == 0; # for last part only
! #$val = oct('0b'.$val); # does not work on Perl prior to 5.6.0
! $val = ('0' x (8-CORE::length($val))).$val if CORE::length($val) < 8;
! $val = ord(pack('B8',$val));
! # print "$val ",substr($$bs,$i,16),"\n";
! $i -= 8; $len --;
! $x += $mul * $val if $val != 0;
! $mul *= $x256 if $len >= 0; # skip last mul
! }
! }
! $x->{sign} = $sign if !$x->is_zero();
! return $x;
! }
! sub _split
! {
! # (ref to num_str) return num_str
! # internal, take apart a string and return the pieces
! my $x = shift;
!
! # pre-parse input
! $$x =~ s/^\s+//g; # strip white space at front
! $$x =~ s/\s+$//g; # strip white space at end
! #$$x =~ s/\s+//g; # strip white space (no longer)
! return if $$x eq "";
!
! return _from_hex($x) if $$x =~ /^[\-\+]?0x/; # hex string
! return _from_bin($x) if $$x =~ /^[\-\+]?0b/; # binary string
!
! return if $$x !~ /^[\-\+]?\.?[0-9]/;
!
! $$x =~ s/(\d)_(\d)/$1$2/g; # strip underscores between digits
! $$x =~ s/(\d)_(\d)/$1$2/g; # do twice for 1_2_3
!
! # some possible inputs:
! # 2.1234 # 0.12 # 1 # 1E1 # 2.134E1 # 434E-10 # 1.02009E-2
! # .2 # 1_2_3.4_5_6 # 1.4E1_2_3 # 1e3 # +.2
!
! #print "input: '$$x' ";
! my ($m,$e) = split /[Ee]/,$$x;
! $e = '0' if !defined $e || $e eq "";
! # print "m '$m' e '$e'\n";
! # sign,value for exponent,mantint,mantfrac
! my ($es,$ev,$mis,$miv,$mfv);
! # valid exponent?
! if ($e =~ /^([+-]?)0*(\d+)$/) # strip leading zeros
! {
! $es = $1; $ev = $2;
! #print "'$m' '$e' e: $es $ev ";
! # valid mantissa?
! return if $m eq '.' || $m eq '';
! my ($mi,$mf) = split /\./,$m;
! $mi = '0' if !defined $mi;
! $mi .= '0' if $mi =~ /^[\-\+]?$/;
! $mf = '0' if !defined $mf || $mf eq '';
! if ($mi =~ /^([+-]?)0*(\d+)$/) # strip leading zeros
! {
! $mis = $1||'+'; $miv = $2;
! # print "$mis $miv";
! # valid, existing fraction part of mantissa?
! return unless ($mf =~ /^(\d*?)0*$/); # strip trailing zeros
! $mfv = $1;
! #print " split: $mis $miv . $mfv E $es $ev\n";
! return (\$mis,\$miv,\$mfv,\$es,\$ev);
! }
}
! return; # NaN, not a number
! }
! sub as_number
! {
! # an object might be asked to return itself as bigint on certain overloaded
! # operations, this does exactly this, so that sub classes can simple inherit
! # it or override with their own integer conversion routine
! my $self = shift;
+ return $self->copy();
+ }
+
+ ##############################################################################
+ # internal calculation routines (others are in Math::BigInt::Calc etc)
+
+ sub cmp
+ {
+ # post-normalized compare for internal use (honors signs)
+ # input: ref to value, ref to value, sign, sign
+ # output: <0, 0, >0
+ my ($cx,$cy,$sx,$sy) = @_;
+
+ if ($sx eq '+')
+ {
+ return 1 if $sy eq '-'; # 0 check handled above
+ #return acmp($cx,$cy);
+ return $CALC->_acmp($cx,$cy);
+ }
+ else
+ {
+ # $sx eq '-'
+ return -1 if $sy eq '+';
+ #return acmp($cy,$cx);
+ return $CALC->_acmp($cy,$cx);
+ }
+ return 0; # equal
+ }
+
+ sub _lcm
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # does modify first argument
+ # LCM
+
+ my $x = shift; my $ty = shift;
+ return $x->bnan() if ($x->{sign} eq $nan) || ($ty->{sign} eq $nan);
+ return $x * $ty / bgcd($x,$ty);
+ }
+
+ sub _gcd
+ {
+ # (BINT or num_str, BINT or num_str) return BINT
+ # does modify first arg
+ # GCD -- Euclids algorithm E, Knuth Vol 2 pg 296
+
+ my $x = shift; my $ty = $class->new(shift); # preserve y, but make class
+ return $x->bnan() if $x->{sign} !~ /^[+-]$/ || $ty->{sign} !~ /^[+-]$/;
+
+ while (!$ty->is_zero())
+ {
+ ($x, $ty) = ($ty,bmod($x,$ty));
+ }
+ $x;
+ }
+
+ ###############################################################################
+ # this method return 0 if the object can be modified, or 1 for not
+ # We use a fast use constant statement here, to avoid costly calls. Subclasses
+ # may override it with special code (f.i. Math::BigInt::Constant does so)
+
+ sub modify () { 0; }
+
1;
__END__
***************
*** 437,520 ****
=head1 SYNOPSIS
use Math::BigInt;
- $i = Math::BigInt->new($string);
! $i->bneg return BINT negation
! $i->babs return BINT absolute value
! $i->bcmp(BINT) return CODE compare numbers (undef,<0,=0,>0)
! $i->badd(BINT) return BINT addition
! $i->bsub(BINT) return BINT subtraction
! $i->bmul(BINT) return BINT multiplication
! $i->bdiv(BINT) return (BINT,BINT) division (quo,rem) just quo if scalar
! $i->bmod(BINT) return BINT modulus
! $i->bgcd(BINT) return BINT greatest common divisor
! $i->bnorm return BINT normalization
! $i->blsft(BINT) return BINT left shift
! $i->brsft(BINT) return (BINT,BINT) right shift (quo,rem) just quo if scalar
! $i->band(BINT) return BINT bit-wise and
! $i->bior(BINT) return BINT bit-wise inclusive or
! $i->bxor(BINT) return BINT bit-wise exclusive or
! $i->bnot return BINT bit-wise not
=head1 DESCRIPTION
! All basic math operations are overloaded if you declare your big
! integers as
! $i = new Math::BigInt '123 456 789 123 456 789';
=over 2
=item Canonical notation
! Big integer value are strings of the form C</^[+-]\d+$/> with leading
zeros suppressed.
=item Input
! Input values to these routines may be strings of the form
! C</^\s*[+-]?[\d\s]+$/>.
=item Output
! Output values always always in canonical form
=back
! Actual math is done in an internal format consisting of an array
! whose first element is the sign (/^[+-]$/) and whose remaining
! elements are base 100000 digits with the least significant digit first.
! The string 'NaN' is used to represent the result when input arguments
! are not numbers, as well as the result of dividing by zero.
=head1 EXAMPLES
! '+0' canonical zero value
! ' -123 123 123' canonical value '-123123123'
! '1 23 456 7890' canonical value '+1234567890'
=head1 Autocreating constants
! After C<use Math::BigInt ':constant'> all the integer decimal constants
! in the given scope are converted to C<Math::BigInt>. This conversion
happens at compile time.
! In particular
! perl -MMath::BigInt=:constant -e 'print 2**100'
! print the integer value of C<2**100>. Note that without conversion of
! constants the expression 2**100 will be calculated as floating point number.
=head1 BUGS
! The current version of this module is a preliminary version of the
! real thing that is currently (as of perl5.002) under development.
! =head1 AUTHOR
! Mark Biggar, overloaded interface by Ilya Zakharevich.
=cut
--- 1842,2711 ----
=head1 SYNOPSIS
use Math::BigInt;
! # Number creation
! $x = Math::BigInt->new($str); # defaults to 0
! $nan = Math::BigInt->bnan(); # create a NotANumber
! $zero = Math::BigInt->bzero();# create a "+0"
+ # Testing
+ $x->is_zero(); # return whether arg is zero or not
+ $x->is_nan(); # return whether arg is NaN or not
+ $x->is_one(); # true if arg is +1
+ $x->is_one('-'); # true if arg is -1
+ $x->is_odd(); # true if odd, false for even
+ $x->is_even(); # true if even, false for odd
+ $x->is_positive(); # true if >= 0
+ $x->is_negative(); # true if < 0
+ $x->is_inf(sign); # true if +inf, or -inf (sign is default '+')
+
+ $x->bcmp($y); # compare numbers (undef,<0,=0,>0)
+ $x->bacmp($y); # compare absolutely (undef,<0,=0,>0)
+ $x->sign(); # return the sign, either +,- or NaN
+ $x->digit($n); # return the nth digit, counting from right
+ $x->digit(-$n); # return the nth digit, counting from left
+
+ # The following all modify their first argument:
+
+ # set
+ $x->bzero(); # set $x to 0
+ $x->bnan(); # set $x to NaN
+
+ $x->bneg(); # negation
+ $x->babs(); # absolute value
+ $x->bnorm(); # normalize (no-op)
+ $x->bnot(); # two's complement (bit wise not)
+ $x->binc(); # increment x by 1
+ $x->bdec(); # decrement x by 1
+
+ $x->badd($y); # addition (add $y to $x)
+ $x->bsub($y); # subtraction (subtract $y from $x)
+ $x->bmul($y); # multiplication (multiply $x by $y)
+ $x->bdiv($y); # divide, set $x to quotient
+ # return (quo,rem) or quo if scalar
+
+ $x->bmod($y); # modulus (x % y)
+ $x->bpow($y); # power of arguments (x ** y)
+ $x->blsft($y); # left shift
+ $x->brsft($y); # right shift
+ $x->blsft($y,$n); # left shift, by base $n (like 10)
+ $x->brsft($y,$n); # right shift, by base $n (like 10)
+
+ $x->band($y); # bitwise and
+ $x->bior($y); # bitwise inclusive or
+ $x->bxor($y); # bitwise exclusive or
+ $x->bnot(); # bitwise not (two's complement)
+
+ $x->bsqrt(); # calculate square-root
+
+ $x->round($A,$P,$round_mode); # round to accuracy or precision using mode $r
+ $x->bround($N); # accuracy: preserve $N digits
+ $x->bfround($N); # round to $Nth digit, no-op for BigInts
+
+ # The following do not modify their arguments in BigInt, but do in BigFloat:
+ $x->bfloor(); # return integer less or equal than $x
+ $x->bceil(); # return integer greater or equal than $x
+
+ # The following do not modify their arguments:
+
+ bgcd(@values); # greatest common divisor
+ blcm(@values); # lowest common multiplicator
+
+ $x->bstr(); # normalized string
+ $x->bsstr(); # normalized string in scientific notation
+ $x->length(); # return number of digits in number
+ ($x,$f) = $x->length(); # length of number and length of fraction part
+
+ $x->exponent(); # return exponent as BigInt
+ $x->mantissa(); # return mantissa as BigInt
+ $x->parts(); # return (mantissa,exponent) as BigInt
+ $x->copy(); # make a true copy of $x (unlike $y = $x;)
+ $x->as_number(); # return as BigInt (in BigInt: same as copy())
+
=head1 DESCRIPTION
! All operators (inlcuding basic math operations) are overloaded if you
! declare your big integers as
! $i = new Math::BigInt '123_456_789_123_456_789';
+ Operations with overloaded operators preserve the arguments which is
+ exactly what you expect.
=over 2
=item Canonical notation
! Big integer values are strings of the form C</^[+-]\d+$/> with leading
zeros suppressed.
+ '-0' canonical value '-0', normalized '0'
+ ' -123_123_123' canonical value '-123123123'
+ '1_23_456_7890' canonical value '1234567890'
+
=item Input
! Input values to these routines may be either Math::BigInt objects or
! strings of the form C</^\s*[+-]?[\d]+\.?[\d]*E?[+-]?[\d]*$/>.
+ You can include one underscore between any two digits.
+
+ This means integer values like 1.01E2 or even 1000E-2 are also accepted.
+ Non integer values result in NaN.
+
+ Math::BigInt::new() defaults to 0, while Math::BigInt::new('') results
+ in 'NaN'.
+
+ bnorm() on a BigInt object is now effectively a no-op, since the numbers
+ are always stored in normalized form. On a string, it creates a BigInt
+ object.
+
=item Output
! Output values are BigInt objects (normalized), except for bstr(), which
! returns a string in normalized form.
! Some routines (C<is_odd()>, C<is_even()>, C<is_zero()>, C<is_one()>,
! C<is_nan()>) return true or false, while others (C<bcmp()>, C<bacmp()>)
! return either undef, <0, 0 or >0 and are suited for sort.
=back
! =head1 ACCURACY and PRECISION
+ Since version v1.33, Math::BigInt and Math::BigFloat have full support for
+ accuracy and precision based rounding, both automatically after every
+ operation as well as manually.
+
+ This section describes the accuracy/precision handling in Math::Big* as it
+ used to be and as it is now, complete with an explanation of all terms and
+ abbreviations.
+
+ Not yet implemented things (but with correct description) are marked with '!',
+ things that need to be answered are marked with '?'.
+
+ In the next paragraph follows a short description of terms used here (because
+ these may differ from terms used by other people or documentation).
+
+ During the rest of this document, the shortcuts A (for accuracy), P (for
+ precision), F (fallback) and R (rounding mode) will be used.
+
+ =head2 Precision P
+
+ A fixed number of digits before (positive) or after (negative)
+ the decimal point. For example, 123.45 has a precision of -2. 0 means an
+ integer like 123 (or 120). A precision of 2 means two digits to the left
+ of the decimal point are zero, so 123 with P = 1 becomes 120. Note that
+ numbers with zeros before the decimal point may have different precisions,
+ because 1200 can have p = 0, 1 or 2 (depending on what the inital value
+ was). It could also have p < 0, when the digits after the decimal point
+ are zero.
+
+ !The string output of such a number should be padded with zeros:
+ !
+ ! Initial value P Result String
+ ! 1234.01 -3 1000 1000
+ ! 1234 -2 1200 1200
+ ! 1234.5 -1 1230 1230
+ ! 1234.001 1 1234 1234.0
+ ! 1234.01 0 1234 1234
+ ! 1234.01 2 1234.01 1234.01
+ ! 1234.01 5 1234.01 1234.01000
+
+ =head2 Accuracy A
+
+ Number of significant digits. Leading zeros are not counted. A
+ number may have an accuracy greater than the non-zero digits
+ when there are zeros in it or trailing zeros. For example, 123.456 has
+ A of 6, 10203 has 5, 123.0506 has 7, 123.450000 has 8 and 0.000123 has 3.
+
+ =head2 Fallback F
+
+ When both A and P are undefined, this is used as a fallback accuracy.
+
+ =head2 Rounding mode R
+
+ When rounding a number, different 'styles' or 'kinds'
+ of rounding are possible. (Note that random rounding, as in
+ Math::Round, is not implemented.)
+
+ =over 2
+
+ =item 'trunc'
+
+ truncation invariably removes all digits following the
+ rounding place, replacing them with zeros. Thus, 987.65 rounded
+ to tens (P=1) becomes 980, and rounded to the fourth sigdig
+ becomes 987.6 (A=4). 123.456 rounded to the second place after the
+ decimal point (P=-2) becomes 123.46.
+
+ All other implemented styles of rounding attempt to round to the
+ "nearest digit." If the digit D immediately to the right of the
+ rounding place (skipping the decimal point) is greater than 5, the
+ number is incremented at the rounding place (possibly causing a
+ cascade of incrementation): e.g. when rounding to units, 0.9 rounds
+ to 1, and -19.9 rounds to -20. If D < 5, the number is similarly
+ truncated at the rounding place: e.g. when rounding to units, 0.4
+ rounds to 0, and -19.4 rounds to -19.
+
+ However the results of other styles of rounding differ if the
+ digit immediately to the right of the rounding place (skipping the
+ decimal point) is 5 and if there are no digits, or no digits other
+ than 0, after that 5. In such cases:
+
+ =item 'even'
+
+ rounds the digit at the rounding place to 0, 2, 4, 6, or 8
+ if it is not already. E.g., when rounding to the first sigdig, 0.45
+ becomes 0.4, -0.55 becomes -0.6, but 0.4501 becomes 0.5.
+
+ =item 'odd'
+
+ rounds the digit at the rounding place to 1, 3, 5, 7, or 9 if
+ it is not already. E.g., when rounding to the first sigdig, 0.45
+ becomes 0.5, -0.55 becomes -0.5, but 0.5501 becomes 0.6.
+
+ =item '+inf'
+
+ round to plus infinity, i.e. always round up. E.g., when
+ rounding to the first sigdig, 0.45 becomes 0.5, -0.55 becomes -0.5,
+ and 0.4501 also becomes 0.5.
+
+ =item '-inf'
+
+ round to minus infinity, i.e. always round down. E.g., when
+ rounding to the first sigdig, 0.45 becomes 0.4, -0.55 becomes -0.6,
+ but 0.4501 becomes 0.5.
+
+ =item 'zero'
+
+ round to zero, i.e. positive numbers down, negative ones up.
+ E.g., when rounding to the first sigdig, 0.45 becomes 0.4, -0.55
+ becomes -0.5, but 0.4501 becomes 0.5.
+
+ =back
+
+ The handling of A & P in MBI/MBF (the old core code shipped with Perl
+ versions <= 5.7.2) is like this:
+
+ =over 2
+
+ =item Precision
+
+ * ffround($p) is able to round to $p number of digits after the decimal
+ point
+ * otherwise P is unused
+
+ =item Accuracy (significant digits)
+
+ * fround($a) rounds to $a significant digits
+ * only fdiv() and fsqrt() take A as (optional) paramater
+ + other operations simply create the same number (fneg etc), or more (fmul)
+ of digits
+ + rounding/truncating is only done when explicitly calling one of fround
+ or ffround, and never for BigInt (not implemented)
+ * fsqrt() simply hands its accuracy argument over to fdiv.
+ * the documentation and the comment in the code indicate two different ways
+ on how fdiv() determines the maximum number of digits it should calculate,
+ and the actual code does yet another thing
+ POD:
+ max($Math::BigFloat::div_scale,length(dividend)+length(divisor))
+ Comment:
+ result has at most max(scale, length(dividend), length(divisor)) digits
+ Actual code:
+ scale = max(scale, length(dividend)-1,length(divisor)-1);
+ scale += length(divisior) - length(dividend);
+ So for lx = 3, ly = 9, scale = 10, scale will actually be 16 (10+9-3).
+ Actually, the 'difference' added to the scale is calculated from the
+ number of "significant digits" in dividend and divisor, which is derived
+ by looking at the length of the mantissa. Which is wrong, since it includes
+ the + sign (oups) and actually gets 2 for '+100' and 4 for '+101'. Oups
+ again. Thus 124/3 with div_scale=1 will get you '41.3' based on the strange
+ assumption that 124 has 3 significant digits, while 120/7 will get you
+ '17', not '17.1' since 120 is thought to have 2 significant digits.
+ The rounding after the division then uses the reminder and $y to determine
+ wether it must round up or down.
+ ? I have no idea which is the right way. That's why I used a slightly more
+ ? simple scheme and tweaked the few failing testcases to match it.
+
+ =back
+
+ This is how it works now:
+
+ =over 2
+
+ =item Setting/Accessing
+
+ * You can set the A global via $Math::BigInt::accuracy or
+ $Math::BigFloat::accuracy or whatever class you are using.
+ * You can also set P globally by using $Math::SomeClass::precision likewise.
+ * Globals are classwide, and not inherited by subclasses.
+ * to undefine A, use $Math::SomeCLass::accuracy = undef
+ * to undefine P, use $Math::SomeClass::precision = undef
+ * To be valid, A must be > 0, P can have any value.
+ * If P is negative, this means round to the P'th place to the right of the
+ decimal point; positive values mean to the left of the decimal point.
+ P of 0 means round to integer.
+ * to find out the current global A, take $Math::SomeClass::accuracy
+ * use $x->accuracy() for the local setting of $x.
+ * to find out the current global P, take $Math::SomeClass::precision
+ * use $x->precision() for the local setting
+
+ =item Creating numbers
+
+ !* When you create a number, there should be a way to define its A & P
+ * When a number without specific A or P is created, but the globals are
+ defined, these should be used to round the number immediately and also
+ stored locally with the number. Thus changing the global defaults later on
+ will not change the A or P of previously created numbers (i.e., A and P of
+ $x will be what was in effect when $x was created)
+
+ =item Usage
+
+ * If A or P are enabled/defined, they are used to round the result of each
+ operation according to the rules below
+ * Negative P is ignored in Math::BigInt, since BigInts never have digits
+ after the decimal point
+ !* Math::BigFloat uses Math::BigInts internally, but setting A or P inside
+ ! Math::BigInt as globals should not tamper with the parts of a BigFloat.
+ ! Thus a flag is used to mark all Math::BigFloat numbers as 'never round'
+
+ =item Precedence
+
+ * It only makes sense that a number has only one of A or P at a time.
+ Since you can set/get both A and P, there is a rule that will practically
+ enforce only A or P to be in effect at a time, even if both are set.
+ This is called precedence.
+ !* If two objects are involved in an operation, and one of them has A in
+ ! effect, and the other P, this should result in a warning or an error,
+ ! probably in NaN.
+ * A takes precendence over P (Hint: A comes before P). If A is defined, it
+ is used, otherwise P is used. If neither of them is defined, nothing is
+ used, i.e. the result will have as many digits as it can (with an
+ exception for fdiv/fsqrt) and will not be rounded.
+ * There is another setting for fdiv() (and thus for fsqrt()). If neither of
+ A or P is defined, fdiv() will use a fallback (F) of $div_scale digits.
+ If either the dividend's or the divisor's mantissa has more digits than
+ the value of F, the higher value will be used instead of F.
+ This is to limit the digits (A) of the result (just consider what would
+ happen with unlimited A and P in the case of 1/3 :-)
+ * fdiv will calculate 1 more digit than required (determined by
+ A, P or F), and, if F is not used, round the result
+ (this will still fail in the case of a result like 0.12345000000001 with A
+ or P of 5, but this cannot be helped - or can it?)
+ * Thus you can have the math done by on Math::Big* class in three modes:
+ + never round (this is the default):
+ This is done by setting A and P to undef. No math operation
+ will round the result, with fdiv() and fsqrt() as exceptions to guard
+ against overflows. You must explicitely call bround(), bfround() or
+ round() (the latter with parameters).
+ Note: Once you have rounded a number, the settings will 'stick' on it
+ and 'infect' all other numbers engaged in math operations with it, since
+ local settings have the highest precedence. So, to get SaferRound[tm],
+ use a copy() before rounding like this:
+
+ $x = Math::BigFloat->new(12.34);
+ $y = Math::BigFloat->new(98.76);
+ $z = $x * $y; # 1218.6984
+ print $x->copy()->fround(3); # 12.3 (but A is now 3!)
+ $z = $x * $y; # still 1218.6984, without
+ # copy would have been 1210!
+
+ + round after each op:
+ After each single operation (except for testing like is_zero()), the
+ method round() is called and the result is rounded appropriately. By
+ setting proper values for A and P, you can have all-the-same-A or
+ all-the-same-P modes. For example, Math::Currency might set A to undef,
+ and P to -2, globally.
+
+ ?Maybe an extra option that forbids local A & P settings would be in order,
+ ?so that intermediate rounding does not 'poison' further math?
+
+ =item Overriding globals
+
+ * you will be able to give A, P and R as an argument to all the calculation
+ routines; the second parameter is A, the third one is P, and the fourth is
+ R (shift place by one for binary operations like add). P is used only if
+ the first parameter (A) is undefined. These three parameters override the
+ globals in the order detailed as follows, i.e. the first defined value
+ wins:
+ (local: per object, global: global default, parameter: argument to sub)
+ + parameter A
+ + parameter P
+ + local A (if defined on both of the operands: smaller one is taken)
+ + local P (if defined on both of the operands: smaller one is taken)
+ + global A
+ + global P
+ + global F
+ * fsqrt() will hand its arguments to fdiv(), as it used to, only now for two
+ arguments (A and P) instead of one
+
+ =item Local settings
+
+ * You can set A and P locally by using $x->accuracy() and $x->precision()
+ and thus force different A and P for different objects/numbers.
+ * Setting A or P this way immediately rounds $x to the new value.
+
+ =item Rounding
+
+ * the rounding routines will use the respective global or local settings.
+ fround()/bround() is for accuracy rounding, while ffround()/bfround()
+ is for precision
+ * the two rounding functions take as the second parameter one of the
+ following rounding modes (R):
+ 'even', 'odd', '+inf', '-inf', 'zero', 'trunc'
+ * you can set and get the global R by using Math::SomeClass->round_mode()
+ or by setting $Math::SomeClass::rnd_mode
+ * after each operation, $result->round() is called, and the result may
+ eventually be rounded (that is, if A or P were set either locally,
+ globally or as parameter to the operation)
+ * to manually round a number, call $x->round($A,$P,$rnd_mode);
+ this will round the number by using the appropriate rounding function
+ and then normalize it.
+ * rounding modifies the local settings of the number:
+
+ $x = Math::BigFloat->new(123.456);
+ $x->accuracy(5);
+ $x->bround(4);
+
+ Here 4 takes precedence over 5, so 123.5 is the result and $x->accuracy()
+ will be 4 from now on.
+
+ =item Default values
+
+ * R: 'even'
+ * F: 40
+ * A: undef
+ * P: undef
+
+ =item Remarks
+
+ * The defaults are set up so that the new code gives the same results as
+ the old code (except in a few cases on fdiv):
+ + Both A and P are undefined and thus will not be used for rounding
+ after each operation.
+ + round() is thus a no-op, unless given extra parameters A and P
+
+ =back
+
+ =head1 INTERNALS
+
+ The actual numbers are stored as unsigned big integers, and math with them is
+ done (by default) by a module called Math::BigInt::Calc. This is equivalent to:
+
+ use Math::BigInt lib => 'calc';
+
+ You can change this by using:
+
+ use Math::BigInt lib => 'BitVect';
+
+ ('Math::BitInt::BitVect' works, too.)
+
+ Calc.pm uses as internal format an array of elements of base 100000 digits
+ with the least significant digit first, BitVect.pm uses a bit vector of base 2,
+ most significant bit first.
+
+ The sign C</^[+-]$/> is stored separately. The string 'NaN' is used to
+ represent the result when input arguments are not numbers. '+inf' and
+ '-inf' represent infinity.
+
+ You should neither care about nor depend on the internal representation; it
+ might change without notice. Use only method calls like C<< $x->sign(); >>
+ instead of relying on the internal hash keys like in C<< $x->{sign}; >>.
+
+ =head2 mantissa(), exponent() and parts()
+
+ C<mantissa()> and C<exponent()> return the said parts of the BigInt such
+ that:
+
+ $m = $x->mantissa();
+ $e = $x->exponent();
+ $y = $m * ( 10 ** $e );
+ print "ok\n" if $x == $y;
+
+ C<< ($m,$e) = $x->parts() >> is just a shortcut that gives you both of them
+ in one go. Both the returned mantissa and exponent have a sign.
+
+ Currently, for BigInts C<$e> will be always 0, except for NaN where it will be
+ NaN and for $x == 0, then it will be 1 (to be compatible with Math::BigFloat's
+ internal representation of a zero as C<0E1>).
+
+ C<$m> will always be a copy of the original number. The relation between $e
+ and $m might change in the future, but will always be equivalent in a
+ numerical sense, e.g. $m might get minimized.
+
=head1 EXAMPLES
+
+ use Math::BigInt qw(bstr bint);
+ $x = bstr("1234") # string "1234"
+ $x = "$x"; # same as bstr()
+ $x = bneg("1234") # Bigint "-1234"
+ $x = Math::BigInt->bneg("1234"); # Bigint "-1234"
+ $x = Math::BigInt->babs("-12345"); # Bigint "12345"
+ $x = Math::BigInt->bnorm("-0 00"); # BigInt "0"
+ $x = bint(1) + bint(2); # BigInt "3"
+ $x = bint(1) + "2"; # ditto (auto-BigIntify of "2")
+ $x = bint(1); # BigInt "1"
+ $x = $x + 5 / 2; # BigInt "3"
+ $x = $x ** 3; # BigInt "27"
+ $x *= 2; # BigInt "54"
+ $x = new Math::BigInt; # BigInt "0"
+ $x--; # BigInt "-1"
+ $x = Math::BigInt->badd(4,5) # BigInt "9"
+ $x = Math::BigInt::badd(4,5) # BigInt "9"
+ print $x->bsstr(); # 9e+0
! Examples for rounding:
+ use Math::BigFloat;
+ use Test;
+ $x = Math::BigFloat->new(123.4567);
+ $y = Math::BigFloat->new(123.456789);
+ $Math::BigFloat::accuracy = 4; # no more A than 4
+
+ ok ($x->copy()->fround(),123.4); # even rounding
+ print $x->copy()->fround(),"\n"; # 123.4
+ Math::BigFloat->round_mode('odd'); # round to odd
+ print $x->copy()->fround(),"\n"; # 123.5
+ $Math::BigFloat::accuracy = 5; # no more A than 5
+ Math::BigFloat->round_mode('odd'); # round to odd
+ print $x->copy()->fround(),"\n"; # 123.46
+ $y = $x->copy()->fround(4),"\n"; # A = 4: 123.4
+ print "$y, ",$y->accuracy(),"\n"; # 123.4, 4
+
+ $Math::BigFloat::accuracy = undef; # A not important
+ $Math::BigFloat::precision = 2; # P important
+ print $x->copy()->bnorm(),"\n"; # 123.46
+ print $x->copy()->fround(),"\n"; # 123.46
+
=head1 Autocreating constants
! After C<use Math::BigInt ':constant'> all the B<integer> decimal constants
! in the given scope are converted to C<Math::BigInt>. This conversion
happens at compile time.
! In particular,
! perl -MMath::BigInt=:constant -e 'print 2**100,"\n"'
! prints the integer value of C<2**100>. Note that without conversion of
! constants the expression 2**100 will be calculated as perl scalar.
+ Please note that strings and floating point constants are not affected,
+ so that
+
+ use Math::BigInt qw/:constant/;
+
+ $x = 1234567890123456789012345678901234567890
+ + 123456789123456789;
+ $y = '1234567890123456789012345678901234567890'
+ + '123456789123456789';
+
+ do not work. You need an explicit Math::BigInt->new() around one of the
+ operands.
+
+ =head1 PERFORMANCE
+
+ Using the form $x += $y; etc over $x = $x + $y is faster, since a copy of $x
+ must be made in the second case. For long numbers, the copy can eat up to 20%
+ of the work (in the case of addition/subtraction, less for
+ multiplication/division). If $y is very small compared to $x, the form
+ $x += $y is MUCH faster than $x = $x + $y since making the copy of $x takes
+ more time then the actual addition.
+
+ With a technique called copy-on-write, the cost of copying with overload could
+ be minimized or even completely avoided. This is currently not implemented.
+
+ The new version of this module is slower on new(), bstr() and numify(). Some
+ operations may be slower for small numbers, but are significantly faster for
+ big numbers. Other operations are now constant (O(1), like bneg(), babs()
+ etc), instead of O(N) and thus nearly always take much less time.
+
+ For more benchmark results see http://bloodgate.com/perl/benchmarks.html
+
+ =head2 Replacing the math library
+
+ You can use an alternative library to drive Math::BigInt via:
+
+ use Math::BigInt lib => 'Module';
+
+ The default is called Math::BigInt::Calc and is a pure-perl base 100,000
+ math package that consists of the standard routine present in earlier versions
+ of Math::BigInt.
+
+ There are also Math::BigInt::Scalar (primarily for testing) and
+ Math::BigInt::BitVect; these and others can be found via
+ L<http://search.cpan.org/>:
+
+ use Math::BigInt lib => 'BitVect';
+
+ my $x = Math::BigInt->new(2);
+ print $x ** (1024*1024);
+
=head1 BUGS
! =over 2
! =item :constant and eval()
! Under Perl prior to 5.6.0 having an C<use Math::BigInt ':constant';> and
! C<eval()> in your code will crash with "Out of memory". This is probably an
! overload/exporter bug. You can workaround by not having C<eval()>
! and ':constant' at the same time or upgrade your Perl.
!
! =back
!
! =head1 CAVEATS
!
! Some things might not work as you expect them. Below is documented what is
! known to be troublesome:
!
! =over 1
!
! =item stringify, bstr(), bsstr() and 'cmp'
!
! Both stringify and bstr() now drop the leading '+'. The old code would return
! '+3', the new returns '3'. This is to be consistent with Perl and to make
! cmp (especially with overloading) to work as you expect. It also solves
! problems with Test.pm, it's ok() uses 'eq' internally.
!
! Mark said, when asked about to drop the '+' altogether, or make only cmp work:
!
! I agree (with the first alternative), don't add the '+' on positive
! numbers. It's not as important anymore with the new internal
! form for numbers. It made doing things like abs and neg easier,
! but those have to be done differently now anyway.
!
! So, the following examples will now work all as expected:
!
! use Test;
! BEGIN { plan tests => 1 }
! use Math::BigInt;
!
! my $x = new Math::BigInt 3*3;
! my $y = new Math::BigInt 3*3;
!
! ok ($x,3*3);
! print "$x eq 9" if $x eq $y;
! print "$x eq 9" if $x eq '9';
! print "$x eq 9" if $x eq 3*3;
!
! Additionally, the following still works:
!
! print "$x == 9" if $x == $y;
! print "$x == 9" if $x == 9;
! print "$x == 9" if $x == 3*3;
!
! There is now a C<bsstr()> method to get the string in scientific notation aka
! C<1e+2> instead of C<100>. Be advised that overloaded 'eq' always uses bstr()
! for comparisation, but Perl will represent some numbers as 100 and others
! as 1e+308. If in doubt, convert both arguments to Math::BigInt before doing eq:
!
! use Test;
! BEGIN { plan tests => 3 }
! use Math::BigInt;
!
! $x = Math::BigInt->new('1e56'); $y = 1e56;
! ok ($x,$y); # will fail
! ok ($x->bsstr(),$y); # okay
! $y = Math::BigInt->new($y);
! ok ($x,$y); # okay
!
! =item int()
!
! C<int()> will return (at least for Perl v5.7.1 and up) another BigInt, not a
! Perl scalar:
!
! $x = Math::BigInt->new(123);
! $y = int($x); # BigInt 123
! $x = Math::BigFloat->new(123.45);
! $y = int($x); # BigInt 123
!
! In all Perl versions you can use C<as_number()> for the same effect:
!
! $x = Math::BigFloat->new(123.45);
! $y = $x->as_number(); # BigInt 123
!
! This also works for other subclasses, like Math::String.
!
! =item bdiv
!
! The following will probably not do what you expect:
!
! print $c->bdiv(10000),"\n";
!
! It prints both quotient and reminder since print calls C<bdiv()> in list
! context. Also, C<bdiv()> will modify $c, so be carefull. You probably want
! to use
!
! print $c / 10000,"\n";
! print scalar $c->bdiv(10000),"\n"; # or if you want to modify $c
!
! instead.
!
! The quotient is always the greatest integer less than or equal to the
! real-valued quotient of the two operands, and the remainder (when it is
! nonzero) always has the same sign as the second operand; so, for
! example,
!
! 1 / 4 => ( 0, 1)
! 1 / -4 => (-1,-3)
! -3 / 4 => (-1, 1)
! -3 / -4 => ( 0,-3)
!
! As a consequence, the behavior of the operator % agrees with the
! behavior of Perl's built-in % operator (as documented in the perlop
! manpage), and the equation
!
! $x == ($x / $y) * $y + ($x % $y)
!
! holds true for any $x and $y, which justifies calling the two return
! values of bdiv() the quotient and remainder.
!
! Perl's 'use integer;' changes the behaviour of % and / for scalars, but will
! not change BigInt's way to do things. This is because under 'use integer' Perl
! will do what the underlying C thinks is right and this is different for each
! system. If you need BigInt's behaving exactly like Perl's 'use integer', bug
! the author to implement it ;)
!
! =item Modifying and =
!
! Beware of:
!
! $x = Math::BigFloat->new(5);
! $y = $x;
!
! It will not do what you think, e.g. making a copy of $x. Instead it just makes
! a second reference to the B<same> object and stores it in $y. Thus anything
! that modifies $x will modify $y, and vice versa.
!
! $x->bmul(2);
! print "$x, $y\n"; # prints '10, 10'
!
! If you want a true copy of $x, use:
!
! $y = $x->copy();
!
! See also the documentation for overload.pm regarding C<=>.
!
! =item bpow
!
! C<bpow()> (and the rounding functions) now modifies the first argument and
! return it, unlike the old code which left it alone and only returned the
! result. This is to be consistent with C<badd()> etc. The first three will
! modify $x, the last one won't:
!
! print bpow($x,$i),"\n"; # modify $x
! print $x->bpow($i),"\n"; # ditto
! print $x **= $i,"\n"; # the same
! print $x ** $i,"\n"; # leave $x alone
!
! The form C<$x **= $y> is faster than C<$x = $x ** $y;>, though.
!
! =item Overloading -$x
!
! The following:
!
! $x = -$x;
!
! is slower than
!
! $x->bneg();
!
! since overload calls C<sub($x,0,1);> instead of C<neg($x)>. The first variant
! needs to preserve $x since it does not know that it later will get overwritten.
! This makes a copy of $x and takes O(N), but $x->bneg() is O(1).
!
! With Copy-On-Write, this issue will be gone. Stay tuned...
!
! =item Mixing different object types
!
! In Perl you will get a floating point value if you do one of the following:
!
! $float = 5.0 + 2;
! $float = 2 + 5.0;
! $float = 5 / 2;
!
! With overloaded math, only the first two variants will result in a BigFloat:
!
! use Math::BigInt;
! use Math::BigFloat;
!
! $mbf = Math::BigFloat->new(5);
! $mbi2 = Math::BigInteger->new(5);
! $mbi = Math::BigInteger->new(2);
!
! # what actually gets called:
! $float = $mbf + $mbi; # $mbf->badd()
! $float = $mbf / $mbi; # $mbf->bdiv()
! $integer = $mbi + $mbf; # $mbi->badd()
! $integer = $mbi2 / $mbi; # $mbi2->bdiv()
! $integer = $mbi2 / $mbf; # $mbi2->bdiv()
!
! This is because math with overloaded operators follows the first (dominating)
! operand, this one's operation is called and returns thus the result. So,
! Math::BigInt::bdiv() will always return a Math::BigInt, regardless whether
! the result should be a Math::BigFloat or the second operant is one.
!
! To get a Math::BigFloat you either need to call the operation manually,
! make sure the operands are already of the proper type or casted to that type
! via Math::BigFloat->new():
!
! $float = Math::BigFloat->new($mbi2) / $mbi; # = 2.5
!
! Beware of simple "casting" the entire expression, this would only convert
! the already computed result:
!
! $float = Math::BigFloat->new($mbi2 / $mbi); # = 2.0 thus wrong!
!
! Beware also of the order of more complicated expressions like:
!
! $integer = ($mbi2 + $mbi) / $mbf; # int / float => int
! $integer = $mbi2 / Math::BigFloat->new($mbi); # ditto
!
! If in doubt, break the expression into simpler terms, or cast all operands
! to the desired resulting type.
!
! Scalar values are a bit different, since:
!
! $float = 2 + $mbf;
! $float = $mbf + 2;
!
! will both result in the proper type due to the way the overloaded math works.
!
! This section also applies to other overloaded math packages, like Math::String.
!
! =item bsqrt()
!
! C<bsqrt()> works only good if the result is an big integer, e.g. the square
! root of 144 is 12, but from 12 the square root is 3, regardless of rounding
! mode.
!
! If you want a better approximation of the square root, then use:
!
! $x = Math::BigFloat->new(12);
! $Math::BigFloat::precision = 0;
! Math::BigFloat->round_mode('even');
! print $x->copy->bsqrt(),"\n"; # 4
!
! $Math::BigFloat::precision = 2;
! print $x->bsqrt(),"\n"; # 3.46
! print $x->bsqrt(3),"\n"; # 3.464
!
! =back
!
! =head1 LICENSE
!
! This program is free software; you may redistribute it and/or modify it under
! the same terms as Perl itself.
!
! =head1 SEE ALSO
!
! L<Math::BigFloat> and L<Math::Big>.
!
! =head1 AUTHORS
!
! Original code by Mark Biggar, overloaded interface by Ilya Zakharevich.
! Completely rewritten by Tels http://bloodgate.com in late 2000, 2001.
=cut
diff -c /dev/null 'perl-5.7.2/lib/Math/BigInt/Calc.pm'
Index: ./lib/Math/BigInt/Calc.pm
*** ./lib/Math/BigInt/Calc.pm Thu Jan 1 02:00:00 1970
--- ./lib/Math/BigInt/Calc.pm Tue Jul 10 17:50:05 2001
***************
*** 0 ****
--- 1,622 ----
+ package Math::BigInt::Calc;
+
+ use 5.005;
+ use strict;
+ use warnings;
+
+ require Exporter;
+
+ use vars qw/ @ISA @EXPORT $VERSION/;
+ @ISA = qw(Exporter);
+
+ @EXPORT = qw(
+ _add _mul _div _mod _sub
+ _new
+ _str _num _acmp _len
+ _digit
+ _is_zero _is_one
+ _is_even _is_odd
+ _check _zero _one _copy _zeros
+ );
+ $VERSION = '0.06';
+
+ # Package to store unsigned big integers in decimal and do math with them
+
+ # Internally the numbers are stored in an array with at least 1 element, no
+ # leading zero parts (except the first) and in base 100000
+
+ # todo:
+ # - fully remove funky $# stuff (maybe)
+ # - use integer; vs 1e7 as base
+
+ # USE_MUL: due to problems on certain os (os390, posix-bc) "* 1e-5" is used
+ # instead of "/ 1e5" at some places, (marked with USE_MUL). But instead of
+ # using the reverse only on problematic machines, I used it everytime to avoid
+ # the costly comparisons. This _should_ work everywhere. Thanx Peter Prymmer
+
+ ##############################################################################
+ # global constants, flags and accessory
+
+ # constants for easier life
+ my $nan = 'NaN';
+ my $BASE_LEN = 5;
+ my $BASE = int("1e".$BASE_LEN); # var for trying to change it to 1e7
+ my $RBASE = 1e-5; # see USE_MUL
+ my $class = 'Math::BigInt::Calc';
+
+ ##############################################################################
+ # create objects from various representations
+
+ sub _new
+ {
+ # (string) return ref to num_array
+ # Convert a number from string format to internal base 100000 format.
+ # Assumes normalized value as input.
+ shift @_ if $_[0] eq $class;
+ my $d = shift;
+ # print "_new $d $$d\n";
+ my $il = CORE::length($$d)-1;
+ # these leaves '00000' instead of int 0 and will be corrected after any op
+ return [ reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $$d)) ];
+ }
+
+ sub _zero
+ {
+ # create a zero
+ return [ 0 ];
+ }
+
+ sub _one
+ {
+ # create a one
+ return [ 1 ];
+ }
+
+ sub _copy
+ {
+ shift @_ if $_[0] eq $class;
+ my $x = shift;
+ return [ @$x ];
+ }
+
+ ##############################################################################
+ # convert back to string and number
+
+ sub _str
+ {
+ # (ref to BINT) return num_str
+ # Convert number from internal base 100000 format to string format.
+ # internal format is always normalized (no leading zeros, "-0" => "+0")
+ shift @_ if $_[0] eq $class;
+ my $ar = shift;
+ my $ret = "";
+ my $l = scalar @$ar; # number of parts
+ return $nan if $l < 1; # should not happen
+ # handle first one different to strip leading zeros from it (there are no
+ # leading zero parts in internal representation)
+ $l --; $ret .= $ar->[$l]; $l--;
+ # Interestingly, the pre-padd method uses more time
+ # the old grep variant takes longer (14 to 10 sec)
+ while ($l >= 0)
+ {
+ $ret .= substr('0000'.$ar->[$l],-5); # fastest way I could think of
+ $l--;
+ }
+ return \$ret;
+ }
+
+ sub _num
+ {
+ # Make a number (scalar int/float) from a BigInt object
+ shift @_ if $_[0] eq $class;
+ my $x = shift;
+ return $x->[0] if scalar @$x == 1; # below $BASE
+ my $fac = 1;
+ my $num = 0;
+ foreach (@$x)
+ {
+ $num += $fac*$_; $fac *= $BASE;
+ }
+ return $num;
+ }
+
+ ##############################################################################
+ # actual math code
+
+ sub _add
+ {
+ # (ref to int_num_array, ref to int_num_array)
+ # routine to add two base 1e5 numbers
+ # stolen from Knuth Vol 2 Algorithm A pg 231
+ # there are separate routines to add and sub as per Knuth pg 233
+ # This routine clobbers up array x, but not y.
+
+ shift @_ if $_[0] eq $class;
+ my ($x,$y) = @_;
+
+ # for each in Y, add Y to X and carry. If after that, something is left in
+ # X, foreach in X add carry to X and then return X, carry
+ # Trades one "$j++" for having to shift arrays, $j could be made integer
+ # but this would impose a limit to number-length of 2**32.
+ my $i; my $car = 0; my $j = 0;
+ for $i (@$y)
+ {
+ $x->[$j] -= $BASE
+ if $car = (($x->[$j] += $i + $car) >= $BASE) ? 1 : 0;
+ $j++;
+ }
+ while ($car != 0)
+ {
+ $x->[$j] -= $BASE if $car = (($x->[$j] += $car) >= $BASE) ? 1 : 0; $j++;
+ }
+ return $x;
+ }
+
+ sub _sub
+ {
+ # (ref to int_num_array, ref to int_num_array)
+ # subtract base 1e5 numbers -- stolen from Knuth Vol 2 pg 232, $x > $y
+ # subtract Y from X (X is always greater/equal!) by modifying x in place
+ shift @_ if $_[0] eq $class;
+ my ($sx,$sy,$s) = @_;
+
+ my $car = 0; my $i; my $j = 0;
+ if (!$s)
+ {
+ #print "case 2\n";
+ for $i (@$sx)
+ {
+ last unless defined $sy->[$j] || $car;
+ #print "x: $i y: $sy->[$j] c: $car\n";
+ $i += $BASE if $car = (($i -= ($sy->[$j] || 0) + $car) < 0); $j++;
+ #print "x: $i y: $sy->[$j-1] c: $car\n";
+ }
+ # might leave leading zeros, so fix that
+ __strip_zeros($sx);
+ return $sx;
+ }
+ else
+ {
+ #print "case 1 (swap)\n";
+ for $i (@$sx)
+ {
+ last unless defined $sy->[$j] || $car;
+ #print "$sy->[$j] $i $car => $sx->[$j]\n";
+ $sy->[$j] += $BASE
+ if $car = (($sy->[$j] = $i-($sy->[$j]||0) - $car) < 0);
+ #print "$sy->[$j] $i $car => $sy->[$j]\n";
+ $j++;
+ }
+ # might leave leading zeros, so fix that
+ __strip_zeros($sy);
+ return $sy;
+ }
+ }
+
+ sub _mul
+ {
+ # (BINT, BINT) return nothing
+ # multiply two numbers in internal representation
+ # modifies first arg, second need not be different from first
+ shift @_ if $_[0] eq $class;
+ my ($xv,$yv) = @_;
+
+ my @prod = (); my ($prod,$car,$cty,$xi,$yi);
+ # since multiplying $x with $x fails, make copy in this case
+ $yv = [@$xv] if "$xv" eq "$yv";
+ # looping through @$y if $xi == 0 is silly! optimize it!
+ for $xi (@$xv)
+ {
+ $car = 0; $cty = 0;
+ for $yi (@$yv)
+ {
+ $prod = $xi * $yi + ($prod[$cty] || 0) + $car;
+ $prod[$cty++] =
+ $prod - ($car = int($prod * 1e-5)) * $BASE; # see USE_MUL
+ }
+ $prod[$cty] += $car if $car; # need really to check for 0?
+ $xi = shift @prod;
+ }
+ # for $xi (@$xv)
+ # {
+ # $car = 0; $cty = 0;
+ # # looping through this if $xi == 0 is silly! optimize it!
+ # if (($xi||0) != 0)
+ # {
+ # for $yi (@$yv)
+ # {
+ # $prod = $prod[$cty]; $prod += ($car + $xi * $yi); # no ||0 here
+ # $prod[$cty++] =
+ # $prod - ($car = int($prod * 1e-5)) * $BASE; # see USE_MUL
+ # }
+ # }
+ # $prod[$cty] += $car if $car; # need really to check for 0?
+ # $xi = shift @prod;
+ # }
+ push @$xv, @prod;
+ __strip_zeros($xv);
+ # normalize (handled last to save check for $y->is_zero()
+ return $xv;
+ }
+
+ sub _div
+ {
+ # ref to array, ref to array, modify first array and return remainder if
+ # in list context
+ # no longer handles sign
+ shift @_ if $_[0] eq $class;
+ my ($x,$yorg) = @_;
+ my ($car,$bar,$prd,$dd,$xi,$yi,@q,$v2,$v1);
+
+ my (@d,$tmp,$q,$u2,$u1,$u0);
+
+ $car = $bar = $prd = 0;
+
+ my $y = [ @$yorg ];
+ if (($dd = int($BASE/($y->[-1]+1))) != 1)
+ {
+ for $xi (@$x)
+ {
+ $xi = $xi * $dd + $car;
+ $xi -= ($car = int($xi * $RBASE)) * $BASE; # see USE_MUL
+ }
+ push(@$x, $car); $car = 0;
+ for $yi (@$y)
+ {
+ $yi = $yi * $dd + $car;
+ $yi -= ($car = int($yi * $RBASE)) * $BASE; # see USE_MUL
+ }
+ }
+ else
+ {
+ push(@$x, 0);
+ }
+ @q = (); ($v2,$v1) = @$y[-2,-1];
+ $v2 = 0 unless $v2;
+ while ($#$x > $#$y)
+ {
+ ($u2,$u1,$u0) = @$x[-3..-1];
+ $u2 = 0 unless $u2;
+ #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n"
+ # if $v1 == 0;
+ $q = (($u0 == $v1) ? 99999 : int(($u0*$BASE+$u1)/$v1));
+ --$q while ($v2*$q > ($u0*1e5+$u1-$q*$v1)*$BASE+$u2);
+ if ($q)
+ {
+ ($car, $bar) = (0,0);
+ for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi)
+ {
+ $prd = $q * $y->[$yi] + $car;
+ $prd -= ($car = int($prd * $RBASE)) * $BASE; # see USE_MUL
+ $x->[$xi] += 1e5 if ($bar = (($x->[$xi] -= $prd + $bar) < 0));
+ }
+ if ($x->[-1] < $car + $bar)
+ {
+ $car = 0; --$q;
+ for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi)
+ {
+ $x->[$xi] -= 1e5
+ if ($car = (($x->[$xi] += $y->[$yi] + $car) > $BASE));
+ }
+ }
+ }
+ pop(@$x); unshift(@q, $q);
+ }
+ if (wantarray)
+ {
+ @d = ();
+ if ($dd != 1)
+ {
+ $car = 0;
+ for $xi (reverse @$x)
+ {
+ $prd = $car * $BASE + $xi;
+ $car = $prd - ($tmp = int($prd / $dd)) * $dd; # see USE_MUL
+ unshift(@d, $tmp);
+ }
+ }
+ else
+ {
+ @d = @$x;
+ }
+ @$x = @q;
+ __strip_zeros($x);
+ __strip_zeros(\@d);
+ return ($x,\@d);
+ }
+ @$x = @q;
+ __strip_zeros($x);
+ return $x;
+ }
+
+ ##############################################################################
+ # testing
+
+ sub _acmp
+ {
+ # internal absolute post-normalized compare (ignore signs)
+ # ref to array, ref to array, return <0, 0, >0
+ # arrays must have at least one entry; this is not checked for
+
+ shift @_ if $_[0] eq $class;
+ my ($cx, $cy) = @_;
+
+ #print "$cx $cy\n";
+ my ($i,$a,$x,$y,$k);
+ # calculate length based on digits, not parts
+ $x = _len($cx); $y = _len($cy);
+ # print "length: ",($x-$y),"\n";
+ return $x-$y if ($x - $y); # if different in length
+ #print "full compare\n";
+ $i = 0; $a = 0;
+ # first way takes 5.49 sec instead of 4.87, but has the early out advantage
+ # so grep is slightly faster, but more inflexible. hm. $_ instead of $k
+ # yields 5.6 instead of 5.5 sec huh?
+ # manual way (abort if unequal, good for early ne)
+ my $j = scalar @$cx - 1;
+ while ($j >= 0)
+ {
+ # print "$cx->[$j] $cy->[$j] $a",$cx->[$j]-$cy->[$j],"\n";
+ last if ($a = $cx->[$j] - $cy->[$j]); $j--;
+ }
+ return $a;
+ # while it early aborts, it is even slower than the manual variant
+ #grep { return $a if ($a = $_ - $cy->[$i++]); } @$cx;
+ # grep way, go trough all (bad for early ne)
+ #grep { $a = $_ - $cy->[$i++]; } @$cx;
+ #return $a;
+ }
+
+ sub _len
+ {
+ # computer number of digits in bigint, minus the sign
+ # int() because add/sub sometimes leaves strings (like '00005') instead of
+ # int ('5') in this place, causing length to fail
+ shift @_ if $_[0] eq $class;
+ my $cx = shift;
+
+ return (@$cx-1)*5+length(int($cx->[-1]));
+ }
+
+ sub _digit
+ {
+ # return the nth digit, negative values count backward
+ # zero is rightmost, so _digit(123,0) will give 3
+ shift @_ if $_[0] eq $class;
+ my $x = shift;
+ my $n = shift || 0;
+
+ my $len = _len($x);
+
+ $n = $len+$n if $n < 0; # -1 last, -2 second-to-last
+ $n = abs($n); # if negative was too big
+ $len--; $n = $len if $n > $len; # n to big?
+
+ my $elem = int($n / 5); # which array element
+ my $digit = $n % 5; # which digit in this element
+ $elem = '0000'.@$x[$elem]; # get element padded with 0's
+ return substr($elem,-$digit-1,1);
+ }
+
+ sub _zeros
+ {
+ # return amount of trailing zeros in decimal
+ # check each array elem in _m for having 0 at end as long as elem == 0
+ # Upon finding a elem != 0, stop
+ shift @_ if $_[0] eq $class;
+ my $x = shift;
+ my $zeros = 0; my $elem;
+ foreach my $e (@$x)
+ {
+ if ($e != 0)
+ {
+ $elem = "$e"; # preserve x
+ $elem =~ s/.*?(0*$)/$1/; # strip anything not zero
+ $zeros *= 5; # elems * 5
+ $zeros += CORE::length($elem); # count trailing zeros
+ last; # early out
+ }
+ $zeros ++; # real else branch: 50% slower!
+ }
+ return $zeros;
+ }
+
+ ##############################################################################
+ # _is_* routines
+
+ sub _is_zero
+ {
+ # return true if arg (BINT or num_str) is zero (array '+', '0')
+ shift @_ if $_[0] eq $class;
+ my ($x) = shift;
+ return (((scalar @$x == 1) && ($x->[0] == 0))) <=> 0;
+ }
+
+ sub _is_even
+ {
+ # return true if arg (BINT or num_str) is even
+ shift @_ if $_[0] eq $class;
+ my ($x) = shift;
+ return (!($x->[0] & 1)) <=> 0;
+ }
+
+ sub _is_odd
+ {
+ # return true if arg (BINT or num_str) is even
+ shift @_ if $_[0] eq $class;
+ my ($x) = shift;
+ return (($x->[0] & 1)) <=> 0;
+ }
+
+ sub _is_one
+ {
+ # return true if arg (BINT or num_str) is one (array '+', '1')
+ shift @_ if $_[0] eq $class;
+ my ($x) = shift;
+ return (scalar @$x == 1) && ($x->[0] == 1) <=> 0;
+ }
+
+ sub __strip_zeros
+ {
+ # internal normalization function that strips leading zeros from the array
+ # args: ref to array
+ #trace(@_);
+ shift @_ if $_[0] eq $class;
+ my $s = shift;
+
+ my $cnt = scalar @$s; # get count of parts
+ my $i = $cnt-1;
+ #print "strip: cnt $cnt i $i\n";
+ # '0', '3', '4', '0', '0',
+ # 0 1 2 3 4
+ # cnt = 5, i = 4
+ # i = 4
+ # i = 3
+ # => fcnt = cnt - i (5-2 => 3, cnt => 5-1 = 4, throw away from 4th pos)
+ # >= 1: skip first part (this can be zero)
+ while ($i > 0) { last if $s->[$i] != 0; $i--; }
+ $i++; splice @$s,$i if ($i < $cnt); # $i cant be 0
+ return $s;
+ }
+
+ ###############################################################################
+ # check routine to test internal state of corruptions
+
+ sub _check
+ {
+ # no checks yet, pull it out from the test suite
+ shift @_ if $_[0] eq $class;
+
+ my ($x) = shift;
+ return "$x is not a reference" if !ref($x);
+
+ # are all parts are valid?
+ my $i = 0; my $j = scalar @$x; my ($e,$try);
+ while ($i < $j)
+ {
+ $e = $x->[$i]; $e = 'undef' unless defined $e;
+ $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e)";
+ last if $e !~ /^[+]?[0-9]+$/;
+ $try = ' < 0 || >= $BASE; '."($x, $e)";
+ last if $e <0 || $e >= $BASE;
+ # this test is disabled, since new/bnorm and certain ops (like early out
+ # in add/sub) are allowed/expected to leave '00000' in some elements
+ #$try = '=~ /^00+/; '."($x, $e)";
+ #last if $e =~ /^00+/;
+ $i++;
+ }
+ return "Illegal part '$e' at pos $i (tested: $try)" if $i < $j;
+ return 0;
+ }
+
+ 1;
+ __END__
+
+ =head1 NAME
+
+ Math::BigInt::Calc - Pure Perl module to support Math::BigInt
+
+ =head1 SYNOPSIS
+
+ Provides support for big integer calculations. Not intended
+ to be used by other modules. Other modules which export the
+ same functions can also be used to support Math::Bigint
+
+ =head1 DESCRIPTION
+
+ In order to allow for multiple big integer libraries, Math::BigInt
+ was rewritten to use library modules for core math routines. Any
+ module which follows the same API as this can be used instead by
+ using the following call:
+
+ use Math::BigInt Calc => BigNum;
+
+ =head1 EXPORT
+
+ The following functions MUST be exported in order to support
+ the use by Math::BigInt:
+
+ _new(string) return ref to new object from ref to decimal string
+ _zero() return a new object with value 0
+ _one() return a new object with value 1
+
+ _str(obj) return ref to a string representing the object
+ _num(obj) returns a Perl integer/floating point number
+ NOTE: because of Perl numeric notation defaults,
+ the _num'ified obj may lose accuracy due to
+ machine-dependend floating point size limitations
+
+ _add(obj,obj) Simple addition of two objects
+ _mul(obj,obj) Multiplication of two objects
+ _div(obj,obj) Division of the 1st object by the 2nd
+ In list context, returns (result,remainder).
+ NOTE: this is integer math, so no
+ fractional part will be returned.
+ _sub(obj,obj) Simple subtraction of 1 object from another
+ a third, optional parameter indicates that the params
+ are swapped. In this case, the first param needs to
+ be preserved, while you can destroy the second.
+ sub (x,y,1) => return x - y and keep x intact!
+
+ _acmp(obj,obj) <=> operator for objects (return -1, 0 or 1)
+
+ _len(obj) returns count of the decimal digits of the object
+ _digit(obj,n) returns the n'th decimal digit of object
+
+ _is_one(obj) return true if argument is +1
+ _is_zero(obj) return true if argument is 0
+ _is_even(obj) return true if argument is even (0,2,4,6..)
+ _is_odd(obj) return true if argument is odd (1,3,5,7..)
+
+ _copy return a ref to a true copy of the object
+
+ _check(obj) check whether internal representation is still intact
+ return 0 for ok, otherwise error message as string
+
+ The following functions are optional, and can be exported if the underlying lib
+ has a fast way to do them. If not defined, Math::BigInt will use a pure, but
+ slow, Perl function as fallback to emulate these:
+
+ _from_hex(str) return ref to new object from ref to hexadecimal string
+ _from_bin(str) return ref to new object from ref to binary string
+
+ _rsft(obj,N,B) shift object in base B by N 'digits' right
+ _lsft(obj,N,B) shift object in base B by N 'digits' left
+
+ _xor(obj1,obj2) XOR (bit-wise) object 1 with object 2
+ Mote: XOR, AND and OR pad with zeros if size mismatches
+ _and(obj1,obj2) AND (bit-wise) object 1 with object 2
+ _or(obj1,obj2) OR (bit-wise) object 1 with object 2
+
+ _sqrt(obj) return the square root of object
+ _pow(obj,obj) return object 1 to the power of object 2
+ _gcd(obj,obj) return Greatest Common Divisor of two objects
+
+ _zeros(obj) return number of trailing decimal zeros
+
+ _dec(obj) decrement object by one (input is >= 1)
+ _inc(obj) increment object by one
+
+ Input strings come in as unsigned but with prefix (i.e. as '123', '0xabc'
+ or '0b1101').
+
+ Testing of input parameter validity is done by the caller, so you need not
+ worry about underflow (C<_sub()>, C<_dec()>) nor about division by zero or
+ similar cases.
+
+ =head1 LICENSE
+
+ This program is free software; you may redistribute it and/or modify it under
+ the same terms as Perl itself.
+
+ =head1 AUTHORS
+
+ Original math code by Mark Biggar, rewritten by Tels L<http://bloodgate.com/>
+ in late 2000, 2001.
+ Seperated from BigInt and shaped API with the help of John Peacock.
+
+ =head1 SEE ALSO
+
+ L<Math::BigInt>, L<Math::BigFloat>.
+
+ =cut
diff -c /dev/null 'perl-5.7.2/lib/Math/BigInt/t/bigfltpm.t'
Index: ./lib/Math/BigInt/t/bigfltpm.t
*** ./lib/Math/BigInt/t/bigfltpm.t Thu Jan 1 02:00:00 1970
--- ./lib/Math/BigInt/t/bigfltpm.t Tue Jul 10 05:28:27 2001
***************
*** 0 ****
--- 1,752 ----
+ #!/usr/bin/perl -w
+
+ use Test;
+ use strict;
+
+ BEGIN
+ {
+ $| = 1;
+ unshift @INC, '../lib'; # for running manually
+ # chdir 't' if -d 't';
+ plan tests => 945;
+ }
+
+ use Math::BigFloat;
+ use Math::BigInt;
+
+ my ($x,$y,$f,@args,$ans,$try,$ans1,$ans1_str,$setup);
+ while (<DATA>)
+ {
+ chop;
+ $_ =~ s/#.*$//; # remove comments
+ $_ =~ s/\s+$//; # trailing spaces
+ next if /^$/; # skip empty lines & comments
+ if (s/^&//)
+ {
+ $f = $_;
+ }
+ elsif (/^\$/)
+ {
+ $setup = $_; $setup =~ s/^\$/\$Math::BigFloat::/; # rnd_mode, div_scale
+ # print "$setup\n";
+ }
+ else
+ {
+ if (m|^(.*?):(/.+)$|)
+ {
+ $ans = $2;
+ @args = split(/:/,$1,99);
+ }
+ else
+ {
+ @args = split(/:/,$_,99); $ans = pop(@args);
+ }
+ $try = "\$x = new Math::BigFloat \"$args[0]\";";
+ if ($f eq "fnorm")
+ {
+ $try .= "\$x;";
+ } elsif ($f eq "binf") {
+ $try .= "\$x->binf('$args[1]');";
+ } elsif ($f eq "bsstr") {
+ $try .= "\$x->bsstr();";
+ } elsif ($f eq "fneg") {
+ $try .= "-\$x;";
+ } elsif ($f eq "bfloor") {
+ $try .= "\$x->bfloor();";
+ } elsif ($f eq "bceil") {
+ $try .= "\$x->bceil();";
+ } elsif ($f eq "is_zero") {
+ $try .= "\$x->is_zero()+0;";
+ } elsif ($f eq "is_one") {
+ $try .= "\$x->is_one()+0;";
+ } elsif ($f eq "is_odd") {
+ $try .= "\$x->is_odd()+0;";
+ } elsif ($f eq "is_even") {
+ $try .= "\$x->is_even()+0;";
+ } elsif ($f eq "as_number") {
+ $try .= "\$x->as_number();";
+ } elsif ($f eq "fabs") {
+ $try .= "abs \$x;";
+ }elsif ($f eq "fround") {
+ $try .= "$setup; \$x->fround($args[1]);";
+ } elsif ($f eq "ffround") {
+ $try .= "$setup; \$x->ffround($args[1]);";
+ } elsif ($f eq "fsqrt") {
+ $try .= "$setup; \$x->fsqrt();";
+ }
+ else
+ {
+ $try .= "\$y = new Math::BigFloat \"$args[1]\";";
+ if ($f eq "fcmp") {
+ $try .= "\$x <=> \$y;";
+ } elsif ($f eq "fpow") {
+ $try .= "\$x ** \$y;";
+ } elsif ($f eq "fadd") {
+ $try .= "\$x + \$y;";
+ } elsif ($f eq "fsub") {
+ $try .= "\$x - \$y;";
+ } elsif ($f eq "fmul") {
+ $try .= "\$x * \$y;";
+ } elsif ($f eq "fdiv") {
+ $try .= "$setup; \$x / \$y;";
+ } elsif ($f eq "fmod") {
+ $try .= "\$x % \$y;";
+ } else { warn "Unknown op '$f'"; }
+ }
+ $ans1 = eval $try;
+ if ($ans =~ m|^/(.*)$|)
+ {
+ my $pat = $1;
+ if ($ans1 =~ /$pat/)
+ {
+ ok (1,1);
+ }
+ else
+ {
+ print "# '$try' expected: /$pat/ got: '$ans1'\n" if !ok(1,0);
+ }
+ }
+ else
+ {
+ if ($ans eq "")
+ {
+ ok_undef ($ans1);
+ }
+ else
+ {
+ print "# Tried: '$try'\n" if !ok ($ans1, $ans);
+ if (ref($ans1) eq 'Math::BigFloat')
+ {
+ #print $ans1->_trailing_zeros(),"\n";
+ print "# Has trailing zeros after '$try'\n"
+ if !ok ($ans1->{_m}->_trailing_zeros(), 0);
+ }
+ }
+ } # end pattern or string
+ }
+ } # end while
+
+ # check whether new() for BigInts destroys them ($y == 12 in this case)
+ $x = Math::BigInt->new(1200); $y = Math::BigFloat->new($x);
+ ok ($y,1200); ok ($x,1200);
+
+ # all done
+
+ ###############################################################################
+ # Perl 5.005 does not like ok ($x,undef)
+
+ sub ok_undef
+ {
+ my $x = shift;
+
+ ok (1,1) and return if !defined $x;
+ ok ($x,'undef');
+ }
+
+ __END__
+ &as_number
+ 0:0
+ 1:1
+ 1.2:1
+ 2.345:2
+ -2:-2
+ -123.456:-123
+ -200:-200
+ &binf
+ 1:+:+inf
+ 2:-:-inf
+ 3:abc:+inf
+ &bsstr
+ +inf:+inf
+ -inf:-inf
+ abc:NaN
+ &fnorm
+ +inf:+inf
+ -inf:-inf
+ +infinity:NaN
+ +-inf:NaN
+ abc:NaN
+ 1 a:NaN
+ 1bcd2:NaN
+ 11111b:NaN
+ +1z:NaN
+ -1z:NaN
+ 0:0
+ +0:0
+ +00:0
+ +0_0_0:0
+ 000000_0000000_00000:0
+ -0:0
+ -0000:0
+ +1:1
+ +01:1
+ +001:1
+ +00000100000:100000
+ 123456789:123456789
+ -1:-1
+ -01:-1
+ -001:-1
+ -123456789:-123456789
+ -00000100000:-100000
+ 123.456a:NaN
+ 123.456:123.456
+ 0.01:0.01
+ .002:0.002
+ +.2:0.2
+ -0.0003:-0.0003
+ -.0000000004:-0.0000000004
+ 123456E2:12345600
+ 123456E-2:1234.56
+ -123456E2:-12345600
+ -123456E-2:-1234.56
+ 1e1:10
+ 2e-11:0.00000000002
+ -3e111:-3000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
+ -4e-1111:-0.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004
+ &fpow
+ 2:2:4
+ 1:2:1
+ 1:3:1
+ -1:2:1
+ -1:3:-1
+ 123.456:2:15241.383936
+ 2:-2:0.25
+ 2:-3:0.125
+ 128:-2:0.00006103515625
+ abc:123.456:NaN
+ 123.456:abc:NaN
+ +inf:123.45:+inf
+ -inf:123.45:-inf
+ +inf:-123.45:+inf
+ -inf:-123.45:-inf
+ &fneg
+ abc:NaN
+ +0:0
+ +1:-1
+ -1:1
+ +123456789:-123456789
+ -123456789:123456789
+ +123.456789:-123.456789
+ -123456.789:123456.789
+ &fabs
+ abc:NaN
+ +0:0
+ +1:1
+ -1:1
+ +123456789:123456789
+ -123456789:123456789
+ +123.456789:123.456789
+ -123456.789:123456.789
+ &fround
+ $rnd_mode = "trunc"
+ +10123456789:5:10123000000
+ -10123456789:5:-10123000000
+ +10123456789.123:5:10123000000
+ -10123456789.123:5:-10123000000
+ +10123456789:9:10123456700
+ -10123456789:9:-10123456700
+ +101234500:6:101234000
+ -101234500:6:-101234000
+ $rnd_mode = "zero"
+ +20123456789:5:20123000000
+ -20123456789:5:-20123000000
+ +20123456789.123:5:20123000000
+ -20123456789.123:5:-20123000000
+ +20123456789:9:20123456800
+ -20123456789:9:-20123456800
+ +201234500:6:201234000
+ -201234500:6:-201234000
+ $rnd_mode = "+inf"
+ +30123456789:5:30123000000
+ -30123456789:5:-30123000000
+ +30123456789.123:5:30123000000
+ -30123456789.123:5:-30123000000
+ +30123456789:9:30123456800
+ -30123456789:9:-30123456800
+ +301234500:6:301235000
+ -301234500:6:-301234000
+ $rnd_mode = "-inf"
+ +40123456789:5:40123000000
+ -40123456789:5:-40123000000
+ +40123456789.123:5:40123000000
+ -40123456789.123:5:-40123000000
+ +40123456789:9:40123456800
+ -40123456789:9:-40123456800
+ +401234500:6:401234000
+ -401234500:6:-401235000
+ $rnd_mode = "odd"
+ +50123456789:5:50123000000
+ -50123456789:5:-50123000000
+ +50123456789.123:5:50123000000
+ -50123456789.123:5:-50123000000
+ +50123456789:9:50123456800
+ -50123456789:9:-50123456800
+ +501234500:6:501235000
+ -501234500:6:-501235000
+ $rnd_mode = "even"
+ +60123456789:5:60123000000
+ -60123456789:5:-60123000000
+ +60123456789:9:60123456800
+ -60123456789:9:-60123456800
+ +601234500:6:601234000
+ -601234500:6:-601234000
+ +60123456789.0123:5:60123000000
+ -60123456789.0123:5:-60123000000
+ &ffround
+ $rnd_mode = "trunc"
+ +1.23:-1:1.2
+ +1.234:-1:1.2
+ +1.2345:-1:1.2
+ +1.23:-2:1.23
+ +1.234:-2:1.23
+ +1.2345:-2:1.23
+ +1.23:-3:1.23
+ +1.234:-3:1.234
+ +1.2345:-3:1.234
+ -1.23:-1:-1.2
+ +1.27:-1:1.2
+ -1.27:-1:-1.2
+ +1.25:-1:1.2
+ -1.25:-1:-1.2
+ +1.35:-1:1.3
+ -1.35:-1:-1.3
+ -0.0061234567890:-1:0
+ -0.0061:-1:0
+ -0.00612:-1:0
+ -0.00612:-2:0
+ -0.006:-1:0
+ -0.006:-2:0
+ -0.0006:-2:0
+ -0.0006:-3:0
+ -0.0065:-3:/-0\.006|-6e-03
+ -0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03
+ -0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03
+ 0.05:0:0
+ 0.5:0:0
+ 0.51:0:0
+ 0.41:0:0
+ $rnd_mode = "zero"
+ +2.23:-1:/2.2(?:0{5}\d+)?
+ -2.23:-1:/-2.2(?:0{5}\d+)?
+ +2.27:-1:/2.(?:3|29{5}\d+)
+ -2.27:-1:/-2.(?:3|29{5}\d+)
+ +2.25:-1:/2.2(?:0{5}\d+)?
+ -2.25:-1:/-2.2(?:0{5}\d+)?
+ +2.35:-1:/2.(?:3|29{5}\d+)
+ -2.35:-1:/-2.(?:3|29{5}\d+)
+ -0.0065:-1:0
+ -0.0065:-2:/-0\.01|-1e-02
+ -0.0065:-3:/-0\.006|-6e-03
+ -0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03
+ -0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03
+ 0.05:0:0
+ 0.5:0:0
+ 0.51:0:1
+ 0.41:0:0
+ $rnd_mode = "+inf"
+ +3.23:-1:/3.2(?:0{5}\d+)?
+ -3.23:-1:/-3.2(?:0{5}\d+)?
+ +3.27:-1:/3.(?:3|29{5}\d+)
+ -3.27:-1:/-3.(?:3|29{5}\d+)
+ +3.25:-1:/3.(?:3|29{5}\d+)
+ -3.25:-1:/-3.2(?:0{5}\d+)?
+ +3.35:-1:/3.(?:4|39{5}\d+)
+ -3.35:-1:/-3.(?:3|29{5}\d+)
+ -0.0065:-1:0
+ -0.0065:-2:/-0\.01|-1e-02
+ -0.0065:-3:/-0\.006|-6e-03
+ -0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03
+ -0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03
+ 0.05:0:0
+ 0.5:0:1
+ 0.51:0:1
+ 0.41:0:0
+ $rnd_mode = "-inf"
+ +4.23:-1:/4.2(?:0{5}\d+)?
+ -4.23:-1:/-4.2(?:0{5}\d+)?
+ +4.27:-1:/4.(?:3|29{5}\d+)
+ -4.27:-1:/-4.(?:3|29{5}\d+)
+ +4.25:-1:/4.2(?:0{5}\d+)?
+ -4.25:-1:/-4.(?:3|29{5}\d+)
+ +4.35:-1:/4.(?:3|29{5}\d+)
+ -4.35:-1:/-4.(?:4|39{5}\d+)
+ -0.0065:-1:0
+ -0.0065:-2:/-0\.01|-1e-02
+ -0.0065:-3:/-0\.007|-7e-03
+ -0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03
+ -0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03
+ 0.05:0:0
+ 0.5:0:0
+ 0.51:0:1
+ 0.41:0:0
+ $rnd_mode = "odd"
+ +5.23:-1:/5.2(?:0{5}\d+)?
+ -5.23:-1:/-5.2(?:0{5}\d+)?
+ +5.27:-1:/5.(?:3|29{5}\d+)
+ -5.27:-1:/-5.(?:3|29{5}\d+)
+ +5.25:-1:/5.(?:3|29{5}\d+)
+ -5.25:-1:/-5.(?:3|29{5}\d+)
+ +5.35:-1:/5.(?:3|29{5}\d+)
+ -5.35:-1:/-5.(?:3|29{5}\d+)
+ -0.0065:-1:0
+ -0.0065:-2:/-0\.01|-1e-02
+ -0.0065:-3:/-0\.007|-7e-03
+ -0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03
+ -0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03
+ 0.05:0:0
+ 0.5:0:1
+ 0.51:0:1
+ 0.41:0:0
+ $rnd_mode = "even"
+ +6.23:-1:/6.2(?:0{5}\d+)?
+ -6.23:-1:/-6.2(?:0{5}\d+)?
+ +6.27:-1:/6.(?:3|29{5}\d+)
+ -6.27:-1:/-6.(?:3|29{5}\d+)
+ +6.25:-1:/6.(?:2(?:0{5}\d+)?|29{5}\d+)
+ -6.25:-1:/-6.(?:2(?:0{5}\d+)?|29{5}\d+)
+ +6.35:-1:/6.(?:4|39{5}\d+|29{8}\d+)
+ -6.35:-1:/-6.(?:4|39{5}\d+|29{8}\d+)
+ -0.0065:-1:0
+ -0.0065:-2:/-0\.01|-1e-02
+ -0.0065:-3:/-0\.006|-7e-03
+ -0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03
+ -0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03
+ 0.05:0:0
+ 0.5:0:0
+ 0.51:0:1
+ 0.41:0:0
+ 0.01234567:-3:0.012
+ 0.01234567:-4:0.0123
+ 0.01234567:-5:0.01235
+ 0.01234567:-6:0.012346
+ 0.01234567:-7:0.0123457
+ 0.01234567:-8:0.01234567
+ 0.01234567:-9:0.01234567
+ 0.01234567:-12:0.01234567
+ &fcmp
+ abc:abc:
+ abc:+0:
+ +0:abc:
+ +0:+0:0
+ -1:+0:-1
+ +0:-1:1
+ +1:+0:1
+ +0:+1:-1
+ -1:+1:-1
+ +1:-1:1
+ -1:-1:0
+ +1:+1:0
+ -1.1:0:-1
+ +0:-1.1:1
+ +1.1:+0:1
+ +0:+1.1:-1
+ +123:+123:0
+ +123:+12:1
+ +12:+123:-1
+ -123:-123:0
+ -123:-12:-1
+ -12:-123:1
+ +123:+124:-1
+ +124:+123:1
+ -123:-124:1
+ -124:-123:-1
+ 0:0.01:-1
+ 0:0.0001:-1
+ 0:-0.0001:1
+ 0:-0.1:1
+ 0.1:0:1
+ 0.00001:0:1
+ -0.0001:0:-1
+ -0.1:0:-1
+ 0:0.0001234:-1
+ 0:-0.0001234:1
+ 0.0001234:0:1
+ -0.0001234:0:-1
+ 0.0001:0.0005:-1
+ 0.0005:0.0001:1
+ 0.005:0.0001:1
+ 0.001:0.0005:1
+ 0.000001:0.0005:-2 # <0, but can't test this
+ 0.00000123:0.0005:-2 # <0, but can't test this
+ 0.00512:0.0001:1
+ 0.005:0.000112:1
+ 0.00123:0.0005:1
+ # infinity
+ -inf:5432112345:-1
+ +inf:5432112345:1
+ -inf:-5432112345:-1
+ +inf:-5432112345:1
+ -inf:54321.12345:-1
+ +inf:54321.12345:1
+ -inf:-54321.12345:-1
+ +inf:-54321.12345:1
+ +inf:+inf:0
+ -inf:-inf:0
+ # return undef
+ +inf:NaN:
+ NaN:+inf:
+ -inf:NaN:
+ NaN:-inf:
+ &fadd
+ abc:abc:NaN
+ abc:+0:NaN
+ +0:abc:NaN
+ +0:+0:0
+ +1:+0:1
+ +0:+1:1
+ +1:+1:2
+ -1:+0:-1
+ +0:-1:-1
+ -1:-1:-2
+ -1:+1:0
+ +1:-1:0
+ +9:+1:10
+ +99:+1:100
+ +999:+1:1000
+ +9999:+1:10000
+ +99999:+1:100000
+ +999999:+1:1000000
+ +9999999:+1:10000000
+ +99999999:+1:100000000
+ +999999999:+1:1000000000
+ +9999999999:+1:10000000000
+ +99999999999:+1:100000000000
+ +10:-1:9
+ +100:-1:99
+ +1000:-1:999
+ +10000:-1:9999
+ +100000:-1:99999
+ +1000000:-1:999999
+ +10000000:-1:9999999
+ +100000000:-1:99999999
+ +1000000000:-1:999999999
+ +10000000000:-1:9999999999
+ +123456789:+987654321:1111111110
+ -123456789:+987654321:864197532
+ -123456789:-987654321:-1111111110
+ +123456789:-987654321:-864197532
+ 0.001234:0.0001234:0.0013574
+ &fsub
+ abc:abc:NaN
+ abc:+0:NaN
+ +0:abc:NaN
+ +0:+0:0
+ +1:+0:1
+ +0:+1:-1
+ +1:+1:0
+ -1:+0:-1
+ +0:-1:1
+ -1:-1:0
+ -1:+1:-2
+ +1:-1:2
+ +9:+1:8
+ +99:+1:98
+ +999:+1:998
+ +9999:+1:9998
+ +99999:+1:99998
+ +999999:+1:999998
+ +9999999:+1:9999998
+ +99999999:+1:99999998
+ +999999999:+1:999999998
+ +9999999999:+1:9999999998
+ +99999999999:+1:99999999998
+ +10:-1:11
+ +100:-1:101
+ +1000:-1:1001
+ +10000:-1:10001
+ +100000:-1:100001
+ +1000000:-1:1000001
+ +10000000:-1:10000001
+ +100000000:-1:100000001
+ +1000000000:-1:1000000001
+ +10000000000:-1:10000000001
+ +123456789:+987654321:-864197532
+ -123456789:+987654321:-1111111110
+ -123456789:-987654321:864197532
+ +123456789:-987654321:1111111110
+ &fmul
+ abc:abc:NaN
+ abc:+0:NaN
+ +0:abc:NaN
+ +0:+0:0
+ +0:+1:0
+ +1:+0:0
+ +0:-1:0
+ -1:+0:0
+ +123456789123456789:+0:0
+ +0:+123456789123456789:0
+ -1:-1:1
+ -1:+1:-1
+ +1:-1:-1
+ +1:+1:1
+ +2:+3:6
+ -2:+3:-6
+ +2:-3:-6
+ -2:-3:6
+ +111:+111:12321
+ +10101:+10101:102030201
+ +1001001:+1001001:1002003002001
+ +100010001:+100010001:10002000300020001
+ +10000100001:+10000100001:100002000030000200001
+ +11111111111:+9:99999999999
+ +22222222222:+9:199999999998
+ +33333333333:+9:299999999997
+ +44444444444:+9:399999999996
+ +55555555555:+9:499999999995
+ +66666666666:+9:599999999994
+ +77777777777:+9:699999999993
+ +88888888888:+9:799999999992
+ +99999999999:+9:899999999991
+ 6:120:720
+ 10:10000:100000
+ &fdiv
+ $div_scale = 40; $Math::BigFloat::rnd_mode = 'even'
+ abc:abc:NaN
+ abc:+1:abc:NaN
+ +1:abc:NaN
+ +0:+0:NaN
+ +0:+1:0
+ +1:+0:NaN
+ +0:-1:0
+ -1:+0:NaN
+ +1:+1:1
+ -1:-1:1
+ +1:-1:-1
+ -1:+1:-1
+ +1:+2:0.5
+ +2:+1:2
+ +10:+5:2
+ +100:+4:25
+ +1000:+8:125
+ +10000:+16:625
+ +10000:-16:-625
+ +999999999999:+9:111111111111
+ +999999999999:+99:10101010101
+ +999999999999:+999:1001001001
+ +999999999999:+9999:100010001
+ +999999999999999:+99999:10000100001
+ +1000000000:+9:111111111.1111111111111111111111111111111
+ +2000000000:+9:222222222.2222222222222222222222222222222
+ +3000000000:+9:333333333.3333333333333333333333333333333
+ +4000000000:+9:444444444.4444444444444444444444444444444
+ +5000000000:+9:555555555.5555555555555555555555555555556
+ +6000000000:+9:666666666.6666666666666666666666666666667
+ +7000000000:+9:777777777.7777777777777777777777777777778
+ +8000000000:+9:888888888.8888888888888888888888888888889
+ +9000000000:+9:1000000000
+ +35500000:+113:314159.2920353982300884955752212389380531
+ +71000000:+226:314159.2920353982300884955752212389380531
+ +106500000:+339:314159.2920353982300884955752212389380531
+ +1000000000:+3:333333333.3333333333333333333333333333333
+ 2:25.024996000799840031993601279744051189762:0.07992009269196593320152084692285869265447
+ $div_scale = 20
+ +1000000000:+9:111111111.11111111111
+ +2000000000:+9:222222222.22222222222
+ +3000000000:+9:333333333.33333333333
+ +4000000000:+9:444444444.44444444444
+ +5000000000:+9:555555555.55555555556
+ +6000000000:+9:666666666.66666666667
+ +7000000000:+9:777777777.77777777778
+ +8000000000:+9:888888888.88888888889
+ +9000000000:+9:1000000000
+ 1:10:0.1
+ 1:100:0.01
+ 1:1000:0.001
+ 1:10000:0.0001
+ 1:504:0.001984126984126984127
+ 2:1.987654321:1.0062111801179738436
+ # the next two cases are the "old" behaviour, but are now (>v0.01) different
+ #+35500000:+113:314159.292035398230088
+ #+71000000:+226:314159.292035398230088
+ +35500000:+113:314159.29203539823009
+ +71000000:+226:314159.29203539823009
+ +106500000:+339:314159.29203539823009
+ +1000000000:+3:333333333.33333333333
+ $div_scale = 1
+ # round to accuracy 1 after bdiv
+ +124:+3:40
+ # reset scale for further tests
+ $div_scale = 40
+ &fmod
+ +0:0:NaN
+ +0:1:0
+ +3:1:0
+ #+5:2:1
+ #+9:4:1
+ #+9:5:4
+ #+9000:56:40
+ #+56:9000:56
+ &fsqrt
+ +0:0
+ -1:NaN
+ -2:NaN
+ -16:NaN
+ -123.45:NaN
+ nanfsqrt:NaN
+ +inf:+inf
+ -inf:NaN
+ +1:1
+ +2:1.41421356237309504880168872420969807857
+ +4:2
+ +16:4
+ +100:10
+ +123.456:11.11107555549866648462149404118219234119
+ +15241.38393:123.4559999756998444766131352122991626468
+ +1.44:1.2
+ &is_odd
+ abc:0
+ 0:0
+ -1:1
+ -3:1
+ 1:1
+ 3:1
+ 1000001:1
+ 1000002:0
+ +inf:0
+ -inf:0
+ 123.45:0
+ -123.45:0
+ 2:0
+ &is_even
+ abc:0
+ 0:1
+ -1:0
+ -3:0
+ 1:0
+ 3:0
+ 1000001:0
+ 1000002:1
+ 2:1
+ +inf:0
+ -inf:0
+ 123.456:0
+ -123.456:0
+ &is_zero
+ NaNzero:0
+ 0:1
+ -1:0
+ 1:0
+ &is_one
+ 0:0
+ 2:0
+ 1:1
+ -1:0
+ -2:0
+ &bfloor
+ 0:0
+ abc:NaN
+ +inf:+inf
+ -inf:-inf
+ 1:1
+ -51:-51
+ -51.2:-52
+ 12.2:12
+ &bceil
+ 0:0
+ abc:NaN
+ +inf:+inf
+ -inf:-inf
+ 1:1
+ -51:-51
+ -51.2:-51
+ 12.2:13
diff -c /dev/null 'perl-5.7.2/lib/Math/BigInt/t/bigintc.t'
Index: ./lib/Math/BigInt/t/bigintc.t
*** ./lib/Math/BigInt/t/bigintc.t Thu Jan 1 02:00:00 1970
--- ./lib/Math/BigInt/t/bigintc.t Tue Jul 10 05:28:38 2001
***************
*** 0 ****
--- 1,73 ----
+ #!/usr/bin/perl -w
+
+ use strict;
+ use Test;
+
+ BEGIN
+ {
+ $| = 1;
+ # chdir 't' if -d 't';
+ unshift @INC, '../lib'; # for running manually
+ plan tests => 29;
+ }
+
+ # testing of Math::BigInt::Calc, primarily for interface/api and not for the
+ # math functionality
+
+ use Math::BigInt::Calc;
+
+ my $s123 = \'123'; my $s321 = \'321';
+ # _new and _str
+ my $x = _new($s123); my $u = _str($x);
+ ok ($$u,123); ok ($x->[0],123); ok (@$x,1);
+ my $y = _new($s321);
+
+ # _add, _sub, _mul, _div
+
+ ok (${_str(_add($x,$y))},444);
+ ok (${_str(_sub($x,$y))},123);
+ ok (${_str(_mul($x,$y))},39483);
+ ok (${_str(_div($x,$y))},123);
+
+ # division with reminder
+ my $z = _new(\"111");
+ _mul($x,$y);
+ ok (${_str($x)},39483);
+ _add($x,$z);
+ ok (${_str($x)},39594);
+ my ($re,$rr) = _div($x,$y);
+
+ ok (${_str($re)},123); ok (${_str($rr)},111);
+
+ # _copy
+ $x = _new(\"12356");
+ ok (${_str(_copy($x))},12356);
+
+ # digit
+ $x = _new(\"123456789");
+ ok (_digit($x,0),9);
+ ok (_digit($x,1),8);
+ ok (_digit($x,2),7);
+ ok (_digit($x,-1),1);
+ ok (_digit($x,-2),2);
+ ok (_digit($x,-3),3);
+
+ # is_zero, _is_one, _one, _zero
+ $x = _new(\"12356");
+ ok (_is_zero($x),0);
+ ok (_is_one($x),0);
+
+ # _zeros
+ $x = _new(\"1256000000"); ok (_zeros($x),6);
+ $x = _new(\"152"); ok (_zeros($x),0);
+ $x = _new(\"123000"); ok (_zeros($x),3);
+
+ ok (_is_one(_one()),1); ok (_is_one(_zero()),0);
+ ok (_is_zero(_zero()),1); ok (_is_zero(_one()),0);
+
+ ok (_check($x),0);
+ ok (_check(123),'123 is not a reference');
+
+ # done
+
+ 1;
diff -c /dev/null 'perl-5.7.2/lib/Math/BigInt/t/bigintpm.t'
Index: ./lib/Math/BigInt/t/bigintpm.t
*** ./lib/Math/BigInt/t/bigintpm.t Thu Jan 1 02:00:00 1970
--- ./lib/Math/BigInt/t/bigintpm.t Tue Jul 10 17:50:05 2001
***************
*** 0 ****
--- 1,1227 ----
+ #!/usr/bin/perl -w
+
+ use strict;
+ use Test;
+
+ BEGIN
+ {
+ $| = 1;
+ # chdir 't' if -d 't';
+ unshift @INC, '../lib'; # for running manually
+ plan tests => 1222;
+ }
+ my $version = '1.36'; # for $VERSION tests, match current release (by hand!)
+
+ ##############################################################################
+ # for testing inheritance of _swap
+
+ package Math::Foo;
+
+ use Math::BigInt;
+ use vars qw/@ISA/;
+ @ISA = (qw/Math::BigInt/);
+
+ use overload
+ # customized overload for sub, since original does not use swap there
+ '-' => sub { my @a = ref($_[0])->_swap(@_);
+ $a[0]->bsub($a[1])};
+
+ sub _swap
+ {
+ # a fake _swap, which reverses the params
+ my $self = shift; # for override in subclass
+ if ($_[2])
+ {
+ my $c = ref ($_[0] ) || 'Math::Foo';
+ return ( $_[0]->copy(), $_[1] );
+ }
+ else
+ {
+ return ( Math::Foo->new($_[1]), $_[0] );
+ }
+ }
+
+ ##############################################################################
+ package main;
+
+ use Math::BigInt;
+ #use Math::BigInt lib => 'BitVect'; # for testing
+ #use Math::BigInt lib => 'Small'; # for testing
+
+ my $CALC = Math::BigInt::_core_lib();
+
+ my (@args,$f,$try,$x,$y,$z,$a,$exp,$ans,$ans1,@a,$m,$e,$round_mode);
+
+ while (<DATA>)
+ {
+ chop;
+ next if /^#/; # skip comments
+ if (s/^&//)
+ {
+ $f = $_;
+ }
+ elsif (/^\$/)
+ {
+ $round_mode = $_;
+ $round_mode =~ s/^\$/Math::BigInt->/;
+ # print "$round_mode\n";
+ }
+ else
+ {
+ @args = split(/:/,$_,99);
+ $ans = pop(@args);
+ $try = "\$x = Math::BigInt->new(\"$args[0]\");";
+ if ($f eq "bnorm"){
+ # $try .= '$x+0;';
+ } elsif ($f eq "is_zero") {
+ $try .= '$x->is_zero()+0;';
+ } elsif ($f eq "is_one") {
+ $try .= '$x->is_one()+0;';
+ } elsif ($f eq "is_odd") {
+ $try .= '$x->is_odd()+0;';
+ } elsif ($f eq "is_even") {
+ $try .= '$x->is_even()+0;';
+ } elsif ($f eq "is_inf") {
+ $try .= "\$x->is_inf('$args[1]')+0;";
+ } elsif ($f eq "binf") {
+ $try .= "\$x->binf('$args[1]');";
+ } elsif ($f eq "bfloor") {
+ $try .= '$x->bfloor();';
+ } elsif ($f eq "bceil") {
+ $try .= '$x->bceil();';
+ } elsif ($f eq "bsstr") {
+ $try .= '$x->bsstr();';
+ } elsif ($f eq "bneg") {
+ $try .= '-$x;';
+ } elsif ($f eq "babs") {
+ $try .= 'abs $x;';
+ } elsif ($f eq "binc") {
+ $try .= '++$x;';
+ } elsif ($f eq "bdec") {
+ $try .= '--$x;';
+ }elsif ($f eq "bnot") {
+ $try .= '~$x;';
+ }elsif ($f eq "bsqrt") {
+ $try .= '$x->bsqrt();';
+ }elsif ($f eq "length") {
+ $try .= "\$x->length();";
+ }elsif ($f eq "exponent"){
+ $try .= '$x = $x->exponent()->bstr();';
+ }elsif ($f eq "mantissa"){
+ $try .= '$x = $x->mantissa()->bstr();';
+ }elsif ($f eq "parts"){
+ $try .= "(\$m,\$e) = \$x->parts();";
+ $try .= '$m = $m->bstr(); $m = "NaN" if !defined $m;';
+ $try .= '$e = $e->bstr(); $e = "NaN" if !defined $e;';
+ $try .= '"$m,$e";';
+ } else {
+ $try .= "\$y = new Math::BigInt ('$args[1]');";
+ if ($f eq "bcmp"){
+ $try .= '$x <=> $y;';
+ }elsif ($f eq "bround") {
+ $try .= "$round_mode; \$x->bround(\$y);";
+ }elsif ($f eq "bacmp"){
+ $try .= "\$x->bacmp(\$y);";
+ }elsif ($f eq "badd"){
+ $try .= "\$x + \$y;";
+ }elsif ($f eq "bsub"){
+ $try .= "\$x - \$y;";
+ }elsif ($f eq "bmul"){
+ $try .= "\$x * \$y;";
+ }elsif ($f eq "bdiv"){
+ $try .= "\$x / \$y;";
+ }elsif ($f eq "bmod"){
+ $try .= "\$x % \$y;";
+ }elsif ($f eq "bgcd")
+ {
+ if (defined $args[2])
+ {
+ $try .= " \$z = new Math::BigInt \"$args[2]\"; ";
+ }
+ $try .= "Math::BigInt::bgcd(\$x, \$y";
+ $try .= ", \$z" if (defined $args[2]);
+ $try .= " );";
+ }
+ elsif ($f eq "blcm")
+ {
+ if (defined $args[2])
+ {
+ $try .= " \$z = new Math::BigInt \"$args[2]\"; ";
+ }
+ $try .= "Math::BigInt::blcm(\$x, \$y";
+ $try .= ", \$z" if (defined $args[2]);
+ $try .= " );";
+ }elsif ($f eq "blsft"){
+ if (defined $args[2])
+ {
+ $try .= "\$x->blsft(\$y,$args[2]);";
+ }
+ else
+ {
+ $try .= "\$x << \$y;";
+ }
+ }elsif ($f eq "brsft"){
+ if (defined $args[2])
+ {
+ $try .= "\$x->brsft(\$y,$args[2]);";
+ }
+ else
+ {
+ $try .= "\$x >> \$y;";
+ }
+ }elsif ($f eq "band"){
+ $try .= "\$x & \$y;";
+ }elsif ($f eq "bior"){
+ $try .= "\$x | \$y;";
+ }elsif ($f eq "bxor"){
+ $try .= "\$x ^ \$y;";
+ }elsif ($f eq "bpow"){
+ $try .= "\$x ** \$y;";
+ }elsif ($f eq "digit"){
+ $try = "\$x = Math::BigInt->new(\"$args[0]\"); \$x->digit($args[1]);";
+ } else { warn "Unknown op '$f'"; }
+ }
+ # print "trying $try\n";
+ $ans1 = eval $try;
+ $ans =~ s/^[+]([0-9])/$1/; # remove leading '+'
+ if ($ans eq "")
+ {
+ ok_undef ($ans1);
+ }
+ else
+ {
+ #print "try: $try ans: $ans1 $ans\n";
+ print "# Tried: '$try'\n" if !ok ($ans1, $ans);
+ }
+ # check internal state of number objects
+ is_valid($ans1,$f) if ref $ans1;
+ }
+ } # endwhile data tests
+ close DATA;
+
+ # XXX Tels 06/29/2001 following tests never fail or do not work :(
+
+ # test whether use Math::BigInt qw/version/ works
+ $try = "use Math::BigInt ($version.'1');";
+ $try .= ' $x = Math::BigInt->new(123); $x = "$x";';
+ $ans1 = eval $try;
+ ok_undef ( $_ ); # should result in error!
+
+ # test whether constant works or not, also test for qw($version)
+ $try = "use Math::BigInt ($version,'babs',':constant');";
+ $try .= ' $x = 2**150; babs($x); $x = "$x";';
+ $ans1 = eval $try;
+ ok ( $ans1, "1427247692705959881058285969449495136382746624");
+
+ # test wether Math::BigInt::Small via use works (w/ dff. spellings of calc)
+ #$try = "use Math::BigInt ($version,'CALC','Small');";
+ #$try .= ' $x = 2**10; $x = "$x";';
+ #$ans1 = eval $try;
+ #ok ( $ans1, "1024");
+ #$try = "use Math::BigInt ($version,'cAlC','Math::BigInt::Small');";
+ #$try .= ' $x = 2**10; $x = "$x";';
+ #$ans1 = eval $try;
+ #ok ( $ans1, "1024");
+ # test wether calc => undef (array element not existing) works
+ #$try = "use Math::BigInt ($version,'CALC');";
+ #$try = "require Math::BigInt; Math::BigInt::import($version,'CALC');";
+ #$try .= ' $x = Math::BigInt->new(2)**10; $x = "$x";';
+ #$ans1 = eval $try;
+ #ok ( $ans1, 1024);
+
+ # test some more
+ @a = ();
+ for (my $i = 1; $i < 10; $i++)
+ {
+ push @a, $i;
+ }
+ ok "@a", "1 2 3 4 5 6 7 8 9";
+
+ # test whether selfmultiplication works correctly (result is 2**64)
+ $try = '$x = new Math::BigInt "+4294967296";';
+ $try .= '$a = $x->bmul($x);';
+ $ans1 = eval $try;
+ print "# Tried: '$try'\n" if !ok ($ans1, Math::BigInt->new(2) ** 64);
+
+ # test whether op destroys args or not (should better not)
+
+ $x = new Math::BigInt (3);
+ $y = new Math::BigInt (4);
+ $z = $x & $y;
+ ok ($x,3);
+ ok ($y,4);
+ ok ($z,0);
+ $z = $x | $y;
+ ok ($x,3);
+ ok ($y,4);
+ ok ($z,7);
+ $x = new Math::BigInt (1);
+ $y = new Math::BigInt (2);
+ $z = $x | $y;
+ ok ($x,1);
+ ok ($y,2);
+ ok ($z,3);
+
+ $x = new Math::BigInt (5);
+ $y = new Math::BigInt (4);
+ $z = $x ^ $y;
+ ok ($x,5);
+ ok ($y,4);
+ ok ($z,1);
+
+ $x = new Math::BigInt (-5); $y = -$x;
+ ok ($x, -5);
+
+ $x = new Math::BigInt (-5); $y = abs($x);
+ ok ($x, -5);
+
+ # check whether overloading cmp works
+ $try = "\$x = Math::BigInt->new(0);";
+ $try .= "\$y = 10;";
+ $try .= "'false' if \$x ne \$y;";
+ $ans = eval $try;
+ print "# For '$try'\n" if (!ok "$ans" , "false" );
+
+ # we cant test for working cmpt with other objects here, we would need a dummy
+ # object with stringify overload for this. see Math::String tests
+
+ ###############################################################################
+ # check shortcuts
+ $try = "\$x = Math::BigInt->new(1); \$x += 9;";
+ $try .= "'ok' if \$x == 10;";
+ $ans = eval $try;
+ print "# For '$try'\n" if (!ok "$ans" , "ok" );
+
+ $try = "\$x = Math::BigInt->new(1); \$x -= 9;";
+ $try .= "'ok' if \$x == -8;";
+ $ans = eval $try;
+ print "# For '$try'\n" if (!ok "$ans" , "ok" );
+
+ $try = "\$x = Math::BigInt->new(1); \$x *= 9;";
+ $try .= "'ok' if \$x == 9;";
+ $ans = eval $try;
+ print "# For '$try'\n" if (!ok "$ans" , "ok" );
+
+ $try = "\$x = Math::BigInt->new(10); \$x /= 2;";
+ $try .= "'ok' if \$x == 5;";
+ $ans = eval $try;
+ print "# For '$try'\n" if (!ok "$ans" , "ok" );
+
+ ###############################################################################
+ # check reversed order of arguments
+ $try = "\$x = Math::BigInt->new(10); \$x = 2 ** \$x;";
+ $try .= "'ok' if \$x == 1024;"; $ans = eval $try;
+ print "# For '$try'\n" if (!ok "$ans" , "ok" );
+
+ $try = "\$x = Math::BigInt->new(10); \$x = 2 * \$x;";
+ $try .= "'ok' if \$x == 20;"; $ans = eval $try;
+ print "# For '$try'\n" if (!ok "$ans" , "ok" );
+
+ $try = "\$x = Math::BigInt->new(10); \$x = 2 + \$x;";
+ $try .= "'ok' if \$x == 12;"; $ans = eval $try;
+ print "# For '$try'\n" if (!ok "$ans" , "ok" );
+
+ $try = "\$x = Math::BigInt->new(10); \$x = 2 - \$x;";
+ $try .= "'ok' if \$x == -8;"; $ans = eval $try;
+ print "# For '$try'\n" if (!ok "$ans" , "ok" );
+
+ $try = "\$x = Math::BigInt->new(10); \$x = 20 / \$x;";
+ $try .= "'ok' if \$x == 2;"; $ans = eval $try;
+ print "# For '$try'\n" if (!ok "$ans" , "ok" );
+
+ ###############################################################################
+ # check badd(4,5) form
+
+ $try = "\$x = Math::BigInt::badd(4,5);";
+ $try .= "'ok' if \$x == 9;";
+ $ans = eval $try;
+ print "# For '$try'\n" if (!ok "$ans" , "ok" );
+
+ $try = "\$x = Math::BigInt->badd(4,5);";
+ $try .= "'ok' if \$x == 9;";
+ $ans = eval $try;
+ print "# For '$try'\n" if (!ok "$ans" , "ok" );
+
+ ###############################################################################
+ # check proper length of internal arrays
+
+ $x = Math::BigInt->new(99999); is_valid($x);
+ $x += 1; ok ($x,100000); is_valid($x);
+ $x -= 1; ok ($x,99999); is_valid($x);
+
+ ###############################################################################
+ # check numify, these tests only make sense with Math::BigInt::Calc, since
+ # only this uses $BASE
+
+ my $BASE = int(1e5); # should access Math::BigInt::Calc::BASE
+ $x = Math::BigInt->new($BASE-1); ok ($x->numify(),$BASE-1);
+ $x = Math::BigInt->new(-($BASE-1)); ok ($x->numify(),-($BASE-1));
+ $x = Math::BigInt->new($BASE); ok ($x->numify(),$BASE);
+ $x = Math::BigInt->new(-$BASE); ok ($x->numify(),-$BASE);
+ $x = Math::BigInt->new( -($BASE*$BASE*1+$BASE*1+1) );
+ ok($x->numify(),-($BASE*$BASE*1+$BASE*1+1));
+
+ ###############################################################################
+ # test bug in _digits with length($c[-1]) where $c[-1] was "00001" instead of 1
+
+ $x = Math::BigInt->new(99998); $x++; $x++; $x++; $x++;
+ if ($x > 100000) { ok (1,1) } else { ok ("$x < 100000","$x > 100000"); }
+
+ $x = Math::BigInt->new(100003); $x++;
+ $y = Math::BigInt->new(1000000);
+ if ($x < 1000000) { ok (1,1) } else { ok ("$x > 1000000","$x < 1000000"); }
+
+ ###############################################################################
+ # bug in sub where number with at least 6 trailing zeros after any op failed
+
+ $x = Math::BigInt->new(123456); $z = Math::BigInt->new(10000); $z *= 10;
+ $x -= $z;
+ ok ($z, 100000);
+ ok ($x, 23456);
+
+ ###############################################################################
+ # bug with rest "-0" in div, causing further div()s to fail
+
+ $x = Math::BigInt->new('-322056000'); ($x,$y) = $x->bdiv('-12882240');
+
+ ok ($y,'0','not -0'); # not '-0'
+ is_valid($y);
+
+ ###############################################################################
+ # check undefs: NOT DONE YET
+
+ ###############################################################################
+ # bool
+
+ $x = Math::BigInt->new(1); if ($x) { ok (1,1); } else { ok($x,'to be true') }
+ $x = Math::BigInt->new(0); if (!$x) { ok (1,1); } else { ok($x,'to be false') }
+
+ ###############################################################################
+ # objectify()
+
+ @args = Math::BigInt::objectify(2,4,5);
+ ok (scalar @args,3); # 'Math::BigInt', 4, 5
+ ok ($args[0],'Math::BigInt');
+ ok ($args[1],4);
+ ok ($args[2],5);
+
+ @args = Math::BigInt::objectify(0,4,5);
+ ok (scalar @args,3); # 'Math::BigInt', 4, 5
+ ok ($args[0],'Math::BigInt');
+ ok ($args[1],4);
+ ok ($args[2],5);
+
+ @args = Math::BigInt::objectify(2,4,5);
+ ok (scalar @args,3); # 'Math::BigInt', 4, 5
+ ok ($args[0],'Math::BigInt');
+ ok ($args[1],4);
+ ok ($args[2],5);
+
+ @args = Math::BigInt::objectify(2,4,5,6,7);
+ ok (scalar @args,5); # 'Math::BigInt', 4, 5, 6, 7
+ ok ($args[0],'Math::BigInt');
+ ok ($args[1],4); ok (ref($args[1]),$args[0]);
+ ok ($args[2],5); ok (ref($args[2]),$args[0]);
+ ok ($args[3],6); ok (ref($args[3]),'');
+ ok ($args[4],7); ok (ref($args[4]),'');
+
+ @args = Math::BigInt::objectify(2,'Math::BigInt',4,5,6,7);
+ ok (scalar @args,5); # 'Math::BigInt', 4, 5, 6, 7
+ ok ($args[0],'Math::BigInt');
+ ok ($args[1],4); ok (ref($args[1]),$args[0]);
+ ok ($args[2],5); ok (ref($args[2]),$args[0]);
+ ok ($args[3],6); ok (ref($args[3]),'');
+ ok ($args[4],7); ok (ref($args[4]),'');
+
+ ###############################################################################
+ # test for floating-point input (other tests in bnorm() below)
+
+ $z = 1050000000000000; # may be int on systems with 64bit?
+ $x = Math::BigInt->new($z); ok ($x->bsstr(),'105e+13'); # not 1.03e+15
+ $z = 1e+129; # definitely a float (may fail on UTS)
+ $x = Math::BigInt->new($z); ok ($x->bsstr(),$z);
+
+ ###############################################################################
+ # prime number tests, also test for **= and length()
+ # found on: http://www.utm.edu/research/primes/notes/by_year.html
+
+ # ((2^148)-1)/17
+ $x = Math::BigInt->new(2); $x **= 148; $x++; $x = $x / 17;
+ ok ($x,"20988936657440586486151264256610222593863921");
+ ok ($x->length(),length "20988936657440586486151264256610222593863921");
+
+ # MM7 = 2^127-1
+ $x = Math::BigInt->new(2); $x **= 127; $x--;
+ ok ($x,"170141183460469231731687303715884105727");
+
+ # I am afraid the following is not yet possible due to slowness
+ # Also, testing for 2 meg output is a bit hard ;)
+ #$x = new Math::BigInt(2); $x **= 6972593; $x--;
+
+ # 593573509*2^332162+1 has exactly 1,000,000 digits
+ # takes about 24 mins on 300 Mhz, so cannot be done yet ;)
+ #$x = Math::BigInt->new(2); $x **= 332162; $x *= "593573509"; $x++;
+ #ok ($x->length(),1_000_000);
+
+ ###############################################################################
+ # inheritance and overriding of _swap
+
+ $x = Math::Foo->new(5);
+ $x = $x - 8; # 8 - 5 instead of 5-8
+ ok ($x,3);
+ ok (ref($x),'Math::Foo');
+
+ $x = Math::Foo->new(5);
+ $x = 8 - $x; # 5 - 8 instead of 8 - 5
+ ok ($x,-3);
+ ok (ref($x),'Math::Foo');
+
+ ###############################################################################
+ # all tests done
+
+ ###############################################################################
+ # Perl 5.005 does not like ok ($x,undef)
+
+ sub ok_undef
+ {
+ my $x = shift;
+
+ ok (1,1) and return if !defined $x;
+ ok ($x,'undef');
+ }
+
+ ###############################################################################
+ # sub to check validity of a BigInt internally, to ensure that no op leaves a
+ # number object in an invalid state (f.i. "-0")
+
+ sub is_valid
+ {
+ my ($x,$f) = @_;
+
+ my $e = 0; # error?
+ # ok as reference?
+ $e = 'Not a reference to Math::BigInt' if !ref($x);
+
+ # has ok sign?
+ $e = "Illegal sign $x->{sign} (expected: '+', '-', '-inf', '+inf' or 'NaN'"
+ if $e eq '0' && $x->{sign} !~ /^(\+|-|\+inf|-inf|NaN)$/;
+
+ $e = "-0 is invalid!" if $e ne '0' && $x->{sign} eq '-' && $x == 0;
+ $e = $CALC->_check($x->{value}) if $e eq '0';
+
+ # test done, see if error did crop up
+ ok (1,1), return if ($e eq '0');
+
+ ok (1,$e." op '$f'");
+ }
+
+ __END__
+ &is_odd
+ abc:0
+ 0:0
+ 1:1
+ 3:1
+ -1:1
+ -3:1
+ 10000001:1
+ 10000002:0
+ 2:0
+ &is_even
+ abc:0
+ 0:1
+ 1:0
+ 3:0
+ -1:0
+ -3:0
+ 10000001:0
+ 10000002:1
+ 2:1
+ &bacmp
+ +0:-0:0
+ +0:+1:-1
+ -1:+1:0
+ +1:-1:0
+ -1:+2:-1
+ +2:-1:1
+ -123456789:+987654321:-1
+ +123456789:-987654321:-1
+ +987654321:+123456789:1
+ -987654321:+123456789:1
+ -123:+4567889:-1
+ &bnorm
+ 123:123
+ # binary input
+ 0babc:NaN
+ 0b123:NaN
+ 0b0:0
+ -0b0:0
+ -0b1:-1
+ 0b0001:1
+ 0b001:1
+ 0b011:3
+ 0b101:5
+ 0b1000000000000000000000000000000:1073741824
+ # hex input
+ -0x0:0
+ 0xabcdefgh:NaN
+ 0x1234:4660
+ 0xabcdef:11259375
+ -0xABCDEF:-11259375
+ -0x1234:-4660
+ 0x12345678:305419896
+ # inf input
+ +inf:+inf
+ -inf:-inf
+ 0inf:NaN
+ # normal input
+ :NaN
+ abc:NaN
+ 1 a:NaN
+ 1bcd2:NaN
+ 11111b:NaN
+ +1z:NaN
+ -1z:NaN
+ 0:0
+ +0:0
+ +00:0
+ +000:0
+ 000000000000000000:0
+ -0:0
+ -0000:0
+ +1:1
+ +01:1
+ +001:1
+ +00000100000:100000
+ 123456789:123456789
+ -1:-1
+ -01:-1
+ -001:-1
+ -123456789:-123456789
+ -00000100000:-100000
+ 1_2_3:123
+ _123:NaN
+ _123_:NaN
+ _123_:NaN
+ 1__23:NaN
+ 10000000000E-1_0:1
+ 1E2:100
+ 1E1:10
+ 1E0:1
+ E1:NaN
+ E23:NaN
+ 1.23E2:123
+ 1.23E1:NaN
+ 1.23E-1:NaN
+ 100E-1:10
+ # floating point input
+ 1.01E2:101
+ 1010E-1:101
+ -1010E0:-1010
+ -1010E1:-10100
+ -1010E-2:NaN
+ -1.01E+1:NaN
+ -1.01E-1:NaN
+ &binf
+ 1:+:+inf
+ 2:-:-inf
+ 3:abc:+inf
+ &is_inf
+ +inf::1
+ -inf::1
+ abc::0
+ 1::0
+ NaN::0
+ -1::0
+ +inf:-:0
+ +inf:+:1
+ -inf:-:1
+ -inf:+:0
+ # it must be exactly /^[+-]inf$/
+ +infinity::0
+ -infinity::0
+ &blsft
+ abc:abc:NaN
+ +2:+2:+8
+ +1:+32:+4294967296
+ +1:+48:+281474976710656
+ +8:-2:NaN
+ # excercise base 10
+ +12345:4:10:123450000
+ -1234:0:10:-1234
+ +1234:0:10:+1234
+ +2:2:10:200
+ +12:2:10:1200
+ +1234:-3:10:NaN
+ 1234567890123:12:10:1234567890123000000000000
+ &brsft
+ abc:abc:NaN
+ +8:+2:+2
+ +4294967296:+32:+1
+ +281474976710656:+48:+1
+ +2:-2:NaN
+ # excercise base 10
+ -1234:0:10:-1234
+ +1234:0:10:+1234
+ +200:2:10:2
+ +1234:3:10:1
+ +1234:2:10:12
+ +1234:-3:10:NaN
+ 310000:4:10:31
+ 12300000:5:10:123
+ 1230000000000:10:10:123
+ 09876123456789067890:12:10:9876123
+ 1234561234567890123:13:10:123456
+ &bsstr
+ 1e+34:1e+34
+ 123.456E3:123456e+0
+ 100:1e+2
+ abc:NaN
+ &bneg
+ abd:NaN
+ +0:+0
+ +1:-1
+ -1:+1
+ +123456789:-123456789
+ -123456789:+123456789
+ &babs
+ abc:NaN
+ +0:+0
+ +1:+1
+ -1:+1
+ +123456789:+123456789
+ -123456789:+123456789
+ &bcmp
+ abc:abc:
+ abc:+0:
+ +0:abc:
+ +0:+0:0
+ -1:+0:-1
+ +0:-1:1
+ +1:+0:1
+ +0:+1:-1
+ -1:+1:-1
+ +1:-1:1
+ -1:-1:0
+ +1:+1:0
+ +123:+123:0
+ +123:+12:1
+ +12:+123:-1
+ -123:-123:0
+ -123:-12:-1
+ -12:-123:1
+ +123:+124:-1
+ +124:+123:1
+ -123:-124:1
+ -124:-123:-1
+ +100:+5:1
+ -123456789:+987654321:-1
+ +123456789:-987654321:1
+ -987654321:+123456789:-1
+ -inf:5432112345:-1
+ +inf:5432112345:1
+ -inf:-5432112345:-1
+ +inf:-5432112345:1
+ +inf:+inf:0
+ -inf:-inf:0
+ # return undef
+ +inf:NaN:
+ NaN:+inf:
+ -inf:NaN:
+ NaN:-inf:
+ &binc
+ abc:NaN
+ +0:+1
+ +1:+2
+ -1:+0
+ &bdec
+ abc:NaN
+ +0:-1
+ +1:+0
+ -1:-2
+ &badd
+ abc:abc:NaN
+ abc:+0:NaN
+ +0:abc:NaN
+ +0:+0:+0
+ +1:+0:+1
+ +0:+1:+1
+ +1:+1:+2
+ -1:+0:-1
+ +0:-1:-1
+ -1:-1:-2
+ -1:+1:+0
+ +1:-1:+0
+ +9:+1:+10
+ +99:+1:+100
+ +999:+1:+1000
+ +9999:+1:+10000
+ +99999:+1:+100000
+ +999999:+1:+1000000
+ +9999999:+1:+10000000
+ +99999999:+1:+100000000
+ +999999999:+1:+1000000000
+ +9999999999:+1:+10000000000
+ +99999999999:+1:+100000000000
+ +10:-1:+9
+ +100:-1:+99
+ +1000:-1:+999
+ +10000:-1:+9999
+ +100000:-1:+99999
+ +1000000:-1:+999999
+ +10000000:-1:+9999999
+ +100000000:-1:+99999999
+ +1000000000:-1:+999999999
+ +10000000000:-1:+9999999999
+ +123456789:+987654321:+1111111110
+ -123456789:+987654321:+864197532
+ -123456789:-987654321:-1111111110
+ +123456789:-987654321:-864197532
+ &bsub
+ abc:abc:NaN
+ abc:+0:NaN
+ +0:abc:NaN
+ +0:+0:+0
+ +1:+0:+1
+ +0:+1:-1
+ +1:+1:+0
+ -1:+0:-1
+ +0:-1:+1
+ -1:-1:+0
+ -1:+1:-2
+ +1:-1:+2
+ +9:+1:+8
+ +99:+1:+98
+ +999:+1:+998
+ +9999:+1:+9998
+ +99999:+1:+99998
+ +999999:+1:+999998
+ +9999999:+1:+9999998
+ +99999999:+1:+99999998
+ +999999999:+1:+999999998
+ +9999999999:+1:+9999999998
+ +99999999999:+1:+99999999998
+ +10:-1:+11
+ +100:-1:+101
+ +1000:-1:+1001
+ +10000:-1:+10001
+ +100000:-1:+100001
+ +1000000:-1:+1000001
+ +10000000:-1:+10000001
+ +100000000:-1:+100000001
+ +1000000000:-1:+1000000001
+ +10000000000:-1:+10000000001
+ +123456789:+987654321:-864197532
+ -123456789:+987654321:-1111111110
+ -123456789:-987654321:+864197532
+ +123456789:-987654321:+1111111110
+ &bmul
+ abc:abc:NaN
+ abc:+0:NaN
+ +0:abc:NaN
+ +0:+0:+0
+ +0:+1:+0
+ +1:+0:+0
+ +0:-1:+0
+ -1:+0:+0
+ +123456789123456789:+0:+0
+ +0:+123456789123456789:+0
+ -1:-1:+1
+ -1:+1:-1
+ +1:-1:-1
+ +1:+1:+1
+ +2:+3:+6
+ -2:+3:-6
+ +2:-3:-6
+ -2:-3:+6
+ +111:+111:+12321
+ +10101:+10101:+102030201
+ +1001001:+1001001:+1002003002001
+ +100010001:+100010001:+10002000300020001
+ +10000100001:+10000100001:+100002000030000200001
+ +11111111111:+9:+99999999999
+ +22222222222:+9:+199999999998
+ +33333333333:+9:+299999999997
+ +44444444444:+9:+399999999996
+ +55555555555:+9:+499999999995
+ +66666666666:+9:+599999999994
+ +77777777777:+9:+699999999993
+ +88888888888:+9:+799999999992
+ +99999999999:+9:+899999999991
+ +25:+25:+625
+ +12345:+12345:+152399025
+ +99999:+11111:+1111088889
+ &bdiv
+ abc:abc:NaN
+ abc:+1:abc:NaN
+ # really?
+ #+5:0:+inf
+ #-5:0:-inf
+ +1:abc:NaN
+ +0:+0:NaN
+ +0:+1:+0
+ +1:+0:NaN
+ +0:-1:+0
+ -1:+0:NaN
+ +1:+1:+1
+ -1:-1:+1
+ +1:-1:-1
+ -1:+1:-1
+ +1:+2:+0
+ +2:+1:+2
+ +1:+26:+0
+ +1000000000:+9:+111111111
+ +2000000000:+9:+222222222
+ +3000000000:+9:+333333333
+ +4000000000:+9:+444444444
+ +5000000000:+9:+555555555
+ +6000000000:+9:+666666666
+ +7000000000:+9:+777777777
+ +8000000000:+9:+888888888
+ +9000000000:+9:+1000000000
+ +35500000:+113:+314159
+ +71000000:+226:+314159
+ +106500000:+339:+314159
+ +1000000000:+3:+333333333
+ +10:+5:+2
+ +100:+4:+25
+ +1000:+8:+125
+ +10000:+16:+625
+ +999999999999:+9:+111111111111
+ +999999999999:+99:+10101010101
+ +999999999999:+999:+1001001001
+ +999999999999:+9999:+100010001
+ +999999999999999:+99999:+10000100001
+ +1111088889:+99999:+11111
+ -5:-3:1
+ 4:3:1
+ 1:3:0
+ -2:-3:0
+ -2:3:-1
+ 1:-3:-1
+ -5:3:-2
+ 4:-3:-2
+ &bmod
+ abc:abc:NaN
+ abc:+1:abc:NaN
+ +1:abc:NaN
+ +0:+0:NaN
+ +0:+1:+0
+ +1:+0:NaN
+ +0:-1:+0
+ -1:+0:NaN
+ +1:+1:+0
+ -1:-1:+0
+ +1:-1:+0
+ -1:+1:+0
+ +1:+2:+1
+ +2:+1:+0
+ +1000000000:+9:+1
+ +2000000000:+9:+2
+ +3000000000:+9:+3
+ +4000000000:+9:+4
+ +5000000000:+9:+5
+ +6000000000:+9:+6
+ +7000000000:+9:+7
+ +8000000000:+9:+8
+ +9000000000:+9:+0
+ +35500000:+113:+33
+ +71000000:+226:+66
+ +106500000:+339:+99
+ +1000000000:+3:+1
+ +10:+5:+0
+ +100:+4:+0
+ +1000:+8:+0
+ +10000:+16:+0
+ +999999999999:+9:+0
+ +999999999999:+99:+0
+ +999999999999:+999:+0
+ +999999999999:+9999:+0
+ +999999999999999:+99999:+0
+ -9:+5:+1
+ +9:-5:-1
+ -9:-5:-4
+ -5:3:1
+ -2:3:1
+ 4:3:1
+ 1:3:1
+ -5:-3:-2
+ -2:-3:-2
+ 4:-3:-2
+ 1:-3:-2
+ &bgcd
+ abc:abc:NaN
+ abc:+0:NaN
+ +0:abc:NaN
+ +0:+0:+0
+ +0:+1:+1
+ +1:+0:+1
+ +1:+1:+1
+ +2:+3:+1
+ +3:+2:+1
+ -3:+2:+1
+ +100:+625:+25
+ +4096:+81:+1
+ +1034:+804:+2
+ +27:+90:+56:+1
+ +27:+90:+54:+9
+ &blcm
+ abc:abc:NaN
+ abc:+0:NaN
+ +0:abc:NaN
+ +0:+0:NaN
+ +1:+0:+0
+ +0:+1:+0
+ +27:+90:+270
+ +1034:+804:+415668
+ &band
+ abc:abc:NaN
+ abc:0:NaN
+ 0:abc:NaN
+ 1:2:0
+ 3:2:2
+ +8:+2:+0
+ +281474976710656:+0:+0
+ +281474976710656:+1:+0
+ +281474976710656:+281474976710656:+281474976710656
+ &bior
+ abc:abc:NaN
+ abc:0:NaN
+ 0:abc:NaN
+ 1:2:3
+ +8:+2:+10
+ +281474976710656:+0:+281474976710656
+ +281474976710656:+1:+281474976710657
+ +281474976710656:+281474976710656:+281474976710656
+ &bxor
+ abc:abc:NaN
+ abc:0:NaN
+ 0:abc:NaN
+ 1:2:3
+ +8:+2:+10
+ +281474976710656:+0:+281474976710656
+ +281474976710656:+1:+281474976710657
+ +281474976710656:+281474976710656:+0
+ &bnot
+ abc:NaN
+ +0:-1
+ +8:-9
+ +281474976710656:-281474976710657
+ &digit
+ 0:0:0
+ 12:0:2
+ 12:1:1
+ 123:0:3
+ 123:1:2
+ 123:2:1
+ 123:-1:1
+ 123:-2:2
+ 123:-3:3
+ 123456:0:6
+ 123456:1:5
+ 123456:2:4
+ 123456:3:3
+ 123456:4:2
+ 123456:5:1
+ 123456:-1:1
+ 123456:-2:2
+ 123456:-3:3
+ 100000:-3:0
+ 100000:0:0
+ 100000:1:0
+ &mantissa
+ abc:NaN
+ 1e4:1
+ 2e0:2
+ 123:123
+ -1:-1
+ -2:-2
+ &exponent
+ abc:NaN
+ 1e4:4
+ 2e0:0
+ 123:0
+ -1:0
+ -2:0
+ 0:1
+ &parts
+ abc:NaN,NaN
+ 1e4:1,4
+ 2e0:2,0
+ 123:123,0
+ -1:-1,0
+ -2:-2,0
+ 0:0,1
+ &bpow
+ abc:12:NaN
+ 12:abc:NaN
+ 0:0:1
+ 0:1:0
+ 0:2:0
+ 0:-1:NaN
+ 0:-2:NaN
+ 1:0:1
+ 1:1:1
+ 1:2:1
+ 1:3:1
+ 1:-1:1
+ 1:-2:1
+ 1:-3:1
+ 2:0:1
+ 2:1:2
+ 2:2:4
+ 2:3:8
+ 3:3:27
+ 2:-1:NaN
+ -2:-1:NaN
+ 2:-2:NaN
+ -2:-2:NaN
+ +inf:1234500012:+inf
+ -inf:1234500012:-inf
+ +inf:-12345000123:+inf
+ -inf:-12345000123:-inf
+ # 1 ** -x => 1 / (1 ** x)
+ -1:0:1
+ -2:0:1
+ -1:1:-1
+ -1:2:1
+ -1:3:-1
+ -1:4:1
+ -1:5:-1
+ -1:-1:-1
+ -1:-2:1
+ -1:-3:-1
+ -1:-4:1
+ 10:2:100
+ 10:3:1000
+ 10:4:10000
+ 10:5:100000
+ 10:6:1000000
+ 10:7:10000000
+ 10:8:100000000
+ 10:9:1000000000
+ 10:20:100000000000000000000
+ 123456:2:15241383936
+ &length
+ 100:3
+ 10:2
+ 1:1
+ 0:1
+ 12345:5
+ 10000000000000000:17
+ -123:3
+ &bsqrt
+ 144:12
+ 16:4
+ 4:2
+ 2:1
+ 12:3
+ 256:16
+ 100000000:10000
+ 4000000000000:2000000
+ 1:1
+ 0:0
+ -2:NaN
+ Nan:NaN
+ &bround
+ $round_mode('trunc')
+ 1234:0:1234
+ 1234:2:1200
+ 123456:4:123400
+ 123456:5:123450
+ 123456:6:123456
+ +10123456789:5:+10123000000
+ -10123456789:5:-10123000000
+ +10123456789:9:+10123456700
+ -10123456789:9:-10123456700
+ +101234500:6:+101234000
+ -101234500:6:-101234000
+ #+101234500:-4:+101234000
+ #-101234500:-4:-101234000
+ $round_mode('zero')
+ +20123456789:5:+20123000000
+ -20123456789:5:-20123000000
+ +20123456789:9:+20123456800
+ -20123456789:9:-20123456800
+ +201234500:6:+201234000
+ -201234500:6:-201234000
+ #+201234500:-4:+201234000
+ #-201234500:-4:-201234000
+ +12345000:4:12340000
+ -12345000:4:-12340000
+ $round_mode('+inf')
+ +30123456789:5:+30123000000
+ -30123456789:5:-30123000000
+ +30123456789:9:+30123456800
+ -30123456789:9:-30123456800
+ +301234500:6:+301235000
+ -301234500:6:-301234000
+ #+301234500:-4:+301235000
+ #-301234500:-4:-301234000
+ +12345000:4:12350000
+ -12345000:4:-12340000
+ $round_mode('-inf')
+ +40123456789:5:+40123000000
+ -40123456789:5:-40123000000
+ +40123456789:9:+40123456800
+ -40123456789:9:-40123456800
+ +401234500:6:+401234000
+ +401234500:6:+401234000
+ #-401234500:-4:-401235000
+ #-401234500:-4:-401235000
+ +12345000:4:12340000
+ -12345000:4:-12350000
+ $round_mode('odd')
+ +50123456789:5:+50123000000
+ -50123456789:5:-50123000000
+ +50123456789:9:+50123456800
+ -50123456789:9:-50123456800
+ +501234500:6:+501235000
+ -501234500:6:-501235000
+ #+501234500:-4:+501235000
+ #-501234500:-4:-501235000
+ +12345000:4:12350000
+ -12345000:4:-12350000
+ $round_mode('even')
+ +60123456789:5:+60123000000
+ -60123456789:5:-60123000000
+ +60123456789:9:+60123456800
+ -60123456789:9:-60123456800
+ +601234500:6:+601234000
+ -601234500:6:-601234000
+ #+601234500:-4:+601234000
+ #-601234500:-4:-601234000
+ #-601234500:-9:0
+ #-501234500:-9:0
+ #-601234500:-8:0
+ #-501234500:-8:0
+ +1234567:7:1234567
+ +1234567:6:1234570
+ +12345000:4:12340000
+ -12345000:4:-12340000
+ &is_zero
+ 0:1
+ NaNzero:0
+ 123:0
+ -1:0
+ 1:0
+ &is_one
+ 0:0
+ 1:1
+ 2:0
+ -1:0
+ -2:0
+ # floor and ceil tests are pretty pointless in integer space...but play safe
+ &bfloor
+ 0:0
+ -1:-1
+ -2:-2
+ 2:2
+ 3:3
+ abc:NaN
+ &bceil
+ 0:0
+ -1:-1
+ -2:-2
+ 2:2
+ 3:3
+ abc:NaN
diff -c /dev/null 'perl-5.7.2/lib/Math/BigInt/t/mbimbf.t'
Index: ./lib/Math/BigInt/t/mbimbf.t
*** ./lib/Math/BigInt/t/mbimbf.t Thu Jan 1 02:00:00 1970
--- ./lib/Math/BigInt/t/mbimbf.t Tue Jul 10 05:28:56 2001
***************
*** 0 ****
--- 1,214 ----
+ #!/usr/bin/perl -w
+
+ # test accuracy, precicion and fallback, round_mode
+
+ use strict;
+ use Test;
+
+ BEGIN
+ {
+ $| = 1;
+ # chdir 't' if -d 't';
+ unshift @INC, '../lib'; # for running manually
+ plan tests => 103;
+ }
+
+ use Math::BigInt;
+ use Math::BigFloat;
+
+ my ($x,$y,$z,$u);
+
+ ###############################################################################
+ # test defaults and set/get
+
+ ok_undef ($Math::BigInt::accuracy);
+ ok_undef ($Math::BigInt::precision);
+ ok ($Math::BigInt::div_scale,40);
+ ok (Math::BigInt::round_mode(),'even');
+ ok ($Math::BigInt::rnd_mode,'even');
+
+ ok_undef ($Math::BigFloat::accuracy);
+ ok_undef ($Math::BigFloat::precision);
+ ok ($Math::BigFloat::div_scale,40);
+ ok ($Math::BigFloat::rnd_mode,'even');
+
+ # accuracy
+ foreach (qw/5 42 -1 0/)
+ {
+ ok ($Math::BigFloat::accuracy = $_,$_);
+ ok ($Math::BigInt::accuracy = $_,$_);
+ }
+ ok_undef ($Math::BigFloat::accuracy = undef);
+ ok_undef ($Math::BigInt::accuracy = undef);
+
+ # precision
+ foreach (qw/5 42 -1 0/)
+ {
+ ok ($Math::BigFloat::precision = $_,$_);
+ ok ($Math::BigInt::precision = $_,$_);
+ }
+ ok_undef ($Math::BigFloat::precision = undef);
+ ok_undef ($Math::BigInt::precision = undef);
+
+ # fallback
+ foreach (qw/5 42 1/)
+ {
+ ok ($Math::BigFloat::div_scale = $_,$_);
+ ok ($Math::BigInt::div_scale = $_,$_);
+ }
+ # illegal values are possible for fallback due to no accessor
+
+ # round_mode
+ foreach (qw/odd even zero trunc +inf -inf/)
+ {
+ ok ($Math::BigFloat::rnd_mode = $_,$_);
+ ok ($Math::BigInt::rnd_mode = $_,$_);
+ }
+ $Math::BigFloat::rnd_mode = 4;
+ ok ($Math::BigFloat::rnd_mode,4);
+ ok ($Math::BigInt::rnd_mode,'-inf'); # from above
+
+ $Math::BigInt::accuracy = undef;
+ $Math::BigInt::precision = undef;
+ # local copies
+ $x = Math::BigFloat->new(123.456);
+ ok_undef ($x->accuracy());
+ ok ($x->accuracy(5),5);
+ ok_undef ($x->accuracy(undef),undef);
+ ok_undef ($x->precision());
+ ok ($x->precision(5),5);
+ ok_undef ($x->precision(undef),undef);
+
+ # see if MBF changes MBIs values
+ ok ($Math::BigInt::accuracy = 42,42);
+ ok ($Math::BigFloat::accuracy = 64,64);
+ ok ($Math::BigInt::accuracy,42); # should be still 42
+ ok ($Math::BigFloat::accuracy,64); # should be still 64
+
+ ###############################################################################
+ # see if creating a number under set A or P will round it
+
+ $Math::BigInt::accuracy = 4;
+ $Math::BigInt::precision = 3;
+
+ ok (Math::BigInt->new(123456),123500); # with A
+ $Math::BigInt::accuracy = undef;
+ ok (Math::BigInt->new(123456),123000); # with P
+
+ $Math::BigFloat::accuracy = 4;
+ $Math::BigFloat::precision = -1;
+ $Math::BigInt::precision = undef;
+
+ ok (Math::BigFloat->new(123.456),123.5); # with A
+ $Math::BigFloat::accuracy = undef;
+ ok (Math::BigFloat->new(123.456),123.5); # with P from MBF, not MBI!
+
+ $Math::BigFloat::precision = undef;
+
+ ###############################################################################
+ # see if setting accuracy/precision actually rounds the number
+
+ $x = Math::BigFloat->new(123.456); $x->accuracy(4); ok ($x,123.5);
+ $x = Math::BigFloat->new(123.456); $x->precision(-2); ok ($x,123.46);
+
+ $x = Math::BigInt->new(123456); $x->accuracy(4); ok ($x,123500);
+ $x = Math::BigInt->new(123456); $x->precision(2); ok ($x,123500);
+
+ ###############################################################################
+ # test actual rounding via round()
+
+ $x = Math::BigFloat->new(123.456);
+ ok ($x->copy()->round(5,2),123.46);
+ ok ($x->copy()->round(4,2),123.5);
+ ok ($x->copy()->round(undef,-2),123.46);
+ ok ($x->copy()->round(undef,2),100);
+
+ $x = Math::BigFloat->new(123.45000);
+ ok ($x->copy()->round(undef,-1,'odd'),123.5);
+
+ # see if rounding is 'sticky'
+ $x = Math::BigFloat->new(123.4567);
+ $y = $x->copy()->bround(); # no-op since nowhere A or P defined
+
+ ok ($y,123.4567);
+ $y = $x->copy()->round(5,2);
+ ok ($y->accuracy(),5);
+ ok_undef ($y->precision()); # A has precedence, so P still unset
+ $y = $x->copy()->round(undef,2);
+ ok ($y->precision(),2);
+ ok_undef ($y->accuracy()); # P has precedence, so A still unset
+
+ # does copy work?
+ $x = Math::BigFloat->new(123.456); $x->accuracy(4); $x->precision(2);
+ $z = $x->copy(); ok ($z->accuracy(),4); ok ($z->precision(),2);
+
+ ###############################################################################
+ # test wether operations round properly afterwards
+ # These tests are not complete, since they do not excercise every "return"
+ # statement in the op's. But heh, it's better than nothing...
+
+ $x = Math::BigFloat->new(123.456);
+ $y = Math::BigFloat->new(654.321);
+ $x->{_a} = 5; # $x->accuracy(5) would round $x straightaway
+ $y->{_a} = 4; # $y->accuracy(4) would round $x straightaway
+
+ $z = $x + $y; ok ($z,777.8);
+ $z = $y - $x; ok ($z,530.9);
+ $z = $y * $x; ok ($z,80780);
+ $z = $x ** 2; ok ($z,15241);
+ $z = $x * $x; ok ($z,15241);
+ # not yet: $z = -$x; ok ($z,-123.46); ok ($x,123.456);
+ $z = $x->copy(); $z->{_a} = 2; $z = $z / 2; ok ($z,62);
+ $x = Math::BigFloat->new(123456); $x->{_a} = 4;
+ $z = $x->copy; $z++; ok ($z,123500);
+
+ $x = Math::BigInt->new(123456);
+ $y = Math::BigInt->new(654321);
+ $x->{_a} = 5; # $x->accuracy(5) would round $x straightaway
+ $y->{_a} = 4; # $y->accuracy(4) would round $x straightaway
+
+ $z = $x + $y; ok ($z,777800);
+ $z = $y - $x; ok ($z,530900);
+ $z = $y * $x; ok ($z,80780000000);
+ $z = $x ** 2; ok ($z,15241000000);
+ # not yet: $z = -$x; ok ($z,-123460); ok ($x,123456);
+ $z = $x->copy; $z++; ok ($z,123460);
+ $z = $x->copy(); $z->{_a} = 2; $z = $z / 2; ok ($z,62000);
+
+ ###############################################################################
+ # test mixed arguments
+
+ $x = Math::BigFloat->new(10);
+ $u = Math::BigFloat->new(2.5);
+ $y = Math::BigInt->new(2);
+
+ $z = $x + $y; ok ($z,12); ok (ref($z),'Math::BigFloat');
+ $z = $x / $y; ok ($z,5); ok (ref($z),'Math::BigFloat');
+ $z = $u * $y; ok ($z,5); ok (ref($z),'Math::BigFloat');
+
+ $y = Math::BigInt->new(12345);
+ $z = $u->copy()->bmul($y,2,0,'odd'); ok ($z,31000);
+ $z = $u->copy()->bmul($y,3,0,'odd'); ok ($z,30900);
+ $z = $u->copy()->bmul($y,undef,0,'odd'); ok ($z,30863);
+ $z = $u->copy()->bmul($y,undef,1,'odd'); ok ($z,30860);
+ $z = $u->copy()->bmul($y,undef,-1,'odd'); ok ($z,30862.5);
+
+ # breakage:
+ # $z = $y->copy()->bmul($u,2,0,'odd'); ok ($z,31000);
+ # $z = $y * $u; ok ($z,5); ok (ref($z),'Math::BigInt');
+ # $z = $y + $x; ok ($z,12); ok (ref($z),'Math::BigInt');
+ # $z = $y / $x; ok ($z,0); ok (ref($z),'Math::BigInt');
+
+ # all done
+
+ ###############################################################################
+ # Perl 5.005 does not like ok ($x,undef)
+
+ sub ok_undef
+ {
+ my $x = shift;
+
+ ok (1,1) and return if !defined $x;
+ ok ($x,'undef');
+ }
+
diff -c 'perl-5.7.1/lib/Math/Complex.pm' 'perl-5.7.2/lib/Math/Complex.pm'
Index: ./lib/Math/Complex.pm
*** ./lib/Math/Complex.pm Tue Mar 6 04:05:32 2001
--- ./lib/Math/Complex.pm Mon Jul 9 17:10:37 2001
***************
*** 9,15 ****
our($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $Inf);
! $VERSION = 1.31;
BEGIN {
unless ($^O eq 'unicosmk') {
--- 9,15 ----
our($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $Inf);
! $VERSION = 1.32;
BEGIN {
unless ($^O eq 'unicosmk') {
diff -c /dev/null 'perl-5.7.2/lib/Math/Complex.t'
Index: ./lib/Math/Complex.t
*** ./lib/Math/Complex.t Thu Jan 1 02:00:00 1970
--- ./lib/Math/Complex.t Mon Jul 9 17:10:37 2001
***************
*** 0 ****
--- 1,979 ----
+ #!./perl
+
+ # $RCSfile: complex.t,v $
+ #
+ # Regression tests for the Math::Complex pacakge
+ # -- Raphael Manfredi since Sep 1996
+ # -- Jarkko Hietaniemi since Mar 1997
+ # -- Daniel S. Lewart since Sep 1997
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use Math::Complex;
+
+ use vars qw($VERSION);
+
+ $VERSION = 1.91;
+
+ my ($args, $op, $target, $test, $test_set, $try, $val, $zvalue, @set, @val);
+
+ $test = 0;
+ $| = 1;
+ my @script = (
+ 'my ($res, $s0,$s1,$s2,$s3,$s4,$s5,$s6,$s7,$s8,$s9,$s10, $z0,$z1,$z2);' .
+ "\n\n"
+ );
+ my $eps = 1e-13;
+
+ if ($^O eq 'unicos') { # For some reason root() produces very inaccurate
+ $eps = 1e-10; # results in Cray UNICOS, and occasionally also
+ } # cos(), sin(), cosh(), sinh(). The division
+ # of doubles is the current suspect.
+
+ while (<DATA>) {
+ s/^\s+//;
+ next if $_ eq '' || /^\#/;
+ chomp;
+ $test_set = 0; # Assume not a test over a set of values
+ if (/^&(.+)/) {
+ $op = $1;
+ next;
+ }
+ elsif (/^\{(.+)\}/) {
+ set($1, \@set, \@val);
+ next;
+ }
+ elsif (s/^\|//) {
+ $test_set = 1; # Requests we loop over the set...
+ }
+ my @args = split(/:/);
+ if ($test_set == 1) {
+ my $i;
+ for ($i = 0; $i < @set; $i++) {
+ # complex number
+ $target = $set[$i];
+ # textual value as found in set definition
+ $zvalue = $val[$i];
+ test($zvalue, $target, @args);
+ }
+ } else {
+ test($op, undef, @args);
+ }
+ }
+
+ #
+
+ sub test_mutators {
+ my $op;
+
+ $test++;
+ push(@script, <<'EOT');
+ {
+ my $z = cplx( 1, 1);
+ $z->Re(2);
+ $z->Im(3);
+ print "# $test Re(z) = ",$z->Re(), " Im(z) = ", $z->Im(), " z = $z\n";
+ print 'not ' unless Re($z) == 2 and Im($z) == 3;
+ EOT
+ push(@script, qq(print "ok $test\\n"}\n));
+
+ $test++;
+ push(@script, <<'EOT');
+ {
+ my $z = cplx( 1, 1);
+ $z->abs(3 * sqrt(2));
+ print "# $test Re(z) = ",$z->Re(), " Im(z) = ", $z->Im(), " z = $z\n";
+ print 'not ' unless (abs($z) - 3 * sqrt(2)) < $eps and
+ (arg($z) - pi / 4 ) < $eps and
+ (Re($z) - 3 ) < $eps and
+ (Im($z) - 3 ) < $eps;
+ EOT
+ push(@script, qq(print "ok $test\\n"}\n));
+
+ $test++;
+ push(@script, <<'EOT');
+ {
+ my $z = cplx( 1, 1);
+ $z->arg(-3 / 4 * pi);
+ print "# $test Re(z) = ",$z->Re(), " Im(z) = ", $z->Im(), " z = $z\n";
+ print 'not ' unless (arg($z) + 3 / 4 * pi) < $eps and
+ (abs($z) - sqrt(2) ) < $eps and
+ (Re($z) + 1 ) < $eps and
+ (Im($z) + 1 ) < $eps;
+ EOT
+ push(@script, qq(print "ok $test\\n"}\n));
+ }
+
+ test_mutators();
+
+ my $constants = '
+ my $i = cplx(0, 1);
+ my $pi = cplx(pi, 0);
+ my $pii = cplx(0, pi);
+ my $pip2 = cplx(pi/2, 0);
+ my $zero = cplx(0, 0);
+ ';
+
+ push(@script, $constants);
+
+
+ # test the divbyzeros
+
+ sub test_dbz {
+ for my $op (@_) {
+ $test++;
+ push(@script, <<EOT);
+ eval '$op';
+ (\$bad) = (\$@ =~ /(.+)/);
+ print "# $test op = $op divbyzero? \$bad...\n";
+ print 'not ' unless (\$@ =~ /Division by zero/);
+ EOT
+ push(@script, qq(print "ok $test\\n";\n));
+ }
+ }
+
+ # test the logofzeros
+
+ sub test_loz {
+ for my $op (@_) {
+ $test++;
+ push(@script, <<EOT);
+ eval '$op';
+ (\$bad) = (\$@ =~ /(.+)/);
+ print "# $test op = $op logofzero? \$bad...\n";
+ print 'not ' unless (\$@ =~ /Logarithm of zero/);
+ EOT
+ push(@script, qq(print "ok $test\\n";\n));
+ }
+ }
+
+ test_dbz(
+ 'i/0',
+ 'acot(0)',
+ 'acot(+$i)',
+ # 'acoth(-1)', # Log of zero.
+ 'acoth(0)',
+ 'acoth(+1)',
+ 'acsc(0)',
+ 'acsch(0)',
+ 'asec(0)',
+ 'asech(0)',
+ 'atan($i)',
+ # 'atanh(-1)', # Log of zero.
+ 'atanh(+1)',
+ 'cot(0)',
+ 'coth(0)',
+ 'csc(0)',
+ 'csch(0)',
+ );
+
+ test_loz(
+ 'log($zero)',
+ 'atan(-$i)',
+ 'acot(-$i)',
+ 'atanh(-1)',
+ 'acoth(-1)',
+ );
+
+ # test the bad roots
+
+ sub test_broot {
+ for my $op (@_) {
+ $test++;
+ push(@script, <<EOT);
+ eval 'root(2, $op)';
+ (\$bad) = (\$@ =~ /(.+)/);
+ print "# $test op = $op badroot? \$bad...\n";
+ print 'not ' unless (\$@ =~ /root rank must be/);
+ EOT
+ push(@script, qq(print "ok $test\\n";\n));
+ }
+ }
+
+ test_broot(qw(-3 -2.1 0 0.99));
+
+ sub test_display_format {
+ $test++;
+ push @script, <<EOS;
+ print "# package display_format cartesian?\n";
+ print "not " unless Math::Complex->display_format eq 'cartesian';
+ print "ok $test\n";
+ EOS
+
+ push @script, <<EOS;
+ my \$j = (root(1,3))[1];
+
+ \$j->display_format('polar');
+ EOS
+
+ $test++;
+ push @script, <<EOS;
+ print "# j display_format polar?\n";
+ print "not " unless \$j->display_format eq 'polar';
+ print "ok $test\n";
+ EOS
+
+ $test++;
+ push @script, <<EOS;
+ print "# j = \$j\n";
+ print "not " unless "\$j" eq "[1,2pi/3]";
+ print "ok $test\n";
+
+ my %display_format;
+
+ %display_format = \$j->display_format;
+ EOS
+
+ $test++;
+ push @script, <<EOS;
+ print "# display_format{style} polar?\n";
+ print "not " unless \$display_format{style} eq 'polar';
+ print "ok $test\n";
+ EOS
+
+ $test++;
+ push @script, <<EOS;
+ print "# keys %display_format == 2?\n";
+ print "not " unless keys %display_format == 2;
+ print "ok $test\n";
+
+ \$j->display_format('style' => 'cartesian', 'format' => '%.5f');
+ EOS
+
+ $test++;
+ push @script, <<EOS;
+ print "# j = \$j\n";
+ print "not " unless "\$j" eq "-0.50000+0.86603i";
+ print "ok $test\n";
+
+ %display_format = \$j->display_format;
+ EOS
+
+ $test++;
+ push @script, <<EOS;
+ print "# display_format{format} %.5f?\n";
+ print "not " unless \$display_format{format} eq '%.5f';
+ print "ok $test\n";
+ EOS
+
+ $test++;
+ push @script, <<EOS;
+ print "# keys %display_format == 3?\n";
+ print "not " unless keys %display_format == 3;
+ print "ok $test\n";
+
+ \$j->display_format('format' => undef);
+ EOS
+
+ $test++;
+ push @script, <<EOS;
+ print "# j = \$j\n";
+ print "not " unless "\$j" =~ /^-0(?:\\.5(?:0000\\d+)?|\\.49999\\d+)\\+0.86602540\\d+i\$/;
+ print "ok $test\n";
+
+ \$j->display_format('style' => 'polar', 'polar_pretty_print' => 0);
+ EOS
+
+ $test++;
+ push @script, <<EOS;
+ print "# j = \$j\n";
+ print "not " unless "\$j" =~ /^\\[1,2\\.09439510\\d+\\]\$/;
+ print "ok $test\n";
+
+ \$j->display_format('style' => 'cartesian', 'format' => '(%.5g)');
+ EOS
+
+ $test++;
+ push @script, <<EOS;
+ print "# j = \$j\n";
+ print "not " unless "\$j" eq "(-0.5)+(0.86603)i";
+ print "ok $test\n";
+ EOS
+
+ $test++;
+ push @script, <<EOS;
+ print "# j display_format cartesian?\n";
+ print "not " unless \$j->display_format eq 'cartesian';
+ print "ok $test\n";
+ EOS
+ }
+
+ test_display_format();
+
+ print "1..$test\n";
+ eval join '', @script;
+ die $@ if $@;
+
+ sub abop {
+ my ($op) = @_;
+
+ push(@script, qq(print "# $op=\n";));
+ }
+
+ sub test {
+ my ($op, $z, @args) = @_;
+ my ($baop) = 0;
+ $test++;
+ my $i;
+ $baop = 1 if ($op =~ s/;=$//);
+ for ($i = 0; $i < @args; $i++) {
+ $val = value($args[$i]);
+ push @script, "\$z$i = $val;\n";
+ }
+ if (defined $z) {
+ $args = "'$op'"; # Really the value
+ $try = "abs(\$z0 - \$z1) <= $eps ? \$z1 : \$z0";
+ push @script, "\$res = $try; ";
+ push @script, "check($test, $args[0], \$res, \$z$#args, $args);\n";
+ } else {
+ my ($try, $args);
+ if (@args == 2) {
+ $try = "$op \$z0";
+ $args = "'$args[0]'";
+ } else {
+ $try = ($op =~ /^\w/) ? "$op(\$z0, \$z1)" : "\$z0 $op \$z1";
+ $args = "'$args[0]', '$args[1]'";
+ }
+ push @script, "\$res = $try; ";
+ push @script, "check($test, '$try', \$res, \$z$#args, $args);\n";
+ if (@args > 2 and $baop) { # binary assignment ops
+ $test++;
+ # check the op= works
+ push @script, <<EOB;
+ {
+ my \$za = cplx(ref \$z0 ? \@{\$z0->cartesian} : (\$z0, 0));
+
+ my (\$z1r, \$z1i) = ref \$z1 ? \@{\$z1->cartesian} : (\$z1, 0);
+
+ my \$zb = cplx(\$z1r, \$z1i);
+
+ \$za $op= \$zb;
+ my (\$zbr, \$zbi) = \@{\$zb->cartesian};
+
+ check($test, '\$z0 $op= \$z1', \$za, \$z$#args, $args);
+ EOB
+ $test++;
+ # check that the rhs has not changed
+ push @script, qq(print "not " unless (\$zbr == \$z1r and \$zbi == \$z1i););
+ push @script, qq(print "ok $test\\n";\n);
+ push @script, "}\n";
+ }
+ }
+ }
+
+ sub set {
+ my ($set, $setref, $valref) = @_;
+ @{$setref} = ();
+ @{$valref} = ();
+ my @set = split(/;\s*/, $set);
+ my @res;
+ my $i;
+ for ($i = 0; $i < @set; $i++) {
+ push(@{$valref}, $set[$i]);
+ my $val = value($set[$i]);
+ push @script, "\$s$i = $val;\n";
+ push @{$setref}, "\$s$i";
+ }
+ }
+
+ sub value {
+ local ($_) = @_;
+ if (/^\s*\((.*),(.*)\)/) {
+ return "cplx($1,$2)";
+ }
+ elsif (/^\s*([\-\+]?(?:\d+(\.\d+)?|\.\d+)(?:[e[\-\+]\d+])?)/) {
+ return "cplx($1,0)";
+ }
+ elsif (/^\s*\[(.*),(.*)\]/) {
+ return "cplxe($1,$2)";
+ }
+ elsif (/^\s*'(.*)'/) {
+ my $ex = $1;
+ $ex =~ s/\bz\b/$target/g;
+ $ex =~ s/\br\b/abs($target)/g;
+ $ex =~ s/\bt\b/arg($target)/g;
+ $ex =~ s/\ba\b/Re($target)/g;
+ $ex =~ s/\bb\b/Im($target)/g;
+ return $ex;
+ }
+ elsif (/^\s*"(.*)"/) {
+ return "\"$1\"";
+ }
+ return $_;
+ }
+
+ sub check {
+ my ($test, $try, $got, $expected, @z) = @_;
+
+ print "# @_\n";
+
+ if ("$got" eq "$expected"
+ ||
+ ($expected =~ /^-?\d/ && $got == $expected)
+ ||
+ (abs($got - $expected) < $eps)
+ ) {
+ print "ok $test\n";
+ } else {
+ print "not ok $test\n";
+ my $args = (@z == 1) ? "z = $z[0]" : "z0 = $z[0], z1 = $z[1]";
+ print "# '$try' expected: '$expected' got: '$got' for $args\n";
+ }
+ }
+
+ sub addsq {
+ my ($z1, $z2) = @_;
+ return ($z1 + i*$z2) * ($z1 - i*$z2);
+ }
+
+ sub subsq {
+ my ($z1, $z2) = @_;
+ return ($z1 + $z2) * ($z1 - $z2);
+ }
+
+ __END__
+ &+;=
+ (3,4):(3,4):(6,8)
+ (-3,4):(3,-4):(0,0)
+ (3,4):-3:(0,4)
+ 1:(4,2):(5,2)
+ [2,0]:[2,pi]:(0,0)
+
+ &++
+ (2,1):(3,1)
+
+ &-;=
+ (2,3):(-2,-3)
+ [2,pi/2]:[2,-(pi)/2]
+ 2:[2,0]:(0,0)
+ [3,0]:2:(1,0)
+ 3:(4,5):(-1,-5)
+ (4,5):3:(1,5)
+ (2,1):(3,5):(-1,-4)
+
+ &--
+ (1,2):(0,2)
+ [2,pi]:[3,pi]
+
+ &*;=
+ (0,1):(0,1):(-1,0)
+ (4,5):(1,0):(4,5)
+ [2,2*pi/3]:(1,0):[2,2*pi/3]
+ 2:(0,1):(0,2)
+ (0,1):3:(0,3)
+ (0,1):(4,1):(-1,4)
+ (2,1):(4,-1):(9,2)
+
+ &/;=
+ (3,4):(3,4):(1,0)
+ (4,-5):1:(4,-5)
+ 1:(0,1):(0,-1)
+ (0,6):(0,2):(3,0)
+ (9,2):(4,-1):(2,1)
+ [4,pi]:[2,pi/2]:[2,pi/2]
+ [2,pi/2]:[4,pi]:[0.5,-(pi)/2]
+
+ &**;=
+ (2,0):(3,0):(8,0)
+ (3,0):(2,0):(9,0)
+ (2,3):(4,0):(-119,-120)
+ (0,0):(1,0):(0,0)
+ (0,0):(2,3):(0,0)
+ (1,0):(0,0):(1,0)
+ (1,0):(1,0):(1,0)
+ (1,0):(2,3):(1,0)
+ (2,3):(0,0):(1,0)
+ (2,3):(1,0):(2,3)
+ (0,0):(0,0):(1,0)
+
+ &Re
+ (3,4):3
+ (-3,4):-3
+ [1,pi/2]:0
+
+ &Im
+ (3,4):4
+ (3,-4):-4
+ [1,pi/2]:1
+
+ &abs
+ (3,4):5
+ (-3,4):5
+
+ &arg
+ [2,0]:0
+ [-2,0]:pi
+
+ &~
+ (4,5):(4,-5)
+ (-3,4):(-3,-4)
+ [2,pi/2]:[2,-(pi)/2]
+
+ &<
+ (3,4):(1,2):0
+ (3,4):(3,2):0
+ (3,4):(3,8):1
+ (4,4):(5,129):1
+
+ &==
+ (3,4):(4,5):0
+ (3,4):(3,5):0
+ (3,4):(2,4):0
+ (3,4):(3,4):1
+
+ &sqrt
+ -9:(0,3)
+ (-100,0):(0,10)
+ (16,-30):(5,-3)
+
+ &stringify_cartesian
+ (-100,0):"-100"
+ (0,1):"i"
+ (4,-3):"4-3i"
+ (4,0):"4"
+ (-4,0):"-4"
+ (-2,4):"-2+4i"
+ (-2,-1):"-2-i"
+
+ &stringify_polar
+ [-1, 0]:"[1,pi]"
+ [1, pi/3]:"[1,pi/3]"
+ [6, -2*pi/3]:"[6,-2pi/3]"
+ [0.5, -9*pi/11]:"[0.5,-9pi/11]"
+
+ { (4,3); [3,2]; (-3,4); (0,2); [2,1] }
+
+ |'z + ~z':'2*Re(z)'
+ |'z - ~z':'2*i*Im(z)'
+ |'z * ~z':'abs(z) * abs(z)'
+
+ { (0.5, 0); (-0.5, 0); (2,3); [3,2]; (-3,2); (0,2); 3; 1.2; (-3, 0); (-2, -1); [2,1] }
+
+ |'(root(z, 4))[1] ** 4':'z'
+ |'(root(z, 5))[3] ** 5':'z'
+ |'(root(z, 8))[7] ** 8':'z'
+ |'abs(z)':'r'
+ |'acot(z)':'acotan(z)'
+ |'acsc(z)':'acosec(z)'
+ |'acsc(z)':'asin(1 / z)'
+ |'asec(z)':'acos(1 / z)'
+ |'cbrt(z)':'cbrt(r) * exp(i * t/3)'
+ |'cos(acos(z))':'z'
+ |'addsq(cos(z), sin(z))':1
+ |'cos(z)':'cosh(i*z)'
+ |'subsq(cosh(z), sinh(z))':1
+ |'cot(acot(z))':'z'
+ |'cot(z)':'1 / tan(z)'
+ |'cot(z)':'cotan(z)'
+ |'csc(acsc(z))':'z'
+ |'csc(z)':'1 / sin(z)'
+ |'csc(z)':'cosec(z)'
+ |'exp(log(z))':'z'
+ |'exp(z)':'exp(a) * exp(i * b)'
+ |'ln(z)':'log(z)'
+ |'log(exp(z))':'z'
+ |'log(z)':'log(r) + i*t'
+ |'log10(z)':'log(z) / log(10)'
+ |'logn(z, 2)':'log(z) / log(2)'
+ |'logn(z, 3)':'log(z) / log(3)'
+ |'sec(asec(z))':'z'
+ |'sec(z)':'1 / cos(z)'
+ |'sin(asin(z))':'z'
+ |'sin(i * z)':'i * sinh(z)'
+ |'sqrt(z) * sqrt(z)':'z'
+ |'sqrt(z)':'sqrt(r) * exp(i * t/2)'
+ |'tan(atan(z))':'z'
+ |'z**z':'exp(z * log(z))'
+
+ { (1,1); [1,0.5]; (-2, -1); 2; -3; (-1,0.5); (0,0.5); 0.5; (2, 0); (-1, -2) }
+
+ |'cosh(acosh(z))':'z'
+ |'coth(acoth(z))':'z'
+ |'coth(z)':'1 / tanh(z)'
+ |'coth(z)':'cotanh(z)'
+ |'csch(acsch(z))':'z'
+ |'csch(z)':'1 / sinh(z)'
+ |'csch(z)':'cosech(z)'
+ |'sech(asech(z))':'z'
+ |'sech(z)':'1 / cosh(z)'
+ |'sinh(asinh(z))':'z'
+ |'tanh(atanh(z))':'z'
+
+ { (0.2,-0.4); [1,0.5]; -1.2; (-1,0.5); 0.5; (1.1, 0) }
+
+ |'acos(cos(z)) ** 2':'z * z'
+ |'acosh(cosh(z)) ** 2':'z * z'
+ |'acoth(z)':'acotanh(z)'
+ |'acoth(z)':'atanh(1 / z)'
+ |'acsch(z)':'acosech(z)'
+ |'acsch(z)':'asinh(1 / z)'
+ |'asech(z)':'acosh(1 / z)'
+ |'asin(sin(z))':'z'
+ |'asinh(sinh(z))':'z'
+ |'atan(tan(z))':'z'
+ |'atanh(tanh(z))':'z'
+
+ &log
+ (-2.0,0):( 0.69314718055995, 3.14159265358979)
+ (-1.0,0):( 0 , 3.14159265358979)
+ (-0.5,0):( -0.69314718055995, 3.14159265358979)
+ ( 0.5,0):( -0.69314718055995, 0 )
+ ( 1.0,0):( 0 , 0 )
+ ( 2.0,0):( 0.69314718055995, 0 )
+
+ &log
+ ( 2, 3):( 1.28247467873077, 0.98279372324733)
+ (-2, 3):( 1.28247467873077, 2.15879893034246)
+ (-2,-3):( 1.28247467873077, -2.15879893034246)
+ ( 2,-3):( 1.28247467873077, -0.98279372324733)
+
+ &sin
+ (-2.0,0):( -0.90929742682568, 0 )
+ (-1.0,0):( -0.84147098480790, 0 )
+ (-0.5,0):( -0.47942553860420, 0 )
+ ( 0.0,0):( 0 , 0 )
+ ( 0.5,0):( 0.47942553860420, 0 )
+ ( 1.0,0):( 0.84147098480790, 0 )
+ ( 2.0,0):( 0.90929742682568, 0 )
+
+ &sin
+ ( 2, 3):( 9.15449914691143, -4.16890695996656)
+ (-2, 3):( -9.15449914691143, -4.16890695996656)
+ (-2,-3):( -9.15449914691143, 4.16890695996656)
+ ( 2,-3):( 9.15449914691143, 4.16890695996656)
+
+ &cos
+ (-2.0,0):( -0.41614683654714, 0 )
+ (-1.0,0):( 0.54030230586814, 0 )
+ (-0.5,0):( 0.87758256189037, 0 )
+ ( 0.0,0):( 1 , 0 )
+ ( 0.5,0):( 0.87758256189037, 0 )
+ ( 1.0,0):( 0.54030230586814, 0 )
+ ( 2.0,0):( -0.41614683654714, 0 )
+
+ &cos
+ ( 2, 3):( -4.18962569096881, -9.10922789375534)
+ (-2, 3):( -4.18962569096881, 9.10922789375534)
+ (-2,-3):( -4.18962569096881, -9.10922789375534)
+ ( 2,-3):( -4.18962569096881, 9.10922789375534)
+
+ &tan
+ (-2.0,0):( 2.18503986326152, 0 )
+ (-1.0,0):( -1.55740772465490, 0 )
+ (-0.5,0):( -0.54630248984379, 0 )
+ ( 0.0,0):( 0 , 0 )
+ ( 0.5,0):( 0.54630248984379, 0 )
+ ( 1.0,0):( 1.55740772465490, 0 )
+ ( 2.0,0):( -2.18503986326152, 0 )
+
+ &tan
+ ( 2, 3):( -0.00376402564150, 1.00323862735361)
+ (-2, 3):( 0.00376402564150, 1.00323862735361)
+ (-2,-3):( 0.00376402564150, -1.00323862735361)
+ ( 2,-3):( -0.00376402564150, -1.00323862735361)
+
+ &sec
+ (-2.0,0):( -2.40299796172238, 0 )
+ (-1.0,0):( 1.85081571768093, 0 )
+ (-0.5,0):( 1.13949392732455, 0 )
+ ( 0.0,0):( 1 , 0 )
+ ( 0.5,0):( 1.13949392732455, 0 )
+ ( 1.0,0):( 1.85081571768093, 0 )
+ ( 2.0,0):( -2.40299796172238, 0 )
+
+ &sec
+ ( 2, 3):( -0.04167496441114, 0.09061113719624)
+ (-2, 3):( -0.04167496441114, -0.09061113719624)
+ (-2,-3):( -0.04167496441114, 0.09061113719624)
+ ( 2,-3):( -0.04167496441114, -0.09061113719624)
+
+ &csc
+ (-2.0,0):( -1.09975017029462, 0 )
+ (-1.0,0):( -1.18839510577812, 0 )
+ (-0.5,0):( -2.08582964293349, 0 )
+ ( 0.5,0):( 2.08582964293349, 0 )
+ ( 1.0,0):( 1.18839510577812, 0 )
+ ( 2.0,0):( 1.09975017029462, 0 )
+
+ &csc
+ ( 2, 3):( 0.09047320975321, 0.04120098628857)
+ (-2, 3):( -0.09047320975321, 0.04120098628857)
+ (-2,-3):( -0.09047320975321, -0.04120098628857)
+ ( 2,-3):( 0.09047320975321, -0.04120098628857)
+
+ &cot
+ (-2.0,0):( 0.45765755436029, 0 )
+ (-1.0,0):( -0.64209261593433, 0 )
+ (-0.5,0):( -1.83048772171245, 0 )
+ ( 0.5,0):( 1.83048772171245, 0 )
+ ( 1.0,0):( 0.64209261593433, 0 )
+ ( 2.0,0):( -0.45765755436029, 0 )
+
+ &cot
+ ( 2, 3):( -0.00373971037634, -0.99675779656936)
+ (-2, 3):( 0.00373971037634, -0.99675779656936)
+ (-2,-3):( 0.00373971037634, 0.99675779656936)
+ ( 2,-3):( -0.00373971037634, 0.99675779656936)
+
+ &asin
+ (-2.0,0):( -1.57079632679490, 1.31695789692482)
+ (-1.0,0):( -1.57079632679490, 0 )
+ (-0.5,0):( -0.52359877559830, 0 )
+ ( 0.0,0):( 0 , 0 )
+ ( 0.5,0):( 0.52359877559830, 0 )
+ ( 1.0,0):( 1.57079632679490, 0 )
+ ( 2.0,0):( 1.57079632679490, -1.31695789692482)
+
+ &asin
+ ( 2, 3):( 0.57065278432110, 1.98338702991654)
+ (-2, 3):( -0.57065278432110, 1.98338702991654)
+ (-2,-3):( -0.57065278432110, -1.98338702991654)
+ ( 2,-3):( 0.57065278432110, -1.98338702991654)
+
+ &acos
+ (-2.0,0):( 3.14159265358979, -1.31695789692482)
+ (-1.0,0):( 3.14159265358979, 0 )
+ (-0.5,0):( 2.09439510239320, 0 )
+ ( 0.0,0):( 1.57079632679490, 0 )
+ ( 0.5,0):( 1.04719755119660, 0 )
+ ( 1.0,0):( 0 , 0 )
+ ( 2.0,0):( 0 , 1.31695789692482)
+
+ &acos
+ ( 2, 3):( 1.00014354247380, -1.98338702991654)
+ (-2, 3):( 2.14144911111600, -1.98338702991654)
+ (-2,-3):( 2.14144911111600, 1.98338702991654)
+ ( 2,-3):( 1.00014354247380, 1.98338702991654)
+
+ &atan
+ (-2.0,0):( -1.10714871779409, 0 )
+ (-1.0,0):( -0.78539816339745, 0 )
+ (-0.5,0):( -0.46364760900081, 0 )
+ ( 0.0,0):( 0 , 0 )
+ ( 0.5,0):( 0.46364760900081, 0 )
+ ( 1.0,0):( 0.78539816339745, 0 )
+ ( 2.0,0):( 1.10714871779409, 0 )
+
+ &atan
+ ( 2, 3):( 1.40992104959658, 0.22907268296854)
+ (-2, 3):( -1.40992104959658, 0.22907268296854)
+ (-2,-3):( -1.40992104959658, -0.22907268296854)
+ ( 2,-3):( 1.40992104959658, -0.22907268296854)
+
+ &asec
+ (-2.0,0):( 2.09439510239320, 0 )
+ (-1.0,0):( 3.14159265358979, 0 )
+ (-0.5,0):( 3.14159265358979, -1.31695789692482)
+ ( 0.5,0):( 0 , 1.31695789692482)
+ ( 1.0,0):( 0 , 0 )
+ ( 2.0,0):( 1.04719755119660, 0 )
+
+ &asec
+ ( 2, 3):( 1.42041072246703, 0.23133469857397)
+ (-2, 3):( 1.72118193112276, 0.23133469857397)
+ (-2,-3):( 1.72118193112276, -0.23133469857397)
+ ( 2,-3):( 1.42041072246703, -0.23133469857397)
+
+ &acsc
+ (-2.0,0):( -0.52359877559830, 0 )
+ (-1.0,0):( -1.57079632679490, 0 )
+ (-0.5,0):( -1.57079632679490, 1.31695789692482)
+ ( 0.5,0):( 1.57079632679490, -1.31695789692482)
+ ( 1.0,0):( 1.57079632679490, 0 )
+ ( 2.0,0):( 0.52359877559830, 0 )
+
+ &acsc
+ ( 2, 3):( 0.15038560432786, -0.23133469857397)
+ (-2, 3):( -0.15038560432786, -0.23133469857397)
+ (-2,-3):( -0.15038560432786, 0.23133469857397)
+ ( 2,-3):( 0.15038560432786, 0.23133469857397)
+
+ &acot
+ (-2.0,0):( -0.46364760900081, 0 )
+ (-1.0,0):( -0.78539816339745, 0 )
+ (-0.5,0):( -1.10714871779409, 0 )
+ ( 0.5,0):( 1.10714871779409, 0 )
+ ( 1.0,0):( 0.78539816339745, 0 )
+ ( 2.0,0):( 0.46364760900081, 0 )
+
+ &acot
+ ( 2, 3):( 0.16087527719832, -0.22907268296854)
+ (-2, 3):( -0.16087527719832, -0.22907268296854)
+ (-2,-3):( -0.16087527719832, 0.22907268296854)
+ ( 2,-3):( 0.16087527719832, 0.22907268296854)
+
+ &sinh
+ (-2.0,0):( -3.62686040784702, 0 )
+ (-1.0,0):( -1.17520119364380, 0 )
+ (-0.5,0):( -0.52109530549375, 0 )
+ ( 0.0,0):( 0 , 0 )
+ ( 0.5,0):( 0.52109530549375, 0 )
+ ( 1.0,0):( 1.17520119364380, 0 )
+ ( 2.0,0):( 3.62686040784702, 0 )
+
+ &sinh
+ ( 2, 3):( -3.59056458998578, 0.53092108624852)
+ (-2, 3):( 3.59056458998578, 0.53092108624852)
+ (-2,-3):( 3.59056458998578, -0.53092108624852)
+ ( 2,-3):( -3.59056458998578, -0.53092108624852)
+
+ &cosh
+ (-2.0,0):( 3.76219569108363, 0 )
+ (-1.0,0):( 1.54308063481524, 0 )
+ (-0.5,0):( 1.12762596520638, 0 )
+ ( 0.0,0):( 1 , 0 )
+ ( 0.5,0):( 1.12762596520638, 0 )
+ ( 1.0,0):( 1.54308063481524, 0 )
+ ( 2.0,0):( 3.76219569108363, 0 )
+
+ &cosh
+ ( 2, 3):( -3.72454550491532, 0.51182256998738)
+ (-2, 3):( -3.72454550491532, -0.51182256998738)
+ (-2,-3):( -3.72454550491532, 0.51182256998738)
+ ( 2,-3):( -3.72454550491532, -0.51182256998738)
+
+ &tanh
+ (-2.0,0):( -0.96402758007582, 0 )
+ (-1.0,0):( -0.76159415595576, 0 )
+ (-0.5,0):( -0.46211715726001, 0 )
+ ( 0.0,0):( 0 , 0 )
+ ( 0.5,0):( 0.46211715726001, 0 )
+ ( 1.0,0):( 0.76159415595576, 0 )
+ ( 2.0,0):( 0.96402758007582, 0 )
+
+ &tanh
+ ( 2, 3):( 0.96538587902213, -0.00988437503832)
+ (-2, 3):( -0.96538587902213, -0.00988437503832)
+ (-2,-3):( -0.96538587902213, 0.00988437503832)
+ ( 2,-3):( 0.96538587902213, 0.00988437503832)
+
+ &sech
+ (-2.0,0):( 0.26580222883408, 0 )
+ (-1.0,0):( 0.64805427366389, 0 )
+ (-0.5,0):( 0.88681888397007, 0 )
+ ( 0.0,0):( 1 , 0 )
+ ( 0.5,0):( 0.88681888397007, 0 )
+ ( 1.0,0):( 0.64805427366389, 0 )
+ ( 2.0,0):( 0.26580222883408, 0 )
+
+ &sech
+ ( 2, 3):( -0.26351297515839, -0.03621163655877)
+ (-2, 3):( -0.26351297515839, 0.03621163655877)
+ (-2,-3):( -0.26351297515839, -0.03621163655877)
+ ( 2,-3):( -0.26351297515839, 0.03621163655877)
+
+ &csch
+ (-2.0,0):( -0.27572056477178, 0 )
+ (-1.0,0):( -0.85091812823932, 0 )
+ (-0.5,0):( -1.91903475133494, 0 )
+ ( 0.5,0):( 1.91903475133494, 0 )
+ ( 1.0,0):( 0.85091812823932, 0 )
+ ( 2.0,0):( 0.27572056477178, 0 )
+
+ &csch
+ ( 2, 3):( -0.27254866146294, -0.04030057885689)
+ (-2, 3):( 0.27254866146294, -0.04030057885689)
+ (-2,-3):( 0.27254866146294, 0.04030057885689)
+ ( 2,-3):( -0.27254866146294, 0.04030057885689)
+
+ &coth
+ (-2.0,0):( -1.03731472072755, 0 )
+ (-1.0,0):( -1.31303528549933, 0 )
+ (-0.5,0):( -2.16395341373865, 0 )
+ ( 0.5,0):( 2.16395341373865, 0 )
+ ( 1.0,0):( 1.31303528549933, 0 )
+ ( 2.0,0):( 1.03731472072755, 0 )
+
+ &coth
+ ( 2, 3):( 1.03574663776500, 0.01060478347034)
+ (-2, 3):( -1.03574663776500, 0.01060478347034)
+ (-2,-3):( -1.03574663776500, -0.01060478347034)
+ ( 2,-3):( 1.03574663776500, -0.01060478347034)
+
+ &asinh
+ (-2.0,0):( -1.44363547517881, 0 )
+ (-1.0,0):( -0.88137358701954, 0 )
+ (-0.5,0):( -0.48121182505960, 0 )
+ ( 0.0,0):( 0 , 0 )
+ ( 0.5,0):( 0.48121182505960, 0 )
+ ( 1.0,0):( 0.88137358701954, 0 )
+ ( 2.0,0):( 1.44363547517881, 0 )
+
+ &asinh
+ ( 2, 3):( 1.96863792579310, 0.96465850440760)
+ (-2, 3):( -1.96863792579310, 0.96465850440761)
+ (-2,-3):( -1.96863792579310, -0.96465850440761)
+ ( 2,-3):( 1.96863792579310, -0.96465850440760)
+
+ &acosh
+ (-2.0,0):( 1.31695789692482, 3.14159265358979)
+ (-1.0,0):( 0, 3.14159265358979)
+ (-0.5,0):( 0, 2.09439510239320)
+ ( 0.0,0):( 0, 1.57079632679490)
+ ( 0.5,0):( 0, 1.04719755119660)
+ ( 1.0,0):( 0 , 0 )
+ ( 2.0,0):( 1.31695789692482, 0 )
+
+ &acosh
+ ( 2, 3):( 1.98338702991654, 1.00014354247380)
+ (-2, 3):( 1.98338702991653, 2.14144911111600)
+ (-2,-3):( 1.98338702991653, -2.14144911111600)
+ ( 2,-3):( 1.98338702991654, -1.00014354247380)
+
+ &atanh
+ (-2.0,0):( -0.54930614433405, 1.57079632679490)
+ (-0.5,0):( -0.54930614433405, 0 )
+ ( 0.0,0):( 0 , 0 )
+ ( 0.5,0):( 0.54930614433405, 0 )
+ ( 2.0,0):( 0.54930614433405, 1.57079632679490)
+
+ &atanh
+ ( 2, 3):( 0.14694666622553, 1.33897252229449)
+ (-2, 3):( -0.14694666622553, 1.33897252229449)
+ (-2,-3):( -0.14694666622553, -1.33897252229449)
+ ( 2,-3):( 0.14694666622553, -1.33897252229449)
+
+ &asech
+ (-2.0,0):( 0 , 2.09439510239320)
+ (-1.0,0):( 0 , 3.14159265358979)
+ (-0.5,0):( 1.31695789692482, 3.14159265358979)
+ ( 0.5,0):( 1.31695789692482, 0 )
+ ( 1.0,0):( 0 , 0 )
+ ( 2.0,0):( 0 , 1.04719755119660)
+
+ &asech
+ ( 2, 3):( 0.23133469857397, -1.42041072246703)
+ (-2, 3):( 0.23133469857397, -1.72118193112276)
+ (-2,-3):( 0.23133469857397, 1.72118193112276)
+ ( 2,-3):( 0.23133469857397, 1.42041072246703)
+
+ &acsch
+ (-2.0,0):( -0.48121182505960, 0 )
+ (-1.0,0):( -0.88137358701954, 0 )
+ (-0.5,0):( -1.44363547517881, 0 )
+ ( 0.5,0):( 1.44363547517881, 0 )
+ ( 1.0,0):( 0.88137358701954, 0 )
+ ( 2.0,0):( 0.48121182505960, 0 )
+
+ &acsch
+ ( 2, 3):( 0.15735549884499, -0.22996290237721)
+ (-2, 3):( -0.15735549884499, -0.22996290237721)
+ (-2,-3):( -0.15735549884499, 0.22996290237721)
+ ( 2,-3):( 0.15735549884499, 0.22996290237721)
+
+ &acoth
+ (-2.0,0):( -0.54930614433405, 0 )
+ (-0.5,0):( -0.54930614433405, 1.57079632679490)
+ ( 0.5,0):( 0.54930614433405, 1.57079632679490)
+ ( 2.0,0):( 0.54930614433405, 0 )
+
+ &acoth
+ ( 2, 3):( 0.14694666622553, -0.23182380450040)
+ (-2, 3):( -0.14694666622553, -0.23182380450040)
+ (-2,-3):( -0.14694666622553, 0.23182380450040)
+ ( 2,-3):( 0.14694666622553, 0.23182380450040)
+
+ # eof
diff -c 'perl-5.7.1/lib/Math/Trig.pm' 'perl-5.7.2/lib/Math/Trig.pm'
Index: ./lib/Math/Trig.pm
*** ./lib/Math/Trig.pm Sun Apr 1 21:41:50 2001
--- ./lib/Math/Trig.pm Mon Jul 9 17:10:37 2001
***************
*** 16,22 ****
@ISA = qw(Exporter);
! $VERSION = 1.00;
my @angcnv = qw(rad2deg rad2grad
deg2rad deg2grad
--- 16,22 ----
@ISA = qw(Exporter);
! $VERSION = 1.01;
my @angcnv = qw(rad2deg rad2grad
deg2rad deg2grad
diff -c /dev/null 'perl-5.7.2/lib/Math/Trig.t'
Index: ./lib/Math/Trig.t
*** ./lib/Math/Trig.t Thu Jan 1 02:00:00 1970
--- ./lib/Math/Trig.t Mon Jul 9 17:10:37 2001
***************
*** 0 ****
--- 1,200 ----
+ #!./perl
+
+ #
+ # Regression tests for the Math::Trig package
+ #
+ # The tests are quite modest as the Math::Complex tests exercise
+ # these quite vigorously.
+ #
+ # -- Jarkko Hietaniemi, April 1997
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use Math::Trig;
+
+ use strict;
+
+ use vars qw($x $y $z);
+
+ my $eps = 1e-11;
+
+ if ($^O eq 'unicos') { # See lib/Math/Complex.pm and t/lib/complex.t.
+ $eps = 1e-10;
+ }
+
+ sub near ($$;$) {
+ my $e = defined $_[2] ? $_[2] : $eps;
+ $_[1] ? (abs($_[0]/$_[1] - 1) < $e) : abs($_[0]) < $e;
+ }
+
+ print "1..26\n";
+
+ $x = 0.9;
+ print 'not ' unless (near(tan($x), sin($x) / cos($x)));
+ print "ok 1\n";
+
+ print 'not ' unless (near(sinh(2), 3.62686040784702));
+ print "ok 2\n";
+
+ print 'not ' unless (near(acsch(0.1), 2.99822295029797));
+ print "ok 3\n";
+
+ $x = asin(2);
+ print 'not ' unless (ref $x eq 'Math::Complex');
+ print "ok 4\n";
+
+ # avoid using Math::Complex here
+ $x =~ /^([^-]+)(-[^i]+)i$/;
+ ($y, $z) = ($1, $2);
+ print 'not ' unless (near($y, 1.5707963267949) and
+ near($z, -1.31695789692482));
+ print "ok 5\n";
+
+ print 'not ' unless (near(deg2rad(90), pi/2));
+ print "ok 6\n";
+
+ print 'not ' unless (near(rad2deg(pi), 180));
+ print "ok 7\n";
+
+ use Math::Trig ':radial';
+
+ {
+ my ($r,$t,$z) = cartesian_to_cylindrical(1,1,1);
+
+ print 'not ' unless (near($r, sqrt(2))) and
+ (near($t, deg2rad(45))) and
+ (near($z, 1));
+ print "ok 8\n";
+
+ ($x,$y,$z) = cylindrical_to_cartesian($r, $t, $z);
+
+ print 'not ' unless (near($x, 1)) and
+ (near($y, 1)) and
+ (near($z, 1));
+ print "ok 9\n";
+
+ ($r,$t,$z) = cartesian_to_cylindrical(1,1,0);
+
+ print 'not ' unless (near($r, sqrt(2))) and
+ (near($t, deg2rad(45))) and
+ (near($z, 0));
+ print "ok 10\n";
+
+ ($x,$y,$z) = cylindrical_to_cartesian($r, $t, $z);
+
+ print 'not ' unless (near($x, 1)) and
+ (near($y, 1)) and
+ (near($z, 0));
+ print "ok 11\n";
+ }
+
+ {
+ my ($r,$t,$f) = cartesian_to_spherical(1,1,1);
+
+ print 'not ' unless (near($r, sqrt(3))) and
+ (near($t, deg2rad(45))) and
+ (near($f, atan2(sqrt(2), 1)));
+ print "ok 12\n";
+
+ ($x,$y,$z) = spherical_to_cartesian($r, $t, $f);
+
+ print 'not ' unless (near($x, 1)) and
+ (near($y, 1)) and
+ (near($z, 1));
+ print "ok 13\n";
+
+ ($r,$t,$f) = cartesian_to_spherical(1,1,0);
+
+ print 'not ' unless (near($r, sqrt(2))) and
+ (near($t, deg2rad(45))) and
+ (near($f, deg2rad(90)));
+ print "ok 14\n";
+
+ ($x,$y,$z) = spherical_to_cartesian($r, $t, $f);
+
+ print 'not ' unless (near($x, 1)) and
+ (near($y, 1)) and
+ (near($z, 0));
+ print "ok 15\n";
+ }
+
+ {
+ my ($r,$t,$z) = cylindrical_to_spherical(spherical_to_cylindrical(1,1,1));
+
+ print 'not ' unless (near($r, 1)) and
+ (near($t, 1)) and
+ (near($z, 1));
+ print "ok 16\n";
+
+ ($r,$t,$z) = spherical_to_cylindrical(cylindrical_to_spherical(1,1,1));
+
+ print 'not ' unless (near($r, 1)) and
+ (near($t, 1)) and
+ (near($z, 1));
+ print "ok 17\n";
+ }
+
+ {
+ use Math::Trig 'great_circle_distance';
+
+ print 'not '
+ unless (near(great_circle_distance(0, 0, 0, pi/2), pi/2));
+ print "ok 18\n";
+
+ print 'not '
+ unless (near(great_circle_distance(0, 0, pi, pi), pi));
+ print "ok 19\n";
+
+ # London to Tokyo.
+ my @L = (deg2rad(-0.5), deg2rad(90 - 51.3));
+ my @T = (deg2rad(139.8),deg2rad(90 - 35.7));
+
+ my $km = great_circle_distance(@L, @T, 6378);
+
+ print 'not ' unless (near($km, 9605.26637021388));
+ print "ok 20\n";
+ }
+
+ {
+ my $R2D = 57.295779513082320876798154814169;
+
+ sub frac { $_[0] - int($_[0]) }
+
+ my $lotta_radians = deg2rad(1E+20, 1);
+ print "not " unless near($lotta_radians, 1E+20/$R2D);
+ print "ok 21\n";
+
+ my $negat_degrees = rad2deg(-1E20, 1);
+ print "not " unless near($negat_degrees, -1E+20*$R2D);
+ print "ok 22\n";
+
+ my $posit_degrees = rad2deg(-10000, 1);
+ print "not " unless near($posit_degrees, -10000*$R2D);
+ print "ok 23\n";
+ }
+
+ {
+ use Math::Trig 'great_circle_direction';
+
+ print 'not '
+ unless (near(great_circle_direction(0, 0, 0, pi/2), pi));
+ print "ok 24\n";
+
+ print 'not '
+ unless (near(great_circle_direction(0, 0, pi, pi), -pi()/2));
+ print "ok 25\n";
+
+ # London to Tokyo.
+ my @L = (deg2rad(-0.5), deg2rad(90 - 51.3));
+ my @T = (deg2rad(139.8),deg2rad(90 - 35.7));
+
+ my $rad = great_circle_direction(@L, @T);
+
+ print 'not ' unless (near($rad, -0.546644569997376));
+ print "ok 26\n";
+ }
+
+ # eof
diff -c /dev/null 'perl-5.7.2/lib/Memoize.pm'
Index: ./lib/Memoize.pm
*** ./lib/Memoize.pm Thu Jan 1 02:00:00 1970
--- ./lib/Memoize.pm Mon Jul 9 17:10:37 2001
***************
*** 0 ****
--- 1,1037 ----
+ # -*- mode: perl; perl-indent-level: 2; -*-
+ # Memoize.pm
+ #
+ # Transparent memoization of idempotent functions
+ #
+ # Copyright 1998, 1999, 2000, 2001 M-J. Dominus.
+ # You may copy and distribute this program under the
+ # same terms as Perl itself. If in doubt,
+ # write to mjd-perl-memoize+@plover.com for a license.
+ #
+ # Version 0.65 beta $Revision: 1.17 $ $Date: 2000/10/24 04:33:49 $
+
+ package Memoize;
+ $VERSION = '0.65';
+
+ # Compile-time constants
+ sub SCALAR () { 0 }
+ sub LIST () { 1 }
+
+
+ #
+ # Usage memoize(functionname/ref,
+ # { NORMALIZER => coderef, INSTALL => name,
+ # LIST_CACHE => descriptor, SCALAR_CACHE => descriptor }
+ #
+
+ use Carp;
+ use Exporter;
+ use vars qw($DEBUG);
+ use Config; # Dammit.
+ @ISA = qw(Exporter);
+ @EXPORT = qw(memoize);
+ @EXPORT_OK = qw(unmemoize flush_cache);
+ use strict;
+
+ my %memotable;
+ my %revmemotable;
+ my @CONTEXT_TAGS = qw(MERGE TIE MEMORY FAULT HASH);
+ my %IS_CACHE_TAG = map {($_ => 1)} @CONTEXT_TAGS;
+
+ # Raise an error if the user tries to specify one of thesepackage as a
+ # tie for LIST_CACHE
+
+ my %scalar_only = map {($_ => 1)} qw(DB_File GDBM_File SDBM_File ODBM_File NDBM_File);
+
+ sub memoize {
+ my $fn = shift;
+ my %options = @_;
+ my $options = \%options;
+
+ unless (defined($fn) &&
+ (ref $fn eq 'CODE' || ref $fn eq '')) {
+ croak "Usage: memoize 'functionname'|coderef {OPTIONS}";
+ }
+
+ my $uppack = caller; # TCL me Elmo!
+ my $cref; # Code reference to original function
+ my $name = (ref $fn ? undef : $fn);
+
+ # Convert function names to code references
+ $cref = &_make_cref($fn, $uppack);
+
+ # Locate function prototype, if any
+ my $proto = prototype $cref;
+ if (defined $proto) { $proto = "($proto)" }
+ else { $proto = "" }
+
+ # I would like to get rid of the eval, but there seems not to be any
+ # other way to set the prototype properly. The switch here for
+ # 'usethreads' works around a bug in threadperl having to do with
+ # magic goto. It would be better to fix the bug and use the magic
+ # goto version everywhere.
+ my $wrapper =
+ $Config{usethreads}
+ ? eval "sub $proto { &_memoizer(\$cref, \@_); }"
+ : eval "sub $proto { unshift \@_, \$cref; goto &_memoizer; }";
+
+ my $normalizer = $options{NORMALIZER};
+ if (defined $normalizer && ! ref $normalizer) {
+ $normalizer = _make_cref($normalizer, $uppack);
+ }
+
+ my $install_name;
+ if (defined $options->{INSTALL}) {
+ # INSTALL => name
+ $install_name = $options->{INSTALL};
+ } elsif (! exists $options->{INSTALL}) {
+ # No INSTALL option provided; use original name if possible
+ $install_name = $name;
+ } else {
+ # INSTALL => undef means don't install
+ }
+
+ if (defined $install_name) {
+ $install_name = $uppack . '::' . $install_name
+ unless $install_name =~ /::/;
+ no strict;
+ local($^W) = 0; # ``Subroutine $install_name redefined at ...''
+ *{$install_name} = $wrapper; # Install memoized version
+ }
+
+ $revmemotable{$wrapper} = "" . $cref; # Turn code ref into hash key
+
+ # These will be the caches
+ my %caches;
+ for my $context (qw(SCALAR LIST)) {
+ # suppress subsequent 'uninitialized value' warnings
+ $options{"${context}_CACHE"} ||= '';
+
+ my $cache_opt = $options{"${context}_CACHE"};
+ my @cache_opt_args;
+ if (ref $cache_opt) {
+ @cache_opt_args = @$cache_opt;
+ $cache_opt = shift @cache_opt_args;
+ }
+ if ($cache_opt eq 'FAULT') { # no cache
+ $caches{$context} = undef;
+ } elsif ($cache_opt eq 'HASH') { # user-supplied hash
+ my $cache = $cache_opt_args[0];
+ my $package = ref(tied %$cache);
+ if ($context eq 'LIST' && $scalar_only{$package}) {
+ croak("You can't use $package for LIST_CACHE because it can only store scalars");
+ }
+ $caches{$context} = $cache;
+ } elsif ($cache_opt eq '' || $IS_CACHE_TAG{$cache_opt}) {
+ # default is that we make up an in-memory hash
+ $caches{$context} = {};
+ # (this might get tied later, or MERGEd away)
+ } else {
+ croak "Unrecognized option to `${context}_CACHE': `$cache_opt' should be one of (@CONTEXT_TAGS); aborting";
+ }
+ }
+
+ # Perhaps I should check here that you didn't supply *both* merge
+ # options. But if you did, it does do something reasonable: They
+ # both get merged to the same in-memory hash.
+ if ($options{SCALAR_CACHE} eq 'MERGE') {
+ $caches{SCALAR} = $caches{LIST};
+ } elsif ($options{LIST_CACHE} eq 'MERGE') {
+ $caches{LIST} = $caches{SCALAR};
+ }
+
+ # Now deal with the TIE options
+ {
+ my $context;
+ foreach $context (qw(SCALAR LIST)) {
+ # If the relevant option wasn't `TIE', this call does nothing.
+ _my_tie($context, $caches{$context}, $options); # Croaks on failure
+ }
+ }
+
+ # We should put some more stuff in here eventually.
+ # We've been saying that for serveral versions now.
+ # And you know what? More stuff keeps going in!
+ $memotable{$cref} =
+ {
+ O => $options, # Short keys here for things we need to access frequently
+ N => $normalizer,
+ U => $cref,
+ MEMOIZED => $wrapper,
+ PACKAGE => $uppack,
+ NAME => $install_name,
+ S => $caches{SCALAR},
+ L => $caches{LIST},
+ };
+
+ $wrapper # Return just memoized version
+ }
+
+ # This function tries to load a tied hash class and tie the hash to it.
+ sub _my_tie {
+ my ($context, $hash, $options) = @_;
+ my $fullopt = $options->{"${context}_CACHE"};
+
+ # We already checked to make sure that this works.
+ my $shortopt = (ref $fullopt) ? $fullopt->[0] : $fullopt;
+
+ return unless defined $shortopt && $shortopt eq 'TIE';
+ carp("TIE option to memoize() is deprecated; use HASH instead") if $^W;
+
+
+ my @args = ref $fullopt ? @$fullopt : ();
+ shift @args;
+ my $module = shift @args;
+ if ($context eq 'LIST' && $scalar_only{$module}) {
+ croak("You can't use $module for LIST_CACHE because it can only store scalars");
+ }
+ my $modulefile = $module . '.pm';
+ $modulefile =~ s{::}{/}g;
+ eval { require $modulefile };
+ if ($@) {
+ croak "Memoize: Couldn't load hash tie module `$module': $@; aborting";
+ }
+ my $rc = (tie %$hash => $module, @args);
+ unless ($rc) {
+ croak "Memoize: Couldn't tie hash to `$module': $!; aborting";
+ }
+ 1;
+ }
+
+ sub flush_cache {
+ my $func = _make_cref($_[0], scalar caller);
+ my $info = $memotable{$revmemotable{$func}};
+ die "$func not memoized" unless defined $info;
+ for my $context (qw(S L)) {
+ my $cache = $info->{$context};
+ if (tied %$cache && ! (tied %$cache)->can('CLEAR')) {
+ my $funcname = defined($info->{NAME}) ?
+ "function $info->{NAME}" : "anonymous function $func";
+ my $context = {S => 'scalar', L => 'list'}->{$context};
+ croak "Tied cache hash for $context-context $funcname does not support flushing";
+ } else {
+ %$cache = ();
+ }
+ }
+ }
+
+ # This is the function that manages the memo tables.
+ sub _memoizer {
+ my $orig = shift; # stringized version of ref to original func.
+ my $info = $memotable{$orig};
+ my $normalizer = $info->{N};
+
+ my $argstr;
+ my $context = (wantarray() ? LIST : SCALAR);
+
+ if (defined $normalizer) {
+ no strict;
+ if ($context == SCALAR) {
+ $argstr = &{$normalizer}(@_);
+ } elsif ($context == LIST) {
+ ($argstr) = &{$normalizer}(@_);
+ } else {
+ croak "Internal error \#41; context was neither LIST nor SCALAR\n";
+ }
+ } else { # Default normalizer
+ local $^W = 0;
+ $argstr = join chr(28),@_;
+ }
+
+ if ($context == SCALAR) {
+ my $cache = $info->{S};
+ _crap_out($info->{NAME}, 'scalar') unless $cache;
+ if (exists $cache->{$argstr}) {
+ return $cache->{$argstr};
+ } else {
+ my $val = &{$info->{U}}(@_);
+ # Scalars are considered to be lists; store appropriately
+ if ($info->{O}{SCALAR_CACHE} eq 'MERGE') {
+ $cache->{$argstr} = [$val];
+ } else {
+ $cache->{$argstr} = $val;
+ }
+ $val;
+ }
+ } elsif ($context == LIST) {
+ my $cache = $info->{L};
+ _crap_out($info->{NAME}, 'list') unless $cache;
+ if (exists $cache->{$argstr}) {
+ my $val = $cache->{$argstr};
+ # If LISTCONTEXT=>MERGE, then the function never returns lists,
+ # so we have a scalar value cached, so just return it straightaway:
+ return ($val) if $info->{O}{LIST_CACHE} eq 'MERGE';
+ # Maybe in a later version we can use a faster test.
+
+ # Otherwise, we cached an array containing the returned list:
+ return @$val;
+ } else {
+ my $q = $cache->{$argstr} = [&{$info->{U}}(@_)];
+ @$q;
+ }
+ } else {
+ croak "Internal error \#42; context was neither LIST nor SCALAR\n";
+ }
+ }
+
+ sub unmemoize {
+ my $f = shift;
+ my $uppack = caller;
+ my $cref = _make_cref($f, $uppack);
+
+ unless (exists $revmemotable{$cref}) {
+ croak "Could not unmemoize function `$f', because it was not memoized to begin with";
+ }
+
+ my $tabent = $memotable{$revmemotable{$cref}};
+ unless (defined $tabent) {
+ croak "Could not figure out how to unmemoize function `$f'";
+ }
+ my $name = $tabent->{NAME};
+ if (defined $name) {
+ no strict;
+ local($^W) = 0; # ``Subroutine $install_name redefined at ...''
+ *{$name} = $tabent->{U}; # Replace with original function
+ }
+ undef $memotable{$revmemotable{$cref}};
+ undef $revmemotable{$cref};
+
+ # This removes the last reference to the (possibly tied) memo tables
+ # my ($old_function, $memotabs) = @{$tabent}{'U','S','L'};
+ # undef $tabent;
+
+ # # Untie the memo tables if they were tied.
+ # my $i;
+ # for $i (0,1) {
+ # if (tied %{$memotabs->[$i]}) {
+ # warn "Untying hash #$i\n";
+ # untie %{$memotabs->[$i]};
+ # }
+ # }
+
+ $tabent->{U};
+ }
+
+ sub _make_cref {
+ my $fn = shift;
+ my $uppack = shift;
+ my $cref;
+ my $name;
+
+ if (ref $fn eq 'CODE') {
+ $cref = $fn;
+ } elsif (! ref $fn) {
+ if ($fn =~ /::/) {
+ $name = $fn;
+ } else {
+ $name = $uppack . '::' . $fn;
+ }
+ no strict;
+ if (defined $name and !defined(&$name)) {
+ croak "Cannot operate on nonexistent function `$fn'";
+ }
+ # $cref = \&$name;
+ $cref = *{$name}{CODE};
+ } else {
+ my $parent = (caller(1))[3]; # Function that called _make_cref
+ croak "Usage: argument 1 to `$parent' must be a function name or reference.\n";
+ }
+ $DEBUG and warn "${name}($fn) => $cref in _make_cref\n";
+ $cref;
+ }
+
+ sub _crap_out {
+ my ($funcname, $context) = @_;
+ if (defined $funcname) {
+ croak "Function `$funcname' called in forbidden $context context; faulting";
+ } else {
+ croak "Anonymous function called in forbidden $context context; faulting";
+ }
+ }
+
+ 1;
+
+
+
+
+
+ =head1 NAME
+
+ Memoize - Make your functions faster by trading space for time
+
+ =head1 SYNOPSIS
+
+ use Memoize;
+ memoize('slow_function');
+ slow_function(arguments); # Is faster than it was before
+
+
+ This is normally all you need to know. However, many options are available:
+
+ memoize(function, options...);
+
+ Options include:
+
+ NORMALIZER => function
+ INSTALL => new_name
+
+ SCALAR_CACHE => 'MEMORY'
+ SCALAR_CACHE => ['HASH', \%cache_hash ]
+ SCALAR_CACHE => 'FAULT'
+ SCALAR_CACHE => 'MERGE'
+
+ LIST_CACHE => 'MEMORY'
+ LIST_CACHE => ['HASH', \%cache_hash ]
+ LIST_CACHE => 'FAULT'
+ LIST_CACHE => 'MERGE'
+
+ =head1 DESCRIPTION
+
+ `Memoizing' a function makes it faster by trading space for time. It
+ does this by caching the return values of the function in a table.
+ If you call the function again with the same arguments, C<memoize>
+ jmups in and gives you the value out of the table, instead of letting
+ the function compute the value all over again.
+
+ Here is an extreme example. Consider the Fibonacci sequence, defined
+ by the following function:
+
+ # Compute Fibonacci numbers
+ sub fib {
+ my $n = shift;
+ return $n if $n < 2;
+ fib($n-1) + fib($n-2);
+ }
+
+ This function is very slow. Why? To compute fib(14), it first wants
+ to compute fib(13) and fib(12), and add the results. But to compute
+ fib(13), it first has to compute fib(12) and fib(11), and then it
+ comes back and computes fib(12) all over again even though the answer
+ is the same. And both of the times that it wants to compute fib(12),
+ it has to compute fib(11) from scratch, and then it has to do it
+ again each time it wants to compute fib(13). This function does so
+ much recomputing of old results that it takes a really long time to
+ run---fib(14) makes 1,200 extra recursive calls to itself, to compute
+ and recompute things that it already computed.
+
+ This function is a good candidate for memoization. If you memoize the
+ `fib' function above, it will compute fib(14) exactly once, the first
+ time it needs to, and then save the result in a table. Then if you
+ ask for fib(14) again, it gives you the result out of the table.
+ While computing fib(14), instead of computing fib(12) twice, it does
+ it once; the second time it needs the value it gets it from the table.
+ It doesn't compute fib(11) four times; it computes it once, getting it
+ from the table the next three times. Instead of making 1,200
+ recursive calls to `fib', it makes 15. This makes the function about
+ 150 times faster.
+
+ You could do the memoization yourself, by rewriting the function, like
+ this:
+
+ # Compute Fibonacci numbers, memoized version
+ { my @fib;
+ sub fib {
+ my $n = shift;
+ return $fib[$n] if defined $fib[$n];
+ return $fib[$n] = $n if $n < 2;
+ $fib[$n] = fib($n-1) + fib($n-2);
+ }
+ }
+
+ Or you could use this module, like this:
+
+ use Memoize;
+ memoize('fib');
+
+ # Rest of the fib function just like the original version.
+
+ This makes it easy to turn memoizing on and off.
+
+ Here's an even simpler example: I wrote a simple ray tracer; the
+ program would look in a certain direction, figure out what it was
+ looking at, and then convert the `color' value (typically a string
+ like `red') of that object to a red, green, and blue pixel value, like
+ this:
+
+ for ($direction = 0; $direction < 300; $direction++) {
+ # Figure out which object is in direction $direction
+ $color = $object->{color};
+ ($r, $g, $b) = @{&ColorToRGB($color)};
+ ...
+ }
+
+ Since there are relatively few objects in a picture, there are only a
+ few colors, which get looked up over and over again. Memoizing
+ C<ColorToRGB> speeded up the program by several percent.
+
+ =head1 DETAILS
+
+ This module exports exactly one function, C<memoize>. The rest of the
+ functions in this package are None of Your Business.
+
+ You should say
+
+ memoize(function)
+
+ where C<function> is the name of the function you want to memoize, or
+ a reference to it. C<memoize> returns a reference to the new,
+ memoized version of the function, or C<undef> on a non-fatal error.
+ At present, there are no non-fatal errors, but there might be some in
+ the future.
+
+ If C<function> was the name of a function, then C<memoize> hides the
+ old version and installs the new memoized version under the old name,
+ so that C<&function(...)> actually invokes the memoized version.
+
+ =head1 OPTIONS
+
+ There are some optional options you can pass to C<memoize> to change
+ the way it behaves a little. To supply options, invoke C<memoize>
+ like this:
+
+ memoize(function, NORMALIZER => function,
+ INSTALL => newname,
+ SCALAR_CACHE => option,
+ LIST_CACHE => option
+ );
+
+ Each of these options is optional; you can include some, all, or none
+ of them.
+
+ =head2 INSTALL
+
+ If you supply a function name with C<INSTALL>, memoize will install
+ the new, memoized version of the function under the name you give.
+ For example,
+
+ memoize('fib', INSTALL => 'fastfib')
+
+ installs the memoized version of C<fib> as C<fastfib>; without the
+ C<INSTALL> option it would have replaced the old C<fib> with the
+ memoized version.
+
+ To prevent C<memoize> from installing the memoized version anywhere, use
+ C<INSTALL =E<gt> undef>.
+
+ =head2 NORMALIZER
+
+ Suppose your function looks like this:
+
+ # Typical call: f('aha!', A => 11, B => 12);
+ sub f {
+ my $a = shift;
+ my %hash = @_;
+ $hash{B} ||= 2; # B defaults to 2
+ $hash{C} ||= 7; # C defaults to 7
+
+ # Do something with $a, %hash
+ }
+
+ Now, the following calls to your function are all completely equivalent:
+
+ f(OUCH);
+ f(OUCH, B => 2);
+ f(OUCH, C => 7);
+ f(OUCH, B => 2, C => 7);
+ f(OUCH, C => 7, B => 2);
+ (etc.)
+
+ However, unless you tell C<Memoize> that these calls are equivalent,
+ it will not know that, and it will compute the values for these
+ invocations of your function separately, and store them separately.
+
+ To prevent this, supply a C<NORMALIZER> function that turns the
+ program arguments into a string in a way that equivalent arguments
+ turn into the same string. A C<NORMALIZER> function for C<f> above
+ might look like this:
+
+ sub normalize_f {
+ my $a = shift;
+ my %hash = @_;
+ $hash{B} ||= 2;
+ $hash{C} ||= 7;
+
+ join($;, $a, map ($_ => $hash{$_}) sort keys %hash);
+ }
+
+ Each of the argument lists above comes out of the C<normalize_f>
+ function looking exactly the same, like this:
+
+ OUCH^\B^\2^\C^\7
+
+ You would tell C<Memoize> to use this normalizer this way:
+
+ memoize('f', NORMALIZER => 'normalize_f');
+
+ C<memoize> knows that if the normalized version of the arguments is
+ the same for two argument lists, then it can safely look up the value
+ that it computed for one argument list and return it as the result of
+ calling the function with the other argument list, even if the
+ argument lists look different.
+
+ The default normalizer just concatenates the arguments with C<$;> in
+ between. This always works correctly for functions with only one
+ string argument, and also when the arguments never contain C<$;>
+ (which is normally character #28, control-\. ) However, it can
+ confuse certain argument lists:
+
+ normalizer("a\034", "b")
+ normalizer("a", "\034b")
+ normalizer("a\034\034b")
+
+ for example.
+
+ Since hash keys are strings, the default normalizer will not
+ distinguish between C<undef> and the empty string. It also won't work
+ when the function's arguments are references. For example, consider
+ a function C<g> which gets two arguments: A number, and a reference to
+ an array of numbers:
+
+ g(13, [1,2,3,4,5,6,7]);
+
+ The default normalizer will turn this into something like
+ C<"13\024ARRAY(0x436c1f)">. That would be all right, except that a
+ subsequent array of numbers might be stored at a different location
+ even though it contains the same data. If this happens, C<Memoize>
+ will think that the arguments are different, even though they are
+ equivalent. In this case, a normalizer like this is appropriate:
+
+ sub normalize { join ' ', $_[0], @{$_[1]} }
+
+ For the example above, this produces the key "13 1 2 3 4 5 6 7".
+
+ Another use for normalizers is when the function depends on data other
+ than those in its arguments. Suppose you have a function which
+ returns a value which depends on the current hour of the day:
+
+ sub on_duty {
+ my ($problem_type) = @_;
+ my $hour = (localtime)[2];
+ open my $fh, "$DIR/$problem_type" or die...;
+ my $line;
+ while ($hour-- > 0)
+ $line = <$fh>;
+ }
+ return $line;
+ }
+
+ At 10:23, this function generates the tenth line of a data file; at
+ 3:45 PM it generates the 15th line instead. By default, C<Memoize>
+ will only see the $problem_type argument. To fix this, include the
+ current hour in the normalizer:
+
+ sub normalize { join ' ', (localtime)[2], @_ }
+
+ The calling context of the function (scalar or list context) is
+ propagated to the normalizer. This means that if the memoized
+ function will treat its arguments differently in list context than it
+ would in scalar context, you can have the normalizer function select
+ its behavior based on the results of C<wantarray>. Even if called in
+ a list context, a normalizer should still return a single string.
+
+ =head2 C<SCALAR_CACHE>, C<LIST_CACHE>
+
+ Normally, C<Memoize> caches your function's return values into an
+ ordinary Perl hash variable. However, you might like to have the
+ values cached on the disk, so that they persist from one run of your
+ program to the next, or you might like to associate some other
+ interesting semantics with the cached values.
+
+ There's a slight complication under the hood of C<Memoize>: There are
+ actually I<two> caches, one for scalar values and one for list values.
+ When your function is called in scalar context, its return value is
+ cached in one hash, and when your function is called in list context,
+ its value is cached in the other hash. You can control the caching
+ behavior of both contexts independently with these options.
+
+ The argument to C<LIST_CACHE> or C<SCALAR_CACHE> must either be one of
+ the following four strings:
+
+ MEMORY
+ FAULT
+ MERGE
+ HASH
+
+ or else it must be a reference to a list whose first element is one of
+ these four strings, such as C<[HASH, arguments...]>.
+
+ =over 4
+
+ =item C<MEMORY>
+
+ C<MEMORY> means that return values from the function will be cached in
+ an ordinary Perl hash variable. The hash variable will not persist
+ after the program exits. This is the default.
+
+ =item C<HASH>
+
+ C<HASH> allows you to specify that a particular hash that you supply
+ will be used as the cache. You can tie this hash beforehand to give
+ it any behavior you want.
+
+ A tied hash can have any semantics at all. It is typically tied to an
+ on-disk database, so that cached values are stored in the database and
+ retrieved from it again when needed, and the disk file typically
+ persists after your program has exited. See C<perltie> for more
+ complete details about C<tie>.
+
+ A typical example is:
+
+ use DB_File;
+ tie my %cache => 'DB_File', $filename, O_RDWR|O_CREAT, 0666;
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache];
+
+ This has the effect of storing the cache in a C<DB_File> database
+ whose name is in C<$filename>. The cache will persist after the
+ program has exited. Next time the program runs, it will find the
+ cache already populated from the previous run of the program. Or you
+ can forcibly populate the cache by constructing a batch program that
+ runs in the background and populates the cache file. Then when you
+ come to run your real program the memoized function will be fast
+ because all its results have been precomputed.
+
+ =item C<TIE>
+
+ This option is B<strongly deprecated> and will be removed
+ in the B<next> release of C<Memoize>. Use the C<HASH> option instead.
+
+ memoize ... [TIE, ARGS...]
+
+ is merely a shortcut for
+
+ tie my %cache, ARGS...;
+ memoize ... [HASH => \%cache];
+
+
+ =item C<FAULT>
+
+ C<FAULT> means that you never expect to call the function in scalar
+ (or list) context, and that if C<Memoize> detects such a call, it
+ should abort the program. The error message is one of
+
+ `foo' function called in forbidden list context at line ...
+ `foo' function called in forbidden scalar context at line ...
+
+ =item C<MERGE>
+
+ C<MERGE> normally means the function does not distinguish between list
+ and sclar context, and that return values in both contexts should be
+ stored together. C<LIST_CACHE =E<gt> MERGE> means that list context
+ return values should be stored in the same hash that is used for
+ scalar context returns, and C<SCALAR_CACHE =E<gt> MERGE> means the
+ same, mutatis mutandis. It is an error to specify C<MERGE> for both,
+ but it probably does something useful.
+
+ Consider this function:
+
+ sub pi { 3; }
+
+ Normally, the following code will result in two calls to C<pi>:
+
+ $x = pi();
+ ($y) = pi();
+ $z = pi();
+
+ The first call caches the value C<3> in the scalar cache; the second
+ caches the list C<(3)> in the list cache. The third call doesn't call
+ the real C<pi> function; it gets the value from the scalar cache.
+
+ Obviously, the second call to C<pi> is a waste of time, and storing
+ its return value is a waste of space. Specifying C<LIST_CACHE
+ =E<gt> MERGE> will make C<memoize> use the same cache for scalar and
+ list context return values, so that the second call uses the scalar
+ cache that was populated by the first call. C<pi> ends up being
+ cvalled only once, and both subsequent calls return C<3> from the
+ cache, regardless of the calling context.
+
+ Another use for C<MERGE> is when you want both kinds of return values
+ stored in the same disk file; this saves you from having to deal with
+ two disk files instead of one. You can use a normalizer function to
+ keep the two sets of return values separate. For example:
+
+ tie my %cache => 'MLDBM', 'DB_File', $filename, ...;
+
+ memoize 'myfunc',
+ NORMALIZER => 'n',
+ SCALAR_CACHE => [HASH => \%cache],
+ LIST_CACHE => MERGE,
+ ;
+
+ sub n {
+ my $context = wantarray() ? 'L' : 'S';
+ # ... now compute the hash key from the arguments ...
+ $hashkey = "$context:$hashkey";
+ }
+
+ This normalizer function will store scalar context return values in
+ the disk file under keys that begin with C<S:>, and list context
+ return values under keys that begin with C<L:>.
+
+ =back
+
+ =head1 OTHER FACILITIES
+
+ =head2 C<unmemoize>
+
+ There's an C<unmemoize> function that you can import if you want to.
+ Why would you want to? Here's an example: Suppose you have your cache
+ tied to a DBM file, and you want to make sure that the cache is
+ written out to disk if someone interrupts the program. If the program
+ exits normally, this will happen anyway, but if someone types
+ control-C or something then the program will terminate immediately
+ without synchronizing the database. So what you can do instead is
+
+ $SIG{INT} = sub { unmemoize 'function' };
+
+ Thanks to Jonathan Roy for discovering a use for C<unmemoize>.
+
+ C<unmemoize> accepts a reference to, or the name of a previously
+ memoized function, and undoes whatever it did to provide the memoized
+ version in the first place, including making the name refer to the
+ unmemoized version if appropriate. It returns a reference to the
+ unmemoized version of the function.
+
+ If you ask it to unmemoize a function that was never memoized, it
+ croaks.
+
+ =head2 C<flush_cache>
+
+ C<flush_cache(function)> will flush out the caches, discarding I<all>
+ the cached data. The argument may be a funciton name or a reference
+ to a function. For finer control over when data is discarded or
+ expired, see the documentation for C<Memoize::Expire>, included in
+ this package.
+
+ Note that if the cache is a tied hash, C<flush_cache> will attempt to
+ invoke the C<CLEAR> method on the hash. If there is no C<CLEAR>
+ method, this will cause a run-time error.
+
+ An alternative approach to cache flushing is to use the C<HASH> option
+ (see above) to request that C<Memoize> use a particular hash variable
+ as its cache. Then you can examine or modify the hash at any time in
+ any way you desire.
+
+ =head1 CAVEATS
+
+ Memoization is not a cure-all:
+
+ =over 4
+
+ =item *
+
+ Do not memoize a function whose behavior depends on program
+ state other than its own arguments, such as global variables, the time
+ of day, or file input. These functions will not produce correct
+ results when memoized. For a particularly easy example:
+
+ sub f {
+ time;
+ }
+
+ This function takes no arguments, and as far as C<Memoize> is
+ concerned, it always returns the same result. C<Memoize> is wrong, of
+ course, and the memoized version of this function will call C<time> once
+ to get the current time, and it will return that same time
+ every time you call it after that.
+
+ =item *
+
+ Do not memoize a function with side effects.
+
+ sub f {
+ my ($a, $b) = @_;
+ my $s = $a + $b;
+ print "$a + $b = $s.\n";
+ }
+
+ This function accepts two arguments, adds them, and prints their sum.
+ Its return value is the numuber of characters it printed, but you
+ probably didn't care about that. But C<Memoize> doesn't understand
+ that. If you memoize this function, you will get the result you
+ expect the first time you ask it to print the sum of 2 and 3, but
+ subsequent calls will return 1 (the return value of
+ C<print>) without actually printing anything.
+
+ =item *
+
+ Do not memoize a function that returns a data structure that is
+ modified by its caller.
+
+ Consider these functions: C<getusers> returns a list of users somehow,
+ and then C<main> throws away the first user on the list and prints the
+ rest:
+
+ sub main {
+ my $userlist = getusers();
+ shift @$userlist;
+ foreach $u (@$userlist) {
+ print "User $u\n";
+ }
+ }
+
+ sub getusers {
+ my @users;
+ # Do something to get a list of users;
+ \@users; # Return reference to list.
+ }
+
+ If you memoize C<getusers> here, it will work right exactly once. The
+ reference to the users list will be stored in the memo table. C<main>
+ will discard the first element from the referenced list. The next
+ time you invoke C<main>, C<Memoize> will not call C<getusers>; it will
+ just return the same reference to the same list it got last time. But
+ this time the list has already had its head removed; C<main> will
+ erroneously remove another element from it. The list will get shorter
+ and shorter every time you call C<main>.
+
+ Similarly, this:
+
+ $u1 = getusers();
+ $u2 = getusers();
+ pop @$u1;
+
+ will modify $u2 as well as $u1, because both variables are references
+ to the same array. Had C<getusers> not been memoized, $u1 and $u2
+ would have referred to different arrays.
+
+ =item *
+
+ Do not memoize a very simple function.
+
+ Recently someone mentioned to me that the Memoize module made his
+ program run slower instead of faster. It turned out that he was
+ memoizing the following function:
+
+ sub square {
+ $_[0] * $_[0];
+ }
+
+ I pointed out that C<Memoize> uses a hash, and that looking up a
+ number in the hash is necessarily going to take a lot longer than a
+ single multiplication. There really is no way to speed up the
+ C<square> function.
+
+ Memoization is not magical.
+
+ =back
+
+ =head1 PERSISTENT CACHE SUPPORT
+
+ You can tie the cache tables to any sort of tied hash that you want
+ to, as long as it supports C<TIEHASH>, C<FETCH>, C<STORE>, and
+ C<EXISTS>. For example,
+
+ tie my %cache => 'GDBM_File', $filename, O_RDWR|O_CREAT, 0666;
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache];
+
+ works just fine. For some storage methods, you need a little glue.
+
+ C<SDBM_File> doesn't supply an C<EXISTS> method, so included in this
+ package is a glue module called C<Memoize::SDBM_File> which does
+ provide one. Use this instead of plain C<SDBM_File> to store your
+ cache table on disk in an C<SDBM_File> database:
+
+ tie my %cache => 'Memoize::SDBM_File', $filename, O_RDWR|O_CREAT, 0666;
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache];
+
+ C<NDBM_File> has the same problem and the same solution. (Use
+ C<Memoize::NDBM_File instead of plain NDBM_File.>)
+
+ C<Storable> isn't a tied hash class at all. You can use it to store a
+ hash to disk and retrieve it again, but you can't modify the hash while
+ it's on the disk. So if you want to store your cache table in a
+ C<Storable> database, use C<Memoize::Storable>, which puts a hashlike
+ front-end onto C<Storable>. The hash table is actually kept in
+ memory, and is loaded from your C<Storable> file at the time you
+ memoize the function, and stored back at the time you unmemoize the
+ function (or when your program exits):
+
+ tie my %cache => 'Memoize::Storable', $filename;
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache];
+
+ tie my %cache => 'Memoize::Storable', $filename, 'nstore';
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache];
+
+ Include the `nstore' option to have the C<Storable> database written
+ in `network order'. (See L<Storable> for more details about this.)
+
+ =head1 EXPIRATION SUPPORT
+
+ See Memoize::Expire, which is a plug-in module that adds expiration
+ functionality to Memoize. If you don't like the kinds of policies
+ that Memoize::Expire implements, it is easy to write your own plug-in
+ module to implement whatever policy you desire. Memoize comes with
+ several examples. An expiration manager that implements a LRU policy
+ is available on CPAN as Memoize::ExpireLRU.
+
+ =head1 BUGS
+
+ The test suite is much better, but always needs improvement.
+
+ There used to be some problem with the way C<goto &f> works under
+ threaded Perl, because of the lexical scoping of C<@_>. This is a bug
+ in Perl, and until it is resolved, Memoize won't work with these
+ Perls. This is probably still the case, although I have not been able
+ to try it out. If you encounter this problem, you can fix it by
+ chopping the source code a little. Find the comment in the source
+ code that says C<--- THREADED PERL COMMENT---> and comment out the
+ active line and uncomment the commented one. Then try it again.
+
+ Here's a bug that isn't my fault: Some versions of C<DB_File> won't
+ let you store data under a key of length 0. That means that if you
+ have a function C<f> which you memoized and the cache is in a
+ C<DB_File> database, then the value of C<f()> (C<f> called with no
+ arguments) will not be memoized. Let us all breathe deeply and repeat
+ this mantra: ``Gosh, Keith, that sure was a stupid thing to do.''
+
+ =head1 MAILING LIST
+
+ To join a very low-traffic mailing list for announcements about
+ C<Memoize>, send an empty note to C<mjd-perl-memoize-request@plover.com>.
+
+ =head1 AUTHOR
+
+ Mark-Jason Dominus (C<mjd-perl-memoize+@plover.com>), Plover Systems co.
+
+ See the C<Memoize.pm> Page at http://www.plover.com/~mjd/perl/Memoize/
+ for news and upgrades. Near this page, at
+ http://www.plover.com/~mjd/perl/MiniMemoize/ there is an article about
+ memoization and about the internals of Memoize that appeared in The
+ Perl Journal, issue #13. (This article is also included in the
+ Memoize distribution as `article.html'.)
+
+ To join a mailing list for announcements about C<Memoize>, send an
+ empty message to C<mjd-perl-memoize-request@plover.com>. This mailing
+ list is for announcements only and has extremely low traffic---about
+ four messages per year.
+
+ =head1 COPYRIGHT AND LICENSE
+
+ Copyright 1998, 1999, 2000, 2001 by Mark Jason Dominus
+
+ This library is free software; you may redistribute it and/or modify
+ it under the same terms as Perl itself.
+
+ =head1 THANK YOU
+
+ Many thanks to Jonathan Roy for bug reports and suggestions, to
+ Michael Schwern for other bug reports and patches, to Mike Cariaso for
+ helping me to figure out the Right Thing to Do About Expiration, to
+ Joshua Gerth, Joshua Chamas, Jonathan Roy, Mark D. Anderson, and
+ Andrew Johnson for more suggestions about expiration, to Brent Powers
+ for the Memoize::ExpireLRU module, to Ariel Scolnicov for delightful
+ messages about the Fibonacci function, to Dion Almaer for
+ thought-provoking suggestions about the default normalizer, to Walt
+ Mankowski and Kurt Starsinic for much help investigating problems
+ under threaded Perl, to Alex Dudkevich for reporting the bug in
+ prototyped functions and for checking my patch, to Tony Bass for many
+ helpful suggestions, to Philippe Verdret for enlightening discussion
+ of Hook::PrePostCall, to Nat Torkington for advice I ignored, to Chris
+ Nandor for portability advice, to Randal Schwartz for suggesting the
+ 'C<flush_cache> function, and to Jenda Krynicky for being a light in
+ the world.
+
+ Special thanks to Jarkko Hietaniemi, the 5.8.0 pumpking, for including
+ this module in the core and for his patient and helpful guidance
+ during the integration process.
+ =cut
diff -c /dev/null 'perl-5.7.2/lib/Memoize/AnyDBM_File.pm'
Index: ./lib/Memoize/AnyDBM_File.pm
*** ./lib/Memoize/AnyDBM_File.pm Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/AnyDBM_File.pm Mon Jul 9 17:10:37 2001
***************
*** 0 ****
--- 1,29 ----
+ package Memoize::AnyDBM_File;
+
+ =head1 NAME
+
+ Memoize::AnyDBM_File - glue to provide EXISTS for AnyDBM_File for Storable use
+
+ =head1 DESCRIPTION
+
+ See L<Memoize>.
+
+ =cut
+
+ use vars qw(@ISA $VERSION);
+ $VERSION = 0.65;
+ @ISA = qw(DB_File GDBM_File Memoize::NDBM_File Memoize::SDBM_File ODBM_File) unless @ISA;
+
+ my $verbose = 1;
+
+ my $mod;
+ for $mod (@ISA) {
+ # (my $truemod = $mod) =~ s/^Memoize:://;
+ if (eval "require $mod") {
+ print STDERR "AnyDBM_File => Selected $mod.\n" if $Verbose;
+ @ISA = ($mod); # if we leave @ISA alone, warnings abound
+ return 1;
+ }
+ }
+
+ die "No DBM package was successfully found or installed";
diff -c /dev/null 'perl-5.7.2/lib/Memoize/Expire.pm'
Index: ./lib/Memoize/Expire.pm
*** ./lib/Memoize/Expire.pm Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/Expire.pm Mon Jul 9 17:10:37 2001
***************
*** 0 ****
--- 1,361 ----
+
+ package Memoize::Expire;
+ # require 5.00556;
+ use Carp;
+ $DEBUG = 0;
+ $VERSION = '0.65';
+
+ # This package will implement expiration by prepending a fixed-length header
+ # to the font of the cached data. The format of the header will be:
+ # (4-byte number of last-access-time) (For LRU when I implement it)
+ # (4-byte expiration time: unsigned seconds-since-unix-epoch)
+ # (2-byte number-of-uses-before-expire)
+
+ sub _header_fmt () { "N N n" }
+ sub _header_size () { length(_header_fmt) }
+
+ # Usage: memoize func
+ # TIE => [Memoize::Expire, LIFETIME => sec, NUM_USES => n,
+ # TIE => [...] ]
+
+ sub TIEHASH {
+ my ($package, %args) = @_;
+ my %cache;
+ if ($args{TIE}) {
+ my ($module, @opts) = @{$args{TIE}};
+ my $modulefile = $module . '.pm';
+ $modulefile =~ s{::}{/}g;
+ eval { require $modulefile };
+ if ($@) {
+ croak "Memoize::Expire: Couldn't load hash tie module `$module': $@; aborting";
+ }
+ my $rc = (tie %cache => $module, @opts);
+ unless ($rc) {
+ croak "Memoize::Expire: Couldn't tie hash to `$module': $@; aborting";
+ }
+ }
+ $args{LIFETIME} ||= 0;
+ $args{NUM_USES} ||= 0;
+ $args{C} = \%cache;
+ bless \%args => $package;
+ }
+
+ sub STORE {
+ $DEBUG and print STDERR " >> Store $_[1] $_[2]\n";
+ my ($self, $key, $value) = @_;
+ my $expire_time = $self->{LIFETIME} > 0 ? $self->{LIFETIME} + time : 0;
+ # The call that results in a value to store into the cache is the
+ # first of the NUM_USES allowed calls.
+ my $header = _make_header(time, $expire_time, $self->{NUM_USES}-1);
+ $self->{C}{$key} = $header . $value;
+ $value;
+ }
+
+ sub FETCH {
+ $DEBUG and print STDERR " >> Fetch cached value for $_[1]\n";
+ my ($data, $last_access, $expire_time, $num_uses_left) = _get_item($_[0]{C}{$_[1]});
+ $DEBUG and print STDERR " >> (ttl: ", ($expire_time-time), ", nuses: $num_uses_left)\n";
+ $num_uses_left--;
+ $last_access = time;
+ _set_header(@_, $data, $last_access, $expire_time, $num_uses_left);
+ $data;
+ }
+
+ sub EXISTS {
+ $DEBUG and print STDERR " >> Exists $_[1]\n";
+ unless (exists $_[0]{C}{$_[1]}) {
+ $DEBUG and print STDERR " Not in underlying hash at all.\n";
+ return 0;
+ }
+ my $item = $_[0]{C}{$_[1]};
+ my ($last_access, $expire_time, $num_uses_left) = _get_header($item);
+ my $ttl = $expire_time - time;
+ if ($DEBUG) {
+ $_[0]{LIFETIME} and print STDERR " Time to live for this item: $ttl\n";
+ $_[0]{NUM_USES} and print STDERR " Uses remaining: $num_uses_left\n";
+ }
+ if ( (! $_[0]{LIFETIME} || $expire_time > time)
+ && (! $_[0]{NUM_USES} || $num_uses_left > 0 )) {
+ $DEBUG and print STDERR " (Still good)\n";
+ return 1;
+ } else {
+ $DEBUG and print STDERR " (Expired)\n";
+ return 0;
+ }
+ }
+
+ # Arguments: last access time, expire time, number of uses remaining
+ sub _make_header {
+ pack "N N n", @_;
+ }
+
+ sub _strip_header {
+ substr($_[0], 10);
+ }
+
+ # Arguments: last access time, expire time, number of uses remaining
+ sub _set_header {
+ my ($self, $key, $data, @header) = @_;
+ $self->{C}{$key} = _make_header(@header) . $data;
+ }
+
+ sub _get_item {
+ my $data = substr($_[0], 10);
+ my @header = unpack "N N n", substr($_[0], 0, 10);
+ # print STDERR " >> _get_item: $data => $data @header\n";
+ ($data, @header);
+ }
+
+ # Return last access time, expire time, number of uses remaining
+ sub _get_header {
+ unpack "N N n", substr($_[0], 0, 10);
+ }
+
+ 1;
+
+ # Below is the stub of documentation for your module. You better edit it!
+
+ =head1 NAME
+
+ Memoize::Expire - Plug-in module for automatic expiration of memoized values
+
+ =head1 SYNOPSIS
+
+ use Memoize;
+ use Memoize::Expire;
+ tie my %cache => 'Memoize::Expire',
+ LIFETIME => $lifetime, # In seconds
+ NUM_USES => $n_uses;
+
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache ];
+
+ =head1 DESCRIPTION
+
+ Memoize::Expire is a plug-in module for Memoize. It allows the cached
+ values for memoized functions to expire automatically. This manual
+ assumes you are already familiar with the Memoize module. If not, you
+ should study that manual carefully first, paying particular attention
+ to the HASH feature.
+
+ Memoize::Expire is a layer of software that you can insert in between
+ Memoize itself and whatever underlying package implements the cache.
+ The layer presents a hash variable whose values expire whenever they
+ get too old, have been used too often, or both. You tell C<Memoize> to
+ use this forgetful hash as its cache instead of the default, which is
+ an ordinary hash.
+
+ To specify a real-time timeout, supply the C<LIFETIME> option with a
+ numeric value. Cached data will expire after this many seconds, and
+ will be looked up afresh when it expires. When a data item is looked
+ up afresh, its lifetime is reset.
+
+ If you specify C<NUM_USES> with an argument of I<n>, then each cached
+ data item will be discarded and looked up afresh after the I<n>th time
+ you access it. When a data item is looked up afresh, its number of
+ uses is reset.
+
+ If you specify both arguments, data will be discarded from the cache
+ when either expiration condition holds.
+
+ Memoize::Expire uses a real hash internally to store the cached data.
+ You can use the C<HASH> option to Memoize::Expire to supply a tied
+ hash in place of the ordinary hash that Memoize::Expire will normally
+ use. You can use this feature to add Memoize::Expire as a layer in
+ between a persistent disk hash and Memoize. If you do this, you get a
+ persistent disk cache whose entries expire automatically. For
+ example:
+
+ # Memoize
+ # |
+ # Memoize::Expire enforces data expiration policy
+ # |
+ # DB_File implements persistence of data in a disk file
+ # |
+ # Disk file
+
+ use Memoize;
+ use Memoize::Expire;
+ use DB_File;
+
+ # Set up persistence
+ tie my %disk_cache => 'DB_File', $filename, O_CREAT|O_RDWR, 0666];
+
+ # Set up expiration policy, supplying persistent hash as a target
+ tie my %cache => 'Memoize::Expire',
+ LIFETIME => $lifetime, # In seconds
+ NUM_USES => $n_uses,
+ HASH => \%disk_cache;
+
+ # Set up memoization, supplying expiring persistent hash for cache
+ memoize 'function', SCALAR_CACHE => [ HASH => \%cache ];
+
+ =head1 INTERFACE
+
+ There is nothing special about Memoize::Expire. It is just an
+ example. If you don't like the policy that it implements, you are
+ free to write your own expiration policy module that implements
+ whatever policy you desire. Here is how to do that. Let us suppose
+ that your module will be named MyExpirePolicy.
+
+ Short summary: You need to create a package that defines four methods:
+
+ =over 4
+
+ =item
+ TIEHASH
+
+ Construct and return cache object.
+
+ =item
+ EXISTS
+
+ Given a function argument, is the corresponding function value in the
+ cache, and if so, is it fresh enough to use?
+
+ =item
+ FETCH
+
+ Given a function argument, look up the corresponding function value in
+ the cache and return it.
+
+ =item
+ STORE
+
+ Given a function argument and the corresponding function value, store
+ them into the cache.
+
+ =back
+
+ The user who wants the memoization cache to be expired according to
+ your policy will say so by writing
+
+ tie my %cache => 'MyExpirePolicy', args...;
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache];
+
+ This will invoke C<< MyExpirePolicy->TIEHASH(args) >>.
+ MyExpirePolicy::TIEHASH should do whatever is appropriate to set up
+ the cache, and it should return the cache object to the caller.
+
+ For example, MyExpirePolicy::TIEHASH might create an object that
+ contains a regular Perl hash (which it will to store the cached
+ values) and some extra information about the arguments and how old the
+ data is and things like that. Let us call this object `C'.
+
+ When Memoize needs to check to see if an entry is in the cache
+ already, it will invoke C<< C->EXISTS(key) >>. C<key> is the normalized
+ function argument. MyExpirePolicy::EXISTS should return 0 if the key
+ is not in the cache, or if it has expired, and 1 if an unexpired value
+ is in the cache. It should I<not> return C<undef>, because there is a
+ bug in some versions of Perl that will cause a spurious FETCH if the
+ EXISTS method returns C<undef>.
+
+ If your EXISTS function returns true, Memoize will try to fetch the
+ cached value by invoking C<< C->FETCH(key) >>. MyExpirePolicy::FETCH should
+ return the cached value. Otherwise, Memoize will call the memoized
+ function to compute the appropriate value, and will store it into the
+ cache by calling C<< C->STORE(key, value) >>.
+
+ Here is a very brief example of a policy module that expires each
+ cache item after ten seconds.
+
+ package Memoize::TenSecondExpire;
+
+ sub TIEHASH {
+ my ($package, %args) = @_;
+ my $cache = $args{$HASH} || {};
+ bless $cache => $package;
+ }
+
+ sub EXISTS {
+ my ($cache, $key) = @_;
+ if (exists $cache->{$key} &&
+ $cache->{$key}{EXPIRE_TIME} > time) {
+ return 1
+ } else {
+ return 0; # Do NOT return `undef' here.
+ }
+ }
+
+ sub FETCH {
+ my ($cache, $key) = @_;
+ return $cache->{$key}{VALUE};
+ }
+
+ sub STORE {
+ my ($cache, $key, $newvalue) = @_;
+ $cache->{$key}{VALUE} = $newvalue;
+ $cache->{$key}{EXPIRE_TIME} = time + 10;
+ }
+
+ To use this expiration policy, the user would say
+
+ use Memoize;
+ tie my %cache10sec => 'Memoize::TenSecondExpire';
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache10sec];
+
+ Memoize would then call C<function> whenever a cached value was
+ entirely absent or was older than ten seconds.
+
+ You should always support a C<HASH> argument to C<TIEHASH> that ties
+ the underlying cache so that the user can specify that the cache is
+ also persistent or that it has some other interesting semantics. The
+ example above demonstrates how to do this, as does C<Memozie::Expire>.
+
+ Another sample module, C<Memoize::Saves>, is included with this
+ package. It implements a policy that allows you to specify that
+ certain function values whould always be looked up afresh. See the
+ documentation for details.
+
+ =head1 ALTERNATIVES
+
+ Brent Powers has a C<Memoize::ExpireLRU> module that was designed to
+ wotk with Memoize and provides expiration of least-recently-used data.
+ The cache is held at a fixed number of entries, and when new data
+ comes in, the least-recently used data is expired. See
+ L<http://search.cpan.org/search?mode=module&query=ExpireLRU>.
+
+ Joshua Chamas's Tie::Cache module may be useful as an expiration
+ manager. (If you try this, let me know how it works out.)
+
+ If you develop any useful expiration managers that you think should be
+ distributed with Memoize, please let me know.
+
+ =head1 CAVEATS
+
+ This module is experimental, and may contain bugs. Please report bugs
+ to the address below.
+
+ Number-of-uses is stored as a 16-bit unsigned integer, so can't exceed
+ 65535.
+
+ Because of clock granularity, expiration times may occur up to one
+ second sooner than you expect. For example, suppose you store a value
+ with a lifetime of ten seconds, and you store it at 12:00:00.998 on a
+ certain day. Memoize will look at the clock and see 12:00:00. Then
+ 9.01 seconds later, at 12:00:10.008 you try to read it back. Memoize
+ will look at the clock and see 12:00:10 and conclude that the value
+ has expired. Solution: Build an expiration policy module that uses
+ Time::HiRes to examine a clock with better granularity. Contributions
+ are welcome. Send them to:
+
+ =head1 AUTHOR
+
+ Mark-Jason Dominus (mjd-perl-memoize+@plover.com)
+
+ Mike Cariaso provided valuable insight into the best way to solve this
+ problem.
+
+ =head1 SEE ALSO
+
+ perl(1)
+
+ The Memoize man page.
+
+ http://www.plover.com/~mjd/perl/Memoize/ (for news and updates)
+
+ I maintain a mailing list on which I occasionally announce new
+ versions of Memoize. The list is for announcements only, not
+ discussion. To join, send an empty message to
+ mjd-perl-memoize-request@Plover.com.
+
+ =cut
diff -c /dev/null 'perl-5.7.2/lib/Memoize/ExpireFile.pm'
Index: ./lib/Memoize/ExpireFile.pm
*** ./lib/Memoize/ExpireFile.pm Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/ExpireFile.pm Mon Jul 9 17:10:37 2001
***************
*** 0 ****
--- 1,48 ----
+ package Memoize::ExpireFile;
+
+ =head1 NAME
+
+ Memoize::ExpireFile - test for Memoize expiration semantics
+
+ =head1 DESCRIPTION
+
+ See L<Memoize::Expire>.
+
+ =cut
+
+ $VERSION = 0.65;
+ use Carp;
+
+ my $Zero = pack("N", 0);
+
+ sub TIEHASH {
+ my ($package, %args) = @_;
+ my $cache = $args{HASH} || {};
+ bless {ARGS => \%args, C => $cache} => $package;
+ }
+
+
+ sub STORE {
+ my ($self, $key, $data) = @_;
+ my $cache = $self->{C};
+ my $cur_date = pack("N", (stat($key))[9]);
+ $cache->{"C$key"} = $data;
+ $cache->{"T$key"} = $cur_date;
+ }
+
+ sub FETCH {
+ my ($self, $key) = @_;
+ $self->{C}{"C$key"};
+ }
+
+ sub EXISTS {
+ my ($self, $key) = @_;
+ my $old_date = $self->{C}{"T$key"} || $Zero;
+ my $cur_date = pack("N", (stat($key))[9]);
+ # if ($self->{ARGS}{CHECK_DATE} && $old_date gt $cur_date) {
+ # return $self->{ARGS}{CHECK_DATE}->($key, $old_date, $cur_date);
+ # }
+ return $old_date ge $cur_date;
+ }
+
+ 1;
diff -c /dev/null 'perl-5.7.2/lib/Memoize/ExpireTest.pm'
Index: ./lib/Memoize/ExpireTest.pm
*** ./lib/Memoize/ExpireTest.pm Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/ExpireTest.pm Mon Jul 9 17:10:37 2001
***************
*** 0 ****
--- 1,49 ----
+ package Memoize::ExpireTest;
+
+ =head1 NAME
+
+ Memoize::ExpireTest - test for Memoize expiration semantics
+
+ =head1 DESCRIPTION
+
+ This module is just for testing expiration semantics. It's not a very
+ good example of how to write an expiration module.
+
+ If you are looking for an example, I recommend that you look at the
+ simple example in the Memoize::Expire documentation, or at the code
+ for Memoize::Expire itself.
+
+ If you have questions, I will be happy to answer them if you send them
+ to mjd-perl-memoize+@plover.com.
+
+ =cut
+
+ $VERSION = 0.65;
+ my %cache;
+
+ sub TIEHASH {
+ my ($pack) = @_;
+ bless \%cache => $pack;
+ }
+
+ sub EXISTS {
+ my ($cache, $key) = @_;
+ exists $cache->{$key} ? 1 : 0;
+ }
+
+ sub FETCH {
+ my ($cache, $key) = @_;
+ $cache->{$key};
+ }
+
+ sub STORE {
+ my ($cache, $key, $val) = @_;
+ $cache->{$key} = $val;
+ }
+
+ sub expire {
+ my ($key) = @_;
+ delete $cache{$key};
+ }
+
+ 1;
diff -c /dev/null 'perl-5.7.2/lib/Memoize/NDBM_File.pm'
Index: ./lib/Memoize/NDBM_File.pm
*** ./lib/Memoize/NDBM_File.pm Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/NDBM_File.pm Mon Jul 9 17:10:37 2001
***************
*** 0 ****
--- 1,77 ----
+ package Memoize::NDBM_File;
+
+ =head1 NAME
+
+ Memoize::NDBM_File - glue to provide EXISTS for NDBM_File for Storable use
+
+ =head1 DESCRIPTION
+
+ See L<Memoize>.
+
+ =cut
+
+ use NDBM_File;
+ @ISA = qw(NDBM_File);
+ $VERSION = 0.65;
+
+ $Verbose = 0;
+
+ sub AUTOLOAD {
+ warn "Nonexistent function $AUTOLOAD invoked in Memoize::NDBM_File\n";
+ }
+
+ sub import {
+ warn "Importing Memoize::NDBM_File\n" if $Verbose;
+ }
+
+
+ my %keylist;
+
+ # This is so ridiculous...
+ sub _backhash {
+ my $self = shift;
+ my %fakehash;
+ my $k;
+ for ($k = $self->FIRSTKEY(); defined $k; $k = $self->NEXTKEY($k)) {
+ $fakehash{$k} = undef;
+ }
+ $keylist{$self} = \%fakehash;
+ }
+
+ sub EXISTS {
+ warn "Memoize::NDBM_File EXISTS (@_)\n" if $Verbose;
+ my $self = shift;
+ _backhash($self) unless exists $keylist{$self};
+ my $r = exists $keylist{$self}{$_[0]};
+ warn "Memoize::NDBM_File EXISTS (@_) ==> $r\n" if $Verbose;
+ $r;
+ }
+
+ sub DEFINED {
+ warn "Memoize::NDBM_File DEFINED (@_)\n" if $Verbose;
+ my $self = shift;
+ _backhash($self) unless exists $keylist{$self};
+ defined $keylist{$self}{$_[0]};
+ }
+
+ sub DESTROY {
+ warn "Memoize::NDBM_File DESTROY (@_)\n" if $Verbose;
+ my $self = shift;
+ delete $keylist{$self}; # So much for reference counting...
+ $self->SUPER::DESTROY(@_);
+ }
+
+ # Maybe establish the keylist at TIEHASH time instead?
+
+ sub STORE {
+ warn "Memoize::NDBM_File STORE (@_)\n" if $VERBOSE;
+ my $self = shift;
+ $keylist{$self}{$_[0]} = undef;
+ $self->SUPER::STORE(@_);
+ }
+
+
+
+ # Inherit FETCH and TIEHASH
+
+ 1;
diff -c /dev/null 'perl-5.7.2/lib/Memoize/README'
Index: ./lib/Memoize/README
*** ./lib/Memoize/README Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/README Mon Jul 9 17:10:37 2001
***************
*** 0 ****
--- 1,64 ----
+
+ Name: Memoize
+ What: Transparently speed up functions by caching return values.
+ Version: 0.65
+ Author: Mark-Jason Dominus (mjd-perl-memoize+@plover.com)
+
+ ################################################################
+
+ How to build me:
+
+ perl Makefile.PL
+ make
+ make test
+
+ There's a very small chance that the tests in speed.t and
+ expire_module_t.t might fail because of clock skew or bizarre system
+ load conditions. If the tests there fail, rerun them and see if the
+ problem persists.
+
+ If the tests work,
+
+ make install
+
+ If not, please send me a report that mentions which tests failed.
+ The address is: mjd-perl-memoize+@plover.com.
+
+ ################################################################
+ What's new since 0.62:
+
+
+ N O T I C E !
+
+ ****************************************************************
+ ** **
+ ** The TIE option is now strongly deprecated. It will be **
+ ** permanently removed in the NEXT release of Memoize. **
+ ** Please convert all extant software to use HASH instead. **
+ ** **
+ ** See the manual for details. **
+ ** **
+ ****************************************************************
+
+ I'm sorry about this. I hate making incompatible changes. But as of
+ v0.65, Memoize is included in the Perl core. It is about to become
+ much more difficult to make incompatible interface changes; if I don't
+ get rid of TIE now, I may not get another chance.
+
+ TIE presented serious problems. First, it had a bizarre syntax. But
+ the big problem was that it was difficult and complicated for
+ expiration manager authors to support; evern expiration manager had to
+ duplicate the logic for handling TIE. HASH is much simpler to use,
+ more powerful, and is trivial for expiration managers to support.
+
+ Many long-awaited cleanups and bug fixes.
+
+ Memoize now works under threaded perl
+
+ Slow tests speeded up. More test file improvements.
+
+ Long-standing LIST_CACHE bug cleared up---it turns out that there
+ never was a bug. I put in tests for it anyway.
+
+ Manual increased.
+
diff -c /dev/null 'perl-5.7.2/lib/Memoize/SDBM_File.pm'
Index: ./lib/Memoize/SDBM_File.pm
*** ./lib/Memoize/SDBM_File.pm Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/SDBM_File.pm Mon Jul 9 17:10:37 2001
***************
*** 0 ****
--- 1,75 ----
+ package Memoize::SDBM_File;
+
+ =head1 NAME
+
+ Memoize::SDBM_File - glue to provide EXISTS for SDBM_File for Storable use
+
+ =head1 DESCRIPTION
+
+ See L<Memoize>.
+
+ =cut
+
+ use SDBM_File;
+ @ISA = qw(SDBM_File);
+ $VERSION = 0.65;
+
+ $Verbose = 0;
+
+ sub AUTOLOAD {
+ warn "Nonexistent function $AUTOLOAD invoked in Memoize::SDBM_File\n";
+ }
+
+ sub import {
+ warn "Importing Memoize::SDBM_File\n" if $Verbose;
+ }
+
+
+ my %keylist;
+
+ # This is so ridiculous...
+ sub _backhash {
+ my $self = shift;
+ my %fakehash;
+ my $k;
+ for ($k = $self->FIRSTKEY(); defined $k; $k = $self->NEXTKEY($k)) {
+ $fakehash{$k} = undef;
+ }
+ $keylist{$self} = \%fakehash;
+ }
+
+ sub EXISTS {
+ warn "Memoize::SDBM_File EXISTS (@_)\n" if $Verbose;
+ my $self = shift;
+ _backhash($self) unless exists $keylist{$self};
+ my $r = exists $keylist{$self}{$_[0]};
+ warn "Memoize::SDBM_File EXISTS (@_) ==> $r\n" if $Verbose;
+ $r;
+ }
+
+ sub DEFINED {
+ warn "Memoize::SDBM_File DEFINED (@_)\n" if $Verbose;
+ my $self = shift;
+ _backhash($self) unless exists $keylist{$self};
+ defined $keylist{$self}{$_[0]};
+ }
+
+ sub DESTROY {
+ warn "Memoize::SDBM_File DESTROY (@_)\n" if $Verbose;
+ my $self = shift;
+ delete $keylist{$self}; # So much for reference counting...
+ $self->SUPER::DESTROY(@_);
+ }
+
+ # Maybe establish the keylist at TIEHASH time instead?
+
+ sub STORE {
+ warn "Memoize::SDBM_File STORE (@_)\n" if $VERBOSE;
+ my $self = shift;
+ $keylist{$self}{$_[0]} = undef;
+ $self->SUPER::STORE(@_);
+ }
+
+ # Inherit FETCH and TIEHASH
+
+ 1;
diff -c /dev/null 'perl-5.7.2/lib/Memoize/Saves.pm'
Index: ./lib/Memoize/Saves.pm
*** ./lib/Memoize/Saves.pm Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/Saves.pm Mon Jul 9 17:10:37 2001
***************
*** 0 ****
--- 1,193 ----
+ package Memoize::Saves;
+
+ $VERSION = 0.65;
+
+ $DEBUG = 0;
+
+ sub TIEHASH
+ {
+ my ($package, %args) = @_;
+ my $cache = $args{HASH} || {};
+
+ # Convert the CACHE to a referenced hash for quick lookup
+ #
+ if( $args{CACHE} )
+ {
+ my %hash;
+ $args{CACHE} = [ $args{CACHE} ] unless ref $args{CACHE} eq "ARRAY";
+ foreach my $value ( @{$args{CACHE}} )
+ {
+ $hash{$value} = 1;
+ }
+ $args{CACHE} = \%hash;
+ }
+
+ # Convert the DUMP list to a referenced hash for quick lookup
+ #
+ if( $args{DUMP} )
+ {
+ my %hash;
+ $args{DUMP} = [ $args{DUMP} ] unless ref $args{DUMP} eq "ARRAY";
+ foreach my $value ( @{$args{DUMP}} )
+ {
+ $hash{$value} = 1;
+ }
+ $args{DUMP} = \%hash;
+ }
+
+ if ($args{TIE})
+ {
+ my ($module, @opts) = @{$args{TIE}};
+ my $modulefile = $module . '.pm';
+ $modulefile =~ s{::}{/}g;
+ eval { require $modulefile };
+ if ($@) {
+ die "Memoize::Saves: Couldn't load hash tie module `$module': $@; aborting";
+ }
+ my $rc = (tie %$cache => $module, @opts);
+ unless ($rc) {
+ die "Memoize::Saves: Couldn't tie hash to `$module': $@; aborting";
+ }
+ }
+
+ $args{C} = $cache;
+ bless \%args => $package;
+ }
+
+ sub EXISTS
+ {
+ my $self = shift;
+ my $key = shift;
+
+ if( exists $self->{C}->{$key} )
+ {
+ return 1;
+ }
+
+ return 0;
+ }
+
+
+ sub FETCH
+ {
+ my $self = shift;
+ my $key = shift;
+
+ return $self->{C}->{$key};
+ }
+
+ sub STORE
+ {
+ my $self = shift;
+ my $key = shift;
+ my $value = shift;
+
+ # If CACHE defined and this is not in our list don't save it
+ #
+ if(( defined $self->{CACHE} )&&
+ ( ! defined $self->{CACHE}->{$value} ))
+ {
+ print "$value not in CACHE list.\n" if $DEBUG;
+ return;
+ }
+
+ # If DUMP is defined and this is in our list don't save it
+ #
+ if(( defined $self->{DUMP} )&&
+ ( defined $self->{DUMP}->{$value} ))
+ {
+ print "$value in DUMP list.\n" if $DEBUG;
+ return;
+ }
+
+ # If REGEX is defined we will store it only if its true
+ #
+ if(( defined $self->{REGEX} )&&
+ ( $value !~ /$self->{REGEX}/ ))
+ {
+ print "$value did not match regex.\n" if $DEBUG;
+ return;
+ }
+
+ # If we get this far we should save the value
+ #
+ print "Saving $key:$value\n" if $DEBUG;
+ $self->{C}->{$key} = $value;
+ }
+
+ 1;
+
+ # Documentation
+ #
+
+ =head1 NAME
+
+ Memoize::Saves - Plug-in module to specify which return values should be memoized
+
+ =head1 SYNOPSIS
+
+ use Memoize;
+
+ memoize 'function',
+ SCALAR_CACHE => [TIE, Memoize::Saves,
+ CACHE => [ "word1", "word2" ],
+ DUMP => [ "word3", "word4" ],
+ REGEX => "Regular Expression",
+ HASH => $cache_hashref,
+ ],
+
+ =head1 DESCRIPTION
+
+ Memoize::Saves is a plug-in module for Memoize. It allows the
+ user to specify which values should be cached or which should be
+ dumped. Please read the manual for Memoize for background
+ information.
+
+ Use the CACHE option to specify a list of return values which should
+ be memoized. All other values will need to be recomputed each time.
+
+ Use the DUMP option to specify a list of return values which should
+ not be memoized. Only these values will need to be recomputed each
+ time.
+
+ Use the REGEX option to specify a Regular Expression which must match
+ for the return value to be saved. You can supply either a plain text
+ string or a compiled regular expression using qr//. Obviously the
+ second method is prefered.
+
+ Specifying multiple options will result in the least common denominator
+ being saved.
+
+ You can use the HASH option to string multiple Memoize Plug-ins together:
+
+ tie my %disk_hash => 'GDBM_File', $filename, O_RDWR|O_CREAT, 0666;
+ tie my %expiring_cache => 'Memoize::Expire',
+ LIFETIME => 5, HASH => \%disk_cache;
+ tie my %cache => 'Memoize::Saves',
+ REGEX => qr/my/, HASH => \%expiring_cache;
+
+ memoize ('printme', SCALAR_CACHE => [HASH => \%cache]);
+
+ =head1 CAVEATS
+
+ This module is experimental, and may contain bugs. Please report bugs
+ to C<mjd-perl-memoize+@plover.com>.
+
+ If you are going to use Memoize::Saves with Memoize::Expire it is
+ important to use it in that order. Memoize::Expire changes the return
+ value to include expire information and it may no longer match
+ your CACHE, DUMP, or REGEX.
+
+
+ =head1 AUTHOR
+
+ Joshua Gerth <gerth@teleport.com>
+
+ =head1 SEE ALSO
+
+ perl(1)
+
+ L<Memoize>
+
+
+
diff -c /dev/null 'perl-5.7.2/lib/Memoize/Storable.pm'
Index: ./lib/Memoize/Storable.pm
*** ./lib/Memoize/Storable.pm Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/Storable.pm Mon Jul 9 17:10:37 2001
***************
*** 0 ****
--- 1,72 ----
+ package Memoize::Storable;
+
+ =head1 NAME
+
+ Memoize::Storable - store Memoized data in Storable database
+
+ =head1 DESCRIPTION
+
+ See L<Memoize>.
+
+ =cut
+
+ use Storable ();
+ $VERSION = 0.65;
+ $Verbose = 0;
+
+ sub TIEHASH {
+ require Carp if $Verbose;
+ my $package = shift;
+ my $filename = shift;
+ my $truehash = (-e $filename) ? Storable::retrieve($filename) : {};
+ my %options;
+ print STDERR "Memoize::Storable::TIEHASH($filename, @_)\n" if $Verbose;
+ @options{@_} = ();
+ my $self =
+ {FILENAME => $filename,
+ H => $truehash,
+ OPTIONS => \%options
+ };
+ bless $self => $package;
+ }
+
+ sub STORE {
+ require Carp if $Verbose;
+ my $self = shift;
+ print STDERR "Memoize::Storable::STORE(@_)\n" if $Verbose;
+ $self->{H}{$_[0]} = $_[1];
+ }
+
+ sub FETCH {
+ require Carp if $Verbose;
+ my $self = shift;
+ print STDERR "Memoize::Storable::FETCH(@_)\n" if $Verbose;
+ $self->{H}{$_[0]};
+ }
+
+ sub EXISTS {
+ require Carp if $Verbose;
+ my $self = shift;
+ print STDERR "Memoize::Storable::EXISTS(@_)\n" if $Verbose;
+ exists $self->{H}{$_[0]};
+ }
+
+ sub DESTROY {
+ require Carp if $Verbose;
+ my $self= shift;
+ print STDERR "Memoize::Storable::DESTROY(@_)\n" if $Verbose;
+ if ($self->{OPTIONS}{'nstore'}) {
+ Storable::nstore($self->{H}, $self->{FILENAME});
+ } else {
+ Storable::store($self->{H}, $self->{FILENAME});
+ }
+ }
+
+ sub FIRSTKEY {
+ 'Fake hash from Memoize::Storable';
+ }
+
+ sub NEXTKEY {
+ undef;
+ }
+ 1;
diff -c /dev/null 'perl-5.7.2/lib/Memoize/TODO'
Index: ./lib/Memoize/TODO
*** ./lib/Memoize/TODO Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/TODO Mon Jul 9 17:10:37 2001
***************
*** 0 ****
--- 1,355 ----
+ # Version 0.05 alpha $Revision: 1.5 $ $Date: 1999/09/17 14:57:55 $
+
+ =head1 TO DO
+
+ =over 4
+
+ =item *
+
+ LIST_CACHE doesn't work with ties to most DBM implementations, because
+ Memouze tries to save a listref, and DB_File etc. can only store
+ strings. This should at least be documented. Maybe Memoize could
+ detect the problem at TIE time and throw a fatal error.
+
+ 20010623 This was added sometime prior to 20001025.
+
+ Try out MLDBM here and document it if it works.
+
+ =item *
+
+ We should extend the benchmarking module to allow
+
+ timethis(main, { MEMOIZED => [ suba, subb ] })
+
+ What would this do? It would time C<main> three times, once with
+ C<suba> and C<subb> unmemoized, twice with them memoized.
+
+ Why would you want to do this? By the third set of runs, the memo
+ tables would be fully populated, so all calls by C<main> to C<suba>
+ and C<subb> would return immediately. You would be able to see how
+ much of C<main>'s running time was due to time spent computing in
+ C<suba> and C<subb>. If that was just a little time, you would know
+ that optimizing or improving C<suba> and C<subb> would not have a
+ large effect on the performance of C<main>. But if there was a big
+ difference, you would know that C<suba> or C<subb> was a good
+ candidate for optimization if you needed to make C<main> go faster.
+
+ Done.
+
+ =item *
+
+ Perhaps C<memoize> should return a reference to the original function
+ as well as one to the memoized version? But the programmer could
+ always construct such a reference themselves, so perhaps it's not
+ necessary. We save such a reference anyway, so a new package method
+ could return it on demand even if it wasn't provided by C<memoize>.
+ We could even bless the new function reference so that it could have
+ accessor methods for getting to the original function, the options,
+ the memo table, etc.
+
+ Naah.
+
+ =item *
+
+ The TODISK feature is not ready yet. It will have to be rather
+ complicated, providing options for which disk method to use (GDBM?
+ DB_File? Flat file? Storable? User-supplied?) and which stringizing
+ method to use (FreezeThaw? Marshal? User-supplied?)
+
+ Done!
+
+ =item *
+
+ Maybe an option for automatic expiration of cache values? (`After one
+ day,' `After five uses,' etc.) Also possibly an option to limit the
+ number of active entries with automatic LRU expiration.
+
+ You have a long note to Mike Cariaso that outlines a good approach
+ that you sent on 9 April 1999.
+
+ What's the timeout stuff going to look like?
+
+ EXPIRE_TIME => time_in_sec
+ EXPIRE_USES => num_uses
+ MAXENTRIES => n
+
+ perhaps? Is EXPIRE_USES actually useful?
+
+ 19990916: Memoize::Expire does EXPIRE_TIME and EXPIRE_USES.
+ MAXENTRIES can come later as a separate module.
+
+ =item *
+
+ Put in a better example than C<fibo>. Show an example of a
+ nonrecursive function that simply takes a long time to run.
+ C<getpwuid> for example? But this exposes the bug that you can't say
+ C<memoize('getpwuid')>, so perhaps it's not a very good example.
+
+ Well, I did add the ColorToRGB example, but it's still not so good.
+ These examples need a lot of work. C<factorial> might be a better
+ example than C<fibo>.
+
+ =item *
+
+ Add more regression tests for normalizers.
+
+ =item *
+
+ Maybe resolve normalizer function to code-ref at memoize time instead
+ of at function call time for efficiency? I think there was some
+ reason not to do this, but I can't remember what it was.
+
+ =item *
+
+ Add more array value tests to the test suite.
+
+ Does it need more now?
+
+ =item *
+
+ Fix that `Subroutine u redefined ... line 484' message.
+
+ Fixed, I think.
+
+ =item *
+
+ Get rid of any remaining *{$ref}{CODE} or similar magic hashes.
+
+ =item *
+
+ There should be an option to dump out the memoized values or to
+ otherwise traverse them.
+
+ What for?
+
+ Maybe the tied hash interface taskes care of this anyway?
+
+ =item *
+
+ Include an example that caches DNS lookups.
+
+ =item *
+
+ Make tie for Storable (Memoize::Storable)
+
+ A prototype of Memoize::Storable is finished. Test it and add to the
+ test suite.
+
+ Done.
+
+ =item *
+
+ Make tie for DBI (Memoize::DBI)
+
+ =item *
+
+ I think there's a bug. See `###BUG'.
+
+ =item *
+
+ Storable probably can't be done, because it doesn't allow updating.
+ Maybe a different interface that supports readonly caches fronted by a
+ writable in-memory cache? A generic tied hash maybe?
+
+ FETCH {
+ if (it's in the memory hash) {
+ return it
+ } elsif (it's in the readonly disk hash) {
+ return it
+ } else {
+ not-there
+ }
+ }
+
+ STORE {
+ put it into the in-memory hash
+ }
+
+ Maybe `save' and `restore' methods?
+
+ It isn't working right because the destructor doesn't get called at
+ the right time.
+
+ This is fixed. `use strict vars' would have caught it immediately. Duh.
+
+ =item *
+
+ Don't forget about generic interface to Storable-like packages
+
+ 20010627 It would appear that you put this into 0.51.
+
+ =item *
+
+ Maybe add in TODISK after all, with TODISK => 'filename' equivalent to
+
+ SCALAR_CACHE => [TIE, Memoize::SDBM_File, $filename, O_RDWR|O_CREAT, 0666],
+ LIST_CACHE => MERGE
+
+ =item *
+
+ Maybe the default for LIST_CACHE should be MERGE anyway.
+
+ =item *
+
+ There's some terrible bug probably related to use under threaded perl,
+ possibly connected with line 56:
+
+ my $wrapper = eval "sub { unshift \@_, qq{$cref}; goto &_memoizer; }";
+
+ I think becayse C<@_> is lexically scoped in threadperl, the effect of
+ C<unshift> never makes it into C<_memoizer>. That's probably a bug in
+ Perl, but maybe I should work around it. Can anyone provide more
+ information here, or lend me a machine with threaded Perl where I can
+ test this theory? Line 59, currently commented out, may fix the
+ problem.
+
+ 20010623 Working around this in 0.65, but it still blows.
+
+ =item *
+
+ Maybe if the original function has a prototype, the module can use
+ that to select the most appropriate default normalizer. For example,
+ if the prototype was C<($)>, there's no reason to use `join'. If it's
+ C<(\@)> then it can use C<join $;,@$_[0];> instead of C<join $;,@_;>.
+
+ =item *
+
+ Ariel Scolnikov suggests using the change counting problem as an
+ example. (How many ways to make change of a dollar?)
+
+ =item *
+
+ Jonathan Roy found a use for `unmemoize'. If you're using the
+ Storable glue, and your program gets SIGINT, you find that the cache
+ data is not in the cache, because Perl normally writes it all out at
+ once from a DESTROY method, and signals skip DESTROY processing. So
+ you could add
+
+ $sig{INT} = sub { unmemoize ... };
+
+
+ =item *
+
+ This means it would be useful to have a method to return references to
+ all the currently-memoized functions so that you could say
+
+ $sig{INT} = sub { for $f (Memoize->all_memoized) {
+ unmemoize $f;
+ }
+ }
+
+
+ =item *
+
+ 19990917 There should be a call you can make to get back the cache
+ itself. If there were, then you could delete stuff from it to
+ manually expire data items.
+
+ =item *
+
+ 19990925 Randal says that the docs for Memoize;:Expire should make it
+ clear that the expired entries are never flushed all at once. He
+ asked if you would need to do that manually. I said:
+
+ Right, if that's what you want. If you have EXISTS return false,
+ it'll throw away the old cached item and replace it in the cache
+ with a new item. But if you want the cache to actually get smaller,
+ you have to do that yourself.
+
+ I was planning to build an Expire module that implemented an LRU
+ queue and kept the cache at a constant fixed size, but I didn't get
+ to it yet. It's not clear to me that the automatic exptynig-out
+ behavior is very useful anyway. The whole point of a cache is to
+ trade space for time, so why bother going through the cache to throw
+ away old items before you need to?
+
+ Randal then pointed out that it could discard expired items at DESTRoY
+ or TIEHASH time, which seemed like a good idea, because if the cache
+ is on disk you might like to keep it as small as possible.
+
+ =item *
+
+ 19991219 Philip Gwyn suggests this technique: You have a load_file
+ function that memoizes the file contexts. But then if the file
+ changes you get the old contents. So add a normalizer that does
+
+ return join $;, (stat($_[0])[9]), $_[0];
+
+ Now when the modification date changes, the true key returned by the
+ normalizer is different, so you get a cache miss and it loads the new
+ contents. Disadvantage: The old contents are still in the cache. I
+ think it makes more sense to have a special expiration manager for
+ this. Make one up and bundle it.
+
+ 19991220 I have one written: Memoize::ExpireFile. But how can you
+ make this work when the function might have several arguments, of
+ which some are filenames and some aren't?
+
+ =item *
+
+ 19991219 There should be an inheritable TIEHASH method that does the
+ argument processing properly.
+
+ 19991220 Philip Gwyn contributed a patch for this.
+
+ 20001231 You should really put this in. Jonathan Roy uncovered a
+ problem that it will be needed to solve. Here's the problem: He has:
+
+ memoize "get_items",
+ LIST_CACHE => ["TIE", "Memoize::Expire",
+ LIFETIME => 86400,
+ TIE => ["DB_File", "debug.db", O_CREAT|O_RDWR, 0666]
+ ];
+
+ This won't work, because memoize is trying to store listrefs in a
+ DB_File. He owuld have gotten a fatal error if he had done this:
+
+ memoize "get_items",
+ LIST_CACHE => ["TIE", "DB_File", "debug.db", O_CREAT|O_RDWR, 0666]'
+
+
+ But in this case, he tied the cache to Memoize::Expire, which is *not*
+ scalar-only, and the check for scalar-only ties is missing from
+ Memoize::Expire. The inheritable method can take care of this.
+
+ 20010623 I decided not to put it in. Instead, we avoid the problem by
+ getting rid of TIE. The HASH option does the same thing, and HASH is
+ so simple to support that a module is superfluous.
+
+ =item *
+
+ 20001130 Custom cache manager that checks to make sure the function
+ return values actually match the memoized values.
+
+ =item *
+
+ 20001231 Expiration manager that watches cache performance and
+ accumulates statistics. Variation: Have it automatically unmemoize
+ the function if performance is bad.
+
+ =item *
+
+ 20010517 Option to have normalizer *modify* @_ for use by memoized
+ function. This would save code and time in cases like the one in the
+ manual under 'NORMALIZER', where both f() and normalize_f() do the
+ same analysis and make the same adjustments to the hash. If the
+ normalizer could make the adjustments and save the changes in @_, you
+ wouldn't have to do it twice.
+
+ =item*
+ 20010623 Add CLEAR methods to tied hash modules.
+
+ =item*
+ 20010623 You get a warning if you try to use DB_File as LIST_CACHE,
+ because it won't store lists. But if you use it as the underlying
+ cache with an expiration manager in the middle, no warning---the
+ expiration manager doesn't know it's managing a list cache, and
+ memoize doesn't know that DB_File is underlying. Is this fixable?
+ Probably not, but think about it.
+
+ =item *
+ There was probably some other stuff that I forgot.
+
+
+
+ =back
diff -c /dev/null 'perl-5.7.2/lib/Memoize/t/array.t'
Index: ./lib/Memoize/t/array.t
*** ./lib/Memoize/t/array.t Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/t/array.t Mon Jul 9 17:10:37 2001
***************
*** 0 ****
--- 1,68 ----
+ #!/usr/bin/perl
+
+ use lib '..';
+ use Memoize;
+
+
+ print "1..11\n";
+
+ sub timelist {
+ return (time) x $_[0];
+ }
+
+ memoize('timelist');
+
+ @t1 = &timelist(1);
+ sleep 2;
+ @u1 = &timelist(1);
+ print ((("@t1" eq "@u1") ? '' : 'not '), "ok 1\n");
+
+ @t7 = &timelist(7);
+ print (((@t7 == 7) ? '' : 'not '), "ok 2\n");
+ $BAD = 0;
+ for ($i = 1; $i < 7; $i++) {
+ $BAD++ unless $t7[$i-1] == $t7[$i];
+ }
+ print (($BAD ? 'not ' : ''), "ok 3\n");
+
+ sleep 2;
+ @u7 = &timelist(7);
+ print (((@u7 == 7) ? '' : 'not '), "ok 4\n");
+ $BAD = 0;
+ for ($i = 1; $i < 7; $i++) {
+ $BAD++ unless $u7[$i-1] == $u7[$i];
+ }
+ print (($BAD ? 'not ' : ''), "ok 5\n");
+ # Properly memoized?
+ print ((("@t7" eq "@u7") ? '' : 'not '), "ok 6\n");
+
+ sub con {
+ return wantarray()
+ }
+
+ # Same arguments yield different results in different contexts?
+ memoize('con');
+ $s = con(1);
+ @a = con(1);
+ print ((($s == $a[0]) ? 'not ' : ''), "ok 7\n");
+
+ # Context propagated correctly?
+ print ((($s eq '') ? '' : 'not '), "ok 8\n"); # Scalar context
+ print ((("@a" eq '1' && @a == 1) ? '' : 'not '), "ok 9\n"); # List context
+
+ # Context propagated correctly to normalizer?
+ sub n {
+ my $arg = shift;
+ my $test = shift;
+ if (wantarray) {
+ print ((($arg eq ARRAY) ? '' : 'not '), "ok $test\n"); # List context
+ } else {
+ print ((($arg eq SCALAR) ? '' : 'not '), "ok $test\n"); # Scalar context
+ }
+ }
+
+ sub f { 1 }
+ memoize('f', NORMALIZER => 'n');
+ $s = f('SCALAR', 10); # Test 10
+ @a = f('ARRAY' , 11); # Test 11
+
diff -c /dev/null 'perl-5.7.2/lib/Memoize/t/array_confusion.t'
Index: ./lib/Memoize/t/array_confusion.t
*** ./lib/Memoize/t/array_confusion.t Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/t/array_confusion.t Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,43 ----
+ #!/usr/bin/perl
+
+ use lib '..';
+ use Memoize 'memoize', 'unmemoize';
+
+ sub reff {
+ return [1,2,3];
+
+ }
+
+ sub listf {
+ return (1,2,3);
+ }
+
+ print "1..6\n";
+
+ memoize 'reff', LIST_CACHE => 'MERGE';
+ print "ok 1\n";
+ memoize 'listf';
+ print "ok 2\n";
+
+ $s = reff();
+ @a = reff();
+ print @a == 1 ? "ok 3\n" : "not ok 3\n";
+
+ $s = listf();
+ @a = listf();
+ print @a == 3 ? "ok 4\n" : "not ok 4\n";
+
+ unmemoize 'reff';
+ memoize 'reff', LIST_CACHE => 'MERGE';
+ unmemoize 'listf';
+ memoize 'listf';
+
+ @a = reff();
+ $s = reff();
+ print @a == 1 ? "ok 5\n" : "not ok 5\n";
+
+ @a = listf();
+ $s = listf();
+ print @a == 3 ? "ok 6\n" : "not ok 6\n";
+
+
diff -c /dev/null 'perl-5.7.2/lib/Memoize/t/correctness.t'
Index: ./lib/Memoize/t/correctness.t
*** ./lib/Memoize/t/correctness.t Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/t/correctness.t Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,129 ----
+ #!/usr/bin/perl
+
+ use lib '..';
+ use Memoize;
+
+ print "1..25\n";
+
+ print "# Basic\n";
+
+ # A function that should only be called once.
+ { my $COUNT = 0;
+ sub no_args {
+ $FAIL++ if $COUNT++;
+ 11;
+ }
+ }
+
+ #
+ memoize('no_args');
+
+ $c1 = &no_args();
+ print (($c1 == 11) ? "ok 1\n" : "not ok 1\n");
+ $c2 = &no_args();
+ print (($c2 == 11) ? "ok 2\n" : "not ok 2\n");
+ print $FAIL ? "not ok 3\n" : "ok 3\n"; # Was it really memoized?
+
+ $FAIL = 0;
+ $f = do { my $COUNT = 0; sub { $FAIL++ if $COUNT++; 12 } };
+ $fm = memoize($f);
+
+ $c1 = &$fm();
+ print (($c1 == 12) ? "ok 4\n" : "not ok 4\n");
+ $c2 = &$fm();
+ print (($c2 == 12) ? "ok 5\n" : "not ok 5\n");
+ print $FAIL ? "not ok 6\n" : "ok 6\n"; # Was it really memoized?
+
+ $f = do { my $COUNT = 0; sub { $FAIL++ if $COUNT++; 13 } };
+ $fm = memoize($f, INSTALL => 'another');
+
+ $c1 = &another(); # Was it really installed?
+ print (($c1 == 13) ? "ok 7\n" : "not ok 7\n");
+ $c2 = &another();
+ print (($c2 == 13) ? "ok 8\n" : "not ok 8\n");
+ print $FAIL ? "not ok 9\n" : "ok 9\n"; # Was it really memoized?
+ $c3 = &$fm(); # Call memoized version through returned ref
+ print (($c3 == 13) ? "ok 10\n" : "not ok 10\n");
+ print $FAIL ? "not ok 11\n" : "ok 11\n"; # Was it really memoized?
+ $c4 = &$f(); # Call original version again
+ print (($c4 == 13) ? "ok 12\n" : "not ok 12\n");
+ print $FAIL ? "ok 13\n" : "not ok 13\n"; # Did we get the original?
+
+ print "# Fibonacci\n";
+
+ sub mt1 { # Fibonacci
+ my $n = shift;
+ return $n if $n < 2;
+ mt1($n-1) + mt2($n-2);
+ }
+ sub mt2 {
+ my $n = shift;
+ return $n if $n < 2;
+ mt1($n-1) + mt2($n-2);
+ }
+
+ @f1 = map { mt1($_) } (0 .. 15);
+ @f2 = map { mt2($_) } (0 .. 15);
+ memoize('mt1');
+ @f3 = map { mt1($_) } (0 .. 15);
+ @f4 = map { mt1($_) } (0 .. 15);
+ @arrays = (\@f1, \@f2, \@f3, \@f4);
+ $n = 13;
+ for ($i=0; $i<3; $i++) {
+ for ($j=$i+1; $j<3; $j++) {
+ $n++;
+ print ((@{$arrays[$i]} == @{$arrays[$j]}) ? "ok $n\n" : "not ok $n\n");
+ $n++;
+ for ($k=0; $k < @{$arrays[$i]}; $k++) {
+ (print "not ok $n\n", next) if $arrays[$i][$k] != $arrays[$j][$k];
+ }
+ print "ok $n\n";
+ }
+ }
+
+
+
+ print "# Normalizers\n";
+
+ sub fake_normalize {
+ return '';
+ }
+
+ sub f1 {
+ return shift;
+ }
+ sub f2 {
+ return shift;
+ }
+ sub f3 {
+ return shift;
+ }
+ &memoize('f1');
+ &memoize('f2', NORMALIZER => 'fake_normalize');
+ &memoize('f3', NORMALIZER => \&fake_normalize);
+ @f1r = map { f1($_) } (1 .. 10);
+ @f2r = map { f2($_) } (1 .. 10);
+ @f3r = map { f3($_) } (1 .. 10);
+ $n++;
+ print (("@f1r" eq "1 2 3 4 5 6 7 8 9 10") ? "ok $n\n" : "not ok $n\n");
+ $n++;
+ print (("@f2r" eq "1 1 1 1 1 1 1 1 1 1") ? "ok $n\n" : "not ok $n\n");
+ $n++;
+ print (("@f3r" eq "1 1 1 1 1 1 1 1 1 1") ? "ok $n\n" : "not ok $n\n");
+
+ print "# INSTALL => undef option.\n";
+ { my $i = 1;
+ sub u1 { $i++ }
+ }
+ my $um = memoize('u1', INSTALL => undef);
+ @umr = (&$um, &$um, &$um);
+ @u1r = (&u1, &u1, &u1 ); # Did *not* clobber &u1
+ $n++;
+ print (("@umr" eq "1 1 1") ? "ok $n\n" : "not ok $n\n"); # Increment once
+ $n++;
+ print (("@u1r" eq "2 3 4") ? "ok $n\n" : "not ok $n\n"); # Increment thrice
+ $n++;
+ print ((defined &{"undef"}) ? "not ok $n\n" : "ok $n\n"); # Just in case
+
+ print "# $n tests in all.\n";
+
diff -c /dev/null 'perl-5.7.2/lib/Memoize/t/errors.t'
Index: ./lib/Memoize/t/errors.t
*** ./lib/Memoize/t/errors.t Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/t/errors.t Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,53 ----
+ #!/usr/bin/perl
+
+ use lib '..';
+ use Memoize;
+ use Config;
+
+ print "1..11\n";
+
+ eval { memoize({}) };
+ print $@ ? "ok 1\n" : "not ok 1 # $@\n";
+
+ eval { memoize([]) };
+ print $@ ? "ok 2\n" : "not ok 2 # $@\n";
+
+ eval { my $x; memoize(\$x) };
+ print $@ ? "ok 3\n" : "not ok 3 # $@\n";
+
+ # 4--8
+ $n = 4;
+ my $dummyfile = './dummydb';
+ use Fcntl;
+ my %args = ( DB_File => [],
+ GDBM_File => [$dummyfile, 2, 0666],
+ ODBM_File => [$dummyfile, O_RDWR|O_CREAT, 0666],
+ NDBM_File => [$dummyfile, O_RDWR|O_CREAT, 0666],
+ SDBM_File => [$dummyfile, O_RDWR|O_CREAT, 0666],
+ );
+ for $mod (qw(DB_File GDBM_File SDBM_File ODBM_File NDBM_File)) {
+ eval {
+ require "$mod.pm";
+ tie my %cache => $mod, @{$args{$mod}};
+ memoize(sub {}, LIST_CACHE => [HASH => \%cache ]);
+ };
+ print $@ =~ /can only store scalars/
+ || $@ =~ /Can't locate.*in \@INC/ ? "ok $n\n" : "not ok $n # $@\n";
+ 1 while unlink $dummyfile;
+ $n++;
+ }
+
+ # 9
+ eval { local $^W = 0;
+ memoize(sub {}, LIST_CACHE => ['TIE', 'WuggaWugga'])
+ };
+ print $@ ? "ok 9\n" : "not ok 9 # $@\n";
+
+ # 10
+ eval { memoize(sub {}, LIST_CACHE => 'YOB GORGLE') };
+ print $@ ? "ok 10\n" : "not ok 10 # $@\n";
+
+ # 11
+ eval { memoize(sub {}, SCALAR_CACHE => ['YOB GORGLE']) };
+ print $@ ? "ok 11\n" : "not ok 11 # $@\n";
+
diff -c /dev/null 'perl-5.7.2/lib/Memoize/t/expire.t'
Index: ./lib/Memoize/t/expire.t
*** ./lib/Memoize/t/expire.t Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/t/expire.t Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,72 ----
+ #!/usr/bin/perl
+
+ use lib '..';
+ use Memoize;
+ use Memoize::ExpireTest;
+
+ my $n = 0;
+
+ print "1..17\n";
+
+ $n++; print "ok $n\n";
+
+ my %CALLS;
+ sub id {
+ my($arg) = @_;
+ ++$CALLS{$arg};
+ $arg;
+ }
+
+ tie my %cache => 'Memoize::ExpireTest';
+ memoize 'id',
+ SCALAR_CACHE => [HASH => \%cache],
+ LIST_CACHE => 'FAULT';
+ $n++; print "ok $n\n";
+
+ for $i (1, 2, 3, 1, 2, 1) {
+ $n++;
+ unless ($i == id($i)) {
+ print "not ";
+ }
+ print "ok $n\n";
+ }
+
+ for $i (1, 2, 3) {
+ $n++;
+ unless ($CALLS{$i} == 1) {
+ print "not ";
+ }
+ print "ok $n\n";
+ }
+
+ Memoize::ExpireTest::expire(1);
+
+ for $i (1, 2, 3) {
+ my $v = id($i);
+ }
+
+ for $i (1, 2, 3) {
+ $n++;
+ unless ($CALLS{$i} == 1 + ($i == 1)) {
+ print "not ";
+ }
+ print "ok $n\n";
+ }
+
+ Memoize::ExpireTest::expire(1);
+ Memoize::ExpireTest::expire(2);
+
+ for $i (1, 2, 3) {
+ my $v = id($i);
+ }
+
+ for $i (1, 2, 3) {
+ $n++;
+ unless ($CALLS{$i} == 4 - $i) {
+ print "not ";
+ }
+ print "ok $n\n";
+ }
+
+ exit 0;
+
diff -c /dev/null 'perl-5.7.2/lib/Memoize/t/expire_file.t'
Index: ./lib/Memoize/t/expire_file.t
*** ./lib/Memoize/t/expire_file.t Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/t/expire_file.t Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,68 ----
+ #!/usr/bin/perl
+
+ use lib '..';
+ use Memoize;
+
+ my $n = 0;
+
+
+ if (-e '.fast') {
+ print "1..0\n";
+ exit 0;
+ }
+
+ print "1..12\n";
+
+ ++$n; print "ok $n\n";
+
+ my $READFILE_CALLS = 0;
+ my $FILE = './TESTFILE';
+
+ sub writefile {
+ my $FILE = shift;
+ open F, "> $FILE" or die "Couldn't write temporary file $FILE: $!";
+ print F scalar(localtime), "\n";
+ close F;
+ }
+
+ sub readfile {
+ $READFILE_CALLS++;
+ my $FILE = shift;
+ open F, "< $FILE" or die "Couldn't write temporary file $FILE: $!";
+ my $data = <F>;
+ close F;
+ $data;
+ }
+
+ require Memoize::ExpireFile;
+ ++$n; print "ok $n\n";
+
+ tie my %cache => 'Memoize::ExpireFile';
+ memoize 'readfile',
+ SCALAR_CACHE => [HASH => \%cache],
+ LIST_CACHE => 'FAULT'
+ ;
+
+ ++$n; print "ok $n\n";
+
+ writefile($FILE);
+ ++$n; print "ok $n\n";
+ sleep 1;
+
+ my $t1 = readfile($FILE);
+ ++$n; print "ok $n\n";
+ ++$n; print ((($READFILE_CALLS == 1) ? '' : 'not '), "ok $n\n");
+
+ my $t2 = readfile($FILE);
+ ++$n; print "ok $n\n";
+ ++$n; print ((($READFILE_CALLS == 1) ? '' : 'not '), "ok $n\n");
+ ++$n; print ((($t1 eq $t2) ? '' : 'not '), "ok $n\n");
+
+ sleep 2;
+ writefile($FILE);
+ my $t3 = readfile($FILE);
+ ++$n; print "ok $n\n";
+ ++$n; print ((($READFILE_CALLS == 2) ? '' : 'not '), "ok $n\n");
+ ++$n; print ((($t1 ne $t3) ? '' : 'not '), "ok $n\n");
+
+ END { 1 while unlink $FILE }
diff -c /dev/null 'perl-5.7.2/lib/Memoize/t/expire_module_n.t'
Index: ./lib/Memoize/t/expire_module_n.t
*** ./lib/Memoize/t/expire_module_n.t Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/t/expire_module_n.t Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,62 ----
+ #!/usr/bin/perl
+
+ use lib '..';
+ use Memoize;
+
+ my $n = 0;
+
+
+ print "1..22\n";
+
+ ++$n; print "ok $n\n";
+
+ $RETURN = 1;
+
+ %CALLS = ();
+ sub call {
+ # print "CALL $_[0] => $RETURN\n";
+ ++$CALLS{$_[0]};
+ $RETURN;
+ }
+
+ require Memoize::Expire;
+ ++$n; print "ok $n\n";
+
+ tie my %cache => 'Memoize::Expire', NUM_USES => 2;
+ memoize 'call',
+ SCALAR_CACHE => [HASH => \%cache],
+ LIST_CACHE => 'FAULT';
+
+ # $Memoize::Expire::DEBUG = 1;
+ ++$n; print "ok $n\n";
+
+ # 3--6
+ for (0,1,2,3) {
+ print "not " unless call($_) == 1;
+ ++$n; print "ok $n\n";
+ }
+
+ # 7--10
+ for (keys %CALLS) {
+ print "not " unless $CALLS{$_} == (1,1,1,1)[$_];
+ ++$n; print "ok $n\n";
+ }
+
+ # 11--13
+ $RETURN = 2;
+ ++$n; print ((call(1) == 1 ? '' : 'not '), "ok $n\n"); # 1 expires
+ ++$n; print ((call(1) == 2 ? '' : 'not '), "ok $n\n"); # 1 gets new val
+ ++$n; print ((call(2) == 1 ? '' : 'not '), "ok $n\n"); # 2 expires
+
+ # 14--17
+ $RETURN = 3;
+ for (0,1,2,3) {
+ # 0 expires, 1 expires, 2 gets new val, 3 expires
+ print "not " unless call($_) == (1,2,3,1)[$_];
+ ++$n; print "ok $n\n";
+ }
+
+ for (0,1,2,3) {
+ print "not " unless $CALLS{$_} == (1,2,2,1)[$_];
+ ++$n; print "ok $n\n";
+ }
diff -c /dev/null 'perl-5.7.2/lib/Memoize/t/expire_module_t.t'
Index: ./lib/Memoize/t/expire_module_t.t
*** ./lib/Memoize/t/expire_module_t.t Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/t/expire_module_t.t Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,108 ----
+ #!/usr/bin/perl
+
+ use lib '..';
+ use Memoize;
+ use Time::HiRes 'time';
+ my $DEBUG = 0;
+
+ my $n = 0;
+ $| = 1;
+
+ if (-e '.fast') {
+ print "1..0\n";
+ exit 0;
+ }
+
+ # Perhaps nobody will notice if we don't say anything
+ # print "# Warning: I'm testing the timed expiration policy.\n# This will take about thirty seconds.\n";
+
+ print "1..15\n";
+ $| = 1;
+
+ ++$n; print "ok $n\n";
+
+ require Memoize::Expire;
+ ++$n; print "ok $n\n";
+
+ sub close_enough {
+ # print "Close enough? @_[0,1]\n";
+ abs($_[0] - $_[1]) <= 1;
+ }
+
+ my $t0;
+ sub start_timer {
+ $t0 = time;
+ $DEBUG and print "# $t0\n";
+ }
+
+ sub wait_until {
+ my $until = shift();
+ my $diff = $until - (time() - $t0);
+ $DEBUG and print "# until $until; diff = $diff\n";
+ return if $diff <= 0;
+ select undef, undef, undef, $diff;
+ }
+
+ sub now {
+ # print "NOW: @_ ", time(), "\n";
+ time;
+ }
+
+ tie my %cache => 'Memoize::Expire', LIFETIME => 8;
+ memoize 'now',
+ SCALAR_CACHE => [HASH => \%cache ],
+ LIST_CACHE => 'FAULT'
+ ;
+
+ ++$n; print "ok $n\n";
+
+
+ # T
+ start_timer();
+ for (1,2,3) {
+ $when{$_} = now($_);
+ ++$n;
+ print "not " unless close_enough($when{$_}, time());
+ print "ok $n\n";
+ sleep 3 if $_ < 3;
+ $DEBUG and print "# ", time()-$t0, "\n";
+ }
+ # values will now expire at T=8, 11, 14
+ # it is now T=6
+
+ # T+6
+ for (1,2,3) {
+ $again{$_} = now($_); # Should be the same as before, because of memoization
+ }
+
+ # T+6
+ foreach (1,2,3) {
+ ++$n;
+ print "not " unless close_enough($when{$_}, $again{$_});
+ print "ok $n\n";
+ }
+
+ wait_until(9.5); # now(1) expires
+ print "not " unless close_enough(time, $again{1} = now(1));
+ ++$n; print "ok $n\n";
+
+ # T+9.5
+ foreach (2,3) { # Should not have expired yet.
+ ++$n;
+ print "not " unless close_enough(scalar(now($_)), $again{$_});
+ print "ok $n\n";
+ }
+
+ wait_until(12.5); # now(2) expires
+
+ # T+12.5
+ print "not " unless close_enough(time, $again{2} = now(2));
+ ++$n; print "ok $n\n";
+
+ # T+12.5
+ foreach (1,3) { # 1 is good again because it was recomputed after it expired
+ ++$n;
+ print "not " unless close_enough(scalar(now($_)), $again{$_});
+ print "ok $n\n";
+ }
+
diff -c /dev/null 'perl-5.7.2/lib/Memoize/t/flush.t'
Index: ./lib/Memoize/t/flush.t
*** ./lib/Memoize/t/flush.t Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/t/flush.t Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,42 ----
+ #!/usr/bin/perl
+
+ use lib '..';
+ use Memoize 'flush_cache', 'memoize';
+ print "1..8\n";
+ print "ok 1\n";
+
+
+
+ my $V = 100;
+ sub VAL { $V }
+
+ memoize 'VAL';
+ print "ok 2\n";
+
+ my $c1 = VAL();
+ print (($c1 == 100) ? "ok 3\n" : "not ok 3\n");
+
+ $V = 200;
+ $c1 = VAL();
+ print (($c1 == 100) ? "ok 4\n" : "not ok 4\n");
+
+ flush_cache('VAL');
+ $c1 = VAL();
+ print (($c1 == 200) ? "ok 5\n" : "not ok 5\n");
+
+ $V = 300;
+ $c1 = VAL();
+ print (($c1 == 200) ? "ok 6\n" : "not ok 6\n");
+
+ flush_cache(\&VAL);
+ $c1 = VAL();
+ print (($c1 == 300) ? "ok 7\n" : "not ok 7\n");
+
+ $V = 400;
+ $c1 = VAL();
+ print (($c1 == 300) ? "ok 8\n" : "not ok 8\n");
+
+
+
+
+
diff -c /dev/null 'perl-5.7.2/lib/Memoize/t/normalize.t'
Index: ./lib/Memoize/t/normalize.t
*** ./lib/Memoize/t/normalize.t Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/t/normalize.t Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,57 ----
+ #!/usr/bin/perl
+
+ use lib '..';
+ use Memoize;
+
+ print "1..7\n";
+
+
+ sub n_null { '' }
+
+ { my $I = 0;
+ sub n_diff { $I++ }
+ }
+
+ { my $I = 0;
+ sub a1 { $I++; "$_[0]-$I" }
+ my $J = 0;
+ sub a2 { $J++; "$_[0]-$J" }
+ my $K = 0;
+ sub a3 { $K++; "$_[0]-$K" }
+ }
+
+ my $a_normal = memoize('a1', INSTALL => undef);
+ my $a_nomemo = memoize('a2', INSTALL => undef, NORMALIZER => 'n_diff');
+ my $a_allmemo = memoize('a3', INSTALL => undef, NORMALIZER => 'n_null');
+
+ @ARGS = (1, 2, 3, 2, 1);
+
+ @res = map { &$a_normal($_) } @ARGS;
+ print ((("@res" eq "1-1 2-2 3-3 2-2 1-1") ? '' : 'not '), "ok 1\n");
+
+ @res = map { &$a_nomemo($_) } @ARGS;
+ print ((("@res" eq "1-1 2-2 3-3 2-4 1-5") ? '' : 'not '), "ok 2\n");
+
+ @res = map { &$a_allmemo($_) } @ARGS;
+ print ((("@res" eq "1-1 1-1 1-1 1-1 1-1") ? '' : 'not '), "ok 3\n");
+
+
+
+ # Test fully-qualified name and installation
+ $COUNT = 0;
+ sub parity { $COUNT++; $_[0] % 2 }
+ sub parnorm { $_[0] % 2 }
+ memoize('parity', NORMALIZER => 'main::parnorm');
+ @res = map { &parity($_) } @ARGS;
+ print ((("@res" eq "1 0 1 0 1") ? '' : 'not '), "ok 4\n");
+ print (( ($COUNT == 2) ? '' : 'not '), "ok 5\n");
+
+ # Test normalization with reference to normalizer function
+ $COUNT = 0;
+ sub par2 { $COUNT++; $_[0] % 2 }
+ memoize('par2', NORMALIZER => \&parnorm);
+ @res = map { &par2($_) } @ARGS;
+ print ((("@res" eq "1 0 1 0 1") ? '' : 'not '), "ok 6\n");
+ print (( ($COUNT == 2) ? '' : 'not '), "ok 7\n");
+
+
diff -c /dev/null 'perl-5.7.2/lib/Memoize/t/prototype.t'
Index: ./lib/Memoize/t/prototype.t
*** ./lib/Memoize/t/prototype.t Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/t/prototype.t Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,36 ----
+ #!/usr/bin/perl
+
+ use lib '..';
+ use Memoize;
+ $EXPECTED_WARNING = '(no warning expected)';
+
+
+ print "1..4\n";
+
+ sub q1 ($) { $_[0] + 1 }
+ sub q2 () { time }
+ sub q3 { join "--", @_ }
+
+ $SIG{__WARN__} = \&handle_warnings;
+
+ $RES = 'ok';
+ memoize 'q1';
+ print "$RES 1\n";
+
+ $RES = 'ok';
+ memoize 'q2';
+ print "$RES 2\n";
+
+ $RES = 'ok';
+ memoize 'q3';
+ print "$RES 3\n";
+
+ # Let's see if the prototype is actually honored
+ @q = (1..5);
+ $r = q1(@q);
+ print (($r == 6) ? '' : 'not ', "ok 4\n");
+
+ sub handle_warnings {
+ print $_[0];
+ $RES = 'not ok' unless $_[0] eq $EXPECTED_WARNING;
+ }
diff -c /dev/null 'perl-5.7.2/lib/Memoize/t/speed.t'
Index: ./lib/Memoize/t/speed.t
*** ./lib/Memoize/t/speed.t Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/t/speed.t Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,95 ----
+ #!/usr/bin/perl
+
+ use lib '..';
+ use Memoize;
+
+ if (-e '.fast') {
+ print "1..0\n";
+ exit 0;
+ }
+ $| = 1;
+
+ # If we don't say anything, maybe nobody will notice.
+ # print STDERR "\nWarning: I'm testing the speedup. This might take up to thirty seconds.\n ";
+
+
+ print "1..6\n";
+
+ # This next test finds an example that takes a long time to run, then
+ # checks to make sure that the run is actually speeded up by memoization.
+ # In some sense, this is the most essential correctness test in the package.
+ #
+ # We do this by running the fib() function with successfily larger
+ # arguments until we find one that tales at leasrtt $LONG_RUN seconds
+ # to execute. Then we memoize fib() and run the same call cagain. If
+ # it doesn't produce the same test in less than one-tenth the time,
+ # something is seriously wrong.
+ #
+ # $LONG_RUN is the number of seconds that the function call must last
+ # in order for the call to be considered sufficiently long.
+
+
+ sub fib {
+ my $n = shift;
+ $COUNT++;
+ return $n if $n < 2;
+ fib($n-1) + fib($n-2);
+ }
+
+ sub max { $_[0] > $_[1] ?
+ $_[0] : $_[1]
+ }
+
+ $N = 1;
+
+ $ELAPSED = 0;
+
+ my $LONG_RUN = 10;
+
+ while (1) {
+ my $start = time;
+ $COUNT=0;
+ $RESULT = fib($N);
+ $ELAPSED = time - $start;
+ last if $ELAPSED >= $LONG_RUN;
+ if ($ELAPSED > 1) {
+ print "# fib($N) took $ELAPSED seconds.\n" if $N % 1 == 0;
+ # we'd expect that fib(n+1) takes about 1.618 times as long as fib(n)
+ # so now that we have a longish run, let's estimate the value of $N
+ # that will get us a sufficiently long run.
+ $N += 1 + int(log($LONG_RUN/$ELAPSED)/log(1.618));
+ print "# OK, N=$N ought to do it.\n";
+ # It's important not to overshoot here because the running time
+ # is exponential in $N. If we increase $N too aggressively,
+ # the user will be forced to wait a very long time.
+ } else {
+ $N++;
+ }
+ }
+
+ print "# OK, fib($N) was slow enough; it took $ELAPSED seconds.\n";
+ print "# Total calls: $COUNT.\n";
+
+ &memoize('fib');
+
+ $COUNT=0;
+ $start = time;
+ $RESULT2 = fib($N);
+ $ELAPSED2 = time - $start + .001; # prevent division by 0 errors
+
+ print (($RESULT == $RESULT2) ? "ok 1\n" : "not ok 1\n");
+ # If it's not ten times as fast, something is seriously wrong.
+ print (($ELAPSED/$ELAPSED2 > 10) ? "ok 2\n" : "not ok 2\n");
+ # If it called the function more than $N times, it wasn't memoized properly
+ print (($COUNT > $N) ? "ok 3\n" : "not ok 3\n");
+
+ # Do it again. Should be even faster this time.
+ $COUNT = 0;
+ $start = time;
+ $RESULT2 = fib($N);
+ $ELAPSED2 = time - $start + .001; # prevent division by 0 errors
+
+ print (($RESULT == $RESULT2) ? "ok 4\n" : "not ok 4\n");
+ print (($ELAPSED/$ELAPSED2 > 10) ? "ok 5\n" : "not ok 5\n");
+ # This time it shouldn't have called the function at all.
+ print ($COUNT == 0 ? "ok 6\n" : "not ok 6\n");
diff -c /dev/null 'perl-5.7.2/lib/Memoize/t/tie.t'
Index: ./lib/Memoize/t/tie.t
*** ./lib/Memoize/t/tie.t Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/t/tie.t Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,87 ----
+ #!/usr/bin/perl
+
+ use lib qw(. ..);
+ use Memoize 0.52 qw(memoize unmemoize);
+ use Fcntl;
+ eval {require Memoize::AnyDBM_File};
+ if ($@) {
+ print "1..0\n";
+ exit 0;
+ }
+
+
+
+ print "1..4\n";
+
+ sub i {
+ $_[0];
+ }
+
+ $ARG = 'Keith Bostic is a pinhead';
+
+ sub c119 { 119 }
+ sub c7 { 7 }
+ sub c43 { 43 }
+ sub c23 { 23 }
+ sub c5 { 5 }
+
+ sub n {
+ $_[0]+1;
+ }
+
+ if (eval {require File::Spec::Functions}) {
+ File::Spec::Functions->import('tmpdir', 'catfile');
+ $tmpdir = tmpdir();
+ } else {
+ *catfile = sub { join '/', @_ };
+ $tmpdir = $ENV{TMP} || $ENV{TMPDIR} || '/tmp';
+ }
+ $file = catfile($tmpdir, "md$$");
+ @files = ($file, "$file.db", "$file.dir", "$file.pag");
+ 1 while unlink @files;
+
+
+ tryout('Memoize::AnyDBM_File', $file, 1); # Test 1..4
+ # tryout('DB_File', $file, 1); # Test 1..4
+ 1 while unlink $file, "$file.dir", "$file.pag";
+
+ sub tryout {
+ my ($tiepack, $file, $testno) = @_;
+
+ tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666
+ or die $!;
+
+ memoize 'c5',
+ SCALAR_CACHE => [HASH => \%cache],
+ LIST_CACHE => 'FAULT'
+ ;
+
+ my $t1 = c5($ARG);
+ my $t2 = c5($ARG);
+ print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n");
+ $testno++;
+ print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n");
+ unmemoize 'c5';
+
+ # Now something tricky---we'll memoize c23 with the wrong table that
+ # has the 5 already cached.
+ memoize 'c23',
+ SCALAR_CACHE => ['HASH', \%cache],
+ LIST_CACHE => 'FAULT'
+ ;
+
+ my $t3 = c23($ARG);
+ my $t4 = c23($ARG);
+ $testno++;
+ print (($t3 == 5) ? "ok $testno\n" : "not ok $testno # Result $t3\n");
+ $testno++;
+ print (($t4 == 5) ? "ok $testno\n" : "not ok $testno # Result $t4\n");
+ unmemoize 'c23';
+ }
+
+ {
+ my @present = grep -e, @files;
+ if (@present && (@failed = grep { not unlink } @present)) {
+ warn "Can't unlink @failed! ($!)";
+ }
+ }
diff -c /dev/null 'perl-5.7.2/lib/Memoize/t/tie_gdbm.t'
Index: ./lib/Memoize/t/tie_gdbm.t
*** ./lib/Memoize/t/tie_gdbm.t Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/t/tie_gdbm.t Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,74 ----
+ #!/usr/bin/perl
+
+ use lib qw(. ..);
+ use Memoize 0.45 qw(memoize unmemoize);
+ use Fcntl;
+
+ sub i {
+ $_[0];
+ }
+
+ sub c119 { 119 }
+ sub c7 { 7 }
+ sub c43 { 43 }
+ sub c23 { 23 }
+ sub c5 { 5 }
+
+ sub n {
+ $_[0]+1;
+ }
+
+ eval {require GDBM_File};
+ if ($@) {
+ print "1..0\n";
+ exit 0;
+ }
+
+ print "1..4\n";
+
+ if (eval {require File::Spec::Functions}) {
+ File::Spec::Functions->import();
+ } else {
+ *catfile = sub { join '/', @_ };
+ }
+ $tmpdir = $ENV{TMP} || $ENV{TMPDIR} || '/tmp';
+ $file = catfile($tmpdir, "md$$");
+ 1 while unlink $file, "$file.dir", "$file.pag";
+ tryout('GDBM_File', $file, 1); # Test 1..4
+ 1 while unlink $file, "$file.dir", "$file.pag";
+
+ sub tryout {
+ require GDBM_File;
+ my ($tiepack, $file, $testno) = @_;
+
+ tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666
+ or die $!;
+
+ memoize 'c5',
+ SCALAR_CACHE => [HASH => \%cache],
+ LIST_CACHE => 'FAULT'
+ ;
+
+ my $t1 = c5();
+ my $t2 = c5();
+ print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n");
+ $testno++;
+ print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n");
+ unmemoize 'c5';
+
+ # Now something tricky---we'll memoize c23 with the wrong table that
+ # has the 5 already cached.
+ memoize 'c23',
+ SCALAR_CACHE => [HASH => \%cache],
+ LIST_CACHE => 'FAULT'
+ ;
+
+ my $t3 = c23();
+ my $t4 = c23();
+ $testno++;
+ print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n");
+ $testno++;
+ print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n");
+ unmemoize 'c23';
+ }
+
diff -c /dev/null 'perl-5.7.2/lib/Memoize/t/tie_ndbm.t'
Index: ./lib/Memoize/t/tie_ndbm.t
*** ./lib/Memoize/t/tie_ndbm.t Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/t/tie_ndbm.t Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,77 ----
+ #!/usr/bin/perl
+
+ use lib qw(. ..);
+ use Memoize 0.45 qw(memoize unmemoize);
+ use Fcntl;
+ # use Memoize::NDBM_File;
+ # $Memoize::NDBM_File::Verbose = 0;
+
+ sub i {
+ $_[0];
+ }
+
+ sub c119 { 119 }
+ sub c7 { 7 }
+ sub c43 { 43 }
+ sub c23 { 23 }
+ sub c5 { 5 }
+
+ sub n {
+ $_[0]+1;
+ }
+
+ eval {require Memoize::NDBM_File};
+ if ($@) {
+ print "1..0\n";
+ exit 0;
+ }
+
+ print "1..4\n";
+
+
+ if (eval {require File::Spec::Functions}) {
+ File::Spec::Functions->import();
+ } else {
+ *catfile = sub { join '/', @_ };
+ }
+ $tmpdir = $ENV{TMP} || $ENV{TMPDIR} || '/tmp';
+ $file = catfile($tmpdir, "md$$");
+ 1 while unlink $file, "$file.dir", "$file.pag";
+ tryout('Memoize::NDBM_File', $file, 1); # Test 1..4
+ 1 while unlink $file, "$file.dir", "$file.pag";
+
+ sub tryout {
+ my ($tiepack, $file, $testno) = @_;
+
+
+ tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666
+ or die $!;
+
+ memoize 'c5',
+ SCALAR_CACHE => [HASH => \%cache],
+ LIST_CACHE => 'FAULT'
+ ;
+
+ my $t1 = c5();
+ my $t2 = c5();
+ print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n");
+ $testno++;
+ print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n");
+ unmemoize 'c5';
+
+ # Now something tricky---we'll memoize c23 with the wrong table that
+ # has the 5 already cached.
+ memoize 'c23',
+ SCALAR_CACHE => [HASH => \%cache],
+ LIST_CACHE => 'FAULT'
+ ;
+
+ my $t3 = c23();
+ my $t4 = c23();
+ $testno++;
+ print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n");
+ $testno++;
+ print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n");
+ unmemoize 'c23';
+ }
+
diff -c /dev/null 'perl-5.7.2/lib/Memoize/t/tie_sdbm.t'
Index: ./lib/Memoize/t/tie_sdbm.t
*** ./lib/Memoize/t/tie_sdbm.t Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/t/tie_sdbm.t Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,76 ----
+ #!/usr/bin/perl
+
+ use lib qw(. ..);
+ use Memoize 0.45 qw(memoize unmemoize);
+ use Fcntl;
+ # use Memoize::SDBM_File;
+ # $Memoize::GDBM_File::Verbose = 0;
+
+ sub i {
+ $_[0];
+ }
+
+ sub c119 { 119 }
+ sub c7 { 7 }
+ sub c43 { 43 }
+ sub c23 { 23 }
+ sub c5 { 5 }
+
+ sub n {
+ $_[0]+1;
+ }
+
+ eval {require Memoize::SDBM_File};
+ if ($@) {
+ print "1..0\n";
+ exit 0;
+ }
+
+ print "1..4\n";
+
+ if (eval {require File::Spec::Functions}) {
+ File::Spec::Functions->import('tmpdir', 'catfile');
+ $tmpdir = tmpdir();
+ } else {
+ *catfile = sub { join '/', @_ };
+ $tmpdir = $ENV{TMP} || $ENV{TMPDIR} || '/tmp';
+ }
+ $file = catfile($tmpdir, "md$$");
+ 1 while unlink $file, "$file.dir", "$file.pag";
+ tryout('Memoize::SDBM_File', $file, 1); # Test 1..4
+ 1 while unlink $file, "$file.dir", "$file.pag";
+
+ sub tryout {
+ my ($tiepack, $file, $testno) = @_;
+
+ tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666
+ or die $!;
+
+ memoize 'c5',
+ SCALAR_CACHE => [HASH => \%cache],
+ LIST_CACHE => 'FAULT'
+ ;
+
+ my $t1 = c5();
+ my $t2 = c5();
+ print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n");
+ $testno++;
+ print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n");
+ unmemoize 'c5';
+
+ # Now something tricky---we'll memoize c23 with the wrong table that
+ # has the 5 already cached.
+ memoize 'c23',
+ SCALAR_CACHE => [HASH => \%cache],
+ LIST_CACHE => 'FAULT'
+ ;
+
+ my $t3 = c23();
+ my $t4 = c23();
+ $testno++;
+ print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n");
+ $testno++;
+ print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n");
+ unmemoize 'c23';
+ }
+
diff -c /dev/null 'perl-5.7.2/lib/Memoize/t/tie_storable.t'
Index: ./lib/Memoize/t/tie_storable.t
*** ./lib/Memoize/t/tie_storable.t Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/t/tie_storable.t Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,83 ----
+ #!/usr/bin/perl
+ # -*- mode: perl; perl-indent-level: 2 -*-
+
+ use lib qw(. ..);
+ use Memoize 0.45 qw(memoize unmemoize);
+ # $Memoize::Storable::Verbose = 0;
+
+ eval {require Memoize::Storable};
+ if ($@) {
+ print "1..0\n";
+ exit 0;
+ }
+
+ sub i {
+ $_[0];
+ }
+
+ sub c119 { 119 }
+ sub c7 { 7 }
+ sub c43 { 43 }
+ sub c23 { 23 }
+ sub c5 { 5 }
+
+ sub n {
+ $_[0]+1;
+ }
+
+ eval {require Storable};
+ if ($@) {
+ print "1..0\n";
+ exit 0;
+ }
+
+ print "1..4\n";
+
+
+ if (eval {require File::Spec::Functions}) {
+ File::Spec::Functions->import();
+ } else {
+ *catfile = sub { join '/', @_ };
+ }
+ $tmpdir = $ENV{TMP} || $ENV{TMPDIR} || '/tmp';
+ $file = catfile($tmpdir, "storable$$");
+ 1 while unlink $file;
+ tryout('Memoize::Storable', $file, 1); # Test 1..4
+ 1 while unlink $file;
+
+ sub tryout {
+ my ($tiepack, $file, $testno) = @_;
+
+ tie my %cache => $tiepack, $file
+ or die $!;
+
+ memoize 'c5',
+ SCALAR_CACHE => [HASH => \%cache],
+ LIST_CACHE => 'FAULT'
+ ;
+
+ my $t1 = c5();
+ my $t2 = c5();
+ print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n");
+ $testno++;
+ print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n");
+ unmemoize 'c5';
+ 1;
+ 1;
+
+ # Now something tricky---we'll memoize c23 with the wrong table that
+ # has the 5 already cached.
+ memoize 'c23',
+ SCALAR_CACHE => [HASH => \%cache],
+ LIST_CACHE => 'FAULT'
+ ;
+
+ my $t3 = c23();
+ my $t4 = c23();
+ $testno++;
+ print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n");
+ $testno++;
+ print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n");
+ unmemoize 'c23';
+ }
+
diff -c /dev/null 'perl-5.7.2/lib/Memoize/t/tiefeatures.t'
Index: ./lib/Memoize/t/tiefeatures.t
*** ./lib/Memoize/t/tiefeatures.t Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/t/tiefeatures.t Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,50 ----
+ #!/usr/bin/perl
+
+ use lib 'blib/lib';
+ use Memoize 0.45 qw(memoize unmemoize);
+ use Fcntl;
+
+ # print STDERR $INC{'Memoize.pm'}, "\n";
+
+ print "1..10\n";
+
+ # Test MERGE
+ sub xx {
+ wantarray();
+ }
+
+ my $s = xx();
+ print ((!$s) ? "ok 1\n" : "not ok 1\n");
+ my ($a) = xx();
+ print (($a) ? "ok 2\n" : "not ok 2\n");
+ memoize 'xx', LIST_CACHE => MERGE;
+ $s = xx();
+ print ((!$s) ? "ok 3\n" : "not ok 3\n");
+ ($a) = xx(); # Should return cached false value from previous invocation
+ print ((!$a) ? "ok 4\n" : "not ok 4\n");
+
+
+ # Test FAULT
+ sub ns {}
+ sub na {}
+ memoize 'ns', SCALAR_CACHE => FAULT;
+ memoize 'na', LIST_CACHE => FAULT;
+ eval { my $s = ns() }; # Should fault
+ print (($@) ? "ok 5\n" : "not ok 5\n");
+ eval { my ($a) = na() }; # Should fault
+ print (($@) ? "ok 6\n" : "not ok 6\n");
+
+
+ # Test HASH
+ my (%s, %l);
+ sub nul {}
+ memoize 'nul', SCALAR_CACHE => [HASH => \%s], LIST_CACHE => [HASH => \%l];
+ nul('x');
+ nul('y');
+ print ((join '', sort keys %s) eq 'xy' ? "ok 7\n" : "not ok 7\n");
+ print ((join '', sort keys %l) eq '' ? "ok 8\n" : "not ok 8\n");
+ () = nul('p');
+ () = nul('q');
+ print ((join '', sort keys %s) eq 'xy' ? "ok 9\n" : "not ok 9\n");
+ print ((join '', sort keys %l) eq 'pq' ? "ok 10\n" : "not ok 10\n");
+
diff -c /dev/null 'perl-5.7.2/lib/Memoize/t/unmemoize.t'
Index: ./lib/Memoize/t/unmemoize.t
*** ./lib/Memoize/t/unmemoize.t Thu Jan 1 02:00:00 1970
--- ./lib/Memoize/t/unmemoize.t Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,26 ----
+ #!/usr/bin/perl
+
+ use lib '..';
+ use Memoize qw(memoize unmemoize);
+
+ print "1..5\n";
+
+ eval { unmemoize('f') }; # Should fail
+ print (($@ ? '' : 'not '), "ok 1\n");
+
+ { my $I = 0;
+ sub u { $I++ }
+ }
+ memoize('u');
+ my @ur = (&u, &u, &u);
+ print (("@ur" eq "0 0 0") ? "ok 2\n" : "not ok 2\n");
+
+ eval { unmemoize('u') }; # Should succeed
+ print ($@ ? "not ok 3\n" : "ok 3\n");
+
+ @ur = (&u, &u, &u);
+ print (("@ur" eq "1 2 3") ? "ok 4\n" : "not ok 4\n");
+
+ eval { unmemoize('u') }; # Should fail
+ print ($@ ? "ok 5\n" : "not ok 5\n");
+
diff -c /dev/null 'perl-5.7.2/lib/NEXT.pm'
Index: ./lib/NEXT.pm
*** ./lib/NEXT.pm Thu Jan 1 02:00:00 1970
--- ./lib/NEXT.pm Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,140 ----
+ package NEXT;
+ use Carp;
+ use strict;
+
+ sub ancestors
+ {
+ my @inlist = @_;
+ my @outlist = ();
+ while (@inlist) {
+ push @outlist, shift @inlist;
+ no strict 'refs';
+ unshift @inlist, @{"$outlist[-1]::ISA"};
+ }
+ return @outlist;
+ }
+
+ sub AUTOLOAD
+ {
+ my ($self) = @_;
+ my $caller = (caller(1))[3];
+ my $wanted = $NEXT::AUTOLOAD || 'NEXT::AUTOLOAD';
+ undef $NEXT::AUTOLOAD;
+ my ($caller_class, $caller_method) = $caller =~ m{(.*)::(.*)}g;
+ my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
+ croak "Can't call $wanted from $caller"
+ unless $caller_method eq $wanted_method;
+
+ local $NEXT::NEXT{$self,$wanted_method} =
+ $NEXT::NEXT{$self,$wanted_method};
+
+ unless (@{$NEXT::NEXT{$self,$wanted_method}||[]}) {
+ my @forebears = ancestors ref $self;
+ while (@forebears) {
+ last if shift @forebears eq $caller_class
+ }
+ no strict 'refs';
+ @{$NEXT::NEXT{$self,$wanted_method}} =
+ map { *{"${_}::$caller_method"}{CODE}||() } @forebears;
+ @{$NEXT::NEXT{$self,$wanted_method}} =
+ map { *{"${_}::AUTOLOAD"}{CODE}||() } @forebears
+ unless @{$NEXT::NEXT{$self,$wanted_method}};
+ }
+ $wanted_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
+ return shift()->$wanted_method(@_) if $wanted_method;
+ return;
+ }
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ NEXT.pm - Provide a pseudo-class NEXT that allows method redispatch
+
+
+ =head1 SYNOPSIS
+
+ use NEXT;
+
+ package A;
+ sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() }
+ sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() }
+
+ package B;
+ use base qw( A );
+ sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
+ sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() }
+
+ package C;
+ sub C::method { print "$_[0]: C method\n"; $_[0]->NEXT::method() }
+ sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
+ sub C::DESTROY { print "$_[0]: C dtor\n"; $_[0]->NEXT::DESTROY() }
+
+ package D;
+ use base qw( B C );
+ sub D::method { print "$_[0]: D method\n"; $_[0]->NEXT::method() }
+ sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
+ sub D::DESTROY { print "$_[0]: D dtor\n"; $_[0]->NEXT::DESTROY() }
+
+ package main;
+
+ my $obj = bless {}, "D";
+
+ $obj->method(); # Calls D::method, A::method, C::method
+ $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
+
+ # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
+
+
+ =head1 DESCRIPTION
+
+ NEXT.pm adds a pseudoclass named C<NEXT> to any program
+ that uses it. If a method C<m> calls C<$self->NEXT::m()>, the call to
+ C<m> is redispatched as if the calling method had not originally been found.
+
+ In other words, a call to C<$self->NEXT::m()> resumes the depth-first,
+ left-to-right search of parent classes that resulted in the original
+ call to C<m>.
+
+ A typical use would be in the destructors of a class hierarchy,
+ as illustrated in the synopsis above. Each class in the hierarchy
+ has a DESTROY method that performs some class-specific action
+ and then redispatches the call up the hierarchy. As a result,
+ when an object of class D is destroyed, the destructors of I<all>
+ its parent classes are called (in depth-first, left-to-right order).
+
+ Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
+ If such a method determined that it was not able to handle a
+ particular call, it might choose to redispatch that call, in the
+ hope that some other C<AUTOLOAD> (above it, or to its left) might
+ do better.
+
+ Note that it is a fatal error for any method (including C<AUTOLOAD>)
+ to attempt to redispatch any method except itself. For example:
+
+ sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
+
+
+ =head1 AUTHOR
+
+ Damian Conway (damian@conway.org)
+
+ =head1 BUGS AND IRRITATIONS
+
+ Because it's a module, not an integral part of the interpreter, NEXT.pm
+ has to guess where the surrounding call was found in the method
+ look-up sequence. In the presence of diamond inheritance patterns
+ it occasionally guesses wrong.
+
+ It's also too slow (despite caching).
+
+ Comment, suggestions, and patches welcome.
+
+ =head1 COPYRIGHT
+
+ Copyright (c) 2000, Damian Conway. All Rights Reserved.
+ This module is free software. It may be used, redistributed
+ and/or modified under the terms of the Perl Artistic License
+ (see http://www.perl.com/perl/misc/Artistic.html)
diff -c /dev/null 'perl-5.7.2/lib/NEXT/test.pl'
Index: ./lib/NEXT/test.pl
*** ./lib/NEXT/test.pl Thu Jan 1 02:00:00 1970
--- ./lib/NEXT/test.pl Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,99 ----
+ #! /usr/local/bin/perl -w
+
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ BEGIN { print "1..20\n"; }
+
+ use NEXT;
+
+ print "ok 1\n";
+
+ package A;
+ sub A::method { return ( 3, $_[0]->NEXT::method() ) }
+ sub A::DESTROY { $_[0]->NEXT::DESTROY() }
+
+ package B;
+ use base qw( A );
+ sub B::AUTOLOAD { return ( 9, $_[0]->NEXT::AUTOLOAD() ) }
+ sub B::DESTROY { $_[0]->NEXT::DESTROY() }
+
+ package C;
+ sub C::DESTROY { print "ok 18\n"; $_[0]->NEXT::DESTROY() }
+
+ package D;
+ @D::ISA = qw( B C E );
+ sub D::method { return ( 2, $_[0]->NEXT::method() ) }
+ sub D::AUTOLOAD { return ( 8, $_[0]->NEXT::AUTOLOAD() ) }
+ sub D::DESTROY { print "ok 17\n"; $_[0]->NEXT::DESTROY() }
+ sub D::oops { $_[0]->NEXT::method() }
+
+ package E;
+ @E::ISA = qw( F G );
+ sub E::method { return ( 4, $_[0]->NEXT::method(), $_[0]->NEXT::method() ) }
+ sub E::AUTOLOAD { return ( 10, $_[0]->NEXT::AUTOLOAD() ) }
+ sub E::DESTROY { print "ok 19\n"; $_[0]->NEXT::DESTROY() }
+
+ package F;
+ sub F::method { return ( 5 ) }
+ sub F::AUTOLOAD { return ( 11 ) }
+ sub F::DESTROY { print "ok 20\n" }
+
+ package G;
+ sub G::method { return ( 6 ) }
+ sub G::AUTOLOAD { print "not "; return }
+ sub G::DESTROY { print "not ok 21"; return }
+
+ package main;
+
+ my $obj = bless {}, "D";
+
+ my @vals;
+
+ # TEST NORMAL REDISPATCH (ok 2..6)
+ @vals = $obj->method();
+ print map "ok $_\n", @vals;
+
+ # RETEST NORMAL REDISPATCH SHOULD BE THE SAME (ok 7)
+ @vals = $obj->method();
+ print "not " unless join("", @vals) == "23456";
+ print "ok 7\n";
+
+ # TEST AUTOLOAD REDISPATCH (ok 8..11)
+ @vals = $obj->missing_method();
+ print map "ok $_\n", @vals;
+
+ # NAMED METHOD CAN'T REDISPATCH TO NAMED METHOD OF DIFFERENT NAME (ok 12)
+ eval { $obj->oops() } && print "not ";
+ print "ok 12\n";
+
+ # AUTOLOAD'ED METHOD CAN'T REDISPATCH TO NAMED METHOD (ok 13)
+ eval q{
+ package C;
+ sub AUTOLOAD { $_[0]->NEXT::method() };
+ };
+ eval { $obj->missing_method(); } && print "not ";
+ print "ok 13\n";
+
+ # NAMED METHOD CAN'T REDISPATCH TO AUTOLOAD'ED METHOD (ok 14)
+ eval q{
+ package C;
+ sub method { $_[0]->NEXT::AUTOLOAD() };
+ };
+ eval { $obj->method(); } && print "not ";
+ print "ok 14\n";
+
+ # BASE CLASS METHODS ONLY REDISPATCHED WITHIN HIERARCHY (ok 15..16)
+ my $ob2 = bless {}, "B";
+ @val = $ob2->method();
+ print "not " unless @val==1 && $val[0]==3;
+ print "ok 15\n";
+
+ @val = $ob2->missing_method();
+ print "not " unless @val==1 && $val[0]==9;
+ print "ok 16\n";
+
+ # CAN REDISPATCH DESTRUCTORS (ok 17..20)
diff -c /dev/null 'perl-5.7.2/lib/Net/ChangeLog.libnet'
Index: ./lib/Net/ChangeLog.libnet
*** ./lib/Net/ChangeLog.libnet Thu Jan 1 02:00:00 1970
--- ./lib/Net/ChangeLog.libnet Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,717 ----
+ Change 402 on 2000/03/23 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Config
+ - Fix typos in requires_firewall(), Thanks to Johan Vromans <jvromans@squirrel.nl>
+
+ Change 401 on 2000/03/23 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - fix rmdir for when ls() returns full paths
+
+ Change 379 on 2000/03/13 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.0702
+
+ Change 378 on 2000/03/10 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP::A
+ - Fix to stop possible forever loop
+
+ Change 377 on 2000/03/10 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP::A
+ - use " not '
+
+ Change 376 on 2000/03/10 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Config
+ - need to import inet_aton and inet_ntoa
+
+ Change 375 on 2000/03/10 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Config
+ - change arg to split to /\./ from "."
+
+ Change 374 on 2000/03/07 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP::A
+ - Fix return value of read()
+
+ Change 373 on 2000/03/07 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP::I
+ - Fix typo
+
+ Change 372 on 2000/03/07 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.07
+
+ Change 371 on 2000/03/06 by <gbarr@pobox.com> (Graham Barr)
+
+ - Moved FAQ to Net/libnetFAQ.pod
+
+ Change 370 on 2000/03/06 by <gbarr@pobox.com> (Graham Barr)
+
+ - Added mput and mget examples
+
+ Change 369 on 2000/03/06 by <gbarr@pobox.com> (Graham Barr)
+
+ - Added support for the xwho command in qpage, but no docs yet.
+
+ Change 368 on 2000/03/06 by <gbarr@pobox.com> (Graham Barr)
+
+ new Configure script
+
+ Change 367 on 2000/03/06 by <gbarr@pobox.com> (Graham Barr)
+
+ Local-ize $SIG{__DIE__}
+
+ Change 361 on 2000/02/17 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Fix arg count check in cwd()
+
+ Change 351 on 2000/01/31 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Cmd
+ - Fixed bug in getline returning an empty line
+ - Added optional filehandle argument to read_until_dot.
+
+ Net::POP3
+ - get now takes an optional filehandle argument, if given the
+ message is sent to the handle.
+
+ Change 348 on 2000/01/17 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Cmd
+ - fix getline not to drop blank lines
+
+ Change 347 on 2000/01/12 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Time
+ - Fix use of uninitialized warning caused by _socket
+
+ Change 346 on 2000/01/11 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Change firewall code to use Net::Config->requires_firewall
+
+ Net::Config
+ - renamed is_external to be requires_firewall
+
+ Change 345 on 2000/01/06 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Added workaround for a Y2K bug that exists with the MDTM
+ command on some servers.
+
+ Change 341 on 1999/09/29 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP, Net::FTP::A, Net::FTP::I, Net::FTP::datacon
+ - Added BlockSize option to control size of blocks read from server
+ (defaults to 10K)
+
+ Change 340 on 1999/09/28 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP, Configure
+ - First attempt to add multiple firewall type support
+
+ Change 339 on 1999/09/28 by <gbarr@pobox.com> (Graham Barr)
+
+ Added ppd info to Makefile.PL and libnet.ppd to MANIFEST
+
+ Change 333 on 1999/09/18 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.0607
+
+ Change 332 on 1999/09/18 by <gbarr@pobox.com> (Graham Barr)
+
+ Configure
+ - Fix typo
+
+ Change 331 on 1999/09/18 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - get and put now accept *FD as well as \*FD for the local filehandle
+
+ Change 330 on 1999/09/18 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Domain
+ - Added support for VMS as suggest by lane@DUPHY4.Physics.Drexel.Edu
+
+ Change 329 on 1999/09/18 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Netrc
+ - Added support for spaces in passwords
+
+ Change 328 on 1999/09/18 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Cmd
+ - Map \n's in commands to " "
+
+ Change 327 on 1999/09/18 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Netrc
+ - Applied patch from Randy Merrell to fix / escaping
+
+ Change 318 on 1999/08/06 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Cmd
+ - Remove use of defined(@ISA)
+
+ Change 316 on 1999/07/11 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::POP3
+ - Added ping method supplied by William Rolston <rolston@freerealtime.com>
+
+ Change 309 on 1999/05/05 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Check that writes to local file succeed
+
+ Change 308 on 1999/05/05 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Fix bug ->size when SIZE and STAT are not implemented
+
+ Change 307 on 1999/05/05 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::POP3
+ - The return value for apop is now the same as login
+
+ Change 306 on 1999/05/05 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::POP3
+ - login now returns "0E0" when there are no messages on te server.
+ This is true in a boolean context, but zero in a numeric context
+
+ Change 305 on 1999/05/05 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP::A
+ - Fixed bug when sending a file in ascii mode that already contains
+ \r\n character sequences
+ - Made improvements to speed of \r\n <-> \n translation
+
+ Change 304 on 1999/05/04 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Added hash mark printing
+
+ Change 264 on 1999/03/17 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::TFTP
+ - Fix typo in CLOSE()
+
+ Change 262 on 1999/03/16 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - new should only call authorize if there is user/passwd data
+
+ Net::SMTP
+ - Allow ->to to ignore bad addresses
+
+ Change 254 on 1999/02/24 by <gbarr@pobox.com> (Graham Barr)
+
+ Added some debug to t/ftp.t to help understand failure
+
+ Change 253 on 1999/02/17 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Cmd
+ - Added checks for a closed connection
+
+ Change 252 on 1999/02/17 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Domain
+ - set FQDN = IP if host does not have a name
+
+ Change 248 on 1999/02/05 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Domain
+ - check for defined(&main::SYS_gethostname) before calling syscall
+ as user may have a UNIVERSAL::AUTOLOADER defined
+
+ Change 245 on 1999/01/18 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Modify mkdir to call ->cwd(), not ->cd()
+
+ Change 206 on 1998/10/20 by <gbarr@pobox.com> (Graham Barr)
+
+ Fix typo in Net::Cmd
+
+ Change 204 on 1998/10/18 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::SMTP
+ - DESTROY now does nothing, so any half-sent message should be aborted
+
+ Change 198 on 1998/10/15 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Config added
+
+ Configure, Makefile.PL
+ - Canges to handle new Net::Config module
+
+ Change 197 on 1998/10/15 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Fixed return vlue of _ACCT
+
+ Net::Cmd
+ - Fixed datasend to ensure all data is sent
+ - Fixed a || bug in getline
+
+ Some FAQ updates
+
+ Change 196 on 1998/10/15 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::TFTP
+ - Initial public release
+
+ Change 195 on 1998/10/04 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Fixed bad use of ||= in cwd()
+
+ Net::POP3
+ - Fixed pattern for -ERR (had +ERR)
+
+ Change 191 on 1998/09/26 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::POP3
+ - Fix bug in UIDL
+
+ Change 187 on 1998/09/01 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::TFTP
+ - Some cleanup of the code
+ - removed leading - from named args
+
+ Change 185 on 1998/08/23 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::TFTP
+ - Initial version
+
+ Change 184 on 1998/08/23 by <gbarr@pobox.com> (Graham Barr)
+
+ Remove mention of Net::SNMP from README
+
+ Change 183 on 1998/08/06 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Domain
+ - Fix problem with returning last name instead of first name for a
+ win32 multi-homed machine
+
+ Change 182 on 1998/08/06 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - _list_cmd returned (undef) instead of ()
+ - Fix typo in docs
+
+ Net::NNTP
+ - Fix typo in docs
+
+ Change 181 on 1998/08/04 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Allow spaces in filenames (ick!)
+
+ Change 179 on 1998/08/04 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - added new rmdir from Dunkin Software
+ - fix to the code generating the listen port
+
+ Change 171 on 1998/07/08 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - login will now send ACCT if $acct is defined and the PASS
+ command completed with 2xx or 3xx
+ - Added a check for the close of the dataconn in _store_cmd
+ - Debug trace will hide any parameter given to ACCT
+
+ Change 167 on 1998/07/04 by <gbarr@pobox.com> (Graham Barr)
+
+ - Added Config.eg, an example Config.pm
+ - Removed set method from Net::Config
+ - Removed check for Data::Dumper from Makefile.PL
+
+ Change 157 on 1998/06/19 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Another small tweak to ->supported()
+
+ Change 156 on 1998/06/18 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Tweak to ->supported() to better detect reports from some
+ servers (NcFTPd)
+
+ Change 153 on 1998/06/16 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Fix "Use of uninitialized" warning, patch from
+ Lars Thegler <lth@dannet.dk>
+
+ Change 148 on 1998/06/07 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::SMTP
+ - Fix typo
+
+ Change 147 on 1998/06/07 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::SMTP
+ - Added ->supports()
+ - Added ->etrn()
+
+ Updated FAQ
+
+ Change 141 on 1998/05/24 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::SMTP
+ - Added banner() method
+
+ Change 132 on 1998/04/18 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::POP3
+ - Added ResvPort option to new()
+
+ Change 131 on 1998/04/18 by <gbarr@pobox.com> (Graham Barr)
+
+ Makefile.PL
+ - Patch for running $^X Configure under VMS
+
+ Change 130 on 1998/04/18 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP, Net::POP3
+ - wrapped getpwuid in eval {} as some OSs (eg NT) do not support it
+
+ Change 129 on 1998/04/18 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Enhanced ->size() to try different approaces if SIZE is
+ not implemented
+
+ Change 128 on 1998/04/15 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Time
+ - Correct number of seconds in a year
+
+ Change 126 on 1998/04/06 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP, Net::FTP::A, Net::FTP::I, Net::Cmd
+ - changes for undef checking on sysread/syswrite
+
+ Change 118 on 1998/02/23 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Added site method
+
+ Change 117 on 1998/02/23 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::POP3
+ - Remove use of map in a void context
+
+ Change 116 on 1998/02/21 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Changes to mkdir for recursive creates.
+
+ Change 114 on 1998/02/20 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Domain
+ - Change $SIG{__DIE__} to $SIG{'__DIE__'} to stop warning in 5.003
+
+ Change 113 on 1998/02/17 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP::A
+ - modified regexp in write for converting to CRLF, should now work with MacOS
+
+ Net::FTP
+ - Added use of File::Basename
+ - Small tweak to abort()
+
+ Net::Time
+ - Changed inet_time to handle MacOS
+
+ Net::Netrc
+ - Fixes for MacOS
+
+ Net::Domain
+ - Fixes for MacOS
+
+ Net::SMTP
+ - Fix for new() to fail if HELO command fails
+
+ Change 108 on 1998/02/14 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Added check for filenames with spaces, \r or \n
+
+ Change 107 on 1998/02/06 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Ensure dataconn object is in reading mode for data transfers
+
+ Change 101 on 1998/01/22 by <gbarr@pobox.com> (Graham Barr)
+
+ Renamed FAQ.pod as FAQ
+
+ Change 100 on 1998/01/22 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::NNTP
+ - Added Reader option to new()
+
+ Change 99 on 1998/01/22 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::POP3
+ - fix pass() to call popstat() if pattern does not match for
+ message count
+
+ Change 98 on 1998/01/22 by <gbarr@pobox.com> (Graham Barr)
+
+ Restore changes lost in disk-crash
+
+ *** Patch 1.0605
+
+ Sun Dec 21 1997 <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Fix for pasv_xfer, previous version hung if an error occured
+ while setting up the link between the two servers.
+
+ Sun Dec 14 1997 <gbarr@pobox.com> (Graham Barr)
+
+ Net::Domain
+ - Fix for 'Use of uninitialized' when setting $SIG{__DIE__}
+
+ Sat Dec 13 1997 <gbarr@pobox.com> (Graham Barr)
+
+ Net::Domain, Net::Netrc
+ - patches from Nick Ing-Simmons for MSWin32
+
+ *** Patch 1.0604
+
+ Thu Dec 11 1997 <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Removed use of AutoLoader, it was causing problems on
+ some platforms
+
+ Change 92 on 1997/12/08 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Fix to pasv_xfer, the command stream on the source side was left
+ out of sync.
+
+ Change 91 on 1997/12/04 by <gbarr@pobox.com> (Graham Barr)
+
+ MANIFEST, FAQ.pod
+ - Added initial FAQ document
+
+ Change 90 on 1997/12/04 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Set $@ if ->new() fails
+
+ Change 82 on 1997/11/30 by <gbarr@pobox.com> (Graham Barr)
+
+ x
+
+ Change 79 on 1997/11/30 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Cmd
+ - Fix for read_until_dot entering an endless loop, now returns undef
+
+ Net::POP3
+ - Fix ->list() and ->uidl() to handle undef being returned from
+ ->read_until_dot()
+
+ Change 78 on 1997/11/30 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Fix to login() and authorize() for OS/2 which does not
+ support getpw*()
+
+ Change 65 on 1997/11/28 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Domain
+ - If user has defined $SIG{__DIE__} then failures inside eval
+ still call it. local-ized $SIG{__DIE__} to stop this as Net::Domain
+ used eval to hide such errors.
+
+ Change 64 on 1997/11/28 by <gbarr@pobox.com> (Graham Barr)
+
+ t/nntp.t
+ - Now exits passing if commands fail due to not having
+ authorization.
+
+ Change 61 on 1997/11/25 by <gbarr@pobox.com> (Graham Barr)
+
+ none
+
+ Change 60 on 1997/11/25 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP::I
+ - Fix to prevent ABOR being sent when xfer is complete
+ - Change to write() to ensure whole packet is sent
+
+ Net::FTP
+ - Moved $TELNET_ vars to top of file so that autosplit does not place them
+ in the wrong file and cause "Use of undefined ...."
+ - Clarification on the result from ->size() added to docs.
+ - pasv_xfer changed to use stor as stou is not a "MUST-have" command
+ - added pasv_xfer_unique
+
+ Net::PH
+ - Documentation updates.
+
+ t/nntp.t
+ - Modified to test for a list of groups
+
+ Change 58 on 1997/11/17 by <gbarr@pobox.com> (Graham Barr)
+
+ t/nntp.t
+ - Modified to check for more groups before failure
+
+ Change 56 on 1997/11/17 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::SMTP
+ - Corrected documentation for ->expand()
+
+ Change 54 on 1997/11/17 by <gbarr@pobox.com> (Graham Barr)
+
+ Makefile.PL
+ - change to code for creating Net::Config
+
+ Net::FTP::A
+ - Change to write() to ensure whole packet is sent
+ - Documentation correction to dir() and ls()
+
+ Net::FTP::dataconn
+ - Stop abort be called when a write socket is being closed.
+
+ Net::NNTP
+ - Changes to postok logic
+
+ Net::PH
+ - fields() now also returns a reference to an ordered array of tag names
+ if called in an array context.
+
+ Net::Cmd
+ - Catch added for SIGPIPE while in ->command()
+
+ Change 43 on 1997/11/05 by <gbarr@pobox.com> (Graham Barr)
+
+ rename files
+
+ Change 39 on 1997/11/04 by <gbarr@pobox.com> (Graham Barr)
+
+ Configure
+ - Fix croak problem
+
+ Change 38 on 1997/11/04 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP, Net::NNTP, Net::PH, Net::POP3, Net::SMTP, Net::SNPP
+ - Fix error cause by calling close method when "unexpected EOF:
+ has been encountered.
+
+ t/require.t
+ - Remove Net::Telnet test
+
+ Change 37 on 1997/10/31 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.06
+
+ Change 36 on 1997/10/31 by <gbarr@pobox.com> (Graham Barr)
+
+ none
+
+ Change 35 on 1997/10/31 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Fixed undef warning in login() when $ruser does not exist in .netrc
+
+ Change 34 on 1997/10/31 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Added new supported() method
+
+ Change 33 on 1997/10/31 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - DESTORY now sends quit command
+ - corrected OOB commands sent prior to an abort command
+ - close will call abort unless eof seen
+ - documentation updates
+
+ Net::FTP::datacon
+ - abort() will read a byte if non have been read
+
+ Net::FTP::A
+ - read was using arg#3 as an offset ?? change to use as timeout, this
+ now matches Net::FTP::I::read and the docs
+ - speedup to read()
+
+ Change 18 on 1997/10/03 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.17
+
+ Change 15 on 1997/09/26 by <gbarr@pobox.com> (Graham Barr)
+
+ Email address and documentation changes
+
+ Change 14 on 1997/09/26 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Added account method so ACCT command can be sent independantly
+ of ->login()
+ - Fixed a bug which caused an infinite loop if EOF happend on the
+ command channel while executing code to work around MS FTP
+ servers
+
+ Net::Cmd
+ - Fixed undefined warning when an unexpected EOF is encountered
+
+ Net::NNTP
+ - Added a call to ->reader() from within ->new(), just in case we are
+ talking to an INN server, but we have transfer rights. This will
+ ensure we are talking to nnrpd.
+
+ Net::SNPP
+ - Fixed a bug in ->new() while locating default host
+
+ Change 13 on 1997/09/26 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Modified code which determined whether to connect via a Firewall.
+ if the Firewall wall option is passed then it will be used,
+ reguardless of whether the real machine can be reached.
+ - The Firewall option to new is now used in preference over
+ the FTP_FIREWALL environment variable.
+
+ Change 12 on 1997/09/26 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::Cmd
+ - modified ->response() to return CMD_ERROR if ->getline() returns
+ undef
+
+ Change 6 on 1997/09/14 by <gbarr@pobox.com> (Graham Barr)
+
+ Small tweak to Makefile,PL to remove requirement for Data::Dumper
+
+ Change 3 on 1997/09/12 by <gbarr@pobox.com> (Graham Barr)
+
+ Makefile.PL
+ - Local config file libnet.cfg installed as Net::Config
+
+ Change 2 on 1997/09/12 by <gbarr@pobox.com> (Graham Barr)
+
+ Net::FTP
+ - Modified to use AutoLoader
+ - Fixed Net::FTP::[AI]::write to trap SIGPIPE errors
+ and return an error, instead of aborting the script
+
+ Change 1 on 1997/09/12 by <gbarr@pobox.com> (Graham Barr)
+
+ A new beginning
+
diff -c /dev/null 'perl-5.7.2/lib/Net/Cmd.pm'
Index: ./lib/Net/Cmd.pm
*** ./lib/Net/Cmd.pm Thu Jan 1 02:00:00 1970
--- ./lib/Net/Cmd.pm Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,591 ----
+ # Net::Cmd.pm
+ #
+ # Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ # This program is free software; you can redistribute it and/or
+ # modify it under the same terms as Perl itself.
+
+ package Net::Cmd;
+
+ require 5.001;
+ require Exporter;
+
+ use strict;
+ use vars qw(@ISA @EXPORT $VERSION);
+ use Carp;
+
+ $VERSION = "2.18";
+ @ISA = qw(Exporter);
+ @EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
+
+ sub CMD_INFO { 1 }
+ sub CMD_OK { 2 }
+ sub CMD_MORE { 3 }
+ sub CMD_REJECT { 4 }
+ sub CMD_ERROR { 5 }
+ sub CMD_PENDING { 0 }
+
+ my %debug = ();
+
+ sub _print_isa
+ {
+ no strict qw(refs);
+
+ my $pkg = shift;
+ my $cmd = $pkg;
+
+ $debug{$pkg} ||= 0;
+
+ my %done = ();
+ my @do = ($pkg);
+ my %spc = ( $pkg , "");
+
+ print STDERR "\n";
+ while ($pkg = shift @do)
+ {
+ next if defined $done{$pkg};
+
+ $done{$pkg} = 1;
+
+ my $v = defined ${"${pkg}::VERSION"}
+ ? "(" . ${"${pkg}::VERSION"} . ")"
+ : "";
+
+ my $spc = $spc{$pkg};
+ print STDERR "$cmd: ${spc}${pkg}${v}\n";
+
+ if(@{"${pkg}::ISA"})
+ {
+ @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"};
+ unshift(@do, @{"${pkg}::ISA"});
+ }
+ }
+
+ print STDERR "\n";
+ }
+
+ sub debug
+ {
+ @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
+
+ my($cmd,$level) = @_;
+ my $pkg = ref($cmd) || $cmd;
+ my $oldval = 0;
+
+ if(ref($cmd))
+ {
+ $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
+ }
+ else
+ {
+ $oldval = $debug{$pkg} || 0;
+ }
+
+ return $oldval
+ unless @_ == 2;
+
+ $level = $debug{$pkg} || 0
+ unless defined $level;
+
+ _print_isa($pkg)
+ if($level && !exists $debug{$pkg});
+
+ if(ref($cmd))
+ {
+ ${*$cmd}{'net_cmd_debug'} = $level;
+ }
+ else
+ {
+ $debug{$pkg} = $level;
+ }
+
+ $oldval;
+ }
+
+ sub message
+ {
+ @_ == 1 or croak 'usage: $obj->message()';
+
+ my $cmd = shift;
+
+ wantarray ? @{${*$cmd}{'net_cmd_resp'}}
+ : join("", @{${*$cmd}{'net_cmd_resp'}});
+ }
+
+ sub debug_text { $_[2] }
+
+ sub debug_print
+ {
+ my($cmd,$out,$text) = @_;
+ print STDERR $cmd,($out ? '>>> ' : '<<< '), $cmd->debug_text($out,$text);
+ }
+
+ sub code
+ {
+ @_ == 1 or croak 'usage: $obj->code()';
+
+ my $cmd = shift;
+
+ ${*$cmd}{'net_cmd_code'} = "000"
+ unless exists ${*$cmd}{'net_cmd_code'};
+
+ ${*$cmd}{'net_cmd_code'};
+ }
+
+ sub status
+ {
+ @_ == 1 or croak 'usage: $obj->status()';
+
+ my $cmd = shift;
+
+ substr(${*$cmd}{'net_cmd_code'},0,1);
+ }
+
+ sub set_status
+ {
+ @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';
+
+ my $cmd = shift;
+ my($code,$resp) = @_;
+
+ $resp = [ $resp ]
+ unless ref($resp);
+
+ (${*$cmd}{'net_cmd_code'},${*$cmd}{'net_cmd_resp'}) = ($code, $resp);
+
+ 1;
+ }
+
+ sub command
+ {
+ my $cmd = shift;
+
+ return $cmd unless defined fileno($cmd);
+
+ $cmd->dataend()
+ if(exists ${*$cmd}{'net_cmd_lastch'});
+
+ if (scalar(@_))
+ {
+ local $SIG{PIPE} = 'IGNORE';
+
+ my $str = join(" ", map { /\n/ ? do { my $n = $_; $n =~ tr/\n/ /; $n } : $_; } @_) . "\015\012";
+ my $len = length $str;
+ my $swlen;
+
+ $cmd->close
+ unless (defined($swlen = syswrite($cmd,$str,$len)) && $swlen == $len);
+
+ $cmd->debug_print(1,$str)
+ if($cmd->debug);
+
+ ${*$cmd}{'net_cmd_resp'} = []; # the response
+ ${*$cmd}{'net_cmd_code'} = "000"; # Made this one up :-)
+ }
+
+ $cmd;
+ }
+
+ sub ok
+ {
+ @_ == 1 or croak 'usage: $obj->ok()';
+
+ my $code = $_[0]->code;
+ 0 < $code && $code < 400;
+ }
+
+ sub unsupported
+ {
+ my $cmd = shift;
+
+ ${*$cmd}{'net_cmd_resp'} = [ 'Unsupported command' ];
+ ${*$cmd}{'net_cmd_code'} = 580;
+ 0;
+ }
+
+ sub getline
+ {
+ my $cmd = shift;
+
+ ${*$cmd}{'net_cmd_lines'} ||= [];
+
+ return shift @{${*$cmd}{'net_cmd_lines'}}
+ if scalar(@{${*$cmd}{'net_cmd_lines'}});
+
+ my $partial = defined(${*$cmd}{'net_cmd_partial'})
+ ? ${*$cmd}{'net_cmd_partial'} : "";
+ my $fd = fileno($cmd);
+
+ return undef
+ unless defined $fd;
+
+ my $rin = "";
+ vec($rin,$fd,1) = 1;
+
+ my $buf;
+
+ until(scalar(@{${*$cmd}{'net_cmd_lines'}}))
+ {
+ my $timeout = $cmd->timeout || undef;
+ my $rout;
+ if (select($rout=$rin, undef, undef, $timeout))
+ {
+ unless (sysread($cmd, $buf="", 1024))
+ {
+ carp(ref($cmd) . ": Unexpected EOF on command channel")
+ if $cmd->debug;
+ $cmd->close;
+ return undef;
+ }
+
+ substr($buf,0,0) = $partial; ## prepend from last sysread
+
+ my @buf = split(/\015?\012/, $buf, -1); ## break into lines
+
+ $partial = pop @buf;
+
+ push(@{${*$cmd}{'net_cmd_lines'}}, map { "$_\n" } @buf);
+
+ }
+ else
+ {
+ carp("$cmd: Timeout") if($cmd->debug);
+ return undef;
+ }
+ }
+
+ ${*$cmd}{'net_cmd_partial'} = $partial;
+
+ shift @{${*$cmd}{'net_cmd_lines'}};
+ }
+
+ sub ungetline
+ {
+ my($cmd,$str) = @_;
+
+ ${*$cmd}{'net_cmd_lines'} ||= [];
+ unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
+ }
+
+ sub parse_response
+ {
+ return ()
+ unless $_[1] =~ s/^(\d\d\d)(.?)//o;
+ ($1, $2 eq "-");
+ }
+
+ sub response
+ {
+ my $cmd = shift;
+ my($code,$more) = (undef) x 2;
+
+ ${*$cmd}{'net_cmd_resp'} ||= [];
+
+ while(1)
+ {
+ my $str = $cmd->getline();
+
+ return CMD_ERROR
+ unless defined($str);
+
+ $cmd->debug_print(0,$str)
+ if ($cmd->debug);
+
+ ($code,$more) = $cmd->parse_response($str);
+ unless(defined $code)
+ {
+ $cmd->ungetline($str);
+ last;
+ }
+
+ ${*$cmd}{'net_cmd_code'} = $code;
+
+ push(@{${*$cmd}{'net_cmd_resp'}},$str);
+
+ last unless($more);
+ }
+
+ substr($code,0,1);
+ }
+
+ sub read_until_dot
+ {
+ my $cmd = shift;
+ my $fh = shift;
+ my $arr = [];
+
+ while(1)
+ {
+ my $str = $cmd->getline() or return undef;
+
+ $cmd->debug_print(0,$str)
+ if ($cmd->debug & 4);
+
+ last if($str =~ /^\.\r?\n/o);
+
+ $str =~ s/^\.\././o;
+
+ if (defined $fh)
+ {
+ print $fh $str;
+ }
+ else
+ {
+ push(@$arr,$str);
+ }
+ }
+
+ $arr;
+ }
+
+ sub datasend
+ {
+ my $cmd = shift;
+ my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
+ my $line = join("" ,@$arr);
+
+ return 0 unless defined(fileno($cmd));
+
+ return 1
+ unless length($line);
+
+ if($cmd->debug)
+ {
+ my $b = "$cmd>>> ";
+ print STDERR $b,join("\n$b",split(/\n/,$line)),"\n";
+ }
+
+ $line =~ s/\n/\015\012/sgo;
+
+ ${*$cmd}{'net_cmd_lastch'} ||= " ";
+ $line = ${*$cmd}{'net_cmd_lastch'} . $line;
+
+ $line =~ s/(\012\.)/$1./sog;
+
+ ${*$cmd}{'net_cmd_lastch'} = substr($line,-1,1);
+
+ my $len = length($line) - 1;
+ my $offset = 1;
+ my $win = "";
+ vec($win,fileno($cmd),1) = 1;
+ my $timeout = $cmd->timeout || undef;
+
+ while($len)
+ {
+ my $wout;
+ if (select(undef,$wout=$win, undef, $timeout) > 0)
+ {
+ my $w = syswrite($cmd, $line, $len, $offset);
+ unless (defined($w))
+ {
+ carp("$cmd: $!") if $cmd->debug;
+ return undef;
+ }
+ $len -= $w;
+ $offset += $w;
+ }
+ else
+ {
+ carp("$cmd: Timeout") if($cmd->debug);
+ return undef;
+ }
+ }
+
+ 1;
+ }
+
+ sub dataend
+ {
+ my $cmd = shift;
+
+ return 0 unless defined(fileno($cmd));
+
+ return 1
+ unless(exists ${*$cmd}{'net_cmd_lastch'});
+
+ if(${*$cmd}{'net_cmd_lastch'} eq "\015")
+ {
+ syswrite($cmd,"\012",1);
+ print STDERR "\n"
+ if($cmd->debug);
+ }
+ elsif(${*$cmd}{'net_cmd_lastch'} ne "\012")
+ {
+ syswrite($cmd,"\015\012",2);
+ print STDERR "\n"
+ if($cmd->debug);
+ }
+
+ print STDERR "$cmd>>> .\n"
+ if($cmd->debug);
+
+ syswrite($cmd,".\015\012",3);
+
+ delete ${*$cmd}{'net_cmd_lastch'};
+
+ $cmd->response() == CMD_OK;
+ }
+
+ 1;
+
+ __END__
+
+
+ =head1 NAME
+
+ Net::Cmd - Network Command class (as used by FTP, SMTP etc)
+
+ =head1 SYNOPSIS
+
+ use Net::Cmd;
+
+ @ISA = qw(Net::Cmd);
+
+ =head1 DESCRIPTION
+
+ C<Net::Cmd> is a collection of methods that can be inherited by a sub class
+ of C<IO::Handle>. These methods implement the functionality required for a
+ command based protocol, for example FTP and SMTP.
+
+ =head1 USER METHODS
+
+ These methods provide a user interface to the C<Net::Cmd> object.
+
+ =over 4
+
+ =item debug ( VALUE )
+
+ Set the level of debug information for this object. If C<VALUE> is not given
+ then the current state is returned. Otherwise the state is changed to
+ C<VALUE> and the previous state returned.
+
+ Set the level of debug information for this object. If no argument is
+ given then the current state is returned. Otherwise the state is
+ changed to C<$value>and the previous state returned. Different packages
+ may implement different levels of debug but, a non-zero value result in
+ copies of all commands and responses also being sent to STDERR.
+
+ If C<VALUE> is C<undef> then the debug level will be set to the default
+ debug level for the class.
+
+ This method can also be called as a I<static> method to set/get the default
+ debug level for a given class.
+
+ =item message ()
+
+ Returns the text message returned from the last command
+
+ =item code ()
+
+ Returns the 3-digit code from the last command. If a command is pending
+ then the value 0 is returned
+
+ =item ok ()
+
+ Returns non-zero if the last code value was greater than zero and
+ less than 400. This holds true for most command servers. Servers
+ where this does not hold may override this method.
+
+ =item status ()
+
+ Returns the most significant digit of the current status code. If a command
+ is pending then C<CMD_PENDING> is returned.
+
+ =item datasend ( DATA )
+
+ Send data to the remote server, converting LF to CRLF. Any line starting
+ with a '.' will be prefixed with another '.'.
+ C<DATA> may be an array or a reference to an array.
+
+ =item dataend ()
+
+ End the sending of data to the remote server. This is done by ensuring that
+ the data already sent ends with CRLF then sending '.CRLF' to end the
+ transmission. Once this data has been sent C<dataend> calls C<response> and
+ returns true if C<response> returns CMD_OK.
+
+ =back
+
+ =head1 CLASS METHODS
+
+ These methods are not intended to be called by the user, but used or
+ over-ridden by a sub-class of C<Net::Cmd>
+
+ =over 4
+
+ =item debug_print ( DIR, TEXT )
+
+ Print debugging information. C<DIR> denotes the direction I<true> being
+ data being sent to the server. Calls C<debug_text> before printing to
+ STDERR.
+
+ =item debug_text ( TEXT )
+
+ This method is called to print debugging information. TEXT is
+ the text being sent. The method should return the text to be printed
+
+ This is primarily meant for the use of modules such as FTP where passwords
+ are sent, but we do not want to display them in the debugging information.
+
+ =item command ( CMD [, ARGS, ... ])
+
+ Send a command to the command server. All arguments a first joined with
+ a space character and CRLF is appended, this string is then sent to the
+ command server.
+
+ Returns undef upon failure
+
+ =item unsupported ()
+
+ Sets the status code to 580 and the response text to 'Unsupported command'.
+ Returns zero.
+
+ =item response ()
+
+ Obtain a response from the server. Upon success the most significant digit
+ of the status code is returned. Upon failure, timeout etc., I<undef> is
+ returned.
+
+ =item parse_response ( TEXT )
+
+ This method is called by C<response> as a method with one argument. It should
+ return an array of 2 values, the 3-digit status code and a flag which is true
+ when this is part of a multi-line response and this line is not the list.
+
+ =item getline ()
+
+ Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
+ upon failure.
+
+ B<NOTE>: If you do use this method for any reason, please remember to add
+ some C<debug_print> calls into your method.
+
+ =item ungetline ( TEXT )
+
+ Unget a line of text from the server.
+
+ =item read_until_dot ()
+
+ Read data from the remote server until a line consisting of a single '.'.
+ Any lines starting with '..' will have one of the '.'s removed.
+
+ Returns a reference to a list containing the lines, or I<undef> upon failure.
+
+ =back
+
+ =head1 EXPORTS
+
+ C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
+ C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR> ,correspond to possible results
+ of C<response> and C<status>. The sixth is C<CMD_PENDING>.
+
+ =head1 AUTHOR
+
+ Graham Barr <gbarr@pobox.com>
+
+ =head1 COPYRIGHT
+
+ Copyright (c) 1995-1997 Graham Barr. All rights reserved.
+ This program is free software; you can redistribute it and/or modify
+ it under the same terms as Perl itself.
+
+ =cut
diff -c /dev/null 'perl-5.7.2/lib/Net/Config.eg'
Index: ./lib/Net/Config.eg
*** ./lib/Net/Config.eg Thu Jan 1 02:00:00 1970
--- ./lib/Net/Config.eg Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,49 ----
+ package Net::Config;
+
+ require Exporter;
+ use vars qw(@ISA @EXPORT %NetConfig);
+ use strict;
+
+ @EXPORT = qw(%NetConfig);
+ @ISA = qw(Exporter);
+
+ # WARNING WARNING WARNING WARNING WARNING WARNING WARNING
+ # WARNING WARNING WARNING WARNING WARNING WARNING WARNING
+ #
+ # Below this line is auto-generated, *ANY* changes will be lost
+
+ %NetConfig = (
+ # the followinf parameters are all lists of hosts for the
+ # respective protocols.
+ nntp_hosts => [],
+ snpp_hosts => [],
+ pop3_hosts => [],
+ smtp_hosts => [],
+ ph_hosts => [],
+ daytime_hosts => [],
+ time_hosts => [],
+
+ # your internet domain
+ inet_domain => undef,
+
+ # If you have an ftp proxy firewall (not a http firewall)
+ # then set this to the name of the firewall
+ ftp_firewall => undef,
+
+ # set if all connections done via the firewall should use
+ # passive data connections
+ ftp_ext_passive => 0,
+
+ # set if all connections not done via the firewall should use
+ # passive data connections
+ ftp_int_passive => 0,
+
+ # If set the make test will attempt to connect to the hosts above
+ test_hosts => 0,
+
+ # Used during Configure (which you are not using) to do
+ # DNS lookups to ensure hosts exist
+ test_exist => 0,
+
+ );
+ 1;
diff -c /dev/null 'perl-5.7.2/lib/Net/Config.pm'
Index: ./lib/Net/Config.pm
*** ./lib/Net/Config.pm Thu Jan 1 02:00:00 1970
--- ./lib/Net/Config.pm Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,213 ----
+
+ package Net::Config;
+ # $Id: //depot/libnet/Net/Config.pm#6 $
+
+ require Exporter;
+ use vars qw(@ISA @EXPORT %NetConfig $VERSION $CONFIGURE $LIBNET_CFG);
+ use Socket qw(inet_aton inet_ntoa);
+ use strict;
+
+ @EXPORT = qw(%NetConfig);
+ @ISA = qw(Net::LocalCfg Exporter);
+ $VERSION = "1.04";
+
+ eval { local $SIG{__DIE__}; require Net::LocalCfg };
+
+ %NetConfig = (
+ nntp_hosts => [],
+ snpp_hosts => [],
+ pop3_hosts => [],
+ smtp_hosts => [],
+ ph_hosts => [],
+ daytime_hosts => [],
+ time_hosts => [],
+ inet_domain => undef,
+ ftp_firewall => undef,
+ ftp_ext_passive => 0,
+ ftp_int_passive => 0,
+ test_hosts => 1,
+ test_exist => 1,
+ );
+
+ my $file = __FILE__;
+ my $ref;
+ $file =~ s/Config.pm/libnet.cfg/;
+ if ( -f $file ) {
+ $ref = eval { do $file };
+ if (ref($ref) eq 'HASH') {
+ %NetConfig = (%NetConfig, %{ $ref });
+ $LIBNET_CFG = $file;
+ }
+ }
+ if ($< == $> and !$CONFIGURE) {
+ use File::Spec;
+ my $home = eval { (getpwuid($>))[7] } || $ENV{HOME} || $ENV{HOMEDRIVE} || $ENV{HOMEPATH} || File::Spec->curdir;
+ $file = File::Spec->catfile($home, ".libnetrc");
+ $ref = eval { do $file } if -f $file;
+ %NetConfig = (%NetConfig, %{ $ref })
+ if ref($ref) eq 'HASH';
+ }
+ my ($k,$v);
+ while(($k,$v) = each %NetConfig) {
+ $v = [ $v ]
+ if($k =~ /_hosts$/ && !ref($v));
+ }
+
+ # Take a hostname and determine if it is inside te firewall
+
+ sub requires_firewall {
+ shift; # ignore package
+ my $host = shift;
+
+ return 0 unless defined $NetConfig{'ftp_firewall'};
+
+ $host = inet_aton($host) or return -1;
+ $host = inet_ntoa($host);
+
+ if(exists $NetConfig{'local_netmask'}) {
+ my $quad = unpack("N",pack("C*",split(/\./,$host)));
+ my $list = $NetConfig{'local_netmask'};
+ $list = [$list] unless ref($list);
+ foreach (@$list) {
+ my($net,$bits) = (m#^(\d+\.\d+\.\d+\.\d+)/(\d+)$#) or next;
+ my $mask = ~0 << (32 - $bits);
+ my $addr = unpack("N",pack("C*",split(/\./,$net)));
+
+ return 0 if (($addr & $mask) == ($quad & $mask));
+ }
+ return 1;
+ }
+
+ return 0;
+ }
+
+ use vars qw(*is_external);
+ *is_external = \&requires_firewall;
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ Net::Config - Local configuration data for libnet
+
+ =head1 SYNOPSYS
+
+ use Net::Config qw(%NetConfig);
+
+ =head1 DESCRIPTION
+
+ C<Net::Config> holds configuration data for the modules in the libnet
+ distribuion. During installation you will be asked for these values.
+
+ The configuration data is held globally in a file in the perl installation
+ tree, but a user may override any of these values by providing thier own. This
+ can be done by having a C<.libnetrc> file in thier home directory. This file
+ should return a reference to a HASH containing the keys described below.
+ For example
+
+ # .libnetrc
+ {
+ nntp_hosts => [ "my_prefered_host" ],
+ ph_hosts => [ "my_ph_server" ],
+ }
+ __END__
+
+ =head1 METHODS
+
+ C<Net::Config> defines the following methods. They are methods as they are
+ invoked as class methods. This is because C<Net::Config> inherits from
+ C<Net::LocalCfg> so you can override these methods if you want.
+
+ =over 4
+
+ =item requires_firewall HOST
+
+ Attempts to determine if a given host is outside your firewall. Possible
+ return values are.
+
+ -1 Cannot lookup hostname
+ 0 Host is inside firewall (or there is no ftp_firewall entry)
+ 1 Host is outside the firewall
+
+ This is done by using hostname lookup and the C<local_netmask> entry in
+ the configuration data.
+
+ =back
+
+ =head1 NetConfig VALUES
+
+ =over 4
+
+ =item nntp_hosts
+
+ =item snpp_hosts
+
+ =item pop3_hosts
+
+ =item smtp_hosts
+
+ =item ph_hosts
+
+ =item daytime_hosts
+
+ =item time_hosts
+
+ Each is a reference to an array of hostnames (in order of preference),
+ which should be used for the given protocol
+
+ =item inet_domain
+
+ Your internet domain name
+
+ =item ftp_firewall
+
+ If you have an FTP proxy firewall (B<NOT> a HTTP or SOCKS firewall)
+ then this value should be set to the firewall hostname. If your firewall
+ does not listen to port 21, then this value should be set to
+ C<"hostname:port"> (eg C<"hostname:99">)
+
+ =item ftp_ext_passive
+
+ =item ftp_int_pasive
+
+ FTP servers normally work on a non-passive mode. That is when you want to
+ transfer data you have to tell the server the address and port to
+ connect to.
+
+ With some firewalls this does not work as te server cannot
+ connect to your machine (because you are beind a firewall) and the firewall
+ does not re-write te command. In this case you should set C<ftp_ext_passive>
+ to a I<true> value.
+
+ Some servers are configured to only work in passive mode. If you have
+ one of these you can force C<Net::FTP> to always transfer in passive
+ mode, when not going via a firewall, by cetting C<ftp_int_passive> to
+ a I<true> value.
+
+ =item local_netmask
+
+ A reference to a list of netmask strings in the form C<"134.99.4.0/24">.
+ These are used by the C<requires_firewall> function to determine if a given
+ host is inside or outside your firewall.
+
+ =back
+
+ The following entries are used during installation & testing on the
+ libnet package
+
+ =over 4
+
+ =item test_hosts
+
+ If true them C<make test> may attempt to connect to hosts given in the
+ configuration.
+
+ =item test_exists
+
+ If true the C<Configure> will check each hostname given that it exists
+
+ =back
+
+ =cut
diff -c /dev/null 'perl-5.7.2/lib/Net/Domain.pm'
Index: ./lib/Net/Domain.pm
*** ./lib/Net/Domain.pm Thu Jan 1 02:00:00 1970
--- ./lib/Net/Domain.pm Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,331 ----
+ # Net::Domain.pm
+ #
+ # Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ # This program is free software; you can redistribute it and/or
+ # modify it under the same terms as Perl itself.
+
+ package Net::Domain;
+
+ require Exporter;
+
+ use Carp;
+ use strict;
+ use vars qw($VERSION @ISA @EXPORT_OK);
+ use Net::Config;
+
+ @ISA = qw(Exporter);
+ @EXPORT_OK = qw(hostname hostdomain hostfqdn domainname);
+
+ $VERSION = "2.13"; # $Id: //depot/libnet/Net/Domain.pm#10 $
+
+ my($host,$domain,$fqdn) = (undef,undef,undef);
+
+ # Try every conceivable way to get hostname.
+
+ sub _hostname {
+
+ # we already know it
+ return $host
+ if(defined $host);
+
+ if ($^O eq 'MSWin32' || $^O eq 'cygwin') {
+ require Socket;
+ my ($name,$alias,$type,$len,@addr) = gethostbyname($ENV{'COMPUTERNAME'}||'localhost');
+ while (@addr)
+ {
+ my $a = shift(@addr);
+ $host = gethostbyaddr($a,Socket::AF_INET());
+ last if defined $host;
+ }
+ if (index($host,'.') > 0) {
+ $fqdn = $host;
+ ($host,$domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
+ }
+ return $host;
+ }
+ elsif ($^O eq 'MacOS') {
+ chomp ($host = `hostname`);
+ }
+ elsif ($^O eq 'VMS') { ## multiple varieties of net s/w makes this hard
+ $host = $ENV{'UCX$INET_HOST'} if defined($ENV{'UCX$INET_HOST'});
+ $host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'});
+ if (index($host,'.') > 0) {
+ $fqdn = $host;
+ ($host,$domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
+ }
+ return $host;
+ }
+ else {
+ local $SIG{'__DIE__'};
+
+ # syscall is preferred since it avoids tainting problems
+ eval {
+ my $tmp = "\0" x 256; ## preload scalar
+ eval {
+ package main;
+ require "syscall.ph";
+ defined(&main::SYS_gethostname);
+ }
+ || eval {
+ package main;
+ require "sys/syscall.ph";
+ defined(&main::SYS_gethostname);
+ }
+ and $host = (syscall(&main::SYS_gethostname, $tmp, 256) == 0)
+ ? $tmp
+ : undef;
+ }
+
+ # POSIX
+ || eval {
+ require POSIX;
+ $host = (POSIX::uname())[1];
+ }
+
+ # trusty old hostname command
+ || eval {
+ chop($host = `(hostname) 2>/dev/null`); # BSD'ish
+ }
+
+ # sysV/POSIX uname command (may truncate)
+ || eval {
+ chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish
+ }
+
+ # Apollo pre-SR10
+ || eval {
+ $host = (split(/[:\. ]/,`/com/host`,6))[0];
+ }
+
+ || eval {
+ $host = "";
+ };
+ }
+
+ # remove garbage
+ $host =~ s/[\0\r\n]+//go;
+ $host =~ s/(\A\.+|\.+\Z)//go;
+ $host =~ s/\.\.+/\./go;
+
+ $host;
+ }
+
+ sub _hostdomain {
+
+ # we already know it
+ return $domain
+ if(defined $domain);
+
+ local $SIG{'__DIE__'};
+
+ return $domain = $NetConfig{'inet_domain'}
+ if defined $NetConfig{'inet_domain'};
+
+ # try looking in /etc/resolv.conf
+ # putting this here and assuming that it is correct, eliminates
+ # calls to gethostbyname, and therefore DNS lookups. This helps
+ # those on dialup systems.
+
+ local *RES;
+
+ if(open(RES,"/etc/resolv.conf")) {
+ while(<RES>) {
+ $domain = $1
+ if(/\A\s*(?:domain|search)\s+(\S+)/);
+ }
+ close(RES);
+
+ return $domain
+ if(defined $domain);
+ }
+
+ # just try hostname and system calls
+
+ my $host = _hostname();
+ my(@hosts);
+ local($_);
+
+ @hosts = ($host,"localhost");
+
+ unless($host =~ /\./) {
+ my $dom = undef;
+ eval {
+ my $tmp = "\0" x 256; ## preload scalar
+ eval {
+ package main;
+ require "syscall.ph";
+ }
+ || eval {
+ package main;
+ require "sys/syscall.ph";
+ }
+ and $dom = (syscall(&main::SYS_getdomainname, $tmp, 256) == 0)
+ ? $tmp
+ : undef;
+ };
+
+ chop($dom = `domainname 2>/dev/null`)
+ unless(defined $dom);
+
+ if(defined $dom) {
+ my @h = ();
+ while(length($dom)) {
+ push(@h, "$host.$dom");
+ $dom =~ s/^[^.]+.//;
+ }
+ unshift(@hosts,@h);
+ }
+ }
+
+ # Attempt to locate FQDN
+
+ foreach (@hosts) {
+ my @info = gethostbyname($_);
+
+ next unless @info;
+
+ # look at real name & aliases
+ my $site;
+ foreach $site ($info[0], split(/ /,$info[1])) {
+ if(rindex($site,".") > 0) {
+
+ # Extract domain from FQDN
+
+ ($domain = $site) =~ s/\A[^\.]+\.//;
+ return $domain;
+ }
+ }
+ }
+
+ # Look for environment variable
+
+ $domain ||= $ENV{LOCALDOMAIN} ||= $ENV{DOMAIN} || undef;
+
+ if(defined $domain) {
+ $domain =~ s/[\r\n\0]+//g;
+ $domain =~ s/(\A\.+|\.+\Z)//g;
+ $domain =~ s/\.\.+/\./g;
+ }
+
+ $domain;
+ }
+
+ sub domainname {
+
+ return $fqdn
+ if(defined $fqdn);
+
+ _hostname();
+ _hostdomain();
+
+ # Assumption: If the host name does not contain a period
+ # and the domain name does, then assume that they are correct
+ # this helps to eliminate calls to gethostbyname, and therefore
+ # eleminate DNS lookups
+
+ return $fqdn = $host . "." . $domain
+ if($host !~ /\./ && $domain =~ /\./);
+
+ # For hosts that have no name, just an IP address
+ return $fqdn = $host if $host =~ /^\d+(\.\d+){3}$/;
+
+ my @host = split(/\./, $host);
+ my @domain = split(/\./, $domain);
+ my @fqdn = ();
+
+ # Determine from @host & @domain the FQDN
+
+ my @d = @domain;
+
+ LOOP:
+ while(1) {
+ my @h = @host;
+ while(@h) {
+ my $tmp = join(".",@h,@d);
+ if((gethostbyname($tmp))[0]) {
+ @fqdn = (@h,@d);
+ $fqdn = $tmp;
+ last LOOP;
+ }
+ pop @h;
+ }
+ last unless shift @d;
+ }
+
+ if(@fqdn) {
+ $host = shift @fqdn;
+ until((gethostbyname($host))[0]) {
+ $host .= "." . shift @fqdn;
+ }
+ $domain = join(".", @fqdn);
+ }
+ else {
+ undef $host;
+ undef $domain;
+ undef $fqdn;
+ }
+
+ $fqdn;
+ }
+
+ sub hostfqdn { domainname() }
+
+ sub hostname {
+ domainname()
+ unless(defined $host);
+ return $host;
+ }
+
+ sub hostdomain {
+ domainname()
+ unless(defined $domain);
+ return $domain;
+ }
+
+ 1; # Keep require happy
+
+ __END__
+
+ =head1 NAME
+
+ Net::Domain - Attempt to evaluate the current host's internet name and domain
+
+ =head1 SYNOPSIS
+
+ use Net::Domain qw(hostname hostfqdn hostdomain);
+
+ =head1 DESCRIPTION
+
+ Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
+ of the current host. From this determine the host-name and the host-domain.
+
+ Each of the functions will return I<undef> if the FQDN cannot be determined.
+
+ =over 4
+
+ =item hostfqdn ()
+
+ Identify and return the FQDN of the current host.
+
+ =item hostname ()
+
+ Returns the smallest part of the FQDN which can be used to identify the host.
+
+ =item hostdomain ()
+
+ Returns the remainder of the FQDN after the I<hostname> has been removed.
+
+ =back
+
+ =head1 AUTHOR
+
+ Graham Barr <gbarr@pobox.com>.
+ Adapted from Sys::Hostname by David Sundstrom <sunds@asictest.sc.ti.com>
+
+ =head1 COPYRIGHT
+
+ Copyright (c) 1995-1998 Graham Barr. All rights reserved.
+ This program is free software; you can redistribute it and/or modify
+ it under the same terms as Perl itself.
+
+ =cut
diff -c /dev/null 'perl-5.7.2/lib/Net/FTP.pm'
Index: ./lib/Net/FTP.pm
*** ./lib/Net/FTP.pm Thu Jan 1 02:00:00 1970
--- ./lib/Net/FTP.pm Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,1643 ----
+ # Net::FTP.pm
+ #
+ # Copyright (c) 1995-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ # This program is free software; you can redistribute it and/or
+ # modify it under the same terms as Perl itself.
+ #
+ # Documentation (at end) improved 1996 by Nathan Torkington <gnat@frii.com>.
+
+ package Net::FTP;
+
+ require 5.001;
+
+ use strict;
+ use vars qw(@ISA $VERSION);
+ use Carp;
+
+ use Socket 1.3;
+ use IO::Socket;
+ use Time::Local;
+ use Net::Cmd;
+ use Net::Config;
+ # use AutoLoader qw(AUTOLOAD);
+
+ $VERSION = "2.56"; # $Id:$
+ @ISA = qw(Exporter Net::Cmd IO::Socket::INET);
+
+ # Someday I will "use constant", when I am not bothered to much about
+ # compatability with older releases of perl
+
+ use vars qw($TELNET_IAC $TELNET_IP $TELNET_DM);
+ ($TELNET_IAC,$TELNET_IP,$TELNET_DM) = (255,244,242);
+
+ # Name is too long for AutoLoad, it clashes with pasv_xfer
+ sub pasv_xfer_unique {
+ my($sftp,$sfile,$dftp,$dfile) = @_;
+ $sftp->pasv_xfer($sfile,$dftp,$dfile,1);
+ }
+
+ 1;
+ # Having problems with AutoLoader
+ #__END__
+
+ sub new
+ {
+ my $pkg = shift;
+ my $peer = shift;
+ my %arg = @_;
+
+ my $host = $peer;
+ my $fire = undef;
+
+ if(exists($arg{Firewall}) || Net::Config->requires_firewall($peer))
+ {
+ $fire = $arg{Firewall}
+ || $ENV{FTP_FIREWALL}
+ || $NetConfig{ftp_firewall}
+ || undef;
+
+ if(defined $fire)
+ {
+ $peer = $fire;
+ delete $arg{Port};
+ }
+ }
+
+ my $ftp = $pkg->SUPER::new(PeerAddr => $peer,
+ PeerPort => $arg{Port} || 'ftp(21)',
+ Proto => 'tcp',
+ Timeout => defined $arg{Timeout}
+ ? $arg{Timeout}
+ : 120
+ ) or return undef;
+
+ ${*$ftp}{'net_ftp_host'} = $host; # Remote hostname
+ ${*$ftp}{'net_ftp_type'} = 'A'; # ASCII/binary/etc mode
+ ${*$ftp}{'net_ftp_blksize'} = abs($arg{'BlockSize'} || 10240);
+
+ ${*$ftp}{'net_ftp_firewall'} = $fire
+ if(defined $fire);
+
+ ${*$ftp}{'net_ftp_passive'} = int
+ exists $arg{Passive}
+ ? $arg{Passive}
+ : exists $ENV{FTP_PASSIVE}
+ ? $ENV{FTP_PASSIVE}
+ : defined $fire
+ ? $NetConfig{ftp_ext_passive}
+ : $NetConfig{ftp_int_passive}; # Whew! :-)
+
+ $ftp->hash(exists $arg{Hash} ? $arg{Hash} : 0, 1024);
+
+ $ftp->autoflush(1);
+
+ $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+
+ unless ($ftp->response() == CMD_OK)
+ {
+ $ftp->close();
+ $@ = $ftp->message;
+ undef $ftp;
+ }
+
+ $ftp;
+ }
+
+ ##
+ ## User interface methods
+ ##
+
+ sub hash {
+ my $ftp = shift; # self
+ my $prev = ${*$ftp}{'net_ftp_hash'} || [\*STDERR, 0];
+
+ unless(@_) {
+ return $prev;
+ }
+ my($h,$b) = @_;
+ if(@_ == 1) {
+ unless($h) {
+ delete ${*$ftp}{'net_ftp_hash'};
+ return $prev;
+ }
+ elsif(ref($h)) {
+ $b = 1024;
+ }
+ else {
+ ($h,$b) = (\*STDERR,$h);
+ }
+ }
+ select((select($h), $|=1)[0]);
+ $b = 512 if $b < 512;
+ ${*$ftp}{'net_ftp_hash'} = [$h, $b];
+ $prev;
+ }
+
+ sub quit
+ {
+ my $ftp = shift;
+
+ $ftp->_QUIT;
+ $ftp->close;
+ }
+
+ sub DESTROY
+ {
+ my $ftp = shift;
+ defined(fileno($ftp)) && $ftp->quit
+ }
+
+ sub ascii { shift->type('A',@_); }
+ sub binary { shift->type('I',@_); }
+
+ sub ebcdic
+ {
+ carp "TYPE E is unsupported, shall default to I";
+ shift->type('E',@_);
+ }
+
+ sub byte
+ {
+ carp "TYPE L is unsupported, shall default to I";
+ shift->type('L',@_);
+ }
+
+ # Allow the user to send a command directly, BE CAREFUL !!
+
+ sub quot
+ {
+ my $ftp = shift;
+ my $cmd = shift;
+
+ $ftp->command( uc $cmd, @_);
+ $ftp->response();
+ }
+
+ sub site
+ {
+ my $ftp = shift;
+
+ $ftp->command("SITE", @_);
+ $ftp->response();
+ }
+
+ sub mdtm
+ {
+ my $ftp = shift;
+ my $file = shift;
+
+ # Server Y2K bug workaround
+ #
+ # sigh; some idiotic FTP servers use ("19%d",tm.tm_year) instead of
+ # ("%d",tm.tm_year+1900). This results in an extra digit in the
+ # string returned. To account for this we allow an optional extra
+ # digit in the year. Then if the first two digits are 19 we use the
+ # remainder, otherwise we subtract 1900 from the whole year.
+
+ $ftp->_MDTM($file) && $ftp->message =~ /((\d\d)(\d\d\d?))(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
+ ? timegm($8,$7,$6,$5,$4-1,$2 eq '19' ? $3 : ($1-1900))
+ : undef;
+ }
+
+ sub size {
+ my $ftp = shift;
+ my $file = shift;
+ my $io;
+ if($ftp->supported("SIZE")) {
+ return $ftp->_SIZE($file)
+ ? ($ftp->message =~ /(\d+)/)[0]
+ : undef;
+ }
+ elsif($ftp->supported("STAT")) {
+ my @msg;
+ return undef
+ unless $ftp->_STAT($file) && (@msg = $ftp->message) == 3;
+ my $line;
+ foreach $line (@msg) {
+ return (split(/\s+/,$line))[4]
+ if $line =~ /^[-rw]{10}/
+ }
+ }
+ else {
+ my @files = $ftp->dir($file);
+ if(@files) {
+ return (split(/\s+/,$1))[4]
+ if $files[0] =~ /^([-rw]{10}.*)$/;
+ }
+ }
+ undef;
+ }
+
+ sub login {
+ my($ftp,$user,$pass,$acct) = @_;
+ my($ok,$ruser,$fwtype);
+
+ unless (defined $user) {
+ require Net::Netrc;
+
+ my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'});
+
+ ($user,$pass,$acct) = $rc->lpa()
+ if ($rc);
+ }
+
+ $user ||= "anonymous";
+ $ruser = $user;
+
+ $fwtype = $NetConfig{'ftp_firewall_type'} || 0;
+
+ if ($fwtype && defined ${*$ftp}{'net_ftp_firewall'}) {
+ if ($fwtype == 1 || $fwtype == 7) {
+ $user .= '@' . ${*$ftp}{'net_ftp_host'};
+ }
+ else {
+ require Net::Netrc;
+
+ my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
+
+ my($fwuser,$fwpass,$fwacct) = $rc ? $rc->lpa() : ();
+
+ if ($fwtype == 5) {
+ $user = join('@',$user,$fwuser,${*$ftp}{'net_ftp_host'});
+ $pass = $pass . '@' . $fwpass;
+ }
+ else {
+ if ($fwtype == 2) {
+ $user .= '@' . ${*$ftp}{'net_ftp_host'};
+ }
+ elsif ($fwtype == 6) {
+ $fwuser .= '@' . ${*$ftp}{'net_ftp_host'};
+ }
+
+ $ok = $ftp->_USER($fwuser);
+
+ return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
+
+ $ok = $ftp->_PASS($fwpass || "");
+
+ return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
+
+ $ok = $ftp->_ACCT($fwacct)
+ if defined($fwacct);
+
+ if ($fwtype == 3) {
+ $ok = $ftp->command("SITE",${*$ftp}{'net_ftp_host'})->response;
+ }
+ elsif ($fwtype == 4) {
+ $ok = $ftp->command("OPEN",${*$ftp}{'net_ftp_host'})->response;
+ }
+
+ return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
+ }
+ }
+ }
+
+ $ok = $ftp->_USER($user);
+
+ # Some dumb firewalls don't prefix the connection messages
+ $ok = $ftp->response()
+ if ($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/);
+
+ if ($ok == CMD_MORE) {
+ unless(defined $pass) {
+ require Net::Netrc;
+
+ my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}, $ruser);
+
+ ($ruser,$pass,$acct) = $rc->lpa()
+ if ($rc);
+
+ $pass = "-" . (eval { (getpwuid($>))[0] } || $ENV{NAME} ) . '@'
+ if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o));
+ }
+
+ $ok = $ftp->_PASS($pass || "");
+ }
+
+ $ok = $ftp->_ACCT($acct)
+ if (defined($acct) && ($ok == CMD_MORE || $ok == CMD_OK));
+
+ if ($fwtype == 7 && $ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'}) {
+ my($f,$auth,$resp) = _auth_id($ftp);
+ $ftp->authorize($auth,$resp) if defined($resp);
+ }
+
+ $ok == CMD_OK;
+ }
+
+ sub account
+ {
+ @_ == 2 or croak 'usage: $ftp->account( ACCT )';
+ my $ftp = shift;
+ my $acct = shift;
+ $ftp->_ACCT($acct) == CMD_OK;
+ }
+
+ sub _auth_id {
+ my($ftp,$auth,$resp) = @_;
+
+ unless(defined $resp)
+ {
+ require Net::Netrc;
+
+ $auth ||= eval { (getpwuid($>))[0] } || $ENV{NAME};
+
+ my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth)
+ || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
+
+ ($auth,$resp) = $rc->lpa()
+ if ($rc);
+ }
+ ($ftp,$auth,$resp);
+ }
+
+ sub authorize
+ {
+ @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])';
+
+ my($ftp,$auth,$resp) = &_auth_id;
+
+ my $ok = $ftp->_AUTH($auth || "");
+
+ $ok = $ftp->_RESP($resp || "")
+ if ($ok == CMD_MORE);
+
+ $ok == CMD_OK;
+ }
+
+ sub rename
+ {
+ @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)';
+
+ my($ftp,$from,$to) = @_;
+
+ $ftp->_RNFR($from)
+ && $ftp->_RNTO($to);
+ }
+
+ sub type
+ {
+ my $ftp = shift;
+ my $type = shift;
+ my $oldval = ${*$ftp}{'net_ftp_type'};
+
+ return $oldval
+ unless (defined $type);
+
+ return undef
+ unless ($ftp->_TYPE($type,@_));
+
+ ${*$ftp}{'net_ftp_type'} = join(" ",$type,@_);
+
+ $oldval;
+ }
+
+ sub abort
+ {
+ my $ftp = shift;
+
+ send($ftp,pack("CCC", $TELNET_IAC, $TELNET_IP, $TELNET_IAC),MSG_OOB);
+
+ $ftp->command(pack("C",$TELNET_DM) . "ABOR");
+
+ ${*$ftp}{'net_ftp_dataconn'}->close()
+ if defined ${*$ftp}{'net_ftp_dataconn'};
+
+ $ftp->response();
+
+ $ftp->status == CMD_OK;
+ }
+
+ sub get
+ {
+ my($ftp,$remote,$local,$where) = @_;
+
+ my($loc,$len,$buf,$resp,$localfd,$data);
+ local *FD;
+
+ $localfd = ref($local) || ref(\$local) eq "GLOB"
+ ? fileno($local)
+ : undef;
+
+ ($local = $remote) =~ s#^.*/##
+ unless(defined $local);
+
+ croak("Bad remote filename '$remote'\n")
+ if $remote =~ /[\r\n]/s;
+
+ ${*$ftp}{'net_ftp_rest'} = $where
+ if ($where);
+
+ delete ${*$ftp}{'net_ftp_port'};
+ delete ${*$ftp}{'net_ftp_pasv'};
+
+ $data = $ftp->retr($remote) or
+ return undef;
+
+ if(defined $localfd)
+ {
+ $loc = $local;
+ }
+ else
+ {
+ $loc = \*FD;
+
+ unless(($where) ? open($loc,">>$local") : open($loc,">$local"))
+ {
+ carp "Cannot open Local file $local: $!\n";
+ $data->abort;
+ return undef;
+ }
+ }
+
+ if($ftp->type eq 'I' && !binmode($loc))
+ {
+ carp "Cannot binmode Local file $local: $!\n";
+ $data->abort;
+ close($loc) unless $localfd;
+ return undef;
+ }
+
+ $buf = '';
+ my($count,$hashh,$hashb,$ref) = (0);
+
+ ($hashh,$hashb) = @$ref
+ if($ref = ${*$ftp}{'net_ftp_hash'});
+
+ my $blksize = ${*$ftp}{'net_ftp_blksize'};
+
+ while(1)
+ {
+ last unless $len = $data->read($buf,$blksize);
+ if($hashh) {
+ $count += $len;
+ print $hashh "#" x (int($count / $hashb));
+ $count %= $hashb;
+ }
+ my $written = syswrite($loc,$buf,$len);
+ unless(defined($written) && $written == $len)
+ {
+ carp "Cannot write to Local file $local: $!\n";
+ $data->abort;
+ close($loc)
+ unless defined $localfd;
+ return undef;
+ }
+ }
+
+ print $hashh "\n" if $hashh;
+
+ close($loc)
+ unless defined $localfd;
+
+ $data->close(); # implied $ftp->response
+
+ return $local;
+ }
+
+ sub cwd
+ {
+ @_ == 1 || @_ == 2 or croak 'usage: $ftp->cwd( [ DIR ] )';
+
+ my($ftp,$dir) = @_;
+
+ $dir = "/" unless defined($dir) && $dir =~ /\S/;
+
+ $dir eq ".."
+ ? $ftp->_CDUP()
+ : $ftp->_CWD($dir);
+ }
+
+ sub cdup
+ {
+ @_ == 1 or croak 'usage: $ftp->cdup()';
+ $_[0]->_CDUP;
+ }
+
+ sub pwd
+ {
+ @_ == 1 || croak 'usage: $ftp->pwd()';
+ my $ftp = shift;
+
+ $ftp->_PWD();
+ $ftp->_extract_path;
+ }
+
+ # rmdir( $ftp, $dir, [ $recurse ] )
+ #
+ # Removes $dir on remote host via FTP.
+ # $ftp is handle for remote host
+ #
+ # If $recurse is TRUE, the directory and deleted recursively.
+ # This means all of its contents and subdirectories.
+ #
+ # Initial version contributed by Dinkum Software
+ #
+ sub rmdir
+ {
+ @_ == 2 || @_ == 3 or croak('usage: $ftp->rmdir( DIR [, RECURSE ] )');
+
+ # Pick off the args
+ my ($ftp, $dir, $recurse) = @_ ;
+ my $ok;
+
+ return $ok
+ if $ftp->_RMD( $dir ) || !$recurse;
+
+ # Try to delete the contents
+ # Get a list of all the files in the directory
+ my $filelist = $ftp->ls($dir);
+
+ return undef
+ unless $filelist && @$filelist; # failed, it is probably not a directory
+
+ # Go thru and delete each file or the directory
+ my $file;
+ foreach $file (map { m,/, ? $_ : "$dir/$_" } @$filelist)
+ {
+ next # successfully deleted the file
+ if $ftp->delete($file);
+
+ # Failed to delete it, assume its a directory
+ # Recurse and ignore errors, the final rmdir() will
+ # fail on any errors here
+ return $ok
+ unless $ok = $ftp->rmdir($file, 1) ;
+ }
+
+ # Directory should be empty
+ # Try to remove the directory again
+ # Pass results directly to caller
+ # If any of the prior deletes failed, this
+ # rmdir() will fail because directory is not empty
+ return $ftp->_RMD($dir) ;
+ }
+
+ sub mkdir
+ {
+ @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )';
+
+ my($ftp,$dir,$recurse) = @_;
+
+ $ftp->_MKD($dir) || $recurse or
+ return undef;
+
+ my $path = $dir;
+
+ unless($ftp->ok)
+ {
+ my @path = split(m#(?=/+)#, $dir);
+
+ $path = "";
+
+ while(@path)
+ {
+ $path .= shift @path;
+
+ $ftp->_MKD($path);
+
+ $path = $ftp->_extract_path($path);
+ }
+
+ # If the creation of the last element was not sucessful, see if we
+ # can cd to it, if so then return path
+
+ unless($ftp->ok)
+ {
+ my($status,$message) = ($ftp->status,$ftp->message);
+ my $pwd = $ftp->pwd;
+
+ if($pwd && $ftp->cwd($dir))
+ {
+ $path = $dir;
+ $ftp->cwd($pwd);
+ }
+ else
+ {
+ undef $path;
+ }
+ $ftp->set_status($status,$message);
+ }
+ }
+
+ $path;
+ }
+
+ sub delete
+ {
+ @_ == 2 || croak 'usage: $ftp->delete( FILENAME )';
+
+ $_[0]->_DELE($_[1]);
+ }
+
+ sub put { shift->_store_cmd("stor",@_) }
+ sub put_unique { shift->_store_cmd("stou",@_) }
+ sub append { shift->_store_cmd("appe",@_) }
+
+ sub nlst { shift->_data_cmd("NLST",@_) }
+ sub list { shift->_data_cmd("LIST",@_) }
+ sub retr { shift->_data_cmd("RETR",@_) }
+ sub stor { shift->_data_cmd("STOR",@_) }
+ sub stou { shift->_data_cmd("STOU",@_) }
+ sub appe { shift->_data_cmd("APPE",@_) }
+
+ sub _store_cmd
+ {
+ my($ftp,$cmd,$local,$remote) = @_;
+ my($loc,$sock,$len,$buf,$localfd);
+ local *FD;
+
+ $localfd = ref($local) || ref(\$local) eq "GLOB"
+ ? fileno($local)
+ : undef;
+
+ unless(defined $remote)
+ {
+ croak 'Must specify remote filename with stream input'
+ if defined $localfd;
+
+ require File::Basename;
+ $remote = File::Basename::basename($local);
+ }
+
+ croak("Bad remote filename '$remote'\n")
+ if $remote =~ /[\r\n]/s;
+
+ if(defined $localfd)
+ {
+ $loc = $local;
+ }
+ else
+ {
+ $loc = \*FD;
+
+ unless(open($loc,"<$local"))
+ {
+ carp "Cannot open Local file $local: $!\n";
+ return undef;
+ }
+ }
+
+ if($ftp->type eq 'I' && !binmode($loc))
+ {
+ carp "Cannot binmode Local file $local: $!\n";
+ return undef;
+ }
+
+ delete ${*$ftp}{'net_ftp_port'};
+ delete ${*$ftp}{'net_ftp_pasv'};
+
+ $sock = $ftp->_data_cmd($cmd, $remote) or
+ return undef;
+
+ my $blksize = ${*$ftp}{'net_ftp_blksize'};
+
+ my($count,$hashh,$hashb,$ref) = (0);
+
+ ($hashh,$hashb) = @$ref
+ if($ref = ${*$ftp}{'net_ftp_hash'});
+
+ while(1)
+ {
+ last unless $len = sysread($loc,$buf="",$blksize);
+
+ if($hashh) {
+ $count += $len;
+ print $hashh "#" x (int($count / $hashb));
+ $count %= $hashb;
+ }
+
+ my $wlen;
+ unless(defined($wlen = $sock->write($buf,$len)) && $wlen == $len)
+ {
+ $sock->abort;
+ close($loc)
+ unless defined $localfd;
+ print $hashh "\n" if $hashh;
+ return undef;
+ }
+ }
+
+ print $hashh "\n" if $hashh;
+
+ close($loc)
+ unless defined $localfd;
+
+ $sock->close() or
+ return undef;
+
+ ($remote) = $ftp->message =~ /unique file name:\s*(\S*)\s*\)/
+ if ('STOU' eq uc $cmd);
+
+ return $remote;
+ }
+
+ sub port
+ {
+ @_ == 1 || @_ == 2 or croak 'usage: $ftp->port([PORT])';
+
+ my($ftp,$port) = @_;
+ my $ok;
+
+ delete ${*$ftp}{'net_ftp_intern_port'};
+
+ unless(defined $port)
+ {
+ # create a Listen socket at same address as the command socket
+
+ ${*$ftp}{'net_ftp_listen'} ||= IO::Socket::INET->new(Listen => 5,
+ Proto => 'tcp',
+ );
+
+ my $listen = ${*$ftp}{'net_ftp_listen'};
+
+ my($myport, @myaddr) = ($listen->sockport, split(/\./,$ftp->sockhost));
+
+ $port = join(',', @myaddr, $myport >> 8, $myport & 0xff);
+
+ ${*$ftp}{'net_ftp_intern_port'} = 1;
+ }
+
+ $ok = $ftp->_PORT($port);
+
+ ${*$ftp}{'net_ftp_port'} = $port;
+
+ $ok;
+ }
+
+ sub ls { shift->_list_cmd("NLST",@_); }
+ sub dir { shift->_list_cmd("LIST",@_); }
+
+ sub pasv
+ {
+ @_ == 1 or croak 'usage: $ftp->pasv()';
+
+ my $ftp = shift;
+
+ delete ${*$ftp}{'net_ftp_intern_port'};
+
+ $ftp->_PASV && $ftp->message =~ /(\d+(,\d+)+)/
+ ? ${*$ftp}{'net_ftp_pasv'} = $1
+ : undef;
+ }
+
+ sub unique_name
+ {
+ my $ftp = shift;
+ ${*$ftp}{'net_ftp_unique'} || undef;
+ }
+
+ sub supported {
+ @_ == 2 or croak 'usage: $ftp->supported( CMD )';
+ my $ftp = shift;
+ my $cmd = uc shift;
+ my $hash = ${*$ftp}{'net_ftp_supported'} ||= {};
+
+ return $hash->{$cmd}
+ if exists $hash->{$cmd};
+
+ return $hash->{$cmd} = 0
+ unless $ftp->_HELP($cmd);
+
+ my $text = $ftp->message;
+ if($text =~ /following\s+commands/i) {
+ $text =~ s/^.*\n//;
+ $text =~ s/\n/ /sog;
+ while($text =~ /(\w+)([* ])/g) {
+ $hash->{"\U$1"} = $2 eq " " ? 1 : 0;
+ }
+ }
+ else {
+ $hash->{$cmd} = $text !~ /unimplemented/i;
+ }
+
+ $hash->{$cmd} ||= 0;
+ }
+
+ ##
+ ## Deprecated methods
+ ##
+
+ sub lsl
+ {
+ carp "Use of Net::FTP::lsl deprecated, use 'dir'"
+ if $^W;
+ goto &dir;
+ }
+
+ sub authorise
+ {
+ carp "Use of Net::FTP::authorise deprecated, use 'authorize'"
+ if $^W;
+ goto &authorize;
+ }
+
+
+ ##
+ ## Private methods
+ ##
+
+ sub _extract_path
+ {
+ my($ftp, $path) = @_;
+
+ # This tries to work both with and without the quote doubling
+ # convention (RFC 959 requires it, but the first 3 servers I checked
+ # didn't implement it). It will fail on a server which uses a quote in
+ # the message which isn't a part of or surrounding the path.
+ $ftp->ok &&
+ $ftp->message =~ /(?:^|\s)\"(.*)\"(?:$|\s)/ &&
+ ($path = $1) =~ s/\"\"/\"/g;
+
+ $path;
+ }
+
+ ##
+ ## Communication methods
+ ##
+
+ sub _dataconn
+ {
+ my $ftp = shift;
+ my $data = undef;
+ my $pkg = "Net::FTP::" . $ftp->type;
+
+ eval "require " . $pkg;
+
+ $pkg =~ s/ /_/g;
+
+ delete ${*$ftp}{'net_ftp_dataconn'};
+
+ if(defined ${*$ftp}{'net_ftp_pasv'})
+ {
+ my @port = split(/,/,${*$ftp}{'net_ftp_pasv'});
+
+ $data = $pkg->new(PeerAddr => join(".",@port[0..3]),
+ PeerPort => $port[4] * 256 + $port[5],
+ Proto => 'tcp'
+ );
+ }
+ elsif(defined ${*$ftp}{'net_ftp_listen'})
+ {
+ $data = ${*$ftp}{'net_ftp_listen'}->accept($pkg);
+ close(delete ${*$ftp}{'net_ftp_listen'});
+ }
+
+ if($data)
+ {
+ ${*$data} = "";
+ $data->timeout($ftp->timeout);
+ ${*$ftp}{'net_ftp_dataconn'} = $data;
+ ${*$data}{'net_ftp_cmd'} = $ftp;
+ ${*$data}{'net_ftp_blksize'} = ${*$ftp}{'net_ftp_blksize'};
+ }
+
+ $data;
+ }
+
+ sub _list_cmd
+ {
+ my $ftp = shift;
+ my $cmd = uc shift;
+
+ delete ${*$ftp}{'net_ftp_port'};
+ delete ${*$ftp}{'net_ftp_pasv'};
+
+ my $data = $ftp->_data_cmd($cmd,@_);
+
+ return
+ unless(defined $data);
+
+ require Net::FTP::A;
+ bless $data, "Net::FTP::A"; # Force ASCII mode
+
+ my $databuf = '';
+ my $buf = '';
+ my $blksize = ${*$ftp}{'net_ftp_blksize'};
+
+ while($data->read($databuf,$blksize)) {
+ $buf .= $databuf;
+ }
+
+ my $list = [ split(/\n/,$buf) ];
+
+ $data->close();
+
+ wantarray ? @{$list}
+ : $list;
+ }
+
+ sub _data_cmd
+ {
+ my $ftp = shift;
+ my $cmd = uc shift;
+ my $ok = 1;
+ my $where = delete ${*$ftp}{'net_ftp_rest'} || 0;
+ my $arg;
+
+ for $arg (@_) {
+ croak("Bad argument '$arg'\n")
+ if $arg =~ /[\r\n]/s;
+ }
+
+ if(${*$ftp}{'net_ftp_passive'} &&
+ !defined ${*$ftp}{'net_ftp_pasv'} &&
+ !defined ${*$ftp}{'net_ftp_port'})
+ {
+ my $data = undef;
+
+ $ok = defined $ftp->pasv;
+ $ok = $ftp->_REST($where)
+ if $ok && $where;
+
+ if($ok)
+ {
+ $ftp->command($cmd,@_);
+ $data = $ftp->_dataconn();
+ $ok = CMD_INFO == $ftp->response();
+ if($ok)
+ {
+ $data->reading
+ if $data && $cmd =~ /RETR|LIST|NLST/;
+ return $data
+ }
+ $data->_close
+ if $data;
+ }
+ return undef;
+ }
+
+ $ok = $ftp->port
+ unless (defined ${*$ftp}{'net_ftp_port'} ||
+ defined ${*$ftp}{'net_ftp_pasv'});
+
+ $ok = $ftp->_REST($where)
+ if $ok && $where;
+
+ return undef
+ unless $ok;
+
+ $ftp->command($cmd,@_);
+
+ return 1
+ if(defined ${*$ftp}{'net_ftp_pasv'});
+
+ $ok = CMD_INFO == $ftp->response();
+
+ return $ok
+ unless exists ${*$ftp}{'net_ftp_intern_port'};
+
+ if($ok) {
+ my $data = $ftp->_dataconn();
+
+ $data->reading
+ if $data && $cmd =~ /RETR|LIST|NLST/;
+
+ return $data;
+ }
+
+
+ close(delete ${*$ftp}{'net_ftp_listen'});
+
+ return undef;
+ }
+
+ ##
+ ## Over-ride methods (Net::Cmd)
+ ##
+
+ sub debug_text { $_[2] =~ /^(pass|resp|acct)/i ? "$1 ....\n" : $_[2]; }
+
+ sub command
+ {
+ my $ftp = shift;
+
+ delete ${*$ftp}{'net_ftp_port'};
+ $ftp->SUPER::command(@_);
+ }
+
+ sub response
+ {
+ my $ftp = shift;
+ my $code = $ftp->SUPER::response();
+
+ delete ${*$ftp}{'net_ftp_pasv'}
+ if ($code != CMD_MORE && $code != CMD_INFO);
+
+ $code;
+ }
+
+ sub parse_response
+ {
+ return ($1, $2 eq "-")
+ if $_[1] =~ s/^(\d\d\d)(.?)//o;
+
+ my $ftp = shift;
+
+ # Darn MS FTP server is a load of CRAP !!!!
+ return ()
+ unless ${*$ftp}{'net_cmd_code'} + 0;
+
+ (${*$ftp}{'net_cmd_code'},1);
+ }
+
+ ##
+ ## Allow 2 servers to talk directly
+ ##
+
+ sub pasv_xfer {
+ my($sftp,$sfile,$dftp,$dfile,$unique) = @_;
+
+ ($dfile = $sfile) =~ s#.*/##
+ unless(defined $dfile);
+
+ my $port = $sftp->pasv or
+ return undef;
+
+ $dftp->port($port) or
+ return undef;
+
+ return undef
+ unless($unique ? $dftp->stou($dfile) : $dftp->stor($dfile));
+
+ unless($sftp->retr($sfile) && $sftp->response == CMD_INFO) {
+ $sftp->retr($sfile);
+ $dftp->abort;
+ $dftp->response();
+ return undef;
+ }
+
+ $dftp->pasv_wait($sftp);
+ }
+
+ sub pasv_wait
+ {
+ @_ == 2 or croak 'usage: $ftp->pasv_wait(NON_PASV_FTP)';
+
+ my($ftp, $non_pasv) = @_;
+ my($file,$rin,$rout);
+
+ vec($rin='',fileno($ftp),1) = 1;
+ select($rout=$rin, undef, undef, undef);
+
+ $ftp->response();
+ $non_pasv->response();
+
+ return undef
+ unless $ftp->ok() && $non_pasv->ok();
+
+ return $1
+ if $ftp->message =~ /unique file name:\s*(\S*)\s*\)/;
+
+ return $1
+ if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/;
+
+ return 1;
+ }
+
+ sub cmd { shift->command(@_)->response() }
+
+ ########################################
+ #
+ # RFC959 commands
+ #
+
+ sub _ABOR { shift->command("ABOR")->response() == CMD_OK }
+ sub _CDUP { shift->command("CDUP")->response() == CMD_OK }
+ sub _NOOP { shift->command("NOOP")->response() == CMD_OK }
+ sub _PASV { shift->command("PASV")->response() == CMD_OK }
+ sub _QUIT { shift->command("QUIT")->response() == CMD_OK }
+ sub _DELE { shift->command("DELE",@_)->response() == CMD_OK }
+ sub _CWD { shift->command("CWD", @_)->response() == CMD_OK }
+ sub _PORT { shift->command("PORT",@_)->response() == CMD_OK }
+ sub _RMD { shift->command("RMD", @_)->response() == CMD_OK }
+ sub _MKD { shift->command("MKD", @_)->response() == CMD_OK }
+ sub _PWD { shift->command("PWD", @_)->response() == CMD_OK }
+ sub _TYPE { shift->command("TYPE",@_)->response() == CMD_OK }
+ sub _RNTO { shift->command("RNTO",@_)->response() == CMD_OK }
+ sub _RESP { shift->command("RESP",@_)->response() == CMD_OK }
+ sub _MDTM { shift->command("MDTM",@_)->response() == CMD_OK }
+ sub _SIZE { shift->command("SIZE",@_)->response() == CMD_OK }
+ sub _HELP { shift->command("HELP",@_)->response() == CMD_OK }
+ sub _STAT { shift->command("STAT",@_)->response() == CMD_OK }
+ sub _APPE { shift->command("APPE",@_)->response() == CMD_INFO }
+ sub _LIST { shift->command("LIST",@_)->response() == CMD_INFO }
+ sub _NLST { shift->command("NLST",@_)->response() == CMD_INFO }
+ sub _RETR { shift->command("RETR",@_)->response() == CMD_INFO }
+ sub _STOR { shift->command("STOR",@_)->response() == CMD_INFO }
+ sub _STOU { shift->command("STOU",@_)->response() == CMD_INFO }
+ sub _RNFR { shift->command("RNFR",@_)->response() == CMD_MORE }
+ sub _REST { shift->command("REST",@_)->response() == CMD_MORE }
+ sub _USER { shift->command("user",@_)->response() } # A certain brain dead firewall :-)
+ sub _PASS { shift->command("PASS",@_)->response() }
+ sub _ACCT { shift->command("ACCT",@_)->response() }
+ sub _AUTH { shift->command("AUTH",@_)->response() }
+
+ sub _ALLO { shift->unsupported(@_) }
+ sub _SMNT { shift->unsupported(@_) }
+ sub _MODE { shift->unsupported(@_) }
+ sub _SYST { shift->unsupported(@_) }
+ sub _STRU { shift->unsupported(@_) }
+ sub _REIN { shift->unsupported(@_) }
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ Net::FTP - FTP Client class
+
+ =head1 SYNOPSIS
+
+ use Net::FTP;
+
+ $ftp = Net::FTP->new("some.host.name", Debug => 0);
+ $ftp->login("anonymous",'me@here.there');
+ $ftp->cwd("/pub");
+ $ftp->get("that.file");
+ $ftp->quit;
+
+ =head1 DESCRIPTION
+
+ C<Net::FTP> is a class implementing a simple FTP client in Perl as
+ described in RFC959. It provides wrappers for a subset of the RFC959
+ commands.
+
+ =head1 OVERVIEW
+
+ FTP stands for File Transfer Protocol. It is a way of transferring
+ files between networked machines. The protocol defines a client
+ (whose commands are provided by this module) and a server (not
+ implemented in this module). Communication is always initiated by the
+ client, and the server responds with a message and a status code (and
+ sometimes with data).
+
+ The FTP protocol allows files to be sent to or fetched from the
+ server. Each transfer involves a B<local file> (on the client) and a
+ B<remote file> (on the server). In this module, the same file name
+ will be used for both local and remote if only one is specified. This
+ means that transferring remote file C</path/to/file> will try to put
+ that file in C</path/to/file> locally, unless you specify a local file
+ name.
+
+ The protocol also defines several standard B<translations> which the
+ file can undergo during transfer. These are ASCII, EBCDIC, binary,
+ and byte. ASCII is the default type, and indicates that the sender of
+ files will translate the ends of lines to a standard representation
+ which the receiver will then translate back into their local
+ representation. EBCDIC indicates the file being transferred is in
+ EBCDIC format. Binary (also known as image) format sends the data as
+ a contiguous bit stream. Byte format transfers the data as bytes, the
+ values of which remain the same regardless of differences in byte size
+ between the two machines (in theory - in practice you should only use
+ this if you really know what you're doing).
+
+ =head1 CONSTRUCTOR
+
+ =over 4
+
+ =item new (HOST [,OPTIONS])
+
+ This is the constructor for a new Net::FTP object. C<HOST> is the
+ name of the remote host to which a FTP connection is required.
+
+ C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
+ Possible options are:
+
+ B<Firewall> - The name of a machine which acts as a FTP firewall. This can be
+ overridden by an environment variable C<FTP_FIREWALL>. If specified, and the
+ given host cannot be directly connected to, then the
+ connection is made to the firewall machine and the string C<@hostname> is
+ appended to the login identifier. This kind of setup is also refered to
+ as a ftp proxy.
+
+ B<BlockSize> - This is the block size that Net::FTP will use when doing
+ transfers. (defaults to 10240)
+
+ B<Port> - The port number to connect to on the remote machine for the
+ FTP connection
+
+ B<Timeout> - Set a timeout value (defaults to 120)
+
+ B<Debug> - debug level (see the debug method in L<Net::Cmd>)
+
+ B<Passive> - If set to a non-zero value then all data transfers will be done
+ using passive mode. This is not usually required except for some I<dumb>
+ servers, and some firewall configurations. This can also be set by the
+ environment variable C<FTP_PASSIVE>.
+
+ B<Hash> - If given a reference to a file handle (e.g., C<\*STDERR>),
+ print hash marks (#) on that filehandle every 1024 bytes. This
+ simply invokes the C<hash()> method for you, so that hash marks
+ are displayed for all transfers. You can, of course, call C<hash()>
+ explicitly whenever you'd like.
+
+ If the constructor fails undef will be returned and an error message will
+ be in $@
+
+ =back
+
+ =head1 METHODS
+
+ Unless otherwise stated all methods return either a I<true> or I<false>
+ value, with I<true> meaning that the operation was a success. When a method
+ states that it returns a value, failure will be returned as I<undef> or an
+ empty list.
+
+ =over 4
+
+ =item login ([LOGIN [,PASSWORD [, ACCOUNT] ] ])
+
+ Log into the remote FTP server with the given login information. If
+ no arguments are given then the C<Net::FTP> uses the C<Net::Netrc>
+ package to lookup the login information for the connected host.
+ If no information is found then a login of I<anonymous> is used.
+ If no password is given and the login is I<anonymous> then the users
+ Email address will be used for a password.
+
+ If the connection is via a firewall then the C<authorize> method will
+ be called with no arguments.
+
+ =item authorize ( [AUTH [, RESP]])
+
+ This is a protocol used by some firewall ftp proxies. It is used
+ to authorise the user to send data out. If both arguments are not specified
+ then C<authorize> uses C<Net::Netrc> to do a lookup.
+
+ =item site (ARGS)
+
+ Send a SITE command to the remote server and wait for a response.
+
+ Returns most significant digit of the response code.
+
+ =item type (TYPE [, ARGS])
+
+ This method will send the TYPE command to the remote FTP server
+ to change the type of data transfer. The return value is the previous
+ value.
+
+ =item ascii ([ARGS]) binary([ARGS]) ebcdic([ARGS]) byte([ARGS])
+
+ Synonyms for C<type> with the first arguments set correctly
+
+ B<NOTE> ebcdic and byte are not fully supported.
+
+ =item rename ( OLDNAME, NEWNAME )
+
+ Rename a file on the remote FTP server from C<OLDNAME> to C<NEWNAME>. This
+ is done by sending the RNFR and RNTO commands.
+
+ =item delete ( FILENAME )
+
+ Send a request to the server to delete C<FILENAME>.
+
+ =item cwd ( [ DIR ] )
+
+ Attempt to change directory to the directory given in C<$dir>. If
+ C<$dir> is C<"..">, the FTP C<CDUP> command is used to attempt to
+ move up one directory. If no directory is given then an attempt is made
+ to change the directory to the root directory.
+
+ =item cdup ()
+
+ Change directory to the parent of the current directory.
+
+ =item pwd ()
+
+ Returns the full pathname of the current directory.
+
+ =item rmdir ( DIR )
+
+ Remove the directory with the name C<DIR>.
+
+ =item mkdir ( DIR [, RECURSE ])
+
+ Create a new directory with the name C<DIR>. If C<RECURSE> is I<true> then
+ C<mkdir> will attempt to create all the directories in the given path.
+
+ Returns the full pathname to the new directory.
+
+ =item ls ( [ DIR ] )
+
+ Get a directory listing of C<DIR>, or the current directory.
+
+ In an array context, returns a list of lines returned from the server. In
+ a scalar context, returns a reference to a list.
+
+ =item dir ( [ DIR ] )
+
+ Get a directory listing of C<DIR>, or the current directory in long format.
+
+ In an array context, returns a list of lines returned from the server. In
+ a scalar context, returns a reference to a list.
+
+ =item get ( REMOTE_FILE [, LOCAL_FILE [, WHERE]] )
+
+ Get C<REMOTE_FILE> from the server and store locally. C<LOCAL_FILE> may be
+ a filename or a filehandle. If not specified the the file will be stored in
+ the current directory with the same leafname as the remote file.
+
+ If C<WHERE> is given then the first C<WHERE> bytes of the file will
+ not be transfered, and the remaining bytes will be appended to
+ the local file if it already exists.
+
+ Returns C<LOCAL_FILE>, or the generated local file name if C<LOCAL_FILE>
+ is not given.
+
+ =item put ( LOCAL_FILE [, REMOTE_FILE ] )
+
+ Put a file on the remote server. C<LOCAL_FILE> may be a name or a filehandle.
+ If C<LOCAL_FILE> is a filehandle then C<REMOTE_FILE> must be specified. If
+ C<REMOTE_FILE> is not specified then the file will be stored in the current
+ directory with the same leafname as C<LOCAL_FILE>.
+
+ Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
+ is not given.
+
+ B<NOTE>: If for some reason the transfer does not complete and an error is
+ returned then the contents that had been transfered will not be remove
+ automatically.
+
+ =item put_unique ( LOCAL_FILE [, REMOTE_FILE ] )
+
+ Same as put but uses the C<STOU> command.
+
+ Returns the name of the file on the server.
+
+ =item append ( LOCAL_FILE [, REMOTE_FILE ] )
+
+ Same as put but appends to the file on the remote server.
+
+ Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
+ is not given.
+
+ =item unique_name ()
+
+ Returns the name of the last file stored on the server using the
+ C<STOU> command.
+
+ =item mdtm ( FILE )
+
+ Returns the I<modification time> of the given file
+
+ =item size ( FILE )
+
+ Returns the size in bytes for the given file as stored on the remote server.
+
+ B<NOTE>: The size reported is the size of the stored file on the remote server.
+ If the file is subsequently transfered from the server in ASCII mode
+ and the remote server and local machine have different ideas about
+ "End Of Line" then the size of file on the local machine after transfer
+ may be different.
+
+ =item supported ( CMD )
+
+ Returns TRUE if the remote server supports the given command.
+
+ =item hash ( [FILEHANDLE_GLOB_REF],[ BYTES_PER_HASH_MARK] )
+
+ Called without parameters, or with the first argument false, hash marks
+ are suppressed. If the first argument is true but not a reference to a
+ file handle glob, then \*STDERR is used. The second argument is the number
+ of bytes per hash mark printed, and defaults to 1024. In all cases the
+ return value is a reference to an array of two: the filehandle glob reference
+ and the bytes per hash mark.
+
+ =back
+
+ The following methods can return different results depending on
+ how they are called. If the user explicitly calls either
+ of the C<pasv> or C<port> methods then these methods will
+ return a I<true> or I<false> value. If the user does not
+ call either of these methods then the result will be a
+ reference to a C<Net::FTP::dataconn> based object.
+
+ =over 4
+
+ =item nlst ( [ DIR ] )
+
+ Send a C<NLST> command to the server, with an optional parameter.
+
+ =item list ( [ DIR ] )
+
+ Same as C<nlst> but using the C<LIST> command
+
+ =item retr ( FILE )
+
+ Begin the retrieval of a file called C<FILE> from the remote server.
+
+ =item stor ( FILE )
+
+ Tell the server that you wish to store a file. C<FILE> is the
+ name of the new file that should be created.
+
+ =item stou ( FILE )
+
+ Same as C<stor> but using the C<STOU> command. The name of the unique
+ file which was created on the server will be available via the C<unique_name>
+ method after the data connection has been closed.
+
+ =item appe ( FILE )
+
+ Tell the server that we want to append some data to the end of a file
+ called C<FILE>. If this file does not exist then create it.
+
+ =back
+
+ If for some reason you want to have complete control over the data connection,
+ this includes generating it and calling the C<response> method when required,
+ then the user can use these methods to do so.
+
+ However calling these methods only affects the use of the methods above that
+ can return a data connection. They have no effect on methods C<get>, C<put>,
+ C<put_unique> and those that do not require data connections.
+
+ =over 4
+
+ =item port ( [ PORT ] )
+
+ Send a C<PORT> command to the server. If C<PORT> is specified then it is sent
+ to the server. If not the a listen socket is created and the correct information
+ sent to the server.
+
+ =item pasv ()
+
+ Tell the server to go into passive mode. Returns the text that represents the
+ port on which the server is listening, this text is in a suitable form to
+ sent to another ftp server using the C<port> method.
+
+ =back
+
+ The following methods can be used to transfer files between two remote
+ servers, providing that these two servers can connect directly to each other.
+
+ =over 4
+
+ =item pasv_xfer ( SRC_FILE, DEST_SERVER [, DEST_FILE ] )
+
+ This method will do a file transfer between two remote ftp servers. If
+ C<DEST_FILE> is omitted then the leaf name of C<SRC_FILE> will be used.
+
+ =item pasv_xfer_unique ( SRC_FILE, DEST_SERVER [, DEST_FILE ] )
+
+ Like C<pasv_xfer> but the file is stored on the remote server using
+ the STOU command.
+
+ =item pasv_wait ( NON_PASV_SERVER )
+
+ This method can be used to wait for a transfer to complete between a passive
+ server and a non-passive server. The method should be called on the passive
+ server with the C<Net::FTP> object for the non-passive server passed as an
+ argument.
+
+ =item abort ()
+
+ Abort the current data transfer.
+
+ =item quit ()
+
+ Send the QUIT command to the remote FTP server and close the socket connection.
+
+ =back
+
+ =head2 Methods for the adventurous
+
+ C<Net::FTP> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may
+ be used to send commands to the remote FTP server.
+
+ =over 4
+
+ =item quot (CMD [,ARGS])
+
+ Send a command, that Net::FTP does not directly support, to the remote
+ server and wait for a response.
+
+ Returns most significant digit of the response code.
+
+ B<WARNING> This call should only be used on commands that do not require
+ data connections. Misuse of this method can hang the connection.
+
+ =back
+
+ =head1 THE dataconn CLASS
+
+ Some of the methods defined in C<Net::FTP> return an object which will
+ be derived from this class.The dataconn class itself is derived from
+ the C<IO::Socket::INET> class, so any normal IO operations can be performed.
+ However the following methods are defined in the dataconn class and IO should
+ be performed using these.
+
+ =over 4
+
+ =item read ( BUFFER, SIZE [, TIMEOUT ] )
+
+ Read C<SIZE> bytes of data from the server and place it into C<BUFFER>, also
+ performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
+ given the the timeout value from the command connection will be used.
+
+ Returns the number of bytes read before any <CRLF> translation.
+
+ =item write ( BUFFER, SIZE [, TIMEOUT ] )
+
+ Write C<SIZE> bytes of data from C<BUFFER> to the server, also
+ performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
+ given the the timeout value from the command connection will be used.
+
+ Returns the number of bytes written before any <CRLF> translation.
+
+ =item abort ()
+
+ Abort the current data transfer.
+
+ =item close ()
+
+ Close the data connection and get a response from the FTP server. Returns
+ I<true> if the connection was closed successfully and the first digit of
+ the response from the server was a '2'.
+
+ =back
+
+ =head1 UNIMPLEMENTED
+
+ The following RFC959 commands have not been implemented:
+
+ =over 4
+
+ =item B<ALLO>
+
+ Allocates storage for the file to be transferred.
+
+ =item B<SMNT>
+
+ Mount a different file system structure without changing login or
+ accounting information.
+
+ =item B<HELP>
+
+ Ask the server for "helpful information" (that's what the RFC says) on
+ the commands it accepts.
+
+ =item B<MODE>
+
+ Specifies transfer mode (stream, block or compressed) for file to be
+ transferred.
+
+ =item B<SYST>
+
+ Request remote server system identification.
+
+ =item B<STAT>
+
+ Request remote server status.
+
+ =item B<STRU>
+
+ Specifies file structure for file to be transferred.
+
+ =item B<REIN>
+
+ Reinitialize the connection, flushing all I/O and account information.
+
+ =back
+
+ =head1 REPORTING BUGS
+
+ When reporting bugs/problems please include as much information as possible.
+ It may be difficult for me to reproduce the problem as almost every setup
+ is different.
+
+ A small script which yields the problem will probably be of help. It would
+ also be useful if this script was run with the extra options C<Debug => 1>
+ passed to the constructor, and the output sent with the bug report. If you
+ cannot include a small script then please include a Debug trace from a
+ run of your program which does yield the problem.
+
+ =head1 AUTHOR
+
+ Graham Barr <gbarr@pobox.com>
+
+ =head1 SEE ALSO
+
+ L<Net::Netrc>
+ L<Net::Cmd>
+
+ ftp(1), ftpd(8), RFC 959
+ http://www.cis.ohio-state.edu/htbin/rfc/rfc959.html
+
+ =head1 CREDITS
+
+ Henry Gabryjelski <henryg@WPI.EDU> - for the suggestion of creating directories
+ recursively.
+
+ Nathan Torkington <gnat@frii.com> - for some input on the documentation.
+
+ Roderick Schertler <roderick@gate.net> - for various inputs
+
+ =head1 COPYRIGHT
+
+ Copyright (c) 1995-1998 Graham Barr. All rights reserved.
+ This program is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
+ =cut
diff -c /dev/null 'perl-5.7.2/lib/Net/FTP/A.pm'
Index: ./lib/Net/FTP/A.pm
*** ./lib/Net/FTP/A.pm Thu Jan 1 02:00:00 1970
--- ./lib/Net/FTP/A.pm Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,99 ----
+ ##
+ ## Package to read/write on ASCII data connections
+ ##
+
+ package Net::FTP::A;
+ use strict;
+ use vars qw(@ISA $buf $VERSION);
+ use Carp;
+
+ require Net::FTP::dataconn;
+
+ @ISA = qw(Net::FTP::dataconn);
+ $VERSION = "1.13"; # $Id: //depot/libnet/Net/FTP/A.pm#9 $
+
+ sub read {
+ my $data = shift;
+ local *buf = \$_[0]; shift;
+ my $size = shift || croak 'read($buf,$size,[$offset])';
+ my $timeout = @_ ? shift : $data->timeout;
+
+ if (length(${*$data}) < $size && !${*$data}{'net_ftp_eof'}) {
+ my $blksize = ${*$data}{'net_ftp_blksize'};
+ $blksize = $size if $size > $blksize;
+
+ my $l = 0;
+ my $n;
+
+ READ:
+ {
+ my $readbuf = defined(${*$data}{'net_ftp_cr'}) ? "\015" : '';
+
+ $data->can_read($timeout) or
+ croak "Timeout";
+
+ if ($n = sysread($data, $readbuf, $blksize, length $readbuf)) {
+ ${*$data}{'net_ftp_bytesread'} += $n;
+ ${*$data}{'net_ftp_cr'} = substr($readbuf,-1) eq "\015"
+ ? chop($readbuf)
+ : undef;
+ }
+ else {
+ return undef
+ unless defined $n;
+
+ ${*$data}{'net_ftp_eof'} = 1;
+ }
+
+ $readbuf =~ s/\015\012/\n/sgo;
+ ${*$data} .= $readbuf;
+
+ unless (length(${*$data})) {
+
+ redo READ
+ if($n > 0);
+
+ $size = length(${*$data})
+ if($n == 0);
+ }
+ }
+ }
+
+ $buf = substr(${*$data},0,$size);
+ substr(${*$data},0,$size) = '';
+
+ length $buf;
+ }
+
+ sub write {
+ my $data = shift;
+ local *buf = \$_[0]; shift;
+ my $size = shift || croak 'write($buf,$size,[$timeout])';
+ my $timeout = @_ ? shift : $data->timeout;
+
+ $data->can_write($timeout) or
+ croak "Timeout";
+
+ (my $tmp = substr($buf,0,$size)) =~ s/\n/\015\012/sg;
+
+ # If the remote server has closed the connection we will be signal'd
+ # when we write. This can happen if the disk on the remote server fills up
+
+ local $SIG{PIPE} = 'IGNORE';
+
+ my $len = length($tmp);
+ my $off = 0;
+ my $wrote = 0;
+
+ while($len) {
+ $off += $wrote;
+ $wrote = syswrite($data, substr($tmp,$off), $len);
+ return undef
+ unless defined($wrote);
+ $len -= $wrote;
+ }
+
+ $size;
+ }
+
+ 1;
diff -c /dev/null 'perl-5.7.2/lib/Net/FTP/E.pm'
Index: ./lib/Net/FTP/E.pm
*** ./lib/Net/FTP/E.pm Thu Jan 1 02:00:00 1970
--- ./lib/Net/FTP/E.pm Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,7 ----
+ package Net::FTP::E;
+
+ require Net::FTP::I;
+
+ @ISA = qw(Net::FTP::I);
+
+ 1;
diff -c /dev/null 'perl-5.7.2/lib/Net/FTP/I.pm'
Index: ./lib/Net/FTP/I.pm
*** ./lib/Net/FTP/I.pm Thu Jan 1 02:00:00 1970
--- ./lib/Net/FTP/I.pm Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,70 ----
+ ##
+ ## Package to read/write on BINARY data connections
+ ##
+
+ package Net::FTP::I;
+
+ use vars qw(@ISA $buf $VERSION);
+ use Carp;
+
+ require Net::FTP::dataconn;
+
+ @ISA = qw(Net::FTP::dataconn);
+ $VERSION = "1.08"; # $Id: //depot/libnet/Net/FTP/I.pm#6$
+
+ sub read {
+ my $data = shift;
+ local *buf = \$_[0]; shift;
+ my $size = shift || croak 'read($buf,$size,[$timeout])';
+ my $timeout = @_ ? shift : $data->timeout;
+
+ $data->can_read($timeout) or
+ croak "Timeout";
+
+ my($b,$n,$l);
+ my $blksize = ${*$data}{'net_ftp_blksize'};
+ $blksize = $size if $size > $blksize;
+
+ while(($l = length(${*$data})) < $size) {
+ $n += ($b = sysread($data, ${*$data}, $blksize, $l));
+ last unless $b;
+ }
+
+ $n = $size < ($l = length(${*$data})) ? $size : $l;
+
+ $buf = substr(${*$data},0,$n);
+ substr(${*$data},0,$n) = '';
+
+ ${*$data}{'net_ftp_bytesread'} += $n if $n;
+ ${*$data}{'net_ftp_eof'} = 1 unless $n;
+
+ $n;
+ }
+
+ sub write {
+ my $data = shift;
+ local *buf = \$_[0]; shift;
+ my $size = shift || croak 'write($buf,$size,[$timeout])';
+ my $timeout = @_ ? shift : $data->timeout;
+
+ $data->can_write($timeout) or
+ croak "Timeout";
+
+ # If the remote server has closed the connection we will be signal'd
+ # when we write. This can happen if the disk on the remote server fills up
+
+ local $SIG{PIPE} = 'IGNORE';
+ my $sent = $size;
+ my $off = 0;
+
+ while($sent > 0) {
+ my $n = syswrite($data, $buf, $sent,$off);
+ return undef unless defined($n);
+ $sent -= $n;
+ $off += $n;
+ }
+
+ $size;
+ }
+
+ 1;
diff -c /dev/null 'perl-5.7.2/lib/Net/FTP/L.pm'
Index: ./lib/Net/FTP/L.pm
*** ./lib/Net/FTP/L.pm Thu Jan 1 02:00:00 1970
--- ./lib/Net/FTP/L.pm Mon Jul 9 17:10:38 2001
***************
*** 0 ****
--- 1,7 ----
+ package Net::FTP::L;
+
+ require Net::FTP::I;
+
+ @ISA = qw(Net::FTP::I);
+
+ 1;
diff -c /dev/null 'perl-5.7.2/lib/Net/FTP/dataconn.pm'
Index: ./lib/Net/FTP/dataconn.pm
*** ./lib/Net/FTP/dataconn.pm Thu Jan 1 02:00:00 1970
--- ./lib/Net/FTP/dataconn.pm Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,123 ----
+ ##
+ ## Generic data connection package
+ ##
+
+ package Net::FTP::dataconn;
+
+ use Carp;
+ use vars qw(@ISA $timeout);
+ use Net::Cmd;
+
+ @ISA = qw(IO::Socket::INET);
+
+ sub reading
+ {
+ my $data = shift;
+ ${*$data}{'net_ftp_bytesread'} = 0;
+ }
+
+ sub abort
+ {
+ my $data = shift;
+ my $ftp = ${*$data}{'net_ftp_cmd'};
+
+ # no need to abort if we have finished the xfer
+ return $data->close
+ if ${*$data}{'net_ftp_eof'};
+
+ # for some reason if we continously open RETR connections and not
+ # read a single byte, then abort them after a while the server will
+ # close our connection, this prevents the unexpected EOF on the
+ # command channel -- GMB
+ if(exists ${*$data}{'net_ftp_bytesread'}
+ && (${*$data}{'net_ftp_bytesread'} == 0)) {
+ my $buf="";
+ my $timeout = $data->timeout;
+ $data->can_read($timeout) && sysread($data,$buf,1);
+ }
+
+ ${*$data}{'net_ftp_eof'} = 1; # fake
+
+ $ftp->abort; # this will close me
+ }
+
+ sub _close
+ {
+ my $data = shift;
+ my $ftp = ${*$data}{'net_ftp_cmd'};
+
+ $data->SUPER::close();
+
+ delete ${*$ftp}{'net_ftp_dataconn'}
+ if exists ${*$ftp}{'net_ftp_dataconn'} &&
+ $data == ${*$ftp}{'net_ftp_dataconn'};
+ }
+
+ sub close
+ {
+ my $data = shift;
+ my $ftp = ${*$data}{'net_ftp_cmd'};
+
+ if(exists ${*$data}{'net_ftp_bytesread'} && !${*$data}{'net_ftp_eof'}) {
+ my $junk;
+ $data->read($junk,1,0);
+ return $data->abort unless ${*$data}{'net_ftp_eof'};
+ }
+
+ $data->_close;
+
+ $ftp->response() == CMD_OK &&
+ $ftp->message =~ /unique file name:\s*(\S*)\s*\)/ &&
+ (${*$ftp}{'net_ftp_unique'} = $1);
+
+ $ftp->status == CMD_OK;
+ }
+
+ sub _select
+ {
+ my $data = shift;
+ local *timeout = \$_[0]; shift;
+ my $rw = shift;
+
+ my($rin,$win);
+
+ return 1 unless $timeout;
+
+ $rin = '';
+ vec($rin,fileno($data),1) = 1;
+
+ $win = $rw ? undef : $rin;
+ $rin = undef unless $rw;
+
+ my $nfound = select($rin, $win, undef, $timeout);
+
+ croak "select: $!"
+ if $nfound < 0;
+
+ return $nfound;
+ }
+
+ sub can_read
+ {
+ my $data = shift;
+ local *timeout = \$_[0];
+
+ $data->_select($timeout,1);
+ }
+
+ sub can_write
+ {
+ my $data = shift;
+ local *timeout = \$_[0];
+
+ $data->_select($timeout,0);
+ }
+
+ sub cmd
+ {
+ my $ftp = shift;
+
+ ${*$ftp}{'net_ftp_cmd'};
+ }
+
+ 1;
diff -c /dev/null 'perl-5.7.2/lib/Net/Hostname.eg'
Index: ./lib/Net/Hostname.eg
*** ./lib/Net/Hostname.eg Thu Jan 1 02:00:00 1970
--- ./lib/Net/Hostname.eg Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,14 ----
+ # This is an example Hostname.pm.
+
+ package Sys::Hostname;
+
+ use Net::Domain qw(hostname);
+ use Carp;
+
+ require Exporter;
+ @ISA = qw(Exporter);
+ @EXPORT = qw(hostname);
+
+ carp "deprecated package 'Sys::Hostname', use Net::Domain" if $^W;
+
+ 1;
diff -c /dev/null 'perl-5.7.2/lib/Net/NNTP.pm'
Index: ./lib/Net/NNTP.pm
*** ./lib/Net/NNTP.pm Thu Jan 1 02:00:00 1970
--- ./lib/Net/NNTP.pm Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,1060 ----
+ # Net::NNTP.pm
+ #
+ # Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ # This program is free software; you can redistribute it and/or
+ # modify it under the same terms as Perl itself.
+
+ package Net::NNTP;
+
+ use strict;
+ use vars qw(@ISA $VERSION $debug);
+ use IO::Socket;
+ use Net::Cmd;
+ use Carp;
+ use Time::Local;
+ use Net::Config;
+
+ $VERSION = "2.19"; # $Id: //depot/libnet/Net/NNTP.pm#8$
+ @ISA = qw(Net::Cmd IO::Socket::INET);
+
+ sub new
+ {
+ my $self = shift;
+ my $type = ref($self) || $self;
+ my $host = shift if @_ % 2;
+ my %arg = @_;
+ my $obj;
+
+ $host ||= $ENV{NNTPSERVER} || $ENV{NEWSHOST};
+
+ my $hosts = defined $host ? [ $host ] : $NetConfig{nntp_hosts};
+
+ @{$hosts} = qw(news)
+ unless @{$hosts};
+
+ my $h;
+ foreach $h (@{$hosts})
+ {
+ $obj = $type->SUPER::new(PeerAddr => ($host = $h),
+ PeerPort => $arg{Port} || 'nntp(119)',
+ Proto => 'tcp',
+ Timeout => defined $arg{Timeout}
+ ? $arg{Timeout}
+ : 120
+ ) and last;
+ }
+
+ return undef
+ unless defined $obj;
+
+ ${*$obj}{'net_nntp_host'} = $host;
+
+ $obj->autoflush(1);
+ $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+
+ unless ($obj->response() == CMD_OK)
+ {
+ $obj->close;
+ return undef;
+ }
+
+ my $c = $obj->code;
+ my @m = $obj->message;
+
+ unless(exists $arg{Reader} && $arg{Reader} == 0) {
+ # if server is INN and we have transfer rights the we are currently
+ # talking to innd not nnrpd
+ if($obj->reader)
+ {
+ # If reader suceeds the we need to consider this code to determine postok
+ $c = $obj->code;
+ }
+ else
+ {
+ # I want to ignore this failure, so restore the previous status.
+ $obj->set_status($c,\@m);
+ }
+ }
+
+ ${*$obj}{'net_nntp_post'} = $c == 200 ? 1 : 0;
+
+ $obj;
+ }
+
+ sub debug_text
+ {
+ my $nntp = shift;
+ my $inout = shift;
+ my $text = shift;
+
+ if(($nntp->code == 350 && $text =~ /^(\S+)/)
+ || ($text =~ /^(authinfo\s+pass)/io))
+ {
+ $text = "$1 ....\n"
+ }
+
+ $text;
+ }
+
+ sub postok
+ {
+ @_ == 1 or croak 'usage: $nntp->postok()';
+ my $nntp = shift;
+ ${*$nntp}{'net_nntp_post'} || 0;
+ }
+
+ sub article
+ {
+ @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->article( [ MSGID ], [ FH ] )';
+ my $nntp = shift;
+ my @fh;
+
+ @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
+
+ $nntp->_ARTICLE(@_)
+ ? $nntp->read_until_dot(@fh)
+ : undef;
+ }
+
+ sub authinfo
+ {
+ @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )';
+ my($nntp,$user,$pass) = @_;
+
+ $nntp->_AUTHINFO("USER",$user) == CMD_MORE
+ && $nntp->_AUTHINFO("PASS",$pass) == CMD_OK;
+ }
+
+ sub authinfo_simple
+ {
+ @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )';
+ my($nntp,$user,$pass) = @_;
+
+ $nntp->_AUTHINFO('SIMPLE') == CMD_MORE
+ && $nntp->command($user,$pass)->response == CMD_OK;
+ }
+
+ sub body
+ {
+ @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->body( [ MSGID ], [ FH ] )';
+ my $nntp = shift;
+ my @fh;
+
+ @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
+
+ $nntp->_BODY(@_)
+ ? $nntp->read_until_dot(@fh)
+ : undef;
+ }
+
+ sub head
+ {
+ @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->head( [ MSGID ], [ FH ] )';
+ my $nntp = shift;
+ my @fh;
+
+ @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
+
+ $nntp->_HEAD(@_)
+ ? $nntp->read_until_dot(@fh)
+ : undef;
+ }
+
+ sub nntpstat
+ {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->nntpstat( [ MSGID ] )';
+ my $nntp = shift;
+
+ $nntp->_STAT(@_) && $nntp->message =~ /(<[^>]+>)/o
+ ? $1
+ : undef;
+ }
+
+
+ sub group
+ {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->group( [ GROUP ] )';
+ my $nntp = shift;
+ my $grp = ${*$nntp}{'net_nntp_group'} || undef;
+
+ return $grp
+ unless(@_ || wantarray);
+
+ my $newgrp = shift;
+
+ return wantarray ? () : undef
+ unless $nntp->_GROUP($newgrp || $grp || "")
+ && $nntp->message =~ /(\d+)\s+(\d+)\s+(\d+)\s+(\S+)/;
+
+ my($count,$first,$last,$group) = ($1,$2,$3,$4);
+
+ # group may be replied as '(current group)'
+ $group = ${*$nntp}{'net_nntp_group'}
+ if $group =~ /\(/;
+
+ ${*$nntp}{'net_nntp_group'} = $group;
+
+ wantarray
+ ? ($count,$first,$last,$group)
+ : $group;
+ }
+
+ sub help
+ {
+ @_ == 1 or croak 'usage: $nntp->help()';
+ my $nntp = shift;
+
+ $nntp->_HELP
+ ? $nntp->read_until_dot
+ : undef;
+ }
+
+ sub ihave
+ {
+ @_ >= 2 or croak 'usage: $nntp->ihave( MESSAGE-ID [, MESSAGE ])';
+ my $nntp = shift;
+ my $mid = shift;
+
+ $nntp->_IHAVE($mid) && $nntp->datasend(@_)
+ ? @_ == 0 || $nntp->dataend
+ : undef;
+ }
+
+ sub last
+ {
+ @_ == 1 or croak 'usage: $nntp->last()';
+ my $nntp = shift;
+
+ $nntp->_LAST && $nntp->message =~ /(<[^>]+>)/o
+ ? $1
+ : undef;
+ }
+
+ sub list
+ {
+ @_ == 1 or croak 'usage: $nntp->list()';
+ my $nntp = shift;
+
+ $nntp->_LIST
+ ? $nntp->_grouplist
+ : undef;
+ }
+
+ sub newgroups
+ {
+ @_ >= 2 or croak 'usage: $nntp->newgroups( SINCE [, DISTRIBUTIONS ])';
+ my $nntp = shift;
+ my $time = _timestr(shift);
+ my $dist = shift || "";
+
+ $dist = join(",", @{$dist})
+ if ref($dist);
+
+ $nntp->_NEWGROUPS($time,$dist)
+ ? $nntp->_grouplist
+ : undef;
+ }
+
+ sub newnews
+ {
+ @_ >= 2 && @_ <= 4 or
+ croak 'usage: $nntp->newnews( SINCE [, GROUPS [, DISTRIBUTIONS ]])';
+ my $nntp = shift;
+ my $time = _timestr(shift);
+ my $grp = @_ ? shift : $nntp->group;
+ my $dist = shift || "";
+
+ $grp ||= "*";
+ $grp = join(",", @{$grp})
+ if ref($grp);
+
+ $dist = join(",", @{$dist})
+ if ref($dist);
+
+ $nntp->_NEWNEWS($grp,$time,$dist)
+ ? $nntp->_articlelist
+ : undef;
+ }
+
+ sub next
+ {
+ @_ == 1 or croak 'usage: $nntp->next()';
+ my $nntp = shift;
+
+ $nntp->_NEXT && $nntp->message =~ /(<[^>]+>)/o
+ ? $1
+ : undef;
+ }
+
+ sub post
+ {
+ @_ >= 1 or croak 'usage: $nntp->post( [ MESSAGE ] )';
+ my $nntp = shift;
+
+ $nntp->_POST() && $nntp->datasend(@_)
+ ? @_ == 0 || $nntp->dataend
+ : undef;
+ }
+
+ sub quit
+ {
+ @_ == 1 or croak 'usage: $nntp->quit()';
+ my $nntp = shift;
+
+ $nntp->_QUIT;
+ $nntp->close;
+ }
+
+ sub slave
+ {
+ @_ == 1 or croak 'usage: $nntp->slave()';
+ my $nntp = shift;
+
+ $nntp->_SLAVE;
+ }
+
+ ##
+ ## The following methods are not implemented by all servers
+ ##
+
+ sub active
+ {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->active( [ PATTERN ] )';
+ my $nntp = shift;
+
+ $nntp->_LIST('ACTIVE',@_)
+ ? $nntp->_grouplist
+ : undef;
+ }
+
+ sub active_times
+ {
+ @_ == 1 or croak 'usage: $nntp->active_times()';
+ my $nntp = shift;
+
+ $nntp->_LIST('ACTIVE.TIMES')
+ ? $nntp->_grouplist
+ : undef;
+ }
+
+ sub distributions
+ {
+ @_ == 1 or croak 'usage: $nntp->distributions()';
+ my $nntp = shift;
+
+ $nntp->_LIST('DISTRIBUTIONS')
+ ? $nntp->_description
+ : undef;
+ }
+
+ sub distribution_patterns
+ {
+ @_ == 1 or croak 'usage: $nntp->distributions()';
+ my $nntp = shift;
+
+ my $arr;
+ local $_;
+
+ $nntp->_LIST('DISTRIB.PATS') && ($arr = $nntp->read_until_dot)
+ ? [grep { /^\d/ && (chomp, $_ = [ split /:/ ]) } @$arr]
+ : undef;
+ }
+
+ sub newsgroups
+ {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->newsgroups( [ PATTERN ] )';
+ my $nntp = shift;
+
+ $nntp->_LIST('NEWSGROUPS',@_)
+ ? $nntp->_description
+ : undef;
+ }
+
+ sub overview_fmt
+ {
+ @_ == 1 or croak 'usage: $nntp->overview_fmt()';
+ my $nntp = shift;
+
+ $nntp->_LIST('OVERVIEW.FMT')
+ ? $nntp->_articlelist
+ : undef;
+ }
+
+ sub subscriptions
+ {
+ @_ == 1 or croak 'usage: $nntp->subscriptions()';
+ my $nntp = shift;
+
+ $nntp->_LIST('SUBSCRIPTIONS')
+ ? $nntp->_articlelist
+ : undef;
+ }
+
+ sub listgroup
+ {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->listgroup( [ GROUP ] )';
+ my $nntp = shift;
+
+ $nntp->_LISTGROUP(@_)
+ ? $nntp->_articlelist
+ : undef;
+ }
+
+ sub reader
+ {
+ @_ == 1 or croak 'usage: $nntp->reader()';
+ my $nntp = shift;
+
+ $nntp->_MODE('READER');
+ }
+
+ sub xgtitle
+ {
+ @_ == 1 || @_ == 2 or croak 'usage: $nntp->xgtitle( [ PATTERN ] )';
+ my $nntp = shift;
+
+ $nntp->_XGTITLE(@_)
+ ? $nntp->_description
+ : undef;
+ }
+
+ sub xhdr
+ {
+ @_ >= 2 && @_ <= 4 or croak 'usage: $nntp->xhdr( HEADER, [ MESSAGE-SPEC ] )';
+ my $nntp = shift;
+ my $hdr = shift;
+ my $arg = _msg_arg(@_);
+
+ $nntp->_XHDR($hdr, $arg)
+ ? $nntp->_description
+ : undef;
+ }
+
+ sub xover
+ {
+ @_ == 2 || @_ == 3 or croak 'usage: $nntp->xover( MESSAGE-SPEC )';
+ my $nntp = shift;
+ my $arg = _msg_arg(@_);
+
+ $nntp->_XOVER($arg)
+ ? $nntp->_fieldlist
+ : undef;
+ }
+
+ sub xpat
+ {
+ @_ == 4 || @_ == 5 or croak '$nntp->xpat( HEADER, PATTERN, MESSAGE-SPEC )';
+ my $nntp = shift;
+ my $hdr = shift;
+ my $pat = shift;
+ my $arg = _msg_arg(@_);
+
+ $pat = join(" ", @$pat)
+ if ref($pat);
+
+ $nntp->_XPAT($hdr,$arg,$pat)
+ ? $nntp->_description
+ : undef;
+ }
+
+ sub xpath
+ {
+ @_ == 2 or croak 'usage: $nntp->xpath( MESSAGE-ID )';
+ my($nntp,$mid) = @_;
+
+ return undef
+ unless $nntp->_XPATH($mid);
+
+ my $m; ($m = $nntp->message) =~ s/^\d+\s+//o;
+ my @p = split /\s+/, $m;
+
+ wantarray ? @p : $p[0];
+ }
+
+ sub xrover
+ {
+ @_ == 2 || @_ == 3 or croak 'usage: $nntp->xrover( MESSAGE-SPEC )';
+ my $nntp = shift;
+ my $arg = _msg_arg(@_);
+
+ $nntp->_XROVER($arg)
+ ? $nntp->_description
+ : undef;
+ }
+
+ sub date
+ {
+ @_ == 1 or croak 'usage: $nntp->date()';
+ my $nntp = shift;
+
+ $nntp->_DATE && $nntp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
+ ? timegm($6,$5,$4,$3,$2-1,$1 - 1900)
+ : undef;
+ }
+
+
+ ##
+ ## Private subroutines
+ ##
+
+ sub _msg_arg
+ {
+ my $spec = shift;
+ my $arg = "";
+
+ if(@_)
+ {
+ carp "Depriciated passing of two message numbers, "
+ . "pass a reference"
+ if $^W;
+ $spec = [ $spec, $_[0] ];
+ }
+
+ if(defined $spec)
+ {
+ if(ref($spec))
+ {
+ $arg = $spec->[0] . "-";
+ $arg .= $spec->[1]
+ if defined $spec->[1] && $spec->[1] > $spec->[0];
+ }
+ else
+ {
+ $arg = $spec;
+ }
+ }
+
+ $arg;
+ }
+
+ sub _timestr
+ {
+ my $time = shift;
+ my @g = reverse((gmtime($time))[0..5]);
+ $g[1] += 1;
+ $g[0] %= 100;
+ sprintf "%02d%02d%02d %02d%02d%02d GMT", @g;
+ }
+
+ sub _grouplist
+ {
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot or
+ return undef;
+
+ my $hash = {};
+ my $ln;
+
+ foreach $ln (@$arr)
+ {
+ my @a = split(/[\s\n]+/,$ln);
+ $hash->{$a[0]} = [ @a[1,2,3] ];
+ }
+
+ $hash;
+ }
+
+ sub _fieldlist
+ {
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot or
+ return undef;
+
+ my $hash = {};
+ my $ln;
+
+ foreach $ln (@$arr)
+ {
+ my @a = split(/[\t\n]/,$ln);
+ my $m = shift @a;
+ $hash->{$m} = [ @a ];
+ }
+
+ $hash;
+ }
+
+ sub _articlelist
+ {
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot;
+
+ chomp(@$arr)
+ if $arr;
+
+ $arr;
+ }
+
+ sub _description
+ {
+ my $nntp = shift;
+ my $arr = $nntp->read_until_dot or
+ return undef;
+
+ my $hash = {};
+ my $ln;
+
+ foreach $ln (@$arr)
+ {
+ chomp($ln);
+
+ $hash->{$1} = $ln
+ if $ln =~ s/^\s*(\S+)\s*//o;
+ }
+
+ $hash;
+
+ }
+
+ ##
+ ## The commands
+ ##
+
+ sub _ARTICLE { shift->command('ARTICLE',@_)->response == CMD_OK }
+ sub _AUTHINFO { shift->command('AUTHINFO',@_)->response }
+ sub _BODY { shift->command('BODY',@_)->response == CMD_OK }
+ sub _DATE { shift->command('DATE')->response == CMD_INFO }
+ sub _GROUP { shift->command('GROUP',@_)->response == CMD_OK }
+ sub _HEAD { shift->command('HEAD',@_)->response == CMD_OK }
+ sub _HELP { shift->command('HELP',@_)->response == CMD_INFO }
+ sub _IHAVE { shift->command('IHAVE',@_)->response == CMD_MORE }
+ sub _LAST { shift->command('LAST')->response == CMD_OK }
+ sub _LIST { shift->command('LIST',@_)->response == CMD_OK }
+ sub _LISTGROUP { shift->command('LISTGROUP',@_)->response == CMD_OK }
+ sub _NEWGROUPS { shift->command('NEWGROUPS',@_)->response == CMD_OK }
+ sub _NEWNEWS { shift->command('NEWNEWS',@_)->response == CMD_OK }
+ sub _NEXT { shift->command('NEXT')->response == CMD_OK }
+ sub _POST { shift->command('POST',@_)->response == CMD_MORE }
+ sub _QUIT { shift->command('QUIT',@_)->response == CMD_OK }
+ sub _SLAVE { shift->command('SLAVE',@_)->response == CMD_OK }
+ sub _STAT { shift->command('STAT',@_)->response == CMD_OK }
+ sub _MODE { shift->command('MODE',@_)->response == CMD_OK }
+ sub _XGTITLE { shift->command('XGTITLE',@_)->response == CMD_OK }
+ sub _XHDR { shift->command('XHDR',@_)->response == CMD_OK }
+ sub _XPAT { shift->command('XPAT',@_)->response == CMD_OK }
+ sub _XPATH { shift->command('XPATH',@_)->response == CMD_OK }
+ sub _XOVER { shift->command('XOVER',@_)->response == CMD_OK }
+ sub _XROVER { shift->command('XROVER',@_)->response == CMD_OK }
+ sub _XTHREAD { shift->unsupported }
+ sub _XSEARCH { shift->unsupported }
+ sub _XINDEX { shift->unsupported }
+
+ ##
+ ## IO/perl methods
+ ##
+
+ sub DESTROY
+ {
+ my $nntp = shift;
+ defined(fileno($nntp)) && $nntp->quit
+ }
+
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ Net::NNTP - NNTP Client class
+
+ =head1 SYNOPSIS
+
+ use Net::NNTP;
+
+ $nntp = Net::NNTP->new("some.host.name");
+ $nntp->quit;
+
+ =head1 DESCRIPTION
+
+ C<Net::NNTP> is a class implementing a simple NNTP client in Perl as described
+ in RFC977. C<Net::NNTP> inherits its communication methods from C<Net::Cmd>
+
+ =head1 CONSTRUCTOR
+
+ =over 4
+
+ =item new ( [ HOST ] [, OPTIONS ])
+
+ This is the constructor for a new Net::NNTP object. C<HOST> is the
+ name of the remote host to which a NNTP connection is required. If not
+ given two environment variables are checked, first C<NNTPSERVER> then
+ C<NEWSHOST>, then C<Net::Config> is checked, and if a host is not found
+ then C<news> is used.
+
+ C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
+ Possible options are:
+
+ B<Timeout> - Maximum time, in seconds, to wait for a response from the
+ NNTP server, a value of zero will cause all IO operations to block.
+ (default: 120)
+
+ B<Debug> - Enable the printing of debugging information to STDERR
+
+ B<Reader> - If the remote server is INN then initially the connection
+ will be to nnrpd, by default C<Net::NNTP> will issue a C<MODE READER> command
+ so that the remote server becomes innd. If the C<Reader> option is given
+ with a value of zero, then this command will not be sent and the
+ connection will be left talking to nnrpd.
+
+ =back
+
+ =head1 METHODS
+
+ Unless otherwise stated all methods return either a I<true> or I<false>
+ value, with I<true> meaning that the operation was a success. When a method
+ states that it returns a value, failure will be returned as I<undef> or an
+ empty list.
+
+ =over 4
+
+ =item article ( [ MSGID|MSGNUM ], [FH] )
+
+ Retrieve the header, a blank line, then the body (text) of the
+ specified article.
+
+ If C<FH> is specified then it is expected to be a valid filehandle
+ and the result will be printed to it, on sucess a true value will be
+ returned. If C<FH> is not specified then the return value, on sucess,
+ will be a reference to an array containg the article requested, each
+ entry in the array will contain one line of the article.
+
+ If no arguments are passed then the current article in the currently
+ selected newsgroup is fetched.
+
+ C<MSGNUM> is a numeric id of an article in the current newsgroup, and
+ will change the current article pointer. C<MSGID> is the message id of
+ an article as shown in that article's header. It is anticipated that the
+ client will obtain the C<MSGID> from a list provided by the C<newnews>
+ command, from references contained within another article, or from the
+ message-id provided in the response to some other commands.
+
+ If there is an error then C<undef> will be returned.
+
+ =item body ( [ MSGID|MSGNUM ], [FH] )
+
+ Like C<article> but only fetches the body of the article.
+
+ =item head ( [ MSGID|MSGNUM ], [FH] )
+
+ Like C<article> but only fetches the headers for the article.
+
+ =item nntpstat ( [ MSGID|MSGNUM ] )
+
+ The C<nntpstat> command is similar to the C<article> command except that no
+ text is returned. When selecting by message number within a group,
+ the C<nntpstat> command serves to set the "current article pointer" without
+ sending text.
+
+ Using the C<nntpstat> command to
+ select by message-id is valid but of questionable value, since a
+ selection by message-id does B<not> alter the "current article pointer".
+
+ Returns the message-id of the "current article".
+
+ =item group ( [ GROUP ] )
+
+ Set and/or get the current group. If C<GROUP> is not given then information
+ is returned on the current group.
+
+ In a scalar context it returns the group name.
+
+ In an array context the return value is a list containing, the number
+ of articles in the group, the number of the first article, the number
+ of the last article and the group name.
+
+ =item ihave ( MSGID [, MESSAGE ])
+
+ The C<ihave> command informs the server that the client has an article
+ whose id is C<MSGID>. If the server desires a copy of that
+ article, and C<MESSAGE> has been given the it will be sent.
+
+ Returns I<true> if the server desires the article and C<MESSAGE> was
+ successfully sent,if specified.
+
+ If C<MESSAGE> is not specified then the message must be sent using the
+ C<datasend> and C<dataend> methods from L<Net::Cmd>
+
+ C<MESSAGE> can be either an array of lines or a reference to an array.
+
+ =item last ()
+
+ Set the "current article pointer" to the previous article in the current
+ newsgroup.
+
+ Returns the message-id of the article.
+
+ =item date ()
+
+ Returns the date on the remote server. This date will be in a UNIX time
+ format (seconds since 1970)
+
+ =item postok ()
+
+ C<postok> will return I<true> if the servers initial response indicated
+ that it will allow posting.
+
+ =item authinfo ( USER, PASS )
+
+ =item list ()
+
+ Obtain information about all the active newsgroups. The results is a reference
+ to a hash where the key is a group name and each value is a reference to an
+ array. The elements in this array are:- the first article number in the group,
+ the last article number in the group and any information flags about the group.
+
+ =item newgroups ( SINCE [, DISTRIBUTIONS ])
+
+ C<SINCE> is a time value and C<DISTRIBUTIONS> is either a distribution
+ pattern or a reference to a list of distribution patterns.
+ The result is the same as C<list>, but the
+ groups return will be limited to those created after C<SINCE> and, if
+ specified, in one of the distribution areas in C<DISTRIBUTIONS>.
+
+ =item newnews ( SINCE [, GROUPS [, DISTRIBUTIONS ]])
+
+ C<SINCE> is a time value. C<GROUPS> is either a group pattern or a reference
+ to a list of group patterns. C<DISTRIBUTIONS> is either a distribution
+ pattern or a reference to a list of distribution patterns.
+
+ Returns a reference to a list which contains the message-ids of all news posted
+ after C<SINCE>, that are in a groups which matched C<GROUPS> and a
+ distribution which matches C<DISTRIBUTIONS>.
+
+ =item next ()
+
+ Set the "current article pointer" to the next article in the current
+ newsgroup.
+
+ Returns the message-id of the article.
+
+ =item post ( [ MESSAGE ] )
+
+ Post a new article to the news server. If C<MESSAGE> is specified and posting
+ is allowed then the message will be sent.
+
+ If C<MESSAGE> is not specified then the message must be sent using the
+ C<datasend> and C<dataend> methods from L<Net::Cmd>
+
+ C<MESSAGE> can be either an array of lines or a reference to an array.
+
+ =item slave ()
+
+ Tell the remote server that I am not a user client, but probably another
+ news server.
+
+ =item quit ()
+
+ Quit the remote server and close the socket connection.
+
+ =back
+
+ =head2 Extension methods
+
+ These methods use commands that are not part of the RFC977 documentation. Some
+ servers may not support all of them.
+
+ =over 4
+
+ =item newsgroups ( [ PATTERN ] )
+
+ Returns a reference to a hash where the keys are all the group names which
+ match C<PATTERN>, or all of the groups if no pattern is specified, and
+ each value contains the description text for the group.
+
+ =item distributions ()
+
+ Returns a reference to a hash where the keys are all the possible
+ distribution names and the values are the distribution descriptions.
+
+ =item subscriptions ()
+
+ Returns a reference to a list which contains a list of groups which
+ are recommended for a new user to subscribe to.
+
+ =item overview_fmt ()
+
+ Returns a reference to an array which contain the names of the fields returned
+ by C<xover>.
+
+ =item active_times ()
+
+ Returns a reference to a hash where the keys are the group names and each
+ value is a reference to an array containing the time the groups was created
+ and an identifier, possibly an Email address, of the creator.
+
+ =item active ( [ PATTERN ] )
+
+ Similar to C<list> but only active groups that match the pattern are returned.
+ C<PATTERN> can be a group pattern.
+
+ =item xgtitle ( PATTERN )
+
+ Returns a reference to a hash where the keys are all the group names which
+ match C<PATTERN> and each value is the description text for the group.
+
+ =item xhdr ( HEADER, MESSAGE-SPEC )
+
+ Obtain the header field C<HEADER> for all the messages specified.
+
+ The return value will be a reference
+ to a hash where the keys are the message numbers and each value contains
+ the text of the requested header for that message.
+
+ =item xover ( MESSAGE-SPEC )
+
+ The return value will be a reference
+ to a hash where the keys are the message numbers and each value contains
+ a reference to an array which contains the overview fields for that
+ message.
+
+ The names of the fields can be obtained by calling C<overview_fmt>.
+
+ =item xpath ( MESSAGE-ID )
+
+ Returns the path name to the file on the server which contains the specified
+ message.
+
+ =item xpat ( HEADER, PATTERN, MESSAGE-SPEC)
+
+ The result is the same as C<xhdr> except the is will be restricted to
+ headers where the text of the header matches C<PATTERN>
+
+ =item xrover
+
+ The XROVER command returns reference information for the article(s)
+ specified.
+
+ Returns a reference to a HASH where the keys are the message numbers and the
+ values are the References: lines from the articles
+
+ =item listgroup ( [ GROUP ] )
+
+ Returns a reference to a list of all the active messages in C<GROUP>, or
+ the current group if C<GROUP> is not specified.
+
+ =item reader
+
+ Tell the server that you are a reader and not another server.
+
+ This is required by some servers. For example if you are connecting to
+ an INN server and you have transfer permission your connection will
+ be connected to the transfer daemon, not the NNTP daemon. Issuing
+ this command will cause the transfer daemon to hand over control
+ to the NNTP daemon.
+
+ Some servers do not understand this command, but issuing it and ignoring
+ the response is harmless.
+
+ =back
+
+ =head1 UNSUPPORTED
+
+ The following NNTP command are unsupported by the package, and there are
+ no plans to do so.
+
+ AUTHINFO GENERIC
+ XTHREAD
+ XSEARCH
+ XINDEX
+
+ =head1 DEFINITIONS
+
+ =over 4
+
+ =item MESSAGE-SPEC
+
+ C<MESSAGE-SPEC> is either a single message-id, a single message number, or
+ a reference to a list of two message numbers.
+
+ If C<MESSAGE-SPEC> is a reference to a list of two message numbers and the
+ second number in a range is less than or equal to the first then the range
+ represents all messages in the group after the first message number.
+
+ B<NOTE> For compatibility reasons only with earlier versions of Net::NNTP
+ a message spec can be passed as a list of two numbers, this is deprecated
+ and a reference to the list should now be passed
+
+ =item PATTERN
+
+ The C<NNTP> protocol uses the C<WILDMAT> format for patterns.
+ The WILDMAT format was first developed by Rich Salz based on
+ the format used in the UNIX "find" command to articulate
+ file names. It was developed to provide a uniform mechanism
+ for matching patterns in the same manner that the UNIX shell
+ matches filenames.
+
+ Patterns are implicitly anchored at the
+ beginning and end of each string when testing for a match.
+
+ There are five pattern matching operations other than a strict
+ one-to-one match between the pattern and the source to be
+ checked for a match.
+
+ The first is an asterisk C<*> to match any sequence of zero or more
+ characters.
+
+ The second is a question mark C<?> to match any single character. The
+ third specifies a specific set of characters.
+
+ The set is specified as a list of characters, or as a range of characters
+ where the beginning and end of the range are separated by a minus (or dash)
+ character, or as any combination of lists and ranges. The dash can
+ also be included in the set as a character it if is the beginning
+ or end of the set. This set is enclosed in square brackets. The
+ close square bracket C<]> may be used in a set if it is the first
+ character in the set.
+
+ The fourth operation is the same as the
+ logical not of the third operation and is specified the same
+ way as the third with the addition of a caret character C<^> at
+ the beginning of the test string just inside the open square
+ bracket.
+
+ The final operation uses the backslash character to
+ invalidate the special meaning of the a open square bracket C<[>,
+ the asterisk, backslash or the question mark. Two backslashes in
+ sequence will result in the evaluation of the backslash as a
+ character with no special meaning.
+
+ =over 4
+
+ =item Examples
+
+ =item C<[^]-]>
+
+ matches any single character other than a close square
+ bracket or a minus sign/dash.
+
+ =item C<*bdc>
+
+ matches any string that ends with the string "bdc"
+ including the string "bdc" (without quotes).
+
+ =item C<[0-9a-zA-Z]>
+
+ matches any single printable alphanumeric ASCII character.
+
+ =item C<a??d>
+
+ matches any four character string which begins
+ with a and ends with d.
+
+ =back
+
+ =back
+
+ =head1 SEE ALSO
+
+ L<Net::Cmd>
+
+ =head1 AUTHOR
+
+ Graham Barr <gbarr@pobox.com>
+
+ =head1 COPYRIGHT
+
+ Copyright (c) 1995-1997 Graham Barr. All rights reserved.
+ This program is free software; you can redistribute it and/or modify
+ it under the same terms as Perl itself.
+
+ =cut
diff -c /dev/null 'perl-5.7.2/lib/Net/Netrc.pm'
Index: ./lib/Net/Netrc.pm
*** ./lib/Net/Netrc.pm Thu Jan 1 02:00:00 1970
--- ./lib/Net/Netrc.pm Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,326 ----
+ # Net::Netrc.pm
+ #
+ # Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ # This program is free software; you can redistribute it and/or
+ # modify it under the same terms as Perl itself.
+
+ package Net::Netrc;
+
+ use Carp;
+ use strict;
+ use FileHandle;
+ use vars qw($VERSION);
+
+ $VERSION = "2.10"; # $Id: //depot/libnet/Net/Netrc.pm#4$
+
+ my %netrc = ();
+
+ sub _readrc
+ {
+ my $host = shift;
+ my($home,$file);
+
+ if($^O eq "MacOS") {
+ $home = $ENV{HOME} || `pwd`;
+ chomp($home);
+ $file = ($home =~ /:$/ ? $home . "netrc" : $home . ":netrc");
+ } else {
+ # Some OS's don't have `getpwuid', so we default to $ENV{HOME}
+ $home = eval { (getpwuid($>))[7] } || $ENV{HOME};
+ $file = $home . "/.netrc";
+ }
+
+ my($login,$pass,$acct) = (undef,undef,undef);
+ my $fh;
+ local $_;
+
+ $netrc{default} = undef;
+
+ # OS/2 and Win32 do not handle stat in a way compatable with this check :-(
+ unless($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'MacOS')
+ {
+ my @stat = stat($file);
+
+ if(@stat)
+ {
+ if($stat[2] & 077)
+ {
+ carp "Bad permissions: $file";
+ return;
+ }
+ if($stat[4] != $<)
+ {
+ carp "Not owner: $file";
+ return;
+ }
+ }
+ }
+
+ if($fh = FileHandle->new($file,"r"))
+ {
+ my($mach,$macdef,$tok,@tok) = (0,0);
+
+ while(<$fh>)
+ {
+ undef $macdef if /\A\n\Z/;
+
+ if($macdef)
+ {
+ push(@$macdef,$_);
+ next;
+ }
+
+ s/^\s*//;
+ chomp;
+ push(@tok, $+)
+ while(length && s/^("([^"]*)"|(\S+))\s*//);
+
+ TOKEN:
+ while(@tok)
+ {
+ if($tok[0] eq "default")
+ {
+ shift(@tok);
+ $mach = bless {};
+ $netrc{default} = [$mach];
+
+ next TOKEN;
+ }
+
+ last TOKEN
+ unless @tok > 1;
+
+ $tok = shift(@tok);
+
+ if($tok eq "machine")
+ {
+ my $host = shift @tok;
+ $mach = bless {machine => $host};
+
+ $netrc{$host} = []
+ unless exists($netrc{$host});
+ push(@{$netrc{$host}}, $mach);
+ }
+ elsif($tok =~ /^(login|password|account)$/)
+ {
+ next TOKEN unless $mach;
+ my $value = shift @tok;
+ # Following line added by rmerrell to remove '/' escape char in .netrc
+ $value =~ s/\/\\/\\/g;
+ $mach->{$1} = $value;
+ }
+ elsif($tok eq "macdef")
+ {
+ next TOKEN unless $mach;
+ my $value = shift @tok;
+ $mach->{macdef} = {}
+ unless exists $mach->{macdef};
+ $macdef = $mach->{machdef}{$value} = [];
+ }
+ }
+ }
+ $fh->close();
+ }
+ }
+
+ sub lookup
+ {
+ my($pkg,$mach,$login) = @_;
+
+ _readrc()
+ unless exists $netrc{default};
+
+ $mach ||= 'default';
+ undef $login
+ if $mach eq 'default';
+
+ if(exists $netrc{$mach})
+ {
+ if(defined $login)
+ {
+ my $m;
+ foreach $m (@{$netrc{$mach}})
+ {
+ return $m
+ if(exists $m->{login} && $m->{login} eq $login);
+ }
+ return undef;
+ }
+ return $netrc{$mach}->[0]
+ }
+
+ return $netrc{default}->[0]
+ if defined $netrc{default};
+
+ return undef;
+ }
+
+ sub login
+ {
+ my $me = shift;
+
+ exists $me->{login}
+ ? $me->{login}
+ : undef;
+ }
+
+ sub account
+ {
+ my $me = shift;
+
+ exists $me->{account}
+ ? $me->{account}
+ : undef;
+ }
+
+ sub password
+ {
+ my $me = shift;
+
+ exists $me->{password}
+ ? $me->{password}
+ : undef;
+ }
+
+ sub lpa
+ {
+ my $me = shift;
+ ($me->login, $me->password, $me->account);
+ }
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ Net::Netrc - OO interface to users netrc file
+
+ =head1 SYNOPSIS
+
+ use Net::Netrc;
+
+ $mach = Net::Netrc->lookup('some.machine');
+ $login = $mach->login;
+ ($login, $password, $account) = $mach->lpa;
+
+ =head1 DESCRIPTION
+
+ C<Net::Netrc> is a class implementing a simple interface to the .netrc file
+ used as by the ftp program.
+
+ C<Net::Netrc> also implements security checks just like the ftp program,
+ these checks are, first that the .netrc file must be owned by the user and
+ second the ownership permissions should be such that only the owner has
+ read and write access. If these conditions are not met then a warning is
+ output and the .netrc file is not read.
+
+ =head1 THE .netrc FILE
+
+ The .netrc file contains login and initialization information used by the
+ auto-login process. It resides in the user's home directory. The following
+ tokens are recognized; they may be separated by spaces, tabs, or new-lines:
+
+ =over 4
+
+ =item machine name
+
+ Identify a remote machine name. The auto-login process searches
+ the .netrc file for a machine token that matches the remote machine
+ specified. Once a match is made, the subsequent .netrc tokens
+ are processed, stopping when the end of file is reached or an-
+ other machine or a default token is encountered.
+
+ =item default
+
+ This is the same as machine name except that default matches
+ any name. There can be only one default token, and it must be
+ after all machine tokens. This is normally used as:
+
+ default login anonymous password user@site
+
+ thereby giving the user automatic anonymous login to machines
+ not specified in .netrc.
+
+ =item login name
+
+ Identify a user on the remote machine. If this token is present,
+ the auto-login process will initiate a login using the
+ specified name.
+
+ =item password string
+
+ Supply a password. If this token is present, the auto-login
+ process will supply the specified string if the remote server
+ requires a password as part of the login process.
+
+ =item account string
+
+ Supply an additional account password. If this token is present,
+ the auto-login process will supply the specified string
+ if the remote server requires an additional account password.
+
+ =item macdef name
+
+ Define a macro. C<Net::Netrc> only parses this field to be compatible
+ with I<ftp>.
+
+ =back
+
+ =head1 CONSTRUCTOR
+
+ The constructor for a C<Net::Netrc> object is not called new as it does not
+ really create a new object. But instead is called C<lookup> as this is
+ essentially what it does.
+
+ =over 4
+
+ =item lookup ( MACHINE [, LOGIN ])
+
+ Lookup and return a reference to the entry for C<MACHINE>. If C<LOGIN> is given
+ then the entry returned will have the given login. If C<LOGIN> is not given then
+ the first entry in the .netrc file for C<MACHINE> will be returned.
+
+ If a matching entry cannot be found, and a default entry exists, then a
+ reference to the default entry is returned.
+
+ =back
+
+ =head1 METHODS
+
+ =over 4
+
+ =item login ()
+
+ Return the login id for the netrc entry
+
+ =item password ()
+
+ Return the password for the netrc entry
+
+ =item account ()
+
+ Return the account information for the netrc entry
+
+ =item lpa ()
+
+ Return a list of login, password and account information fir the netrc entry
+
+ =back
+
+ =head1 AUTHOR
+
+ Graham Barr <gbarr@pobox.com>
+
+ =head1 SEE ALSO
+
+ L<Net::Netrc>
+ L<Net::Cmd>
+
+ =head1 COPYRIGHT
+
+ Copyright (c) 1995-1998 Graham Barr. All rights reserved.
+ This program is free software; you can redistribute it and/or modify
+ it under the same terms as Perl itself.
+
+ =cut
diff -c /dev/null 'perl-5.7.2/lib/Net/POP3.pm'
Index: ./lib/Net/POP3.pm
*** ./lib/Net/POP3.pm Thu Jan 1 02:00:00 1970
--- ./lib/Net/POP3.pm Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,521 ----
+ # Net::POP3.pm
+ #
+ # Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ # This program is free software; you can redistribute it and/or
+ # modify it under the same terms as Perl itself.
+
+ package Net::POP3;
+
+ use strict;
+ use IO::Socket;
+ use vars qw(@ISA $VERSION $debug);
+ use Net::Cmd;
+ use Carp;
+ use Net::Config;
+
+ $VERSION = "2.21"; # $Id$
+
+ @ISA = qw(Net::Cmd IO::Socket::INET);
+
+ sub new
+ {
+ my $self = shift;
+ my $type = ref($self) || $self;
+ my $host = shift if @_ % 2;
+ my %arg = @_;
+ my $hosts = defined $host ? [ $host ] : $NetConfig{pop3_hosts};
+ my $obj;
+ my @localport = exists $arg{ResvPort} ? ( LocalPort => $arg{ResvPort} ): ();
+
+ my $h;
+ foreach $h (@{$hosts})
+ {
+ $obj = $type->SUPER::new(PeerAddr => ($host = $h),
+ PeerPort => $arg{Port} || 'pop3(110)',
+ Proto => 'tcp',
+ @localport,
+ Timeout => defined $arg{Timeout}
+ ? $arg{Timeout}
+ : 120
+ ) and last;
+ }
+
+ return undef
+ unless defined $obj;
+
+ ${*$obj}{'net_pop3_host'} = $host;
+
+ $obj->autoflush(1);
+ $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+
+ unless ($obj->response() == CMD_OK)
+ {
+ $obj->close();
+ return undef;
+ }
+
+ ${*$obj}{'net_pop3_banner'} = $obj->message;
+
+ $obj;
+ }
+
+ ##
+ ## We don't want people sending me their passwords when they report problems
+ ## now do we :-)
+ ##
+
+ sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; }
+
+ sub login
+ {
+ @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )';
+ my($me,$user,$pass) = @_;
+
+ if(@_ <= 2)
+ {
+ require Net::Netrc;
+
+ $user ||= eval { (getpwuid($>))[0] } || $ENV{NAME};
+
+ my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user);
+
+ $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
+
+ $pass = $m ? $m->password || ""
+ : "";
+ }
+
+ $me->user($user) and
+ $me->pass($pass);
+ }
+
+ sub apop
+ {
+ @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )';
+ my($me,$user,$pass) = @_;
+ my $banner;
+
+ unless(eval { require MD5 })
+ {
+ carp "You need to install MD5 to use the APOP command";
+ return undef;
+ }
+
+ return undef
+ unless ( $banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0] );
+
+ if(@_ <= 2)
+ {
+ require Net::Netrc;
+
+ $user ||= eval { (getpwuid($>))[0] } || $ENV{NAME};
+
+ my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user);
+
+ $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
+
+ $pass = $m ? $m->password || ""
+ : "";
+ }
+
+ my $md = new MD5;
+ $md->add($banner,$pass);
+
+ return undef
+ unless($me->_APOP($user,$md->hexdigest));
+
+ my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io)
+ ? $1 : ($me->popstat)[0];
+
+ $ret ? $ret : "0E0";
+ }
+
+ sub user
+ {
+ @_ == 2 or croak 'usage: $pop3->user( USER )';
+ $_[0]->_USER($_[1]) ? 1 : undef;
+ }
+
+ sub pass
+ {
+ @_ == 2 or croak 'usage: $pop3->pass( PASS )';
+
+ my($me,$pass) = @_;
+
+ return undef
+ unless($me->_PASS($pass));
+
+ my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io)
+ ? $1 : ($me->popstat)[0];
+
+ $ret ? $ret : "0E0";
+ }
+
+ sub reset
+ {
+ @_ == 1 or croak 'usage: $obj->reset()';
+
+ my $me = shift;
+
+ return 0
+ unless($me->_RSET);
+
+ if(defined ${*$me}{'net_pop3_mail'})
+ {
+ local $_;
+ foreach (@{${*$me}{'net_pop3_mail'}})
+ {
+ delete $_->{'net_pop3_deleted'};
+ }
+ }
+ }
+
+ sub last
+ {
+ @_ == 1 or croak 'usage: $obj->last()';
+
+ return undef
+ unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/;
+
+ return $1;
+ }
+
+ sub top
+ {
+ @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])';
+ my $me = shift;
+
+ return undef
+ unless $me->_TOP($_[0], $_[1] || 0);
+
+ $me->read_until_dot;
+ }
+
+ sub popstat
+ {
+ @_ == 1 or croak 'usage: $pop3->popstat()';
+ my $me = shift;
+
+ return ()
+ unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/;
+
+ ($1 || 0, $2 || 0);
+ }
+
+ sub list
+ {
+ @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )';
+ my $me = shift;
+
+ return undef
+ unless $me->_LIST(@_);
+
+ if(@_)
+ {
+ $me->message =~ /\d+\D+(\d+)/;
+ return $1 || undef;
+ }
+
+ my $info = $me->read_until_dot
+ or return undef;
+
+ my %hash = map { (/(\d+)\D+(\d+)/) } @$info;
+
+ return \%hash;
+ }
+
+ sub get
+ {
+ @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])';
+ my $me = shift;
+
+ return undef
+ unless $me->_RETR(shift);
+
+ $me->read_until_dot(@_);
+ }
+
+ sub delete
+ {
+ @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';
+ $_[0]->_DELE($_[1]);
+ }
+
+ sub uidl
+ {
+ @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )';
+ my $me = shift;
+ my $uidl;
+
+ $me->_UIDL(@_) or
+ return undef;
+ if(@_)
+ {
+ $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0];
+ }
+ else
+ {
+ my $ref = $me->read_until_dot
+ or return undef;
+ my $ln;
+ $uidl = {};
+ foreach $ln (@$ref) {
+ my($msg,$uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/;
+ $uidl->{$msg} = $uid;
+ }
+ }
+ return $uidl;
+ }
+
+ sub ping
+ {
+ @_ == 2 or croak 'usage: $pop3->ping( USER )';
+ my $me = shift;
+
+ return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/;
+
+ ($1 || 0, $2 || 0);
+ }
+
+
+ sub _STAT { shift->command('STAT')->response() == CMD_OK }
+ sub _LIST { shift->command('LIST',@_)->response() == CMD_OK }
+ sub _RETR { shift->command('RETR',$_[0])->response() == CMD_OK }
+ sub _DELE { shift->command('DELE',$_[0])->response() == CMD_OK }
+ sub _NOOP { shift->command('NOOP')->response() == CMD_OK }
+ sub _RSET { shift->command('RSET')->response() == CMD_OK }
+ sub _QUIT { shift->command('QUIT')->response() == CMD_OK }
+ sub _TOP { shift->command('TOP', @_)->response() == CMD_OK }
+ sub _UIDL { shift->command('UIDL',@_)->response() == CMD_OK }
+ sub _USER { shift->command('USER',$_[0])->response() == CMD_OK }
+ sub _PASS { shift->command('PASS',$_[0])->response() == CMD_OK }
+ sub _APOP { shift->command('APOP',@_)->response() == CMD_OK }
+ sub _PING { shift->command('PING',$_[0])->response() == CMD_OK }
+
+ sub _RPOP { shift->command('RPOP',$_[0])->response() == CMD_OK }
+ sub _LAST { shift->command('LAST')->response() == CMD_OK }
+
+ sub quit
+ {
+ my $me = shift;
+
+ $me->_QUIT;
+ $me->close;
+ }
+
+ sub DESTROY
+ {
+ my $me = shift;
+
+ if(defined fileno($me))
+ {
+ $me->reset;
+ $me->quit;
+ }
+ }
+
+ ##
+ ## POP3 has weird responses, so we emulate them to look the same :-)
+ ##
+
+ sub response
+ {
+ my $cmd = shift;
+ my $str = $cmd->getline() || return undef;
+ my $code = "500";
+
+ $cmd->debug_print(0,$str)
+ if ($cmd->debug);
+
+ if($str =~ s/^\+OK\s+//io)
+ {
+ $code = "200"
+ }
+ else
+ {
+ $str =~ s/^-ERR\s+//io;
+ }
+
+ ${*$cmd}{'net_cmd_resp'} = [ $str ];
+ ${*$cmd}{'net_cmd_code'} = $code;
+
+ substr($code,0,1);
+ }
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ Net::POP3 - Post Office Protocol 3 Client class (RFC1081)
+
+ =head1 SYNOPSIS
+
+ use Net::POP3;
+
+ # Constructors
+ $pop = Net::POP3->new('pop3host');
+ $pop = Net::POP3->new('pop3host', Timeout => 60);
+
+ =head1 DESCRIPTION
+
+ This module implements a client interface to the POP3 protocol, enabling
+ a perl5 application to talk to POP3 servers. This documentation assumes
+ that you are familiar with the POP3 protocol described in RFC1081.
+
+ A new Net::POP3 object must be created with the I<new> method. Once
+ this has been done, all POP3 commands are accessed via method calls
+ on the object.
+
+ =head1 EXAMPLES
+
+ Need some small examples in here :-)
+
+ =head1 CONSTRUCTOR
+
+ =over 4
+
+ =item new ( [ HOST, ] [ OPTIONS ] )
+
+ This is the constructor for a new Net::POP3 object. C<HOST> is the
+ name of the remote host to which a POP3 connection is required.
+
+ If C<HOST> is not given, then the C<POP3_Host> specified in C<Net::Config>
+ will be used.
+
+ C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
+ Possible options are:
+
+ B<ResvPort> - If given then the socket for the C<Net::POP3> object
+ will be bound to the local port given using C<bind> when the socket is
+ created.
+
+ B<Timeout> - Maximum time, in seconds, to wait for a response from the
+ POP3 server (default: 120)
+
+ B<Debug> - Enable debugging information
+
+ =back
+
+ =head1 METHODS
+
+ Unless otherwise stated all methods return either a I<true> or I<false>
+ value, with I<true> meaning that the operation was a success. When a method
+ states that it returns a value, failure will be returned as I<undef> or an
+ empty list.
+
+ =over 4
+
+ =item user ( USER )
+
+ Send the USER command.
+
+ =item pass ( PASS )
+
+ Send the PASS command. Returns the number of messages in the mailbox.
+
+ =item login ( [ USER [, PASS ]] )
+
+ Send both the the USER and PASS commands. If C<PASS> is not given the
+ C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
+ and username. If the username is not specified then the current user name
+ will be used.
+
+ Returns the number of messages in the mailbox. However if there are no
+ messages on the server the string C<"0E0"> will be returned. This is
+ will give a true value in a boolean context, but zero in a numeric context.
+
+ If there was an error authenticating the user then I<undef> will be returned.
+
+ =item apop ( USER, PASS )
+
+ Authenticate with the server identifying as C<USER> with password C<PASS>.
+ Similar ti L<login>, but the password is not sent in clear text.
+
+ To use this method you must have the MD5 package installed, if you do not
+ this method will return I<undef>
+
+
+ =item top ( MSGNUM [, NUMLINES ] )
+
+ Get the header and the first C<NUMLINES> of the body for the message
+ C<MSGNUM>. Returns a reference to an array which contains the lines of text
+ read from the server.
+
+ =item list ( [ MSGNUM ] )
+
+ If called with an argument the C<list> returns the size of the message
+ in octets.
+
+ If called without arguments a reference to a hash is returned. The
+ keys will be the C<MSGNUM>'s of all undeleted messages and the values will
+ be their size in octets.
+
+ =item get ( MSGNUM [, FH ] )
+
+ Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given
+ then get returns a reference to an array which contains the lines of
+ text read from the server. If C<FH> is given then the lines returned
+ from the server are printed to the filehandle C<FH>.
+
+ =item last ()
+
+ Returns the highest C<MSGNUM> of all the messages accessed.
+
+ =item popstat ()
+
+ Returns a list of two elements. These are the number of undeleted
+ elements and the size of the mbox in octets.
+
+ =item ping ( USER )
+
+ Returns a list of two elements. These are the number of new messages
+ and the total number of messages for C<USER>.
+
+ =item uidl ( [ MSGNUM ] )
+
+ Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not
+ given C<uidl> returns a reference to a hash where the keys are the
+ message numbers and the values are the unique identifiers.
+
+ =item delete ( MSGNUM )
+
+ Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
+ that are marked to be deleted will be removed from the remote mailbox
+ when the server connection closed.
+
+ =item reset ()
+
+ Reset the status of the remote POP3 server. This includes reseting the
+ status of all messages to not be deleted.
+
+ =item quit ()
+
+ Quit and close the connection to the remote POP3 server. Any messages marked
+ as deleted will be deleted from the remote mailbox.
+
+ =back
+
+ =head1 NOTES
+
+ If a C<Net::POP3> object goes out of scope before C<quit> method is called
+ then the C<reset> method will called before the connection is closed. This
+ means that any messages marked to be deleted will not be.
+
+ =head1 SEE ALSO
+
+ L<Net::Netrc>
+ L<Net::Cmd>
+
+ =head1 AUTHOR
+
+ Graham Barr <gbarr@pobox.com>
+
+ =head1 COPYRIGHT
+
+ Copyright (c) 1995-1997 Graham Barr. All rights reserved.
+ This program is free software; you can redistribute it and/or modify
+ it under the same terms as Perl itself.
+
+ =cut
diff -c 'perl-5.7.1/lib/Net/Ping.pm' 'perl-5.7.2/lib/Net/Ping.pm'
Index: ./lib/Net/Ping.pm
*** ./lib/Net/Ping.pm Fri Mar 23 15:40:09 2001
--- ./lib/Net/Ping.pm Mon Jul 9 17:10:39 2001
***************
*** 1,6 ****
--- 1,7 ----
package Net::Ping;
# Current maintainer: colinm@cpan.org (Colin McMillen)
+ # stream protocol: bronson@trestle.com (Scott Bronson)
#
# Original author: mose@ccsn.edu (Russell Mosemann)
#
***************
*** 23,29 ****
@ISA = qw(Exporter);
@EXPORT = qw(pingecho);
! $VERSION = 2.03;
# Constants
--- 24,30 ----
@ISA = qw(Exporter);
@EXPORT = qw(pingecho);
! $VERSION = 2.04;
# Constants
***************
*** 70,77 ****
bless($self, $class);
$proto = $def_proto unless $proto; # Determine the protocol
! croak('Protocol for ping must be "icmp", "tcp", "udp", or "external"')
! unless $proto =~ m/^(tcp|udp|icmp|external)$/;
$self->{"proto"} = $proto;
$timeout = $def_timeout unless $timeout; # Determine the timeout
--- 71,78 ----
bless($self, $class);
$proto = $def_proto unless $proto; # Determine the protocol
! croak('Protocol for ping must be "icmp", "udp", "tcp", "stream", or "external"')
! unless $proto =~ m/^(icmp|udp|tcp|stream|external)$/;
$self->{"proto"} = $proto;
$timeout = $def_timeout unless $timeout; # Determine the timeout
***************
*** 114,120 ****
socket($self->{"fh"}, &PF_INET(), &SOCK_RAW(), $self->{"proto_num"}) ||
croak("icmp socket error - $!");
}
! elsif ($self->{"proto"} eq "tcp") # Just a file handle for now
{
$self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
croak("Can't get tcp protocol by name");
--- 115,121 ----
socket($self->{"fh"}, &PF_INET(), &SOCK_RAW(), $self->{"proto_num"}) ||
croak("icmp socket error - $!");
}
! elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream")
{
$self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
croak("Can't get tcp protocol by name");
***************
*** 154,159 ****
--- 155,161 ----
return $self->ping_udp($ip, $timeout) if $self->{"proto"} eq "udp";
return $self->ping_icmp($ip, $timeout) if $self->{"proto"} eq "icmp";
return $self->ping_tcp($ip, $timeout) if $self->{"proto"} eq "tcp";
+ return $self->ping_stream($ip, $timeout) if $self->{"proto"} eq "stream";
croak("Unknown protocol \"$self->{proto}\" in ping()");
}
***************
*** 283,406 ****
return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement
}
! # Description: Perform a tcp echo ping. Since a tcp connection is
! # host specific, we have to open and close each connection here. We
! # can't just leave a socket open. Because of the robust nature of
! # tcp, it will take a while before it gives up trying to establish a
! # connection. Therefore, we use select() on a non-blocking socket to
! # check against our timeout. No data bytes are actually
! # sent since the successful establishment of a connection is proof
! # enough of the reachability of the remote host. Also, tcp is
! # expensive and doesn't need our help to add to the overhead.
! sub ping_tcp
{
! my ($self,
! $ip, # Packed IP number of the host
! $timeout # Seconds after which ping times out
! ) = @_;
! my ($saddr, # sockaddr_in with port and ip
! $rin, # Used in select()
! $ret # The return value
! );
! socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) ||
! croak("tcp socket error - $!");
! $saddr = sockaddr_in($self->{"port_num"}, $ip);
! $ret = 0; # Default to unreachable
! # Buggy Winsock API doesn't allow us to use non-blocking connect()
! # calls. Hence, if our OS is Windows, we need to create a new process
! # to run a blocking connect attempt, and kill it after the timeout has
! # passed.
! if ($^O =~ /win32/i)
! {
! my ($child, $ret, $pid, $time);
! my $host = inet_ntoa($ip);
! # The code we will be executing in our new process.
! my $code = '"use Net::Ping; $p = Net::Ping->new(\'tcp\'); ';
! $code .= 'exit($p->_ping_tcp_win(' . $host . '))"';
! # Call the process.
! $pid = system(1, "perl", "-e", $code);
! # Import the POSIX version of <sys/wait.h>
! require POSIX;
! import POSIX qw(:sys_wait_h);
! # Get the current time; will be used to tell if we've timed out.
! $time = time;
! # Wait for the child to return or for the timeout to expire.
! do {
! $child = waitpid($pid, &WNOHANG);
! $ret = $?;
! } until time > ($time + $timeout) or $child;
! # Return an appropriate value; 0 if the child didn't return,
! # the return value of the child otherwise.
! return $ret >> 8 if $child;
! kill $pid;
! return 0;
! }
! # If our OS isn't Windows, do this stuff instead...
! else
! {
! # Try a non-blocking TCP connect to the remote echo port.
! # Our call to select() below will stop after the timeout has
! # passed or set the return value to true if the connection
! # succeeds in time.
! $self->{"fh"}->blocking(0);
! connect($self->{"fh"}, $saddr);
! $rin = "";
! vec($rin, fileno($self->{"fh"}), 1) = 1;
! $ret = 1 if select($rin, undef, undef, $timeout);
! # Close our filehandle, restore it to its default state (i.e. blocking),
! # and return our result.
! $self->{"fh"}->blocking(1);
! $self->{"fh"}->close();
! }
! return($ret);
}
! # Warning: this method may generate false positives.
! # It is meant to be a private method and should only
! # be invoked by ping_tcp() if $^O =~ /win32/i.
! sub _ping_tcp_win
{
my ($self,
$ip, # Packed IP number of the host
) = @_;
- my ($saddr, # sockaddr_in with port and ip
- $ret # The return value
- );
socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) ||
! croak("tcp socket error - $!");
! $saddr = sockaddr_in($self->{"port_num"}, $ip);
! $ret = 0; # Default to unreachable
! eval { $ret = connect($self->{"fh"}, $saddr) };
! # If the remote host exists but returns "Connection refused",
! # the call to connect() sets $! to "Unknown error". So, we
! # assume that an "Unknown error" actually means the host is
! # alive. This assumption may occassionally give false positives.
! $ret = 1 if $! =~ /Unknown error/i;
! $self->{"fh"}->close();
return $ret;
}
# Description: Perform a udp echo ping. Construct a message of
# at least the one-byte sequence number and any additional data bytes.
# Send the message out and wait for a message to come back. If we
--- 285,534 ----
return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement
}
! # Warning: this method may generate false positives.
! # It is meant to be a private method and should only
! # be invoked by ping_tcp() if $^O =~ /win32/i.
! sub _ping_tcp_win
{
! my ($self,
! $ip, # Packed IP number of the host
! ) = @_;
! my ($saddr, # sockaddr_in with port and ip
! $ret # The return value
! );
! socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) ||
! croak("tcp socket error - $!");
! $saddr = sockaddr_in($self->{"port_num"}, $ip);
! $ret = 0; # Default to unreachable
! eval { $ret = connect($self->{"fh"}, $saddr) };
! # If the remote host exists but returns "Connection refused",
! # the call to connect() sets $! to "Unknown error". So, we
! # assume that an "Unknown error" actually means the host is
! # alive. This assumption may occassionally give false positives.
! $ret = 1 if $! =~ /Unknown error/i;
! $self->{"fh"}->close();
! return $ret;
! }
! # Buggy Winsock API doesn't allow us to use non-blocking connect()
! # calls. Hence, if our OS is Windows, we need to create a new process
! # to run a blocking connect attempt, and kill it after the timeout has
! # passed. Unfortunately, this won't work with the stream protocol.
! sub ping_tcp_win32
! {
! my ($self,
! $ip, # Packed IP number of the host
! $timeout # Seconds after which open times out
! ) = @_;
! socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) ||
! croak("tcp socket error - $!");
! my $saddr = sockaddr_in($self->{"port_num"}, $ip);
! my ($child, $ret, $pid, $time);
! my $host = inet_ntoa($ip);
! # The code we will be executing in our new process.
! my $code = '"use Net::Ping; $p = Net::Ping->new(\'tcp\'); ';
! $code .= 'exit($p->_ping_tcp_win(' . $host . '))"';
! # Call the process.
! $pid = system(1, "perl", "-e", $code);
! # Import the POSIX version of <sys/wait.h>
! require POSIX;
! import POSIX qw(:sys_wait_h);
!
! # Get the current time; will be used to tell if we've timed out.
! $time = time;
!
! # Wait for the child to return or for the timeout to expire.
! do {
! $child = waitpid($pid, &WNOHANG);
! $ret = $?;
! } until time > ($time + $timeout) or $child;
!
! # Return an appropriate value; 0 if the child didn't return,
! # the return value of the child otherwise.
! return $ret >> 8 if $child;
!
! kill $pid;
! return 0;
}
! # This writes the given string to the socket and then reads it
! # back. It returns 1 on success, 0 on failure.
! sub tcp_echo
{
+ my $self = shift;
+ my $timeout = shift;
+ my $pingstring = shift;
+
+ my $ret = undef;
+ my $time = time;
+ my $wrstr = $pingstring;
+ my $rdstr = "";
+
+ eval <<'EOM';
+ do {
+ my $rin = "";
+ vec($rin, $self->{"fh"}->fileno(), 1) = 1;
+
+ my $rout = undef;
+ if($wrstr) {
+ $rout = "";
+ vec($rout, $self->{"fh"}->fileno(), 1) = 1;
+ }
+
+ if(select($rin, $rout, undef, ($time + $timeout) - time())) {
+
+ if($rout && vec($rout,$self->{"fh"}->fileno(),1)) {
+ my $num = syswrite($self->{"fh"}, $wrstr);
+ if($num) {
+ # If it was a partial write, update and try again.
+ $wrstr = substr($wrstr,$num);
+ } else {
+ # There was an error.
+ $ret = 0;
+ }
+ }
+
+ if(vec($rin,$self->{"fh"}->fileno(),1)) {
+ my $reply;
+ if(sysread($self->{"fh"},$reply,length($pingstring)-length($rdstr))) {
+ $rdstr .= $reply;
+ $ret = 1 if $rdstr eq $pingstring;
+ } else {
+ # There was an error.
+ $ret = 0;
+ }
+ }
+
+ }
+ } until time() > ($time + $timeout) || defined($ret);
+ EOM
+
+ return $ret;
+ }
+
+ sub tcp_connect
+ {
my ($self,
$ip, # Packed IP number of the host
+ $timeout # Seconds after which open times out
) = @_;
+ # Should we go back to using blocking IO and alarms to implement
+ # the stream protocol on win32?
+ croak "no nonblocking io -- can't stream ping on win32"
+ if ($^O =~ /win32/i);
+
+ $self->{"ip"} = $ip;
+
socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) ||
! croak("tcp socket error - $!");
! my $saddr = sockaddr_in($self->{"port_num"}, $ip);
! my $ret = 0;
! # Try a non-blocking TCP connect to the remote echo port.
! # Our call to select() below will stop after the timeout has
! # passed or set the return value to true if the connection
! # succeeds in time.
! $self->{"fh"}->blocking(0);
! connect($self->{"fh"}, $saddr);
! # This replaces the breakage where we were listening on a
! # socket that would never produce any data. This works, but
! # it's now quite a bit heavier than the old Net::Ping. I'd
! # like to see it reverted.
! return $self->tcp_echo($timeout, "ping!\n");
! }
! # Description: Perform a tcp echo ping. Since a tcp connection is
! # host specific, we have to open and close each connection here. We
! # can't just leave a socket open. Because of the robust nature of
! # tcp, it will take a while before it gives up trying to establish a
! # connection. Therefore, we use select() on a non-blocking socket to
! # check against our timeout. No data bytes are actually
! # sent since the successful establishment of a connection is proof
! # enough of the reachability of the remote host. Also, tcp is
! # expensive and doesn't need our help to add to the overhead.
! sub ping_tcp
! {
! my ($self,
! $ip, # Packed IP number of the host
! $timeout # Seconds after which ping times out
! ) = @_;
!
! my $ret;
!
! # tcp_connect won't work on win32, so special-case it if need be.
! if ($^O =~ /win32/i) {
! $ret = $self->ping_tcp_win32($ip, $timeout);
! } else {
! $ret = $self->tcp_connect($ip, $timeout);
! $self->{"fh"}->close();
! }
!
return $ret;
}
+ # Description: Perform a stream ping. If the tcp connection isn't
+ # already open, it opens it. It then sends some data and waits for
+ # a reply. It leaves the stream open on exit.
+
+ sub ping_stream
+ {
+ my ($self,
+ $ip, # Packed IP number of the host
+ $timeout # Seconds after which ping times out
+ ) = @_;
+
+ my $pingstring = "ping!\n"; # The data we exchange with the server
+
+ # Open the stream if it's not already open
+ if(!defined $self->{"fh"}->fileno()) {
+ $self->tcp_connect($ip, $timeout) or return 0;
+ }
+
+ croak "tried to switch servers while stream pinging"
+ if $self->{"ip"} ne $ip;
+
+ return $self->tcp_echo($timeout, "pingschwingping!\n");
+ }
+
+ # Description: opens the stream. You would do this if you want to
+ # separate the overhead of opening the stream from the first ping.
+
+ sub open
+ {
+ my ($self,
+ $ip, # Packed IP number of the host
+ $timeout # Seconds after which open times out
+ ) = @_;
+
+ $timeout = $self->{"timeout"} unless $timeout;
+
+ if($self->{"proto"} eq "stream") {
+ if(defined($self->{"fh"}->fileno())) {
+ croak("socket is already open");
+ } else {
+ $self->tcp_connect($ip, $timeout);
+ }
+ }
+ }
+
# Description: Perform a udp echo ping. Construct a message of
# at least the one-byte sequence number and any additional data bytes.
# Send the message out and wait for a message to come back. If we
***************
*** 527,565 ****
parameters, a variable number of hosts may be pinged multiple
times and then the connection is closed.
! You may choose one of four different protocols to use for the
! ping. The "udp" protocol is the default. Note that a live remote host
! may still fail to be pingable by one or more of these protocols. For
! example, www.microsoft.com is generally alive but not pingable.
! With the "tcp" protocol the ping() method attempts to establish a
! connection to the remote host's echo port. If the connection is
! successfully established, the remote host is considered reachable. No
! data is actually echoed. This protocol does not require any special
! privileges but has higher overhead than the other two protocols.
! Specifying the "udp" protocol causes the ping() method to send a udp
packet to the remote host's echo port. If the echoed packet is
received from the remote host and the received packet contains the
same data as the packet that was sent, the remote host is considered
reachable. This protocol does not require any special privileges.
! It should be borne in mind that, for both udp ping, a host
will be reported as unreachable if it is not running the
appropriate echo service. For Unix-like systems see L<inetd(8)> for
more information.
! If the "icmp" protocol is specified, the ping() method sends an icmp
! echo message to the remote host, which is what the UNIX ping program
! does. If the echoed message is received from the remote host and
! the echoed information is correct, the remote host is considered
! reachable. Specifying the "icmp" protocol requires that the program
! be run as root or that the program be setuid to root.
! If the "external" protocol is specified, the ping() method attempts to
! use the C<Net::Ping::External> module to ping the remote host.
! C<Net::Ping::External> interfaces with your system's default C<ping>
! utility to perform the ping, and generally produces relatively
accurate results. If C<Net::Ping::External> if not installed on your
system, specifying the "external" protocol will result in an error.
--- 655,718 ----
parameters, a variable number of hosts may be pinged multiple
times and then the connection is closed.
! Ping supports five ping protocols, each with its own strengths
! and weaknesses. The "udp" protocol is the default. A host
! may be configured to respond to only a few of these protocols,
! or even none at all. For example, www.microsoft.com is generally
! alive but not pingable.
! =over 4
! =item icmp
!
! The C<ping()> method sends an icmp echo message to the remote host
! (this is what the UNIX ping program does).
! If the echoed message is received from the remote host and
! the echoed information is correct, the remote host is considered
! reachable. Specifying this protocol requires that the program
! be run as root or that the program be setuid to root.
!
! =item udp
!
! The C<ping()> method sends a udp
packet to the remote host's echo port. If the echoed packet is
received from the remote host and the received packet contains the
same data as the packet that was sent, the remote host is considered
reachable. This protocol does not require any special privileges.
! It should be borne in mind that, for both udp and tcp ping, a host
will be reported as unreachable if it is not running the
appropriate echo service. For Unix-like systems see L<inetd(8)> for
more information.
! =item tcp
! The C<ping()> method attempts to establish a
! connection to the remote host's echo port. If the connection is
! successfully established, the remote host is considered reachable.
! Once the connection is made, it is torn down immediately -- no data
! is actually echoed. This protocol does not require any special
! privileges but has highest overhead of the protocols.
!
! =item stream
!
! This is just like the tcp protocol, except that once it establishes
! the tcp connection, it keeps it up. Each subsequent ping
! request re-uses the existing connection. stream
! provides better performance than tcp since the connection
! doesn't need to be created and torn down with every ping. It is
! also the only protocol that will recognize that the original host is
! gone, even if it is immediately replaced by an
! identical host responding in exactly the same way. The drawback
! is that you can only ping one host per Ping instance. You will get
! an error if you neglect to call C<close()> before trying to ping
! a different network device.
!
! =item external
!
! The ping() method attempts to use the C<Net::Ping::External> module to ping
! the remote host. C<Net::Ping::External> interfaces with your system's default
! L<ping(8)> utility to perform the ping, and generally produces relatively
accurate results. If C<Net::Ping::External> if not installed on your
system, specifying the "external" protocol will result in an error.
***************
*** 594,599 ****
--- 747,763 ----
1 is returned if the host is reachable and 0 if it is not. For all
practical purposes, undef and 0 and can be treated as the same case.
+ =item $p->open($host);
+
+ When you are using the stream protocol, this call pre-opens the
+ tcp socket. It's only necessary to do this if you want to
+ provide a different timeout when creating the connection, or
+ remove the overhead of establishing the connection from the
+ first ping. If you don't call C<open()>, the connection is
+ automatically openeed the first time C<ping()> is called.
+ This call simply does nothing if you are using any protocol other
+ than stream.
+
=item $p->close();
Close the network connection for this ping object. The network
***************
*** 622,630 ****
avoid flooding your network with packets.
The icmp protocol requires that the program be run as root or that it
! be setuid to root. The tcp and udp protocols do not require special
! privileges, but not all network devices implement the echo protocol
! for tcp or udp.
Local hosts should normally respond to pings within milliseconds.
However, on a very congested network it may take up to 3 seconds or
--- 786,793 ----
avoid flooding your network with packets.
The icmp protocol requires that the program be run as root or that it
! be setuid to root. The other protocols do not require special
! privileges, but not all network devices implement tcp or udp echo.
Local hosts should normally respond to pings within milliseconds.
However, on a very congested network it may take up to 3 seconds or
***************
*** 633,639 ****
host is not reachable (which is almost the truth).
Reachability doesn't necessarily mean that the remote host is actually
! functioning beyond its ability to echo packets.
Because of a lack of anything better, this module uses its own
routines to pack and unpack ICMP packets. It would be better for a
--- 796,804 ----
host is not reachable (which is almost the truth).
Reachability doesn't necessarily mean that the remote host is actually
! functioning beyond its ability to echo packets. tcp is slightly better
! at indicating the health of a system than icmp because it uses more
! of the networking stack to respond.
Because of a lack of anything better, this module uses its own
routines to pack and unpack ICMP packets. It would be better for a
diff -c /dev/null 'perl-5.7.2/lib/Net/README.config'
Index: ./lib/Net/README.config
*** ./lib/Net/README.config Thu Jan 1 02:00:00 1970
--- ./lib/Net/README.config Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,28 ----
+ Hopefully the next release of libnet will be release 2.00. For this
+ release I want to completely re-write the configuration system.
+
+ My current thoughts are that a hash of values is not sufficient and that
+ Net::Config should be code. This is what I have planned, if you see any
+ problems or have any ideas please let me know by sending an Email
+ to gbarr@pobox.com
+
+ Net::Config will become an object based interface. Methods will be called
+ as static methods on the package. Net::Config will inherit from
+ Net::LocalCfg and Net::Config::default. Net::LocalCfg is a package
+ that local sys-admins can write to override the defaulr behaviour of
+ Net::Config.
+
+ Most of the variables that are currently stored in Net::Config will
+ be turned into method calls, eg $NetConfig{'nntp_hosts'} will
+ become Net::Config->nntp_hosts
+
+ This approach will allow for a better implementation of the firewall code,
+ which currently makes a lot of assumptions. To aid this Net::Config::default
+ will provide a method 'reachable' which will take a single argument as
+ a hostname and should return true it the host is reachable directly.
+
+ This will also allow people who have dialup accounts, and appear in different
+ domains at different times, to do what they need.
+
+ Graham
+ gbarr@pobox.com
diff -c /dev/null 'perl-5.7.2/lib/Net/README.libnet'
Index: ./lib/Net/README.libnet
*** ./lib/Net/README.libnet Thu Jan 1 02:00:00 1970
--- ./lib/Net/README.libnet Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,100 ----
+ libnet is a collection of Perl modules which provides a simple
+ and consistent programming interface (API) to the client side
+ of various protocols used in the internet community.
+
+ For details of each protocol please refer to the RFC. RFC's
+ can be found a various places on the WEB, for a staring
+ point look at:
+
+ http://www.yahoo.com/Computers_and_Internet/Standards/RFCs/
+
+ The RFC implemented in this distribution are
+
+ Net::FTP RFC959 File Transfer Protocol
+ Net::SMTP RFC821 Simple Mail Transfer Protocol
+ Net::Time RFC867 Daytime Protocol
+ Net::Time RFC868 Time Protocol
+ Net::NNTP RFC977 Network News Transfer Protocol
+ Net::POP3 RFC1939 Post Office Protocol 3
+ Net::SNPP RFC1861 Simple Network Pager Protocol
+
+ The distribution also contains a module (Net::PH) which facilitates
+ comunicate with with servers using the CCSO Nameserver Server-Client
+ Protocol
+
+ FUTURE WORK
+
+ AVAILABILITY
+
+ The latest version of libnet is available from the Comprehensive Perl
+ Archive Network (CPAN). To find a CPAN site near you see:
+
+ http://www.perl.com/CPAN
+ ^ no slash here !!
+
+ INSTALLATION
+
+ In order to use this package you will need Perl version 5.002 or
+ better. You install libnet, as you would install any perl module
+ library, by running these commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+ If you want to install a private copy of libnet in your home
+ directory, then you should try to produce the initial Makefile with
+ something like this command:
+
+ perl Makefile.PL PREFIX=~/perl
+
+
+ The Makefile.PL program will start out by checking your perl
+ installation for a few packages that are recommended to be installed
+ together with libnet. These packages should be available on CPAN
+ (described above).
+
+ CONFIGURE
+
+ Normally when perl Makefile.PL is run it will run Configure which will ask some
+ questions about your system. The results of these questions will be stored in
+ the Net::Config package. If you are on a system when this script cannot be run
+ for some reason then the file Config.eg can be edited manually and installed
+ as Net::Config (Net/Comfig.pm)
+
+ DOCUMENTATION
+
+ See ChangeLog for recent changes. POD style documentation is included
+ in all modules and scripts. These are normally converted to manual
+ pages and installed as part of the "make install" process. You should
+ also be able to use the 'perldoc' utility to extract documentation from
+ the module files directly.
+
+ DEMOS
+
+ The demos directory does contain a few demo scripts. These should be
+ run from the top directory like
+
+ demos/smtp.self -user my-email-address -debug
+
+ However I do not guarantee these scripts to work.
+
+ SUPPORT
+
+ Questions about how to use this library should be directed to the
+ comp.lang.perl.modules USENET Newsgroup. Bug reports and suggestions
+ for improvements can be sendt to me at <gbarr@pobox.com>.
+
+ Most of the modules in this library have an option to output a debug
+ transcript to STDERR. When reporting bugs/problems please, if possible,
+ include a transcript of a run.
+
+ COPYRIGHT
+
+ � 1996-98 Graham Barr. All rights reserved.
+
+ This library is free software; you can redistribute it and/or modify
+ it under the same terms as Perl itself.
+
+ Share and Enjoy!
diff -c /dev/null 'perl-5.7.2/lib/Net/SMTP.pm'
Index: ./lib/Net/SMTP.pm
*** ./lib/Net/SMTP.pm Thu Jan 1 02:00:00 1970
--- ./lib/Net/SMTP.pm Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,596 ----
+ # Net::SMTP.pm
+ #
+ # Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ # This program is free software; you can redistribute it and/or
+ # modify it under the same terms as Perl itself.
+
+ package Net::SMTP;
+
+ require 5.001;
+
+ use strict;
+ use vars qw($VERSION @ISA);
+ use Socket 1.3;
+ use Carp;
+ use IO::Socket;
+ use Net::Cmd;
+ use Net::Config;
+
+ $VERSION = "2.15"; # $Id$
+
+ @ISA = qw(Net::Cmd IO::Socket::INET);
+
+ sub new
+ {
+ my $self = shift;
+ my $type = ref($self) || $self;
+ my $host = shift if @_ % 2;
+ my %arg = @_;
+ my $hosts = defined $host ? [ $host ] : $NetConfig{smtp_hosts};
+ my $obj;
+
+ my $h;
+ foreach $h (@{$hosts})
+ {
+ $obj = $type->SUPER::new(PeerAddr => ($host = $h),
+ PeerPort => $arg{Port} || 'smtp(25)',
+ Proto => 'tcp',
+ Timeout => defined $arg{Timeout}
+ ? $arg{Timeout}
+ : 120
+ ) and last;
+ }
+
+ return undef
+ unless defined $obj;
+
+ $obj->autoflush(1);
+
+ $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
+
+ unless ($obj->response() == CMD_OK)
+ {
+ $obj->close();
+ return undef;
+ }
+
+ ${*$obj}{'net_smtp_host'} = $host;
+
+ (${*$obj}{'net_smtp_banner'}) = $obj->message;
+ (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/;
+
+ unless($obj->hello($arg{Hello} || ""))
+ {
+ $obj->close();
+ return undef;
+ }
+
+ $obj;
+ }
+
+ ##
+ ## User interface methods
+ ##
+
+ sub banner
+ {
+ my $me = shift;
+
+ return ${*$me}{'net_smtp_banner'} || undef;
+ }
+
+ sub domain
+ {
+ my $me = shift;
+
+ return ${*$me}{'net_smtp_domain'} || undef;
+ }
+
+ sub etrn {
+ my $self = shift;
+ defined($self->supports('ETRN',500,["Command unknown: 'ETRN'"])) &&
+ $self->_ETRN(@_);
+ }
+
+ sub hello
+ {
+ my $me = shift;
+ my $domain = shift ||
+ eval {
+ require Net::Domain;
+ Net::Domain::hostfqdn();
+ } ||
+ "";
+ my $ok = $me->_EHLO($domain);
+ my @msg = $me->message;
+
+ if($ok)
+ {
+ my $h = ${*$me}{'net_smtp_esmtp'} = {};
+ my $ln;
+ foreach $ln (@msg) {
+ $h->{$1} = $2
+ if $ln =~ /(\S+)\b[ \t]*([^\n]*)/;
+ }
+ }
+ elsif($me->status == CMD_ERROR)
+ {
+ @msg = $me->message
+ if $ok = $me->_HELO($domain);
+ }
+
+ $ok && $msg[0] =~ /\A(\S+)/
+ ? $1
+ : undef;
+ }
+
+ sub supports {
+ my $self = shift;
+ my $cmd = uc shift;
+ return ${*$self}{'net_smtp_esmtp'}->{$cmd}
+ if exists ${*$self}{'net_smtp_esmtp'}->{$cmd};
+ $self->set_status(@_)
+ if @_;
+ return;
+ }
+
+ sub _addr
+ {
+ my $addr = shift || "";
+
+ return $1
+ if $addr =~ /(<[^>]+>)/so;
+
+ $addr =~ s/\n/ /sog;
+ $addr =~ s/(\A\s+|\s+\Z)//sog;
+
+ return "<" . $addr . ">";
+ }
+
+
+ sub mail
+ {
+ my $me = shift;
+ my $addr = _addr(shift);
+ my $opts = "";
+
+ if(@_)
+ {
+ my %opt = @_;
+ my($k,$v);
+
+ if(exists ${*$me}{'net_smtp_esmtp'})
+ {
+ my $esmtp = ${*$me}{'net_smtp_esmtp'};
+
+ if(defined($v = delete $opt{Size}))
+ {
+ if(exists $esmtp->{SIZE})
+ {
+ $opts .= sprintf " SIZE=%d", $v + 0
+ }
+ else
+ {
+ carp 'Net::SMTP::mail: SIZE option not supported by host';
+ }
+ }
+
+ if(defined($v = delete $opt{Return}))
+ {
+ if(exists $esmtp->{DSN})
+ {
+ $opts .= " RET=" . uc $v
+ }
+ else
+ {
+ carp 'Net::SMTP::mail: DSN option not supported by host';
+ }
+ }
+
+ if(defined($v = delete $opt{Bits}))
+ {
+ if(exists $esmtp->{'8BITMIME'})
+ {
+ $opts .= $v == 8 ? " BODY=8BITMIME" : " BODY=7BIT"
+ }
+ else
+ {
+ carp 'Net::SMTP::mail: 8BITMIME option not supported by host';
+ }
+ }
+
+ if(defined($v = delete $opt{Transaction}))
+ {
+ if(exists $esmtp->{CHECKPOINT})
+ {
+ $opts .= " TRANSID=" . _addr($v);
+ }
+ else
+ {
+ carp 'Net::SMTP::mail: CHECKPOINT option not supported by host';
+ }
+ }
+
+ if(defined($v = delete $opt{Envelope}))
+ {
+ if(exists $esmtp->{DSN})
+ {
+ $v =~ s/([^\041-\176]|=|\+)/sprintf "+%02x", ord($1)/sge;
+ $opts .= " ENVID=$v"
+ }
+ else
+ {
+ carp 'Net::SMTP::mail: DSN option not supported by host';
+ }
+ }
+
+ carp 'Net::SMTP::recipient: unknown option(s) '
+ . join(" ", keys %opt)
+ . ' - ignored'
+ if scalar keys %opt;
+ }
+ else
+ {
+ carp 'Net::SMTP::mail: ESMTP not supported by host - options discarded :-(';
+ }
+ }
+
+ $me->_MAIL("FROM:".$addr.$opts);
+ }
+
+ sub send { shift->_SEND("FROM:" . _addr($_[0])) }
+ sub send_or_mail { shift->_SOML("FROM:" . _addr($_[0])) }
+ sub send_and_mail { shift->_SAML("FROM:" . _addr($_[0])) }
+
+ sub reset
+ {
+ my $me = shift;
+
+ $me->dataend()
+ if(exists ${*$me}{'net_smtp_lastch'});
+
+ $me->_RSET();
+ }
+
+
+ sub recipient
+ {
+ my $smtp = shift;
+ my $opts = "";
+ my $skip_bad = 0;
+
+ if(@_ && ref($_[-1]))
+ {
+ my %opt = %{pop(@_)};
+ my $v;
+
+ $skip_bad = delete $opt{'SkipBad'};
+
+ if(exists ${*$smtp}{'net_smtp_esmtp'})
+ {
+ my $esmtp = ${*$smtp}{'net_smtp_esmtp'};
+
+ if(defined($v = delete $opt{Notify}))
+ {
+ if(exists $esmtp->{DSN})
+ {
+ $opts .= " NOTIFY=" . join(",",map { uc $_ } @$v)
+ }
+ else
+ {
+ carp 'Net::SMTP::recipient: DSN option not supported by host';
+ }
+ }
+
+ carp 'Net::SMTP::recipient: unknown option(s) '
+ . join(" ", keys %opt)
+ . ' - ignored'
+ if scalar keys %opt;
+ }
+ elsif(%opt)
+ {
+ carp 'Net::SMTP::recipient: ESMTP not supported by host - options discarded :-(';
+ }
+ }
+
+ my @ok;
+ my $addr;
+ foreach $addr (@_)
+ {
+ if($smtp->_RCPT("TO:" . _addr($addr) . $opts)) {
+ push(@ok,$addr) if $skip_bad;
+ }
+ elsif(!$skip_bad) {
+ return 0;
+ }
+ }
+
+ return $skip_bad ? @ok : 1;
+ }
+
+ sub to { shift->recipient(@_) }
+
+ sub data
+ {
+ my $me = shift;
+
+ my $ok = $me->_DATA() && $me->datasend(@_);
+
+ $ok && @_ ? $me->dataend
+ : $ok;
+ }
+
+ sub expand
+ {
+ my $me = shift;
+
+ $me->_EXPN(@_) ? ($me->message)
+ : ();
+ }
+
+
+ sub verify { shift->_VRFY(@_) }
+
+ sub help
+ {
+ my $me = shift;
+
+ $me->_HELP(@_) ? scalar $me->message
+ : undef;
+ }
+
+ sub quit
+ {
+ my $me = shift;
+
+ $me->_QUIT;
+ $me->close;
+ }
+
+ sub DESTROY
+ {
+ # ignore
+ }
+
+ ##
+ ## RFC821 commands
+ ##
+
+ sub _EHLO { shift->command("EHLO", @_)->response() == CMD_OK }
+ sub _HELO { shift->command("HELO", @_)->response() == CMD_OK }
+ sub _MAIL { shift->command("MAIL", @_)->response() == CMD_OK }
+ sub _RCPT { shift->command("RCPT", @_)->response() == CMD_OK }
+ sub _SEND { shift->command("SEND", @_)->response() == CMD_OK }
+ sub _SAML { shift->command("SAML", @_)->response() == CMD_OK }
+ sub _SOML { shift->command("SOML", @_)->response() == CMD_OK }
+ sub _VRFY { shift->command("VRFY", @_)->response() == CMD_OK }
+ sub _EXPN { shift->command("EXPN", @_)->response() == CMD_OK }
+ sub _HELP { shift->command("HELP", @_)->response() == CMD_OK }
+ sub _RSET { shift->command("RSET")->response() == CMD_OK }
+ sub _NOOP { shift->command("NOOP")->response() == CMD_OK }
+ sub _QUIT { shift->command("QUIT")->response() == CMD_OK }
+ sub _DATA { shift->command("DATA")->response() == CMD_MORE }
+ sub _TURN { shift->unsupported(@_); }
+ sub _ETRN { shift->command("ETRN", @_)->response() == CMD_OK }
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ Net::SMTP - Simple Mail Transfer Protocol Client
+
+ =head1 SYNOPSIS
+
+ use Net::SMTP;
+
+ # Constructors
+ $smtp = Net::SMTP->new('mailhost');
+ $smtp = Net::SMTP->new('mailhost', Timeout => 60);
+
+ =head1 DESCRIPTION
+
+ This module implements a client interface to the SMTP and ESMTP
+ protocol, enabling a perl5 application to talk to SMTP servers. This
+ documentation assumes that you are familiar with the concepts of the
+ SMTP protocol described in RFC821.
+
+ A new Net::SMTP object must be created with the I<new> method. Once
+ this has been done, all SMTP commands are accessed through this object.
+
+ The Net::SMTP class is a subclass of Net::Cmd and IO::Socket::INET.
+
+ =head1 EXAMPLES
+
+ This example prints the mail domain name of the SMTP server known as mailhost:
+
+ #!/usr/local/bin/perl -w
+
+ use Net::SMTP;
+
+ $smtp = Net::SMTP->new('mailhost');
+ print $smtp->domain,"\n";
+ $smtp->quit;
+
+ This example sends a small message to the postmaster at the SMTP server
+ known as mailhost:
+
+ #!/usr/local/bin/perl -w
+
+ use Net::SMTP;
+
+ $smtp = Net::SMTP->new('mailhost');
+
+ $smtp->mail($ENV{USER});
+ $smtp->to('postmaster');
+
+ $smtp->data();
+ $smtp->datasend("To: postmaster\n");
+ $smtp->datasend("\n");
+ $smtp->datasend("A simple test message\n");
+ $smtp->dataend();
+
+ $smtp->quit;
+
+ =head1 CONSTRUCTOR
+
+ =over 4
+
+ =item new Net::SMTP [ HOST, ] [ OPTIONS ]
+
+ This is the constructor for a new Net::SMTP object. C<HOST> is the
+ name of the remote host to which a SMTP connection is required.
+
+ If C<HOST> is not given, then the C<SMTP_Host> specified in C<Net::Config>
+ will be used.
+
+ C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
+ Possible options are:
+
+ B<Hello> - SMTP requires that you identify yourself. This option
+ specifies a string to pass as your mail domain. If not
+ given a guess will be taken.
+
+ B<Timeout> - Maximum time, in seconds, to wait for a response from the
+ SMTP server (default: 120)
+
+ B<Debug> - Enable debugging information
+
+
+ Example:
+
+
+ $smtp = Net::SMTP->new('mailhost',
+ Hello => 'my.mail.domain'
+ Timeout => 30,
+ Debug => 1,
+ );
+
+ =head1 METHODS
+
+ Unless otherwise stated all methods return either a I<true> or I<false>
+ value, with I<true> meaning that the operation was a success. When a method
+ states that it returns a value, failure will be returned as I<undef> or an
+ empty list.
+
+ =over 4
+
+ =item banner ()
+
+ Returns the banner message which the server replied with when the
+ initial connection was made.
+
+ =item domain ()
+
+ Returns the domain that the remote SMTP server identified itself as during
+ connection.
+
+ =item hello ( DOMAIN )
+
+ Tell the remote server the mail domain which you are in using the EHLO
+ command (or HELO if EHLO fails). Since this method is invoked
+ automatically when the Net::SMTP object is constructed the user should
+ normally not have to call it manually.
+
+ =item etrn ( DOMAIN )
+
+ Request a queue run for the DOMAIN given.
+
+ =item mail ( ADDRESS [, OPTIONS] )
+
+ =item send ( ADDRESS )
+
+ =item send_or_mail ( ADDRESS )
+
+ =item send_and_mail ( ADDRESS )
+
+ Send the appropriate command to the server MAIL, SEND, SOML or SAML. C<ADDRESS>
+ is the address of the sender. This initiates the sending of a message. The
+ method C<recipient> should be called for each address that the message is to
+ be sent to.
+
+ The C<mail> method can some additional ESMTP OPTIONS which is passed
+ in hash like fashion, using key and value pairs. Possible options are:
+
+ Size => <bytes>
+ Return => <???>
+ Bits => "7" | "8"
+ Transaction => <ADDRESS>
+ Envelope => <ENVID>
+
+
+ =item reset ()
+
+ Reset the status of the server. This may be called after a message has been
+ initiated, but before any data has been sent, to cancel the sending of the
+ message.
+
+ =item recipient ( ADDRESS [, ADDRESS [ ...]] [, OPTIONS ] )
+
+ Notify the server that the current message should be sent to all of the
+ addresses given. Each address is sent as a separate command to the server.
+ Should the sending of any address result in a failure then the
+ process is aborted and a I<false> value is returned. It is up to the
+ user to call C<reset> if they so desire.
+
+ The C<recipient> method can some additional OPTIONS which is passed
+ in hash like fashion, using key and value pairs. Possible options are:
+
+ Notify =>
+ SkipBad => ignore bad addresses
+
+ If C<SkipBad> is true the C<recipient> will not return an error when a
+ bad address is encountered and it will return an array of addresses
+ that did succeed.
+
+ =item to ( ADDRESS [, ADDRESS [...]] )
+
+ A synonym for C<recipient>.
+
+ =item data ( [ DATA ] )
+
+ Initiate the sending of the data from the current message.
+
+ C<DATA> may be a reference to a list or a list. If specified the contents
+ of C<DATA> and a termination string C<".\r\n"> is sent to the server. And the
+ result will be true if the data was accepted.
+
+ If C<DATA> is not specified then the result will indicate that the server
+ wishes the data to be sent. The data must then be sent using the C<datasend>
+ and C<dataend> methods described in L<Net::Cmd>.
+
+ =item expand ( ADDRESS )
+
+ Request the server to expand the given address Returns an array
+ which contains the text read from the server.
+
+ =item verify ( ADDRESS )
+
+ Verify that C<ADDRESS> is a legitimate mailing address.
+
+ =item help ( [ $subject ] )
+
+ Request help text from the server. Returns the text or undef upon failure
+
+ =item quit ()
+
+ Send the QUIT command to the remote SMTP server and close the socket connection.
+
+ =back
+
+ =head1 SEE ALSO
+
+ L<Net::Cmd>
+
+ =head1 AUTHOR
+
+ Graham Barr <gbarr@pobox.com>
+
+ =head1 COPYRIGHT
+
+ Copyright (c) 1995-1997 Graham Barr. All rights reserved.
+ This program is free software; you can redistribute it and/or modify
+ it under the same terms as Perl itself.
+
+ =cut
diff -c /dev/null 'perl-5.7.2/lib/Net/Time.pm'
Index: ./lib/Net/Time.pm
*** ./lib/Net/Time.pm Thu Jan 1 02:00:00 1970
--- ./lib/Net/Time.pm Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,147 ----
+ # Net::Time.pm
+ #
+ # Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ # This program is free software; you can redistribute it and/or
+ # modify it under the same terms as Perl itself.
+
+ package Net::Time;
+
+ use strict;
+ use vars qw($VERSION @ISA @EXPORT_OK $TIMEOUT);
+ use Carp;
+ use IO::Socket;
+ require Exporter;
+ use Net::Config;
+ use IO::Select;
+
+ @ISA = qw(Exporter);
+ @EXPORT_OK = qw(inet_time inet_daytime);
+
+ $VERSION = "2.08";
+
+ $TIMEOUT = 120;
+
+ sub _socket
+ {
+ my($pname,$pnum,$host,$proto,$timeout) = @_;
+
+ $proto ||= 'udp';
+
+ my $port = (getservbyname($pname, $proto))[2] || $pnum;
+
+ my $hosts = defined $host ? [ $host ] : $NetConfig{$pname . '_hosts'};
+
+ my $me;
+
+ foreach $host (@$hosts)
+ {
+ $me = IO::Socket::INET->new(PeerAddr => $host,
+ PeerPort => $port,
+ Proto => $proto
+ ) and last;
+ }
+
+ return unless $me;
+
+ $me->send("\n")
+ if $proto eq 'udp';
+
+ $timeout = $TIMEOUT
+ unless defined $timeout;
+
+ IO::Select->new($me)->can_read($timeout)
+ ? $me
+ : undef;
+ }
+
+ sub inet_time
+ {
+ my $s = _socket('time',37,@_) || return undef;
+ my $buf = '';
+ my $offset = 0 | 0;
+
+ return undef
+ unless $s->recv($buf, length(pack("N",0)));
+
+ # unpack, we | 0 to ensure we have an unsigned
+ my $time = (unpack("N",$buf))[0] | 0;
+
+ # the time protocol return time in seconds since 1900, convert
+ # it to a the required format
+
+ if($^O eq "MacOS") {
+ # MacOS return seconds since 1904, 1900 was not a leap year.
+ $offset = (4 * 31536000) | 0;
+ }
+ else {
+ # otherwise return seconds since 1972, there were 17 leap years between
+ # 1900 and 1972
+ $offset = (70 * 31536000 + 17 * 86400) | 0;
+ }
+
+ $time - $offset;
+ }
+
+ sub inet_daytime
+ {
+ my $s = _socket('daytime',13,@_) || return undef;
+ my $buf = '';
+
+ $s->recv($buf, 1024) ? $buf
+ : undef;
+ }
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ Net::Time - time and daytime network client interface
+
+ =head1 SYNOPSIS
+
+ use Net::Time qw(inet_time inet_daytime);
+
+ print inet_time(); # use default host from Net::Config
+ print inet_time('localhost');
+ print inet_time('localhost', 'tcp');
+
+ print inet_daytime(); # use default host from Net::Config
+ print inet_daytime('localhost');
+ print inet_daytime('localhost', 'tcp');
+
+ =head1 DESCRIPTION
+
+ C<Net::Time> provides subroutines that obtain the time on a remote machine.
+
+ =over 4
+
+ =item inet_time ( [HOST [, PROTOCOL [, TIMEOUT]]])
+
+ Obtain the time on C<HOST>, or some default host if C<HOST> is not given
+ or not defined, using the protocol as defined in RFC868. The optional
+ argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
+ C<udp>. The result will be a time value in the same units as returned
+ by time() or I<undef> upon failure.
+
+ =item inet_daytime ( [HOST [, PROTOCOL [, TIMEOUT]]])
+
+ Obtain the time on C<HOST>, or some default host if C<HOST> is not given
+ or not defined, using the protocol as defined in RFC867. The optional
+ argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
+ C<udp>. The result will be an ASCII string or I<undef> upon failure.
+
+ =back
+
+ =head1 AUTHOR
+
+ Graham Barr <gbarr@pobox.com>
+
+ =head1 COPYRIGHT
+
+ Copyright (c) 1995-1998 Graham Barr. All rights reserved.
+ This program is free software; you can redistribute it and/or modify
+ it under the same terms as Perl itself.
+
+ =cut
diff -c /dev/null 'perl-5.7.2/lib/Net/demos/ftp'
Index: ./lib/Net/demos/ftp
*** ./lib/Net/demos/ftp Thu Jan 1 02:00:00 1970
--- ./lib/Net/demos/ftp Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,21 ----
+ #!/usr/local/bin/perl
+
+ use blib;
+ use Net::FTP;
+ use Getopt::Long;
+
+ $opt_debug = undef;
+ $opt_firewall = undef;
+
+ GetOptions(qw(debug firewall=s));
+
+ @firewall = defined $opt_firewall ? (Firewall => $opt_firewall) : ();
+
+ foreach $host (@ARGV)
+ {
+ $ftp = Net::FTP->new($host, @firewall, Debug => $opt_debug ? 1 : 0);
+ $ftp->login();
+ print $ftp->pwd,"\n";
+ $ftp->quit;
+ }
+
diff -c /dev/null 'perl-5.7.2/lib/Net/demos/inetd'
Index: ./lib/Net/demos/inetd
*** ./lib/Net/demos/inetd Thu Jan 1 02:00:00 1970
--- ./lib/Net/demos/inetd Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,9 ----
+ #!/usr/local/bin/perl
+
+ use Net::DummyInetd;
+ use Net::SMTP;
+
+ $p = new Net::DummyInetd qw(/usr/lib/sendmail -ba -bs);
+
+ $smtp = Net::SMTP->new('localhost', Port => $p->port, Debug => 7);
+ $smtp->quit;
diff -c /dev/null 'perl-5.7.2/lib/Net/demos/nntp'
Index: ./lib/Net/demos/nntp
*** ./lib/Net/demos/nntp Thu Jan 1 02:00:00 1970
--- ./lib/Net/demos/nntp Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,40 ----
+ #!/usr/local/bin/perl
+
+ use blib;
+ use Getopt::Long;
+ use Net::NNTP;
+
+ $opt_debug = undef;
+
+ GetOptions(qw(debug));
+
+ @groups = @ARGV;
+
+ $nntp = Net::NNTP->new('news', Debug => $opt_debug ? 1 : 0);
+
+ if($subs = $nntp->newsgroups)
+ {
+ print join("\n",(keys %$subs)[0 .. 10]),"\n";
+ }
+ else
+ {
+ warn $nntp->message;
+ }
+
+ foreach $group (@groups)
+ {
+ $new = $nntp->newnews(time - 3600, lc $group);
+
+ if(ref($new) && scalar(@$new))
+ {
+ print@{$news}[0..3],"\n"
+ if $news = $nntp->article($new->[-1]);
+
+ warn $nntp->message
+ unless $news;
+ }
+ }
+
+ $nntp->quit;
+
+
diff -c /dev/null 'perl-5.7.2/lib/Net/demos/nntp.mirror'
Index: ./lib/Net/demos/nntp.mirror
*** ./lib/Net/demos/nntp.mirror Thu Jan 1 02:00:00 1970
--- ./lib/Net/demos/nntp.mirror Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,86 ----
+ #!/usr/bin/perl5
+
+ ### Subject: Re: Fuller example of Net::NNTP?
+ ### Date: Tue, 4 Feb 1997 10:37:58 -0800
+ ### From: "Paul E. Hoffman" <phoffman@imc.org>
+ ### To: Graham Barr <gbarr@ti.com>
+ ###
+ ### Thanks for your reply. After looking at the examples, I realized that
+ ### you're not doing what I want, which is to store the messages on the local
+ ### hard disk with the same message number as what was on the remote. So, I
+ ### rolled my own program, although I haven't finished it yet (I have a hook
+ ### for expiring, but haven't done it yet).
+ ###
+ ### You are welcome to use this in the Net:: distribution if you think it is
+ ### useful.
+ ###
+ ### NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
+ ###
+ ### This script is included as-is, I give no guarantee that it will
+ ### work on every system
+ ###
+
+ use Net::NNTP;
+
+ $BaseDir = '/usr/usenet';
+ chdir($BaseDir) or die "Could not cd to $BaseDir\n";
+
+ # Format of grouplist is:
+ # groupname<tab>expirationdays
+ # expirationdays is the number of days to leave the articles around;
+ # set it to 0 if you want the articles to stay forever
+ # If the groupname starts with a #, it is skipped
+ open(GROUPLIST, 'grouplist.txt') or die "Could not open grouplist.txt\n";
+ while(<GROUPLIST>) {
+ $Line = $_; chomp($Line);
+ if($Line eq '') { next }; # Skip blank lines
+ if(substr($Line, 0, 1) eq '#') { next }; # Skip comments
+ push(@Groups, $Line)
+ }
+
+ $NntpPtr = Net::NNTP->new('news.server.com');
+
+ foreach $GroupLine (@Groups) {
+ ($GroupName, $GroupExp) = split(/\s/, $GroupLine, 2);
+ # Process the expiration first (still to be done...)
+
+ # See if this is a new group
+ unless(-e "$BaseDir/$GroupName") {
+ unless(mkdir("$BaseDir/$GroupName", 0755))
+ { die "Could not make $BaseDir/$GroupName\n" }
+ }
+ chdir("$BaseDir/$GroupName") or die "Couldn't chdir to $GroupName\n";
+ # Find the last article in the directory
+ @AllInDir = <*>; @RevSortedAllInDir = reverse(sort(@AllInDir));
+ $LenArr = @RevSortedAllInDir;
+ if($LenArr > 0) { $NumLastInDir = $RevSortedAllInDir[0] }
+ else { $NumLastInDir = 0 }
+ ($NumArt, $NumFirst, $NumLast, $XGroupName) =
+ $NntpPtr->group($GroupName);
+
+ if($NumLast == $NumLastInDir) { next } # No new articles
+ if($NumLast < $NumLastInDir)
+ { die "In $GroupName, the last number was $NumLast, but the " .
+ " last number in the directory was $NumLastInDir\n" }
+ # Figure out which article to start from
+ if($NumLastInDir == 0) { $GetArtNum = $NumFirst }
+ else { $GetArtNum = $NumLastInDir + 1 }
+
+ # Now read each of the new articles
+ while(1) { # Loop until "last" is called
+ $ArtRef = $NntpPtr->article($GetArtNum);
+ @ArtArr = @$ArtRef; $ArtArrLen = @ArtArr;
+ if($ArtArrLen > 0 ) { # Skip article numbers that had 0 len
+ open(OUT, ">$GetArtNum") or
+ die "Could not create $GroupName/$GetArtNum\n";
+ print OUT @$ArtRef; close(OUT);
+ }
+
+ # Check if we're at the end
+ if($GetArtNum == $NumLast) { last }
+ $GetArtNum += 1; # Increment the article number to get
+ }
+ }
+
+ $NntpPtr->quit;
+ exit;
diff -c /dev/null 'perl-5.7.2/lib/Net/demos/pop3'
Index: ./lib/Net/demos/pop3
*** ./lib/Net/demos/pop3 Thu Jan 1 02:00:00 1970
--- ./lib/Net/demos/pop3 Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,24 ----
+ #!/usr/local/bin/perl -w
+
+ use blib;
+ use Net::POP3;
+ use Getopt::Long;
+
+ $opt_debug = 0;
+ $opt_user = undef;
+
+ GetOptions(qw(debug user=s));
+
+ $pop = Net::POP3->new('backup3', Debug => $opt_debug ? 6 : 0);
+
+ $user = $opt_user || $ENV{USER} || $ENV{LOGNAME};
+
+ $count = $pop->login($user);
+
+ if($count)
+ {
+ $m = $pop->get(1);
+ print @$m if $m;
+ }
+
+ $pop->quit;
diff -c /dev/null 'perl-5.7.2/lib/Net/demos/smtp.self'
Index: ./lib/Net/demos/smtp.self
*** ./lib/Net/demos/smtp.self Thu Jan 1 02:00:00 1970
--- ./lib/Net/demos/smtp.self Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,80 ----
+ #!/usr/local/bin/perl -w
+
+ use blib;
+ use Net::SMTP;
+ use Getopt::Long;
+
+ =head1 NAME
+
+ smtp.self - mail a message via smtp
+
+ =head1 DESCRIPTION
+
+ C<smtp.self> will attempt to send a message to a given user
+
+ =head1 OPTIONS
+
+ =over 4
+
+ =item -debug
+
+ Enabe the output of dubug information
+
+ =item -help
+
+ Display this help text and quit
+
+ =item -user USERNAME
+
+ Send the message to C<USERNAME>
+
+ =head1 EXAMPLE
+
+ demos/smtp.self -user foo.bar
+
+ demos/smtp.self -debug -user Graham.Barr
+
+ =back
+
+ =cut
+
+ $opt_debug = undef;
+ $opt_user = undef;
+ $opt_help = undef;
+ GetOptions(qw(debug user=s help));
+
+ exec("pod2text $0")
+ if defined $opt_help;
+
+ Net::SMTP->debug(1) if $opt_debug;
+
+ $smtp = Net::SMTP->new("mailhost");
+
+ $user = $opt_user || $ENV{USER} || $ENV{LOGNAME};
+
+ $smtp->mail($user) && $smtp->to($user);
+ $smtp->reset;
+
+ if($smtp->mail($user) && $smtp->to($user))
+ {
+ $smtp->data();
+
+ map { s/-USER-/$user/g } @data=<DATA>;
+
+ $smtp->datasend(@data);
+ $smtp->dataend;
+ }
+ else
+ {
+ warn $smtp->message;
+ }
+
+ $smtp->quit;
+
+ __DATA__
+ To: <-USER->
+ Subject: A test message
+
+ The message was sent directly via SMTP using Net::SMTP
+ .
+ The message was sent directly via SMTP using Net::SMTP
diff -c /dev/null 'perl-5.7.2/lib/Net/demos/snpp'
Index: ./lib/Net/demos/snpp
*** ./lib/Net/demos/snpp Thu Jan 1 02:00:00 1970
--- ./lib/Net/demos/snpp Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,39 ----
+ #!/usr/local/bin/perl
+
+ use blib;
+ use Getopt::Long;
+ use Net::SNPP;
+
+ $opt_debug = undef;
+ $opt_h = undef;
+ $opt_p = undef;
+
+ GetOptions(qw(debug h p));
+
+ die "usage: $0 -h <host> -p <pagerid> <message>"
+ unless defined $opt_h && defined $opt_p && @ARGV;
+
+ Net::SNPP->debug(1)
+ if $opt_debug;
+
+ $snpp = Net::SNPP->new($opt_host);
+
+ $snpp->pager_id($opt_p) || die $snpp->message;
+ $snpp->content(join(" ",@ARGV)) || die $snpp->message;
+ $snpp->send() || die $snpp->message;
+
+ $snpp->quit;
+
+ __END__
+
+ or you could dp
+
+ $snpp = Net::SNPP->new($opt_host);
+
+ $snpp->send( Pager => $opt_p,
+ Message => join(" ",@ARGV),
+ Alert => 1,
+ Hold => time + 3600
+ ) || die $snpp->message;
+
+ $snpp->quit;
diff -c /dev/null 'perl-5.7.2/lib/Net/demos/time'
Index: ./lib/Net/demos/time
*** ./lib/Net/demos/time Thu Jan 1 02:00:00 1970
--- ./lib/Net/demos/time Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,13 ----
+ #!/usr/local/bin/perl -w
+
+ use blib;
+ use Net::Time qw(inet_time inet_daytime);
+
+ print inet_daytime('localhost');
+ print inet_daytime('localhost','tcp');
+ print inet_daytime('localhost','udp');
+
+ print inet_time('localhost'),"\n";
+ print inet_time('localhost','tcp'),"\n";
+ print inet_time('localhost','udp'),"\n";
+
diff -c /dev/null 'perl-5.7.2/lib/Net/hostent.t'
Index: ./lib/Net/hostent.t
*** ./lib/Net/hostent.t Thu Jan 1 02:00:00 1970
--- ./lib/Net/hostent.t Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,72 ----
+ #!./perl -w
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bSocket\b/ &&
+ !(($^O eq 'VMS') && $Config{d_socket})) {
+ print "1..0 # Test uses Socket, Socket not built\n";
+ exit 0;
+ }
+ }
+
+ BEGIN { $| = 1; print "1..7\n"; }
+
+ END {print "not ok 1\n" unless $loaded;}
+
+ use Net::hostent;
+
+ $loaded = 1;
+ print "ok 1\n";
+
+ # test basic resolution of localhost <-> 127.0.0.1
+ use Socket;
+
+ my $h = gethost('localhost');
+ print +(defined $h ? '' : 'not ') . "ok 2\n";
+ my $i = gethostbyaddr(inet_aton("127.0.0.1"));
+ print +(!defined $i ? 'not ' : '') . "ok 3\n";
+
+ print "not " if inet_ntoa($h->addr) ne "127.0.0.1";
+ print "ok 4\n";
+
+ print "not " if inet_ntoa($i->addr) ne "127.0.0.1";
+ print "ok 5\n";
+
+ # need to skip the name comparisons on Win32 because windows will
+ # return the name of the machine instead of "localhost" when resolving
+ # 127.0.0.1 or even "localhost"
+
+ # VMS returns "LOCALHOST" under tcp/ip services V4.1 ECO 2, possibly others
+ # OS/390 returns localhost.YADDA.YADDA
+
+ if ($^O eq 'MSWin32' or $^O eq 'NetWare' or $^O eq 'cygwin') {
+ print "ok $_ # skipped on win32\n" for (6,7);
+ } else {
+ my $in_alias;
+ unless ($h->name =~ /^localhost(?:\..+)?$/i) {
+ foreach (@{$h->aliases}) {
+ if (/^localhost(?:\..+)?$/i) {
+ $in_alias = 1;
+ last;
+ }
+ }
+ print "not " unless $in_alias;
+ } # Else we found it as the hostname
+ print "ok 6 # ",$h->name, " ", join (",", @{$h->aliases}), "\n";
+
+ if ($in_alias) {
+ # If we found it in the aliases before, expect to find it there again.
+ foreach (@{$h->aliases}) {
+ if (/^localhost(?:\..+)?$/i) {
+ undef $in_alias; # This time, clear the flag if we see "localhost"
+ last;
+ }
+ }
+ print "not " if $in_alias;
+ } else {
+ print "not " unless $i->name =~ /^localhost(?:\..+)?$/i;
+ }
+ print "ok 7 # ",$h->name, " ", join (",", @{$h->aliases}), "\n";
+ }
diff -c /dev/null 'perl-5.7.2/lib/Net/libnet.ppd'
Index: ./lib/Net/libnet.ppd
*** ./lib/Net/libnet.ppd Thu Jan 1 02:00:00 1970
--- ./lib/Net/libnet.ppd Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,12 ----
+ <SOFTPKG NAME="libnet" VERSION="1,06,0,0">
+ <TITLE>libnet</TITLE>
+ <ABSTRACT>Collection of Network protocol modules</ABSTRACT>
+ <AUTHOR>Graham Barr <gbarr@pobox.com></AUTHOR>
+ <IMPLEMENTATION>
+ <DEPENDENCY NAME="IO-Socket" VERSION="1,05,0,0" />
+ <DEPENDENCY NAME="Socket" VERSION="1,3,0,0" />
+ <OS NAME="linux" />
+ <ARCHITECTURE NAME="i586-linux" />
+ <CODEBASE HREF="" />
+ </IMPLEMENTATION>
+ </SOFTPKG>
diff -c /dev/null 'perl-5.7.2/lib/Net/libnetFAQ.pod'
Index: ./lib/Net/libnetFAQ.pod
*** ./lib/Net/libnetFAQ.pod Thu Jan 1 02:00:00 1970
--- ./lib/Net/libnetFAQ.pod Mon Jul 9 17:10:39 2001
***************
*** 0 ****
--- 1,321 ----
+ =head1 NAME
+
+ libnetFAQ - libnet Frequently Asked Questions
+
+ =head1 DESCRIPTION
+
+ =head2 Where to get this document
+
+ This document is distributed with the libnet disribution, and is also
+ avaliable on the libnet web page at
+
+ http://www.pobox.com/~gbarr/libnet/
+
+
+
+ =head2 How to contribute to this document
+
+ You may mail corrections, additions, and suggestions to me
+ gbarr@pobox.com.
+
+
+ =head1 Author and Copyright Information
+
+ Copyright (c) 1997-1998 Graham Barr. All rights reserved.
+ This document is free; you can redistribute it and/or modify it
+ under the terms of the Artistic Licence.
+
+ =head2 Disclaimer
+
+ This information is offered in good faith and in the hope that it may
+ be of use, but is not guaranteed to be correct, up to date, or suitable
+ for any particular purpose whatsoever. The authors accept no liability
+ in respect of this information or its use.
+
+
+ =head1 Obtaining and installing libnet
+
+ =over 4
+
+ =head2 What is libnet ?
+
+ libnet is a collection of perl5 modules which all related to network
+ programming. The majority of the modules avaliable provided the
+ client side of popular server-client protocols that are used in
+ the internet community.
+
+ =head2 Which version of perl do I need ?
+
+ libnet has been know to work with versions of perl from 5.002 onwards. However
+ if your release of perl is prior to perl5.004 then you will need to
+ obtain and install the IO distribution from CPAN. If you have perl5.004
+ or later then you will have the IO modules in your installation already,
+ but CPAN may contain updates.
+
+ =head2 What other modules do I need ?
+
+ The only modules you will need installed are the modules from the IO
+ distribution. If you have perl5.004 or later you will already have
+ these modules.
+
+ =head2 What machines support libnet ?
+
+ libnet itself is an entirly perl-code distribution so it should work
+ on any machine that perl runs on. However IO may not work
+ with some machines and earlier releases of perl. But this
+ should not be the case with perl version 5.004 or later.
+
+ =head2 Where can I get the latest libnet release
+
+ The latest libnet release is always on CPAN, you will find it
+ in
+
+ http://www.perl.com/CPAN/modules/by-module/Net/
+
+ The latest release and information is also avaliable on the libnet web page
+ at
+
+ http://www.pobox.com/~gbarr/libnet/
+
+ =back
+
+ =head1 Using Net::FTP
+
+ =over
+
+ =head2 How do I download files from a FTP server ?
+
+ An example taken from an article posted to comp.lang.perl.misc
+
+ #!/your/path/to/perl
+
+ # a module making life easier
+
+ use Net::FTP;
+
+ # for debuging: $ftp = Net::FTP->new('site','Debug',10);
+ # open a connection and log in!
+
+ $ftp = Net::FTP->new('target_site.somewhere.xxx');
+ $ftp->login('username','password');
+
+ # set transfer mode to binary
+
+ $ftp->binary();
+
+ # change the directory on the ftp site
+
+ $ftp->cwd('/some/path/to/somewhere/');
+
+ foreach $name ('file1', 'file2', 'file3') {
+
+ # get's arguments are in the following order:
+ # ftp server's filename
+ # filename to save the transfer to on the local machine
+ # can be simply used as get($name) if you want the same name
+
+ $ftp->get($name,$name);
+ }
+
+ # ftp done!
+
+ $ftp->quit;
+
+ =head2 How do I transfer files in binary mode ?
+
+ To transfer files without <LF><CR> translation Net::FTP provides
+ the C<binary> method
+
+ $ftp->binary;
+
+ =head2 How can I get the size of a file on a remote FTP server ?
+
+ =head2 How can I get the modification time of a file on a remote FTP server ?
+
+ =head2 How can I change the permissions of a file on a remote server ?
+
+ The FTP protocol does not have a command for changing the permissions
+ of a file on the remote server. But some ftp servers may allow a chmod
+ command to be issued via a SITE command, eg
+
+ $ftp->quot('site chmod 0777',$filename);
+
+ But this is not guaranteed to work.
+
+ =head2 Can I do a reget operation like the ftp command ?
+
+ =head2 How do I get a directory listing from a FTP server ?
+
+ =head2 Changeing directory to "" does not fail ?
+
+ Passing an argument of "" to ->cwd() has the same affect of calling ->cwd()
+ without any arguments. Turn on Debug (I<See below>) and you will see what is
+ happening
+
+ $ftp = Net::FTP->new($host, Debug => 1);
+ $ftp->login;
+ $ftp->cwd("");
+
+ gives
+
+ Net::FTP=GLOB(0x82196d8)>>> CWD /
+ Net::FTP=GLOB(0x82196d8)<<< 250 CWD command successful.
+
+ =head2 I am behind a SOCKS firewall, but the Firewall option does not work ?
+
+ The Firewall option is only for support of one type of firewall. The type
+ supported is a ftp proxy.
+
+ To use Net::FTP, or any other module in the libnet distribution,
+ through a SOCKS firewall you must create a socks-ified perl executable
+ by compiling perl with the socks library.
+
+ =head2 I am behind a FTP proxy firewall, but cannot access machines outside ?
+
+ Net::FTP implements the most popular ftp proxy firewall approach. The sceme
+ implemented is that where you loginin to the firewall with C<user@hostname>
+
+ I have heard of one other type of firewall which requires a login to the
+ firewall with an accont, then a second login with C<user@hostname>. You can
+ still use Net::FTP to traverse these firewalls, but a more manual approach
+ must be taken, eg
+
+ $ftp = Net::FTP->new($firewall) or die $@;
+ $ftp->login($firewall_user, $firewall_passwd) or die $ftp->message;
+ $ftp->login($ext_user . '@' . $ext_host, $ext_passwd) or die $ftp->message.
+
+ =head2 My ftp proxy firewall does not listen on port 21
+
+ FTP servers usually listen on the same port number, port 21, as any other
+ FTP server. But there is no reason why thi has to be the case.
+
+ If you pass a port number to Net::FTP then it assumes this is the port
+ number of the final destination. By default Net::FTP will always try
+ to connect to the firewall on port 21.
+
+ Net::FTP uses IO::Socket to open the connection and IO::Socket allows
+ the port number to be specified as part of the hostname. So this problem
+ can be resolved by either passing a Firewall option like C<"hostname:1234">
+ or by setting the C<ftp_firewall> option in Net::Config to be a string
+ in in the same form.
+
+ =head2 Is it possible to change the file permissions of a file on an FTP server ?
+
+ The answer to this is "maybe". The FTP protocol does not specify a command to change
+ file permissions on a remote host. However many servers do allow you to run the
+ chmod command via the C<SITE> command. This can be done with
+
+ $ftp->site('chmod','0775',$file);
+
+ =head2 I have seen scripts call a method message, but cannot find it documented ?
+
+ Net::FTP, like several other packages in libnet, inherits from Net::Cmd, so
+ all the methods described in Net::Cmd are also avaliable on Net::FTP
+ objects.
+
+ =head2 Why does Net::FTP not implement mput and mget methods
+
+ The quick answer is because they are easy to implement yourself. The long
+ answer is that to write these in such a way that multiple platforms are
+ supported correctly would just require too much code. Below are
+ some examples how you can implement these yourself.
+
+ sub mput {
+ my($ftp,$pattern) = @_;
+ foreach my $file (<$pattern>) {
+ $ftp->put($file) or warn $ftp->message;
+ }
+ }
+
+ sub mget {
+ my($ftp,$pattern) = @_;
+ foreach my $file ($ftp->ls($pattern)) {
+ $ftp->get($file) or warn $ftp->message;
+ }
+ }
+
+
+ =back
+
+ =head1 Using Net::SMTP
+
+ =over
+
+ =head2 Why can't the part of an Email address after the @ be used as the hostname ?
+
+ The part of an Email address which follows the @ is not necessarily a hostname,
+ it is a mail domain. To find the name of a host to connect for a mail domain
+ you need to do a DNS MX lookup
+
+ =head2 Why does Net::SMTP not do DNS MX lookups ?
+
+ Net::SMTP implements the SMTP protocol. The DNS MX lookup is not part
+ of this protocol.
+
+ =head2 The verify method always returns true ?
+
+ Well it may seem thay way, but it does not. The verify method returns true
+ if the command suceeded. If you pass verify an address which the
+ server would normally have to forward to another machine the the command
+ will suceed with something like
+
+ 252 Couldn't verify <someone@there> but will attempt delivery anyway
+
+ This command will only fail if you pass it an address in a domain the
+ the server directly delivers for, and that address does not exist.
+
+ =back
+
+ =head1 Debugging scripts
+
+ =over
+
+ =head2 How can I debug my scripts that use Net::* modules ?
+
+ Most of the libnet client classes allow options to be passed to the
+ constructor, in most cases one option is called C<Debug>. Passing
+ this option with a non-zero value will turn on a protocol trace, which
+ will be sent to STDERR. This trace can be useful to see what commands
+ are being sent to the remote server and what responces are being
+ received back.
+
+ #!/your/path/to/perl
+
+ use Net::FTP;
+
+ my $ftp = new Net::FTP($host, Debug => 1);
+ $ftp->login('gbarr','password');
+ $ftp->quit;
+
+ this script would output something like
+
+ Net::FTP: Net::FTP(2.22)
+ Net::FTP: Exporter
+ Net::FTP: Net::Cmd(2.0801)
+ Net::FTP: IO::Socket::INET
+ Net::FTP: IO::Socket(1.1603)
+ Net::FTP: IO::Handle(1.1504)
+
+ Net::FTP=GLOB(0x8152974)<<< 220 imagine FTP server (Version wu-2.4(5) Tue Jul 29 11:17:18 CDT 1997) ready.
+ Net::FTP=GLOB(0x8152974)>>> user gbarr
+ Net::FTP=GLOB(0x8152974)<<< 331 Password required for gbarr.
+ Net::FTP=GLOB(0x8152974)>>> PASS ....
+ Net::FTP=GLOB(0x8152974)<<< 230 User gbarr logged in. Access restrictions apply.
+ Net::FTP=GLOB(0x8152974)>>> QUIT
+ Net::FTP=GLOB(0x8152974)<<< 221 Goodbye.
+
+ The first few lines tell you the modules that Net::FTP uses and thier versions,
+ this is usefule data to me when a user reports a bug. The last seven lines
+ show the communication with the server. Each line has three parts. The first
+ part is the object itself, this is useful for separating the output
+ if you are using mutiple objects. The second part is either C<<<<<> to
+ show data coming from the server or C<>>>>> to show data
+ going to the server. The remainder of the line is the command
+ being sent or responce being received.
+
+ =back
+
+ =head1 AUTHOR AND COPYRIGHT
+
+ Copyright (c) 1997 Graham Barr.
+ All rights reserved.
diff -c /dev/null 'perl-5.7.2/lib/Net/netent.t'
Index: ./lib/Net/netent.t
*** ./lib/Net/netent.t Thu Jan 1 02:00:00 1970
--- ./lib/Net/netent.t Mon Jul 9 17:10:40 2001
***************
*** 0 ****
--- 1,36 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ BEGIN {
+ our $hasne;
+ eval { my @n = getnetbyname "loopback" };
+ $hasne = 1 unless $@ && $@ =~ /unimplemented|unsupported/i;
+ unless ($hasne) { print "1..0 # Skip: no getnetbyname\n"; exit 0 }
+ use Config;
+ $hasne = 0 unless $Config{'i_netdb'} eq 'define';
+ unless ($hasne) { print "1..0 # Skip: no netdb.h\n"; exit 0 }
+ }
+
+ BEGIN {
+ our @netent = getnetbyname "loopback"; # This is the function getnetbyname.
+ unless (@netent) { print "1..0 # Skip: no loopback net\n"; exit 0 }
+ }
+
+ print "1..2\n";
+
+ use Net::netent;
+
+ print "ok 1\n";
+
+ my $netent = getnetbyname "loopback"; # This is the OO getnetbyname.
+
+ print "not " unless $netent->name eq $netent[0];
+ print "ok 2\n";
+
+ # Testing pretty much anything else is unportable;
+ # e.g. the canonical name of the "loopback" net may be "loop".
+
diff -c /dev/null 'perl-5.7.2/lib/Net/protoent.t'
Index: ./lib/Net/protoent.t
*** ./lib/Net/protoent.t Thu Jan 1 02:00:00 1970
--- ./lib/Net/protoent.t Mon Jul 9 17:10:40 2001
***************
*** 0 ****
--- 1,38 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ BEGIN {
+ our $haspe;
+ eval { my @n = getprotobyname "tcp" };
+ $haspe = 1 unless $@ && $@ =~ /unimplemented|unsupported/i;
+ unless ($haspe) { print "1..0 # Skip: no getprotobyname\n"; exit 0 }
+ use Config;
+ $haspe = 0 unless $Config{'i_netdb'} eq 'define';
+ unless ($haspe) { print "1..0 # Skip: no netdb.h\n"; exit 0 }
+ }
+
+ BEGIN {
+ our @protoent = getprotobyname "tcp"; # This is the function getprotobyname.
+ unless (@protoent) { print "1..0 # Skip: no tcp protocol\n"; exit 0 }
+ }
+
+ print "1..3\n";
+
+ use Net::protoent;
+
+ print "ok 1\n";
+
+ my $protoent = getprotobyname "tcp"; # This is the OO getprotobyname.
+
+ print "not " unless $protoent->name eq $protoent[0];
+ print "ok 2\n";
+
+ print "not " unless $protoent->proto == $protoent[2];
+ print "ok 3\n";
+
+ # Testing pretty much anything else is unportable.
+
diff -c /dev/null 'perl-5.7.2/lib/Net/servent.t'
Index: ./lib/Net/servent.t
*** ./lib/Net/servent.t Thu Jan 1 02:00:00 1970
--- ./lib/Net/servent.t Mon Jul 9 17:10:40 2001
***************
*** 0 ****
--- 1,38 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ BEGIN {
+ our $hasse;
+ eval { my @n = getservbyname "echo", "tcp" };
+ $hasse = 1 unless $@ && $@ =~ /unimplemented|unsupported/i;
+ unless ($hasse) { print "1..0 # Skip: no getservbyname\n"; exit 0 }
+ use Config;
+ $hasse = 0 unless $Config{'i_netdb'} eq 'define';
+ unless ($hasse) { print "1..0 # Skip: no netdb.h\n"; exit 0 }
+ }
+
+ BEGIN {
+ our @servent = getservbyname "echo", "tcp"; # This is the function getservbyname.
+ unless (@servent) { print "1..0 # Skip: no echo service\n"; exit 0 }
+ }
+
+ print "1..3\n";
+
+ use Net::servent;
+
+ print "ok 1\n";
+
+ my $servent = getservbyname "echo", "tcp"; # This is the OO getservbyname.
+
+ print "not " unless $servent->name eq $servent[0];
+ print "ok 2\n";
+
+ print "not " unless $servent->port == $servent[2];
+ print "ok 3\n";
+
+ # Testing pretty much anything else is unportable.
+
diff -c /dev/null 'perl-5.7.2/lib/Net/t/ftp.t'
Index: ./lib/Net/t/ftp.t
*** ./lib/Net/t/ftp.t Thu Jan 1 02:00:00 1970
--- ./lib/Net/t/ftp.t Mon Jul 9 17:10:40 2001
***************
*** 0 ****
--- 1,60 ----
+ #!./perl -w
+
+ use Net::Config;
+ use Net::FTP;
+
+ unless(defined($NetConfig{ftp_testhost}) && $NetConfig{test_hosts}) {
+ print "1..0\n";
+ exit 0;
+ }
+
+ my $t = 1;
+ print "1..7\n";
+
+ $ftp = Net::FTP->new($NetConfig{ftp_testhost}, Debug => 0)
+ or (print("not ok 1\n"), exit);
+
+ printf "ok %d\n",$t++;
+
+ $ftp->login('anonymous') or die($ftp->message . "\n");
+ printf "ok %d\n",$t++;
+
+ $ftp->pwd or do {
+ print STDERR $ftp->message,"\n";
+ print "not ";
+ };
+
+ printf "ok %d\n",$t++;
+
+ $ftp->cwd('/pub') or do {
+ print STDERR $ftp->message,"\n";
+ print "not ";
+ };
+
+ if ($data = $ftp->stor('libnet.tst')) {
+ my $text = "abc\ndef\nqwe\n";
+ printf "ok %d\n",$t++;
+ $data->write($text,length $text);
+ $data->close;
+ $data = $ftp->retr('libnet.tst');
+ $data->read($buf,length $text);
+ $data->close;
+ print "not " unless $text eq $buf;
+ printf "ok %d\n",$t++;
+ $ftp->delete('libnet.tst') or print "not ";
+ printf "ok %d\n",$t++;
+
+ }
+ else {
+ print STDERR $ftp->message,"\n";
+ printf "not ok %d\n",$t++;
+ printf "not ok %d\n",$t++;
+ printf "not ok %d\n",$t++;
+ }
+
+ $ftp->quit or do {
+ print STDERR $ftp->message,"\n";
+ print "not ";
+ };
+
+ printf "ok %d\n",$t++;
diff -c /dev/null 'perl-5.7.2/lib/Net/t/hostname.t'
Index: ./lib/Net/t/hostname.t
*** ./lib/Net/t/hostname.t Thu Jan 1 02:00:00 1970
--- ./lib/Net/t/hostname.t Mon Jul 9 17:10:41 2001
***************
*** 0 ****
--- 1,19 ----
+
+ use Net::Domain qw(hostname domainname hostdomain);
+ use Net::Config;
+
+ unless($NetConfig{test_hosts}) {
+ print "1..0\n";
+ exit 0;
+ }
+
+ print "1..1\n";
+
+ $domain = domainname();
+
+ if(defined $domain && $domain ne "") {
+ print "ok 1\n";
+ }
+ else {
+ print "not ok 1\n";
+ }
diff -c /dev/null 'perl-5.7.2/lib/Net/t/nntp.t'
Index: ./lib/Net/t/nntp.t
*** ./lib/Net/t/nntp.t Thu Jan 1 02:00:00 1970
--- ./lib/Net/t/nntp.t Mon Jul 9 17:10:41 2001
***************
*** 0 ****
--- 1,46 ----
+ #!./perl -w
+
+ use Net::Config;
+ use Net::NNTP;
+ use Net::Cmd qw(CMD_REJECT);
+
+ unless(@{$NetConfig{nntp_hosts}} && $NetConfig{test_hosts}) {
+ print "1..0\n";
+ exit;
+ }
+
+ print "1..4\n";
+
+ my $i = 1;
+
+ $nntp = Net::NNTP->new(Debug => 0)
+ or (print("not ok 1\n"), exit);
+
+ print "ok 1\n";
+
+ my $grp;
+ foreach $grp (qw(test alt.test control news.announce.newusers)) {
+ @grp = $nntp->group($grp);
+ last if @grp;
+ }
+
+ if($nntp->status == CMD_REJECT) {
+ # Command was rejected, probably because we need authinfo
+ map { print "ok ",$_,"\n" } 2,3,4;
+ exit;
+ }
+
+ print "not " unless @grp;
+ print "ok 2\n";
+
+
+ if(@grp && $grp[2] > $grp[1]) {
+ $nntp->head($grp[1]) or print "not ";
+ }
+ print "ok 3\n";
+
+ if(@grp) {
+ $nntp->quit or print "not ";
+ }
+ print "ok 4\n";
+
diff -c /dev/null 'perl-5.7.2/lib/Net/t/require.t'
Index: ./lib/Net/t/require.t
*** ./lib/Net/t/require.t Thu Jan 1 02:00:00 1970
--- ./lib/Net/t/require.t Mon Jul 9 17:10:41 2001
***************
*** 0 ****
--- 1,14 ----
+
+ print "1..9\n";
+ my $i = 1;
+ eval { require Net::Config; } || print "not "; print "ok ",$i++,"\n";
+ eval { require Net::Domain; } || print "not "; print "ok ",$i++,"\n";
+ eval { require Net::Cmd; } || print "not "; print "ok ",$i++,"\n";
+ eval { require Net::Netrc; } || print "not "; print "ok ",$i++,"\n";
+ eval { require Net::FTP; } || print "not "; print "ok ",$i++,"\n";
+ eval { require Net::SMTP; } || print "not "; print "ok ",$i++,"\n";
+ eval { require Net::NNTP; } || print "not "; print "ok ",$i++,"\n";
+ eval { require Net::POP3; } || print "not "; print "ok ",$i++,"\n";
+ eval { require Net::Time; } || print "not "; print "ok ",$i++,"\n";
+
+
diff -c /dev/null 'perl-5.7.2/lib/Net/t/smtp.t'
Index: ./lib/Net/t/smtp.t
*** ./lib/Net/t/smtp.t Thu Jan 1 02:00:00 1970
--- ./lib/Net/t/smtp.t Mon Jul 9 17:10:41 2001
***************
*** 0 ****
--- 1,25 ----
+ #!./perl -w
+
+ use Net::Config;
+ use Net::SMTP;
+
+ unless(@{$NetConfig{smtp_hosts}} && $NetConfig{test_hosts}) {
+ print "1..0\n";
+ exit 0;
+ }
+
+ print "1..3\n";
+
+ my $i = 1;
+
+ $smtp = Net::SMTP->new(Debug => 0)
+ or (print("not ok 1\n"), exit);
+
+ print "ok 1\n";
+
+ $smtp->domain or print "not ";
+ print "ok 2\n";
+
+ $smtp->quit or print "not ";
+ print "ok 3\n";
+
diff -c 'perl-5.7.1/lib/PerlIO.pm' 'perl-5.7.2/lib/PerlIO.pm'
Index: ./lib/PerlIO.pm
*** ./lib/PerlIO.pm Wed Mar 28 21:32:55 2001
--- ./lib/PerlIO.pm Mon Jul 9 17:25:42 2001
***************
*** 39,46 ****
=head1 DESCRIPTION
! When an undefined layer 'foo' is encountered in an C<open> or C<binmode> layer
! specification then C code performs the equivalent of:
use PerlIO 'foo';
--- 39,46 ----
=head1 DESCRIPTION
! When an undefined layer 'foo' is encountered in an C<open> or
! C<binmode> layer specification then C code performs the equivalent of:
use PerlIO 'foo';
***************
*** 48,55 ****
require PerlIO::foo;
! Otherwise the C<PerlIO> package is a place holder for additional PerLIO related
! functions.
The following layers are currently defined:
--- 48,55 ----
require PerlIO::foo;
! Otherwise the C<PerlIO> package is a place holder for additional
! PerlIO related functions.
The following layers are currently defined:
***************
*** 61,105 ****
=item stdio
! Layer which calls C<fread>, C<fwrite> and C<fseek>/C<ftell> etc.
! Note that as this is "real" stdio it will ignore any layers beneath it and
got straight to the operating system via the C library as usual.
=item perlio
! This is a re-implementation of "stdio-like" buffering written as a PerlIO "layer".
! As such it will call whatever layer is below it for its operations.
=item crlf
! A layer which does CRLF to "\n" translation distinguishing "text" and "binary"
! files in the manner of MS-DOS and similar operating systems.
=item utf8
! Declares that the stream accepts perl's internal encoding of characters.
! (Which really is UTF-8 on ASCII machines, but is UTF-EBCDIC on EBCDIC machines.)
! This allows any character perl can represent to be read from or written to the
! stream. The UTF-X encoding is chosen to render simple text parts (i.e.
! non-accented letters, digits and common punctuation) human readable in the
! encoded file.
=item raw
! A pseudo-layer which performs two functions (which is messy, but necessary to
! maintain compatibility with non-PerLIO builds of perl and they way things
! have been documented elsewhere).
! Firstly it forces the file handle to be considered binary at that point
! in the layer stack,
! Secondly in prevents the IO system seaching back before it in the layer specification.
! Thus:
! open($fh,":raw:perlio"),...)
! Forces the use of C<perlio> layer even if the platform default, or C<use open> default
! is something else (such as ":encoding(iso-8859-7)" ) which would interfere with
binary nature of the stream.
=back
--- 61,118 ----
=item stdio
! Layer which calls C<fread>, C<fwrite> and C<fseek>/C<ftell> etc. Note
! that as this is "real" stdio it will ignore any layers beneath it and
got straight to the operating system via the C library as usual.
=item perlio
! This is a re-implementation of "stdio-like" buffering written as a
! PerlIO "layer". As such it will call whatever layer is below it for
! its operations.
=item crlf
! A layer which does CRLF to "\n" translation distinguishing "text" and
! "binary" files in the manner of MS-DOS and similar operating systems.
=item utf8
! Declares that the stream accepts perl's internal encoding of
! characters. (Which really is UTF-8 on ASCII machines, but is
! UTF-EBCDIC on EBCDIC machines.) This allows any character perl can
! represent to be read from or written to the stream. The UTF-X encoding
! is chosen to render simple text parts (i.e. non-accented letters,
! digits and common punctuation) human readable in the encoded file.
+ Here is how to write your native data out using UTF-8 (or UTF-EBCDIC)
+ and then read it back in.
+
+ open(F, ">:utf8", "data.utf");
+ print F $out;
+ close(F);
+
+ open(F, "<:utf8", "data.utf");
+ $in = <F>;
+ close(F);
+
=item raw
! A pseudo-layer which performs two functions (which is messy, but
! necessary to maintain compatibility with non-PerlIO builds of Perl
! and their way things have been documented elsewhere).
! Firstly it forces the file handle to be considered binary at that
! point in the layer stack,
! Secondly in prevents the IO system seaching back before it in the
! layer specification. Thus:
! open($fh,":raw:perlio",...)
! Forces the use of C<perlio> layer even if the platform default, or
! C<use open> default is something else (such as ":encoding(iso-8859-7)")
! (the C<:encoding> requires C<use Encode>) which would interfere with
binary nature of the stream.
=back
***************
*** 106,120 ****
=head2 Defaults and how to override them
! If the platform is MS-DOS like and normally does CRLF to "\n" translation
! for text files then the default layers are :
unix crlf
! (The low level "unix" layer may be replaced by a platform specific low level layer.)
! Otherwise if C<Configure> found out how to do "fast" IO using system's stdio, then
! the default layers are :
unix stdio
--- 119,134 ----
=head2 Defaults and how to override them
! If the platform is MS-DOS like and normally does CRLF to "\n"
! translation for text files then the default layers are :
unix crlf
! (The low level "unix" layer may be replaced by a platform specific low
! level layer.)
! Otherwise if C<Configure> found out how to do "fast" IO using system's
! stdio, then the default layers are :
unix stdio
***************
*** 124,132 ****
These defaults may change once perlio has been better tested and tuned.
! The default can be overridden by setting the environment variable PERLIO
! to a space separated list of layers (unix or platform low level layer is
! always pushed first).
This can be used to see the effect of/bugs in the various layers e.g.
cd .../perl/t
--- 138,147 ----
These defaults may change once perlio has been better tested and tuned.
! The default can be overridden by setting the environment variable
! PERLIO to a space separated list of layers (unix or platform low level
! layer is always pushed first).
!
This can be used to see the effect of/bugs in the various layers e.g.
cd .../perl/t
***************
*** 139,145 ****
=head1 SEE ALSO
! L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<open>
=cut
--- 154,160 ----
=head1 SEE ALSO
! L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<Encode>
=cut
diff -c 'perl-5.7.1/lib/Pod/Html.pm' 'perl-5.7.2/lib/Pod/Html.pm'
Index: ./lib/Pod/Html.pm
*** ./lib/Pod/Html.pm Tue Mar 6 04:05:33 2001
--- ./lib/Pod/Html.pm Mon Jul 9 17:10:41 2001
***************
*** 3,9 ****
require Exporter;
use vars qw($VERSION @ISA @EXPORT);
! $VERSION = 1.03;
@ISA = qw(Exporter);
@EXPORT = qw(pod2html htmlify);
--- 3,9 ----
require Exporter;
use vars qw($VERSION @ISA @EXPORT);
! $VERSION = 1.04;
@ISA = qw(Exporter);
@EXPORT = qw(pod2html htmlify);
***************
*** 43,48 ****
--- 43,54 ----
Adds "Back to Top" links in front of every HEAD1 heading (except for
the first). By default, no backlink are being generated.
+ =item cachedir
+
+ --cachedir=name
+
+ Creates the item and directory caches in the given directory.
+
=item css
--css=stylesheet
***************
*** 194,199 ****
--- 200,207 ----
=cut
+ my $cachedir = "."; # The directory to which item and directory
+ # caches will be written.
my $cache_ext = $^O eq 'VMS' ? ".tmp" : ".x~~";
my $dircache = "pod2htmd$cache_ext";
my $itemcache = "pod2htmi$cache_ext";
***************
*** 305,311 ****
${$dataref}[$i] =~ s/\s+\Z//;
# have a look for all-space lines
! if( ${$dataref}[$i] =~ /^\s+$/m ){
my @chunks = split( /^\s+$/m, ${$dataref}[$i] );
splice( @$dataref, $i, 1, @chunks );
}
--- 313,319 ----
${$dataref}[$i] =~ s/\s+\Z//;
# have a look for all-space lines
! if( ${$dataref}[$i] =~ /^\s+$/m and $dataref->[$i] !~ /^\s/ ){
my @chunks = split( /^\s+$/m, ${$dataref}[$i] );
splice( @$dataref, $i, 1, @chunks );
}
***************
*** 491,496 ****
--- 499,505 ----
else {
next if $ignore;
next if @begin_stack && $begin_stack[-1] ne 'html';
+ print HTML and next if @begin_stack && $begin_stack[-1] eq 'html';
my $text = $_;
if( $text =~ /\A\s+/ ){
process_pre( \$text );
***************
*** 565,573 ****
Usage: $0 --help --htmlroot=<name> --infile=<name> --outfile=<name>
--podpath=<name>:...:<name> --podroot=<name>
--libpods=<name>:...:<name> --recurse --verbose --index
! --netscape --norecurse --noindex
--backlink - set text for "back to top" links (default: none).
--css - stylesheet URL
--flush - flushes the item and directory caches.
--[no]header - produce block header/footer (default is no headers).
--- 574,583 ----
Usage: $0 --help --htmlroot=<name> --infile=<name> --outfile=<name>
--podpath=<name>:...:<name> --podroot=<name>
--libpods=<name>:...:<name> --recurse --verbose --index
! --netscape --norecurse --noindex --cachedir=<name>
--backlink - set text for "back to top" links (default: none).
+ --cachedir - directory for the item and directory cache files.
--css - stylesheet URL
--flush - flushes the item and directory caches.
--[no]header - produce block header/footer (default is no headers).
***************
*** 600,613 ****
END_OF_USAGE
sub parse_command_line {
! my ($opt_backlink,$opt_css,$opt_flush,$opt_header,$opt_help,$opt_htmldir,
! $opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,$opt_netscape,
! $opt_outfile,$opt_podpath,$opt_podroot,$opt_quiet,$opt_recurse,
! $opt_title,$opt_verbose);
unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html};
my $result = GetOptions(
'backlink=s' => \$opt_backlink,
'css=s' => \$opt_css,
'flush' => \$opt_flush,
'header!' => \$opt_header,
--- 610,624 ----
END_OF_USAGE
sub parse_command_line {
! my ($opt_backlink,$opt_cachedir,$opt_css,$opt_flush,$opt_header,$opt_help,
! $opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,
! $opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_quiet,
! $opt_recurse,$opt_title,$opt_verbose);
unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html};
my $result = GetOptions(
'backlink=s' => \$opt_backlink,
+ 'cachedir=s' => \$opt_cachedir,
'css=s' => \$opt_css,
'flush' => \$opt_flush,
'header!' => \$opt_header,
***************
*** 635,640 ****
--- 646,652 ----
@libpods = split(":", $opt_libpods) if defined $opt_libpods;
$backlink = $opt_backlink if defined $opt_backlink;
+ $cachedir = $opt_cachedir if defined $opt_cachedir;
$css = $opt_css if defined $opt_css;
$header = $opt_header if defined $opt_header;
$htmldir = $opt_htmldir if defined $opt_htmldir;
***************
*** 651,656 ****
--- 663,670 ----
warn "Flushing item and directory caches\n"
if $opt_verbose && defined $opt_flush;
+ $dircache = "$cachedir/pod2htmd$cache_ext";
+ $itemcache = "$cachedir/pod2htmi$cache_ext";
unlink($dircache, $itemcache) if defined $opt_flush;
}
diff -c 'perl-5.7.1/lib/Pod/Man.pm' 'perl-5.7.2/lib/Pod/Man.pm'
Index: ./lib/Pod/Man.pm
Prereq: 1.16
*** ./lib/Pod/Man.pm Mon Apr 9 16:34:48 2001
--- ./lib/Pod/Man.pm Tue Jul 10 17:16:14 2001
***************
*** 1,16 ****
# Pod::Man -- Convert POD data to formatted *roff input.
! # $Id: Man.pm,v 1.16 2001/04/09 13:06:02 eagle Exp $
#
# Copyright 1999, 2000, 2001 by Russ Allbery <rra@stanford.edu>
#
! # This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
# This module is intended to be a replacement for the pod2man script
# distributed with versions of Perl prior to 5.6, and attempts to match its
# output except for some specific circumstances where other decisions seemed
! # to produce better output. It uses Pod::Parser and is designed to be easy
! # to subclass.
#
# Perl core hackers, please note that this module is also separately
# maintained outside of the Perl core as part of the podlators. Please send
--- 1,16 ----
# Pod::Man -- Convert POD data to formatted *roff input.
! # $Id: Man.pm,v 1.19 2001/07/10 11:08:09 eagle Exp $
#
# Copyright 1999, 2000, 2001 by Russ Allbery <rra@stanford.edu>
#
! # This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.
#
# This module is intended to be a replacement for the pod2man script
# distributed with versions of Perl prior to 5.6, and attempts to match its
# output except for some specific circumstances where other decisions seemed
! # to produce better output. It uses Pod::Parser and is designed to be easy to
! # subclass.
#
# Perl core hackers, please note that this module is also separately
# maintained outside of the Perl core as part of the podlators. Please send
***************
*** 17,25 ****
# me any patches at the address above in addition to sending them to the
# standard Perl mailing lists.
! ############################################################################
# Modules and declarations
! ############################################################################
package Pod::Man;
--- 17,25 ----
# me any patches at the address above in addition to sending them to the
# standard Perl mailing lists.
! ##############################################################################
# Modules and declarations
! ##############################################################################
package Pod::Man;
***************
*** 34,56 ****
@ISA = qw(Pod::Parser);
! # Don't use the CVS revision as the version, since this module is also in
! # Perl core and too many things could munge CVS magic revision strings.
! # This number should ideally be the same as the CVS revision in podlators,
! # however.
! $VERSION = 1.16;
! ############################################################################
# Preamble and *roff output tables
! ############################################################################
# The following is the static preamble which starts all *roff output we
# generate. It's completely static except for the font to use as a
# fixed-width font, which is designed by @CFONT@, and the left and right
! # quotes to use for C<> text, designated by @LQOUTE@ and @RQUOTE@.
! # $PREAMBLE should therefore be run through s/\@CFONT\@/<font>/g before
! # output.
$PREAMBLE = <<'----END OF PREAMBLE----';
.de Sh \" Subsection heading
.br
--- 34,54 ----
@ISA = qw(Pod::Parser);
! # Don't use the CVS revision as the version, since this module is also in Perl
! # core and too many things could munge CVS magic revision strings. This
! # number should ideally be the same as the CVS revision in podlators, however.
! $VERSION = 1.19;
! ##############################################################################
# Preamble and *roff output tables
! ##############################################################################
# The following is the static preamble which starts all *roff output we
# generate. It's completely static except for the font to use as a
# fixed-width font, which is designed by @CFONT@, and the left and right
! # quotes to use for C<> text, designated by @LQOUTE@ and @RQUOTE@. $PREAMBLE
! # should therefore be run through s/\@CFONT\@/<font>/g before output.
$PREAMBLE = <<'----END OF PREAMBLE----';
.de Sh \" Subsection heading
.br
***************
*** 64,75 ****
.if t .sp .5v
.if n .sp
..
- .de Ip \" List item
- .br
- .ie \\n(.$>=3 .ne \\$3
- .el .ne 3
- .IP "\\$1" \\$2
- ..
.de Vb \" Begin verbatim text
.ft @CFONT@
.nf
--- 62,67 ----
***************
*** 83,91 ****
.\" Set up some character translations and predefined strings. \*(-- will
.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left
.\" double quote, and \*(R" will give a right double quote. | will give a
! .\" real vertical bar. \*(C+ will give a nicer C++. Capital omega is used
! .\" to do unbreakable dashes and therefore won't be available. \*(C` and
! .\" \*(C' expand to `' in nroff, nothing in troff, for use with C<>
.tr \(*W-|\(bv\*(Tr
.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p'
.ie n \{\
--- 75,83 ----
.\" Set up some character translations and predefined strings. \*(-- will
.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left
.\" double quote, and \*(R" will give a right double quote. | will give a
! .\" real vertical bar. \*(C+ will give a nicer C++. Capital omega is used to
! .\" do unbreakable dashes and therefore won't be available. \*(C` and \*(C'
! .\" expand to `' in nroff, nothing in troff, for use with C<>.
.tr \(*W-|\(bv\*(Tr
.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p'
.ie n \{\
***************
*** 105,114 ****
. ds R" ''
'br\}
.\"
! .\" If the F register is turned on, we'll generate index entries on stderr
! .\" for titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and
! .\" index entries marked with X<> in POD. Of course, you'll have to process
! .\" the output yourself in some meaningful fashion.
.if \nF \{\
. de IX
. tm Index:\\$1\t\\n%\t"\\$2"
--- 97,106 ----
. ds R" ''
'br\}
.\"
! .\" If the F register is turned on, we'll generate index entries on stderr for
! .\" titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and index
! .\" entries marked with X<> in POD. Of course, you'll have to process the
! .\" output yourself in some meaningful fashion.
.if \nF \{\
. de IX
. tm Index:\\$1\t\\n%\t"\\$2"
***************
*** 117,130 ****
. rr F
.\}
.\"
! .\" For nroff, turn off justification. Always turn off hyphenation; it
! .\" makes way too many mistakes in technical documents.
.hy 0
.if n .na
.\"
.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2).
.\" Fear. Run. Save yourself. No user-serviceable parts.
- .bd B 3
. \" fudge factors for nroff and troff
.if n \{\
. ds #H 0
--- 109,121 ----
. rr F
.\}
.\"
! .\" For nroff, turn off justification. Always turn off hyphenation; it makes
! .\" way too many mistakes in technical documents.
.hy 0
.if n .na
.\"
.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2).
.\" Fear. Run. Save yourself. No user-serviceable parts.
. \" fudge factors for nroff and troff
.if n \{\
. ds #H 0
***************
*** 265,278 ****
);
! ############################################################################
# Static helper functions
! ############################################################################
! # Protect leading quotes and periods against interpretation as commands.
! # Also protect anything starting with a backslash, since it could expand
! # or hide something that *roff would interpret as a command. This is
! # overkill, but it's much simpler than trying to parse *roff here.
sub protect {
local $_ = shift;
s/^([.\'\\])/\\&$1/mg;
--- 256,269 ----
);
! ##############################################################################
# Static helper functions
! ##############################################################################
! # Protect leading quotes and periods against interpretation as commands. Also
! # protect anything starting with a backslash, since it could expand or hide
! # something that *roff would interpret as a command. This is overkill, but
! # it's much simpler than trying to parse *roff here.
sub protect {
local $_ = shift;
s/^([.\'\\])/\\&$1/mg;
***************
*** 283,303 ****
sub toescape { (length ($_[0]) > 1 ? '\f(' : '\f') . $_[0] }
! ############################################################################
# Initialization
! ############################################################################
! # Initialize the object. Here, we also process any additional options
! # passed to the constructor or set up defaults if none were given. center
! # is the centered title, release is the version number, and date is the date
! # for the documentation. Note that we can't know what file name we're
! # processing due to the architecture of Pod::Parser, so that *has* to either
! # be passed to the constructor or set separately with Pod::Man::name().
sub initialize {
my $self = shift;
! # Figure out the fixed-width font. If user-supplied, make sure that
! # they are the right length.
for (qw/fixed fixedbold fixeditalic fixedbolditalic/) {
if (defined $$self{$_}) {
if (length ($$self{$_}) < 1 || length ($$self{$_}) > 2) {
--- 274,294 ----
sub toescape { (length ($_[0]) > 1 ? '\f(' : '\f') . $_[0] }
! ##############################################################################
# Initialization
! ##############################################################################
! # Initialize the object. Here, we also process any additional options passed
! # to the constructor or set up defaults if none were given. center is the
! # centered title, release is the version number, and date is the date for the
! # documentation. Note that we can't know what file name we're processing due
! # to the architecture of Pod::Parser, so that *has* to either be passed to the
! # constructor or set separately with Pod::Man::name().
sub initialize {
my $self = shift;
! # Figure out the fixed-width font. If user-supplied, make sure that they
! # are the right length.
for (qw/fixed fixedbold fixeditalic fixedbolditalic/) {
if (defined $$self{$_}) {
if (length ($$self{$_}) < 1 || length ($$self{$_}) > 2) {
***************
*** 309,323 ****
}
}
! # Set the default fonts. We can't be sure what fixed bold-italic is
! # going to be called, so default to just bold.
$$self{fixed} ||= 'CW';
$$self{fixedbold} ||= 'CB';
$$self{fixeditalic} ||= 'CI';
$$self{fixedbolditalic} ||= 'CB';
! # Set up a table of font escapes. First number is fixed-width, second
! # is bold, third is italic.
$$self{FONTS} = { '000' => '\fR', '001' => '\fI',
'010' => '\fB', '011' => '\f(BI',
'100' => toescape ($$self{fixed}),
--- 300,314 ----
}
}
! # Set the default fonts. We can't be sure what fixed bold-italic is going
! # to be called, so default to just bold.
$$self{fixed} ||= 'CW';
$$self{fixedbold} ||= 'CB';
$$self{fixeditalic} ||= 'CI';
$$self{fixedbolditalic} ||= 'CB';
! # Set up a table of font escapes. First number is fixed-width, second is
! # bold, third is italic.
$$self{FONTS} = { '000' => '\fR', '001' => '\fI',
'010' => '\fB', '011' => '\f(BI',
'100' => toescape ($$self{fixed}),
***************
*** 330,339 ****
unless defined $$self{center};
$$self{indent} = 4 unless defined $$self{indent};
! # We used to try first to get the version number from a local binary,
! # but we shouldn't need that any more. Get the version from the running
! # Perl. Work a little magic to handle subversions correctly under both
! # the pre-5.6 and the post-5.6 version numbering schemes.
if (!defined $$self{release}) {
my @version = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/);
$version[2] ||= 0;
--- 321,330 ----
unless defined $$self{center};
$$self{indent} = 4 unless defined $$self{indent};
! # We used to try first to get the version number from a local binary, but
! # we shouldn't need that any more. Get the version from the running Perl.
! # Work a little magic to handle subversions correctly under both the
! # pre-5.6 and the post-5.6 version numbering schemes.
if (!defined $$self{release}) {
my @version = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/);
$version[2] ||= 0;
***************
*** 361,369 ****
croak qq(Invalid quote specification "$$self{quotes}");
}
! # Double the first quote; note that this should not be s///g as two
! # double quotes is represented in *roff as three double quotes, not
! # four. Weird, I know.
$$self{LQUOTE} =~ s/\"/\"\"/;
$$self{RQUOTE} =~ s/\"/\"\"/;
--- 352,360 ----
croak qq(Invalid quote specification "$$self{quotes}");
}
! # Double the first quote; note that this should not be s///g as two double
! # quotes is represented in *roff as three double quotes, not four. Weird,
! # I know.
$$self{LQUOTE} =~ s/\"/\"\"/;
$$self{RQUOTE} =~ s/\"/\"\"/;
***************
*** 394,401 ****
# */lib/*perl* standard or site_perl module
# */*perl*/lib from -D prefix=/opt/perl
# */*perl*/ random module hierarchy
! # which works. Should be fixed to use File::Spec. Also handle
! # a leading lib/ since that's what ExtUtils::MakeMaker creates.
for ($name) {
s%//+%/%g;
if ( s%^.*?/lib/[^/]*perl[^/]*/%%si
--- 385,392 ----
# */lib/*perl* standard or site_perl module
# */*perl*/lib from -D prefix=/opt/perl
# */*perl*/ random module hierarchy
! # which works. Should be fixed to use File::Spec. Also handle a
! # leading lib/ since that's what ExtUtils::MakeMaker creates.
for ($name) {
s%//+%/%g;
if ( s%^.*?/lib/[^/]*perl[^/]*/%%si
***************
*** 410,417 ****
}
}
! # If $name contains spaces, quote it; this mostly comes up in the case
! # of input from stdin.
$name = '"' . $name . '"' if ($name =~ /\s/);
# Modification date header. Try to use the modification time of our
--- 401,408 ----
}
}
! # If $name contains spaces, quote it; this mostly comes up in the case of
! # input from stdin.
$name = '"' . $name . '"' if ($name =~ /\s/);
# Modification date header. Try to use the modification time of our
***************
*** 435,443 ****
.\\" @{[ scalar localtime ]}
.\\"
.\\" Standard preamble:
! .\\" ======================================================================
$_
! .\\" ======================================================================
.\\"
.IX Title "$name $section"
.TH $name $section "$$self{release}" "$$self{date}" "$$self{center}"
--- 426,434 ----
.\\" @{[ scalar localtime ]}
.\\"
.\\" Standard preamble:
! .\\" ========================================================================
$_
! .\\" ========================================================================
.\\"
.IX Title "$name $section"
.TH $name $section "$$self{release}" "$$self{date}" "$$self{center}"
***************
*** 451,459 ****
}
! ############################################################################
# Core overrides
! ############################################################################
# Called for each command paragraph. Gets the command, the associated
# paragraph, the line number, and a Pod::Paragraph object. Just dispatches
--- 442,450 ----
}
! ##############################################################################
# Core overrides
! ##############################################################################
# Called for each command paragraph. Gets the command, the associated
# paragraph, the line number, and a Pod::Paragraph object. Just dispatches
***************
*** 463,473 ****
my $self = shift;
my $command = shift;
return if $command eq 'pod';
! return if ($$self{EXCLUDE} && $command ne 'end');
if ($self->can ('cmd_' . $command)) {
$command = 'cmd_' . $command;
$self->$command (@_);
! } else {
my ($text, $line, $paragraph) = @_;
my $file;
($file, $line) = $paragraph->file_line;
--- 454,464 ----
my $self = shift;
my $command = shift;
return if $command eq 'pod';
! return if ($$self{EXCLUDE} && $command ne 'end');
if ($self->can ('cmd_' . $command)) {
$command = 'cmd_' . $command;
$self->$command (@_);
! } else {
my ($text, $line, $paragraph) = @_;
my $file;
($file, $line) = $paragraph->file_line;
***************
*** 478,487 ****
}
}
! # Called for a verbatim paragraph. Gets the paragraph, the line number, and
! # a Pod::Paragraph object. Rofficate backslashes, untabify, put a
! # zero-width character at the beginning of each line to protect against
! # commands, and wrap in .Vb/.Ve.
sub verbatim {
my $self = shift;
return if $$self{EXCLUDE};
--- 469,478 ----
}
}
! # Called for a verbatim paragraph. Gets the paragraph, the line number, and a
! # Pod::Paragraph object. Rofficate backslashes, untabify, put a zero-width
! # character at the beginning of each line to protect against commands, and
! # wrap in .Vb/.Ve.
sub verbatim {
my $self = shift;
return if $$self{EXCLUDE};
***************
*** 497,512 ****
$$self{NEEDSPACE} = 0;
}
! # Called for a regular text block. Gets the paragraph, the line number, and
! # a Pod::Paragraph object. Perform interpolation and output the results.
sub textblock {
my $self = shift;
return if $$self{EXCLUDE};
$self->output ($_[0]), return if $$self{VERBATIM};
! # Perform a little magic to collapse multiple L<> references. We'll
! # just rewrite the whole thing into actual text at this part, bypassing
! # the whole internal sequence parsing thing.
my $text = shift;
$text =~ s{
(L< # A link of the form L</something>.
--- 488,503 ----
$$self{NEEDSPACE} = 0;
}
! # Called for a regular text block. Gets the paragraph, the line number, and a
! # Pod::Paragraph object. Perform interpolation and output the results.
sub textblock {
my $self = shift;
return if $$self{EXCLUDE};
$self->output ($_[0]), return if $$self{VERBATIM};
! # Perform a little magic to collapse multiple L<> references. We'll just
! # rewrite the whole thing into actual text at this part, bypassing the
! # whole internal sequence parsing thing.
my $text = shift;
$text =~ s{
(L< # A link of the form L</something>.
***************
*** 552,559 ****
# Called for an interior sequence. Takes a Pod::InteriorSequence object and
# returns a reference to a scalar. This scalar is the final formatted text.
! # It's returned as a reference so that other interior sequences above us
! # know that the text has already been processed.
sub sequence {
my ($self, $seq) = @_;
my $command = $seq->cmd_name;
--- 543,550 ----
# Called for an interior sequence. Takes a Pod::InteriorSequence object and
# returns a reference to a scalar. This scalar is the final formatted text.
! # It's returned as a reference so that other interior sequences above us know
! # that the text has already been processed.
sub sequence {
my ($self, $seq) = @_;
my $command = $seq->cmd_name;
***************
*** 594,601 ****
} elsif ($command eq 'I') {
return bless \ ('\f(IS' . $_ . '\f(IE'), 'Pod::Man::String';
} elsif ($command eq 'C') {
! return bless \ ('\f(FS\*(C`' . $_ . "\\*(C'\\f(FE"),
! 'Pod::Man::String';
}
# Handle links.
--- 585,593 ----
} elsif ($command eq 'I') {
return bless \ ('\f(IS' . $_ . '\f(IE'), 'Pod::Man::String';
} elsif ($command eq 'C') {
! # A bug in lvalue subs in 5.6 requires the temporary variable.
! my $tmp = $self->quote_literal ($_);
! return bless \ "$tmp", 'Pod::Man::String';
}
# Handle links.
***************
*** 619,634 ****
}
! ############################################################################
# Command paragraphs
! ############################################################################
# All command paragraphs take the paragraph and the line number.
# First level heading. We can't output .IX in the NAME section due to a bug
# in some versions of catman, so don't output a .IX for that section. .SH
! # already uses small caps, so remove any E<> sequences that would cause
! # them.
sub cmd_head1 {
my $self = shift;
local $_ = $self->parse (@_);
--- 611,625 ----
}
! ##############################################################################
# Command paragraphs
! ##############################################################################
# All command paragraphs take the paragraph and the line number.
# First level heading. We can't output .IX in the NAME section due to a bug
# in some versions of catman, so don't output a .IX for that section. .SH
! # already uses small caps, so remove any E<> sequences that would cause them.
sub cmd_head1 {
my $self = shift;
local $_ = $self->parse (@_);
***************
*** 728,737 ****
# An individual list item. Emit an index entry for anything that's
# interesting, but don't emit index entries for things like bullets and
! # numbers. rofficate bullets too while we're at it (so for nice output, use
! # * for your lists rather than o or . or - or some other thing). Newlines
! # in an item title are turned into spaces since *roff can't handle them
! # embedded.
sub cmd_item {
my $self = shift;
local $_ = $self->parse (@_);
--- 719,727 ----
# An individual list item. Emit an index entry for anything that's
# interesting, but don't emit index entries for things like bullets and
! # numbers. rofficate bullets too while we're at it (so for nice output, use *
! # for your lists rather than o or . or - or some other thing). Newlines in an
! # item title are turned into spaces since *roff can't handle them embedded.
sub cmd_item {
my $self = shift;
local $_ = $self->parse (@_);
***************
*** 749,755 ****
}
$_ = $self->textmapfonts ($_);
$self->output (".PD 0\n") if ($$self{ITEMS} == 1);
! $self->output ($self->switchquotes ('.Ip', $_, $$self{INDENT}));
$self->outindex ($index ? ('Item', $index) : ());
$$self{NEEDSPACE} = 0;
$$self{ITEMS}++;
--- 739,745 ----
}
$_ = $self->textmapfonts ($_);
$self->output (".PD 0\n") if ($$self{ITEMS} == 1);
! $self->output ($self->switchquotes ('.IP', $_, $$self{INDENT}));
$self->outindex ($index ? ('Item', $index) : ());
$$self{NEEDSPACE} = 0;
$$self{ITEMS}++;
***************
*** 786,794 ****
}
! ############################################################################
# Link handling
! ############################################################################
# Handle links. We can't actually make real hyperlinks, so this is all to
# figure out what text and formatting we print out.
--- 776,784 ----
}
! ##############################################################################
# Link handling
! ##############################################################################
# Handle links. We can't actually make real hyperlinks, so this is all to
# figure out what text and formatting we print out.
***************
*** 806,821 ****
s/^\s+//;
s/\s+$//;
! # If the argument looks like a URL, return it verbatim. This only
! # handles URLs that use the server syntax.
if (m%^[a-z]+://\S+$%) { return $_ }
! # Default to using the whole content of the link entry as a section
! # name. Note that L<manpage/> forces a manpage interpretation, as does
! # something looking like L<manpage(section)>. Do the same thing to
! # L<manpage(section)> as we would to manpage(section) without the L<>;
! # see guesswork(). If we've added italics, don't add the "manpage"
! # text; markup is sufficient.
my ($manpage, $section) = ('', $_);
if (/^"\s*(.*?)\s*"$/) {
$section = '"' . $1 . '"';
--- 796,810 ----
s/^\s+//;
s/\s+$//;
! # If the argument looks like a URL, return it verbatim. This only handles
! # URLs that use the server syntax.
if (m%^[a-z]+://\S+$%) { return $_ }
! # Default to using the whole content of the link entry as a section name.
! # Note that L<manpage/> forces a manpage interpretation, as does something
! # looking like L<manpage(section)>. Do the same to L<manpage(section)> as
! # we would to manpage(section) without the L<>; see guesswork(). If we've
! # added italics, don't add the "manpage" text; markup is sufficient.
my ($manpage, $section) = ('', $_);
if (/^"\s*(.*?)\s*"$/) {
$section = '"' . $1 . '"';
***************
*** 853,875 ****
}
! ############################################################################
# Escaping and fontification
! ############################################################################
# At this point, we'll have embedded font codes of the form \f(<font>[SE]
! # where <font> is one of B, I, or F. Turn those into the right font start
! # or end codes. The old pod2man didn't get B<someI<thing> else> right;
! # after I<> it switched back to normal text rather than bold. We take care
! # of this by using variables as a combined pointer to our current font
! # sequence, and set each to the number of current nestings of start tags for
! # that font. Use them as a vector to look up what font sequence to use.
#
# \fP changes to the previous font, but only one previous font is kept. We
# don't know what the outside level font is; normally it's R, but if we're
! # inside a heading it could be something else. So arrange things so that
! # the outside font is always the "previous" font and end with \fP instead of
! # \fR. Idea from Zack Weinberg.
sub mapfonts {
my $self = shift;
local $_ = shift;
--- 842,864 ----
}
! ##############################################################################
# Escaping and fontification
! ##############################################################################
# At this point, we'll have embedded font codes of the form \f(<font>[SE]
! # where <font> is one of B, I, or F. Turn those into the right font start or
! # end codes. The old pod2man didn't get B<someI<thing> else> right; after I<>
! # it switched back to normal text rather than bold. We take care of this by
! # using variables as a combined pointer to our current font sequence, and set
! # each to the number of current nestings of start tags for that font. Use
! # them as a vector to look up what font sequence to use.
#
# \fP changes to the previous font, but only one previous font is kept. We
# don't know what the outside level font is; normally it's R, but if we're
! # inside a heading it could be something else. So arrange things so that the
! # outside font is always the "previous" font and end with \fP instead of \fR.
! # Idea from Zack Weinberg.
sub mapfonts {
my $self = shift;
local $_ = shift;
***************
*** 896,904 ****
# Unfortunately, there is a bug in Solaris 2.6 nroff (not present in GNU
# groff) where the sequence \fB\fP\f(CW\fP leaves the font set to B rather
! # than R, presumably because \f(CW doesn't actually do a font change. To
! # work around this, use a separate textmapfonts for text blocks where the
! # default font is always R and only use the smart mapfonts for headings.
sub textmapfonts {
my $self = shift;
local $_ = shift;
--- 885,893 ----
# Unfortunately, there is a bug in Solaris 2.6 nroff (not present in GNU
# groff) where the sequence \fB\fP\f(CW\fP leaves the font set to B rather
! # than R, presumably because \f(CW doesn't actually do a font change. To work
! # around this, use a separate textmapfonts for text blocks where the default
! # font is always R and only use the smart mapfonts for headings.
sub textmapfonts {
my $self = shift;
local $_ = shift;
***************
*** 913,921 ****
}
! ############################################################################
! # *roff-specific parsing
! ############################################################################
# Called instead of parse_text, calls parse_text with the right flags.
sub parse {
--- 902,910 ----
}
! ##############################################################################
! # *roff-specific parsing and magic
! ##############################################################################
# Called instead of parse_text, calls parse_text with the right flags.
sub parse {
***************
*** 925,937 ****
}
# Takes a parse tree and a flag saying whether or not to treat it as literal
! # text (not call guesswork on it), and returns the concatenation of all of
! # the text strings in that parse tree. If the literal flag isn't true,
# guesswork() will be called on all plain scalars in the parse tree.
! # Otherwise, just escape backslashes in the normal case. If collapse is
! # being called on a C<> sequence, literal is set to 2, and we do some
! # additional cleanup. Assumes that everything in the parse tree is either a
! # scalar or a reference to a scalar.
sub collapse {
my ($self, $ptree, $literal) = @_;
if ($literal) {
--- 914,926 ----
}
# Takes a parse tree and a flag saying whether or not to treat it as literal
! # text (not call guesswork on it), and returns the concatenation of all of the
! # text strings in that parse tree. If the literal flag isn't true,
# guesswork() will be called on all plain scalars in the parse tree.
! # Otherwise, just escape backslashes in the normal case. If collapse is being
! # called on a C<> sequence, literal is set to 2, and we do some additional
! # cleanup. Assumes that everything in the parse tree is either a scalar or a
! # reference to a scalar.
sub collapse {
my ($self, $ptree, $literal) = @_;
if ($literal) {
***************
*** 953,960 ****
}
# Takes a text block to perform guesswork on; this is guaranteed not to
! # contain any interior sequences. Returns the text block with remapping
! # done.
sub guesswork {
my $self = shift;
local $_ = shift;
--- 942,948 ----
}
# Takes a text block to perform guesswork on; this is guaranteed not to
! # contain any interior sequences. Returns the text block with remapping done.
sub guesswork {
my $self = shift;
local $_ = shift;
***************
*** 965,972 ****
# Ensure double underbars have a tiny space between them.
s/__/_\\|_/g;
! # Make all caps a little smaller. Be careful here, since we don't want
! # to make @ARGV into small caps, nor do we want to fix the MIME in
# MIME-Version, since it looks weird with the full-height V.
s{
( ^ | [\s\(\"\'\`\[\{<>] )
--- 953,960 ----
# Ensure double underbars have a tiny space between them.
s/__/_\\|_/g;
! # Make all caps a little smaller. Be careful here, since we don't want to
! # make @ARGV into small caps, nor do we want to fix the MIME in
# MIME-Version, since it looks weird with the full-height V.
s{
( ^ | [\s\(\"\'\`\[\{<>] )
***************
*** 974,982 ****
(?: (?= [\s>\}\]\(\)\'\".?!,;] | -- ) | $ )
} { $1 . '\s-1' . $2 . '\s0' }egx;
- # Turn PI into a pretty pi.
- s{ (?: \\s-1 | \b ) PI (?: \\s0 | \b ) } {\\*\(PI}gx;
-
# Italize functions in the form func().
s{
( \b | \\s-1 )
--- 962,967 ----
***************
*** 1029,1038 ****
$_;
}
! ############################################################################
# Output formatting
! ############################################################################
# Make vertical whitespace.
sub makespace {
--- 1014,1055 ----
$_;
}
+ # Handles C<> text, deciding whether to put \*C` around it or not. This is a
+ # whole bunch of messy heuristics to try to avoid overquoting, originally from
+ # Barrie Slaymaker. This largely duplicates similar code in Pod::Text.
+ sub quote_literal {
+ my $self = shift;
+ local $_ = shift;
! # A regex that matches the portion of a variable reference that's the
! # array or hash index, separated out just because we want to use it in
! # several places in the following regex.
! my $index = '(?: \[.*\] | \{.*\} )?';
!
! # Check for things that we don't want to quote, and if we find any of
! # them, return the string with just a font change and no quoting.
! m{
! ^\s*
! (?:
! ( [\'\`\"] ) .* \1 # already quoted
! | \` .* \' # `quoted'
! | \$+ [\#^]? \S $index # special ($^Foo, $")
! | [\$\@%&*]+ \#? [:\'\w]+ $index # plain var or func
! | [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call
! | [+-]? [\d.]+ (?: [eE] [+-]? \d+ )? # a number
! | 0x [a-fA-F\d]+ # a hex constant
! )
! \s*\z
! }xo && return '\f(FS' . $_ . '\f(FE';
!
! # If we didn't return, go ahead and quote the text.
! return '\f(FS\*(C`' . $_ . "\\*(C'\\f(FE";
! }
!
!
! ##############################################################################
# Output formatting
! ##############################################################################
# Make vertical whitespace.
sub makespace {
***************
*** 1043,1051 ****
if $$self{NEEDSPACE};
}
! # Output any pending index entries, and optionally an index entry given as
! # an argument. Support multiple index entries in X<> separated by slashes,
! # and strip special escapes from index entries.
sub outindex {
my ($self, $section, $index) = @_;
my @entries = map { split m%\s*/\s*% } @{ $$self{INDEX} };
--- 1060,1068 ----
if $$self{NEEDSPACE};
}
! # Output any pending index entries, and optionally an index entry given as an
! # argument. Support multiple index entries in X<> separated by slashes, and
! # strip special escapes from index entries.
sub outindex {
my ($self, $section, $index) = @_;
my @entries = map { split m%\s*/\s*% } @{ $$self{INDEX} };
***************
*** 1085,1106 ****
# We also have to deal with \*C` and \*C', which are used to add the
# quotes around C<> text, since they may expand to " and if they do this
! # confuses the .SH macros and the like no end. Expand them ourselves.
! # If $extra is set, we're dealing with =item, which in most nroff macro
! # sets requires an extra level of quoting of double quotes.
my $c_is_quote = ($$self{LQUOTE} =~ /\"/) || ($$self{RQUOTE} =~ /\"/);
! if (/\"/ || ($c_is_quote && /\\\*\(C[\'\`]/)) {
s/\"/\"\"/g;
my $troff = $_;
$troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g;
! s/\\\*\(C\`/$$self{LQUOTE}/g;
! s/\\\*\(C\'/$$self{RQUOTE}/g;
! $troff =~ s/\\\*\(C[\'\`]//g;
! s/\"/\"\"/g if $extra;
! $troff =~ s/\"/\"\"/g if $extra;
! $_ = qq("$_") . ($extra ? " $extra" : '');
$troff = qq("$troff") . ($extra ? " $extra" : '');
! return ".if n $command $_\n.el $command $troff\n";
} else {
$_ = qq("$_") . ($extra ? " $extra" : '');
return "$command $_\n";
--- 1102,1140 ----
# We also have to deal with \*C` and \*C', which are used to add the
# quotes around C<> text, since they may expand to " and if they do this
! # confuses the .SH macros and the like no end. Expand them ourselves. If
! # $extra is set, we're dealing with =item, which in most nroff macro sets
! # requires an extra level of quoting of double quotes because it passes
! # the argument off to .TP.
my $c_is_quote = ($$self{LQUOTE} =~ /\"/) || ($$self{RQUOTE} =~ /\"/);
! if (/\"/ || /\\f\(CW/) {
s/\"/\"\"/g;
+ my $nroff = $_;
my $troff = $_;
$troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g;
! if ($c_is_quote && /\\\*\(C[\'\`]/) {
! $nroff =~ s/\\\*\(C\`/$$self{LQUOTE}/g;
! $nroff =~ s/\\\*\(C\'/$$self{RQUOTE}/g;
! $troff =~ s/\\\*\(C[\'\`]//g;
! }
! $nroff = qq("$nroff") . ($extra ? " $extra" : '');
$troff = qq("$troff") . ($extra ? " $extra" : '');
!
! # Work around the Solaris nroff bug where \f(CW\fP leaves the font set
! # to Roman rather than the actual previous font when used in headings.
! # troff output may still be broken, but at least we can fix nroff by
! # just stripping out the font changes since fixed-width fonts don't
! # mean anything for nroff. While we're at it, also remove the font
! # changes for nroff in =item tags, since they're unnecessary.
! $nroff =~ s/\\f\(CW(.*)\\f[PR]/$1/g;
!
! # Now finally output the command. Only bother with .if if the nroff
! # and troff output isn't the same.
! if ($nroff ne $troff) {
! return ".if n $command $nroff\n.el $command $troff\n";
! } else {
! return "$command $nroff\n";
! }
} else {
$_ = qq("$_") . ($extra ? " $extra" : '');
return "$command $_\n";
***************
*** 1139,1147 ****
. ds Oe OE
.\}
! ############################################################################
# Documentation
! ############################################################################
=head1 NAME
--- 1173,1181 ----
. ds Oe OE
.\}
! ##############################################################################
# Documentation
! ##############################################################################
=head1 NAME
***************
*** 1320,1330 ****
(W) The POD source contained a non-standard interior sequence (something of
the form C<XE<lt>E<gt>>) that Pod::Man didn't know about. It was ignored.
- =item %s: Unknown command paragraph "%s" on line %d.
-
- (W) The POD source contained a non-standard command paragraph (something of
- the form C<=command args>) that Pod::Man didn't know about. It was ignored.
-
=item Unmatched =back
(W) Pod::Man encountered a C<=back> command that didn't correspond to an
--- 1354,1359 ----
***************
*** 1383,1387 ****
--- 1412,1423 ----
Russ Allbery E<lt>rra@stanford.eduE<gt>, based I<very> heavily on the
original B<pod2man> by Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>.
+
+ =head1 COPYRIGHT AND LICENSE
+
+ Copyright 1999, 2000, 2001 by Russ Allbery <rra@stanford.edu>.
+
+ This program is free software; you may redistribute it and/or modify it
+ under the same terms as Perl itself.
=cut
diff -c 'perl-5.7.1/lib/Pod/Text.pm' 'perl-5.7.2/lib/Pod/Text.pm'
Index: ./lib/Pod/Text.pm
Prereq: 2.9
*** ./lib/Pod/Text.pm Mon Apr 9 16:34:48 2001
--- ./lib/Pod/Text.pm Tue Jul 10 17:16:19 2001
***************
*** 1,19 ****
# Pod::Text -- Convert POD data to formatted ASCII text.
! # $Id: Text.pm,v 2.9 2001/04/09 13:00:50 eagle Exp $
#
# Copyright 1999, 2000, 2001 by Russ Allbery <rra@stanford.edu>
#
! # This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
! # This module is intended to be a replacement for Pod::Text, and attempts to
! # match its output except for some specific circumstances where other
! # decisions seemed to produce better output. It uses Pod::Parser and is
! # designed to be very easy to subclass.
! ############################################################################
# Modules and declarations
! ############################################################################
package Pod::Text;
--- 1,24 ----
# Pod::Text -- Convert POD data to formatted ASCII text.
! # $Id: Text.pm,v 2.11 2001/07/10 11:08:10 eagle Exp $
#
# Copyright 1999, 2000, 2001 by Russ Allbery <rra@stanford.edu>
#
! # This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.
#
! # This module replaces the old Pod::Text that came with versions of Perl prior
! # to 5.6.0, and attempts to match its output except for some specific
! # circumstances where other decisions seemed to produce better output. It
! # uses Pod::Parser and is designed to be very easy to subclass.
! #
! # Perl core hackers, please note that this module is also separately
! # maintained outside of the Perl core as part of the podlators. Please send
! # me any patches at the address above in addition to sending them to the
! # standard Perl mailing lists.
! ##############################################################################
# Modules and declarations
! ##############################################################################
package Pod::Text;
***************
*** 26,53 ****
use strict;
use vars qw(@ISA @EXPORT %ESCAPES $VERSION);
! # We inherit from Pod::Select instead of Pod::Parser so that we can be used
! # by Pod::Usage.
@ISA = qw(Pod::Select Exporter);
# We have to export pod2text for backward compatibility.
@EXPORT = qw(pod2text);
! # Don't use the CVS revision as the version, since this module is also in
! # Perl core and too many things could munge CVS magic revision strings.
! # This number should ideally be the same as the CVS revision in podlators,
! # however.
! $VERSION = 2.09;
! ############################################################################
# Table of supported E<> escapes
! ############################################################################
! # This table is taken near verbatim from Pod::PlainText in Pod::Parser,
! # which got it near verbatim from the original Pod::Text. It is therefore
! # credited to Tom Christiansen, and I'm glad I didn't have to write it. :)
! # "iexcl" to "divide" added by Tim Jenness.
%ESCAPES = (
'amp' => '&', # ampersand
'lt' => '<', # left chevron, less-than
--- 31,57 ----
use strict;
use vars qw(@ISA @EXPORT %ESCAPES $VERSION);
! # We inherit from Pod::Select instead of Pod::Parser so that we can be used by
! # Pod::Usage.
@ISA = qw(Pod::Select Exporter);
# We have to export pod2text for backward compatibility.
@EXPORT = qw(pod2text);
! # Don't use the CVS revision as the version, since this module is also in Perl
! # core and too many things could munge CVS magic revision strings. This
! # number should ideally be the same as the CVS revision in podlators, however.
! $VERSION = 2.11;
! ##############################################################################
# Table of supported E<> escapes
! ##############################################################################
! # This table is taken near verbatim from Pod::PlainText in Pod::Parser, which
! # got it near verbatim from the original Pod::Text. It is therefore credited
! # to Tom Christiansen, and I'm glad I didn't have to write it. :) "iexcl" to
! # "divide" added by Tim Jenness.
%ESCAPES = (
'amp' => '&', # ampersand
'lt' => '<', # left chevron, less-than
***************
*** 158,166 ****
);
! ############################################################################
# Initialization
! ############################################################################
# Initialize the object. Must be sure to call our parent initializer.
sub initialize {
--- 162,170 ----
);
! ##############################################################################
# Initialization
! ##############################################################################
# Initialize the object. Must be sure to call our parent initializer.
sub initialize {
***************
*** 193,201 ****
}
! ############################################################################
# Core overrides
! ############################################################################
# Called for each command paragraph. Gets the command, the associated
# paragraph, the line number, and a Pod::Paragraph object. Just dispatches
--- 197,205 ----
}
! ##############################################################################
# Core overrides
! ##############################################################################
# Called for each command paragraph. Gets the command, the associated
# paragraph, the line number, and a Pod::Paragraph object. Just dispatches
***************
*** 221,229 ****
}
}
! # Called for a verbatim paragraph. Gets the paragraph, the line number, and
! # a Pod::Paragraph object. Just output it verbatim, but with tabs converted
! # to spaces.
sub verbatim {
my $self = shift;
return if $$self{EXCLUDE};
--- 225,233 ----
}
}
! # Called for a verbatim paragraph. Gets the paragraph, the line number, and a
! # Pod::Paragraph object. Just output it verbatim, but with tabs converted to
! # spaces.
sub verbatim {
my $self = shift;
return if $$self{EXCLUDE};
***************
*** 234,241 ****
$self->output ($_);
}
! # Called for a regular text block. Gets the paragraph, the line number, and
! # a Pod::Paragraph object. Perform interpolation and output the results.
sub textblock {
my $self = shift;
return if $$self{EXCLUDE};
--- 238,245 ----
$self->output ($_);
}
! # Called for a regular text block. Gets the paragraph, the line number, and a
! # Pod::Paragraph object. Perform interpolation and output the results.
sub textblock {
my $self = shift;
return if $$self{EXCLUDE};
***************
*** 294,301 ****
# Called for an interior sequence. Gets the command, argument, and a
# Pod::InteriorSequence object and is expected to return the resulting text.
! # Calls code, bold, italic, file, and link to handle those types of
! # sequences, and handles S<>, E<>, X<>, and Z<> directly.
sub interior_sequence {
my $self = shift;
my $command = shift;
--- 298,305 ----
# Called for an interior sequence. Gets the command, argument, and a
# Pod::InteriorSequence object and is expected to return the resulting text.
! # Calls code, bold, italic, file, and link to handle those types of sequences,
! # and handles S<>, E<>, X<>, and Z<> directly.
sub interior_sequence {
my $self = shift;
my $command = shift;
***************
*** 343,351 ****
}
! ############################################################################
# Command paragraphs
! ############################################################################
# All command paragraphs take the paragraph and the line number.
--- 347,355 ----
}
! ##############################################################################
# Command paragraphs
! ##############################################################################
# All command paragraphs take the paragraph and the line number.
***************
*** 462,470 ****
}
! ############################################################################
# Interior sequences
! ############################################################################
# The simple formatting ones. These are here mostly so that subclasses can
# override them and do more complicated things.
--- 466,474 ----
}
! ##############################################################################
# Interior sequences
! ##############################################################################
# The simple formatting ones. These are here mostly so that subclasses can
# override them and do more complicated things.
***************
*** 471,478 ****
sub seq_b { return $_[0]{alt} ? "``$_[1]''" : $_[1] }
sub seq_f { return $_[0]{alt} ? "\"$_[1]\"" : $_[1] }
sub seq_i { return '*' . $_[1] . '*' }
sub seq_c {
! return $_[0]{alt} ? "``$_[1]''" : "$_[0]{LQUOTE}$_[1]$_[0]{RQUOTE}"
}
# The complicated one. Handle links. Since this is plain text, we can't
--- 475,511 ----
sub seq_b { return $_[0]{alt} ? "``$_[1]''" : $_[1] }
sub seq_f { return $_[0]{alt} ? "\"$_[1]\"" : $_[1] }
sub seq_i { return '*' . $_[1] . '*' }
+
+ # Apply a whole bunch of messy heuristics to not quote things that don't
+ # benefit from being quoted. These originally come from Barrie Slaymaker and
+ # largely duplicate code in Pod::Man.
sub seq_c {
! my $self = shift;
! local $_ = shift;
!
! # A regex that matches the portion of a variable reference that's the
! # array or hash index, separated out just because we want to use it in
! # several places in the following regex.
! my $index = '(?: \[.*\] | \{.*\} )?';
!
! # Check for things that we don't want to quote, and if we find any of
! # them, return the string with just a font change and no quoting.
! m{
! ^\s*
! (?:
! ( [\'\`\"] ) .* \1 # already quoted
! | \` .* \' # `quoted'
! | \$+ [\#^]? \S $index # special ($^Foo, $")
! | [\$\@%&*]+ \#? [:\'\w]+ $index # plain var or func
! | [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call
! | [+-]? [\d.]+ (?: [eE] [+-]? \d+ )? # a number
! | 0x [a-fA-F\d]+ # a hex constant
! )
! \s*\z
! }xo && return $_;
!
! # If we didn't return, go ahead and quote the text.
! return $$self{alt} ? "``$_''" : "$$self{LQUOTE}$_$$self{RQUOTE}";
}
# The complicated one. Handle links. Since this is plain text, we can't
***************
*** 492,505 ****
s/^\s+//;
s/\s+$//;
! # If the argument looks like a URL, return it verbatim. This only
! # handles URLs that use the server syntax.
if (m%^[a-z]+://\S+$%) { return $_ }
! # Default to using the whole content of the link entry as a section
! # name. Note that L<manpage/> forces a manpage interpretation, as does
! # something looking like L<manpage(section)>. The latter is an
! # enhancement over the original Pod::Text.
my ($manpage, $section) = ('', $_);
if (/^"\s*(.*?)\s*"$/) {
$section = '"' . $1 . '"';
--- 525,538 ----
s/^\s+//;
s/\s+$//;
! # If the argument looks like a URL, return it verbatim. This only handles
! # URLs that use the server syntax.
if (m%^[a-z]+://\S+$%) { return $_ }
! # Default to using the whole content of the link entry as a section name.
! # Note that L<manpage/> forces a manpage interpretation, as does something
! # looking like L<manpage(section)>. The latter is an enhancement over the
! # original Pod::Text.
my ($manpage, $section) = ('', $_);
if (/^"\s*(.*?)\s*"$/) {
$section = '"' . $1 . '"';
***************
*** 527,543 ****
}
! ############################################################################
# List handling
! ############################################################################
! # This method is called whenever an =item command is complete (in other
! # words, we've seen its associated paragraph or know for certain that it
! # doesn't have one). It gets the paragraph associated with the item as an
! # argument. If that argument is empty, just output the item tag; if it
! # contains a newline, output the item tag followed by the newline.
! # Otherwise, see if there's enough room for us to output the item tag in the
! # margin of the text or if we have to put it on a separate line.
sub item {
my $self = shift;
local $_ = shift;
--- 560,576 ----
}
! ##############################################################################
# List handling
! ##############################################################################
! # This method is called whenever an =item command is complete (in other words,
! # we've seen its associated paragraph or know for certain that it doesn't have
! # one). It gets the paragraph associated with the item as an argument. If
! # that argument is empty, just output the item tag; if it contains a newline,
! # output the item tag followed by the newline. Otherwise, see if there's
! # enough room for us to output the item tag in the margin of the text or if we
! # have to put it on a separate line.
sub item {
my $self = shift;
local $_ = shift;
***************
*** 569,582 ****
}
! ############################################################################
# Output formatting
! ############################################################################
! # Wrap a line, indenting by the current left margin. We can't use
! # Text::Wrap because it plays games with tabs. We can't use formline, even
! # though we'd really like to, because it screws up non-printing characters.
! # So we have to do the wrapping ourselves.
sub wrap {
my $self = shift;
local $_ = shift;
--- 602,615 ----
}
! ##############################################################################
# Output formatting
! ##############################################################################
! # Wrap a line, indenting by the current left margin. We can't use Text::Wrap
! # because it plays games with tabs. We can't use formline, even though we'd
! # really like to, because it screws up non-printing characters. So we have to
! # do the wrapping ourselves.
sub wrap {
my $self = shift;
local $_ = shift;
***************
*** 601,608 ****
my $self = shift;
local $_ = shift;
! # If we're trying to preserve two spaces after sentences, do some
! # munging to support that. Otherwise, smash all repeated whitespace.
if ($$self{sentence}) {
s/ +$//mg;
s/\.\n/. \n/g;
--- 634,641 ----
my $self = shift;
local $_ = shift;
! # If we're trying to preserve two spaces after sentences, do some munging
! # to support that. Otherwise, smash all repeated whitespace.
if ($$self{sentence}) {
s/ +$//mg;
s/\.\n/. \n/g;
***************
*** 618,626 ****
sub output { $_[1] =~ tr/\01/ /; print { $_[0]->output_handle } $_[1] }
! ############################################################################
# Backwards compatibility
! ############################################################################
# The old Pod::Text module did everything in a pod2text() function. This
# tries to provide the same interface for legacy applications.
--- 651,659 ----
sub output { $_[1] =~ tr/\01/ /; print { $_[0]->output_handle } $_[1] }
! ##############################################################################
# Backwards compatibility
! ##############################################################################
# The old Pod::Text module did everything in a pod2text() function. This
# tries to provide the same interface for legacy applications.
***************
*** 644,652 ****
my $parser = Pod::Text->new (@args);
# If two arguments were given, the second argument is going to be a file
! # handle. That means we want to call parse_from_filehandle(), which
! # means we need to turn the first argument into a file handle. Magic
! # open will handle the <&STDIN case automagically.
if (defined $_[1]) {
my @fhs = @_;
local *IN;
--- 677,685 ----
my $parser = Pod::Text->new (@args);
# If two arguments were given, the second argument is going to be a file
! # handle. That means we want to call parse_from_filehandle(), which means
! # we need to turn the first argument into a file handle. Magic open will
! # handle the <&STDIN case automagically.
if (defined $_[1]) {
my @fhs = @_;
local *IN;
***************
*** 662,670 ****
}
! ############################################################################
# Module return value and documentation
! ############################################################################
1;
__END__
--- 695,703 ----
}
! ##############################################################################
# Module return value and documentation
! ##############################################################################
1;
__END__
***************
*** 823,827 ****
--- 856,867 ----
original Pod::Text by Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> and
its conversion to Pod::Parser by Brad Appleton
E<lt>bradapp@enteract.comE<gt>.
+
+ =head1 COPYRIGHT AND LICENSE
+
+ Copyright 1999, 2000, 2001 by Russ Allbery <rra@stanford.edu>.
+
+ This program is free software; you may redistribute it and/or modify it
+ under the same terms as Perl itself.
=cut
diff -c 'perl-5.7.1/lib/Pod/Text/Color.pm' 'perl-5.7.2/lib/Pod/Text/Color.pm'
Index: ./lib/Pod/Text/Color.pm
Prereq: 0.6
*** ./lib/Pod/Text/Color.pm Tue Mar 6 04:05:34 2001
--- ./lib/Pod/Text/Color.pm Tue Jul 10 17:16:33 2001
***************
*** 1,18 ****
# Pod::Text::Color -- Convert POD data to formatted color ASCII text
! # $Id: Color.pm,v 0.6 2000/12/25 12:52:39 eagle Exp $
#
# Copyright 1999 by Russ Allbery <rra@stanford.edu>
#
! # This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
! # This is just a basic proof of concept. It should later be modified to
! # make better use of color, take options changing what colors are used for
! # what text, and the like.
! ############################################################################
# Modules and declarations
! ############################################################################
package Pod::Text::Color;
--- 1,18 ----
# Pod::Text::Color -- Convert POD data to formatted color ASCII text
! # $Id: Color.pm,v 1.0 2001/07/10 11:03:43 eagle Exp $
#
# Copyright 1999 by Russ Allbery <rra@stanford.edu>
#
! # This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.
#
! # This is just a basic proof of concept. It should later be modified to make
! # better use of color, take options changing what colors are used for what
! # text, and the like.
! ##############################################################################
# Modules and declarations
! ##############################################################################
package Pod::Text::Color;
***************
*** 26,41 ****
@ISA = qw(Pod::Text);
! # Don't use the CVS revision as the version, since this module is also in
! # Perl core and too many things could munge CVS magic revision strings.
! # This number should ideally be the same as the CVS revision in podlators,
! # however.
! $VERSION = 0.06;
! ############################################################################
# Overrides
! ############################################################################
# Make level one headings bold.
sub cmd_head1 {
--- 26,40 ----
@ISA = qw(Pod::Text);
! # Don't use the CVS revision as the version, since this module is also in Perl
! # core and too many things could munge CVS magic revision strings. This
! # number should ideally be the same as the CVS revision in podlators, however.
! $VERSION = 1.00;
! ##############################################################################
# Overrides
! ##############################################################################
# Make level one headings bold.
sub cmd_head1 {
***************
*** 79,87 ****
$output;
}
! ############################################################################
# Module return value and documentation
! ############################################################################
1;
__END__
--- 78,86 ----
$output;
}
! ##############################################################################
# Module return value and documentation
! ##############################################################################
1;
__END__
***************
*** 123,128 ****
=head1 AUTHOR
! Russ Allbery E<lt>rra@stanford.eduE<gt>.
=cut
--- 122,134 ----
=head1 AUTHOR
! Russ Allbery <rra@stanford.edu>.
!
! =head1 COPYRIGHT AND LICENSE
!
! Copyright 1999 by Russ Allbery <rra@stanford.edu>.
!
! This program is free software; you may redistribute it and/or modify it
! under the same terms as Perl itself.
=cut
diff -c 'perl-5.7.1/lib/Pod/Text/Overstrike.pm' 'perl-5.7.2/lib/Pod/Text/Overstrike.pm'
Index: ./lib/Pod/Text/Overstrike.pm
Prereq: 1.1
*** ./lib/Pod/Text/Overstrike.pm Tue Mar 6 04:05:34 2001
--- ./lib/Pod/Text/Overstrike.pm Tue Jul 10 17:16:33 2001
***************
*** 1,10 ****
# Pod::Text::Overstrike -- Convert POD data to formatted overstrike text
! # $Id: Overstrike.pm,v 1.1 2000/12/25 12:51:23 eagle Exp $
#
# Created by Joe Smith <Joe.Smith@inwap.com> 30-Nov-2000
# (based on Pod::Text::Color by Russ Allbery <rra@stanford.edu>)
#
! # This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
# This was written because the output from:
--- 1,10 ----
# Pod::Text::Overstrike -- Convert POD data to formatted overstrike text
! # $Id: Overstrike.pm,v 1.2 2001/07/10 11:04:36 eagle Exp $
#
# Created by Joe Smith <Joe.Smith@inwap.com> 30-Nov-2000
# (based on Pod::Text::Color by Russ Allbery <rra@stanford.edu>)
#
! # This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.
#
# This was written because the output from:
***************
*** 18,26 ****
# and because both Pod::Text::Color and Pod::Text::Termcap are not device
# independent.
! ############################################################################
# Modules and declarations
! ############################################################################
package Pod::Text::Overstrike;
--- 18,26 ----
# and because both Pod::Text::Color and Pod::Text::Termcap are not device
# independent.
! ##############################################################################
# Modules and declarations
! ##############################################################################
package Pod::Text::Overstrike;
***************
*** 33,48 ****
@ISA = qw(Pod::Text);
! # Don't use the CVS revision as the version, since this module is also in
! # Perl core and too many things could munge CVS magic revision strings.
! # This number should ideally be the same as the CVS revision in podlators,
! # however.
! $VERSION = 1.01;
! ############################################################################
# Overrides
! ############################################################################
# Make level one headings bold, overridding any existing formatting.
sub cmd_head1 {
--- 33,47 ----
@ISA = qw(Pod::Text);
! # Don't use the CVS revision as the version, since this module is also in Perl
! # core and too many things could munge CVS magic revision strings. This
! # number should ideally be the same as the CVS revision in podlators, however.
! $VERSION = 1.02;
! ##############################################################################
# Overrides
! ##############################################################################
# Make level one headings bold, overridding any existing formatting.
sub cmd_head1 {
***************
*** 103,111 ****
$output;
}
! ############################################################################
# Module return value and documentation
! ############################################################################
1;
__END__
--- 102,110 ----
$output;
}
! ##############################################################################
# Module return value and documentation
! ##############################################################################
1;
__END__
***************
*** 154,160 ****
=head1 AUTHOR
! Joe Smith E<lt>Joe.Smith@inwap.comE<gt>, using the framework created by Russ
! Allbery E<lt>rra@stanford.eduE<gt>.
=cut
--- 153,166 ----
=head1 AUTHOR
! Joe Smith <Joe.Smith@inwap.com>, using the framework created by Russ Allbery
! <rra@stanford.edu>.
!
! =head1 COPYRIGHT AND LICENSE
!
! Copyright 2000 by Joe Smith <Joe.Smith@inwap.com>.
!
! This program is free software; you may redistribute it and/or modify it
! under the same terms as Perl itself.
=cut
diff -c 'perl-5.7.1/lib/Pod/Text/Termcap.pm' 'perl-5.7.2/lib/Pod/Text/Termcap.pm'
Index: ./lib/Pod/Text/Termcap.pm
Prereq: 1.0
*** ./lib/Pod/Text/Termcap.pm Tue Mar 6 04:05:34 2001
--- ./lib/Pod/Text/Termcap.pm Tue Jul 10 17:16:35 2001
***************
*** 1,18 ****
# Pod::Text::Termcap -- Convert POD data to ASCII text with format escapes.
! # $Id: Termcap.pm,v 1.0 2000/12/25 12:52:48 eagle Exp $
#
# Copyright 1999 by Russ Allbery <rra@stanford.edu>
#
! # This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
# This is a simple subclass of Pod::Text that overrides a few key methods to
! # output the right termcap escape sequences for formatted text on the
! # current terminal type.
! ############################################################################
# Modules and declarations
! ############################################################################
package Pod::Text::Termcap;
--- 1,18 ----
# Pod::Text::Termcap -- Convert POD data to ASCII text with format escapes.
! # $Id: Termcap.pm,v 1.1 2001/07/10 11:04:36 eagle Exp $
#
# Copyright 1999 by Russ Allbery <rra@stanford.edu>
#
! # This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.
#
# This is a simple subclass of Pod::Text that overrides a few key methods to
! # output the right termcap escape sequences for formatted text on the current
! # terminal type.
! ##############################################################################
# Modules and declarations
! ##############################################################################
package Pod::Text::Termcap;
***************
*** 27,42 ****
@ISA = qw(Pod::Text);
! # Don't use the CVS revision as the version, since this module is also in
! # Perl core and too many things could munge CVS magic revision strings.
! # This number should ideally be the same as the CVS revision in podlators,
! # however.
! $VERSION = 1.00;
! ############################################################################
# Overrides
! ############################################################################
# In the initialization method, grab our terminal characteristics as well as
# do all the stuff we normally do.
--- 27,41 ----
@ISA = qw(Pod::Text);
! # Don't use the CVS revision as the version, since this module is also in Perl
! # core and too many things could munge CVS magic revision strings. This
! # number should ideally be the same as the CVS revision in podlators, however.
! $VERSION = 1.01;
! ##############################################################################
# Overrides
! ##############################################################################
# In the initialization method, grab our terminal characteristics as well as
# do all the stuff we normally do.
***************
*** 105,113 ****
}
! ############################################################################
# Module return value and documentation
! ############################################################################
1;
__END__
--- 104,112 ----
}
! ##############################################################################
# Module return value and documentation
! ##############################################################################
1;
__END__
***************
*** 140,145 ****
=head1 AUTHOR
! Russ Allbery E<lt>rra@stanford.eduE<gt>.
=cut
--- 139,151 ----
=head1 AUTHOR
! Russ Allbery <rra@stanford.edu>.
!
! =head1 COPYRIGHT AND LICENSE
!
! Copyright 1999 by Russ Allbery <rra@stanford.edu>.
!
! This program is free software; you may redistribute it and/or modify it
! under the same terms as Perl itself.
=cut
diff -c /dev/null 'perl-5.7.2/lib/Search/Dict.t'
Index: ./lib/Search/Dict.t
*** ./lib/Search/Dict.t Thu Jan 1 02:00:00 1970
--- ./lib/Search/Dict.t Mon Jul 9 17:10:42 2001
***************
*** 0 ****
--- 1,87 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ print "1..4\n";
+
+ $DICT = <<EOT;
+ Aarhus
+ Aaron
+ Ababa
+ aback
+ abaft
+ abandon
+ abandoned
+ abandoning
+ abandonment
+ abandons
+ abase
+ abased
+ abasement
+ abasements
+ abases
+ abash
+ abashed
+ abashes
+ abashing
+ abasing
+ abate
+ abated
+ abatement
+ abatements
+ abater
+ abates
+ abating
+ Abba
+ EOT
+
+ use Search::Dict;
+
+ open(DICT, "+>dict-$$") or die "Can't create dict-$$: $!";
+ binmode DICT; # To make length expected one.
+ print DICT $DICT;
+
+ my $pos = look *DICT, "Ababa";
+ chomp($word = <DICT>);
+ print "not " if $pos < 0 || $word ne "Ababa";
+ print "ok 1\n";
+
+ if (ord('a') > ord('A') ) { # ASCII
+
+ $pos = look *DICT, "foo";
+ chomp($word = <DICT>);
+
+ print "not " if $pos != length($DICT); # will search to end of file
+ print "ok 2\n";
+
+ my $pos = look *DICT, "abash";
+ chomp($word = <DICT>);
+ print "not " if $pos < 0 || $word ne "abash";
+ print "ok 3\n";
+
+ }
+ else { # EBCDIC systems e.g. os390
+
+ $pos = look *DICT, "FOO";
+ chomp($word = <DICT>);
+
+ print "not " if $pos != length($DICT); # will search to end of file
+ print "ok 2\n";
+
+ my $pos = look *DICT, "Abba";
+ chomp($word = <DICT>);
+ print "not " if $pos < 0 || $word ne "Abba";
+ print "ok 3\n";
+ }
+
+ $pos = look *DICT, "aarhus", 1, 1;
+ chomp($word = <DICT>);
+
+ print "not " if $pos < 0 || $word ne "Aarhus";
+ print "ok 4\n";
+
+ close DICT or die "cannot close";
+ unlink "dict-$$";
diff -c /dev/null 'perl-5.7.2/lib/SelectSaver.t'
Index: ./lib/SelectSaver.t
*** ./lib/SelectSaver.t Thu Jan 1 02:00:00 1970
--- ./lib/SelectSaver.t Mon Jul 9 17:10:42 2001
***************
*** 0 ****
--- 1,28 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ print "1..3\n";
+
+ use SelectSaver;
+
+ open(FOO, ">foo-$$") || die;
+
+ print "ok 1\n";
+ {
+ my $saver = new SelectSaver(FOO);
+ print "foo\n";
+ }
+
+ # Get data written to file
+ open(FOO, "foo-$$") || die;
+ chomp($foo = <FOO>);
+ close FOO;
+ unlink "foo-$$";
+
+ print "ok 2\n" if $foo eq "foo";
+
+ print "ok 3\n";
diff -c 'perl-5.7.1/lib/SelfLoader.pm' 'perl-5.7.2/lib/SelfLoader.pm'
Index: ./lib/SelfLoader.pm
*** ./lib/SelfLoader.pm Tue Mar 6 04:05:35 2001
--- ./lib/SelfLoader.pm Mon Jul 9 17:10:42 2001
***************
*** 47,53 ****
sub load_stubs { shift->_load_stubs((caller)[0]) }
sub _load_stubs {
! my($self, $callpack) = @_;
my $fh = \*{"${callpack}::DATA"};
my $currpack = $callpack;
my($line,$name,@lines, @stubs, $protoype);
--- 47,54 ----
sub load_stubs { shift->_load_stubs((caller)[0]) }
sub _load_stubs {
! # $endlines is used by Devel::SelfStubber to capture lines after __END__
! my($self, $callpack, $endlines) = @_;
my $fh = \*{"${callpack}::DATA"};
my $currpack = $callpack;
my($line,$name,@lines, @stubs, $protoype);
***************
*** 94,100 ****
push(@lines,$line);
}
}
! close($fh) unless defined($line) && $line =~ /^__END__\s*DATA/; # __END__
push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
eval join('', @stubs) if @stubs;
}
--- 95,110 ----
push(@lines,$line);
}
}
! if (defined($line) && $line =~ /^__END__/) { # __END__
! unless ($line =~ /^__END__\s*DATA/) {
! if ($endlines) {
! # Devel::SelfStubber would like us to capture the lines after
! # __END__ so it can write out the entire file
! @$endlines = <$fh>;
! }
! close($fh);
! }
! }
push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
eval join('', @stubs) if @stubs;
}
diff -c /dev/null 'perl-5.7.2/lib/SelfLoader.t'
Index: ./lib/SelfLoader.t
*** ./lib/SelfLoader.t Thu Jan 1 02:00:00 1970
--- ./lib/SelfLoader.t Mon Jul 9 17:10:42 2001
***************
*** 0 ****
--- 1,208 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ $dir = "self-$$";
+ $sep = "/";
+
+ if ($^O eq 'MacOS') {
+ $dir = ":" . $dir;
+ $sep = ":";
+ }
+
+ @INC = $dir;
+ push @INC, '../lib';
+
+ print "1..19\n";
+
+ # First we must set up some selfloader files
+ mkdir $dir, 0755 or die "Can't mkdir $dir: $!";
+
+ open(FOO, ">$dir${sep}Foo.pm") or die;
+ print FOO <<'EOT';
+ package Foo;
+ use SelfLoader;
+
+ sub new { bless {}, shift }
+ sub foo;
+ sub bar;
+ sub bazmarkhianish;
+ sub a;
+ sub never; # declared but definition should never be read
+ 1;
+ __DATA__
+
+ sub foo { shift; shift || "foo" };
+
+ sub bar { shift; shift || "bar" }
+
+ sub bazmarkhianish { shift; shift || "baz" }
+
+ package sheep;
+ sub bleat { shift; shift || "baa" }
+
+ __END__
+ sub never { die "D'oh" }
+ EOT
+
+ close(FOO);
+
+ open(BAR, ">$dir${sep}Bar.pm") or die;
+ print BAR <<'EOT';
+ package Bar;
+ use SelfLoader;
+
+ @ISA = 'Baz';
+
+ sub new { bless {}, shift }
+ sub a;
+
+ 1;
+ __DATA__
+
+ sub a { 'a Bar'; }
+ sub b { 'b Bar' }
+
+ __END__ DATA
+ sub never { die "D'oh" }
+ EOT
+
+ close(BAR);
+ };
+
+
+ package Baz;
+
+ sub a { 'a Baz' }
+ sub b { 'b Baz' }
+ sub c { 'c Baz' }
+
+
+ package main;
+ use Foo;
+ use Bar;
+
+ $foo = new Foo;
+
+ print "not " unless $foo->foo eq 'foo'; # selfloaded first time
+ print "ok 1\n";
+
+ print "not " unless $foo->foo eq 'foo'; # regular call
+ print "ok 2\n";
+
+ # Try an undefined method
+ eval {
+ $foo->will_fail;
+ };
+ if ($@ =~ /^Undefined subroutine/) {
+ print "ok 3\n";
+ } else {
+ print "not ok 3 $@\n";
+ }
+
+ # Used to be trouble with this
+ eval {
+ my $foo = new Foo;
+ die "oops";
+ };
+ if ($@ =~ /oops/) {
+ print "ok 4\n";
+ } else {
+ print "not ok 4 $@\n";
+ }
+
+ # Pass regular expression variable to autoloaded function. This used
+ # to go wrong in AutoLoader because it used regular expressions to generate
+ # autoloaded filename.
+ "foo" =~ /(\w+)/;
+ print "not " unless $1 eq 'foo';
+ print "ok 5\n";
+
+ print "not " unless $foo->bar($1) eq 'foo';
+ print "ok 6\n";
+
+ print "not " unless $foo->bar($1) eq 'foo';
+ print "ok 7\n";
+
+ print "not " unless $foo->bazmarkhianish($1) eq 'foo';
+ print "ok 8\n";
+
+ print "not " unless $foo->bazmarkhianish($1) eq 'foo';
+ print "ok 9\n";
+
+ # Check nested packages inside __DATA__
+ print "not " unless sheep::bleat() eq 'baa';
+ print "ok 10\n";
+
+ # Now check inheritance:
+
+ $bar = new Bar;
+
+ # Before anything is SelfLoaded there is no declaration of Foo::b so we should
+ # get Baz::b
+ print "not " unless $bar->b() eq 'b Baz';
+ print "ok 11\n";
+
+ # There is no Bar::c so we should get Baz::c
+ print "not " unless $bar->c() eq 'c Baz';
+ print "ok 12\n";
+
+ # This selfloads Bar::a because it is stubbed. It also stubs Bar::b as a side
+ # effect
+ print "not " unless $bar->a() eq 'a Bar';
+ print "ok 13\n";
+
+ print "not " unless $bar->b() eq 'b Bar';
+ print "ok 14\n";
+
+ print "not " unless $bar->c() eq 'c Baz';
+ print "ok 15\n";
+
+
+
+ # Check that __END__ is honoured
+ # Try an subroutine that should never be noticed by selfloader
+ eval {
+ $foo->never;
+ };
+ if ($@ =~ /^Undefined subroutine/) {
+ print "ok 16\n";
+ } else {
+ print "not ok 16 $@\n";
+ }
+
+ # Try to read from the data file handle
+ my $foodata = <Foo::DATA>;
+ close Foo::DATA;
+ if (defined $foodata) {
+ print "not ok 17 # $foodata\n";
+ } else {
+ print "ok 17\n";
+ }
+
+ # Check that __END__ DATA is honoured
+ # Try an subroutine that should never be noticed by selfloader
+ eval {
+ $bar->never;
+ };
+ if ($@ =~ /^Undefined subroutine/) {
+ print "ok 18\n";
+ } else {
+ print "not ok 18 $@\n";
+ }
+
+ # Try to read from the data file handle
+ my $bardata = <Bar::DATA>;
+ close Bar::DATA;
+ if ($bardata ne "sub never { die \"D'oh\" }\n") {
+ print "not ok 19 # $bardata\n";
+ } else {
+ print "ok 19\n";
+ }
+
+ # cleanup
+ END {
+ return unless $dir && -d $dir;
+ unlink "$dir${sep}Foo.pm", "$dir${sep}Bar.pm";
+ rmdir "$dir";
+ }
diff -c 'perl-5.7.1/lib/Shell.pm' 'perl-5.7.2/lib/Shell.pm'
Index: ./lib/Shell.pm
*** ./lib/Shell.pm Tue Mar 6 04:05:35 2001
--- ./lib/Shell.pm Mon Jul 9 17:10:42 2001
***************
*** 196,201 ****
Changes by Jenda@Krynicky.cz and Dave Cottle <d.cottle@csc.canterbury.ac.nz>
! Changes and bug fixes by Casey Tweten <crt@kiski.net>
=cut
--- 196,201 ----
Changes by Jenda@Krynicky.cz and Dave Cottle <d.cottle@csc.canterbury.ac.nz>
! Changes and bug fixes by Casey West <casey@geeknest.com>
=cut
diff -c 'perl-5.7.1/lib/Switch.pm' 'perl-5.7.2/lib/Switch.pm'
Index: ./lib/Switch.pm
*** ./lib/Switch.pm Fri Mar 16 05:17:50 2001
--- ./lib/Switch.pm Mon Jul 9 17:10:42 2001
***************
*** 4,10 ****
use vars qw($VERSION);
use Carp;
! $VERSION = '2.01';
# LOAD FILTERING MODULE...
--- 4,10 ----
use vars qw($VERSION);
use Carp;
! $VERSION = '2.03';
# LOAD FILTERING MODULE...
***************
*** 18,30 ****
my $offset;
my $fallthrough;
- my $nextlabel = 1;
sub import
{
$fallthrough = grep /\bfallthrough\b/, @_;
$offset = (caller)[2]+1;
! filter_add({}) unless @_>1 && $_[1] ne '__';
my $pkg = caller;
no strict 'refs';
for ( qw( on_defined on_exists ) )
--- 18,30 ----
my $offset;
my $fallthrough;
sub import
{
+ $DB::single = 1;
$fallthrough = grep /\bfallthrough\b/, @_;
$offset = (caller)[2]+1;
! filter_add({}) unless @_>1 && $_[1] eq 'noimport';
my $pkg = caller;
no strict 'refs';
for ( qw( on_defined on_exists ) )
***************
*** 80,86 ****
my $text = "";
component: while (pos $source < length $source)
{
! if ($source =~ m/(\G\s*use\s+switch\b)/gc)
{
$text .= q{use Switch 'noimport'};
next component;
--- 80,86 ----
my $text = "";
component: while (pos $source < length $source)
{
! if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
{
$text .= q{use Switch 'noimport'};
next component;
***************
*** 88,100 ****
my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,1);
if (defined $pos[0])
{
! $text .= substr($source,$pos[2],$pos[18]-$pos[2]);
next component;
}
@pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
if (defined $pos[0])
{
! $text .= substr($source,$pos[0],$pos[4]-$pos[0]);
next component;
}
--- 88,100 ----
my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,1);
if (defined $pos[0])
{
! $text .= " " . substr($source,$pos[2],$pos[18]-$pos[2]);
next component;
}
@pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
if (defined $pos[0])
{
! $text .= " " . substr($source,$pos[0],$pos[4]-$pos[0]);
next component;
}
***************
*** 101,107 ****
if ($source =~ m/\G(\n*)(\s*)switch\b(?=\s*[(])/gc)
{
$text .= $1.$2.'S_W_I_T_C_H: while (1) ';
! @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/\{/,qr/\}/,undef)
or do {
die "Bad switch statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
};
--- 101,107 ----
if ($source =~ m/\G(\n*)(\s*)switch\b(?=\s*[(])/gc)
{
$text .= $1.$2.'S_W_I_T_C_H: while (1) ';
! @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
or do {
die "Bad switch statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
};
***************
*** 182,192 ****
my @numy;
for my $nextx ( @$x )
{
! my $numx = ref($nextx) || (~$nextx&$nextx) eq 0;
for my $j ( 0..$#$y )
{
my $nexty = $y->[$j];
! push @numy, ref($nexty) || (~$nexty&$nexty) eq 0
if @numy <= $j;
return 1 if $numx && $numy[$j] && $nextx==$nexty
|| $nextx eq $nexty;
--- 182,192 ----
my @numy;
for my $nextx ( @$x )
{
! my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
for my $j ( 0..$#$y )
{
my $nexty = $y->[$j];
! push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
if @numy <= $j;
return 1 if $numx && $numy[$j] && $nextx==$nexty
|| $nextx eq $nexty;
***************
*** 222,233 ****
return $s_val->($c_val);
};
}
! elsif ($s_ref eq "" && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
{
$::_S_W_I_T_C_H =
sub { my $c_val = $_[0];
my $c_ref = ref $c_val;
return $s_val == $c_val if $c_ref eq ""
&& (~$c_val&$c_val) eq 0;
return $s_val eq $c_val if $c_ref eq "";
return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
--- 222,234 ----
return $s_val->($c_val);
};
}
! elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
{
$::_S_W_I_T_C_H =
sub { my $c_val = $_[0];
my $c_ref = ref $c_val;
return $s_val == $c_val if $c_ref eq ""
+ && defined $c_val
&& (~$c_val&$c_val) eq 0;
return $s_val eq $c_val if $c_ref eq "";
return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
***************
*** 454,461 ****
=head1 VERSION
! This document describes version 2.01 of Switch,
! released January 9, 2001.
=head1 SYNOPSIS
--- 455,462 ----
=head1 VERSION
! This document describes version 2.03 of Switch,
! released May 15, 2001.
=head1 SYNOPSIS
diff -c /dev/null 'perl-5.7.2/lib/Switch/test.pl'
Index: ./lib/Switch/test.pl
*** ./lib/Switch/test.pl Thu Jan 1 02:00:00 1970
--- ./lib/Switch/test.pl Mon Jul 9 17:10:42 2001
***************
*** 0 ****
--- 1,277 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use Carp;
+ use Switch qw(__ fallthrough);
+
+ my($C,$M);sub ok{$C++;$M.=$_[0]?"ok $C\n":"not ok $C (line ".(caller)[2].")\n"}
+ END{print"1..$C\n$M"}
+
+ # NON-case THINGS;
+
+ $case->{case} = { case => "case" };
+
+ *case = \&case;
+
+ # PREMATURE case
+
+ eval { case 1 { ok(0) }; ok(0) } || ok(1);
+
+ # H.O. FUNCS
+
+ switch (__ > 2) {
+
+ case 1 { ok(0) } else { ok(1) }
+ case 2 { ok(0) } else { ok(1) }
+ case 3 { ok(1) } else { ok(0) }
+ }
+
+ switch (3) {
+
+ eval { case __ <= 1 || __ > 2 { ok(0) } } || ok(1);
+ case __ <= 2 { ok(0) };
+ case __ <= 3 { ok(1) };
+ }
+
+ # POSSIBLE ARGS: NUMERIC, STRING, ARRAY, HASH, REGEX, CODE
+
+ # 1. NUMERIC SWITCH
+
+ for (1..3)
+ {
+ switch ($_) {
+ # SELF
+ case ($_) { ok(1) } else { ok(0) }
+
+ # NUMERIC
+ case (1) { ok ($_==1) } else { ok($_!=1) }
+ case 1 { ok ($_==1) } else { ok($_!=1) }
+ case (3) { ok ($_==3) } else { ok($_!=3) }
+ case (4) { ok (0) } else { ok(1) }
+ case (2) { ok ($_==2) } else { ok($_!=2) }
+
+ # STRING
+ case ('a') { ok (0) } else { ok(1) }
+ case 'a' { ok (0) } else { ok(1) }
+ case ('3') { ok ($_ == 3) } else { ok($_ != 3) }
+ case ('3.0') { ok (0) } else { ok(1) }
+
+ # ARRAY
+ case ([10,5,1]) { ok ($_==1) } else { ok($_!=1) }
+ case [10,5,1] { ok ($_==1) } else { ok($_!=1) }
+ case (['a','b']) { ok (0) } else { ok(1) }
+ case (['a','b',3]) { ok ($_==3) } else { ok ($_!=3) }
+ case (['a','b',2.0]) { ok ($_==2) } else { ok ($_!=2) }
+ case ([]) { ok (0) } else { ok(1) }
+
+ # HASH
+ case ({}) { ok (0) } else { ok (1) }
+ case {} { ok (0) } else { ok (1) }
+ case {1,1} { ok ($_==1) } else { ok($_!=1) }
+ case ({1=>1, 2=>0}) { ok ($_==1) } else { ok($_!=1) }
+
+ # SUB/BLOCK
+ case (sub {$_[0]==2}) { ok ($_==2) } else { ok($_!=2) }
+ case {$_[0]==2} { ok ($_==2) } else { ok($_!=2) }
+ case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
+ case {1} { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH
+ }
+ }
+
+
+ # 2. STRING SWITCH
+
+ for ('a'..'c','1')
+ {
+ switch ($_) {
+ # SELF
+ case ($_) { ok(1) } else { ok(0) }
+
+ # NUMERIC
+ case (1) { ok ($_ !~ /[a-c]/) } else { ok ($_ =~ /[a-c]/) }
+ case (1.0) { ok ($_ !~ /[a-c]/) } else { ok ($_ =~ /[a-c]/) }
+
+ # STRING
+ case ('a') { ok ($_ eq 'a') } else { ok($_ ne 'a') }
+ case ('b') { ok ($_ eq 'b') } else { ok($_ ne 'b') }
+ case ('c') { ok ($_ eq 'c') } else { ok($_ ne 'c') }
+ case ('1') { ok ($_ eq '1') } else { ok($_ ne '1') }
+ case ('d') { ok (0) } else { ok (1) }
+
+ # ARRAY
+ case (['a','1']) { ok ($_ eq 'a' || $_ eq '1') }
+ else { ok ($_ ne 'a' && $_ ne '1') }
+ case (['z','2']) { ok (0) } else { ok(1) }
+ case ([]) { ok (0) } else { ok(1) }
+
+ # HASH
+ case ({}) { ok (0) } else { ok (1) }
+ case ({a=>'a', 1=>1, 2=>0}) { ok ($_ eq 'a' || $_ eq '1') }
+ else { ok ($_ ne 'a' && $_ ne '1') }
+
+ # SUB/BLOCK
+ case (sub{$_[0] eq 'a' }) { ok ($_ eq 'a') }
+ else { ok($_ ne 'a') }
+ case {$_[0] eq 'a'} { ok ($_ eq 'a') } else { ok($_ ne 'a') }
+ case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
+ case {1} { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH
+ }
+ }
+
+
+ # 3. ARRAY SWITCH
+
+ my $iteration = 0;
+ for ([],[1,'a'],[2,'b'])
+ {
+ switch ($_) {
+ $iteration++;
+ # SELF
+ case ($_) { ok(1) }
+
+ # NUMERIC
+ case (1) { ok ($iteration==2) } else { ok ($iteration!=2) }
+ case (1.0) { ok ($iteration==2) } else { ok ($iteration!=2) }
+
+ # STRING
+ case ('a') { ok ($iteration==2) } else { ok ($iteration!=2) }
+ case ('b') { ok ($iteration==3) } else { ok ($iteration!=3) }
+ case ('1') { ok ($iteration==2) } else { ok ($iteration!=2) }
+
+ # ARRAY
+ case (['a',2]) { ok ($iteration>=2) } else { ok ($iteration<2) }
+ case ([1,'a']) { ok ($iteration==2) } else { ok($iteration!=2) }
+ case ([]) { ok (0) } else { ok(1) }
+ case ([7..100]) { ok (0) } else { ok(1) }
+
+ # HASH
+ case ({}) { ok (0) } else { ok (1) }
+ case ({a=>'a', 1=>1, 2=>0}) { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+
+ # SUB/BLOCK
+ case {scalar grep /a/, @_} { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+ case (sub {scalar grep /a/, @_ }) { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+ case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
+ case {1} { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH
+ }
+ }
+
+
+ # 4. HASH SWITCH
+
+ $iteration = 0;
+ for ({},{a=>1,b=>0})
+ {
+ switch ($_) {
+ $iteration++;
+
+ # SELF
+ case ($_) { ok(1) } else { ok(0) }
+
+ # NUMERIC
+ case (1) { ok (0) } else { ok (1) }
+ case (1.0) { ok (0) } else { ok (1) }
+
+ # STRING
+ case ('a') { ok ($iteration==2) } else { ok ($iteration!=2) }
+ case ('b') { ok (0) } else { ok (1) }
+ case ('c') { ok (0) } else { ok (1) }
+
+ # ARRAY
+ case (['a',2]) { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+ case (['b','a']) { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+ case (['b','c']) { ok (0) } else { ok (1) }
+ case ([]) { ok (0) } else { ok(1) }
+ case ([7..100]) { ok (0) } else { ok(1) }
+
+ # HASH
+ case ({}) { ok (0) } else { ok (1) }
+ case ({a=>'a', 1=>1, 2=>0}) { ok (0) } else { ok (1) }
+
+ # SUB/BLOCK
+ case {$_[0]{a}} { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+ case (sub {$_[0]{a}}) { ok ($iteration==2) }
+ else { ok ($iteration!=2) }
+ case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
+ case {1} { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH
+ }
+ }
+
+
+ # 5. CODE SWITCH
+
+ $iteration = 0;
+ for ( sub {1},
+ sub { return 0 unless @_;
+ my ($data) = @_;
+ my $type = ref $data;
+ return $type eq 'HASH' && $data->{a}
+ || $type eq 'Regexp' && 'a' =~ /$data/
+ || $type eq "" && $data eq '1';
+ },
+ sub {0} )
+ {
+ switch ($_) {
+ $iteration++;
+ # SELF
+ case ($_) { ok(1) } else { ok(0) }
+
+ # NUMERIC
+ case (1) { ok ($iteration<=2) } else { ok ($iteration>2) }
+ case (1.0) { ok ($iteration<=2) } else { ok ($iteration>2) }
+ case (1.1) { ok ($iteration==1) } else { ok ($iteration!=1) }
+
+ # STRING
+ case ('a') { ok ($iteration==1) } else { ok ($iteration!=1) }
+ case ('b') { ok ($iteration==1) } else { ok ($iteration!=1) }
+ case ('c') { ok ($iteration==1) } else { ok ($iteration!=1) }
+ case ('1') { ok ($iteration<=2) } else { ok ($iteration>2) }
+
+ # ARRAY
+ case ([1, 'a']) { ok ($iteration<=2) }
+ else { ok ($iteration>2) }
+ case (['b','a']) { ok ($iteration==1) }
+ else { ok ($iteration!=1) }
+ case (['b','c']) { ok ($iteration==1) }
+ else { ok ($iteration!=1) }
+ case ([]) { ok ($iteration==1) } else { ok($iteration!=1) }
+ case ([7..100]) { ok ($iteration==1) }
+ else { ok($iteration!=1) }
+
+ # HASH
+ case ({}) { ok ($iteration==1) } else { ok ($iteration!=1) }
+ case ({a=>'a', 1=>1, 2=>0}) { ok ($iteration<=2) }
+ else { ok ($iteration>2) }
+
+ # SUB/BLOCK
+ case {$_[0]->{a}} { ok (0) } else { ok (1) }
+ case (sub {$_[0]{a}}) { ok (0) } else { ok (1) }
+ case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
+ case {1} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH
+ }
+ }
+
+
+ # NESTED SWITCHES
+
+ for my $count (1..3)
+ {
+ switch ([9,"a",11]) {
+ case (qr/\d/) {
+ switch ($count) {
+ case (1) { ok($count==1) }
+ else { ok($count!=1) }
+ case ([5,6]) { ok(0) } else { ok(1) }
+ }
+ }
+ ok(1) case (11);
+ }
+ }
diff -c 'perl-5.7.1/lib/Symbol.pm' 'perl-5.7.2/lib/Symbol.pm'
Index: ./lib/Symbol.pm
*** ./lib/Symbol.pm Tue Mar 6 04:05:35 2001
--- ./lib/Symbol.pm Mon Jul 9 17:10:42 2001
***************
*** 70,76 ****
@EXPORT = qw(gensym ungensym qualify qualify_to_ref);
@EXPORT_OK = qw(delete_package);
! $VERSION = 1.02;
my $genpkg = "Symbol::";
my $genseq = 0;
--- 70,76 ----
@EXPORT = qw(gensym ungensym qualify qualify_to_ref);
@EXPORT_OK = qw(delete_package);
! $VERSION = 1.03;
my $genpkg = "Symbol::";
my $genseq = 0;
diff -c /dev/null 'perl-5.7.2/lib/Symbol.t'
Index: ./lib/Symbol.t
*** ./lib/Symbol.t Thu Jan 1 02:00:00 1970
--- ./lib/Symbol.t Mon Jul 9 17:10:42 2001
***************
*** 0 ****
--- 1,52 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ print "1..8\n";
+
+ BEGIN { $_ = 'foo'; } # because Symbol used to clobber $_
+
+ use Symbol;
+
+ # First check $_ clobbering
+ print "not " if $_ ne 'foo';
+ print "ok 1\n";
+
+
+ # First test gensym()
+ $sym1 = gensym;
+ print "not " if ref($sym1) ne 'GLOB';
+ print "ok 2\n";
+
+ $sym2 = gensym;
+
+ print "not " if $sym1 eq $sym2;
+ print "ok 3\n";
+
+ ungensym $sym1;
+
+ $sym1 = $sym2 = undef;
+
+
+ # Test qualify()
+ package foo;
+
+ use Symbol qw(qualify); # must import into this package too
+
+ qualify("x") eq "foo::x" or print "not ";
+ print "ok 4\n";
+
+ qualify("x", "FOO") eq "FOO::x" or print "not ";
+ print "ok 5\n";
+
+ qualify("BAR::x") eq "BAR::x" or print "not ";
+ print "ok 6\n";
+
+ qualify("STDOUT") eq "main::STDOUT" or print "not ";
+ print "ok 7\n";
+
+ qualify("ARGV", "FOO") eq "main::ARGV" or print "not ";
+ print "ok 8\n";
diff -c 'perl-5.7.1/lib/Term/ANSIColor.pm' 'perl-5.7.2/lib/Term/ANSIColor.pm'
Index: ./lib/Term/ANSIColor.pm
Prereq: 1.3
*** ./lib/Term/ANSIColor.pm Fri Mar 16 04:54:50 2001
--- ./lib/Term/ANSIColor.pm Tue Jul 10 17:10:43 2001
***************
*** 1,10 ****
# Term::ANSIColor -- Color screen output using ANSI escape sequences.
! # $Id: ANSIColor.pm,v 1.3 2000/08/06 18:28:10 eagle Exp $
#
! # Copyright 1996, 1997, 1998, 2000
! # by Russ Allbery <rra@stanford.edu> and Zenin <zenin@best.com>
#
! # This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
# Ah, September, when the sysadmins turn colors and fall off the trees....
--- 1,10 ----
# Term::ANSIColor -- Color screen output using ANSI escape sequences.
! # $Id: ANSIColor.pm,v 1.4 2001/07/10 08:52:05 eagle Exp $
#
! # Copyright 1996, 1997, 1998, 2000, 2001
! # by Russ Allbery <rra@stanford.edu> and Zenin <zenin@bawdycaste.com>
#
! # This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.
#
# Ah, September, when the sysadmins turn colors and fall off the trees....
***************
*** 18,29 ****
require 5.001;
use strict;
! use vars qw(@ISA @EXPORT %EXPORT_TAGS $VERSION $AUTOLOAD %attributes
! $AUTORESET $EACHLINE);
use Exporter ();
@ISA = qw(Exporter);
@EXPORT = qw(color colored);
%EXPORT_TAGS = (constants => [qw(CLEAR RESET BOLD UNDERLINE UNDERSCORE BLINK
REVERSE CONCEALED BLACK RED GREEN YELLOW
BLUE MAGENTA CYAN WHITE ON_BLACK ON_RED
--- 18,30 ----
require 5.001;
use strict;
! use vars qw($AUTOLOAD $AUTORESET $EACHLINE @ISA @EXPORT @EXPORT_OK
! %EXPORT_TAGS $VERSION %attributes %attributes_r);
use Exporter ();
@ISA = qw(Exporter);
@EXPORT = qw(color colored);
+ @EXPORT_OK = qw(uncolor);
%EXPORT_TAGS = (constants => [qw(CLEAR RESET BOLD UNDERLINE UNDERSCORE BLINK
REVERSE CONCEALED BLACK RED GREEN YELLOW
BLUE MAGENTA CYAN WHITE ON_BLACK ON_RED
***************
*** 33,39 ****
# Don't use the CVS revision as the version, since this module is also in
# Perl core and too many things could munge CVS magic revision strings.
! $VERSION = 1.03;
############################################################################
--- 34,40 ----
# Don't use the CVS revision as the version, since this module is also in
# Perl core and too many things could munge CVS magic revision strings.
! $VERSION = 1.04;
############################################################################
***************
*** 50,65 ****
'reverse' => 7,
'concealed' => 8,
! 'black' => 30, 'on_black' => 40,
! 'red' => 31, 'on_red' => 41,
! 'green' => 32, 'on_green' => 42,
! 'yellow' => 33, 'on_yellow' => 43,
! 'blue' => 34, 'on_blue' => 44,
! 'magenta' => 35, 'on_magenta' => 45,
! 'cyan' => 36, 'on_cyan' => 46,
'white' => 37, 'on_white' => 47);
############################################################################
# Implementation (constant form)
############################################################################
--- 51,71 ----
'reverse' => 7,
'concealed' => 8,
! 'black' => 30, 'on_black' => 40,
! 'red' => 31, 'on_red' => 41,
! 'green' => 32, 'on_green' => 42,
! 'yellow' => 33, 'on_yellow' => 43,
! 'blue' => 34, 'on_blue' => 44,
! 'magenta' => 35, 'on_magenta' => 45,
! 'cyan' => 36, 'on_cyan' => 46,
'white' => 37, 'on_white' => 47);
+ # Reverse lookup. Alphabetically first name for a sequence is preferred.
+ for (reverse sort keys %attributes) {
+ $attributes_r{$attributes{$_}} = $_;
+ }
+
############################################################################
# Implementation (constant form)
############################################################################
***************
*** 81,92 ****
# sub to define the constant subs on demand. To do that, we check the name
# of the called sub against the list of attributes, and if it's an all-caps
# version of one of them, we define the sub on the fly and then run it.
sub AUTOLOAD {
my $sub;
($sub = $AUTOLOAD) =~ s/^.*:://;
my $attr = $attributes{lc $sub};
if ($sub =~ /^[A-Z_]+$/ && defined $attr) {
! $attr = "\e[" . $attr . 'm';
eval qq {
sub $AUTOLOAD {
if (\$AUTORESET && \@_) {
--- 87,104 ----
# sub to define the constant subs on demand. To do that, we check the name
# of the called sub against the list of attributes, and if it's an all-caps
# version of one of them, we define the sub on the fly and then run it.
+ #
+ # If the environment variable ANSI_COLORS_DISABLED is set, turn all of the
+ # generated subs into pass-through functions that don't add any escape
+ # sequences. This is to make it easier to write scripts that also work on
+ # systems without any ANSI support, like Windows consoles.
sub AUTOLOAD {
+ my $enable_colors = !defined $ENV{ANSI_COLORS_DISABLED};
my $sub;
($sub = $AUTOLOAD) =~ s/^.*:://;
my $attr = $attributes{lc $sub};
if ($sub =~ /^[A-Z_]+$/ && defined $attr) {
! $attr = $enable_colors ? "\e[" . $attr . 'm' : '';
eval qq {
sub $AUTOLOAD {
if (\$AUTORESET && \@_) {
***************
*** 110,115 ****
--- 122,128 ----
# Return the escape code for a given set of color attributes.
sub color {
+ return '' if defined $ENV{ANSI_COLORS_DISABLED};
my @codes = map { split } @_;
my $attribute = '';
foreach (@codes) {
***************
*** 124,129 ****
--- 137,169 ----
($attribute ne '') ? "\e[${attribute}m" : undef;
}
+ # Return a list of named color attributes for a given set of escape codes.
+ # Escape sequences can be given with or without enclosing "\e[" and "m".
+ # The empty escape sequence '' or "\e[m" gives an empty list of attrs.
+ sub uncolor {
+ my (@nums, @result);
+ for (@_) {
+ my $escape = $_;
+ $escape =~ s/^\e\[//;
+ $escape =~ s/m$//;
+ unless ($escape =~ /^((?:\d+;)*\d*)$/) {
+ require Carp;
+ Carp::croak ("Bad escape sequence $_");
+ }
+ push (@nums, split (/;/, $1));
+ }
+ for (@nums) {
+ $_ += 0; # Strip leading zeroes
+ my $name = $attributes_r{$_};
+ if (!defined $name) {
+ require Carp;
+ Carp::croak ("No name for escape sequence $_" );
+ }
+ push (@result, $name);
+ }
+ @result;
+ }
+
# Given a string and a set of attributes, returns the string surrounded by
# escape codes to set those attributes and then clear them at the end of the
# string. The attributes can be given either as an array ref as the first
***************
*** 141,149 ****
$string = shift;
@codes = @_;
}
if (defined $EACHLINE) {
my $attr = color (@codes);
! join '',
map { $_ && $_ ne $EACHLINE ? $attr . $_ . "\e[0m" : $_ }
split (/(\Q$EACHLINE\E)/, $string);
} else {
--- 181,190 ----
$string = shift;
@codes = @_;
}
+ return $string if defined $ENV{ANSI_COLORS_DISABLED};
if (defined $EACHLINE) {
my $attr = color (@codes);
! join '',
map { $_ && $_ ne $EACHLINE ? $attr . $_ . "\e[0m" : $_ }
split (/(\Q$EACHLINE\E)/, $string);
} else {
***************
*** 175,180 ****
--- 216,224 ----
print "This text is normal.\n";
print colored ['yellow on_magenta'], "Yellow on magenta.\n";
+ use Term::ANSIColor qw(uncolor);
+ print uncolor '01;31', "\n";
+
use Term::ANSIColor qw(:constants);
print BOLD, BLUE, "This text is in bold blue.\n", RESET;
***************
*** 186,207 ****
=head1 DESCRIPTION
This module has two interfaces, one through color() and colored() and the
! other through constants.
color() takes any number of strings as arguments and considers them to be
space-separated lists of attributes. It then forms and returns the escape
! sequence to set those attributes. It doesn't print it out, just returns
! it, so you'll have to print it yourself if you want to (this is so that
! you can save it as a string, pass it to something else, send it to a file
! handle, or do anything else with it that you might care to).
The recognized attributes (all of which should be fairly intuitive) are
! clear, reset, dark, bold, underline, underscore, blink, reverse,
! concealed, black, red, green, yellow, blue, magenta, on_black, on_red,
! on_green, on_yellow, on_blue, on_magenta, on_cyan, and on_white. Case is
! not significant. Underline and underscore are equivalent, as are clear
! and reset, so use whichever is the most intuitive to you. The color alone
! sets the foreground color, and on_color sets the background color.
Note that not all attributes are supported by all terminal types, and some
terminals may not support any of these sequences. Dark, blink, and
--- 230,255 ----
=head1 DESCRIPTION
This module has two interfaces, one through color() and colored() and the
! other through constants. It also offers the utility function uncolor(),
! which has to be explicitly imported to be used (see L<SYNOPSYS>).
color() takes any number of strings as arguments and considers them to be
space-separated lists of attributes. It then forms and returns the escape
! sequence to set those attributes. It doesn't print it out, just returns it,
! so you'll have to print it yourself if you want to (this is so that you can
! save it as a string, pass it to something else, send it to a file handle, or
! do anything else with it that you might care to).
+ uncolor() performs the opposite translation, turning escape sequences
+ into a list of strings.
+
The recognized attributes (all of which should be fairly intuitive) are
! clear, reset, dark, bold, underline, underscore, blink, reverse, concealed,
! black, red, green, yellow, blue, magenta, on_black, on_red, on_green,
! on_yellow, on_blue, on_magenta, on_cyan, and on_white. Case is not
! significant. Underline and underscore are equivalent, as are clear and
! reset, so use whichever is the most intuitive to you. The color alone sets
! the foreground color, and on_color sets the background color.
Note that not all attributes are supported by all terminal types, and some
terminals may not support any of these sequences. Dark, blink, and
***************
*** 212,239 ****
after your script is done running, and people get very annoyed at having
their prompt and typing changed to weird colors.
! As an aid to help with this, colored() takes a scalar as the first
! argument and any number of attribute strings as the second argument and
! returns the scalar wrapped in escape codes so that the attributes will be
! set as requested before the string and reset to normal after the string.
! Alternately, you can pass a reference to an array as the first argument,
! and then the contents of that array will be taken as attributes and color
! codes and the remainder of the arguments as text to colorize.
Normally, colored() just puts attribute codes at the beginning and end of
! the string, but if you set $Term::ANSIColor::EACHLINE to some string,
! that string will be considered the line delimiter and the attribute will
! be set at the beginning of each line of the passed string and reset at the
! end of each line. This is often desirable if the output is being sent to
! a program like a pager that can be confused by attributes that span lines.
! Normally you'll want to set $Term::ANSIColor::EACHLINE to C<"\n"> to use
! this feature.
Alternately, if you import C<:constants>, you can use the constants CLEAR,
! RESET, BOLD, DARK, UNDERLINE, UNDERSCORE, BLINK, REVERSE, CONCEALED,
! BLACK, RED, GREEN, YELLOW, BLUE, MAGENTA, ON_BLACK, ON_RED, ON_GREEN,
! ON_YELLOW, ON_BLUE, ON_MAGENTA, ON_CYAN, and ON_WHITE directly. These are
! the same as color('attribute') and can be used if you prefer typing:
print BOLD BLUE ON_WHITE "Text\n", RESET;
--- 260,287 ----
after your script is done running, and people get very annoyed at having
their prompt and typing changed to weird colors.
! As an aid to help with this, colored() takes a scalar as the first argument
! and any number of attribute strings as the second argument and returns the
! scalar wrapped in escape codes so that the attributes will be set as
! requested before the string and reset to normal after the string.
! Alternately, you can pass a reference to an array as the first argument, and
! then the contents of that array will be taken as attributes and color codes
! and the remainder of the arguments as text to colorize.
Normally, colored() just puts attribute codes at the beginning and end of
! the string, but if you set $Term::ANSIColor::EACHLINE to some string, that
! string will be considered the line delimiter and the attribute will be set
! at the beginning of each line of the passed string and reset at the end of
! each line. This is often desirable if the output is being sent to a program
! like a pager that can be confused by attributes that span lines. Normally
! you'll want to set $Term::ANSIColor::EACHLINE to C<"\n"> to use this
! feature.
Alternately, if you import C<:constants>, you can use the constants CLEAR,
! RESET, BOLD, DARK, UNDERLINE, UNDERSCORE, BLINK, REVERSE, CONCEALED, BLACK,
! RED, GREEN, YELLOW, BLUE, MAGENTA, ON_BLACK, ON_RED, ON_GREEN, ON_YELLOW,
! ON_BLUE, ON_MAGENTA, ON_CYAN, and ON_WHITE directly. These are the same as
! color('attribute') and can be used if you prefer typing:
print BOLD BLUE ON_WHITE "Text\n", RESET;
***************
*** 260,274 ****
twenty-two in the constants interface. On the flip side, the constants
interface has the advantage of better compile time error checking, since
misspelled names of colors or attributes in calls to color() and colored()
! won't be caught until runtime whereas misspelled names of constants will
! be caught at compile time. So, polute your namespace with almost two
! dozen subroutines that you may not even use that often, or risk a silly
! bug by mistyping an attribute. Your choice, TMTOWTDI after all.
=head1 DIAGNOSTICS
=over 4
=item Invalid attribute name %s
(F) You passed an invalid attribute name to either color() or colored().
--- 308,339 ----
twenty-two in the constants interface. On the flip side, the constants
interface has the advantage of better compile time error checking, since
misspelled names of colors or attributes in calls to color() and colored()
! won't be caught until runtime whereas misspelled names of constants will be
! caught at compile time. So, polute your namespace with almost two dozen
! subroutines that you may not even use that often, or risk a silly bug by
! mistyping an attribute. Your choice, TMTOWTDI after all.
=head1 DIAGNOSTICS
=over 4
+ =item Bad escape sequence %s
+
+ (F) You passed an invalid ANSI escape sequence to uncolor().
+
+ =item Bareword "%s" not allowed while "strict subs" in use
+
+ (F) You probably mistyped a constant color name such as:
+
+ $Foobar = FOOBAR . "This line should be blue\n";
+
+ or:
+
+ @Foobar = FOOBAR, "This line should be blue\n";
+
+ This will only show up under use strict (another good reason to run under
+ use strict).
+
=item Invalid attribute name %s
(F) You passed an invalid attribute name to either color() or colored().
***************
*** 292,310 ****
the constants interface, since you'll immediately know if you mistype a
color name.
! =item Bareword "%s" not allowed while "strict subs" in use
! (F) You probably mistyped a constant color name such as:
! $Foobar = FOOBAR . "This line should be blue\n";
! or:
! @Foobar = FOOBAR, "This line should be blue\n";
! This will only show up under use strict (another good reason to run under
! use strict).
=back
=head1 RESTRICTIONS
--- 357,385 ----
the constants interface, since you'll immediately know if you mistype a
color name.
! =item No name for escape sequence %s
! (F) The ANSI escape sequence passed to uncolor() contains escapes which
! aren't recognized and can't be translated to names.
! =back
! =head1 ENVIRONMENT
! =over 4
! =item ANSI_COLORS_DISABLED
+ If this environment variable is set, all of the functions defined by this
+ module (color(), colored(), and all of the constants not previously used in
+ the program) will not output any escape sequences and instead will just
+ return the empty string or pass through the original text as appropriate.
+ This is intended to support easy use of scripts using this module on
+ platforms that don't support ANSI escape sequences.
+
+ For it to have its proper effect, this environment variable must be set
+ before any color constants are used in the program.
+
=back
=head1 RESTRICTIONS
***************
*** 316,330 ****
but the syntax of Perl doesn't allow this. You need a comma after the
string. (Of course, you may consider it a bug that commas between all the
! constants aren't required, in which case you may feel free to insert
! commas unless you're using $Term::ANSIColor::AUTORESET.)
For easier debuging, you may prefer to always use the commas when not
! setting $Term::ANSIColor::AUTORESET so that you'll get a fatal compile
! error rather than a warning.
=head1 NOTES
Jean Delvare provided the following table of different common terminal
emulators and their support for the various attributes:
--- 391,417 ----
but the syntax of Perl doesn't allow this. You need a comma after the
string. (Of course, you may consider it a bug that commas between all the
! constants aren't required, in which case you may feel free to insert commas
! unless you're using $Term::ANSIColor::AUTORESET.)
For easier debuging, you may prefer to always use the commas when not
! setting $Term::ANSIColor::AUTORESET so that you'll get a fatal compile error
! rather than a warning.
=head1 NOTES
+ The codes generated by this module are standard terminal control codes,
+ complying with ECMA-48 and ISO 6429 (generally referred to as "ANSI color"
+ for the color codes). The non-color control codes (bold, dark, italic,
+ underline, and reverse) are part of the earlier ANSI X3.64 standard for
+ control sequences for video terminals and peripherals.
+
+ Note that not all displays are ISO 6429-compliant, or even X3.64-compliant
+ (or are even attempting to be so). This module will not work as expected on
+ displays that do not honor these escape sequences, such as (reportedly) the
+ "console" in at least some versions of Windows. They may just be ignored,
+ or they may display as an ESC character followed by some apparent garbage.
+
Jean Delvare provided the following table of different common terminal
emulators and their support for the various attributes:
***************
*** 338,351 ****
aixterm kinda normal no yes no yes yes
Where the entry is other than yes or no, that emulator interpret the given
! attribute as something else instead. Note that on an aixterm, clear
! doesn't reset colors; you have to explicitly set the colors back to what
! you want. More entries in this table are welcome.
=head1 AUTHORS
! Original idea (using constants) by Zenin (zenin@best.com), reimplemented
! using subs by Russ Allbery (rra@stanford.edu), and then combined with the
! original idea by Russ with input from Zenin.
=cut
--- 425,463 ----
aixterm kinda normal no yes no yes yes
Where the entry is other than yes or no, that emulator interpret the given
! attribute as something else instead. Note that on an aixterm, clear doesn't
! reset colors; you have to explicitly set the colors back to what you want.
! More entries in this table are welcome.
+ Note that codes 3 (italic), 6 (rapid blink), and 9 (strikethrough) are
+ specified in ANSI X3.64 and ECMA-048 but are not commonly supported by most
+ displays and emulators and therefore aren't supported by this module at the
+ present time. ECMA-048 also specifies a large number of other attributes,
+ including a sequence of attributes for font changes, Fraktur characters,
+ double-underlining, framing, circling, and overlining. As none of these
+ attributes are widely supported or useful, they also aren't currently
+ supported by this module.
+
+ =head1 SEE ALSO
+
+ ECMA-048 is available on-line (at least at the time of this writing) at
+ E<lt>http://www.ecma.ch/ecma1/STAND/ECMA-048.HTME<gt>.
+
+ ISO 6429 is available from ISO for a charge; the author of this module does
+ not own a copy of it. Since the source material for ISO 6429 was ECMA-048
+ and the latter is available for free, there seems little reason to obtain
+ the ISO standard.
+
=head1 AUTHORS
! Original idea (using constants) by Zenin, reimplemented using subs by Russ
! Allbery E<lt>rra@stanford.eduE<gt>, and then combined with the original idea
! by Russ with input from Zenin. Russ Allbery now maintains this module.
!
! =head1 LICENSE
!
! Copyright 1996, 1997, 1998, 2000, 2001 Russ Allbery <rra@stanford.edu> and
! Zenin <zenin@bawdycaste.org>. This program is free software; you may
! redistribute it and/or modify it under the same terms as Perl itself.
=cut
diff -c /dev/null 'perl-5.7.2/lib/Term/ANSIColor/ChangeLog'
Index: ./lib/Term/ANSIColor/ChangeLog
*** ./lib/Term/ANSIColor/ChangeLog Thu Jan 1 02:00:00 1970
--- ./lib/Term/ANSIColor/ChangeLog Tue Jul 10 17:10:23 2001
***************
*** 0 ****
--- 1,127 ----
+ 2001-07-10 Russ Allbery <rra@stanford.edu>
+
+ * ANSIColor.pm: Version 1.04 released.
+
+ * ANSIColor.pm: Add documentation, examples, and diagnostics for
+ uncolor. Document ANSI_COLORS_DISABLED. Add information about
+ the relevant standards for these escape sequences and the
+ additional ones that aren't supported by this module. Add a
+ pointer to the relevant standards. Add a LICENSE section. Update
+ Zenin's e-mail address.
+
+ * ANSIColor.pm (AUTOLOAD): Add support for ANSI_COLORS_DISABLED.
+ (color): Likewise.
+ (colored): Likewise.
+ * test.pl: Add tests for ANSI_COLORS_DISABLED.
+
+ * ANSIColor.pm (uncolor): New function.
+ * test.pl: Add a test for it.
+
+ 2000-08-06 Russ Allbery <rra@stanford.edu>
+
+ * ANSIColor.pm: Version 1.03 released.
+
+ * Makefile.PL: Install in the Perl library directory for Perl
+ versions >= 5.6.0.
+
+ * test.pl: Added a new test for the array reference syntax for
+ colored.
+
+ * ANSIColor.pm: Changed $VERSION to a static string. Added dark
+ to the attributes. Updated the documentation to include a table
+ of supported attributes on different terminal emulators, to add
+ dark, to document the new optional way to call colored, and to
+ mark the diagnostics as fatal errors or warnings.
+ (colored): Allow the attributes to be passed as an initial array
+ reference as well as a final list, and for that calling syntax
+ take the rest of the arguments as text to be colored.
+
+ 1998-11-27 Russ Allbery <rra@stanford.edu>
+
+ * ANSIColor.pm: Version 1.02 released.
+
+ * Makefile.PL: Added a 5.005-only section giving ABSTRACT and
+ AUTHOR settings for generating a PPD to go with a binary
+ distribution or the Perl Resource Kits.
+
+ 1998-04-14 Russ Allbery <rra@stanford.edu>
+
+ * ANSIColor.pm: croak() instead of die() on AUTOLOAD failure to
+ get the right error text, fixed a bunch of typos in the
+ documentation, added a quote.
+
+ 1997-12-10 Russ Allbery <rra@stanford.edu>
+
+ * ANSIColor.pm: Version 1.01 released.
+
+ * ANSIColor.pm (color): Carp::croak() isn't predeclared, so it
+ needs parens around its argument. This bug will only show up in
+ versions of Perl >5.004_04 since up until then strict.pm imports
+ Carp which predeclares the function.
+
+ 1997-11-29 Russ Allbery <rra@stanford.edu>
+
+ * ANSIColor.pm: Version 1.00 released.
+
+ * Makefile.PL: Now gets version information from the module, has
+ the correct rules to build a distribution.
+
+ * test.pl: Comments trimmed, minor test modifications.
+
+ * ANSIColor.pm: Changed my e-mail address, fixed to deal correctly
+ with trailing delimiters when EACHLINE is being used, die()
+ changed to croak() if the caller uses an invalid attribute name,
+ getting $VERSION from RCS updated to my current method, source
+ detabified.
+
+ * test.pl: Added test for EACHLINE with trailing delimiters.
+
+ 1997-02-17 Russ Allbery <rra@stanford.edu>
+
+ * ANSIColor.pm: Version 0.9 released.
+
+ * ANSIColor.pm: Changed the runtime error message to start with an
+ uppercase letter, reworked the documentation considerably
+ including adding more comparison between the two interfaces,
+ fixing some formatting bugs, fixing a typo, adding more
+ diagnostics, and generally being more verbose.
+
+ 1997-01-08 Russ Allbery <rra@stanford.edu>
+
+ * ANSIColor.pm: Version 0.8 released.
+
+ * test.pl: Fixed the test numbering in the BEGIN block.
+
+ * test.pl: Reformatted and commented to fit my programming style.
+
+ * ANSIColor.pm: Changed the method by which $VERSION is set so
+ that it will always have two digits after the decimal point.
+
+ * test.pl: New file.
+
+ * ANSIColor.pm: [Revision 0.7] Changed the codes so that reset is
+ always consistantly "\e[0m".
+
+ * ANSIColor.pm: [Revision 0.6] Added $EACHLINE and support to
+ colored() for it so that attributes can be reset around every
+ newline (or other line delimiter -- we're flexible). Documented
+ this as well.
+
+ * ANSIColor.pm: [Revision 0.5] Changed implementation of the
+ constants to autoloaded subs, added the $AUTORESET variable for
+ use with the constants, and documented this.
+
+ 1996-12-07 Russ Allbery <rra@stanford.edu>
+
+ * ANSIColor.pm: [Revision 0.4] Added POD documentation.
+
+ * ANSIColor.pm: [Revision 0.3] Added constant forms, modified to
+ allow a space-separated string of attributes to be passed to
+ color() and colored(), added Zenin to the credits.
+
+ 1996-12-04 Russ Allbery <rra@stanford.edu>
+
+ * ANSIColor.pm: [Revision 0.2] Changed return syntax and check for
+ the null attribute string.
+
+ * ANSIColor.pm: New file.
diff -c /dev/null 'perl-5.7.2/lib/Term/ANSIColor/README'
Index: ./lib/Term/ANSIColor/README
*** ./lib/Term/ANSIColor/README Thu Jan 1 02:00:00 1970
--- ./lib/Term/ANSIColor/README Tue Jul 10 17:10:23 2001
***************
*** 0 ****
--- 1,77 ----
+ Term::ANSIColor version 1.04
+ (A simple ANSI text attribute control module)
+
+ Copyright 1996, 1997, 1998, 2000, 2001 Russ Allbery <rra@stanford.edu>
+ and Zenin <zenin@bawdycaste.org>. This program is free software; you
+ may redistribute it and/or modify it under the same terms as Perl
+ itself.
+
+
+ INTRODUCTION
+
+ This module grew out of a thread on comp.lang.perl.misc where several of
+ us were throwing around different ways to print colored text from Perl
+ scripts and Zenin posted his old library to do that. I (Russ) disagreed
+ with the implementation and offered my own (the color() and colored()
+ functions implemented in this package), Zenin convinced me that the
+ constants had their place as well, and we started figuring out the best
+ ways of implementing both.
+
+ While ANSI color escape codes are fairly simple, it can be hard to
+ remember the codes for all of the attributes and the code resulting from
+ hard-coding them into your script is definitely difficult to read. This
+ module is designed to fix those problems, as well as provide a convenient
+ interface to do a few things for you automatically (like resetting
+ attributes after the text you print out so that you don't accidentally
+ leave attributes set).
+
+ Despite its name, this module can also handle non-color ANSI text
+ attributes (bold, underline, reverse video, and blink). It uses either of
+ two interfaces, one of which uses "constants" for each different attribute
+ and the other of which uses two subs which take strings of attributes as
+ arguments.
+
+ See the POD documentation for complete details, features, and usage.
+
+
+ INSTALLATION
+
+ Follow the standard installation procedure for Perl modules, which is to
+ type the following commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+ You'll probably need to do the last as root. If instead you wish to
+ install the module by hand, simply copy it into a directory named Term in
+ your Perl library directory.
+
+ Note that make install, for Perl 5.6.0 or later, will replace the
+ Term::ANSIColor that came with Perl. You may wan to save a backup copy
+ of the standard version first.
+
+
+ THANKS
+
+ To Jon Lennox for looking at early versions of this module, providing
+ feedback, and offering suggestions for improvement.
+
+ To Jesse Taylor for writing the first significant script to use this
+ module (colorized calsplit), thus offering innumerable opportunities to
+ test and debug.
+
+ To Jean Delvare for providing documentation of what the various
+ attributes do on various different terminal emulators, and for noting
+ that attribute 2 is dark.
+
+ To Edward Avis for the implementation of uncolor.
+
+ To Rani Pinchuk for the idea of ANSI_COLORS_DISABLED and an initial
+ implementation.
+
+ To Larry Wall, as always, for Perl.
+
+ Russ Allbery
+ rra@stanford.edu
diff -c /dev/null 'perl-5.7.2/lib/Term/ANSIColor/test.pl'
Index: ./lib/Term/ANSIColor/test.pl
*** ./lib/Term/ANSIColor/test.pl Thu Jan 1 02:00:00 1970
--- ./lib/Term/ANSIColor/test.pl Tue Jul 10 17:10:53 2001
***************
*** 0 ****
--- 1,104 ----
+ # Test suite for the Term::ANSIColor Perl module. Before `make install' is
+ # performed this script should be runnable with `make test'. After `make
+ # install' it should work as `perl test.pl'.
+
+ ############################################################################
+ # Ensure module can be loaded
+ ############################################################################
+
+ BEGIN { $| = 1; print "1..12\n" }
+ END { print "not ok 1\n" unless $loaded }
+ delete $ENV{ANSI_COLORS_DISABLED};
+ use Term::ANSIColor qw(:constants color colored uncolor);
+ $loaded = 1;
+ print "ok 1\n";
+
+
+ ############################################################################
+ # Test suite
+ ############################################################################
+
+ # Test simple color attributes.
+ if (color ('blue on_green', 'bold') eq "\e[34;42;1m") {
+ print "ok 2\n";
+ } else {
+ print "not ok 2\n";
+ }
+
+ # Test colored.
+ if (colored ("testing", 'blue', 'bold') eq "\e[34;1mtesting\e[0m") {
+ print "ok 3\n";
+ } else {
+ print "not ok 3\n";
+ }
+
+ # Test the constants.
+ if (BLUE BOLD "testing" eq "\e[34m\e[1mtesting") {
+ print "ok 4\n";
+ } else {
+ print "not ok 4\n";
+ }
+
+ # Test AUTORESET.
+ $Term::ANSIColor::AUTORESET = 1;
+ if (BLUE BOLD "testing" eq "\e[34m\e[1mtesting\e[0m\e[0m") {
+ print "ok 5\n";
+ } else {
+ print "not ok 5\n";
+ }
+
+ # Test EACHLINE.
+ $Term::ANSIColor::EACHLINE = "\n";
+ if (colored ("test\n\ntest", 'bold')
+ eq "\e[1mtest\e[0m\n\n\e[1mtest\e[0m") {
+ print "ok 6\n";
+ } else {
+ print colored ("test\n\ntest", 'bold'), "\n";
+ print "not ok 6\n";
+ }
+
+ # Test EACHLINE with multiple trailing delimiters.
+ $Term::ANSIColor::EACHLINE = "\r\n";
+ if (colored ("test\ntest\r\r\n\r\n", 'bold')
+ eq "\e[1mtest\ntest\r\e[0m\r\n\r\n") {
+ print "ok 7\n";
+ } else {
+ print "not ok 7\n";
+ }
+
+ # Test the array ref form.
+ $Term::ANSIColor::EACHLINE = "\n";
+ if (colored (['bold', 'on_green'], "test\n", "\n", "test")
+ eq "\e[1;42mtest\e[0m\n\n\e[1;42mtest\e[0m") {
+ print "ok 8\n";
+ } else {
+ print colored (['bold', 'on_green'], "test\n", "\n", "test");
+ print "not ok 8\n";
+ }
+
+ # Test uncolor.
+ my @names = uncolor ('1;42', "\e[m", '', "\e[0m");
+ if (join ('|', @names) eq 'bold|on_green|clear') {
+ print "ok 9\n";
+ } else {
+ print join ('|', @names), "\n";
+ print "not ok 9\n";
+ }
+
+ # Test ANSI_COLORS_DISABLED.
+ $ENV{ANSI_COLORS_DISABLED} = 1;
+ if (color ('blue') == '') {
+ print "ok 10\n";
+ } else {
+ print "not ok 10\n";
+ }
+ if (colored ('testing', 'blue', 'on_red') == 'testing') {
+ print "ok 11\n";
+ } else {
+ print "not ok 11\n";
+ }
+ if (GREEN 'testing' eq 'testing') {
+ print "ok 12\n";
+ } else {
+ print "not ok 12\n";
+ }
diff -c 'perl-5.7.1/lib/Term/Cap.pm' 'perl-5.7.2/lib/Term/Cap.pm'
Index: ./lib/Term/Cap.pm
*** ./lib/Term/Cap.pm Tue Mar 6 04:05:35 2001
--- ./lib/Term/Cap.pm Mon Jul 9 17:10:42 2001
***************
*** 1,9 ****
package Term::Cap;
use Carp;
! our $VERSION = '1.00';
! # Last updated: Thu Nov 30 23:34:29 EST 2000 by schwern@pobox.com
# TODO:
# support Berkeley DB termcaps
--- 1,13 ----
package Term::Cap;
use Carp;
! our $VERSION = '1.01';
! # Version undef: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com
! # Version 1.00: Thu Nov 30 23:34:29 EST 2000 by schwern@pobox.com
! # [PATCH] $VERSION crusade, strict, tests, etc... all over lib/
! # Version 1.01: Wed May 23 00:00:00 CST 2001 by d-lewart@uiuc.edu
! # Avoid warnings in Tgetent and Tputs
# TODO:
# support Berkeley DB termcaps
***************
*** 164,169 ****
--- 168,181 ----
}
my @termcap_path = termcap_path;
+
+ unless (@termcap_path || $entry)
+ {
+ # last resort--fake up a termcap from terminfo
+ local $ENV{TERM} = $term;
+ $entry = `infocmp -C 2>/dev/null`;
+ }
+
croak "Can't find a valid termcap file" unless @termcap_path || $entry;
$state = 1; # 0 == finished
***************
*** 204,210 ****
}
}
defined $entry or $entry = '';
! $entry .= $_;
};
while ($state != 0) {
--- 216,222 ----
}
}
defined $entry or $entry = '';
! $entry .= $_ if $_;
};
while ($state != 0) {
***************
*** 307,314 ****
$string = Tpad($self, $self->{'_' . $cap}, $cnt);
} else {
# cache result because Tpad can be slow
! $string = defined $self->{$cap} ? $self->{$cap} :
! ($self->{$cap} = Tpad($self, $self->{'_' . $cap}, 1));
}
print $FH $string if $FH;
$string;
--- 319,329 ----
$string = Tpad($self, $self->{'_' . $cap}, $cnt);
} else {
# cache result because Tpad can be slow
! unless (exists $self->{$cap}) {
! $self->{$cap} = exists $self->{"_$cap"} ?
! Tpad($self, $self->{"_$cap"}, 1) : undef;
! }
! $string = $self->{$cap};
}
print $FH $string if $FH;
$string;
diff -c 'perl-5.7.1/lib/Test.pm' 'perl-5.7.2/lib/Test.pm'
Index: ./lib/Test.pm
*** ./lib/Test.pm Fri Mar 16 04:54:50 2001
--- ./lib/Test.pm Mon Jul 9 17:10:43 2001
***************
*** 1,18 ****
- use strict;
package Test;
! use Test::Harness 1.1601 ();
use Carp;
! our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $ntest, $TestLevel); #public-ish
! our($TESTOUT, $ONFAIL, %todo, %history, $planned, @FAILDETAIL); #private-ish
! $VERSION = '1.15';
require Exporter;
@ISA=('Exporter');
- @EXPORT=qw(&plan &ok &skip);
- @EXPORT_OK=qw($ntest $TESTOUT);
$TestLevel = 0; # how many extra stack frames to skip
$|=1;
- #$^W=1; ?
$ntest=1;
$TESTOUT = *STDOUT{IO};
--- 1,23 ----
package Test;
!
! require 5.004;
!
! use strict;
!
use Carp;
! use vars (qw($VERSION @ISA @EXPORT @EXPORT_OK $ntest $TestLevel), #public-ish
! qw($TESTOUT $ONFAIL %todo %history $planned @FAILDETAIL)#private-ish
! );
!
! $VERSION = '1.17_00';
require Exporter;
@ISA=('Exporter');
+ @EXPORT = qw(&plan &ok &skip);
+ @EXPORT_OK = qw($ntest $TESTOUT);
+
$TestLevel = 0; # how many extra stack frames to skip
$|=1;
$ntest=1;
$TESTOUT = *STDOUT{IO};
***************
*** 20,28 ****
--- 25,114 ----
# help test coverage analyzers know which test is running.
$ENV{REGRESSION_TEST} = $0;
+
+ =head1 NAME
+
+ Test - provides a simple framework for writing test scripts
+
+ =head1 SYNOPSIS
+
+ use strict;
+ use Test;
+
+ # use a BEGIN block so we print our plan before MyModule is loaded
+ BEGIN { plan tests => 14, todo => [3,4] }
+
+ # load your module...
+ use MyModule;
+
+ ok(0); # failure
+ ok(1); # success
+
+ ok(0); # ok, expected failure (see todo list, above)
+ ok(1); # surprise success!
+
+ ok(0,1); # failure: '0' ne '1'
+ ok('broke','fixed'); # failure: 'broke' ne 'fixed'
+ ok('fixed','fixed'); # success: 'fixed' eq 'fixed'
+ ok('fixed',qr/x/); # success: 'fixed' =~ qr/x/
+
+ ok(sub { 1+1 }, 2); # success: '2' eq '2'
+ ok(sub { 1+1 }, 3); # failure: '2' ne '3'
+ ok(0, int(rand(2)); # (just kidding :-)
+
+ my @list = (0,0);
+ ok @list, 3, "\@list=".join(',',@list); #extra diagnostics
+ ok 'segmentation fault', '/(?i)success/'; #regex match
+
+ skip($feature_is_missing, ...); #do platform specific test
+
+ =head1 DESCRIPTION
+
+ L<Test::Harness|Test::Harness> expects to see particular output when it
+ executes tests. This module aims to make writing proper test scripts just
+ a little bit easier (and less error prone :-).
+
+
+ =head2 Functions
+
+ All the following are exported by Test by default.
+
+ =over 4
+
+ =item B<plan>
+
+ BEGIN { plan %theplan; }
+
+ This should be the first thing you call in your test script. It
+ declares your testing plan, how many there will be, if any of them
+ should be allowed to fail, etc...
+
+ Typical usage is just:
+
+ use Test;
+ BEGIN { plan tests => 23 }
+
+ Things you can put in the plan:
+
+ tests The number of tests in your script.
+ This means all ok() and skip() calls.
+ todo A reference to a list of tests which are allowed
+ to fail. See L</TODO TESTS>.
+ onfail A subroutine reference to be run at the end of
+ the test script should any of the tests fail.
+ See L</ONFAIL>.
+
+ You must call plan() once and only once.
+
+ =cut
+
sub plan {
croak "Test::plan(%args): odd number of arguments" if @_ & 1;
croak "Test::plan(): should not be called more than once" if $planned;
+
+ local($\, $,); # guard against -l and other things that screw with
+ # print
+
my $max=0;
for (my $x=0; $x < @_; $x+=2) {
my ($k,$v) = @_[$x,$x+1];
***************
*** 42,68 ****
print $TESTOUT "1..$max\n";
}
++$planned;
}
! sub to_value {
my ($v) = @_;
! (ref $v or '') eq 'CODE' ? $v->() : $v;
}
sub ok ($;$$) {
croak "ok: plan before you test!" if !$planned;
my ($pkg,$file,$line) = caller($TestLevel);
my $repetition = ++$history{"$file:$line"};
my $context = ("$file at line $line".
($repetition > 1 ? " fail \#$repetition" : ''));
my $ok=0;
! my $result = to_value(shift);
! my ($expected,$diag);
if (@_ == 0) {
$ok = $result;
} else {
! $expected = to_value(shift);
! my ($regex,$ignore);
if (!defined $expected) {
$ok = !defined $result;
} elsif (!defined $result) {
--- 128,237 ----
print $TESTOUT "1..$max\n";
}
++$planned;
+
+ # Never used.
+ return undef;
}
!
! =begin _private
!
! =item B<_to_value>
!
! my $value = _to_value($input);
!
! Converts an ok parameter to its value. Typically this just means
! running it if its a code reference. You should run all inputed
! values through this.
!
! =cut
!
! sub _to_value {
my ($v) = @_;
! return (ref $v or '') eq 'CODE' ? $v->() : $v;
}
+ =end _private
+
+ =item B<ok>
+
+ ok(1 + 1 == 2);
+ ok($have, $expect);
+ ok($have, $expect, $diagnostics);
+
+ This is the reason for Test's existance. Its the basic function that
+ handles printing "ok" or "not ok" along with the current test number.
+
+ In its most basic usage, it simply takes an expression. If its true,
+ the test passes, if false, the test fails. Simp.
+
+ ok( 1 + 1 == 2 ); # ok if 1 + 1 == 2
+ ok( $foo =~ /bar/ ); # ok if $foo contains 'bar'
+ ok( baz($x + $y) eq 'Armondo' ); # ok if baz($x + $y) returns
+ # 'Armondo'
+ ok( @a == @b ); # ok if @a and @b are the same length
+
+ The expression is evaluated in scalar context. So the following will
+ work:
+
+ ok( @stuff ); # ok if @stuff has any elements
+ ok( !grep !defined $_, @stuff ); # ok if everything in @stuff is
+ # defined.
+
+ A special case is if the expression is a subroutine reference. In
+ that case, it is executed and its value (true or false) determines if
+ the test passes or fails.
+
+ In its two argument form it compares the two values to see if they
+ equal (with C<eq>).
+
+ ok( "this", "that" ); # not ok, 'this' ne 'that'
+
+ If either is a subroutine reference, that is run and used as a
+ comparison.
+
+ Should $expect either be a regex reference (ie. qr//) or a string that
+ looks like a regex (ie. '/foo/') ok() will perform a pattern match
+ against it rather than using eq.
+
+ ok( 'JaffO', '/Jaff/' ); # ok, 'JaffO' =~ /Jaff/
+ ok( 'JaffO', qr/Jaff/ ); # ok, 'JaffO' =~ qr/Jaff/;
+ ok( 'JaffO', '/(?i)jaff/ ); # ok, 'JaffO' =~ /jaff/i;
+
+ Finally, an optional set of $diagnostics will be printed should the
+ test fail. This should usually be some useful information about the
+ test pertaining to why it failed or perhaps a description of the test.
+ Or both.
+
+ ok( grep($_ eq 'something unique', @stuff), 1,
+ "Something that should be unique isn't!\n".
+ '@stuff = '.join ', ', @stuff
+ );
+
+ Unfortunately, a diagnostic cannot be used with the single argument
+ style of ok().
+
+ All these special cases can cause some problems. See L</BUGS and CAVEATS>.
+
+ =cut
+
sub ok ($;$$) {
croak "ok: plan before you test!" if !$planned;
+
+ local($\,$,); # guard against -l and other things that screw with
+ # print
+
my ($pkg,$file,$line) = caller($TestLevel);
my $repetition = ++$history{"$file:$line"};
my $context = ("$file at line $line".
($repetition > 1 ? " fail \#$repetition" : ''));
my $ok=0;
! my $result = _to_value(shift);
! my ($expected,$diag,$isregex,$regex);
if (@_ == 0) {
$ok = $result;
} else {
! $expected = _to_value(shift);
if (!defined $expected) {
$ok = !defined $result;
} elsif (!defined $result) {
***************
*** 69,76 ****
$ok = 0;
} elsif ((ref($expected)||'') eq 'Regexp') {
$ok = $result =~ /$expected/;
} elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or
! ($ignore, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) {
$ok = $result =~ /$regex/;
} else {
$ok = $result eq $expected;
--- 238,246 ----
$ok = 0;
} elsif ((ref($expected)||'') eq 'Regexp') {
$ok = $result =~ /$expected/;
+ $regex = $expected;
} elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or
! (undef, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) {
$ok = $result =~ /$regex/;
} else {
$ok = $result eq $expected;
***************
*** 81,97 ****
$context .= ' TODO?!' if $todo;
print $TESTOUT "ok $ntest # ($context)\n";
} else {
! # Issuing two separate print()s causes severe trouble with
! # Test::Harness on VMS. The "not "'s for failed tests occur
! # on a separate line and would not get counted as failures.
! #print $TESTOUT "not " if !$ok;
! #print $TESTOUT "ok $ntest\n";
! # Replace with one of a pair of single print()'s as a workaround:
! if (!$ok) {
! print $TESTOUT "not ok $ntest\n";
}
! else {
! print $TESTOUT "ok $ntest\n";
}
if (!$ok) {
--- 251,262 ----
$context .= ' TODO?!' if $todo;
print $TESTOUT "ok $ntest # ($context)\n";
} else {
! # Issuing two seperate prints() causes problems on VMS.
! if (!$ok) {
! print $TESTOUT "not ok $ntest\n";
}
! else {
! print $TESTOUT "ok $ntest\n";
}
if (!$ok) {
***************
*** 98,104 ****
my $detail = { 'repetition' => $repetition, 'package' => $pkg,
'result' => $result, 'todo' => $todo };
$$detail{expected} = $expected if defined $expected;
! $diag = $$detail{diagnostic} = to_value(shift) if @_;
$context .= ' *TODO*' if $todo;
if (!defined $expected) {
if (!$diag) {
--- 263,274 ----
my $detail = { 'repetition' => $repetition, 'package' => $pkg,
'result' => $result, 'todo' => $todo };
$$detail{expected} = $expected if defined $expected;
!
! # Get the user's diagnostic, protecting against multi-line
! # diagnostics.
! $diag = $$detail{diagnostic} = _to_value(shift) if @_;
! $diag =~ s/\n/\n#/g if defined $diag;
!
$context .= ' *TODO*' if $todo;
if (!defined $expected) {
if (!$diag) {
***************
*** 111,119 ****
print $TESTOUT "# $prefix got: ".
(defined $result? "'$result'":'<UNDEF>')." ($context)\n";
$prefix = ' ' x (length($prefix) - 5);
! if ((ref($expected)||'') eq 'Regexp') {
! $expected = 'qr/'.$expected.'/'
! } else {
$expected = "'$expected'";
}
if (!$diag) {
--- 281,290 ----
print $TESTOUT "# $prefix got: ".
(defined $result? "'$result'":'<UNDEF>')." ($context)\n";
$prefix = ' ' x (length($prefix) - 5);
! if (defined $regex) {
! $expected = 'qr{'.$regex.'}';
! }
! else {
$expected = "'$expected'";
}
if (!$diag) {
***************
*** 129,147 ****
$ok;
}
! sub skip ($$;$$) {
! my $whyskip = to_value(shift);
! if ($whyskip) {
! $whyskip = 'skip' if $whyskip =~ m/^\d+$/;
! print $TESTOUT "ok $ntest # $whyskip\n";
! ++ $ntest;
! 1;
} else {
local($TestLevel) = $TestLevel+1; #ignore this stack frame
! &ok;
}
}
END {
$ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL;
}
--- 300,340 ----
$ok;
}
! sub skip ($;$$$) {
! local($\, $,); # guard against -l and other things that screw with
! # print
!
! my $whyskip = _to_value(shift);
! if (!@_ or $whyskip) {
! $whyskip = '' if $whyskip =~ m/^\d+$/;
! $whyskip =~ s/^[Ss]kip(?:\s+|$)//; # backwards compatibility, old
! # versions required the reason
! # to start with 'skip'
! # We print in one shot for VMSy reasons.
! my $ok = "ok $ntest # skip";
! $ok .= " $whyskip" if length $whyskip;
! $ok .= "\n";
! print $TESTOUT $ok;
! ++ $ntest;
! return 1;
} else {
+ # backwards compatiblity (I think). skip() used to be
+ # called like ok(), which is weird. I haven't decided what to do with
+ # this yet.
+ # warn <<WARN if $^W;
+ #This looks like a skip() using the very old interface. Please upgrade to
+ #the documented interface as this has been deprecated.
+ #WARN
+
local($TestLevel) = $TestLevel+1; #ignore this stack frame
! return &ok(@_);
}
}
+ =back
+
+ =cut
+
END {
$ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL;
}
***************
*** 149,196 ****
1;
__END__
- =head1 NAME
-
- Test - provides a simple framework for writing test scripts
-
- =head1 SYNOPSIS
-
- use strict;
- use Test;
-
- # use a BEGIN block so we print our plan before MyModule is loaded
- BEGIN { plan tests => 14, todo => [3,4] }
-
- # load your module...
- use MyModule;
-
- ok(0); # failure
- ok(1); # success
-
- ok(0); # ok, expected failure (see todo list, above)
- ok(1); # surprise success!
-
- ok(0,1); # failure: '0' ne '1'
- ok('broke','fixed'); # failure: 'broke' ne 'fixed'
- ok('fixed','fixed'); # success: 'fixed' eq 'fixed'
- ok('fixed',qr/x/); # success: 'fixed' =~ qr/x/
-
- ok(sub { 1+1 }, 2); # success: '2' eq '2'
- ok(sub { 1+1 }, 3); # failure: '2' ne '3'
- ok(0, int(rand(2)); # (just kidding :-)
-
- my @list = (0,0);
- ok @list, 3, "\@list=".join(',',@list); #extra diagnostics
- ok 'segmentation fault', '/(?i)success/'; #regex match
-
- skip($feature_is_missing, ...); #do platform specific test
-
- =head1 DESCRIPTION
-
- L<Test::Harness|Test::Harness> expects to see particular output when it
- executes tests. This module aims to make writing proper test scripts just
- a little bit easier (and less error prone :-).
-
=head1 TEST TYPES
=over 4
--- 342,347 ----
***************
*** 221,231 ****
=back
- =head1 RETURN VALUE
-
- Both C<ok> and C<skip> return true if their test succeeds and false
- otherwise in a scalar context.
-
=head1 ONFAIL
BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } }
--- 372,377 ----
***************
*** 248,260 ****
probably over-kill in most cases. (Your test code should be simpler
than the code it is testing, yes?)
=head1 SEE ALSO
! L<Test::Harness> and, perhaps, test coverage analysis tools.
=head1 AUTHOR
! Copyright (c) 1998-1999 Joshua Nathaniel Pritikin. All rights reserved.
This package is free software and is provided "as is" without express
or implied warranty. It may be used, redistributed and/or modified
--- 394,448 ----
probably over-kill in most cases. (Your test code should be simpler
than the code it is testing, yes?)
+
+ =head1 BUGS and CAVEATS
+
+ ok()'s special handling of subroutine references is an unfortunate
+ "feature" that can't be removed due to compatibility.
+
+ ok()'s use of string eq can sometimes cause odd problems when comparing
+ numbers, especially if you're casting a string to a number:
+
+ $foo = "1.0";
+ ok( $foo, 1 ); # not ok, "1.0" ne 1
+
+ Your best bet is to use the single argument form:
+
+ ok( $foo == 1 ); # ok "1.0" == 1
+
+ ok()'s special handing of strings which look like they might be
+ regexes can also cause unexpected behavior. An innocent:
+
+ ok( $fileglob, '/path/to/some/*stuff/' );
+
+ will fail since Test.pm considers the second argument to a regex.
+ Again, best bet is to use the single argument form:
+
+ ok( $fileglob eq '/path/to/some/*stuff/' );
+
+
+ =head1 TODO
+
+ Add todo().
+
+ Allow named tests.
+
+ Implement noplan().
+
+
=head1 SEE ALSO
! L<Test::Simple>, L<Test::More>, L<Test::Harness>, L<Devel::Cover>
+ L<Test::Unit> is an interesting alternative testing library.
+
+
=head1 AUTHOR
! Copyright (c) 1998-2000 Joshua Nathaniel Pritikin. All rights reserved.
! Copyright (c) 2001 Michael G Schwern.
!
! Current maintainer, Michael G Schwern <schwern@pobox.com>
This package is free software and is provided "as is" without express
or implied warranty. It may be used, redistributed and/or modified
diff -c 'perl-5.7.1/lib/Test/Harness.pm' 'perl-5.7.2/lib/Test/Harness.pm'
Index: ./lib/Test/Harness.pm
*** ./lib/Test/Harness.pm Fri Mar 16 04:54:50 2001
--- ./lib/Test/Harness.pm Mon Jul 9 17:10:43 2001
***************
*** 1,16 ****
# -*- Mode: cperl; cperl-indent-level: 4 -*-
package Test::Harness;
! use 5.005_64;
use Exporter;
use Benchmark;
use Config;
use strict;
! our($VERSION, $Verbose, $Switches, $Have_Devel_Corestack, $Curtest,
! $Columns, $verbose, $switches,
! @ISA, @EXPORT, @EXPORT_OK
! );
# Backwards compatibility for exportable variable names.
*verbose = \$Verbose;
--- 1,18 ----
# -*- Mode: cperl; cperl-indent-level: 4 -*-
+ # $Id: Harness.pm,v 1.11 2001/05/23 18:24:41 schwern Exp $
+
package Test::Harness;
! require 5.004;
use Exporter;
use Benchmark;
use Config;
use strict;
! use vars qw($VERSION $Verbose $Switches $Have_Devel_Corestack $Curtest
! $Columns $verbose $switches
! @ISA @EXPORT @EXPORT_OK
! );
# Backwards compatibility for exportable variable names.
*verbose = \$Verbose;
***************
*** 18,24 ****
$Have_Devel_Corestack = 0;
! $VERSION = "1.1702";
$ENV{HARNESS_ACTIVE} = 1;
--- 20,26 ----
$Have_Devel_Corestack = 0;
! $VERSION = "1.21";
$ENV{HARNESS_ACTIVE} = 1;
***************
*** 35,55 ****
$Verbose = 0;
$Switches = "-w";
$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
! sub globdir { opendir DIRH, shift; my @f = readdir DIRH; closedir DIRH; @f }
sub runtests {
my(@tests) = @_;
! my($tot, $failedtests) = _runtests(@tests);
_show_results($tot, $failedtests);
! return ($tot->{bad} == 0 && $tot->{max}) ;
}
! sub _runtests {
my(@tests) = @_;
local($|) = 1;
my(%failedtests);
--- 37,362 ----
$Verbose = 0;
$Switches = "-w";
$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
+ $Columns--; # Some shells have trouble with a full line of text.
! =head1 NAME
+ Test::Harness - run perl standard test scripts with statistics
+
+ =head1 SYNOPSIS
+
+ use Test::Harness;
+
+ runtests(@test_files);
+
+ =head1 DESCRIPTION
+
+ B<STOP!> If all you want to do is write a test script, consider using
+ Test::Simple. Otherwise, read on.
+
+ (By using the Test module, you can write test scripts without
+ knowing the exact output this module expects. However, if you need to
+ know the specifics, read on!)
+
+ Perl test scripts print to standard output C<"ok N"> for each single
+ test, where C<N> is an increasing sequence of integers. The first line
+ output by a standard test script is C<"1..M"> with C<M> being the
+ number of tests that should be run within the test
+ script. Test::Harness::runtests(@tests) runs all the testscripts
+ named as arguments and checks standard output for the expected
+ C<"ok N"> strings.
+
+ After all tests have been performed, runtests() prints some
+ performance statistics that are computed by the Benchmark module.
+
+ =head2 The test script output
+
+ The following explains how Test::Harness interprets the output of your
+ test program.
+
+ =over 4
+
+ =item B<'1..M'>
+
+ This header tells how many tests there will be. It should be the
+ first line output by your test program (but its okay if its preceded
+ by comments).
+
+ In certain instanced, you may not know how many tests you will
+ ultimately be running. In this case, it is permitted (but not
+ encouraged) for the 1..M header to appear as the B<last> line output
+ by your test (again, it can be followed by further comments). But we
+ strongly encourage you to put it first.
+
+ Under B<no> circumstances should 1..M appear in the middle of your
+ output or more than once.
+
+
+ =item B<'ok', 'not ok'. Ok?>
+
+ Any output from the testscript to standard error is ignored and
+ bypassed, thus will be seen by the user. Lines written to standard
+ output containing C</^(not\s+)?ok\b/> are interpreted as feedback for
+ runtests(). All other lines are discarded.
+
+ C</^not ok/> indicates a failed test. C</^ok/> is a successful test.
+
+
+ =item B<test numbers>
+
+ Perl normally expects the 'ok' or 'not ok' to be followed by a test
+ number. It is tolerated if the test numbers after 'ok' are
+ omitted. In this case Test::Harness maintains temporarily its own
+ counter until the script supplies test numbers again. So the following
+ test script
+
+ print <<END;
+ 1..6
+ not ok
+ ok
+ not ok
+ ok
+ ok
+ END
+
+ will generate
+
+ FAILED tests 1, 3, 6
+ Failed 3/6 tests, 50.00% okay
+
+
+ =item B<$Test::Harness::verbose>
+
+ The global variable $Test::Harness::verbose is exportable and can be
+ used to let runtests() display the standard output of the script
+ without altering the behavior otherwise.
+
+ =item B<$Test::Harness::switches>
+
+ The global variable $Test::Harness::switches is exportable and can be
+ used to set perl command line options used for running the test
+ script(s). The default value is C<-w>.
+
+ =item B<Skipping tests>
+
+ If the standard output line contains the substring C< # Skip> (with
+ variations in spacing and case) after C<ok> or C<ok NUMBER>, it is
+ counted as a skipped test. If the whole testscript succeeds, the
+ count of skipped tests is included in the generated output.
+ C<Test::Harness> reports the text after C< # Skip\S*\s+> as a reason
+ for skipping.
+
+ ok 23 # skip Insufficient flogiston pressure.
+
+ Similarly, one can include a similar explanation in a C<1..0> line
+ emitted if the test script is skipped completely:
+
+ 1..0 # Skipped: no leverage found
+
+ =item B<Todo tests>
+
+ If the standard output line contains the substring C< # TODO> after
+ C<not ok> or C<not ok NUMBER>, it is counted as a todo test. The text
+ afterwards is the thing that has to be done before this test will
+ succeed.
+
+ not ok 13 # TODO harness the power of the atom
+
+ These tests represent a feature to be implemented or a bug to be fixed
+ and act as something of an executable "thing to do" list. They are
+ B<not> expected to succeed. Should a todo test begin succeeding,
+ Test::Harness will report it as a bonus. This indicates that whatever
+ you were supposed to do has been done and you should promote this to a
+ normal test.
+
+ =item B<Bail out!>
+
+ As an emergency measure, a test script can decide that further tests
+ are useless (e.g. missing dependencies) and testing should stop
+ immediately. In that case the test script prints the magic words
+
+ Bail out!
+
+ to standard output. Any message after these words will be displayed by
+ C<Test::Harness> as the reason why testing is stopped.
+
+ =item B<Comments>
+
+ Additional comments may be put into the testing output on their own
+ lines. Comment lines should begin with a '#', Test::Harness will
+ ignore them.
+
+ ok 1
+ # Life is good, the sun is shining, RAM is cheap.
+ not ok 2
+ # got 'Bush' expected 'Gore'
+
+ =item B<Anything else>
+
+ Any other output Test::Harness sees it will silently ignore B<BUT WE
+ PLAN TO CHANGE THIS!> If you wish to place additional output in your
+ test script, please use a comment.
+
+ =back
+
+
+ =head2 Failure
+
+ It will happen, your tests will fail. After you mop up your ego, you
+ can begin examining the summary report:
+
+ t/base..............ok
+ t/nonumbers.........ok
+ t/ok................ok
+ t/test-harness......ok
+ t/waterloo..........dubious
+ Test returned status 3 (wstat 768, 0x300)
+ DIED. FAILED tests 1, 3, 5, 7, 9, 11, 13, 15, 17, 19
+ Failed 10/20 tests, 50.00% okay
+ Failed Test Stat Wstat Total Fail Failed List of Failed
+ -----------------------------------------------------------------------
+ t/waterloo.t 3 768 20 10 50.00% 1 3 5 7 9 11 13 15 17 19
+ Failed 1/5 test scripts, 80.00% okay. 10/44 subtests failed, 77.27% okay.
+
+ Everything passed but t/waterloo.t. It failed 10 of 20 tests and
+ exited with non-zero status indicating something dubious happened.
+
+ The columns in the summary report mean:
+
+ =over 4
+
+ =item B<Failed Test>
+
+ The test file which failed.
+
+ =item B<Stat>
+
+ If the test exited with non-zero, this is its exit status.
+
+ =item B<Wstat>
+
+ The wait status of the test I<umm, I need a better explanation here>.
+
+ =item B<Total>
+
+ Total number of tests expected to run.
+
+ =item B<Fail>
+
+ Number which failed, either from "not ok" or because they never ran.
+
+ =item B<Failed>
+
+ Percentage of the total tests which failed.
+
+ =item B<List of Failed>
+
+ A list of the tests which failed. Successive failures may be
+ abbreviated (ie. 15-20 to indicate that tests 15, 16, 17, 18, 19 and
+ 20 failed).
+
+ =back
+
+
+ =head2 Functions
+
+ Test::Harness currently only has one function, here it is.
+
+ =over 4
+
+ =item B<runtests>
+
+ my $allok = runtests(@test_files);
+
+ This runs all the given @test_files and divines whether they passed
+ or failed based on their output to STDOUT (details above). It prints
+ out each individual test which failed along with a summary report and
+ a how long it all took.
+
+ It returns true if everything was ok, false otherwise.
+
+ =for _private
+ This is just _run_all_tests() plus _show_results()
+
+ =cut
+
sub runtests {
my(@tests) = @_;
! local ($\, $,);
!
! my($tot, $failedtests) = _run_all_tests(@tests);
_show_results($tot, $failedtests);
! my $ok = ($tot->{bad} == 0 && $tot->{max});
!
! die q{Assert '$ok xor keys %$failedtests' failed!}
! unless $ok xor keys %$failedtests;
!
! return $ok;
}
+ =begin _private
! =item B<_globdir>
!
! my @files = _globdir $dir;
!
! Returns all the files in a directory. This is shorthand for backwards
! compatibility on systems where glob() doesn't work right.
!
! =cut
!
! sub _globdir {
! opendir DIRH, shift;
! my @f = readdir DIRH;
! closedir DIRH;
!
! return @f;
! }
!
! =item B<_run_all_tests>
!
! my($total, $failed) = _run_all_tests(@test_files);
!
! Runs all the given @test_files (as runtests()) but does it quietly (no
! report). $total is a hash ref summary of all the tests run. Its keys
! and values are this:
!
! bonus Number of individual todo tests unexpectedly passed
! max Number of individual tests ran
! ok Number of individual tests passed
! sub_skipped Number of individual tests skipped
!
! files Number of test files ran
! good Number of test files passed
! bad Number of test files failed
! tests Number of test files originally given
! skipped Number of test files skipped
!
! If $total->{bad} == 0 and $total->{max} > 0, you've got a successful
! test.
!
! $failed is a hash ref of all the test scripts which failed. Each key
! is the name of a test script, each value is another hash representing
! how that script failed. Its keys are these:
!
! name Name of the test which failed
! estat Script's exit value
! wstat Script's wait status
! max Number of individual tests
! failed Number which failed
! percent Percentage of tests which failed
! canon List of tests which failed (as string).
!
! Needless to say, $failed should be empty if everything passed.
!
! B<NOTE> Currently this function is still noisy. I'm working on it.
!
! =cut
!
! sub _run_all_tests {
my(@tests) = @_;
local($|) = 1;
my(%failedtests);
***************
*** 85,118 ****
local($ENV{'PERL5LIB'}) = $new5lib;
! my @dir_files = globdir $Files_In_Dir if defined $Files_In_Dir;
my $t_start = new Benchmark;
! foreach my $test (@tests) {
! my $te = $test;
! chop($te); # XXX chomp?
! if ($^O eq 'VMS') { $te =~ s/^.*\.t\./[.t./s; }
! my $blank = (' ' x 77);
! my $leader = "$te" . '.' x (20 - length($te));
! my $ml = "";
! $ml = "\r$blank\r$leader"
! if -t STDOUT and not $ENV{HARNESS_NOTTY} and not $Verbose;
! print $leader;
- my $s = _set_switches($test);
-
- my $cmd = ($ENV{'HARNESS_COMPILE_TEST'})
- ? "./perl -I../lib ../utils/perlcc $test "
- . "-r 2>> ./compilelog |"
- : "$^X $s $test|";
- $cmd = "MCR $cmd" if $^O eq 'VMS';
- open(my $fh, $cmd) or print "can't run $test. $!\n";
-
# state of the current test.
my %test = (
ok => 0,
! next => 0,
max => 0,
failed => [],
todo => {},
--- 392,421 ----
local($ENV{'PERL5LIB'}) = $new5lib;
! my @dir_files = _globdir $Files_In_Dir if defined $Files_In_Dir;
my $t_start = new Benchmark;
! my $maxlen = 0;
! my $maxsuflen = 0;
! foreach (@tests) { # The same code in t/TEST
! my $suf = /\.(\w+)$/ ? $1 : '';
! my $len = length;
! my $suflen = length $suf;
! $maxlen = $len if $len > $maxlen;
! $maxsuflen = $suflen if $suflen > $maxsuflen;
! }
! # + 3 : we want three dots between the test name and the "ok"
! my $width = $maxlen + 3 - $maxsuflen;
! foreach my $tfile (@tests) {
! my($leader, $ml) = _mk_leader($tfile, $width);
! print $leader;
! my $fh = _open_test($tfile);
# state of the current test.
my %test = (
ok => 0,
! 'next' => 0,
max => 0,
failed => [],
todo => {},
***************
*** 140,151 ****
my($estatus, $wstatus) = _close_fh($fh);
if ($wstatus) {
! $failedtests{$test} = _dubious_return(\%test, \%tot,
$estatus, $wstatus);
! $failedtests{$test}{name} = $test;
}
! elsif ($test{ok} == $test{max} && $test{next} == $test{max}+1) {
if ($test{max} and $test{skipped} + $test{bonus}) {
my @msg;
push(@msg, "$test{skipped}/$test{max} skipped: $test{skip_reason}")
--- 443,456 ----
my($estatus, $wstatus) = _close_fh($fh);
+ my $allok = $test{ok} == $test{max} && $test{'next'} == $test{max}+1;
+
if ($wstatus) {
! $failedtests{$tfile} = _dubious_return(\%test, \%tot,
$estatus, $wstatus);
! $failedtests{$tfile}{name} = $tfile;
}
! elsif ($allok) {
if ($test{max} and $test{skipped} + $test{bonus}) {
my @msg;
push(@msg, "$test{skipped}/$test{max} skipped: $test{skip_reason}")
***************
*** 163,213 ****
$tot{skipped}++;
}
$tot{good}++;
- } elsif ($test{max}) {
- if ($test{next} <= $test{max}) {
- push @{$test{failed}}, $test{next}..$test{max};
- }
- if (@{$test{failed}}) {
- my ($txt, $canon) = canonfailed($test{max},$test{skipped},
- @{$test{failed}});
- print "$test{ml}$txt";
- $failedtests{$test} = { canon => $canon,
- max => $test{max},
- failed => scalar @{$test{failed}},
- name => $test,
- percent => 100*(scalar @{$test{failed}})/$test{max},
- estat => '',
- wstat => '',
- };
- } else {
- print "Don't know which tests failed: got $test{ok} ok, ".
- "expected $test{max}\n";
- $failedtests{$test} = { canon => '??',
- max => $test{max},
- failed => '??',
- name => $test,
- percent => undef,
- estat => '',
- wstat => '',
- };
- }
- $tot{bad}++;
- } elsif ($test{next} == 0) {
- print "FAILED before any test output arrived\n";
- $tot{bad}++;
- $failedtests{$test} = { canon => '??',
- max => '??',
- failed => '??',
- name => $test,
- percent => undef,
- estat => '',
- wstat => '',
- };
}
$tot{sub_skipped} += $test{skipped};
if (defined $Files_In_Dir) {
! my @new_dir_files = globdir $Files_In_Dir;
if (@new_dir_files != @dir_files) {
my %f;
@f{@new_dir_files} = (1) x @new_dir_files;
--- 468,522 ----
$tot{skipped}++;
}
$tot{good}++;
}
+ else {
+ if ($test{max}) {
+ if ($test{'next'} <= $test{max}) {
+ push @{$test{failed}}, $test{'next'}..$test{max};
+ }
+ if (@{$test{failed}}) {
+ my ($txt, $canon) = canonfailed($test{max},$test{skipped},
+ @{$test{failed}});
+ print "$test{ml}$txt";
+ $failedtests{$tfile} = { canon => $canon,
+ max => $test{max},
+ failed => scalar @{$test{failed}},
+ name => $tfile,
+ percent => 100*(scalar @{$test{failed}})/$test{max},
+ estat => '',
+ wstat => '',
+ };
+ } else {
+ print "Don't know which tests failed: got $test{ok} ok, ".
+ "expected $test{max}\n";
+ $failedtests{$tfile} = { canon => '??',
+ max => $test{max},
+ failed => '??',
+ name => $tfile,
+ percent => undef,
+ estat => '',
+ wstat => '',
+ };
+ }
+ $tot{bad}++;
+ } elsif ($test{'next'} == 0) {
+ print "FAILED before any test output arrived\n";
+ $tot{bad}++;
+ $failedtests{$tfile} = { canon => '??',
+ max => '??',
+ failed => '??',
+ name => $tfile,
+ percent => undef,
+ estat => '',
+ wstat => '',
+ };
+ }
+ }
+
$tot{sub_skipped} += $test{skipped};
if (defined $Files_In_Dir) {
! my @new_dir_files = _globdir $Files_In_Dir;
if (@new_dir_files != @dir_files) {
my %f;
@f{@new_dir_files} = (1) x @new_dir_files;
***************
*** 231,237 ****
--- 540,573 ----
return(\%tot, \%failedtests);
}
+ =item B<_mk_leader>
+ my($leader, $ml) = _mk_leader($test_file, $width);
+
+ Generates the 't/foo........' $leader for the given $test_file as well
+ as a similar version which will overwrite the current line (by use of
+ \r and such). $ml may be empty if Test::Harness doesn't think you're
+ on TTY. The width is the width of the "yada/blah..." string.
+
+ =cut
+
+ sub _mk_leader {
+ my ($te, $width) = @_;
+
+ $te =~ s/\.\w+$/./;
+
+ if ($^O eq 'VMS') { $te =~ s/^.*\.t\./\[.t./s; }
+ my $blank = (' ' x 77);
+ my $leader = "$te" . '.' x ($width - length($te));
+ my $ml = "";
+
+ $ml = "\r$blank\r$leader"
+ if -t STDOUT and not $ENV{HARNESS_NOTTY} and not $Verbose;
+
+ return($leader, $ml);
+ }
+
+
sub _show_results {
my($tot, $failedtests) = @_;
***************
*** 239,245 ****
my $bonusmsg = _bonusmsg($tot);
if ($tot->{bad} == 0 && $tot->{max}) {
! print "All tests successful$bonusmsg.\n";
} elsif ($tot->{tests}==0){
die "FAILED--no tests were run for some reason.\n";
} elsif ($tot->{max} == 0) {
--- 575,582 ----
my $bonusmsg = _bonusmsg($tot);
if ($tot->{bad} == 0 && $tot->{max}) {
! # print "All tests successful$bonusmsg.\n";
! print "All tests successful.\n";
} elsif ($tot->{tests}==0){
die "FAILED--no tests were run for some reason.\n";
} elsif ($tot->{max} == 0) {
***************
*** 292,298 ****
# 1..10
# 1..0 # skip Why? Because I said so!
elsif ($line =~ /^1\.\.([0-9]+)
! (\s*\#\s*[Ss]kip\S*(?>\s+) (.+))?
/x
)
{
--- 629,635 ----
# 1..10
# 1..0 # skip Why? Because I said so!
elsif ($line =~ /^1\.\.([0-9]+)
! (\s*\#\s*[Ss]kip\S*\s* (.+))?
/x
)
{
***************
*** 299,305 ****
$test->{max} = $1;
$tot->{max} += $test->{max};
$tot->{files}++;
! $test->{next} = 1 unless $test->{next};
$test->{skip_reason} = $3 if not $test->{max} and defined $3;
$is_header = 1;
--- 636,642 ----
$test->{max} = $1;
$tot->{max} += $test->{max};
$tot->{files}++;
! $test->{'next'} = 1 unless $test->{'next'};
$test->{skip_reason} = $3 if not $test->{max} and defined $3;
$is_header = 1;
***************
*** 312,322 ****
}
sub _parse_test_line {
my($line, $test, $tot) = @_;
if ($line =~ /^(not\s+)?ok\b/i) {
! my $this = $test->{next} || 1;
# "not ok 23"
if ($line =~ /^(not )?ok\s*(\d*)(\s*#.*)?/) {
my($not, $tnum, $extra) = ($1, $2, $3);
--- 649,687 ----
}
+ sub _open_test {
+ my($test) = shift;
+
+ my $s = _set_switches($test);
+
+ # XXX This is WAY too core specific!
+ my $cmd = ($ENV{'HARNESS_COMPILE_TEST'})
+ ? "./perl -I../lib ../utils/perlcc $test "
+ . "-r 2>> ./compilelog |"
+ : "$^X $s $test|";
+ $cmd = "MCR $cmd" if $^O eq 'VMS';
+
+ if( open(PERL, $cmd) ) {
+ return \*PERL;
+ }
+ else {
+ print "can't run $test. $!\n";
+ return;
+ }
+ }
+
+ sub _run_one_test {
+ my($test) = @_;
+
+
+ }
+
+
sub _parse_test_line {
my($line, $test, $tot) = @_;
if ($line =~ /^(not\s+)?ok\b/i) {
! my $this = $test->{'next'} || 1;
# "not ok 23"
if ($line =~ /^(not )?ok\s*(\d*)(\s*#.*)?/) {
my($not, $tnum, $extra) = ($1, $2, $3);
***************
*** 349,354 ****
--- 714,721 ----
$tot->{ok}++;
$test->{skipped}++ if $isskip;
+ $reason = '[no reason given]'
+ if $isskip and not defined $reason;
if (defined $reason and defined $test->{skip_reason}) {
# print "was: '$skip_reason' new '$reason'\n";
$test->{skip_reason} = 'various reasons'
***************
*** 373,390 ****
next;
}
! if ($this > $test->{next}) {
# print "Test output counter mismatch [test $this]\n";
# no need to warn probably
! push @{$test->{failed}}, $test->{next}..$this-1;
}
! elsif ($this < $test->{next}) {
#we have seen more "ok" lines than the number suggests
print "Confused test output: test $this answered after ".
! "test ", $test->{next}-1, "\n";
! $test->{next} = $this;
}
! $test->{next} = $this + 1;
}
elsif ($line =~ /^Bail out!\s*(.*)/i) { # magic words
--- 740,757 ----
next;
}
! if ($this > $test->{'next'}) {
# print "Test output counter mismatch [test $this]\n";
# no need to warn probably
! push @{$test->{failed}}, $test->{'next'}..$this-1;
}
! elsif ($this < $test->{'next'}) {
#we have seen more "ok" lines than the number suggests
print "Confused test output: test $this answered after ".
! "test ", $test->{'next'}-1, "\n";
! $test->{'next'} = $this;
}
! $test->{'next'} = $this + 1;
}
elsif ($line =~ /^Bail out!\s*(.*)/i) { # magic words
***************
*** 440,447 ****
sub _set_switches {
my($test) = shift;
! open(my $fh, $test) or print "can't open $test. $!\n";
! my $first = <$fh>;
my $s = $Switches;
$s .= " $ENV{'HARNESS_PERL_SWITCHES'}"
if exists $ENV{'HARNESS_PERL_SWITCHES'};
--- 807,815 ----
sub _set_switches {
my($test) = shift;
! local *TEST;
! open(TEST, $test) or print "can't open $test. $!\n";
! my $first = <TEST>;
my $s = $Switches;
$s .= " $ENV{'HARNESS_PERL_SWITCHES'}"
if exists $ENV{'HARNESS_PERL_SWITCHES'};
***************
*** 448,454 ****
$s .= join " ", q[ "-T"], map {qq["-I$_"]} @INC
if $first =~ /^#!.*\bperl.*-\w*T/;
! close($fh) or print "can't close $test. $!\n";
return $s;
}
--- 816,822 ----
$s .= join " ", q[ "-T"], map {qq["-I$_"]} @INC
if $first =~ /^#!.*\bperl.*-\w*T/;
! close(TEST) or print "can't close $test. $!\n";
return $s;
}
***************
*** 475,487 ****
$tot->{bad}++;
if ($test->{max}) {
! if ($test->{next} == $test->{max} + 1 and not @{$test->{failed}}) {
print "\tafter all the subtests completed successfully\n";
$percent = 0;
$failed = 0; # But we do not set $canon!
}
else {
! push @{$test->{failed}}, $test->{next}..$test->{max};
$failed = @{$test->{failed}};
(my $txt, $canon) = canonfailed($test->{max},$test->{skipped},@{$test->{failed}});
$percent = 100*(scalar @{$test->{failed}})/$test->{max};
--- 843,855 ----
$tot->{bad}++;
if ($test->{max}) {
! if ($test->{'next'} == $test->{max} + 1 and not @{$test->{failed}}) {
print "\tafter all the subtests completed successfully\n";
$percent = 0;
$failed = 0; # But we do not set $canon!
}
else {
! push @{$test->{failed}}, $test->{'next'}..$test->{max};
$failed = @{$test->{failed}};
(my $txt, $canon) = canonfailed($test->{max},$test->{skipped},@{$test->{failed}});
$percent = 100*(scalar @{$test->{failed}})/$test->{max};
***************
*** 507,513 ****
my($failedtests) = @_;
my $failed_str = "Failed Test";
! my $middle_str = " Status Wstat Total Fail Failed ";
my $list_str = "List of Failed";
# Figure out our longest name string for formatting purposes.
--- 875,881 ----
my($failedtests) = @_;
my $failed_str = "Failed Test";
! my $middle_str = " Stat Wstat Total Fail Failed ";
my $list_str = "List of Failed";
# Figure out our longest name string for formatting purposes.
***************
*** 536,542 ****
my $fmt = "format STDOUT =\n"
. "@" . "<" x ($max_namelen - 1)
! . " @>> @>>>> @>>>> @>>> ^##.##% "
. "^" . "<" x ($list_len - 1) . "\n"
. '{ $Curtest->{name}, $Curtest->{estat},'
. ' $Curtest->{wstat}, $Curtest->{max},'
--- 904,910 ----
my $fmt = "format STDOUT =\n"
. "@" . "<" x ($max_namelen - 1)
! . " @>> @>>>> @>>>> @>>> ^##.##% "
. "^" . "<" x ($list_len - 1) . "\n"
. '{ $Curtest->{name}, $Curtest->{estat},'
. ' $Curtest->{wstat}, $Curtest->{max},'
***************
*** 556,573 ****
return($fmt_top, $fmt);
}
! my $tried_devel_corestack;
! sub corestatus {
! my($st) = @_;
! eval {require 'wait.ph'};
! my $ret = defined &WCOREDUMP ? WCOREDUMP($st) : $st & 0200;
! eval { require Devel::CoreStack; $Have_Devel_Corestack++ }
! unless $tried_devel_corestack++;
! $ret;
}
sub canonfailed ($@) {
--- 924,943 ----
return($fmt_top, $fmt);
}
+ {
+ my $tried_devel_corestack;
! sub corestatus {
! my($st) = @_;
! eval {require 'wait.ph'};
! my $ret = defined &WCOREDUMP ? WCOREDUMP($st) : $st & 0200;
! eval { require Devel::CoreStack; $Have_Devel_Corestack++ }
! unless $tried_devel_corestack++;
! $ret;
! }
}
sub canonfailed ($@) {
***************
*** 594,600 ****
}
local $" = ", ";
push @result, "FAILED tests @canon\n";
! $canon = "@canon";
} else {
push @result, "FAILED test $last\n";
$canon = $last;
--- 964,970 ----
}
local $" = ", ";
push @result, "FAILED tests @canon\n";
! $canon = join ' ', @canon;
} else {
push @result, "FAILED test $last\n";
$canon = $last;
***************
*** 613,772 ****
($txt, $canon);
}
! 1;
! __END__
! =head1 NAME
! Test::Harness - run perl standard test scripts with statistics
- =head1 SYNOPSIS
! use Test::Harness;
- runtests(@test_files);
- =head1 DESCRIPTION
-
- (By using the Test module, you can write test scripts without
- knowing the exact output this module expects. However, if you need to
- know the specifics, read on!)
-
- Perl test scripts print to standard output C<"ok N"> for each single
- test, where C<N> is an increasing sequence of integers. The first line
- output by a standard test script is C<"1..M"> with C<M> being the
- number of tests that should be run within the test
- script. Test::Harness::runtests(@tests) runs all the testscripts
- named as arguments and checks standard output for the expected
- C<"ok N"> strings.
-
- After all tests have been performed, runtests() prints some
- performance statistics that are computed by the Benchmark module.
-
- =head2 The test script output
-
- The following explains how Test::Harness interprets the output of your
- test program.
-
- =over 4
-
- =item B<'1..M'>
-
- This header tells how many tests there will be. It should be the
- first line output by your test program (but its okay if its preceded
- by comments).
-
- In certain instanced, you may not know how many tests you will
- ultimately be running. In this case, it is permitted (but not
- encouraged) for the 1..M header to appear as the B<last> line output
- by your test (again, it can be followed by further comments). But we
- strongly encourage you to put it first.
-
- Under B<no> circumstances should 1..M appear in the middle of your
- output or more than once.
-
-
- =item B<'ok', 'not ok'. Ok?>
-
- Any output from the testscript to standard error is ignored and
- bypassed, thus will be seen by the user. Lines written to standard
- output containing C</^(not\s+)?ok\b/> are interpreted as feedback for
- runtests(). All other lines are discarded.
-
- C</^not ok/> indicates a failed test. C</^ok/> is a successful test.
-
-
- =item B<test numbers>
-
- Perl normally expects the 'ok' or 'not ok' to be followed by a test
- number. It is tolerated if the test numbers after 'ok' are
- omitted. In this case Test::Harness maintains temporarily its own
- counter until the script supplies test numbers again. So the following
- test script
-
- print <<END;
- 1..6
- not ok
- ok
- not ok
- ok
- ok
- END
-
- will generate
-
- FAILED tests 1, 3, 6
- Failed 3/6 tests, 50.00% okay
-
-
- =item B<$Test::Harness::verbose>
-
- The global variable $Test::Harness::verbose is exportable and can be
- used to let runtests() display the standard output of the script
- without altering the behavior otherwise.
-
- =item B<$Test::Harness::switches>
-
- The global variable $Test::Harness::switches is exportable and can be
- used to set perl command line options used for running the test
- script(s). The default value is C<-w>.
-
- =item B<Skipping tests>
-
- If the standard output line contains the substring C< # Skip> (with
- variations in spacing and case) after C<ok> or C<ok NUMBER>, it is
- counted as a skipped test. If the whole testscript succeeds, the
- count of skipped tests is included in the generated output.
- C<Test::Harness> reports the text after C< # Skip\S*\s+> as a reason
- for skipping.
-
- ok 23 # skip Insufficient flogiston pressure.
-
- Similarly, one can include a similar explanation in a C<1..0> line
- emitted if the test script is skipped completely:
-
- 1..0 # Skipped: no leverage found
-
- =item B<Todo tests>
-
- If the standard output line contains the substring C< # TODO> after
- C<not ok> or C<not ok NUMBER>, it is counted as a todo test. The text
- afterwards is the thing that has to be done before this test will
- succeed.
-
- not ok 13 # TODO harness the power of the atom
-
- These tests represent a feature to be implemented or a bug to be fixed
- and act as something of an executable "thing to do" list. They are
- B<not> expected to succeed. Should a todo test begin succeeding,
- Test::Harness will report it as a bonus. This indicates that whatever
- you were supposed to do has been done and you should promote this to a
- normal test.
-
- =item B<Bail out!>
-
- As an emergency measure, a test script can decide that further tests
- are useless (e.g. missing dependencies) and testing should stop
- immediately. In that case the test script prints the magic words
-
- Bail out!
-
- to standard output. Any message after these words will be displayed by
- C<Test::Harness> as the reason why testing is stopped.
-
- =item B<Comments>
-
- Additional comments may be put into the testing output on their own
- lines. Comment lines should begin with a '#', Test::Harness will
- ignore them.
-
- ok 1
- # Life is good, the sun is shining, RAM is cheap.
- not ok 2
- # got 'Bush' expected 'Gore'
-
- =back
-
=head1 EXPORT
C<&runtests> is exported by Test::Harness per default.
--- 983,999 ----
($txt, $canon);
}
! =end _private
! =back
! =cut
! 1;
! __END__
=head1 EXPORT
C<&runtests> is exported by Test::Harness per default.
***************
*** 811,821 ****
=over 4
! =item C<HARNESS_IGNORE_EXITCODE>
Makes harness ignore the exit status of child processes when defined.
! =item C<HARNESS_NOTTY>
When set to a true value, forces it to behave as though STDOUT were
not a console. You may need to set this if you don't want harness to
--- 1038,1048 ----
=over 4
! =item C<HARNESS_IGNORE_EXITCODE>
Makes harness ignore the exit status of child processes when defined.
! =item C<HARNESS_NOTTY>
When set to a true value, forces it to behave as though STDOUT were
not a console. You may need to set this if you don't want harness to
***************
*** 823,835 ****
consoles may not handle carriage returns properly (which results in a
somewhat messy output).
! =item C<HARNESS_COMPILE_TEST>
When true it will make harness attempt to compile the test using
C<perlcc> before running it.
! =item C<HARNESS_FILELEAK_IN_DIR>
When set to the name of a directory, harness will check after each
test whether new files appeared in that directory, and report them as
--- 1050,1065 ----
consoles may not handle carriage returns properly (which results in a
somewhat messy output).
! =item C<HARNESS_COMPILE_TEST>
When true it will make harness attempt to compile the test using
C<perlcc> before running it.
! B<NOTE> This currently only works when sitting in the perl source
! directory!
+ =item C<HARNESS_FILELEAK_IN_DIR>
+
When set to the name of a directory, harness will check after each
test whether new files appeared in that directory, and report them as
***************
*** 839,851 ****
the moment runtests() was called. Putting absolute path into
C<HARNESS_FILELEAK_IN_DIR> may give more predicatable results.
! =item C<HARNESS_PERL_SWITCHES>
Its value will be prepended to the switches used to invoke perl on
! each test. For example, setting C<HARNESS_PERL_SWITCHES> to "-W" will
run all tests with all warnings enabled.
! =item C<HARNESS_COLUMNS>
This value will be used for the width of the terminal. If it is not
set then it will default to C<COLUMNS>. If this is not set, it will
--- 1069,1081 ----
the moment runtests() was called. Putting absolute path into
C<HARNESS_FILELEAK_IN_DIR> may give more predicatable results.
! =item C<HARNESS_PERL_SWITCHES>
Its value will be prepended to the switches used to invoke perl on
! each test. For example, setting C<HARNESS_PERL_SWITCHES> to C<-W> will
run all tests with all warnings enabled.
! =item C<HARNESS_COLUMNS>
This value will be used for the width of the terminal. If it is not
set then it will default to C<COLUMNS>. If this is not set, it will
***************
*** 852,858 ****
default to 80. Note that users of Bourne-sh based shells will need to
C<export COLUMNS> for this module to use that variable.
! =item C<HARNESS_ACTIVE>
Harness sets this before executing the individual tests. This allows
the tests to determine if they are being executed through the harness
--- 1082,1088 ----
default to 80. Note that users of Bourne-sh based shells will need to
C<export COLUMNS> for this module to use that variable.
! =item C<HARNESS_ACTIVE>
Harness sets this before executing the individual tests. This allows
the tests to determine if they are being executed through the harness
***************
*** 860,870 ****
=back
=head1 SEE ALSO
! L<Test> for writing test scripts, L<Benchmark> for the underlying
! timing routines and L<Devel::Coverage> for test coverage analysis.
=head1 AUTHORS
--- 1090,1116 ----
=back
+ =head1 EXAMPLE
+ Here's how Test::Harness tests itself
+
+ $ cd ~/src/devel/Test-Harness
+ $ perl -Mblib -e 'use Test::Harness qw(&runtests $verbose);
+ $verbose=0; runtests @ARGV;' t/*.t
+ Using /home/schwern/src/devel/Test-Harness/blib
+ t/base..............ok
+ t/nonumbers.........ok
+ t/ok................ok
+ t/test-harness......ok
+ All tests successful.
+ Files=4, Tests=24, 2 wallclock secs ( 0.61 cusr + 0.41 csys = 1.02 CPU)
+
=head1 SEE ALSO
! L<Test> and L<Test::Simple> for writing test scripts, L<Benchmark> for
! the underlying timing routines, L<Devel::CoreStack> to generate core
! dumps from failed tests and L<Devel::Cover> for test coverage
! analysis.
=head1 AUTHORS
***************
*** 871,881 ****
Either Tim Bunce or Andreas Koenig, we don't know. What we know for
sure is, that it was inspired by Larry Wall's TEST script that came
with perl distributions for ages. Numerous anonymous contributors
! exist.
! Current maintainers are Andreas Koenig <andreas.koenig@anima.de> and
! Michael G Schwern <schwern@pobox.com>
=head1 BUGS
Test::Harness uses $^X to determine the perl binary to run the tests
--- 1117,1151 ----
Either Tim Bunce or Andreas Koenig, we don't know. What we know for
sure is, that it was inspired by Larry Wall's TEST script that came
with perl distributions for ages. Numerous anonymous contributors
! exist. Andreas Koenig held the torch for many years.
! Current maintainer is Michael G Schwern E<lt>schwern@pobox.comE<gt>
+ =head1 TODO
+
+ Provide a way of running tests quietly (ie. no printing) for automated
+ validation of tests. This will probably take the form of a version
+ of runtests() which rather than printing its output returns raw data
+ on the state of the tests.
+
+ Fix HARNESS_COMPILE_TEST without breaking its core usage.
+
+ Figure a way to report test names in the failure summary.
+
+ Rework the test summary so long test names are not truncated as badly.
+
+ Merge back into bleadperl.
+
+ Deal with VMS's "not \nok 4\n" mistake.
+
+ Add option for coverage analysis.
+
+ =for _private
+ Keeping whittling away at _run_all_tests()
+
+ =for _private
+ Clean up how the summary is printed. Get rid of those damned formats.
+
=head1 BUGS
Test::Harness uses $^X to determine the perl binary to run the tests
***************
*** 883,887 ****
--- 1153,1160 ----
portable because $^X is not consistent for shebang scripts across
platforms. This is no problem when Test::Harness is run with an
absolute path to the perl binary or when $^X can be found in the path.
+
+ HARNESS_COMPILE_TEST currently assumes its run from the Perl source
+ directory.
=cut
diff -c /dev/null 'perl-5.7.2/lib/Test/Harness.t'
Index: ./lib/Test/Harness.t
*** ./lib/Test/Harness.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/Harness.t Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,205 ----
+ #!perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use strict;
+
+ # For shutting up Test::Harness.
+ package My::Dev::Null;
+ use Tie::Handle;
+ @My::Dev::Null::ISA = qw(Tie::StdHandle);
+
+ sub WRITE { }
+
+
+ package main;
+
+ # Utility testing functions.
+ my $test_num = 1;
+ sub ok ($;$) {
+ my($test, $name) = @_;
+ my $okstring = '';
+ $okstring = "not " unless $test;
+ $okstring .= "ok $test_num";
+ $okstring .= " - $name" if defined $name;
+ print "$okstring\n";
+ $test_num++;
+ }
+
+ sub eqhash {
+ my($a1, $a2) = @_;
+ return 0 unless keys %$a1 == keys %$a2;
+
+ my $ok = 1;
+ foreach my $k (keys %$a1) {
+ $ok = $a1->{$k} eq $a2->{$k};
+ last unless $ok;
+ }
+
+ return $ok;
+ }
+
+ use vars qw($Total_tests %samples);
+
+ my $loaded;
+ BEGIN { $| = 1; $^W = 1; }
+ END {print "not ok $test_num\n" unless $loaded;}
+ print "1..$Total_tests\n";
+ use Test::Harness;
+ $loaded = 1;
+ ok(1, 'compile');
+ ######################### End of black magic.
+
+ BEGIN {
+ %samples = (
+ simple => {
+ bonus => 0,
+ max => 5,
+ 'ok' => 5,
+ files => 1,
+ bad => 0,
+ good => 1,
+ tests => 1,
+ sub_skipped=> 0,
+ skipped => 0,
+ },
+ simple_fail => {
+ bonus => 0,
+ max => 5,
+ 'ok' => 3,
+ files => 1,
+ bad => 1,
+ good => 0,
+ tests => 1,
+ sub_skipped => 0,
+ skipped => 0,
+ },
+ descriptive => {
+ bonus => 0,
+ max => 5,
+ 'ok' => 5,
+ files => 1,
+ bad => 0,
+ good => 1,
+ tests => 1,
+ sub_skipped=> 0,
+ skipped => 0,
+ },
+ no_nums => {
+ bonus => 0,
+ max => 5,
+ 'ok' => 4,
+ files => 1,
+ bad => 1,
+ good => 0,
+ tests => 1,
+ sub_skipped=> 0,
+ skipped => 0,
+ },
+ todo => {
+ bonus => 1,
+ max => 5,
+ 'ok' => 5,
+ files => 1,
+ bad => 0,
+ good => 1,
+ tests => 1,
+ sub_skipped=> 0,
+ skipped => 0,
+ },
+ skip => {
+ bonus => 0,
+ max => 5,
+ 'ok' => 5,
+ files => 1,
+ bad => 0,
+ good => 1,
+ tests => 1,
+ sub_skipped=> 1,
+ skipped => 0,
+ },
+ bailout => 0,
+ combined => {
+ bonus => 1,
+ max => 10,
+ 'ok' => 8,
+ files => 1,
+ bad => 1,
+ good => 0,
+ tests => 1,
+ sub_skipped=> 1,
+ skipped => 0
+ },
+ duplicates => {
+ bonus => 0,
+ max => 10,
+ 'ok' => 11,
+ files => 1,
+ bad => 1,
+ good => 0,
+ tests => 1,
+ sub_skipped=> 0,
+ skipped => 0,
+ },
+ header_at_end => {
+ bonus => 0,
+ max => 4,
+ 'ok' => 4,
+ files => 1,
+ bad => 0,
+ good => 1,
+ tests => 1,
+ sub_skipped=> 0,
+ skipped => 0,
+ },
+ skip_all => {
+ bonus => 0,
+ max => 0,
+ 'ok' => 0,
+ files => 1,
+ bad => 0,
+ good => 1,
+ tests => 1,
+ sub_skipped=> 0,
+ skipped => 1,
+ },
+ with_comments => {
+ bonus => 2,
+ max => 5,
+ 'ok' => 5,
+ files => 1,
+ bad => 0,
+ good => 1,
+ tests => 1,
+ sub_skipped=> 0,
+ skipped => 0,
+ },
+ );
+
+ $Total_tests = keys(%samples) + 1;
+ }
+
+ tie *NULL, 'My::Dev::Null' or die $!;
+
+ while (my($test, $expect) = each %samples) {
+ # _run_all_tests() runs the tests but skips the formatting.
+ my($totals, $failed);
+ eval {
+ select NULL; # _run_all_tests() isn't as quiet as it should be.
+ ($totals, $failed) =
+ Test::Harness::_run_all_tests("lib/sample-tests/$test");
+ };
+ select STDOUT;
+
+ unless( $@ ) {
+ ok( eqhash( $expect, {map { $_=>$totals->{$_} } keys %$expect} ),
+ $test );
+ }
+ else { # special case for bailout
+ ok( ($test eq 'bailout' and $@ =~ /Further testing stopped: GERONI/i),
+ $test );
+ }
+ }
diff -c /dev/null 'perl-5.7.2/lib/Test/More.pm'
Index: ./lib/Test/More.pm
*** ./lib/Test/More.pm Thu Jan 1 02:00:00 1970
--- ./lib/Test/More.pm Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,698 ----
+ package Test::More;
+
+ use strict;
+
+
+ # Special print function to guard against $\ and -l munging.
+ sub _print (*@) {
+ my($fh, @args) = @_;
+
+ local $\;
+ print $fh @args;
+ }
+
+ sub print { die "DON'T USE PRINT! Use _print instead" }
+
+
+ BEGIN {
+ require Test::Simple;
+ *TESTOUT = \*Test::Simple::TESTOUT;
+ *TESTERR = \*Test::Simple::TESTERR;
+ }
+
+ require Exporter;
+ use vars qw($VERSION @ISA @EXPORT);
+ $VERSION = '0.07';
+ @ISA = qw(Exporter);
+ @EXPORT = qw(ok use_ok require_ok
+ is isnt like
+ skip todo
+ pass fail
+ eq_array eq_hash eq_set
+ );
+
+
+ sub import {
+ my($class, $plan, @args) = @_;
+
+ if( $plan eq 'skip_all' ) {
+ $Test::Simple::Skip_All = 1;
+ _print *TESTOUT, "1..0\n";
+ exit(0);
+ }
+ else {
+ Test::Simple->import($plan => @args);
+ }
+
+ __PACKAGE__->_export_to_level(1, __PACKAGE__);
+ }
+
+ # 5.004's Exporter doesn't have export_to_level.
+ sub _export_to_level
+ {
+ my $pkg = shift;
+ my $level = shift;
+ (undef) = shift; # XXX redundant arg
+ my $callpkg = caller($level);
+ $pkg->export($callpkg, @_);
+ }
+
+
+ =head1 NAME
+
+ Test::More - yet another framework for writing test scripts
+
+ =head1 SYNOPSIS
+
+ use Test::More tests => $Num_Tests;
+ # or
+ use Test::More qw(no_plan);
+ # or
+ use Test::More qw(skip_all);
+
+ BEGIN { use_ok( 'Some::Module' ); }
+ require_ok( 'Some::Module' );
+
+ # Various ways to say "ok"
+ ok($this eq $that, $test_name);
+
+ is ($this, $that, $test_name);
+ isnt($this, $that, $test_name);
+ like($this, qr/that/, $test_name);
+
+ skip { # UNIMPLEMENTED!!!
+ ok( foo(), $test_name );
+ is( foo(42), 23, $test_name );
+ } $how_many, $why;
+
+ todo { # UNIMPLEMENTED!!!
+ ok( foo(), $test_name );
+ is( foo(42), 23, $test_name );
+ } $how_many, $why;
+
+ pass($test_name);
+ fail($test_name);
+
+ # Utility comparison functions.
+ eq_array(\@this, \@that);
+ eq_hash(\%this, \%that);
+ eq_set(\@this, \@that);
+
+ # UNIMPLEMENTED!!!
+ my @status = Test::More::status;
+
+
+ =head1 DESCRIPTION
+
+ If you're just getting started writing tests, have a look at
+ Test::Simple first.
+
+ This module provides a very wide range of testing utilities. Various
+ ways to say "ok", facilities to skip tests, test future features
+ and compare complicated data structures.
+
+
+ =head2 I love it when a plan comes together
+
+ Before anything else, you need a testing plan. This basically declares
+ how many tests your script is going to run to protect against premature
+ failure.
+
+ The prefered way to do this is to declare a plan when you C<use Test::More>.
+
+ use Test::More tests => $Num_Tests;
+
+ There are rare cases when you will not know beforehand how many tests
+ your script is going to run. In this case, you can declare that you
+ have no plan. (Try to avoid using this as it weakens your test.)
+
+ use Test::More qw(no_plan);
+
+ In some cases, you'll want to completely skip an entire testing script.
+
+ use Test::More qw(skip_all);
+
+ Your script will declare a skip and exit immediately with a zero
+ (success). L<Test::Harness> for details.
+
+
+ =head2 Test names
+
+ By convention, each test is assigned a number in order. This is
+ largely done automatically for you. However, its often very useful to
+ assign a name to each test. Which would you rather see:
+
+ ok 4
+ not ok 5
+ ok 6
+
+ or
+
+ ok 4 - basic multi-variable
+ not ok 5 - simple exponential
+ ok 6 - force == mass * acceleration
+
+ The later gives you some idea of what failed. It also makes it easier
+ to find the test in your script, simply search for "simple
+ exponential".
+
+ All test functions take a name argument. Its optional, but highly
+ suggested that you use it.
+
+
+ =head2 I'm ok, you're not ok.
+
+ The basic purpose of this module is to print out either "ok #" or "not
+ ok #" depending on if a given test succeeded or failed. Everything
+ else is just gravy.
+
+ All of the following print "ok" or "not ok" depending on if the test
+ succeeded or failed. They all also return true or false,
+ respectively.
+
+ =over 4
+
+ =item B<ok>
+
+ ok($this eq $that, $test_name);
+
+ This simply evaluates any expression (C<$this eq $that> is just a
+ simple example) and uses that to determine if the test succeeded or
+ failed. A true expression passes, a false one fails. Very simple.
+
+ For example:
+
+ ok( $exp{9} == 81, 'simple exponential' );
+ ok( Film->can('db_Main'), 'set_db()' );
+ ok( $p->tests == 4, 'saw tests' );
+ ok( !grep !defined $_, @items, 'items populated' );
+
+ (Mnemonic: "This is ok.")
+
+ $test_name is a very short description of the test that will be printed
+ out. It makes it very easy to find a test in your script when it fails
+ and gives others an idea of your intentions. $test_name is optional,
+ but we B<very> strongly encourage its use.
+
+ Should an ok() fail, it will produce some diagnostics:
+
+ not ok 18 - sufficient mucus
+ # Failed test 18 (foo.t at line 42)
+
+ This is actually Test::Simple's ok() routine.
+
+ =cut
+
+ # We get ok() from Test::Simple's import().
+
+ =item B<is>
+
+ =item B<isnt>
+
+ is ( $this, $that, $test_name );
+ isnt( $this, $that, $test_name );
+
+ Similar to ok(), is() and isnt() compare their two arguments with
+ C<eq> and C<ne> respectively and use the result of that to determine
+ if the test succeeded or failed. So these:
+
+ # Is the ultimate answer 42?
+ is( ultimate_answer(), 42, "Meaning of Life" );
+
+ # $foo isn't empty
+ isnt( $foo, '', "Got some foo" );
+
+ are similar to these:
+
+ ok( ultimate_answer() eq 42, "Meaning of Life" );
+ ok( $foo ne '', "Got some foo" );
+
+ (Mnemonic: "This is that." "This isn't that.")
+
+ So why use these? They produce better diagnostics on failure. ok()
+ cannot know what you are testing for (beyond the name), but is() and
+ isnt() know what the test was and why it failed. For example this
+ test:
+
+ my $foo = 'waffle'; my $bar = 'yarblokos';
+ is( $foo, $bar, 'Is foo the same as bar?' );
+
+ Will produce something like this:
+
+ not ok 17 - Is foo the same as bar?
+ # Failed test 1 (foo.t at line 139)
+ # got: 'waffle'
+ # expected: 'yarblokos'
+
+ So you can figure out what went wrong without rerunning the test.
+
+ You are encouraged to use is() and isnt() over ok() where possible,
+ however do not be tempted to use them to find out if something is
+ true or false!
+
+ # XXX BAD! $pope->isa('Catholic') eq 1
+ is( $pope->isa('Catholic'), 1, 'Is the Pope Catholic?' );
+
+ This does not check if C<$pope->isa('Catholic')> is true, it checks if
+ it returns 1. Very different. Similar caveats exist for false and 0.
+ In these cases, use ok().
+
+ ok( $pope->isa('Catholic') ), 'Is the Pope Catholic?' );
+
+ For those grammatical pedants out there, there's an isn't() function
+ which is an alias of isnt().
+
+ =cut
+
+ sub is ($$;$) {
+ my($this, $that, $name) = @_;
+
+ my $ok = @_ == 3 ? ok($this eq $that, $name)
+ : ok($this eq $that);
+
+ unless( $ok ) {
+ _print *TESTERR, <<DIAGNOSTIC;
+ # got: '$this'
+ # expected: '$that'
+ DIAGNOSTIC
+
+ }
+
+ return $ok;
+ }
+
+ sub isnt ($$;$) {
+ my($this, $that, $name) = @_;
+
+ my $ok = @_ == 3 ? ok($this ne $that, $name)
+ : ok($this ne $that);
+
+ unless( $ok ) {
+ _print *TESTERR, <<DIAGNOSTIC;
+ # it should not be '$that'
+ # but it is.
+ DIAGNOSTIC
+
+ }
+
+ return $ok;
+ }
+
+ *isn't = \&isnt;
+
+
+ =item B<like>
+
+ like( $this, qr/that/, $test_name );
+
+ Similar to ok(), like() matches $this against the regex C<qr/that/>.
+
+ So this:
+
+ like($this, qr/that/, 'this is like that');
+
+ is similar to:
+
+ ok( $this =~ /that/, 'this is like that');
+
+ (Mnemonic "This is like that".)
+
+ The second argument is a regular expression. It may be given as a
+ regex reference (ie. qr//) or (for better compatibility with older
+ perls) as a string that looks like a regex (alternative delimiters are
+ currently not supported):
+
+ like( $this, '/that/', 'this is like that' );
+
+ Regex options may be placed on the end (C<'/that/i'>).
+
+ Its advantages over ok() are similar to that of is() and isnt(). Better
+ diagnostics on failure.
+
+ =cut
+
+ sub like ($$;$) {
+ my($this, $regex, $name) = @_;
+
+ my $ok = 0;
+ if( ref $regex eq 'Regexp' ) {
+ $ok = @_ == 3 ? ok( $this =~ $regex ? 1 : 0, $name )
+ : ok( $this =~ $regex ? 1 : 0 );
+ }
+ # Check if it looks like '/foo/i'
+ elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) {
+ $ok = @_ == 3 ? ok( $this =~ /(?$opts)$re/ ? 1 : 0, $name )
+ : ok( $this =~ /(?$opts)$re/ ? 1 : 0 );
+ }
+ else {
+ # Can't use fail() here, the call stack will be fucked.
+ my $ok = @_ == 3 ? ok(0, $name )
+ : ok(0);
+
+ _print *TESTERR, <<ERR;
+ # '$regex' doesn't look much like a regex to me. Failing the test.
+ ERR
+
+ return $ok;
+ }
+
+ unless( $ok ) {
+ _print *TESTERR, <<DIAGNOSTIC;
+ # '$this'
+ # doesn't match '$regex'
+ DIAGNOSTIC
+
+ }
+
+ return $ok;
+ }
+
+ =item B<pass>
+
+ =item B<fail>
+
+ pass($test_name);
+ fail($test_name);
+
+ Sometimes you just want to say that the tests have passed. Usually
+ the case is you've got some complicated condition that is difficult to
+ wedge into an ok(). In this case, you can simply use pass() (to
+ declare the test ok) or fail (for not ok). They are synonyms for
+ ok(1) and ok(0).
+
+ Use these very, very, very sparingly.
+
+ =cut
+
+ sub pass ($) {
+ my($name) = @_;
+ return @_ == 1 ? ok(1, $name)
+ : ok(1);
+ }
+
+ sub fail ($) {
+ my($name) = @_;
+ return @_ == 1 ? ok(0, $name)
+ : ok(0);
+ }
+
+ =back
+
+ =head2 Module tests
+
+ You usually want to test if the module you're testing loads ok, rather
+ than just vomiting if its load fails. For such purposes we have
+ C<use_ok> and C<require_ok>.
+
+ =over 4
+
+ =item B<use_ok>
+
+ =item B<require_ok>
+
+ BEGIN { use_ok($module); }
+ require_ok($module);
+
+ These simply use or require the given $module and test to make sure
+ the load happened ok. Its recommended that you run use_ok() inside a
+ BEGIN block so its functions are exported at compile-time and
+ prototypes are properly honored.
+
+ =cut
+
+ sub use_ok ($) {
+ my($module) = shift;
+
+ my $pack = caller;
+
+ eval <<USE;
+ package $pack;
+ require $module;
+ $module->import;
+ USE
+
+ my $ok = ok( !$@, "use $module;" );
+
+ unless( $ok ) {
+ _print *TESTERR, <<DIAGNOSTIC;
+ # Tried to use '$module'.
+ # Error: $@
+ DIAGNOSTIC
+
+ }
+
+ return $ok;
+ }
+
+
+ sub require_ok ($) {
+ my($module) = shift;
+
+ my $pack = caller;
+
+ eval <<REQUIRE;
+ package $pack;
+ require $module;
+ REQUIRE
+
+ my $ok = ok( !$@, "require $module;" );
+
+ unless( $ok ) {
+ _print *TESTERR, <<DIAGNOSTIC;
+ # Tried to require '$module'.
+ # Error: $@
+ DIAGNOSTIC
+
+ }
+
+ return $ok;
+ }
+
+
+ =head2 Conditional tests
+
+ Sometimes running a test under certain conditions will cause the
+ test script to die. A certain function or method isn't implemented
+ (such as fork() on MacOS), some resource isn't available (like a
+ net connection) or a module isn't available. In these cases its
+ necessary to skip test, or declare that they are supposed to fail
+ but will work in the future (a todo test).
+
+ For more details on skip and todo tests, L<Test::Harness>.
+
+ =over 4
+
+ =item B<skip> * UNIMPLEMENTED *
+
+ skip BLOCK $how_many, $why, $if;
+
+ B<NOTE> Should that be $if or $unless?
+
+ This declares a block of tests to skip, why and under what conditions
+ to skip them. An example is the easiest way to illustrate:
+
+ skip {
+ ok( head("http://www.foo.com"), "www.foo.com is alive" );
+ ok( head("http://www.foo.com/bar"), " and has bar" );
+ } 2, "LWP::Simple not installed",
+ !eval { require LWP::Simple; LWP::Simple->import; 1 };
+
+ The $if condition is optional, but $why is not.
+
+ =cut
+
+ sub skip {
+ die "skip() is UNIMPLEMENTED!";
+ }
+
+ =item B<todo> * UNIMPLEMENTED *
+
+ todo BLOCK $how_many, $why;
+ todo BLOCK $how_many, $why, $until;
+
+ Declares a block of tests you expect to fail and why. Perhaps its
+ because you haven't fixed a bug:
+
+ todo { is( $Gravitational_Constant, 0 ) } 1,
+ "Still tinkering with physics --God";
+
+ If you have a set of functionality yet to implement, you can make the
+ whole suite dependent on that new feature.
+
+ todo {
+ $pig->takeoff;
+ ok( $pig->altitude > 0 );
+ ok( $pig->mach > 2 );
+ ok( $pig->serve_peanuts );
+ } 1, "Pigs are still safely grounded",
+ Pigs->can('fly');
+
+ =cut
+
+ sub todo {
+ die "todo() is UNIMPLEMENTED!";
+ }
+
+ =head2 Comparision functions
+
+ Not everything is a simple eq check or regex. There are times you
+ need to see if two arrays are equivalent, for instance. For these
+ instances, Test::More provides a handful of useful functions.
+
+ B<NOTE> These are NOT well-tested on circular references. Nor am I
+ quite sure what will happen with filehandles.
+
+ =over 4
+
+ =item B<eq_array>
+
+ eq_array(\@this, \@that);
+
+ Checks if two arrays are equivalent. This is a deep check, so
+ multi-level structures are handled correctly.
+
+ =cut
+
+ #'#
+ sub eq_array {
+ my($a1, $a2) = @_;
+ return 0 unless @$a1 == @$a2;
+ return 1 if $a1 eq $a2;
+
+ my $ok = 1;
+ for (0..$#{$a1}) {
+ my($e1,$e2) = ($a1->[$_], $a2->[$_]);
+ $ok = _deep_check($e1,$e2);
+ last unless $ok;
+ }
+ return $ok;
+ }
+
+ sub _deep_check {
+ my($e1, $e2) = @_;
+ my $ok = 0;
+
+ if($e1 eq $e2) {
+ $ok = 1;
+ }
+ else {
+ if( UNIVERSAL::isa($e1, 'ARRAY') and
+ UNIVERSAL::isa($e2, 'ARRAY') )
+ {
+ $ok = eq_array($e1, $e2);
+ }
+ elsif( UNIVERSAL::isa($e1, 'HASH') and
+ UNIVERSAL::isa($e2, 'HASH') )
+ {
+ $ok = eq_hash($e1, $e2);
+ }
+ else {
+ $ok = 0;
+ }
+ }
+ return $ok;
+ }
+
+
+ =item B<eq_hash>
+
+ eq_hash(\%this, \%that);
+
+ Determines if the two hashes contain the same keys and values. This
+ is a deep check.
+
+ =cut
+
+ sub eq_hash {
+ my($a1, $a2) = @_;
+ return 0 unless keys %$a1 == keys %$a2;
+ return 1 if $a1 eq $a2;
+
+ my $ok = 1;
+ foreach my $k (keys %$a1) {
+ my($e1, $e2) = ($a1->{$k}, $a2->{$k});
+ $ok = _deep_check($e1, $e2);
+ last unless $ok;
+ }
+
+ return $ok;
+ }
+
+ =item B<eq_set>
+
+ eq_set(\@this, \@that);
+
+ Similar to eq_array(), except the order of the elements is B<not>
+ important. This is a deep check, but the irrelevancy of order only
+ applies to the top level.
+
+ =cut
+
+ # We must make sure that references are treated neutrally. It really
+ # doesn't matter how we sort them, as long as both arrays are sorted
+ # with the same algorithm.
+ sub _bogus_sort { ref $a ? 0 : $a cmp $b }
+
+ sub eq_set {
+ my($a1, $a2) = @_;
+ return 0 unless @$a1 == @$a2;
+
+ # There's faster ways to do this, but this is easiest.
+ return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] );
+ }
+
+
+ =back
+
+ =head1 BUGS and CAVEATS
+
+ The eq_* family have some caveats.
+
+ todo() and skip() are unimplemented.
+
+ The no_plan feature depends on new Test::Harness feature. If you're going
+ to distribute tests that use no_plan your end-users will have to upgrade
+ Test::Harness to the latest one on CPAN.
+
+ =head1 AUTHOR
+
+ Michael G Schwern <schwern@pobox.com> with much inspiration from
+ Joshua Pritikin's Test module and lots of discussion with Barrie
+ Slaymaker and the perl-qa gang.
+
+
+ =head1 HISTORY
+
+ This is a case of convergent evolution with Joshua Pritikin's Test
+ module. I was actually largely unware of its existance when I'd first
+ written my own ok() routines. This module exists because I can't
+ figure out how to easily wedge test names into Test's interface (along
+ with a few other problems).
+
+ The goal here is to have a testing utility that's simple to learn,
+ quick to use and difficult to trip yourself up with while still
+ providing more flexibility than the existing Test.pm. As such, the
+ names of the most common routines are kept tiny, special cases and
+ magic side-effects are kept to a minimum. WYSIWYG.
+
+
+ =head1 SEE ALSO
+
+ L<Test::Simple> if all this confuses you and you just want to write
+ some tests. You can upgrade to Test::More later (its forward
+ compatible).
+
+ L<Test> for a similar testing module.
+
+ L<Test::Harness> for details on how your test results are interpreted
+ by Perl.
+
+ L<Test::Unit> describes a very featureful unit testing interface.
+
+ L<Pod::Tests> shows the idea of embedded testing.
+
+ L<SelfTest> is another approach to embedded testing.
+
+ =cut
+
+ 1;
diff -c /dev/null 'perl-5.7.2/lib/Test/More/Changes'
Index: ./lib/Test/More/Changes
*** ./lib/Test/More/Changes Thu Jan 1 02:00:00 1970
--- ./lib/Test/More/Changes Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,32 ----
+ Revision history for Perl extension Test::More.
+
+ 0.07 Wed Jun 27 03:06:56 EDT 2001
+ - VMS and Win32 fixes. Nothing was actually wrong, but the tests
+ had little problems.
+ - like()'s failure report wasn't always accurate
+
+ 0.06 Fri Jun 15 14:39:50 EDT 2001
+ - Guarding against $/ and -l
+ - Reformatted the way failed tests are reported to make them stand out
+ a bit better.
+ - Fixed tests without names
+
+ 0.05 Tue Jun 12 16:16:55 EDT 2001
+ * use Test::More no_plan; implemented
+
+ 0.04 Thu Jun 7 11:26:18 BST 2001
+ - minor bug in eq_set() with complex data structures
+ Thanks to Tatsuhiko Miyagawa for finding this.
+
+ 0.03 Tue Jun 5 19:59:59 BST 2001
+ - Fixed export problem in 5.004.
+ - prototyped the functions properly
+ * fixed bug with like() involving qr//
+
+ 0.02 Thu Apr 5 12:48:48 BST 2001
+ - Fixed Makefile.PL to work around MakeMaker bug that 'use's Test::Simple
+ instead of 'require'ing.
+
+ 0.01 Fri Mar 30 07:49:14 GMT 2001
+ - First working version
+
diff -c /dev/null 'perl-5.7.2/lib/Test/More/t/More.t'
Index: ./lib/Test/More/t/More.t
*** ./lib/Test/More/t/More.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/More/t/More.t Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,78 ----
+ use Test::More tests => 18;
+
+ use_ok('Text::Soundex');
+ require_ok('Test::More');
+
+
+ ok( 2 eq 2, 'two is two is two is two' );
+ is( "foo", "foo", 'foo is foo' );
+ isnt( "foo", "bar", 'foo isnt bar');
+ isn't("foo", "bar", 'foo isn\'t bar');
+
+ #'#
+ like("fooble", '/^foo/', 'foo is like fooble');
+ like("FooBle", '/foo/i', 'foo is like FooBle');
+
+ pass('pass() passed');
+
+ ok( eq_array([qw(this that whatever)], [qw(this that whatever)]),
+ 'eq_array with simple arrays' );
+ ok( eq_hash({ foo => 42, bar => 23 }, {bar => 23, foo => 42}),
+ 'eq_hash with simple hashes' );
+ ok( eq_set([qw(this that whatever)], [qw(that whatever this)]),
+ 'eq_set with simple sets' );
+
+ my @complex_array1 = (
+ [qw(this that whatever)],
+ {foo => 23, bar => 42},
+ "moo",
+ "yarrow",
+ [qw(498 10 29)],
+ );
+ my @complex_array2 = (
+ [qw(this that whatever)],
+ {foo => 23, bar => 42},
+ "moo",
+ "yarrow",
+ [qw(498 10 29)],
+ );
+
+ ok( eq_array(\@complex_array1, \@complex_array2),
+ 'eq_array with complicated arrays' );
+ ok( eq_set(\@complex_array1, \@complex_array2),
+ 'eq_set with complicated arrays' );
+
+ my @array1 = (qw(this that whatever),
+ {foo => 23, bar => 42} );
+ my @array2 = (qw(this that whatever),
+ {foo => 24, bar => 42} );
+
+ ok( !eq_array(\@array1, \@array2),
+ 'eq_array with slightly different complicated arrays' );
+ ok( !eq_set(\@array1, \@array2),
+ 'eq_set with slightly different complicated arrays' );
+
+ my %hash1 = ( foo => 23,
+ bar => [qw(this that whatever)],
+ har => { foo => 24, bar => 42 },
+ );
+ my %hash2 = ( foo => 23,
+ bar => [qw(this that whatever)],
+ har => { foo => 24, bar => 42 },
+ );
+
+
+ ok( eq_hash(\%hash1, \%hash2),
+ 'eq_hash with complicated hashes');
+
+ %hash1 = ( foo => 23,
+ bar => [qw(this that whatever)],
+ har => { foo => 24, bar => 42 },
+ );
+ %hash2 = ( foo => 23,
+ bar => [qw(this tha whatever)],
+ har => { foo => 24, bar => 42 },
+ );
+
+ ok( !eq_hash(\%hash1, \%hash2),
+ 'eq_hash with slightly different complicated hashes' );
diff -c /dev/null 'perl-5.7.2/lib/Test/More/t/fail-like.t'
Index: ./lib/Test/More/t/fail-like.t
*** ./lib/Test/More/t/fail-like.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/More/t/fail-like.t Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,64 ----
+ # qr// was introduced in 5.004-devel. Skip this test if we're not
+ # of high enough version.
+ BEGIN {
+ if( $] < 5.005 ) {
+ print "1..0\n";
+ exit(0);
+ }
+ }
+
+
+ # There was a bug with like() involving a qr// not failing properly.
+ # This tests against that.
+
+ use strict;
+
+ # Can't use Test.pm, that's a 5.005 thing.
+ package My::Test;
+
+ print "1..2\n";
+
+ my $test_num = 1;
+ # Utility testing functions.
+ sub ok ($;$) {
+ my($test, $name) = @_;
+ my $ok = '';
+ $ok .= "not " unless $test;
+ $ok .= "ok $test_num";
+ $ok .= " - $name" if defined $name;
+ $ok .= "\n";
+ print $ok;
+ $test_num++;
+ }
+
+
+ package main;
+ require Test::More;
+
+ @INC = ('../lib', 'lib/Test/More');
+ require Catch;
+ my($out, $err) = Catch::caught();
+
+ Test::More->import(tests => 1);
+
+ eval q{ like( "foo", qr/that/, 'is foo like that' ); };
+
+
+ END {
+ My::Test::ok($$out eq <<OUT, 'failing output');
+ 1..1
+ not ok 1 - is foo like that
+ OUT
+
+ my $err_re = <<ERR;
+ # Failed test \\(.*\\)
+ # 'foo'
+ # doesn't match '\\(\\?-xism:that\\)'
+ # Looks like you failed 1 tests of 1\\.
+ ERR
+
+
+ My::Test::ok($$err =~ /^$err_re$/, 'failing errors');
+
+ exit(0);
+ }
diff -c /dev/null 'perl-5.7.2/lib/Test/More/t/fail.t'
Index: ./lib/Test/More/t/fail.t
*** ./lib/Test/More/t/fail.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/More/t/fail.t Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,89 ----
+ use strict;
+
+ # Can't use Test.pm, that's a 5.005 thing.
+ package My::Test;
+
+ print "1..2\n";
+
+ my $test_num = 1;
+ # Utility testing functions.
+ sub ok ($;$) {
+ my($test, $name) = @_;
+ my $ok = '';
+ $ok .= "not " unless $test;
+ $ok .= "ok $test_num";
+ $ok .= " - $name" if defined $name;
+ $ok .= "\n";
+ print $ok;
+ $test_num++;
+ }
+
+
+ package main;
+ require Test::More;
+
+ @INC = ('../lib', 'lib/Test/More');
+ require Catch;
+ my($out, $err) = Catch::caught();
+
+ Test::More->import(tests => 8);
+
+ ok( 0, 'failing' );
+ is( "foo", "bar", 'foo is bar?');
+ isnt("foo", "foo", 'foo isnt foo?' );
+ isn't("foo", "foo",'foo isn\'t foo?' );
+
+ like( "foo", '/that/', 'is foo like that' );
+
+ fail('fail()');
+
+ use_ok('Hooble::mooble::yooble');
+ require_ok('ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble');
+
+ END {
+ My::Test::ok($$out eq <<OUT, 'failing output');
+ 1..8
+ not ok 1 - failing
+ not ok 2 - foo is bar?
+ not ok 3 - foo isnt foo?
+ not ok 4 - foo isn't foo?
+ not ok 5 - is foo like that
+ not ok 6 - fail()
+ not ok 7 - use Hooble::mooble::yooble;
+ not ok 8 - require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble;
+ OUT
+
+ my $err_re = <<ERR;
+ # Failed test ($0 at line 31)
+ # Failed test ($0 at line 32)
+ # got: 'foo'
+ # expected: 'bar'
+ # Failed test ($0 at line 33)
+ # it should not be 'foo'
+ # but it is.
+ # Failed test ($0 at line 34)
+ # it should not be 'foo'
+ # but it is.
+ # Failed test ($0 at line 36)
+ # 'foo'
+ # doesn't match '/that/'
+ # Failed test ($0 at line 38)
+ ERR
+
+ my $filename = quotemeta $0;
+ my $more_err_re = <<ERR;
+ # Failed test \\($filename at line 40\\)
+ # Tried to use 'Hooble::mooble::yooble'.
+ # Error: Can't locate Hooble.* in \\\@INC .*
+
+ # Failed test \\($filename at line 41\\)
+ # Tried to require 'ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'.
+ # Error: Can't locate ALL.* in \\\@INC .*
+
+ # Looks like you failed 8 tests of 8.
+ ERR
+
+ My::Test::ok($$err =~ /^\Q$err_re\E$more_err_re$/, 'failing errors');
+
+ exit(0);
+ }
diff -c /dev/null 'perl-5.7.2/lib/Test/More/t/plan_is_noplan.t'
Index: ./lib/Test/More/t/plan_is_noplan.t
*** ./lib/Test/More/t/plan_is_noplan.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/More/t/plan_is_noplan.t Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,45 ----
+ # Can't use Test.pm, that's a 5.005 thing.
+ package My::Test;
+
+ print "1..2\n";
+
+ my $test_num = 1;
+ # Utility testing functions.
+ sub ok ($;$) {
+ my($test, $name) = @_;
+ my $ok = '';
+ $ok .= "not " unless $test;
+ $ok .= "ok $test_num";
+ $ok .= " - $name" if defined $name;
+ $ok .= "\n";
+ print $ok;
+ $test_num++;
+ }
+
+
+ package main;
+
+ require Test::More;
+
+ @INC = ('../lib', 'lib/Test/More');
+ require Catch;
+ my($out, $err) = Catch::caught();
+
+
+ Test::More->import('no_plan');
+
+ ok(1, 'foo');
+
+
+ END {
+ My::Test::ok($$out eq <<OUT);
+ ok 1 - foo
+ 1..1
+ OUT
+
+ My::Test::ok($$err eq <<ERR);
+ ERR
+
+ # Prevent Test::More from exiting with non zero
+ exit 0;
+ }
diff -c /dev/null 'perl-5.7.2/lib/Test/More/t/skipall.t'
Index: ./lib/Test/More/t/skipall.t
*** ./lib/Test/More/t/skipall.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/More/t/skipall.t Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,35 ----
+ use strict;
+
+ # Can't use Test.pm, that's a 5.005 thing.
+ package My::Test;
+
+ print "1..2\n";
+
+ my $test_num = 1;
+ # Utility testing functions.
+ sub ok ($;$) {
+ my($test, $name) = @_;
+ my $ok = '';
+ $ok .= "not " unless $test;
+ $ok .= "ok $test_num";
+ $ok .= " - $name" if defined $name;
+ $ok .= "\n";
+ print $ok;
+ $test_num++;
+ }
+
+
+ package main;
+ require Test::More;
+
+ @INC = ('../lib', 'lib/Test/More');
+ require Catch;
+ my($out, $err) = Catch::caught();
+
+ Test::More->import('skip_all');
+
+
+ END {
+ My::Test::ok($$out eq "1..0\n");
+ My::Test::ok($$err eq "");
+ }
diff -c /dev/null 'perl-5.7.2/lib/Test/Simple.pm'
Index: ./lib/Test/Simple.pm
*** ./lib/Test/Simple.pm Thu Jan 1 02:00:00 1970
--- ./lib/Test/Simple.pm Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,444 ----
+ package Test::Simple;
+
+ require 5.004;
+
+ $Test::Simple::VERSION = '0.09';
+
+ my(@Test_Results) = ();
+ my($Num_Tests, $Planned_Tests, $Test_Died) = (0,0,0);
+ my($Have_Plan) = 0;
+
+
+ # Special print function to guard against $\ and -l munging.
+ sub _print (*@) {
+ my($fh, @args) = @_;
+
+ local $\;
+ print $fh @args;
+ }
+
+ sub print { die "DON'T USE PRINT! Use _print instead" }
+
+
+ # I'd like to have Test::Simple interfere with the program being
+ # tested as little as possible. This includes using Exporter or
+ # anything else (including strict).
+ sub import {
+ # preserve caller()
+ if( @_ > 1 ) {
+ if( $_[1] eq 'no_plan' ) {
+ goto &no_plan;
+ }
+ else {
+ goto &plan
+ }
+ }
+ }
+
+ sub plan {
+ my($class, %config) = @_;
+
+ if( !exists $config{tests} ) {
+ die "You have to tell $class how many tests you plan to run.\n".
+ " use $class tests => 42; for example.\n";
+ }
+ elsif( !defined $config{tests} ) {
+ die "Got an undefined number of tests. Looks like you tried to tell ".
+ "$class how many tests you plan to run but made a mistake.\n";
+ }
+ elsif( !$config{tests} ) {
+ die "You told $class you plan to run 0 tests! You've got to run ".
+ "something.\n";
+ }
+ else {
+ $Planned_Tests = $config{tests};
+ }
+
+ $Have_Plan = 1;
+
+ _print *TESTOUT, "1..$Planned_Tests\n";
+
+ my($caller) = caller;
+ *{$caller.'::ok'} = \&ok;
+
+ }
+
+
+ sub no_plan {
+ $Have_Plan = 1;
+
+ my($caller) = caller;
+ *{$caller.'::ok'} = \&ok;
+ }
+
+
+
+ $| = 1;
+ open(*TESTOUT, ">&STDOUT") or _whoa(1, "Can't dup STDOUT!");
+ open(*TESTERR, ">&STDERR") or _whoa(1, "Can't dup STDERR!");
+ {
+ my $orig_fh = select TESTOUT;
+ $| = 1;
+ select TESTERR;
+ $| = 1;
+ select $orig_fh;
+ }
+
+ =head1 NAME
+
+ Test::Simple - Basic utilities for writing tests.
+
+ =head1 SYNOPSIS
+
+ use Test::Simple tests => 1;
+
+ ok( $foo eq $bar, 'foo is bar' );
+
+
+ =head1 DESCRIPTION
+
+ This is an extremely simple, extremely basic module for writing tests
+ suitable for CPAN modules and other pursuits.
+
+ The basic unit of Perl testing is the ok. For each thing you want to
+ test your program will print out an "ok" or "not ok" to indicate pass
+ or fail. You do this with the ok() function (see below).
+
+ The only other constraint is you must predeclare how many tests you
+ plan to run. This is in case something goes horribly wrong during the
+ test and your test program aborts, or skips a test or whatever. You
+ do this like so:
+
+ use Test::Simple tests => 23;
+
+ You must have a plan.
+
+
+ =over 4
+
+ =item B<ok>
+
+ ok( $foo eq $bar, $name );
+ ok( $foo eq $bar );
+
+ ok() is given an expression (in this case C<$foo eq $bar>). If its
+ true, the test passed. If its false, it didn't. That's about it.
+
+ ok() prints out either "ok" or "not ok" along with a test number (it
+ keeps track of that for you).
+
+ # This produces "ok 1 - Hell not yet frozen over" (or not ok)
+ ok( get_temperature($hell) > 0, 'Hell not yet frozen over' );
+
+ If you provide a $name, that will be printed along with the "ok/not
+ ok" to make it easier to find your test when if fails (just search for
+ the name). It also makes it easier for the next guy to understand
+ what your test is for. Its highly recommended you use test names.
+
+ All tests are run in scalar context. So this:
+
+ ok( @stuff, 'I have some stuff' );
+
+ will do what you mean (fail if stuff is empty).
+
+ =cut
+
+ sub ok ($;$) {
+ my($test, $name) = @_;
+
+ unless( $Have_Plan ) {
+ die "You tried to use ok() without a plan! Gotta have a plan.\n".
+ " use Test::Simple tests => 23; for example.\n";
+ }
+
+ $Num_Tests++;
+
+ # Make sure the print doesn't get interfered with.
+ local($\, $,);
+
+ _print *TESTERR, <<ERR if defined $name and $name !~ /\D/;
+ You named your test '$name'. You shouldn't use numbers for your test names.
+ Very confusing.
+ ERR
+
+
+ # We must print this all in one shot or else it will break on VMS
+ my $msg;
+ unless( $test ) {
+ $msg .= "not ";
+ $Test_Results[$Num_Tests-1] = 0;
+ }
+ else {
+ $Test_Results[$Num_Tests-1] = 1;
+ }
+ $msg .= "ok $Num_Tests";
+ $msg .= " - $name" if @_ == 2;
+ $msg .= "\n";
+
+ _print *TESTOUT, $msg;
+
+ #'#
+ unless( $test ) {
+ my($pack, $file, $line) = (caller)[0,1,2];
+ if( $pack eq 'Test::More' ) {
+ ($file, $line) = (caller(1))[1,2];
+ }
+ _print *TESTERR, "# Failed test ($file at line $line)\n";
+ }
+
+ return $test;
+ }
+
+ =back
+
+ Test::Simple will start by printing number of tests run in the form
+ "1..M" (so "1..5" means you're going to run 5 tests). This strange
+ format lets Test::Harness know how many tests you plan on running in
+ case something goes horribly wrong.
+
+ If all your tests passed, Test::Simple will exit with zero (which is
+ normal). If anything failed it will exit with how many failed. If
+ you run less (or more) tests than you planned, the missing (or extras)
+ will be considered failures. If no tests were ever run Test::Simple
+ will throw a warning and exit with 255. If the test died, even after
+ having successfully completed all its tests, it will still be
+ considered a failure and will exit with 255.
+
+ So the exit codes are...
+
+ 0 all tests successful
+ 255 test died
+ any other number how many failed (including missing or extras)
+
+ If you fail more than 254 tests, it will be reported as 254.
+
+ =begin _private
+
+ =over 4
+
+ =item B<_sanity_check>
+
+ _sanity_check();
+
+ Runs a bunch of end of test sanity checks to make sure reality came
+ through ok. If anything is wrong it will die with a fairly friendly
+ error message.
+
+ =cut
+
+ #'#
+ sub _sanity_check {
+ _whoa($Num_Tests < 0, 'Says here you ran a negative number of tests!');
+ _whoa(!$Have_Plan and $Num_Tests,
+ 'Somehow your tests ran without a plan!');
+ _whoa($Num_Tests != @Test_Results,
+ 'Somehow you got a different number of results than tests ran!');
+ }
+
+ =item B<_whoa>
+
+ _whoa($check, $description);
+
+ A sanity check, similar to assert(). If the $check is true, something
+ has gone horribly wrong. It will die with the given $description and
+ a note to contact the author.
+
+ =cut
+
+ sub _whoa {
+ my($check, $desc) = @_;
+ if( $check ) {
+ die <<WHOA;
+ WHOA! $desc
+ This should never happen! Please contact the author immediately!
+ WHOA
+ }
+ }
+
+ =item B<_my_exit>
+
+ _my_exit($exit_num);
+
+ Perl seems to have some trouble with exiting inside an END block. 5.005_03
+ and 5.6.1 both seem to do odd things. Instead, this function edits $?
+ directly. It should ONLY be called from inside an END block. It
+ doesn't actually exit, that's your job.
+
+ =cut
+
+ sub _my_exit {
+ $? = $_[0];
+ return 1;
+ }
+
+
+ =back
+
+ =end _private
+
+ =cut
+
+ $SIG{__DIE__} = sub {
+ # We don't want to muck with death in an eval, but $^S isn't
+ # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
+ # with it. Instead, we use caller. This also means it runs under
+ # 5.004!
+ my $in_eval = 0;
+ for( my $stack = 1; my $sub = (caller($stack))[3]; $stack++ ) {
+ $in_eval = 1 if $sub =~ /^\(eval\)/;
+ }
+ $Test_Died = 1 unless $in_eval;
+ };
+
+ END {
+ _sanity_check();
+
+ # Bailout if import() was never called. This is so
+ # "require Test::Simple" doesn't puke.
+ do{ _my_exit(0) && return } if !$Have_Plan and !$Num_Tests;
+
+ # Figure out if we passed or failed and print helpful messages.
+ if( $Num_Tests ) {
+ # The plan? We have no plan.
+ unless( $Planned_Tests ) {
+ _print *TESTOUT, "1..$Num_Tests\n";
+ $Planned_Tests = $Num_Tests;
+ }
+
+ my $num_failed = grep !$_, @Test_Results[0..$Planned_Tests-1];
+ $num_failed += abs($Planned_Tests - @Test_Results);
+
+ if( $Num_Tests < $Planned_Tests ) {
+ _print *TESTERR, <<"FAIL";
+ # Looks like you planned $Planned_Tests tests but only ran $Num_Tests.
+ FAIL
+ }
+ elsif( $Num_Tests > $Planned_Tests ) {
+ my $num_extra = $Num_Tests - $Planned_Tests;
+ _print *TESTERR, <<"FAIL";
+ # Looks like you planned $Planned_Tests tests but ran $num_extra extra.
+ FAIL
+ }
+ elsif ( $num_failed ) {
+ _print *TESTERR, <<"FAIL";
+ # Looks like you failed $num_failed tests of $Planned_Tests.
+ FAIL
+ }
+
+ if( $Test_Died ) {
+ _print *TESTERR, <<"FAIL";
+ # Looks like your test died just after $Num_Tests.
+ FAIL
+
+ _my_exit( 255 ) && return;
+ }
+
+ _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return;
+ }
+ elsif ( $Test::Simple::Skip_All ) {
+ _my_exit( 0 ) && return;
+ }
+ else {
+ _print *TESTERR, "# No tests run!\n";
+ _my_exit( 255 ) && return;
+ }
+ }
+
+
+ =pod
+
+ This module is by no means trying to be a complete testing system.
+ Its just to get you started. Once you're off the ground its
+ recommended you look at L<Test::More>.
+
+
+ =head1 EXAMPLE
+
+ Here's an example of a simple .t file for the fictional Film module.
+
+ use Test::Simple tests => 5;
+
+ use Film; # What you're testing.
+
+ my $btaste = Film->new({ Title => 'Bad Taste',
+ Director => 'Peter Jackson',
+ Rating => 'R',
+ NumExplodingSheep => 1
+ });
+ ok( defined($btaste) and ref $btaste eq 'Film', 'new() works' );
+
+ ok( $btaste->Title eq 'Bad Taste', 'Title() get' );
+ ok( $btsate->Director eq 'Peter Jackson', 'Director() get' );
+ ok( $btaste->Rating eq 'R', 'Rating() get' );
+ ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' );
+
+ It will produce output like this:
+
+ 1..5
+ ok 1 - new() works
+ ok 2 - Title() get
+ ok 3 - Director() get
+ not ok 4 - Rating() get
+ ok 5 - NumExplodingSheep() get
+
+ Indicating the Film::Rating() method is broken.
+
+
+ =head1 CAVEATS
+
+ Test::Simple will only report a maximum of 254 failures in its exit
+ code. If this is a problem, you probably have a huge test script.
+ Split it into multiple files. (Otherwise blame the Unix folks for
+ using an unsigned short integer as the exit status).
+
+
+ =head1 HISTORY
+
+ This module was conceived while talking with Tony Bowden in his
+ kitchen one night about the problems I was having writing some really
+ complicated feature into the new Testing module. He observed that the
+ main problem is not dealing with these edge cases but that people hate
+ to write tests B<at all>. What was needed was a dead simple module
+ that took all the hard work out of testing and was really, really easy
+ to learn. Paul Johnson simultaneously had this idea (unfortunately,
+ he wasn't in Tony's kitchen). This is it.
+
+
+ =head1 AUTHOR
+
+ Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+ <schwern@pobox.com>, wardrobe by Calvin Klein.
+
+
+ =head1 SEE ALSO
+
+ =over 4
+
+ =item L<Test::More>
+
+ More testing functions! Once you outgrow Test::Simple, look at
+ Test::More. Test::Simple is 100% forward compatible with Test::More
+ (ie. you can just use Test::More instead of Test::Simple in your
+ programs and things will still work).
+
+ =item L<Test>
+
+ The original Perl testing module.
+
+ =item L<Test::Unit>
+
+ Elaborate unit testing.
+
+ =item L<Pod::Tests>, L<SelfTest>
+
+ Embed tests in your code!
+
+ =item L<Test::Harness>
+
+ Interprets the output of your test program.
+
+ =back
+
+ =cut
+
+ 1;
diff -c /dev/null 'perl-5.7.2/lib/Test/Simple/Changes'
Index: ./lib/Test/Simple/Changes
*** ./lib/Test/Simple/Changes Thu Jan 1 02:00:00 1970
--- ./lib/Test/Simple/Changes Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,44 ----
+ Revision history for Perl extension Test::Simple
+
+ 0.09 Wed Jun 27 02:55:54 EDT 2001
+ - VMS fixes
+
+ 0.08 Fri Jun 15 14:39:50 EDT 2001
+ - Guarding against $/ and -l
+ - Reformatted the way failed tests are reported to make them stand out
+ a bit better.
+
+ 0.07 Tue Jun 12 15:55:54 BST 2001
+ - 'use Test::Simple' by itself no longer causes death
+ - Yet more fixes for death in eval
+ - Limiting max failures reported via exit code to 254.
+
+ 0.06 Wed May 9 23:38:17 BST 2001
+ - Whoops, left a private method in the public docs.
+
+ 0.05 Wed May 9 20:40:35 BST 2001
+ - Forgot to include the exit tests.
+ - Trouble with exiting properly under 5.005_03 and 5.6.1 fixed
+ - Turned off buffering
+ * 5.004 new minimum version
+ - Now explicitly tested with 5.6.1, 5.6.0, 5.005_03 and 5.004
+
+ 0.04 Mon Apr 2 11:05:01 BST 2001
+ - Fixed "require Test::Simple" so it doesn't bitch and exit 255
+ - Now installable with the CPAN shell.
+
+ 0.03 Fri Mar 30 08:08:33 BST 2001
+ - ok() now prints on what line and file it failed.
+ - eval 'die' was considered abnormal. Fixed.
+
+ 0.02 Fri Mar 30 05:12:14 BST 2001 *UNRELEASED*
+ - exit codes tested
+ * exit code on abnormal exit changed to 255 (thanks to Tim Bunce for
+ pointing out that Unix can't do negative exit codes)
+ - abnormal exits now better caught.
+ - No longer using Test.pm to test this, but still minimum of 5.005
+ due to needing $^S.
+
+ 0.01 Wed Mar 28 06:44:44 BST 2001
+ - First working version released to CPAN
+
diff -c /dev/null 'perl-5.7.2/lib/Test/Simple/t/exit.t'
Index: ./lib/Test/Simple/t/exit.t
*** ./lib/Test/Simple/t/exit.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/Simple/t/exit.t Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,45 ----
+ # Can't use Test.pm, that's a 5.005 thing.
+ package My::Test;
+
+ my $test_num = 1;
+ # Utility testing functions.
+ sub ok ($;$) {
+ my($test, $name) = @_;
+ my $ok = '';
+ $ok .= "not " unless $test;
+ $ok .= "ok $test_num";
+ $ok .= " - $name" if defined $name;
+ $ok .= "\n";
+ print $ok;
+ $test_num++;
+ }
+
+
+ package main;
+
+ my %Tests = (
+ 'success.plx' => 0,
+ 'one_fail.plx' => 1,
+ 'two_fail.plx' => 2,
+ 'five_fail.plx' => 5,
+ 'extras.plx' => 3,
+ 'too_few.plx' => 4,
+ 'death.plx' => 255,
+ 'last_minute_death.plx' => 255,
+ 'death_in_eval.plx' => 0,
+ 'require.plx' => 0,
+ );
+
+ print "1..".keys(%Tests)."\n";
+
+ chdir 't' if -d 't';
+ use File::Spec;
+ my $lib = File::Spec->catdir('lib', 'Test', 'Simple', 'sample_tests');
+ while( my($test_name, $exit_code) = each %Tests ) {
+ my $file = File::Spec->catfile($lib, $test_name);
+ my $wait_stat = system(qq{$^X -"I../lib" -"Ilib/Test/Simple" $file});
+ My::Test::ok( $wait_stat >> 8 == $exit_code,
+ "$test_name exited with $exit_code" );
+ }
+
+
diff -c /dev/null 'perl-5.7.2/lib/Test/Simple/t/extra.t'
Index: ./lib/Test/Simple/t/extra.t
*** ./lib/Test/Simple/t/extra.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/Simple/t/extra.t Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,53 ----
+ # Can't use Test.pm, that's a 5.005 thing.
+ package My::Test;
+
+ print "1..2\n";
+
+ my $test_num = 1;
+ # Utility testing functions.
+ sub ok ($;$) {
+ my($test, $name) = @_;
+ my $ok = '';
+ $ok .= "not " unless $test;
+ $ok .= "ok $test_num";
+ $ok .= " - $name" if defined $name;
+ $ok .= "\n";
+ print $ok;
+ $test_num++;
+ }
+
+
+ package main;
+
+ require Test::Simple;
+
+ @INC = ('../lib', 'lib/Test/Simple');
+ require Catch;
+ my($out, $err) = Catch::caught();
+
+ Test::Simple->import(tests => 3);
+
+ ok(1, 'Foo');
+ ok(0, 'Bar');
+ ok(1, 'Yar');
+ ok(1, 'Car');
+ ok(0, 'Sar');
+
+ END {
+ My::Test::ok($$out eq <<OUT);
+ 1..3
+ ok 1 - Foo
+ not ok 2 - Bar
+ ok 3 - Yar
+ ok 4 - Car
+ not ok 5 - Sar
+ OUT
+
+ My::Test::ok($$err eq <<ERR);
+ # Failed test ($0 at line 31)
+ # Failed test ($0 at line 34)
+ # Looks like you planned 3 tests but ran 2 extra.
+ ERR
+
+ exit 0;
+ }
diff -c /dev/null 'perl-5.7.2/lib/Test/Simple/t/fail.t'
Index: ./lib/Test/Simple/t/fail.t
*** ./lib/Test/Simple/t/fail.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/Simple/t/fail.t Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,57 ----
+ use strict;
+
+ # Can't use Test.pm, that's a 5.005 thing.
+ package My::Test;
+
+ print "1..2\n";
+
+ my $test_num = 1;
+ # Utility testing functions.
+ sub ok ($;$) {
+ my($test, $name) = @_;
+ my $ok = '';
+ $ok .= "not " unless $test;
+ $ok .= "ok $test_num";
+ $ok .= " - $name" if defined $name;
+ $ok .= "\n";
+ print $ok;
+ $test_num++;
+ }
+
+
+ package main;
+
+ require Test::Simple;
+
+ @INC = ('../lib', 'lib/Test/Simple');
+ require Catch;
+ my($out, $err) = Catch::caught();
+
+ Test::Simple->import(tests => 5);
+
+ ok( 1, 'passing' );
+ ok( 2, 'passing still' );
+ ok( 3, 'still passing' );
+ ok( 0, 'oh no!' );
+ ok( 0, 'damnit' );
+
+
+ END {
+ My::Test::ok($$out eq <<OUT);
+ 1..5
+ ok 1 - passing
+ ok 2 - passing still
+ ok 3 - still passing
+ not ok 4 - oh no!
+ not ok 5 - damnit
+ OUT
+
+ My::Test::ok($$err eq <<ERR);
+ # Failed test ($0 at line 35)
+ # Failed test ($0 at line 36)
+ # Looks like you failed 2 tests of 5.
+ ERR
+
+ # Prevent Test::Simple from exiting with non zero
+ exit 0;
+ }
diff -c /dev/null 'perl-5.7.2/lib/Test/Simple/t/missing.t'
Index: ./lib/Test/Simple/t/missing.t
*** ./lib/Test/Simple/t/missing.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/Simple/t/missing.t Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,46 ----
+ # Can't use Test.pm, that's a 5.005 thing.
+ package My::Test;
+
+ print "1..2\n";
+
+ my $test_num = 1;
+ # Utility testing functions.
+ sub ok ($;$) {
+ my($test, $name) = @_;
+ my $ok = '';
+ $ok .= "not " unless $test;
+ $ok .= "ok $test_num";
+ $ok .= " - $name" if defined $name;
+ $ok .= "\n";
+ print $ok;
+ $test_num++;
+ }
+
+
+ package main;
+
+ require Test::Simple;
+
+ @INC = ('../lib', 'lib/Test/Simple');
+ require Catch;
+ my($out, $err) = Catch::caught();
+
+ Test::Simple->import(tests => 5);
+
+ ok(1, 'Foo');
+ ok(0, 'Bar');
+
+ END {
+ My::Test::ok($$out eq <<OUT);
+ 1..5
+ ok 1 - Foo
+ not ok 2 - Bar
+ OUT
+
+ My::Test::ok($$err eq <<ERR);
+ # Failed test ($0 at line 31)
+ # Looks like you planned 5 tests but only ran 2.
+ ERR
+
+ exit 0;
+ }
diff -c /dev/null 'perl-5.7.2/lib/Test/Simple/t/no_plan.t'
Index: ./lib/Test/Simple/t/no_plan.t
*** ./lib/Test/Simple/t/no_plan.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/Simple/t/no_plan.t Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,64 ----
+ # Can't use Test.pm, that's a 5.005 thing.
+ package My::Test;
+
+ print "1..12\n";
+
+ my $test_num = 1;
+ # Utility testing functions.
+ sub ok ($;$) {
+ my($test, $name) = @_;
+ my $ok = '';
+ $ok .= "not " unless $test;
+ $ok .= "ok $test_num";
+ $ok .= " - $name" if defined $name;
+ $ok .= "\n";
+ print $ok;
+ $test_num++;
+ }
+
+
+ package main;
+
+ require Test::Simple;
+
+ @INC = ('../lib', 'lib/Test/Simple');
+ require Catch;
+ my($out, $err) = Catch::caught();
+
+ eval {
+ Test::Simple->import;
+ };
+
+ My::Test::ok($$out eq '');
+ My::Test::ok($$err eq '');
+ My::Test::ok($@ eq '');
+
+ eval {
+ Test::Simple->import(tests => undef);
+ };
+
+ My::Test::ok($$out eq '');
+ My::Test::ok($$err eq '');
+ My::Test::ok($@ =~ /Got an undefined number of tests/);
+
+ eval {
+ Test::Simple->import(tests => 0);
+ };
+
+ My::Test::ok($$out eq '');
+ My::Test::ok($$err eq '');
+ My::Test::ok($@ =~ /You told Test::Simple you plan to run 0 tests!/);
+
+ eval {
+ Test::Simple::ok(1);
+ };
+ My::Test::ok( $@ =~ /You tried to use ok\(\) without a plan!/);
+
+
+ END {
+ My::Test::ok($$out eq '');
+ My::Test::ok($$err eq "");
+
+ # Prevent Test::Simple from exiting with non zero.
+ exit 0;
+ }
diff -c /dev/null 'perl-5.7.2/lib/Test/Simple/t/plan_is_noplan.t'
Index: ./lib/Test/Simple/t/plan_is_noplan.t
*** ./lib/Test/Simple/t/plan_is_noplan.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/Simple/t/plan_is_noplan.t Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,54 ----
+ # Can't use Test.pm, that's a 5.005 thing.
+ package My::Test;
+
+ # This feature requires a fairly new version of Test::Harness
+ BEGIN {
+ require Test::Harness;
+ if( $Test::Harness::VERSION < 1.20 ) {
+ print "1..0\n";
+ exit(0);
+ }
+ }
+
+ print "1..2\n";
+
+ my $test_num = 1;
+ # Utility testing functions.
+ sub ok ($;$) {
+ my($test, $name) = @_;
+ my $ok = '';
+ $ok .= "not " unless $test;
+ $ok .= "ok $test_num";
+ $ok .= " - $name" if defined $name;
+ $ok .= "\n";
+ print $ok;
+ $test_num++;
+ }
+
+
+ package main;
+
+ require Test::Simple;
+
+ @INC = ('../lib', 'lib/Test/Simple');
+ require Catch;
+ my($out, $err) = Catch::caught();
+
+
+ Test::Simple->import('no_plan');
+
+ ok(1, 'foo');
+
+
+ END {
+ My::Test::ok($$out eq <<OUT);
+ ok 1 - foo
+ 1..1
+ OUT
+
+ My::Test::ok($$err eq <<ERR);
+ ERR
+
+ # Prevent Test::Simple from exiting with non zero
+ exit 0;
+ }
diff -c /dev/null 'perl-5.7.2/lib/Test/Simple/t/simple.t'
Index: ./lib/Test/Simple/t/simple.t
*** ./lib/Test/Simple/t/simple.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/Simple/t/simple.t Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,10 ----
+ use strict;
+
+ BEGIN { $| = 1; $^W = 1; }
+
+ use Test::Simple tests => 3;
+
+ ok(1, 'compile');
+
+ ok(1);
+ ok(1, 'foo');
diff -c /dev/null 'perl-5.7.2/lib/Test/t/fail.t'
Index: ./lib/Test/t/fail.t
*** ./lib/Test/t/fail.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/t/fail.t Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,93 ----
+ # -*-perl-*-
+ use strict;
+ use vars qw($Expect);
+ use Test qw($TESTOUT $ntest ok skip plan);
+ plan tests => 14;
+
+ open F, ">fails";
+ $TESTOUT = *F{IO};
+
+ my $r=0;
+ {
+ # Shut up deprecated usage warning.
+ local $^W = 0;
+ $r |= skip(0,0);
+ }
+ $r |= ok(0);
+ $r |= ok(0,1);
+ $r |= ok(sub { 1+1 }, 3);
+ $r |= ok(sub { 1+1 }, sub { 2 * 0});
+
+ my @list = (0,0);
+ $r |= ok @list, 1, "\@list=".join(',',@list);
+ $r |= ok @list, 1, sub { "\@list=".join ',',@list };
+ $r |= ok 'segmentation fault', '/bongo/';
+
+ for (1..2) { $r |= ok(0); }
+
+ $r |= ok(1, undef);
+ $r |= ok(undef, 1);
+
+ ok($r); # (failure==success :-)
+
+ close F;
+ $TESTOUT = *STDOUT{IO};
+ $ntest = 1;
+
+ open F, "fails";
+ my $O;
+ while (<F>) { $O .= $_; }
+ close F;
+ unlink "fails";
+
+ ok join(' ', map { m/(\d+)/; $1 } grep /^not ok/, split /\n+/, $O),
+ join(' ', 1..13);
+
+ my @got = split /not ok \d+\n/, $O;
+ shift @got;
+
+ $Expect =~ s/\n+$//;
+ my @expect = split /\n\n/, $Expect;
+
+ for (my $x=0; $x < @got; $x++) {
+ ok $got[$x], $expect[$x]."\n";
+ }
+
+
+ BEGIN {
+ $Expect = <<"EXPECT";
+ # Failed test 1 in $0 at line 14
+
+ # Failed test 2 in $0 at line 16
+
+ # Test 3 got: '0' ($0 at line 17)
+ # Expected: '1'
+
+ # Test 4 got: '2' ($0 at line 18)
+ # Expected: '3'
+
+ # Test 5 got: '2' ($0 at line 19)
+ # Expected: '0'
+
+ # Test 6 got: '2' ($0 at line 22)
+ # Expected: '1' (\@list=0,0)
+
+ # Test 7 got: '2' ($0 at line 23)
+ # Expected: '1' (\@list=0,0)
+
+ # Test 8 got: 'segmentation fault' ($0 at line 24)
+ # Expected: qr{bongo}
+
+ # Failed test 9 in $0 at line 26
+
+ # Failed test 10 in $0 at line 26 fail #2
+
+ # Failed test 11 in $0 at line 28
+
+ # Test 12 got: <UNDEF> ($0 at line 29)
+ # Expected: '1'
+
+ # Failed test 13 in $0 at line 31
+ EXPECT
+
+ }
diff -c /dev/null 'perl-5.7.2/lib/Test/t/mix.t'
Index: ./lib/Test/t/mix.t
*** ./lib/Test/t/mix.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/t/mix.t Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,17 ----
+ # -*-perl-*-
+ use strict;
+ use Test;
+ BEGIN { plan tests => 4, todo => [2,3] }
+
+ ok(sub {
+ my $r = 0;
+ for (my $x=0; $x < 10; $x++) {
+ $r += $x*($r+1);
+ }
+ $r
+ }, 3628799);
+
+ ok(0);
+ ok(1);
+
+ skip(1,0);
diff -c /dev/null 'perl-5.7.2/lib/Test/t/onfail.t'
Index: ./lib/Test/t/onfail.t
*** ./lib/Test/t/onfail.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/t/onfail.t Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,31 ----
+ # -*-perl-*-
+
+ use strict;
+ use Test qw($ntest plan ok $TESTOUT);
+ use vars qw($mycnt);
+
+ BEGIN { plan test => 6, onfail => \&myfail }
+
+ $mycnt = 0;
+
+ my $why = "zero != one";
+ # sneak in a test that Test::Harness wont see
+ open J, ">junk";
+ $TESTOUT = *J{IO};
+ ok(0, 1, $why);
+ $TESTOUT = *STDOUT{IO};
+ close J;
+ unlink "junk";
+ $ntest = 1;
+
+ sub myfail {
+ my ($f) = @_;
+ ok(@$f, 1);
+
+ my $t = $$f[0];
+ ok($$t{diagnostic}, $why);
+ ok($$t{'package'}, 'main');
+ ok($$t{repetition}, 1);
+ ok($$t{result}, 0);
+ ok($$t{expected}, 1);
+ }
diff -c /dev/null 'perl-5.7.2/lib/Test/t/qr.t'
Index: ./lib/Test/t/qr.t
*** ./lib/Test/t/qr.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/t/qr.t Mon Jul 9 17:10:43 2001
***************
*** 0 ****
--- 1,13 ----
+ #!./perl -w
+
+ use strict;
+ BEGIN {
+ if ($] < 5.005) {
+ print "1..0\n";
+ print "ok 1 # skipped; this test requires at least perl 5.005\n";
+ exit;
+ }
+ }
+ use Test; plan tests => 1;
+
+ ok 'abc', qr/b/;
diff -c /dev/null 'perl-5.7.2/lib/Test/t/skip.t'
Index: ./lib/Test/t/skip.t
*** ./lib/Test/t/skip.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/t/skip.t Mon Jul 9 17:10:44 2001
***************
*** 0 ****
--- 1,40 ----
+ # -*-perl-*-
+ use strict;
+ use Test qw($TESTOUT $ntest plan ok skip); plan tests => 6;
+
+ open F, ">skips" or die "open skips: $!";
+ $TESTOUT = *F{IO};
+
+ skip(1, 0); #should skip
+
+ my $skipped=1;
+ skip('hop', sub { $skipped = 0 });
+ skip(sub {'jump'}, sub { $skipped = 0 });
+ skip('skipping stones is more fun', sub { $skipped = 0 });
+
+ close F;
+
+ $TESTOUT = *STDOUT{IO};
+ $ntest = 1;
+ open F, "skips" or die "open skips: $!";
+
+ ok $skipped, 1, 'not skipped?';
+
+ my @T = <F>;
+ chop @T;
+ my @expect = split /\n+/, join('',<DATA>);
+ ok @T, 4;
+ for (my $x=0; $x < @T; $x++) {
+ ok $T[$x], $expect[$x];
+ }
+
+ END { close F; unlink "skips" }
+
+ __DATA__
+ ok 1 # skip
+
+ ok 2 # skip hop
+
+ ok 3 # skip jump
+
+ ok 4 # skip skipping stones is more fun
diff -c /dev/null 'perl-5.7.2/lib/Test/t/success.t'
Index: ./lib/Test/t/success.t
*** ./lib/Test/t/success.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/t/success.t Mon Jul 9 17:10:44 2001
***************
*** 0 ****
--- 1,11 ----
+ # -*-perl-*-
+ use strict;
+ use Test;
+ BEGIN { plan tests => 11 }
+
+ ok(ok(1));
+ ok(ok('fixed', 'fixed'));
+ ok(skip(1,0));
+ ok(undef, undef);
+ ok(ok 'the brown fox jumped over the lazy dog', '/lazy/');
+ ok(ok 'the brown fox jumped over the lazy dog', 'm,fox,');
diff -c /dev/null 'perl-5.7.2/lib/Test/t/todo.t'
Index: ./lib/Test/t/todo.t
*** ./lib/Test/t/todo.t Thu Jan 1 02:00:00 1970
--- ./lib/Test/t/todo.t Mon Jul 9 17:10:44 2001
***************
*** 0 ****
--- 1,13 ----
+ # -*-perl-*-
+ use strict;
+ use Test;
+ BEGIN {
+ my $tests = 5;
+ plan tests => $tests, todo => [1..$tests];
+ }
+
+ ok(0);
+ ok(1);
+ ok(0,1);
+ ok(0,1,"need more tuits");
+ ok(1,1);
diff -c /dev/null 'perl-5.7.2/lib/Text/Abbrev.t'
Index: ./lib/Text/Abbrev.t
*** ./lib/Text/Abbrev.t Thu Jan 1 02:00:00 1970
--- ./lib/Text/Abbrev.t Mon Jul 9 17:10:44 2001
***************
*** 0 ****
--- 1,51 ----
+ #!./perl
+
+ print "1..7\n";
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use Text::Abbrev;
+
+ print "ok 1\n";
+
+ # old style as reference
+ local(%x);
+ my @z = qw(list edit send abort gripe listen);
+ abbrev(*x, @z);
+ my $r = join ':', sort keys %x;
+ print "not " if exists $x{'l'} ||
+ exists $x{'li'} ||
+ exists $x{'lis'};
+ print "ok 2\n";
+
+ print "not " unless $x{'list'} eq 'list' &&
+ $x{'liste'} eq 'listen' &&
+ $x{'listen'} eq 'listen';
+ print "ok 3\n";
+
+ print "not " unless $x{'a'} eq 'abort' &&
+ $x{'ab'} eq 'abort' &&
+ $x{'abo'} eq 'abort' &&
+ $x{'abor'} eq 'abort' &&
+ $x{'abort'} eq 'abort';
+ print "ok 4\n";
+
+ my $test = 5;
+
+ # wantarray
+ my %y = abbrev @z;
+ my $s = join ':', sort keys %y;
+ print (($r eq $s)?"ok $test\n":"not ok $test\n"); $test++;
+
+ my $y = abbrev @z;
+ $s = join ':', sort keys %$y;
+ print (($r eq $s)?"ok $test\n":"not ok $test\n"); $test++;
+
+ %y = ();
+ abbrev \%y, @z;
+
+ $s = join ':', sort keys %y;
+ print (($r eq $s)?"ok $test\n":"not ok $test\n"); $test++;
diff -c 'perl-5.7.1/lib/Text/Balanced.pm' 'perl-5.7.2/lib/Text/Balanced.pm'
Index: ./lib/Text/Balanced.pm
*** ./lib/Text/Balanced.pm Tue Mar 13 02:48:54 2001
--- ./lib/Text/Balanced.pm Mon Jul 9 17:10:44 2001
***************
*** 10,16 ****
use SelfLoader;
use vars qw { $VERSION @ISA %EXPORT_TAGS };
! $VERSION = '1.83';
@ISA = qw ( Exporter );
%EXPORT_TAGS = ( ALL => [ qw(
--- 10,16 ----
use SelfLoader;
use vars qw { $VERSION @ISA %EXPORT_TAGS };
! $VERSION = '1.85';
@ISA = qw ( Exporter );
%EXPORT_TAGS = ( ALL => [ qw(
***************
*** 233,239 ****
}
elsif ($qdel && $$textref =~ m/\G([$qdel])/gc)
{
! $$textref =~ m/\G[^\\$1]*(?:\\.[^\\$1]*)*(\Q$1\E)/gc and next;
_failmsg "Unmatched embedded quote ($1)",
pos $$textref;
pos $$textref = $startpos;
--- 233,239 ----
}
elsif ($qdel && $$textref =~ m/\G([$qdel])/gc)
{
! $$textref =~ m/\G[^\\$1]*(?:\\.[^\\$1]*)*(\Q$1\E)/gsc and next;
_failmsg "Unmatched embedded quote ($1)",
pos $$textref;
pos $$textref = $startpos;
***************
*** 455,461 ****
while (1)
{
next if _match_codeblock($textref,
! qr/\s*->\s*(?:[a-zA-Z]\w+\s*)?/,
qr/[({[]/, qr/[)}\]]/,
qr/[({[]/, qr/[)}\]]/, 0);
next if _match_codeblock($textref,
--- 455,461 ----
while (1)
{
next if _match_codeblock($textref,
! qr/\s*->\s*(?:[_a-zA-Z]\w+\s*)?/,
qr/[({[]/, qr/[)}\]]/,
qr/[({[]/, qr/[)}\]]/, 0);
next if _match_codeblock($textref,
***************
*** 667,673 ****
|| $rawmatch && $initial =~ m|^/|
|| $qmark && $initial =~ m|^\?|)
{
! unless ($$textref =~ m/ \Q$initial\E [^\\$initial]* (\\.[^\\$initial]*)* \Q$initial\E /gcx)
{
_failmsg qq{Did not find closing delimiter to match '$initial' at "} .
substr($$textref, $oppos, 20) .
--- 667,673 ----
|| $rawmatch && $initial =~ m|^/|
|| $qmark && $initial =~ m|^\?|)
{
! unless ($$textref =~ m/ \Q$initial\E [^\\$initial]* (\\.[^\\$initial]*)* \Q$initial\E /gcsx)
{
_failmsg qq{Did not find closing delimiter to match '$initial' at "} .
substr($$textref, $oppos, 20) .
***************
*** 720,726 ****
elsif ($$textref =~ m{ \G ' ([^'\\]* (?:\\.[^'\\]*)*) '
| \G " ([^"\\]* (?:\\.[^"\\]*)*) "
| \G ` ([^`\\]* (?:\\.[^`\\]*)*) `
! }gcx) {
$label = $+;
}
else {
--- 720,726 ----
elsif ($$textref =~ m{ \G ' ([^'\\]* (?:\\.[^'\\]*)*) '
| \G " ([^"\\]* (?:\\.[^"\\]*)*) "
| \G ` ([^`\\]* (?:\\.[^`\\]*)*) `
! }gcsx) {
$label = $+;
}
else {
***************
*** 776,782 ****
}
else
{
! $$textref =~ /$ldel1[^\\$ldel1]*(\\.[^\\$ldel1]*)*$ldel1/gc
|| do { pos $$textref = $startpos; return };
}
$ld2pos = $rd1pos = pos($$textref)-1;
--- 776,782 ----
}
else
{
! $$textref =~ /$ldel1[^\\$ldel1]*(\\.[^\\$ldel1]*)*$ldel1/gcs
|| do { pos $$textref = $startpos; return };
}
$ld2pos = $rd1pos = pos($$textref)-1;
***************
*** 811,817 ****
}
else
{
! $$textref =~ /[^\\$ldel2]*(\\.[^\\$ldel2]*)*$ldel2/gc
|| do { pos $$textref = $startpos; return };
}
$rd2pos = pos($$textref)-1;
--- 811,817 ----
}
else
{
! $$textref =~ /[^\\$ldel2]*(\\.[^\\$ldel2]*)*$ldel2/gcs
|| do { pos $$textref = $startpos; return };
}
$rd2pos = pos($$textref)-1;
diff -c /dev/null 'perl-5.7.2/lib/Text/Balanced/t/genxt.t'
Index: ./lib/Text/Balanced/t/genxt.t
*** ./lib/Text/Balanced/t/genxt.t Thu Jan 1 02:00:00 1970
--- ./lib/Text/Balanced/t/genxt.t Mon Jul 9 17:10:44 2001
***************
*** 0 ****
--- 1,104 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # Before `make install' is performed this script should be runnable with
+ # `make test'. After `make install' it should work as `perl test.pl'
+
+ ######################### We start with some black magic to print on failure.
+
+ # Change 1..1 below to 1..last_test_to_print .
+ # (It may become useful if the test is moved to ./t subdirectory.)
+
+ BEGIN { $| = 1; print "1..35\n"; }
+ END {print "not ok 1\n" unless $loaded;}
+ use Text::Balanced qw ( gen_extract_tagged );
+ $loaded = 1;
+ print "ok 1\n";
+ $count=2;
+ use vars qw( $DEBUG );
+ sub debug { print "\t>>>",@_ if $DEBUG }
+
+ ######################### End of black magic.
+
+
+ $cmd = "print";
+ $neg = 0;
+ while (defined($str = <DATA>))
+ {
+ chomp $str;
+ $str =~ s/\\n/\n/g;
+ if ($str =~ s/\A# USING://)
+ {
+ $neg = 0;
+ eval{local$^W;*f = eval $str || die};
+ next;
+ }
+ elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
+ elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
+ $str =~ s/\\n/\n/g;
+ debug "\tUsing: $cmd\n";
+ debug "\t on: [$str]\n";
+
+ my @res;
+ $var = eval { @res = f($str) };
+ debug "\t list got: [" . join("|",@res) . "]\n";
+ debug "\t list left: [$str]\n";
+ print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+
+ pos $str = 0;
+ $var = eval { scalar f($str) };
+ $var = "<undef>" unless defined $var;
+ debug "\t scalar got: [$var]\n";
+ debug "\t scalar left: [$str]\n";
+ print "not " if ($str =~ '\A;')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+ }
+
+ __DATA__
+
+ # USING: gen_extract_tagged(qr/<[A-Z]+>/,undef, undef, {ignore=>["<BR>"]});
+ <A>aaa<B>bbb<BR>ccc</B>ddd</A>;
+
+ # USING: gen_extract_tagged("BEGIN","END");
+ BEGIN at the BEGIN keyword and END at the END;
+ BEGIN at the beginning and end at the END;
+
+ # USING: gen_extract_tagged(undef,undef,undef,{ignore=>["<[^>]*/>"]});
+ <A>aaa<B>bbb<BR/>ccc</B>ddd</A>;
+
+ # USING: gen_extract_tagged(";","-",undef,{reject=>[";"],fail=>"MAX"});
+ ; at the ;-) keyword
+
+ # USING: gen_extract_tagged("<[A-Z]+>",undef, undef, {ignore=>["<BR>"]});
+ <A>aaa<B>bbb<BR>ccc</B>ddd</A>;
+
+ # THESE SHOULD FAIL
+ BEGIN at the beginning and end at the end;
+ BEGIN at the BEGIN keyword and END at the end;
+
+ # TEST EXTRACTION OF TAGGED STRINGS
+ # USING: gen_extract_tagged("BEGIN","END",undef,{reject=>["BEGIN","END"]});
+ # THESE SHOULD FAIL
+ BEGIN at the BEGIN keyword and END at the end;
+
+ # USING: gen_extract_tagged(";","-",undef,{reject=>[";"],fail=>"PARA"});
+ ; at the ;-) keyword
+
+
+ # USING: gen_extract_tagged();
+ <A>some text</A>;
+ <B>some text<A>other text</A></B>;
+ <A>some text<A>other text</A></A>;
+ <A HREF="#section2">some text</A>;
+
+ # THESE SHOULD FAIL
+ <A>some text
+ <A>some text<A>other text</A>;
+ <B>some text<A>other text</B>;
diff -c /dev/null 'perl-5.7.2/lib/Text/Balanced/t/xbrak.t'
Index: ./lib/Text/Balanced/t/xbrak.t
*** ./lib/Text/Balanced/t/xbrak.t Thu Jan 1 02:00:00 1970
--- ./lib/Text/Balanced/t/xbrak.t Mon Jul 9 17:10:44 2001
***************
*** 0 ****
--- 1,81 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # Before `make install' is performed this script should be runnable with
+ # `make test'. After `make install' it should work as `perl test.pl'
+
+ ######################### We start with some black magic to print on failure.
+
+ # Change 1..1 below to 1..last_test_to_print .
+ # (It may become useful if the test is moved to ./t subdirectory.)
+
+ BEGIN { $| = 1; print "1..19\n"; }
+ END {print "not ok 1\n" unless $loaded;}
+ use Text::Balanced qw ( extract_bracketed );
+ $loaded = 1;
+ print "ok 1\n";
+ $count=2;
+ use vars qw( $DEBUG );
+ sub debug { print "\t>>>",@_ if $DEBUG }
+
+ ######################### End of black magic.
+
+
+ $cmd = "print";
+ $neg = 0;
+ while (defined($str = <DATA>))
+ {
+ chomp $str;
+ if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
+ elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
+ elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
+ $str =~ s/\\n/\n/g;
+ debug "\tUsing: $cmd\n";
+ debug "\t on: [$str]\n";
+
+ $var = eval "() = $cmd";
+ debug "\t list got: [$var]\n";
+ debug "\t list left: [$str]\n";
+ print "not " if (substr($str,pos($str),1) eq ';')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+
+ pos $str = 0;
+ $var = eval $cmd;
+ $var = "<undef>" unless defined $var;
+ debug "\t scalar got: [$var]\n";
+ debug "\t scalar left: [$str]\n";
+ print "not " if ($str =~ '\A;')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+ }
+
+ __DATA__
+
+ # USING: extract_bracketed($str);
+ {a nested { and } are okay as are () and <> pairs and escaped \}'s };
+ {a nested\n{ and } are okay as are\n() and <> pairs and escaped \}'s };
+
+ # USING: extract_bracketed($str,'{}');
+ {a nested { and } are okay as are unbalanced ( and < pairs and escaped \}'s };
+
+ # THESE SHOULD FAIL
+ {an unmatched nested { isn't okay, nor are ( and < };
+ {an unbalanced nested [ even with } and ] to match them;
+
+
+ # USING: extract_bracketed($str,'<"`q>');
+ <a q{uoted} ">" unbalanced right bracket of /(q>)/ either sort (`>>>""">>>>`) is okay >;
+
+ # USING: extract_bracketed($str,'<">');
+ <a quoted ">" unbalanced right bracket is okay >;
+
+ # USING: extract_bracketed($str,'<"`>');
+ <a quoted ">" unbalanced right bracket of either sort (`>>>""">>>>`) is okay >;
+
+ # THIS SHOULD FAIL
+ <a misquoted '>' unbalanced right bracket is bad >;
diff -c /dev/null 'perl-5.7.2/lib/Text/Balanced/t/xcode.t'
Index: ./lib/Text/Balanced/t/xcode.t
*** ./lib/Text/Balanced/t/xcode.t Thu Jan 1 02:00:00 1970
--- ./lib/Text/Balanced/t/xcode.t Mon Jul 9 17:10:44 2001
***************
*** 0 ****
--- 1,94 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # Before `make install' is performed this script should be runnable with
+ # `make test'. After `make install' it should work as `perl test.pl'
+
+ ######################### We start with some black magic to print on failure.
+
+ # Change 1..1 below to 1..last_test_to_print .
+ # (It may become useful if the test is moved to ./t subdirectory.)
+
+ BEGIN { $| = 1; print "1..37\n"; }
+ END {print "not ok 1\n" unless $loaded;}
+ use Text::Balanced qw ( extract_codeblock );
+ $loaded = 1;
+ print "ok 1\n";
+ $count=2;
+ use vars qw( $DEBUG );
+ sub debug { print "\t>>>",@_ if $DEBUG }
+
+ ######################### End of black magic.
+
+
+ $cmd = "print";
+ $neg = 0;
+ while (defined($str = <DATA>))
+ {
+ chomp $str;
+ if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
+ elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
+ elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
+ $str =~ s/\\n/\n/g;
+ debug "\tUsing: $cmd\n";
+ debug "\t on: [$str]\n";
+
+ my @res;
+ $var = eval "\@res = $cmd";
+ debug "\t Failed: $@ at " . $@+0 .")" if $@;
+ debug "\t list got: [" . join("|",@res) . "]\n";
+ debug "\t list left: [$str]\n";
+ print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
+ print "ok ", $count++;
+ print "\n";
+
+ pos $str = 0;
+ $var = eval $cmd;
+ $var = "<undef>" unless defined $var;
+ debug "\t scalar got: [$var]\n";
+ debug "\t scalar left: [$str]\n";
+ print "not " if ($str =~ '\A;')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+ }
+
+ __DATA__
+
+ # USING: extract_codeblock($str,'<>');
+ < %x = ( try => "this") >;
+ < %x = () >;
+ < %x = ( $try->{this}, "too") >;
+ < %'x = ( $try->{this}, "too") >;
+ < %'x'y = ( $try->{this}, "too") >;
+ < %::x::y = ( $try->{this}, "too") >;
+
+ # THIS SHOULD FAIL
+ < %x = do { $try > 10 } >;
+
+ # USING: extract_codeblock($str);
+
+ { $a = /\}/; };
+ { sub { $_[0] /= $_[1] } }; # / here
+ { 1; };
+ { $a = 1; };
+
+
+ # USING: extract_codeblock($str,undef,'=*');
+ ========{$a=1};
+
+ # USING: extract_codeblock($str,'{}<>');
+ < %x = do { $try > 10 } >;
+
+ # USING: extract_codeblock($str,'{}',undef,'<>');
+ < %x = do { $try > 10 } >;
+
+ # USING: extract_codeblock($str,'{}');
+ { $a = $b; # what's this doing here? \n };'
+ { $a = $b; \n $a =~ /$b/; \n @a = map /\s/ @b };
+
+ # THIS SHOULD FAIL
+ { $a = $b; # what's this doing here? };'
+ { $a = $b; # what's this doing here? ;'
diff -c /dev/null 'perl-5.7.2/lib/Text/Balanced/t/xdeli.t'
Index: ./lib/Text/Balanced/t/xdeli.t
*** ./lib/Text/Balanced/t/xdeli.t Thu Jan 1 02:00:00 1970
--- ./lib/Text/Balanced/t/xdeli.t Mon Jul 9 17:10:44 2001
***************
*** 0 ****
--- 1,95 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # Before `make install' is performed this script should be runnable with
+ # `make test'. After `make install' it should work as `perl test.pl'
+
+ ######################### We start with some black magic to print on failure.
+
+ # Change 1..1 below to 1..last_test_to_print .
+ # (It may become useful if the test is moved to ./t subdirectory.)
+
+ BEGIN { $| = 1; print "1..45\n"; }
+ END {print "not ok 1\n" unless $loaded;}
+ use Text::Balanced qw ( extract_delimited );
+ $loaded = 1;
+ print "ok 1\n";
+ $count=2;
+ use vars qw( $DEBUG );
+ sub debug { print "\t>>>",@_ if $DEBUG }
+
+ ######################### End of black magic.
+
+
+ $cmd = "print";
+ $neg = 0;
+ while (defined($str = <DATA>))
+ {
+ chomp $str;
+ if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
+ elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
+ elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
+ $str =~ s/\\n/\n/g;
+ debug "\tUsing: $cmd\n";
+ debug "\t on: [$str]\n";
+
+ $var = eval "() = $cmd";
+ debug "\t list got: [$var]\n";
+ debug "\t list left: [$str]\n";
+ print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+
+ pos $str = 0;
+ $var = eval $cmd;
+ $var = "<undef>" unless defined $var;
+ debug "\t scalar got: [$var]\n";
+ debug "\t scalar left: [$str]\n";
+ print "not " if ($str =~ '\A;')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+ }
+
+ __DATA__
+ # USING: extract_delimited($str,'/#$',undef,'/#$');
+ /a/;
+ /a///;
+ #b#;
+ #b###;
+ $c$;
+ $c$$$;
+
+ # TEST EXTRACTION OF DELIMITED TEXT WITH ESCAPES
+ # USING: extract_delimited($str,'/#$',undef,'\\');
+ /a/;
+ /a\//;
+ #b#;
+ #b\##;
+ $c$;
+ $c\$$;
+
+ # TEST EXTRACTION OF DELIMITED TEXT
+ # USING: extract_delimited($str);
+ 'a';
+ "b";
+ `c`;
+ 'a\'';
+ 'a\\';
+ '\\a';
+ "a\\";
+ "\\a";
+ "b\'\"\'";
+ `c '\`abc\`'`;
+
+ # TEST EXTRACTION OF DELIMITED TEXT
+ # USING: extract_delimited($str,'/#$','-->');
+ -->/a/;
+ -->#b#;
+ -->$c$;
+
+ # THIS SHOULD FAIL
+ $c$;
diff -c /dev/null 'perl-5.7.2/lib/Text/Balanced/t/xmult.t'
Index: ./lib/Text/Balanced/t/xmult.t
*** ./lib/Text/Balanced/t/xmult.t Thu Jan 1 02:00:00 1970
--- ./lib/Text/Balanced/t/xmult.t Mon Jul 9 17:10:44 2001
***************
*** 0 ****
--- 1,316 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # Before `make install' is performed this script should be runnable with
+ # `make test'. After `make install' it should work as `perl test.pl'
+
+ ######################### We start with some black magic to print on failure.
+
+ # Change 1..1 below to 1..last_test_to_print .
+ # (It may become useful if the test is moved to ./t subdirectory.)
+
+ BEGIN { $| = 1; print "1..85\n"; }
+ END {print "not ok 1\n" unless $loaded;}
+ use Text::Balanced qw ( :ALL );
+ $loaded = 1;
+ print "ok 1\n";
+ $count=2;
+ use vars qw( $DEBUG );
+ sub debug { print "\t>>>",@_ if $DEBUG }
+
+ ######################### End of black magic.
+
+ sub expect
+ {
+ local $^W;
+ my ($l1, $l2) = @_;
+
+ if (@$l1 != @$l2)
+ {
+ print "\@l1: ", join(", ", @$l1), "\n";
+ print "\@l2: ", join(", ", @$l2), "\n";
+ print "not ";
+ }
+ else
+ {
+ for (my $i = 0; $i < @$l1; $i++)
+ {
+ if ($l1->[$i] ne $l2->[$i])
+ {
+ print "field $i: '$l1->[$i]' ne '$l2->[$i]'\n";
+ print "not ";
+ last;
+ }
+ }
+ }
+
+ print "ok $count\n";
+ $count++;
+ }
+
+ sub divide
+ {
+ my ($text, @index) = @_;
+ my @bits = ();
+ unshift @index, 0;
+ push @index, length($text);
+ for ( my $i= 0; $i < $#index; $i++)
+ {
+ push @bits, substr($text, $index[$i], $index[$i+1]-$index[$i]);
+ }
+ pop @bits;
+ return @bits;
+
+ }
+
+
+ $stdtext1 = q{$var = do {"val" && $val;};};
+
+ # TESTS 2-4
+ $text = $stdtext1;
+ expect [ extract_multiple($text,undef,1) ],
+ [ divide $stdtext1 => 4 ];
+
+ expect [ pos $text], [ 4 ];
+ expect [ $text ], [ $stdtext1 ];
+
+ # TESTS 5-7
+ $text = $stdtext1;
+ expect [ scalar extract_multiple($text,undef,1) ],
+ [ divide $stdtext1 => 4 ];
+
+ expect [ pos $text], [ 0 ];
+ expect [ $text ], [ substr($stdtext1,4) ];
+
+
+ # TESTS 8-10
+ $text = $stdtext1;
+ expect [ extract_multiple($text,undef,2) ],
+ [ divide($stdtext1 => 4, 10) ];
+
+ expect [ pos $text], [ 10 ];
+ expect [ $text ], [ $stdtext1 ];
+
+ # TESTS 11-13
+ $text = $stdtext1;
+ expect [ eval{local$^W;scalar extract_multiple($text,undef,2)} ],
+ [ substr($stdtext1,0,4) ];
+
+ expect [ pos $text], [ 0 ];
+ expect [ $text ], [ substr($stdtext1,4) ];
+
+
+ # TESTS 14-16
+ $text = $stdtext1;
+ expect [ extract_multiple($text,undef,3) ],
+ [ divide($stdtext1 => 4, 10, 26) ];
+
+ expect [ pos $text], [ 26 ];
+ expect [ $text ], [ $stdtext1 ];
+
+ # TESTS 17-19
+ $text = $stdtext1;
+ expect [ eval{local$^W;scalar extract_multiple($text,undef,3)} ],
+ [ substr($stdtext1,0,4) ];
+
+ expect [ pos $text], [ 0 ];
+ expect [ $text ], [ substr($stdtext1,4) ];
+
+
+ # TESTS 20-22
+ $text = $stdtext1;
+ expect [ extract_multiple($text,undef,4) ],
+ [ divide($stdtext1 => 4, 10, 26, 27) ];
+
+ expect [ pos $text], [ 27 ];
+ expect [ $text ], [ $stdtext1 ];
+
+ # TESTS 23-25
+ $text = $stdtext1;
+ expect [ eval{local$^W;scalar extract_multiple($text,undef,4)} ],
+ [ substr($stdtext1,0,4) ];
+
+ expect [ pos $text], [ 0 ];
+ expect [ $text ], [ substr($stdtext1,4) ];
+
+
+ # TESTS 26-28
+ $text = $stdtext1;
+ expect [ extract_multiple($text,undef,5) ],
+ [ divide($stdtext1 => 4, 10, 26, 27) ];
+
+ expect [ pos $text], [ 27 ];
+ expect [ $text ], [ $stdtext1 ];
+
+
+ # TESTS 29-31
+ $text = $stdtext1;
+ expect [ eval{local$^W;scalar extract_multiple($text,undef,5)} ],
+ [ substr($stdtext1,0,4) ];
+
+ expect [ pos $text], [ 0 ];
+ expect [ $text ], [ substr($stdtext1,4) ];
+
+
+
+ # TESTS 32-34
+ $stdtext2 = q{$var = "val" && (1,2,3);};
+
+ $text = $stdtext2;
+ expect [ extract_multiple($text) ],
+ [ divide($stdtext2 => 4, 7, 12, 24) ];
+
+ expect [ pos $text], [ 24 ];
+ expect [ $text ], [ $stdtext2 ];
+
+ # TESTS 35-37
+ $text = $stdtext2;
+ expect [ scalar extract_multiple($text) ],
+ [ substr($stdtext2,0,4) ];
+
+ expect [ pos $text], [ 0 ];
+ expect [ $text ], [ substr($stdtext2,4) ];
+
+
+ # TESTS 38-40
+ $text = $stdtext2;
+ expect [ extract_multiple($text,[\&extract_bracketed]) ],
+ [ substr($stdtext2,0,15), substr($stdtext2,16,7), substr($stdtext2,23) ];
+
+ expect [ pos $text], [ 24 ];
+ expect [ $text ], [ $stdtext2 ];
+
+ # TESTS 41-43
+ $text = $stdtext2;
+ expect [ scalar extract_multiple($text,[\&extract_bracketed]) ],
+ [ substr($stdtext2,0,15) ];
+
+ expect [ pos $text], [ 0 ];
+ expect [ $text ], [ substr($stdtext2,15) ];
+
+
+ # TESTS 44-46
+ $text = $stdtext2;
+ expect [ extract_multiple($text,[\&extract_variable]) ],
+ [ substr($stdtext2,0,4), substr($stdtext2,4) ];
+
+ expect [ pos $text], [ length($text) ];
+ expect [ $text ], [ $stdtext2 ];
+
+ # TESTS 47-49
+ $text = $stdtext2;
+ expect [ scalar extract_multiple($text,[\&extract_variable]) ],
+ [ substr($stdtext2,0,4) ];
+
+ expect [ pos $text], [ 0 ];
+ expect [ $text ], [ substr($stdtext2,4) ];
+
+
+ # TESTS 50-52
+ $text = $stdtext2;
+ expect [ extract_multiple($text,[\&extract_quotelike]) ],
+ [ substr($stdtext2,0,6), substr($stdtext2,7,5), substr($stdtext2,12) ];
+
+ expect [ pos $text], [ length($text) ];
+ expect [ $text ], [ $stdtext2 ];
+
+ # TESTS 53-55
+ $text = $stdtext2;
+ expect [ scalar extract_multiple($text,[\&extract_quotelike]) ],
+ [ substr($stdtext2,0,6) ];
+
+ expect [ pos $text], [ 0 ];
+ expect [ $text ], [ substr($stdtext2,6) ];
+
+
+ # TESTS 56-58
+ $text = $stdtext2;
+ expect [ extract_multiple($text,[\&extract_quotelike],2,1) ],
+ [ substr($stdtext2,7,5) ];
+
+ expect [ pos $text], [ 23 ];
+ expect [ $text ], [ $stdtext2 ];
+
+ # TESTS 59-61
+ $text = $stdtext2;
+ expect [ eval{local$^W;scalar extract_multiple($text,[\&extract_quotelike],2,1)} ],
+ [ substr($stdtext2,7,5) ];
+
+ expect [ pos $text], [ 6 ];
+ expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ];
+
+
+ # TESTS 62-64
+ $text = $stdtext2;
+ expect [ extract_multiple($text,[\&extract_quotelike],1,1) ],
+ [ substr($stdtext2,7,5) ];
+
+ expect [ pos $text], [ 12 ];
+ expect [ $text ], [ $stdtext2 ];
+
+ # TESTS 65-67
+ $text = $stdtext2;
+ expect [ scalar extract_multiple($text,[\&extract_quotelike],1,1) ],
+ [ substr($stdtext2,7,5) ];
+
+ expect [ pos $text], [ 6 ];
+ expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ];
+
+ # TESTS 68-70
+ my $stdtext3 = "a,b,c";
+
+ $_ = $stdtext3;
+ expect [ extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ],
+ [ divide($stdtext3 => 1,2,3,4,5) ];
+
+ expect [ pos ], [ 5 ];
+ expect [ $_ ], [ $stdtext3 ];
+
+ # TESTS 71-73
+
+ $_ = $stdtext3;
+ expect [ scalar extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ],
+ [ divide($stdtext3 => 1) ];
+
+ expect [ pos ], [ 0 ];
+ expect [ $_ ], [ substr($stdtext3,1) ];
+
+
+ # TESTS 74-76
+
+ $_ = $stdtext3;
+ expect [ extract_multiple(undef, [ qr/\G[a-z]/ ]) ],
+ [ divide($stdtext3 => 1,2,3,4,5) ];
+
+ expect [ pos ], [ 5 ];
+ expect [ $_ ], [ $stdtext3 ];
+
+ # TESTS 77-79
+
+ $_ = $stdtext3;
+ expect [ scalar extract_multiple(undef, [ qr/\G[a-z]/ ]) ],
+ [ divide($stdtext3 => 1) ];
+
+ expect [ pos ], [ 0 ];
+ expect [ $_ ], [ substr($stdtext3,1) ];
+
+
+ # TESTS 80-82
+
+ $_ = $stdtext3;
+ expect [ extract_multiple(undef, [ q/([a-z]),?/ ]) ],
+ [ qw(a b c) ];
+
+ expect [ pos ], [ 5 ];
+ expect [ $_ ], [ $stdtext3 ];
+
+ # TESTS 83-85
+
+ $_ = $stdtext3;
+ expect [ scalar extract_multiple(undef, [ q/([a-z]),?/ ]) ],
+ [ divide($stdtext3 => 1) ];
+
+ expect [ pos ], [ 0 ];
+ expect [ $_ ], [ substr($stdtext3,2) ];
diff -c /dev/null 'perl-5.7.2/lib/Text/Balanced/t/xquot.t'
Index: ./lib/Text/Balanced/t/xquot.t
*** ./lib/Text/Balanced/t/xquot.t Thu Jan 1 02:00:00 1970
--- ./lib/Text/Balanced/t/xquot.t Mon Jul 9 17:10:44 2001
***************
*** 0 ****
--- 1,118 ----
+ #!./perl -ws
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # Before `make install' is performed this script should be runnable with
+ # `make test'. After `make install' it should work as `perl test.pl'
+
+ ######################### We start with some black magic to print on failure.
+
+ # Change 1..1 below to 1..last_test_to_print .
+ # (It may become useful if the test is moved to ./t subdirectory.)
+
+ BEGIN { $| = 1; print "1..89\n"; }
+ END {print "not ok 1\n" unless $loaded;}
+ use Text::Balanced qw ( extract_quotelike );
+ $loaded = 1;
+ print "ok 1\n";
+ $count=2;
+ use vars qw( $DEBUG );
+ # $DEBUG=1;
+ sub debug { print "\t>>>",@_ if $DEBUG }
+
+ ######################### End of black magic.
+
+
+ $cmd = "print";
+ $neg = 0;
+ while (defined($str = <DATA>))
+ {
+ chomp $str;
+ if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
+ elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
+ elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
+ debug "\tUsing: $cmd\n";
+ debug "\t on: [$str]\n";
+ $str =~ s/\\n/\n/g;
+ my $orig = $str;
+
+ my @res;
+ eval qq{\@res = $cmd; };
+ debug "\t got:\n" . join "", map { $res[$_]=~s/\n/\\n/g; "\t\t\t$_: [$res[$_]]\n"} (0..$#res);
+ debug "\t left: " . (map { s/\n/\\n/g; "[$_]\n" } my $cpy1 = $str)[0];
+ debug "\t pos: " . (map { s/\n/\\n/g; "[$_]\n" } my $cpy2 = substr($str,pos($str)))[0] . "...]\n";
+ print "not " if (substr($str,pos($str),1) eq ';')==$neg;
+ print "ok ", $count++;
+ print "\n";
+
+ $str = $orig;
+ debug "\tUsing: scalar $cmd\n";
+ debug "\t on: [$str]\n";
+ $var = eval $cmd;
+ print " ($@)" if $@ && $DEBUG;
+ $var = "<undef>" unless defined $var;
+ debug "\t scalar got: " . (map { s/\n/\\n/g; "[$_]\n" } $var)[0];
+ debug "\t scalar left: " . (map { s/\n/\\n/g; "[$_]\n" } $str)[0];
+ print "not " if ($str =~ '\A;')==$neg;
+ print "ok ", $count++;
+ print "\n";
+ }
+
+ __DATA__
+
+ # USING: extract_quotelike($str);
+ '';
+ "";
+ "a";
+ 'b';
+ `cc`;
+
+
+ <<EOHERE; done();\nline1\nline2\nEOHERE\n; next;
+ <<EOHERE; done();\nline1\nline2\nEOHERE\n; next;
+ <<"EOHERE"; done()\nline1\nline2\nEOHERE\n and next
+ <<`EOHERE`; done()\nline1\nline2\nEOHERE\n and next
+ <<'EOHERE'; done()\nline1\n'line2'\nEOHERE\n and next
+ <<'EOHERE;'; done()\nline1\nline2\nEOHERE;\n and next
+ <<" EOHERE"; done() \nline1\nline2\n EOHERE\nand next
+ <<""; done()\nline1\nline2\n\n and next
+ <<; done()\nline1\nline2\n\n and next
+
+
+ "this is a nested $var[$x] {";
+ /a/gci;
+ m/a/gci;
+
+ q(d);
+ qq(e);
+ qx(f);
+ qr(g);
+ qw(h i j);
+ q{d};
+ qq{e};
+ qx{f};
+ qr{g};
+ qq{a nested { and } are okay as are () and <> pairs and escaped \}'s };
+ q/slash/;
+ q # slash #;
+ qr qw qx;
+
+ s/x/y/;
+ s/x/y/cgimsox;
+ s{a}{b};
+ s{a}\n {b};
+ s(a){b};
+ s(a)/b/;
+ s/'/\\'/g;
+ tr/x/y/;
+ y/x/y/;
+
+ # THESE SHOULD FAIL
+ s<$self->{pat}>{$self->{sub}}; # CAN'T HANDLE '>' in '->'
+ s-$self->{pap}-$self->{sub}-; # CAN'T HANDLE '-' in '->'
+ <<EOHERE; done();\nline1\nline2\nEOHERE;\n; next; # RDEL HAS NO ';'
+ <<'EOHERE'; done();\nline1\nline2\nEOHERE;\n; next; # RDEF HAS NO ';'
+ << EOTHERE; done();\nline1\nline2\n EOTHERE\n; next; # RDEL IS "" (!)
diff -c /dev/null 'perl-5.7.2/lib/Text/Balanced/t/xtagg.t'
Index: ./lib/Text/Balanced/t/xtagg.t
*** ./lib/Text/Balanced/t/xtagg.t Thu Jan 1 02:00:00 1970
--- ./lib/Text/Balanced/t/xtagg.t Mon Jul 9 17:10:44 2001
***************
*** 0 ****
--- 1,118 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # Before `make install' is performed this script should be runnable with
+ # `make test'. After `make install' it should work as `perl test.pl'
+
+ ######################### We start with some black magic to print on failure.
+
+ # Change 1..1 below to 1..last_test_to_print .
+ # (It may become useful if the test is moved to ./t subdirectory.)
+
+ BEGIN { $| = 1; print "1..53\n"; }
+ END {print "not ok 1\n" unless $loaded;}
+ use Text::Balanced qw ( extract_tagged gen_extract_tagged );
+ $loaded = 1;
+ print "ok 1\n";
+ $count=2;
+ use vars qw( $DEBUG );
+ sub debug { print "\t>>>",@_ if $DEBUG }
+
+ ######################### End of black magic.
+
+
+ $cmd = "print";
+ $neg = 0;
+ while (defined($str = <DATA>))
+ {
+ chomp $str;
+ if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
+ elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
+ elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
+ $str =~ s/\\n/\n/g;
+ debug "\tUsing: $cmd\n";
+ debug "\t on: [$str]\n";
+
+ my @res;
+ $var = eval "\@res = $cmd";
+ debug "\t list got: [" . join("|",@res) . "]\n";
+ debug "\t list left: [$str]\n";
+ print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+
+ pos $str = 0;
+ $var = eval $cmd;
+ $var = "<undef>" unless defined $var;
+ debug "\t scalar got: [$var]\n";
+ debug "\t scalar left: [$str]\n";
+ print "not " if ($str =~ '\A;')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+ }
+
+ __DATA__
+ # USING: gen_extract_tagged("BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)")->($str);
+ ignore\n this and then BEGINHERE at the ENDHERE;
+ ignore\n this and then BEGINTHIS at the ENDTHIS;
+
+ # USING: extract_tagged($str,"BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)");
+ ignore\n this and then BEGINHERE at the ENDHERE;
+ ignore\n this and then BEGINTHIS at the ENDTHIS;
+
+ # USING: extract_tagged($str,"BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)");
+ ignore\n this and then BEGINHERE at the ENDHERE;
+ ignore\n this and then BEGINTHIS at the ENDTHIS;
+
+ # THIS SHOULD FAIL
+ ignore\n this and then BEGINTHIS at the ENDTHAT;
+
+ # USING: extract_tagged($str,"BEGIN","END","(?s).*?(?=BEGIN)");
+ ignore\n this and then BEGIN at the END;
+
+ # USING: extract_tagged($str);
+ <A-1 HREF="#section2">some text</A-1>;
+
+ # USING: extract_tagged($str,qr/<[A-Z]+>/,undef, undef, {ignore=>["<BR>"]});
+ <A>aaa<B>bbb<BR>ccc</B>ddd</A>;
+
+ # USING: extract_tagged($str,"BEGIN","END");
+ BEGIN at the BEGIN keyword and END at the END;
+ BEGIN at the beginning and end at the END;
+
+ # USING: extract_tagged($str,undef,undef,undef,{ignore=>["<[^>]*/>"]});
+ <A>aaa<B>bbb<BR/>ccc</B>ddd</A>;
+
+ # USING: extract_tagged($str,";","-",undef,{reject=>[";"],fail=>"MAX"});
+ ; at the ;-) keyword
+
+ # USING: extract_tagged($str,"<[A-Z]+>",undef, undef, {ignore=>["<BR>"]});
+ <A>aaa<B>bbb<BR>ccc</B>ddd</A>;
+
+ # THESE SHOULD FAIL
+ BEGIN at the beginning and end at the end;
+ BEGIN at the BEGIN keyword and END at the end;
+
+ # TEST EXTRACTION OF TAGGED STRINGS
+ # USING: extract_tagged($str,"BEGIN","END",undef,{reject=>["BEGIN","END"]});
+ # THESE SHOULD FAIL
+ BEGIN at the BEGIN keyword and END at the end;
+
+ # USING: extract_tagged($str,";","-",undef,{reject=>[";"],fail=>"PARA"});
+ ; at the ;-) keyword
+
+
+ # USING: extract_tagged($str);
+ <A>some text</A>;
+ <B>some text<A>other text</A></B>;
+ <A>some text<A>other text</A></A>;
+ <A HREF="#section2">some text</A>;
+
+ # THESE SHOULD FAIL
+ <A>some text
+ <A>some text<A>other text</A>;
+ <B>some text<A>other text</B>;
diff -c /dev/null 'perl-5.7.2/lib/Text/Balanced/t/xvari.t'
Index: ./lib/Text/Balanced/t/xvari.t
*** ./lib/Text/Balanced/t/xvari.t Thu Jan 1 02:00:00 1970
--- ./lib/Text/Balanced/t/xvari.t Mon Jul 9 17:10:44 2001
***************
*** 0 ****
--- 1,107 ----
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # Before `make install' is performed this script should be runnable with
+ # `make test'. After `make install' it should work as `perl test.pl'
+
+ ######################### We start with some black magic to print on failure.
+
+ # Change 1..1 below to 1..last_test_to_print .
+ # (It may become useful if the test is moved to ./t subdirectory.)
+
+ BEGIN { $| = 1; print "1..81\n"; }
+ END {print "not ok 1\n" unless $loaded;}
+ use Text::Balanced qw ( extract_variable );
+ $loaded = 1;
+ print "ok 1\n";
+ $count=2;
+ use vars qw( $DEBUG );
+ sub debug { print "\t>>>",@_ if $DEBUG }
+
+ ######################### End of black magic.
+
+
+ $cmd = "print";
+ $neg = 0;
+ while (defined($str = <DATA>))
+ {
+ chomp $str;
+ if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
+ elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
+ elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
+ $str =~ s/\\n/\n/g;
+ debug "\tUsing: $cmd\n";
+ debug "\t on: [$str]\n";
+
+ my @res;
+ $var = eval "\@res = $cmd";
+ debug "\t list got: [" . join("|",@res) . "]\n";
+ debug "\t list left: [$str]\n";
+ print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+
+ pos $str = 0;
+ $var = eval $cmd;
+ $var = "<undef>" unless defined $var;
+ debug "\t scalar got: [$var]\n";
+ debug "\t scalar left: [$str]\n";
+ print "not " if ($str =~ '\A;')==$neg;
+ print "ok ", $count++;
+ print " ($@)" if $@ && $DEBUG;
+ print "\n";
+ }
+
+ __DATA__
+
+ # USING: extract_variable($str);
+ # THESE SHOULD FAIL
+ $a->;
+ $a (1..3) { print $a };
+
+ # USING: extract_variable($str);
+ *var;
+ *$var;
+ *{var};
+ *{$var};
+ *var{cat};
+ \&var;
+ \&mod::var;
+ \&mod'var;
+ $a;
+ $_;
+ $a[1];
+ $_[1];
+ $a{cat};
+ $_{cat};
+ $a->[1];
+ $a->{"cat"}[1];
+ @$listref;
+ @{$listref};
+ $obj->nextval;
+ $obj->_nextval;
+ $obj->next_val_;
+ @{$obj->nextval};
+ @{$obj->nextval($cat,$dog)->{new}};
+ @{$obj->nextval($cat?$dog:$fish)->{new}};
+ @{$obj->nextval(cat()?$dog:$fish)->{new}};
+ $ a {'cat'};
+ $a::b::c{d}->{$e->()};
+ $a'b'c'd{e}->{$e->()};
+ $a'b::c'd{e}->{$e->()};
+ $#_;
+ $#array;
+ $#{array};
+ $var[$#var];
+
+ # THESE SHOULD FAIL
+ $a->;
+ @{$;
+ $ a :: b :: c
+ $ a ' b ' c
+
+ # USING: extract_variable($str,'=*');
+ ========$a;
diff -c 'perl-5.7.1/lib/Text/ParseWords.pm' 'perl-5.7.2/lib/Text/ParseWords.pm'
Index: ./lib/Text/ParseWords.pm
*** ./lib/Text/ParseWords.pm Tue Mar 6 04:05:36 2001
--- ./lib/Text/ParseWords.pm Mon Jul 9 17:10:44 2001
***************
*** 1,7 ****
package Text::ParseWords;
use vars qw($VERSION @ISA @EXPORT $PERL_SINGLE_QUOTE);
! $VERSION = "3.2";
require 5.000;
--- 1,7 ----
package Text::ParseWords;
use vars qw($VERSION @ISA @EXPORT $PERL_SINGLE_QUOTE);
! $VERSION = "3.21";
require 5.000;
diff -c /dev/null 'perl-5.7.2/lib/Text/ParseWords.t'
Index: ./lib/Text/ParseWords.t
*** ./lib/Text/ParseWords.t Thu Jan 1 02:00:00 1970
--- ./lib/Text/ParseWords.t Mon Jul 9 17:10:44 2001
***************
*** 0 ****
--- 1,110 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use warnings;
+ use Text::ParseWords;
+
+ print "1..18\n";
+
+ @words = shellwords(qq(foo "bar quiz" zoo));
+ print "not " if $words[0] ne 'foo';
+ print "ok 1\n";
+ print "not " if $words[1] ne 'bar quiz';
+ print "ok 2\n";
+ print "not " if $words[2] ne 'zoo';
+ print "ok 3\n";
+
+ {
+ # Gonna get some undefined things back
+ no warnings 'uninitialized' ;
+
+ # Test quotewords() with other parameters and null last field
+ @words = quotewords(':+', 1, 'foo:::"bar:foo":zoo zoo:');
+ print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo;);
+ print "ok 4\n";
+ }
+
+ # Test $keep eq 'delimiters' and last field zero
+ @words = quotewords('\s+', 'delimiters', '4 3 2 1 0');
+ print "not " unless join(";", @words) eq qq(4; ;3; ;2; ;1; ;0);
+ print "ok 5\n";
+
+ # Big ol' nasty test (thanks, Joerk!)
+ $string = 'aaaa"bbbbb" cc\\ cc \\\\\\"dddd" eee\\\\\\"ffff" "gg"';
+
+ # First with $keep == 1
+ $result = join('|', parse_line('\s+', 1, $string));
+ print "not " unless $result eq 'aaaa"bbbbb"|cc\\ cc|\\\\\\"dddd" eee\\\\\\"ffff"|"gg"';
+ print "ok 6\n";
+
+ # Now, $keep == 0
+ $result = join('|', parse_line('\s+', 0, $string));
+ print "not " unless $result eq 'aaaabbbbb|cc cc|\\"dddd eee\\"ffff|gg';
+ print "ok 7\n";
+
+ # Now test single quote behavior
+ $string = 'aaaa"bbbbb" cc\\ cc \\\\\\"dddd\' eee\\\\\\"ffff\' gg';
+ $result = join('|', parse_line('\s+', 0, $string));
+ print "not " unless $result eq 'aaaabbbbb|cc cc|\\"dddd eee\\\\\\"ffff|gg';
+ print "ok 8\n";
+
+ # Make sure @nested_quotewords does the right thing
+ @lists = nested_quotewords('\s+', 0, 'a b c', '1 2 3', 'x y z');
+ print "not " unless (@lists == 3 && @{$lists[0]} == 3 && @{$lists[1]} == 3 && @{$lists[2]} == 3);
+ print "ok 9\n";
+
+ # Now test error return
+ $string = 'foo bar baz"bach blech boop';
+
+ @words = shellwords($string);
+ print "not " if (@words);
+ print "ok 10\n";
+
+ @words = parse_line('s+', 0, $string);
+ print "not " if (@words);
+ print "ok 11\n";
+
+ @words = quotewords('s+', 0, $string);
+ print "not " if (@words);
+ print "ok 12\n";
+
+ {
+ # Gonna get some more undefined things back
+ no warnings 'uninitialized' ;
+
+ @words = nested_quotewords('s+', 0, $string);
+ print "not " if (@words);
+ print "ok 13\n";
+
+ # Now test empty fields
+ $result = join('|', parse_line(':', 0, 'foo::0:"":::'));
+ print "not " unless ($result eq 'foo||0||||');
+ print "ok 14\n";
+
+ # Test for 0 in quotes without $keep
+ $result = join('|', parse_line(':', 0, ':"0":'));
+ print "not " unless ($result eq '|0|');
+ print "ok 15\n";
+
+ # Test for \001 in quoted string
+ $result = join('|', parse_line(':', 0, ':"' . "\001" . '":'));
+ print "not " unless ($result eq "|\1|");
+ print "ok 16\n";
+
+ }
+
+ # Now test perlish single quote behavior
+ $Text::ParseWords::PERL_SINGLE_QUOTE = 1;
+ $string = 'aaaa"bbbbb" cc\ cc \\\\\"dddd\' eee\\\\\"\\\'ffff\' gg';
+ $result = join('|', parse_line('\s+', 0, $string));
+ print "not " unless $result eq 'aaaabbbbb|cc cc|\"dddd eee\\\\"\'ffff|gg';
+ print "ok 17\n";
+
+ # test whitespace in the delimiters
+ @words = quotewords(' ', 1, '4 3 2 1 0');
+ print "not " unless join(";", @words) eq qq(4;3;2;1;0);
+ print "ok 18\n";
diff -c 'perl-5.7.1/lib/Text/Soundex.pm' 'perl-5.7.2/lib/Text/Soundex.pm'
Index: ./lib/Text/Soundex.pm
Prereq: 1.2
*** ./lib/Text/Soundex.pm Tue Mar 6 04:05:36 2001
--- ./lib/Text/Soundex.pm Mon Jul 9 17:10:44 2001
***************
*** 5,11 ****
@ISA = qw(Exporter);
@EXPORT = qw(&soundex $soundex_nocode);
! $VERSION = '1.0';
# $Id: soundex.pl,v 1.2 1994/03/24 00:30:27 mike Exp $
#
--- 5,11 ----
@ISA = qw(Exporter);
@EXPORT = qw(&soundex $soundex_nocode);
! $VERSION = '1.01';
# $Id: soundex.pl,v 1.2 1994/03/24 00:30:27 mike Exp $
#
diff -c /dev/null 'perl-5.7.2/lib/Text/Soundex.t'
Index: ./lib/Text/Soundex.t
*** ./lib/Text/Soundex.t Thu Jan 1 02:00:00 1970
--- ./lib/Text/Soundex.t Mon Jul 9 17:10:45 2001
***************
*** 0 ****
--- 1,143 ----
+ #!./perl
+ #
+ # $Id: soundex.t,v 1.2 1994/03/24 00:30:27 mike Exp $
+ #
+ # test module for soundex.pl
+ #
+ # $Log: soundex.t,v $
+ # Revision 1.2 1994/03/24 00:30:27 mike
+ # Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu>
+ # in the way I handles leasing characters which were different but had
+ # the same soundex code. This showed up comparing it with Oracle's
+ # soundex output.
+ #
+ # Revision 1.1 1994/03/02 13:03:02 mike
+ # Initial revision
+ #
+ #
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use Text::Soundex;
+
+ $test = 0;
+ print "1..13\n";
+
+ while (<DATA>)
+ {
+ chop;
+ next if /^\s*;?#/;
+ next if /^\s*$/;
+
+ ++$test;
+ $bad = 0;
+
+ if (/^eval\s+/)
+ {
+ ($try = $_) =~ s/^eval\s+//;
+
+ eval ($try);
+ if ($@)
+ {
+ $bad++;
+ print "not ok $test\n";
+ print "# eval '$try' returned $@";
+ }
+ }
+ elsif (/^\(/)
+ {
+ ($in, $out) = split (':');
+
+ $try = "\@expect = $out; \@got = &soundex $in;";
+ eval ($try);
+
+ if (@expect != @got)
+ {
+ $bad++;
+ print "not ok $test\n";
+ print "# expected ", scalar @expect, " results, got ", scalar @got, "\n";
+ print "# expected (", join (', ', @expect),
+ ") got (", join (', ', @got), ")\n";
+ }
+ else
+ {
+ while (@got)
+ {
+ $expect = shift @expect;
+ $got = shift @got;
+
+ if ($expect ne $got)
+ {
+ $bad++;
+ print "not ok $test\n";
+ print "# expected $expect, got $got\n";
+ }
+ }
+ }
+ }
+ else
+ {
+ ($in, $out) = split (':');
+
+ $try = "\$expect = $out; \$got = &soundex ($in);";
+ eval ($try);
+
+ if ($expect ne $got)
+ {
+ $bad++;
+ print "not ok $test\n";
+ print "# expected $expect, got $got\n";
+ }
+ }
+
+ print "ok $test\n" unless $bad;
+ }
+
+ __END__
+ #
+ # 1..6
+ #
+ # Knuth's test cases, scalar in, scalar out
+ #
+ 'Euler':'E460'
+ 'Gauss':'G200'
+ 'Hilbert':'H416'
+ 'Knuth':'K530'
+ 'Lloyd':'L300'
+ 'Lukasiewicz':'L222'
+ #
+ # 7..8
+ #
+ # check default bad code
+ #
+ '2 + 2 = 4':undef
+ undef:undef
+ #
+ # 9
+ #
+ # check array in, array out
+ #
+ ('Ellery', 'Ghosh', 'Heilbronn', 'Kant', 'Ladd', 'Lissajous'):('E460', 'G200', 'H416', 'K530', 'L300', 'L222')
+ #
+ # 10
+ #
+ # check array with explicit undef
+ #
+ ('Mike', undef, 'Stok'):('M200', undef, 'S320')
+ #
+ # 11..12
+ #
+ # check setting $Text::Soundex::noCode
+ #
+ eval $soundex_nocode = 'Z000';
+ ('Mike', undef, 'Stok'):('M200', 'Z000', 'S320')
+ #
+ # 13
+ #
+ # a subtle difference between me & oracle, spotted by Rich Pinder
+ # <rpinder@hsc.usc.edu>
+ #
+ CZARKOWSKA:C622
diff -c /dev/null 'perl-5.7.2/lib/Text/TabsWrap/t/fill.t'
Index: ./lib/Text/TabsWrap/t/fill.t
*** ./lib/Text/TabsWrap/t/fill.t Thu Jan 1 02:00:00 1970
--- ./lib/Text/TabsWrap/t/fill.t Mon Jul 9 17:10:45 2001
***************
*** 0 ****
--- 1,98 ----
+ #!./perl -w
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use Text::Wrap qw(&fill);
+
+ @tests = (split(/\nEND\n/s, <<DONE));
+ TEST1
+ Cyberdog Information
+
+ Cyberdog & Netscape in the news
+ Important Press Release regarding Cyberdog and Netscape. Check it out!
+
+ Cyberdog Plug-in Support!
+ Cyberdog support for Netscape Plug-ins is now available to download! Go
+ to the Cyberdog Beta Download page and download it now!
+
+ Cyberdog Book
+ Check out Jesse Feiler's way-cool book about Cyberdog. You can find
+ details out about the book as well as ordering information at Philmont
+ Software Mill site.
+
+ Java!
+ Looking to view Java applets in Cyberdog 1.1 Beta 3? Download and install
+ the Mac OS Runtime for Java and try it out!
+
+ Cyberdog 1.1 Beta 3
+ We hope that Cyberdog and OpenDoc 1.1 will be available within the next
+ two weeks. In the meantime, we have released another version of
+ Cyberdog, Cyberdog 1.1 Beta 3. This version fixes several bugs that were
+ reported to us during out public beta period. You can check out our release
+ notes to see what we fixed!
+ END
+ Cyberdog Information
+ Cyberdog & Netscape in the news Important Press Release regarding
+ Cyberdog and Netscape. Check it out!
+ Cyberdog Plug-in Support! Cyberdog support for Netscape Plug-ins is now
+ available to download! Go to the Cyberdog Beta Download page and download
+ it now!
+ Cyberdog Book Check out Jesse Feiler's way-cool book about Cyberdog.
+ You can find details out about the book as well as ordering information at
+ Philmont Software Mill site.
+ Java! Looking to view Java applets in Cyberdog 1.1 Beta 3? Download and
+ install the Mac OS Runtime for Java and try it out!
+ Cyberdog 1.1 Beta 3 We hope that Cyberdog and OpenDoc 1.1 will be
+ available within the next two weeks. In the meantime, we have released
+ another version of Cyberdog, Cyberdog 1.1 Beta 3. This version fixes
+ several bugs that were reported to us during out public beta period. You
+ can check out our release notes to see what we fixed!
+ END
+ DONE
+
+
+ $| = 1;
+
+ print "1..", @tests/2, "\n";
+
+ use Text::Wrap;
+
+ $rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1;
+
+ $tn = 1;
+ while (@tests) {
+ my $in = shift(@tests);
+ my $out = shift(@tests);
+
+ $in =~ s/^TEST(\d+)?\n//;
+
+ my $back = fill(' ', ' ', $in);
+
+ if ($back eq $out) {
+ print "ok $tn\n";
+ } elsif ($rerun) {
+ my $oi = $in;
+ open(F,">#o") and do { print F $back; close(F) };
+ open(F,">#e") and do { print F $out; close(F) };
+ foreach ($in, $back, $out) {
+ s/\t/^I\t/gs;
+ s/\n/\$\n/gs;
+ }
+ print "------------ input ------------\n";
+ print $in;
+ print "\n------------ output -----------\n";
+ print $back;
+ print "\n------------ expected ---------\n";
+ print $out;
+ print "\n-------------------------------\n";
+ $Text::Wrap::debug = 1;
+ fill(' ', ' ', $oi);
+ exit(1);
+ } else {
+ print "not ok $tn\n";
+ }
+ $tn++;
+ }
diff -c /dev/null 'perl-5.7.2/lib/Text/TabsWrap/t/tabs.t'
Index: ./lib/Text/TabsWrap/t/tabs.t
*** ./lib/Text/TabsWrap/t/tabs.t Thu Jan 1 02:00:00 1970
--- ./lib/Text/TabsWrap/t/tabs.t Mon Jul 9 17:10:45 2001
***************
*** 0 ****
--- 1,141 ----
+ #!./perl -w
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ @tests = (split(/\nEND\n/s, <<DONE));
+ TEST 1 u
+ x
+ END
+ x
+ END
+ TEST 2 e
+ x
+ END
+ x
+ END
+ TEST 3 e
+ x
+ y
+ z
+ END
+ x
+ y
+ z
+ END
+ TEST 4 u
+ x
+ y
+ z
+ END
+ x
+ y
+ z
+ END
+ TEST 5 u
+ This Is a test of a line with many embedded tabs
+ END
+ This Is a test of a line with many embedded tabs
+ END
+ TEST 6 e
+ This Is a test of a line with many embedded tabs
+ END
+ This Is a test of a line with many embedded tabs
+ END
+ TEST 7 u
+ x
+ END
+ x
+ END
+ TEST 8 e
+
+
+
+
+
+ END
+
+
+
+
+
+ END
+ TEST 9 u
+
+ END
+
+ END
+ TEST 10 u
+
+
+
+
+
+ END
+
+
+
+
+
+ END
+ TEST 11 u
+ foobar IN A 140.174.82.12
+
+ END
+ foobar IN A 140.174.82.12
+
+ END
+ DONE
+
+ $| = 1;
+
+ my $testcount = "1..";
+ $testcount .= @tests/2;
+ print "$testcount\n";
+
+ use Text::Tabs;
+
+ $rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1;
+
+ $tn = 1;
+ while (@tests) {
+ my $in = shift(@tests);
+ my $out = shift(@tests);
+
+ $in =~ s/^TEST\s*(\d+)?\s*(\S+)?\n//;
+
+ if ($2 eq 'e') {
+ $f = \&expand;
+ $fn = 'expand';
+ } else {
+ $f = \&unexpand;
+ $fn = 'unexpand';
+ }
+
+ my $back = &$f($in);
+
+ if ($back eq $out) {
+ print "ok $tn\n";
+ } elsif ($rerun) {
+ my $oi = $in;
+ foreach ($in, $back, $out) {
+ s/\t/^I\t/gs;
+ s/\n/\$\n/gs;
+ }
+ print "------------ input ------------\n";
+ print $in;
+ print "\$\n------------ $fn -----------\n";
+ print $back;
+ print "\$\n------------ expected ---------\n";
+ print $out;
+ print "\$\n-------------------------------\n";
+ $Text::Tabs::debug = 1;
+ my $back = &$f($in);
+ exit(1);
+ } else {
+ print "not ok $tn\n";
+ }
+ $tn++;
+ }
diff -c /dev/null 'perl-5.7.2/lib/Text/TabsWrap/t/wrap.t'
Index: ./lib/Text/TabsWrap/t/wrap.t
*** ./lib/Text/TabsWrap/t/wrap.t Thu Jan 1 02:00:00 1970
--- ./lib/Text/TabsWrap/t/wrap.t Mon Jul 9 17:10:45 2001
***************
*** 0 ****
--- 1,209 ----
+ #!./perl -w
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ @tests = (split(/\nEND\n/s, <<DONE));
+ TEST1
+ This
+ is
+ a
+ test
+ END
+ This
+ is
+ a
+ test
+ END
+ TEST2
+ This is a test of a very long line. It should be broken up and put onto multiple lines.
+ This is a test of a very long line. It should be broken up and put onto multiple lines.
+
+ This is a test of a very long line. It should be broken up and put onto multiple lines.
+ END
+ This is a test of a very long line. It should be broken up and put onto
+ multiple lines.
+ This is a test of a very long line. It should be broken up and put onto
+ multiple lines.
+
+ This is a test of a very long line. It should be broken up and put onto
+ multiple lines.
+ END
+ TEST3
+ This is a test of a very long line. It should be broken up and put onto multiple lines.
+ END
+ This is a test of a very long line. It should be broken up and put onto
+ multiple lines.
+ END
+ TEST4
+ This is a test of a very long line. It should be broken up and put onto multiple lines.
+
+ END
+ This is a test of a very long line. It should be broken up and put onto
+ multiple lines.
+
+ END
+ TEST5
+ This is a test of a very long line. It should be broken up and put onto multiple This is a test of a very long line. It should be broken up and put
+ END
+ This is a test of a very long line. It should be broken up and put onto
+ multiple This is a test of a very long line. It should be broken up and
+ put
+ END
+ TEST6
+ 11111111 22222222 33333333 44444444 55555555 66666666 77777777 888888888 999999999 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee ffffffff gggggggg hhhhhhhh iiiiiiii jjjjjjjj kkkkkkkk llllllll mmmmmmmmm nnnnnnnnn ooooooooo ppppppppp qqqqqqqqq rrrrrrrrr sssssssss
+ END
+ 11111111 22222222 33333333 44444444 55555555 66666666 77777777 888888888
+ 999999999 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee ffffffff
+ gggggggg hhhhhhhh iiiiiiii jjjjjjjj kkkkkkkk llllllll mmmmmmmmm nnnnnnnnn
+ ooooooooo ppppppppp qqqqqqqqq rrrrrrrrr sssssssss
+ END
+ TEST7
+ c3t1d0s6 c4t1d0s6 c5t1d0s6 c6t1d0s6 c7t1d0s6 c8t1d0s6 c9t1d0s6 c10t1d0s6 c11t1d0s6 c12t1d0s6 c13t1d0s6 c14t1d0s6 c15t1d0s6 c16t1d0s6 c3t1d0s0 c4t1d0s0 c5t1d0s0 c6t1d0s0 c7t1d0s0 c8t1d0s0 c9t1d0s0 c10t1d0s0 c11t1d0s0 c12t1d0s0 c13t1d0s0 c14t1d0s0 c15t1d0s0 c16t1d0s0
+ END
+ c3t1d0s6 c4t1d0s6 c5t1d0s6 c6t1d0s6 c7t1d0s6 c8t1d0s6 c9t1d0s6 c10t1d0s6
+ c11t1d0s6 c12t1d0s6 c13t1d0s6 c14t1d0s6 c15t1d0s6 c16t1d0s6 c3t1d0s0
+ c4t1d0s0 c5t1d0s0 c6t1d0s0 c7t1d0s0 c8t1d0s0 c9t1d0s0 c10t1d0s0 c11t1d0s0
+ c12t1d0s0 c13t1d0s0 c14t1d0s0 c15t1d0s0 c16t1d0s0
+ END
+ TEST8
+ A test of a very very long word.
+ a123456789b123456789c123456789d123456789e123456789f123456789g123456789g1234567
+ END
+ A test of a very very long word.
+ a123456789b123456789c123456789d123456789e123456789f123456789g123456789g123
+ 4567
+ END
+ TEST9
+ A test of a very very long word. a123456789b123456789c123456789d123456789e123456789f123456789g123456789g1234567
+ END
+ A test of a very very long word.
+ a123456789b123456789c123456789d123456789e123456789f123456789g123456789g123
+ 4567
+ END
+ TEST10
+ my mother once said
+ "never eat paste my darling"
+ would that I heeded
+ END
+ my mother once said
+ "never eat paste my darling"
+ would that I heeded
+ END
+ TEST11
+ This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_program_does_not_crash_and_burn
+ END
+ This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_pr
+ ogram_does_not_crash_and_burn
+ END
+ TEST12
+ This
+
+ Has
+
+ Blank
+
+ Lines
+
+ END
+ This
+
+ Has
+
+ Blank
+
+ Lines
+
+ END
+ DONE
+
+
+ $| = 1;
+
+ print "1..", 1 +@tests, "\n";
+
+ use Text::Wrap;
+
+ $rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1;
+
+ $tn = 1;
+
+ @st = @tests;
+ while (@st) {
+ my $in = shift(@st);
+ my $out = shift(@st);
+
+ $in =~ s/^TEST(\d+)?\n//;
+
+ my $back = wrap(' ', ' ', $in);
+
+ if ($back eq $out) {
+ print "ok $tn\n";
+ } elsif ($rerun) {
+ my $oi = $in;
+ foreach ($in, $back, $out) {
+ s/\t/^I\t/gs;
+ s/\n/\$\n/gs;
+ }
+ print "------------ input ------------\n";
+ print $in;
+ print "\n------------ output -----------\n";
+ print $back;
+ print "\n------------ expected ---------\n";
+ print $out;
+ print "\n-------------------------------\n";
+ $Text::Wrap::debug = 1;
+ wrap(' ', ' ', $oi);
+ exit(1);
+ } else {
+ print "not ok $tn\n";
+ }
+ $tn++;
+
+ }
+
+ @st = @tests;
+ while(@st) {
+ my $in = shift(@st);
+ my $out = shift(@st);
+
+ $in =~ s/^TEST(\d+)?\n//;
+
+ my @in = split("\n", $in, -1);
+ @in = ((map { "$_\n" } @in[0..$#in-1]), $in[-1]);
+
+ my $back = wrap(' ', ' ', @in);
+
+ if ($back eq $out) {
+ print "ok $tn\n";
+ } elsif ($rerun) {
+ my $oi = $in;
+ foreach ($in, $back, $out) {
+ s/\t/^I\t/gs;
+ s/\n/\$\n/gs;
+ }
+ print "------------ input2 ------------\n";
+ print $in;
+ print "\n------------ output2 -----------\n";
+ print $back;
+ print "\n------------ expected2 ---------\n";
+ print $out;
+ print "\n-------------------------------\n";
+ $Text::Wrap::debug = 1;
+ wrap(' ', ' ', $oi);
+ exit(1);
+ } else {
+ print "not ok $tn\n";
+ }
+ $tn++;
+ }
+
+ $Text::Wrap::huge = 'overflow';
+
+ my $tw = 'This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_program_does_not_crash_and_burn';
+ my $w = wrap('zzz','yyy',$tw);
+ print (($w eq "zzz$tw") ? "ok $tn\n" : "not ok $tn");
+ $tn++;
+
diff -c 'perl-5.7.1/lib/Tie/Array.pm' 'perl-5.7.2/lib/Tie/Array.pm'
Index: ./lib/Tie/Array.pm
*** ./lib/Tie/Array.pm Fri Mar 16 04:54:51 2001
--- ./lib/Tie/Array.pm Thu Jul 12 17:11:32 2001
***************
*** 3,9 ****
use 5.005_64;
use strict;
use Carp;
! our $VERSION = '1.01';
# Pod documentation after __END__ below.
--- 3,9 ----
use 5.005_64;
use strict;
use Carp;
! our $VERSION = '1.02';
# Pod documentation after __END__ below.
***************
*** 11,17 ****
sub EXTEND { }
sub UNSHIFT { scalar shift->SPLICE(0,0,@_) }
sub SHIFT { shift->SPLICE(0,1) }
- #sub SHIFT { (shift->SPLICE(0,1))[0] }
sub CLEAR { shift->STORESIZE(0) }
sub PUSH
--- 11,16 ----
***************
*** 70,76 ****
for (my $i=0; $i < @_; $i++) {
$obj->STORE($off+$i,$_[$i]);
}
! return @result;
}
sub EXISTS {
--- 69,75 ----
for (my $i=0; $i < @_; $i++) {
$obj->STORE($off+$i,$_[$i]);
}
! return wantarray ? @result : pop @result;
}
sub EXISTS {
diff -c /dev/null 'perl-5.7.2/lib/Tie/Array/push.t'
Index: ./lib/Tie/Array/push.t
*** ./lib/Tie/Array/push.t Thu Jan 1 02:00:00 1970
--- ./lib/Tie/Array/push.t Mon Jul 9 17:10:45 2001
***************
*** 0 ****
--- 1,25 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ }
+
+ {
+ package Basic;
+ use Tie::Array;
+ @ISA = qw(Tie::Array);
+
+ sub TIEARRAY { return bless [], shift }
+ sub FETCH { $_[0]->[$_[1]] }
+ sub STORE { $_[0]->[$_[1]] = $_[2] }
+ sub FETCHSIZE { scalar(@{$_[0]}) }
+ sub STORESIZE { $#{$_[0]} = $_[1]-1 }
+ }
+
+ tie @x,Basic;
+ tie @get,Basic;
+ tie @got,Basic;
+ tie @tests,Basic;
+ require "op/push.t"
diff -c /dev/null 'perl-5.7.2/lib/Tie/Array/splice.t'
Index: ./lib/Tie/Array/splice.t
*** ./lib/Tie/Array/splice.t Thu Jan 1 02:00:00 1970
--- ./lib/Tie/Array/splice.t Mon Jul 9 17:10:45 2001
***************
*** 0 ****
--- 1,17 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ }
+
+ # bug id 20001020.002
+ # -dlc 20001021
+
+ use Tie::Array;
+ tie @a,Tie::StdArray;
+ undef *Tie::StdArray::SPLICE;
+ require "op/splice.t"
+
+ # Pre-fix, this failed tests 6-9
diff -c /dev/null 'perl-5.7.2/lib/Tie/Array/std.t'
Index: ./lib/Tie/Array/std.t
*** ./lib/Tie/Array/std.t Thu Jan 1 02:00:00 1970
--- ./lib/Tie/Array/std.t Mon Jul 9 17:10:45 2001
***************
*** 0 ****
--- 1,13 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ }
+
+ use Tie::Array;
+ tie @foo,Tie::StdArray;
+ tie @ary,Tie::StdArray;
+ tie @bar,Tie::StdArray;
+ require "op/array.t"
diff -c /dev/null 'perl-5.7.2/lib/Tie/Array/stdpush.t'
Index: ./lib/Tie/Array/stdpush.t
*** ./lib/Tie/Array/stdpush.t Thu Jan 1 02:00:00 1970
--- ./lib/Tie/Array/stdpush.t Mon Jul 9 17:10:45 2001
***************
*** 0 ****
--- 1,11 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ }
+
+ use Tie::Array;
+ tie @x,Tie::StdArray;
+ require "op/push.t"
diff -c /dev/null 'perl-5.7.2/lib/Tie/Handle/stdhandle.t'
Index: ./lib/Tie/Handle/stdhandle.t
*** ./lib/Tie/Handle/stdhandle.t Thu Jan 1 02:00:00 1970
--- ./lib/Tie/Handle/stdhandle.t Mon Jul 9 17:10:45 2001
***************
*** 0 ****
--- 1,47 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use Tie::Handle;
+ tie *tst,Tie::StdHandle;
+
+ $f = 'tst';
+
+ print "1..13\n";
+
+ # my $file tests
+
+ unlink("afile.new") if -f "afile";
+ print "$!\nnot " unless open($f,"+>afile") && open($f, "+<", "afile");
+ print "ok 1\n";
+ print "$!\nnot " unless binmode($f);
+ print "ok 2\n";
+ print "not " unless -f "afile";
+ print "ok 3\n";
+ print "not " unless print $f "SomeData\n";
+ print "ok 4\n";
+ print "not " unless tell($f) == 9;
+ print "ok 5\n";
+ print "not " unless printf $f "Some %d value\n",1234;
+ print "ok 6\n";
+ print "not " unless seek($f,0,0);
+ print "ok 7\n";
+ $b = <$f>;
+ print "not " unless $b eq "SomeData\n";
+ print "ok 8\n";
+ print "not " if eof($f);
+ print "ok 9\n";
+ read($f,($b=''),4);
+ print "'$b' not " unless $b eq 'Some';
+ print "ok 10\n";
+ print "not " unless getc($f) eq ' ';
+ print "ok 11\n";
+ $b = <$f>;
+ print "not " unless eof($f);
+ print "ok 12\n";
+ print "not " unless close($f);
+ print "ok 13\n";
+ unlink("afile");
diff -c 'perl-5.7.1/lib/Tie/Hash.pm' 'perl-5.7.2/lib/Tie/Hash.pm'
Index: ./lib/Tie/Hash.pm
*** ./lib/Tie/Hash.pm Fri Mar 16 04:54:51 2001
--- ./lib/Tie/Hash.pm Mon Jul 9 17:10:45 2001
***************
*** 65,75 ****
=item FIRSTKEY this
! Return the (key, value) pair for the first key in the hash.
=item NEXTKEY this, lastkey
! Return the next key for the hash.
=item EXISTS this, key
--- 65,75 ----
=item FIRSTKEY this
! Return the first key in the hash.
=item NEXTKEY this, lastkey
! Return the next key in the hash.
=item EXISTS this, key
diff -c /dev/null 'perl-5.7.2/lib/Tie/RefHash.t'
Index: ./lib/Tie/RefHash.t
*** ./lib/Tie/RefHash.t Thu Jan 1 02:00:00 1970
--- ./lib/Tie/RefHash.t Mon Jul 9 17:10:45 2001
***************
*** 0 ****
--- 1,305 ----
+ #!/usr/bin/perl -w
+ #
+ # Basic test suite for Tie::RefHash and Tie::RefHash::Nestable.
+ #
+ # The testing is in two parts: first, run lots of tests on both a tied
+ # hash and an ordinary un-tied hash, and check they give the same
+ # answer. Then there are tests for those cases where the tied hashes
+ # should behave differently to normal hashes, that is, when using
+ # references as keys.
+ #
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ }
+
+ use strict;
+ use Tie::RefHash;
+ use Data::Dumper;
+ my $numtests = 34;
+ my $currtest = 1;
+ print "1..$numtests\n";
+
+ my $ref = []; my $ref1 = [];
+
+ # Test standard hash functionality, by performing the same operations
+ # on a tied hash and on a normal hash, and checking that the results
+ # are the same. This does of course assume that Perl hashes are not
+ # buggy :-)
+ #
+ my @tests = standard_hash_tests();
+
+ my @ordinary_results = runtests(\@tests, undef);
+ foreach my $class ('Tie::RefHash', 'Tie::RefHash::Nestable') {
+ my @tied_results = runtests(\@tests, $class);
+ my $all_ok = 1;
+
+ die if @ordinary_results != @tied_results;
+ foreach my $i (0 .. $#ordinary_results) {
+ my ($or, $ow, $oe) = @{$ordinary_results[$i]};
+ my ($tr, $tw, $te) = @{$tied_results[$i]};
+
+ my $ok = 1;
+ local $^W = 0;
+ $ok = 0 if (defined($or) != defined($tr)) or ($or ne $tr);
+ $ok = 0 if (defined($ow) != defined($tw)) or ($ow ne $tw);
+ $ok = 0 if (defined($oe) != defined($te)) or ($oe ne $te);
+
+ if (not $ok) {
+ print STDERR
+ "failed for $class: $tests[$i]\n",
+ "ordinary hash gave:\n",
+ defined $or ? "\tresult: $or\n" : "\tundef result\n",
+ defined $ow ? "\twarning: $ow\n" : "\tno warning\n",
+ defined $oe ? "\texception: $oe\n" : "\tno exception\n",
+ "tied $class hash gave:\n",
+ defined $tr ? "\tresult: $tr\n" : "\tundef result\n",
+ defined $tw ? "\twarning: $tw\n" : "\tno warning\n",
+ defined $te ? "\texception: $te\n" : "\tno exception\n",
+ "\n";
+ $all_ok = 0;
+ }
+ }
+ test($all_ok);
+ }
+
+ # Now test Tie::RefHash's special powers
+ my (%h, $h);
+ $h = eval { tie %h, 'Tie::RefHash' };
+ warn $@ if $@;
+ test(not $@);
+ test(ref($h) eq 'Tie::RefHash');
+ test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash/);
+ $h{$ref} = 'cholet';
+ test($h{$ref} eq 'cholet');
+ test(exists $h{$ref});
+ test((keys %h) == 1);
+ test(ref((keys %h)[0]) eq 'ARRAY');
+ test((keys %h)[0] eq $ref);
+ test((values %h) == 1);
+ test((values %h)[0] eq 'cholet');
+ my $count = 0;
+ while (my ($k, $v) = each %h) {
+ if ($count++ == 0) {
+ test(ref($k) eq 'ARRAY');
+ test($k eq $ref);
+ }
+ }
+ test($count == 1);
+ delete $h{$ref};
+ test(not defined $h{$ref});
+ test(not exists($h{$ref}));
+ test((keys %h) == 0);
+ test((values %h) == 0);
+ undef $h;
+ untie %h;
+
+ # And now Tie::RefHash::Nestable's differences from Tie::RefHash.
+ $h = eval { tie %h, 'Tie::RefHash::Nestable' };
+ warn $@ if $@;
+ test(not $@);
+ test(ref($h) eq 'Tie::RefHash::Nestable');
+ test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash::Nestable/);
+ $h{$ref}->{$ref1} = 'bungo';
+ test($h{$ref}->{$ref1} eq 'bungo');
+
+ # Test that the nested hash is also tied (for current implementation)
+ test(defined(tied(%{$h{$ref}}))
+ and tied(%{$h{$ref}}) =~ /^Tie::RefHash::Nestable=/ );
+
+ test((keys %h) == 1);
+ test((keys %h)[0] eq $ref);
+ test((keys %{$h{$ref}}) == 1);
+ test((keys %{$h{$ref}})[0] eq $ref1);
+
+
+ die "expected to run $numtests tests, but ran ", $currtest - 1
+ if $currtest - 1 != $numtests;
+
+ @tests = ();
+ undef $ref;
+ undef $ref1;
+
+ exit();
+
+
+ # Print 'ok X' if true, 'not ok X' if false
+ # Uses global $currtest.
+ #
+ sub test {
+ my $t = shift;
+ print 'not ' if not $t;
+ print 'ok ', $currtest++, "\n";
+ }
+
+
+ # Wrapper for Data::Dumper to 'dump' a scalar as an EXPR string.
+ sub dumped {
+ my $s = shift;
+ my $d = Dumper($s);
+ $d =~ s/^\$VAR1 =\s*//;
+ $d =~ s/;$//;
+ chomp $d;
+ return $d;
+ }
+
+ # Crudely dump a hash into a canonical string representation (because
+ # hash keys can appear in any order, Data::Dumper may give different
+ # strings for the same hash).
+ #
+ sub dumph {
+ my $h = shift;
+ my $r = '';
+ foreach (sort keys %$h) {
+ $r = dumped($_) . ' => ' . dumped($h->{$_}) . "\n";
+ }
+ return $r;
+ }
+
+ # Run the tests and give results.
+ #
+ # Parameters: reference to list of tests to run
+ # name of class to use for tied hash, or undef if not tied
+ #
+ # Returns: list of [R, W, E] tuples, one for each test.
+ # R is the return value from running the test, W any warnings it gave,
+ # and E any exception raised with 'die'. E and W will be tidied up a
+ # little to remove irrelevant details like line numbers :-)
+ #
+ # Will also run a few of its own 'ok N' tests.
+ #
+ sub runtests {
+ my ($tests, $class) = @_;
+ my @r;
+
+ my (%h, $h);
+ if (defined $class) {
+ $h = eval { tie %h, $class };
+ warn $@ if $@;
+ test(not $@);
+ test(ref($h) eq $class);
+ test(defined(tied(%h)) and tied(%h) =~ /^\Q$class\E/);
+ }
+
+ foreach (@$tests) {
+ my ($result, $warning, $exception);
+ local $SIG{__WARN__} = sub { $warning .= $_[0] };
+ $result = scalar(eval $_);
+ if ($@)
+ {
+ die "$@:$_" unless defined $class;
+ $exception = $@;
+ }
+
+ foreach ($warning, $exception) {
+ next if not defined;
+ s/ at .+ line \d+\.$//mg;
+ s/ at .+ line \d+, at .*//mg;
+ s/ at .+ line \d+, near .*//mg;
+ }
+
+ my (@warnings, %seen);
+ foreach (split /\n/, $warning) {
+ push @warnings, $_ unless $seen{$_}++;
+ }
+ $warning = join("\n", @warnings);
+
+ push @r, [ $result, $warning, $exception ];
+ }
+
+ return @r;
+ }
+
+
+ # Things that should work just the same for an ordinary hash and a
+ # Tie::RefHash.
+ #
+ # Each test is a code string to be eval'd, it should do something with
+ # %h and give a scalar return value. The global $ref and $ref1 may
+ # also be used.
+ #
+ # One thing we don't test is that the ordering from 'keys', 'values'
+ # and 'each' is the same. You can't reasonably expect that.
+ #
+ sub standard_hash_tests {
+ my @r;
+
+ # Library of standard tests on keys, values and each
+ my $STD_TESTS = <<'END'
+ join $;, sort keys %h;
+ join $;, sort values %h;
+ { my ($v, %tmp); $tmp{$v}++ while (defined($v = each %h)); dumph(\%tmp) }
+ { my ($k, $v, %tmp); $tmp{"$k$;$v"}++ while (($k, $v) = each %h); dumph(\%tmp) }
+ END
+ ;
+
+ # Tests on the existence of the element 'foo'
+ my $FOO_TESTS = <<'END'
+ defined $h{foo};
+ exists $h{foo};
+ $h{foo};
+ END
+ ;
+
+ # Test storing and deleting 'foo'
+ push @r, split /\n/, <<"END"
+ $STD_TESTS;
+ $FOO_TESTS;
+ \$h{foo} = undef;
+ $STD_TESTS;
+ $FOO_TESTS;
+ \$h{foo} = 'hello';
+ $STD_TESTS;
+ $FOO_TESTS;
+ delete \$h{foo};
+ $STD_TESTS;
+ $FOO_TESTS;
+ END
+ ;
+
+ # Test storing and removing under ordinary keys
+ my @things = ('boink', 0, 1, '', undef);
+ foreach my $key (map { dumped($_) } @things) {
+ foreach my $value ((map { dumped($_) } @things), '$ref') {
+ push @r, split /\n/, <<"END"
+ \$h{$key} = $value;
+ $STD_TESTS;
+ defined \$h{$key};
+ exists \$h{$key};
+ \$h{$key};
+ delete \$h{$key};
+ $STD_TESTS;
+ defined \$h{$key};
+ exists \$h{$key};
+ \$h{$key};
+ END
+ ;
+ }
+ }
+
+ # Test hash slices
+ my @slicetests;
+ @slicetests = split /\n/, <<'END'
+ @h{'b'} = ();
+ @h{'c'} = ('d');
+ @h{'e'} = ('f', 'g');
+ @h{'h', 'i'} = ();
+ @h{'j', 'k'} = ('l');
+ @h{'m', 'n'} = ('o', 'p');
+ @h{'q', 'r'} = ('s', 't', 'u');
+ END
+ ;
+ my @aaa = @slicetests;
+ foreach (@slicetests) {
+ push @r, $_;
+ push @r, split(/\n/, $STD_TESTS);
+ }
+
+ # Test CLEAR
+ push @r, '%h = ();', split(/\n/, $STD_TESTS);
+
+ return @r;
+ }
+
diff -c /dev/null 'perl-5.7.2/lib/Tie/SubstrHash.t'
Index: ./lib/Tie/SubstrHash.t
*** ./lib/Tie/SubstrHash.t Thu Jan 1 02:00:00 1970
--- ./lib/Tie/SubstrHash.t Mon Jul 9 17:10:45 2001
***************
*** 0 ****
--- 1,111 ----
+ #!/usr/bin/perl -w
+ #
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ }
+
+ print "1..20\n";
+
+ use strict;
+
+ require Tie::SubstrHash;
+
+ my %a;
+
+ tie %a, 'Tie::SubstrHash', 3, 3, 3;
+
+ $a{abc} = 123;
+ $a{bcd} = 234;
+
+ print "not " unless $a{abc} == 123;
+ print "ok 1\n";
+
+ print "not " unless keys %a == 2;
+ print "ok 2\n";
+
+ delete $a{abc};
+
+ print "not " unless $a{bcd} == 234;
+ print "ok 3\n";
+
+ print "not " unless (values %a)[0] == 234;
+ print "ok 4\n";
+
+ eval { $a{abcd} = 123 };
+ print "not " unless $@ =~ /Key "abcd" is not 3 characters long/;
+ print "ok 5\n";
+
+ eval { $a{abc} = 1234 };
+ print "not " unless $@ =~ /Value "1234" is not 3 characters long/;
+ print "ok 6\n";
+
+ eval { $a = $a{abcd}; $a++ };
+ print "not " unless $@ =~ /Key "abcd" is not 3 characters long/;
+ print "ok 7\n";
+
+ @a{qw(abc cde)} = qw(123 345);
+
+ print "not " unless $a{cde} == 345;
+ print "ok 8\n";
+
+ eval { $a{def} = 456 };
+ print "not " unless $@ =~ /Table is full \(3 elements\)/;
+ print "ok 9\n";
+
+ %a = ();
+
+ print "not " unless keys %a == 0;
+ print "ok 10\n";
+
+ # Tests 11..16 by Linc Madison.
+
+ my $hashsize = 119; # arbitrary values from my data
+ my %test;
+ tie %test, "Tie::SubstrHash", 13, 86, $hashsize;
+
+ for (my $i = 1; $i <= $hashsize; $i++) {
+ my $key1 = $i + 100_000; # fix to uniform 6-digit numbers
+ my $key2 = "abcdefg$key1";
+ $test{$key2} = ("abcdefgh" x 10) . "$key1";
+ }
+
+ for (my $i = 1; $i <= $hashsize; $i++) {
+ my $key1 = $i + 100_000;
+ my $key2 = "abcdefg$key1";
+ unless ($test{$key2}) {
+ print "not ";
+ last;
+ }
+ }
+ print "ok 11\n";
+
+ print "not " unless Tie::SubstrHash::findgteprime(1) == 2;
+ print "ok 12\n";
+
+ print "not " unless Tie::SubstrHash::findgteprime(2) == 2;
+ print "ok 13\n";
+
+ print "not " unless Tie::SubstrHash::findgteprime(5.5) == 7;
+ print "ok 14\n";
+
+ print "not " unless Tie::SubstrHash::findgteprime(13) == 13;
+ print "ok 15\n";
+
+ print "not " unless Tie::SubstrHash::findgteprime(13.000001) == 17;
+ print "ok 16\n";
+
+ print "not " unless Tie::SubstrHash::findgteprime(114) == 127;
+ print "ok 17\n";
+
+ print "not " unless Tie::SubstrHash::findgteprime(1000) == 1009;
+ print "ok 18\n";
+
+ print "not " unless Tie::SubstrHash::findgteprime(1024) == 1031;
+ print "ok 19\n";
+
+ print "not " unless Tie::SubstrHash::findgteprime(10000) == 10007;
+ print "ok 20\n";
+
diff -c 'perl-5.7.1/lib/Time/Local.pm' 'perl-5.7.2/lib/Time/Local.pm'
Index: ./lib/Time/Local.pm
*** ./lib/Time/Local.pm Tue Mar 6 04:05:37 2001
--- ./lib/Time/Local.pm Mon Jul 9 17:10:46 2001
***************
*** 4,10 ****
use Carp;
use strict;
! our $VERSION = '1.00';
our @ISA = qw( Exporter );
our @EXPORT = qw( timegm timelocal );
our @EXPORT_OK = qw( timegm_nocheck timelocal_nocheck );
--- 4,10 ----
use Carp;
use strict;
! our $VERSION = '1.01';
our @ISA = qw( Exporter );
our @EXPORT = qw( timegm timelocal );
our @EXPORT_OK = qw( timegm_nocheck timelocal_nocheck );
***************
*** 87,98 ****
sub cheat {
my($ym, @date) = @_;
my($sec, $min, $hour, $day, $month, $year) = @date;
unless ($Options{no_range_check}) {
! croak "Month '$month' out of range 0..11" if $month > 11 || $month < 0;
! croak "Day '$day' out of range 1..31" if $day > 31 || $day < 1;
! croak "Hour '$hour' out of range 0..23" if $hour > 23 || $hour < 0;
! croak "Minute '$min' out of range 0..59" if $min > 59 || $min < 0;
! croak "Second '$sec' out of range 0..59" if $sec > 59 || $sec < 0;
}
my $guess = $^T;
my @g = gmtime($guess);
--- 87,100 ----
sub cheat {
my($ym, @date) = @_;
my($sec, $min, $hour, $day, $month, $year) = @date;
+ my($md);
unless ($Options{no_range_check}) {
! croak "Month '$month' out of range 0..11" if $month > 11 || $month < 0;
! $md = (31, 29, 31, 30, 31, 30, 31, 30, 30, 31, 30, 31)[$month];
! croak "Day '$day' out of range 1..$md" if $day > $md || $day < 1;
! croak "Hour '$hour' out of range 0..23" if $hour > 23 || $hour < 0;
! croak "Minute '$min' out of range 0..59" if $min > 59 || $min < 0;
! croak "Second '$sec' out of range 0..59" if $sec > 59 || $sec < 0;
}
my $guess = $^T;
my @g = gmtime($guess);
***************
*** 151,158 ****
January 1, 1970). This value can be positive or negative.
It is worth drawing particular attention to the expected ranges for
! the values provided. While the day of the month is expected to be in
! the range 1..31, the month should be in the range 0..11.
This is consistent with the values returned from localtime() and gmtime().
The timelocal() and timegm() functions perform range checking on the
--- 153,160 ----
January 1, 1970). This value can be positive or negative.
It is worth drawing particular attention to the expected ranges for
! the values provided. The value for the day of the month is the actual day
! (ie 1..31), while the month is the number of months since January (0..11).
This is consistent with the values returned from localtime() and gmtime().
The timelocal() and timegm() functions perform range checking on the
diff -c /dev/null 'perl-5.7.2/lib/Time/Local.t'
Index: ./lib/Time/Local.t
*** ./lib/Time/Local.t Thu Jan 1 02:00:00 1970
--- ./lib/Time/Local.t Mon Jul 9 17:10:46 2001
***************
*** 0 ****
--- 1,90 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use Time::Local;
+
+ # Set up time values to test
+ @time =
+ (
+ #year,mon,day,hour,min,sec
+ [1970, 1, 2, 00, 00, 00],
+ [1980, 2, 28, 12, 00, 00],
+ [1980, 2, 29, 12, 00, 00],
+ [1999, 12, 31, 23, 59, 59],
+ [2000, 1, 1, 00, 00, 00],
+ [2010, 10, 12, 14, 13, 12],
+ );
+
+ # use vmsish 'time' makes for oddness around the Unix epoch
+ if ($^O eq 'VMS') { $time[0][2]++ }
+
+ print "1..", @time * 2 + 5, "\n";
+
+ $count = 1;
+ for (@time) {
+ my($year, $mon, $mday, $hour, $min, $sec) = @$_;
+ $year -= 1900;
+ $mon --;
+ my $time = timelocal($sec,$min,$hour,$mday,$mon,$year);
+ # print scalar(localtime($time)), "\n";
+ my($s,$m,$h,$D,$M,$Y) = localtime($time);
+
+ if ($s == $sec &&
+ $m == $min &&
+ $h == $hour &&
+ $D == $mday &&
+ $M == $mon &&
+ $Y == $year
+ ) {
+ print "ok $count\n";
+ } else {
+ print "not ok $count\n";
+ }
+ $count++;
+
+ # Test gmtime function
+ $time = timegm($sec,$min,$hour,$mday,$mon,$year);
+ ($s,$m,$h,$D,$M,$Y) = gmtime($time);
+
+ if ($s == $sec &&
+ $m == $min &&
+ $h == $hour &&
+ $D == $mday &&
+ $M == $mon &&
+ $Y == $year
+ ) {
+ print "ok $count\n";
+ } else {
+ print "not ok $count\n";
+ }
+ $count++;
+ }
+
+ #print "Testing that the differences between a few dates makes sence...\n";
+
+ timelocal(0,0,1,1,0,90) - timelocal(0,0,0,1,0,90) == 3600
+ or print "not ";
+ print "ok ", $count++, "\n";
+
+ timelocal(1,2,3,1,0,100) - timelocal(1,2,3,31,11,99) == 24 * 3600
+ or print "not ";
+ print "ok ", $count++, "\n";
+
+ # Diff beween Jan 1, 1970 and Mar 1, 1970 = (31 + 28 = 59 days)
+ timegm(0,0,0, 1, 2, 70) - timegm(0,0,0, 1, 0, 70) == 59 * 24 * 3600
+ or print "not ";
+ print "ok ", $count++, "\n";
+
+
+ #print "Testing timelocal.pl module too...\n";
+ package test;
+ require 'timelocal.pl';
+ timegm(0,0,0,1,0,70) == main::timegm(0,0,0,1,0,70) or print "not ";
+ print "ok ", $main::count++, "\n";
+
+ timelocal(1,2,3,4,5,78) == main::timelocal(1,2,3,4,5,78) or print "not ";
+ print "ok ", $main::count++, "\n";
diff -c /dev/null 'perl-5.7.2/lib/Time/gmtime.t'
Index: ./lib/Time/gmtime.t
*** ./lib/Time/gmtime.t Thu Jan 1 02:00:00 1970
--- ./lib/Time/gmtime.t Mon Jul 9 17:10:46 2001
***************
*** 0 ****
--- 1,57 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ BEGIN {
+ our $hasgm;
+ eval { my $n = gmtime 0 };
+ $hasgm = 1 unless $@ && $@ =~ /unimplemented/;
+ unless ($hasgm) { print "1..0 # Skip: no gmtime\n"; exit 0 }
+ }
+
+ BEGIN {
+ our @gmtime = gmtime 0; # This is the function gmtime.
+ unless (@gmtime) { print "1..0 # Skip: gmtime failed\n"; exit 0 }
+ }
+
+ print "1..10\n";
+
+ use Time::gmtime;
+
+ print "ok 1\n";
+
+ my $gmtime = gmtime 0 ; # This is the OO gmtime.
+
+ print "not " unless $gmtime->sec == $gmtime[0];
+ print "ok 2\n";
+
+ print "not " unless $gmtime->min == $gmtime[1];
+ print "ok 3\n";
+
+ print "not " unless $gmtime->hour == $gmtime[2];
+ print "ok 4\n";
+
+ print "not " unless $gmtime->mday == $gmtime[3];
+ print "ok 5\n";
+
+ print "not " unless $gmtime->mon == $gmtime[4];
+ print "ok 6\n";
+
+ print "not " unless $gmtime->year == $gmtime[5];
+ print "ok 7\n";
+
+ print "not " unless $gmtime->wday == $gmtime[6];
+ print "ok 8\n";
+
+ print "not " unless $gmtime->yday == $gmtime[7];
+ print "ok 9\n";
+
+ print "not " unless $gmtime->isdst == $gmtime[8];
+ print "ok 10\n";
+
+
+
+
diff -c /dev/null 'perl-5.7.2/lib/Time/localtime.t'
Index: ./lib/Time/localtime.t
*** ./lib/Time/localtime.t Thu Jan 1 02:00:00 1970
--- ./lib/Time/localtime.t Mon Jul 9 17:10:46 2001
***************
*** 0 ****
--- 1,57 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ BEGIN {
+ our $haslocal;
+ eval { my $n = localtime 0 };
+ $haslocal = 1 unless $@ && $@ =~ /unimplemented/;
+ unless ($haslocal) { print "1..0 # Skip: no localtime\n"; exit 0 }
+ }
+
+ BEGIN {
+ our @localtime = localtime 0; # This is the function localtime.
+ unless (@localtime) { print "1..0 # Skip: localtime failed\n"; exit 0 }
+ }
+
+ print "1..10\n";
+
+ use Time::localtime;
+
+ print "ok 1\n";
+
+ my $localtime = localtime 0 ; # This is the OO localtime.
+
+ print "not " unless $localtime->sec == $localtime[0];
+ print "ok 2\n";
+
+ print "not " unless $localtime->min == $localtime[1];
+ print "ok 3\n";
+
+ print "not " unless $localtime->hour == $localtime[2];
+ print "ok 4\n";
+
+ print "not " unless $localtime->mday == $localtime[3];
+ print "ok 5\n";
+
+ print "not " unless $localtime->mon == $localtime[4];
+ print "ok 6\n";
+
+ print "not " unless $localtime->year == $localtime[5];
+ print "ok 7\n";
+
+ print "not " unless $localtime->wday == $localtime[6];
+ print "ok 8\n";
+
+ print "not " unless $localtime->yday == $localtime[7];
+ print "ok 9\n";
+
+ print "not " unless $localtime->isdst == $localtime[8];
+ print "ok 10\n";
+
+
+
+
diff -c /dev/null 'perl-5.7.2/lib/UnicodeCD.pm'
Index: ./lib/UnicodeCD.pm
*** ./lib/UnicodeCD.pm Thu Jan 1 02:00:00 1970
--- ./lib/UnicodeCD.pm Thu Jul 12 18:22:37 2001
***************
*** 0 ****
--- 1,607 ----
+ package UnicodeCD;
+
+ use strict;
+ use warnings;
+
+ our $VERSION = '0.1';
+
+ require Exporter;
+
+ our @ISA = qw(Exporter);
+ our @EXPORT_OK = qw(charinfo
+ charblock charscript
+ charblocks charscripts
+ charinrange
+ compexcl
+ casefold casespec);
+
+ use Carp;
+
+ =head1 NAME
+
+ UnicodeCD - Unicode character database
+
+ =head1 SYNOPSIS
+
+ use UnicodeCD 'charinfo';
+ my $charinfo = charinfo($codepoint);
+
+ use UnicodeCD 'charblock';
+ my $charblock = charblock($codepoint);
+
+ use UnicodeCD 'charscript';
+ my $charscript = charblock($codepoint);
+
+ =head1 DESCRIPTION
+
+ The Unicode module offers a simple interface to the Unicode Character
+ Database.
+
+ =cut
+
+ my $UNICODEFH;
+ my $BLOCKSFH;
+ my $SCRIPTSFH;
+ my $VERSIONFH;
+ my $COMPEXCLFH;
+ my $CASEFOLDFH;
+ my $CASESPECFH;
+
+ sub openunicode {
+ my ($rfh, @path) = @_;
+ my $f;
+ unless (defined $$rfh) {
+ for my $d (@INC) {
+ use File::Spec;
+ $f = File::Spec->catfile($d, "unicode", @path);
+ last if open($$rfh, $f);
+ undef $f;
+ }
+ croak __PACKAGE__, ": failed to find ",
+ File::Spec->catfile(@path), " in @INC"
+ unless defined $f;
+ }
+ return $f;
+ }
+
+ =head2 charinfo
+
+ use UnicodeCD 'charinfo';
+
+ my $charinfo = charinfo(0x41);
+
+ charinfo() returns a reference to a hash that has the following fields
+ as defined by the Unicode standard:
+
+ key
+
+ code code point with at least four hexdigits
+ name name of the character IN UPPER CASE
+ category general category of the character
+ combining classes used in the Canonical Ordering Algorithm
+ bidi bidirectional category
+ decomposition character decomposition mapping
+ decimal if decimal digit this is the integer numeric value
+ digit if digit this is the numeric value
+ numeric if numeric is the integer or rational numeric value
+ mirrored if mirrored in bidirectional text
+ unicode10 Unicode 1.0 name if existed and different
+ comment ISO 10646 comment field
+ upper uppercase equivalent mapping
+ lower lowercase equivalent mapping
+ title titlecase equivalent mapping
+
+ block block the character belongs to (used in \p{In...})
+ script script the character belongs to
+
+ If no match is found, a reference to an empty hash is returned.
+
+ The C<block> property is the same as as returned by charinfo(). It is
+ not defined in the Unicode Character Database proper (Chapter 4 of the
+ Unicode 3.0 Standard) but instead in an auxiliary database (Chapter 14
+ of TUS3). Similarly for the C<script> property.
+
+ Note that you cannot do (de)composition and casing based solely on the
+ above C<decomposition> and C<lower>, C<upper>, C<title>, properties,
+ you will need also the compexcl(), casefold(), and casespec() functions.
+
+ =cut
+
+ sub _getcode {
+ my $arg = shift;
+
+ if ($arg =~ /^\d+$/) {
+ return $arg;
+ } elsif ($arg =~ /^(?:U\+|0x)?([[:xdigit:]]+)$/) {
+ return hex($1);
+ }
+
+ return;
+ }
+
+ sub charinfo {
+ my $arg = shift;
+ my $code = _getcode($arg);
+ croak __PACKAGE__, "::charinfo: unknown code '$arg'"
+ unless defined $code;
+ my $hexk = sprintf("%04X", $code);
+
+ openunicode(\$UNICODEFH, "Unicode.txt");
+ if (defined $UNICODEFH) {
+ use Search::Dict;
+ if (look($UNICODEFH, "$hexk;") >= 0) {
+ my $line = <$UNICODEFH>;
+ chomp $line;
+ my %prop;
+ @prop{qw(
+ code name category
+ combining bidi decomposition
+ decimal digit numeric
+ mirrored unicode10 comment
+ upper lower title
+ )} = split(/;/, $line, -1);
+ if ($prop{code} eq $hexk) {
+ $prop{block} = charblock($code);
+ $prop{script} = charscript($code);
+ return \%prop;
+ }
+ }
+ }
+ return;
+ }
+
+ sub _search { # Binary search in a [[lo,hi,prop],[...],...] table.
+ my ($table, $lo, $hi, $code) = @_;
+
+ return if $lo > $hi;
+
+ my $mid = int(($lo+$hi) / 2);
+
+ if ($table->[$mid]->[0] < $code) {
+ if ($table->[$mid]->[1] >= $code) {
+ return $table->[$mid]->[2];
+ } else {
+ _search($table, $mid + 1, $hi, $code);
+ }
+ } elsif ($table->[$mid]->[0] > $code) {
+ _search($table, $lo, $mid - 1, $code);
+ } else {
+ return $table->[$mid]->[2];
+ }
+ }
+
+ sub charinrange {
+ my ($range, $arg) = @_;
+ my $code = _getcode($arg);
+ croak __PACKAGE__, "::charinrange: unknown code '$arg'"
+ unless defined $code;
+ _search($range, 0, $#$range, $code);
+ }
+
+ =head2 charblock
+
+ use UnicodeCD 'charblock';
+
+ my $charblock = charblock(0x41);
+ my $charblock = charblock(1234);
+ my $charblock = charblock("0x263a");
+ my $charblock = charblock("U+263a");
+
+ my $ranges = charblock('Armenian');
+
+ With a B<code point argument> charblock() returns the block the character
+ belongs to, e.g. C<Basic Latin>. Note that not all the character
+ positions within all blocks are defined.
+
+ If supplied with an argument that can't be a code point, charblock()
+ tries to do the opposite and interpret the argument as a character
+ block. The return value is a I<range>: an anonymous list that
+ contains anonymous lists, which in turn contain I<start-of-range>,
+ I<end-of-range> code point pairs. You can test whether a code point
+ is in a range using the L</charinrange> function. If the argument is
+ not a known charater block, C<undef> is returned.
+
+ =cut
+
+ my @BLOCKS;
+ my %BLOCKS;
+
+ sub _charblocks {
+ unless (@BLOCKS) {
+ if (openunicode(\$BLOCKSFH, "Blocks.txt")) {
+ while (<$BLOCKSFH>) {
+ if (/^([0-9A-F]+)\.\.([0-9A-F]+);\s+(.+)/) {
+ my ($lo, $hi) = (hex($1), hex($2));
+ my $subrange = [ $lo, $hi, $3 ];
+ push @BLOCKS, $subrange;
+ push @{$BLOCKS{$3}}, $subrange;
+ }
+ }
+ close($BLOCKSFH);
+ }
+ }
+ }
+
+ sub charblock {
+ my $arg = shift;
+
+ _charblocks() unless @BLOCKS;
+
+ my $code = _getcode($arg);
+
+ if (defined $code) {
+ _search(\@BLOCKS, 0, $#BLOCKS, $code);
+ } else {
+ if (exists $BLOCKS{$arg}) {
+ return $BLOCKS{$arg};
+ } else {
+ return;
+ }
+ }
+ }
+
+ =head2 charscript
+
+ use UnicodeCD 'charscript';
+
+ my $charscript = charscript(0x41);
+ my $charscript = charscript(1234);
+ my $charscript = charscript("U+263a");
+
+ my $ranges = charscript('Thai');
+
+ With a B<code point argument> charscript() returns the script the
+ character belongs to, e.g. C<Latin>, C<Greek>, C<Han>.
+
+ If supplied with an argument that can't be a code point, charscript()
+ tries to do the opposite and interpret the argument as a character
+ script. The return value is a I<range>: an anonymous list that
+ contains anonymous lists, which in turn contain I<start-of-range>,
+ I<end-of-range> code point pairs. You can test whether a code point
+ is in a range using the L</charinrange> function. If the argument is
+ not a known charater script, C<undef> is returned.
+
+ =cut
+
+ my @SCRIPTS;
+ my %SCRIPTS;
+
+ sub _charscripts {
+ unless (@SCRIPTS) {
+ if (openunicode(\$SCRIPTSFH, "Scripts.txt")) {
+ while (<$SCRIPTSFH>) {
+ if (/^([0-9A-F]+)(?:\.\.([0-9A-F]+))?\s+;\s+(\w+)/) {
+ my ($lo, $hi) = (hex($1), $2 ? hex($2) : hex($1));
+ my $script = lc($3);
+ $script =~ s/\b(\w)/uc($1)/ge;
+ my $subrange = [ $lo, $hi, $script ];
+ push @SCRIPTS, $subrange;
+ push @{$SCRIPTS{$script}}, $subrange;
+ }
+ }
+ close($SCRIPTSFH);
+ @SCRIPTS = sort { $a->[0] <=> $b->[0] } @SCRIPTS;
+ }
+ }
+ }
+
+ sub charscript {
+ my $arg = shift;
+
+ _charscripts() unless @SCRIPTS;
+
+ my $code = _getcode($arg);
+
+ if (defined $code) {
+ _search(\@SCRIPTS, 0, $#SCRIPTS, $code);
+ } else {
+ if (exists $SCRIPTS{$arg}) {
+ return $SCRIPTS{$arg};
+ } else {
+ return;
+ }
+ }
+ }
+
+ =head2 charblocks
+
+ use UnicodeCD 'charblocks';
+
+ my $charblocks = charblocks();
+
+ charblocks() returns a reference to a hash with the known block names
+ as the keys, and the code point ranges (see L</charblock>) as the values.
+
+ =cut
+
+ sub charblocks {
+ _charblocks() unless %BLOCKS;
+ return \%BLOCKS;
+ }
+
+ =head2 charscripts
+
+ use UnicodeCD 'charscripts';
+
+ my %charscripts = charscripts();
+
+ charscripts() returns a hash with the known script names as the keys,
+ and the code point ranges (see L</charscript>) as the values.
+
+ =cut
+
+ sub charscripts {
+ _charscripts() unless %SCRIPTS;
+ return \%SCRIPTS;
+ }
+
+ =head2 Blocks versus Scripts
+
+ The difference between a block and a script is that scripts are closer
+ to the linguistic notion of a set of characters required to present
+ languages, while block is more of an artifact of the Unicode character
+ numbering and separation into blocks of 256 characters.
+
+ For example the Latin B<script> is spread over several B<blocks>, such
+ as C<Basic Latin>, C<Latin 1 Supplement>, C<Latin Extended-A>, and
+ C<Latin Extended-B>. On the other hand, the Latin script does not
+ contain all the characters of the C<Basic Latin> block (also known as
+ the ASCII): it includes only the letters, not for example the digits
+ or the punctuation.
+
+ For blocks see http://www.unicode.org/Public/UNIDATA/Blocks.txt
+
+ For scripts see UTR #24: http://www.unicode.org/unicode/reports/tr24/
+
+ =head2 Matching Scripts and Blocks
+
+ Both scripts and blocks can be matched using the regular expression
+ construct C<\p{In...}> and its negation C<\P{In...}>.
+
+ The name of the script or the block comes after the C<In>, for example
+ C<\p{InCyrillic}>, C<\P{InBasicLatin}>. Spaces and dashes ('-') are
+ removed from the names for the C<\p{In...}>, for example
+ C<LatinExtendedA> instead of C<Latin Extended-A>.
+
+ There are a few cases where there exists both a script and a block by
+ the same name, in these cases the block version has C<Block> appended:
+ C<\p{InKatakana}> is the script, C<\p{InKatakanaBlock}> is the block.
+
+ =head2 Code Point Arguments
+
+ A <code point argument> is either a decimal or a hexadecimal scalar,
+ or "U+" followed by hexadecimals.
+
+ =head2 charinrange
+
+ In addition to using the C<\p{In...}> and C<\P{In...}> constructs, you
+ can also test whether a code point is in the I<range> as returned by
+ L</charblock> and L</charscript> or as the values of the hash returned
+ by L</charblocks> and </charscripts> by using charinrange():
+
+ use UnicodeCD qw(charscript charinrange);
+
+ $range = charscript('Hiragana');
+ print "looks like hiragana\n" if charinrange($range, $code);
+
+ =cut
+
+ =head2 compexcl
+
+ use UnicodeCD 'compexcl';
+
+ my $compexcl = compexcl("09dc");
+
+ The compexcl() returns the composition exclusion (that is, if the
+ character cannot be decomposed) of the character specified by a B<code
+ point argument>.
+
+ If there is a composition exclusion for the character, true is
+ returned. Otherwise, false is returned.
+
+ =cut
+
+ my %COMPEXCL;
+
+ sub _compexcl {
+ unless (%COMPEXCL) {
+ if (openunicode(\$COMPEXCLFH, "CompExcl.txt")) {
+ while (<$COMPEXCLFH>) {
+ if (/^([0-9A-F]+) \# /) {
+ my $code = hex($1);
+ $COMPEXCL{$code} = undef;
+ }
+ }
+ close($COMPEXCLFH);
+ }
+ }
+ }
+
+ sub compexcl {
+ my $arg = shift;
+ my $code = _getcode($arg);
+
+ _compexcl() unless %COMPEXCL;
+
+ return exists $COMPEXCL{$code};
+ }
+
+ =head2 casefold
+
+ use UnicodeCD 'casefold';
+
+ my %casefold = casefold("09dc");
+
+ The casefold() returns the locale-independent case folding of the
+ character specified by a B<code point argument>.
+
+ If there is a case folding for that character, a reference to a hash
+ with the following fields is returned:
+
+ key
+
+ code code point with at least four hexdigits
+ status "C", "F", "S", or "I"
+ mapping one or more codes separated by spaces
+
+ The meaning of the I<status> is as follows:
+
+ C common case folding, common mappings shared
+ by both simple and full mappings
+ F full case folding, mappings that cause strings
+ to grow in length. Multiple characters are separated
+ by spaces
+ S simple case folding, mappings to single characters
+ where different from F
+ I special case for dotted uppercase I and
+ dotless lowercase i
+ - If this mapping is included, the result is
+ case-insensitive, but dotless and dotted I's
+ are not distinguished
+ - If this mapping is excluded, the result is not
+ fully case-insensitive, but dotless and dotted
+ I's are distinguished
+
+ If there is no case folding for that character, C<undef> is returned.
+
+ For more information about case mappings see
+ http://www.unicode.org/unicode/reports/tr21/
+
+ =cut
+
+ my %CASEFOLD;
+
+ sub _casefold {
+ unless (%CASEFOLD) {
+ if (openunicode(\$CASEFOLDFH, "CaseFold.txt")) {
+ while (<$CASEFOLDFH>) {
+ if (/^([0-9A-F]+); ([CFSI]); ([0-9A-F]+(?: [0-9A-F]+)*);/) {
+ my $code = hex($1);
+ $CASEFOLD{$code} = { code => $1,
+ status => $2,
+ mapping => $3 };
+ }
+ }
+ close($CASEFOLDFH);
+ }
+ }
+ }
+
+ sub casefold {
+ my $arg = shift;
+ my $code = _getcode($arg);
+
+ _casefold() unless %CASEFOLD;
+
+ return $CASEFOLD{$code};
+ }
+
+ =head2 casespec
+
+ use UnicodeCD 'casespec';
+
+ my %casespec = casespec("09dc");
+
+ The casespec() returns the potentially locale-dependent case mapping
+ of the character specified by a B<code point argument>. The mapping
+ may change the length of the string (which the basic Unicode case
+ mappings as returned by charinfo() never do).
+
+ If there is a case folding for that character, a reference to a hash
+ with the following fields is returned:
+
+ key
+
+ code code point with at least four hexdigits
+ lower lowercase
+ title titlecase
+ upper uppercase
+ condition condition list (may be undef)
+
+ The C<condition> is optional. Where present, it consists of one or
+ more I<locales> or I<contexts>, separated by spaces (other than as
+ used to separate elements, spaces are to be ignored). A condition
+ list overrides the normal behavior if all of the listed conditions are
+ true. Case distinctions in the condition list are not significant.
+ Conditions preceded by "NON_" represent the negation of the condition
+
+ A I<locale> is defined as a 2-letter ISO 3166 country code, possibly
+ followed by a "_" and a 2-letter ISO language code (, possibly followed
+ by a "_" and a variant code). You can find the list of those codes
+ in L<Locale::Country> and L<Locale::Language>.
+
+ A I<context> is one of the following choices:
+
+ FINAL The letter is not followed by a letter of
+ general category L (e.g. Ll, Lt, Lu, Lm, or Lo)
+ MODERN The mapping is only used for modern text
+ AFTER_i The last base character was "i" 0069
+
+ For more information about case mappings see
+ http://www.unicode.org/unicode/reports/tr21/
+
+ =cut
+
+ my %CASESPEC;
+
+ sub _casespec {
+ unless (%CASESPEC) {
+ if (openunicode(\$CASESPECFH, "SpecCase.txt")) {
+ while (<$CASESPECFH>) {
+ if (/^([0-9A-F]+); ([0-9A-F]+(?: [0-9A-F]+)*)?; ([0-9A-F]+(?: [0-9A-F]+)*)?; ([0-9A-F]+(?: [0-9A-F]+)*)?; (\w+(?: \w+)*)?/) {
+ my $code = hex($1);
+ $CASESPEC{$code} = { code => $1,
+ lower => $2,
+ title => $3,
+ upper => $4,
+ condition => $5 };
+ }
+ }
+ close($CASESPECFH);
+ }
+ }
+ }
+
+ sub casespec {
+ my $arg = shift;
+ my $code = _getcode($arg);
+
+ _casespec() unless %CASESPEC;
+
+ return $CASESPEC{$code};
+ }
+
+ =head2 UnicodeCD::UnicodeVersion
+
+ UnicodeCD::UnicodeVersion() returns the version of the Unicode Character
+ Database, in other words, the version of the Unicode standard the
+ database implements.
+
+ =cut
+
+ my $UNICODEVERSION;
+
+ sub UnicodeVersion {
+ unless (defined $UNICODEVERSION) {
+ openunicode(\$VERSIONFH, "version");
+ chomp($UNICODEVERSION = <$VERSIONFH>);
+ close($VERSIONFH);
+ croak __PACKAGE__, "::VERSION: strange version '$UNICODEVERSION'"
+ unless $UNICODEVERSION =~ /^\d+(?:\.\d+)+$/;
+ }
+ return $UNICODEVERSION;
+ }
+
+ =head2 Implementation Note
+
+ The first use of charinfo() opens a read-only filehandle to the Unicode
+ Character Database (the database is included in the Perl distribution).
+ The filehandle is then kept open for further queries.
+
+ =head1 AUTHOR
+
+ Jarkko Hietaniemi
+
+ =cut
+
+ 1;
diff -c /dev/null 'perl-5.7.2/lib/UnicodeCD.t'
Index: ./lib/UnicodeCD.t
*** ./lib/UnicodeCD.t Thu Jan 1 02:00:00 1970
--- ./lib/UnicodeCD.t Thu Jul 12 18:22:26 2001
***************
*** 0 ****
--- 1,207 ----
+ use UnicodeCD;
+
+ use Test;
+ use strict;
+
+ BEGIN { plan tests => 111 };
+
+ use UnicodeCD 'charinfo';
+
+ my $charinfo;
+
+ $charinfo = charinfo(0x41);
+
+ ok($charinfo->{code}, '0041');
+ ok($charinfo->{name}, 'LATIN CAPITAL LETTER A');
+ ok($charinfo->{category}, 'Lu');
+ ok($charinfo->{combining}, '0');
+ ok($charinfo->{bidi}, 'L');
+ ok($charinfo->{decomposition}, '');
+ ok($charinfo->{decimal}, '');
+ ok($charinfo->{digit}, '');
+ ok($charinfo->{numeric}, '');
+ ok($charinfo->{mirrored}, 'N');
+ ok($charinfo->{unicode10}, '');
+ ok($charinfo->{comment}, '');
+ ok($charinfo->{upper}, '');
+ ok($charinfo->{lower}, '0061');
+ ok($charinfo->{title}, '');
+ ok($charinfo->{block}, 'Basic Latin');
+ ok($charinfo->{script}, 'Latin');
+
+ $charinfo = charinfo(0x100);
+
+ ok($charinfo->{code}, '0100');
+ ok($charinfo->{name}, 'LATIN CAPITAL LETTER A WITH MACRON');
+ ok($charinfo->{category}, 'Lu');
+ ok($charinfo->{combining}, '0');
+ ok($charinfo->{bidi}, 'L');
+ ok($charinfo->{decomposition}, '0041 0304');
+ ok($charinfo->{decimal}, '');
+ ok($charinfo->{digit}, '');
+ ok($charinfo->{numeric}, '');
+ ok($charinfo->{mirrored}, 'N');
+ ok($charinfo->{unicode10}, 'LATIN CAPITAL LETTER A MACRON');
+ ok($charinfo->{comment}, '');
+ ok($charinfo->{upper}, '');
+ ok($charinfo->{lower}, '0101');
+ ok($charinfo->{title}, '');
+ ok($charinfo->{block}, 'Latin Extended-A');
+ ok($charinfo->{script}, 'Latin');
+
+ # 0x0590 is in the Hebrew block but unused.
+
+ $charinfo = charinfo(0x590);
+
+ ok($charinfo->{code}, undef);
+ ok($charinfo->{name}, undef);
+ ok($charinfo->{category}, undef);
+ ok($charinfo->{combining}, undef);
+ ok($charinfo->{bidi}, undef);
+ ok($charinfo->{decomposition}, undef);
+ ok($charinfo->{decimal}, undef);
+ ok($charinfo->{digit}, undef);
+ ok($charinfo->{numeric}, undef);
+ ok($charinfo->{mirrored}, undef);
+ ok($charinfo->{unicode10}, undef);
+ ok($charinfo->{comment}, undef);
+ ok($charinfo->{upper}, undef);
+ ok($charinfo->{lower}, undef);
+ ok($charinfo->{title}, undef);
+ ok($charinfo->{block}, undef);
+ ok($charinfo->{script}, undef);
+
+ # 0x05d0 is in the Hebrew block and used.
+
+ $charinfo = charinfo(0x5d0);
+
+ ok($charinfo->{code}, '05D0');
+ ok($charinfo->{name}, 'HEBREW LETTER ALEF');
+ ok($charinfo->{category}, 'Lo');
+ ok($charinfo->{combining}, '0');
+ ok($charinfo->{bidi}, 'R');
+ ok($charinfo->{decomposition}, '');
+ ok($charinfo->{decimal}, '');
+ ok($charinfo->{digit}, '');
+ ok($charinfo->{numeric}, '');
+ ok($charinfo->{mirrored}, 'N');
+ ok($charinfo->{unicode10}, '');
+ ok($charinfo->{comment}, '');
+ ok($charinfo->{upper}, '');
+ ok($charinfo->{lower}, '');
+ ok($charinfo->{title}, '');
+ ok($charinfo->{block}, 'Hebrew');
+ ok($charinfo->{script}, 'Hebrew');
+
+ use UnicodeCD qw(charblock charscript);
+
+ # 0x0590 is in the Hebrew block but unused.
+
+ ok(charblock(0x590), 'Hebrew');
+ ok(charscript(0x590), undef);
+
+ $charinfo = charinfo(0xbe);
+
+ ok($charinfo->{code}, '00BE');
+ ok($charinfo->{name}, 'VULGAR FRACTION THREE QUARTERS');
+ ok($charinfo->{category}, 'No');
+ ok($charinfo->{combining}, '0');
+ ok($charinfo->{bidi}, 'ON');
+ ok($charinfo->{decomposition}, '<fraction> 0033 2044 0034');
+ ok($charinfo->{decimal}, '');
+ ok($charinfo->{digit}, '');
+ ok($charinfo->{numeric}, '3/4');
+ ok($charinfo->{mirrored}, 'N');
+ ok($charinfo->{unicode10}, 'FRACTION THREE QUARTERS');
+ ok($charinfo->{comment}, '');
+ ok($charinfo->{upper}, '');
+ ok($charinfo->{lower}, '');
+ ok($charinfo->{title}, '');
+ ok($charinfo->{block}, 'Latin-1 Supplement');
+ ok($charinfo->{script}, undef);
+
+ use UnicodeCD qw(charblocks charscripts);
+
+ my $charblocks = charblocks();
+
+ ok(exists $charblocks->{Thai});
+ ok($charblocks->{Thai}->[0]->[0], hex('0e00'));
+ ok(!exists $charblocks->{PigLatin});
+
+ my $charscripts = charscripts();
+
+ ok(exists $charscripts->{Armenian});
+ ok($charscripts->{Armenian}->[0]->[0], hex('0531'));
+ ok(!exists $charscripts->{PigLatin});
+
+ my $charscript;
+
+ $charscript = charscript("12ab");
+ ok($charscript, 'Ethiopic');
+
+ $charscript = charscript("0x12ab");
+ ok($charscript, 'Ethiopic');
+
+ $charscript = charscript("U+12ab");
+ ok($charscript, 'Ethiopic');
+
+ my $ranges;
+
+ $ranges = charscript('Ogham');
+ ok($ranges->[0]->[0], hex('1681'));
+ ok($ranges->[0]->[1], hex('169a'));
+
+ use UnicodeCD qw(charinrange);
+
+ $ranges = charscript('Cherokee');
+ ok(!charinrange($ranges, "139f"));
+ ok( charinrange($ranges, "13a0"));
+ ok( charinrange($ranges, "13f4"));
+ ok(!charinrange($ranges, "13f5"));
+
+ ok(UnicodeCD::UnicodeVersion, 3.1);
+
+ use UnicodeCD qw(compexcl);
+
+ ok(!compexcl(0x0100));
+ ok( compexcl(0x0958));
+
+ use UnicodeCD qw(casefold);
+
+ my $casefold;
+
+ $casefold = casefold(0x41);
+
+ ok($casefold->{code} eq '0041' &&
+ $casefold->{status} eq 'C' &&
+ $casefold->{mapping} eq '0061');
+
+ $casefold = casefold(0xdf);
+
+ ok($casefold->{code} eq '00DF' &&
+ $casefold->{status} eq 'F' &&
+ $casefold->{mapping} eq '0073 0073');
+
+ ok(!casefold(0x20));
+
+ use UnicodeCD qw(casespec);
+
+ my $casespec;
+
+ ok(!casespec(0x41));
+
+ $casespec = casespec(0xdf);
+
+ ok($casespec->{code} eq '00DF' &&
+ $casespec->{lower} eq '00DF' &&
+ $casespec->{title} eq '0053 0073' &&
+ $casespec->{upper} eq '0053 0053' &&
+ $casespec->{condition} eq undef);
+
+ $casespec = casespec(0x307);
+
+ ok($casespec->{code} eq '0307' &&
+ $casespec->{lower} eq '0307' &&
+ $casespec->{title} eq '' &&
+ $casespec->{upper} eq '' &&
+ $casespec->{condition} eq 'lt AFTER_i');
diff -c /dev/null 'perl-5.7.2/lib/User/grent.t'
Index: ./lib/User/grent.t
*** ./lib/User/grent.t Thu Jan 1 02:00:00 1970
--- ./lib/User/grent.t Mon Jul 9 17:10:46 2001
***************
*** 0 ****
--- 1,44 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ BEGIN {
+ our $hasgr;
+ eval { my @n = getgrgid 0 };
+ $hasgr = 1 unless $@ && $@ =~ /unimplemented/;
+ unless ($hasgr) { print "1..0 # Skip: no getgrgid\n"; exit 0 }
+ use Config;
+ $hasgr = 0 unless $Config{'i_grp'} eq 'define';
+ unless ($hasgr) { print "1..0 # Skip: no grp.h\n"; exit 0 }
+ }
+
+ BEGIN {
+ our @grent = getgrgid 0; # This is the function getgrgid.
+ unless (@grent) { print "1..0 # Skip: no gid 0\n"; exit 0 }
+ }
+
+ print "1..5\n";
+
+ use User::grent;
+
+ print "ok 1\n";
+
+ my $grent = getgrgid 0; # This is the OO getgrgid.
+
+ print "not " unless $grent->gid == 0;
+ print "ok 2\n";
+
+ print "not " unless $grent->name == $grent[0];
+ print "ok 3\n";
+
+ print "not " unless $grent->passwd eq $grent[1];
+ print "ok 4\n";
+
+ print "not " unless $grent->gid == $grent[2];
+ print "ok 5\n";
+
+ # Testing pretty much anything else is unportable.
+
diff -c /dev/null 'perl-5.7.2/lib/User/pwent.t'
Index: ./lib/User/pwent.t
*** ./lib/User/pwent.t Thu Jan 1 02:00:00 1970
--- ./lib/User/pwent.t Mon Jul 9 17:10:47 2001
***************
*** 0 ****
--- 1,64 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ BEGIN {
+ our $haspw;
+ eval { my @n = getpwuid 0 };
+ $haspw = 1 unless $@ && $@ =~ /unimplemented/;
+ unless ($haspw) { print "1..0 # Skip: no getpwuid\n"; exit 0 }
+ use Config;
+ $haspw = 0 unless $Config{'i_pwd'} eq 'define';
+ unless ($haspw) { print "1..0 # Skip: no pwd.h\n"; exit 0 }
+ }
+
+ BEGIN {
+ our @pwent = getpwuid 0; # This is the function getpwuid.
+ unless (@pwent) { print "1..0 # Skip: no uid 0\n"; exit 0 }
+ }
+
+ print "1..9\n";
+
+ use User::pwent;
+
+ print "ok 1\n";
+
+ my $pwent = getpwuid 0; # This is the OO getpwuid.
+
+ print "not " unless $pwent->uid == 0 ||
+ ($^O eq 'cygwin' && $pwent->uid == 500); # go figure
+ print "ok 2\n";
+
+ print "not " unless $pwent->name == $pwent[0];
+ print "ok 3\n";
+
+ print "not " unless $pwent->passwd eq $pwent[1];
+ print "ok 4\n";
+
+ print "not " unless $pwent->uid == $pwent[2];
+ print "ok 5\n";
+
+ print "not " unless $pwent->gid == $pwent[3];
+ print "ok 6\n";
+
+ # The quota and comment fields are unportable.
+
+ print "not " unless $pwent->gecos eq $pwent[6];
+ print "ok 7\n";
+
+ print "not " unless $pwent->dir eq $pwent[7];
+ print "ok 8\n";
+
+ print "not " unless $pwent->shell eq $pwent[8];
+ print "ok 9\n";
+
+ # The expire field is unportable.
+
+ # Testing pretty much anything else is unportable:
+ # there maybe more than one username with uid 0;
+ # uid 0's home directory may be "/" or "/root' or something else,
+ # and so on.
+
diff -c 'perl-5.7.1/lib/attributes.pm' 'perl-5.7.2/lib/attributes.pm'
Index: ./lib/attributes.pm
*** ./lib/attributes.pm Tue Mar 6 04:05:37 2001
--- ./lib/attributes.pm Mon Jul 9 17:10:47 2001
***************
*** 1,6 ****
package attributes;
! $VERSION = 0.03;
@EXPORT_OK = qw(get reftype);
@EXPORT = ();
--- 1,6 ----
package attributes;
! our $VERSION = 0.04;
@EXPORT_OK = qw(get reftype);
@EXPORT = ();
***************
*** 27,33 ****
#
# The extra trips through newATTRSUB in the interpreter wipe out any savings
# from avoiding the BEGIN block. Just do the bootstrap now.
! BEGIN { bootstrap }
sub import {
@_ > 2 && ref $_[2] or do {
--- 27,33 ----
#
# The extra trips through newATTRSUB in the interpreter wipe out any savings
# from avoiding the BEGIN block. Just do the bootstrap now.
! BEGIN { bootstrap attributes }
sub import {
@_ > 2 && ref $_[2] or do {
***************
*** 130,136 ****
feature. The semantics of such declarations could change or be removed
in future versions. They are present for purposes of experimentation
with what the semantics ought to be. Do not rely on the current
! implementation of this feature.
There are only a few attributes currently handled by Perl itself (or
directly by this module, depending on how you look at it.) However,
--- 130,137 ----
feature. The semantics of such declarations could change or be removed
in future versions. They are present for purposes of experimentation
with what the semantics ought to be. Do not rely on the current
! implementation of this feature. Variable attributes are currently
! not usable for tieing.
There are only a few attributes currently handled by Perl itself (or
directly by this module, depending on how you look at it.) However,
diff -c 'perl-5.7.1/lib/autouse.pm' 'perl-5.7.2/lib/autouse.pm'
Index: ./lib/autouse.pm
*** ./lib/autouse.pm Fri Mar 16 04:54:51 2001
--- ./lib/autouse.pm Mon Jul 9 17:10:47 2001
***************
*** 3,9 ****
#use strict; # debugging only
use 5.003_90; # ->can, for my $var
! $autouse::VERSION = '1.02';
$autouse::DEBUG ||= 0;
--- 3,9 ----
#use strict; # debugging only
use 5.003_90; # ->can, for my $var
! $autouse::VERSION = '1.03';
$autouse::DEBUG ||= 0;
***************
*** 39,45 ****
my $closure_import_func = $func; # Full name
my $closure_func = $func; # Name inside package
! my $index = index($func, '::');
if ($index == -1) {
$closure_import_func = "${callpkg}::$func";
} else {
--- 39,45 ----
my $closure_import_func = $func; # Full name
my $closure_func = $func; # Name inside package
! my $index = rindex($func, '::');
if ($index == -1) {
$closure_import_func = "${callpkg}::$func";
} else {
***************
*** 54,59 ****
--- 54,60 ----
die if $@;
vet_import $module;
}
+ no warnings 'redefine';
*$closure_import_func = \&{"${module}::$closure_func"};
print "autousing $module; "
."imported $closure_func as $closure_import_func\n"
***************
*** 95,115 ****
If the module C<Module> is already loaded, then the declaration
! use autouse 'Module' => qw(func1 func2($;$) Module::func3);
is equivalent to
use Module qw(func1 func2);
! if C<Module> defines func2() with prototype C<($;$)>, and func1() and
! func3() have no prototypes. (At least if C<Module> uses C<Exporter>'s
! C<import>, otherwise it is a fatal error.)
If the module C<Module> is not loaded yet, then the above declaration
! declares functions func1() and func2() in the current package, and
! declares a function Module::func3(). When these functions are called,
! they load the package C<Module> if needed, and substitute themselves
! with the correct definitions.
=head1 WARNING
--- 96,128 ----
If the module C<Module> is already loaded, then the declaration
! use autouse 'Module' => qw(func1 func2($;$));
is equivalent to
use Module qw(func1 func2);
! if C<Module> defines func2() with prototype C<($;$)>, and func1() has
! no prototypes. (At least if C<Module> uses C<Exporter>'s C<import>,
! otherwise it is a fatal error.)
If the module C<Module> is not loaded yet, then the above declaration
! declares functions func1() and func2() in the current package. When
! these functions are called, they load the package C<Module> if needed,
! and substitute themselves with the correct definitions.
!
! =begin _deprecated
!
! use Module qw(Module::func3);
!
! will work and is the equivalent to:
!
! use Module qw(func3);
!
! It is not a very useful feature and has been deprecated.
!
! =end _deprecated
!
=head1 WARNING
diff -c /dev/null 'perl-5.7.2/lib/autouse.t'
Index: ./lib/autouse.t
*** ./lib/autouse.t Thu Jan 1 02:00:00 1970
--- ./lib/autouse.t Mon Jul 9 17:10:47 2001
***************
*** 0 ****
--- 1,57 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use Test;
+ BEGIN { plan tests => 10; }
+
+ BEGIN {
+ require autouse;
+ eval {
+ "autouse"->import('List::Util' => 'List::Util::first(&@)');
+ };
+ ok( !$@ );
+
+ eval {
+ "autouse"->import('List::Util' => 'Foo::min');
+ };
+ ok( $@, qr/^autouse into different package attempted/ );
+
+ "autouse"->import('List::Util' => qw(max first(&@)));
+ }
+
+ my @a = (1,2,3,4,5.5);
+ ok( max(@a), 5.5);
+
+
+ # first() has a prototype of &@. Make sure that's preserved.
+ ok( (first { $_ > 3 } @a), 4);
+
+
+ # Example from the docs.
+ use autouse 'Carp' => qw(carp croak);
+
+ {
+ my @warning;
+ local $SIG{__WARN__} = sub { push @warning, @_ };
+ carp "this carp was predeclared and autoused\n";
+ ok( scalar @warning, 1 );
+ ok( $warning[0], "this carp was predeclared and autoused\n" );
+
+ eval { croak "It is but a scratch!" };
+ ok( $@, qr/^It is but a scratch!/);
+ }
+
+
+ # Test that autouse's lazy module loading works. We assume that nothing
+ # involved in this test uses Text::Soundex, which is pretty safe.
+ use autouse 'Text::Soundex' => qw(soundex);
+
+ my $mod_file = 'Text/Soundex.pm'; # just fine and portable for %INC
+ ok( !exists $INC{$mod_file} );
+ ok( soundex('Basset'), 'B230' );
+ ok( exists $INC{$mod_file} );
+
diff -c 'perl-5.7.1/lib/base.pm' 'perl-5.7.2/lib/base.pm'
Index: ./lib/base.pm
*** ./lib/base.pm Fri Apr 6 01:30:50 2001
--- ./lib/base.pm Mon Jul 9 17:10:47 2001
***************
*** 45,51 ****
package base;
use 5.005_64;
! our $VERSION = "1.01";
sub import {
my $class = shift;
--- 45,51 ----
package base;
use 5.005_64;
! our $VERSION = "1.02";
sub import {
my $class = shift;
***************
*** 56,62 ****
next if $pkg->isa($base);
push @{"$pkg\::ISA"}, $base;
my $vglob;
! unless ($vglob = ${"$base\::"}{VERSION} and $vglob{SCALAR}) {
eval "require $base";
# Only ignore "Can't locate" errors from our eval require.
# Other fatal errors (syntax etc) must be reported.
--- 56,62 ----
next if $pkg->isa($base);
push @{"$pkg\::ISA"}, $base;
my $vglob;
! unless (${*{"$base\::VERSION"}{SCALAR}}) {
eval "require $base";
# Only ignore "Can't locate" errors from our eval require.
# Other fatal errors (syntax etc) must be reported.
***************
*** 68,74 ****
"which defines that package first.)");
}
${"$base\::VERSION"} = "-1, set by base.pm"
! unless $vglob = ${"$base\::"}{VERSION} and $vglob{SCALAR};
}
# A simple test like (defined %{"$base\::FIELDS"}) will
--- 68,74 ----
"which defines that package first.)");
}
${"$base\::VERSION"} = "-1, set by base.pm"
! unless ${*{"$base\::VERSION"}{SCALAR}};
}
# A simple test like (defined %{"$base\::FIELDS"}) will
diff -c /dev/null 'perl-5.7.2/lib/bigfloat.t'
Index: ./lib/bigfloat.t
*** ./lib/bigfloat.t Thu Jan 1 02:00:00 1970
--- ./lib/bigfloat.t Mon Jul 9 17:10:47 2001
***************
*** 0 ****
--- 1,408 ----
+ #!./perl
+
+ BEGIN { @INC = '../lib' }
+ require "bigfloat.pl";
+
+ $test = 0;
+ $| = 1;
+ print "1..355\n";
+ while (<DATA>) {
+ chop;
+ if (/^&/) {
+ $f = $_;
+ } elsif (/^\$.*/) {
+ eval "$_;";
+ } else {
+ ++$test;
+ @args = split(/:/,$_,99);
+ $ans = pop(@args);
+ $try = "$f('" . join("','", @args) . "');";
+ if (($ans1 = eval($try)) eq $ans) {
+ print "ok $test\n";
+ } else {
+ print "not ok $test\n";
+ print "# '$try' expected: '$ans' got: '$ans1'\n";
+ }
+ }
+ }
+ __END__
+ &fnorm
+ abc:NaN
+ 1 a:NaN
+ 1bcd2:NaN
+ 11111b:NaN
+ +1z:NaN
+ -1z:NaN
+ 0:+0E+0
+ +0:+0E+0
+ +00:+0E+0
+ +0 0 0:+0E+0
+ 000000 0000000 00000:+0E+0
+ -0:+0E+0
+ -0000:+0E+0
+ +1:+1E+0
+ +01:+1E+0
+ +001:+1E+0
+ +00000100000:+1E+5
+ 123456789:+123456789E+0
+ -1:-1E+0
+ -01:-1E+0
+ -001:-1E+0
+ -123456789:-123456789E+0
+ -00000100000:-1E+5
+ 123.456a:NaN
+ 123.456:+123456E-3
+ 0.01:+1E-2
+ .002:+2E-3
+ -0.0003:-3E-4
+ -.0000000004:-4E-10
+ 123456E2:+123456E+2
+ 123456E-2:+123456E-2
+ -123456E2:-123456E+2
+ -123456E-2:-123456E-2
+ 1e1:+1E+1
+ 2e-11:+2E-11
+ -3e111:-3E+111
+ -4e-1111:-4E-1111
+ &fneg
+ abd:NaN
+ +0:+0E+0
+ +1:-1E+0
+ -1:+1E+0
+ +123456789:-123456789E+0
+ -123456789:+123456789E+0
+ +123.456789:-123456789E-6
+ -123456.789:+123456789E-3
+ &fabs
+ abc:NaN
+ +0:+0E+0
+ +1:+1E+0
+ -1:+1E+0
+ +123456789:+123456789E+0
+ -123456789:+123456789E+0
+ +123.456789:+123456789E-6
+ -123456.789:+123456789E-3
+ &fround
+ $bigfloat::rnd_mode = 'trunc'
+ +10123456789:5:+10123E+6
+ -10123456789:5:-10123E+6
+ +10123456789:9:+101234567E+2
+ -10123456789:9:-101234567E+2
+ +101234500:6:+101234E+3
+ -101234500:6:-101234E+3
+ $bigfloat::rnd_mode = 'zero'
+ +20123456789:5:+20123E+6
+ -20123456789:5:-20123E+6
+ +20123456789:9:+201234568E+2
+ -20123456789:9:-201234568E+2
+ +201234500:6:+201234E+3
+ -201234500:6:-201234E+3
+ $bigfloat::rnd_mode = '+inf'
+ +30123456789:5:+30123E+6
+ -30123456789:5:-30123E+6
+ +30123456789:9:+301234568E+2
+ -30123456789:9:-301234568E+2
+ +301234500:6:+301235E+3
+ -301234500:6:-301234E+3
+ $bigfloat::rnd_mode = '-inf'
+ +40123456789:5:+40123E+6
+ -40123456789:5:-40123E+6
+ +40123456789:9:+401234568E+2
+ -40123456789:9:-401234568E+2
+ +401234500:6:+401234E+3
+ -401234500:6:-401235E+3
+ $bigfloat::rnd_mode = 'odd'
+ +50123456789:5:+50123E+6
+ -50123456789:5:-50123E+6
+ +50123456789:9:+501234568E+2
+ -50123456789:9:-501234568E+2
+ +501234500:6:+501235E+3
+ -501234500:6:-501235E+3
+ $bigfloat::rnd_mode = 'even'
+ +60123456789:5:+60123E+6
+ -60123456789:5:-60123E+6
+ +60123456789:9:+601234568E+2
+ -60123456789:9:-601234568E+2
+ +601234500:6:+601234E+3
+ -601234500:6:-601234E+3
+ &ffround
+ $bigfloat::rnd_mode = 'trunc'
+ +1.23:-1:+12E-1
+ -1.23:-1:-12E-1
+ +1.27:-1:+12E-1
+ -1.27:-1:-12E-1
+ +1.25:-1:+12E-1
+ -1.25:-1:-12E-1
+ +1.35:-1:+13E-1
+ -1.35:-1:-13E-1
+ -0.006:-1:+0E+0
+ -0.006:-2:+0E+0
+ $bigfloat::rnd_mode = 'zero'
+ +2.23:-1:+22E-1
+ -2.23:-1:-22E-1
+ +2.27:-1:+23E-1
+ -2.27:-1:-23E-1
+ +2.25:-1:+22E-1
+ -2.25:-1:-22E-1
+ +2.35:-1:+23E-1
+ -2.35:-1:-23E-1
+ -0.0065:-1:+0E+0
+ -0.0065:-2:-1E-2
+ -0.0065:-3:-6E-3
+ -0.0065:-4:-65E-4
+ -0.0065:-5:-65E-4
+ $bigfloat::rnd_mode = '+inf'
+ +3.23:-1:+32E-1
+ -3.23:-1:-32E-1
+ +3.27:-1:+33E-1
+ -3.27:-1:-33E-1
+ +3.25:-1:+33E-1
+ -3.25:-1:-32E-1
+ +3.35:-1:+34E-1
+ -3.35:-1:-33E-1
+ -0.0065:-1:+0E+0
+ -0.0065:-2:-1E-2
+ -0.0065:-3:-6E-3
+ -0.0065:-4:-65E-4
+ -0.0065:-5:-65E-4
+ $bigfloat::rnd_mode = '-inf'
+ +4.23:-1:+42E-1
+ -4.23:-1:-42E-1
+ +4.27:-1:+43E-1
+ -4.27:-1:-43E-1
+ +4.25:-1:+42E-1
+ -4.25:-1:-43E-1
+ +4.35:-1:+43E-1
+ -4.35:-1:-44E-1
+ -0.0065:-1:+0E+0
+ -0.0065:-2:-1E-2
+ -0.0065:-3:-7E-3
+ -0.0065:-4:-65E-4
+ -0.0065:-5:-65E-4
+ $bigfloat::rnd_mode = 'odd'
+ +5.23:-1:+52E-1
+ -5.23:-1:-52E-1
+ +5.27:-1:+53E-1
+ -5.27:-1:-53E-1
+ +5.25:-1:+53E-1
+ -5.25:-1:-53E-1
+ +5.35:-1:+53E-1
+ -5.35:-1:-53E-1
+ -0.0065:-1:+0E+0
+ -0.0065:-2:-1E-2
+ -0.0065:-3:-7E-3
+ -0.0065:-4:-65E-4
+ -0.0065:-5:-65E-4
+ $bigfloat::rnd_mode = 'even'
+ +6.23:-1:+62E-1
+ -6.23:-1:-62E-1
+ +6.27:-1:+63E-1
+ -6.27:-1:-63E-1
+ +6.25:-1:+62E-1
+ -6.25:-1:-62E-1
+ +6.35:-1:+64E-1
+ -6.35:-1:-64E-1
+ -0.0065:-1:+0E+0
+ -0.0065:-2:-1E-2
+ -0.0065:-3:-6E-3
+ -0.0065:-4:-65E-4
+ -0.0065:-5:-65E-4
+ &fcmp
+ abc:abc:
+ abc:+0:
+ +0:abc:
+ +0:+0:0
+ -1:+0:-1
+ +0:-1:1
+ +1:+0:1
+ +0:+1:-1
+ -1:+1:-1
+ +1:-1:1
+ -1:-1:0
+ +1:+1:0
+ +123:+123:0
+ +123:+12:1
+ +12:+123:-1
+ -123:-123:0
+ -123:-12:-1
+ -12:-123:1
+ +123:+124:-1
+ +124:+123:1
+ -123:-124:1
+ -124:-123:-1
+ &fadd
+ abc:abc:NaN
+ abc:+0:NaN
+ +0:abc:NaN
+ +0:+0:+0E+0
+ +1:+0:+1E+0
+ +0:+1:+1E+0
+ +1:+1:+2E+0
+ -1:+0:-1E+0
+ +0:-1:-1E+0
+ -1:-1:-2E+0
+ -1:+1:+0E+0
+ +1:-1:+0E+0
+ +9:+1:+1E+1
+ +99:+1:+1E+2
+ +999:+1:+1E+3
+ +9999:+1:+1E+4
+ +99999:+1:+1E+5
+ +999999:+1:+1E+6
+ +9999999:+1:+1E+7
+ +99999999:+1:+1E+8
+ +999999999:+1:+1E+9
+ +9999999999:+1:+1E+10
+ +99999999999:+1:+1E+11
+ +10:-1:+9E+0
+ +100:-1:+99E+0
+ +1000:-1:+999E+0
+ +10000:-1:+9999E+0
+ +100000:-1:+99999E+0
+ +1000000:-1:+999999E+0
+ +10000000:-1:+9999999E+0
+ +100000000:-1:+99999999E+0
+ +1000000000:-1:+999999999E+0
+ +10000000000:-1:+9999999999E+0
+ +123456789:+987654321:+111111111E+1
+ -123456789:+987654321:+864197532E+0
+ -123456789:-987654321:-111111111E+1
+ +123456789:-987654321:-864197532E+0
+ &fsub
+ abc:abc:NaN
+ abc:+0:NaN
+ +0:abc:NaN
+ +0:+0:+0E+0
+ +1:+0:+1E+0
+ +0:+1:-1E+0
+ +1:+1:+0E+0
+ -1:+0:-1E+0
+ +0:-1:+1E+0
+ -1:-1:+0E+0
+ -1:+1:-2E+0
+ +1:-1:+2E+0
+ +9:+1:+8E+0
+ +99:+1:+98E+0
+ +999:+1:+998E+0
+ +9999:+1:+9998E+0
+ +99999:+1:+99998E+0
+ +999999:+1:+999998E+0
+ +9999999:+1:+9999998E+0
+ +99999999:+1:+99999998E+0
+ +999999999:+1:+999999998E+0
+ +9999999999:+1:+9999999998E+0
+ +99999999999:+1:+99999999998E+0
+ +10:-1:+11E+0
+ +100:-1:+101E+0
+ +1000:-1:+1001E+0
+ +10000:-1:+10001E+0
+ +100000:-1:+100001E+0
+ +1000000:-1:+1000001E+0
+ +10000000:-1:+10000001E+0
+ +100000000:-1:+100000001E+0
+ +1000000000:-1:+1000000001E+0
+ +10000000000:-1:+10000000001E+0
+ +123456789:+987654321:-864197532E+0
+ -123456789:+987654321:-111111111E+1
+ -123456789:-987654321:+864197532E+0
+ +123456789:-987654321:+111111111E+1
+ &fmul
+ abc:abc:NaN
+ abc:+0:NaN
+ +0:abc:NaN
+ +0:+0:+0E+0
+ +0:+1:+0E+0
+ +1:+0:+0E+0
+ +0:-1:+0E+0
+ -1:+0:+0E+0
+ +123456789123456789:+0:+0E+0
+ +0:+123456789123456789:+0E+0
+ -1:-1:+1E+0
+ -1:+1:-1E+0
+ +1:-1:-1E+0
+ +1:+1:+1E+0
+ +2:+3:+6E+0
+ -2:+3:-6E+0
+ +2:-3:-6E+0
+ -2:-3:+6E+0
+ +111:+111:+12321E+0
+ +10101:+10101:+102030201E+0
+ +1001001:+1001001:+1002003002001E+0
+ +100010001:+100010001:+10002000300020001E+0
+ +10000100001:+10000100001:+100002000030000200001E+0
+ +11111111111:+9:+99999999999E+0
+ +22222222222:+9:+199999999998E+0
+ +33333333333:+9:+299999999997E+0
+ +44444444444:+9:+399999999996E+0
+ +55555555555:+9:+499999999995E+0
+ +66666666666:+9:+599999999994E+0
+ +77777777777:+9:+699999999993E+0
+ +88888888888:+9:+799999999992E+0
+ +99999999999:+9:+899999999991E+0
+ &fdiv
+ abc:abc:NaN
+ abc:+1:abc:NaN
+ +1:abc:NaN
+ +0:+0:NaN
+ +0:+1:+0E+0
+ +1:+0:NaN
+ +0:-1:+0E+0
+ -1:+0:NaN
+ +1:+1:+1E+0
+ -1:-1:+1E+0
+ +1:-1:-1E+0
+ -1:+1:-1E+0
+ +1:+2:+5E-1
+ +2:+1:+2E+0
+ +10:+5:+2E+0
+ +100:+4:+25E+0
+ +1000:+8:+125E+0
+ +10000:+16:+625E+0
+ +10000:-16:-625E+0
+ +999999999999:+9:+111111111111E+0
+ +999999999999:+99:+10101010101E+0
+ +999999999999:+999:+1001001001E+0
+ +999999999999:+9999:+100010001E+0
+ +999999999999999:+99999:+10000100001E+0
+ +1000000000:+9:+1111111111111111111111111111111111111111E-31
+ +2000000000:+9:+2222222222222222222222222222222222222222E-31
+ +3000000000:+9:+3333333333333333333333333333333333333333E-31
+ +4000000000:+9:+4444444444444444444444444444444444444444E-31
+ +5000000000:+9:+5555555555555555555555555555555555555556E-31
+ +6000000000:+9:+6666666666666666666666666666666666666667E-31
+ +7000000000:+9:+7777777777777777777777777777777777777778E-31
+ +8000000000:+9:+8888888888888888888888888888888888888889E-31
+ +9000000000:+9:+1E+9
+ +35500000:+113:+3141592920353982300884955752212389380531E-34
+ +71000000:+226:+3141592920353982300884955752212389380531E-34
+ +106500000:+339:+3141592920353982300884955752212389380531E-34
+ +1000000000:+3:+3333333333333333333333333333333333333333E-31
+ $bigfloat::div_scale = 20
+ +1000000000:+9:+11111111111111111111E-11
+ +2000000000:+9:+22222222222222222222E-11
+ +3000000000:+9:+33333333333333333333E-11
+ +4000000000:+9:+44444444444444444444E-11
+ +5000000000:+9:+55555555555555555556E-11
+ +6000000000:+9:+66666666666666666667E-11
+ +7000000000:+9:+77777777777777777778E-11
+ +8000000000:+9:+88888888888888888889E-11
+ +9000000000:+9:+1E+9
+ +35500000:+113:+314159292035398230088E-15
+ +71000000:+226:+314159292035398230088E-15
+ +106500000:+339:+31415929203539823009E-14
+ +1000000000:+3:+33333333333333333333E-11
+ $bigfloat::div_scale = 40
+ &fsqrt
+ +0:+0E+0
+ -1:NaN
+ -2:NaN
+ -16:NaN
+ -123.456:NaN
+ +1:+1E+0
+ +1.44:+12E-1
+ +2:+141421356237309504880168872420969807857E-38
+ +4:+2E+0
+ +16:+4E+0
+ +100:+1E+1
+ +123.456:+1111107555549866648462149404118219234119E-38
+ +15241.383936:+123456E-3
diff -c /dev/null 'perl-5.7.2/lib/bigint.t'
Index: ./lib/bigint.t
*** ./lib/bigint.t Thu Jan 1 02:00:00 1970
--- ./lib/bigint.t Mon Jul 9 17:10:47 2001
***************
*** 0 ****
--- 1,282 ----
+ #!./perl
+
+ BEGIN { @INC = '../lib' }
+ require "bigint.pl";
+
+ $test = 0;
+ $| = 1;
+ print "1..246\n";
+ while (<DATA>) {
+ chop;
+ if (/^&/) {
+ $f = $_;
+ } else {
+ ++$test;
+ @args = split(/:/,$_,99);
+ $ans = pop(@args);
+ $try = "$f('" . join("','", @args) . "');";
+ if (($ans1 = eval($try)) eq $ans) {
+ print "ok $test\n";
+ } else {
+ print "not ok $test\n";
+ print "# '$try' expected: '$ans' got: '$ans1'\n";
+ }
+ }
+ }
+ __END__
+ &bnorm
+ abc:NaN
+ 1 a:NaN
+ 1bcd2:NaN
+ 11111b:NaN
+ +1z:NaN
+ -1z:NaN
+ 0:+0
+ +0:+0
+ +00:+0
+ +0 0 0:+0
+ 000000 0000000 00000:+0
+ -0:+0
+ -0000:+0
+ +1:+1
+ +01:+1
+ +001:+1
+ +00000100000:+100000
+ 123456789:+123456789
+ -1:-1
+ -01:-1
+ -001:-1
+ -123456789:-123456789
+ -00000100000:-100000
+ &bneg
+ abd:NaN
+ +0:+0
+ +1:-1
+ -1:+1
+ +123456789:-123456789
+ -123456789:+123456789
+ &babs
+ abc:NaN
+ +0:+0
+ +1:+1
+ -1:+1
+ +123456789:+123456789
+ -123456789:+123456789
+ &bcmp
+ abc:abc:
+ abc:+0:
+ +0:abc:
+ +0:+0:0
+ -1:+0:-1
+ +0:-1:1
+ +1:+0:1
+ +0:+1:-1
+ -1:+1:-1
+ +1:-1:1
+ -1:-1:0
+ +1:+1:0
+ +123:+123:0
+ +123:+12:1
+ +12:+123:-1
+ -123:-123:0
+ -123:-12:-1
+ -12:-123:1
+ +123:+124:-1
+ +124:+123:1
+ -123:-124:1
+ -124:-123:-1
+ &badd
+ abc:abc:NaN
+ abc:+0:NaN
+ +0:abc:NaN
+ +0:+0:+0
+ +1:+0:+1
+ +0:+1:+1
+ +1:+1:+2
+ -1:+0:-1
+ +0:-1:-1
+ -1:-1:-2
+ -1:+1:+0
+ +1:-1:+0
+ +9:+1:+10
+ +99:+1:+100
+ +999:+1:+1000
+ +9999:+1:+10000
+ +99999:+1:+100000
+ +999999:+1:+1000000
+ +9999999:+1:+10000000
+ +99999999:+1:+100000000
+ +999999999:+1:+1000000000
+ +9999999999:+1:+10000000000
+ +99999999999:+1:+100000000000
+ +10:-1:+9
+ +100:-1:+99
+ +1000:-1:+999
+ +10000:-1:+9999
+ +100000:-1:+99999
+ +1000000:-1:+999999
+ +10000000:-1:+9999999
+ +100000000:-1:+99999999
+ +1000000000:-1:+999999999
+ +10000000000:-1:+9999999999
+ +123456789:+987654321:+1111111110
+ -123456789:+987654321:+864197532
+ -123456789:-987654321:-1111111110
+ +123456789:-987654321:-864197532
+ &bsub
+ abc:abc:NaN
+ abc:+0:NaN
+ +0:abc:NaN
+ +0:+0:+0
+ +1:+0:+1
+ +0:+1:-1
+ +1:+1:+0
+ -1:+0:-1
+ +0:-1:+1
+ -1:-1:+0
+ -1:+1:-2
+ +1:-1:+2
+ +9:+1:+8
+ +99:+1:+98
+ +999:+1:+998
+ +9999:+1:+9998
+ +99999:+1:+99998
+ +999999:+1:+999998
+ +9999999:+1:+9999998
+ +99999999:+1:+99999998
+ +999999999:+1:+999999998
+ +9999999999:+1:+9999999998
+ +99999999999:+1:+99999999998
+ +10:-1:+11
+ +100:-1:+101
+ +1000:-1:+1001
+ +10000:-1:+10001
+ +100000:-1:+100001
+ +1000000:-1:+1000001
+ +10000000:-1:+10000001
+ +100000000:-1:+100000001
+ +1000000000:-1:+1000000001
+ +10000000000:-1:+10000000001
+ +123456789:+987654321:-864197532
+ -123456789:+987654321:-1111111110
+ -123456789:-987654321:+864197532
+ +123456789:-987654321:+1111111110
+ &bmul
+ abc:abc:NaN
+ abc:+0:NaN
+ +0:abc:NaN
+ +0:+0:+0
+ +0:+1:+0
+ +1:+0:+0
+ +0:-1:+0
+ -1:+0:+0
+ +123456789123456789:+0:+0
+ +0:+123456789123456789:+0
+ -1:-1:+1
+ -1:+1:-1
+ +1:-1:-1
+ +1:+1:+1
+ +2:+3:+6
+ -2:+3:-6
+ +2:-3:-6
+ -2:-3:+6
+ +111:+111:+12321
+ +10101:+10101:+102030201
+ +1001001:+1001001:+1002003002001
+ +100010001:+100010001:+10002000300020001
+ +10000100001:+10000100001:+100002000030000200001
+ +11111111111:+9:+99999999999
+ +22222222222:+9:+199999999998
+ +33333333333:+9:+299999999997
+ +44444444444:+9:+399999999996
+ +55555555555:+9:+499999999995
+ +66666666666:+9:+599999999994
+ +77777777777:+9:+699999999993
+ +88888888888:+9:+799999999992
+ +99999999999:+9:+899999999991
+ &bdiv
+ abc:abc:NaN
+ abc:+1:abc:NaN
+ +1:abc:NaN
+ +0:+0:NaN
+ +0:+1:+0
+ +1:+0:NaN
+ +0:-1:+0
+ -1:+0:NaN
+ +1:+1:+1
+ -1:-1:+1
+ +1:-1:-1
+ -1:+1:-1
+ +1:+2:+0
+ +2:+1:+2
+ +1000000000:+9:+111111111
+ +2000000000:+9:+222222222
+ +3000000000:+9:+333333333
+ +4000000000:+9:+444444444
+ +5000000000:+9:+555555555
+ +6000000000:+9:+666666666
+ +7000000000:+9:+777777777
+ +8000000000:+9:+888888888
+ +9000000000:+9:+1000000000
+ +35500000:+113:+314159
+ +71000000:+226:+314159
+ +106500000:+339:+314159
+ +1000000000:+3:+333333333
+ +10:+5:+2
+ +100:+4:+25
+ +1000:+8:+125
+ +10000:+16:+625
+ +999999999999:+9:+111111111111
+ +999999999999:+99:+10101010101
+ +999999999999:+999:+1001001001
+ +999999999999:+9999:+100010001
+ +999999999999999:+99999:+10000100001
+ &bmod
+ abc:abc:NaN
+ abc:+1:abc:NaN
+ +1:abc:NaN
+ +0:+0:NaN
+ +0:+1:+0
+ +1:+0:NaN
+ +0:-1:+0
+ -1:+0:NaN
+ +1:+1:+0
+ -1:-1:+0
+ +1:-1:+0
+ -1:+1:+0
+ +1:+2:+1
+ +2:+1:+0
+ +1000000000:+9:+1
+ +2000000000:+9:+2
+ +3000000000:+9:+3
+ +4000000000:+9:+4
+ +5000000000:+9:+5
+ +6000000000:+9:+6
+ +7000000000:+9:+7
+ +8000000000:+9:+8
+ +9000000000:+9:+0
+ +35500000:+113:+33
+ +71000000:+226:+66
+ +106500000:+339:+99
+ +1000000000:+3:+1
+ +10:+5:+0
+ +100:+4:+0
+ +1000:+8:+0
+ +10000:+16:+0
+ +999999999999:+9:+0
+ +999999999999:+99:+0
+ +999999999999:+999:+0
+ +999999999999:+9999:+0
+ +999999999999999:+99999:+0
+ &bgcd
+ abc:abc:NaN
+ abc:+0:NaN
+ +0:abc:NaN
+ +0:+0:+0
+ +0:+1:+1
+ +1:+0:+1
+ +1:+1:+1
+ +2:+3:+1
+ +3:+2:+1
+ +100:+625:+25
+ +4096:+81:+1
diff -c /dev/null 'perl-5.7.2/lib/charnames.t'
Index: ./lib/charnames.t
*** ./lib/charnames.t Thu Jan 1 02:00:00 1970
--- ./lib/charnames.t Mon Jul 9 17:10:48 2001
***************
*** 0 ****
--- 1,131 ----
+ #!./perl
+
+ BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+
+ $| = 1;
+ print "1..16\n";
+
+ use charnames ':full';
+
+ print "not " unless "Here\N{EXCLAMATION MARK}?" eq "Here\041?";
+ print "ok 1\n";
+
+ {
+ use bytes; # TEST -utf8 can switch utf8 on
+
+ print "# \$res=$res \$\@='$@'\nnot "
+ if $res = eval <<'EOE'
+ use charnames ":full";
+ "Here: \N{CYRILLIC SMALL LETTER BE}!";
+ 1
+ EOE
+ or $@ !~ /above 0xFF/;
+ print "ok 2\n";
+ # print "# \$res=$res \$\@='$@'\n";
+
+ print "# \$res=$res \$\@='$@'\nnot "
+ if $res = eval <<'EOE'
+ use charnames 'cyrillic';
+ "Here: \N{Be}!";
+ 1
+ EOE
+ or $@ !~ /CYRILLIC CAPITAL LETTER BE.*above 0xFF/;
+ print "ok 3\n";
+ }
+
+ # If octal representation of unicode char is \0xyzt, then the utf8 is \3xy\2zt
+ if (ord('A') == 65) { # as on ASCII or UTF-8 machines
+ $encoded_be = "\320\261";
+ $encoded_alpha = "\316\261";
+ $encoded_bet = "\327\221";
+ $encoded_deseng = "\360\220\221\215";
+ }
+ else { # EBCDIC where UTF-EBCDIC may be used (this may be 1047 specific since
+ # UTF-EBCDIC is codepage specific)
+ $encoded_be = "\270\102\130";
+ $encoded_alpha = "\264\130";
+ $encoded_bet = "\270\125\130";
+ $encoded_deseng = "\336\102\103\124";
+ }
+
+ sub to_bytes {
+ pack"a*", shift;
+ }
+
+ {
+ use charnames ':full';
+
+ print "not " unless to_bytes("\N{CYRILLIC SMALL LETTER BE}") eq $encoded_be;
+ print "ok 4\n";
+
+ use charnames qw(cyrillic greek :short);
+
+ print "not " unless to_bytes("\N{be},\N{alpha},\N{hebrew:bet}")
+ eq "$encoded_be,$encoded_alpha,$encoded_bet";
+ print "ok 5\n";
+ }
+
+ {
+ use charnames ':full';
+ print "not " unless "\x{263a}" eq "\N{WHITE SMILING FACE}";
+ print "ok 6\n";
+ print "not " unless length("\x{263a}") == 1;
+ print "ok 7\n";
+ print "not " unless length("\N{WHITE SMILING FACE}") == 1;
+ print "ok 8\n";
+ print "not " unless sprintf("%vx", "\x{263a}") eq "263a";
+ print "ok 9\n";
+ print "not " unless sprintf("%vx", "\N{WHITE SMILING FACE}") eq "263a";
+ print "ok 10\n";
+ print "not " unless sprintf("%vx", "\xFF\N{WHITE SMILING FACE}") eq "ff.263a";
+ print "ok 11\n";
+ print "not " unless sprintf("%vx", "\x{ff}\N{WHITE SMILING FACE}") eq "ff.263a";
+ print "ok 12\n";
+ }
+
+ {
+ use charnames qw(:full);
+ use utf8;
+
+ my $x = "\x{221b}";
+ my $named = "\N{CUBE ROOT}";
+
+ print "not " unless ord($x) == ord($named);
+ print "ok 13\n";
+ }
+
+ {
+ use charnames qw(:full);
+ use utf8;
+ print "not " unless "\x{100}\N{CENT SIGN}" eq "\x{100}"."\N{CENT SIGN}";
+ print "ok 14\n";
+ }
+
+ {
+ use charnames ':full';
+
+ print "not "
+ unless to_bytes("\N{DESERET SMALL LETTER ENG}") eq $encoded_deseng;
+ print "ok 15\n";
+ }
+
+ {
+ # 20001114.001
+
+ no utf8; # so that the naked 8-bit character won't gripe under use utf8
+
+ if (ord("�") == 0xc4) { # Try to do this only on Latin-1.
+ use charnames ':full';
+ my $text = "\N{LATIN CAPITAL LETTER A WITH DIAERESIS}";
+ print "not " unless $text eq "\xc4" && ord($text) == 0xc4;
+ print "ok 16\n";
+ } else {
+ print "ok 16 # Skip: not Latin-1\n";
+ }
+ }
+
diff -c 'perl-5.7.1/lib/constant.pm' 'perl-5.7.2/lib/constant.pm'
Index: ./lib/constant.pm
*** ./lib/constant.pm Tue Mar 6 04:05:38 2001
--- ./lib/constant.pm Mon Jul 9 17:10:48 2001
***************
*** 5,11 ****
use warnings::register;
our($VERSION, %declared);
! $VERSION = '1.02';
#=======================================================================
--- 5,11 ----
use warnings::register;
our($VERSION, %declared);
! $VERSION = '1.03';
#=======================================================================
***************
*** 314,321 ****
Tom Phoenix, E<lt>F<rootbeer@redcat.com>E<gt>, with help from
many other folks.
! Multiple constant declarations at once added by Casey Tweten,
! E<lt>F<crt@kiski.net>E<gt>.
=head1 COPYRIGHT
--- 314,321 ----
Tom Phoenix, E<lt>F<rootbeer@redcat.com>E<gt>, with help from
many other folks.
! Multiple constant declarations at once added by Casey West,
! E<lt>F<casey@geeknest.com>E<gt>.
=head1 COPYRIGHT
diff -c /dev/null 'perl-5.7.2/lib/constant.t'
Index: ./lib/constant.t
*** ./lib/constant.t Thu Jan 1 02:00:00 1970
--- ./lib/constant.t Mon Jul 9 17:10:48 2001
***************
*** 0 ****
--- 1,251 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ use warnings;
+ use vars qw{ @warnings };
+ BEGIN { # ...and save 'em for later
+ $SIG{'__WARN__'} = sub { push @warnings, @_ }
+ }
+ END { print @warnings }
+
+ ######################### We start with some black magic to print on failure.
+
+ BEGIN { $| = 1; print "1..82\n"; }
+ END {print "not ok 1\n" unless $loaded;}
+ use constant 1.01;
+ $loaded = 1;
+ #print "# Version: $constant::VERSION\n";
+ print "ok 1\n";
+
+ ######################### End of black magic.
+
+ use strict;
+
+ sub test ($$;$) {
+ my($num, $bool, $diag) = @_;
+ if ($bool) {
+ print "ok $num\n";
+ return;
+ }
+ print "not ok $num\n";
+ return unless defined $diag;
+ $diag =~ s/\Z\n?/\n/; # unchomp
+ print map "# $num : $_", split m/^/m, $diag;
+ }
+
+ use constant PI => 4 * atan2 1, 1;
+
+ test 2, substr(PI, 0, 7) eq '3.14159';
+ test 3, defined PI;
+
+ sub deg2rad { PI * $_[0] / 180 }
+
+ my $ninety = deg2rad 90;
+
+ test 4, $ninety > 1.5707;
+ test 5, $ninety < 1.5708;
+
+ use constant UNDEF1 => undef; # the right way
+ use constant UNDEF2 => ; # the weird way
+ use constant 'UNDEF3' ; # the 'short' way
+ use constant EMPTY => ( ) ; # the right way for lists
+
+ test 6, not defined UNDEF1;
+ test 7, not defined UNDEF2;
+ test 8, not defined UNDEF3;
+ my @undef = UNDEF1;
+ test 9, @undef == 1;
+ test 10, not defined $undef[0];
+ @undef = UNDEF2;
+ test 11, @undef == 0;
+ @undef = UNDEF3;
+ test 12, @undef == 0;
+ @undef = EMPTY;
+ test 13, @undef == 0;
+
+ use constant COUNTDOWN => scalar reverse 1, 2, 3, 4, 5;
+ use constant COUNTLIST => reverse 1, 2, 3, 4, 5;
+ use constant COUNTLAST => (COUNTLIST)[-1];
+
+ test 14, COUNTDOWN eq '54321';
+ my @cl = COUNTLIST;
+ test 15, @cl == 5;
+ test 16, COUNTDOWN eq join '', @cl;
+ test 17, COUNTLAST == 1;
+ test 18, (COUNTLIST)[1] == 4;
+
+ use constant ABC => 'ABC';
+ test 19, "abc${\( ABC )}abc" eq "abcABCabc";
+
+ use constant DEF => 'D', 'E', chr ord 'F';
+ test 20, "d e f @{[ DEF ]} d e f" eq "d e f D E F d e f";
+
+ use constant SINGLE => "'";
+ use constant DOUBLE => '"';
+ use constant BACK => '\\';
+ my $tt = BACK . SINGLE . DOUBLE ;
+ test 21, $tt eq q(\\'");
+
+ use constant MESS => q('"'\\"'"\\);
+ test 22, MESS eq q('"'\\"'"\\);
+ test 23, length(MESS) == 8;
+
+ use constant TRAILING => '12 cats';
+ {
+ no warnings 'numeric';
+ test 24, TRAILING == 12;
+ }
+ test 25, TRAILING eq '12 cats';
+
+ use constant LEADING => " \t1234";
+ test 26, LEADING == 1234;
+ test 27, LEADING eq " \t1234";
+
+ use constant ZERO1 => 0;
+ use constant ZERO2 => 0.0;
+ use constant ZERO3 => '0.0';
+ test 28, ZERO1 eq '0';
+ test 29, ZERO2 eq '0';
+ test 30, ZERO3 eq '0.0';
+
+ {
+ package Other;
+ use constant PI => 3.141;
+ }
+
+ test 31, (PI > 3.1415 and PI < 3.1416);
+ test 32, Other::PI == 3.141;
+
+ use constant E2BIG => $! = 7;
+ test 33, E2BIG == 7;
+ # This is something like "Arg list too long", but the actual message
+ # text may vary, so we can't test much better than this.
+ test 34, length(E2BIG) > 6;
+ test 35, index(E2BIG, " ") > 0;
+
+ test 36, @warnings == 0, join "\n", "unexpected warning", @warnings;
+ @warnings = (); # just in case
+ undef &PI;
+ test 37, @warnings &&
+ ($warnings[0] =~ /Constant sub.* undefined/),
+ shift @warnings;
+
+ test 38, @warnings == 0, "unexpected warning";
+ test 39, 1;
+
+ use constant CSCALAR => \"ok 40\n";
+ use constant CHASH => { foo => "ok 41\n" };
+ use constant CARRAY => [ undef, "ok 42\n" ];
+ use constant CPHASH => [ { foo => 1 }, "ok 43\n" ];
+ use constant CCODE => sub { "ok $_[0]\n" };
+
+ print ${+CSCALAR};
+ print CHASH->{foo};
+ print CARRAY->[1];
+ print CPHASH->{foo};
+ eval q{ CPHASH->{bar} };
+ test 44, scalar($@ =~ /^No such pseudo-hash field/);
+ print CCODE->(45);
+ eval q{ CCODE->{foo} };
+ test 46, scalar($@ =~ /^Constant is not a HASH/);
+
+ # Allow leading underscore
+ use constant _PRIVATE => 47;
+ test 47, _PRIVATE == 47;
+
+ # Disallow doubled leading underscore
+ eval q{
+ use constant __DISALLOWED => "Oops";
+ };
+ test 48, $@ =~ /begins with '__'/;
+
+ # Check on declared() and %declared. This sub should be EXACTLY the
+ # same as the one quoted in the docs!
+ sub declared ($) {
+ use constant 1.01; # don't omit this!
+ my $name = shift;
+ $name =~ s/^::/main::/;
+ my $pkg = caller;
+ my $full_name = $name =~ /::/ ? $name : "${pkg}::$name";
+ $constant::declared{$full_name};
+ }
+
+ test 49, declared 'PI';
+ test 50, $constant::declared{'main::PI'};
+
+ test 51, !declared 'PIE';
+ test 52, !$constant::declared{'main::PIE'};
+
+ {
+ package Other;
+ use constant IN_OTHER_PACK => 42;
+ ::test 53, ::declared 'IN_OTHER_PACK';
+ ::test 54, $constant::declared{'Other::IN_OTHER_PACK'};
+ ::test 55, ::declared 'main::PI';
+ ::test 56, $constant::declared{'main::PI'};
+ }
+
+ test 57, declared 'Other::IN_OTHER_PACK';
+ test 58, $constant::declared{'Other::IN_OTHER_PACK'};
+
+ @warnings = ();
+ eval q{
+ no warnings;
+ use warnings 'constant';
+ use constant 'BEGIN' => 1 ;
+ use constant 'INIT' => 1 ;
+ use constant 'CHECK' => 1 ;
+ use constant 'END' => 1 ;
+ use constant 'DESTROY' => 1 ;
+ use constant 'AUTOLOAD' => 1 ;
+ use constant 'STDIN' => 1 ;
+ use constant 'STDOUT' => 1 ;
+ use constant 'STDERR' => 1 ;
+ use constant 'ARGV' => 1 ;
+ use constant 'ARGVOUT' => 1 ;
+ use constant 'ENV' => 1 ;
+ use constant 'INC' => 1 ;
+ use constant 'SIG' => 1 ;
+ };
+
+ test 59, @warnings == 15 ;
+ test 60, (shift @warnings) =~ /^Constant name 'BEGIN' is a Perl keyword at/;
+ shift @warnings; #Constant subroutine BEGIN redefined at
+ test 61, (shift @warnings) =~ /^Constant name 'INIT' is a Perl keyword at/;
+ test 62, (shift @warnings) =~ /^Constant name 'CHECK' is a Perl keyword at/;
+ test 63, (shift @warnings) =~ /^Constant name 'END' is a Perl keyword at/;
+ test 64, (shift @warnings) =~ /^Constant name 'DESTROY' is a Perl keyword at/;
+ test 65, (shift @warnings) =~ /^Constant name 'AUTOLOAD' is a Perl keyword at/;
+ test 66, (shift @warnings) =~ /^Constant name 'STDIN' is forced into package main:: a/;
+ test 67, (shift @warnings) =~ /^Constant name 'STDOUT' is forced into package main:: at/;
+ test 68, (shift @warnings) =~ /^Constant name 'STDERR' is forced into package main:: at/;
+ test 69, (shift @warnings) =~ /^Constant name 'ARGV' is forced into package main:: at/;
+ test 70, (shift @warnings) =~ /^Constant name 'ARGVOUT' is forced into package main:: at/;
+ test 71, (shift @warnings) =~ /^Constant name 'ENV' is forced into package main:: at/;
+ test 72, (shift @warnings) =~ /^Constant name 'INC' is forced into package main:: at/;
+ test 73, (shift @warnings) =~ /^Constant name 'SIG' is forced into package main:: at/;
+ @warnings = ();
+
+
+ use constant {
+ THREE => 3,
+ FAMILY => [ qw( John Jane Sally ) ],
+ AGES => { John => 33, Jane => 28, Sally => 3 },
+ RFAM => [ [ qw( John Jane Sally ) ] ],
+ SPIT => sub { shift },
+ PHFAM => [ { John => 1, Jane => 2, Sally => 3 }, 33, 28, 3 ],
+ };
+
+ test 74, @{+FAMILY} == THREE;
+ test 75, @{+FAMILY} == @{RFAM->[0]};
+ test 76, FAMILY->[2] eq RFAM->[0]->[2];
+ test 77, AGES->{FAMILY->[1]} == 28;
+ test 78, PHFAM->{John} == AGES->{John};
+ test 79, PHFAM->[3] == AGES->{FAMILY->[2]};
+ test 80, @{+PHFAM} == SPIT->(THREE+1);
+ test 81, THREE**3 eq SPIT->(@{+FAMILY}**3);
+ test 82, AGES->{FAMILY->[THREE-1]} == PHFAM->[THREE];
diff -c 'perl-5.7.1/lib/diagnostics.pm' 'perl-5.7.2/lib/diagnostics.pm'
Index: ./lib/diagnostics.pm
*** ./lib/diagnostics.pm Tue Mar 6 04:05:38 2001
--- ./lib/diagnostics.pm Mon Jul 9 17:10:48 2001
***************
*** 168,174 ****
=cut
use strict;
! use 5.005_64;
use Carp;
our $VERSION = 1.0;
--- 168,174 ----
=cut
use strict;
! use 5.6.0;
use Carp;
our $VERSION = 1.0;
***************
*** 195,200 ****
--- 195,206 ----
unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
+ if ($^O eq 'MacOS') {
+ # just updir one from each lib dir, we'll find it ...
+ ($PODFILE) = grep { -e } map { "$_:pod:perldiag.pod" } @INC;
+ }
+
+
$DEBUG ||= 0;
my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
***************
*** 343,351 ****
next;
}
# strip formatting directives in =item line
- $header = $for_item || $1;
- undef $for_item;
$header =~ s/[A-Z]<(.*?)>/$1/g;
if ($header =~ /%[csd]/) {
--- 349,364 ----
next;
}
+ if( $for_item ) { $header = $for_item; undef $for_item }
+ else {
+ $header = $1;
+ while( $header =~ /[;,]\z/ ) {
+ <POD_DIAG> =~ /^\s*(.*?)\s*\z/;
+ $header .= ' '.$1;
+ }
+ }
+
# strip formatting directives in =item line
$header =~ s/[A-Z]<(.*?)>/$1/g;
if ($header =~ /%[csd]/) {
diff -c /dev/null 'perl-5.7.2/lib/diagnostics.t'
Index: ./lib/diagnostics.t
*** ./lib/diagnostics.t Thu Jan 1 02:00:00 1970
--- ./lib/diagnostics.t Mon Jul 9 17:10:48 2001
***************
*** 0 ****
--- 1,38 ----
+ #!./perl
+
+ BEGIN {
+ chdir '..' if -d '../pod' && -d '../t';
+ @INC = 'lib';
+ }
+
+
+ ######################### We start with some black magic to print on failure.
+
+ # Change 1..1 below to 1..last_test_to_print .
+ # (It may become useful if the test is moved to ./t subdirectory.)
+ use strict;
+ use warnings;
+
+ use vars qw($Test_Num $Total_tests);
+
+ my $loaded;
+ BEGIN { $| = 1; $Test_Num = 1 }
+ END {print "not ok $Test_Num\n" unless $loaded;}
+ print "1..$Total_tests\n";
+ BEGIN { require diagnostics; } # Don't want diagnostics' noise yet.
+ $loaded = 1;
+ ok($loaded, 'compile');
+ ######################### End of black magic.
+
+ sub ok {
+ my($test, $name) = shift;
+ print "not " unless $test;
+ print "ok $Test_Num";
+ print " - $name" if defined $name;
+ print "\n";
+ $Test_Num++;
+ }
+
+
+ # Change this to your # of ok() calls + 1
+ BEGIN { $Total_tests = 1 }
diff -c 'perl-5.7.1/lib/dumpvar.pl' 'perl-5.7.2/lib/dumpvar.pl'
Index: ./lib/dumpvar.pl
*** ./lib/dumpvar.pl Tue Mar 6 04:05:38 2001
--- ./lib/dumpvar.pl Mon Jul 9 17:10:48 2001
***************
*** 187,193 ****
$tArrayDepth = $#{$v} ;
undef $more ;
$tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1
! unless $arrayDepth eq '' ;
$more = "....\n" if $tArrayDepth < $#{$v} ;
$shortmore = "";
$shortmore = " ..." if $tArrayDepth < $#{$v} ;
--- 187,193 ----
$tArrayDepth = $#{$v} ;
undef $more ;
$tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1
! if defined $arrayDepth && $arrayDepth ne '';
$more = "....\n" if $tArrayDepth < $#{$v} ;
$shortmore = "";
$shortmore = " ..." if $tArrayDepth < $#{$v} ;
diff -c 'perl-5.7.1/lib/fields.pm' 'perl-5.7.2/lib/fields.pm'
Index: ./lib/fields.pm
*** ./lib/fields.pm Tue Mar 6 04:05:39 2001
--- ./lib/fields.pm Mon Jul 9 17:10:48 2001
***************
*** 133,139 ****
use warnings::register;
our(%attr, $VERSION);
! $VERSION = "1.01";
# some constants
sub _PUBLIC () { 1 }
--- 133,139 ----
use warnings::register;
our(%attr, $VERSION);
! $VERSION = "1.02";
# some constants
sub _PUBLIC () { 1 }
diff -c /dev/null 'perl-5.7.2/lib/fields.t'
Index: ./lib/fields.t
*** ./lib/fields.t Thu Jan 1 02:00:00 1970
--- ./lib/fields.t Mon Jul 9 17:10:48 2001
***************
*** 0 ****
--- 1,197 ----
+ #!./perl -w
+
+ my $w;
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ $SIG{__WARN__} = sub {
+ if ($_[0] =~ /^Hides field 'b1' in base class/) {
+ $w++;
+ return;
+ }
+ print $_[0];
+ };
+ }
+
+ use strict;
+ use warnings;
+ use vars qw($DEBUG);
+
+ package B1;
+ use fields qw(b1 b2 b3);
+
+ package B2;
+ use fields '_b1';
+ use fields qw(b1 _b2 b2);
+
+ sub new { bless [], shift }
+
+ package D1;
+ use base 'B1';
+ use fields qw(d1 d2 d3);
+
+ package D2;
+ use base 'B1';
+ use fields qw(_d1 _d2);
+ use fields qw(d1 d2);
+
+ package D3;
+ use base 'B2';
+ use fields qw(b1 d1 _b1 _d1); # hide b1
+
+ package D4;
+ use base 'D3';
+ use fields qw(_d3 d3);
+
+ package M;
+ sub m {}
+
+ package D5;
+ use base qw(M B2);
+
+ package Foo::Bar;
+ use base 'B1';
+
+ package Foo::Bar::Baz;
+ use base 'Foo::Bar';
+ use fields qw(foo bar baz);
+
+ # Test repeatability for when modules get reloaded.
+ package B1;
+ use fields qw(b1 b2 b3);
+
+ package D3;
+ use base 'B2';
+ use fields qw(b1 d1 _b1 _d1); # hide b1
+
+ package main;
+
+ sub fstr {
+ my $h = shift;
+ my @tmp;
+ for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) {
+ my $v = $h->{$k};
+ push(@tmp, "$k:$v");
+ }
+ my $str = join(",", @tmp);
+ print "$h => $str\n" if $DEBUG;
+ $str;
+ }
+
+ my %expect = (
+ B1 => "b1:1,b2:2,b3:3",
+ B2 => "_b1:1,b1:2,_b2:3,b2:4",
+ D1 => "b1:1,b2:2,b3:3,d1:4,d2:5,d3:6",
+ D2 => "b1:1,b2:2,b3:3,_d1:4,_d2:5,d1:6,d2:7",
+ D3 => "b2:4,b1:5,d1:6,_b1:7,_d1:8",
+ D4 => "b2:4,b1:5,d1:6,_d3:9,d3:10",
+ D5 => "b1:2,b2:4",
+ 'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6',
+ );
+
+ print "1..", int(keys %expect)+15, "\n";
+ my $testno = 0;
+ while (my($class, $exp) = each %expect) {
+ no strict 'refs';
+ my $fstr = fstr(\%{$class."::FIELDS"});
+ print "EXP: $exp\nGOT: $fstr\nnot " unless $fstr eq $exp;
+ print "ok ", ++$testno, "\n";
+ }
+
+ # Did we get the appropriate amount of warnings?
+ print "not " unless $w == 1;
+ print "ok ", ++$testno, "\n";
+
+ # A simple object creation and AVHV attribute access test
+ my B2 $obj1 = D3->new;
+ $obj1->{b1} = "B2";
+ my D3 $obj2 = $obj1;
+ $obj2->{b1} = "D3";
+
+ print "not " unless $obj1->[2] eq "B2" && $obj1->[5] eq "D3";
+ print "ok ", ++$testno, "\n";
+
+ # We should get compile time failures field name typos
+ eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = "");
+ print "not " unless $@ && $@ =~ /^No such pseudo-hash field "notthere"/;
+ print "ok ", ++$testno, "\n";
+
+ # Slices
+ @$obj1{"_b1", "b1"} = (17, 29);
+ print "not " unless "@$obj1[1,2]" eq "17 29";
+ print "ok ", ++$testno, "\n";
+ @$obj1[1,2] = (44,28);
+ print "not " unless "@$obj1{'b1','_b1','b1'}" eq "28 44 28";
+ print "ok ", ++$testno, "\n";
+
+ my $ph = fields::phash(a => 1, b => 2, c => 3);
+ print "not " unless fstr($ph) eq 'a:1,b:2,c:3';
+ print "ok ", ++$testno, "\n";
+
+ $ph = fields::phash([qw/a b c/], [1, 2, 3]);
+ print "not " unless fstr($ph) eq 'a:1,b:2,c:3';
+ print "ok ", ++$testno, "\n";
+
+ $ph = fields::phash([qw/a b c/], [1]);
+ print "not " if exists $ph->{b} or exists $ph->{c} or !exists $ph->{a};
+ print "ok ", ++$testno, "\n";
+
+ eval '$ph = fields::phash("odd")';
+ print "not " unless $@ && $@ =~ /^Odd number of/;
+ print "ok ", ++$testno, "\n";
+
+ #fields::_dump();
+
+ # check if fields autovivify
+ {
+ package Foo;
+ use fields qw(foo bar);
+ sub new { bless [], $_[0]; }
+
+ package main;
+ my Foo $a = Foo->new();
+ $a->{foo} = ['a', 'ok ' . ++$testno, 'c'];
+ $a->{bar} = { A => 'ok ' . ++$testno };
+ print $a->{foo}[1], "\n";
+ print $a->{bar}->{A}, "\n";
+ }
+
+ # check if fields autovivify
+ {
+ package Bar;
+ use fields qw(foo bar);
+ sub new { return fields::new($_[0]) }
+
+ package main;
+ my Bar $a = Bar::->new();
+ $a->{foo} = ['a', 'ok ' . ++$testno, 'c'];
+ $a->{bar} = { A => 'ok ' . ++$testno };
+ print $a->{foo}[1], "\n";
+ print $a->{bar}->{A}, "\n";
+ }
+
+
+ # Test $VERSION bug
+ package No::Version;
+
+ use vars qw($Foo);
+ sub VERSION { 42 }
+
+ package Test::Version;
+
+ use base qw(No::Version);
+ print "not " unless $No::Version::VERSION =~ /set by base\.pm/;
+ print "ok ", ++$testno ,"\n";
+
+ # Test Inverse of $VERSION bug base.pm should not clobber existing $VERSION
+ package Has::Version;
+
+ BEGIN { $Has::Version::VERSION = '42' };
+
+ package Test::Version2;
+
+ use base qw(Has::Version);
+ print "#$Has::Version::VERSION\nnot " unless $Has::Version::VERSION eq '42';
+ print "ok ", ++$testno ,"\n";
+
diff -c /dev/null 'perl-5.7.2/lib/h2ph.t'
Index: ./lib/h2ph.t
*** ./lib/h2ph.t Thu Jan 1 02:00:00 1970
--- ./lib/h2ph.t Mon Jul 9 17:10:49 2001
***************
*** 0 ****
--- 1,37 ----
+ #!./perl
+
+ # quickie tests to see if h2ph actually runs and does more or less what is
+ # expected
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ my $extracted_program = '../utils/h2ph'; # unix, nt, ...
+ if ($^O eq 'VMS') { $extracted_program = '[-.utils]h2ph.com'; }
+ if (!(-e $extracted_program)) {
+ print "1..0 # Skip: $extracted_program was not built\n";
+ exit 0;
+ }
+
+ print "1..2\n";
+
+ # quickly compare two text files
+ sub txt_compare {
+ local ($/, $A, $B);
+ for (($A,$B) = @_) { open(_,"<$_") ? $_ = <_> : die "$_ : $!"; close _ }
+ $A cmp $B;
+ }
+
+ # does it run?
+ $ok = system("$^X \"-I../lib\" $extracted_program -d. \"-Q\" lib/h2ph.h");
+ print(($ok == 0 ? "" : "not "), "ok 1\n");
+
+ # does it work? well, does it do what we expect? :-)
+ $ok = txt_compare("lib/h2ph.ph", "lib/h2ph.pht");
+ print(($ok == 0 ? "" : "not "), "ok 2\n");
+
+ # cleanup - should this be in an END block?
+ unlink("lib/h2ph.ph");
+ unlink("_h2ph_pre.ph");
diff -c /dev/null 'perl-5.7.2/lib/h2xs.t'
Index: ./lib/h2xs.t
*** ./lib/h2xs.t Thu Jan 1 02:00:00 1970
--- ./lib/h2xs.t Mon Jul 9 17:10:49 2001
***************
*** 0 ****
--- 1,122 ----
+ #!./perl -w
+
+ # Some quick tests to see if h2xs actually runs and creates files as
+ # expected. File contents include date stamps and/or usernames
+ # hence are not checked. File existence is checked with -e though.
+ # This test depends on File::Path::rmtree() to clean up with.
+ # - pvhp
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # use strict; # we are not really testing this
+ use File::Path; # for cleaning up with rmtree()
+ use Test;
+
+
+ my $extracted_program = '../utils/h2xs'; # unix, nt, ...
+ if ($^O eq 'VMS') { $extracted_program = '[-.utils]h2xs.com'; }
+ if ($^O eq 'MacOS') { $extracted_program = '::utils:h2xs'; }
+ if (!(-e $extracted_program)) {
+ print "1..0 # Skip: $extracted_program was not built\n";
+ exit 0;
+ }
+ # You might also wish to bail out if your perl platform does not
+ # do `$^X -e 'warn "Writing h2xst"' 2>&1`; duplicity.
+
+ my $dupe = '2>&1'; # ok on unix, nt, VMS, ...
+ my $lib = '"-I../lib"'; # ok on unix, nt, The extra \" are for VMS
+ # The >&1 would create a file named &1 on MPW (STDERR && STDOUT are
+ # already merged).
+ if ($^O eq 'MacOS') {
+ $dupe = '';
+ $lib = '-x -I::lib:'; # -x overcomes MPW $Config{startperl} anomaly
+ }
+ # $name should differ from system header file names and must
+ # not already be found in the t/ subdirectory for perl.
+ my $name = 'h2xst';
+ my $header = "$name.h";
+
+ my @tests = (
+ "-f -n $name", <<"EOXSFILES",
+ Writing $name/$name.pm
+ Writing $name/$name.xs
+ Writing $name/Makefile.PL
+ Writing $name/README
+ Writing $name/t/1.t
+ Writing $name/Changes
+ Writing $name/MANIFEST
+ EOXSFILES
+
+ "\"-X\" -f -n $name", <<"EONOXSFILES",
+ Writing $name/$name.pm
+ Writing $name/Makefile.PL
+ Writing $name/README
+ Writing $name/t/1.t
+ Writing $name/Changes
+ Writing $name/MANIFEST
+ EONOXSFILES
+
+ "-f -n $name $header", <<"EOXSFILES",
+ Writing $name/$name.pm
+ Writing $name/$name.xs
+ Writing $name/Makefile.PL
+ Writing $name/README
+ Writing $name/t/1.t
+ Writing $name/Changes
+ Writing $name/MANIFEST
+ EOXSFILES
+ );
+
+ my $total_tests = 3; # opening, closing and deleting the header file.
+ for (my $i = $#tests; $i > 0; $i-=2) {
+ # 1 test for running it, 1 test for the expected result, and 1 for each file
+ # use the () to force list context and hence count the number of matches.
+ $total_tests += 2 + (() = $tests[$i] =~ /(Writing)/sg);
+ }
+
+ plan tests => $total_tests;
+
+ ok (open (HEADER, ">$header"));
+ print HEADER <<HEADER or die $!;
+ #define Camel 2
+ #define Dromedary 1
+ HEADER
+ ok (close (HEADER));
+
+ while (my ($args, $expectation) = splice @tests, 0, 2) {
+ # h2xs warns about what it is writing hence the (possibly unportable)
+ # 2>&1 dupe:
+ # does it run?
+ my $prog = "$^X $lib $extracted_program $args $dupe";
+ @result = `$prog`;
+ ok ($?, 0, "running $prog");
+ $result = join("",@result);
+
+ # accomodate MPW # comment character prependage
+ if ($^O eq 'MacOS') {
+ $result =~ s/#\s*//gs;
+ }
+
+ #print "# expectation is >$expectation<\n";
+ #print "# result is >$result<\n";
+ # Was the output the list of files that were expected?
+ ok ($result, $expectation, "running $prog");
+
+ $expectation =~ s/Writing //; # remove leader
+ foreach (split(/Writing /,$expectation)) {
+ chomp; # remove \n
+ if ($^O eq 'MacOS') {
+ $_ = ':' . join(':',split(/\//,$_));
+ $_ =~ s/$name:t:1.t/$name:t\/1.t/; # is this an h2xs bug?
+ }
+ ok (-e $_, 1, "$_ missing");
+ }
+
+ # clean up
+ rmtree($name);
+ }
+
+ ok (unlink ($header), 1, $!);
diff -c 'perl-5.7.1/lib/locale.pm' 'perl-5.7.2/lib/locale.pm'
Index: ./lib/locale.pm
*** ./lib/locale.pm Tue Mar 6 04:05:40 2001
--- ./lib/locale.pm Mon Jul 9 17:10:49 2001
***************
*** 27,33 ****
=cut
! $locale::hint_bits = 0x800;
sub import {
$^H |= $locale::hint_bits;
--- 27,33 ----
=cut
! $locale::hint_bits = 0x4;
sub import {
$^H |= $locale::hint_bits;
diff -c /dev/null 'perl-5.7.2/lib/locale.t'
Index: ./lib/locale.t
*** ./lib/locale.t Thu Jan 1 02:00:00 1970
--- ./lib/locale.t Mon Jul 9 17:10:49 2001
***************
*** 0 ****
--- 1,839 ----
+ #!./perl -wT
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ unshift @INC, '.';
+ require Config; import Config;
+ if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) {
+ print "1..0\n";
+ exit;
+ }
+ $| = 1;
+ }
+
+ use strict;
+
+ my $debug = 1;
+
+ use Dumpvalue;
+
+ my $dumper = Dumpvalue->new(
+ tick => qq{"},
+ quoteHighBit => 0,
+ unctrl => "quote"
+ );
+ sub debug {
+ return unless $debug;
+ my($mess) = join "", @_;
+ chop $mess;
+ print $dumper->stringify($mess,1), "\n";
+ }
+
+ sub debugf {
+ printf @_ if $debug;
+ }
+
+ my $have_setlocale = 0;
+ eval {
+ require POSIX;
+ import POSIX ':locale_h';
+ $have_setlocale++;
+ };
+
+ # Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1"
+ # and mingw32 uses said silly CRT
+ $have_setlocale = 0 if (($^O eq 'MSWin32' || $^O eq 'NetWare') && $Config{cc} =~ /^(cl|gcc)/i);
+
+ my $last = $have_setlocale ? &last : &last_without_setlocale;
+
+ print "1..$last\n";
+
+ use vars qw(&LC_ALL);
+
+ $a = 'abc %';
+
+ sub ok {
+ my ($n, $result) = @_;
+
+ print 'not ' unless ($result);
+ print "ok $n\n";
+ }
+
+ # First we'll do a lot of taint checking for locales.
+ # This is the easiest to test, actually, as any locale,
+ # even the default locale will taint under 'use locale'.
+
+ sub is_tainted { # hello, camel two.
+ no warnings 'uninitialized' ;
+ my $dummy;
+ not eval { $dummy = join("", @_), kill 0; 1 }
+ }
+
+ sub check_taint ($$) {
+ ok $_[0], is_tainted($_[1]);
+ }
+
+ sub check_taint_not ($$) {
+ ok $_[0], not is_tainted($_[1]);
+ }
+
+ use locale; # engage locale and therefore locale taint.
+
+ check_taint_not 1, $a;
+
+ check_taint 2, uc($a);
+ check_taint 3, "\U$a";
+ check_taint 4, ucfirst($a);
+ check_taint 5, "\u$a";
+ check_taint 6, lc($a);
+ check_taint 7, "\L$a";
+ check_taint 8, lcfirst($a);
+ check_taint 9, "\l$a";
+
+ check_taint_not 10, sprintf('%e', 123.456);
+ check_taint_not 11, sprintf('%f', 123.456);
+ check_taint_not 12, sprintf('%g', 123.456);
+ check_taint_not 13, sprintf('%d', 123.456);
+ check_taint_not 14, sprintf('%x', 123.456);
+
+ $_ = $a; # untaint $_
+
+ $_ = uc($a); # taint $_
+
+ check_taint 15, $_;
+
+ /(\w)/; # taint $&, $`, $', $+, $1.
+ check_taint 16, $&;
+ check_taint 17, $`;
+ check_taint 18, $';
+ check_taint 19, $+;
+ check_taint 20, $1;
+ check_taint_not 21, $2;
+
+ /(.)/; # untaint $&, $`, $', $+, $1.
+ check_taint_not 22, $&;
+ check_taint_not 23, $`;
+ check_taint_not 24, $';
+ check_taint_not 25, $+;
+ check_taint_not 26, $1;
+ check_taint_not 27, $2;
+
+ /(\W)/; # taint $&, $`, $', $+, $1.
+ check_taint 28, $&;
+ check_taint 29, $`;
+ check_taint 30, $';
+ check_taint 31, $+;
+ check_taint 32, $1;
+ check_taint_not 33, $2;
+
+ /(\s)/; # taint $&, $`, $', $+, $1.
+ check_taint 34, $&;
+ check_taint 35, $`;
+ check_taint 36, $';
+ check_taint 37, $+;
+ check_taint 38, $1;
+ check_taint_not 39, $2;
+
+ /(\S)/; # taint $&, $`, $', $+, $1.
+ check_taint 40, $&;
+ check_taint 41, $`;
+ check_taint 42, $';
+ check_taint 43, $+;
+ check_taint 44, $1;
+ check_taint_not 45, $2;
+
+ $_ = $a; # untaint $_
+
+ check_taint_not 46, $_;
+
+ /(b)/; # this must not taint
+ check_taint_not 47, $&;
+ check_taint_not 48, $`;
+ check_taint_not 49, $';
+ check_taint_not 50, $+;
+ check_taint_not 51, $1;
+ check_taint_not 52, $2;
+
+ $_ = $a; # untaint $_
+
+ check_taint_not 53, $_;
+
+ $b = uc($a); # taint $b
+ s/(.+)/$b/; # this must taint only the $_
+
+ check_taint 54, $_;
+ check_taint_not 55, $&;
+ check_taint_not 56, $`;
+ check_taint_not 57, $';
+ check_taint_not 58, $+;
+ check_taint_not 59, $1;
+ check_taint_not 60, $2;
+
+ $_ = $a; # untaint $_
+
+ s/(.+)/b/; # this must not taint
+ check_taint_not 61, $_;
+ check_taint_not 62, $&;
+ check_taint_not 63, $`;
+ check_taint_not 64, $';
+ check_taint_not 65, $+;
+ check_taint_not 66, $1;
+ check_taint_not 67, $2;
+
+ $b = $a; # untaint $b
+
+ ($b = $a) =~ s/\w/$&/;
+ check_taint 68, $b; # $b should be tainted.
+ check_taint_not 69, $a; # $a should be not.
+
+ $_ = $a; # untaint $_
+
+ s/(\w)/\l$1/; # this must taint
+ check_taint 70, $_;
+ check_taint 71, $&;
+ check_taint 72, $`;
+ check_taint 73, $';
+ check_taint 74, $+;
+ check_taint 75, $1;
+ check_taint_not 76, $2;
+
+ $_ = $a; # untaint $_
+
+ s/(\w)/\L$1/; # this must taint
+ check_taint 77, $_;
+ check_taint 78, $&;
+ check_taint 79, $`;
+ check_taint 80, $';
+ check_taint 81, $+;
+ check_taint 82, $1;
+ check_taint_not 83, $2;
+
+ $_ = $a; # untaint $_
+
+ s/(\w)/\u$1/; # this must taint
+ check_taint 84, $_;
+ check_taint 85, $&;
+ check_taint 86, $`;
+ check_taint 87, $';
+ check_taint 88, $+;
+ check_taint 89, $1;
+ check_taint_not 90, $2;
+
+ $_ = $a; # untaint $_
+
+ s/(\w)/\U$1/; # this must taint
+ check_taint 91, $_;
+ check_taint 92, $&;
+ check_taint 93, $`;
+ check_taint 94, $';
+ check_taint 95, $+;
+ check_taint 96, $1;
+ check_taint_not 97, $2;
+
+ # After all this tainting $a should be cool.
+
+ check_taint_not 98, $a;
+
+ sub last_without_setlocale { 98 }
+
+ # I think we've seen quite enough of taint.
+ # Let us do some *real* locale work now,
+ # unless setlocale() is missing (i.e. minitest).
+
+ exit unless $have_setlocale;
+
+ # Find locales.
+
+ debug "# Scanning for locales...\n";
+
+ # Note that it's okay that some languages have their native names
+ # capitalized here even though that's not "right". They are lowercased
+ # anyway later during the scanning process (and besides, some clueless
+ # vendor might have them capitalized errorneously anyway).
+
+ my $locales = <<EOF;
+ Afrikaans:af:za:1 15
+ Arabic:ar:dz eg sa:6 arabic8
+ Brezhoneg Breton:br:fr:1 15
+ Bulgarski Bulgarian:bg:bg:5
+ Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW Big5 GB2312 tw.EUC
+ Hrvatski Croatian:hr:hr:2
+ Cymraeg Welsh:cy:cy:1 14 15
+ Czech:cs:cz:2
+ Dansk Danish:dk:da:1 15
+ Nederlands Dutch:nl:be nl:1 15
+ English American British:en:au ca gb ie nz us uk zw:1 15 cp850
+ Esperanto:eo:eo:3
+ Eesti Estonian:et:ee:4 6 13
+ Suomi Finnish:fi:fi:1 15
+ Flamish::fl:1 15
+ Deutsch German:de:at be ch de lu:1 15
+ Euskaraz Basque:eu:es fr:1 15
+ Galego Galician:gl:es:1 15
+ Ellada Greek:el:gr:7 g8
+ Frysk:fy:nl:1 15
+ Greenlandic:kl:gl:4 6
+ Hebrew:iw:il:8 hebrew8
+ Hungarian:hu:hu:2
+ Indonesian:in:id:1 15
+ Gaeilge Irish:ga:IE:1 14 15
+ Italiano Italian:it:ch it:1 15
+ Nihongo Japanese:ja:jp:euc eucJP jp.EUC sjis
+ Korean:ko:kr:
+ Latine Latin:la:va:1 15
+ Latvian:lv:lv:4 6 13
+ Lithuanian:lt:lt:4 6 13
+ Macedonian:mk:mk:1 15
+ Maltese:mt:mt:3
+ Moldovan:mo:mo:2
+ Norsk Norwegian:no no\@nynorsk:no:1 15
+ Occitan:oc:es:1 15
+ Polski Polish:pl:pl:2
+ Rumanian:ro:ro:2
+ Russki Russian:ru:ru su ua:5 koi8 koi8r KOI8-R koi8u cp1251 cp866
+ Serbski Serbian:sr:yu:5
+ Slovak:sk:sk:2
+ Slovene Slovenian:sl:si:2
+ Sqhip Albanian:sq:sq:1 15
+ Svenska Swedish:sv:fi se:1 15
+ Thai:th:th:11 tis620
+ Turkish:tr:tr:9 turkish8
+ Yiddish:yi::1 15
+ EOF
+
+ if ($^O eq 'os390') {
+ # These cause heartburn. Broken locales?
+ $locales =~ s/Svenska Swedish:sv:fi se:1 15\n//;
+ $locales =~ s/Thai:th:th:11 tis620\n//;
+ }
+
+ sub in_utf8 () { $^H & 0x08 }
+
+ if (in_utf8) {
+ require "lib/locale/utf8";
+ } else {
+ require "lib/locale/latin1";
+ }
+
+ my @Locale;
+ my $Locale;
+ my @Alnum_;
+
+ my @utf8locale;
+ my %utf8skip;
+
+ sub getalnum_ {
+ sort grep /\w/, map { chr } 0..255
+ }
+
+ sub trylocale {
+ my $locale = shift;
+ if (setlocale(LC_ALL, $locale)) {
+ push @Locale, $locale;
+ }
+ }
+
+ sub decode_encodings {
+ my @enc;
+
+ foreach (split(/ /, shift)) {
+ if (/^(\d+)$/) {
+ push @enc, "ISO8859-$1";
+ push @enc, "iso8859$1"; # HP
+ if ($1 eq '1') {
+ push @enc, "roman8"; # HP
+ }
+ } else {
+ push @enc, $_;
+ push @enc, "$_.UTF-8";
+ }
+ }
+ if ($^O eq 'os390') {
+ push @enc, qw(IBM-037 IBM-819 IBM-1047);
+ }
+
+ return @enc;
+ }
+
+ trylocale("C");
+ trylocale("POSIX");
+ foreach (0..15) {
+ trylocale("ISO8859-$_");
+ trylocale("iso8859$_");
+ trylocale("iso8859-$_");
+ trylocale("iso_8859_$_");
+ trylocale("isolatin$_");
+ trylocale("isolatin-$_");
+ trylocale("iso_latin_$_");
+ }
+
+ # Sanitize the environment so that we can run the external 'locale'
+ # program without the taint mode getting grumpy.
+
+ # $ENV{PATH} is special in VMS.
+ delete $ENV{PATH} if $^O ne 'VMS' or $Config{d_setenv};
+
+ # Other subversive stuff.
+ delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
+
+ if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) {
+ while (<LOCALES>) {
+ chomp;
+ trylocale($_);
+ }
+ close(LOCALES);
+ } elsif ($^O eq 'VMS' && defined($ENV{'SYS$I18N_LOCALE'}) && -d 'SYS$I18N_LOCALE') {
+ # The SYS$I18N_LOCALE logical name search list was not present on
+ # VAX VMS V5.5-12, but was on AXP && VAX VMS V6.2 as well as later versions.
+ opendir(LOCALES, "SYS\$I18N_LOCALE:");
+ while ($_ = readdir(LOCALES)) {
+ chomp;
+ trylocale($_);
+ }
+ close(LOCALES);
+ } else {
+
+ # This is going to be slow.
+
+ foreach my $locale (split(/\n/, $locales)) {
+ my ($locale_name, $language_codes, $country_codes, $encodings) =
+ split(/:/, $locale);
+ my @enc = decode_encodings($encodings);
+ foreach my $loc (split(/ /, $locale_name)) {
+ trylocale($loc);
+ foreach my $enc (@enc) {
+ trylocale("$loc.$enc");
+ }
+ $loc = lc $loc;
+ foreach my $enc (@enc) {
+ trylocale("$loc.$enc");
+ }
+ }
+ foreach my $lang (split(/ /, $language_codes)) {
+ trylocale($lang);
+ foreach my $country (split(/ /, $country_codes)) {
+ my $lc = "${lang}_${country}";
+ trylocale($lc);
+ foreach my $enc (@enc) {
+ trylocale("$lc.$enc");
+ }
+ my $lC = "${lang}_\U${country}";
+ trylocale($lC);
+ foreach my $enc (@enc) {
+ trylocale("$lC.$enc");
+ }
+ }
+ }
+ }
+ }
+
+ setlocale(LC_ALL, "C");
+
+ sub utf8locale { $_[0] =~ /utf-?8/i }
+
+ @Locale = sort @Locale;
+
+ debug "# Locales = @Locale\n";
+
+ my %Problem;
+ my %Okay;
+ my %Testing;
+ my @Neoalpha;
+ my %Neoalpha;
+
+ sub tryneoalpha {
+ my ($Locale, $i, $test) = @_;
+ unless ($test) {
+ $Problem{$i}{$Locale} = 1;
+ debug "# failed $i with locale '$Locale'\n";
+ } else {
+ push @{$Okay{$i}}, $Locale;
+ }
+ }
+
+ foreach $Locale (@Locale) {
+ debug "# Locale = $Locale\n";
+ @Alnum_ = getalnum_();
+ debug "# w = ", join("",@Alnum_), "\n";
+
+ unless (setlocale(LC_ALL, $Locale)) {
+ foreach (99..103) {
+ $Problem{$_}{$Locale} = -1;
+ }
+ next;
+ }
+
+ # Sieve the uppercase and the lowercase.
+
+ my %UPPER = ();
+ my %lower = ();
+ my %BoThCaSe = ();
+ for (@Alnum_) {
+ if (/[^\d_]/) { # skip digits and the _
+ if (uc($_) eq $_) {
+ $UPPER{$_} = $_;
+ }
+ if (lc($_) eq $_) {
+ $lower{$_} = $_;
+ }
+ }
+ }
+ foreach (keys %UPPER) {
+ $BoThCaSe{$_}++ if exists $lower{$_};
+ }
+ foreach (keys %lower) {
+ $BoThCaSe{$_}++ if exists $UPPER{$_};
+ }
+ foreach (keys %BoThCaSe) {
+ delete $UPPER{$_};
+ delete $lower{$_};
+ }
+
+ debug "# UPPER = ", join("", sort keys %UPPER ), "\n";
+ debug "# lower = ", join("", sort keys %lower ), "\n";
+ debug "# BoThCaSe = ", join("", sort keys %BoThCaSe), "\n";
+
+ # Find the alphabets that are not alphabets in the default locale.
+
+ {
+ no locale;
+
+ @Neoalpha = ();
+ for (keys %UPPER, keys %lower) {
+ push(@Neoalpha, $_) if (/\W/);
+ $Neoalpha{$_} = $_;
+ }
+ }
+
+ @Neoalpha = sort @Neoalpha;
+
+ debug "# Neoalpha = ", join("",@Neoalpha), "\n";
+
+ if (@Neoalpha == 0) {
+ # If we have no Neoalphas the remaining tests are no-ops.
+ debug "# no Neoalpha, skipping tests 99..102 for locale '$Locale'\n";
+ foreach (99..102) {
+ push @{$Okay{$_}}, $Locale;
+ }
+ } else {
+
+ # Test \w.
+
+ if (utf8locale($Locale)) {
+ # utf8 and locales do not mix.
+ debug "# skipping UTF-8 locale '$Locale'\n";
+ push @utf8locale, $Locale;
+ @utf8skip{99..102} = ();
+ } else {
+ my $word = join('', @Neoalpha);
+
+ $word =~ /^(\w+)$/;
+
+ tryneoalpha($Locale, 99, $1 eq $word);
+ }
+ # Cross-check the whole 8-bit character set.
+
+ for (map { chr } 0..255) {
+ tryneoalpha($Locale, 100,
+ (/\w/ xor /\W/) ||
+ (/\d/ xor /\D/) ||
+ (/\s/ xor /\S/));
+ }
+
+ # Test for read-only scalars' locale vs non-locale comparisons.
+
+ {
+ no locale;
+ $a = "qwerty";
+ {
+ use locale;
+ tryneoalpha($Locale, 101, ($a cmp "qwerty") == 0);
+ }
+ }
+
+ {
+ my ($from, $to, $lesser, $greater,
+ @test, %test, $test, $yes, $no, $sign);
+
+ for (0..9) {
+ # Select a slice.
+ $from = int(($_*@Alnum_)/10);
+ $to = $from + int(@Alnum_/10);
+ $to = $#Alnum_ if ($to > $#Alnum_);
+ $lesser = join('', @Alnum_[$from..$to]);
+ # Select a slice one character on.
+ $from++; $to++;
+ $to = $#Alnum_ if ($to > $#Alnum_);
+ $greater = join('', @Alnum_[$from..$to]);
+ ($yes, $no, $sign) = ($lesser lt $greater
+ ? (" ", "not ", 1)
+ : ("not ", " ", -1));
+ # all these tests should FAIL (return 0).
+ # Exact lt or gt cannot be tested because
+ # in some locales, say, eacute and E may test equal.
+ @test =
+ (
+ $no.' ($lesser le $greater)', # 1
+ 'not ($lesser ne $greater)', # 2
+ ' ($lesser eq $greater)', # 3
+ $yes.' ($lesser ge $greater)', # 4
+ $yes.' ($lesser ge $greater)', # 5
+ $yes.' ($greater le $lesser )', # 7
+ 'not ($greater ne $lesser )', # 8
+ ' ($greater eq $lesser )', # 9
+ $no.' ($greater ge $lesser )', # 10
+ 'not (($lesser cmp $greater) == -($sign))' # 11
+ );
+ @test{@test} = 0 x @test;
+ $test = 0;
+ for my $ti (@test) {
+ $test{$ti} = eval $ti;
+ $test ||= $test{$ti}
+ }
+ tryneoalpha($Locale, 102, $test == 0);
+ if ($test) {
+ debug "# lesser = '$lesser'\n";
+ debug "# greater = '$greater'\n";
+ debug "# lesser cmp greater = ",
+ $lesser cmp $greater, "\n";
+ debug "# greater cmp lesser = ",
+ $greater cmp $lesser, "\n";
+ debug "# (greater) from = $from, to = $to\n";
+ for my $ti (@test) {
+ debugf("# %-40s %-4s", $ti,
+ $test{$ti} ? 'FAIL' : 'ok');
+ if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) {
+ debugf("(%s == %4d)", $1, eval $1);
+ }
+ debug "\n#";
+ }
+
+ last;
+ }
+ }
+ }
+ }
+
+ use locale;
+
+ my ($x, $y) = (1.23, 1.23);
+
+ $a = "$x";
+ printf ''; # printf used to reset locale to "C"
+ $b = "$y";
+
+ debug "# 103..107: a = $a, b = $b, Locale = $Locale\n";
+
+ tryneoalpha($Locale, 103, $a eq $b);
+
+ my $c = "$x";
+ my $z = sprintf ''; # sprintf used to reset locale to "C"
+ my $d = "$y";
+
+ debug "# 104..107: c = $c, d = $d, Locale = $Locale\n";
+
+ tryneoalpha($Locale, 104, $c eq $d);
+
+ {
+ use warnings;
+ my $w = 0;
+ local $SIG{__WARN__} =
+ sub {
+ print "# @_\n";
+ $w++;
+ };
+
+ # The == (among other ops) used to warn for locales
+ # that had something else than "." as the radix character.
+
+ tryneoalpha($Locale, 105, $c == 1.23);
+
+ tryneoalpha($Locale, 106, $c == $x);
+
+ tryneoalpha($Locale, 107, $c == $d);
+
+ {
+ # no locale; # XXX did this ever work correctly?
+
+ my $e = "$x";
+
+ debug "# 108..110: e = $e, Locale = $Locale\n";
+
+ tryneoalpha($Locale, 108, $e == 1.23);
+
+ tryneoalpha($Locale, 109, $e == $x);
+
+ tryneoalpha($Locale, 110, $e == $c);
+ }
+
+ my $f = "1.23";
+ my $g = 2.34;
+
+ debug "# 111..115: f = $f, g = $g, locale = $Locale\n";
+
+ tryneoalpha($Locale, 111, $f == 1.23);
+
+ tryneoalpha($Locale, 112, $f == $x);
+
+ tryneoalpha($Locale, 113, $f == $c);
+
+ tryneoalpha($Locale, 114, abs(($f + $g) - 3.57) < 0.01);
+
+ tryneoalpha($Locale, 115, $w == 0);
+ }
+
+ # Does taking lc separately differ from taking
+ # the lc "in-line"? (This was the bug 19990704.002, change #3568.)
+ # The bug was in the caching of the 'o'-magic.
+ {
+ use locale;
+
+ sub lcA {
+ my $lc0 = lc $_[0];
+ my $lc1 = lc $_[1];
+ return $lc0 cmp $lc1;
+ }
+
+ sub lcB {
+ return lc($_[0]) cmp lc($_[1]);
+ }
+
+ my $x = "ab";
+ my $y = "aa";
+ my $z = "AB";
+
+ tryneoalpha($Locale, 116,
+ lcA($x, $y) == 1 && lcB($x, $y) == 1 ||
+ lcA($x, $z) == 0 && lcB($x, $z) == 0);
+ }
+
+ # Does lc of an UPPER (if different from the UPPER) match
+ # case-insensitively the UPPER, and does the UPPER match
+ # case-insensitively the lc of the UPPER. And vice versa.
+ {
+ if (utf8locale($Locale)) {
+ # utf8 and locales do not mix.
+ debug "# skipping UTF-8 locale '$Locale'\n";
+ push @utf8locale, $Locale;
+ $utf8skip{117}++;
+ } else {
+ use locale;
+ use locale;
+ no utf8; # so that the native 8-bit characters work
+
+ my @f = ();
+ foreach my $x (keys %UPPER) {
+ my $y = lc $x;
+ next unless uc $y eq $x;
+ push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
+ }
+ foreach my $x (keys %lower) {
+ my $y = uc $x;
+ next unless lc $y eq $x;
+ push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
+ }
+ tryneoalpha($Locale, 117, @f == 0);
+ if (@f) {
+ print "# failed 117 locale '$Locale' characters @f\n"
+ }
+ }
+ }
+ }
+
+ # Recount the errors.
+
+ foreach (&last_without_setlocale()+1..$last) {
+ if ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) {
+ if ($_ == 102) {
+ print "# The failure of test 102 is not necessarily fatal.\n";
+ print "# It usually indicates a problem in the enviroment,\n";
+ print "# not in Perl itself.\n";
+ }
+ print "not ";
+ }
+ print "ok $_\n";
+ }
+
+ # Give final advice.
+
+ my $didwarn = 0;
+
+ foreach (99..$last) {
+ if ($Problem{$_}) {
+ my @f = sort keys %{ $Problem{$_} };
+ my $f = join(" ", @f);
+ $f =~ s/(.{50,60}) /$1\n#\t/g;
+ print
+ "#\n",
+ "# The locale ", (@f == 1 ? "definition" : "definitions"), "\n#\n",
+ "#\t", $f, "\n#\n",
+ "# on your system may have errors because the locale test $_\n",
+ "# failed in ", (@f == 1 ? "that locale" : "those locales"),
+ ".\n";
+ print <<EOW;
+ #
+ # If your users are not using these locales you are safe for the moment,
+ # but please report this failure first to perlbug\@perl.com using the
+ # perlbug script (as described in the INSTALL file) so that the exact
+ # details of the failures can be sorted out first and then your operating
+ # system supplier can be alerted about these anomalies.
+ #
+ EOW
+ $didwarn = 1;
+ }
+ }
+
+ # Tell which locales were okay and which were not.
+
+ if ($didwarn) {
+ my (@s, @F);
+
+ foreach my $l (@Locale) {
+ my $p = 0;
+ foreach my $t (102..$last) {
+ $p++ if $Problem{$t}{$l};
+ }
+ push @s, $l if $p == 0;
+ push @F, $l unless $p == 0;
+ }
+
+ if (@s) {
+ my $s = join(" ", @s);
+ $s =~ s/(.{50,60}) /$1\n#\t/g;
+
+ warn
+ "# The following locales\n#\n",
+ "#\t", $s, "\n#\n",
+ "# tested okay.\n#\n",
+ } else {
+ warn "# None of your locales were fully okay.\n";
+ }
+
+ if (@F) {
+ my $F = join(" ", @F);
+ $F =~ s/(.{50,60}) /$1\n#\t/g;
+
+ warn
+ "# The following locales\n#\n",
+ "#\t", $F, "\n#\n",
+ "# had problems.\n#\n",
+ } else {
+ warn "# None of your locales were broken.\n";
+ }
+
+ if (@utf8locale) {
+ my $S = join(" ", @utf8locale);
+ $S =~ s/(.{50,60}) /$1\n#\t/g;
+
+ warn "#\n# The following locales\n#\n",
+ "#\t", $S, "\n#\n",
+ "# were skipped for the tests ",
+ join(" ", sort {$a<=>$b} keys %utf8skip), "\n",
+ "# because UTF-8 and locales do not work together in Perl.\n#\n";
+ }
+ }
+
+ sub last { 117 }
+
+ # eof
diff -c 'perl-5.7.1/lib/open.pm' 'perl-5.7.2/lib/open.pm'
Index: ./lib/open.pm
*** ./lib/open.pm Wed Mar 28 21:32:58 2001
--- ./lib/open.pm Thu Jul 12 21:09:01 2001
***************
*** 2,24 ****
use Carp;
$open::hint_bits = 0x20000;
! # layers array and hash mainly manipulated by C code in perlio.c
! use vars qw(%layers @layers);
! # Populate hash in non-PerlIO case
! %layers = (crlf => 1, raw => 0) unless (@layers);
! # warn join(',',keys %layers);
! our $VERSION = '1.00';
sub import {
my ($class,@args) = @_;
croak("`use open' needs explicit list of disciplines") unless @args;
$^H |= $open::hint_bits;
! my ($in,$out) = split(/\0/,(${^OPEN} || '\0'));
! my @in = split(/\s+/,$in);
! my @out = split(/\s+/,$out);
while (@args) {
my $type = shift(@args);
my $discp = shift(@args);
--- 2,59 ----
use Carp;
$open::hint_bits = 0x20000;
! our $VERSION = '1.01';
! my $locale_encoding;
! sub in_locale { $^H & $locale::hint_bits }
! sub _get_locale_encoding {
! unless (defined $locale_encoding) {
! eval {
! # I18N::Langinfo isn't available everywhere
! require I18N::Langinfo;
! I18N::Langinfo->import('langinfo', 'CODESET');
! };
! unless ($@) {
! $locale_encoding = langinfo(CODESET());
! }
! my $country_language;
! if (not $locale_encoding && in_locale()) {
! if ($ENV{LC_ALL} =~ /^([^.]+)\.([^.]+)$/) {
! ($country_language, $locale_encoding) = ($1, $2);
! } elsif ($ENV{LANG} =~ /^([^.]+)\.([^.]+)$/) {
! ($country_language, $locale_encoding) = ($1, $2);
! }
! } else {
! # Could do heuristics based on the country and language
! # parts of LC_ALL and LANG (the parts before the dot (if any)),
! # since we have Locale::Country and Locale::Language available.
! # TODO: get a database of Language -> Encoding mappings
! # (the Estonian database at http://www.eki.ee/letter/
! # would be excellent!) --jhi
! }
! if (defined $locale_encoding &&
! $locale_encoding eq 'euc' &&
! defined $country_language) {
! if ($country_language =~ /^ja_JP|japan(?:ese)?$/i) {
! $locale_encoding = 'eucjp';
! } elsif ($country_language =~ /^ko_KR|korean?$/i) {
! $locale_encoding = 'euckr';
! } elsif ($country_language =~ /^zh_TW|taiwan(?:ese)?$/i) {
! $locale_encoding = 'euctw';
! }
! croak "Locale encoding 'euc' too ambiguous"
! if $locale_encoding eq 'euc';
! }
! }
! }
sub import {
my ($class,@args) = @_;
croak("`use open' needs explicit list of disciplines") unless @args;
$^H |= $open::hint_bits;
! my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1);
while (@args) {
my $type = shift(@args);
my $discp = shift(@args);
***************
*** 25,31 ****
my @val;
foreach my $layer (split(/\s+/,$discp)) {
$layer =~ s/^://;
! unless(exists $layers{$layer}) {
carp("Unknown discipline layer '$layer'");
}
push(@val,":$layer");
--- 60,78 ----
my @val;
foreach my $layer (split(/\s+/,$discp)) {
$layer =~ s/^://;
! if ($layer eq 'locale') {
! use Encode;
! _get_locale_encoding()
! unless defined $locale_encoding;
! croak "Cannot figure out an encoding to use"
! unless defined $locale_encoding;
! if ($locale_encoding =~ /^utf-?8$/i) {
! $layer = "utf8";
! } else {
! $layer = "encoding($locale_encoding)";
! }
! }
! unless(PerlIO::Layer::->find($layer)) {
carp("Unknown discipline layer '$layer'");
}
push(@val,":$layer");
***************
*** 33,38 ****
--- 80,86 ----
$^H{"open_$type"} = $layer;
}
}
+ # print "# type = $type, val = @val\n";
if ($type eq 'IN') {
$in = join(' ',@val);
}
***************
*** 39,44 ****
--- 87,95 ----
elsif ($type eq 'OUT') {
$out = join(' ',@val);
}
+ elsif ($type eq 'INOUT') {
+ $in = $out = join(' ',@val);
+ }
else {
croak "Unknown discipline class '$type'";
}
***************
*** 56,118 ****
=head1 SYNOPSIS
use open IN => ":crlf", OUT => ":raw";
=head1 DESCRIPTION
! Full-fledged support for I/O disciplines is now implemented provided perl is
! configured to use PerlIO as its IO system (which is now the default).
The C<open> pragma serves as one of the interfaces to declare default
"layers" (aka disciplines) for all I/O.
The C<open> pragma is used to declare one or more default layers for
! I/O operations. Any open(), readpipe() (aka qx//) and similar operators
! found within the lexical scope of this pragma will use the declared defaults.
! When open() is given an explicit list of layers they are appended to the
! list declared using this pragma.
Directory handles may also support disciplines in future.
=head1 NONPERLIO FUNCTIONALITY
! If perl is not built to use PerlIO as its IO system then only the two pseudo-disciplines
! ":raw" and ":crlf" are available.
The ":raw" discipline corresponds to "binary mode" and the ":crlf"
discipline corresponds to "text mode" on platforms that distinguish
between the two modes when opening files (which is many DOS-like
! platforms, including Windows). These two disciplines are
! no-ops on platforms where binmode() is a no-op, but perform their
! functions everywhere if PerlIO is enabled.
=head1 IMPLEMENTATION DETAILS
! There are two package variables C<%layers> and C<@layers> which
! are mainly manipulated by C code in F<perlio.c>, but are visible
! to the nosy:
! print "Have ",join(',',keys %open::layers),"\n";
! print "Using ",join(',',@open::layers),"\n";
! The C<%open::layers> hash is a record of the available "layers" that may be pushed
! onto a C<PerlIO> stream. The values of the hash are perl objects, of class C<PerlIO::Layer>
! which are created by the C code in F<perlio.c>. As yet there is nothing useful you
! can do with the objects at the perl level.
!
! The C<@open::layers> array is the current set of layers and their arguments.
! The array consists of layer => argument pairs and I<must> always have even number of
! entries and the even entries I<must> be C<PerlIO::Layer> objects or perl will "die"
! when it attempts to open a filehandle. In most cases the odd entry will be C<undef>,
! but in the case of (say) ":encoding(iso-8859-1)" it will be 'iso-8859-1'. These
! argument entries are currently restricted to being strings.
!
! When a new C<PerlIO> stream is opened, the C code looks at the
! array to determine the default layers to be pushed. So with care it is possible
! to manipulate the default layer "stack":
!
! splice(@PerlIO::layers,-2,2);
! push(@PerlIO::layers,$PerlIO::layers{'stdio'} => undef);
=head1 SEE ALSO
--- 107,157 ----
=head1 SYNOPSIS
use open IN => ":crlf", OUT => ":raw";
+ use open INOUT => ":utf8";
=head1 DESCRIPTION
! Full-fledged support for I/O disciplines is now implemented provided
! Perl is configured to use PerlIO as its IO system (which is now the
! default).
The C<open> pragma serves as one of the interfaces to declare default
"layers" (aka disciplines) for all I/O.
The C<open> pragma is used to declare one or more default layers for
! I/O operations. Any open(), readpipe() (aka qx//) and similar
! operators found within the lexical scope of this pragma will use the
! declared defaults.
! When open() is given an explicit list of layers they are appended to
! the list declared using this pragma.
Directory handles may also support disciplines in future.
=head1 NONPERLIO FUNCTIONALITY
! If Perl is not built to use PerlIO as its IO system then only the two
! pseudo-disciplines ":raw" and ":crlf" are available.
The ":raw" discipline corresponds to "binary mode" and the ":crlf"
discipline corresponds to "text mode" on platforms that distinguish
between the two modes when opening files (which is many DOS-like
! platforms, including Windows). These two disciplines are no-ops on
! platforms where binmode() is a no-op, but perform their functions
! everywhere if PerlIO is enabled.
=head1 IMPLEMENTATION DETAILS
! There is a class method in C<PerlIO::Layer> C<find> which is
! implemented as XS code. It is called by C<import> to validate the
! layers:
! PerlIO::Layer::->find("perlio")
! The return value (if defined) is a Perl object, of class
! C<PerlIO::Layer> which is created by the C code in F<perlio.c>. As
! yet there is nothing useful you can do with the object at the perl
! level.
=head1 SEE ALSO
diff -c /dev/null 'perl-5.7.2/lib/overload.t'
Index: ./lib/overload.t
*** ./lib/overload.t Thu Jan 1 02:00:00 1970
--- ./lib/overload.t Mon Jul 9 17:10:49 2001
***************
*** 0 ****
--- 1,1050 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ package Oscalar;
+ use overload (
+ # Anonymous subroutines:
+ '+' => sub {new Oscalar $ {$_[0]}+$_[1]},
+ '-' => sub {new Oscalar
+ $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]},
+ '<=>' => sub {new Oscalar
+ $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]},
+ 'cmp' => sub {new Oscalar
+ $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])},
+ '*' => sub {new Oscalar ${$_[0]}*$_[1]},
+ '/' => sub {new Oscalar
+ $_[2]? $_[1]/${$_[0]} :
+ ${$_[0]}/$_[1]},
+ '%' => sub {new Oscalar
+ $_[2]? $_[1]%${$_[0]} : ${$_[0]}%$_[1]},
+ '**' => sub {new Oscalar
+ $_[2]? $_[1]**${$_[0]} : ${$_[0]}-$_[1]},
+
+ qw(
+ "" stringify
+ 0+ numify) # Order of arguments unsignificant
+ );
+
+ sub new {
+ my $foo = $_[1];
+ bless \$foo, $_[0];
+ }
+
+ sub stringify { "${$_[0]}" }
+ sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead
+ # comparing to direct compilation based on
+ # stringify
+
+ package main;
+
+ $test = 0;
+ $| = 1;
+ print "1..",&last,"\n";
+
+ sub test {
+ $test++;
+ if (@_ > 1) {
+ if ($_[0] eq $_[1]) {
+ print "ok $test\n";
+ } else {
+ print "not ok $test: '$_[0]' ne '$_[1]'\n";
+ }
+ } else {
+ if (shift) {
+ print "ok $test\n";
+ } else {
+ print "not ok $test\n";
+ }
+ }
+ }
+
+ $a = new Oscalar "087";
+ $b= "$a";
+
+ # All test numbers in comments are off by 1.
+ # So much for hard-wiring them in :-) To fix this:
+ test(1); # 1
+
+ test ($b eq $a); # 2
+ test ($b eq "087"); # 3
+ test (ref $a eq "Oscalar"); # 4
+ test ($a eq $a); # 5
+ test ($a eq "087"); # 6
+
+ $c = $a + 7;
+
+ test (ref $c eq "Oscalar"); # 7
+ test (!($c eq $a)); # 8
+ test ($c eq "94"); # 9
+
+ $b=$a;
+
+ test (ref $a eq "Oscalar"); # 10
+
+ $b++;
+
+ test (ref $b eq "Oscalar"); # 11
+ test ( $a eq "087"); # 12
+ test ( $b eq "88"); # 13
+ test (ref $a eq "Oscalar"); # 14
+
+ $c=$b;
+ $c-=$a;
+
+ test (ref $c eq "Oscalar"); # 15
+ test ( $a eq "087"); # 16
+ test ( $c eq "1"); # 17
+ test (ref $a eq "Oscalar"); # 18
+
+ $b=1;
+ $b+=$a;
+
+ test (ref $b eq "Oscalar"); # 19
+ test ( $a eq "087"); # 20
+ test ( $b eq "88"); # 21
+ test (ref $a eq "Oscalar"); # 22
+
+ eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ];
+
+ $b=$a;
+
+ test (ref $a eq "Oscalar"); # 23
+
+ $b++;
+
+ test (ref $b eq "Oscalar"); # 24
+ test ( $a eq "087"); # 25
+ test ( $b eq "88"); # 26
+ test (ref $a eq "Oscalar"); # 27
+
+ package Oscalar;
+ $dummy=bless \$dummy; # Now cache of method should be reloaded
+ package main;
+
+ $b=$a;
+ $b++;
+
+ test (ref $b eq "Oscalar"); # 28
+ test ( $a eq "087"); # 29
+ test ( $b eq "88"); # 30
+ test (ref $a eq "Oscalar"); # 31
+
+ undef $b; # Destroying updates tables too...
+
+ eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ];
+
+ $b=$a;
+
+ test (ref $a eq "Oscalar"); # 32
+
+ $b++;
+
+ test (ref $b eq "Oscalar"); # 33
+ test ( $a eq "087"); # 34
+ test ( $b eq "88"); # 35
+ test (ref $a eq "Oscalar"); # 36
+
+ package Oscalar;
+ $dummy=bless \$dummy; # Now cache of method should be reloaded
+ package main;
+
+ $b++;
+
+ test (ref $b eq "Oscalar"); # 37
+ test ( $a eq "087"); # 38
+ test ( $b eq "90"); # 39
+ test (ref $a eq "Oscalar"); # 40
+
+ $b=$a;
+ $b++;
+
+ test (ref $b eq "Oscalar"); # 41
+ test ( $a eq "087"); # 42
+ test ( $b eq "89"); # 43
+ test (ref $a eq "Oscalar"); # 44
+
+
+ test ($b? 1:0); # 45
+
+ eval q[ package Oscalar; use overload ('=' => sub {$main::copies++;
+ package Oscalar;
+ local $new=$ {$_[0]};
+ bless \$new } ) ];
+
+ $b=new Oscalar "$a";
+
+ test (ref $b eq "Oscalar"); # 46
+ test ( $a eq "087"); # 47
+ test ( $b eq "087"); # 48
+ test (ref $a eq "Oscalar"); # 49
+
+ $b++;
+
+ test (ref $b eq "Oscalar"); # 50
+ test ( $a eq "087"); # 51
+ test ( $b eq "89"); # 52
+ test (ref $a eq "Oscalar"); # 53
+ test ($copies == 0); # 54
+
+ $b+=1;
+
+ test (ref $b eq "Oscalar"); # 55
+ test ( $a eq "087"); # 56
+ test ( $b eq "90"); # 57
+ test (ref $a eq "Oscalar"); # 58
+ test ($copies == 0); # 59
+
+ $b=$a;
+ $b+=1;
+
+ test (ref $b eq "Oscalar"); # 60
+ test ( $a eq "087"); # 61
+ test ( $b eq "88"); # 62
+ test (ref $a eq "Oscalar"); # 63
+ test ($copies == 0); # 64
+
+ $b=$a;
+ $b++;
+
+ test (ref $b eq "Oscalar") || print ref $b,"=ref(b)\n"; # 65
+ test ( $a eq "087"); # 66
+ test ( $b eq "89"); # 67
+ test (ref $a eq "Oscalar"); # 68
+ test ($copies == 1); # 69
+
+ eval q[package Oscalar; use overload ('+=' => sub {$ {$_[0]} += 3*$_[1];
+ $_[0] } ) ];
+ $c=new Oscalar; # Cause rehash
+
+ $b=$a;
+ $b+=1;
+
+ test (ref $b eq "Oscalar"); # 70
+ test ( $a eq "087"); # 71
+ test ( $b eq "90"); # 72
+ test (ref $a eq "Oscalar"); # 73
+ test ($copies == 2); # 74
+
+ $b+=$b;
+
+ test (ref $b eq "Oscalar"); # 75
+ test ( $b eq "360"); # 76
+ test ($copies == 2); # 77
+ $b=-$b;
+
+ test (ref $b eq "Oscalar"); # 78
+ test ( $b eq "-360"); # 79
+ test ($copies == 2); # 80
+
+ $b=abs($b);
+
+ test (ref $b eq "Oscalar"); # 81
+ test ( $b eq "360"); # 82
+ test ($copies == 2); # 83
+
+ $b=abs($b);
+
+ test (ref $b eq "Oscalar"); # 84
+ test ( $b eq "360"); # 85
+ test ($copies == 2); # 86
+
+ eval q[package Oscalar;
+ use overload ('x' => sub {new Oscalar ( $_[2] ? "_.$_[1]._" x $ {$_[0]}
+ : "_.${$_[0]}._" x $_[1])}) ];
+
+ $a=new Oscalar "yy";
+ $a x= 3;
+ test ($a eq "_.yy.__.yy.__.yy._"); # 87
+
+ eval q[package Oscalar;
+ use overload ('.' => sub {new Oscalar ( $_[2] ?
+ "_.$_[1].__.$ {$_[0]}._"
+ : "_.$ {$_[0]}.__.$_[1]._")}) ];
+
+ $a=new Oscalar "xx";
+
+ test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88
+
+ # Check inheritance of overloading;
+ {
+ package OscalarI;
+ @ISA = 'Oscalar';
+ }
+
+ $aI = new OscalarI "$a";
+ test (ref $aI eq "OscalarI"); # 89
+ test ("$aI" eq "xx"); # 90
+ test ($aI eq "xx"); # 91
+ test ("b${aI}c" eq "_._.b.__.xx._.__.c._"); # 92
+
+ # Here we test blessing to a package updates hash
+
+ eval "package Oscalar; no overload '.'";
+
+ test ("b${a}" eq "_.b.__.xx._"); # 93
+ $x="1";
+ bless \$x, Oscalar;
+ test ("b${a}c" eq "bxxc"); # 94
+ new Oscalar 1;
+ test ("b${a}c" eq "bxxc"); # 95
+
+ # Negative overloading:
+
+ $na = eval { ~$a };
+ test($@ =~ /no method found/); # 96
+
+ # Check AUTOLOADING:
+
+ *Oscalar::AUTOLOAD =
+ sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ;
+ goto &{"Oscalar::$AUTOLOAD"}};
+
+ eval "package Oscalar; sub comple; use overload '~' => 'comple'";
+
+ $na = eval { ~$a }; # Hash was not updated
+ test($@ =~ /no method found/); # 97
+
+ bless \$x, Oscalar;
+
+ $na = eval { ~$a }; # Hash updated
+ warn "`$na', $@" if $@;
+ test !$@; # 98
+ test($na eq '_!_xx_!_'); # 99
+
+ $na = 0;
+
+ $na = eval { ~$aI }; # Hash was not updated
+ test($@ =~ /no method found/); # 100
+
+ bless \$x, OscalarI;
+
+ $na = eval { ~$aI };
+ print $@;
+
+ test !$@; # 101
+ test($na eq '_!_xx_!_'); # 102
+
+ eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'";
+
+ $na = eval { $aI >> 1 }; # Hash was not updated
+ test($@ =~ /no method found/); # 103
+
+ bless \$x, OscalarI;
+
+ $na = 0;
+
+ $na = eval { $aI >> 1 };
+ print $@;
+
+ test !$@; # 104
+ test($na eq '_!_xx_!_'); # 105
+
+ # warn overload::Method($a, '0+'), "\n";
+ test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106
+ test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107
+ test (overload::Overloaded($aI)); # 108
+ test (!overload::Overloaded('overload')); # 109
+
+ test (! defined overload::Method($aI, '<<')); # 110
+ test (! defined overload::Method($a, '<')); # 111
+
+ test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112
+ test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113
+
+ # Check overloading by methods (specified deep in the ISA tree).
+ {
+ package OscalarII;
+ @ISA = 'OscalarI';
+ sub Oscalar::lshft {"_<<_" . shift() . "_<<_"}
+ eval "package OscalarI; use overload '<<' => 'lshft', '|' => 'lshft'";
+ }
+
+ $aaII = "087";
+ $aII = \$aaII;
+ bless $aII, 'OscalarII';
+ bless \$fake, 'OscalarI'; # update the hash
+ test(($aI | 3) eq '_<<_xx_<<_'); # 114
+ # warn $aII << 3;
+ test(($aII << 3) eq '_<<_087_<<_'); # 115
+
+ {
+ BEGIN { $int = 7; overload::constant 'integer' => sub {$int++; shift}; }
+ $out = 2**10;
+ }
+ test($int, 9); # 116
+ test($out, 1024); # 117
+
+ $foo = 'foo';
+ $foo1 = 'f\'o\\o';
+ {
+ BEGIN { $q = $qr = 7;
+ overload::constant 'q' => sub {$q++; push @q, shift, ($_[1] || 'none'); shift},
+ 'qr' => sub {$qr++; push @qr, shift, ($_[1] || 'none'); shift}; }
+ $out = 'foo';
+ $out1 = 'f\'o\\o';
+ $out2 = "a\a$foo,\,";
+ /b\b$foo.\./;
+ }
+
+ test($out, 'foo'); # 118
+ test($out, $foo); # 119
+ test($out1, 'f\'o\\o'); # 120
+ test($out1, $foo1); # 121
+ test($out2, "a\afoo,\,"); # 122
+ test("@q", "foo q f'o\\\\o q a\\a qq ,\\, qq"); # 123
+ test($q, 11); # 124
+ test("@qr", "b\\b qq .\\. qq"); # 125
+ test($qr, 9); # 126
+
+ {
+ $_ = '!<b>!foo!<-.>!';
+ BEGIN { overload::constant 'q' => sub {push @q1, shift, ($_[1] || 'none'); "_<" . (shift) . ">_"},
+ 'qr' => sub {push @qr1, shift, ($_[1] || 'none'); "!<" . (shift) . ">!"}; }
+ $out = 'foo';
+ $out1 = 'f\'o\\o';
+ $out2 = "a\a$foo,\,";
+ $res = /b\b$foo.\./;
+ $a = <<EOF;
+ oups
+ EOF
+ $b = <<'EOF';
+ oups1
+ EOF
+ $c = bareword;
+ m'try it';
+ s'first part'second part';
+ s/yet another/tail here/;
+ tr/A-Z/a-z/;
+ }
+
+ test($out, '_<foo>_'); # 117
+ test($out1, '_<f\'o\\o>_'); # 128
+ test($out2, "_<a\a>_foo_<,\,>_"); # 129
+ test("@q1", "foo q f'o\\\\o q a\\a qq ,\\, qq oups
+ qq oups1
+ q second part q tail here s A-Z tr a-z tr"); # 130
+ test("@qr1", "b\\b qq .\\. qq try it q first part q yet another qq"); # 131
+ test($res, 1); # 132
+ test($a, "_<oups
+ >_"); # 133
+ test($b, "_<oups1
+ >_"); # 134
+ test($c, "bareword"); # 135
+
+ {
+ package symbolic; # Primitive symbolic calculator
+ use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num,
+ '=' => \&cpy, '++' => \&inc, '--' => \&dec;
+
+ sub new { shift; bless ['n', @_] }
+ sub cpy {
+ my $self = shift;
+ bless [@$self], ref $self;
+ }
+ sub inc { $_[0] = bless ['++', $_[0], 1]; }
+ sub dec { $_[0] = bless ['--', $_[0], 1]; }
+ sub wrap {
+ my ($obj, $other, $inv, $meth) = @_;
+ if ($meth eq '++' or $meth eq '--') {
+ @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference
+ return $obj;
+ }
+ ($obj, $other) = ($other, $obj) if $inv;
+ bless [$meth, $obj, $other];
+ }
+ sub str {
+ my ($meth, $a, $b) = @{+shift};
+ $a = 'u' unless defined $a;
+ if (defined $b) {
+ "[$meth $a $b]";
+ } else {
+ "[$meth $a]";
+ }
+ }
+ my %subr = ( 'n' => sub {$_[0]} );
+ foreach my $op (split " ", $overload::ops{with_assign}) {
+ $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}";
+ }
+ my @bins = qw(binary 3way_comparison num_comparison str_comparison);
+ foreach my $op (split " ", "@overload::ops{ @bins }") {
+ $subr{$op} = eval "sub {shift() $op shift()}";
+ }
+ foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
+ $subr{$op} = eval "sub {$op shift()}";
+ }
+ $subr{'++'} = $subr{'+'};
+ $subr{'--'} = $subr{'-'};
+
+ sub num {
+ my ($meth, $a, $b) = @{+shift};
+ my $subr = $subr{$meth}
+ or die "Do not know how to ($meth) in symbolic";
+ $a = $a->num if ref $a eq __PACKAGE__;
+ $b = $b->num if ref $b eq __PACKAGE__;
+ $subr->($a,$b);
+ }
+ sub TIESCALAR { my $pack = shift; $pack->new(@_) }
+ sub FETCH { shift }
+ sub nop { } # Around a bug
+ sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; }
+ sub STORE {
+ my $obj = shift;
+ $#$obj = 1;
+ $obj->[1] = shift;
+ }
+ }
+
+ {
+ my $foo = new symbolic 11;
+ my $baz = $foo++;
+ test( (sprintf "%d", $foo), '12');
+ test( (sprintf "%d", $baz), '11');
+ my $bar = $foo;
+ $baz = ++$foo;
+ test( (sprintf "%d", $foo), '13');
+ test( (sprintf "%d", $bar), '12');
+ test( (sprintf "%d", $baz), '13');
+ my $ban = $foo;
+ $baz = ($foo += 1);
+ test( (sprintf "%d", $foo), '14');
+ test( (sprintf "%d", $bar), '12');
+ test( (sprintf "%d", $baz), '14');
+ test( (sprintf "%d", $ban), '13');
+ $baz = 0;
+ $baz = $foo++;
+ test( (sprintf "%d", $foo), '15');
+ test( (sprintf "%d", $baz), '14');
+ test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]');
+ }
+
+ {
+ my $iter = new symbolic 2;
+ my $side = new symbolic 1;
+ my $cnt = $iter;
+
+ while ($cnt) {
+ $cnt = $cnt - 1; # The "simple" way
+ $side = (sqrt(1 + $side**2) - 1)/$side;
+ }
+ my $pi = $side*(2**($iter+2));
+ test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]';
+ test( (sprintf "%f", $pi), '3.182598');
+ }
+
+ {
+ my $iter = new symbolic 2;
+ my $side = new symbolic 1;
+ my $cnt = $iter;
+
+ while ($cnt--) {
+ $side = (sqrt(1 + $side**2) - 1)/$side;
+ }
+ my $pi = $side*(2**($iter+2));
+ test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]';
+ test( (sprintf "%f", $pi), '3.182598');
+ }
+
+ {
+ my ($a, $b);
+ symbolic->vars($a, $b);
+ my $c = sqrt($a**2 + $b**2);
+ $a = 3; $b = 4;
+ test( (sprintf "%d", $c), '5');
+ $a = 12; $b = 5;
+ test( (sprintf "%d", $c), '13');
+ }
+
+ {
+ package symbolic1; # Primitive symbolic calculator
+ # Mutator inc/dec
+ use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, '=' => \&cpy;
+
+ sub new { shift; bless ['n', @_] }
+ sub cpy {
+ my $self = shift;
+ bless [@$self], ref $self;
+ }
+ sub wrap {
+ my ($obj, $other, $inv, $meth) = @_;
+ if ($meth eq '++' or $meth eq '--') {
+ @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference
+ return $obj;
+ }
+ ($obj, $other) = ($other, $obj) if $inv;
+ bless [$meth, $obj, $other];
+ }
+ sub str {
+ my ($meth, $a, $b) = @{+shift};
+ $a = 'u' unless defined $a;
+ if (defined $b) {
+ "[$meth $a $b]";
+ } else {
+ "[$meth $a]";
+ }
+ }
+ my %subr = ( 'n' => sub {$_[0]} );
+ foreach my $op (split " ", $overload::ops{with_assign}) {
+ $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}";
+ }
+ my @bins = qw(binary 3way_comparison num_comparison str_comparison);
+ foreach my $op (split " ", "@overload::ops{ @bins }") {
+ $subr{$op} = eval "sub {shift() $op shift()}";
+ }
+ foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
+ $subr{$op} = eval "sub {$op shift()}";
+ }
+ $subr{'++'} = $subr{'+'};
+ $subr{'--'} = $subr{'-'};
+
+ sub num {
+ my ($meth, $a, $b) = @{+shift};
+ my $subr = $subr{$meth}
+ or die "Do not know how to ($meth) in symbolic";
+ $a = $a->num if ref $a eq __PACKAGE__;
+ $b = $b->num if ref $b eq __PACKAGE__;
+ $subr->($a,$b);
+ }
+ sub TIESCALAR { my $pack = shift; $pack->new(@_) }
+ sub FETCH { shift }
+ sub nop { } # Around a bug
+ sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; }
+ sub STORE {
+ my $obj = shift;
+ $#$obj = 1;
+ $obj->[1] = shift;
+ }
+ }
+
+ {
+ my $foo = new symbolic1 11;
+ my $baz = $foo++;
+ test( (sprintf "%d", $foo), '12');
+ test( (sprintf "%d", $baz), '11');
+ my $bar = $foo;
+ $baz = ++$foo;
+ test( (sprintf "%d", $foo), '13');
+ test( (sprintf "%d", $bar), '12');
+ test( (sprintf "%d", $baz), '13');
+ my $ban = $foo;
+ $baz = ($foo += 1);
+ test( (sprintf "%d", $foo), '14');
+ test( (sprintf "%d", $bar), '12');
+ test( (sprintf "%d", $baz), '14');
+ test( (sprintf "%d", $ban), '13');
+ $baz = 0;
+ $baz = $foo++;
+ test( (sprintf "%d", $foo), '15');
+ test( (sprintf "%d", $baz), '14');
+ test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]');
+ }
+
+ {
+ my $iter = new symbolic1 2;
+ my $side = new symbolic1 1;
+ my $cnt = $iter;
+
+ while ($cnt) {
+ $cnt = $cnt - 1; # The "simple" way
+ $side = (sqrt(1 + $side**2) - 1)/$side;
+ }
+ my $pi = $side*(2**($iter+2));
+ test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]';
+ test( (sprintf "%f", $pi), '3.182598');
+ }
+
+ {
+ my $iter = new symbolic1 2;
+ my $side = new symbolic1 1;
+ my $cnt = $iter;
+
+ while ($cnt--) {
+ $side = (sqrt(1 + $side**2) - 1)/$side;
+ }
+ my $pi = $side*(2**($iter+2));
+ test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]';
+ test( (sprintf "%f", $pi), '3.182598');
+ }
+
+ {
+ my ($a, $b);
+ symbolic1->vars($a, $b);
+ my $c = sqrt($a**2 + $b**2);
+ $a = 3; $b = 4;
+ test( (sprintf "%d", $c), '5');
+ $a = 12; $b = 5;
+ test( (sprintf "%d", $c), '13');
+ }
+
+ {
+ package two_face; # Scalars with separate string and
+ # numeric values.
+ sub new { my $p = shift; bless [@_], $p }
+ use overload '""' => \&str, '0+' => \&num, fallback => 1;
+ sub num {shift->[1]}
+ sub str {shift->[0]}
+ }
+
+ {
+ my $seven = new two_face ("vii", 7);
+ test( (sprintf "seven=$seven, seven=%d, eight=%d", $seven, $seven+1),
+ 'seven=vii, seven=7, eight=8');
+ test( scalar ($seven =~ /i/), '1')
+ }
+
+ {
+ package sorting;
+ use overload 'cmp' => \∁
+ sub new { my ($p, $v) = @_; bless \$v, $p }
+ sub comp { my ($x,$y) = @_; ($$x * 3 % 10) <=> ($$y * 3 % 10) or $$x cmp $$y }
+ }
+ {
+ my @arr = map sorting->new($_), 0..12;
+ my @sorted1 = sort @arr;
+ my @sorted2 = map $$_, @sorted1;
+ test "@sorted2", '0 10 7 4 1 11 8 5 12 2 9 6 3';
+ }
+ {
+ package iterator;
+ use overload '<>' => \&iter;
+ sub new { my ($p, $v) = @_; bless \$v, $p }
+ sub iter { my ($x) = @_; return undef if $$x < 0; return $$x--; }
+ }
+
+ # XXX iterator overload not intended to work with CORE::GLOBAL?
+ if (defined &CORE::GLOBAL::glob) {
+ test '1', '1'; # 175
+ test '1', '1'; # 176
+ test '1', '1'; # 177
+ }
+ else {
+ my $iter = iterator->new(5);
+ my $acc = '';
+ my $out;
+ $acc .= " $out" while $out = <${iter}>;
+ test $acc, ' 5 4 3 2 1 0'; # 175
+ $iter = iterator->new(5);
+ test scalar <${iter}>, '5'; # 176
+ $acc = '';
+ $acc .= " $out" while $out = <$iter>;
+ test $acc, ' 4 3 2 1 0'; # 177
+ }
+ {
+ package deref;
+ use overload '%{}' => \&hderef, '&{}' => \&cderef,
+ '*{}' => \&gderef, '${}' => \&sderef, '@{}' => \&aderef;
+ sub new { my ($p, $v) = @_; bless \$v, $p }
+ sub deref {
+ my ($self, $key) = (shift, shift);
+ my $class = ref $self;
+ bless $self, 'deref::dummy'; # Disable overloading of %{}
+ my $out = $self->{$key};
+ bless $self, $class; # Restore overloading
+ $out;
+ }
+ sub hderef {shift->deref('h')}
+ sub aderef {shift->deref('a')}
+ sub cderef {shift->deref('c')}
+ sub gderef {shift->deref('g')}
+ sub sderef {shift->deref('s')}
+ }
+ {
+ my $deref = bless { h => { foo => 5 , fake => 23 },
+ c => sub {return shift() + 34},
+ 's' => \123,
+ a => [11..13],
+ g => \*srt,
+ }, 'deref';
+ # Hash:
+ my @cont = sort %$deref;
+ if ("\t" eq "\011") { # ascii
+ test "@cont", '23 5 fake foo'; # 178
+ }
+ else { # ebcdic alpha-numeric sort order
+ test "@cont", 'fake foo 23 5'; # 178
+ }
+ my @keys = sort keys %$deref;
+ test "@keys", 'fake foo'; # 179
+ my @val = sort values %$deref;
+ test "@val", '23 5'; # 180
+ test $deref->{foo}, 5; # 181
+ test defined $deref->{bar}, ''; # 182
+ my $key;
+ @keys = ();
+ push @keys, $key while $key = each %$deref;
+ @keys = sort @keys;
+ test "@keys", 'fake foo'; # 183
+ test exists $deref->{bar}, ''; # 184
+ test exists $deref->{foo}, 1; # 185
+ # Code:
+ test $deref->(5), 39; # 186
+ test &$deref(6), 40; # 187
+ sub xxx_goto { goto &$deref }
+ test xxx_goto(7), 41; # 188
+ my $srt = bless { c => sub {$b <=> $a}
+ }, 'deref';
+ *srt = \&$srt;
+ my @sorted = sort srt 11, 2, 5, 1, 22;
+ test "@sorted", '22 11 5 2 1'; # 189
+ # Scalar
+ test $$deref, 123; # 190
+ # Code
+ @sorted = sort $srt 11, 2, 5, 1, 22;
+ test "@sorted", '22 11 5 2 1'; # 191
+ # Array
+ test "@$deref", '11 12 13'; # 192
+ test $#$deref, '2'; # 193
+ my $l = @$deref;
+ test $l, 3; # 194
+ test $deref->[2], '13'; # 195
+ $l = pop @$deref;
+ test $l, 13; # 196
+ $l = 1;
+ test $deref->[$l], '12'; # 197
+ # Repeated dereference
+ my $double = bless { h => $deref,
+ }, 'deref';
+ test $double->{foo}, 5; # 198
+ }
+
+ {
+ package two_refs;
+ use overload '%{}' => \&gethash, '@{}' => sub { ${shift()} };
+ sub new {
+ my $p = shift;
+ bless \ [@_], $p;
+ }
+ sub gethash {
+ my %h;
+ my $self = shift;
+ tie %h, ref $self, $self;
+ \%h;
+ }
+
+ sub TIEHASH { my $p = shift; bless \ shift, $p }
+ my %fields;
+ my $i = 0;
+ $fields{$_} = $i++ foreach qw{zero one two three};
+ sub STORE {
+ my $self = ${shift()};
+ my $key = $fields{shift()};
+ defined $key or die "Out of band access";
+ $$self->[$key] = shift;
+ }
+ sub FETCH {
+ my $self = ${shift()};
+ my $key = $fields{shift()};
+ defined $key or die "Out of band access";
+ $$self->[$key];
+ }
+ }
+
+ my $bar = new two_refs 3,4,5,6;
+ $bar->[2] = 11;
+ test $bar->{two}, 11; # 199
+ $bar->{three} = 13;
+ test $bar->[3], 13; # 200
+
+ {
+ package two_refs_o;
+ @ISA = ('two_refs');
+ }
+
+ $bar = new two_refs_o 3,4,5,6;
+ $bar->[2] = 11;
+ test $bar->{two}, 11; # 201
+ $bar->{three} = 13;
+ test $bar->[3], 13; # 202
+
+ {
+ package two_refs1;
+ use overload '%{}' => sub { ${shift()}->[1] },
+ '@{}' => sub { ${shift()}->[0] };
+ sub new {
+ my $p = shift;
+ my $a = [@_];
+ my %h;
+ tie %h, $p, $a;
+ bless \ [$a, \%h], $p;
+ }
+ sub gethash {
+ my %h;
+ my $self = shift;
+ tie %h, ref $self, $self;
+ \%h;
+ }
+
+ sub TIEHASH { my $p = shift; bless \ shift, $p }
+ my %fields;
+ my $i = 0;
+ $fields{$_} = $i++ foreach qw{zero one two three};
+ sub STORE {
+ my $a = ${shift()};
+ my $key = $fields{shift()};
+ defined $key or die "Out of band access";
+ $a->[$key] = shift;
+ }
+ sub FETCH {
+ my $a = ${shift()};
+ my $key = $fields{shift()};
+ defined $key or die "Out of band access";
+ $a->[$key];
+ }
+ }
+
+ $bar = new two_refs_o 3,4,5,6;
+ $bar->[2] = 11;
+ test $bar->{two}, 11; # 203
+ $bar->{three} = 13;
+ test $bar->[3], 13; # 204
+
+ {
+ package two_refs1_o;
+ @ISA = ('two_refs1');
+ }
+
+ $bar = new two_refs1_o 3,4,5,6;
+ $bar->[2] = 11;
+ test $bar->{two}, 11; # 205
+ $bar->{three} = 13;
+ test $bar->[3], 13; # 206
+
+ {
+ package B;
+ use overload bool => sub { ${+shift} };
+ }
+
+ my $aaa;
+ { my $bbbb = 0; $aaa = bless \$bbbb, B }
+
+ test !$aaa, 1; # 207
+
+ unless ($aaa) {
+ test 'ok', 'ok'; # 208
+ } else {
+ test 'is not', 'ok'; # 208
+ }
+
+ # check that overload isn't done twice by join
+ { my $c = 0;
+ package Join;
+ use overload '""' => sub { $c++ };
+ my $x = join '', bless([]), 'pq', bless([]);
+ main::test $x, '0pq1'; # 209
+ };
+
+ # Test module-specific warning
+ {
+ # check the Odd number of arguments for overload::constant warning
+ my $a = "" ;
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+ $x = eval ' overload::constant "integer" ; ' ;
+ test($a eq "") ; # 210
+ use warnings 'overload' ;
+ $x = eval ' overload::constant "integer" ; ' ;
+ test($a =~ /^Odd number of arguments for overload::constant at/) ; # 211
+ }
+
+ {
+ # check the `$_[0]' is not an overloadable type warning
+ my $a = "" ;
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+ $x = eval ' overload::constant "fred" => sub {} ; ' ;
+ test($a eq "") ; # 212
+ use warnings 'overload' ;
+ $x = eval ' overload::constant "fred" => sub {} ; ' ;
+ test($a =~ /^`fred' is not an overloadable type at/); # 213
+ }
+
+ {
+ # check the `$_[1]' is not a code reference warning
+ my $a = "" ;
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+ $x = eval ' overload::constant "integer" => 1; ' ;
+ test($a eq "") ; # 214
+ use warnings 'overload' ;
+ $x = eval ' overload::constant "integer" => 1; ' ;
+ test($a =~ /^`1' is not a code reference at/); # 215
+ }
+
+ {
+ my $c = 0;
+ package ov_int1;
+ use overload '""' => sub { 3+shift->[0] },
+ '0+' => sub { 10+shift->[0] },
+ 'int' => sub { 100+shift->[0] };
+ sub new {my $p = shift; bless [shift], $p}
+
+ package ov_int2;
+ use overload '""' => sub { 5+shift->[0] },
+ '0+' => sub { 30+shift->[0] },
+ 'int' => sub { 'ov_int1'->new(1000+shift->[0]) };
+ sub new {my $p = shift; bless [shift], $p}
+
+ package noov_int;
+ use overload '""' => sub { 2+shift->[0] },
+ '0+' => sub { 9+shift->[0] };
+ sub new {my $p = shift; bless [shift], $p}
+
+ package main;
+
+ my $x = new noov_int 11;
+ my $int_x = int $x;
+ main::test("$int_x" eq 20); # 216
+ $x = new ov_int1 31;
+ $int_x = int $x;
+ main::test("$int_x" eq 131); # 217
+ $x = new ov_int2 51;
+ $int_x = int $x;
+ main::test("$int_x" eq 1054); # 218
+ }
+
+ # make sure that we don't inifinitely recurse
+ {
+ my $c = 0;
+ package Recurse;
+ use overload '""' => sub { shift },
+ '0+' => sub { shift },
+ 'bool' => sub { shift },
+ fallback => 1;
+ my $x = bless([]);
+ main::test("$x" =~ /Recurse=ARRAY/); # 219
+ main::test($x); # 220
+ main::test($x+0 =~ /Recurse=ARRAY/); # 221
+ }
+
+ # BugID 20010422.003
+ package Foo;
+
+ use overload
+ 'bool' => sub { return !$_[0]->is_zero() || undef; }
+ ;
+
+ sub is_zero
+ {
+ my $self = shift;
+ return $self->{var} == 0;
+ }
+
+ sub new
+ {
+ my $class = shift;
+ my $self = {};
+ $self->{var} = shift;
+ bless $self,$class;
+ }
+
+ package main;
+
+ use strict;
+
+ my $r = Foo->new(8);
+ $r = Foo->new(0);
+
+ test(($r || 0) == 0); # 222
+
+ # Last test is:
+ sub last {222}
diff -c 'perl-5.7.1/lib/perl5db.pl' 'perl-5.7.2/lib/perl5db.pl'
Index: ./lib/perl5db.pl
*** ./lib/perl5db.pl Tue Mar 6 04:05:41 2001
--- ./lib/perl5db.pl Mon Jul 9 17:10:49 2001
***************
*** 2,8 ****
# Debugger for Perl 5.00x; perl5db.pl patch level:
! $VERSION = 1.07;
$header = "perl5db.pl version $VERSION";
#
--- 2,8 ----
# Debugger for Perl 5.00x; perl5db.pl patch level:
! $VERSION = 1.13;
$header = "perl5db.pl version $VERSION";
#
***************
*** 82,88 ****
##################################################################
# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
- # Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
# modified Perl debugger, to be run from Emacs in perldb-mode
# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
--- 82,87 ----
***************
*** 119,125 ****
# Some additional words on internal work of debugger.
# `b load filename' implemented.
# `b postpone subr' implemented.
! # now only `q' exits debugger (overwriteable on $inhibit_exit).
# When restarting debugger breakpoints/actions persist.
# Buglet: When restarting debugger only one breakpoint/action per
# autoloaded function persists.
--- 118,124 ----
# Some additional words on internal work of debugger.
# `b load filename' implemented.
# `b postpone subr' implemented.
! # now only `q' exits debugger (overwritable on $inhibit_exit).
# When restarting debugger breakpoints/actions persist.
# Buglet: When restarting debugger only one breakpoint/action per
# autoloaded function persists.
***************
*** 129,135 ****
# new `inhibitExit' option.
# printing of a very long statement interruptible.
# Changes: 0.98: New command `m' for printing possible methods
! # 'l -' is a synonim for `-'.
# Cosmetic bugs in printing stack trace.
# `frame' & 8 to print "expanded args" in stack trace.
# Can list/break in imported subs.
--- 128,134 ----
# new `inhibitExit' option.
# printing of a very long statement interruptible.
# Changes: 0.98: New command `m' for printing possible methods
! # 'l -' is a synonym for `-'.
# Cosmetic bugs in printing stack trace.
# `frame' & 8 to print "expanded args" in stack trace.
# Can list/break in imported subs.
***************
*** 147,153 ****
# when completing a subroutine name (same for `l').
# Changes: 1.07: Many fixed by tchrist 13-March-2000
# BUG FIXES:
! # + Added bare mimimal security checks on perldb rc files, plus
# comments on what else is needed.
# + Fixed the ornaments that made "|h" completely unusable.
# They are not used in print_help if they will hurt. Strip pod
--- 146,152 ----
# when completing a subroutine name (same for `l').
# Changes: 1.07: Many fixed by tchrist 13-March-2000
# BUG FIXES:
! # + Added bare minimal security checks on perldb rc files, plus
# comments on what else is needed.
# + Fixed the ornaments that made "|h" completely unusable.
# They are not used in print_help if they will hurt. Strip pod
***************
*** 155,161 ****
# + Fixed mis-formatting of help messages caused by ornaments
# to restore Larry's original formatting.
# + Fixed many other formatting errors. The code is still suboptimal,
! # and needs a lot of work at restructuing. It's also misindented
# in many places.
# + Fixed bug where trying to look at an option like your pager
# shows "1".
--- 154,160 ----
# + Fixed mis-formatting of help messages caused by ornaments
# to restore Larry's original formatting.
# + Fixed many other formatting errors. The code is still suboptimal,
! # and needs a lot of work at restructuring. It's also misindented
# in many places.
# + Fixed bug where trying to look at an option like your pager
# shows "1".
***************
*** 164,170 ****
# or else not caring about detailed status. This should really be
# unified into one place, too.
# + Fixed bug where invisible trailing whitespace on commands hoses you,
! # tricking Perl into thinking you wern't calling a debugger command!
# + Fixed bug where leading whitespace on commands hoses you. (One
# suggests a leading semicolon or any other irrelevant non-whitespace
# to indicate literal Perl code.)
--- 163,169 ----
# or else not caring about detailed status. This should really be
# unified into one place, too.
# + Fixed bug where invisible trailing whitespace on commands hoses you,
! # tricking Perl into thinking you weren't calling a debugger command!
# + Fixed bug where leading whitespace on commands hoses you. (One
# suggests a leading semicolon or any other irrelevant non-whitespace
# to indicate literal Perl code.)
***************
*** 187,193 ****
# + Added to and rearranged the help information.
# + Detected apparent misuse of { ... } to declare a block; this used
# to work but now is a command, and mysteriously gave no complaint.
!
####################################################################
# Needed for the statement after exec():
--- 186,259 ----
# + Added to and rearranged the help information.
# + Detected apparent misuse of { ... } to declare a block; this used
# to work but now is a command, and mysteriously gave no complaint.
! #
! # Changes: 1.08: Apr 25, 2001 Jon Eveland <jweveland@yahoo.com>
! # BUG FIX:
! # + This patch to perl5db.pl cleans up formatting issues on the help
! # summary (h h) screen in the debugger. Mostly columnar alignment
! # issues, plus converted the printed text to use all spaces, since
! # tabs don't seem to help much here.
! #
! # Changes: 1.09: May 19, 2001 Ilya Zakharevich <ilya@math.ohio-state.edu>
! # 0) Minor bugs corrected;
! # a) Support for auto-creation of new TTY window on startup, either
! # unconditionally, or if started as a kid of another debugger session;
! # b) New `O'ption CreateTTY
! # I<CreateTTY> bits control attempts to create a new TTY on events:
! # 1: on fork() 2: debugger is started inside debugger
! # 4: on startup
! # c) Code to auto-create a new TTY window on OS/2 (currently one one
! # extra window per session - need named pipes to have more...);
! # d) Simplified interface for custom createTTY functions (with a backward
! # compatibility hack); now returns the TTY name to use; return of ''
! # means that the function reset the I/O handles itself;
! # d') Better message on the semantic of custom createTTY function;
! # e) Convert the existing code to create a TTY into a custom createTTY
! # function;
! # f) Consistent support for TTY names of the form "TTYin,TTYout";
! # g) Switch line-tracing output too to the created TTY window;
! # h) make `b fork' DWIM with CORE::GLOBAL::fork;
! # i) High-level debugger API cmd_*():
! # cmd_b_load($filenamepart) # b load filenamepart
! # cmd_b_line($lineno [, $cond]) # b lineno [cond]
! # cmd_b_sub($sub [, $cond]) # b sub [cond]
! # cmd_stop() # Control-C
! # cmd_d($lineno) # d lineno
! # The cmd_*() API returns FALSE on failure; in this case it outputs
! # the error message to the debugging output.
! # j) Low-level debugger API
! # break_on_load($filename) # b load filename
! # @files = report_break_on_load() # List files with load-breakpoints
! # breakable_line_in_filename($name, $from [, $to])
! # # First breakable line in the
! # # range $from .. $to. $to defaults
! # # to $from, and may be less than $to
! # breakable_line($from [, $to]) # Same for the current file
! # break_on_filename_line($name, $lineno [, $cond])
! # # Set breakpoint,$cond defaults to 1
! # break_on_filename_line_range($name, $from, $to [, $cond])
! # # As above, on the first
! # # breakable line in range
! # break_on_line($lineno [, $cond]) # As above, in the current file
! # break_subroutine($sub [, $cond]) # break on the first breakable line
! # ($name, $from, $to) = subroutine_filename_lines($sub)
! # # The range of lines of the text
! # The low-level API returns TRUE on success, and die()s on failure.
! #
! # Changes: 1.10: May 23, 2001 Daniel Lewart <d-lewart@uiuc.edu>
! # BUG FIXES:
! # + Fixed warnings generated by "perl -dWe 42"
! # + Corrected spelling errors
! # + Squeezed Help (h) output into 80 columns
! #
! # Changes: 1.11: May 24, 2001 David Dyck <dcd@tc.fluke.com>
! # + Made "x @INC" work like it used to
! #
! # Changes: 1.12: May 24, 2001 Daniel Lewart <d-lewart@uiuc.edu>
! # + Fixed warnings generated by "O" (Show debugger options)
! # + Fixed warnings generated by "p 42" (Print expression)
! # Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com
! # + Added windowSize option
####################################################################
# Needed for the statement after exec():
***************
*** 224,231 ****
TTY noTTY ReadLine NonStop LineInfo maxTraceLen
recallCommand ShellBang pager tkRunning ornaments
signalLevel warnLevel dieLevel inhibit_exit
! ImmediateStop bareStringify
! RemotePort);
%optionVars = (
hashDepth => \$dumpvar::hashDepth,
--- 290,297 ----
TTY noTTY ReadLine NonStop LineInfo maxTraceLen
recallCommand ShellBang pager tkRunning ornaments
signalLevel warnLevel dieLevel inhibit_exit
! ImmediateStop bareStringify CreateTTY
! RemotePort windowSize);
%optionVars = (
hashDepth => \$dumpvar::hashDepth,
***************
*** 236,242 ****
HighBit => \$dumpvar::quoteHighBit,
undefPrint => \$dumpvar::printUndef,
globPrint => \$dumpvar::globPrint,
! UsageOnly => \$dumpvar::usageOnly,
bareStringify => \$dumpvar::bareStringify,
frame => \$frame,
AutoTrace => \$trace,
--- 302,309 ----
HighBit => \$dumpvar::quoteHighBit,
undefPrint => \$dumpvar::printUndef,
globPrint => \$dumpvar::globPrint,
! UsageOnly => \$dumpvar::usageOnly,
! CreateTTY => \$CreateTTY,
bareStringify => \$dumpvar::bareStringify,
frame => \$frame,
AutoTrace => \$trace,
***************
*** 244,249 ****
--- 311,317 ----
maxTraceLen => \$maxtrace,
ImmediateStop => \$ImmediateStop,
RemotePort => \$remoteport,
+ windowSize => \$window,
);
%optionAction = (
***************
*** 274,285 ****
# These guys may be defined in $ENV{PERL5DB} :
$rl = 1 unless defined $rl;
! $warnLevel = 0 unless defined $warnLevel;
! $dieLevel = 0 unless defined $dieLevel;
$signalLevel = 1 unless defined $signalLevel;
$pre = [] unless defined $pre;
$post = [] unless defined $post;
$pretype = [] unless defined $pretype;
warnLevel($warnLevel);
dieLevel($dieLevel);
--- 342,354 ----
# These guys may be defined in $ENV{PERL5DB} :
$rl = 1 unless defined $rl;
! $warnLevel = 1 unless defined $warnLevel;
! $dieLevel = 1 unless defined $dieLevel;
$signalLevel = 1 unless defined $signalLevel;
$pre = [] unless defined $pre;
$post = [] unless defined $post;
$pretype = [] unless defined $pretype;
+ $CreateTTY = 3 unless defined $CreateTTY;
warnLevel($warnLevel);
dieLevel($dieLevel);
***************
*** 294,300 ****
--- 363,382 ----
setman();
&recallCommand("!") unless defined $prc;
&shellBang("!") unless defined $psh;
+ sethelp();
$maxtrace = 400 unless defined $maxtrace;
+ $ini_pids = $ENV{PERLDB_PIDS};
+ if (defined $ENV{PERLDB_PIDS}) {
+ $pids = "[$ENV{PERLDB_PIDS}]";
+ $ENV{PERLDB_PIDS} .= "->$$";
+ $term_pid = -1;
+ } else {
+ $ENV{PERLDB_PIDS} = "$$";
+ $pids = '';
+ $term_pid = $$;
+ }
+ $pidprompt = '';
+ *emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
if (-e "/dev/tty") { # this is the wrong metric!
$rcfile=".perldb";
***************
*** 358,363 ****
--- 440,452 ----
parse_options($ENV{PERLDB_OPTS});
}
+ if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
+ and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
+ *get_fork_TTY = \&xterm_get_fork_TTY;
+ } elsif ($^O eq 'os2') {
+ *get_fork_TTY = \&os2_get_fork_TTY;
+ }
+
# Here begin the unreadable code. It needs fixing.
if (exists $ENV{PERLDB_RESTART}) {
***************
*** 415,420 ****
--- 504,513 ----
$console = undef;
}
+ if ($^O eq 'NetWare') {
+ $console = undef;
+ }
+
# Around a bug:
if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
$console = undef;
***************
*** 434,444 ****
);
if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
$IN = $OUT;
! }
! else {
if (defined $console) {
! open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
! open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
|| open(OUT,">&STDOUT"); # so we don't dongle stdout
} else {
open(IN,"<&STDIN");
--- 527,540 ----
);
if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
$IN = $OUT;
! } elsif ($CreateTTY & 4) {
! create_IN_OUT(4);
! } else {
if (defined $console) {
! my ($i, $o) = split /,/, $console;
! $o = $i unless defined $o;
! open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
! open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
|| open(OUT,">&STDOUT"); # so we don't dongle stdout
} else {
open(IN,"<&STDIN");
***************
*** 450,471 ****
$OUT = \*OUT;
}
! select($OUT);
$| = 1; # for DB::OUT
! select(STDOUT);
$LINEINFO = $OUT unless defined $LINEINFO;
$lineinfo = $console unless defined $lineinfo;
- $| = 1; # for real STDOUT
-
$header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
unless ($runnonstop) {
! print $OUT "\nLoading DB routines from $header\n";
! print $OUT ("Editor support ",
! $slave_editor ? "enabled" : "available",
! ".\n");
! print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
}
}
--- 546,569 ----
$OUT = \*OUT;
}
! my $previous = select($OUT);
$| = 1; # for DB::OUT
! select($previous);
$LINEINFO = $OUT unless defined $LINEINFO;
$lineinfo = $console unless defined $lineinfo;
$header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
unless ($runnonstop) {
! if ($term_pid eq '-1') {
! print $OUT "\nDaughter DB session started...\n";
! } else {
! print $OUT "\nLoading DB routines from $header\n";
! print $OUT ("Editor support ",
! $slave_editor ? "enabled" : "available",
! ".\n");
! print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
! }
}
}
***************
*** 505,511 ****
"package $package;"; # this won't let them modify, alas
local(*dbline) = $main::{'_<' . $filename};
$max = $#dbline;
! if (($stop,$action) = split(/\0/,$dbline{$line})) {
if ($stop eq '1') {
$signal |= 1;
} elsif ($stop) {
--- 603,609 ----
"package $package;"; # this won't let them modify, alas
local(*dbline) = $main::{'_<' . $filename};
$max = $#dbline;
! if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
if ($stop eq '1') {
$signal |= 1;
} elsif ($stop) {
***************
*** 540,546 ****
if ($single || ($trace & 1) || $was_signal) {
if ($slave_editor) {
$position = "\032\032$filename:$line:0\n";
! print $LINEINFO $position;
} elsif ($package eq 'DB::fake') {
$term || &setterm;
print_help(<<EOP);
--- 638,644 ----
if ($single || ($trace & 1) || $was_signal) {
if ($slave_editor) {
$position = "\032\032$filename:$line:0\n";
! print_lineinfo($position);
} elsif ($package eq 'DB::fake') {
$term || &setterm;
print_help(<<EOP);
***************
*** 565,573 ****
$position = "$prefix$line$infix$dbline[$line]$after";
}
if ($frame) {
! print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after";
} else {
! print $LINEINFO $position;
}
for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
--- 663,671 ----
$position = "$prefix$line$infix$dbline[$line]$after";
}
if ($frame) {
! print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
} else {
! print_lineinfo($position);
}
for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
***************
*** 576,584 ****
$incr_pos = "$prefix$i$infix$dbline[$i]$after";
$position .= $incr_pos;
if ($frame) {
! print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after";
} else {
! print $LINEINFO $incr_pos;
}
}
}
--- 674,682 ----
$incr_pos = "$prefix$i$infix$dbline[$i]$after";
$position .= $incr_pos;
if ($frame) {
! print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
} else {
! print_lineinfo($incr_pos);
}
}
}
***************
*** 596,603 ****
@typeahead = (@$pretype, @typeahead);
CMD:
while (($term || &setterm),
! ($term_pid == $$ or &resetterm),
! defined ($cmd=&readline(" DB" . ('<' x $level) .
($#hist+1) . ('>' x $level) .
" ")))
{
--- 694,701 ----
@typeahead = (@$pretype, @typeahead);
CMD:
while (($term || &setterm),
! ($term_pid == $$ or resetterm(1)),
! defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
($#hist+1) . ('>' x $level) .
" ")))
{
***************
*** 725,734 ****
$cmd = "$1 $s";
};
$cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
! $subname = $1;
$subname =~ s/\'/::/;
$subname = $package."::".$subname
unless $subname =~ /::/;
$subname = "main".$subname if substr($subname,0,2) eq "::";
@pieces = split(/:/,find_sub($subname) || $sub{$subname});
$subrange = pop @pieces;
--- 823,835 ----
$cmd = "$1 $s";
};
$cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
! my $s = $subname = $1;
$subname =~ s/\'/::/;
$subname = $package."::".$subname
unless $subname =~ /::/;
+ $subname = "CORE::GLOBAL::$s"
+ if not defined &$subname and $s !~ /::/
+ and defined &{"CORE::GLOBAL::$s"};
$subname = "main".$subname if substr($subname,0,2) eq "::";
@pieces = split(/:/,find_sub($subname) || $sub{$subname});
$subrange = pop @pieces;
***************
*** 755,761 ****
$filename = $filename_ini;
*dbline = $main::{'_<' . $filename};
$max = $#dbline;
! print $LINEINFO $position;
next CMD };
$cmd =~ /^w\b\s*(\d*)$/ && do {
$incr = $window - 1;
--- 856,862 ----
$filename = $filename_ini;
*dbline = $main::{'_<' . $filename};
$max = $#dbline;
! print_lineinfo($position);
next CMD };
$cmd =~ /^w\b\s*(\d*)$/ && do {
$incr = $window - 1;
***************
*** 788,794 ****
$i = $end;
} else {
for (; $i <= $end; $i++) {
! ($stop,$action) = split(/\0/, $dbline{$i});
$arrow = ($i==$line
and $filename eq $filename_ini)
? '==>'
--- 889,897 ----
$i = $end;
} else {
for (; $i <= $end; $i++) {
! my ($stop,$action);
! ($stop,$action) = split(/\0/, $dbline{$i}) if
! $dbline{$i};
$arrow = ($i==$line
and $filename eq $filename_ini)
? '==>'
***************
*** 896,908 ****
next CMD; };
$cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
my $file = $1; $file =~ s/\s+$//;
! {
! $break_on_load{$file} = 1;
! $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
! $file .= '.pm', redo unless $file =~ /\./;
! }
! $had_breakpoints{$file} |= 1;
! print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
next CMD; };
$cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
my $cond = length $3 ? $3 : '1';
--- 999,1005 ----
next CMD; };
$cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
my $file = $1; $file =~ s/\s+$//;
! cmd_b_load($file);
next CMD; };
$cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
my $cond = length $3 ? $3 : '1';
***************
*** 917,958 ****
$cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
$subname = $1;
$cond = length $2 ? $2 : '1';
! $subname =~ s/\'/::/g;
! $subname = "${'package'}::" . $subname
! unless $subname =~ /::/;
! $subname = "main".$subname if substr($subname,0,2) eq "::";
! # Filename below can contain ':'
! ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
! $i += 0;
! if ($i) {
! local $filename = $file;
! local *dbline = $main::{'_<' . $filename};
! $had_breakpoints{$filename} |= 1;
! $max = $#dbline;
! ++$i while $dbline[$i] == 0 && $i < $max;
! $dbline{$i} =~ s/^[^\0]*/$cond/;
! } else {
! print $OUT "Subroutine $subname not found.\n";
! }
next CMD; };
$cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
$i = $1 || $line;
$cond = length $2 ? $2 : '1';
! if ($dbline[$i] == 0) {
! print $OUT "Line $i not breakable.\n";
! } else {
! $had_breakpoints{$filename} |= 1;
! $dbline{$i} =~ s/^[^\0]*/$cond/;
! }
next CMD; };
$cmd =~ /^d\b\s*(\d*)/ && do {
! $i = $1 || $line;
! if ($dbline[$i] == 0) {
! print $OUT "Line $i not breakable.\n";
! } else {
! $dbline{$i} =~ s/^[^\0]*//;
! delete $dbline{$i} if $dbline{$i} eq '';
! }
next CMD; };
$cmd =~ /^A$/ && do {
print $OUT "Deleting all actions...\n";
--- 1014,1028 ----
$cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
$subname = $1;
$cond = length $2 ? $2 : '1';
! cmd_b_sub($subname, $cond);
next CMD; };
$cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
$i = $1 || $line;
$cond = length $2 ? $2 : '1';
! cmd_b_line($i, $cond);
next CMD; };
$cmd =~ /^d\b\s*(\d*)/ && do {
! cmd_d($1 || $line);
next CMD; };
$cmd =~ /^A$/ && do {
print $OUT "Deleting all actions...\n";
***************
*** 1201,1208 ****
set_list("PERLDB_POST", @$post);
set_list("PERLDB_TYPEAHEAD", @typeahead);
$ENV{PERLDB_RESTART} = 1;
#print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
! exec $^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS;
print $OUT "exec failed: $!\n";
last CMD; };
$cmd =~ /^T$/ && do {
--- 1271,1280 ----
set_list("PERLDB_POST", @$post);
set_list("PERLDB_TYPEAHEAD", @typeahead);
$ENV{PERLDB_RESTART} = 1;
+ delete $ENV{PERLDB_PIDS}; # Restore ini state
+ $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
#print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
! exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
print $OUT "exec failed: $!\n";
last CMD; };
$cmd =~ /^T$/ && do {
***************
*** 1459,1475 ****
$single &= 1;
$single |= 4 if $stack_depth == $deep;
($frame & 4
! ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in "),
# Why -1? But it works! :-(
print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
! : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame;
if (wantarray) {
@ret = &$sub;
$single |= $stack[$stack_depth--];
($frame & 4
! ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
! : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
if ($doret eq $stack_depth or $frame & 16) {
my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
print $fh ' ' x $stack_depth if $frame & 16;
--- 1531,1547 ----
$single &= 1;
$single |= 4 if $stack_depth == $deep;
($frame & 4
! ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
# Why -1? But it works! :-(
print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
! : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
if (wantarray) {
@ret = &$sub;
$single |= $stack[$stack_depth--];
($frame & 4
! ? ( print_lineinfo(' ' x $stack_depth, "out "),
print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
! : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
if ($doret eq $stack_depth or $frame & 16) {
my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
print $fh ' ' x $stack_depth if $frame & 16;
***************
*** 1486,1494 ****
};
$single |= $stack[$stack_depth--];
($frame & 4
! ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
! : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
print $fh (' ' x $stack_depth) if $frame & 16;
--- 1558,1566 ----
};
$single |= $stack[$stack_depth--];
($frame & 4
! ? ( print_lineinfo(' ' x $stack_depth, "out "),
print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
! : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
print $fh (' ' x $stack_depth) if $frame & 16;
***************
*** 1502,1518 ****
}
}
sub save {
@saved = ($@, $!, $^E, $,, $/, $\, $^W);
$, = ""; $/ = "\n"; $\ = ""; $^W = 0;
}
# The following takes its argument via $evalarg to preserve current @_
sub eval {
# 'my' would make it visible from user code
! # but so does local! --tchrist
! local @res;
{
local $otrace = $trace;
local $osingle = $single;
--- 1574,1727 ----
}
}
+ ### The API section
+
+ ### Functions with multiple modes of failure die on error, the rest
+ ### returns FALSE on error.
+ ### User-interface functions cmd_* output error message.
+
+ sub break_on_load {
+ my $file = shift;
+ $break_on_load{$file} = 1;
+ $had_breakpoints{$file} |= 1;
+ }
+
+ sub report_break_on_load {
+ sort keys %break_on_load;
+ }
+
+ sub cmd_b_load {
+ my $file = shift;
+ my @files;
+ {
+ push @files, $file;
+ push @files, $::INC{$file} if $::INC{$file};
+ $file .= '.pm', redo unless $file =~ /\./;
+ }
+ break_on_load($_) for @files;
+ @files = report_break_on_load;
+ print $OUT "Will stop on load of `@files'.\n";
+ }
+
+ $filename_error = '';
+
+ sub breakable_line {
+ my ($from, $to) = @_;
+ my $i = $from;
+ if (@_ >= 2) {
+ my $delta = $from < $to ? +1 : -1;
+ my $limit = $delta > 0 ? $#dbline : 1;
+ $limit = $to if ($limit - $to) * $delta > 0;
+ $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
+ }
+ return $i unless $dbline[$i] == 0;
+ my ($pl, $upto) = ('', '');
+ ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
+ die "Line$pl $from$upto$filename_error not breakable\n";
+ }
+
+ sub breakable_line_in_filename {
+ my ($f) = shift;
+ local *dbline = $main::{'_<' . $f};
+ local $filename_error = " of `$f'";
+ breakable_line(@_);
+ }
+
+ sub break_on_line {
+ my ($i, $cond) = @_;
+ $cond = 1 unless @_ >= 2;
+ my $inii = $i;
+ my $after = '';
+ my $pl = '';
+ die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
+ $had_breakpoints{$filename} |= 1;
+ if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
+ else { $dbline{$i} = $cond; }
+ }
+
+ sub cmd_b_line {
+ eval { break_on_line(@_); 1 } or print $OUT $@ and return;
+ }
+
+ sub break_on_filename_line {
+ my ($f, $i, $cond) = @_;
+ $cond = 1 unless @_ >= 3;
+ local *dbline = $main::{'_<' . $f};
+ local $filename_error = " of `$f'";
+ local $filename = $f;
+ break_on_line($i, $cond);
+ }
+
+ sub break_on_filename_line_range {
+ my ($f, $from, $to, $cond) = @_;
+ my $i = breakable_line_in_filename($f, $from, $to);
+ $cond = 1 unless @_ >= 3;
+ break_on_filename_line($f,$i,$cond);
+ }
+
+ sub subroutine_filename_lines {
+ my ($subname,$cond) = @_;
+ # Filename below can contain ':'
+ find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
+ }
+
+ sub break_subroutine {
+ my $subname = shift;
+ my ($file,$s,$e) = subroutine_filename_lines($subname) or
+ die "Subroutine $subname not found.\n";
+ $cond = 1 unless @_ >= 2;
+ break_on_filename_line_range($file,$s,$e,@_);
+ }
+
+ sub cmd_b_sub {
+ my ($subname,$cond) = @_;
+ $cond = 1 unless @_ >= 2;
+ unless (ref $subname eq 'CODE') {
+ $subname =~ s/\'/::/g;
+ my $s = $subname;
+ $subname = "${'package'}::" . $subname
+ unless $subname =~ /::/;
+ $subname = "CORE::GLOBAL::$s"
+ if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
+ $subname = "main".$subname if substr($subname,0,2) eq "::";
+ }
+ eval { break_subroutine($subname,$cond); 1 } or print $OUT $@ and return;
+ }
+
+ sub cmd_stop { # As on ^C, but not signal-safy.
+ $signal = 1;
+ }
+
+ sub delete_breakpoint {
+ my $i = shift;
+ die "Line $i not breakable.\n" if $dbline[$i] == 0;
+ $dbline{$i} =~ s/^[^\0]*//;
+ delete $dbline{$i} if $dbline{$i} eq '';
+ }
+
+ sub cmd_d {
+ my $i = shift;
+ eval { delete_breakpoint $i; 1 } or print $OUT $@ and return;
+ }
+
+ ### END of the API section
+
sub save {
@saved = ($@, $!, $^E, $,, $/, $\, $^W);
$, = ""; $/ = "\n"; $\ = ""; $^W = 0;
}
+ sub print_lineinfo {
+ resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
+ print $LINEINFO @_;
+ }
+
# The following takes its argument via $evalarg to preserve current @_
sub eval {
# 'my' would make it visible from user code
! # but so does local! --tchrist [... into @DB::res, not @res. IZ]
! local @res;
{
local $otrace = $trace;
local $osingle = $single;
***************
*** 1528,1537 ****
eval { &DB::save };
if ($at) {
print $OUT $at;
! } elsif ($onetimeDump eq 'dump') {
! dumpit($OUT, \@res);
! } elsif ($onetimeDump eq 'methods') {
! methods($res[0]);
}
@res;
}
--- 1737,1745 ----
eval { &DB::save };
if ($at) {
print $OUT $at;
! } elsif ($onetimeDump) {
! dumpit($OUT, \@res) if $onetimeDump eq 'dump';
! methods($res[0]) if $onetimeDump eq 'methods';
}
@res;
}
***************
*** 1572,1578 ****
$filename =~ s/^_<//;
$signal = 1, print $OUT "'$filename' loaded...\n"
if $break_on_load{$filename};
! print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
return unless $postponed_file{$filename};
$had_breakpoints{$filename} |= 1;
#%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
--- 1780,1786 ----
$filename =~ s/^_<//;
$signal = 1, print $OUT "'$filename' loaded...\n"
if $break_on_load{$filename};
! print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
return unless $postponed_file{$filename};
$had_breakpoints{$filename} |= 1;
#%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
***************
*** 1607,1612 ****
--- 1815,1821 ----
sub print_trace {
my $fh = shift;
+ resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
my @sub = dump_trace($_[0] + 1, $_[1]);
my $short = $_[2]; # Print short report, next one for sub name
my $s;
***************
*** 1746,1753 ****
eval { require Term::ReadLine } or die $@;
if ($notty) {
if ($tty) {
! open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
! open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
$IN = \*IN;
$OUT = \*OUT;
my $sel = select($OUT);
--- 1955,1964 ----
eval { require Term::ReadLine } or die $@;
if ($notty) {
if ($tty) {
! my ($i, $o) = split $tty, /,/;
! $o = $i unless defined $o;
! open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
! open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
$IN = \*IN;
$OUT = \*OUT;
my $sel = select($OUT);
***************
*** 1761,1766 ****
--- 1972,1980 ----
$OUT = $term_rv->OUT;
}
}
+ if ($term_pid eq '-1') { # In a TTY with another debugger
+ resetterm(2);
+ }
if (!$rl) {
$term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
} else {
***************
*** 1784,1817 ****
$term_pid = $$;
}
! sub resetterm { # We forked, so we need a different TTY
! $term_pid = $$;
! if (defined &get_fork_TTY) {
! &get_fork_TTY;
! } elsif (not defined $fork_TTY
! and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
! and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
! # Possibly _inside_ XTERM
! open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
sleep 10000000' |];
! $fork_TTY = <XT>;
! chomp $fork_TTY;
! }
! if (defined $fork_TTY) {
! TTY($fork_TTY);
! undef $fork_TTY;
! } else {
print_help(<<EOP);
! I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
! Define B<\$DB::fork_TTY>
! - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
! The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
EOP
}
}
sub readline {
local $.;
if (@typeahead) {
--- 1998,2098 ----
$term_pid = $$;
}
! # Example get_fork_TTY functions
! sub xterm_get_fork_TTY {
! (my $name = $0) =~ s,^.*[/\\],,s;
! open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
sleep 10000000' |];
! my $tty = <XT>;
! chomp $tty;
! $pidprompt = ''; # Shown anyway in titlebar
! return $tty;
! }
!
! # This one resets $IN, $OUT itself
! sub os2_get_fork_TTY {
! $^F = 40; # XXXX Fixme!
! my ($in1, $out1, $in2, $out2);
! # Having -d in PERL5OPT would lead to a disaster...
! local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
! $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
! $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
! print $OUT "Making PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
! (my $name = $0) =~ s,^.*[/\\],,s;
! if ( pipe $in1, $out1 and pipe $in2, $out2 and
! # system P_SESSION will fail if there is another process
! # in the same session with a "dependent" asynchronous child session.
! (($kpid = CORE::system 4, $^X, '-we', <<'ES', fileno $in1, fileno $out2, "Daughter Perl debugger $pids $name") >= 0 or warn "system P_SESSION: $!, $^E" and 0) # P_SESSION
! use Term::ReadKey;
! use OS2::Process;
!
! my $in = shift; # Read from here and pass through
! set_title pop;
! system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
! open IN, '<&=$in' or die "open <&=$in: \$!";
! \$| = 1; print while sysread IN, \$_, 1<<16;
! EOS
!
! my $out = shift;
! open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
! select OUT; $| = 1;
! ReadMode 4; # Nodelay on kbd. Pipe is automatically nodelay...
! print while sysread STDIN, $_, 1<<16;
! ES
! and close $in1 and close $out2 ) {
! $pidprompt = ''; # Shown anyway in titlebar
! reset_IN_OUT($in2, $out1);
! $tty = '*reset*';
! return ''; # Indicate that reset_IN_OUT is called
! }
! return;
! }
!
! sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
! my $in = &get_fork_TTY if defined &get_fork_TTY;
! $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
! if (not defined $in) {
! my $why = shift;
! print_help(<<EOP) if $why == 1;
! I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
! EOP
! print_help(<<EOP) if $why == 2;
! I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
! This may be an asynchronous session, so the parent debugger may be active.
! EOP
! print_help(<<EOP) if $why != 4;
! Since two debuggers fight for the same TTY, input is severely entangled.
!
! EOP
print_help(<<EOP);
! I know how to switch the output to a different window in xterms
! and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
! in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
!
On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
+
EOP
+ } elsif ($in ne '') {
+ TTY($in);
}
+ undef $fork_TTY;
}
+ sub resetterm { # We forked, so we need a different TTY
+ my $in = shift;
+ my $systemed = $in > 1 ? '-' : '';
+ if ($pids) {
+ $pids =~ s/\]/$systemed->$$]/;
+ } else {
+ $pids = "[$term_pid->$$]";
+ }
+ $pidprompt = $pids;
+ $term_pid = $$;
+ return unless $CreateTTY & $in;
+ create_IN_OUT($in);
+ }
+
sub readline {
local $.;
if (@typeahead) {
***************
*** 1859,1864 ****
--- 2140,2146 ----
} else {
$val = $option{$opt};
}
+ $val = $default unless defined $val;
$val
}
***************
*** 1867,1873 ****
# too dangerous to let intuitive usage overwrite important things
# defaultion should never be the default
my %opt_needs_val = map { ( $_ => 1 ) } qw{
! arrayDepth hashDepth LineInfo maxTraceLen ornaments
pager quote ReadLine recallCommand RemotePort ShellBang TTY
};
while (length) {
--- 2149,2155 ----
# too dangerous to let intuitive usage overwrite important things
# defaultion should never be the default
my %opt_needs_val = map { ( $_ => 1 ) } qw{
! arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
pager quote ReadLine recallCommand RemotePort ShellBang TTY
};
while (length) {
***************
*** 1975,1980 ****
--- 2257,2278 ----
print $OUT $msg;
}
+ sub reset_IN_OUT {
+ my $switch_li = $LINEINFO eq $OUT;
+ if ($term and $term->Features->{newTTY}) {
+ ($IN, $OUT) = (shift, shift);
+ $term->newTTY($IN, $OUT);
+ } elsif ($term) {
+ &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
+ } else {
+ ($IN, $OUT) = (shift, shift);
+ }
+ my $o = select $OUT;
+ $| = 1;
+ select $o;
+ $LINEINFO = $OUT if $switch_li;
+ }
+
sub TTY {
if (@_ and $term and $term->Features->{newTTY}) {
my ($in, $out) = shift;
***************
*** 1985,1997 ****
}
open IN, $in or die "cannot open `$in' for read: $!";
open OUT, ">$out" or die "cannot open `$out' for write: $!";
! $term->newTTY(\*IN, \*OUT);
! $IN = \*IN;
! $OUT = \*OUT;
return $tty = $in;
! } elsif ($term and @_) {
! &warn("Too late to set TTY, enabled on next `R'!\n");
! }
$tty = shift if @_;
$tty or $console;
}
--- 2283,2293 ----
}
open IN, $in or die "cannot open `$in' for read: $!";
open OUT, ">$out" or die "cannot open `$out' for write: $!";
! reset_IN_OUT(\*IN,\*OUT);
return $tty = $in;
! }
! &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
! # Useful if done through PERLDB_OPTS:
$tty = shift if @_;
$tty or $console;
}
***************
*** 2053,2059 ****
$psh = $sh;
$psh =~ s/\\b$//;
$psh =~ s/\\(.)/$1/g;
- &sethelp;
$psh;
}
--- 2349,2354 ----
***************
*** 2075,2081 ****
$prc = $rc;
$prc =~ s/\\b$//;
$prc =~ s/\\(.)/$1/g;
- &sethelp;
$prc;
}
--- 2370,2375 ----
***************
*** 2110,2116 ****
}
sub sethelp {
! # XXX: make sure these are tabs between the command and explantion,
# or print_help will screw up your formatting if you have
# eeevil ornaments enabled. This is an insane mess.
--- 2404,2410 ----
}
sub sethelp {
! # XXX: make sure there are tabs between the command and explanation,
# or print_help will screw up your formatting if you have
# eeevil ornaments enabled. This is an insane mess.
***************
*** 2184,2190 ****
B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
B<{> I<db_command> Define debugger command to run before each prompt.
B<{> ? List debugger commands to run before each prompt.
- B<<> I<expr> Define Perl command to run before each prompt.
B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
B<$prc> I<number> Redo a previous command (default previous command).
B<$prc> I<-number> Redo number'th-to-last command.
--- 2478,2483 ----
***************
*** 2203,2209 ****
B<v> Show versions of loaded modules.
B<R> Pure-man-restart of debugger, some of debugger state
and command-line options may be lost.
! Currently the following setting are preserved:
history, breakpoints and actions, debugger B<O>ptions
and the following command-line options: I<-w>, I<-I>, I<-e>.
--- 2496,2502 ----
B<v> Show versions of loaded modules.
B<R> Pure-man-restart of debugger, some of debugger state
and command-line options may be lost.
! Currently the following settings are preserved:
history, breakpoints and actions, debugger B<O>ptions
and the following command-line options: I<-w>, I<-I>, I<-e>.
***************
*** 2229,2238 ****
I<bareStringify> Do not print the overload-stringified value;
Other options include:
I<PrintRet> affects printing of return value after B<r> command,
! I<frame> affects printing messages on entry and exit from subroutines.
! I<AutoTrace> affects printing messages on every possible breaking point.
! I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
I<ornaments> affects screen appearance of the command line.
During startup options are initialized from \$ENV{PERLDB_OPTS}.
You can put additional initialization options I<TTY>, I<noTTY>,
I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
--- 2522,2534 ----
I<bareStringify> Do not print the overload-stringified value;
Other options include:
I<PrintRet> affects printing of return value after B<r> command,
! I<frame> affects printing messages on subroutine entry/exit.
! I<AutoTrace> affects printing messages on possible breaking points.
! I<maxTraceLen> gives max length of evals/args listed in stack trace.
I<ornaments> affects screen appearance of the command line.
+ I<CreateTTY> bits control attempts to create a new TTY on events:
+ 1: on fork() 2: debugger is started inside debugger
+ 4: on startup
During startup options are initialized from \$ENV{PERLDB_OPTS}.
You can put additional initialization options I<TTY>, I<noTTY>,
I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
***************
*** 2247,2254 ****
Type `|h' for a paged display if this was too hard to read.
! "; # Fix balance of vi % matching: } }}
$summary = <<"END_SUM";
I<List/search source lines:> I<Control script execution:>
B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
--- 2543,2551 ----
Type `|h' for a paged display if this was too hard to read.
! "; # Fix balance of vi % matching: }}}}
+ # note: tabs in the following section are not-so-helpful
$summary = <<"END_SUM";
I<List/search source lines:> I<Control script execution:>
B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
***************
*** 2256,2262 ****
B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
! B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
I<Debugger controls:> B<L> List break/watch/actions
B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
--- 2553,2559 ----
B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
! B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
I<Debugger controls:> B<L> List break/watch/actions
B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
***************
*** 2265,2277 ****
B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
! B<q> or B<^D> Quit B<R> Attempt a restart
! I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
! B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
! B<p> I<expr> Print expression (uses script's current package).
! B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
! B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
! B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
END_SUM
# ')}}; # Fix balance of vi % matching
--- 2562,2574 ----
B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
! B<q> or B<^D> Quit B<R> Attempt a restart
! I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
! B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
! B<p> I<expr> Print expression (uses script's current package).
! B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
! B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
! B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
END_SUM
# ')}}; # Fix balance of vi % matching
***************
*** 2284,2291 ****
# ornaments: A pox on both their houses!
#
# A help command will have everything up to and including
! # the first tab sequence paddeed into a field 16 (or if indented 20)
! # wide. If it's wide than that, an extra space will be added.
s{
^ # only matters at start of line
( \040{4} | \t )* # some subcommands are indented
--- 2581,2588 ----
# ornaments: A pox on both their houses!
#
# A help command will have everything up to and including
! # the first tab sequence padded into a field 16 (or if indented 20)
! # wide. If it's wider than that, an extra space will be added.
s{
^ # only matters at start of line
( \040{4} | \t )* # some subcommands are indented
***************
*** 2299,2307 ****
my $clean = $command;
$clean =~ s/[BI]<([^>]*)>/$1/g;
# replace with this whole string:
! (length($leadwhite) ? " " x 4 : "")
. $command
! . ((" " x (16 + (length($leadwhite) ? 4 : 0) - length($clean))) || " ")
. $text;
}mgex;
--- 2596,2604 ----
my $clean = $command;
$clean =~ s/[BI]<([^>]*)>/$1/g;
# replace with this whole string:
! ($leadwhite ? " " x 4 : "")
. $command
! . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
. $text;
}mgex;
***************
*** 2362,2368 ****
local $SIG{__DIE__} = '';
eval { require Carp } if defined $^S; # If error/warning during compilation,
# require may be broken.
! warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
return unless defined &Carp::longmess;
my ($mysingle,$mytrace) = ($single,$trace);
$single = 0; $trace = 0;
--- 2659,2665 ----
local $SIG{__DIE__} = '';
eval { require Carp } if defined $^S; # If error/warning during compilation,
# require may be broken.
! CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
return unless defined &Carp::longmess;
my ($mysingle,$mytrace) = ($single,$trace);
$single = 0; $trace = 0;
***************
*** 2385,2391 ****
if ($dieLevel < 2) {
die @_ if $^S; # in eval propagate
}
! eval { require Carp } if defined $^S; # If error/warning during compilation,
# require may be broken.
die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
--- 2682,2689 ----
if ($dieLevel < 2) {
die @_ if $^S; # in eval propagate
}
! # No need to check $^S, eval is much more robust nowadays
! eval { require Carp }; #if defined $^S;# If error/warning during compilation,
# require may be broken.
die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
***************
*** 2395,2401 ****
# inside DB::DB, but not in Carp).
my ($mysingle,$mytrace) = ($single,$trace);
$single = 0; $trace = 0;
! my $mess = Carp::longmess(@_);
($single,$trace) = ($mysingle,$mytrace);
die $mess;
}
--- 2693,2705 ----
# inside DB::DB, but not in Carp).
my ($mysingle,$mytrace) = ($single,$trace);
$single = 0; $trace = 0;
! my $mess = "@_";
! {
! package Carp; # Do not include us in the list
! eval {
! $mess = Carp::longmess(@_);
! };
! }
($single,$trace) = ($mysingle,$mytrace);
die $mess;
}
***************
*** 2406,2412 ****
$warnLevel = shift;
if ($warnLevel) {
$SIG{__WARN__} = \&DB::dbwarn;
! } else {
$SIG{__WARN__} = $prevwarn;
}
}
--- 2710,2716 ----
$warnLevel = shift;
if ($warnLevel) {
$SIG{__WARN__} = \&DB::dbwarn;
! } elsif ($prevwarn) {
$SIG{__WARN__} = $prevwarn;
}
}
***************
*** 2424,2430 ****
( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
if $I_m_init;
print $OUT "Dump printed too.\n" if $dieLevel > 2;
! } else {
$SIG{__DIE__} = $prevdie;
print $OUT "Default die handler restored.\n";
}
--- 2728,2734 ----
( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
if $I_m_init;
print $OUT "Dump printed too.\n" if $dieLevel > 2;
! } elsif ($prevdie) {
$SIG{__DIE__} = $prevdie;
print $OUT "Default die handler restored.\n";
}
***************
*** 2457,2462 ****
--- 2761,2767 ----
sub CvGV_name_or_bust {
my $in = shift;
return if $skipCvGV; # Backdoor to avoid problems if XS broken...
+ return unless ref $in;
$in = \&$in; # Hard reference...
eval {require Devel::Peek; 1} or return;
my $gv = Devel::Peek::CvGV($in) or return;
***************
*** 2510,2516 ****
}
sub setman {
! $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS)\z/s
? "man" # O Happy Day!
: "perldoc"; # Alas, poor unfortunates
}
--- 2815,2821 ----
}
sub setman {
! $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
? "man" # O Happy Day!
: "perldoc"; # Alas, poor unfortunates
}
***************
*** 2542,2548 ****
my $oldpath = $ENV{MANPATH};
$ENV{MANPATH} = $manpath if $manpath;
my $nopathopt = $^O =~ /dunno what goes here/;
! if (system($doccmd,
# I just *know* there are men without -M
(($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
split ' ', $page) )
--- 2847,2853 ----
my $oldpath = $ENV{MANPATH};
$ENV{MANPATH} = $manpath if $manpath;
my $nopathopt = $^O =~ /dunno what goes here/;
! if (CORE::system($doccmd,
# I just *know* there are men without -M
(($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
split ' ', $page) )
***************
*** 2559,2565 ****
})
{
$page =~ s/^/perl/;
! system($doccmd,
(($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
$page);
}
--- 2864,2870 ----
})
{
$page =~ s/^/perl/;
! CORE::system($doccmd,
(($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
$page);
}
***************
*** 2603,2609 ****
BEGIN {$^W = $ini_warn;} # Switch warnings back
! #use Carp; # This did break, left for debuggin
sub db_complete {
# Specific code for b c l V m f O, &blah, $blah, @blah, %blah
--- 2908,2914 ----
BEGIN {$^W = $ini_warn;} # Switch warnings back
! #use Carp; # This did break, left for debugging
sub db_complete {
# Specific code for b c l V m f O, &blah, $blah, @blah, %blah
diff -c /dev/null 'perl-5.7.2/lib/ph.t'
Index: ./lib/ph.t
*** ./lib/ph.t Thu Jan 1 02:00:00 1970
--- ./lib/ph.t Mon Jul 9 17:10:49 2001
***************
*** 0 ****
--- 1,96 ----
+ #!./perl
+
+ # Check for presence and correctness of .ph files; for now,
+ # just socket.ph and pals.
+ # -- Kurt Starsinic <kstar@isinet.com>
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # All the constants which Socket.pm tries to make available:
+ my @possibly_defined = qw(
+ INADDR_ANY INADDR_LOOPBACK INADDR_NONE AF_802 AF_APPLETALK AF_CCITT
+ AF_CHAOS AF_DATAKIT AF_DECnet AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK
+ AF_INET AF_LAT AF_MAX AF_NBS AF_NIT AF_NS AF_OSI AF_OSINET AF_PUP
+ AF_SNA AF_UNIX AF_UNSPEC AF_X25 MSG_DONTROUTE MSG_MAXIOVLEN MSG_OOB
+ MSG_PEEK PF_802 PF_APPLETALK PF_CCITT PF_CHAOS PF_DATAKIT PF_DECnet PF_DLI
+ PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_LAT PF_MAX PF_NBS PF_NIT
+ PF_NS PF_OSI PF_OSINET PF_PUP PF_SNA PF_UNIX PF_UNSPEC PF_X25 SOCK_DGRAM
+ SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM SOL_SOCKET SOMAXCONN
+ SO_ACCEPTCONN SO_BROADCAST SO_DEBUG SO_DONTLINGER SO_DONTROUTE SO_ERROR
+ SO_KEEPALIVE SO_LINGER SO_OOBINLINE SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO
+ SO_REUSEADDR SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO SO_TYPE SO_USELOOPBACK
+ );
+
+
+ # The libraries which I'm going to require:
+ my @libs = qw(Socket "sys/types.ph" "sys/socket.ph" "netinet/in.ph");
+
+
+ # These are defined by Socket.pm even if the C header files don't define them:
+ my %ok_to_miss = (
+ INADDR_NONE => 1,
+ INADDR_LOOPBACK => 1,
+ );
+
+
+ my $total_tests = scalar @libs + scalar @possibly_defined;
+ my $i = 0;
+
+ print "1..$total_tests\n";
+
+
+ foreach (@libs) {
+ $i++;
+
+ if (eval "require $_" ) {
+ print "ok $i\n";
+ } else {
+ print "# Skipping tests; $_ may be missing\n";
+ foreach ($i .. $total_tests) { print "ok $_\n" }
+ exit;
+ }
+ }
+
+
+ foreach (@possibly_defined) {
+ $i++;
+
+ $pm_val = eval "Socket::$_()";
+ $ph_val = eval "main::$_()";
+
+ if (defined $pm_val and !defined $ph_val) {
+ if ($ok_to_miss{$_}) { print "ok $i\n" }
+ else { print "not ok $i\n" }
+ next;
+ } elsif (defined $ph_val and !defined $pm_val) {
+ print "not ok $i\n";
+ next;
+ }
+
+ # Socket.pm converts these to network byte order, so we convert the
+ # socket.ph version to match; note that these cases skip the following
+ # `elsif', which is only applied to _numeric_ values, not literal
+ # bitmasks.
+ if ($_ eq 'INADDR_ANY'
+ or $_ eq 'INADDR_LOOPBACK'
+ or $_ eq 'INADDR_NONE') {
+ $ph_val = pack("N*", $ph_val); # htonl(3) equivalent
+ }
+
+ # Since Socket.pm and socket.ph wave their hands over macros differently,
+ # they could return functionally equivalent bitmaps with different numeric
+ # interpretations (due to sign extension). The only apparent case of this
+ # is SO_DONTLINGER (only on Solaris, and deprecated, at that):
+ elsif ($pm_val != $ph_val) {
+ $pm_val = oct(sprintf "0x%lx", $pm_val);
+ $ph_val = oct(sprintf "0x%lx", $ph_val);
+ }
+
+ if ($pm_val == $ph_val) { print "ok $i\n" }
+ else { print "not ok $i\n" }
+ }
+
+
diff -c 'perl-5.7.1/lib/strict.pm' 'perl-5.7.2/lib/strict.pm'
Index: ./lib/strict.pm
*** ./lib/strict.pm Tue Mar 6 04:05:46 2001
--- ./lib/strict.pm Mon Jul 9 17:10:50 2001
***************
*** 90,96 ****
=cut
! $strict::VERSION = "1.01";
my %bitmask = (
refs => 0x00000002,
--- 90,96 ----
=cut
! $strict::VERSION = "1.02";
my %bitmask = (
refs => 0x00000002,
diff -c /dev/null 'perl-5.7.2/lib/strict.t'
Index: ./lib/strict.t
*** ./lib/strict.t Thu Jan 1 02:00:00 1970
--- ./lib/strict.t Mon Jul 9 17:10:50 2001
***************
*** 0 ****
--- 1,100 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ $ENV{PERL5LIB} = '../lib';
+ }
+
+ $| = 1;
+
+ my $Is_VMS = $^O eq 'VMS';
+ my $Is_MSWin32 = $^O eq 'MSWin32';
+ my $Is_NetWare = $^O eq 'NetWare';
+ my $tmpfile = "tmp0000";
+ my $i = 0 ;
+ 1 while -f ++$tmpfile;
+ END { if ($tmpfile) { 1 while unlink $tmpfile; } }
+
+ my @prgs = () ;
+
+ foreach (sort glob($^O eq 'MacOS' ? ":lib::strict:*" : "lib/strict/*")) {
+
+ next if /(~|\.orig|,v)$/;
+
+ open F, "<$_" or die "Cannot open $_: $!\n" ;
+ while (<F>) {
+ last if /^__END__/ ;
+ }
+
+ {
+ local $/ = undef;
+ @prgs = (@prgs, split "\n########\n", <F>) ;
+ }
+ close F ;
+ }
+
+ undef $/;
+
+ print "1..", scalar @prgs, "\n";
+
+
+ for (@prgs){
+ my $switch = "";
+ my @temps = () ;
+ if (s/^\s*-\w+//){
+ $switch = $&;
+ }
+ my($prog,$expected) = split(/\nEXPECT\n/, $_);
+ if ( $prog =~ /--FILE--/) {
+ my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
+ shift @files ;
+ die "Internal error test $i didn't split into pairs, got " .
+ scalar(@files) . "[" . join("%%%%", @files) ."]\n"
+ if @files % 2 ;
+ while (@files > 2) {
+ my $filename = shift @files ;
+ my $code = shift @files ;
+ $code =~ s|\./abc|:abc|g if $^O eq 'MacOS';
+ push @temps, $filename ;
+ open F, ">$filename" or die "Cannot open $filename: $!\n" ;
+ print F $code ;
+ close F ;
+ }
+ shift @files ;
+ $prog = shift @files ;
+ $prog =~ s|\./abc|:abc|g if $^O eq 'MacOS';
+ }
+ open TEST, ">$tmpfile";
+ print TEST $prog,"\n";
+ close TEST;
+ my $results = $Is_MSWin32 ?
+ `.\\perl -I../lib $switch $tmpfile 2>&1` :
+ $^O eq 'MacOS' ?
+ `$^X -I::lib $switch $tmpfile` :
+ $^O eq 'NetWare' ?
+ `perl -I../lib $switch $tmpfile 2>&1` :
+ `./perl $switch $tmpfile 2>&1`;
+ my $status = $?;
+ $results =~ s/\n+$//;
+ # allow expected output to be written as if $prog is on STDIN
+ $results =~ s/tmp\d+/-/g;
+ $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg
+ $expected =~ s/\n+$//;
+ $expected =~ s|(\./)?abc\.pm|:abc.pm|g if $^O eq 'MacOS';
+ $expected =~ s|./abc|:abc|g if $^O eq 'MacOS';
+ my $prefix = ($results =~ s/^PREFIX\n//) ;
+ if ( $results =~ s/^SKIPPED\n//) {
+ print "$results\n" ;
+ }
+ elsif (($prefix and $results !~ /^\Q$expected/) or
+ (!$prefix and $results ne $expected)){
+ print STDERR "PROG: $switch\n$prog\n";
+ print STDERR "EXPECTED:\n$expected\n";
+ print STDERR "GOT:\n$results\n";
+ print "not ";
+ }
+ print "ok ", ++$i, "\n";
+ foreach (@temps)
+ { unlink $_ if $_ }
+ }
diff -c /dev/null 'perl-5.7.2/lib/subs.t'
Index: ./lib/subs.t
*** ./lib/subs.t Thu Jan 1 02:00:00 1970
--- ./lib/subs.t Mon Jul 9 17:10:50 2001
***************
*** 0 ****
--- 1,162 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ $ENV{PERL5LIB} = '../lib';
+ }
+
+ $| = 1;
+ undef $/;
+ my @prgs = split "\n########\n", <DATA>;
+ print "1..", scalar @prgs, "\n";
+
+ my $Is_VMS = $^O eq 'VMS';
+ my $Is_MSWin32 = $^O eq 'MSWin32';
+ my $Is_NetWare = $^O eq 'NetWare';
+ my $tmpfile = "tmp0000";
+ my $i = 0 ;
+ 1 while -f ++$tmpfile;
+ END { if ($tmpfile) { 1 while unlink $tmpfile} }
+
+ for (@prgs){
+ my $switch = "";
+ my @temps = () ;
+ if (s/^\s*-\w+//){
+ $switch = $&;
+ }
+ my($prog,$expected) = split(/\nEXPECT\n/, $_);
+ if ( $prog =~ /--FILE--/) {
+ my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
+ shift @files ;
+ die "Internal error test $i didn't split into pairs, got " .
+ scalar(@files) . "[" . join("%%%%", @files) ."]\n"
+ if @files % 2 ;
+ while (@files > 2) {
+ my $filename = shift @files ;
+ my $code = shift @files ;
+ push @temps, $filename ;
+ open F, ">$filename" or die "Cannot open $filename: $!\n" ;
+ print F $code ;
+ close F ;
+ }
+ shift @files ;
+ $prog = shift @files ;
+ }
+ open TEST, ">$tmpfile";
+ print TEST $prog,"\n";
+ close TEST;
+ my $results = $Is_VMS ?
+ `./perl $switch $tmpfile 2>&1` :
+ $Is_MSWin32 ?
+ `.\\perl -I../lib $switch $tmpfile 2>&1` :
+ $Is_NetWare ?
+ `perl -I../lib $switch $tmpfile 2>&1` :
+ `./perl $switch $tmpfile 2>&1`;
+ my $status = $?;
+ $results =~ s/\n+$//;
+ # allow expected output to be written as if $prog is on STDIN
+ $results =~ s/tmp\d+/-/g;
+ $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg
+ # bison says 'parse error' instead of 'syntax error',
+ # various yaccs may or may not capitalize 'syntax'.
+ $results =~ s/^(syntax|parse) error/syntax error/mig;
+ $expected =~ s/\n+$//;
+ my $prefix = ($results =~ s/^PREFIX\n//) ;
+ if ( $results =~ s/^SKIPPED\n//) {
+ print "$results\n" ;
+ }
+ elsif (($prefix and $results !~ /^\Q$expected/) or
+ (!$prefix and $results ne $expected)){
+ print STDERR "PROG: $switch\n$prog\n";
+ print STDERR "EXPECTED:\n$expected\n";
+ print STDERR "GOT:\n$results\n";
+ print "not ";
+ }
+ print "ok ", ++$i, "\n";
+ foreach (@temps)
+ { unlink $_ if $_ }
+ }
+
+ __END__
+
+ # Error - not predeclaring a sub
+ Fred 1,2 ;
+ sub Fred {}
+ EXPECT
+ Number found where operator expected at - line 3, near "Fred 1"
+ (Do you need to predeclare Fred?)
+ syntax error at - line 3, near "Fred 1"
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # Error - not predeclaring a sub in time
+ Fred 1,2 ;
+ use subs qw( Fred ) ;
+ sub Fred {}
+ EXPECT
+ Number found where operator expected at - line 3, near "Fred 1"
+ (Do you need to predeclare Fred?)
+ syntax error at - line 3, near "Fred 1"
+ BEGIN not safe after errors--compilation aborted at - line 4.
+ ########
+
+ # AOK
+ use subs qw( Fred) ;
+ Fred 1,2 ;
+ sub Fred { print $_[0] + $_[1], "\n" }
+ EXPECT
+ 3
+ ########
+
+ # override a built-in function
+ use subs qw( open ) ;
+ open 1,2 ;
+ sub open { print $_[0] + $_[1], "\n" }
+ EXPECT
+ 3
+ ########
+
+ # override a built-in function, call after definition
+ use subs qw( open ) ;
+ sub open { print $_[0] + $_[1], "\n" }
+ open 1,2 ;
+ EXPECT
+ 3
+ ########
+
+ # override a built-in function, call with ()
+ use subs qw( open ) ;
+ open (1,2) ;
+ sub open { print $_[0] + $_[1], "\n" }
+ EXPECT
+ 3
+ ########
+
+ # override a built-in function, call with () after definition
+ use subs qw( open ) ;
+ sub open { print $_[0] + $_[1], "\n" }
+ open (1,2) ;
+ EXPECT
+ 3
+ ########
+
+ --FILE-- abc
+ Fred 1,2 ;
+ 1;
+ --FILE--
+ use subs qw( Fred ) ;
+ require "./abc" ;
+ sub Fred { print $_[0] + $_[1], "\n" }
+ EXPECT
+ 3
+ ########
+
+ # check that it isn't affected by block scope
+ {
+ use subs qw( Fred ) ;
+ }
+ Fred 1, 2;
+ sub Fred { print $_[0] + $_[1], "\n" }
+ EXPECT
+ 3
diff -c /dev/null 'perl-5.7.2/lib/unicode/Blocks.pl'
Index: ./lib/unicode/Blocks.pl
*** ./lib/unicode/Blocks.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/Blocks.pl Mon Jul 9 17:10:50 2001
***************
*** 0 ****
--- 1,104 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0000 007F Basic Latin # BasicLatin In/40.pl
+ 0080 00FF Latin-1 Supplement # Latin1Supplement In/41.pl
+ 0100 017F Latin Extended-A # LatinExtendedA In/42.pl
+ 0180 024F Latin Extended-B # LatinExtendedB In/43.pl
+ 0250 02AF IPA Extensions # IPAExtensions In/44.pl
+ 02B0 02FF Spacing Modifier Letters # SpacingModifierLetters In/45.pl
+ 0300 036F Combining Diacritical Marks # CombiningDiacriticalMarks In/46.pl
+ 0370 03FF Greek # GreekBlock In/47.pl
+ 0400 04FF Cyrillic # CyrillicBlock In/48.pl
+ 0530 058F Armenian # ArmenianBlock In/49.pl
+ 0590 05FF Hebrew # HebrewBlock In/50.pl
+ 0600 06FF Arabic # ArabicBlock In/51.pl
+ 0700 074F Syriac # SyriacBlock In/52.pl
+ 0780 07BF Thaana # ThaanaBlock In/53.pl
+ 0900 097F Devanagari # DevanagariBlock In/54.pl
+ 0980 09FF Bengali # BengaliBlock In/55.pl
+ 0A00 0A7F Gurmukhi # GurmukhiBlock In/56.pl
+ 0A80 0AFF Gujarati # GujaratiBlock In/57.pl
+ 0B00 0B7F Oriya # OriyaBlock In/58.pl
+ 0B80 0BFF Tamil # TamilBlock In/59.pl
+ 0C00 0C7F Telugu # TeluguBlock In/60.pl
+ 0C80 0CFF Kannada # KannadaBlock In/61.pl
+ 0D00 0D7F Malayalam # MalayalamBlock In/62.pl
+ 0D80 0DFF Sinhala # SinhalaBlock In/63.pl
+ 0E00 0E7F Thai # ThaiBlock In/64.pl
+ 0E80 0EFF Lao # LaoBlock In/65.pl
+ 0F00 0FFF Tibetan # TibetanBlock In/66.pl
+ 1000 109F Myanmar # MyanmarBlock In/67.pl
+ 10A0 10FF Georgian # GeorgianBlock In/68.pl
+ 1100 11FF Hangul Jamo # HangulJamo In/69.pl
+ 1200 137F Ethiopic # EthiopicBlock In/70.pl
+ 13A0 13FF Cherokee # CherokeeBlock In/71.pl
+ 1400 167F Unified Canadian Aboriginal Syllabics # UnifiedCanadianAboriginalSyllabics In/72.pl
+ 1680 169F Ogham # OghamBlock In/73.pl
+ 16A0 16FF Runic # RunicBlock In/74.pl
+ 1780 17FF Khmer # KhmerBlock In/75.pl
+ 1800 18AF Mongolian # MongolianBlock In/76.pl
+ 1E00 1EFF Latin Extended Additional # LatinExtendedAdditional In/77.pl
+ 1F00 1FFF Greek Extended # GreekExtended In/78.pl
+ 2000 206F General Punctuation # GeneralPunctuation In/79.pl
+ 2070 209F Superscripts and Subscripts # SuperscriptsandSubscripts In/80.pl
+ 20A0 20CF Currency Symbols # CurrencySymbols In/81.pl
+ 20D0 20FF Combining Marks for Symbols # CombiningMarksforSymbols In/82.pl
+ 2100 214F Letterlike Symbols # LetterlikeSymbols In/83.pl
+ 2150 218F Number Forms # NumberForms In/84.pl
+ 2190 21FF Arrows # Arrows In/85.pl
+ 2200 22FF Mathematical Operators # MathematicalOperators In/86.pl
+ 2300 23FF Miscellaneous Technical # MiscellaneousTechnical In/87.pl
+ 2400 243F Control Pictures # ControlPictures In/88.pl
+ 2440 245F Optical Character Recognition # OpticalCharacterRecognition In/89.pl
+ 2460 24FF Enclosed Alphanumerics # EnclosedAlphanumerics In/90.pl
+ 2500 257F Box Drawing # BoxDrawing In/91.pl
+ 2580 259F Block Elements # BlockElements In/92.pl
+ 25A0 25FF Geometric Shapes # GeometricShapes In/93.pl
+ 2600 26FF Miscellaneous Symbols # MiscellaneousSymbols In/94.pl
+ 2700 27BF Dingbats # Dingbats In/95.pl
+ 2800 28FF Braille Patterns # BraillePatterns In/96.pl
+ 2E80 2EFF CJK Radicals Supplement # CJKRadicalsSupplement In/97.pl
+ 2F00 2FDF Kangxi Radicals # KangxiRadicals In/98.pl
+ 2FF0 2FFF Ideographic Description Characters # IdeographicDescriptionCharacters In/99.pl
+ 3000 303F CJK Symbols and Punctuation # CJKSymbolsandPunctuation In/100.pl
+ 3040 309F Hiragana # HiraganaBlock In/101.pl
+ 30A0 30FF Katakana # KatakanaBlock In/102.pl
+ 3100 312F Bopomofo # BopomofoBlock In/103.pl
+ 3130 318F Hangul Compatibility Jamo # HangulCompatibilityJamo In/104.pl
+ 3190 319F Kanbun # Kanbun In/105.pl
+ 31A0 31BF Bopomofo Extended # BopomofoExtended In/106.pl
+ 3200 32FF Enclosed CJK Letters and Months # EnclosedCJKLettersandMonths In/107.pl
+ 3300 33FF CJK Compatibility # CJKCompatibility In/108.pl
+ 3400 4DB5 CJK Unified Ideographs Extension A # CJKUnifiedIdeographsExtensionA In/109.pl
+ 4E00 9FFF CJK Unified Ideographs # CJKUnifiedIdeographs In/110.pl
+ A000 A48F Yi Syllables # YiSyllables In/111.pl
+ A490 A4CF Yi Radicals # YiRadicals In/112.pl
+ AC00 D7A3 Hangul Syllables # HangulSyllables In/113.pl
+ D800 DB7F High Surrogates # HighSurrogates In/114.pl
+ DB80 DBFF High Private Use Surrogates # HighPrivateUseSurrogates In/115.pl
+ DC00 DFFF Low Surrogates # LowSurrogates In/116.pl
+ E000 F8FF Private Use # PrivateUse In/117.pl
+ F900 FAFF CJK Compatibility Ideographs # CJKCompatibilityIdeographs In/118.pl
+ FB00 FB4F Alphabetic Presentation Forms # AlphabeticPresentationForms In/119.pl
+ FB50 FDFF Arabic Presentation Forms-A # ArabicPresentationFormsA In/120.pl
+ FE20 FE2F Combining Half Marks # CombiningHalfMarks In/121.pl
+ FE30 FE4F CJK Compatibility Forms # CJKCompatibilityForms In/122.pl
+ FE50 FE6F Small Form Variants # SmallFormVariants In/123.pl
+ FE70 FEFE Arabic Presentation Forms-B # ArabicPresentationFormsB In/124.pl
+ FEFF FEFF Specials # Specials In/125.pl
+ FF00 FFEF Halfwidth and Fullwidth Forms # HalfwidthandFullwidthForms In/126.pl
+ FFF0 FFFD Specials # Specials In/125.pl
+ 10300 1032F Old Italic # OldItalicBlock In/127.pl
+ 10330 1034F Gothic # GothicBlock In/128.pl
+ 10400 1044F Deseret # DeseretBlock In/129.pl
+ 1D000 1D0FF Byzantine Musical Symbols # ByzantineMusicalSymbols In/130.pl
+ 1D100 1D1FF Musical Symbols # MusicalSymbols In/131.pl
+ 1D400 1D7FF Mathematical Alphanumeric Symbols # MathematicalAlphanumericSymbols In/132.pl
+ 20000 2A6D6 CJK Unified Ideographs Extension B # CJKUnifiedIdeographsExtensionB In/133.pl
+ 2F800 2FA1F CJK Compatibility Ideographs Supplement # CJKCompatibilityIdeographsSupplement In/134.pl
+ E0000 E007F Tags # Tags In/135.pl
+ F0000 FFFFD Private Use # PrivateUse In/117.pl
+ 100000 10FFFD Private Use # PrivateUse In/117.pl
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In.pl'
Index: ./lib/unicode/In.pl
*** ./lib/unicode/In.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In.pl Mon Jul 9 17:10:51 2001
***************
*** 0 ****
--- 1,141 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ %utf8::In = (
+ 'Latin' => 0,
+ 'Greek' => 1,
+ 'Cyrillic' => 2,
+ 'Armenian' => 3,
+ 'Hebrew' => 4,
+ 'Arabic' => 5,
+ 'Syriac' => 6,
+ 'Thaana' => 7,
+ 'Devanagari' => 8,
+ 'Bengali' => 9,
+ 'Gurmukhi' => 10,
+ 'Gujarati' => 11,
+ 'Oriya' => 12,
+ 'Tamil' => 13,
+ 'Telugu' => 14,
+ 'Kannada' => 15,
+ 'Malayalam' => 16,
+ 'Sinhala' => 17,
+ 'Thai' => 18,
+ 'Lao' => 19,
+ 'Tibetan' => 20,
+ 'Myanmar' => 21,
+ 'Georgian' => 22,
+ 'Hangul' => 23,
+ 'Ethiopic' => 24,
+ 'Cherokee' => 25,
+ 'CanadianAboriginal' => 26,
+ 'Ogham' => 27,
+ 'Runic' => 28,
+ 'Khmer' => 29,
+ 'Mongolian' => 30,
+ 'Hiragana' => 31,
+ 'Katakana' => 32,
+ 'Bopomofo' => 33,
+ 'Han' => 34,
+ 'Yi' => 35,
+ 'OldItalic' => 36,
+ 'Gothic' => 37,
+ 'Deseret' => 38,
+ 'Inherited' => 39,
+ 'BasicLatin' => 40,
+ 'Latin1Supplement' => 41,
+ 'LatinExtendedA' => 42,
+ 'LatinExtendedB' => 43,
+ 'IPAExtensions' => 44,
+ 'SpacingModifierLetters' => 45,
+ 'CombiningDiacriticalMarks' => 46,
+ 'GreekBlock' => 47,
+ 'CyrillicBlock' => 48,
+ 'ArmenianBlock' => 49,
+ 'HebrewBlock' => 50,
+ 'ArabicBlock' => 51,
+ 'SyriacBlock' => 52,
+ 'ThaanaBlock' => 53,
+ 'DevanagariBlock' => 54,
+ 'BengaliBlock' => 55,
+ 'GurmukhiBlock' => 56,
+ 'GujaratiBlock' => 57,
+ 'OriyaBlock' => 58,
+ 'TamilBlock' => 59,
+ 'TeluguBlock' => 60,
+ 'KannadaBlock' => 61,
+ 'MalayalamBlock' => 62,
+ 'SinhalaBlock' => 63,
+ 'ThaiBlock' => 64,
+ 'LaoBlock' => 65,
+ 'TibetanBlock' => 66,
+ 'MyanmarBlock' => 67,
+ 'GeorgianBlock' => 68,
+ 'HangulJamo' => 69,
+ 'EthiopicBlock' => 70,
+ 'CherokeeBlock' => 71,
+ 'UnifiedCanadianAboriginalSyllabics' => 72,
+ 'OghamBlock' => 73,
+ 'RunicBlock' => 74,
+ 'KhmerBlock' => 75,
+ 'MongolianBlock' => 76,
+ 'LatinExtendedAdditional' => 77,
+ 'GreekExtended' => 78,
+ 'GeneralPunctuation' => 79,
+ 'SuperscriptsandSubscripts' => 80,
+ 'CurrencySymbols' => 81,
+ 'CombiningMarksforSymbols' => 82,
+ 'LetterlikeSymbols' => 83,
+ 'NumberForms' => 84,
+ 'Arrows' => 85,
+ 'MathematicalOperators' => 86,
+ 'MiscellaneousTechnical' => 87,
+ 'ControlPictures' => 88,
+ 'OpticalCharacterRecognition' => 89,
+ 'EnclosedAlphanumerics' => 90,
+ 'BoxDrawing' => 91,
+ 'BlockElements' => 92,
+ 'GeometricShapes' => 93,
+ 'MiscellaneousSymbols' => 94,
+ 'Dingbats' => 95,
+ 'BraillePatterns' => 96,
+ 'CJKRadicalsSupplement' => 97,
+ 'KangxiRadicals' => 98,
+ 'IdeographicDescriptionCharacters' => 99,
+ 'CJKSymbolsandPunctuation' => 100,
+ 'HiraganaBlock' => 101,
+ 'KatakanaBlock' => 102,
+ 'BopomofoBlock' => 103,
+ 'HangulCompatibilityJamo' => 104,
+ 'Kanbun' => 105,
+ 'BopomofoExtended' => 106,
+ 'EnclosedCJKLettersandMonths' => 107,
+ 'CJKCompatibility' => 108,
+ 'CJKUnifiedIdeographsExtensionA' => 109,
+ 'CJKUnifiedIdeographs' => 110,
+ 'YiSyllables' => 111,
+ 'YiRadicals' => 112,
+ 'HangulSyllables' => 113,
+ 'HighSurrogates' => 114,
+ 'HighPrivateUseSurrogates' => 115,
+ 'LowSurrogates' => 116,
+ 'PrivateUse' => 117,
+ 'CJKCompatibilityIdeographs' => 118,
+ 'AlphabeticPresentationForms' => 119,
+ 'ArabicPresentationFormsA' => 120,
+ 'CombiningHalfMarks' => 121,
+ 'CJKCompatibilityForms' => 122,
+ 'SmallFormVariants' => 123,
+ 'ArabicPresentationFormsB' => 124,
+ 'Specials' => 125,
+ 'HalfwidthandFullwidthForms' => 126,
+ 'OldItalicBlock' => 127,
+ 'GothicBlock' => 128,
+ 'DeseretBlock' => 129,
+ 'ByzantineMusicalSymbols' => 130,
+ 'MusicalSymbols' => 131,
+ 'MathematicalAlphanumericSymbols' => 132,
+ 'CJKUnifiedIdeographsExtensionB' => 133,
+ 'CJKCompatibilityIdeographsSupplement' => 134,
+ 'Tags' => 135,
+ );
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/0.pl'
Index: ./lib/unicode/In/0.pl
*** ./lib/unicode/In/0.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/0.pl Mon Jul 9 17:10:51 2001
***************
*** 0 ****
--- 1,27 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0041 005A
+ 0061 007A
+ 00AA
+ 00BA
+ 00C0 00D6
+ 00D8 00F6
+ 00F8 01BA
+ 01BB
+ 01BC 01BF
+ 01C0 01C3
+ 01C4 021F
+ 0222 0233
+ 0250 02AD
+ 02B0 02B8
+ 02E0 02E4
+ 1E00 1E9B
+ 1EA0 1EF9
+ 207F
+ 212A 212B
+ FB00 FB06
+ FF21 FF3A
+ FF41 FF5A
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/1.pl'
Index: ./lib/unicode/In/1.pl
*** ./lib/unicode/In/1.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/1.pl Mon Jul 9 17:10:51 2001
***************
*** 0 ****
--- 1,34 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 00B5
+ 037A
+ 0386
+ 0388 038A
+ 038C
+ 038E 03A1
+ 03A3 03CE
+ 03D0 03D7
+ 03DA 03F5
+ 1F00 1F15
+ 1F18 1F1D
+ 1F20 1F45
+ 1F48 1F4D
+ 1F50 1F57
+ 1F59
+ 1F5B
+ 1F5D
+ 1F5F 1F7D
+ 1F80 1FB4
+ 1FB6 1FBC
+ 1FBE
+ 1FC2 1FC4
+ 1FC6 1FCC
+ 1FD0 1FD3
+ 1FD6 1FDB
+ 1FE0 1FEC
+ 1FF2 1FF4
+ 1FF6 1FFC
+ 2126
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/10.pl'
Index: ./lib/unicode/In/10.pl
*** ./lib/unicode/In/10.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/10.pl Mon Jul 9 17:10:51 2001
***************
*** 0 ****
--- 1,23 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0A02
+ 0A05 0A0A
+ 0A0F 0A10
+ 0A13 0A28
+ 0A2A 0A30
+ 0A32 0A33
+ 0A35 0A36
+ 0A38 0A39
+ 0A3C
+ 0A3E 0A40
+ 0A41 0A42
+ 0A47 0A48
+ 0A4B 0A4D
+ 0A59 0A5C
+ 0A5E
+ 0A66 0A6F
+ 0A70 0A71
+ 0A72 0A74
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/100.pl'
Index: ./lib/unicode/In/100.pl
*** ./lib/unicode/In/100.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/100.pl Mon Jul 9 17:10:51 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 3000 303F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/101.pl'
Index: ./lib/unicode/In/101.pl
*** ./lib/unicode/In/101.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/101.pl Mon Jul 9 17:10:51 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 3040 309F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/102.pl'
Index: ./lib/unicode/In/102.pl
*** ./lib/unicode/In/102.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/102.pl Mon Jul 9 17:10:51 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 30A0 30FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/103.pl'
Index: ./lib/unicode/In/103.pl
*** ./lib/unicode/In/103.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/103.pl Mon Jul 9 17:10:51 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 3100 312F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/104.pl'
Index: ./lib/unicode/In/104.pl
*** ./lib/unicode/In/104.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/104.pl Mon Jul 9 17:10:51 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 3130 318F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/105.pl'
Index: ./lib/unicode/In/105.pl
*** ./lib/unicode/In/105.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/105.pl Mon Jul 9 17:10:51 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 3190 319F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/106.pl'
Index: ./lib/unicode/In/106.pl
*** ./lib/unicode/In/106.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/106.pl Mon Jul 9 17:10:51 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 31A0 31BF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/107.pl'
Index: ./lib/unicode/In/107.pl
*** ./lib/unicode/In/107.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/107.pl Mon Jul 9 17:10:51 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 3200 32FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/108.pl'
Index: ./lib/unicode/In/108.pl
*** ./lib/unicode/In/108.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/108.pl Mon Jul 9 17:10:51 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 3300 33FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/109.pl'
Index: ./lib/unicode/In/109.pl
*** ./lib/unicode/In/109.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/109.pl Mon Jul 9 17:10:51 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 3400 4DB5
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/11.pl'
Index: ./lib/unicode/In/11.pl
*** ./lib/unicode/In/11.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/11.pl Mon Jul 9 17:10:51 2001
***************
*** 0 ****
--- 1,25 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0A81 0A82
+ 0A83
+ 0A85 0A8B
+ 0A8D
+ 0A8F 0A91
+ 0A93 0AA8
+ 0AAA 0AB0
+ 0AB2 0AB3
+ 0AB5 0AB9
+ 0ABC
+ 0ABD
+ 0ABE 0AC0
+ 0AC1 0AC5
+ 0AC7 0AC8
+ 0AC9
+ 0ACB 0ACC
+ 0ACD
+ 0AD0
+ 0AE0
+ 0AE6 0AEF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/110.pl'
Index: ./lib/unicode/In/110.pl
*** ./lib/unicode/In/110.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/110.pl Mon Jul 9 17:10:51 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 4E00 9FFF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/111.pl'
Index: ./lib/unicode/In/111.pl
*** ./lib/unicode/In/111.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/111.pl Mon Jul 9 17:10:51 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ A000 A48F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/112.pl'
Index: ./lib/unicode/In/112.pl
*** ./lib/unicode/In/112.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/112.pl Mon Jul 9 17:10:51 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ A490 A4CF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/113.pl'
Index: ./lib/unicode/In/113.pl
*** ./lib/unicode/In/113.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/113.pl Mon Jul 9 17:10:51 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ AC00 D7A3
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/114.pl'
Index: ./lib/unicode/In/114.pl
*** ./lib/unicode/In/114.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/114.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ D800 DB7F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/115.pl'
Index: ./lib/unicode/In/115.pl
*** ./lib/unicode/In/115.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/115.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ DB80 DBFF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/116.pl'
Index: ./lib/unicode/In/116.pl
*** ./lib/unicode/In/116.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/116.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ DC00 DFFF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/117.pl'
Index: ./lib/unicode/In/117.pl
*** ./lib/unicode/In/117.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/117.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 100000 10FFFD
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/118.pl'
Index: ./lib/unicode/In/118.pl
*** ./lib/unicode/In/118.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/118.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ F900 FAFF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/119.pl'
Index: ./lib/unicode/In/119.pl
*** ./lib/unicode/In/119.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/119.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ FB00 FB4F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/12.pl'
Index: ./lib/unicode/In/12.pl
*** ./lib/unicode/In/12.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/12.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,27 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0B01
+ 0B02 0B03
+ 0B05 0B0C
+ 0B0F 0B10
+ 0B13 0B28
+ 0B2A 0B30
+ 0B32 0B33
+ 0B36 0B39
+ 0B3C
+ 0B3D
+ 0B3E
+ 0B3F
+ 0B40
+ 0B41 0B43
+ 0B47 0B48
+ 0B4B 0B4C
+ 0B4D
+ 0B56
+ 0B57
+ 0B5C 0B5D
+ 0B5F 0B61
+ 0B66 0B6F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/120.pl'
Index: ./lib/unicode/In/120.pl
*** ./lib/unicode/In/120.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/120.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ FB50 FDFF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/121.pl'
Index: ./lib/unicode/In/121.pl
*** ./lib/unicode/In/121.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/121.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ FE20 FE2F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/122.pl'
Index: ./lib/unicode/In/122.pl
*** ./lib/unicode/In/122.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/122.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ FE30 FE4F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/123.pl'
Index: ./lib/unicode/In/123.pl
*** ./lib/unicode/In/123.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/123.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ FE50 FE6F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/124.pl'
Index: ./lib/unicode/In/124.pl
*** ./lib/unicode/In/124.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/124.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ FE70 FEFE
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/125.pl'
Index: ./lib/unicode/In/125.pl
*** ./lib/unicode/In/125.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/125.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ FFF0 FFFD
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/126.pl'
Index: ./lib/unicode/In/126.pl
*** ./lib/unicode/In/126.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/126.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ FF00 FFEF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/127.pl'
Index: ./lib/unicode/In/127.pl
*** ./lib/unicode/In/127.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/127.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 10300 1032F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/128.pl'
Index: ./lib/unicode/In/128.pl
*** ./lib/unicode/In/128.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/128.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 10330 1034F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/129.pl'
Index: ./lib/unicode/In/129.pl
*** ./lib/unicode/In/129.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/129.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 10400 1044F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/13.pl'
Index: ./lib/unicode/In/13.pl
*** ./lib/unicode/In/13.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/13.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,26 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0B82
+ 0B83
+ 0B85 0B8A
+ 0B8E 0B90
+ 0B92 0B95
+ 0B99 0B9A
+ 0B9C
+ 0B9E 0B9F
+ 0BA3 0BA4
+ 0BA8 0BAA
+ 0BAE 0BB5
+ 0BB7 0BB9
+ 0BBE 0BBF
+ 0BC0
+ 0BC1 0BC2
+ 0BC6 0BC8
+ 0BCA 0BCC
+ 0BCD
+ 0BD7
+ 0BE7 0BEF
+ 0BF0 0BF2
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/130.pl'
Index: ./lib/unicode/In/130.pl
*** ./lib/unicode/In/130.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/130.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 1D000 1D0FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/131.pl'
Index: ./lib/unicode/In/131.pl
*** ./lib/unicode/In/131.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/131.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 1D100 1D1FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/132.pl'
Index: ./lib/unicode/In/132.pl
*** ./lib/unicode/In/132.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/132.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 1D400 1D7FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/133.pl'
Index: ./lib/unicode/In/133.pl
*** ./lib/unicode/In/133.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/133.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 20000 2A6D6
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/134.pl'
Index: ./lib/unicode/In/134.pl
*** ./lib/unicode/In/134.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/134.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2F800 2FA1F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/135.pl'
Index: ./lib/unicode/In/135.pl
*** ./lib/unicode/In/135.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/135.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ E0000 E007F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/14.pl'
Index: ./lib/unicode/In/14.pl
*** ./lib/unicode/In/14.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/14.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,18 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0C01 0C03
+ 0C05 0C0C
+ 0C0E 0C10
+ 0C12 0C28
+ 0C2A 0C33
+ 0C35 0C39
+ 0C3E 0C40
+ 0C41 0C44
+ 0C46 0C48
+ 0C4A 0C4D
+ 0C55 0C56
+ 0C60 0C61
+ 0C66 0C6F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/15.pl'
Index: ./lib/unicode/In/15.pl
*** ./lib/unicode/In/15.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/15.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,22 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0C82 0C83
+ 0C85 0C8C
+ 0C8E 0C90
+ 0C92 0CA8
+ 0CAA 0CB3
+ 0CB5 0CB9
+ 0CBE
+ 0CBF
+ 0CC0 0CC4
+ 0CC6
+ 0CC7 0CC8
+ 0CCA 0CCB
+ 0CCC 0CCD
+ 0CD5 0CD6
+ 0CDE
+ 0CE0 0CE1
+ 0CE6 0CEF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/16.pl'
Index: ./lib/unicode/In/16.pl
*** ./lib/unicode/In/16.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/16.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,18 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0D02 0D03
+ 0D05 0D0C
+ 0D0E 0D10
+ 0D12 0D28
+ 0D2A 0D39
+ 0D3E 0D40
+ 0D41 0D43
+ 0D46 0D48
+ 0D4A 0D4C
+ 0D4D
+ 0D57
+ 0D60 0D61
+ 0D66 0D6F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/17.pl'
Index: ./lib/unicode/In/17.pl
*** ./lib/unicode/In/17.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/17.pl Mon Jul 9 17:10:52 2001
***************
*** 0 ****
--- 1,17 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0D82 0D83
+ 0D85 0D96
+ 0D9A 0DB1
+ 0DB3 0DBB
+ 0DBD
+ 0DC0 0DC6
+ 0DCA
+ 0DCF 0DD1
+ 0DD2 0DD4
+ 0DD6
+ 0DD8 0DDF
+ 0DF2 0DF3
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/18.pl'
Index: ./lib/unicode/In/18.pl
*** ./lib/unicode/In/18.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/18.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,13 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0E01 0E30
+ 0E31
+ 0E32 0E33
+ 0E34 0E3A
+ 0E40 0E45
+ 0E46
+ 0E47 0E4E
+ 0E50 0E59
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/19.pl'
Index: ./lib/unicode/In/19.pl
*** ./lib/unicode/In/19.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/19.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,27 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0E81 0E82
+ 0E84
+ 0E87 0E88
+ 0E8A
+ 0E8D
+ 0E94 0E97
+ 0E99 0E9F
+ 0EA1 0EA3
+ 0EA5
+ 0EA7
+ 0EAA 0EAB
+ 0EAD 0EB0
+ 0EB1
+ 0EB2 0EB3
+ 0EB4 0EB9
+ 0EBB 0EBC
+ 0EBD
+ 0EC0 0EC4
+ 0EC6
+ 0EC8 0ECD
+ 0ED0 0ED9
+ 0EDC 0EDD
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/2.pl'
Index: ./lib/unicode/In/2.pl
*** ./lib/unicode/In/2.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/2.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,12 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0400 0481
+ 0483 0486
+ 048C 04C4
+ 04C7 04C8
+ 04CB 04CC
+ 04D0 04F5
+ 04F8 04F9
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/20.pl'
Index: ./lib/unicode/In/20.pl
*** ./lib/unicode/In/20.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/20.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,22 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0F00
+ 0F18 0F19
+ 0F20 0F29
+ 0F2A 0F33
+ 0F35
+ 0F37
+ 0F39
+ 0F40 0F47
+ 0F49 0F6A
+ 0F71 0F7E
+ 0F7F
+ 0F80 0F84
+ 0F86 0F87
+ 0F88 0F8B
+ 0F90 0F97
+ 0F99 0FBC
+ 0FC6
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/21.pl'
Index: ./lib/unicode/In/21.pl
*** ./lib/unicode/In/21.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/21.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,19 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 1000 1021
+ 1023 1027
+ 1029 102A
+ 102C
+ 102D 1030
+ 1031
+ 1032
+ 1036 1037
+ 1038
+ 1039
+ 1040 1049
+ 1050 1055
+ 1056 1057
+ 1058 1059
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/22.pl'
Index: ./lib/unicode/In/22.pl
*** ./lib/unicode/In/22.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/22.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,7 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 10A0 10C5
+ 10D0 10F6
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/23.pl'
Index: ./lib/unicode/In/23.pl
*** ./lib/unicode/In/23.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/23.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,15 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 1100 1159
+ 115F 11A2
+ 11A8 11F9
+ 3131 318E
+ AC00 D7A3
+ FFA0 FFBE
+ FFC2 FFC7
+ FFCA FFCF
+ FFD2 FFD7
+ FFDA FFDC
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/24.pl'
Index: ./lib/unicode/In/24.pl
*** ./lib/unicode/In/24.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/24.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,32 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 1200 1206
+ 1208 1246
+ 1248
+ 124A 124D
+ 1250 1256
+ 1258
+ 125A 125D
+ 1260 1286
+ 1288
+ 128A 128D
+ 1290 12AE
+ 12B0
+ 12B2 12B5
+ 12B8 12BE
+ 12C0
+ 12C2 12C5
+ 12C8 12CE
+ 12D0 12D6
+ 12D8 12EE
+ 12F0 130E
+ 1310
+ 1312 1315
+ 1318 131E
+ 1320 1346
+ 1348 135A
+ 1369 1371
+ 1372 137C
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/25.pl'
Index: ./lib/unicode/In/25.pl
*** ./lib/unicode/In/25.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/25.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 13A0 13F4
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/26.pl'
Index: ./lib/unicode/In/26.pl
*** ./lib/unicode/In/26.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/26.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,7 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 1401 166C
+ 166F 1676
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/27.pl'
Index: ./lib/unicode/In/27.pl
*** ./lib/unicode/In/27.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/27.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 1681 169A
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/28.pl'
Index: ./lib/unicode/In/28.pl
*** ./lib/unicode/In/28.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/28.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,7 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 16A0 16EA
+ 16EE 16F0
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/29.pl'
Index: ./lib/unicode/In/29.pl
*** ./lib/unicode/In/29.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/29.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,13 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 1780 17B3
+ 17B4 17B6
+ 17B7 17BD
+ 17BE 17C5
+ 17C6
+ 17C7 17C8
+ 17C9 17D3
+ 17E0 17E9
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/3.pl'
Index: ./lib/unicode/In/3.pl
*** ./lib/unicode/In/3.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/3.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,9 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0531 0556
+ 0559
+ 0561 0587
+ FB13 FB17
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/30.pl'
Index: ./lib/unicode/In/30.pl
*** ./lib/unicode/In/30.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/30.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,11 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 1810 1819
+ 1820 1842
+ 1843
+ 1844 1877
+ 1880 18A8
+ 18A9
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/31.pl'
Index: ./lib/unicode/In/31.pl
*** ./lib/unicode/In/31.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/31.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,7 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 3041 3094
+ 309D 309E
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/32.pl'
Index: ./lib/unicode/In/32.pl
*** ./lib/unicode/In/32.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/32.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,9 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 30A1 30FA
+ 30FD 30FE
+ FF66 FF6F
+ FF71 FF9D
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/33.pl'
Index: ./lib/unicode/In/33.pl
*** ./lib/unicode/In/33.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/33.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,7 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 3105 312C
+ 31A0 31B7
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/34.pl'
Index: ./lib/unicode/In/34.pl
*** ./lib/unicode/In/34.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/34.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,17 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2E80 2E99
+ 2E9B 2EF3
+ 2F00 2FD5
+ 3005
+ 3007
+ 3021 3029
+ 3038 303A
+ 3400 4DB5
+ 4E00 9FA5
+ F900 FA2D
+ 20000 2A6D6
+ 2F800 2FA1D
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/35.pl'
Index: ./lib/unicode/In/35.pl
*** ./lib/unicode/In/35.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/35.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,11 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ A000 A48C
+ A490 A4A1
+ A4A4 A4B3
+ A4B5 A4C0
+ A4C2 A4C4
+ A4C6
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/36.pl'
Index: ./lib/unicode/In/36.pl
*** ./lib/unicode/In/36.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/36.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 10300 1031E
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/37.pl'
Index: ./lib/unicode/In/37.pl
*** ./lib/unicode/In/37.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/37.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,7 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 10330 10349
+ 1034A
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/38.pl'
Index: ./lib/unicode/In/38.pl
*** ./lib/unicode/In/38.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/38.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,7 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 10400 10425
+ 10428 1044D
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/39.pl'
Index: ./lib/unicode/In/39.pl
*** ./lib/unicode/In/39.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/39.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,33 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0300 034E
+ 0360 0362
+ 0488 0489
+ 0591 05A1
+ 05A3 05B9
+ 05BB 05BD
+ 05BF
+ 05C1 05C2
+ 05C4
+ 064B 0655
+ 0670
+ 06D6 06DC
+ 06DD 06DE
+ 06DF 06E4
+ 06E7 06E8
+ 06EA 06ED
+ 20D0 20DC
+ 20DD 20E0
+ 20E1
+ 20E2 20E3
+ 302A 302F
+ 3099 309A
+ FB1E
+ FE20 FE23
+ 1D167 1D169
+ 1D17B 1D182
+ 1D185 1D18B
+ 1D1AA 1D1AD
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/4.pl'
Index: ./lib/unicode/In/4.pl
*** ./lib/unicode/In/4.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/4.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,15 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 05D0 05EA
+ 05F0 05F2
+ FB1D
+ FB1F FB28
+ FB2A FB36
+ FB38 FB3C
+ FB3E
+ FB40 FB41
+ FB43 FB44
+ FB46 FB4F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/40.pl'
Index: ./lib/unicode/In/40.pl
*** ./lib/unicode/In/40.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/40.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0000 007F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/41.pl'
Index: ./lib/unicode/In/41.pl
*** ./lib/unicode/In/41.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/41.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0080 00FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/42.pl'
Index: ./lib/unicode/In/42.pl
*** ./lib/unicode/In/42.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/42.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0100 017F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/43.pl'
Index: ./lib/unicode/In/43.pl
*** ./lib/unicode/In/43.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/43.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0180 024F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/44.pl'
Index: ./lib/unicode/In/44.pl
*** ./lib/unicode/In/44.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/44.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0250 02AF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/45.pl'
Index: ./lib/unicode/In/45.pl
*** ./lib/unicode/In/45.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/45.pl Mon Jul 9 17:10:53 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 02B0 02FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/46.pl'
Index: ./lib/unicode/In/46.pl
*** ./lib/unicode/In/46.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/46.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0300 036F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/47.pl'
Index: ./lib/unicode/In/47.pl
*** ./lib/unicode/In/47.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/47.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0370 03FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/48.pl'
Index: ./lib/unicode/In/48.pl
*** ./lib/unicode/In/48.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/48.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0400 04FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/49.pl'
Index: ./lib/unicode/In/49.pl
*** ./lib/unicode/In/49.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/49.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0530 058F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/5.pl'
Index: ./lib/unicode/In/5.pl
*** ./lib/unicode/In/5.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/5.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,19 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0621 063A
+ 0641 064A
+ 0671 06D3
+ 06D5
+ 06E5 06E6
+ 06FA 06FC
+ FB50 FBB1
+ FBD3 FD3D
+ FD50 FD8F
+ FD92 FDC7
+ FDF0 FDFB
+ FE70 FE72
+ FE74
+ FE76 FEFC
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/50.pl'
Index: ./lib/unicode/In/50.pl
*** ./lib/unicode/In/50.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/50.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0590 05FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/51.pl'
Index: ./lib/unicode/In/51.pl
*** ./lib/unicode/In/51.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/51.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0600 06FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/52.pl'
Index: ./lib/unicode/In/52.pl
*** ./lib/unicode/In/52.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/52.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0700 074F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/53.pl'
Index: ./lib/unicode/In/53.pl
*** ./lib/unicode/In/53.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/53.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0780 07BF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/54.pl'
Index: ./lib/unicode/In/54.pl
*** ./lib/unicode/In/54.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/54.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0900 097F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/55.pl'
Index: ./lib/unicode/In/55.pl
*** ./lib/unicode/In/55.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/55.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0980 09FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/56.pl'
Index: ./lib/unicode/In/56.pl
*** ./lib/unicode/In/56.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/56.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0A00 0A7F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/57.pl'
Index: ./lib/unicode/In/57.pl
*** ./lib/unicode/In/57.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/57.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0A80 0AFF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/58.pl'
Index: ./lib/unicode/In/58.pl
*** ./lib/unicode/In/58.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/58.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0B00 0B7F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/59.pl'
Index: ./lib/unicode/In/59.pl
*** ./lib/unicode/In/59.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/59.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0B80 0BFF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/6.pl'
Index: ./lib/unicode/In/6.pl
*** ./lib/unicode/In/6.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/6.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,9 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0710
+ 0711
+ 0712 072C
+ 0730 074A
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/60.pl'
Index: ./lib/unicode/In/60.pl
*** ./lib/unicode/In/60.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/60.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0C00 0C7F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/61.pl'
Index: ./lib/unicode/In/61.pl
*** ./lib/unicode/In/61.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/61.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0C80 0CFF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/62.pl'
Index: ./lib/unicode/In/62.pl
*** ./lib/unicode/In/62.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/62.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0D00 0D7F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/63.pl'
Index: ./lib/unicode/In/63.pl
*** ./lib/unicode/In/63.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/63.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0D80 0DFF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/64.pl'
Index: ./lib/unicode/In/64.pl
*** ./lib/unicode/In/64.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/64.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0E00 0E7F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/65.pl'
Index: ./lib/unicode/In/65.pl
*** ./lib/unicode/In/65.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/65.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0E80 0EFF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/66.pl'
Index: ./lib/unicode/In/66.pl
*** ./lib/unicode/In/66.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/66.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0F00 0FFF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/67.pl'
Index: ./lib/unicode/In/67.pl
*** ./lib/unicode/In/67.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/67.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 1000 109F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/68.pl'
Index: ./lib/unicode/In/68.pl
*** ./lib/unicode/In/68.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/68.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 10A0 10FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/69.pl'
Index: ./lib/unicode/In/69.pl
*** ./lib/unicode/In/69.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/69.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 1100 11FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/7.pl'
Index: ./lib/unicode/In/7.pl
*** ./lib/unicode/In/7.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/7.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,7 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0780 07A5
+ 07A6 07B0
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/70.pl'
Index: ./lib/unicode/In/70.pl
*** ./lib/unicode/In/70.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/70.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 1200 137F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/71.pl'
Index: ./lib/unicode/In/71.pl
*** ./lib/unicode/In/71.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/71.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 13A0 13FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/72.pl'
Index: ./lib/unicode/In/72.pl
*** ./lib/unicode/In/72.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/72.pl Mon Jul 9 17:10:54 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 1400 167F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/73.pl'
Index: ./lib/unicode/In/73.pl
*** ./lib/unicode/In/73.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/73.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 1680 169F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/74.pl'
Index: ./lib/unicode/In/74.pl
*** ./lib/unicode/In/74.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/74.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 16A0 16FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/75.pl'
Index: ./lib/unicode/In/75.pl
*** ./lib/unicode/In/75.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/75.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 1780 17FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/76.pl'
Index: ./lib/unicode/In/76.pl
*** ./lib/unicode/In/76.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/76.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 1800 18AF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/77.pl'
Index: ./lib/unicode/In/77.pl
*** ./lib/unicode/In/77.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/77.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 1E00 1EFF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/78.pl'
Index: ./lib/unicode/In/78.pl
*** ./lib/unicode/In/78.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/78.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 1F00 1FFF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/79.pl'
Index: ./lib/unicode/In/79.pl
*** ./lib/unicode/In/79.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/79.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2000 206F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/8.pl'
Index: ./lib/unicode/In/8.pl
*** ./lib/unicode/In/8.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/8.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,19 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0901 0902
+ 0903
+ 0905 0939
+ 093C
+ 093D
+ 093E 0940
+ 0941 0948
+ 0949 094C
+ 094D
+ 0950
+ 0951 0954
+ 0958 0961
+ 0962 0963
+ 0966 096F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/80.pl'
Index: ./lib/unicode/In/80.pl
*** ./lib/unicode/In/80.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/80.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2070 209F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/81.pl'
Index: ./lib/unicode/In/81.pl
*** ./lib/unicode/In/81.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/81.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 20A0 20CF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/82.pl'
Index: ./lib/unicode/In/82.pl
*** ./lib/unicode/In/82.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/82.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 20D0 20FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/83.pl'
Index: ./lib/unicode/In/83.pl
*** ./lib/unicode/In/83.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/83.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2100 214F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/84.pl'
Index: ./lib/unicode/In/84.pl
*** ./lib/unicode/In/84.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/84.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2150 218F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/85.pl'
Index: ./lib/unicode/In/85.pl
*** ./lib/unicode/In/85.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/85.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2190 21FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/86.pl'
Index: ./lib/unicode/In/86.pl
*** ./lib/unicode/In/86.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/86.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2200 22FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/87.pl'
Index: ./lib/unicode/In/87.pl
*** ./lib/unicode/In/87.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/87.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2300 23FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/88.pl'
Index: ./lib/unicode/In/88.pl
*** ./lib/unicode/In/88.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/88.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2400 243F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/89.pl'
Index: ./lib/unicode/In/89.pl
*** ./lib/unicode/In/89.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/89.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2440 245F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/9.pl'
Index: ./lib/unicode/In/9.pl
*** ./lib/unicode/In/9.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/9.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,24 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0981
+ 0985 098C
+ 098F 0990
+ 0993 09A8
+ 09AA 09B0
+ 09B2
+ 09B6 09B9
+ 09BC
+ 09BE 09C0
+ 09C1 09C4
+ 09C7 09C8
+ 09CB 09CC
+ 09CD
+ 09D7
+ 09DC 09DD
+ 09DF 09E1
+ 09E2 09E3
+ 09E6 09EF
+ 09F0 09F1
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/90.pl'
Index: ./lib/unicode/In/90.pl
*** ./lib/unicode/In/90.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/90.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2460 24FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/91.pl'
Index: ./lib/unicode/In/91.pl
*** ./lib/unicode/In/91.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/91.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2500 257F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/92.pl'
Index: ./lib/unicode/In/92.pl
*** ./lib/unicode/In/92.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/92.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2580 259F
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/93.pl'
Index: ./lib/unicode/In/93.pl
*** ./lib/unicode/In/93.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/93.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 25A0 25FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/94.pl'
Index: ./lib/unicode/In/94.pl
*** ./lib/unicode/In/94.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/94.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2600 26FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/95.pl'
Index: ./lib/unicode/In/95.pl
*** ./lib/unicode/In/95.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/95.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2700 27BF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/96.pl'
Index: ./lib/unicode/In/96.pl
*** ./lib/unicode/In/96.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/96.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2800 28FF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/97.pl'
Index: ./lib/unicode/In/97.pl
*** ./lib/unicode/In/97.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/97.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2E80 2EFF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/98.pl'
Index: ./lib/unicode/In/98.pl
*** ./lib/unicode/In/98.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/98.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2F00 2FDF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/In/99.pl'
Index: ./lib/unicode/In/99.pl
*** ./lib/unicode/In/99.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/In/99.pl Mon Jul 9 17:10:55 2001
***************
*** 0 ****
--- 1,6 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 2FF0 2FFF
+ END
diff -c /dev/null 'perl-5.7.2/lib/unicode/Scripts.pl'
Index: ./lib/unicode/Scripts.pl
*** ./lib/unicode/Scripts.pl Thu Jan 1 02:00:00 1970
--- ./lib/unicode/Scripts.pl Mon Jul 9 17:11:02 2001
***************
*** 0 ****
--- 1,445 ----
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by mktables.PL from e.g. Unicode.txt.
+ # Any changes made here will be lost!
+ return <<'END';
+ 0041 005A LATIN # Latin In/0.pl
+ 0061 007A LATIN # Latin In/0.pl
+ 00AA LATIN # Latin In/0.pl
+ 00BA LATIN # Latin In/0.pl
+ 00C0 00D6 LATIN # Latin In/0.pl
+ 00D8 00F6 LATIN # Latin In/0.pl
+ 00F8 01BA LATIN # Latin In/0.pl
+ 01BB LATIN # Latin In/0.pl
+ 01BC 01BF LATIN # Latin In/0.pl
+ 01C0 01C3 LATIN # Latin In/0.pl
+ 01C4 021F LATIN # Latin In/0.pl
+ 0222 0233 LATIN # Latin In/0.pl
+ 0250 02AD LATIN # Latin In/0.pl
+ 02B0 02B8 LATIN # Latin In/0.pl
+ 02E0 02E4 LATIN # Latin In/0.pl
+ 1E00 1E9B LATIN # Latin In/0.pl
+ 1EA0 1EF9 LATIN # Latin In/0.pl
+ 207F LATIN # Latin In/0.pl
+ 212A 212B LATIN # Latin In/0.pl
+ FB00 FB06 LATIN # Latin In/0.pl
+ FF21 FF3A LATIN # Latin In/0.pl
+ FF41 FF5A LATIN # Latin In/0.pl
+ 00B5 GREEK # Greek In/1.pl
+ 037A GREEK # Greek In/1.pl
+ 0386 GREEK # Greek In/1.pl
+ 0388 038A GREEK # Greek In/1.pl
+ 038C GREEK # Greek In/1.pl
+ 038E 03A1 GREEK # Greek In/1.pl
+ 03A3 03CE GREEK # Greek In/1.pl
+ 03D0 03D7 GREEK # Greek In/1.pl
+ 03DA 03F5 GREEK # Greek In/1.pl
+ 1F00 1F15 GREEK # Greek In/1.pl
+ 1F18 1F1D GREEK # Greek In/1.pl
+ 1F20 1F45 GREEK # Greek In/1.pl
+ 1F48 1F4D GREEK # Greek In/1.pl
+ 1F50 1F57 GREEK # Greek In/1.pl
+ 1F59 GREEK # Greek In/1.pl
+ 1F5B GREEK # Greek In/1.pl
+ 1F5D GREEK # Greek In/1.pl
+ 1F5F 1F7D GREEK # Greek In/1.pl
+ 1F80 1FB4 GREEK # Greek In/1.pl
+ 1FB6 1FBC GREEK # Greek In/1.pl
+ 1FBE GREEK # Greek In/1.pl
+ 1FC2 1FC4 GREEK # Greek In/1.pl
+ 1FC6 1FCC GREEK # Greek In/1.pl
+ 1FD0 1FD3 GREEK # Greek In/1.pl
+ 1FD6 1FDB GREEK # Greek In/1.pl
+ 1FE0 1FEC GREEK # Greek In/1.pl
+ 1FF2 1FF4 GREEK # Greek In/1.pl
+ 1FF6 1FFC GREEK # Greek In/1.pl
+ 2126 GREEK # Greek In/1.pl
+ 0400 0481 CYRILLIC # Cyrillic In/2.pl
+ 0483 0486 CYRILLIC # Cyrillic In/2.pl
+ 048C 04C4 CYRILLIC # Cyrillic In/2.pl
+ 04C7 04C8 CYRILLIC # Cyrillic In/2.pl
+ 04CB 04CC CYRILLIC # Cyrillic In/2.pl
+ 04D0 04F5 CYRILLIC # Cyrillic In/2.pl
+ 04F8 04F9 CYRILLIC # Cyrillic In/2.pl
+ 0531 0556 ARMENIAN # Armenian In/3.pl
+ 0559 ARMENIAN # Armenian In/3.pl
+ 0561 0587 ARMENIAN # Armenian In/3.pl
+ FB13 FB17 ARMENIAN # Armenian In/3.pl
+ 05D0 05EA HEBREW # Hebrew In/4.pl
+ 05F0 05F2 HEBREW # Hebrew In/4.pl
+ FB1D HEBREW # Hebrew In/4.pl
+ FB1F FB28 HEBREW # Hebrew In/4.pl
+ FB2A FB36 HEBREW # Hebrew In/4.pl
+ FB38 FB3C HEBREW # Hebrew In/4.pl
+ FB3E HEBREW # Hebrew In/4.pl
+ FB40 FB41 HEBREW # Hebrew In/4.pl
+ FB43 FB44 HEBREW # Hebrew In/4.pl
+ FB46 FB4F HEBREW # Hebrew In/4.pl
+ 0621 063A ARABIC # Arabic In/5.pl
+ 0641 064A ARABIC # Arabic In/5.pl
+ 0671 06D3 ARABIC # Arabic In/5.pl
+ 06D5 ARABIC # Arabic In/5.pl
+ 06E5 06E6 ARABIC # Arabic In/5.pl
+ 06FA 06FC ARABIC # Arabic In/5.pl
+ FB50 FBB1 ARABIC # Arabic In/5.pl
+ FBD3 FD3D ARABIC # Arabic In/5.pl
+ FD50 FD8F ARABIC # Arabic In/5.pl
+ FD92 FDC7 ARABIC # Arabic In/5.pl
+ FDF0 FDFB ARABIC # Arabic In/5.pl
+ FE70 FE72 ARABIC # Arabic In/5.pl
+ FE74 ARABIC # Arabic In/5.pl
+ FE76 FEFC ARABIC # Arabic In/5.pl
+ 0710 SYRIAC # Syriac In/6.pl
+ 0711 SYRIAC # Syriac In/6.pl
+ 0712 072C SYRIAC # Syriac In/6.pl
+ 0730 074A SYRIAC # Syriac In/6.pl
+ 0780 07A5 THAANA # Thaana In/7.pl
+ 07A6 07B0 THAANA # Thaana In/7.pl
+ 0901 0902 DEVANAGARI # Devanagari In/8.pl
+ 0903 DEVANAGARI # Devanagari In/8.pl
+ 0905 0939 DEVANAGARI # Devanagari In/8.pl
+ 093C DEVANAGARI # Devanagari In/8.pl
+ 093D DEVANAGARI # Devanagari In/8.pl
+ 093E 0940 DEVANAGARI # Devanagari In/8.pl
+ 0941 0948 DEVANAGARI # Devanagari In/8.pl
+ 0949 094C DEVANAGARI # Devanagari In/8.pl
+ 094D DEVANAGARI # Devanagari In/8.pl
+ 0950 DEVANAGARI # Devanagari In/8.pl
+ 0951 0954 DEVANAGARI # Devanagari In/8.pl
+ 0958 0961 DEVANAGARI # Devanagari In/8.pl
+ 0962 0963 DEVANAGARI # Devanagari In/8.pl
+ 0966 096F DEVANAGARI # Devanagari In/8.pl
+ 0981 BENGALI # Bengali In/9.pl
+ 0985 098C BENGALI # Bengali In/9.pl
+ 098F 0990 BENGALI # Bengali In/9.pl
+ 0993 09A8 BENGALI # Bengali In/9.pl
+ 09AA 09B0 BENGALI # Bengali In/9.pl
+ 09B2 BENGALI # Bengali In/9.pl
+ 09B6 09B9 BENGALI # Bengali In/9.pl
+ 09BC BENGALI # Bengali In/9.pl
+ 09BE 09C0 BENGALI # Bengali In/9.pl
+ 09C1 09C4 BENGALI # Bengali In/9.pl
+ 09C7 09C8 BENGALI # Bengali In/9.pl
+ 09CB 09CC BENGALI # Bengali In/9.pl
+ 09CD BENGALI # Bengali In/9.pl
+ 09D7 BENGALI # Bengali In/9.pl
+ 09DC 09DD BENGALI # Bengali In/9.pl
+ 09DF 09E1 BENGALI # Bengali In/9.pl
+ 09E2 09E3 BENGALI # Bengali In/9.pl
+ 09E6 09EF BENGALI # Bengali In/9.pl
+ 09F0 09F1 BENGALI # Bengali In/9.pl
+ 0A02 GURMUKHI # Gurmukhi In/10.pl
+ 0A05 0A0A GURMUKHI # Gurmukhi In/10.pl
+ 0A0F 0A10 GURMUKHI # Gurmukhi In/10.pl
+ 0A13 0A28 GURMUKHI # Gurmukhi In/10.pl
+ 0A2A 0A30 GURMUKHI # Gurmukhi In/10.pl
+ 0A32 0A33 GURMUKHI # Gurmukhi In/10.pl
+ 0A35 0A36 GURMUKHI # Gurmukhi In/10.pl
+ 0A38 0A39 GURMUKHI # Gurmukhi In/10.pl
+ 0A3C GURMUKHI # Gurmukhi In/10.pl
+ 0A3E 0A40 GURMUKHI # Gurmukhi In/10.pl
+ 0A41 0A42 GURMUKHI # Gurmukhi In/10.pl
+ 0A47 0A48 GURMUKHI # Gurmukhi In/10.pl
+ 0A4B 0A4D GURMUKHI # Gurmukhi In/10.pl
+ 0A59 0A5C GURMUKHI # Gurmukhi In/10.pl
+ 0A5E GURMUKHI # Gurmukhi In/10.pl
+ 0A66 0A6F GURMUKHI # Gurmukhi In/10.pl
+ 0A70 0A71 GURMUKHI # Gurmukhi In/10.pl
+ 0A72 0A74 GURMUKHI # Gurmukhi In/10.pl
+ 0A81 0A82 GUJARATI # Gujarati In/11.pl
+ 0A83 GUJARATI # Gujarati In/11.pl
+ 0A85 0A8B GUJARATI # Gujarati In/11.pl
+ 0A8D GUJARATI # Gujarati In/11.pl
+ 0A8F 0A91 GUJARATI # Gujarati In/11.pl
+ 0A93 0AA8 GUJARATI # Gujarati In/11.pl
+ 0AAA 0AB0 GUJARATI # Gujarati In/11.pl
+ 0AB2 0AB3 GUJARATI # Gujarati In/11.pl
+ 0AB5 0AB9 GUJARATI # Gujarati In/11.pl
+ 0ABC GUJARATI # Gujarati In/11.pl
+ 0ABD GUJARATI # Gujarati In/11.pl
+ 0ABE 0AC0 GUJARATI # Gujarati In/11.pl
+ 0AC1 0AC5 GUJARATI # Gujarati In/11.pl
+ 0AC7 0AC8 GUJARATI # Gujarati In/11.pl
+ 0AC9 GUJARATI # Gujarati In/11.pl
+ 0ACB 0ACC GUJARATI # Gujarati In/11.pl
+ 0ACD GUJARATI # Gujarati In/11.pl
+ 0AD0 GUJARATI # Gujarati In/11.pl
+ 0AE0 GUJARATI # Gujarati In/11.pl
+ 0AE6 0AEF GUJARATI # Gujarati In/11.pl
+ 0B01 ORIYA # Oriya In/12.pl
+ 0B02 0B03 ORIYA # Oriya In/12.pl
+ 0B05 0B0C ORIYA # Oriya In/12.pl
+ 0B0F 0B10 ORIYA # Oriya In/12.pl
+ 0B13 0B28 ORIYA # Oriya In/12.pl
+ 0B2A 0B30 ORIYA # Oriya In/12.pl
+ 0B32 0B33 ORIYA # Oriya In/12.pl
+ 0B36 0B39 ORIYA # Oriya In/12.pl
+ 0B3C ORIYA # Oriya In/12.pl
+ 0B3D ORIYA # Oriya In/12.pl
+ 0B3E ORIYA # Oriya In/12.pl
+ 0B3F ORIYA # Oriya In/12.pl
+ 0B40 ORIYA # Oriya In/12.pl
+ 0B41 0B43 ORIYA # Oriya In/12.pl
+ 0B47 0B48 ORIYA # Oriya In/12.pl
+ 0B4B 0B4C ORIYA # Oriya In/12.pl
+ 0B4D ORIYA # Oriya In/12.pl
+ 0B56 ORIYA # Oriya In/12.pl
+ 0B57 ORIYA # Oriya In/12.pl
+ 0B5C 0B5D ORIYA # Oriya In/12.pl
+ 0B5F 0B61 ORIYA # Oriya In/12.pl
+ 0B66 0B6F ORIYA # Oriya In/12.pl
+ 0B82 TAMIL # Tamil In/13.pl
+ 0B83 TAMIL # Tamil In/13.pl
+ 0B85 0B8A TAMIL # Tamil In/13.pl
+ 0B8E 0B90 TAMIL # Tamil In/13.pl
+ 0B92 0B95 TAMIL # Tamil In/13.pl
+ 0B99 0B9A TAMIL # Tamil In/13.pl
+ 0B9C TAMIL # Tamil In/13.pl
+ 0B9E 0B9F TAMIL # Tamil In/13.pl
+ 0BA3 0BA4 TAMIL # Tamil In/13.pl
+ 0BA8 0BAA TAMIL # Tamil In/13.pl
+ 0BAE 0BB5 TAMIL # Tamil In/13.pl
+ 0BB7 0BB9 TAMIL # Tamil In/13.pl
+ 0BBE 0BBF TAMIL # Tamil In/13.pl
+ 0BC0 TAMIL # Tamil In/13.pl
+ 0BC1 0BC2 TAMIL # Tamil In/13.pl
+ 0BC6 0BC8 TAMIL # Tamil In/13.pl
+ 0BCA 0BCC TAMIL # Tamil In/13.pl
+ 0BCD TAMIL # Tamil In/13.pl
+ 0BD7 TAMIL # Tamil In/13.pl
+ 0BE7 0BEF TAMIL # Tamil In/13.pl
+ 0BF0 0BF2 TAMIL # Tamil In/13.pl
+ 0C01 0C03 TELUGU # Telugu In/14.pl
+ 0C05 0C0C TELUGU # Telugu In/14.pl
+ 0C0E 0C10 TELUGU # Telugu In/14.pl
+ 0C12 0C28 TELUGU # Telugu In/14.pl
+ 0C2A 0C33 TELUGU # Telugu In/14.pl
+ 0C35 0C39 TELUGU # Telugu In/14.pl
+ 0C3E 0C40 TELUGU # Telugu In/14.pl
+ 0C41 0C44 TELUGU # Telugu In/14.pl
+ 0C46 0C48 TELUGU # Telugu In/14.pl
+ 0C4A 0C4D TELUGU # Telugu In/14.pl
+ 0C55 0C56 TELUGU # Telugu In/14.pl
+ 0C60 0C61 TELUGU # Telugu In/14.pl
+ 0C66 0C6F TELUGU # Telugu In/14.pl
+ 0C82 0C83 KANNADA # Kannada In/15.pl
+ 0C85 0C8C KANNADA # Kannada In/15.pl
+ 0C8E 0C90 KANNADA # Kannada In/15.pl
+ 0C92 0CA8 KANNADA # Kannada In/15.pl
+ 0CAA 0CB3 KANNADA # Kannada In/15.pl
+ 0CB5 0CB9 KANNADA # Kannada In/15.pl
+ 0CBE KANNADA # Kannada In/15.pl
+ 0CBF KANNADA # Kannada In/15.pl
+ 0CC0 0CC4 KANNADA # Kannada In/15.pl
+ 0CC6 KANNADA # Kannada In/15.pl
+ 0CC7 0CC8 KANNADA # Kannada In/15.pl
+ 0CCA 0CCB KANNADA # Kannada In/15.pl
+ 0CCC 0CCD KANNADA # Kannada In/15.pl
+ 0CD5 0CD6 KANNADA # Kannada In/15.pl
+ 0CDE KANNADA # Kannada In/15.pl
+ 0CE0 0CE1 KANNADA # Kannada In/15.pl
+ 0CE6 0CEF KANNADA # Kannada In/15.pl
+ 0D02 0D03 MALAYALAM # Malayalam In/16.pl
+ 0D05 0D0C MALAYALAM # Malayalam In/16.pl
+ 0D0E 0D10 MALAYALAM # Malayalam In/16.pl
+ 0D12 0D28 MALAYALAM # Malayalam In/16.pl
+ 0D2A 0D39 MALAYALAM # Malayalam In/16.pl
+ 0D3E 0D40 MALAYALAM # Malayalam In/16.pl
+ 0D41 0D43 MALAYALAM # Malayalam In/16.pl
+ 0D46 0D48 MALAYALAM # Malayalam In/16.pl
+ 0D4A 0D4C MALAYALAM # Malayalam In/16.pl
+ 0D4D MALAYALAM # Malayalam In/16.pl
+ 0D57 MALAYALAM # Malayalam In/16.pl
+ 0D60 0D61 MALAYALAM # Malayalam In/16.pl
+ 0D66 0D6F MALAYALAM # Malayalam In/16.pl
+ 0D82 0D83 SINHALA # Sinhala In/17.pl
+ 0D85 0D96 SINHALA # Sinhala In/17.pl
+ 0D9A 0DB1 SINHALA # Sinhala In/17.pl
+ 0DB3 0DBB SINHALA # Sinhala In/17.pl
+ 0DBD SINHALA # Sinhala In/17.pl
+ 0DC0 0DC6 SINHALA # Sinhala In/17.pl
+ 0DCA SINHALA # Sinhala In/17.pl
+ 0DCF 0DD1 SINHALA # Sinhala In/17.pl
+ 0DD2 0DD4 SINHALA # Sinhala In/17.pl
+ 0DD6 SINHALA # Sinhala In/17.pl
+ 0DD8 0DDF SINHALA # Sinhala In/17.pl
+ 0DF2 0DF3 SINHALA # Sinhala In/17.pl
+ 0E01 0E30 THAI # Thai In/18.pl
+ 0E31 THAI # Thai In/18.pl
+ 0E32 0E33 THAI # Thai In/18.pl
+ 0E34 0E3A THAI # Thai In/18.pl
+ 0E40 0E45 THAI # Thai In/18.pl
+ 0E46 THAI # Thai In/18.pl
+ 0E47 0E4E THAI # Thai In/18.pl
+ 0E50 0E59 THAI # Thai In/18.pl
+ 0E81 0E82 LAO # Lao In/19.pl
+ 0E84 LAO # Lao In/19.pl
+ 0E87 0E88 LAO # Lao In/19.pl
+ 0E8A LAO # Lao In/19.pl
+ 0E8D LAO # Lao In/19.pl
+ 0E94 0E97 LAO # Lao In/19.pl
+ 0E99 0E9F LAO # Lao In/19.pl
+ 0EA1 0EA3 LAO # Lao In/19.pl
+ 0EA5 LAO # Lao In/19.pl
+ 0EA7 LAO # Lao In/19.pl
+ 0EAA 0EAB LAO # Lao In/19.pl
+ 0EAD 0EB0 LAO # Lao In/19.pl
+ 0EB1 LAO # Lao In/19.pl
+ 0EB2 0EB3 LAO # Lao In/19.pl
+ 0EB4 0EB9 LAO # Lao In/19.pl
+ 0EBB 0EBC LAO # Lao In/19.pl
+ 0EBD LAO # Lao In/19.pl
+ 0EC0 0EC4 LAO # Lao In/19.pl
+ 0EC6 LAO # Lao In/19.pl
+ 0EC8 0ECD LAO # Lao In/19.pl
+ 0ED0 0ED9 LAO # Lao In/19.pl
+ 0EDC 0EDD LAO # Lao In/19.pl
+ 0F00 TIBETAN # Tibetan In/20.pl
+ 0F18 0F19 TIBETAN # Tibetan In/20.pl
+ 0F20 0F29 TIBETAN # Tibetan In/20.pl
+ 0F2A 0F33 TIBETAN # Tibetan In/20.pl
+ 0F35 TIBETAN # Tibetan In/20.pl
+ 0F37 TIBETAN # Tibetan In/20.pl
+ 0F39 TIBETAN # Tibetan In/20.pl
+ 0F40 0F47 TIBETAN # Tibetan In/20.pl
+ 0F49 0F6A TIBETAN # Tibetan In/20.pl
+ 0F71 0F7E TIBETAN # Tibetan In/20.pl
+ 0F7F TIBETAN # Tibetan In/20.pl
+ 0F80 0F84 TIBETAN # Tibetan In/20.pl
+ 0F86 0F87 TIBETAN # Tibetan In/20.pl
+ 0F88 0F8B TIBETAN # Tibetan In/20.pl
+ 0F90 0F97 TIBETAN # Tibetan In/20.pl
+ 0F99 0FBC TIBETAN # Tibetan In/20.pl
+ 0FC6 TIBETAN # Tibetan In/20.pl
+ 1000 1021 MYANMAR # Myanmar In/21.pl
+ 1023 1027 MYANMAR # Myanmar In/21.pl
+ 1029 102A MYANMAR # Myanmar In/21.pl
+ 102C MYANMAR # Myanmar In/21.pl
+ 102D 1030 MYANMAR # Myanmar In/21.pl
+ 1031 MYANMAR # Myanmar In/21.pl
+ 1032 MYANMAR # Myanmar In/21.pl
+ 1036 1037 MYANMAR # Myanmar In/21.pl
+ 1038 MYANMAR # Myanmar In/21.pl
+ 1039 MYANMAR # Myanmar In/21.pl
+ 1040 1049 MYANMAR # Myanmar In/21.pl
+ 1050 1055 MYANMAR # Myanmar In/21.pl
+ 1056 1057 MYANMAR # Myanmar In/21.pl
+ 1058 1059 MYANMAR # Myanmar In/21.pl
+ 10A0 10C5 GEORGIAN # Georgian In/22.pl
+ 10D0 10F6 GEORGIAN # Georgian In/22.pl
+ 1100 1159 HANGUL # Hangul In/23.pl
+ 115F 11A2 HANGUL # Hangul In/23.pl
+ 11A8 11F9 HANGUL # Hangul In/23.pl
+ 3131 318E HANGUL # Hangul In/23.pl
+ AC00 D7A3 HANGUL # Hangul In/23.pl
+ FFA0 FFBE HANGUL # Hangul In/23.pl
+ FFC2 FFC7 HANGUL # Hangul In/23.pl
+ FFCA FFCF HANGUL # Hangul In/23.pl
+ FFD2 FFD7 HANGUL # Hangul In/23.pl
+ FFDA FFDC HANGUL # Hangul In/23.pl
+ 1200 1206 ETHIOPIC # Ethiopic In/24.pl
+ 1208 1246 ETHIOPIC # Ethiopic In/24.pl
+ 1248 ETHIOPIC # Ethiopic In/24.pl
+ 124A 124D ETHIOPIC # Ethiopic In/24.pl
+ 1250 1256 ETHIOPIC # Ethiopic In/24.pl
+ 1258 ETHIOPIC # Ethiopic In/24.pl
+ 125A 125D ETHIOPIC # Ethiopic In/24.pl
+ 1260 1286 ETHIOPIC # Ethiopic In/24.pl
+ 1288 ETHIOPIC # Ethiopic In/24.pl
+ 128A 128D ETHIOPIC # Ethiopic In/24.pl
+ 1290 12AE ETHIOPIC # Ethiopic In/24.pl
+ 12B0 ETHIOPIC # Ethiopic In/24.pl
+ 12B2 12B5 ETHIOPIC # Ethiopic In/24.pl
+ 12B8 12BE ETHIOPIC # Ethiopic In/24.pl
+ 12C0 ETHIOPIC # Ethiopic In/24.pl
+ 12C2 12C5 ETHIOPIC # Ethiopic In/24.pl
+ 12C8 12CE ETHIOPIC # Ethiopic In/24.pl
+ 12D0 12D6 ETHIOPIC # Ethiopic In/24.pl
+ 12D8 12EE ETHIOPIC # Ethiopic In/24.pl
+ 12F0 130E ETHIOPIC # Ethiopic In/24.pl
+ 1310 ETHIOPIC # Ethiopic In/24.pl
+ 1312 1315 ETHIOPIC # Ethiopic In/24.pl
+ 1318 131E ETHIOPIC # Ethiopic In/24.pl
+ 1320 1346 ETHIOPIC # Ethiopic In/24.pl
+ 1348 135A ETHIOPIC # Ethiopic In/24.pl
+ 1369 1371 ETHIOPIC # Ethiopic In/24.pl
+ 1372 137C ETHIOPIC # Ethiopic In/24.pl
+ 13A0 13F4 CHEROKEE # Cherokee In/25.pl
+ 1401 166C CANADIAN-ABORIGINAL # CanadianAboriginal In/26.pl
+ 166F 1676 CANADIAN-ABORIGINAL # CanadianAboriginal In/26.pl
+ 1681 169A OGHAM # Ogham In/27.pl
+ 16A0 16EA RUNIC # Runic In/28.pl
+ 16EE 16F0 RUNIC # Runic In/28.pl
+ 1780 17B3 KHMER # Khmer In/29.pl
+ 17B4 17B6 KHMER # Khmer In/29.pl
+ 17B7 17BD KHMER # Khmer In/29.pl
+ 17BE 17C5 KHMER # Khmer In/29.pl
+ 17C6 KHMER # Khmer In/29.pl
+ 17C7 17C8 KHMER # Khmer In/29.pl
+ 17C9 17D3 KHMER # Khmer In/29.pl
+ 17E0 17E9 KHMER # Khmer In/29.pl
+ 1810 1819 MONGOLIAN # Mongolian In/30.pl
+ 1820 1842 MONGOLIAN # Mongolian In/30.pl
+ 1843 MONGOLIAN # Mongolian In/30.pl
+ 1844 1877 MONGOLIAN # Mongolian In/30.pl
+ 1880 18A8 MONGOLIAN # Mongolian In/30.pl
+ 18A9 MONGOLIAN # Mongolian In/30.pl
+ 3041 3094 HIRAGANA # Hiragana In/31.pl
+ 309D 309E HIRAGANA # Hiragana In/31.pl
+ 30A1 30FA KATAKANA # Katakana In/32.pl
+ 30FD 30FE KATAKANA # Katakana In/32.pl
+ FF66 FF6F KATAKANA # Katakana In/32.pl
+ FF71 FF9D KATAKANA # Katakana In/32.pl
+ 3105 312C BOPOMOFO # Bopomofo In/33.pl
+ 31A0 31B7 BOPOMOFO # Bopomofo In/33.pl
+ 2E80 2E99 HAN # Han In/34.pl
+ 2E9B 2EF3 HAN # Han In/34.pl
+ 2F00 2FD5 HAN # Han In/34.pl
+ 3005 HAN # Han In/34.pl
+ 3007 HAN # Han In/34.pl
+ 3021 3029 HAN # Han In/34.pl
+ 3038 303A HAN # Han In/34.pl
+ 3400 4DB5 HAN # Han In/34.pl
+ 4E00 9FA5 HAN # Han In/34.pl
+ F900 FA2D HAN # Han In/34.pl
+ 20000 2A6D6 HAN # Han In/34.pl
+ 2F800 2FA1D HAN # Han In/34.pl
+ A000 A48C YI # Yi In/35.pl
+ A490 A4A1 YI # Yi In/35.pl
+ A4A4 A4B3 YI # Yi In/35.pl
+ A4B5 A4C0 YI # Yi In/35.pl
+ A4C2 A4C4 YI # Yi In/35.pl
+ A4C6 YI # Yi In/35.pl
+ 10300 1031E OLD-ITALIC # OldItalic In/36.pl
+ 10330 10349 GOTHIC # Gothic In/37.pl
+ 1034A GOTHIC # Gothic In/37.pl
+ 10400 10425 DESERET # Deseret In/38.pl
+ 10428 1044D DESERET # Deseret In/38.pl
+ 0300 034E INHERITED # Inherited In/39.pl
+ 0360 0362 INHERITED # Inherited In/39.pl
+ 0488 0489 INHERITED # Inherited In/39.pl
+ 0591 05A1 INHERITED # Inherited In/39.pl
+ 05A3 05B9 INHERITED # Inherited In/39.pl
+ 05BB 05BD INHERITED # Inherited In/39.pl
+ 05BF INHERITED # Inherited In/39.pl
+ 05C1 05C2 INHERITED # Inherited In/39.pl
+ 05C4 INHERITED # Inherited In/39.pl
+ 064B 0655 INHERITED # Inherited In/39.pl
+ 0670 INHERITED # Inherited In/39.pl
+ 06D6 06DC INHERITED # Inherited In/39.pl
+ 06DD 06DE INHERITED # Inherited In/39.pl
+ 06DF 06E4 INHERITED # Inherited In/39.pl
+ 06E7 06E8 INHERITED # Inherited In/39.pl
+ 06EA 06ED INHERITED # Inherited In/39.pl
+ 20D0 20DC INHERITED # Inherited In/39.pl
+ 20DD 20E0 INHERITED # Inherited In/39.pl
+ 20E1 INHERITED # Inherited In/39.pl
+ 20E2 20E3 INHERITED # Inherited In/39.pl
+ 302A 302F INHERITED # Inherited In/39.pl
+ 3099 309A INHERITED # Inherited In/39.pl
+ FB1E INHERITED # Inherited In/39.pl
+ FE20 FE23 INHERITED # Inherited In/39.pl
+ 1D167 1D169 INHERITED # Inherited In/39.pl
+ 1D17B 1D182 INHERITED # Inherited In/39.pl
+ 1D185 1D18B INHERITED # Inherited In/39.pl
+ 1D1AA 1D1AD INHERITED # Inherited In/39.pl
+ END
diff -c 'perl-5.7.1/lib/unicode/mktables.PL' 'perl-5.7.2/lib/unicode/mktables.PL'
Index: ./lib/unicode/mktables.PL
*** ./lib/unicode/mktables.PL Thu Mar 8 02:54:51 2001
--- ./lib/unicode/mktables.PL Mon Jul 9 17:11:04 2001
***************
*** 231,241 ****
# This is not written for speed...
foreach $file (@todo) {
my ($table, $wanted, $val) = @$file;
next if @ARGV and not grep { $_ eq $table } @ARGV;
! print $table,"\n";
! if ($table =~ /^(Is|In|To)(.*)/) {
open(OUT, ">$1/$2.pl") or die "Can't create $1/$2.pl: $!\n";
}
else {
--- 231,245 ----
# This is not written for speed...
+ my %InId;
+ my $InId = 0;
+
foreach $file (@todo) {
my ($table, $wanted, $val) = @$file;
next if @ARGV and not grep { $_ eq $table } @ARGV;
! print $table, "\n";
! $table =~ s/\W+//g;
! if ($table =~ /^(Is|To)(.+)/) {
open(OUT, ">$1/$2.pl") or die "Can't create $1/$2.pl: $!\n";
}
else {
***************
*** 254,265 ****
close OUT;
}
# Must treat blocks specially.
exit if @ARGV and not grep { $_ eq Block } @ARGV;
! print "Block\n";
open(UD, 'Blocks.txt') or die "Can't open Blocks.txt: $!\n";
! open(OUT, ">Block.pl") or die "Can't create Block.pl: $!\n";
print OUT <<EOH;
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is built by $0 from e.g. $UnicodeData.
--- 258,331 ----
close OUT;
}
+ # Do Scripts before Blocks so that in case of naming conflicts
+ # the more natural one (Script) wins over the artificial one (Block).
+
+ print "Scripts\n";
+ open(UD, 'Scripts.txt') or die "Can't open Scripts.txt: $!\n";
+ open(OUT, ">Scripts.pl") or die "Can't create Scripts.pl: $!\n";
+ print OUT <<EOH;
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by $0 from e.g. $UnicodeData.
+ # Any changes made here will be lost!
+ EOH
+ print OUT <<"END";
+ return <<'END';
+ END
+
+ my %Scripts;
+
+ while (<UD>) {
+ next if /^#/;
+ next if /^$/;
+ chomp;
+ ($code, $last, $name) = /^([0-9a-f]+)(?:\.\.([0-9a-f]+))?\s+;\s+(.+)\s+\#/i;
+ if ($name) {
+ my $InName = lc($name);
+ $InName =~ s/\b(\w)/uc($1)/ge;
+ $InName =~ s/\W+//g;
+ my $id;
+ unless (exists $InId{$InName}) {
+ print "\t$InName\n";
+ $id = $Scripts{$InName} = $InId{$InName} = $InId++;
+ open(SCRIPT, ">In/$id.pl") or die "create In/$id.pl: $!\n";
+ print SCRIPT <<EOH;
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by $0 from e.g. $UnicodeData.
+ # Any changes made here will be lost!
+ return <<'END';
+ EOH
+ close(SCRIPT);
+ } else {
+ $id = $InId{$InName};
+ }
+ $last = "" unless defined $last;
+ print OUT "$code\t$last\t$name\t# $InName In/$id.pl\n";
+ open(SCRIPT, ">>In/$id.pl");
+ print SCRIPT <<END;
+ $code $last
+ END
+ close SCRIPT;
+ }
+ }
+
+ for my $id (values %InId) {
+ open(SCRIPT, ">>In/$id.pl");
+ print SCRIPT <<END2;
+ END
+ END2
+ close(SCRIPT);
+ }
+
+ print OUT "END\n";
+ close OUT;
+
# Must treat blocks specially.
exit if @ARGV and not grep { $_ eq Block } @ARGV;
! print "Blocks\n";
open(UD, 'Blocks.txt') or die "Can't open Blocks.txt: $!\n";
! open(OUT, ">Blocks.pl") or die "Can't create Blocks.pl: $!\n";
print OUT <<EOH;
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is built by $0 from e.g. $UnicodeData.
***************
*** 273,283 ****
next if /^#/;
next if /^$/;
chomp;
! ($code, $last, $name) = /^([0-9a-f]+)\.\.([0-9a-f]); (.+)/i;
if ($name) {
! print OUT "$code $last $name\n";
! $name =~ s/\s+//g;
! open(BLOCK, ">In/$name.pl");
print BLOCK <<EOH;
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is built by $0 from e.g. $UnicodeData.
--- 339,360 ----
next if /^#/;
next if /^$/;
chomp;
! ($code, $last, $name) = /^([0-9a-f]+)\.\.([0-9a-f]+); (.+)/i;
if ($name) {
! my $InName = $name;
! $InName =~ s/\W+//g;
! print "\t$InName\n";
! my $id;
! # TODO: only the first one of Private Use blocks qualifies
! unless (exists $InId{$InName}) {
! $InId{$InName} = $InId++;
! } elsif (exists $Scripts{$InName}) {
! $InName .= 'Block';
! $InId{$InName} = $InId++;
! }
! $id = $InId{$InName};
! open(BLOCK, ">In/$id.pl") or die "create In/$id.pl: $!\n";
! print OUT "$code\t$last\t$name\t# $InName In/$id.pl\n";
print BLOCK <<EOH;
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is built by $0 from e.g. $UnicodeData.
***************
*** 294,299 ****
--- 371,394 ----
print OUT "END\n";
close OUT;
+
+ open(INID, ">In.pl");
+
+ print INID <<EOH;
+ # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ # This file is built by $0 from e.g. $UnicodeData.
+ # Any changes made here will be lost!
+ %utf8::In = (
+ EOH
+
+ # Order doesn't matter but let's prettyprint anyway.
+ foreach my $in (sort { $InId{$a} <=> $InId{$b} } keys %InId) {
+ printf INID "%-40s => %3d,\n", "'$in'", $InId{$in};
+ }
+
+ print INID ");\n";
+
+ close(INID);
##################################################
diff -c 'perl-5.7.1/lib/utf8.pm' 'perl-5.7.2/lib/utf8.pm'
Index: ./lib/utf8.pm
*** ./lib/utf8.pm Mon Apr 9 16:19:18 2001
--- ./lib/utf8.pm Mon Jul 9 17:11:04 2001
***************
*** 61,69 ****
Bytes in the source text that have their high-bit set will be treated
as being part of a literal UTF-8 character. This includes most literals
such as identifiers, string constants, constant regular expression patterns
! and package names. On EBCDIC platforms, characters in the C1 control group
! and the Latin 1 character set are treated as being part of a literal
! UTF-EBCDIC character.
=item *
--- 61,68 ----
Bytes in the source text that have their high-bit set will be treated
as being part of a literal UTF-8 character. This includes most literals
such as identifiers, string constants, constant regular expression patterns
! and package names. On EBCDIC platforms characters in the Latin 1
! character set are treated as being part of a literal UTF-EBCDIC character.
=item *
diff -c /dev/null 'perl-5.7.2/lib/utf8.t'
Index: ./lib/utf8.t
*** ./lib/utf8.t Thu Jan 1 02:00:00 1970
--- ./lib/utf8.t Mon Jul 9 17:11:04 2001
***************
*** 0 ****
--- 1,103 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # NOTE!
+ #
+ # Think carefully before adding tests here. In general this should be
+ # used only for about three categories of tests:
+ #
+ # (1) tests that absolutely require 'use utf8', and since that in general
+ # shouldn't be needed as the utf8 is being obsoleted, this should
+ # have rather few tests. If you want to test Unicode and regexes,
+ # you probably want to go to op/regexp or op/pat; if you want to test
+ # split, go to op/split; pack, op/pack; appending or joining,
+ # op/append or op/join, and so forth
+ #
+ # (2) tests that have to do with Unicode tokenizing (though it's likely
+ # that all the other Unicode tests sprinkled around the t/**/*.t are
+ # going to catch that)
+ #
+ # (3) complicated tests that simultaneously stress so many Unicode features
+ # that deciding into which other test script the tests should go to
+ # is hard -- maybe consider breaking up the complicated test
+ #
+ #
+
+ use Test;
+ plan tests => 15;
+
+ {
+ # bug id 20001009.001
+
+ my ($a, $b);
+
+ { use bytes; $a = "\xc3\xa4" }
+ { use utf8; $b = "\xe4" }
+
+ my $test = 68;
+
+ ok($a ne $b);
+
+ { use utf8; ok($a ne $b) }
+ }
+
+
+ {
+ # bug id 20000730.004
+
+ my $smiley = "\x{263a}";
+
+ for my $s ("\x{263a}",
+ $smiley,
+
+ "" . $smiley,
+ "" . "\x{263a}",
+
+ $smiley . "",
+ "\x{263a}" . "",
+ ) {
+ my $length_chars = length($s);
+ my $length_bytes;
+ { use bytes; $length_bytes = length($s) }
+ my @regex_chars = $s =~ m/(.)/g;
+ my $regex_chars = @regex_chars;
+ my @split_chars = split //, $s;
+ my $split_chars = @split_chars;
+ ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq
+ "1/1/1/3");
+ }
+
+ for my $s ("\x{263a}" . "\x{263a}",
+ $smiley . $smiley,
+
+ "\x{263a}\x{263a}",
+ "$smiley$smiley",
+
+ "\x{263a}" x 2,
+ $smiley x 2,
+ ) {
+ my $length_chars = length($s);
+ my $length_bytes;
+ { use bytes; $length_bytes = length($s) }
+ my @regex_chars = $s =~ m/(.)/g;
+ my $regex_chars = @regex_chars;
+ my @split_chars = split //, $s;
+ my $split_chars = @split_chars;
+ ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq
+ "2/2/2/6");
+ }
+ }
+
+
+ {
+ my $w = 0;
+ local $SIG{__WARN__} = sub { print "#($_[0])\n"; $w++ };
+ my $x = eval q/"\\/ . "\x{100}" . q/"/;;
+
+ ok($w == 0 && $x eq "\x{100}");
+ }
+
diff -c 'perl-5.7.1/lib/utf8_heavy.pl' 'perl-5.7.2/lib/utf8_heavy.pl'
Index: ./lib/utf8_heavy.pl
*** ./lib/utf8_heavy.pl Sat Mar 10 22:56:43 2001
--- ./lib/utf8_heavy.pl Mon Jul 9 17:11:04 2001
***************
*** 26,37 ****
while (($caller = caller($i)) eq __PACKAGE__) { $i++ }
my $encoding = $enc{$caller} || "unicode";
(my $file = $type) =~ s!::!/!g;
! $file =~ s#^(I[sn]|To)([A-Z].*)#$1/$2#;
! $list ||= eval { $caller->$type(); }
! || do "$file.pl"
! || do "$encoding/$file.pl"
! || do "$encoding/Is/${type}.pl"
! || croak("Can't find $encoding character property definition via $caller->$type or $file.pl");
$| = 1;
--- 26,50 ----
while (($caller = caller($i)) eq __PACKAGE__) { $i++ }
my $encoding = $enc{$caller} || "unicode";
(my $file = $type) =~ s!::!/!g;
! if ($file =~ /^In(.+)/) {
! my $In = $1;
! defined %utf8::In || do "$encoding/In.pl";
! if (exists $utf8::In{$In}) {
! $file = "$encoding/In/$utf8::In{$In}";
! }
! } else {
! $file =~ s#^(Is|To)([A-Z].*)#$1/$2#;
! }
!
! {
! $list ||=
! ( exists &{"${caller}::${type}"} &&
! eval { $caller->$type() } )
! || do "$file.pl"
! || do "$encoding/$file.pl"
! || do "$encoding/Is/${type}.pl"
! || croak("Can't find $encoding character property \"$type\"");
! }
$| = 1;
diff -c 'perl-5.7.1/lib/vars.pm' 'perl-5.7.2/lib/vars.pm'
Index: ./lib/vars.pm
*** ./lib/vars.pm Tue Mar 6 04:06:11 2001
--- ./lib/vars.pm Mon Jul 9 17:11:05 2001
***************
*** 1,47 ****
package vars;
! require 5.002;
! our $VERSION = '1.00';
- # The following require can't be removed during maintenance
- # releases, sadly, because of the risk of buggy code that does
- # require Carp; Carp::croak "..."; without brackets dying
- # if Carp hasn't been loaded in earlier compile time. :-(
- # We'll let those bugs get found on the development track.
- require Carp if $] < 5.00450;
-
use warnings::register;
! require strict;
sub import {
my $callpack = caller;
! my ($pack, @imports, $sym, $ch) = @_;
! foreach $sym (@imports) {
! ($ch, $sym) = unpack('a1a*', $sym);
if ($sym =~ tr/A-Za-z_0-9//c) {
# time for a more-detailed check-up
! if ($sym =~ /::/) {
require Carp;
- Carp::croak("Can't declare another package's variables");
- } elsif ($sym =~ /^\w+[[{].*[]}]$/) {
- require Carp;
Carp::croak("Can't declare individual elements of hash or array");
} elsif (warnings::enabled() and length($sym) == 1 and $sym !~ tr/a-zA-Z//) {
warnings::warn("No need to declare built-in vars");
} elsif ( $^H &= strict::bits('vars') ) {
! Carp::croak("'$ch$sym' is not a valid variable name under strict vars");
}
}
! *{"${callpack}::$sym"} =
! ( $ch eq "\$" ? \$ {"${callpack}::$sym"}
! : $ch eq "\@" ? \@ {"${callpack}::$sym"}
! : $ch eq "\%" ? \% {"${callpack}::$sym"}
! : $ch eq "\*" ? \* {"${callpack}::$sym"}
! : $ch eq "\&" ? \& {"${callpack}::$sym"}
: do {
require Carp;
! Carp::croak("'$ch$sym' is not a valid variable name");
});
}
};
--- 1,39 ----
package vars;
! require 5.6.0;
! our $VERSION = '1.01';
use warnings::register;
! use strict qw(vars subs);
sub import {
my $callpack = caller;
! my ($pack, @imports) = @_;
! my ($sym, $ch);
! foreach (@imports) {
! ($ch, $sym) = unpack('a1a*', $_);
if ($sym =~ tr/A-Za-z_0-9//c) {
# time for a more-detailed check-up
! if ($sym =~ /^\w+[[{].*[]}]$/) {
require Carp;
Carp::croak("Can't declare individual elements of hash or array");
} elsif (warnings::enabled() and length($sym) == 1 and $sym !~ tr/a-zA-Z//) {
warnings::warn("No need to declare built-in vars");
} elsif ( $^H &= strict::bits('vars') ) {
! Carp::croak("'$_' is not a valid variable name under strict vars");
}
}
! $sym = "${callpack}::$sym" unless $sym =~ /::/;
! *$sym =
! ( $ch eq "\$" ? \$$sym
! : $ch eq "\@" ? \@$sym
! : $ch eq "\%" ? \%$sym
! : $ch eq "\*" ? \*$sym
! : $ch eq "\&" ? \&$sym
: do {
require Carp;
! Carp::croak("'$_' is not a valid variable name");
});
}
};
***************
*** 59,67 ****
=head1 DESCRIPTION
! NOTE: The functionality provided by this pragma has been superseded
! by C<our> declarations, available in Perl v5.6.0 or later. See
! L<perlfunc/our>.
This will predeclare all the variables whose names are
in the list, allowing you to use them under "use strict", and
--- 51,59 ----
=head1 DESCRIPTION
! NOTE: For variables in the current package, the functionality provided
! by this pragma has been superseded by C<our> declarations, available
! in Perl v5.6.0 or later. See L<perlfunc/our>.
This will predeclare all the variables whose names are
in the list, allowing you to use them under "use strict", and
diff -c /dev/null 'perl-5.7.2/lib/vars.t'
Index: ./lib/vars.t
*** ./lib/vars.t Thu Jan 1 02:00:00 1970
--- ./lib/vars.t Mon Jul 9 17:11:05 2001
***************
*** 0 ****
--- 1,105 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ $ENV{PERL5LIB} = '../lib';
+ }
+
+ $| = 1;
+
+ print "1..27\n";
+
+ # catch "used once" warnings
+ my @warns;
+ BEGIN { $SIG{__WARN__} = sub { push @warns, @_ }; $^W = 1 };
+
+ %x = ();
+ $y = 3;
+ @z = ();
+ $X::x = 13;
+
+ use vars qw($p @q %r *s &t $X::p);
+
+ my $e = !(grep /^Name "X::x" used only once: possible typo/, @warns) && 'not ';
+ print "${e}ok 1\n";
+ $e = !(grep /^Name "main::x" used only once: possible typo/, @warns) && 'not ';
+ print "${e}ok 2\n";
+ $e = !(grep /^Name "main::y" used only once: possible typo/, @warns) && 'not ';
+ print "${e}ok 3\n";
+ $e = !(grep /^Name "main::z" used only once: possible typo/, @warns) && 'not ';
+ print "${e}ok 4\n";
+ ($e, @warns) = @warns != 4 && 'not ';
+ print "${e}ok 5\n";
+
+ # this is inside eval() to avoid creation of symbol table entries and
+ # to avoid "used once" warnings
+ eval <<'EOE';
+ $e = ! $main::{p} && 'not ';
+ print "${e}ok 6\n";
+ $e = ! *q{ARRAY} && 'not ';
+ print "${e}ok 7\n";
+ $e = ! *r{HASH} && 'not ';
+ print "${e}ok 8\n";
+ $e = ! $main::{s} && 'not ';
+ print "${e}ok 9\n";
+ $e = ! *t{CODE} && 'not ';
+ print "${e}ok 10\n";
+ $e = defined $X::{q} && 'not ';
+ print "${e}ok 11\n";
+ $e = ! $X::{p} && 'not ';
+ print "${e}ok 12\n";
+ EOE
+ $e = $@ && 'not ';
+ print "${e}ok 13\n";
+
+ eval q{use vars qw(@X::y !abc); $e = ! *X::y{ARRAY} && 'not '};
+ print "${e}ok 14\n";
+ $e = $@ !~ /^'!abc' is not a valid variable name/ && 'not ';
+ print "${e}ok 15\n";
+
+ eval 'use vars qw($x[3])';
+ $e = $@ !~ /^Can't declare individual elements of hash or array/ && 'not ';
+ print "${e}ok 16\n";
+
+ { local $^W;
+ eval 'use vars qw($!)';
+ ($e, @warns) = ($@ || @warns) ? 'not ' : '';
+ print "${e}ok 17\n";
+ };
+
+ # NB the next test only works because vars.pm has already been loaded
+ eval 'use warnings "vars"; use vars qw($!)';
+ $e = ($@ || (shift(@warns)||'') !~ /^No need to declare built-in vars/)
+ && 'not ';
+ print "${e}ok 18\n";
+
+ no strict 'vars';
+ eval 'use vars qw(@x%%)';
+ $e = $@ && 'not ';
+ print "${e}ok 19\n";
+ $e = ! *{'x%%'}{ARRAY} && 'not ';
+ print "${e}ok 20\n";
+ eval '$u = 3; @v = (); %w = ()';
+ $e = $@ && 'not ';
+ print "${e}ok 21\n";
+
+ use strict 'vars';
+ eval 'use vars qw(@y%%)';
+ $e = $@ !~ /^'\@y%%' is not a valid variable name under strict vars/ && 'not ';
+ print "${e}ok 22\n";
+ $e = *{'y%%'}{ARRAY} && 'not ';
+ print "${e}ok 23\n";
+ eval '$u = 3; @v = (); %w = ()';
+ my @errs = split /\n/, $@;
+ $e = @errs != 3 && 'not ';
+ print "${e}ok 24\n";
+ $e = !(grep(/^Global symbol "\$u" requires explicit package name/, @errs))
+ && 'not ';
+ print "${e}ok 25\n";
+ $e = !(grep(/^Global symbol "\@v" requires explicit package name/, @errs))
+ && 'not ';
+ print "${e}ok 26\n";
+ $e = !(grep(/^Global symbol "\%w" requires explicit package name/, @errs))
+ && 'not ';
+ print "${e}ok 27\n";
diff -c 'perl-5.7.1/lib/warnings.pm' 'perl-5.7.2/lib/warnings.pm'
Index: ./lib/warnings.pm
*** ./lib/warnings.pm Thu Apr 5 20:48:17 2001
--- ./lib/warnings.pm Thu Jul 12 08:23:16 2001
***************
*** 130,285 ****
%Offsets = (
'all' => 0,
! 'chmod' => 2,
! 'closure' => 4,
! 'exiting' => 6,
! 'glob' => 8,
! 'io' => 10,
! 'closed' => 12,
! 'exec' => 14,
! 'newline' => 16,
! 'pipe' => 18,
! 'unopened' => 20,
! 'misc' => 22,
! 'numeric' => 24,
! 'once' => 26,
! 'overflow' => 28,
! 'pack' => 30,
! 'portable' => 32,
! 'recursion' => 34,
! 'redefine' => 36,
! 'regexp' => 38,
! 'severe' => 40,
! 'debugging' => 42,
! 'inplace' => 44,
! 'internal' => 46,
! 'malloc' => 48,
! 'signal' => 50,
! 'substr' => 52,
! 'syntax' => 54,
! 'ambiguous' => 56,
! 'bareword' => 58,
! 'deprecated' => 60,
! 'digit' => 62,
! 'parenthesis' => 64,
! 'precedence' => 66,
! 'printf' => 68,
! 'prototype' => 70,
! 'qw' => 72,
! 'reserved' => 74,
! 'semicolon' => 76,
! 'taint' => 78,
! 'umask' => 80,
! 'uninitialized' => 82,
! 'unpack' => 84,
! 'untie' => 86,
! 'utf8' => 88,
! 'void' => 90,
! 'y2k' => 92,
);
%Bits = (
! 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
! 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [28]
! 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
! 'chmod' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
! 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
! 'closure' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
! 'debugging' => "\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [21]
! 'deprecated' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
! 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
! 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
! 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
! 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
! 'inplace' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
! 'internal' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
! 'io' => "\x00\x54\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..10]
! 'malloc' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
! 'misc' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
! 'newline' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
! 'numeric' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
! 'once' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
! 'overflow' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
! 'pack' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
! 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
! 'pipe' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
! 'portable' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
! 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
! 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
! 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
! 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
! 'recursion' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
! 'redefine' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
! 'regexp' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
! 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
! 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
! 'severe' => "\x00\x00\x00\x00\x00\x55\x01\x00\x00\x00\x00\x00", # [20..24]
! 'signal' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
! 'substr' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
! 'syntax' => "\x00\x00\x00\x00\x00\x00\x40\x55\x55\x15\x00\x00", # [27..38]
! 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
! 'umask' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
! 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
! 'unopened' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
! 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
! 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
! 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
! 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
! 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
);
%DeadBits = (
! 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
! 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [28]
! 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
! 'chmod' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
! 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
! 'closure' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
! 'debugging' => "\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [21]
! 'deprecated' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
! 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
! 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
! 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
! 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
! 'inplace' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
! 'internal' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
! 'io' => "\x00\xa8\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..10]
! 'malloc' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
! 'misc' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
! 'newline' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
! 'numeric' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
! 'once' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
! 'overflow' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
! 'pack' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
! 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
! 'pipe' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
! 'portable' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
! 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
! 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
! 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
! 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
! 'recursion' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
! 'redefine' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
! 'regexp' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
! 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
! 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
! 'severe' => "\x00\x00\x00\x00\x00\xaa\x02\x00\x00\x00\x00\x00", # [20..24]
! 'signal' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
! 'substr' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
! 'syntax' => "\x00\x00\x00\x00\x00\x00\x80\xaa\xaa\x2a\x00\x00", # [27..38]
! 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
! 'umask' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
! 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
! 'unopened' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
! 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
! 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
! 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
! 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
! 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
);
$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
! $LAST_BIT = 94 ;
$BYTES = 12 ;
$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
--- 130,279 ----
%Offsets = (
'all' => 0,
! 'closure' => 2,
! 'exiting' => 4,
! 'glob' => 6,
! 'io' => 8,
! 'closed' => 10,
! 'exec' => 12,
! 'newline' => 14,
! 'pipe' => 16,
! 'unopened' => 18,
! 'misc' => 20,
! 'numeric' => 22,
! 'once' => 24,
! 'overflow' => 26,
! 'pack' => 28,
! 'portable' => 30,
! 'recursion' => 32,
! 'redefine' => 34,
! 'regexp' => 36,
! 'severe' => 38,
! 'debugging' => 40,
! 'inplace' => 42,
! 'internal' => 44,
! 'malloc' => 46,
! 'signal' => 48,
! 'substr' => 50,
! 'syntax' => 52,
! 'ambiguous' => 54,
! 'bareword' => 56,
! 'deprecated' => 58,
! 'digit' => 60,
! 'parenthesis' => 62,
! 'precedence' => 64,
! 'printf' => 66,
! 'prototype' => 68,
! 'qw' => 70,
! 'reserved' => 72,
! 'semicolon' => 74,
! 'taint' => 76,
! 'uninitialized' => 78,
! 'unpack' => 80,
! 'untie' => 82,
! 'utf8' => 84,
! 'void' => 86,
! 'y2k' => 88,
);
%Bits = (
! 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x01", # [0..44]
! 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
! 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [28]
! 'closed' => "\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5]
! 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
! 'debugging' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
! 'deprecated' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
! 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
! 'exec' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
! 'exiting' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
! 'glob' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
! 'inplace' => "\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [21]
! 'internal' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
! 'io' => "\x00\x55\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4..9]
! 'malloc' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
! 'misc' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
! 'newline' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
! 'numeric' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
! 'once' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
! 'overflow' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
! 'pack' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
! 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
! 'pipe' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
! 'portable' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
! 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
! 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
! 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
! 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
! 'recursion' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
! 'redefine' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
! 'regexp' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
! 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
! 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
! 'severe' => "\x00\x00\x00\x00\x40\x55\x00\x00\x00\x00\x00\x00", # [19..23]
! 'signal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
! 'substr' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
! 'syntax' => "\x00\x00\x00\x00\x00\x00\x50\x55\x55\x05\x00\x00", # [26..37]
! 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
! 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
! 'unopened' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
! 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
! 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
! 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
! 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
! 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
);
%DeadBits = (
! 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x02", # [0..44]
! 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
! 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [28]
! 'closed' => "\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5]
! 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
! 'debugging' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
! 'deprecated' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
! 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
! 'exec' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
! 'exiting' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
! 'glob' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
! 'inplace' => "\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [21]
! 'internal' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
! 'io' => "\x00\xaa\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4..9]
! 'malloc' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
! 'misc' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
! 'newline' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
! 'numeric' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
! 'once' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
! 'overflow' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
! 'pack' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
! 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
! 'pipe' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
! 'portable' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
! 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
! 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
! 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
! 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
! 'recursion' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
! 'redefine' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
! 'regexp' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
! 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
! 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
! 'severe' => "\x00\x00\x00\x00\x80\xaa\x00\x00\x00\x00\x00\x00", # [19..23]
! 'signal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
! 'substr' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
! 'syntax' => "\x00\x00\x00\x00\x00\x00\xa0\xaa\xaa\x0a\x00\x00", # [26..37]
! 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
! 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
! 'unopened' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
! 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
! 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
! 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
! 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
! 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
);
$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
! $LAST_BIT = 90 ;
$BYTES = 12 ;
$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
diff -c /dev/null 'perl-5.7.2/lib/warnings.t'
Index: ./lib/warnings.t
*** ./lib/warnings.t Thu Jan 1 02:00:00 1970
--- ./lib/warnings.t Mon Jul 9 17:11:05 2001
***************
*** 0 ****
--- 1,131 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ $ENV{PERL5LIB} = '../lib';
+ require Config; import Config;
+ }
+
+ $| = 1;
+
+ my $Is_VMS = $^O eq 'VMS';
+ my $Is_MSWin32 = $^O eq 'MSWin32';
+ my $Is_NetWare = $^O eq 'NetWare';
+ my $tmpfile = "tmp0000";
+ my $i = 0 ;
+ 1 while -f ++$tmpfile;
+ END { if ($tmpfile) { 1 while unlink $tmpfile} }
+
+ my @prgs = () ;
+ my @w_files = () ;
+
+ if (@ARGV)
+ { print "ARGV = [@ARGV]\n" ; @w_files = map { s#^#./lib/warnings/#; $_ } @ARGV }
+ else
+ { @w_files = sort glob("lib/warnings/*") }
+
+ my $files = 0;
+ foreach my $file (@w_files) {
+
+ next if $file =~ /(~|\.orig|,v)$/;
+
+ open F, "<$file" or die "Cannot open $file: $!\n" ;
+ my $line = 0;
+ while (<F>) {
+ $line++;
+ last if /^__END__/ ;
+ }
+
+ {
+ local $/ = undef;
+ $files++;
+ @prgs = (@prgs, $file, split "\n########\n", <F>) ;
+ }
+ close F ;
+ }
+
+ undef $/;
+
+ print "1..", scalar(@prgs)-$files, "\n";
+
+
+ for (@prgs){
+ unless (/\n/)
+ {
+ print "# From $_\n";
+ next;
+ }
+ my $switch = "";
+ my @temps = () ;
+ if (s/^\s*-\w+//){
+ $switch = $&;
+ $switch =~ s/(-\S*[A-Z]\S*)/"$1"/ if $Is_VMS; # protect uc switches
+ }
+ my($prog,$expected) = split(/\nEXPECT\n/, $_);
+ if ( $prog =~ /--FILE--/) {
+ my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
+ shift @files ;
+ die "Internal error test $i didn't split into pairs, got " .
+ scalar(@files) . "[" . join("%%%%", @files) ."]\n"
+ if @files % 2 ;
+ while (@files > 2) {
+ my $filename = shift @files ;
+ my $code = shift @files ;
+ push @temps, $filename ;
+ open F, ">$filename" or die "Cannot open $filename: $!\n" ;
+ print F $code ;
+ close F ;
+ }
+ shift @files ;
+ $prog = shift @files ;
+ }
+ open TEST, ">$tmpfile";
+ print TEST $prog,"\n";
+ close TEST;
+ my $results = $Is_VMS ?
+ `./perl "-I../lib" $switch $tmpfile 2>&1` :
+ $Is_MSWin32 ?
+ `.\\perl -I../lib $switch $tmpfile 2>&1` :
+ $Is_NetWare ?
+ `perl -I../lib $switch $tmpfile 2>&1` :
+ `./perl -I../lib $switch $tmpfile 2>&1`;
+ my $status = $?;
+ $results =~ s/\n+$//;
+ # allow expected output to be written as if $prog is on STDIN
+ $results =~ s/tmp\d+/-/g;
+ $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg
+ # bison says 'parse error' instead of 'syntax error',
+ # various yaccs may or may not capitalize 'syntax'.
+ $results =~ s/^(syntax|parse) error/syntax error/mig;
+ # allow all tests to run when there are leaks
+ $results =~ s/Scalars leaked: \d+\n//g;
+ $expected =~ s/\n+$//;
+ my $prefix = ($results =~ s#^PREFIX(\n|$)##) ;
+ # any special options? (OPTIONS foo bar zap)
+ my $option_regex = 0;
+ if ($expected =~ s/^OPTIONS? (.+)\n//) {
+ foreach my $option (split(' ', $1)) {
+ if ($option eq 'regex') { # allow regular expressions
+ $option_regex = 1;
+ } else {
+ die "$0: Unknown OPTION '$option'\n";
+ }
+ }
+ }
+ if ( $results =~ s/^SKIPPED\n//) {
+ print "$results\n" ;
+ }
+ elsif (($prefix && (( $option_regex && $results !~ /^$expected/) ||
+ (!$option_regex && $results !~ /^\Q$expected/))) or
+ (!$prefix && (( $option_regex && $results !~ /^$expected/) ||
+ (!$option_regex && $results ne $expected)))) {
+ print STDERR "PROG: $switch\n$prog\n";
+ print STDERR "EXPECTED:\n$expected\n";
+ print STDERR "GOT:\n$results\n";
+ print "not ";
+ }
+ print "ok ", ++$i, "\n";
+ foreach (@temps)
+ { unlink $_ if $_ }
+ }
diff -c /dev/null 'perl-5.7.2/locale.c'
Index: ./locale.c
*** ./locale.c Thu Jan 1 02:00:00 1970
--- ./locale.c Mon Jul 9 17:11:05 2001
***************
*** 0 ****
--- 1,549 ----
+ /* locale.c
+ *
+ * Copyright (c) 2001, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * A Elbereth Gilthoniel,
+ * silivren penna m�riel
+ * o menel aglar elenath!
+ * Na-chaered palan-d�riel
+ * o galadhremmin ennorath,
+ * Fanuilos, le linnathon
+ * nef aear, si nef aearon!
+ */
+
+ #include "EXTERN.h"
+ #define PERL_IN_LOCALE_C
+ #include "perl.h"
+
+ #ifdef I_LOCALE
+ # include <locale.h>
+ #endif
+
+ /*
+ * Standardize the locale name from a string returned by 'setlocale'.
+ *
+ * The standard return value of setlocale() is either
+ * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL
+ * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL
+ * (the space-separated values represent the various sublocales,
+ * in some unspecificed order)
+ *
+ * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n",
+ * which is harmful for further use of the string in setlocale().
+ *
+ */
+ STATIC char *
+ S_stdize_locale(pTHX_ char *locs)
+ {
+ char *s;
+ bool okay = TRUE;
+
+ if ((s = strchr(locs, '='))) {
+ char *t;
+
+ okay = FALSE;
+ if ((t = strchr(s, '.'))) {
+ char *u;
+
+ if ((u = strchr(t, '\n'))) {
+
+ if (u[1] == 0) {
+ STRLEN len = u - s;
+ Move(s + 1, locs, len, char);
+ locs[len] = 0;
+ okay = TRUE;
+ }
+ }
+ }
+ }
+
+ if (!okay)
+ Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
+
+ return locs;
+ }
+
+ void
+ Perl_set_numeric_radix(pTHX)
+ {
+ #ifdef USE_LOCALE_NUMERIC
+ # ifdef HAS_LOCALECONV
+ struct lconv* lc;
+
+ lc = localeconv();
+ if (lc && lc->decimal_point) {
+ if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) {
+ SvREFCNT_dec(PL_numeric_radix_sv);
+ PL_numeric_radix_sv = Nullsv;
+ }
+ else {
+ if (PL_numeric_radix_sv)
+ sv_setpv(PL_numeric_radix_sv, lc->decimal_point);
+ else
+ PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0);
+ }
+ }
+ else
+ PL_numeric_radix_sv = Nullsv;
+ # endif /* HAS_LOCALECONV */
+ #endif /* USE_LOCALE_NUMERIC */
+ }
+
+ /*
+ * Set up for a new numeric locale.
+ */
+ void
+ Perl_new_numeric(pTHX_ char *newnum)
+ {
+ #ifdef USE_LOCALE_NUMERIC
+
+ if (! newnum) {
+ if (PL_numeric_name) {
+ Safefree(PL_numeric_name);
+ PL_numeric_name = NULL;
+ }
+ PL_numeric_standard = TRUE;
+ PL_numeric_local = TRUE;
+ return;
+ }
+
+ if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) {
+ Safefree(PL_numeric_name);
+ PL_numeric_name = stdize_locale(savepv(newnum));
+ PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX"));
+ PL_numeric_local = TRUE;
+ set_numeric_radix();
+ }
+
+ #endif /* USE_LOCALE_NUMERIC */
+ }
+
+ void
+ Perl_set_numeric_standard(pTHX)
+ {
+ #ifdef USE_LOCALE_NUMERIC
+
+ if (! PL_numeric_standard) {
+ setlocale(LC_NUMERIC, "C");
+ PL_numeric_standard = TRUE;
+ PL_numeric_local = FALSE;
+ set_numeric_radix();
+ }
+
+ #endif /* USE_LOCALE_NUMERIC */
+ }
+
+ void
+ Perl_set_numeric_local(pTHX)
+ {
+ #ifdef USE_LOCALE_NUMERIC
+
+ if (! PL_numeric_local) {
+ setlocale(LC_NUMERIC, PL_numeric_name);
+ PL_numeric_standard = FALSE;
+ PL_numeric_local = TRUE;
+ set_numeric_radix();
+ }
+
+ #endif /* USE_LOCALE_NUMERIC */
+ }
+
+ /*
+ * Set up for a new ctype locale.
+ */
+ void
+ Perl_new_ctype(pTHX_ char *newctype)
+ {
+ #ifdef USE_LOCALE_CTYPE
+
+ int i;
+
+ for (i = 0; i < 256; i++) {
+ if (isUPPER_LC(i))
+ PL_fold_locale[i] = toLOWER_LC(i);
+ else if (isLOWER_LC(i))
+ PL_fold_locale[i] = toUPPER_LC(i);
+ else
+ PL_fold_locale[i] = i;
+ }
+
+ #endif /* USE_LOCALE_CTYPE */
+ }
+
+ /*
+ * Set up for a new collation locale.
+ */
+ void
+ Perl_new_collate(pTHX_ char *newcoll)
+ {
+ #ifdef USE_LOCALE_COLLATE
+
+ if (! newcoll) {
+ if (PL_collation_name) {
+ ++PL_collation_ix;
+ Safefree(PL_collation_name);
+ PL_collation_name = NULL;
+ }
+ PL_collation_standard = TRUE;
+ PL_collxfrm_base = 0;
+ PL_collxfrm_mult = 2;
+ return;
+ }
+
+ if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
+ ++PL_collation_ix;
+ Safefree(PL_collation_name);
+ PL_collation_name = stdize_locale(savepv(newcoll));
+ PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX"));
+
+ {
+ /* 2: at most so many chars ('a', 'b'). */
+ /* 50: surely no system expands a char more. */
+ #define XFRMBUFSIZE (2 * 50)
+ char xbuf[XFRMBUFSIZE];
+ Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE);
+ Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
+ SSize_t mult = fb - fa;
+ if (mult < 1)
+ Perl_croak(aTHX_ "strxfrm() gets absurd");
+ PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0;
+ PL_collxfrm_mult = mult;
+ }
+ }
+
+ #endif /* USE_LOCALE_COLLATE */
+ }
+
+ /*
+ * Initialize locale awareness.
+ */
+ int
+ Perl_init_i18nl10n(pTHX_ int printwarn)
+ {
+ int ok = 1;
+ /* returns
+ * 1 = set ok or not applicable,
+ * 0 = fallback to C locale,
+ * -1 = fallback to C locale failed
+ */
+
+ #if defined(USE_LOCALE)
+
+ #ifdef USE_LOCALE_CTYPE
+ char *curctype = NULL;
+ #endif /* USE_LOCALE_CTYPE */
+ #ifdef USE_LOCALE_COLLATE
+ char *curcoll = NULL;
+ #endif /* USE_LOCALE_COLLATE */
+ #ifdef USE_LOCALE_NUMERIC
+ char *curnum = NULL;
+ #endif /* USE_LOCALE_NUMERIC */
+ #ifdef __GLIBC__
+ char *language = PerlEnv_getenv("LANGUAGE");
+ #endif
+ char *lc_all = PerlEnv_getenv("LC_ALL");
+ char *lang = PerlEnv_getenv("LANG");
+ bool setlocale_failure = FALSE;
+
+ #ifdef LOCALE_ENVIRON_REQUIRED
+
+ /*
+ * Ultrix setlocale(..., "") fails if there are no environment
+ * variables from which to get a locale name.
+ */
+
+ bool done = FALSE;
+
+ #ifdef LC_ALL
+ if (lang) {
+ if (setlocale(LC_ALL, ""))
+ done = TRUE;
+ else
+ setlocale_failure = TRUE;
+ }
+ if (!setlocale_failure) {
+ #ifdef USE_LOCALE_CTYPE
+ if (! (curctype =
+ setlocale(LC_CTYPE,
+ (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
+ ? "" : Nullch)))
+ setlocale_failure = TRUE;
+ else
+ curctype = savepv(curctype);
+ #endif /* USE_LOCALE_CTYPE */
+ #ifdef USE_LOCALE_COLLATE
+ if (! (curcoll =
+ setlocale(LC_COLLATE,
+ (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
+ ? "" : Nullch)))
+ setlocale_failure = TRUE;
+ else
+ curcoll = savepv(curcoll);
+ #endif /* USE_LOCALE_COLLATE */
+ #ifdef USE_LOCALE_NUMERIC
+ if (! (curnum =
+ setlocale(LC_NUMERIC,
+ (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
+ ? "" : Nullch)))
+ setlocale_failure = TRUE;
+ else
+ curnum = savepv(curnum);
+ #endif /* USE_LOCALE_NUMERIC */
+ }
+
+ #endif /* LC_ALL */
+
+ #endif /* !LOCALE_ENVIRON_REQUIRED */
+
+ #ifdef LC_ALL
+ if (! setlocale(LC_ALL, ""))
+ setlocale_failure = TRUE;
+ #endif /* LC_ALL */
+
+ if (!setlocale_failure) {
+ #ifdef USE_LOCALE_CTYPE
+ if (! (curctype = setlocale(LC_CTYPE, "")))
+ setlocale_failure = TRUE;
+ else
+ curctype = savepv(curctype);
+ #endif /* USE_LOCALE_CTYPE */
+ #ifdef USE_LOCALE_COLLATE
+ if (! (curcoll = setlocale(LC_COLLATE, "")))
+ setlocale_failure = TRUE;
+ else
+ curcoll = savepv(curcoll);
+ #endif /* USE_LOCALE_COLLATE */
+ #ifdef USE_LOCALE_NUMERIC
+ if (! (curnum = setlocale(LC_NUMERIC, "")))
+ setlocale_failure = TRUE;
+ else
+ curnum = savepv(curnum);
+ #endif /* USE_LOCALE_NUMERIC */
+ }
+
+ if (setlocale_failure) {
+ char *p;
+ bool locwarn = (printwarn > 1 ||
+ (printwarn &&
+ (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
+
+ if (locwarn) {
+ #ifdef LC_ALL
+
+ PerlIO_printf(Perl_error_log,
+ "perl: warning: Setting locale failed.\n");
+
+ #else /* !LC_ALL */
+
+ PerlIO_printf(Perl_error_log,
+ "perl: warning: Setting locale failed for the categories:\n\t");
+ #ifdef USE_LOCALE_CTYPE
+ if (! curctype)
+ PerlIO_printf(Perl_error_log, "LC_CTYPE ");
+ #endif /* USE_LOCALE_CTYPE */
+ #ifdef USE_LOCALE_COLLATE
+ if (! curcoll)
+ PerlIO_printf(Perl_error_log, "LC_COLLATE ");
+ #endif /* USE_LOCALE_COLLATE */
+ #ifdef USE_LOCALE_NUMERIC
+ if (! curnum)
+ PerlIO_printf(Perl_error_log, "LC_NUMERIC ");
+ #endif /* USE_LOCALE_NUMERIC */
+ PerlIO_printf(Perl_error_log, "\n");
+
+ #endif /* LC_ALL */
+
+ PerlIO_printf(Perl_error_log,
+ "perl: warning: Please check that your locale settings:\n");
+
+ #ifdef __GLIBC__
+ PerlIO_printf(Perl_error_log,
+ "\tLANGUAGE = %c%s%c,\n",
+ language ? '"' : '(',
+ language ? language : "unset",
+ language ? '"' : ')');
+ #endif
+
+ PerlIO_printf(Perl_error_log,
+ "\tLC_ALL = %c%s%c,\n",
+ lc_all ? '"' : '(',
+ lc_all ? lc_all : "unset",
+ lc_all ? '"' : ')');
+
+ #if defined(USE_ENVIRON_ARRAY)
+ {
+ char **e;
+ for (e = environ; *e; e++) {
+ if (strnEQ(*e, "LC_", 3)
+ && strnNE(*e, "LC_ALL=", 7)
+ && (p = strchr(*e, '=')))
+ PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
+ (int)(p - *e), *e, p + 1);
+ }
+ }
+ #else
+ PerlIO_printf(Perl_error_log,
+ "\t(possibly more locale environment variables)\n");
+ #endif
+
+ PerlIO_printf(Perl_error_log,
+ "\tLANG = %c%s%c\n",
+ lang ? '"' : '(',
+ lang ? lang : "unset",
+ lang ? '"' : ')');
+
+ PerlIO_printf(Perl_error_log,
+ " are supported and installed on your system.\n");
+ }
+
+ #ifdef LC_ALL
+
+ if (setlocale(LC_ALL, "C")) {
+ if (locwarn)
+ PerlIO_printf(Perl_error_log,
+ "perl: warning: Falling back to the standard locale (\"C\").\n");
+ ok = 0;
+ }
+ else {
+ if (locwarn)
+ PerlIO_printf(Perl_error_log,
+ "perl: warning: Failed to fall back to the standard locale (\"C\").\n");
+ ok = -1;
+ }
+
+ #else /* ! LC_ALL */
+
+ if (0
+ #ifdef USE_LOCALE_CTYPE
+ || !(curctype || setlocale(LC_CTYPE, "C"))
+ #endif /* USE_LOCALE_CTYPE */
+ #ifdef USE_LOCALE_COLLATE
+ || !(curcoll || setlocale(LC_COLLATE, "C"))
+ #endif /* USE_LOCALE_COLLATE */
+ #ifdef USE_LOCALE_NUMERIC
+ || !(curnum || setlocale(LC_NUMERIC, "C"))
+ #endif /* USE_LOCALE_NUMERIC */
+ )
+ {
+ if (locwarn)
+ PerlIO_printf(Perl_error_log,
+ "perl: warning: Cannot fall back to the standard locale (\"C\").\n");
+ ok = -1;
+ }
+
+ #endif /* ! LC_ALL */
+
+ #ifdef USE_LOCALE_CTYPE
+ curctype = savepv(setlocale(LC_CTYPE, Nullch));
+ #endif /* USE_LOCALE_CTYPE */
+ #ifdef USE_LOCALE_COLLATE
+ curcoll = savepv(setlocale(LC_COLLATE, Nullch));
+ #endif /* USE_LOCALE_COLLATE */
+ #ifdef USE_LOCALE_NUMERIC
+ curnum = savepv(setlocale(LC_NUMERIC, Nullch));
+ #endif /* USE_LOCALE_NUMERIC */
+ }
+ else {
+
+ #ifdef USE_LOCALE_CTYPE
+ new_ctype(curctype);
+ #endif /* USE_LOCALE_CTYPE */
+
+ #ifdef USE_LOCALE_COLLATE
+ new_collate(curcoll);
+ #endif /* USE_LOCALE_COLLATE */
+
+ #ifdef USE_LOCALE_NUMERIC
+ new_numeric(curnum);
+ #endif /* USE_LOCALE_NUMERIC */
+ }
+
+ #endif /* USE_LOCALE */
+
+ #ifdef USE_LOCALE_CTYPE
+ if (curctype != NULL)
+ Safefree(curctype);
+ #endif /* USE_LOCALE_CTYPE */
+ #ifdef USE_LOCALE_COLLATE
+ if (curcoll != NULL)
+ Safefree(curcoll);
+ #endif /* USE_LOCALE_COLLATE */
+ #ifdef USE_LOCALE_NUMERIC
+ if (curnum != NULL)
+ Safefree(curnum);
+ #endif /* USE_LOCALE_NUMERIC */
+ return ok;
+ }
+
+ /* Backwards compatibility. */
+ int
+ Perl_init_i18nl14n(pTHX_ int printwarn)
+ {
+ return init_i18nl10n(printwarn);
+ }
+
+ #ifdef USE_LOCALE_COLLATE
+
+ /*
+ * mem_collxfrm() is a bit like strxfrm() but with two important
+ * differences. First, it handles embedded NULs. Second, it allocates
+ * a bit more memory than needed for the transformed data itself.
+ * The real transformed data begins at offset sizeof(collationix).
+ * Please see sv_collxfrm() to see how this is used.
+ */
+ char *
+ Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen)
+ {
+ char *xbuf;
+ STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
+
+ /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
+ /* the +1 is for the terminating NUL. */
+
+ xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
+ New(171, xbuf, xAlloc, char);
+ if (! xbuf)
+ goto bad;
+
+ *(U32*)xbuf = PL_collation_ix;
+ xout = sizeof(PL_collation_ix);
+ for (xin = 0; xin < len; ) {
+ SSize_t xused;
+
+ for (;;) {
+ xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
+ if (xused == -1)
+ goto bad;
+ if (xused < xAlloc - xout)
+ break;
+ xAlloc = (2 * xAlloc) + 1;
+ Renew(xbuf, xAlloc, char);
+ if (! xbuf)
+ goto bad;
+ }
+
+ xin += strlen(s + xin) + 1;
+ xout += xused;
+
+ /* Embedded NULs are understood but silently skipped
+ * because they make no sense in locale collation. */
+ }
+
+ xbuf[xout] = '\0';
+ *xlen = xout - sizeof(PL_collation_ix);
+ return xbuf;
+
+ bad:
+ Safefree(xbuf);
+ *xlen = 0;
+ return NULL;
+ }
+
+ #endif /* USE_LOCALE_COLLATE */
+
diff -c 'perl-5.7.1/makeaperl.SH' 'perl-5.7.2/makeaperl.SH'
Index: ./makeaperl.SH
*** ./makeaperl.SH Tue Mar 6 04:06:11 2001
--- ./makeaperl.SH Mon Jul 9 17:11:05 2001
***************
*** 1,4 ****
! case $CONFIGDOTSH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
--- 1,4 ----
! case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
diff -c 'perl-5.7.1/makedef.pl' 'perl-5.7.2/makedef.pl'
Index: ./makedef.pl
*** ./makedef.pl Wed Mar 28 19:43:48 2001
--- ./makedef.pl Fri Jul 13 16:25:45 2001
***************
*** 50,58 ****
$define{$1} = $2 if ($flag =~ /^-D(\w+)=(.+)$/);
$CCTYPE = $1 if ($flag =~ /^CCTYPE=(\w+)$/);
$PLATFORM = $1 if ($flag =~ /^PLATFORM=(\w+)$/);
}
! my @PLATFORM = qw(aix win32 os2 MacOS);
my %PLATFORM;
@PLATFORM{@PLATFORM} = ();
--- 50,61 ----
$define{$1} = $2 if ($flag =~ /^-D(\w+)=(.+)$/);
$CCTYPE = $1 if ($flag =~ /^CCTYPE=(\w+)$/);
$PLATFORM = $1 if ($flag =~ /^PLATFORM=(\w+)$/);
+ if ($PLATFORM eq 'netware') {
+ $FILETYPE = $1 if ($flag =~ /^FILETYPE=(\w+)$/);
+ }
}
! my @PLATFORM = qw(aix win32 os2 MacOS netware);
my %PLATFORM;
@PLATFORM{@PLATFORM} = ();
***************
*** 72,78 ****
if ($PLATFORM eq 'aix') {
# Nothing for now.
}
! elsif ($PLATFORM eq 'win32') {
$CCTYPE = "MSVC" unless defined $CCTYPE;
foreach ($thrdvar_h, $intrpvar_h, $perlvars_h, $global_sym,
$pp_sym, $globvar_sym, $perlio_sym) {
--- 75,81 ----
if ($PLATFORM eq 'aix') {
# Nothing for now.
}
! elsif ($PLATFORM eq 'win32' || $PLATFORM eq 'netware') {
$CCTYPE = "MSVC" unless defined $CCTYPE;
foreach ($thrdvar_h, $intrpvar_h, $perlvars_h, $global_sym,
$pp_sym, $globvar_sym, $perlio_sym) {
***************
*** 86,92 ****
}
}
! unless ($PLATFORM eq 'win32' || $PLATFORM eq 'MacOS') {
open(CFG,$config_sh) || die "Cannot open $config_sh: $!\n";
while (<CFG>) {
if (/^(?:ccflags|optimize)='(.+)'$/) {
--- 89,95 ----
}
}
! unless ($PLATFORM eq 'win32' || $PLATFORM eq 'MacOS' || $PLATFORM eq 'netware') {
open(CFG,$config_sh) || die "Cannot open $config_sh: $!\n";
while (<CFG>) {
if (/^(?:ccflags|optimize)='(.+)'$/) {
***************
*** 145,150 ****
--- 148,154 ----
if ($define{PERL_IMPLICIT_SYS}) {
output_symbol("perl_get_host_info");
output_symbol("perl_alloc_override");
+ output_symbol("perl_clone_host");
}
}
elsif ($PLATFORM eq 'os2') {
***************
*** 151,159 ****
($v = $]) =~ s/(\d\.\d\d\d)(\d\d)$/$1_$2/;
$v .= '-thread' if $ARCHNAME =~ /-thread/;
($dll = $define{PERL_DLL}) =~ s/\.dll$//i;
print <<"---EOP---";
LIBRARY '$dll' INITINSTANCE TERMINSTANCE
! DESCRIPTION '\@#perl5-porters\@perl.org:$v#\@ Perl interpreter'
STACKSIZE 32768
CODE LOADONCALL
DATA LOADONCALL NONSHARED MULTIPLE
--- 155,165 ----
($v = $]) =~ s/(\d\.\d\d\d)(\d\d)$/$1_$2/;
$v .= '-thread' if $ARCHNAME =~ /-thread/;
($dll = $define{PERL_DLL}) =~ s/\.dll$//i;
+ $d = "DESCRIPTION '\@#perl5-porters\@perl.org:$v#\@ Perl interpreter, configured as $CONFIG_ARGS'";
+ $d = substr($d, 0, 249) . "...'" if length $d > 253;
print <<"---EOP---";
LIBRARY '$dll' INITINSTANCE TERMINSTANCE
! $d
STACKSIZE 32768
CODE LOADONCALL
DATA LOADONCALL NONSHARED MULTIPLE
***************
*** 161,168 ****
---EOP---
}
elsif ($PLATFORM eq 'aix') {
! print "#!\n";
}
my %skip;
my %export;
--- 167,194 ----
---EOP---
}
elsif ($PLATFORM eq 'aix') {
! $OSVER = `uname -v`;
! chop $OSVER;
! $OSREL = `uname -r`;
! chop $OSREL;
! if ($OSVER > 4 || ($OSVER == 4 && $OSREL >= 3)) {
! print "#! ..\n";
! } else {
! print "#!\n";
! }
}
+ elsif ($PLATFORM eq 'netware') {
+ if ($FILETYPE eq 'def') {
+ print "LIBRARY Perl57\n";
+ print "DESCRIPTION 'Perl interpreter for NetWare'\n";
+ print "EXPORTS\n";
+ }
+ if ($define{PERL_IMPLICIT_SYS}) {
+ output_symbol("perl_get_host_info");
+ output_symbol("perl_alloc_override");
+ output_symbol("perl_clone_host");
+ }
+ }
my %skip;
my %export;
***************
*** 213,218 ****
--- 239,245 ----
Perl_dump_fds
Perl_init_thread_intern
Perl_my_bzero
+ Perl_my_bcopy
Perl_my_htonl
Perl_my_ntohl
Perl_my_swap
***************
*** 279,284 ****
--- 306,319 ----
my_flock
my_rmdir
my_mkdir
+ my_getpwuid
+ my_getpwnam
+ my_getpwent
+ my_setpwent
+ my_endpwent
+ setgrent
+ endgrent
+ getgrent
malloc_mutex
threads_mutex
nthreads
***************
*** 307,312 ****
--- 342,349 ----
init_PMWIN_entries
PMWIN_entries
Perl_hab_GET
+ loadByOrdinal
+ pExtFCN
)]);
}
elsif ($PLATFORM eq 'MacOS') {
***************
*** 337,344 ****
Perl_sys_intern_init
)];
}
-
unless ($define{'DEBUGGING'}) {
skip_symbols [qw(
Perl_deb_growlevel
--- 374,430 ----
Perl_sys_intern_init
)];
}
+ elsif ($PLATFORM eq 'netware') {
+ skip_symbols [qw(
+ PL_statusvalue_vms
+ PL_archpat_auto
+ PL_cryptseen
+ PL_DBcv
+ PL_generation
+ PL_lastgotoprobe
+ PL_linestart
+ PL_modcount
+ PL_pending_ident
+ PL_sortcxix
+ PL_sublex_info
+ PL_timesbuf
+ main
+ Perl_ErrorNo
+ Perl_GetVars
+ Perl_do_exec3
+ Perl_do_ipcctl
+ Perl_do_ipcget
+ Perl_do_msgrcv
+ Perl_do_msgsnd
+ Perl_do_semop
+ Perl_do_shmio
+ Perl_dump_fds
+ Perl_init_thread_intern
+ Perl_my_bzero
+ Perl_my_htonl
+ Perl_my_ntohl
+ Perl_my_swap
+ Perl_my_chsize
+ Perl_same_dirent
+ Perl_setenv_getix
+ Perl_unlnk
+ Perl_watch
+ Perl_safexcalloc
+ Perl_safexmalloc
+ Perl_safexfree
+ Perl_safexrealloc
+ Perl_my_memcmp
+ Perl_my_memset
+ PL_cshlen
+ PL_cshname
+ PL_opsave
+ Perl_do_exec
+ Perl_getenv_len
+ Perl_my_pclose
+ Perl_my_popen
+ )];
+ }
unless ($define{'DEBUGGING'}) {
skip_symbols [qw(
Perl_deb_growlevel
***************
*** 383,396 ****
)];
}
if ($define{'MYMALLOC'}) {
emit_symbols [qw(
Perl_dump_mstats
Perl_get_mstats
- Perl_malloc
- Perl_mfree
- Perl_realloc
- Perl_calloc
Perl_strdup
Perl_putenv
)];
--- 469,484 ----
)];
}
+ unless ($define{'USE_REENTRANT_API'}) {
+ skip_symbols [qw(
+ PL_reentrant_buffer
+ )];
+ }
+
if ($define{'MYMALLOC'}) {
emit_symbols [qw(
Perl_dump_mstats
Perl_get_mstats
Perl_strdup
Perl_putenv
)];
***************
*** 410,419 ****
PL_malloc_mutex
Perl_dump_mstats
Perl_get_mstats
- Perl_malloc
- Perl_mfree
- Perl_realloc
- Perl_calloc
Perl_malloced_size
)];
}
--- 498,503 ----
***************
*** 457,462 ****
--- 541,548 ----
skip_symbols [qw(
PL_ptr_table
PL_op_mutex
+ PL_regex_pad
+ PL_regex_padav
Perl_dirp_dup
Perl_cx_dup
Perl_si_dup
***************
*** 671,677 ****
sub try_symbol {
my $symbol = shift;
! return if $symbol !~ /^[A-Za-z]/;
return if $symbol =~ /^\#/;
$symbol =~s/\r//g;
chomp($symbol);
--- 757,763 ----
sub try_symbol {
my $symbol = shift;
! return if $symbol !~ /^[A-Za-z_]/;
return if $symbol =~ /^\#/;
$symbol =~s/\r//g;
chomp($symbol);
***************
*** 859,864 ****
--- 945,1084 ----
close MACSYMS;
}
+ elsif ($PLATFORM eq 'netware') {
+ foreach my $symbol (qw(
+ boot_DynaLoader
+ Perl_init_os_extras
+ Perl_thread_create
+ Perl_nw5_init
+ RunPerl
+ AllocStdPerl
+ FreeStdPerl
+ do_spawn2
+ do_aspawn
+ nw_uname
+ nw_stdin
+ nw_stdout
+ nw_stderr
+ nw_feof
+ nw_ferror
+ nw_fopen
+ nw_fclose
+ nw_clearerr
+ nw_getc
+ nw_fgets
+ nw_fputc
+ nw_fputs
+ nw_fflush
+ nw_ungetc
+ nw_fileno
+ nw_fdopen
+ nw_freopen
+ nw_fread
+ nw_fwrite
+ nw_setbuf
+ nw_setvbuf
+ nw_vfprintf
+ nw_ftell
+ nw_fseek
+ nw_rewind
+ nw_tmpfile
+ nw_fgetpos
+ nw_fsetpos
+ nw_dup
+ nw_access
+ nw_chmod
+ nw_chsize
+ nw_close
+ nw_dup2
+ nw_flock
+ nw_isatty
+ nw_link
+ nw_lseek
+ nw_stat
+ nw_mktemp
+ nw_open
+ nw_read
+ nw_rename
+ nw_setmode
+ nw_unlink
+ nw_utime
+ nw_write
+ nw_chdir
+ nw_rmdir
+ nw_closedir
+ nw_opendir
+ nw_readdir
+ nw_rewinddir
+ nw_seekdir
+ nw_telldir
+ nw_htonl
+ nw_htons
+ nw_ntohl
+ nw_ntohs
+ nw_accept
+ nw_bind
+ nw_connect
+ nw_endhostent
+ nw_endnetent
+ nw_endprotoent
+ nw_endservent
+ nw_gethostbyaddr
+ nw_gethostbyname
+ nw_gethostent
+ nw_gethostname
+ nw_getnetbyaddr
+ nw_getnetbyname
+ nw_getnetent
+ nw_getpeername
+ nw_getprotobyname
+ nw_getprotobynumber
+ nw_getprotoent
+ nw_getservbyname
+ nw_getservbyport
+ nw_getservent
+ nw_getsockname
+ nw_getsockopt
+ nw_inet_addr
+ nw_listen
+ nw_socket
+ nw_recv
+ nw_recvfrom
+ nw_select
+ nw_send
+ nw_sendto
+ nw_sethostent
+ nw_setnetent
+ nw_setprotoent
+ nw_setservent
+ nw_shutdown
+ nw_crypt
+ nw_execvp
+ nw_kill
+ nw_Popen
+ nw_Pclose
+ nw_Pipe
+ nw_times
+ nw_waitpid
+ nw_getpid
+ nw_spawnvp
+ nw_os_id
+ nw_open_osfhandle
+ nw_get_osfhandle
+ nw_abort
+ nw_sleep
+ nw_wait
+ nw_dynaload
+ nw_strerror
+ fnFpSetMode
+ fnInsertHashListAddrs
+ fnGetHashListAddrs
+ Perl_deb
+ ))
+ {
+ try_symbol($symbol);
+ }
+ }
# Now all symbols should be defined because
# next we are going to output them.
***************
*** 867,872 ****
--- 1087,1099 ----
output_symbol($symbol);
}
+ if ($PLATFORM eq 'netware') {
+ # This may not be the right way to do. This is to make sure
+ # that the last symbol will not contain a comma else
+ # Watcom linker cribs
+ print "\tdummy\n";
+ }
+
sub emit_symbol {
my $symbol = shift;
chomp($symbol);
***************
*** 873,878 ****
--- 1100,1107 ----
$export{$symbol} = 1;
}
+ my $sym_ord = 0;
+
sub output_symbol {
my $symbol = shift;
$symbol = $bincompat5005{$symbol}
***************
*** 903,913 ****
# }
}
elsif ($PLATFORM eq 'os2') {
! print qq( "$symbol"\n);
}
elsif ($PLATFORM eq 'aix' || $PLATFORM eq 'MacOS') {
print "$symbol\n";
}
}
1;
--- 1132,1145 ----
# }
}
elsif ($PLATFORM eq 'os2') {
! printf qq( %-31s \@%s\n), qq("$symbol"), ++$sym_ord;
}
elsif ($PLATFORM eq 'aix' || $PLATFORM eq 'MacOS') {
print "$symbol\n";
}
+ elsif ($PLATFORM eq 'netware') {
+ print "\t$symbol,\n";
+ }
}
1;
diff -c 'perl-5.7.1/makedepend.SH' 'perl-5.7.2/makedepend.SH'
Index: ./makedepend.SH
*** ./makedepend.SH Sun Mar 11 18:30:08 2001
--- ./makedepend.SH Mon Jul 9 17:11:05 2001
***************
*** 1,5 ****
#! /bin/sh
! case $CONFIGDOTSH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
--- 1,5 ----
#! /bin/sh
! case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
***************
*** 18,23 ****
--- 18,27 ----
*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
esac
+ case "$osname" in
+ amigaos) cat=/bin/cat ;; # must be absolute
+ esac
+
echo "Extracting makedepend (with variable substitutions)"
rm -f makedepend
$spitshell >makedepend <<!GROK!THIS!
***************
*** 37,43 ****
export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$)
! case $CONFIGDOTSH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
--- 41,47 ----
export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$)
! case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
diff -c 'perl-5.7.1/makedir.SH' 'perl-5.7.2/makedir.SH'
Index: ./makedir.SH
*** ./makedir.SH Tue Mar 6 04:06:12 2001
--- ./makedir.SH Mon Jul 9 17:11:05 2001
***************
*** 1,4 ****
! case $CONFIGDOTSH in
'')
if test ! -f config.sh; then
ln ../config.sh . || \
--- 1,4 ----
! case $PERL_CONFIG_SH in
'')
if test ! -f config.sh; then
ln ../config.sh . || \
diff -c 'perl-5.7.1/malloc.c' 'perl-5.7.2/malloc.c'
Index: ./malloc.c
*** ./malloc.c Fri Mar 9 03:19:24 2001
--- ./malloc.c Mon Jul 9 17:11:05 2001
***************
*** 304,310 ****
# ifndef pTHX
# define pTHX void
# define pTHX_
! # define dTHX extern int Perl___notused
# define WITH_THX(s) s
# endif
# ifndef PERL_GET_INTERP
--- 304,314 ----
# ifndef pTHX
# define pTHX void
# define pTHX_
! # ifdef HASATTRIBUTE
! # define dTHX extern int Perl___notused PERL_UNUSED_DECL
! # else
! # define dTHX extern int Perl___notused
! # endif
# define WITH_THX(s) s
# endif
# ifndef PERL_GET_INTERP
***************
*** 1041,1047 ****
--- 1045,1053 ----
POW2_OPTIMIZE_ADJUST(nbytes);
nbytes += M_OVERHEAD;
nbytes = (nbytes + 3) &~ 3;
+ #if defined(PACK_MALLOC) && !defined(SMALL_BUCKET_VIA_TABLE)
do_shifts:
+ #endif
shiftr = (nbytes - 1) >> START_SHIFT;
bucket = START_SHIFTS_BUCKET;
/* apart from this loop, this is O(1) */
diff -c 'perl-5.7.1/mg.c' 'perl-5.7.2/mg.c'
Index: ./mg.c
*** ./mg.c Sat Mar 31 08:26:20 2001
--- ./mg.c Mon Jul 9 17:11:05 2001
***************
*** 20,25 ****
--- 20,28 ----
# ifndef NGROUPS
# define NGROUPS 32
# endif
+ # ifdef I_GRP
+ # include <grp.h>
+ # endif
#endif
static void restore_magic(pTHXo_ void *p);
***************
*** 42,48 ****
MGS* mgs;
assert(SvMAGICAL(sv));
! SAVEDESTRUCTOR_X(restore_magic, (void*)mgs_ix);
mgs = SSPTR(mgs_ix, MGS*);
mgs->mgs_sv = sv;
--- 45,51 ----
MGS* mgs;
assert(SvMAGICAL(sv));
! SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix));
mgs = SSPTR(mgs_ix, MGS*);
mgs->mgs_sv = sv;
***************
*** 51,57 ****
SvMAGICAL_off(sv);
SvREADONLY_off(sv);
! SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
}
/*
--- 54,60 ----
SvMAGICAL_off(sv);
SvREADONLY_off(sv);
! SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
}
/*
***************
*** 117,123 ****
mgp = &SvMAGIC(sv); /* Re-establish pointer after sv_upgrade */
}
! restore_magic(aTHXo_ (void*)mgs_ix);
return 0;
}
--- 120,126 ----
mgp = &SvMAGIC(sv); /* Re-establish pointer after sv_upgrade */
}
! restore_magic(aTHXo_ INT2PTR(void*, (IV)mgs_ix));
return 0;
}
***************
*** 150,156 ****
CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
}
! restore_magic(aTHXo_ (void*)mgs_ix);
return 0;
}
--- 153,159 ----
CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
}
! restore_magic(aTHXo_ INT2PTR(void*, (IV)mgs_ix));
return 0;
}
***************
*** 166,172 ****
Perl_mg_length(pTHX_ SV *sv)
{
MAGIC* mg;
- char *junk;
STRLEN len;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
--- 169,174 ----
***************
*** 178,189 ****
save_magic(mgs_ix, sv);
/* omit MGf_GSKIP -- not changed here */
len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
! restore_magic(aTHXo_ (void*)mgs_ix);
return len;
}
}
! junk = SvPV(sv, len);
return len;
}
--- 180,191 ----
save_magic(mgs_ix, sv);
/* omit MGf_GSKIP -- not changed here */
len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
! restore_magic(aTHXo_ INT2PTR(void*, (IV)mgs_ix));
return len;
}
}
! (void)SvPV(sv, len);
return len;
}
***************
*** 202,208 ****
save_magic(mgs_ix, sv);
/* omit MGf_GSKIP -- not changed here */
len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
! restore_magic(aTHXo_ (void*)mgs_ix);
return len;
}
}
--- 204,210 ----
save_magic(mgs_ix, sv);
/* omit MGf_GSKIP -- not changed here */
len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
! restore_magic(aTHXo_ INT2PTR(void*, (IV)mgs_ix));
return len;
}
}
***************
*** 245,251 ****
CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
}
! restore_magic(aTHXo_ (void*)mgs_ix);
return 0;
}
--- 247,253 ----
CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
}
! restore_magic(aTHXo_ INT2PTR(void*, (IV)mgs_ix));
return 0;
}
***************
*** 286,293 ****
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
if (isUPPER(mg->mg_type)) {
sv_magic(nsv,
! mg->mg_type == 'P' ? SvTIED_obj(sv, mg) :
! (mg->mg_type == 'D' && mg->mg_obj) ? sv : mg->mg_obj,
toLOWER(mg->mg_type), key, klen);
count++;
}
--- 288,296 ----
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
if (isUPPER(mg->mg_type)) {
sv_magic(nsv,
! mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
! (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
! ? sv : mg->mg_obj,
toLOWER(mg->mg_type), key, klen);
count++;
}
***************
*** 313,319 ****
moremagic = mg->mg_moremagic;
if (vtbl && vtbl->svt_free)
CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
! if (mg->mg_ptr && mg->mg_type != 'g') {
if (mg->mg_len >= 0)
Safefree(mg->mg_ptr);
else if (mg->mg_len == HEf_SVKEY)
--- 316,322 ----
moremagic = mg->mg_moremagic;
if (vtbl && vtbl->svt_free)
CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
! if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
if (mg->mg_len >= 0)
Safefree(mg->mg_ptr);
else if (mg->mg_len == HEf_SVKEY)
***************
*** 337,343 ****
{
register REGEXP *rx;
! if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
if (mg->mg_obj) /* @+ */
return rx->nparens;
else /* @- */
--- 340,346 ----
{
register REGEXP *rx;
! if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
if (mg->mg_obj) /* @+ */
return rx->nparens;
else /* @- */
***************
*** 356,362 ****
register REGEXP *rx;
I32 t;
! if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
paren = mg->mg_len;
if (paren < 0)
return 0;
--- 359,365 ----
register REGEXP *rx;
I32 t;
! if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
paren = mg->mg_len;
if (paren < 0)
return 0;
***************
*** 371,379 ****
if (i > 0 && DO_UTF8(PL_reg_sv)) {
char *b = rx->subbeg;
! i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
}
! sv_setiv(sv,i);
}
}
return 0;
--- 374,384 ----
if (i > 0 && DO_UTF8(PL_reg_sv)) {
char *b = rx->subbeg;
! if (b)
! i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
}
!
! sv_setiv(sv, i);
}
}
return 0;
***************
*** 398,404 ****
switch (*mg->mg_ptr) {
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
! if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
paren = atoi(mg->mg_ptr); /* $& is in [0] */
getparen:
--- 403,409 ----
switch (*mg->mg_ptr) {
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
! if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
paren = atoi(mg->mg_ptr); /* $& is in [0] */
getparen:
***************
*** 423,436 ****
}
return 0;
case '+':
! if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
paren = rx->lastparen;
if (paren)
goto getparen;
}
return 0;
case '`':
! if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
if (rx->startp[0] != -1) {
i = rx->startp[0];
if (i > 0) {
--- 428,448 ----
}
return 0;
case '+':
! if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
paren = rx->lastparen;
if (paren)
goto getparen;
}
return 0;
+ case '\016': /* ^N */
+ if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
+ paren = rx->lastcloseparen;
+ if (paren)
+ goto getparen;
+ }
+ return 0;
case '`':
! if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
if (rx->startp[0] != -1) {
i = rx->startp[0];
if (i > 0) {
***************
*** 442,448 ****
}
return 0;
case '\'':
! if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
if (rx->endp[0] != -1) {
i = rx->sublen - rx->endp[0];
if (i > 0) {
--- 454,460 ----
}
return 0;
case '\'':
! if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
if (rx->endp[0] != -1) {
i = rx->sublen - rx->endp[0];
if (i > 0) {
***************
*** 575,580 ****
--- 587,594 ----
(void)SvOK_off(sv);
else if (PL_in_eval)
sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
+ else
+ sv_setiv(sv, 0);
}
break;
case '\024': /* ^T */
***************
*** 606,612 ****
break;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
! if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
I32 s1, t1;
/*
--- 620,626 ----
break;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
! if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
I32 s1, t1;
/*
***************
*** 626,638 ****
getrx:
if (i >= 0) {
! bool was_tainted;
if (PL_tainting) {
was_tainted = PL_tainted;
PL_tainted = FALSE;
}
sv_setpvn(sv, s, i);
! if (DO_UTF8(PL_reg_sv) && is_utf8_string((U8*)s, i))
SvUTF8_on(sv);
else
SvUTF8_off(sv);
--- 640,652 ----
getrx:
if (i >= 0) {
! bool was_tainted = FALSE;
if (PL_tainting) {
was_tainted = PL_tainted;
PL_tainted = FALSE;
}
sv_setpvn(sv, s, i);
! if (PL_reg_sv && DO_UTF8(PL_reg_sv) && is_utf8_string((U8*)s, i))
SvUTF8_on(sv);
else
SvUTF8_off(sv);
***************
*** 645,651 ****
sv_setsv(sv,&PL_sv_undef);
break;
case '+':
! if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
paren = rx->lastparen;
if (paren)
goto getparen;
--- 659,665 ----
sv_setsv(sv,&PL_sv_undef);
break;
case '+':
! if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
paren = rx->lastparen;
if (paren)
goto getparen;
***************
*** 652,659 ****
}
sv_setsv(sv,&PL_sv_undef);
break;
case '`':
! if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
if ((s = rx->subbeg) && rx->startp[0] != -1) {
i = rx->startp[0];
goto getrx;
--- 666,681 ----
}
sv_setsv(sv,&PL_sv_undef);
break;
+ case '\016': /* ^N */
+ if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
+ paren = rx->lastcloseparen;
+ if (paren)
+ goto getparen;
+ }
+ sv_setsv(sv,&PL_sv_undef);
+ break;
case '`':
! if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
if ((s = rx->subbeg) && rx->startp[0] != -1) {
i = rx->startp[0];
goto getrx;
***************
*** 662,668 ****
sv_setsv(sv,&PL_sv_undef);
break;
case '\'':
! if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
if (rx->subbeg && rx->endp[0] != -1) {
s = rx->subbeg + rx->endp[0];
i = rx->sublen - rx->endp[0];
--- 684,690 ----
sv_setsv(sv,&PL_sv_undef);
break;
case '\'':
! if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
if (rx->subbeg && rx->endp[0] != -1) {
s = rx->subbeg + rx->endp[0];
i = rx->sublen - rx->endp[0];
***************
*** 674,680 ****
case '.':
#ifndef lint
if (GvIO(PL_last_in_gv)) {
! sv_setiv(sv, (IV)IoLINES(GvIO(PL_last_in_gv)));
}
#endif
break;
--- 696,702 ----
case '.':
#ifndef lint
if (GvIO(PL_last_in_gv)) {
! sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
}
#endif
break;
***************
*** 1037,1043 ****
{
register char *s;
I32 i;
! SV** svp;
STRLEN len;
s = MgPV(mg,len);
--- 1059,1065 ----
{
register char *s;
I32 i;
! SV** svp = 0;
STRLEN len;
s = MgPV(mg,len);
***************
*** 1125,1143 ****
Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
{
HV *hv = (HV*)LvTARG(sv);
- HE *entry;
I32 i = 0;
!
if (hv) {
! (void) hv_iterinit(hv);
! if (! SvTIED_mg((SV*)hv, 'P'))
! i = HvKEYS(hv);
! else {
! /*SUPPRESS 560*/
! while ((entry = hv_iternext(hv))) {
! i++;
! }
! }
}
sv_setiv(sv, (IV)i);
--- 1147,1162 ----
Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
{
HV *hv = (HV*)LvTARG(sv);
I32 i = 0;
!
if (hv) {
! (void) hv_iterinit(hv);
! if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
! i = HvKEYS(hv);
! else {
! while (hv_iternext(hv))
! i++;
! }
}
sv_setiv(sv, (IV)i);
***************
*** 1169,1175 ****
else if (mg->mg_len == HEf_SVKEY)
PUSHs((SV*)mg->mg_ptr);
}
! else if (mg->mg_type == 'p') {
PUSHs(sv_2mortal(newSViv(mg->mg_len)));
}
}
--- 1188,1194 ----
else if (mg->mg_len == HEf_SVKEY)
PUSHs((SV*)mg->mg_ptr);
}
! else if (mg->mg_type == PERL_MAGIC_tiedelem) {
PUSHs(sv_2mortal(newSViv(mg->mg_len)));
}
}
***************
*** 1332,1338 ****
SV* lsv = LvTARG(sv);
if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
! mg = mg_find(lsv, 'g');
if (mg && mg->mg_len >= 0) {
I32 i = mg->mg_len;
if (DO_UTF8(lsv))
--- 1351,1357 ----
SV* lsv = LvTARG(sv);
if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
! mg = mg_find(lsv, PERL_MAGIC_regex_global);
if (mg && mg->mg_len >= 0) {
I32 i = mg->mg_len;
if (DO_UTF8(lsv))
***************
*** 1356,1367 ****
mg = 0;
if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
! mg = mg_find(lsv, 'g');
if (!mg) {
if (!SvOK(sv))
return 0;
! sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
! mg = mg_find(lsv, 'g');
}
else if (!SvOK(sv)) {
mg->mg_len = -1;
--- 1375,1386 ----
mg = 0;
if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
! mg = mg_find(lsv, PERL_MAGIC_regex_global);
if (!mg) {
if (!SvOK(sv))
return 0;
! sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
! mg = mg_find(lsv, PERL_MAGIC_regex_global);
}
else if (!SvOK(sv)) {
mg->mg_len = -1;
***************
*** 1581,1587 ****
MAGIC *mg;
SV *value = Nullsv;
! if (!LvTARGLEN(sv) || !(mg = mg_find(sv, 'y')))
return;
if (mg->mg_obj) {
SV *ahv = LvTARG(sv);
--- 1600,1606 ----
MAGIC *mg;
SV *value = Nullsv;
! if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
return;
if (mg->mg_obj) {
SV *ahv = LvTARG(sv);
***************
*** 1650,1656 ****
int
Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
{
! sv_unmagic(sv, 'B');
SvVALID_off(sv);
return 0;
}
--- 1669,1675 ----
int
Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
{
! sv_unmagic(sv, PERL_MAGIC_bm);
SvVALID_off(sv);
return 0;
}
***************
*** 1658,1664 ****
int
Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
{
! sv_unmagic(sv, 'f');
SvCOMPILED_off(sv);
return 0;
}
--- 1677,1683 ----
int
Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
{
! sv_unmagic(sv, PERL_MAGIC_fm);
SvCOMPILED_off(sv);
return 0;
}
***************
*** 1726,1732 ****
# ifdef WIN32
SetLastError( SvIV(sv) );
# else
! # ifndef OS2
/* will anyone ever use this? */
SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
# endif
--- 1745,1753 ----
# ifdef WIN32
SetLastError( SvIV(sv) );
# else
! # ifdef OS2
! os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
! # else
/* will anyone ever use this? */
SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
# endif
***************
*** 2153,2159 ****
{
DEBUG_S(PerlIO_printf(Perl_debug_log,
"0x%"UVxf": magic_mutexfree 0x%"UVxf"\n",
! PTR2UV(thr), PTR2UV(sv));)
if (MgOWNER(mg))
Perl_croak(aTHX_ "panic: magic_mutexfree");
MUTEX_DESTROY(MgMUTEXP(mg));
--- 2174,2180 ----
{
DEBUG_S(PerlIO_printf(Perl_debug_log,
"0x%"UVxf": magic_mutexfree 0x%"UVxf"\n",
! PTR2UV(thr), PTR2UV(sv)));
if (MgOWNER(mg))
Perl_croak(aTHX_ "panic: magic_mutexfree");
MUTEX_DESTROY(MgMUTEXP(mg));
***************
*** 2194,2204 ****
dSP;
GV *gv = Nullgv;
HV *st;
! SV *sv, *tSv = PL_Sv;
CV *cv = Nullcv;
OP *myop = PL_op;
U32 flags = 0;
- I32 o_save_i = PL_savestack_ix;
XPV *tXpv = PL_Xpv;
#if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT)
--- 2215,2224 ----
dSP;
GV *gv = Nullgv;
HV *st;
! SV *sv = Nullsv, *tSv = PL_Sv;
CV *cv = Nullcv;
OP *myop = PL_op;
U32 flags = 0;
XPV *tXpv = PL_Xpv;
#if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT)
***************
*** 2222,2228 ****
infinity, so we fix 4 (in fact 5): */
if (flags & 1) {
PL_savestack_ix += 5; /* Protect save in progress. */
- o_save_i = PL_savestack_ix;
SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
}
if (flags & 4)
--- 2242,2247 ----
diff -c 'perl-5.7.1/miniperlmain.c' 'perl-5.7.2/miniperlmain.c'
Index: ./miniperlmain.c
*** ./miniperlmain.c Mon Mar 26 21:35:05 2001
--- ./miniperlmain.c Thu Jul 12 04:33:36 2001
***************
*** 42,48 ****
--- 42,58 ----
#undef PERLVARIC
#endif
+ /* if user wants control of gprof profiling off by default */
+ /* noop unless Configure is given -Accflags=-DPERL_GPROF_CONTROL */
+ PERL_GPROF_MONCONTROL(0);
+
PERL_SYS_INIT3(&argc,&argv,&env);
+
+ #ifdef USE_ITHREADS
+ PTHREAD_ATFORK(Perl_atfork_lock,
+ Perl_atfork_unlock,
+ Perl_atfork_unlock);
+ #endif
if (!PL_do_undump) {
my_perl = perl_alloc();
diff -c 'perl-5.7.1/mpeix/mpeixish.h' 'perl-5.7.2/mpeix/mpeixish.h'
Index: ./mpeix/mpeixish.h
*** ./mpeix/mpeixish.h Tue Mar 6 04:06:13 2001
--- ./mpeix/mpeixish.h Mon Jul 9 17:11:06 2001
***************
*** 113,125 ****
#define Mkdir(path,mode) mkdir((path),(mode))
#ifndef PERL_SYS_INIT
! #ifdef PERL_SCO5
! /* this should be set in a hint file, not here */
! # define PERL_SYS_INIT(c,v) fpsetmask(0); MALLOC_INIT
! #else
! # define PERL_SYS_INIT(c,v) MALLOC_INIT
#endif
- #endif
#ifndef PERL_SYS_TERM
#define PERL_SYS_TERM() MALLOC_TERM
--- 113,120 ----
#define Mkdir(path,mode) mkdir((path),(mode))
#ifndef PERL_SYS_INIT
! # define PERL_SYS_INIT(c,v) PERL_FPU_INIT MALLOC_INIT
#endif
#ifndef PERL_SYS_TERM
#define PERL_SYS_TERM() MALLOC_TERM
***************
*** 137,139 ****
--- 132,142 ----
#undef PRPASSWD
#undef PWAGE
#undef PWCOMMENT
+
+ /* various missing external function declarations */
+
+ #include <sys/ipc.h>
+ extern key_t ftok (char *pathname, char id);
+ extern char *gcvt (double value, int ndigit, char *buf);
+ extern int isnan (double value);
+ extern void srand48(long int seedval);
diff -c 'perl-5.7.1/mpeix/relink' 'perl-5.7.2/mpeix/relink'
Index: ./mpeix/relink
*** ./mpeix/relink Tue Mar 6 04:06:13 2001
--- ./mpeix/relink Mon Jul 9 17:11:06 2001
***************
*** 8,13 ****
lib/auto/DynaLoader/DynaLoader.a \
libperl.a \
`cat ext.libs` \
! -L/BIND/PUB/lib -lbind \
-L/SYSLOG/PUB -lsyslog
callci 'linkedit "altprog ./perl;xl=/usr/lib/libcurses.sl,/lib/libsvipc.sl,/usr/lib/libsocket.sl,/usr/lib/libstr.sl,/lib/libm.sl,/lib/libc.sl"'
--- 8,13 ----
lib/auto/DynaLoader/DynaLoader.a \
libperl.a \
`cat ext.libs` \
! -L/BINDFW/CURRENT/lib -lbind \
-L/SYSLOG/PUB -lsyslog
callci 'linkedit "altprog ./perl;xl=/usr/lib/libcurses.sl,/lib/libsvipc.sl,/usr/lib/libsocket.sl,/usr/lib/libstr.sl,/lib/libm.sl,/lib/libc.sl"'
diff -c 'perl-5.7.1/myconfig.SH' 'perl-5.7.2/myconfig.SH'
Index: ./myconfig.SH
*** ./myconfig.SH Tue Mar 6 04:06:13 2001
--- ./myconfig.SH Fri Jul 13 08:51:39 2001
***************
*** 1,4 ****
! case $CONFIGDOTSH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
--- 1,4 ----
! case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
***************
*** 27,33 ****
# Note that the text lines /^Summary of/ .. /^\s*$/ are copied into Config.pm.
cat <<'!NO!SUBS!'
! Summary of my $package (revision $baserev version $PERL_VERSION subversion $PERL_SUBVERSION) configuration:
Platform:
osname=$osname, osvers=$osvers, archname=$archname
uname='$myuname'
--- 27,33 ----
# Note that the text lines /^Summary of/ .. /^\s*$/ are copied into Config.pm.
cat <<'!NO!SUBS!'
! Summary of my $package (revision $baserev $version_patchlevel_string) configuration:
Platform:
osname=$osname, osvers=$osvers, archname=$archname
uname='$myuname'
***************
*** 44,50 ****
intsize=$intsize, longsize=$longsize, ptrsize=$ptrsize, doublesize=$doublesize, byteorder=$byteorder
d_longlong=$d_longlong, longlongsize=$longlongsize, d_longdbl=$d_longdbl, longdblsize=$longdblsize
ivtype='$ivtype', ivsize=$ivsize, nvtype='$nvtype', nvsize=$nvsize, Off_t='$lseektype', lseeksize=$lseeksize
! alignbytes=$alignbytes, usemymalloc=$usemymalloc, prototype=$prototype
Linker and Libraries:
ld='$ld', ldflags ='$ldflags'
libpth=$libpth
--- 44,50 ----
intsize=$intsize, longsize=$longsize, ptrsize=$ptrsize, doublesize=$doublesize, byteorder=$byteorder
d_longlong=$d_longlong, longlongsize=$longlongsize, d_longdbl=$d_longdbl, longdblsize=$longdblsize
ivtype='$ivtype', ivsize=$ivsize, nvtype='$nvtype', nvsize=$nvsize, Off_t='$lseektype', lseeksize=$lseeksize
! alignbytes=$alignbytes, usemymalloc=$usemymalloc, prototype=$prototype, bincompat5005=$d_bincompat5005
Linker and Libraries:
ld='$ld', ldflags ='$ldflags'
libpth=$libpth
diff -c /dev/null 'perl-5.7.2/numeric.c'
Index: ./numeric.c
*** ./numeric.c Thu Jan 1 02:00:00 1970
--- ./numeric.c Mon Jul 9 17:11:06 2001
***************
*** 0 ****
--- 1,735 ----
+ /* numeric.c
+ *
+ * Copyright (c) 2001, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ /*
+ * "That only makes eleven (plus one mislaid) and not fourteen, unless
+ * wizards count differently to other people."
+ */
+
+ #include "EXTERN.h"
+ #define PERL_IN_NUMERIC_C
+ #include "perl.h"
+
+ U32
+ Perl_cast_ulong(pTHX_ NV f)
+ {
+ if (f < 0.0)
+ return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f;
+ if (f < U32_MAX_P1) {
+ #if CASTFLAGS & 2
+ if (f < U32_MAX_P1_HALF)
+ return (U32) f;
+ f -= U32_MAX_P1_HALF;
+ return ((U32) f) | (1 + U32_MAX >> 1);
+ #else
+ return (U32) f;
+ #endif
+ }
+ return f > 0 ? U32_MAX : 0 /* NaN */;
+ }
+
+ I32
+ Perl_cast_i32(pTHX_ NV f)
+ {
+ if (f < I32_MAX_P1)
+ return f < I32_MIN ? I32_MIN : (I32) f;
+ if (f < U32_MAX_P1) {
+ #if CASTFLAGS & 2
+ if (f < U32_MAX_P1_HALF)
+ return (I32)(U32) f;
+ f -= U32_MAX_P1_HALF;
+ return (I32)(((U32) f) | (1 + U32_MAX >> 1));
+ #else
+ return (I32)(U32) f;
+ #endif
+ }
+ return f > 0 ? (I32)U32_MAX : 0 /* NaN */;
+ }
+
+ IV
+ Perl_cast_iv(pTHX_ NV f)
+ {
+ if (f < IV_MAX_P1)
+ return f < IV_MIN ? IV_MIN : (IV) f;
+ if (f < UV_MAX_P1) {
+ #if CASTFLAGS & 2
+ /* For future flexibility allowing for sizeof(UV) >= sizeof(IV) */
+ if (f < UV_MAX_P1_HALF)
+ return (IV)(UV) f;
+ f -= UV_MAX_P1_HALF;
+ return (IV)(((UV) f) | (1 + UV_MAX >> 1));
+ #else
+ return (IV)(UV) f;
+ #endif
+ }
+ return f > 0 ? (IV)UV_MAX : 0 /* NaN */;
+ }
+
+ UV
+ Perl_cast_uv(pTHX_ NV f)
+ {
+ if (f < 0.0)
+ return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f;
+ if (f < UV_MAX_P1) {
+ #if CASTFLAGS & 2
+ if (f < UV_MAX_P1_HALF)
+ return (UV) f;
+ f -= UV_MAX_P1_HALF;
+ return ((UV) f) | (1 + UV_MAX >> 1);
+ #else
+ return (UV) f;
+ #endif
+ }
+ return f > 0 ? UV_MAX : 0 /* NaN */;
+ }
+
+ #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
+ /*
+ * This hack is to force load of "huge" support from libm.a
+ * So it is in perl for (say) POSIX to use.
+ * Needed for SunOS with Sun's 'acc' for example.
+ */
+ NV
+ Perl_huge(void)
+ {
+ # if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
+ return HUGE_VALL;
+ # endif
+ return HUGE_VAL;
+ }
+ #endif
+
+ NV
+ Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen)
+ {
+ register char *s = start;
+ register NV rnv = 0.0;
+ register UV ruv = 0;
+ register bool seenb = FALSE;
+ register bool overflowed = FALSE;
+
+ for (; len-- && *s; s++) {
+ if (!(*s == '0' || *s == '1')) {
+ if (*s == '_' && len && *retlen
+ && (s[1] == '0' || s[1] == '1'))
+ {
+ --len;
+ ++s;
+ }
+ else if (seenb == FALSE && *s == 'b' && ruv == 0) {
+ /* Disallow 0bbb0b0bbb... */
+ seenb = TRUE;
+ continue;
+ }
+ else {
+ if (ckWARN(WARN_DIGIT))
+ Perl_warner(aTHX_ WARN_DIGIT,
+ "Illegal binary digit '%c' ignored", *s);
+ break;
+ }
+ }
+ if (!overflowed) {
+ register UV xuv = ruv << 1;
+
+ if ((xuv >> 1) != ruv) {
+ overflowed = TRUE;
+ rnv = (NV) ruv;
+ if (ckWARN_d(WARN_OVERFLOW))
+ Perl_warner(aTHX_ WARN_OVERFLOW,
+ "Integer overflow in binary number");
+ }
+ else
+ ruv = xuv | (*s - '0');
+ }
+ if (overflowed) {
+ rnv *= 2;
+ /* If an NV has not enough bits in its mantissa to
+ * represent an UV this summing of small low-order numbers
+ * is a waste of time (because the NV cannot preserve
+ * the low-order bits anyway): we could just remember when
+ * did we overflow and in the end just multiply rnv by the
+ * right amount. */
+ rnv += (*s - '0');
+ }
+ }
+ if (!overflowed)
+ rnv = (NV) ruv;
+ if ( ( overflowed && rnv > 4294967295.0)
+ #if UVSIZE > 4
+ || (!overflowed && ruv > 0xffffffff )
+ #endif
+ ) {
+ if (ckWARN(WARN_PORTABLE))
+ Perl_warner(aTHX_ WARN_PORTABLE,
+ "Binary number > 0b11111111111111111111111111111111 non-portable");
+ }
+ *retlen = s - start;
+ return rnv;
+ }
+
+ NV
+ Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen)
+ {
+ register char *s = start;
+ register NV rnv = 0.0;
+ register UV ruv = 0;
+ register bool overflowed = FALSE;
+
+ for (; len-- && *s; s++) {
+ if (!(*s >= '0' && *s <= '7')) {
+ if (*s == '_' && len && *retlen
+ && (s[1] >= '0' && s[1] <= '7'))
+ {
+ --len;
+ ++s;
+ }
+ else {
+ /* Allow \octal to work the DWIM way (that is, stop scanning
+ * as soon as non-octal characters are seen, complain only iff
+ * someone seems to want to use the digits eight and nine). */
+ if (*s == '8' || *s == '9') {
+ if (ckWARN(WARN_DIGIT))
+ Perl_warner(aTHX_ WARN_DIGIT,
+ "Illegal octal digit '%c' ignored", *s);
+ }
+ break;
+ }
+ }
+ if (!overflowed) {
+ register UV xuv = ruv << 3;
+
+ if ((xuv >> 3) != ruv) {
+ overflowed = TRUE;
+ rnv = (NV) ruv;
+ if (ckWARN_d(WARN_OVERFLOW))
+ Perl_warner(aTHX_ WARN_OVERFLOW,
+ "Integer overflow in octal number");
+ }
+ else
+ ruv = xuv | (*s - '0');
+ }
+ if (overflowed) {
+ rnv *= 8.0;
+ /* If an NV has not enough bits in its mantissa to
+ * represent an UV this summing of small low-order numbers
+ * is a waste of time (because the NV cannot preserve
+ * the low-order bits anyway): we could just remember when
+ * did we overflow and in the end just multiply rnv by the
+ * right amount of 8-tuples. */
+ rnv += (NV)(*s - '0');
+ }
+ }
+ if (!overflowed)
+ rnv = (NV) ruv;
+ if ( ( overflowed && rnv > 4294967295.0)
+ #if UVSIZE > 4
+ || (!overflowed && ruv > 0xffffffff )
+ #endif
+ ) {
+ if (ckWARN(WARN_PORTABLE))
+ Perl_warner(aTHX_ WARN_PORTABLE,
+ "Octal number > 037777777777 non-portable");
+ }
+ *retlen = s - start;
+ return rnv;
+ }
+
+ NV
+ Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen)
+ {
+ register char *s = start;
+ register NV rnv = 0.0;
+ register UV ruv = 0;
+ register bool overflowed = FALSE;
+ char *hexdigit;
+
+ if (len > 2) {
+ if (s[0] == 'x') {
+ s++;
+ len--;
+ }
+ else if (len > 3 && s[0] == '0' && s[1] == 'x') {
+ s+=2;
+ len-=2;
+ }
+ }
+
+ for (; len-- && *s; s++) {
+ hexdigit = strchr((char *) PL_hexdigit, *s);
+ if (!hexdigit) {
+ if (*s == '_' && len && *retlen && s[1]
+ && (hexdigit = strchr((char *) PL_hexdigit, s[1])))
+ {
+ --len;
+ ++s;
+ }
+ else {
+ if (ckWARN(WARN_DIGIT))
+ Perl_warner(aTHX_ WARN_DIGIT,
+ "Illegal hexadecimal digit '%c' ignored", *s);
+ break;
+ }
+ }
+ if (!overflowed) {
+ register UV xuv = ruv << 4;
+
+ if ((xuv >> 4) != ruv) {
+ overflowed = TRUE;
+ rnv = (NV) ruv;
+ if (ckWARN_d(WARN_OVERFLOW))
+ Perl_warner(aTHX_ WARN_OVERFLOW,
+ "Integer overflow in hexadecimal number");
+ }
+ else
+ ruv = xuv | ((hexdigit - PL_hexdigit) & 15);
+ }
+ if (overflowed) {
+ rnv *= 16.0;
+ /* If an NV has not enough bits in its mantissa to
+ * represent an UV this summing of small low-order numbers
+ * is a waste of time (because the NV cannot preserve
+ * the low-order bits anyway): we could just remember when
+ * did we overflow and in the end just multiply rnv by the
+ * right amount of 16-tuples. */
+ rnv += (NV)((hexdigit - PL_hexdigit) & 15);
+ }
+ }
+ if (!overflowed)
+ rnv = (NV) ruv;
+ if ( ( overflowed && rnv > 4294967295.0)
+ #if UVSIZE > 4
+ || (!overflowed && ruv > 0xffffffff )
+ #endif
+ ) {
+ if (ckWARN(WARN_PORTABLE))
+ Perl_warner(aTHX_ WARN_PORTABLE,
+ "Hexadecimal number > 0xffffffff non-portable");
+ }
+ *retlen = s - start;
+ return rnv;
+ }
+
+ /*
+ =for apidoc grok_numeric_radix
+
+ Scan and skip for a numeric decimal separator (radix).
+
+ =cut
+ */
+ bool
+ Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
+ {
+ #ifdef USE_LOCALE_NUMERIC
+ if (PL_numeric_radix_sv && IN_LOCALE) {
+ STRLEN len;
+ char* radix = SvPV(PL_numeric_radix_sv, len);
+ if (*sp + len <= send && memEQ(*sp, radix, len)) {
+ *sp += len;
+ return TRUE;
+ }
+ }
+ /* always try "." if numeric radix didn't match because
+ * we may have data from different locales mixed */
+ #endif
+ if (*sp < send && **sp == '.') {
+ ++*sp;
+ return TRUE;
+ }
+ return FALSE;
+ }
+
+ /*
+ =for apidoc grok_number
+
+ Recognise (or not) a number. The type of the number is returned
+ (0 if unrecognised), otherwise it is a bit-ORed combination of
+ IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT,
+ IS_NUMBER_NEG, IS_NUMBER_INFINITY (defined in perl.h).
+
+ If the value of the number can fit an in UV, it is returned in the *valuep
+ IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV
+ will never be set unless *valuep is valid, but *valuep may have been assigned
+ to during processing even though IS_NUMBER_IN_UV is not set on return.
+ If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when
+ valuep is non-NULL, but no actual assignment (or SEGV) will occur.
+
+ IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were
+ seen (in which case *valuep gives the true value truncated to an integer), and
+ IS_NUMBER_NEG if the number is negative (in which case *valuep holds the
+ absolute value). IS_NUMBER_IN_UV is not set if e notation was used or the
+ number is larger than a UV.
+
+ =cut
+ */
+ int
+ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
+ {
+ const char *s = pv;
+ const char *send = pv + len;
+ const UV max_div_10 = UV_MAX / 10;
+ const char max_mod_10 = UV_MAX % 10;
+ int numtype = 0;
+ int sawinf = 0;
+
+ while (s < send && isSPACE(*s))
+ s++;
+ if (s == send) {
+ return 0;
+ } else if (*s == '-') {
+ s++;
+ numtype = IS_NUMBER_NEG;
+ }
+ else if (*s == '+')
+ s++;
+
+ if (s == send)
+ return 0;
+
+ /* next must be digit or the radix separator or beginning of infinity */
+ if (isDIGIT(*s)) {
+ /* UVs are at least 32 bits, so the first 9 decimal digits cannot
+ overflow. */
+ UV value = *s - '0';
+ /* This construction seems to be more optimiser friendly.
+ (without it gcc does the isDIGIT test and the *s - '0' separately)
+ With it gcc on arm is managing 6 instructions (6 cycles) per digit.
+ In theory the optimiser could deduce how far to unroll the loop
+ before checking for overflow. */
+ if (++s < send) {
+ int digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ /* Now got 9 digits, so need to check
+ each time for overflow. */
+ digit = *s - '0';
+ while (digit >= 0 && digit <= 9
+ && (value < max_div_10
+ || (value == max_div_10
+ && digit <= max_mod_10))) {
+ value = value * 10 + digit;
+ if (++s < send)
+ digit = *s - '0';
+ else
+ break;
+ }
+ if (digit >= 0 && digit <= 9
+ && (s < send)) {
+ /* value overflowed.
+ skip the remaining digits, don't
+ worry about setting *valuep. */
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ numtype |=
+ IS_NUMBER_GREATER_THAN_UV_MAX;
+ goto skip_value;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ numtype |= IS_NUMBER_IN_UV;
+ if (valuep)
+ *valuep = value;
+
+ skip_value:
+ if (GROK_NUMERIC_RADIX(&s, send)) {
+ numtype |= IS_NUMBER_NOT_INT;
+ while (s < send && isDIGIT(*s)) /* optional digits after the radix */
+ s++;
+ }
+ }
+ else if (GROK_NUMERIC_RADIX(&s, send)) {
+ numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
+ /* no digits before the radix means we need digits after it */
+ if (s < send && isDIGIT(*s)) {
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ if (valuep) {
+ /* integer approximation is valid - it's 0. */
+ *valuep = 0;
+ }
+ }
+ else
+ return 0;
+ } else if (*s == 'I' || *s == 'i') {
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
+ s++; if (s < send && (*s == 'I' || *s == 'i')) {
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
+ s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
+ s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
+ s++;
+ }
+ sawinf = 1;
+ } else /* Add test for NaN here. */
+ return 0;
+
+ if (sawinf) {
+ numtype &= IS_NUMBER_NEG; /* Keep track of sign */
+ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
+ } else if (s < send) {
+ /* we can have an optional exponent part */
+ if (*s == 'e' || *s == 'E') {
+ /* The only flag we keep is sign. Blow away any "it's UV" */
+ numtype &= IS_NUMBER_NEG;
+ numtype |= IS_NUMBER_NOT_INT;
+ s++;
+ if (s < send && (*s == '-' || *s == '+'))
+ s++;
+ if (s < send && isDIGIT(*s)) {
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ }
+ else
+ return 0;
+ }
+ }
+ while (s < send && isSPACE(*s))
+ s++;
+ if (s >= send)
+ return numtype;
+ if (len == 10 && memEQ(pv, "0 but true", 10)) {
+ if (valuep)
+ *valuep = 0;
+ return IS_NUMBER_IN_UV;
+ }
+ return 0;
+ }
+
+ NV
+ S_mulexp10(NV value, I32 exponent)
+ {
+ NV result = 1.0;
+ NV power = 10.0;
+ bool negative = 0;
+ I32 bit;
+
+ if (exponent == 0)
+ return value;
+ else if (exponent < 0) {
+ negative = 1;
+ exponent = -exponent;
+ }
+ #ifdef __VAX /* avoid %SYSTEM-F-FLTOVF_F sans VAXC$ESTABLISH */
+ # if defined(__DECC_VER) && __DECC_VER <= 50390006
+ /* __F_FLT_MAX_10_EXP - 5 == 33 */
+ if (!negative &&
+ (log10(value) + exponent) >= (__F_FLT_MAX_10_EXP - 5))
+ return NV_MAX;
+ # endif
+ #endif
+ for (bit = 1; exponent; bit <<= 1) {
+ if (exponent & bit) {
+ exponent ^= bit;
+ result *= power;
+ }
+ power *= power;
+ }
+ return negative ? value / result : value * result;
+ }
+
+ NV
+ Perl_my_atof(pTHX_ const char* s)
+ {
+ NV x = 0.0;
+ #ifdef USE_LOCALE_NUMERIC
+ if (PL_numeric_local && IN_LOCALE) {
+ NV y;
+
+ /* Scan the number twice; once using locale and once without;
+ * choose the larger result (in absolute value). */
+ Perl_atof2(aTHX_ s, &x);
+ SET_NUMERIC_STANDARD();
+ Perl_atof2(aTHX_ s, &y);
+ SET_NUMERIC_LOCAL();
+ if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
+ return y;
+ }
+ else
+ Perl_atof2(aTHX_ s, &x);
+ #else
+ Perl_atof2(aTHX_ s, &x);
+ #endif
+ return x;
+ }
+
+ char*
+ Perl_my_atof2(pTHX_ const char* orig, NV* value)
+ {
+ NV result = 0.0;
+ bool negative = 0;
+ char* s = (char*)orig;
+ char* send = s + strlen(orig) - 1;
+ bool seendigit = 0;
+ I32 expextra = 0;
+ I32 exponent = 0;
+ I32 i;
+ /* this is arbitrary */
+ #define PARTLIM 6
+ /* we want the largest integers we can usefully use */
+ #if defined(HAS_QUAD) && defined(USE_64_BIT_INT)
+ # define PARTSIZE ((int)TYPE_DIGITS(U64)-1)
+ U64 part[PARTLIM];
+ #else
+ # define PARTSIZE ((int)TYPE_DIGITS(U32)-1)
+ U32 part[PARTLIM];
+ #endif
+ I32 ipart = 0; /* index into part[] */
+ I32 offcount; /* number of digits in least significant part */
+
+ /* sign */
+ switch (*s) {
+ case '-':
+ negative = 1;
+ /* fall through */
+ case '+':
+ ++s;
+ }
+
+ part[0] = offcount = 0;
+ if (isDIGIT(*s)) {
+ seendigit = 1; /* get this over with */
+
+ /* skip leading zeros */
+ while (*s == '0')
+ ++s;
+ }
+
+ /* integer digits */
+ while (isDIGIT(*s)) {
+ if (++offcount > PARTSIZE) {
+ if (++ipart < PARTLIM) {
+ part[ipart] = 0;
+ offcount = 1; /* ++0 */
+ }
+ else {
+ /* limits of precision reached */
+ --ipart;
+ --offcount;
+ if (*s >= '5')
+ ++part[ipart];
+ while (isDIGIT(*s)) {
+ ++expextra;
+ ++s;
+ }
+ /* warn of loss of precision? */
+ break;
+ }
+ }
+ part[ipart] = part[ipart] * 10 + (*s++ - '0');
+ }
+
+ /* decimal point */
+ if (GROK_NUMERIC_RADIX((const char **)&s, send)) {
+ if (isDIGIT(*s))
+ seendigit = 1; /* get this over with */
+
+ /* decimal digits */
+ while (isDIGIT(*s)) {
+ if (++offcount > PARTSIZE) {
+ if (++ipart < PARTLIM) {
+ part[ipart] = 0;
+ offcount = 1; /* ++0 */
+ }
+ else {
+ /* limits of precision reached */
+ --ipart;
+ --offcount;
+ if (*s >= '5')
+ ++part[ipart];
+ while (isDIGIT(*s))
+ ++s;
+ /* warn of loss of precision? */
+ break;
+ }
+ }
+ --expextra;
+ part[ipart] = part[ipart] * 10 + (*s++ - '0');
+ }
+ }
+
+ /* combine components of mantissa */
+ for (i = 0; i <= ipart; ++i)
+ result += S_mulexp10((NV)part[ipart - i],
+ i ? offcount + (i - 1) * PARTSIZE : 0);
+
+ if (seendigit && (*s == 'e' || *s == 'E')) {
+ bool expnegative = 0;
+
+ ++s;
+ switch (*s) {
+ case '-':
+ expnegative = 1;
+ /* fall through */
+ case '+':
+ ++s;
+ }
+ while (isDIGIT(*s))
+ exponent = exponent * 10 + (*s++ - '0');
+ if (expnegative)
+ exponent = -exponent;
+ }
+
+ /* now apply the exponent */
+ exponent += expextra;
+ result = S_mulexp10(result, exponent);
+
+ /* now apply the sign */
+ if (negative)
+ result = -result;
+ *value = result;
+ return s;
+ }
+
diff -c 'perl-5.7.1/objXSUB.h' 'perl-5.7.2/objXSUB.h'
Index: ./objXSUB.h
*** ./objXSUB.h Fri Apr 6 16:42:03 2001
--- ./objXSUB.h Thu Jul 12 21:34:40 2001
***************
*** 579,584 ****
--- 579,588 ----
#define Perl_init_stacks pPerl->Perl_init_stacks
#undef init_stacks
#define init_stacks Perl_init_stacks
+ #undef Perl_init_tm
+ #define Perl_init_tm pPerl->Perl_init_tm
+ #undef init_tm
+ #define init_tm Perl_init_tm
#undef Perl_instr
#define Perl_instr pPerl->Perl_instr
#undef instr
***************
*** 791,796 ****
--- 795,804 ----
#define Perl_leave_scope pPerl->Perl_leave_scope
#undef leave_scope
#define leave_scope Perl_leave_scope
+ #undef Perl_op_null
+ #define Perl_op_null pPerl->Perl_op_null
+ #undef op_null
+ #define op_null Perl_op_null
#undef Perl_load_module
#define Perl_load_module pPerl->Perl_load_module
#undef load_module
***************
*** 803,808 ****
--- 811,824 ----
#define Perl_looks_like_number pPerl->Perl_looks_like_number
#undef looks_like_number
#define looks_like_number Perl_looks_like_number
+ #undef Perl_grok_number
+ #define Perl_grok_number pPerl->Perl_grok_number
+ #undef grok_number
+ #define grok_number Perl_grok_number
+ #undef Perl_grok_numeric_radix
+ #define Perl_grok_numeric_radix pPerl->Perl_grok_numeric_radix
+ #undef grok_numeric_radix
+ #define grok_numeric_radix Perl_grok_numeric_radix
#if defined(USE_THREADS)
#endif
#if defined(USE_LOCALE_COLLATE)
***************
*** 857,862 ****
--- 873,882 ----
#define Perl_mg_size pPerl->Perl_mg_size
#undef mg_size
#define mg_size Perl_mg_size
+ #undef Perl_mini_mktime
+ #define Perl_mini_mktime pPerl->Perl_mini_mktime
+ #undef mini_mktime
+ #define mini_mktime Perl_mini_mktime
#undef Perl_moreswitches
#define Perl_moreswitches pPerl->Perl_moreswitches
#undef moreswitches
***************
*** 865,871 ****
#define Perl_my_atof pPerl->Perl_my_atof
#undef my_atof
#define my_atof Perl_my_atof
! #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
#undef Perl_my_bcopy
#define Perl_my_bcopy pPerl->Perl_my_bcopy
#undef my_bcopy
--- 885,891 ----
#define Perl_my_atof pPerl->Perl_my_atof
#undef my_atof
#define my_atof Perl_my_atof
! #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
#undef Perl_my_bcopy
#define Perl_my_bcopy pPerl->Perl_my_bcopy
#undef my_bcopy
***************
*** 927,932 ****
--- 947,956 ----
#define Perl_my_stat pPerl->Perl_my_stat
#undef my_stat
#define my_stat Perl_my_stat
+ #undef Perl_my_strftime
+ #define Perl_my_strftime pPerl->Perl_my_strftime
+ #undef my_strftime
+ #define my_strftime Perl_my_strftime
#if defined(MYSWAP)
#undef Perl_my_swap
#define Perl_my_swap pPerl->Perl_my_swap
***************
*** 1319,1324 ****
--- 1343,1352 ----
#define Perl_rsignal pPerl->Perl_rsignal
#undef rsignal
#define rsignal Perl_rsignal
+ #undef Perl_rsignal_state
+ #define Perl_rsignal_state pPerl->Perl_rsignal_state
+ #undef rsignal_state
+ #define rsignal_state Perl_rsignal_state
#if !defined(HAS_RENAME)
#endif
#undef Perl_savepv
***************
*** 1629,1634 ****
--- 1657,1666 ----
#define Perl_sv_compile_2op pPerl->Perl_sv_compile_2op
#undef sv_compile_2op
#define sv_compile_2op Perl_sv_compile_2op
+ #undef Perl_getcwd_sv
+ #define Perl_getcwd_sv pPerl->Perl_getcwd_sv
+ #undef getcwd_sv
+ #define getcwd_sv Perl_getcwd_sv
#undef Perl_sv_dec
#define Perl_sv_dec pPerl->Perl_sv_dec
#undef sv_dec
***************
*** 2324,2329 ****
--- 2356,2363 ----
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
#endif
+ #if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
+ #endif
#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
#if defined(PERL_FLEXIBLE_EXCEPTIONS)
#endif
***************
*** 2335,2349 ****
# endif
#endif
#if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT)
#endif
#if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT)
#endif
#if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
#endif
#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
#endif
#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
! # if defined(DEBUGGING)
# endif
# if !defined(NV_PRESERVES_UV)
# endif
--- 2369,2387 ----
# endif
#endif
#if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT)
+ # ifdef DEBUGGING
+ # endif
#endif
#if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT)
#endif
#if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
+ # ifdef DEBUGGING
+ # endif
#endif
#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
#endif
#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
! # ifdef DEBUGGING
# endif
# if !defined(NV_PRESERVES_UV)
# endif
***************
*** 2351,2356 ****
--- 2389,2396 ----
# endif
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
+ # if defined(DEBUGGING)
+ # endif
#if 0
#endif
# if defined(CRIPPLED_CC)
***************
*** 2360,2365 ****
--- 2400,2407 ----
#endif
#if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT)
#endif
+ #if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT)
+ #endif
#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
# if defined(LEAKTEST)
# endif
***************
*** 2366,2371 ****
--- 2408,2441 ----
#endif
#if defined(PERL_OBJECT)
#endif
+ #undef Perl_sv_setsv_flags
+ #define Perl_sv_setsv_flags pPerl->Perl_sv_setsv_flags
+ #undef sv_setsv_flags
+ #define sv_setsv_flags Perl_sv_setsv_flags
+ #undef Perl_sv_catpvn_flags
+ #define Perl_sv_catpvn_flags pPerl->Perl_sv_catpvn_flags
+ #undef sv_catpvn_flags
+ #define sv_catpvn_flags Perl_sv_catpvn_flags
+ #undef Perl_sv_catsv_flags
+ #define Perl_sv_catsv_flags pPerl->Perl_sv_catsv_flags
+ #undef sv_catsv_flags
+ #define sv_catsv_flags Perl_sv_catsv_flags
+ #undef Perl_sv_utf8_upgrade_flags
+ #define Perl_sv_utf8_upgrade_flags pPerl->Perl_sv_utf8_upgrade_flags
+ #undef sv_utf8_upgrade_flags
+ #define sv_utf8_upgrade_flags Perl_sv_utf8_upgrade_flags
+ #undef Perl_sv_pvn_force_flags
+ #define Perl_sv_pvn_force_flags pPerl->Perl_sv_pvn_force_flags
+ #undef sv_pvn_force_flags
+ #define sv_pvn_force_flags Perl_sv_pvn_force_flags
+ #undef Perl_sv_2pv_flags
+ #define Perl_sv_2pv_flags pPerl->Perl_sv_2pv_flags
+ #undef sv_2pv_flags
+ #define sv_2pv_flags Perl_sv_2pv_flags
+ #undef Perl_my_atof2
+ #define Perl_my_atof2 pPerl->Perl_my_atof2
+ #undef my_atof2
+ #define my_atof2 Perl_my_atof2
#endif /* PERL_CORE && PERL_OBJECT */
#endif /* __objXSUB_h__ */
diff -c 'perl-5.7.1/op.c' 'perl-5.7.2/op.c'
Index: ./op.c
*** ./op.c Sat Apr 7 21:29:08 2001
--- ./op.c Thu Jul 12 20:13:25 2001
***************
*** 183,192 ****
if (*name != '$')
yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
name, PL_in_my == KEY_our ? "our" : "my"));
! SvOBJECT_on(sv);
(void)SvUPGRADE(sv, SVt_PVMG);
SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
- PL_sv_objcount++;
}
if (PL_in_my == KEY_our) {
(void)SvUPGRADE(sv, SVt_PVGV);
--- 183,191 ----
if (*name != '$')
yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
name, PL_in_my == KEY_our ? "our" : "my"));
! SvFLAGS(sv) |= SVpad_TYPED;
(void)SvUPGRADE(sv, SVt_PVMG);
SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
}
if (PL_in_my == KEY_our) {
(void)SvUPGRADE(sv, SVt_PVGV);
***************
*** 223,233 ****
(void)SvUPGRADE(namesv, SVt_PVGV);
GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
}
! if (SvOBJECT(proto_namesv)) { /* A typed var */
! SvOBJECT_on(namesv);
(void)SvUPGRADE(namesv, SVt_PVMG);
SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
- PL_sv_objcount++;
}
return newoff;
}
--- 222,231 ----
(void)SvUPGRADE(namesv, SVt_PVGV);
GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
}
! if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
! SvFLAGS(namesv) |= SVpad_TYPED;
(void)SvUPGRADE(namesv, SVt_PVMG);
SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
}
return newoff;
}
***************
*** 348,354 ****
switch (CxTYPE(cx)) {
default:
if (i == 0 && saweval) {
- seq = cxstack[saweval].blk_oldcop->cop_seq;
return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
}
break;
--- 346,351 ----
***************
*** 355,362 ****
case CXt_EVAL:
switch (cx->blk_eval.old_op_type) {
case OP_ENTEREVAL:
! if (CxREALEVAL(cx))
saweval = i;
break;
case OP_DOFILE:
case OP_REQUIRE:
--- 352,369 ----
case CXt_EVAL:
switch (cx->blk_eval.old_op_type) {
case OP_ENTEREVAL:
! if (CxREALEVAL(cx)) {
! PADOFFSET off;
saweval = i;
+ seq = cxstack[i].blk_oldcop->cop_seq;
+ startcv = cxstack[i].blk_eval.cv;
+ if (startcv && CvOUTSIDE(startcv)) {
+ off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
+ i-1, saweval, 0);
+ if (off) /* continue looking if not found here */
+ return off;
+ }
+ }
break;
case OP_DOFILE:
case OP_REQUIRE:
***************
*** 371,379 ****
cv = cx->blk_sub.cv;
if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
saweval = i; /* so we know where we were called from */
continue;
}
- seq = cxstack[saweval].blk_oldcop->cop_seq;
return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
}
}
--- 378,386 ----
cv = cx->blk_sub.cv;
if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
saweval = i; /* so we know where we were called from */
+ seq = cxstack[i].blk_oldcop->cop_seq;
continue;
}
return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
}
}
***************
*** 643,649 ****
break;
case ';':
sv_setpv(sv, "\034");
! sv_magic(sv, 0, 0, name, 1);
break;
case '&':
case '`':
--- 650,656 ----
break;
case ';':
sv_setpv(sv, "\034");
! sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
break;
case '&':
case '`':
***************
*** 667,673 ****
/* case '!': */
default:
! sv_magic(sv, 0, 0, name, 1);
}
DEBUG_S(PerlIO_printf(Perl_error_log,
"find_threadsv: new SV %p for $%s%c\n",
--- 674,680 ----
/* case '!': */
default:
! sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
}
DEBUG_S(PerlIO_printf(Perl_error_log,
"find_threadsv: new SV %p for $%s%c\n",
***************
*** 735,742 ****
#endif
}
! STATIC void
! S_op_clear(pTHX_ OP *o)
{
switch (o->op_type) {
case OP_NULL: /* Was holding old type, if any. */
--- 742,749 ----
#endif
}
! void
! Perl_op_clear(pTHX_ OP *o)
{
switch (o->op_type) {
case OP_NULL: /* Was holding old type, if any. */
***************
*** 835,850 ****
lastpmop = pmop;
pmop = pmop->op_pmnext;
}
#ifdef USE_ITHREADS
! Safefree(PmopSTASHPV(cPMOPo));
#else
! /* NOTE: PMOP.op_pmstash is not refcounted */
#endif
- }
}
cPMOPo->op_pmreplroot = Nullop;
! ReREFCNT_dec(cPMOPo->op_pmregexp);
! cPMOPo->op_pmregexp = (REGEXP*)NULL;
break;
}
--- 842,857 ----
lastpmop = pmop;
pmop = pmop->op_pmnext;
}
+ }
#ifdef USE_ITHREADS
! Safefree(PmopSTASHPV(cPMOPo));
#else
! /* NOTE: PMOP.op_pmstash is not refcounted */
#endif
}
cPMOPo->op_pmreplroot = Nullop;
! ReREFCNT_dec(PM_GETRE(cPMOPo));
! PM_SETRE(cPMOPo, (REGEXP*)NULL);
break;
}
***************
*** 871,878 ****
SvREFCNT_dec(cop->cop_io);
}
! STATIC void
! S_null(pTHX_ OP *o)
{
if (o->op_type == OP_NULL)
return;
--- 878,885 ----
SvREFCNT_dec(cop->cop_io);
}
! void
! Perl_op_null(pTHX_ OP *o)
{
if (o->op_type == OP_NULL)
return;
***************
*** 1137,1142 ****
--- 1144,1152 ----
else {
if (ckWARN(WARN_VOID)) {
useless = "a constant";
+ /* the constants 0 and 1 are permitted as they are
+ conventionally used as dummies in constructs like
+ 1 while some_condition_with_side_effects; */
if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
useless = 0;
else if (SvPOK(sv)) {
***************
*** 1153,1159 ****
}
}
}
! null(o); /* don't execute or even remember it */
break;
case OP_POSTINC:
--- 1163,1169 ----
}
}
}
! op_null(o); /* don't execute or even remember it */
break;
case OP_POSTINC:
***************
*** 1358,1388 ****
PL_modcount++;
return o;
case OP_CONST:
- if (o->op_private & (OPpCONST_BARE) &&
- !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
- SV *sv = ((SVOP*)o)->op_sv;
- GV *gv;
-
- /* Could be a filehandle */
- if ((gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO))) {
- OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv));
- op_free(o);
- o = gvio;
- } else {
- /* OK, it's a sub */
- OP* enter;
- gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
-
- enter = newUNOP(OP_ENTERSUB,0,
- newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0, gv)
- ));
- enter->op_private |= OPpLVAL_INTRO;
- op_free(o);
- o = enter;
- }
- break;
- }
if (!(o->op_private & (OPpCONST_ARYBASE)))
goto nomod;
if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
--- 1368,1373 ----
***************
*** 1408,1414 ****
o->op_type = OP_RV2CV; /* entersub => rv2cv */
o->op_ppaddr = PL_ppaddr[OP_RV2CV];
assert(cUNOPo->op_first->op_type == OP_NULL);
! null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
break;
}
else { /* lvalue subroutine call */
--- 1393,1399 ----
o->op_type = OP_RV2CV; /* entersub => rv2cv */
o->op_ppaddr = PL_ppaddr[OP_RV2CV];
assert(cUNOPo->op_first->op_type == OP_NULL);
! op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
break;
}
else { /* lvalue subroutine call */
***************
*** 1780,1786 ****
o->op_type = OP_RV2CV; /* entersub => rv2cv */
o->op_ppaddr = PL_ppaddr[OP_RV2CV];
assert(cUNOPo->op_first->op_type == OP_NULL);
! null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
o->op_flags |= OPf_SPECIAL;
}
break;
--- 1765,1771 ----
o->op_type = OP_RV2CV; /* entersub => rv2cv */
o->op_ppaddr = PL_ppaddr[OP_RV2CV];
assert(cUNOPo->op_first->op_type == OP_NULL);
! op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
o->op_flags |= OPf_SPECIAL;
}
break;
***************
*** 1885,1891 ****
/* fake up C<use attributes $pkg,$rv,@attrs> */
ENTER; /* need to protect against side-effects of 'use' */
SAVEINT(PL_expect);
! if (stash && HvNAME(stash))
stashsv = newSVpv(HvNAME(stash), 0);
else
stashsv = &PL_sv_no;
--- 1870,1876 ----
/* fake up C<use attributes $pkg,$rv,@attrs> */
ENTER; /* need to protect against side-effects of 'use' */
SAVEINT(PL_expect);
! if (stash)
stashsv = newSVpv(HvNAME(stash), 0);
else
stashsv = &PL_sv_no;
***************
*** 1985,1991 ****
/* check for C<my Dog $spot> when deciding package */
namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
! if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
stash = SvSTASH(*namesvp);
else
stash = PL_curstash;
--- 1970,1976 ----
/* check for C<my Dog $spot> when deciding package */
namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
! if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
stash = SvSTASH(*namesvp);
else
stash = PL_curstash;
***************
*** 2050,2058 ****
right->op_type == OP_SUBST ||
right->op_type == OP_TRANS)) {
right->op_flags |= OPf_STACKED;
! if (right->op_type != OP_MATCH &&
! ! (right->op_type == OP_TRANS &&
! right->op_private & OPpTRANS_IDENTICAL))
left = mod(left, right->op_type);
if (right->op_type == OP_TRANS)
o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
--- 2035,2049 ----
right->op_type == OP_SUBST ||
right->op_type == OP_TRANS)) {
right->op_flags |= OPf_STACKED;
! if ((right->op_type != OP_MATCH &&
! ! (right->op_type == OP_TRANS &&
! right->op_private & OPpTRANS_IDENTICAL)) ||
! /* if SV has magic, then match on original SV, not on its copy.
! see note in pp_helem() */
! (right->op_type == OP_MATCH &&
! (left->op_type == OP_AELEM ||
! left->op_type == OP_HELEM ||
! left->op_type == OP_AELEMFAST)))
left = mod(left, right->op_type);
if (right->op_type == OP_TRANS)
o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
***************
*** 2092,2098 ****
o->op_ppaddr = PL_ppaddr[OP_SCOPE];
kid = ((LISTOP*)o)->op_first;
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
! null(kid);
}
else
o = newLISTOP(OP_SCOPE, 0, o, Nullop);
--- 2083,2089 ----
o->op_ppaddr = PL_ppaddr[OP_SCOPE];
kid = ((LISTOP*)o)->op_first;
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
! op_null(kid);
}
else
o = newLISTOP(OP_SCOPE, 0, o, Nullop);
***************
*** 2290,2297 ****
case OP_SLE:
case OP_SGE:
case OP_SCMP:
!
! if (o->op_private & OPpLOCALE)
goto nope;
}
--- 2281,2288 ----
case OP_SLE:
case OP_SGE:
case OP_SCMP:
! /* XXX what about the numeric ops? */
! if (PL_hints & HINT_LOCALE)
goto nope;
}
***************
*** 2403,2409 ****
o->op_flags &= ~OPf_WANT;
if (!(PL_opargs[type] & OA_MARK))
! null(cLISTOPo->op_first);
o->op_type = type;
o->op_ppaddr = PL_ppaddr[type];
--- 2394,2400 ----
o->op_flags &= ~OPf_WANT;
if (!(PL_opargs[type] & OA_MARK))
! op_null(cLISTOPo->op_first);
o->op_type = type;
o->op_ppaddr = PL_ppaddr[type];
***************
*** 2513,2519 ****
{
if (!o || o->op_type != OP_LIST)
o = newLISTOP(OP_LIST, 0, o, Nullop);
! null(o);
return o;
}
--- 2504,2510 ----
{
if (!o || o->op_type != OP_LIST)
o = newLISTOP(OP_LIST, 0, o, Nullop);
! op_null(o);
return o;
}
***************
*** 2682,2688 ****
U32 max = 0;
I32 bits;
I32 havefinal = 0;
! U32 final;
I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
U8* tsave = NULL;
--- 2673,2679 ----
U32 max = 0;
I32 bits;
I32 havefinal = 0;
! U32 final = 0;
I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
U8* tsave = NULL;
***************
*** 2957,2963 ****
pmop->op_pmpermflags |= PMf_LOCALE;
pmop->op_pmflags = pmop->op_pmpermflags;
! /* link into pm list */
if (type != OP_TRANS && PL_curstash) {
pmop->op_pmnext = HvPMROOT(PL_curstash);
HvPMROOT(PL_curstash) = pmop;
--- 2948,2963 ----
pmop->op_pmpermflags |= PMf_LOCALE;
pmop->op_pmflags = pmop->op_pmpermflags;
! #ifdef USE_ITHREADS
! {
! SV* repointer = newSViv(0);
! av_push(PL_regex_padav,SvREFCNT_inc(repointer));
! pmop->op_pmoffset = av_len(PL_regex_padav);
! PL_regex_pad = AvARRAY(PL_regex_padav);
! }
! #endif
!
! /* link into pm list */
if (type != OP_TRANS && PL_curstash) {
pmop->op_pmnext = HvPMROOT(PL_curstash);
HvPMROOT(PL_curstash) = pmop;
***************
*** 2991,2998 ****
}
if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
pm->op_pmdynflags |= PMdf_UTF8;
! pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
! if (strEQ("\\s+", pm->op_pmregexp->precomp))
pm->op_pmflags |= PMf_WHITE;
op_free(expr);
}
--- 2991,2998 ----
}
if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
pm->op_pmdynflags |= PMdf_UTF8;
! PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
! if (strEQ("\\s+", PM_GETRE(pm)->precomp))
pm->op_pmflags |= PMf_WHITE;
op_free(expr);
}
***************
*** 3088,3101 ****
}
if (curop == repl
&& !(repl_has_vars
! && (!pm->op_pmregexp
! || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
pm->op_pmflags |= PMf_CONST; /* const for long enough */
pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
prepend_elem(o->op_type, scalar(repl), o);
}
else {
! if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
pm->op_pmflags |= PMf_MAYBE_CONST;
pm->op_pmpermflags |= PMf_MAYBE_CONST;
}
--- 3088,3101 ----
}
if (curop == repl
&& !(repl_has_vars
! && (!PM_GETRE(pm)
! || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
pm->op_pmflags |= PMf_CONST; /* const for long enough */
pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
prepend_elem(o->op_type, scalar(repl), o);
}
else {
! if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
pm->op_pmflags |= PMf_MAYBE_CONST;
pm->op_pmpermflags |= PMf_MAYBE_CONST;
}
***************
*** 3202,3207 ****
--- 3202,3208 ----
op_free(o);
}
else {
+ deprecate("\"package\" with no arguments");
sv_setpv(PL_curstname,"<none>");
PL_curstash = Nullhv;
}
***************
*** 3214,3223 ****
Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
{
OP *pack;
- OP *rqop;
OP *imop;
OP *veop;
- GV *gv;
if (id->op_type != OP_CONST)
Perl_croak(aTHX_ "Module name must be constant");
--- 3215,3222 ----
***************
*** 3275,3296 ****
newSVOP(OP_METHOD_NAMED, 0, meth)));
}
- /* Fake up a require, handle override, if any */
- gv = gv_fetchpv("require", FALSE, SVt_PVCV);
- if (!(gv && GvIMPORTED_CV(gv)))
- gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
-
- if (gv && GvIMPORTED_CV(gv)) {
- rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
- append_elem(OP_LIST, id,
- scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0,
- gv))))));
- }
- else {
- rqop = newUNOP(OP_REQUIRE, 0, id);
- }
-
/* Fake up the BEGIN {}, which does its thing immediately. */
newATTRSUB(floor,
newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
--- 3274,3279 ----
***************
*** 3298,3304 ****
Nullop,
append_elem(OP_LINESEQ,
append_elem(OP_LINESEQ,
! newSTATEOP(0, Nullch, rqop),
newSTATEOP(0, Nullch, veop)),
newSTATEOP(0, Nullch, imop) ));
--- 3281,3287 ----
Nullop,
append_elem(OP_LINESEQ,
append_elem(OP_LINESEQ,
! newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
newSTATEOP(0, Nullch, veop)),
newSTATEOP(0, Nullch, imop) ));
***************
*** 3616,3622 ****
cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
}
cop->op_flags = flags;
! cop->op_private = (PL_hints & HINT_BYTE);
#ifdef NATIVE_HINTS
cop->op_private |= NATIVE_HINTS;
#endif
--- 3599,3605 ----
cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
}
cop->op_flags = flags;
! cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
#ifdef NATIVE_HINTS
cop->op_private |= NATIVE_HINTS;
#endif
***************
*** 3964,3970 ****
OP *next = 0;
OP *listop;
OP *o;
- OP *condop;
U8 loopflags = 0;
if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
--- 3947,3952 ----
***************
*** 4026,4032 ****
return Nullop; /* listop already freed by new_logop */
}
if (listop)
! ((LISTOP*)listop)->op_last->op_next = condop =
(o == listop ? redo : LINKLIST(o));
}
else
--- 4008,4014 ----
return Nullop; /* listop already freed by new_logop */
}
if (listop)
! ((LISTOP*)listop)->op_last->op_next =
(o == listop ? redo : LINKLIST(o));
}
else
***************
*** 4122,4128 ****
op_free(expr);
expr = (OP*)(listop);
! null(expr);
iterflags |= OPf_STACKED;
}
else {
--- 4104,4110 ----
op_free(expr);
expr = (OP*)(listop);
! op_null(expr);
iterflags |= OPf_STACKED;
}
else {
***************
*** 4186,4191 ****
--- 4168,4181 ----
}
#endif /* USE_THREADS */
+ #ifdef USE_ITHREADS
+ if (CvFILE(cv) && !CvXSUB(cv)) {
+ /* for XSUBs CvFILE point directly to static memory; __FILE__ */
+ Safefree(CvFILE(cv));
+ }
+ CvFILE(cv) = 0;
+ #endif
+
if (!CvXSUB(cv) && CvROOT(cv)) {
#ifdef USE_THREADS
if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
***************
*** 4209,4217 ****
* CV, they don't hold a refcount on the outside CV. This avoids
* the refcount loop between the outer CV (which keeps a refcount to
* the closure prototype in the pad entry for pp_anoncode()) and the
! * closure prototype, and the ensuing memory leak. --GSAR */
! if (!CvANON(cv) || CvCLONED(cv))
SvREFCNT_dec(CvOUTSIDE(cv));
CvOUTSIDE(cv) = Nullcv;
if (CvCONST(cv)) {
SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
--- 4199,4213 ----
* CV, they don't hold a refcount on the outside CV. This avoids
* the refcount loop between the outer CV (which keeps a refcount to
* the closure prototype in the pad entry for pp_anoncode()) and the
! * closure prototype, and the ensuing memory leak. This does not
! * apply to closures generated within eval"", since eval"" CVs are
! * ephemeral. --GSAR */
! if (!CvANON(cv) || CvCLONED(cv)
! || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
! && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
! {
SvREFCNT_dec(CvOUTSIDE(cv));
+ }
CvOUTSIDE(cv) = Nullcv;
if (CvCONST(cv)) {
SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
***************
*** 4238,4243 ****
--- 4234,4242 ----
}
CvPADLIST(cv) = Nullav;
}
+ if (CvXSUB(cv)) {
+ CvXSUB(cv) = 0;
+ }
CvFLAGS(cv) = 0;
}
***************
*** 4322,4328 ****
--- 4321,4332 ----
MUTEX_INIT(CvMUTEXP(cv));
CvOWNER(cv) = 0;
#endif /* USE_THREADS */
+ #ifdef USE_ITHREADS
+ CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
+ : savepv(CvFILE(proto));
+ #else
CvFILE(cv) = CvFILE(proto);
+ #endif
CvGV(cv) = CvGV(proto);
CvSTASH(cv) = CvSTASH(proto);
CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
***************
*** 4611,4619 ****
cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
! #ifdef GV_SHARED_CHECK
! if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
! Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
}
#endif
--- 4615,4623 ----
cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
! #ifdef GV_UNIQUE_CHECK
! if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
! Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
}
#endif
***************
*** 4625,4633 ****
if (cv) {
bool exists = CvROOT(cv) || CvXSUB(cv);
! #ifdef GV_SHARED_CHECK
! if (exists && GvSHARED(gv)) {
! Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
}
#endif
--- 4629,4637 ----
if (cv) {
bool exists = CvROOT(cv) || CvXSUB(cv);
! #ifdef GV_UNIQUE_CHECK
! if (exists && GvUNIQUE(gv)) {
! Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
}
#endif
***************
*** 4692,4700 ****
*/
if (cv && !block) {
rcv = (SV*)cv;
! if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
stash = GvSTASH(CvGV(cv));
! else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
stash = CvSTASH(cv);
else
stash = PL_curstash;
--- 4696,4704 ----
*/
if (cv && !block) {
rcv = (SV*)cv;
! if (CvGV(cv) && GvSTASH(CvGV(cv)))
stash = GvSTASH(CvGV(cv));
! else if (CvSTASH(cv))
stash = CvSTASH(cv);
else
stash = PL_curstash;
***************
*** 4702,4708 ****
else {
/* possibly about to re-define existing subr -- ignore old cv */
rcv = (SV*)PL_compcv;
! if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
stash = GvSTASH(gv);
else
stash = PL_curstash;
--- 4706,4712 ----
else {
/* possibly about to re-define existing subr -- ignore old cv */
rcv = (SV*)PL_compcv;
! if (name && GvSTASH(gv))
stash = GvSTASH(gv);
else
stash = PL_curstash;
***************
*** 4756,4762 ****
}
}
CvGV(cv) = gv;
! CvFILE(cv) = CopFILE(PL_curcop);
CvSTASH(cv) = PL_curstash;
#ifdef USE_THREADS
CvOWNER(cv) = 0;
--- 4760,4766 ----
}
}
CvGV(cv) = gv;
! CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH(cv) = PL_curstash;
#ifdef USE_THREADS
CvOWNER(cv) = 0;
***************
*** 4847,4858 ****
}
}
! /* If a potential closure prototype, don't keep a refcount on outer CV.
* This is okay as the lifetime of the prototype is tied to the
* lifetime of the outer CV. Avoids memory leak due to reference
* loop. --GSAR */
! if (!name)
SvREFCNT_dec(CvOUTSIDE(cv));
if (name || aname) {
char *s;
--- 4851,4867 ----
}
}
! /* If a potential closure prototype, don't keep a refcount on
! * outer CV, unless the latter happens to be a passing eval"".
* This is okay as the lifetime of the prototype is tied to the
* lifetime of the outer CV. Avoids memory leak due to reference
* loop. --GSAR */
! if (!name && CvOUTSIDE(cv)
! && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
! && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
! {
SvREFCNT_dec(CvOUTSIDE(cv));
+ }
if (name || aname) {
char *s;
***************
*** 5011,5017 ****
else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
/* already defined (or promised) */
if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
- && HvNAME(GvSTASH(CvGV(cv)))
&& strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
line_t oldline = CopLINE(PL_curcop);
if (PL_copline != NOLINE)
--- 5020,5025 ----
***************
*** 5111,5119 ****
else
name = "STDOUT";
gv = gv_fetchpv(name,TRUE, SVt_PVFM);
! #ifdef GV_SHARED_CHECK
! if (GvSHARED(gv)) {
! Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
}
#endif
GvMULTI_on(gv);
--- 5119,5127 ----
else
name = "STDOUT";
gv = gv_fetchpv(name,TRUE, SVt_PVFM);
! #ifdef GV_UNIQUE_CHECK
! if (GvUNIQUE(gv)) {
! Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
}
#endif
GvMULTI_on(gv);
***************
*** 5130,5136 ****
cv = PL_compcv;
GvFORM(gv) = cv;
CvGV(cv) = gv;
! CvFILE(cv) = CopFILE(PL_curcop);
for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
--- 5138,5144 ----
cv = PL_compcv;
GvFORM(gv) = cv;
CvGV(cv) = gv;
! CvFILE_set_from_cop(cv, PL_curcop);
for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
***************
*** 5232,5237 ****
--- 5240,5250 ----
o->op_ppaddr = PL_ppaddr[OP_PADAV];
return o;
}
+ else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
+ && ckWARN(WARN_DEPRECATED)) {
+ Perl_warner(aTHX_ WARN_DEPRECATED,
+ "Using an array as a reference is deprecated");
+ }
return newUNOP(OP_RV2AV, 0, scalar(o));
}
***************
*** 5251,5256 ****
--- 5264,5274 ----
o->op_ppaddr = PL_ppaddr[OP_PADHV];
return o;
}
+ else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
+ && ckWARN(WARN_DEPRECATED)) {
+ Perl_warner(aTHX_ WARN_DEPRECATED,
+ "Using a hash as a reference is deprecated");
+ }
return newUNOP(OP_RV2HV, 0, scalar(o));
}
***************
*** 5368,5374 ****
Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
PL_op_desc[o->op_type]);
}
! null(kid);
}
return o;
}
--- 5386,5392 ----
Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
PL_op_desc[o->op_type]);
}
! op_null(kid);
}
return o;
}
***************
*** 5398,5404 ****
if (!kid) {
o->op_flags &= ~OPf_KIDS;
! null(o);
}
else if (kid->op_type == OP_LINESEQ) {
LOGOP *enter;
--- 5416,5422 ----
if (!kid) {
o->op_flags &= ~OPf_KIDS;
! op_null(o);
}
else if (kid->op_type == OP_LINESEQ) {
LOGOP *enter;
***************
*** 5454,5460 ****
o = ck_fun(o);
kid = cUNOPo->op_first->op_sibling;
if (kid->op_type == OP_RV2GV)
! null(kid);
}
else
o = listkids(o);
--- 5472,5478 ----
o = ck_fun(o);
kid = cUNOPo->op_first->op_sibling;
if (kid->op_type == OP_RV2GV)
! op_null(kid);
}
else
o = listkids(o);
***************
*** 5479,5485 ****
else if (kid->op_type != OP_HELEM)
Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
PL_op_desc[o->op_type]);
! null(kid);
}
return o;
}
--- 5497,5503 ----
else if (kid->op_type != OP_HELEM)
Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
PL_op_desc[o->op_type]);
! op_null(kid);
}
return o;
}
***************
*** 5632,5644 ****
else
o = newUNOP(type, 0, newDEFSVOP());
}
- #ifdef USE_LOCALE
- if (type == OP_FTTEXT || type == OP_FTBINARY) {
- o->op_private = 0;
- if (PL_hints & HINT_LOCALE)
- o->op_private |= OPpLOCALE;
- }
- #endif
return o;
}
--- 5650,5655 ----
***************
*** 5870,5875 ****
--- 5881,5887 ----
gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
GvCV(gv) = GvCV(glob_gv);
+ SvREFCNT_inc((SV*)GvCV(gv));
GvIMPORTED_CV_on(gv);
LEAVE;
}
***************
*** 6047,6078 ****
if (!kid)
append_elem(o->op_type, o, newDEFSVOP());
! o = listkids(o);
!
! o->op_private = 0;
! #ifdef USE_LOCALE
! if (PL_hints & HINT_LOCALE)
! o->op_private |= OPpLOCALE;
! #endif
!
! return o;
}
OP *
- Perl_ck_fun_locale(pTHX_ OP *o)
- {
- o = ck_fun(o);
-
- o->op_private = 0;
- #ifdef USE_LOCALE
- if (PL_hints & HINT_LOCALE)
- o->op_private |= OPpLOCALE;
- #endif
-
- return o;
- }
-
- OP *
Perl_ck_sassign(pTHX_ OP *o)
{
OP *kid = cLISTOPo->op_first;
--- 6059,6068 ----
if (!kid)
append_elem(o->op_type, o, newDEFSVOP());
! return listkids(o);
}
OP *
Perl_ck_sassign(pTHX_ OP *o)
{
OP *kid = cLISTOPo->op_first;
***************
*** 6103,6120 ****
}
OP *
- Perl_ck_scmp(pTHX_ OP *o)
- {
- o->op_private = 0;
- #ifdef USE_LOCALE
- if (PL_hints & HINT_LOCALE)
- o->op_private |= OPpLOCALE;
- #endif
-
- return o;
- }
-
- OP *
Perl_ck_match(pTHX_ OP *o)
{
o->op_private |= OPpRUNTIME;
--- 6093,6098 ----
***************
*** 6194,6199 ****
--- 6172,6179 ----
OP *
Perl_ck_require(pTHX_ OP *o)
{
+ GV* gv;
+
if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
SVOP *kid = (SVOP*)cUNOPo->op_first;
***************
*** 6215,6220 ****
--- 6195,6217 ----
sv_catpvn(kid->op_sv, ".pm", 3);
}
}
+
+ /* handle override, if any */
+ gv = gv_fetchpv("require", FALSE, SVt_PVCV);
+ if (!(gv && GvIMPORTED_CV(gv)))
+ gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
+
+ if (gv && GvIMPORTED_CV(gv)) {
+ OP *kid = cUNOPo->op_first;
+ cUNOPo->op_first = 0;
+ op_free(o);
+ return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST, kid,
+ scalar(newUNOP(OP_RV2CV, 0,
+ newGVOP(OP_GV, 0,
+ gv))))));
+ }
+
return ck_fun(o);
}
***************
*** 6292,6308 ****
Perl_ck_sort(pTHX_ OP *o)
{
OP *firstkid;
- o->op_private = 0;
- #ifdef USE_LOCALE
- if (PL_hints & HINT_LOCALE)
- o->op_private |= OPpLOCALE;
- #endif
if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
simplify_sort(o);
firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
if (o->op_flags & OPf_STACKED) { /* may have been cleared */
! OP *k;
OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
--- 6289,6300 ----
Perl_ck_sort(pTHX_ OP *o)
{
OP *firstkid;
if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
simplify_sort(o);
firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
if (o->op_flags & OPf_STACKED) { /* may have been cleared */
! OP *k = NULL;
OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
***************
*** 6313,6319 ****
}
else if (kid->op_type == OP_LEAVE) {
if (o->op_type == OP_SORT) {
! null(kid); /* wipe out leave */
kid->op_next = kid;
for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
--- 6305,6311 ----
}
else if (kid->op_type == OP_LEAVE) {
if (o->op_type == OP_SORT) {
! op_null(kid); /* wipe out leave */
kid->op_next = kid;
for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
***************
*** 6344,6350 ****
o->op_flags |= OPf_SPECIAL;
}
else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
! null(firstkid);
firstkid = firstkid->op_sibling;
}
--- 6336,6342 ----
o->op_flags |= OPf_SPECIAL;
}
else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
! op_null(firstkid);
firstkid = firstkid->op_sibling;
}
***************
*** 6478,6485 ****
OP *kid = cLISTOPo->op_first->op_sibling;
if (kid && kid->op_type == OP_MATCH) {
char *pmstr = "STRING";
! if (kPMOP->op_pmregexp)
! pmstr = kPMOP->op_pmregexp->precomp;
Perl_warner(aTHX_ WARN_SYNTAX,
"/%s/ should probably be written as \"%s\"",
pmstr, pmstr);
--- 6470,6477 ----
OP *kid = cLISTOPo->op_first->op_sibling;
if (kid && kid->op_type == OP_MATCH) {
char *pmstr = "STRING";
! if (PM_GETRE(kPMOP))
! pmstr = PM_GETRE(kPMOP)->precomp;
Perl_warner(aTHX_ WARN_SYNTAX,
"/%s/ should probably be written as \"%s\"",
pmstr, pmstr);
***************
*** 6507,6513 ****
if (cvop->op_type == OP_RV2CV) {
SVOP* tmpop;
o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
! null(cvop); /* disable rv2cv */
tmpop = (SVOP*)((UNOP*)cvop)->op_first;
if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
GV *gv = cGVOPx_gv(tmpop);
--- 6499,6505 ----
if (cvop->op_type == OP_RV2CV) {
SVOP* tmpop;
o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
! op_null(cvop); /* disable rv2cv */
tmpop = (SVOP*)((UNOP*)cvop)->op_first;
if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
GV *gv = cGVOPx_gv(tmpop);
***************
*** 6769,6775 ****
o->op_private |= OPpTARGET_MY;
}
}
! null(o->op_next);
}
ignore_optimization:
o->op_seq = PL_op_seqmax++;
--- 6761,6767 ----
o->op_private |= OPpTARGET_MY;
}
}
! op_null(o->op_next);
}
ignore_optimization:
o->op_seq = PL_op_seqmax++;
***************
*** 6802,6808 ****
case OP_GV:
if (o->op_next->op_type == OP_RV2SV) {
if (!(o->op_next->op_private & OPpDEREF)) {
! null(o->op_next);
o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
| OPpOUR_INTRO);
o->op_next = o->op_next->op_next;
--- 6794,6800 ----
case OP_GV:
if (o->op_next->op_type == OP_RV2SV) {
if (!(o->op_next->op_private & OPpDEREF)) {
! op_null(o->op_next);
o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
| OPpOUR_INTRO);
o->op_next = o->op_next->op_next;
***************
*** 6823,6831 ****
i >= 0)
{
GV *gv;
! null(o->op_next);
! null(pop->op_next);
! null(pop);
o->op_flags |= pop->op_next->op_flags & OPf_MOD;
o->op_next = pop->op_next->op_next;
o->op_type = OP_AELEMFAST;
--- 6815,6823 ----
i >= 0)
{
GV *gv;
! op_null(o->op_next);
! op_null(pop->op_next);
! op_null(pop);
o->op_flags |= pop->op_next->op_flags & OPf_MOD;
o->op_next = pop->op_next->op_next;
o->op_type = OP_AELEMFAST;
***************
*** 6926,6934 ****
svp = cSVOPx_svp(((BINOP*)o)->op_last);
if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
key = SvPV(sv, keylen);
! if (SvUTF8(sv))
! keylen = -keylen;
! lexname = newSVpvn_share(key, keylen, 0);
SvREFCNT_dec(sv);
*svp = lexname;
}
--- 6918,6926 ----
svp = cSVOPx_svp(((BINOP*)o)->op_last);
if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
key = SvPV(sv, keylen);
! lexname = newSVpvn_share(key,
! SvUTF8(sv) ? -(I32)keylen : keylen,
! 0);
SvREFCNT_dec(sv);
*svp = lexname;
}
***************
*** 6940,6954 ****
if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
break;
lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
! if (!SvOBJECT(lexname))
break;
fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
if (!fields || !GvHV(*fields))
break;
key = SvPV(*svp, keylen);
! if (SvUTF8(*svp))
! keylen = -keylen;
! indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
if (!indsvp) {
Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
--- 6932,6945 ----
if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
break;
lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
! if (!(SvFLAGS(lexname) & SVpad_TYPED))
break;
fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
if (!fields || !GvHV(*fields))
break;
key = SvPV(*svp, keylen);
! indsvp = hv_fetch(GvHV(*fields), key,
! SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
if (!indsvp) {
Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
***************
*** 6990,6996 ****
if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
break;
lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
! if (!SvOBJECT(lexname))
break;
fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
if (!fields || !GvHV(*fields))
--- 6981,6987 ----
if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
break;
lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
! if (!(SvFLAGS(lexname) & SVpad_TYPED))
break;
fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
if (!fields || !GvHV(*fields))
***************
*** 7013,7021 ****
key_op = (SVOP*)key_op->op_sibling) {
svp = cSVOPx_svp(key_op);
key = SvPV(*svp, keylen);
! if (SvUTF8(*svp))
! keylen = -keylen;
! indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
if (!indsvp) {
Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
"in variable %s of type %s",
--- 7004,7011 ----
key_op = (SVOP*)key_op->op_sibling) {
svp = cSVOPx_svp(key_op);
key = SvPV(*svp, keylen);
! indsvp = hv_fetch(GvHV(*fields), key,
! SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
if (!indsvp) {
Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
"in variable %s of type %s",
diff -c 'perl-5.7.1/op.h' 'perl-5.7.2/op.h'
Index: ./op.h
*** ./op.h Sun Mar 18 07:19:12 2001
--- ./op.h Thu Jul 12 20:14:25 2001
***************
*** 184,193 ****
/* Private for OP_EXISTS */
#define OPpEXISTS_SUB 64 /* Checking for &sub, not {} or []. */
- /* Private for OP_SORT, OP_PRTF, OP_SPRINTF, OP_FTTEXT, OP_FTBINARY, */
- /* string comparisons, and case changers. */
- #define OPpLOCALE 64 /* Use locale */
-
/* Private for OP_SORT */
#define OPpSORT_NUMERIC 1 /* Optimized away { $a <=> $b } */
#define OPpSORT_INTEGER 2 /* Ditto while under "use integer" */
--- 184,189 ----
***************
*** 238,244 ****
OP * op_pmreplroot;
OP * op_pmreplstart;
PMOP * op_pmnext; /* list of all scanpats */
! REGEXP * op_pmregexp; /* compiled expression */
U16 op_pmflags;
U16 op_pmpermflags;
U8 op_pmdynflags;
--- 234,244 ----
OP * op_pmreplroot;
OP * op_pmreplstart;
PMOP * op_pmnext; /* list of all scanpats */
! #ifdef USE_ITHREADS
! IV op_pmoffset;
! #else
! REGEXP * op_pmregexp; /* compiled expression */
! #endif
U16 op_pmflags;
U16 op_pmpermflags;
U8 op_pmdynflags;
***************
*** 249,254 ****
--- 249,262 ----
#endif
};
+ #ifdef USE_ITHREADS
+ #define PM_GETRE(o) ((REGEXP*)SvIVX(PL_regex_pad[(o)->op_pmoffset]))
+ #define PM_SETRE(o,r) (sv_setiv(PL_regex_pad[(o)->op_pmoffset], (IV)r))
+ #else
+ #define PM_GETRE(o) ((o)->op_pmregexp)
+ #define PM_SETRE(o,r) ((o)->op_pmregexp = (r))
+ #endif
+
#define PMdf_USED 0x01 /* pm has been used once already */
#define PMdf_TAINTED 0x02 /* pm compiled from tainted pattern */
#define PMdf_UTF8 0x04 /* pm compiled from utf8 data */
***************
*** 384,390 ****
#define Nullop Null(OP*)
! /* Lowest byte of PL_opargs */
#define OA_MARK 1
#define OA_FOLDCONST 2
#define OA_RETSCALAR 4
--- 392,398 ----
#define Nullop Null(OP*)
! /* Lowest byte-and-a-bit of PL_opargs */
#define OA_MARK 1
#define OA_FOLDCONST 2
#define OA_RETSCALAR 4
***************
*** 447,449 ****
--- 455,466 ----
#define PERL_LOADMOD_DENY 0x1
#define PERL_LOADMOD_NOIMPORT 0x2
#define PERL_LOADMOD_IMPORT_OPS 0x4
+
+ #ifdef USE_REENTRANT_API
+ typedef struct {
+ struct tm* tmbuff;
+ } REBUF;
+ #define localtime(a) localtime_r(a,PL_reentrant_buffer->tmbuff)
+ #define gmtime(a) gmtime_r(a,PL_reentrant_buffer->tmbuff)
+ #endif
+
diff -c 'perl-5.7.1/opcode.h' 'perl-5.7.2/opcode.h'
Index: ./opcode.h
*** ./opcode.h Thu Apr 5 20:48:11 2001
--- ./opcode.h Thu Jul 12 07:16:43 2001
***************
*** 1178,1190 ****
MEMBER_TO_FPTR(Perl_ck_null), /* i_ne */
MEMBER_TO_FPTR(Perl_ck_null), /* ncmp */
MEMBER_TO_FPTR(Perl_ck_null), /* i_ncmp */
! MEMBER_TO_FPTR(Perl_ck_scmp), /* slt */
! MEMBER_TO_FPTR(Perl_ck_scmp), /* sgt */
! MEMBER_TO_FPTR(Perl_ck_scmp), /* sle */
! MEMBER_TO_FPTR(Perl_ck_scmp), /* sge */
MEMBER_TO_FPTR(Perl_ck_null), /* seq */
MEMBER_TO_FPTR(Perl_ck_null), /* sne */
! MEMBER_TO_FPTR(Perl_ck_scmp), /* scmp */
MEMBER_TO_FPTR(Perl_ck_bitop), /* bit_and */
MEMBER_TO_FPTR(Perl_ck_bitop), /* bit_xor */
MEMBER_TO_FPTR(Perl_ck_bitop), /* bit_or */
--- 1178,1190 ----
MEMBER_TO_FPTR(Perl_ck_null), /* i_ne */
MEMBER_TO_FPTR(Perl_ck_null), /* ncmp */
MEMBER_TO_FPTR(Perl_ck_null), /* i_ncmp */
! MEMBER_TO_FPTR(Perl_ck_null), /* slt */
! MEMBER_TO_FPTR(Perl_ck_null), /* sgt */
! MEMBER_TO_FPTR(Perl_ck_null), /* sle */
! MEMBER_TO_FPTR(Perl_ck_null), /* sge */
MEMBER_TO_FPTR(Perl_ck_null), /* seq */
MEMBER_TO_FPTR(Perl_ck_null), /* sne */
! MEMBER_TO_FPTR(Perl_ck_null), /* scmp */
MEMBER_TO_FPTR(Perl_ck_bitop), /* bit_and */
MEMBER_TO_FPTR(Perl_ck_bitop), /* bit_xor */
MEMBER_TO_FPTR(Perl_ck_bitop), /* bit_or */
***************
*** 1209,1223 ****
MEMBER_TO_FPTR(Perl_ck_fun), /* vec */
MEMBER_TO_FPTR(Perl_ck_index), /* index */
MEMBER_TO_FPTR(Perl_ck_index), /* rindex */
! MEMBER_TO_FPTR(Perl_ck_fun_locale), /* sprintf */
MEMBER_TO_FPTR(Perl_ck_fun), /* formline */
MEMBER_TO_FPTR(Perl_ck_fun), /* ord */
MEMBER_TO_FPTR(Perl_ck_fun), /* chr */
MEMBER_TO_FPTR(Perl_ck_fun), /* crypt */
! MEMBER_TO_FPTR(Perl_ck_fun_locale), /* ucfirst */
! MEMBER_TO_FPTR(Perl_ck_fun_locale), /* lcfirst */
! MEMBER_TO_FPTR(Perl_ck_fun_locale), /* uc */
! MEMBER_TO_FPTR(Perl_ck_fun_locale), /* lc */
MEMBER_TO_FPTR(Perl_ck_fun), /* quotemeta */
MEMBER_TO_FPTR(Perl_ck_rvconst), /* rv2av */
MEMBER_TO_FPTR(Perl_ck_null), /* aelemfast */
--- 1209,1223 ----
MEMBER_TO_FPTR(Perl_ck_fun), /* vec */
MEMBER_TO_FPTR(Perl_ck_index), /* index */
MEMBER_TO_FPTR(Perl_ck_index), /* rindex */
! MEMBER_TO_FPTR(Perl_ck_fun), /* sprintf */
MEMBER_TO_FPTR(Perl_ck_fun), /* formline */
MEMBER_TO_FPTR(Perl_ck_fun), /* ord */
MEMBER_TO_FPTR(Perl_ck_fun), /* chr */
MEMBER_TO_FPTR(Perl_ck_fun), /* crypt */
! MEMBER_TO_FPTR(Perl_ck_fun), /* ucfirst */
! MEMBER_TO_FPTR(Perl_ck_fun), /* lcfirst */
! MEMBER_TO_FPTR(Perl_ck_fun), /* uc */
! MEMBER_TO_FPTR(Perl_ck_fun), /* lc */
MEMBER_TO_FPTR(Perl_ck_fun), /* quotemeta */
MEMBER_TO_FPTR(Perl_ck_rvconst), /* rv2av */
MEMBER_TO_FPTR(Perl_ck_null), /* aelemfast */
***************
*** 1478,1484 ****
0x00122804, /* bless */
0x00001608, /* backtick */
0x00012808, /* glob */
! 0x00001608, /* readline */
0x00001608, /* rcatline */
0x00002204, /* regcmaybe */
0x00002204, /* regcreset */
--- 1478,1484 ----
0x00122804, /* bless */
0x00001608, /* backtick */
0x00012808, /* glob */
! 0x0001d608, /* readline */
0x00001608, /* rcatline */
0x00002204, /* regcmaybe */
0x00002204, /* regcreset */
diff -c 'perl-5.7.1/opcode.pl' 'perl-5.7.2/opcode.pl'
Index: ./opcode.pl
*** ./opcode.pl Tue Mar 6 04:06:13 2001
--- ./opcode.pl Thu Jul 12 07:01:20 2001
***************
*** 1,9 ****
#!/usr/bin/perl
! chmod 0666, "opcode.h", "opnames.h";
! unlink "opcode.h", "opnames.h";
! open(OC, ">opcode.h") || die "Can't create opcode.h: $!\n";
! open(ON, ">opnames.h") || die "Can't create opnames.h: $!\n";
select OC;
# Read data.
--- 1,7 ----
#!/usr/bin/perl
! open(OC, ">opcode.h.new") || die "Can't create opcode.h.new: $!\n";
! open(ON, ">opnames.h.new") || die "Can't create opnames.h.new: $!\n";
select OC;
# Read data.
***************
*** 256,266 ****
close OC or die "Error closing opcode.h: $!";
close ON or die "Error closing opnames.h: $!";
! unlink "pp_proto.h";
! unlink "pp.sym";
! open PP, '>pp_proto.h' or die "Error creating pp_proto.h: $!";
! open PPSYM, '>pp.sym' or die "Error creating pp.sym: $!";
print PP <<"END";
/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
This file is built by opcode.pl from its data. Any changes made here
--- 254,268 ----
close OC or die "Error closing opcode.h: $!";
close ON or die "Error closing opnames.h: $!";
! chmod 0600, 'opcode.h'; # required by dosish filesystems
! chmod 0600, 'opnames.h'; # required by dosish filesystems
+ rename 'opcode.h.new', 'opcode.h' or die "renaming opcode.h: $!\n";
+ rename 'opnames.h.new', 'opnames.h' or die "renaming opnames.h: $!\n";
+
+ open PP, '>pp_proto.h.new' or die "Error creating pp_proto.h.new: $!";
+ open PPSYM, '>pp.sym.new' or die "Error creating pp.sym.new: $!";
+
print PP <<"END";
/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
This file is built by opcode.pl from its data. Any changes made here
***************
*** 296,301 ****
--- 298,309 ----
close PP or die "Error closing pp_proto.h: $!";
close PPSYM or die "Error closing pp.sym: $!";
+ chmod 0600, 'pp_proto.h'; # required by dosish filesystems
+ chmod 0600, 'pp.sym'; # required by dosish filesystems
+
+ rename 'pp_proto.h.new', 'pp_proto.h' or die "rename pp_proto.h: $!\n";
+ rename 'pp.sym.new', 'pp.sym' or die "rename pp.sym: $!\n";
+
###########################################################################
sub tab {
local($l, $t) = @_;
***************
*** 364,369 ****
--- 372,408 ----
# New ops always go at the very end
+ # A recapitulation of the format of this file:
+ # The file consists of five columns: the name of the op, an English
+ # description, the name of the "check" routine used to optimize this
+ # operation, some flags, and a description of the operands.
+
+ # The flags consist of options followed by a mandatory op class signifier
+
+ # The classes are:
+ # baseop - 0 unop - 1 binop - 2
+ # logop - | listop - @ pmop - /
+ # padop/svop - $ padop - # (unused) loop - {
+ # baseop/unop - % loopexop - } filestatop - -
+ # pvop/svop - "
+
+ # Other options are:
+ # needs stack mark - m
+ # needs constant folding - f
+ # produces a scalar - s
+ # produces an integer - i
+ # needs a target - t
+ # target can be in a pad - T
+ # has a corresponding integer version - I
+ # has side effects - d
+ # uses $_ if no argument given - u
+
+ # Values for the operands are:
+ # scalar - S list - L array - A
+ # hash - H sub (CV) - C file - F
+ # socket - Fs filetest - F- reference - R
+ # "?" denotes an optional operand.
+
# Nothing.
null null operation ck_null 0
***************
*** 405,411 ****
backtick quoted execution (``, qx) ck_open t%
# glob defaults its first arg to $_
glob glob ck_glob t@ S?
! readline <HANDLE> ck_null t%
rcatline append I/O operator ck_null t%
# Bindable operators.
--- 444,450 ----
backtick quoted execution (``, qx) ck_open t%
# glob defaults its first arg to $_
glob glob ck_glob t@ S?
! readline <HANDLE> ck_null t% F?
rcatline append I/O operator ck_null t%
# Bindable operators.
***************
*** 480,492 ****
ncmp numeric comparison (<=>) ck_null Iifst2 S S
i_ncmp integer comparison (<=>) ck_null ifst2 S S
! slt string lt ck_scmp ifs2 S S
! sgt string gt ck_scmp ifs2 S S
! sle string le ck_scmp ifs2 S S
! sge string ge ck_scmp ifs2 S S
seq string eq ck_null ifs2 S S
sne string ne ck_null ifs2 S S
! scmp string comparison (cmp) ck_scmp ifst2 S S
bit_and bitwise and (&) ck_bitop fst2 S S
bit_xor bitwise xor (^) ck_bitop fst2 S S
--- 519,531 ----
ncmp numeric comparison (<=>) ck_null Iifst2 S S
i_ncmp integer comparison (<=>) ck_null ifst2 S S
! slt string lt ck_null ifs2 S S
! sgt string gt ck_null ifs2 S S
! sle string le ck_null ifs2 S S
! sge string ge ck_null ifs2 S S
seq string eq ck_null ifs2 S S
sne string ne ck_null ifs2 S S
! scmp string comparison (cmp) ck_null ifst2 S S
bit_and bitwise and (&) ck_bitop fst2 S S
bit_xor bitwise xor (^) ck_bitop fst2 S S
***************
*** 524,538 ****
index index ck_index isT@ S S S?
rindex rindex ck_index isT@ S S S?
! sprintf sprintf ck_fun_locale mfst@ S L
formline formline ck_fun ms@ S L
ord ord ck_fun ifsTu% S?
chr chr ck_fun fsTu% S?
crypt crypt ck_fun fsT@ S S
! ucfirst ucfirst ck_fun_locale fstu% S?
! lcfirst lcfirst ck_fun_locale fstu% S?
! uc uc ck_fun_locale fstu% S?
! lc lc ck_fun_locale fstu% S?
quotemeta quotemeta ck_fun fstu% S?
# Arrays.
--- 563,577 ----
index index ck_index isT@ S S S?
rindex rindex ck_index isT@ S S S?
! sprintf sprintf ck_fun mfst@ S L
formline formline ck_fun ms@ S L
ord ord ck_fun ifsTu% S?
chr chr ck_fun fsTu% S?
crypt crypt ck_fun fsT@ S S
! ucfirst ucfirst ck_fun fstu% S?
! lcfirst lcfirst ck_fun fstu% S?
! uc uc ck_fun fstu% S?
! lc lc ck_fun fstu% S?
quotemeta quotemeta ck_fun fstu% S?
# Arrays.
diff -c 'perl-5.7.1/os2/Changes' 'perl-5.7.2/os2/Changes'
Index: ./os2/Changes
*** ./os2/Changes Tue Mar 13 03:50:48 2001
--- ./os2/Changes Mon Jul 9 17:11:07 2001
***************
*** 334,336 ****
--- 334,373 ----
compartment. As a result, the return string was not initialized.
A complete example of a mini-application added to OS2::REXX.
README.os2 updated to reflect the current state of Perl.
+
+ pre 5.6.2:
+ aout build: kid bootstrap_* were not associated with XS.
+ bldlevel did not contain enough info.
+ extLibpath* was failing on the call of the second type.
+ Configure defines flushNULL now (EMX -Zomf bug broke autodetection).
+ Configure did not find SIGBREAK.
+ extLibpath supports LIBSTRICT, better error detection.
+ crypt() used if present in -lcrypt or -lufc.
+ dumb getpw*(), getgr*() etc. supported; as in EMX, but if no
+ $ENV{PW_PASSWD}, the passwd field contains a string which
+ cannot be returned by crypt() (for security reasons).
+ The unwound recursion in detecting executable by script was
+ using static buffers. Thus system('pod2text') would fail if the
+ current directory contained an empty file named 'perl'.
+ Put ordinals in the base DLL.
+ Enable EXE-compression.
+ Load time (ms): Without /e:2: 70.6; With /e:2: 75.3; Lxlite: 62.8
+ Size drops from 750K to 627K, with lxlite to 515K.
+ lxlite /c:max gives 488K, but dumps core in t/TEST
+ os2ish.h defines SYSLOG constants ==> Sys::Syslog works.
+ Corrected warnings related to OS/2 code.
+ At one place = was put instead of ==.
+ Setting $^E should work.
+ Force "SYS0dddd=0xbar: " to error messages and to dlerror().
+ ($^E == 2 printed SYS0002 itself, but 110 did not.)
+ $OS2::nsyserror=0 switches off forcing SYSdddd on $^E.
+ perl_.exe does not require PM dlls any more (symbols resolved at
+ runtime on the as needed basis).
+ OS2::Process:
+ get/set: term size; codepages; screen's cursor; screen's contents
+ reliable session name setting;
+ process's parent pid, and the session id;
+ switching to and enumeration of sessions
+ window hierarchy inspection
+ post a message to a window
+ More robust getpriority() on older Warps.
diff -c 'perl-5.7.1/os2/Makefile.SHs' 'perl-5.7.2/os2/Makefile.SHs'
Index: ./os2/Makefile.SHs
*** ./os2/Makefile.SHs Tue Mar 6 04:06:14 2001
--- ./os2/Makefile.SHs Mon Jul 9 17:11:07 2001
***************
*** 14,19 ****
--- 14,28 ----
dll_post="`echo $perl_fullversion | sum | sed -e 's/^0*//' | awk '{print $1}'`"
dll_post="`printf '%x' $dll_post | tr '[a-z]' '[A-Z]'`"
+ aout_extra_libs=''
+ aout_extra_sep=''
+ for xxx in $aout_extra_static_ext; do
+ aout_extra_dir=`echo "$xxx" | sed -e 's/::/\//g'`
+ aout_extra_lib="lib/auto/$aout_extra_dir/"`basename "$aout_extra_dir"`
+ aout_extra_libs="$aout_extra_libs$aout_extra_sep$aout_extra_lib$aout_lib_ext"
+ aout_extra_sep=' '
+ done
+
$spitshell >>Makefile <<!GROK!THIS!
PERL_FULLVERSION = $perl_fullversion
***************
*** 31,42 ****
AOUT_CCCMD_DLL = \$(CC) -DDOSISH -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS -DTWO_POT_OPTIMIZE -DPERL_EMERGENCY_SBRK
AOUT_CLDFLAGS_DLL = -Zexe -Zmt -Zcrtdll -Zstack 32000
! LD_OPT = $optimize
PERL_DLL_BASE = perl$dll_post
PERL_DLL = \$(PERL_DLL_BASE)\$(DLSUFFIX)
TEST_PERL_DLL = perl_dll_t
CONFIG_ARGS = $config_args
!GROK!THIS!
--- 40,52 ----
AOUT_CCCMD_DLL = \$(CC) -DDOSISH -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS -DTWO_POT_OPTIMIZE -DPERL_EMERGENCY_SBRK
AOUT_CLDFLAGS_DLL = -Zexe -Zmt -Zcrtdll -Zstack 32000
! LD_OPT = \$(OPTIMIZE)
PERL_DLL_BASE = perl$dll_post
PERL_DLL = \$(PERL_DLL_BASE)\$(DLSUFFIX)
TEST_PERL_DLL = perl_dll_t
CONFIG_ARGS = $config_args
+ AOUT_EXTRA_LIBS = $aout_extra_libs
!GROK!THIS!
***************
*** 143,157 ****
$(SHRPENV) $(CC) $(SYS_CLDFLAGS) $(CCDLFLAGS) -o perl_sys perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs)
installcmd :
! perl -e 'die qq{Give the option INSTALLCMDDIR=... to make!} if $$ARGV[0] eq ""' $(INSTALLCMDDIR)
! perl os2/perl2cmd.pl $(INSTALLCMDDIR)
# Aout section:
aout_obj = $(addsuffix $(AOUT_OBJ_EXT),$(basename $(obj)))
AOUT_DYNALOADER = $(addsuffix $(AOUT_LIB_EXT),$(basename $(DYNALOADER)))
! aout_static_ext = $(addsuffix $(AOUT_LIB_EXT),$(basename $(dynamic_ext)))
! aout_static_lib = $(addsuffix $(LIB_EXT),$(basename $(dynamic_ext)))
aout_static_ext_dll = $(addsuffix $(AOUT_LIB_EXT),$(basename $(static_ext)))
DYNALOADER_OBJ = ext/DynaLoader/DynaLoader$(OBJ_EXT)
--- 153,168 ----
$(SHRPENV) $(CC) $(SYS_CLDFLAGS) $(CCDLFLAGS) -o perl_sys perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs)
installcmd :
! @perl -e 'die qq{Give the option INSTALLCMDDIR=... to make!} if $$ARGV[0] eq ""' $(INSTALLCMDDIR)
! ./miniperl -Ilib os2/perl2cmd.pl $(INSTALLCMDDIR)
# Aout section:
aout_obj = $(addsuffix $(AOUT_OBJ_EXT),$(basename $(obj)))
AOUT_DYNALOADER = $(addsuffix $(AOUT_LIB_EXT),$(basename $(DYNALOADER)))
! aout_ext = $(dynamic_ext) $(AOUT_EXTRA_LIBS)
! aout_static_ext = $(addsuffix $(AOUT_LIB_EXT),$(basename $(aout_ext)))
! aout_static_lib = $(addsuffix $(LIB_EXT),$(basename $(aout_ext)))
aout_static_ext_dll = $(addsuffix $(AOUT_LIB_EXT),$(basename $(static_ext)))
DYNALOADER_OBJ = ext/DynaLoader/DynaLoader$(OBJ_EXT)
***************
*** 220,237 ****
!NO!SUBS!
! # Now we need to find directories in ./ext/ which are two level deep
dirs=''
preci='ext/%/Makefile.aout '
for d in ext/*
do
! # echo "Checking '$d'..."
! f="`echo $d/*/Makefile.PL`"
! # SDBFile/sdbm, skip kid makefile
! if test ! -e "$d/Makefile.PL" -a ! "$f" = ""; then
! dirs="$dirs $d"
! preci="$preci $d/%/Makefile.aout"
fi
done
--- 231,282 ----
!NO!SUBS!
! # Now we need to find directories in ./ext/ which are up to 3 level deep
! # Currently (2001/06) there is no directories 4 levels deep.
! # (Only directories so that there is no Makefile.PL some levels up matter.)
dirs=''
+ ddirs=''
preci='ext/%/Makefile.aout '
for d in ext/*
do
! # echo "...Checking '$d'..."
! # skip the kid if the parent exists: cmp SDBFile/sdbm, done by MakeMaker
! if test ! -e "$d/Makefile.PL"; then
! # Need to treat subdirectories manually
! # echo "...Checking subdirs of '$d'..."
! d_treated=''
! for dd in $d/*
! do
! if test ! -d $dd; then
! continue
! fi
! if test -e "$dd/Makefile.PL"; then
! if test "X$d_treated" = "X"; then
! d_treated=1
! # echo "...Found parentless 2-level deep Makefile.PL's in $d/*/:" $d/*/Makefile.PL
! dirs="$dirs $d"
! preci="$preci $d/%/Makefile.aout"
! fi
! else
! # Need to treat subsubdirectories manually
! dd_treated=''
! for ddd in $dd/*
! do
! if test ! -d $ddd; then
! continue
! fi
! if test -e "$ddd/Makefile.PL"; then
! if test "X$dd_treated" = "X"; then
! dd_treated=1
! # echo "...Found parentless 3-level deep Makefile.PL's in $dd/*/:" $dd/*/Makefile.PL
! ddirs="$ddirs $dd"
! preci="$preci $dd/%/Makefile.aout"
! fi
! fi
! done
! fi
! done
fi
done
***************
*** 240,252 ****
!GROK!THIS!
for d in $dirs
do
p=`basename $d`
$spitshell >>Makefile <<!GROK!THIS!
! lib/auto/$p/*/%.a : ext/$p/%/Makefile.aout
! @cd ext/$p/\$(basename \$(notdir \$@)) ; make -f Makefile.aout config || echo "\$(MAKE) config failed, continuing anyway..."
! cd ext/$p/\$(basename \$(notdir \$@)) ; make -f Makefile.aout LINKTYPE=static CCCDLFLAGS=
$d/%/Makefile.aout : miniperl_
cd \$(dir \$@) ; ../../../miniperl_ -I ../../../lib Makefile.PL MAKEFILE=Makefile.aout INSTALLDIRS=perl
--- 285,315 ----
!GROK!THIS!
+ for d in $ddirs
+ do
+ # Remove the leading component ext/
+ dd=`dirname $d`
+ pp=`basename $dd`
+ p=$pp/`basename $d`
+ $spitshell >>Makefile <<!GROK!THIS!
+ lib/auto/$p/*/%.a : $d/%/Makefile.aout
+ @cd $d/\$(basename \$(notdir \$@)) ; make -f Makefile.aout config || echo "\$(MAKE) config failed, continuing anyway..."
+ cd $d/\$(basename \$(notdir \$@)) ; make -f Makefile.aout LINKTYPE=static CCCDLFLAGS=
+
+ $d/%/Makefile.aout : miniperl_
+ cd \$(dir \$@) ; ../../../../miniperl_ -I ../../../../lib Makefile.PL MAKEFILE=Makefile.aout INSTALLDIRS=perl
+
+ !GROK!THIS!
+
+ done
+
for d in $dirs
do
p=`basename $d`
$spitshell >>Makefile <<!GROK!THIS!
! lib/auto/$p/*/%.a : $d/%/Makefile.aout
! @cd $d/\$(basename \$(notdir \$@)) ; make -f Makefile.aout config || echo "\$(MAKE) config failed, continuing anyway..."
! cd $d/\$(basename \$(notdir \$@)) ; make -f Makefile.aout LINKTYPE=static CCCDLFLAGS=
$d/%/Makefile.aout : miniperl_
cd \$(dir \$@) ; ../../../miniperl_ -I ../../../lib Makefile.PL MAKEFILE=Makefile.aout INSTALLDIRS=perl
diff -c 'perl-5.7.1/os2/OS2/PrfDB/PrfDB.xs' 'perl-5.7.2/os2/OS2/PrfDB/PrfDB.xs'
Index: ./os2/OS2/PrfDB/PrfDB.xs
*** ./os2/OS2/PrfDB/PrfDB.xs Tue Mar 6 04:06:15 2001
--- ./os2/OS2/PrfDB/PrfDB.xs Mon Jul 9 17:11:07 2001
***************
*** 11,19 ****
}
#endif
! #define Prf_Open(pszFileName) SaveWinError(PrfOpenProfile(Perl_hab, (pszFileName)))
! #define Prf_Close(hini) (!CheckWinError(PrfCloseProfile(hini)))
SV *
Prf_Get(pTHX_ HINI hini, PSZ app, PSZ key) {
ULONG len;
--- 11,41 ----
}
#endif
! #define Prf_Open(pszFileName) SaveWinError(pPrfOpenProfile(Perl_hab, (pszFileName)))
! #define Prf_Close(hini) (!CheckWinError(pPrfCloseProfile(hini)))
+ BOOL (*pPrfCloseProfile) (HINI hini);
+ HINI (*pPrfOpenProfile) (HAB hab, PCSZ pszFileName);
+ BOOL (*pPrfQueryProfile) (HAB hab, PPRFPROFILE pPrfProfile);
+ BOOL (*pPrfQueryProfileData) (HINI hini, PCSZ pszApp, PCSZ pszKey, PVOID pBuffer,
+ PULONG pulBufferLength);
+ /*
+ LONG (*pPrfQueryProfileInt) (HINI hini, PCSZ pszApp, PCSZ pszKey, LONG sDefault);
+ */
+ BOOL (*pPrfQueryProfileSize) (HINI hini, PCSZ pszApp, PCSZ pszKey,
+ PULONG pulReqLen);
+ /*
+ ULONG (*pPrfQueryProfileString) (HINI hini, PCSZ pszApp, PCSZ pszKey,
+ PCSZ pszDefault, PVOID pBuffer, ULONG ulBufferLength);
+ */
+ BOOL (*pPrfReset) (HAB hab, __const__ PRFPROFILE *pPrfProfile);
+ BOOL (*pPrfWriteProfileData) (HINI hini, PCSZ pszApp, PCSZ pszKey,
+ CPVOID pData, ULONG ulDataLength);
+ /*
+ BOOL (*pPrfWriteProfileString) (HINI hini, PCSZ pszApp, PCSZ pszKey,
+ PCSZ pszData);
+ */
+
SV *
Prf_Get(pTHX_ HINI hini, PSZ app, PSZ key) {
ULONG len;
***************
*** 20,29 ****
BOOL rc;
SV *sv;
! if (CheckWinError(PrfQueryProfileSize(hini, app, key, &len))) return &PL_sv_undef;
sv = newSVpv("", 0);
SvGROW(sv, len + 1);
! if (CheckWinError(PrfQueryProfileData(hini, app, key, SvPVX(sv), &len))
|| (len == 0 && (app == NULL || key == NULL))) { /* Somewhy needed. */
SvREFCNT_dec(sv);
return &PL_sv_undef;
--- 42,51 ----
BOOL rc;
SV *sv;
! if (CheckWinError(pPrfQueryProfileSize(hini, app, key, &len))) return &PL_sv_undef;
sv = newSVpv("", 0);
SvGROW(sv, len + 1);
! if (CheckWinError(pPrfQueryProfileData(hini, app, key, SvPVX(sv), &len))
|| (len == 0 && (app == NULL || key == NULL))) { /* Somewhy needed. */
SvREFCNT_dec(sv);
return &PL_sv_undef;
***************
*** 37,48 ****
Prf_GetLength(HINI hini, PSZ app, PSZ key) {
U32 len;
! if (CheckWinError(PrfQueryProfileSize(hini, app, key, &len))) return -1;
return len;
}
#define Prf_Set(hini, app, key, s, l) \
! (!(CheckWinError(PrfWriteProfileData(hini, app, key, s, l))))
#define Prf_System(key) \
( (key) ? ( (key) == 1 ? HINI_USERPROFILE \
--- 59,70 ----
Prf_GetLength(HINI hini, PSZ app, PSZ key) {
U32 len;
! if (CheckWinError(pPrfQueryProfileSize(hini, app, key, &len))) return -1;
return len;
}
#define Prf_Set(hini, app, key, s, l) \
! (!(CheckWinError(pPrfWriteProfileData(hini, app, key, s, l))))
#define Prf_System(key) \
( (key) ? ( (key) == 1 ? HINI_USERPROFILE \
***************
*** 59,65 ****
char system[257];
PRFPROFILE info = { 257, user, 257, system};
! if (CheckWinError(PrfQueryProfile(Perl_hab, &info))) return &PL_sv_undef;
if (info.cchUserName > 257 || info.cchSysName > 257)
die("Panic: Profile names too long");
av_push(av, newSVpv(user, info.cchUserName - 1));
--- 81,87 ----
char system[257];
PRFPROFILE info = { 257, user, 257, system};
! if (CheckWinError(pPrfQueryProfile(Perl_hab, &info))) return &PL_sv_undef;
if (info.cchUserName > 257 || info.cchSysName > 257)
die("Panic: Profile names too long");
av_push(av, newSVpv(user, info.cchUserName - 1));
***************
*** 78,89 ****
if (!SvPOK(sv)) die("User profile name not defined");
if (SvCUR(sv) > 256) die("User profile name too long");
! if (CheckWinError(PrfQueryProfile(Perl_hab, &info))) return 0;
if (info.cchSysName > 257)
die("Panic: System profile name too long");
info.cchUserName = SvCUR(sv) + 1;
info.pszUserName = SvPVX(sv);
! return !CheckWinError(PrfReset(Perl_hab, &info));
}
MODULE = OS2::PrfDB PACKAGE = OS2::Prf PREFIX = Prf_
--- 100,111 ----
if (!SvPOK(sv)) die("User profile name not defined");
if (SvCUR(sv) > 256) die("User profile name too long");
! if (CheckWinError(pPrfQueryProfile(Perl_hab, &info))) return 0;
if (info.cchSysName > 257)
die("Panic: System profile name too long");
info.cchUserName = SvCUR(sv) + 1;
info.pszUserName = SvPVX(sv);
! return !CheckWinError(pPrfReset(Perl_hab, &info));
}
MODULE = OS2::PrfDB PACKAGE = OS2::Prf PREFIX = Prf_
***************
*** 141,143 ****
--- 163,173 ----
BOOT:
Acquire_hab();
+ AssignFuncPByORD(pPrfQueryProfileSize, ORD_PRF32QUERYPROFILESIZE);
+ AssignFuncPByORD(pPrfOpenProfile, ORD_PRF32OPENPROFILE);
+ AssignFuncPByORD(pPrfCloseProfile, ORD_PRF32CLOSEPROFILE);
+ AssignFuncPByORD(pPrfQueryProfile, ORD_PRF32QUERYPROFILE);
+ AssignFuncPByORD(pPrfReset, ORD_PRF32RESET);
+ AssignFuncPByORD(pPrfQueryProfileData, ORD_PRF32QUERYPROFILEDATA);
+ AssignFuncPByORD(pPrfWriteProfileData, ORD_PRF32WRITEPROFILEDATA);
+
diff -c 'perl-5.7.1/os2/OS2/Process/Process.pm' 'perl-5.7.2/os2/OS2/Process/Process.pm'
Index: ./os2/OS2/Process/Process.pm
*** ./os2/OS2/Process/Process.pm Wed Apr 4 17:12:09 2001
--- ./os2/OS2/Process/Process.pm Mon Jul 9 17:11:07 2001
***************
*** 1,12 ****
package OS2::Process;
! $VERSION = 0.2;
! require Exporter;
! require DynaLoader;
! #require AutoLoader;
- @ISA = qw(Exporter DynaLoader);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
--- 1,20 ----
+ package OS2::localMorphPM;
+
+ sub new { my ($c,$f) = @_; OS2::MorphPM($f); bless [shift], $c }
+ sub DESTROY { OS2::UnMorphPM(shift->[0]) }
+
package OS2::Process;
! BEGIN {
! require Exporter;
! require DynaLoader;
! #require AutoLoader;
! @ISA = qw(Exporter DynaLoader);
! $VERSION = "1.0";
! bootstrap OS2::Process;
! }
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
***************
*** 43,52 ****
T_VIRTDRV
T_PROTDLL
T_32BIT
process_entry
! set_title
get_title
);
sub AUTOLOAD {
# This AUTOLOAD is used to 'autoload' constants from the constant()
# XS function. If a constant is not found then control is passed
--- 51,104 ----
T_VIRTDRV
T_PROTDLL
T_32BIT
+ ppid
+ ppidOf
+ sidOf
+ scrsize
+ scrsize_set
process_entry
! process_entries
! process_hentry
! process_hentries
! change_entry
! change_entryh
! Title_set
! Title
! WindowText
! WindowText_set
! WindowPos
! WindowPos_set
! WindowProcess
! SwitchToProgram
! ActiveWindow
! ClassName
! FocusWindow
! FocusWindow_set
! ShowWindow
! PostMsg
! BeginEnumWindows
! EndEnumWindows
! GetNextWindow
! IsWindow
! ChildWindows
! out_codepage
! out_codepage_set
! in_codepage
! in_codepage_set
! cursor
! cursor_set
! screen
! screen_set
! process_codepages
! QueryWindow
! WindowFromId
! WindowFromPoint
! EnumDlgItem
!
get_title
+ set_title
);
+
sub AUTOLOAD {
# This AUTOLOAD is used to 'autoload' constants from the constant()
# XS function. If a constant is not found then control is passed
***************
*** 70,81 ****
goto &$AUTOLOAD;
}
- bootstrap OS2::Process;
-
# Preloaded methods go here.
! sub get_title () { (process_entry())[0] }
# Autoload methods go after __END__, and are processed by the autosplit program.
1;
--- 122,237 ----
goto &$AUTOLOAD;
}
# Preloaded methods go here.
! sub Title () { (process_entry())[0] }
+ # *Title_set = \&sesmgr_title_set;
+
+ sub swTitle_set_sw {
+ my ($title, @sw) = @_;
+ $sw[0] = $title;
+ change_entry(@sw);
+ }
+
+ sub swTitle_set {
+ my (@sw) = process_entry();
+ swTitle_set_sw(shift, @sw);
+ }
+
+ sub winTitle_set_sw {
+ my ($title, @sw) = @_;
+ my $h = OS2::localMorphPM->new(0);
+ WindowText_set $sw[1], $title;
+ }
+
+ sub winTitle_set {
+ my (@sw) = process_entry();
+ winTitle_set_sw(shift, @sw);
+ }
+
+ sub bothTitle_set {
+ my (@sw) = process_entry();
+ my $t = shift;
+ winTitle_set_sw($t, @sw);
+ swTitle_set_sw($t, @sw);
+ }
+
+ sub Title_set {
+ my $t = shift;
+ return 1 if sesmgr_title_set($t);
+ return 0 unless $^E == 372;
+ my (@sw) = process_entry();
+ winTitle_set_sw($t, @sw);
+ swTitle_set_sw($t, @sw);
+ }
+
+ sub process_entry { swentry_expand(process_swentry(@_)) }
+
+ our @hentry_fields = qw( title owner_hwnd icon_hwnd
+ owner_phandle owner_pid owner_sid
+ visible nonswitchable jumpable ptype sw_entry );
+
+ sub swentry_hexpand ($) {
+ my %h;
+ @h{@hentry_fields} = swentry_expand(shift);
+ \%h;
+ }
+
+ sub process_hentry { swentry_hexpand(process_swentry(@_)) }
+
+ my $swentry_size = swentry_size();
+
+ sub sw_entries () {
+ my $s = swentries_list();
+ my ($c, $s1) = unpack 'La*', $s;
+ die "Unconsistent size in swentries_list()" unless 4+$c*$swentry_size == length $s;
+ my (@l, $e);
+ push @l, $e while $e = substr $s1, 0, $swentry_size, '';
+ @l;
+ }
+
+ sub process_entries () {
+ map [swentry_expand($_)], sw_entries;
+ }
+
+ sub process_hentries () {
+ map swentry_hexpand($_), sw_entries;
+ }
+
+ sub change_entry {
+ change_swentry(create_swentry(@_));
+ }
+
+ sub create_swentryh ($) {
+ my $h = shift;
+ create_swentry(@$h{@hentry_fields});
+ }
+
+ sub change_entryh ($) {
+ change_swentry(create_swentryh(shift));
+ }
+
+ # Massage entries into the same order as WindowPos_set:
+ sub WindowPos ($) {
+ my ($fl, $w, $h, $x, $y, $behind, $hwnd, @rest)
+ = unpack 'L l4 L4', WindowSWP(shift);
+ ($x, $y, $fl, $w, $h, $behind, @rest);
+ }
+
+ sub ChildWindows ($) {
+ my @kids;
+ my $h = BeginEnumWindows shift;
+ my $w;
+ push @kids, $w while $w = GetNextWindow $h;
+ EndEnumWindows $h;
+ @kids;
+ }
+
+ # backward compatibility
+ *set_title = \&Title_set;
+ *get_title = \&Title;
+
# Autoload methods go after __END__, and are processed by the autosplit program.
1;
***************
*** 83,97 ****
=head1 NAME
! OS2::Process - exports constants for system() call on OS2.
=head1 SYNOPSIS
use OS2::Process;
! $pid = system(P_PM+P_BACKGROUND, "epm.exe");
=head1 DESCRIPTION
the builtin function system() under OS/2 allows an optional first
argument which denotes the mode of the process. Note that this argument is
recognized only if it is strictly numerical.
--- 239,255 ----
=head1 NAME
! OS2::Process - exports constants for system() call, and process control on OS2.
=head1 SYNOPSIS
use OS2::Process;
! $pid = system(P_PM | P_BACKGROUND, "epm.exe");
=head1 DESCRIPTION
+ =head2 Optional argument to system()
+
the builtin function system() under OS/2 allows an optional first
argument which denotes the mode of the process. Note that this argument is
recognized only if it is strictly numerical.
***************
*** 123,137 ****
=head2 Access to process properties
! Additionaly, subroutines my_type(), process_entry() and
! C<file_type(file)>, get_title() and C<set_title(newtitle)> are implemented.
! my_type() returns the type of the current process (one of
! "FS", "DOS", "VIO", "PM", "DETACH" and "UNKNOWN"), or C<undef> on error.
=over
! =item C<file_type(file)>
returns the type of the executable file C<file>, or
dies on error. The bits 0-2 of the result contain one of the values
--- 281,302 ----
=head2 Access to process properties
! On OS/2 processes have the usual I<parent/child> semantic;
! additionally, there is a hierarchy of sessions with their own
! I<parent/child> tree. A session is either a FS session, or a windowed
! pseudo-session created by PM. A session is a "unit of user
! interaction", a change to in/out settings in one of them does not
! affect other sessions.
=over
! =item my_type()
+ returns the type of the current process (one of
+ "FS", "DOS", "VIO", "PM", "DETACH" and "UNKNOWN"), or C<undef> on error.
+
+ =item C<file_type(file)>
+
returns the type of the executable file C<file>, or
dies on error. The bits 0-2 of the result contain one of the values
***************
*** 139,153 ****
=item C<T_NOTSPEC> (0)
! Application type is not specified in the executable header.
=item C<T_NOTWINDOWCOMPAT> (1)
! Application type is not-window-compatible.
=item C<T_WINDOWCOMPAT> (2)
! Application type is window-compatible.
=item C<T_WINDOWAPI> (3)
--- 304,318 ----
=item C<T_NOTSPEC> (0)
! Application type is not specified in the executable header.
=item C<T_NOTWINDOWCOMPAT> (1)
! Application type is not-window-compatible.
=item C<T_WINDOWCOMPAT> (2)
! Application type is window-compatible.
=item C<T_WINDOWAPI> (3)
***************
*** 177,187 ****
=item C<T_PHYSDRV> (0x40)
! Set to 1 if the executable file is a physical device driver.
=item C<T_VIRTDRV> (0x80)
! Set to 1 if the executable file is a virtual device driver.
=item C<T_PROTDLL> (0x100)
--- 342,352 ----
=item C<T_PHYSDRV> (0x40)
! Set to 1 if the executable file is a physical device driver.
=item C<T_VIRTDRV> (0x80)
! Set to 1 if the executable file is a virtual device driver.
=item C<T_PROTDLL> (0x100)
***************
*** 190,196 ****
=item C<T_32BIT> (0x4000)
! Set to 1 for 32-bit executable files.
=back
--- 355,361 ----
=item C<T_32BIT> (0x4000)
! Set to 1 for 32-bit executable files.
=back
***************
*** 200,205 ****
--- 365,460 ----
add extention F<.exe> if no extension is present (add extension F<.>
to suppress).
+ =item C<@list = process_codepages()>
+
+ the first element is the currently active codepage, up to 2 additional
+ entries specify the system's "prepared codepages": the codepages the
+ user can switch to. The active codepage of a process is one of the
+ prepared codepages of the system (if present).
+
+ =item C<process_codepage_set($cp)>
+
+ sets the currently active codepage. [Affects printer output, in/out
+ codepages of sessions started by this process, and the default
+ codepage for drawing in PM; is inherited by kids. Does not affect the
+ out- and in-codepages of the session.]
+
+ =item ppid()
+
+ returns the PID of the parent process.
+
+ =item C<ppidOf($pid = $$)>
+
+ returns the PID of the parent process of $pid. -1 on error.
+
+ =item C<sidOf($pid = $$)>
+
+ returns the session id of the process id $pid. -1 on error.
+
+ =back
+
+ =head2 Control of VIO sessions
+
+ VIO applications are applications running in a text-mode session.
+
+ =over
+
+ =item out_codepage()
+
+ gets code page used for screen output (glyphs). -1 means that a user font
+ was loaded.
+
+ =item C<out_codepage_set($cp)>
+
+ sets code page used for screen output (glyphs). -1 switches to a preloaded
+ user font. -2 switches off the preloaded user font.
+
+ =item in_codepage()
+
+ gets code page used for keyboard input. 0 means that a hardware codepage
+ is used.
+
+ =item C<in_codepage_set($cp)>
+
+ sets code page used for keyboard input.
+
+ =item C<($w, $h) = scrsize()>
+
+ width and height of the given console window in character cells.
+
+ =item C<scrsize_set([$w, ] $h)>
+
+ set height (and optionally width) of the given console window in
+ character cells. Use 0 size to keep the old size.
+
+ =item C<($s, $e, $w, $a) = cursor()>
+
+ gets start/end lines of the blinking cursor in the charcell, its width
+ (1 on text modes) and attribute (-1 for hidden, in text modes other
+ values mean visible, in graphic modes color).
+
+ =item C<cursor_set($s, $e, [$w [, $a]])>
+
+ sets start/end lines of the blinking cursor in the charcell. Negative
+ values mean percents of the character cell height.
+
+ =item screen()
+
+ gets a buffer with characters and attributes of the screen.
+
+ =item C<screen_set($buffer)>
+
+ restores the screen given the result of screen().
+
+ =back
+
+ =head2 Control of the process list
+
+ With the exception of Title_set(), all these calls require that PM is
+ running, they would not work under alternative Session Managers.
+
+ =over
+
=item process_entry()
returns a list of the following data:
***************
*** 206,236 ****
=over
! =item
Title of the process (in the C<Ctrl-Esc> list);
! =item
window handle of switch entry of the process (in the C<Ctrl-Esc> list);
! =item
window handle of the icon of the process;
! =item
process handle of the owner of the entry in C<Ctrl-Esc> list;
! =item
process id of the owner of the entry in C<Ctrl-Esc> list;
! =item
session id of the owner of the entry in C<Ctrl-Esc> list;
! =item
whether visible in C<Ctrl-Esc> list;
--- 461,491 ----
=over
! =item
Title of the process (in the C<Ctrl-Esc> list);
! =item
window handle of switch entry of the process (in the C<Ctrl-Esc> list);
! =item
window handle of the icon of the process;
! =item
process handle of the owner of the entry in C<Ctrl-Esc> list;
! =item
process id of the owner of the entry in C<Ctrl-Esc> list;
! =item
session id of the owner of the entry in C<Ctrl-Esc> list;
! =item
whether visible in C<Ctrl-Esc> list;
***************
*** 239,258 ****
whether item cannot be switched to (note that it is not actually
grayed in the C<Ctrl-Esc> list));
! =item
whether participates in jump sequence;
! =item
! program type. Possible values are:
! PROG_DEFAULT 0
! PROG_FULLSCREEN 1
! PROG_WINDOWABLEVIO 2
! PROG_PM 3
! PROG_VDM 4
! PROG_WINDOWEDVDM 7
Although there are several other program types for WIN-OS/2 programs,
these do not show up in this field. Instead, the PROG_VDM or
--- 494,513 ----
whether item cannot be switched to (note that it is not actually
grayed in the C<Ctrl-Esc> list));
! =item
whether participates in jump sequence;
! =item
! program type. Possible values are:
! PROG_DEFAULT 0
! PROG_FULLSCREEN 1
! PROG_WINDOWABLEVIO 2
! PROG_PM 3
! PROG_VDM 4
! PROG_WINDOWEDVDM 7
Although there are several other program types for WIN-OS/2 programs,
these do not show up in this field. Instead, the PROG_VDM or
***************
*** 263,293 ****
session. Likewise, if it's a full-screen WIN-OS/2 program, it runs in
a PROG_VDM session.
=back
! =item C<set_title(newtitle)>
! - does not work with some windows (if the title is set from the start).
This is a limitation of OS/2, in such a case $^E is set to 372 (type
help 372
! for a funny - and wrong - explanation ;-).
! =item get_title()
! is a shortcut implemented via process_entry().
=back
=head1 AUTHOR
! Andreas Kaiser <ak@ananke.s.bawue.de>,
Ilya Zakharevich <ilya@math.ohio-state.edu>.
=head1 SEE ALSO
! C<spawn*>() system calls.
=cut
--- 518,868 ----
session. Likewise, if it's a full-screen WIN-OS/2 program, it runs in
a PROG_VDM session.
+ =item
+ switch-entry handle.
+
=back
! Optional arguments: the pid and the window-handle of the application running
! in the OS/2 session to query.
! =item process_hentry()
!
! similar to process_entry(), but returns a hash reference, the keys being
!
! title owner_hwnd icon_hwnd owner_phandle owner_pid owner_sid
! visible nonswitchable jumpable ptype sw_entry
!
! (a copy of the list of keys is in @hentry_fields).
!
! =item process_entries()
!
! similar to process_entry(), but returns a list of array reference for all
! the elements in the switch list (one controlling C<Ctrl-Esc> window).
!
! =item process_hentries()
!
! similar to process_hentry(), but returns a list of hash reference for all
! the elements in the switch list (one controlling C<Ctrl-Esc> window).
!
! =item change_entry()
!
! changes a process entry, arguments are the same as process_entry() returns.
!
! =item change_entryh()
!
! Similar to change_entry(), but takes a hash reference as an argument.
!
! =item Title()
!
! returns a title of the current session. (There is no way to get this
! info in non-standard Session Managers, this implementation is a
! shortcut via process_entry().)
!
! =item C<Title_set(newtitle)>
!
! tries two different interfaces. The Session Manager one does not work
! with some windows (if the title is set from the start).
This is a limitation of OS/2, in such a case $^E is set to 372 (type
help 372
! for a funny - and wrong - explanation ;-). In such cases a
! direct-manipulation of low-level entries is used. Keep in mind that
! some versions of OS/2 leak memory with such a manipulation.
! =item C<SwitchToProgram($sw_entry)>
! switch to session given by a switch list handle.
+ Use of this function causes another window (and its related windows)
+ of a PM session to appear on the front of the screen, or a switch to
+ another session in the case of a non-PM program. In either case,
+ the keyboard (and mouse for the non-PM case) input is directed to
+ the new program.
+
=back
+ =head2 Control of the PM windows
+
+ Some of these API's require sending a message to the specified window.
+ In such a case the process needs to be a PM process, or to be morphed
+ to a PM process via OS2::MorphPM().
+
+ For a temporary morphing to PM use L<OS2::localMorphPM class>.
+
+ Keep in mind that PM windows are engaged in 2 "orthogonal" window
+ trees, as well as in the z-order list.
+
+ One tree is given by the I<parent/child> relationship. This
+ relationship affects drawing (child is drawn relative to its parent
+ (lower-left corner), and the drawing is clipped by the parent's
+ boundary; parent may request that I<it's> drawing is clipped to be
+ confined to the outsize of the childs and/or siblings' windows);
+ hiding; minimizing/restoring; and destroying windows.
+
+ Another tree (not necessarily connected?) is given by I<ownership>
+ relationship. Ownership relationship assumes cooperation of the
+ engaged windows via passing messages on "important events"; e.g.,
+ scrollbars send information messages when the "bar" is moved, menus
+ send messages when an item is selected; frames
+ move/hide/unhide/minimize/restore/change-z-order-of owned frames when
+ the owner is moved/etc., and destroy the owned frames (even when these
+ frames are not descendants) when the owner is destroyed; etc. [An
+ important restriction on ownership is that owner should be created by
+ the same thread as the owned thread, so they engage in the same
+ message queue.]
+
+ Windows may be in many different state: Focused, Activated (=Windows
+ in the I<parent/child> tree between the root and the window with
+ focus; usually indicate such "active state" by titlebar highlights),
+ Enabled/Disabled (this influences *an ability* to receive user input
+ (be focused?), and may change appearance, as for enabled/disabled
+ buttons), Visible/Hidden, Minimized/Maximized/Restored, Modal, etc.
+
+ =over
+
+ =item C<WindowText($hwnd)>
+
+ gets "a text content" of a window.
+
+ =item C<WindowText_set($hwnd, $text)>
+
+ sets "a text content" of a window.
+
+ =item C<WindowPos($hwnd)>
+
+ gets window position info as 8 integers (of C<SWP>), in the order suitable
+ for WindowPos_set(): $x, $y, $fl, $w, $h, $behind, @rest.
+
+ =item C<WindowPos_set($hwnd, $x, $y, $flags = SWP_MOVE, $wid = 0, $h = 0, $behind = HWND_TOP)>
+
+ Set state of the window: position, size, zorder, show/hide, activation,
+ minimize/maximize/restore etc. Which of these operations to perform
+ is governed by $flags.
+
+ =item C<WindowProcess($hwnd)>
+
+ gets I<PID> and I<TID> of the process associated to the window.
+
+ =item ActiveWindow([$parentHwnd])
+
+ gets the active subwindow's handle for $parentHwnd or desktop.
+ Returns FALSE if none.
+
+ =item C<ClassName($hwnd)>
+
+ returns the class name of the window.
+
+ If this window is of any of the preregistered WC_* classes the class
+ name returned is in the form "#nnnnn", where "nnnnn" is a group
+ of up to five digits that corresponds to the value of the WC_* class name
+ constant.
+
+ =item FocusWindow()
+
+ returns the handle of the focus window. Optional argument for specifying the desktop
+ to use.
+
+ =item C<FocusWindow_set($hwnd)>
+
+ set the focus window by handle. Optional argument for specifying the desktop
+ to use. E.g, the first entry in program_entries() is the C<Ctrl-Esc> list.
+ To show it
+
+ WinShowWindow( wlhwnd, TRUE );
+ WinSetFocus( HWND_DESKTOP, wlhwnd );
+ WinSwitchToProgram(wlhswitch);
+
+
+ =item C<ShowWindow($hwnd [, $show])>
+
+ Set visible/hidden flag of the window. Default: $show is TRUE.
+
+ =item C<PostMsg($hwnd, $msg, $mp1, $mp2)>
+
+ post message to a window. The meaning of $mp1, $mp2 is specific for each
+ message id $msg, they default to 0. E.g., in C it is done similar to
+
+ /* Emulate `Restore' */
+ WinPostMsg(SwitchBlock.tswe[i].swctl.hwnd, WM_SYSCOMMAND,
+ MPFROMSHORT(SC_RESTORE), 0);
+
+ /* Emulate `Show-Contextmenu' (Double-Click-2) */
+ hwndParent = WinQueryFocus(HWND_DESKTOP);
+ hwndActive = WinQueryActiveWindow(hwndParent);
+ WinPostMsg(hwndActive, WM_CONTEXTMENU, MPFROM2SHORT(0,0), MPFROMLONG(0));
+
+ /* Emulate `Close' */
+ WinPostMsg(pSWB->aswentry[i].swctl.hwnd, WM_CLOSE, 0, 0);
+
+ /* Same but softer: */
+ WinPostMsg(hwndactive, WM_SAVEAPPLICATION, 0L, 0L);
+ WinPostMsg(hwndactive, WM_CLOSE, 0L, 0L));
+ WinPostMsg(hwndactive, WM_QUIT, 0L, 0L));
+
+ =item C<$eh = BeginEnumWindows($hwnd)>
+
+ starts enumerating immediate child windows of $hwnd in z-order. The
+ enumeration reflects the state at the moment of BeginEnumWindows() calls;
+ use IsWindow() to be sure.
+
+ =item C<$kid_hwnd = GetNextWindow($eh)>
+
+ gets the next kid in the list. Gets 0 on error or when the list ends.
+
+ =item C<EndEnumWindows($eh)>
+
+ End enumeration and release the list.
+
+ =item C<@list = ChildWindows($hwnd)>
+
+ returns the list of child windows at the moment of the call. Same remark
+ as for enumeration interface applies. Example of usage:
+
+ sub l {
+ my ($o,$h) = @_;
+ printf ' ' x $o . "%#x\n", $h;
+ l($o+2,$_) for ChildWindows $h;
+ }
+ l 0, $HWND_DESKTOP
+
+ =item C<IsWindow($hwnd)>
+
+ true if the window handle is still valid.
+
+ =item C<QueryWindow($hwnd, $type)>
+
+ gets the handle of a related window. $type should be one of C<QW_*> constants.
+
+ =item C<IsChild($hwnd, $parent)>
+
+ return TRUE if $hwnd is a descendant of $parent.
+
+ =item C<WindowFromId($hwnd, $id)>
+
+ return a window handle of a child of $hwnd with the given $id.
+
+ hwndSysMenu = WinWindowFromID(hwndDlg, FID_SYSMENU);
+ WinSendMsg(hwndSysMenu, MM_SETITEMATTR,
+ MPFROM2SHORT(SC_CLOSE, TRUE),
+ MPFROM2SHORT(MIA_DISABLED, MIA_DISABLED));
+
+ =item C<WindowFromPoint($x, $y [, $hwndParent [, $descedantsToo]])>
+
+ gets a handle of a child of $hwndParent at C<($x,$y)>. If $descedantsToo
+ (defaulting to 0) then children of children may be returned too. May return
+ $hwndParent (defaults to desktop) if no suitable children are found,
+ or 0 if the point is outside the parent.
+
+ $x and $y are relative to $hwndParent.
+
+ =item C<EnumDlgItem($dlgHwnd, $type [, $relativeHwnd])>
+
+ gets a dialog item window handle for an item of type $type of $dlgHwnd
+ relative to $relativeHwnd, which is descendant of $dlgHwnd.
+ $relativeHwnd may be specified if $type is EDI_FIRSTTABITEM or
+ EDI_LASTTABITEM.
+
+ The return is always an immediate child of hwndDlg, even if hwnd is
+ not an immediate child window. $type may be
+
+ =over
+
+ =item EDI_FIRSTGROUPITEM
+
+ First item in the same group.
+
+ =item EDI_FIRSTTABITEM
+
+ First item in dialog with style WS_TABSTOP. hwnd is ignored.
+
+ =item EDI_LASTGROUPITEM
+
+ Last item in the same group.
+
+ =item EDI_LASTTABITEM
+
+ Last item in dialog with style WS_TABSTOP. hwnd is ignored.
+
+ =item EDI_NEXTGROUPITEM
+
+ Next item in the same group. Wraps around to beginning of group when
+ the end of the group is reached.
+
+ =item EDI_NEXTTABITEM
+
+ Next item with style WS_TABSTOP. Wraps around to beginning of dialog
+ item list when end is reached.
+
+ =item EDI_PREVGROUPITEM
+
+ Previous item in the same group. Wraps around to end of group when the
+ start of the group is reached. For information on the WS_GROUP style,
+ see Window Styles.
+
+ =item EDI_PREVTABITEM
+
+ Previous item with style WS_TABSTOP. Wraps around to end of dialog
+ item list when beginning is reached.
+
+ =back
+
+ =back
+
+ =head1 OS2::localMorphPM class
+
+ This class morphs the process to PM for the duration of the given context.
+
+ {
+ my $h = OS2::localMorphPM->new(0);
+ # Do something
+ }
+
+ The argument has the same meaning as one to OS2::MorphPM(). Calls can
+ nest with internal ones being NOPs.
+
+ =head1 TODO
+
+ Constants (currently one needs to get them looking in a header file):
+
+ HWND_*
+ WM_* /* Separate module? */
+ SC_*
+ SWP_*
+ WC_*
+ PROG_*
+ QW_*
+ EDI_*
+ WS_*
+
+ Show/Hide, Enable/Disable (WinShowWindow(), WinIsWindowVisible(),
+ WinEnableWindow(), WinIsWindowEnabled()).
+
+ Maximize/minimize/restore via WindowPos_set(), check via checking
+ WS_MAXIMIZED/WS_MINIMIZED flags (how to get them?).
+
+ =head1 $^E
+
+ the majority of the APIs of this module set $^E on failure (no matter
+ whether they die() on failure or not). By the semantic of PM API
+ which returns something other than a boolean, it is impossible to
+ distinguish failure from a "normal" 0-return. In such cases C<$^E ==
+ 0> indicates an absence of error.
+
+ =head1 BUGS
+
+ whether a given API dies or returns FALSE/empty-list on error may be
+ confusing. This may change in the future.
+
=head1 AUTHOR
! Andreas Kaiser <ak@ananke.s.bawue.de>,
Ilya Zakharevich <ilya@math.ohio-state.edu>.
=head1 SEE ALSO
! C<spawn*>() system calls, L<OS2::Proc> and L<OS2::WinObject> modules.
=cut
diff -c 'perl-5.7.1/os2/OS2/Process/Process.xs' 'perl-5.7.2/os2/OS2/Process/Process.xs'
Index: ./os2/OS2/Process/Process.xs
*** ./os2/OS2/Process/Process.xs Tue Mar 6 04:06:15 2001
--- ./os2/OS2/Process/Process.xs Mon Jul 9 17:11:07 2001
***************
*** 1,12 ****
- #include "EXTERN.h"
- #include "perl.h"
- #include "XSUB.h"
-
#include <process.h>
#define INCL_DOS
#define INCL_DOSERRORS
#include <os2.h>
static unsigned long
constant(char *name, int arg)
{
--- 1,18 ----
#include <process.h>
#define INCL_DOS
#define INCL_DOSERRORS
+ #define INCL_DOSNLS
+ #define INCL_WINSWITCHLIST
+ #define INCL_WINWINDOWMGR
+ #define INCL_WININPUT
+ #define INCL_VIO
+ #define INCL_KBD
#include <os2.h>
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+
static unsigned long
constant(char *name, int arg)
{
***************
*** 239,265 ****
return apptype;
}
static void
! fill_swcntrl(SWCNTRL *swcntrlp)
{
int rc;
- PTIB ptib;
- PPIB ppib;
HSWITCH hSwitch;
- HWND hwndMe;
if (!(_emx_env & 0x200))
croak("switch_entry not implemented on DOS"); /* not OS/2. */
- if (CheckOSError(DosGetInfoBlocks(&ptib, &ppib)))
- croak("DosGetInfoBlocks err %ld", rc);
if (CheckWinError(hSwitch =
! WinQuerySwitchHandle(NULLHANDLE,
! (PID)ppib->pib_ulpid)))
croak("WinQuerySwitchHandle err %ld", Perl_rc);
! if (CheckOSError(WinQuerySwitchEntry(hSwitch, swcntrlp)))
croak("WinQuerySwitchEntry err %ld", rc);
}
/* static ULONG (* APIENTRY16 pDosSmSetTitle)(ULONG, PSZ); */
ULONG _THUNK_FUNCTION(DosSmSetTitle)(ULONG, PSZ);
--- 245,491 ----
return apptype;
}
+ DeclFuncByORD(HSWITCH, myWinQuerySwitchHandle, ORD_WinQuerySwitchHandle,
+ (HWND hwnd, PID pid), (hwnd, pid))
+ DeclFuncByORD(ULONG, myWinQuerySwitchEntry, ORD_WinQuerySwitchEntry,
+ (HSWITCH hsw, PSWCNTRL pswctl), (hsw, pswctl))
+ DeclFuncByORD(ULONG, myWinSetWindowText, ORD_WinSetWindowText,
+ (HWND hwnd, char* text), (hwnd, text))
+ DeclFuncByORD(BOOL, myWinQueryWindowProcess, ORD_WinQueryWindowProcess,
+ (HWND hwnd, PPID ppid, PTID ptid), (hwnd, ppid, ptid))
+
+ DeclFuncByORD(ULONG, XmyWinSwitchToProgram, ORD_WinSwitchToProgram,
+ (HSWITCH hsw), (hsw))
+ #define myWinSwitchToProgram(hsw) (!CheckOSError(XmyWinSwitchToProgram(hsw)))
+
+ DeclFuncByORD(HWND, myWinQueryActiveWindow, ORD_WinQueryActiveWindow,
+ (HWND hwnd), (hwnd))
+
+
+ ULONG (*pWinQuerySwitchList) (HAB hab, PSWBLOCK pswblk, ULONG usDataLength);
+ ULONG (*pWinChangeSwitchEntry) (HSWITCH hsw, __const__ SWCNTRL *pswctl);
+
+ HWND (*pWinQueryWindow) (HWND hwnd, LONG cmd);
+ BOOL (*pWinQueryWindowPos) (HWND hwnd, PSWP pswp);
+ LONG (*pWinQueryWindowText) (HWND hwnd, LONG cchBufferMax, PCH pchBuffer);
+ LONG (*pWinQueryWindowTextLength) (HWND hwnd);
+ LONG (*pWinQueryClassName) (HWND hwnd, LONG cchMax, PCH pch);
+ HWND (*pWinQueryFocus) (HWND hwndDesktop);
+ BOOL (*pWinSetFocus) (HWND hwndDesktop, HWND hwndFocus);
+ BOOL (*pWinShowWindow) (HWND hwnd, BOOL fShow);
+ BOOL (*pWinPostMsg) (HWND hwnd, ULONG msg, MPARAM mp1, MPARAM mp2);
+ BOOL (*pWinSetWindowPos) (HWND hwnd, HWND hwndInsertBehind, LONG x, LONG y,
+ LONG cx, LONG cy, ULONG fl);
+ HENUM (*pWinBeginEnumWindows) (HWND hwnd);
+ BOOL (*pWinEndEnumWindows) (HENUM henum);
+ HWND (*pWinGetNextWindow) (HENUM henum);
+ BOOL (*pWinIsWindow) (HAB hab, HWND hwnd);
+ HWND (*pWinQueryWindow) (HWND hwnd, LONG cmd);
+
+ DeclWinFuncByORD(HWND, IsChild, ORD_WinIsChild,
+ (HWND hwnd, HWND hwndParent), (hwnd, hwndParent))
+ DeclWinFuncByORD(HWND, WindowFromId, ORD_WinWindowFromId,
+ (HWND hwnd, ULONG id), (hwnd, id))
+
+ HWND (*pWinWindowFromPoint)(HWND hwnd, __const__ POINTL *pptl, BOOL fChildren);
+
+ DeclWinFuncByORD(HWND, EnumDlgItem, ORD_WinEnumDlgItem,
+ (HWND hwndDlg, HWND hwnd, ULONG code), (hwndDlg, hwnd, code));
+
+ int
+ WindowText_set(HWND hwnd, char* text)
+ {
+ return !CheckWinError(myWinSetWindowText(hwnd, text));
+ }
+
+ LONG
+ QueryWindowTextLength(HWND hwnd)
+ {
+ LONG ret;
+
+ if (!pWinQueryWindowTextLength)
+ AssignFuncPByORD(pWinQueryWindowTextLength, ORD_WinQueryWindowTextLength);
+ ret = pWinQueryWindowTextLength(hwnd);
+ CheckWinError(ret); /* May put false positive */
+ return ret;
+ }
+
+ SV *
+ QueryWindowText(HWND hwnd)
+ {
+ LONG l = QueryWindowTextLength(hwnd);
+ SV *sv = newSVpvn("", 0);
+ STRLEN n_a;
+
+ if (l == 0)
+ return sv;
+ SvGROW(sv, l + 1);
+ if (!pWinQueryWindowText)
+ AssignFuncPByORD(pWinQueryWindowText, ORD_WinQueryWindowText);
+ CheckWinError(l = pWinQueryWindowText(hwnd, l + 1, SvPV_force(sv, n_a)));
+ SvCUR_set(sv, l);
+ return sv;
+ }
+
+ SWP
+ QueryWindowSWP_(HWND hwnd)
+ {
+ SWP swp;
+
+ if (!pWinQueryWindowPos)
+ AssignFuncPByORD(pWinQueryWindowPos, ORD_WinQueryWindowPos);
+ if (CheckWinError(pWinQueryWindowPos(hwnd, &swp)))
+ croak("WinQueryWindowPos() error");
+ return swp;
+ }
+
+ SV *
+ QueryWindowSWP(HWND hwnd)
+ {
+ SWP swp = QueryWindowSWP_(hwnd);
+
+ return newSVpvn((char*)&swp, sizeof(swp));
+ }
+
+ SV *
+ QueryClassName(HWND hwnd)
+ {
+ SV *sv = newSVpvn("",0);
+ STRLEN l = 46, len = 0, n_a;
+
+ if (!pWinQueryClassName)
+ AssignFuncPByORD(pWinQueryClassName, ORD_WinQueryClassName);
+ while (l + 1 >= len) {
+ if (len)
+ len = 2*len + 10; /* Grow quick */
+ else
+ len = l + 2;
+ SvGROW(sv, len);
+ l = pWinQueryClassName(hwnd, len, SvPV_force(sv, n_a));
+ CheckWinError(l);
+ SvCUR_set(sv, l);
+ }
+ return sv;
+ }
+
+ HWND
+ QueryFocusWindow(HWND hwndDesktop)
+ {
+ HWND ret;
+
+ if (!pWinQueryFocus)
+ AssignFuncPByORD(pWinQueryFocus, ORD_WinQueryFocus);
+ ret = pWinQueryFocus(hwndDesktop);
+ CheckWinError(ret);
+ return ret;
+ }
+
+ BOOL
+ FocusWindow_set(HWND hwndFocus, HWND hwndDesktop)
+ {
+ if (!pWinSetFocus)
+ AssignFuncPByORD(pWinSetFocus, ORD_WinSetFocus);
+ return !CheckWinError(pWinSetFocus(hwndDesktop, hwndFocus));
+ }
+
+ BOOL
+ ShowWindow(HWND hwnd, BOOL fShow)
+ {
+ if (!pWinShowWindow)
+ AssignFuncPByORD(pWinShowWindow, ORD_WinShowWindow);
+ return !CheckWinError(pWinShowWindow(hwnd, fShow));
+ }
+
+ BOOL
+ PostMsg(HWND hwnd, ULONG msg, ULONG mp1, ULONG mp2)
+ {
+ if (!pWinPostMsg)
+ AssignFuncPByORD(pWinPostMsg, ORD_WinPostMsg);
+ return !CheckWinError(pWinPostMsg(hwnd, msg, (MPARAM)mp1, (MPARAM)mp2));
+ }
+
+ BOOL
+ WindowPos_set(HWND hwnd, LONG x, LONG y, ULONG fl, LONG cx, LONG cy,
+ HWND hwndInsertBehind)
+ {
+ if (!pWinSetWindowPos)
+ AssignFuncPByORD(pWinSetWindowPos, ORD_WinSetWindowPos);
+ return !CheckWinError(pWinSetWindowPos(hwnd, hwndInsertBehind, x, y, cx, cy, fl));
+ }
+
+ HENUM
+ BeginEnumWindows(HWND hwnd)
+ {
+ if (!pWinBeginEnumWindows)
+ AssignFuncPByORD(pWinBeginEnumWindows, ORD_WinBeginEnumWindows);
+ return SaveWinError(pWinBeginEnumWindows(hwnd));
+ }
+
+ BOOL
+ EndEnumWindows(HENUM henum)
+ {
+ if (!pWinEndEnumWindows)
+ AssignFuncPByORD(pWinEndEnumWindows, ORD_WinEndEnumWindows);
+ return !CheckWinError(pWinEndEnumWindows(henum));
+ }
+
+ HWND
+ GetNextWindow(HENUM henum)
+ {
+ if (!pWinGetNextWindow)
+ AssignFuncPByORD(pWinGetNextWindow, ORD_WinGetNextWindow);
+ return SaveWinError(pWinGetNextWindow(henum));
+ }
+
+ BOOL
+ IsWindow(HWND hwnd, HAB hab)
+ {
+ if (!pWinIsWindow)
+ AssignFuncPByORD(pWinIsWindow, ORD_WinIsWindow);
+ return !CheckWinError(pWinIsWindow(hab, hwnd));
+ }
+
+ HWND
+ QueryWindow(HWND hwnd, LONG cmd)
+ {
+ if (!pWinQueryWindow)
+ AssignFuncPByORD(pWinQueryWindow, ORD_WinQueryWindow);
+ return !CheckWinError(pWinQueryWindow(hwnd, cmd));
+ }
+
+ HWND
+ WindowFromPoint(long x, long y, HWND hwnd, BOOL fChildren)
+ {
+ POINTL ppl;
+
+ ppl.x = x; ppl.y = y;
+ if (!pWinWindowFromPoint)
+ AssignFuncPByORD(pWinWindowFromPoint, ORD_WinWindowFromPoint);
+ return SaveWinError(pWinWindowFromPoint(hwnd, &ppl, fChildren));
+ }
+
static void
! fill_swentry(SWENTRY *swentryp, HWND hwnd, PID pid)
{
int rc;
HSWITCH hSwitch;
if (!(_emx_env & 0x200))
croak("switch_entry not implemented on DOS"); /* not OS/2. */
if (CheckWinError(hSwitch =
! myWinQuerySwitchHandle(hwnd, pid)))
croak("WinQuerySwitchHandle err %ld", Perl_rc);
! swentryp->hswitch = hSwitch;
! if (CheckOSError(myWinQuerySwitchEntry(hSwitch, &swentryp->swctl)))
croak("WinQuerySwitchEntry err %ld", rc);
}
+ static void
+ fill_swentry_default(SWENTRY *swentryp)
+ {
+ fill_swentry(swentryp, NULLHANDLE, getpid());
+ }
+
/* static ULONG (* APIENTRY16 pDosSmSetTitle)(ULONG, PSZ); */
ULONG _THUNK_FUNCTION(DosSmSetTitle)(ULONG, PSZ);
***************
*** 267,280 ****
static ULONG (*pDosSmSetTitle)(ULONG, PSZ);
static void
! set_title(char *s)
{
! SWCNTRL swcntrl;
static HMODULE hdosc = 0;
BYTE buf[20];
long rc;
! fill_swcntrl(&swcntrl);
if (!pDosSmSetTitle || !hdosc) {
if (CheckOSError(DosLoadModule(buf, sizeof buf, "sesmgr", &hdosc)))
croak("Cannot load SESMGR: no `%s'", buf);
--- 493,506 ----
static ULONG (*pDosSmSetTitle)(ULONG, PSZ);
static void
! sesmgr_title_set(char *s)
{
! SWENTRY swentry;
static HMODULE hdosc = 0;
BYTE buf[20];
long rc;
! fill_swentry_default(&swentry);
if (!pDosSmSetTitle || !hdosc) {
if (CheckOSError(DosLoadModule(buf, sizeof buf, "sesmgr", &hdosc)))
croak("Cannot load SESMGR: no `%s'", buf);
***************
*** 297,313 ****
#else /* !0 */
static bool
! set_title(char *s)
{
! SWCNTRL swcntrl;
! static HMODULE hdosc = 0;
! BYTE buf[20];
long rc;
! fill_swcntrl(&swcntrl);
rc = ((USHORT)
(_THUNK_PROLOG (2+4);
! _THUNK_SHORT (swcntrl.idSession);
_THUNK_FLAT (s);
_THUNK_CALL (DosSmSetTitle)));
#if 0
--- 523,537 ----
#else /* !0 */
static bool
! sesmgr_title_set(char *s)
{
! SWENTRY swentry;
long rc;
! fill_swentry_default(&swentry);
rc = ((USHORT)
(_THUNK_PROLOG (2+4);
! _THUNK_SHORT (swentry.swctl.idSession);
_THUNK_FLAT (s);
_THUNK_CALL (DosSmSetTitle)));
#if 0
***************
*** 336,341 ****
--- 560,904 ----
}
#endif
+ SV *
+ process_swentry(unsigned long pid, unsigned long hwnd)
+ {
+ SWENTRY swentry;
+
+ if (!(_emx_env & 0x200))
+ croak("process_swentry not implemented on DOS"); /* not OS/2. */
+ fill_swentry(&swentry, hwnd, pid);
+ return newSVpvn((char*)&swentry, sizeof(swentry));
+ }
+
+ SV *
+ swentries_list()
+ {
+ int num, n = 0;
+ STRLEN n_a;
+ PSWBLOCK pswblk;
+ SV *sv = newSVpvn("",0);
+
+ if (!(_emx_env & 0x200))
+ croak("swentries_list not implemented on DOS"); /* not OS/2. */
+ if (!pWinQuerySwitchList)
+ AssignFuncPByORD(pWinQuerySwitchList, ORD_WinQuerySwitchList);
+ num = pWinQuerySwitchList(0, NULL, 0); /* HAB is not required */
+ if (!num)
+ croak("(Unknown) error during WinQuerySwitchList()");
+ /* Allow one extra entry to allow overflow detection (may happen
+ if the list has been changed). */
+ while (num > n) {
+ if (n == 0)
+ n = num + 1;
+ else
+ n = 2*num + 10; /* Enlarge quickly */
+ SvGROW(sv, sizeof(ULONG) + sizeof(SWENTRY) * n + 1);
+ pswblk = (PSWBLOCK) SvPV_force(sv, n_a);
+ num = pWinQuerySwitchList(0, pswblk, SvLEN(sv));
+ }
+ SvCUR_set(sv, sizeof(ULONG) + sizeof(SWENTRY) * num);
+ *SvEND(sv) = 0;
+ return sv;
+ }
+
+ SWENTRY
+ swentry( char *title, HWND sw_hwnd, HWND icon_hwnd, HPROGRAM owner_phandle,
+ PID owner_pid, ULONG owner_sid, ULONG visible, ULONG nonswitchable,
+ ULONG jumpable, ULONG ptype, HSWITCH sw_entry)
+ {
+ SWENTRY e;
+
+ strncpy(e.swctl.szSwtitle, title, MAXNAMEL);
+ e.swctl.szSwtitle[60] = 0;
+ e.swctl.hwnd = sw_hwnd;
+ e.swctl.hwndIcon = icon_hwnd;
+ e.swctl.hprog = owner_phandle;
+ e.swctl.idProcess = owner_pid;
+ e.swctl.idSession = owner_sid;
+ e.swctl.uchVisibility = ((visible ? SWL_VISIBLE : SWL_INVISIBLE)
+ | (nonswitchable ? SWL_GRAYED : 0));
+ e.swctl.fbJump = (jumpable ? SWL_JUMPABLE : 0);
+ e.swctl.bProgType = ptype;
+ e.hswitch = sw_entry;
+ return e;
+ }
+
+ SV *
+ create_swentry( char *title, HWND owner_hwnd, HWND icon_hwnd, HPROGRAM owner_phandle,
+ PID owner_pid, ULONG owner_sid, ULONG visible, ULONG nonswitchable,
+ ULONG jumpable, ULONG ptype, HSWITCH sw_entry)
+ {
+ SWENTRY e = swentry(title, owner_hwnd, icon_hwnd, owner_phandle, owner_pid,
+ owner_sid, visible, nonswitchable, jumpable, ptype,
+ sw_entry);
+
+ return newSVpvn((char*)&e, sizeof(e));
+ }
+
+ int
+ change_swentrysw(SWENTRY *sw)
+ {
+ ULONG rc; /* For CheckOSError */
+
+ if (!(_emx_env & 0x200))
+ croak("change_entry() not implemented on DOS"); /* not OS/2. */
+ if (!pWinChangeSwitchEntry)
+ AssignFuncPByORD(pWinChangeSwitchEntry, ORD_WinChangeSwitchEntry);
+ return !CheckOSError(pWinChangeSwitchEntry(sw->hswitch, &sw->swctl));
+ }
+
+ int
+ change_swentry(SV *sv)
+ {
+ STRLEN l;
+ PSWENTRY pswentry = (PSWENTRY)SvPV(sv, l);
+
+ if (l != sizeof(SWENTRY))
+ croak("Wrong structure size %ld!=%ld in change_swentry()", (long)l, (long)sizeof(SWENTRY));
+ return change_swentrysw(pswentry);
+ }
+
+
+ #define swentry_size() (sizeof(SWENTRY))
+
+ void
+ getscrsize(int *wp, int *hp)
+ {
+ int i[2];
+
+ _scrsize(i);
+ *wp = i[0];
+ *hp = i[1];
+ }
+
+ /* Force vio to not cross 64K-boundary: */
+ #define VIO_FROM_VIOB \
+ vio = viob; \
+ if (!_THUNK_PTR_STRUCT_OK(vio)) \
+ vio++
+
+ bool
+ scrsize_set(int w, int h)
+ {
+ VIOMODEINFO viob[2], *vio;
+ ULONG rc;
+
+ VIO_FROM_VIOB;
+
+ if (h == -9999)
+ h = w, w = 0;
+ vio->cb = sizeof(*vio);
+ if (CheckOSError(VioGetMode( vio, 0 )))
+ return 0;
+
+ if( w > 0 )
+ vio->col = (USHORT)w;
+
+ if( h > 0 )
+ vio->row = (USHORT)h;
+
+ vio->cb = 8;
+ if (CheckOSError(VioSetMode( vio, 0 )))
+ return 0;
+ return 1;
+ }
+
+ void
+ cursor(int *sp, int *ep, int *wp, int *ap)
+ {
+ VIOCURSORINFO viob[2], *vio;
+ ULONG rc;
+
+ VIO_FROM_VIOB;
+
+ if (CheckOSError(VioGetCurType( vio, 0 )))
+ croak("VioGetCurType() error");
+
+ *sp = vio->yStart;
+ *ep = vio->cEnd;
+ *wp = vio->cx;
+ *ep = vio->attr;
+ }
+
+ bool
+ cursor__(int is_a)
+ {
+ int s,e,w,a;
+
+ cursor(&s, &e, &w, &a);
+ if (is_a)
+ return a;
+ else
+ return w;
+ }
+
+ bool
+ cursor_set(int s, int e, int w, int a)
+ {
+ VIOCURSORINFO viob[2], *vio;
+ ULONG rc;
+
+ VIO_FROM_VIOB;
+
+ vio->yStart = s;
+ vio->cEnd = e;
+ vio->cx = w;
+ vio->attr = a;
+ return !CheckOSError(VioSetCurType( vio, 0 ));
+ }
+
+ static int
+ bufsize(void)
+ {
+ #if 1
+ VIOMODEINFO viob[2], *vio;
+ ULONG rc;
+
+ VIO_FROM_VIOB;
+
+ vio->cb = sizeof(*vio);
+ if (CheckOSError(VioGetMode( vio, 0 )))
+ croak("Can't get size of buffer for screen");
+ #if 0 /* buf=323552247, full=1118455, partial=0 */
+ croak("Lengths: buf=%d, full=%d, partial=%d",vio->buf_length,vio->full_length,vio->partial_length);
+ return newSVpvn((char*)vio->buf_addr, vio->full_length);
+ #endif
+ return vio->col * vio->row * 2; /* How to get bytes/cell? 2 or 4? */
+ #else /* 0 */
+ int i[2];
+
+ _scrsize(i);
+ return i[0]*i[1]*2;
+ #endif /* 0 */
+ }
+
+ SV *
+ screen(void)
+ {
+ ULONG rc;
+ USHORT bufl = bufsize();
+ char b[(1<<16) * 3]; /* This/3 is enough for 16-bit calls, we need
+ 2x overhead due to 2 vs 4 issue, and extra
+ 64K due to alignment logic */
+ char *buf = b;
+
+ if (((ULONG)buf) & 0xFFFF)
+ buf += 0x10000 - (((ULONG)buf) & 0xFFFF);
+ if ((sizeof(b) - (buf - b)) < 2*bufl)
+ croak("panic: VIO buffer allocation");
+ if (CheckOSError(VioReadCellStr( buf, &bufl, 0, 0, 0 )))
+ return &PL_sv_undef;
+ return newSVpvn(buf,bufl);
+ }
+
+ bool
+ screen_set(SV *sv)
+ {
+ ULONG rc;
+ STRLEN l = SvCUR(sv), bufl = bufsize();
+ char b[(1<<16) * 2]; /* This/2 is enough for 16-bit calls, we need
+ extra 64K due to alignment logic */
+ char *buf = b;
+
+ if (((ULONG)buf) & 0xFFFF)
+ buf += 0x10000 - (((ULONG)buf) & 0xFFFF);
+ if (!SvPOK(sv) || ((l != bufl) && (l != 2*bufl)))
+ croak("Wrong size %d of saved screen data", SvCUR(sv));
+ if ((sizeof(b) - (buf - b)) < l)
+ croak("panic: VIO buffer allocation");
+ Copy(SvPV(sv,l), buf, bufl, char);
+ if (CheckOSError(VioWrtCellStr( buf, bufl, 0, 0, 0 )))
+ return 0;
+ return 1;
+ }
+
+ int
+ process_codepages()
+ {
+ ULONG cps[4], cp, rc;
+
+ if (CheckOSError(DosQueryCp( sizeof(cps), cps, &cp )))
+ croak("DosQueryCp() error");
+ return cp;
+ }
+
+ int
+ out_codepage()
+ {
+ USHORT cp, rc;
+
+ if (CheckOSError(VioGetCp( 0, &cp, 0 )))
+ croak("VioGetCp() error");
+ return cp;
+ }
+
+ bool
+ out_codepage_set(int cp)
+ {
+ USHORT rc;
+
+ return !(CheckOSError(VioSetCp( 0, cp, 0 )));
+ }
+
+ int
+ in_codepage()
+ {
+ USHORT cp, rc;
+
+ if (CheckOSError(KbdGetCp( 0, &cp, 0 )))
+ croak("KbdGetCp() error");
+ return cp;
+ }
+
+ bool
+ in_codepage_set(int cp)
+ {
+ USHORT rc;
+
+ return !(CheckOSError(KbdSetCp( 0, cp, 0 )));
+ }
+
+ bool
+ process_codepage_set(int cp)
+ {
+ USHORT rc;
+
+ return !(CheckOSError(DosSetProcessCp( cp )));
+ }
+
+ int
+ ppidOf(int pid)
+ {
+ PQTOPLEVEL psi;
+ int ppid;
+
+ if (!pid)
+ return -1;
+ psi = get_sysinfo(pid, QSS_PROCESS);
+ if (!psi)
+ return -1;
+ ppid = psi->procdata->ppid;
+ Safefree(psi);
+ return ppid;
+ }
+
+ int
+ sidOf(int pid)
+ {
+ PQTOPLEVEL psi;
+ int sid;
+
+ if (!pid)
+ return -1;
+ psi = get_sysinfo(pid, QSS_PROCESS);
+ if (!psi)
+ return -1;
+ sid = psi->procdata->sessid;
+ Safefree(psi);
+ return sid;
+ }
+
MODULE = OS2::Process PACKAGE = OS2::Process
***************
*** 351,376 ****
file_type(path)
char *path
! U32
! process_entry()
PPCODE:
{
! SWCNTRL swcntrl;
! fill_swcntrl(&swcntrl);
! EXTEND(sp,9);
! PUSHs(sv_2mortal(newSVpv(swcntrl.szSwtitle, 0)));
! PUSHs(sv_2mortal(newSVnv(swcntrl.hwnd)));
! PUSHs(sv_2mortal(newSVnv(swcntrl.hwndIcon)));
! PUSHs(sv_2mortal(newSViv(swcntrl.hprog)));
! PUSHs(sv_2mortal(newSViv(swcntrl.idProcess)));
! PUSHs(sv_2mortal(newSViv(swcntrl.idSession)));
! PUSHs(sv_2mortal(newSViv(swcntrl.uchVisibility != SWL_INVISIBLE)));
! PUSHs(sv_2mortal(newSViv(swcntrl.uchVisibility == SWL_GRAYED)));
! PUSHs(sv_2mortal(newSViv(swcntrl.fbJump == SWL_JUMPABLE)));
! PUSHs(sv_2mortal(newSViv(swcntrl.bProgType)));
}
bool
! set_title(s)
char *s
--- 914,1092 ----
file_type(path)
char *path
! SV *
! swentry_expand( SV *sv )
PPCODE:
{
! STRLEN l;
! PSWENTRY pswentry = (PSWENTRY)SvPV(sv, l);
! if (l != sizeof(SWENTRY))
! croak("Wrong structure size %ld!=%ld in swentry_expand()", (long)l, (long)sizeof(SWENTRY));
! EXTEND(sp,11);
! PUSHs(sv_2mortal(newSVpv(pswentry->swctl.szSwtitle, 0)));
! PUSHs(sv_2mortal(newSVnv(pswentry->swctl.hwnd)));
! PUSHs(sv_2mortal(newSVnv(pswentry->swctl.hwndIcon)));
! PUSHs(sv_2mortal(newSViv(pswentry->swctl.hprog)));
! PUSHs(sv_2mortal(newSViv(pswentry->swctl.idProcess)));
! PUSHs(sv_2mortal(newSViv(pswentry->swctl.idSession)));
! PUSHs(sv_2mortal(newSViv(pswentry->swctl.uchVisibility & SWL_VISIBLE)));
! PUSHs(sv_2mortal(newSViv(pswentry->swctl.uchVisibility & SWL_GRAYED)));
! PUSHs(sv_2mortal(newSViv(pswentry->swctl.fbJump == SWL_JUMPABLE)));
! PUSHs(sv_2mortal(newSViv(pswentry->swctl.bProgType)));
! PUSHs(sv_2mortal(newSViv(pswentry->hswitch)));
}
+ SV *
+ create_swentry( char *title, unsigned long sw_hwnd, unsigned long icon_hwnd, unsigned long owner_phandle, unsigned long owner_pid, unsigned long owner_sid, unsigned long visible, unsigned long switchable, unsigned long jumpable, unsigned long ptype, unsigned long sw_entry)
+
+ int
+ change_swentry( SV *sv )
+
bool
! sesmgr_title_set(s)
char *s
+
+ SV *
+ process_swentry(unsigned long pid = getpid(), unsigned long hwnd = NULLHANDLE);
+
+ int
+ swentry_size()
+
+ SV *
+ swentries_list()
+
+ int
+ WindowText_set(unsigned long hwndFrame, char *title)
+
+ bool
+ FocusWindow_set(unsigned long hwndFocus, unsigned long hwndDesktop = HWND_DESKTOP)
+
+ bool
+ ShowWindow(unsigned long hwnd, bool fShow = TRUE)
+
+ bool
+ PostMsg(unsigned long hwnd, unsigned long msg, unsigned long mp1 = 0, unsigned long mp2 = 0)
+
+ bool
+ WindowPos_set(unsigned long hwnd, long x, long y, unsigned long fl = SWP_MOVE, long cx = 0, long cy = 0, unsigned long hwndInsertBehind = HWND_TOP)
+
+ unsigned long
+ BeginEnumWindows(unsigned long hwnd)
+
+ bool
+ EndEnumWindows(unsigned long henum)
+
+ unsigned long
+ GetNextWindow(unsigned long henum)
+
+ bool
+ IsWindow(unsigned long hwnd, unsigned long hab = Acquire_hab())
+
+ unsigned long
+ QueryWindow(unsigned long hwnd, long cmd)
+
+ unsigned long
+ IsChild(unsigned long hwnd, unsigned long hwndParent)
+
+ unsigned long
+ WindowFromId(unsigned long hwndParent, unsigned long id)
+
+ unsigned long
+ WindowFromPoint(long x, long y, unsigned long hwnd, bool fChildren = 0)
+
+ unsigned long
+ EnumDlgItem(unsigned long hwndDlg, unsigned long code, unsigned long hwnd = NULLHANDLE)
+ C_ARGS: hwndDlg, hwnd, code
+
+ int
+ out_codepage()
+
+ bool
+ out_codepage_set(int cp)
+
+ int
+ in_codepage()
+
+ bool
+ in_codepage_set(int cp)
+
+ SV *
+ screen()
+
+ bool
+ screen_set(SV *sv)
+
+ SV *
+ process_codepages()
+ PPCODE:
+ {
+ ULONG cps[4], c, i = 0, rc;
+
+ if (CheckOSError(DosQueryCp( sizeof(cps), cps, &c )))
+ c = 0;
+ c /= sizeof(ULONG);
+ if (c >= 3)
+ EXTEND(sp, c);
+ while (i < c)
+ PUSHs(sv_2mortal(newSViv(cps[i++])));
+ }
+
+ bool
+ process_codepage_set(int cp)
+
+ MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = Query
+
+ unsigned long
+ QueryFocusWindow(unsigned long hwndDesktop = HWND_DESKTOP)
+
+ long
+ QueryWindowTextLength(unsigned long hwnd)
+
+ SV *
+ QueryWindowText(unsigned long hwnd)
+
+ SV *
+ QueryWindowSWP(unsigned long hwnd)
+
+ SV *
+ QueryClassName(unsigned long hwnd)
+
+ MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myWin
+
+ NO_OUTPUT BOOL
+ myWinQueryWindowProcess(unsigned long hwnd, OUTLIST unsigned long pid, OUTLIST unsigned long tid)
+ POSTCALL:
+ if (CheckWinError(RETVAL))
+ croak("QueryWindowProcess() error");
+
+ void
+ cursor(OUTLIST int stp, OUTLIST int ep, OUTLIST int wp, OUTLIST int ap)
+
+ bool
+ cursor_set(int s, int e, int w = cursor__(0), int a = cursor__(1))
+
+ int
+ myWinSwitchToProgram(unsigned long hsw)
+ PREINIT:
+ ULONG rc;
+
+ unsigned long
+ myWinQueryActiveWindow(unsigned long hwnd = HWND_DESKTOP)
+
+ MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = get
+
+ int
+ getppid()
+
+ int
+ ppidOf(int pid = getpid())
+
+ int
+ sidOf(int pid = getpid())
+
+ void
+ getscrsize(OUTLIST int wp, OUTLIST int hp)
+
+ bool
+ scrsize_set(int w_or_h, int h = -9999)
diff -c 'perl-5.7.1/os2/OS2/REXX/DLL/DLL.pm' 'perl-5.7.2/os2/OS2/REXX/DLL/DLL.pm'
Index: ./os2/OS2/REXX/DLL/DLL.pm
*** ./os2/OS2/REXX/DLL/DLL.pm Tue Mar 6 04:06:15 2001
--- ./os2/OS2/REXX/DLL/DLL.pm Mon Jul 9 17:11:08 2001
***************
*** 22,27 ****
--- 22,38 ----
# Cannot autoload, the autoloader is used for the REXX functions.
+ sub new {
+ confess 'Usage: OS2::DLL->new( <file> [<dirs>] )' unless @_ >= 2;
+ my ($class, $file) = (shift, shift);
+ my $handle;
+ $handle = $class->load($file, @_) and return $handle;
+ my $path = @_ ? " from '@_'" : '';
+ my $err = DynaLoader::dl_error();
+ $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//;
+ croak "Can't load '$file'$path: $err";
+ }
+
sub load
{
confess 'Usage: load OS2::DLL <file> [<dirs>]' unless $#_ >= 1;
***************
*** 108,114 ****
The DLL is not unloaded when the variable dies.
! Returns DLL object reference, or undef on failure.
=head2 Check for functions (optional):
--- 119,133 ----
The DLL is not unloaded when the variable dies.
! Returns DLL object reference, or undef on failure (in this case one can
! get the reason via C<DynaLoader::dl_error()>).
!
! =head2 Create a REXX DLL handle
!
! $dll = OS2::DLL->new( NAME [, WHERE] );
!
! Same as L<C<load>|Load REXX DLL>, but croaks with a meaningful message on
! failure.
=head2 Check for functions (optional):
diff -c 'perl-5.7.1/os2/OS2/REXX/REXX.xs' 'perl-5.7.2/os2/OS2/REXX/REXX.xs'
Index: ./os2/OS2/REXX/REXX.xs
*** ./os2/OS2/REXX/REXX.xs Tue Mar 6 04:06:16 2001
--- ./os2/OS2/REXX/REXX.xs Mon Jul 9 17:11:08 2001
***************
*** 25,33 ****
--- 25,35 ----
static int nvars;
static char * trace;
+ /*
static RXSTRING rxcommand = { 9, "RXCOMMAND" };
static RXSTRING rxsubroutine = { 12, "RXSUBROUTINE" };
static RXSTRING rxfunction = { 11, "RXFUNCTION" };
+ */
static ULONG PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret);
***************
*** 43,58 ****
static long incompartment;
static SV*
exec_in_REXX(pTHX_ char *cmd, char * handlerName, RexxFunctionHandler *handler)
{
- HMODULE hRexx, hRexxAPI;
- BYTE buf[200];
- LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING,
- PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING);
- APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ,
- RexxFunctionHandler *);
- APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ);
RXSTRING args[1];
RXSTRING inst[2];
RXSTRING result;
--- 45,61 ----
static long incompartment;
+ static LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING,
+ PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING);
+ static APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ,
+ RexxFunctionHandler *);
+ static APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ);
+
+ static ULONG (*pRexxVariablePool) (PSHVBLOCK pRequest);
+
static SV*
exec_in_REXX(pTHX_ char *cmd, char * handlerName, RexxFunctionHandler *handler)
{
RXSTRING args[1];
RXSTRING inst[2];
RXSTRING result;
***************
*** 64,79 ****
Perl_die(aTHX_ "Attempt to reenter into REXX compartment");
incompartment = 1;
- if (DosLoadModule(buf, sizeof buf, "REXX", &hRexx)
- || DosLoadModule(buf, sizeof buf, "REXXAPI", &hRexxAPI)
- || DosQueryProcAddr(hRexx, 0, "RexxStart", (PFN *)&pRexxStart)
- || DosQueryProcAddr(hRexxAPI, 0, "RexxRegisterFunctionExe",
- (PFN *)&pRexxRegisterFunctionExe)
- || DosQueryProcAddr(hRexxAPI, 0, "RexxDeregisterFunction",
- (PFN *)&pRexxDeregisterFunction)) {
- Perl_die(aTHX_ "REXX not available\n");
- }
-
if (handlerName)
pRexxRegisterFunctionExe(handlerName, handler);
--- 67,72 ----
***************
*** 86,93 ****
--- 79,88 ----
incompartment = 0;
pRexxDeregisterFunction("StartPerl");
+ #if 0 /* Do we want to restore these? */
DosFreeModule(hRexxAPI);
DosFreeModule(hRexx);
+ #endif
if (!RXNULLSTRING(result)) {
res = newSVpv(RXSTRPTR(result), RXSTRLEN(result));
DosFreeMem(RXSTRPTR(result));
***************
*** 128,134 ****
int i, rc;
unsigned long len;
char *str;
- char **arr;
SV *res;
dSP;
--- 123,128 ----
***************
*** 207,212 ****
--- 201,212 ----
static void
initialize(void)
{
+ *(PFN *)&pRexxStart = loadByOrdinal(ORD_RexxStart, 1);
+ *(PFN *)&pRexxRegisterFunctionExe
+ = loadByOrdinal(ORD_RexxRegisterFunctionExe, 1);
+ *(PFN *)&pRexxDeregisterFunction
+ = loadByOrdinal(ORD_RexxDeregisterFunction, 1);
+ *(PFN *)&pRexxVariablePool = loadByOrdinal(ORD_RexxVariablePool, 1);
needstrs(8);
needvars(8);
trace = getenv("PERL_REXX_DEBUG");
***************
*** 262,276 ****
MAKERXSTRING(var->shvvalue, value, valuelen);
if (trace)
fprintf(stderr, " %.*s='%.*s'",
! var->shvname.strlength, var->shvname.strptr,
! var->shvvalue.strlength, var->shvvalue.strptr);
}
if (trace)
fprintf(stderr, "\n");
vars[n-1].shvnext = NULL;
! rc = RexxVariablePool(vars);
if (trace)
! fprintf(stderr, " rc=%X\n", rc);
RETVAL = (rc & ~RXSHV_NEWV) ? FALSE : TRUE;
}
OUTPUT:
--- 262,276 ----
MAKERXSTRING(var->shvvalue, value, valuelen);
if (trace)
fprintf(stderr, " %.*s='%.*s'",
! (int)var->shvname.strlength, var->shvname.strptr,
! (int)var->shvvalue.strlength, var->shvvalue.strptr);
}
if (trace)
fprintf(stderr, "\n");
vars[n-1].shvnext = NULL;
! rc = pRexxVariablePool(vars);
if (trace)
! fprintf(stderr, " rc=%#lX\n", rc);
RETVAL = (rc & ~RXSHV_NEWV) ? FALSE : TRUE;
}
OUTPUT:
***************
*** 303,309 ****
if (trace)
fprintf(stderr, "\n");
vars[items-1].shvnext = NULL;
! rc = RexxVariablePool(vars);
if (!(rc & ~RXSHV_NEWV)) {
for (i = 0; i < items; ++i) {
int namelen;
--- 303,309 ----
if (trace)
fprintf(stderr, "\n");
vars[items-1].shvnext = NULL;
! rc = pRexxVariablePool(vars);
if (!(rc & ~RXSHV_NEWV)) {
for (i = 0; i < items; ++i) {
int namelen;
***************
*** 315,321 ****
namelen = var->shvvaluelen; /* is */
if (trace)
fprintf(stderr, " %.*s='%.*s'\n",
! var->shvname.strlength, var->shvname.strptr,
namelen, var->shvvalue.strptr);
if (var->shvret & RXSHV_NEWV || !var->shvvalue.strptr)
PUSHs(&PL_sv_undef);
--- 315,321 ----
namelen = var->shvvaluelen; /* is */
if (trace)
fprintf(stderr, " %.*s='%.*s'\n",
! (int)var->shvname.strlength, var->shvname.strptr,
namelen, var->shvvalue.strptr);
if (var->shvret & RXSHV_NEWV || !var->shvvalue.strptr)
PUSHs(&PL_sv_undef);
***************
*** 325,331 ****
}
} else {
if (trace)
! fprintf(stderr, " rc=%X\n", rc);
}
}
--- 325,331 ----
}
} else {
if (trace)
! fprintf(stderr, " rc=%#lX\n", rc);
}
}
***************
*** 351,357 ****
DosFreeMem(sv.shvvalue.strptr);
MAKERXSTRING(sv.shvvalue, NULL, 0);
}
! rc = RexxVariablePool(&sv);
} while (!rc && memcmp(stem, sv.shvname.strptr, len) != 0);
if (!rc) {
EXTEND(SP, 2);
--- 351,357 ----
DosFreeMem(sv.shvvalue.strptr);
MAKERXSTRING(sv.shvvalue, NULL, 0);
}
! rc = pRexxVariablePool(&sv);
} while (!rc && memcmp(stem, sv.shvname.strptr, len) != 0);
if (!rc) {
EXTEND(SP, 2);
***************
*** 377,383 ****
die("Error %i when in _next", rc);
} else {
if (trace)
! fprintf(stderr, " rc=%X\n", rc);
}
}
--- 377,383 ----
die("Error %i when in _next", rc);
} else {
if (trace)
! fprintf(stderr, " rc=%#lX\n", rc);
}
}
***************
*** 400,406 ****
MAKERXSTRING(var->shvvalue, NULL, 0);
}
vars[items-1].shvnext = NULL;
! RETVAL = (RexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE;
}
OUTPUT:
RETVAL
--- 400,406 ----
MAKERXSTRING(var->shvvalue, NULL, 0);
}
vars[items-1].shvnext = NULL;
! RETVAL = (pRexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE;
}
OUTPUT:
RETVAL
***************
*** 409,415 ****
_register(name)
char * name
CODE:
! RETVAL = RexxRegisterFunctionExe(name, PERLCALL);
OUTPUT:
RETVAL
--- 409,415 ----
_register(name)
char * name
CODE:
! RETVAL = pRexxRegisterFunctionExe(name, PERLCALL);
OUTPUT:
RETVAL
diff -c 'perl-5.7.1/os2/diff.configure' 'perl-5.7.2/os2/diff.configure'
Index: ./os2/diff.configure
*** ./os2/diff.configure Tue Mar 6 04:06:17 2001
--- ./os2/diff.configure Mon Jul 9 17:11:08 2001
***************
*** 1,32 ****
- --- Configure.orig Tue Feb 29 19:07:00 2000
- +++ Configure Thu Mar 2 10:10:24 2000
- @@ -1605,6 +1605,11 @@
- esac
- fi
- if test X"$trnl" = X; then
- + case "`echo foo|tr '\r\n' xy 2>/dev/null`" in
- + fooxy) trnl='\n\r' ;;
- + esac
- +fi
- +if test X"$trnl" = X; then
- cat <<EOM >&2
-
- $me: Fatal Error: cannot figure out how to translate newlines with 'tr'.
- @@ -1921,7 +1926,7 @@
- *)
- echo "I don't know where '$file' is, and my life depends on it." >&4
- echo "Go find a public domain implementation or fix your PATH setting!" >&4
- - exit 1
- + #exit 1
- ;;
- esac
- done
- @@ -5719,7 +5724,7 @@
- esac
- ;;
- esac
- -libnames='';
- +#libnames='';
- case "$libs" in
- '') ;;
- *) for thislib in $libs; do
--- 0 ----
diff -c 'perl-5.7.1/os2/dl_os2.c' 'perl-5.7.2/os2/dl_os2.c'
Index: ./os2/dl_os2.c
*** ./os2/dl_os2.c Tue Mar 6 04:06:17 2001
--- ./os2/dl_os2.c Mon Jul 9 17:11:08 2001
***************
*** 1,4 ****
--- 1,6 ----
#include "dlfcn.h"
+ #include "string.h"
+ #include "stdio.h"
#define INCL_BASE
#include <os2.h>
***************
*** 6,13 ****
static ULONG retcode;
static char fail[300];
void *
! dlopen(char *path, int mode)
{
HMODULE handle;
char tmp[260], *beg, *dot;
--- 8,17 ----
static ULONG retcode;
static char fail[300];
+ char *os2error(int rc);
+
void *
! dlopen(const char *path, int mode)
{
HMODULE handle;
char tmp[260], *beg, *dot;
***************
*** 14,24 ****
ULONG rc;
fail[0] = 0;
! if ((rc = DosLoadModule(fail, sizeof fail, path, &handle)) == 0)
return (void *)handle;
retcode = rc;
/* Not found. Check for non-FAT name and try truncated name. */
/* Don't know if this helps though... */
for (beg = dot = path + strlen(path);
--- 18,31 ----
ULONG rc;
fail[0] = 0;
! if ((rc = DosLoadModule(fail, sizeof fail, (char*)path, &handle)) == 0)
return (void *)handle;
retcode = rc;
+ if (strlen(path) >= sizeof(tmp))
+ return NULL;
+
/* Not found. Check for non-FAT name and try truncated name. */
/* Don't know if this helps though... */
for (beg = dot = path + strlen(path);
***************
*** 28,33 ****
--- 35,41 ----
dot = beg;
if (dot - beg > 8) {
int n = beg+8-path;
+
memmove(tmp, path, n);
memmove(tmp+n, dot, strlen(dot)+1);
if (DosLoadModule(fail, sizeof fail, tmp, &handle) == 0)
***************
*** 38,44 ****
}
void *
! dlsym(void *handle, char *symbol)
{
ULONG rc, type;
PFN addr;
--- 46,52 ----
}
void *
! dlsym(void *handle, const char *symbol)
{
ULONG rc, type;
PFN addr;
***************
*** 60,88 ****
{
static char buf[700];
ULONG len;
if (retcode == 0)
return NULL;
! if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, retcode,
! "OSO001.MSG", &len)) {
! if (fail[0])
! sprintf(buf,
! "OS/2 system error code %d, possible problematic module: '%s'",
! retcode, fail);
! else
! sprintf(buf, "OS/2 system error code %d", retcode);
! } else {
! buf[len] = '\0';
! if (len && buf[len - 1] == '\n')
! buf[--len] = 0;
! if (len && buf[len - 1] == '\r')
! buf[--len] = 0;
! if (len && buf[len - 1] == '.')
! buf[--len] = 0;
! if (fail[0] && len < 300)
! sprintf(buf + len, ", possible problematic module: '%s'",
! fail);
! }
retcode = 0;
return buf;
}
--- 68,84 ----
{
static char buf[700];
ULONG len;
+ char *err;
if (retcode == 0)
return NULL;
! err = os2error(retcode);
! len = strlen(err);
! if (len > sizeof(buf) - 1)
! len = sizeof(buf) - 1;
! strncpy(buf, err, len+1);
! if (fail[0] && len < 300)
! sprintf(buf + len, ", possible problematic module: '%s'", fail);
retcode = 0;
return buf;
}
diff -c 'perl-5.7.1/os2/dlfcn.h' 'perl-5.7.2/os2/dlfcn.h'
Index: ./os2/dlfcn.h
*** ./os2/dlfcn.h Tue Mar 6 04:06:17 2001
--- ./os2/dlfcn.h Mon Jul 9 17:11:08 2001
***************
*** 1,4 ****
! void *dlopen(char *path, int mode);
! void *dlsym(void *handle, char *symbol);
char *dlerror(void);
int dlclose(void *handle);
--- 1,4 ----
! void *dlopen(const char *path, int mode);
! void *dlsym(void *handle, const char *symbol);
char *dlerror(void);
int dlclose(void *handle);
diff -c 'perl-5.7.1/os2/os2.c' 'perl-5.7.2/os2/os2.c'
Index: ./os2/os2.c
*** ./os2/os2.c Tue Mar 6 04:06:17 2001
--- ./os2/os2.c Mon Jul 9 17:11:08 2001
***************
*** 21,26 ****
--- 21,28 ----
#include <limits.h>
#include <process.h>
#include <fcntl.h>
+ #include <pwd.h>
+ #include <grp.h>
#define PERLIO_NOT_STDIO 0
***************
*** 184,270 ****
/*****************************************************************************/
/* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
! static PFN ExtFCN[2]; /* Labeled by ord below. */
! static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
! #define ORD_QUERY_ELP 0
! #define ORD_SET_ELP 1
struct PMWIN_entries_t PMWIN_entries;
HMODULE
! loadModule(char *modname)
{
HMODULE h = (HMODULE)dlopen(modname, 0);
! if (!h)
Perl_croak_nocontext("Error loading module '%s': %s",
modname, dlerror());
return h;
}
! APIRET
! loadByOrd(char *modname, ULONG ord)
{
if (ExtFCN[ord] == NULL) {
! static HMODULE hdosc = 0;
! BYTE buf[20];
! PFN fcn;
APIRET rc;
!
! if (!hdosc) {
! hdosc = loadModule(modname);
! if (CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
! Perl_croak_nocontext(
! "This version of OS/2 does not support %s.%i",
! modname, loadOrd[ord]);
}
ExtFCN[ord] = fcn;
}
! if ((long)ExtFCN[ord] == -1)
Perl_croak_nocontext("panic queryaddr");
}
void
init_PMWIN_entries(void)
{
! static HMODULE hpmwin = 0;
! static const int ords[] = {
! 763, /* Initialize */
! 716, /* CreateMsgQueue */
! 726, /* DestroyMsgQueue */
! 918, /* PeekMsg */
! 915, /* GetMsg */
! 912, /* DispatchMsg */
! 753, /* GetLastError */
! 705, /* CancelShutdown */
! };
! BYTE buf[20];
! int i = 0;
! unsigned long rc;
! if (hpmwin)
! return;
!
! hpmwin = loadModule("pmwin");
! while (i < sizeof(ords)/sizeof(int)) {
! if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL,
! ((PFN*)&PMWIN_entries)+i)))
! Perl_croak_nocontext("This version of OS/2 does not support pmwin.%d", ords[i]);
! i++;
! }
}
/* priorities */
static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
self inverse. */
#define QSS_INI_BUFFER 1024
PQTOPLEVEL
get_sysinfo(ULONG pid, ULONG flags)
{
char *pbuffer;
ULONG rc, buf_len = QSS_INI_BUFFER;
New(1322, pbuffer, buf_len, char);
/* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
rc = QuerySysState(flags, pid, pbuffer, buf_len);
--- 186,384 ----
/*****************************************************************************/
/* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
! #define C_ARR_LEN(sym) (sizeof(sym)/sizeof(*sym))
!
! struct dll_handle {
! const char *modname;
! HMODULE handle;
! };
! static struct dll_handle doscalls_handle = {"doscalls", 0};
! static struct dll_handle tcp_handle = {"tcp32dll", 0};
! static struct dll_handle pmwin_handle = {"pmwin", 0};
! static struct dll_handle rexx_handle = {"rexx", 0};
! static struct dll_handle rexxapi_handle = {"rexxapi", 0};
! static struct dll_handle sesmgr_handle = {"sesmgr", 0};
! static struct dll_handle pmshapi_handle = {"pmshapi", 0};
!
! /* This should match enum entries_ordinals defined in os2ish.h. */
! static const struct {
! struct dll_handle *dll;
! const char *entryname;
! int entrypoint;
! } loadOrdinals[ORD_NENTRIES] = {
! {&doscalls_handle, NULL, 874}, /* DosQueryExtLibpath */
! {&doscalls_handle, NULL, 873}, /* DosSetExtLibpath */
! {&doscalls_handle, NULL, 460}, /* DosVerifyPidTid */
! {&tcp_handle, "SETHOSTENT", 0},
! {&tcp_handle, "SETNETENT" , 0},
! {&tcp_handle, "SETPROTOENT", 0},
! {&tcp_handle, "SETSERVENT", 0},
! {&tcp_handle, "GETHOSTENT", 0},
! {&tcp_handle, "GETNETENT" , 0},
! {&tcp_handle, "GETPROTOENT", 0},
! {&tcp_handle, "GETSERVENT", 0},
! {&tcp_handle, "ENDHOSTENT", 0},
! {&tcp_handle, "ENDNETENT", 0},
! {&tcp_handle, "ENDPROTOENT", 0},
! {&tcp_handle, "ENDSERVENT", 0},
! {&pmwin_handle, NULL, 763}, /* WinInitialize */
! {&pmwin_handle, NULL, 716}, /* WinCreateMsgQueue */
! {&pmwin_handle, NULL, 726}, /* WinDestroyMsgQueue */
! {&pmwin_handle, NULL, 918}, /* WinPeekMsg */
! {&pmwin_handle, NULL, 915}, /* WinGetMsg */
! {&pmwin_handle, NULL, 912}, /* WinDispatchMsg */
! {&pmwin_handle, NULL, 753}, /* WinGetLastError */
! {&pmwin_handle, NULL, 705}, /* WinCancelShutdown */
! /* These are needed in extensions.
! How to protect PMSHAPI: it comes through EMX functions? */
! {&rexx_handle, "RexxStart", 0},
! {&rexx_handle, "RexxVariablePool", 0},
! {&rexxapi_handle, "RexxRegisterFunctionExe", 0},
! {&rexxapi_handle, "RexxDeregisterFunction", 0},
! {&sesmgr_handle, "DOSSMSETTITLE", 0}, /* Would not work runtime-loaded */
! {&pmshapi_handle, "PRF32QUERYPROFILESIZE", 0},
! {&pmshapi_handle, "PRF32OPENPROFILE", 0},
! {&pmshapi_handle, "PRF32CLOSEPROFILE", 0},
! {&pmshapi_handle, "PRF32QUERYPROFILE", 0},
! {&pmshapi_handle, "PRF32RESET", 0},
! {&pmshapi_handle, "PRF32QUERYPROFILEDATA", 0},
! {&pmshapi_handle, "PRF32WRITEPROFILEDATA", 0},
!
! /* At least some of these do not work by name, since they need
! WIN32 instead of WIN... */
! #if 0
! These were generated with
! nm I:\emx\lib\os2.a | fgrep -f API-list | grep = > API-list-entries
! perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( ORD_$1,)" API-list-entries > API-list-ORD_
! perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( {${2}_handle, NULL, $3},\t\t/* $1 */)" WinSwitch-API-list-entries >API-list-entry
! #endif
! {&pmshapi_handle, NULL, 123}, /* WinChangeSwitchEntry */
! {&pmshapi_handle, NULL, 124}, /* WinQuerySwitchEntry */
! {&pmshapi_handle, NULL, 125}, /* WinQuerySwitchHandle */
! {&pmshapi_handle, NULL, 126}, /* WinQuerySwitchList */
! {&pmshapi_handle, NULL, 131}, /* WinSwitchToProgram */
! {&pmwin_handle, NULL, 702}, /* WinBeginEnumWindows */
! {&pmwin_handle, NULL, 737}, /* WinEndEnumWindows */
! {&pmwin_handle, NULL, 740}, /* WinEnumDlgItem */
! {&pmwin_handle, NULL, 756}, /* WinGetNextWindow */
! {&pmwin_handle, NULL, 768}, /* WinIsChild */
! {&pmwin_handle, NULL, 799}, /* WinQueryActiveWindow */
! {&pmwin_handle, NULL, 805}, /* WinQueryClassName */
! {&pmwin_handle, NULL, 817}, /* WinQueryFocus */
! {&pmwin_handle, NULL, 834}, /* WinQueryWindow */
! {&pmwin_handle, NULL, 837}, /* WinQueryWindowPos */
! {&pmwin_handle, NULL, 838}, /* WinQueryWindowProcess */
! {&pmwin_handle, NULL, 841}, /* WinQueryWindowText */
! {&pmwin_handle, NULL, 842}, /* WinQueryWindowTextLength */
! {&pmwin_handle, NULL, 860}, /* WinSetFocus */
! {&pmwin_handle, NULL, 875}, /* WinSetWindowPos */
! {&pmwin_handle, NULL, 877}, /* WinSetWindowText */
! {&pmwin_handle, NULL, 883}, /* WinShowWindow */
! {&pmwin_handle, NULL, 872}, /* WinIsWindow */
! {&pmwin_handle, NULL, 899}, /* WinWindowFromId */
! {&pmwin_handle, NULL, 900}, /* WinWindowFromPoint */
! {&pmwin_handle, NULL, 919}, /* WinPostMsg */
! };
!
! static PFN ExtFCN[C_ARR_LEN(loadOrdinals)]; /* Labeled by ord ORD_*. */
! const Perl_PFN * const pExtFCN = ExtFCN;
struct PMWIN_entries_t PMWIN_entries;
HMODULE
! loadModule(const char *modname, int fail)
{
HMODULE h = (HMODULE)dlopen(modname, 0);
!
! if (!h && fail)
Perl_croak_nocontext("Error loading module '%s': %s",
modname, dlerror());
return h;
}
! PFN
! loadByOrdinal(enum entries_ordinals ord, int fail)
{
if (ExtFCN[ord] == NULL) {
! PFN fcn = (PFN)-1;
APIRET rc;
! if (!loadOrdinals[ord].dll->handle)
! loadOrdinals[ord].dll->handle
! = loadModule(loadOrdinals[ord].dll->modname, fail);
! if (!loadOrdinals[ord].dll->handle)
! return 0; /* Possible with FAIL==0 only */
! if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle,
! loadOrdinals[ord].entrypoint,
! loadOrdinals[ord].entryname,&fcn))) {
! char buf[20], *s = (char*)loadOrdinals[ord].entryname;
!
! if (!fail)
! return 0;
! if (!s)
! sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint);
! Perl_croak_nocontext(
! "This version of OS/2 does not support %s.%s",
! loadOrdinals[ord].dll->modname, s);
}
ExtFCN[ord] = fcn;
}
! if ((long)ExtFCN[ord] == -1)
Perl_croak_nocontext("panic queryaddr");
+ return ExtFCN[ord];
}
void
init_PMWIN_entries(void)
{
! int i;
! for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++)
! ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1);
}
+ /*****************************************************/
+ /* socket forwarders without linking with tcpip DLLs */
+ DeclFuncByORD(struct hostent *, gethostent, ORD_GETHOSTENT, (void), ())
+ DeclFuncByORD(struct netent *, getnetent, ORD_GETNETENT, (void), ())
+ DeclFuncByORD(struct protoent *, getprotoent, ORD_GETPROTOENT, (void), ())
+ DeclFuncByORD(struct servent *, getservent, ORD_GETSERVENT, (void), ())
+
+ DeclVoidFuncByORD(sethostent, ORD_SETHOSTENT, (int x), (x))
+ DeclVoidFuncByORD(setnetent, ORD_SETNETENT, (int x), (x))
+ DeclVoidFuncByORD(setprotoent, ORD_SETPROTOENT, (int x), (x))
+ DeclVoidFuncByORD(setservent, ORD_SETSERVENT, (int x), (x))
+
+ DeclVoidFuncByORD(endhostent, ORD_ENDHOSTENT, (void), ())
+ DeclVoidFuncByORD(endnetent, ORD_ENDNETENT, (void), ())
+ DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ())
+ DeclVoidFuncByORD(endservent, ORD_ENDSERVENT, (void), ())
+
/* priorities */
static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
self inverse. */
#define QSS_INI_BUFFER 1024
+ ULONG (*pDosVerifyPidTid) (PID pid, TID tid);
+ static int pidtid_lookup;
+
PQTOPLEVEL
get_sysinfo(ULONG pid, ULONG flags)
{
char *pbuffer;
ULONG rc, buf_len = QSS_INI_BUFFER;
+ PQTOPLEVEL psi;
+ if (!pidtid_lookup) {
+ pidtid_lookup = 1;
+ *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0);
+ }
+ if (pDosVerifyPidTid) { /* Warp3 or later */
+ /* Up to some fixpak QuerySysState() kills the system if a non-existent
+ pid is used. */
+ if (!pDosVerifyPidTid(pid, 1))
+ return 0;
+ }
New(1322, pbuffer, buf_len, char);
/* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
rc = QuerySysState(flags, pid, pbuffer, buf_len);
***************
*** 277,283 ****
Safefree(pbuffer);
return 0;
}
! return (PQTOPLEVEL)pbuffer;
}
#define PRIO_ERR 0x1111
--- 391,402 ----
Safefree(pbuffer);
return 0;
}
! psi = (PQTOPLEVEL)pbuffer;
! if (psi && pid && pid != psi->procdata->pid) {
! Safefree(psi);
! Perl_croak_nocontext("panic: wrong pid in sysinfo");
! }
! return psi;
}
#define PRIO_ERR 0x1111
***************
*** 288,301 ****
ULONG prio;
PQTOPLEVEL psi;
psi = get_sysinfo(pid, QSS_PROCESS);
! if (!psi) {
return PRIO_ERR;
- }
- if (pid != psi->procdata->pid) {
- Safefree(psi);
- Perl_croak_nocontext("panic: wrong pid in sysinfo");
- }
prio = psi->procdata->threads->priority;
Safefree(psi);
return prio;
--- 407,417 ----
ULONG prio;
PQTOPLEVEL psi;
+ if (!pid)
+ return PRIO_ERR;
psi = get_sysinfo(pid, QSS_PROCESS);
! if (!psi)
return PRIO_ERR;
prio = psi->procdata->threads->priority;
Safefree(psi);
return prio;
***************
*** 304,314 ****
int
setpriority(int which, int pid, int val)
{
! ULONG rc, prio;
! PQTOPLEVEL psi;
- prio = sys_prio(pid);
-
if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
/* Do not change class. */
--- 420,427 ----
int
setpriority(int which, int pid, int val)
{
! ULONG rc, prio = sys_prio(pid);
if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
/* Do not change class. */
***************
*** 336,366 ****
abs(pid)))
? -1 : 0;
}
- /* else return CheckOSError(DosSetPriority((pid < 0) */
- /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
- /* priors[(32 - val) >> 5] + 1, */
- /* (32 - val) % 32 - (prio & 0xFF), */
- /* abs(pid))) */
- /* ? -1 : 0; */
}
int
getpriority(int which /* ignored */, int pid)
{
! TIB *tib;
! PIB *pib;
! ULONG rc, ret;
if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
- /* DosGetInfoBlocks has old priority! */
- /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
- /* if (pid != pib->pib_ulpid) { */
ret = sys_prio(pid);
if (ret == PRIO_ERR) {
return -1;
}
- /* } else */
- /* ret = tib->tib_ptib2->tib2_ulpri; */
return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
}
--- 449,466 ----
abs(pid)))
? -1 : 0;
}
}
int
getpriority(int which /* ignored */, int pid)
{
! ULONG ret;
if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
ret = sys_prio(pid);
if (ret == PRIO_ERR) {
return -1;
}
return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
}
***************
*** 486,500 ****
int trueflag = flag;
int rc, pass = 1;
char *tmps;
- char buf[256], *s = 0, scrbuf[280];
char *args[4];
static char * fargs[4]
= { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
char **argsp = fargs;
! char nargs = 4;
int force_shell;
! int new_stderr = -1, nostderr = 0, fl_stderr;
STRLEN n_a;
if (flag == P_WAIT)
flag = P_NOWAIT;
--- 586,602 ----
int trueflag = flag;
int rc, pass = 1;
char *tmps;
char *args[4];
static char * fargs[4]
= { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
char **argsp = fargs;
! int nargs = 4;
int force_shell;
! int new_stderr = -1, nostderr = 0;
! int fl_stderr = 0;
STRLEN n_a;
+ char *buf;
+ PerlIO *file;
if (flag == P_WAIT)
flag = P_NOWAIT;
***************
*** 571,576 ****
--- 673,680 ----
case FAPPTYP_NOTSPEC:
/* Let the shell handle this... */
force_shell = 1;
+ buf = ""; /* Pacify a warning */
+ file = 0; /* Pacify a warning */
goto doshell_args;
break;
}
***************
*** 620,642 ****
char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
if (scr) {
! PerlIO *file;
! SSize_t rd;
! char *s = 0, *s1, *s2;
! int l;
- l = strlen(scr);
-
- if (l >= sizeof scrbuf) {
- Safefree(scr);
- longbuf:
- Perl_warner(aTHX_ WARN_EXEC, "Size of scriptname too big: %d", l);
- rc = -1;
- goto finish;
- }
- strcpy(scrbuf, scr);
Safefree(scr);
! scr = scrbuf;
file = PerlIO_open(scr, "r");
PL_Argv[0] = scr;
--- 724,735 ----
char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
if (scr) {
! char *s = 0, *s1;
! SV *scrsv = sv_2mortal(newSVpv(scr, 0));
! SV *bufsv = sv_newmortal();
Safefree(scr);
! scr = SvPV(scrsv, n_a); /* free()ed later */
file = PerlIO_open(scr, "r");
PL_Argv[0] = scr;
***************
*** 643,654 ****
if (!file)
goto panic_file;
! rd = PerlIO_read(file, buf, sizeof buf-1);
! buf[rd]='\0';
! if ((s2 = strchr(buf, '\n')) != NULL) *++s2 = '\0';
!
! if (!rd) { /* Empty... */
! buf[0] = 0;
PerlIO_close(file);
/* Special case: maybe from -Zexe build, so
there is an executable around (contrary to
--- 736,745 ----
if (!file)
goto panic_file;
! buf = sv_gets(bufsv, file, 0 /* No append */);
! if (!buf)
! buf = ""; /* XXX Needed? */
! if (!buf[0]) { /* Empty... */
PerlIO_close(file);
/* Special case: maybe from -Zexe build, so
there is an executable around (contrary to
***************
*** 655,678 ****
documentation, DosQueryAppType sometimes (?)
does not append ".exe", so we could have
reached this place). */
! if (l + 5 < sizeof scrbuf) {
! strcpy(scrbuf + l, ".exe");
! if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
! && !S_ISDIR(PL_statbuf.st_mode)) {
! /* Found */
tmps = scr;
pass++;
goto reread;
! } else
! scrbuf[l] = 0;
! } else
! goto longbuf;
}
if (PerlIO_close(file) != 0) { /* Failure */
panic_file:
Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s",
scr, Strerror(errno));
! buf[0] = 0; /* Not #! */
goto doshell_args;
}
if (buf[0] == '#') {
--- 746,768 ----
documentation, DosQueryAppType sometimes (?)
does not append ".exe", so we could have
reached this place). */
! sv_catpv(scrsv, ".exe");
! scr = SvPV(scrsv, n_a); /* Reload */
! if (PerlLIO_stat(scr,&PL_statbuf) >= 0
! && !S_ISDIR(PL_statbuf.st_mode)) { /* Found */
tmps = scr;
pass++;
goto reread;
! } else { /* Restore */
! SvCUR_set(scrsv, SvCUR(scrsv) - 4);
! *SvEND(scrsv) = 0;
! }
}
if (PerlIO_close(file) != 0) { /* Failure */
panic_file:
Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s",
scr, Strerror(errno));
! buf = ""; /* Not #! */
goto doshell_args;
}
if (buf[0] == '#') {
***************
*** 688,694 ****
s = buf + 8;
}
if (!s) {
! buf[0] = 0; /* Not #! */
goto doshell_args;
}
--- 778,784 ----
s = buf + 8;
}
if (!s) {
! buf = ""; /* Not #! */
goto doshell_args;
}
***************
*** 719,724 ****
--- 809,815 ----
nargs = 4;
argsp = fargs;
}
+ /* Can jump from far, buf/file invalid if force_shell: */
doshell_args:
{
char **a = PL_Argv;
***************
*** 740,746 ****
if (inicmd) { /* No spaces at start! */
s = inicmd;
while (*s && !isSPACE(*s)) {
! if (*s++ = '/') {
inicmd = NULL; /* Cannot use */
break;
}
--- 831,837 ----
if (inicmd) { /* No spaces at start! */
s = inicmd;
while (*s && !isSPACE(*s)) {
! if (*s++ == '/') {
inicmd = NULL; /* Cannot use */
break;
}
***************
*** 840,849 ****
{
register char **a;
register char *s;
- char flags[10];
char *shell, *copt, *news = NULL;
! int rc, err, seenspace = 0, mergestderr = 0;
! char fullcmd[MAXNAMLEN + 1];
#ifdef TRYSHELL
if ((shell = getenv("EMXSHELL")) != NULL)
--- 931,938 ----
{
register char **a;
register char *s;
char *shell, *copt, *news = NULL;
! int rc, seenspace = 0, mergestderr = 0;
#ifdef TRYSHELL
if ((shell = getenv("EMXSHELL")) != NULL)
***************
*** 963,970 ****
/* Array spawn. */
int
! os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp)
{
register char **a;
int rc;
int flag = P_WAIT, flag_set = 0;
--- 1052,1061 ----
/* Array spawn. */
int
! os2_do_aspawn(pTHX_ SV *really, register void **vmark, register void **vsp)
{
+ register SV **mark = (SV **)vmark;
+ register SV **sp = (SV **)vsp;
register char **a;
int rc;
int flag = P_WAIT, flag_set = 0;
***************
*** 1028,1040 ****
my_syspopen(pTHX_ char *cmd, char *mode)
{
#ifndef USE_POPEN
-
int p[2];
register I32 this, that, newfd;
! register I32 pid, rc;
! PerlIO *res;
SV *sv;
! int fh_fl;
/* `this' is what we use in the parent, `that' in the child. */
this = (*mode == 'w');
--- 1119,1129 ----
my_syspopen(pTHX_ char *cmd, char *mode)
{
#ifndef USE_POPEN
int p[2];
register I32 this, that, newfd;
! register I32 pid;
SV *sv;
! int fh_fl = 0; /* Pacify the warning */
/* `this' is what we use in the parent, `that' in the child. */
this = (*mode == 'w');
***************
*** 1145,1195 ****
void * ttyname(x) { return 0; }
#endif
- /******************************************************************/
- /* my socket forwarders - EMX lib only provides static forwarders */
-
- static HMODULE htcp = 0;
-
- static void *
- tcp0(char *name)
- {
- PFN fcn;
-
- if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
- if (!htcp)
- htcp = loadModule("tcp32dll");
- if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
- return (void *) ((void * (*)(void)) fcn) ();
- return 0;
- }
-
- static void
- tcp1(char *name, int arg)
- {
- static BYTE buf[20];
- PFN fcn;
-
- if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
- if (!htcp)
- DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
- if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
- ((void (*)(int)) fcn) (arg);
- }
-
- struct hostent * gethostent() { return tcp0("GETHOSTENT"); }
- struct netent * getnetent() { return tcp0("GETNETENT"); }
- struct protoent * getprotoent() { return tcp0("GETPROTOENT"); }
- struct servent * getservent() { return tcp0("GETSERVENT"); }
-
- void sethostent(x) { tcp1("SETHOSTENT", x); }
- void setnetent(x) { tcp1("SETNETENT", x); }
- void setprotoent(x) { tcp1("SETPROTOENT", x); }
- void setservent(x) { tcp1("SETSERVENT", x); }
- void endhostent() { tcp0("ENDHOSTENT"); }
- void endnetent() { tcp0("ENDNETENT"); }
- void endprotoent() { tcp0("ENDPROTOENT"); }
- void endservent() { tcp0("ENDSERVENT"); }
-
/*****************************************************************************/
/* not implemented in C Set++ */
--- 1234,1239 ----
***************
*** 1207,1213 ****
used with 5.001. Now just look for /dev/. */
int
! os2_stat(char *name, struct stat *st)
{
static int ino = SHRT_MAX;
--- 1251,1257 ----
used with 5.001. Now just look for /dev/. */
int
! os2_stat(const char *name, struct stat *st)
{
static int ino = SHRT_MAX;
***************
*** 1291,1297 ****
--- 1335,1343 ----
XSRETURN(1);
}
+ #define PERL_PATCHLEVEL_H_IMPLICIT /* Do not init local_patches. */
#include "patchlevel.h"
+ #undef PERL_PATCHLEVEL_H_IMPLICIT
char *
mod2fname(pTHX_ SV *sv)
***************
*** 1299,1306 ****
static char fname[9];
int pos = 6, len, avlen;
unsigned int sum = 0;
- AV *av;
- SV *svp;
char *s;
STRLEN n_a;
--- 1345,1350 ----
***************
*** 1332,1338 ****
#ifdef USE_THREADS
sum++; /* Avoid conflict of DLLs in memory. */
#endif
! sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* */
fname[pos] = 'A' + (sum % 26);
fname[pos + 1] = 'A' + (sum / 26 % 26);
fname[pos + 2] = '\0';
--- 1376,1393 ----
#ifdef USE_THREADS
sum++; /* Avoid conflict of DLLs in memory. */
#endif
! /* We always load modules as *specific* DLLs, and with the full name.
! When loading a specific DLL by its full name, one cannot get a
! different DLL, even if a DLL with the same basename is loaded already.
! Thus there is no need to include the version into the mangling scheme. */
! #if 0
! sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */
! #else
! # ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */
! # define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
! # endif
! sum += COMPATIBLE_VERSION_SUM;
! #endif
fname[pos] = 'A' + (sum % 26);
fname[pos + 1] = 'A' + (sum / 26 % 26);
fname[pos + 2] = '\0';
***************
*** 1360,1379 ****
{
static char buf[300];
ULONG len;
if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
if (rc == 0)
! return NULL;
! if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
! sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
! else {
! buf[len] = '\0';
! if (len && buf[len - 1] == '\n')
! buf[--len] = 0;
! if (len && buf[len - 1] == '\r')
! buf[--len] = 0;
! if (len && buf[len - 1] == '.')
! buf[--len] = 0;
}
return buf;
}
--- 1415,1450 ----
{
static char buf[300];
ULONG len;
+ char *s;
+ int number = SvTRUE(get_sv("OS2::nsyserror", TRUE));
if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
if (rc == 0)
! return "";
! if (number) {
! sprintf(buf, "SYS%04d=%#x: ", rc, rc);
! s = buf + strlen(buf);
! } else
! s = buf;
! if (DosGetMessage(NULL, 0, s, sizeof(buf) - 1 - (s-buf),
! rc, "OSO001.MSG", &len)) {
! if (!number) {
! sprintf(buf, "SYS%04d=%#x: ", rc, rc);
! s = buf + strlen(buf);
! }
! sprintf(s, "[No description found in OSO001.MSG]");
! } else {
! s[len] = '\0';
! if (len && s[len - 1] == '\n')
! s[--len] = 0;
! if (len && s[len - 1] == '\r')
! s[--len] = 0;
! if (len && s[len - 1] == '.')
! s[--len] = 0;
! if (len >= 10 && number && strnEQ(s, buf, 7)
! && s[7] == ':' && s[8] == ' ')
! /* Some messages start with SYSdddd:, some not */
! Move(s + 9, s, (len -= 9) + 1, char);
}
return buf;
}
***************
*** 1761,1768 ****
if (items == 2) {
I32 cntr;
SV *sv = ST(1);
! int fake = SvIV(sv); /* Force SvIVX */
!
if (!SvIOK(sv))
Perl_croak_nocontext("Can't upgrade count to IV");
cntr = SvIVX(sv);
--- 1832,1839 ----
if (items == 2) {
I32 cntr;
SV *sv = ST(1);
!
! (void)SvIV(sv); /* Force SvIVX */
if (!SvIOK(sv))
Perl_croak_nocontext("Can't upgrade count to IV");
cntr = SvIVX(sv);
***************
*** 1900,1908 ****
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
! char * dir;
char p[MAXPATHLEN];
char * RETVAL;
if (items < 2)
dir = NULL;
--- 1971,1981 ----
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
! char * dir, *s, *t, *e;
char p[MAXPATHLEN];
char * RETVAL;
+ int l;
+ SV *sv;
if (items < 2)
dir = NULL;
***************
*** 1955,1962 ****
In all the cases it is safe to drop the drive part
of the path. */
if ( !sys_is_relative(path) ) {
- int is_drived;
-
if ( ( ( sys_is_absolute(dir)
|| (isALPHA(dir[0]) && dir[1] == ':'
&& strnicmp(dir, path,1) == 0))
--- 2028,2033 ----
***************
*** 1994,2021 ****
done:
}
}
ST(0) = sv_newmortal();
! sv_setpv((SV*)ST(0), RETVAL);
}
XSRETURN(1);
}
typedef APIRET (*PELP)(PSZ path, ULONG type);
APIRET
! ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
{
! loadByOrd("doscalls",ord); /* Guarantied to load or die! */
! return (*(PELP)ExtFCN[ord])(path, type);
}
! #define extLibpath(type) \
! (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
! : BEGIN_LIBPATH))) \
! ? NULL : to )
#define extLibpath_set(p,type) \
! (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
! : BEGIN_LIBPATH))))
XS(XS_Cwd_extLibpath)
{
--- 2065,2125 ----
done:
}
}
+ if (!RETVAL)
+ XSRETURN_EMPTY;
+ /* Backslashes are already converted to slashes. */
+ /* Remove trailing slashes */
+ l = strlen(RETVAL);
+ while (l > 0 && RETVAL[l-1] == '/')
+ l--;
ST(0) = sv_newmortal();
! sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
! /* Remove duplicate slashes, skipping the first three, which
! may be parts of a server-based path */
! s = t = 3 + SvPV_force(sv, n_a);
! e = SvEND(sv);
! /* Do not worry about multibyte chars here, this would contradict the
! eventual UTFization, and currently most other places break too... */
! while (s < e) {
! if (s[0] == t[-1] && s[0] == '/')
! s++; /* Skip duplicate / */
! else
! *t++ = *s++;
! }
! if (t < e) {
! *t = 0;
! SvCUR_set(sv, t - SvPVX(sv));
! }
}
XSRETURN(1);
}
typedef APIRET (*PELP)(PSZ path, ULONG type);
+ /* Kernels after 2000/09/15 understand this too: */
+ #ifndef LIBPATHSTRICT
+ # define LIBPATHSTRICT 3
+ #endif
+
APIRET
! ExtLIBPATH(ULONG ord, PSZ path, IV type)
{
! ULONG what;
! PFN f = loadByOrdinal(ord, 1); /* Guarantied to load or die! */
!
! if (type > 0)
! what = END_LIBPATH;
! else if (type == 0)
! what = BEGIN_LIBPATH;
! else
! what = LIBPATHSTRICT;
! return (*(PELP)f)(path, what);
}
! #define extLibpath(to,type) \
! (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) )
#define extLibpath_set(p,type) \
! (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type))))
XS(XS_Cwd_extLibpath)
{
***************
*** 2023,2029 ****
if (items < 0 || items > 1)
Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
{
! bool type;
char to[1024];
U32 rc;
char * RETVAL;
--- 2127,2133 ----
if (items < 0 || items > 1)
Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
{
! IV type;
char to[1024];
U32 rc;
char * RETVAL;
***************
*** 2031,2040 ****
if (items < 1)
type = 0;
else {
! type = (int)SvIV(ST(0));
}
! RETVAL = extLibpath(type);
ST(0) = sv_newmortal();
sv_setpv((SV*)ST(0), RETVAL);
}
--- 2135,2147 ----
if (items < 1)
type = 0;
else {
! type = SvIV(ST(0));
}
! to[0] = 1; to[1] = 0; /* Sometimes no error reported */
! RETVAL = extLibpath(to, type);
! if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
! Perl_croak_nocontext("panic Cwd::extLibpath parameter");
ST(0) = sv_newmortal();
sv_setpv((SV*)ST(0), RETVAL);
}
***************
*** 2049,2055 ****
{
STRLEN n_a;
char * s = (char *)SvPV(ST(0),n_a);
! bool type;
U32 rc;
bool RETVAL;
--- 2156,2162 ----
{
STRLEN n_a;
char * s = (char *)SvPV(ST(0),n_a);
! IV type;
U32 rc;
bool RETVAL;
***************
*** 2056,2062 ****
if (items < 2)
type = 0;
else {
! type = (int)SvIV(ST(1));
}
RETVAL = extLibpath_set(s, type);
--- 2163,2169 ----
if (items < 2)
type = 0;
else {
! type = SvIV(ST(1));
}
RETVAL = extLibpath_set(s, type);
***************
*** 2179,2185 ****
--- 2286,2296 ----
gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
GvMULTI_on(gv);
sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
+ gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+ sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
}
+ return 0;
}
OS2_Perl_data_t OS2_Perl_data;
***************
*** 2225,2231 ****
my_tmpnam (char *str)
{
char *p = getenv("TMP"), *tpath;
- int len;
if (!p) p = getenv("TEMP");
tpath = tempnam(p, "pltmp");
--- 2336,2341 ----
***************
*** 2392,2395 ****
--- 2502,2610 ----
errno = 0;
return 0;
+ }
+
+ static int pwent_cnt;
+ static int _my_pwent = -1;
+
+ static int
+ use_my_pwent(void)
+ {
+ if (_my_pwent == -1) {
+ char *s = getenv("USE_PERL_PWENT");
+ if (s)
+ _my_pwent = atoi(s);
+ else
+ _my_pwent = 1;
+ }
+ return _my_pwent;
+ }
+
+ #undef setpwent
+ #undef getpwent
+ #undef endpwent
+
+ void
+ my_setpwent(void)
+ {
+ if (!use_my_pwent()) {
+ setpwent(); /* Delegate to EMX. */
+ return;
+ }
+ pwent_cnt = 0;
+ }
+
+ void
+ my_endpwent(void)
+ {
+ if (!use_my_pwent()) {
+ endpwent(); /* Delegate to EMX. */
+ return;
+ }
+ }
+
+ struct passwd *
+ my_getpwent (void)
+ {
+ if (!use_my_pwent())
+ return getpwent(); /* Delegate to EMX. */
+ if (pwent_cnt++)
+ return 0; // Return one entry only
+ return getpwuid(0);
+ }
+
+ static int grent_cnt;
+
+ void
+ setgrent(void)
+ {
+ grent_cnt = 0;
+ }
+
+ void
+ endgrent(void)
+ {
+ }
+
+ struct group *
+ getgrent (void)
+ {
+ if (grent_cnt++)
+ return 0; // Return one entry only
+ return getgrgid(0);
+ }
+
+ #undef getpwuid
+ #undef getpwnam
+
+ /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
+ static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
+
+ static struct passwd *
+ passw_wrap(struct passwd *p)
+ {
+ static struct passwd pw;
+ char *s;
+
+ if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
+ return p;
+ pw = *p;
+ s = getenv("PW_PASSWD");
+ if (!s)
+ s = (char*)pw_p; /* Make match impossible */
+
+ pw.pw_passwd = s;
+ return &pw;
+ }
+
+ struct passwd *
+ my_getpwuid (uid_t id)
+ {
+ return passw_wrap(getpwuid(id));
+ }
+
+ struct passwd *
+ my_getpwnam (__const__ char *n)
+ {
+ return passw_wrap(getpwnam(n));
}
diff -c /dev/null 'perl-5.7.2/os2/os2_base.t'
Index: ./os2/os2_base.t
*** ./os2/os2_base.t Thu Jan 1 02:00:00 1970
--- ./os2/os2_base.t Mon Jul 9 17:11:08 2001
***************
*** 0 ****
--- 1,49 ----
+ print "1.." . lasttest() . "\n";
+
+ $cwd = Cwd::sys_cwd();
+ print "ok 1\n";
+ print "not " unless -d $cwd;
+ print "ok 2\n";
+
+ $lpb = Cwd::extLibpath;
+ print "ok 3\n";
+ $lpb .= ';' unless $lpb and $lpb =~ /;$/;
+
+ $lpe = Cwd::extLibpath(1);
+ print "ok 4\n";
+ $lpe .= ';' unless $lpe and $lpe =~ /;$/;
+
+ Cwd::extLibpath_set("$lpb$cwd") or print "not ";
+ print "ok 5\n";
+
+ $lpb = Cwd::extLibpath;
+ print "ok 6\n";
+ $lpb =~ s#\\#/#g;
+ ($s_cwd = $cwd) =~ s#\\#/#g;
+
+ print "not " unless $lpb =~ /\Q$s_cwd/;
+ print "ok 7\n";
+
+ Cwd::extLibpath_set("$lpe$cwd", 1) or print "not ";
+ print "ok 8\n";
+
+ $lpe = Cwd::extLibpath(1);
+ print "ok 9\n";
+ $lpe =~ s#\\#/#g;
+
+ print "not " unless $lpe =~ /\Q$s_cwd/;
+ print "ok 10\n";
+
+ unshift @INC, 'lib';
+ require OS2::Process;
+ @l = OS2::Process::process_entry();
+ print "not " unless @l == 11;
+ print "ok 11\n";
+
+ # 1: FS 2: Window-VIO
+ print "not " unless $l[9] == 1 or $l[9] == 2;
+ print "ok 12\n";
+
+ print "# $_\n" for @l;
+
+ sub lasttest {12}
diff -c 'perl-5.7.1/os2/os2ish.h' 'perl-5.7.2/os2/os2ish.h'
Index: ./os2/os2ish.h
*** ./os2/os2ish.h Tue Mar 6 04:06:17 2001
--- ./os2/os2ish.h Mon Jul 9 17:11:08 2001
***************
*** 1,4 ****
--- 1,6 ----
#include <signal.h>
+ #include <io.h>
+ /* #include <sys/select.h> */
/* HAS_IOCTL:
* This symbol, if defined, indicates that the ioctl() routine is
***************
*** 17,22 ****
--- 19,41 ----
#define HAS_DLERROR
#define HAS_WAITPID_RUNTIME (_emx_env & 0x200)
+ /* HAS_PASSWD
+ * This symbol, if defined, indicates that the getpwnam() and
+ * getpwuid() routines are available to get password entries.
+ * The getpwent() has a separate definition, HAS_GETPWENT.
+ */
+ #define HAS_PASSWD
+
+ /* HAS_GROUP
+ * This symbol, if defined, indicates that the getgrnam() and
+ * getgrgid() routines are available to get group entries.
+ * The getgrent() has a separate definition, HAS_GETGRENT.
+ */
+ #define HAS_GROUP
+ #define HAS_GETGRENT /* fake */
+ #define HAS_SETGRENT /* fake */
+ #define HAS_ENDGRENT /* fake */
+
/* USEMYBINMODE
* This symbol, if defined, indicates that the program should
* use the routine my_binmode(FILE *fp, char iotype, int mode) to insure
***************
*** 263,269 ****
--- 282,298 ----
char *my_tmpnam (char *);
int my_mkdir (__const__ char *, long);
int my_rmdir (__const__ char *);
+ struct passwd *my_getpwent (void);
+ void my_setpwent (void);
+ void my_endpwent (void);
+ struct group *getgrent (void);
+ void setgrent (void);
+ void endgrent (void);
+
+ struct passwd *my_getpwuid (uid_t);
+ struct passwd *my_getpwnam (__const__ char *);
+
#undef L_tmpnam
#define L_tmpnam MAXPATHLEN
***************
*** 287,292 ****
--- 316,326 ----
#define flock my_flock
#define rmdir my_rmdir
#define mkdir my_mkdir
+ #define setpwent my_setpwent
+ #define getpwent my_getpwent
+ #define endpwent my_endpwent
+ #define getpwuid my_getpwuid
+ #define getpwnam my_getpwnam
void *emx_calloc (size_t, size_t);
void emx_free (void *);
***************
*** 435,444 ****
--- 469,635 ----
#define STATIC_FILE_LENGTH 127
+ /* This should match loadOrdinals[] array in os2.c */
+ enum entries_ordinals {
+ ORD_DosQueryExtLibpath,
+ ORD_DosSetExtLibpath,
+ ORD_DosVerifyPidTid,
+ ORD_SETHOSTENT,
+ ORD_SETNETENT,
+ ORD_SETPROTOENT,
+ ORD_SETSERVENT,
+ ORD_GETHOSTENT,
+ ORD_GETNETENT,
+ ORD_GETPROTOENT,
+ ORD_GETSERVENT,
+ ORD_ENDHOSTENT,
+ ORD_ENDNETENT,
+ ORD_ENDPROTOENT,
+ ORD_ENDSERVENT,
+ ORD_WinInitialize,
+ ORD_WinCreateMsgQueue,
+ ORD_WinDestroyMsgQueue,
+ ORD_WinPeekMsg,
+ ORD_WinGetMsg,
+ ORD_WinDispatchMsg,
+ ORD_WinGetLastError,
+ ORD_WinCancelShutdown,
+ ORD_RexxStart,
+ ORD_RexxVariablePool,
+ ORD_RexxRegisterFunctionExe,
+ ORD_RexxDeregisterFunction,
+ ORD_DOSSMSETTITLE,
+ ORD_PRF32QUERYPROFILESIZE,
+ ORD_PRF32OPENPROFILE,
+ ORD_PRF32CLOSEPROFILE,
+ ORD_PRF32QUERYPROFILE,
+ ORD_PRF32RESET,
+ ORD_PRF32QUERYPROFILEDATA,
+ ORD_PRF32WRITEPROFILEDATA,
+
+ ORD_WinChangeSwitchEntry,
+ ORD_WinQuerySwitchEntry,
+ ORD_WinQuerySwitchHandle,
+ ORD_WinQuerySwitchList,
+ ORD_WinSwitchToProgram,
+ ORD_WinBeginEnumWindows,
+ ORD_WinEndEnumWindows,
+ ORD_WinEnumDlgItem,
+ ORD_WinGetNextWindow,
+ ORD_WinIsChild,
+ ORD_WinQueryActiveWindow,
+ ORD_WinQueryClassName,
+ ORD_WinQueryFocus,
+ ORD_WinQueryWindow,
+ ORD_WinQueryWindowPos,
+ ORD_WinQueryWindowProcess,
+ ORD_WinQueryWindowText,
+ ORD_WinQueryWindowTextLength,
+ ORD_WinSetFocus,
+ ORD_WinSetWindowPos,
+ ORD_WinSetWindowText,
+ ORD_WinShowWindow,
+ ORD_WinIsWindow,
+ ORD_WinWindowFromId,
+ ORD_WinWindowFromPoint,
+ ORD_WinPostMsg,
+ ORD_NENTRIES
+ };
+
+ /* RET: return type, AT: argument signature in (), ARGS: should be in () */
+ #define CallORD(ret,o,at,args) (((ret (*)at) loadByOrdinal(o, 1))args)
+ #define DeclFuncByORD(ret,name,o,at,args) \
+ ret name at { return CallORD(ret,o,at,args); }
+ #define DeclVoidFuncByORD(name,o,at,args) \
+ void name at { CallORD(void,o,at,args); }
+
+ /* These functions return false on error, and save the error info in $^E */
+ #define DeclOSFuncByORD(ret,name,o,at,args) \
+ ret name at { unsigned long rc; return !CheckOSError(CallORD(ret,o,at,args)); }
+ #define DeclWinFuncByORD(ret,name,o,at,args) \
+ ret name at { return SaveWinError(CallORD(ret,o,at,args)); }
+
+ #define AssignFuncPByORD(p,o) (*(Perl_PFN*)&(p) = (loadByOrdinal(o, 1)))
+
#define PERLLIB_MANGLE(s, n) perllib_mangle((s), (n))
char *perllib_mangle(char *, unsigned int);
+ typedef int (*Perl_PFN)();
+ Perl_PFN loadByOrdinal(enum entries_ordinals ord, int fail);
+ extern const Perl_PFN * const pExtFCN;
char *os2error(int rc);
+ int os2_stat(const char *name, struct stat *st);
+ int setpriority(int which, int pid, int val);
+ int getpriority(int which /* ignored */, int pid);
+
+ #ifdef PERL_CORE
+ int os2_do_spawn(pTHX_ char *cmd);
+ int os2_do_aspawn(pTHX_ SV *really, void **vmark, void **vsp);
+ #endif
+
+ #ifndef LOG_DAEMON
+
+ /* Replacement for syslog.h */
+ # define LOG_EMERG 0 /* system is unusable */
+ # define LOG_ALERT 1 /* action must be taken immediately */
+ # define LOG_CRIT 2 /* critical conditions */
+ # define LOG_ERR 3 /* error conditions */
+ # define LOG_WARNING 4 /* warning conditions */
+ # define LOG_NOTICE 5 /* normal but significant condition */
+ # define LOG_INFO 6 /* informational */
+ # define LOG_DEBUG 7 /* debug-level messages */
+
+ # define LOG_PRIMASK 0x007 /* mask to extract priority part (internal) */
+ /* extract priority */
+ # define LOG_PRI(p) ((p) & LOG_PRIMASK)
+ # define LOG_MAKEPRI(fac, pri) (((fac) << 3) | (pri))
+
+ /* facility codes */
+ # define LOG_KERN (0<<3) /* kernel messages */
+ # define LOG_USER (1<<3) /* random user-level messages */
+ # define LOG_MAIL (2<<3) /* mail system */
+ # define LOG_DAEMON (3<<3) /* system daemons */
+ # define LOG_AUTH (4<<3) /* security/authorization messages */
+ # define LOG_SYSLOG (5<<3) /* messages generated internally by syslogd */
+ # define LOG_LPR (6<<3) /* line printer subsystem */
+ # define LOG_NEWS (7<<3) /* network news subsystem */
+ # define LOG_UUCP (8<<3) /* UUCP subsystem */
+ # define LOG_CRON (15<<3) /* clock daemon */
+ /* other codes through 15 reserved for system use */
+ # define LOG_LOCAL0 (16<<3) /* reserved for local use */
+ # define LOG_LOCAL1 (17<<3) /* reserved for local use */
+ # define LOG_LOCAL2 (18<<3) /* reserved for local use */
+ # define LOG_LOCAL3 (19<<3) /* reserved for local use */
+ # define LOG_LOCAL4 (20<<3) /* reserved for local use */
+ # define LOG_LOCAL5 (21<<3) /* reserved for local use */
+ # define LOG_LOCAL6 (22<<3) /* reserved for local use */
+ # define LOG_LOCAL7 (23<<3) /* reserved for local use */
+
+ # define LOG_NFACILITIES 24 /* current number of facilities */
+ # define LOG_FACMASK 0x03f8 /* mask to extract facility part */
+ /* facility of pri */
+ # define LOG_FAC(p) (((p) & LOG_FACMASK) >> 3)
+
+ /*
+ * arguments to setlogmask.
+ */
+ # define LOG_MASK(pri) (1 << (pri)) /* mask for one priority */
+ # define LOG_UPTO(pri) ((1 << ((pri)+1)) - 1) /* all priorities through pri */
+
+ /*
+ * Option flags for openlog.
+ *
+ * LOG_ODELAY no longer does anything.
+ * LOG_NDELAY is the inverse of what it used to be.
+ */
+ # define LOG_PID 0x01 /* log the pid with each message */
+ # define LOG_CONS 0x02 /* log on the console if errors in sending */
+ # define LOG_ODELAY 0x04 /* delay open until first syslog() (default) */
+ # define LOG_NDELAY 0x08 /* don't delay open */
+ # define LOG_NOWAIT 0x10 /* don't wait for console forks: DEPRECATED */
+ # define LOG_PERROR 0x20 /* log to stderr as well */
+
+ #endif
/* ************************************************************ */
#define Dos32QuerySysState DosQuerySysState
diff -c 'perl-5.7.1/perl.c' 'perl-5.7.2/perl.c'
Index: ./perl.c
*** ./perl.c Wed Apr 4 07:14:46 2001
--- ./perl.c Thu Jul 12 08:58:40 2001
***************
*** 58,63 ****
--- 58,86 ----
} STMT_END
#else
# if defined(USE_ITHREADS)
+
+ /* this is called in parent before the fork() */
+ void
+ Perl_atfork_lock(void)
+ {
+ /* locks must be held in locking order (if any) */
+ #ifdef MYMALLOC
+ MUTEX_LOCK(&PL_malloc_mutex);
+ #endif
+ OP_REFCNT_LOCK;
+ }
+
+ /* this is called in both parent and child after the fork() */
+ void
+ Perl_atfork_unlock(void)
+ {
+ /* locks must be released in same order as in S_atfork_lock() */
+ #ifdef MYMALLOC
+ MUTEX_UNLOCK(&PL_malloc_mutex);
+ #endif
+ OP_REFCNT_UNLOCK;
+ }
+
# define INIT_TLS_AND_INTERP \
STMT_START { \
if (!PL_curinterp) { \
***************
*** 149,155 ****
perl_construct(pTHXx)
{
#ifdef USE_THREADS
- int i;
#ifndef FAKE_THREADS
struct perl_thread *thr = NULL;
#endif /* FAKE_THREADS */
--- 172,177 ----
***************
*** 227,234 ****
* space. The other alternative would be to provide STDAUX and STDPRN
* filehandles.
*/
! (void)fclose(stdaux);
! (void)fclose(stdprn);
#endif
}
--- 249,256 ----
* space. The other alternative would be to provide STDAUX and STDPRN
* filehandles.
*/
! (void)PerlIO_close(PerlIO_importFILE(stdaux, 0));
! (void)PerlIO_close(PerlIO_importFILE(stdprn, 0));
#endif
}
***************
*** 284,290 ****
PL_fdpid = newAV(); /* for remembering popen pids by fd */
PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
PL_errors = newSVpvn("",0);
!
ENTER;
}
--- 306,318 ----
PL_fdpid = newAV(); /* for remembering popen pids by fd */
PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
PL_errors = newSVpvn("",0);
! #ifdef USE_ITHREADS
! PL_regex_padav = newAV();
! #endif
! #ifdef USE_REENTRANT_API
! New(31337, PL_reentrant_buffer,1, REBUF);
! New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
! #endif
ENTER;
}
***************
*** 585,591 ****
#ifdef USE_LOCALE_NUMERIC
Safefree(PL_numeric_name);
PL_numeric_name = Nullch;
! SvREFCNT_dec(PL_numeric_radix);
#endif
/* clear utf8 character classes */
--- 613,619 ----
#ifdef USE_LOCALE_NUMERIC
Safefree(PL_numeric_name);
PL_numeric_name = Nullch;
! SvREFCNT_dec(PL_numeric_radix_sv);
#endif
/* clear utf8 character classes */
***************
*** 777,782 ****
--- 805,815 ----
PL_thrsv = Nullsv;
#endif /* USE_THREADS */
+ #ifdef USE_REENTRANT_API
+ Safefree(PL_reentrant_buffer->tmbuff);
+ Safefree(PL_reentrant_buffer);
+ #endif
+
sv_free_arenas();
/* As the absolutely last thing, free the non-arena SV for mess() */
***************
*** 788,794 ****
MAGIC* moremagic;
for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
moremagic = mg->mg_moremagic;
! if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
Safefree(mg->mg_ptr);
Safefree(mg);
}
--- 821,828 ----
MAGIC* moremagic;
for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
moremagic = mg->mg_moremagic;
! if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
! && mg->mg_len >= 0)
Safefree(mg->mg_ptr);
Safefree(mg);
}
***************
*** 816,829 ****
#if defined(PERL_OBJECT)
PerlMem_free(this);
#else
! # if defined(WIN32)
# if defined(PERL_IMPLICIT_SYS)
! void *host = w32_internal_host;
! if (PerlProc_lasthost()) {
PerlIO_cleanup();
! }
PerlMem_free(aTHXx);
! win32_delete_internal_host(host);
#else
PerlIO_cleanup();
PerlMem_free(aTHXx);
--- 850,873 ----
#if defined(PERL_OBJECT)
PerlMem_free(this);
#else
! # if defined(WIN32) || defined(NETWARE)
# if defined(PERL_IMPLICIT_SYS)
! #ifdef NETWARE
! void *host = nw_internal_host;
! #else
! void *host = w32_internal_host;
! #endif
! #ifndef NETWARE
! if (PerlProc_lasthost()) {
PerlIO_cleanup();
! }
! #endif
PerlMem_free(aTHXx);
! #ifdef NETWARE
! nw5_delete_internal_host(host);
! #else
! win32_delete_internal_host(host);
! #endif
#else
PerlIO_cleanup();
PerlMem_free(aTHXx);
***************
*** 964,970 ****
AV* comppadlist;
register SV *sv;
register char *s;
! char *cddir = Nullch;
sv_setpvn(PL_linestr,"",0);
sv = newSVpvn("",0); /* first used for -I flags */
--- 1008,1014 ----
AV* comppadlist;
register SV *sv;
register char *s;
! char *popts, *cddir = Nullch;
sv_setpvn(PL_linestr,"",0);
sv = newSVpvn("",0); /* first used for -I flags */
***************
*** 1142,1148 ****
#endif
sv_catpv(PL_Sv, "; \
$\"=\"\\n \"; \
! @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
print \" \\%ENV:\\n @env\\n\" if @env; \
print \" \\@INC:\\n @INC\\n\";");
}
--- 1186,1197 ----
#endif
sv_catpv(PL_Sv, "; \
$\"=\"\\n \"; \
! @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
! #ifdef __CYGWIN__
! sv_catpv(PL_Sv,"\
! push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
! #endif
! sv_catpv(PL_Sv, "\
print \" \\%ENV:\\n @env\\n\" if @env; \
print \" \\@INC:\\n @INC\\n\";");
}
***************
*** 1189,1196 ****
#ifndef SECURE_INTERNAL_GETENV
!PL_tainting &&
#endif
! (s = PerlEnv_getenv("PERL5OPT")))
{
while (isSPACE(*s))
s++;
if (*s == '-' && *(s+1) == 'T')
--- 1238,1246 ----
#ifndef SECURE_INTERNAL_GETENV
!PL_tainting &&
#endif
! (popts = PerlEnv_getenv("PERL5OPT")))
{
+ s = savepv(popts);
while (isSPACE(*s))
s++;
if (*s == '-' && *(s+1) == 'T')
***************
*** 1295,1300 ****
--- 1345,1351 ----
av_store(comppadlist, 1, (SV*)PL_comppad);
CvPADLIST(PL_compcv) = comppadlist;
+ boot_core_PerlIO();
boot_core_UNIVERSAL();
#ifndef PERL_MICRO
boot_core_xsutils();
***************
*** 1679,1685 ****
LOGOP myop; /* fake syntax tree node */
UNOP method_op;
I32 oldmark;
! I32 retval;
I32 oldscope;
bool oldcatch = CATCH_GET;
int ret;
--- 1730,1736 ----
LOGOP myop; /* fake syntax tree node */
UNOP method_op;
I32 oldmark;
! volatile I32 retval = 0;
I32 oldscope;
bool oldcatch = CATCH_GET;
int ret;
***************
*** 1866,1873 ****
{
dSP;
UNOP myop; /* fake syntax tree node */
! I32 oldmark = SP - PL_stack_base;
! I32 retval;
I32 oldscope;
int ret;
OP* oldop = PL_op;
--- 1917,1924 ----
{
dSP;
UNOP myop; /* fake syntax tree node */
! volatile I32 oldmark = SP - PL_stack_base;
! volatile I32 retval = 0;
I32 oldscope;
int ret;
OP* oldop = PL_op;
***************
*** 2013,2019 ****
register GV *gv;
if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
! sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
}
STATIC void
--- 2064,2070 ----
register GV *gv;
if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
! sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
}
STATIC void
***************
*** 2020,2026 ****
S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
{
/* This message really ought to be max 23 lines.
! * Removed -h because the user already knows that opton. Others? */
static char *usage_msg[] = {
"-0[octal] specify record separator (\\0, if no argument)",
--- 2071,2077 ----
S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
{
/* This message really ought to be max 23 lines.
! * Removed -h because the user already knows that option. Others? */
static char *usage_msg[] = {
"-0[octal] specify record separator (\\0, if no argument)",
***************
*** 2287,2295 ****
--- 2338,2359 ----
s++;
return s;
case 'v':
+ #if !defined(DGUX)
PerlIO_printf(PerlIO_stdout(),
Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
PL_patchlevel, ARCHNAME));
+ #else /* DGUX */
+ /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
+ PerlIO_printf(PerlIO_stdout(),
+ Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
+ PerlIO_printf(PerlIO_stdout(),
+ Perl_form(aTHX_ " built under %s at %s %s\n",
+ OSNAME, __DATE__, __TIME__));
+ PerlIO_printf(PerlIO_stdout(),
+ Perl_form(aTHX_ " OS Specific Release: %s\n",
+ OSVERS));
+ #endif /* !DGUX */
+
#if defined(LOCAL_PATCH_COUNT)
if (LOCAL_PATCH_COUNT > 0)
PerlIO_printf(PerlIO_stdout(),
***************
*** 2329,2335 ****
#endif
#ifdef MPE
PerlIO_printf(PerlIO_stdout(),
! "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
#endif
#ifdef OEMVS
PerlIO_printf(PerlIO_stdout(),
--- 2393,2399 ----
#endif
#ifdef MPE
PerlIO_printf(PerlIO_stdout(),
! "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2001\n");
#endif
#ifdef OEMVS
PerlIO_printf(PerlIO_stdout(),
***************
*** 2615,2620 ****
--- 2679,2687 ----
sv_catpvn(sv, "-I", 2);
sv_catpv(sv,PRIVLIB_EXP);
+ DEBUG_P(PerlIO_printf(Perl_debug_log,
+ "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
+ scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
#if defined(MSDOS) || defined(WIN32)
Perl_sv_setpvf(aTHX_ cmd, "\
sed %s -e \"/^[^#]/b\" \
***************
*** 2718,2725 ****
--- 2785,2798 ----
}
#endif
#endif
+ #ifdef IAMSUID
+ errno = EPERM;
+ Perl_croak(aTHX_ "Can't open perl script: %s\n",
+ Strerror(errno));
+ #else
Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
CopFILE(PL_curcop), Strerror(errno));
+ #endif
}
}
***************
*** 3102,3108 ****
if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
Perl_croak(aTHX_ "No Perl script found in input\n");
#endif
! if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
PL_doextract = FALSE;
while (*s && !(isSPACE (*s) || *s == '#')) s++;
--- 3175,3182 ----
if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
Perl_croak(aTHX_ "No Perl script found in input\n");
#endif
! s2 = s;
! if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
PL_doextract = FALSE;
while (*s && !(isSPACE (*s) || *s == '#')) s++;
***************
*** 3115,3120 ****
--- 3189,3197 ----
while ((s = moreswitches(s)))
;
}
+ #ifdef MACOS_TRADITIONAL
+ break;
+ #endif
}
}
}
***************
*** 3294,3301 ****
char *s;
SV *sv;
GV* tmpgv;
- char **dup_env_base = 0;
#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
int dup_env_count = 0;
#endif
--- 3371,3378 ----
char *s;
SV *sv;
GV* tmpgv;
#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
+ char **dup_env_base = 0;
int dup_env_count = 0;
#endif
***************
*** 3355,3361 ****
HV *hv;
GvMULTI_on(PL_envgv);
hv = GvHVn(PL_envgv);
! hv_magic(hv, Nullgv, 'E');
#ifdef USE_ENVIRON_ARRAY
/* Note that if the supplied env parameter is actually a copy
of the global environ then it may now point to free'd memory
--- 3432,3438 ----
HV *hv;
GvMULTI_on(PL_envgv);
hv = GvHVn(PL_envgv);
! hv_magic(hv, Nullgv, PERL_MAGIC_env);
#ifdef USE_ENVIRON_ARRAY
/* Note that if the supplied env parameter is actually a copy
of the global environ then it may now point to free'd memory
***************
*** 3406,3414 ****
}
#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */
#endif /* USE_ENVIRON_ARRAY */
- #ifdef DYNAMIC_ENV_FETCH
- HvNAME(hv) = savepv(ENV_HV_NAME);
- #endif
}
TAINT_NOT;
if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
--- 3483,3488 ----
diff -c 'perl-5.7.1/perl.h' 'perl-5.7.2/perl.h'
Index: ./perl.h
*** ./perl.h Thu Apr 5 20:20:50 2001
--- ./perl.h Fri Jul 13 07:28:49 2001
***************
*** 225,232 ****
# define CALLPROTECT CALL_FPTR(PL_protect)
#endif
#define NOOP (void)0
! #define dNOOP extern int Perl___notused
#ifndef pTHX
# define pTHX void
--- 225,244 ----
# define CALLPROTECT CALL_FPTR(PL_protect)
#endif
+ #ifdef HASATTRIBUTE
+ # define PERL_UNUSED_DECL __attribute__((unused))
+ #else
+ # define PERL_UNUSED_DECL
+ #endif
+
+ /* gcc -Wall:
+ * for silencing unused variables that are actually used most of the time,
+ * but we cannot quite get rid of, such `ax' in PPCODE+noargs xsubs
+ */
+ #define PERL_UNUSED_VAR(var) if (0) var = var
+
#define NOOP (void)0
! #define dNOOP extern int Perl___notused PERL_UNUSED_DECL
#ifndef pTHX
# define pTHX void
***************
*** 258,263 ****
--- 270,284 ----
# define dTHXx dTHX
#endif
+ /* Under PERL_IMPLICIT_SYS (used in Windows for fork emulation)
+ * PerlIO_foo() expands to PL_StdIO->pFOO(PL_StdIO, ...).
+ * dTHXs is therefore needed for all functions using PerlIO_foo(). */
+ #ifdef PERL_IMPLICIT_SYS
+ # define dTHXs dTHX
+ #else
+ # define dTHXs dNOOP
+ #endif
+
#undef START_EXTERN_C
#undef END_EXTERN_C
#undef EXTERN_C
***************
*** 339,353 ****
*/
/* define this once if either system, instead of cluttering up the src */
! #if defined(MSDOS) || defined(atarist) || defined(WIN32)
#define DOSISH 1
#endif
! #if defined(__STDC__) || defined(vax11c) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) || defined( EPOC)
# define STANDARD_C 1
#endif
! #if defined(__cplusplus) || defined(WIN32) || defined(__sgi) || defined(OS2) || defined(__DGUX) || defined( EPOC) || defined(__QNX__)
# define DONT_DECLARE_STD 1
#endif
--- 360,374 ----
*/
/* define this once if either system, instead of cluttering up the src */
! #if defined(MSDOS) || defined(atarist) || defined(WIN32) || defined(NETWARE)
#define DOSISH 1
#endif
! #if defined(__STDC__) || defined(vax11c) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) || defined( EPOC) || defined(NETWARE)
# define STANDARD_C 1
#endif
! #if defined(__cplusplus) || defined(WIN32) || defined(__sgi) || defined(OS2) || defined(__DGUX) || defined( EPOC) || defined(__QNX__) || defined(NETWARE)
# define DONT_DECLARE_STD 1
#endif
***************
*** 506,511 ****
--- 527,540 ----
# include <unistd.h>
#endif
+ #if defined(HAS_SYSCALL) && !defined(HAS_SYSCALL_PROTO)
+ int syscall(int, ...);
+ #endif
+
+ #if defined(HAS_USLEEP) && !defined(HAS_USLEEP_PROTO)
+ int usleep(unsigned int);
+ #endif
+
#ifdef PERL_MICRO /* Last chance to export Perl_my_swap */
# define MYSWAP
#endif
***************
*** 748,753 ****
--- 777,785 ----
# endif
# endif
# ifdef I_NETDB
+ # ifdef NETWARE
+ # include<stdio.h>
+ # endif
# include <netdb.h>
# endif
# ifndef ENOTSOCK
***************
*** 757,762 ****
--- 789,800 ----
# endif
#endif
+ /* sockatmark() is so new (2001) that many places might have it hidden
+ * behind some -D_BLAH_BLAH_SOURCE guard. */
+ #if defined(HAS_SOCKATMARK) && !defined(HAS_SOCKATMARK_PROTO)
+ int sockatmark(int);
+ #endif
+
#ifdef SETERRNO
# undef SETERRNO /* SOCKS might have defined this */
#endif
***************
*** 1028,1033 ****
--- 1066,1082 ----
#undef UV
#endif
+ #ifdef SPRINTF_E_BUG
+ # define sprintf UTS_sprintf_wrap
+ #endif
+
+ /* Configure gets this right but the UTS compiler gets it wrong.
+ -- Hal Morris <hom00@utsglobal.com> */
+ #ifdef UTS
+ # undef UVTYPE
+ # define UVTYPE unsigned
+ #endif
+
/*
The IV type is supposed to be long enough to hold any integral
value or a pointer.
***************
*** 1086,1091 ****
--- 1135,1145 ----
# endif
#endif
+ #if defined(uts) || defined(UTS)
+ # undef UV_MAX
+ # define UV_MAX (4294967295u)
+ #endif
+
#define IV_DIG (BIT_DIGITS(IVSIZE * 8))
#define UV_DIG (BIT_DIGITS(UVSIZE * 8))
***************
*** 1285,1308 ****
# endif
#endif
! #if !defined(Perl_atof) && defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
! # if !defined(Perl_atof) && defined(HAS_STRTOLD)
! # define Perl_atof(s) (NV)strtold(s, (char**)NULL)
! # endif
! # if !defined(Perl_atof) && defined(HAS_ATOLF)
! # define Perl_atof (NV)atolf
! # endif
! # if !defined(Perl_atof) && defined(PERL_SCNfldbl)
! # define Perl_atof PERL_SCNfldbl
! # define Perl_atof2(s,f) sscanf((s), "%"PERL_SCNfldbl, &(f))
! # endif
! #endif
! #if !defined(Perl_atof)
! # define Perl_atof atof /* we assume atof being available anywhere */
! #endif
! #if !defined(Perl_atof2)
! # define Perl_atof2(s,f) ((f) = (NV)Perl_atof(s))
! #endif
/* Previously these definitions used hardcoded figures.
* It is hoped these formula are more portable, although
--- 1339,1346 ----
# endif
#endif
! #define Perl_atof(s) Perl_my_atof(s)
! #define Perl_atof2(s, np) Perl_my_atof2(s, np)
/* Previously these definitions used hardcoded figures.
* It is hoped these formula are more portable, although
***************
*** 1704,1709 ****
--- 1742,1763 ----
# define NEED_ENVIRON_DUP_FOR_MODIFY
#endif
+ /*
+ * initialise to avoid floating-point exceptions from overflow, etc
+ */
+ #ifndef PERL_FPU_INIT
+ # ifdef HAS_FPSETMASK
+ # if HAS_FLOATINGPOINT_H
+ # include <floatingpoint.h>
+ # endif
+ # define PERL_FPU_INIT fpsetmask(0);
+ # elif PERL_IGNORE_FPUSIG
+ # define PERL_FPU_INIT signal(PERL_IGNORE_FPUSIG, SIG_IGN);
+ # else
+ # define PERL_FPU_INIT
+ # endif
+ #endif
+
#ifndef PERL_SYS_INIT3
# define PERL_SYS_INIT3(argvp,argcp,envp) PERL_SYS_INIT(argvp,argcp)
#endif
***************
*** 1743,1748 ****
--- 1797,1805 ----
* atomic.h everywhere */
# define EMULATE_ATOMIC_REFCOUNTS
# endif
+ # ifdef NETWARE
+ # include <nw5thread.h>
+ # else
# ifdef FAKE_THREADS
# include "fakethr.h"
# else
***************
*** 1773,1778 ****
--- 1830,1836 ----
# endif /* OS2 */
# endif /* WIN32 */
# endif /* FAKE_THREADS */
+ #endif /* NETWARE */
#endif /* USE_THREADS || USE_ITHREADS */
#ifdef WIN32
***************
*** 1779,1784 ****
--- 1837,1846 ----
# include "win32.h"
#endif
+ #ifdef NETWARE
+ # include "netware.h"
+ #endif
+
#ifdef VMS
# define STATUS_NATIVE PL_statusvalue_vms
# define STATUS_NATIVE_EXPORT \
***************
*** 1842,1851 ****
#endif
/* This defines a way to flush all output buffers. This may be a
! * performance issue, so we allow people to disable it.
*/
#ifndef PERL_FLUSHALL_FOR_CHILD
! # if defined(FFLUSH_NULL) || defined(USE_SFIO)
# define PERL_FLUSHALL_FOR_CHILD PerlIO_flush((PerlIO*)NULL)
# else
# ifdef FFLUSH_ALL
--- 1904,1915 ----
#endif
/* This defines a way to flush all output buffers. This may be a
! * performance issue, so we allow people to disable it. Also, if
! * we are using stdio, there are broken implementations of fflush(NULL)
! * out there, Solaris being the most prominent.
*/
#ifndef PERL_FLUSHALL_FOR_CHILD
! # if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
# define PERL_FLUSHALL_FOR_CHILD PerlIO_flush((PerlIO*)NULL)
# else
# ifdef FFLUSH_ALL
***************
*** 2084,2109 ****
/* otherwise default to functions in util.c */
#endif
! #ifdef CASTNEGFLOAT
! #define U_S(what) ((U16)(what))
! #define U_I(what) ((unsigned int)(what))
! #define U_L(what) ((U32)(what))
! #else
! #define U_S(what) ((U16)cast_ulong((NV)(what)))
! #define U_I(what) ((unsigned int)cast_ulong((NV)(what)))
! #define U_L(what) (cast_ulong((NV)(what)))
! #endif
! #ifdef CASTI32
! #define I_32(what) ((I32)(what))
! #define I_V(what) ((IV)(what))
! #define U_V(what) ((UV)(what))
! #else
#define I_32(what) (cast_i32((NV)(what)))
#define I_V(what) (cast_iv((NV)(what)))
#define U_V(what) (cast_uv((NV)(what)))
#endif
/* These do not care about the fractional part, only about the range. */
#define NV_WITHIN_IV(nv) (I_V(nv) >= IV_MIN && I_V(nv) <= IV_MAX)
#define NV_WITHIN_UV(nv) ((nv)>=0.0 && U_V(nv) >= UV_MIN && U_V(nv) <= UV_MAX)
--- 2148,2200 ----
/* otherwise default to functions in util.c */
#endif
! /* *MAX Plus 1. A floating point value.
! Hopefully expressed in a way that dodgy floating point can't mess up.
! >> 2 rather than 1, so that value is safely less than I32_MAX after 1
! is added to it
! May find that some broken compiler will want the value cast to I32.
! [after the shift, as signed >> may not be as secure as unsigned >>]
! */
! #define I32_MAX_P1 (2.0 * (1 + (((U32)I32_MAX) >> 1)))
! #define U32_MAX_P1 (4.0 * (1 + ((U32_MAX) >> 2)))
! /* For compilers that can't correctly cast NVs over 0x7FFFFFFF (or
! 0x7FFFFFFFFFFFFFFF) to an unsigned integer. In the future, sizeof(UV)
! may be greater than sizeof(IV), so don't assume that half max UV is max IV.
! */
! #define U32_MAX_P1_HALF (2.0 * (1 + ((U32_MAX) >> 2)))
! #define UV_MAX_P1 (4.0 * (1 + ((UV_MAX) >> 2)))
! #define IV_MAX_P1 (2.0 * (1 + (((UV)IV_MAX) >> 1)))
! #define UV_MAX_P1_HALF (2.0 * (1 + ((UV_MAX) >> 2)))
!
! /* This may look like unnecessary jumping through hoops, but converting
! out of range floating point values to integers *is* undefined behaviour,
! and it is starting to bite.
! */
! #ifndef CAST_INLINE
#define I_32(what) (cast_i32((NV)(what)))
+ #define U_32(what) (cast_ulong((NV)(what)))
#define I_V(what) (cast_iv((NV)(what)))
#define U_V(what) (cast_uv((NV)(what)))
+ #else
+ #define I_32(n) ((n) < I32_MAX_P1 ? ((n) < I32_MIN ? I32_MIN : (I32) (n)) \
+ : ((n) < U32_MAX_P1 ? (I32)(U32) (n) \
+ : ((n) > 0 ? (I32) U32_MAX : 0 /* NaN */)))
+ #define U_32(n) ((n) < 0.0 ? ((n) < I32_MIN ? (UV) I32_MIN : (U32)(I32) (n)) \
+ : ((n) < U32_MAX_P1 ? (U32) (n) \
+ : ((n) > 0 ? U32_MAX : 0 /* NaN */)))
+ #define I_V(n) ((n) < IV_MAX_P1 ? ((n) < IV_MIN ? IV_MIN : (IV) (n)) \
+ : ((n) < UV_MAX_P1 ? (IV)(UV) (n) \
+ : ((n) > 0 ? (IV)UV_MAX : 0 /* NaN */)))
+ #define U_V(n) ((n) < 0.0 ? ((n) < IV_MIN ? (UV) IV_MIN : (UV)(IV) (n)) \
+ : ((n) < UV_MAX_P1 ? (UV) (n) \
+ : ((n) > 0 ? UV_MAX : 0 /* NaN */)))
#endif
+ #define U_S(what) ((U16)U_32(what))
+ #define U_I(what) ((unsigned int)U_32(what))
+ #define U_L(what) U_32(what)
+
/* These do not care about the fractional part, only about the range. */
#define NV_WITHIN_IV(nv) (I_V(nv) >= IV_MIN && I_V(nv) <= IV_MAX)
#define NV_WITHIN_UV(nv) ((nv)>=0.0 && U_V(nv) >= UV_MIN && U_V(nv) <= UV_MAX)
***************
*** 2208,2230 ****
} STMT_END
# endif
! # define DEBUG_f(a) if (DEBUG_f_TEST) a
! # define DEBUG_r(a) if (DEBUG_r_TEST) a
! # define DEBUG_x(a) if (DEBUG_x_TEST) a
! # define DEBUG_u(a) if (DEBUG_u_TEST) a
! # define DEBUG_L(a) if (DEBUG_L_TEST) a
! # define DEBUG_H(a) if (DEBUG_H_TEST) a
! # define DEBUG_X(a) if (DEBUG_X_TEST) a
! # define DEBUG_D(a) if (DEBUG_D_TEST) a
# ifdef USE_THREADS
! # define DEBUG_S(a) if (DEBUG_S_TEST) a
# else
# define DEBUG_S(a)
# endif
! # define DEBUG_T(a) if (DEBUG_T_TEST) a
! # define DEBUG_R(a) if (DEBUG_R_TEST) a
#else /* DEBUGGING */
--- 2299,2326 ----
} STMT_END
# endif
! # define DEBUG__(t, a) \
! STMT_START { \
! if (t) STMT_START {a;} STMT_END; \
! } STMT_END
+ # define DEBUG_f(a) DEBUG__(DEBUG_f_TEST, a)
+ # define DEBUG_r(a) DEBUG__(DEBUG_r_TEST, a)
+ # define DEBUG_x(a) DEBUG__(DEBUG_x_TEST, a)
+ # define DEBUG_u(a) DEBUG__(DEBUG_u_TEST, a)
+ # define DEBUG_L(a) DEBUG__(DEBUG_L_TEST, a)
+ # define DEBUG_H(a) DEBUG__(DEBUG_H_TEST, a)
+ # define DEBUG_X(a) DEBUG__(DEBUG_X_TEST, a)
+ # define DEBUG_D(a) DEBUG__(DEBUG_D_TEST, a)
+
# ifdef USE_THREADS
! # define DEBUG_S(a) DEBUG__(DEBUG_S_TEST, a)
# else
# define DEBUG_S(a)
# endif
! # define DEBUG_T(a) DEBUG__(DEBUG_T_TEST, a)
! # define DEBUG_R(a) DEBUG__(DEBUG_R_TEST, a)
#else /* DEBUGGING */
***************
*** 2272,2277 ****
--- 2368,2419 ----
#endif /* DEBUGGING */
+ /* These constants should be used in preference to to raw characters
+ * when using magic. Note that some perl guts still assume
+ * certain character properties of these constants, namely that
+ * isUPPER() and toLOWER() may do useful mappings.
+ *
+ * Update the magic_names table in dump.c when adding/amending these
+ */
+
+ #define PERL_MAGIC_sv '\0' /* Special scalar variable */
+ #define PERL_MAGIC_overload 'A' /* %OVERLOAD hash */
+ #define PERL_MAGIC_overload_elem 'a' /* %OVERLOAD hash element */
+ #define PERL_MAGIC_overload_table 'c' /* Holds overload table (AMT) on stash */
+ #define PERL_MAGIC_bm 'B' /* Boyer-Moore (fast string search) */
+ #define PERL_MAGIC_regdata 'D' /* Regex match position data
+ (@+ and @- vars) */
+ #define PERL_MAGIC_regdatum 'd' /* Regex match position data element */
+ #define PERL_MAGIC_env 'E' /* %ENV hash */
+ #define PERL_MAGIC_envelem 'e' /* %ENV hash element */
+ #define PERL_MAGIC_fm 'f' /* Formline ('compiled' format) */
+ #define PERL_MAGIC_regex_global 'g' /* m//g target / study()ed string */
+ #define PERL_MAGIC_isa 'I' /* @ISA array */
+ #define PERL_MAGIC_isaelem 'i' /* @ISA array element */
+ #define PERL_MAGIC_nkeys 'k' /* scalar(keys()) lvalue */
+ #define PERL_MAGIC_dbfile 'L' /* Debugger %_<filename */
+ #define PERL_MAGIC_dbline 'l' /* Debugger %_<filename element */
+ #define PERL_MAGIC_mutex 'm' /* ??? */
+ #define PERL_MAGIC_collxfrm 'o' /* Locale transformation */
+ #define PERL_MAGIC_tied 'P' /* Tied array or hash */
+ #define PERL_MAGIC_tiedelem 'p' /* Tied array or hash element */
+ #define PERL_MAGIC_tiedscalar 'q' /* Tied scalar or handle */
+ #define PERL_MAGIC_qr 'r' /* precompiled qr// regex */
+ #define PERL_MAGIC_sig 'S' /* %SIG hash */
+ #define PERL_MAGIC_sigelem 's' /* %SIG hash element */
+ #define PERL_MAGIC_taint 't' /* Taintedness */
+ #define PERL_MAGIC_uvar 'U' /* Available for use by extensions */
+ #define PERL_MAGIC_vec 'v' /* vec() lvalue */
+ #define PERL_MAGIC_substr 'x' /* substr() lvalue */
+ #define PERL_MAGIC_defelem 'y' /* Shadow "foreach" iterator variable /
+ smart parameter vivification */
+ #define PERL_MAGIC_glob '*' /* GV (typeglob) */
+ #define PERL_MAGIC_arylen '#' /* Array length ($#ary) */
+ #define PERL_MAGIC_pos '.' /* pos() lvalue */
+ #define PERL_MAGIC_backref '<' /* ??? */
+ #define PERL_MAGIC_ext '~' /* Available for use by extensions */
+
+
#define YYMAXDEPTH 300
#ifndef assert /* <assert.h> might have been included somehow */
***************
*** 2289,2295 ****
IV uf_index;
};
! /* In pre-5.7-Perls the 'U' magic didn't get the thread context.
* XS code wanting to be backward compatible can do something
* like the following:
--- 2431,2437 ----
IV uf_index;
};
! /* In pre-5.7-Perls the PERL_MAGIC_uvar magic didn't get the thread context.
* XS code wanting to be backward compatible can do something
* like the following:
***************
*** 2355,2361 ****
# if defined(NeXT) || defined(__NeXT__) /* or whatever catches all NeXTs */
char *crypt (); /* Maybe more hosts will need the unprototyped version */
# else
! # if !defined(WIN32)
char *crypt (const char*, const char*);
# endif /* !WIN32 */
# endif /* !NeXT && !__NeXT__ */
--- 2497,2503 ----
# if defined(NeXT) || defined(__NeXT__) /* or whatever catches all NeXTs */
char *crypt (); /* Maybe more hosts will need the unprototyped version */
# else
! # if !defined(WIN32) && !defined(VMS)
char *crypt (const char*, const char*);
# endif /* !WIN32 */
# endif /* !NeXT && !__NeXT__ */
***************
*** 2381,2386 ****
--- 2523,2537 ----
#define UNLINK PerlLIO_unlink
#endif
+ /* some versions of glibc are missing the setresuid() proto */
+ #if defined(HAS_SETRESUID) && !defined(HAS_SETRESUID_PROTO)
+ int setresuid(uid_t ruid, uid_t euid, uid_t suid);
+ #endif
+ /* some versions of glibc are missing the setresgid() proto */
+ #if defined(HAS_SETRESGID) && !defined(HAS_SETRESGID_PROTO)
+ int setresgid(gid_t rgid, gid_t egid, gid_t sgid);
+ #endif
+
#ifndef HAS_SETREUID
# ifdef HAS_SETRESUID
# define setreuid(r,e) setresuid(r,e,(Uid_t)-1)
***************
*** 2789,2796 ****
#define HINT_PRIVATE_MASK 0x000000ff
#define HINT_INTEGER 0x00000001
#define HINT_STRICT_REFS 0x00000002
! /* #define HINT_notused4 0x00000004 */
! #define HINT_BYTE 0x00000008
/* #define HINT_notused10 0x00000010 */
/* Note: 20,40,80 used for NATIVE_HINTS */
--- 2940,2948 ----
#define HINT_PRIVATE_MASK 0x000000ff
#define HINT_INTEGER 0x00000001
#define HINT_STRICT_REFS 0x00000002
! #define HINT_LOCALE 0x00000004
! #define HINT_BYTES 0x00000008
! #define HINT_BYTES 0x00000008
/* #define HINT_notused10 0x00000010 */
/* Note: 20,40,80 used for NATIVE_HINTS */
***************
*** 2797,2803 ****
#define HINT_BLOCK_SCOPE 0x00000100
#define HINT_STRICT_SUBS 0x00000200
#define HINT_STRICT_VARS 0x00000400
- #define HINT_LOCALE 0x00000800
#define HINT_NEW_INTEGER 0x00001000
#define HINT_NEW_FLOAT 0x00002000
--- 2949,2954 ----
***************
*** 2811,2818 ****
#define HINT_FILETEST_ACCESS 0x00400000
#define HINT_UTF8 0x00800000
- #define HINT_UTF8_DISTINCT 0x01000000
- #define HINT_RE_ASCIIR 0x02000000
/* Various states of an input record separator SV (rs, nrs) */
#define RsSNARF(sv) (! SvOK(sv))
--- 2962,2967 ----
***************
*** 3332,3347 ****
#define SET_NUMERIC_LOCAL() \
set_numeric_local();
! #define IS_NUMERIC_RADIX(s) \
! ((PL_hints & HINT_LOCALE) && \
! PL_numeric_radix && memEQ(s, SvPVX(PL_numeric_radix), SvCUR(PL_numeric_radix)))
#define STORE_NUMERIC_LOCAL_SET_STANDARD() \
! bool was_local = (PL_hints & HINT_LOCALE) && PL_numeric_local; \
if (was_local) SET_NUMERIC_STANDARD();
#define STORE_NUMERIC_STANDARD_SET_LOCAL() \
! bool was_standard = (PL_hints & HINT_LOCALE) && PL_numeric_standard; \
if (was_standard) SET_NUMERIC_LOCAL();
#define RESTORE_NUMERIC_LOCAL() \
--- 3481,3498 ----
#define SET_NUMERIC_LOCAL() \
set_numeric_local();
! #define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE)
! #define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
+ #define IN_LOCALE \
+ (PL_curcop == &PL_compiling ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
+
#define STORE_NUMERIC_LOCAL_SET_STANDARD() \
! bool was_local = PL_numeric_local && IN_LOCALE; \
if (was_local) SET_NUMERIC_STANDARD();
#define STORE_NUMERIC_STANDARD_SET_LOCAL() \
! bool was_standard = PL_numeric_standard && IN_LOCALE; \
if (was_standard) SET_NUMERIC_LOCAL();
#define RESTORE_NUMERIC_LOCAL() \
***************
*** 3356,3367 ****
#define SET_NUMERIC_STANDARD() /**/
#define SET_NUMERIC_LOCAL() /**/
! #define IS_NUMERIC_RADIX(c) (0)
#define STORE_NUMERIC_LOCAL_SET_STANDARD() /**/
#define STORE_NUMERIC_STANDARD_SET_LOCAL() /**/
#define RESTORE_NUMERIC_LOCAL() /**/
#define RESTORE_NUMERIC_STANDARD() /**/
#define Atof Perl_atof
#endif /* !USE_LOCALE_NUMERIC */
--- 3507,3519 ----
#define SET_NUMERIC_STANDARD() /**/
#define SET_NUMERIC_LOCAL() /**/
! #define IS_NUMERIC_RADIX(a, b) (0)
#define STORE_NUMERIC_LOCAL_SET_STANDARD() /**/
#define STORE_NUMERIC_STANDARD_SET_LOCAL() /**/
#define RESTORE_NUMERIC_LOCAL() /**/
#define RESTORE_NUMERIC_STANDARD() /**/
#define Atof Perl_atof
+ #define IN_LOCALE_RUNTIME 0
#endif /* !USE_LOCALE_NUMERIC */
***************
*** 3461,3467 ****
#ifndef PERL_MICRO
# ifndef PERL_OLD_SIGNALS
! # define PERL_ASYNC_CHECK() if (PL_sig_pending) despatch_signals()
# endif
#endif
--- 3613,3621 ----
#ifndef PERL_MICRO
# ifndef PERL_OLD_SIGNALS
! # ifndef PERL_ASYNC_CHECK
! # define PERL_ASYNC_CHECK() if (PL_sig_pending) despatch_signals()
! # endif
# endif
#endif
***************
*** 3483,3499 ****
* nice_chunk and nice_chunk size need to be set
* and queried under the protection of sv_mutex
*/
! #define offer_nice_chunk(chunk, chunk_size) do { \
! LOCK_SV_MUTEX; \
! if (!PL_nice_chunk) { \
! PL_nice_chunk = (char*)(chunk); \
! PL_nice_chunk_size = (chunk_size); \
! } \
! else { \
! Safefree(chunk); \
! } \
! UNLOCK_SV_MUTEX; \
! } while (0)
#ifdef HAS_SEM
# include <sys/ipc.h>
--- 3637,3657 ----
* nice_chunk and nice_chunk size need to be set
* and queried under the protection of sv_mutex
*/
! #define offer_nice_chunk(chunk, chunk_size) STMT_START { \
! void *new_chunk; \
! U32 new_chunk_size; \
! LOCK_SV_MUTEX; \
! new_chunk = (void *)(chunk); \
! new_chunk_size = (chunk_size); \
! if (new_chunk_size > PL_nice_chunk_size) { \
! if (PL_nice_chunk) Safefree(PL_nice_chunk); \
! PL_nice_chunk = new_chunk; \
! PL_nice_chunk_size = new_chunk_size; \
! } else { \
! Safefree(chunk); \
! } \
! UNLOCK_SV_MUTEX; \
! } STMT_END
#ifdef HAS_SEM
# include <sys/ipc.h>
***************
*** 3535,3540 ****
--- 3693,3702 ----
# include <sys/file.h>
#endif
+ #if defined(HAS_FLOCK) && !defined(HAS_FLOCK_PROTO)
+ int flock(int fd, int op);
+ #endif
+
#ifndef O_RDONLY
/* Assume UNIX defaults */
# define O_RDONLY 0000
***************
*** 3554,3559 ****
--- 3716,3724 ----
#ifdef IAMSUID
#ifdef I_SYS_STATVFS
+ # if defined(PERL_SCO) && !defined(_SVID3)
+ # define _SVID3
+ # endif
# include <sys/statvfs.h> /* for f?statvfs() */
#endif
#ifdef I_SYS_MOUNT
***************
*** 3601,3606 ****
--- 3766,3789 ----
#define EXEC_ARGV_CAST(x) x
#endif
+ #define IS_NUMBER_IN_UV 0x01 /* number within UV range (maybe not
+ int). value returned in pointed-
+ to UV */
+ #define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 /* pointed to UV undefined */
+ #define IS_NUMBER_NOT_INT 0x04 /* saw . or E notation */
+ #define IS_NUMBER_NEG 0x08 /* leading minus sign */
+ #define IS_NUMBER_INFINITY 0x10 /* this is big */
+
+ #define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send)
+
+ /* to let user control profiling */
+ #ifdef PERL_GPROF_CONTROL
+ extern void moncontrol(int);
+ #define PERL_GPROF_MONCONTROL(x) moncontrol(x)
+ #else
+ #define PERL_GPROF_MONCONTROL(x)
+ #endif
+
/* and finally... */
#define PERL_PATCHLEVEL_H_IMPLICIT
#include "patchlevel.h"
***************
*** 3644,3649 ****
--- 3827,3836 ----
I_SYSUIO
HAS_STRUCT_MSGHDR
HAS_STRUCT_CMSGHDR
+
+ USE_REENTRANT_API
+
+ HAS_NL_LANGINFO
so that Configure picks them up. */
diff -c 'perl-5.7.1/perlapi.c' 'perl-5.7.2/perlapi.c'
Index: ./perlapi.c
*** ./perlapi.c Fri Apr 6 16:42:03 2001
--- ./perlapi.c Thu Jul 12 21:34:41 2001
***************
*** 1097,1102 ****
--- 1097,1109 ----
((CPerlObj*)pPerl)->Perl_init_stacks();
}
+ #undef Perl_init_tm
+ void
+ Perl_init_tm(pTHXo_ struct tm *ptm)
+ {
+ ((CPerlObj*)pPerl)->Perl_init_tm(ptm);
+ }
+
#undef Perl_instr
char*
Perl_instr(pTHXo_ const char* big, const char* little)
***************
*** 1468,1473 ****
--- 1475,1487 ----
((CPerlObj*)pPerl)->Perl_leave_scope(base);
}
+ #undef Perl_op_null
+ void
+ Perl_op_null(pTHXo_ OP* o)
+ {
+ ((CPerlObj*)pPerl)->Perl_op_null(o);
+ }
+
#undef Perl_load_module
void
Perl_load_module(pTHXo_ U32 flags, SV* name, SV* ver, ...)
***************
*** 1491,1496 ****
--- 1505,1524 ----
{
return ((CPerlObj*)pPerl)->Perl_looks_like_number(sv);
}
+
+ #undef Perl_grok_number
+ int
+ Perl_grok_number(pTHXo_ const char *pv, STRLEN len, UV *valuep)
+ {
+ return ((CPerlObj*)pPerl)->Perl_grok_number(pv, len, valuep);
+ }
+
+ #undef Perl_grok_numeric_radix
+ bool
+ Perl_grok_numeric_radix(pTHXo_ const char **sp, const char *send)
+ {
+ return ((CPerlObj*)pPerl)->Perl_grok_numeric_radix(sp, send);
+ }
#if defined(USE_THREADS)
#endif
#if defined(USE_LOCALE_COLLATE)
***************
*** 1588,1593 ****
--- 1616,1628 ----
return ((CPerlObj*)pPerl)->Perl_mg_size(sv);
}
+ #undef Perl_mini_mktime
+ void
+ Perl_mini_mktime(pTHXo_ struct tm *pm)
+ {
+ ((CPerlObj*)pPerl)->Perl_mini_mktime(pm);
+ }
+
#undef Perl_moreswitches
char*
Perl_moreswitches(pTHXo_ char* s)
***************
*** 1601,1607 ****
{
return ((CPerlObj*)pPerl)->Perl_my_atof(s);
}
! #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
#undef Perl_my_bcopy
char*
--- 1636,1642 ----
{
return ((CPerlObj*)pPerl)->Perl_my_atof(s);
}
! #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
#undef Perl_my_bcopy
char*
***************
*** 1706,1711 ****
--- 1741,1753 ----
{
return ((CPerlObj*)pPerl)->Perl_my_stat();
}
+
+ #undef Perl_my_strftime
+ char *
+ Perl_my_strftime(pTHXo_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
+ {
+ return ((CPerlObj*)pPerl)->Perl_my_strftime(fmt, sec, min, hour, mday, mon, year, wday, yday, isdst);
+ }
#if defined(MYSWAP)
#undef Perl_my_swap
***************
*** 2411,2416 ****
--- 2453,2465 ----
{
return ((CPerlObj*)pPerl)->Perl_rsignal(i, t);
}
+
+ #undef Perl_rsignal_state
+ Sighandler_t
+ Perl_rsignal_state(pTHXo_ int i)
+ {
+ return ((CPerlObj*)pPerl)->Perl_rsignal_state(i);
+ }
#if !defined(HAS_RENAME)
#endif
***************
*** 2953,2958 ****
--- 3002,3014 ----
return ((CPerlObj*)pPerl)->Perl_sv_compile_2op(sv, startp, code, avp);
}
+ #undef Perl_getcwd_sv
+ int
+ Perl_getcwd_sv(pTHXo_ SV* sv)
+ {
+ return ((CPerlObj*)pPerl)->Perl_getcwd_sv(sv);
+ }
+
#undef Perl_sv_dec
void
Perl_sv_dec(pTHXo_ SV* sv)
***************
*** 3329,3337 ****
#undef Perl_swash_fetch
UV
! Perl_swash_fetch(pTHXo_ SV *sv, U8 *ptr)
{
! return ((CPerlObj*)pPerl)->Perl_swash_fetch(sv, ptr);
}
#undef Perl_taint_env
--- 3385,3393 ----
#undef Perl_swash_fetch
UV
! Perl_swash_fetch(pTHXo_ SV *sv, U8 *ptr, bool do_utf8)
{
! return ((CPerlObj*)pPerl)->Perl_swash_fetch(sv, ptr, do_utf8);
}
#undef Perl_taint_env
***************
*** 3991,4013 ****
#undef Perl_cx_dup
PERL_CONTEXT*
! Perl_cx_dup(pTHXo_ PERL_CONTEXT* cx, I32 ix, I32 max)
{
! return ((CPerlObj*)pPerl)->Perl_cx_dup(cx, ix, max);
}
#undef Perl_si_dup
PERL_SI*
! Perl_si_dup(pTHXo_ PERL_SI* si)
{
! return ((CPerlObj*)pPerl)->Perl_si_dup(si);
}
#undef Perl_ss_dup
ANY*
! Perl_ss_dup(pTHXo_ PerlInterpreter* proto_perl)
{
! return ((CPerlObj*)pPerl)->Perl_ss_dup(proto_perl);
}
#undef Perl_any_dup
--- 4047,4069 ----
#undef Perl_cx_dup
PERL_CONTEXT*
! Perl_cx_dup(pTHXo_ PERL_CONTEXT* cx, I32 ix, I32 max, clone_params* param)
{
! return ((CPerlObj*)pPerl)->Perl_cx_dup(cx, ix, max, param);
}
#undef Perl_si_dup
PERL_SI*
! Perl_si_dup(pTHXo_ PERL_SI* si, clone_params* param)
{
! return ((CPerlObj*)pPerl)->Perl_si_dup(si, param);
}
#undef Perl_ss_dup
ANY*
! Perl_ss_dup(pTHXo_ PerlInterpreter* proto_perl, clone_params* param)
{
! return ((CPerlObj*)pPerl)->Perl_ss_dup(proto_perl, param);
}
#undef Perl_any_dup
***************
*** 4019,4034 ****
#undef Perl_he_dup
HE*
! Perl_he_dup(pTHXo_ HE* e, bool shared)
{
! return ((CPerlObj*)pPerl)->Perl_he_dup(e, shared);
}
#undef Perl_re_dup
REGEXP*
! Perl_re_dup(pTHXo_ REGEXP* r)
{
! return ((CPerlObj*)pPerl)->Perl_re_dup(r);
}
#undef Perl_fp_dup
--- 4075,4090 ----
#undef Perl_he_dup
HE*
! Perl_he_dup(pTHXo_ HE* e, bool shared, clone_params* param)
{
! return ((CPerlObj*)pPerl)->Perl_he_dup(e, shared, param);
}
#undef Perl_re_dup
REGEXP*
! Perl_re_dup(pTHXo_ REGEXP* r, clone_params* param)
{
! return ((CPerlObj*)pPerl)->Perl_re_dup(r, param);
}
#undef Perl_fp_dup
***************
*** 4047,4069 ****
#undef Perl_gp_dup
GP*
! Perl_gp_dup(pTHXo_ GP* gp)
{
! return ((CPerlObj*)pPerl)->Perl_gp_dup(gp);
}
#undef Perl_mg_dup
MAGIC*
! Perl_mg_dup(pTHXo_ MAGIC* mg)
{
! return ((CPerlObj*)pPerl)->Perl_mg_dup(mg);
}
#undef Perl_sv_dup
SV*
! Perl_sv_dup(pTHXo_ SV* sstr)
{
! return ((CPerlObj*)pPerl)->Perl_sv_dup(sstr);
}
#if defined(HAVE_INTERP_INTERN)
--- 4103,4125 ----
#undef Perl_gp_dup
GP*
! Perl_gp_dup(pTHXo_ GP* gp, clone_params* param)
{
! return ((CPerlObj*)pPerl)->Perl_gp_dup(gp, param);
}
#undef Perl_mg_dup
MAGIC*
! Perl_mg_dup(pTHXo_ MAGIC* mg, clone_params* param)
{
! return ((CPerlObj*)pPerl)->Perl_mg_dup(mg, param);
}
#undef Perl_sv_dup
SV*
! Perl_sv_dup(pTHXo_ SV* sstr, clone_params* param)
{
! return ((CPerlObj*)pPerl)->Perl_sv_dup(sstr, param);
}
#if defined(HAVE_INTERP_INTERN)
***************
*** 4162,4167 ****
--- 4218,4225 ----
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
#endif
+ #if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
+ #endif
#if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT)
#if defined(PERL_FLEXIBLE_EXCEPTIONS)
#endif
***************
*** 4173,4187 ****
# endif
#endif
#if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT)
#endif
#if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT)
#endif
#if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
#endif
#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
#endif
#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
! # if defined(DEBUGGING)
# endif
# if !defined(NV_PRESERVES_UV)
# endif
--- 4231,4249 ----
# endif
#endif
#if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT)
+ # ifdef DEBUGGING
+ # endif
#endif
#if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT)
#endif
#if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
+ # ifdef DEBUGGING
+ # endif
#endif
#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
#endif
#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
! # ifdef DEBUGGING
# endif
# if !defined(NV_PRESERVES_UV)
# endif
***************
*** 4189,4194 ****
--- 4251,4258 ----
# endif
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
+ # if defined(DEBUGGING)
+ # endif
#if 0
#endif
# if defined(CRIPPLED_CC)
***************
*** 4198,4203 ****
--- 4262,4269 ----
#endif
#if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT)
#endif
+ #if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT)
+ #endif
#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
# if defined(LEAKTEST)
# endif
***************
*** 4204,4209 ****
--- 4270,4324 ----
#endif
#if defined(PERL_OBJECT)
#endif
+
+ #undef Perl_sv_setsv_flags
+ void
+ Perl_sv_setsv_flags(pTHXo_ SV* dsv, SV* ssv, I32 flags)
+ {
+ ((CPerlObj*)pPerl)->Perl_sv_setsv_flags(dsv, ssv, flags);
+ }
+
+ #undef Perl_sv_catpvn_flags
+ void
+ Perl_sv_catpvn_flags(pTHXo_ SV* sv, const char* ptr, STRLEN len, I32 flags)
+ {
+ ((CPerlObj*)pPerl)->Perl_sv_catpvn_flags(sv, ptr, len, flags);
+ }
+
+ #undef Perl_sv_catsv_flags
+ void
+ Perl_sv_catsv_flags(pTHXo_ SV* dsv, SV* ssv, I32 flags)
+ {
+ ((CPerlObj*)pPerl)->Perl_sv_catsv_flags(dsv, ssv, flags);
+ }
+
+ #undef Perl_sv_utf8_upgrade_flags
+ STRLEN
+ Perl_sv_utf8_upgrade_flags(pTHXo_ SV *sv, I32 flags)
+ {
+ return ((CPerlObj*)pPerl)->Perl_sv_utf8_upgrade_flags(sv, flags);
+ }
+
+ #undef Perl_sv_pvn_force_flags
+ char*
+ Perl_sv_pvn_force_flags(pTHXo_ SV* sv, STRLEN* lp, I32 flags)
+ {
+ return ((CPerlObj*)pPerl)->Perl_sv_pvn_force_flags(sv, lp, flags);
+ }
+
+ #undef Perl_sv_2pv_flags
+ char*
+ Perl_sv_2pv_flags(pTHXo_ SV* sv, STRLEN* lp, I32 flags)
+ {
+ return ((CPerlObj*)pPerl)->Perl_sv_2pv_flags(sv, lp, flags);
+ }
+
+ #undef Perl_my_atof2
+ char*
+ Perl_my_atof2(pTHXo_ const char *s, NV* value)
+ {
+ return ((CPerlObj*)pPerl)->Perl_my_atof2(s, value);
+ }
#undef Perl_fprintf_nocontext
int
diff -c 'perl-5.7.1/perlapi.h' 'perl-5.7.2/perlapi.h'
Index: ./perlapi.h
*** ./perlapi.h Fri Apr 6 16:42:03 2001
--- ./perlapi.h Thu Jul 12 21:34:40 2001
***************
*** 390,401 ****
#define PL_nthreads_cond (*Perl_Inthreads_cond_ptr(aTHXo))
#undef PL_nullstash
#define PL_nullstash (*Perl_Inullstash_ptr(aTHXo))
#undef PL_numeric_local
#define PL_numeric_local (*Perl_Inumeric_local_ptr(aTHXo))
#undef PL_numeric_name
#define PL_numeric_name (*Perl_Inumeric_name_ptr(aTHXo))
! #undef PL_numeric_radix
! #define PL_numeric_radix (*Perl_Inumeric_radix_ptr(aTHXo))
#undef PL_numeric_standard
#define PL_numeric_standard (*Perl_Inumeric_standard_ptr(aTHXo))
#undef PL_ofmt
--- 390,403 ----
#define PL_nthreads_cond (*Perl_Inthreads_cond_ptr(aTHXo))
#undef PL_nullstash
#define PL_nullstash (*Perl_Inullstash_ptr(aTHXo))
+ #undef PL_numeric_compat1
+ #define PL_numeric_compat1 (*Perl_Inumeric_compat1_ptr(aTHXo))
#undef PL_numeric_local
#define PL_numeric_local (*Perl_Inumeric_local_ptr(aTHXo))
#undef PL_numeric_name
#define PL_numeric_name (*Perl_Inumeric_name_ptr(aTHXo))
! #undef PL_numeric_radix_sv
! #define PL_numeric_radix_sv (*Perl_Inumeric_radix_sv_ptr(aTHXo))
#undef PL_numeric_standard
#define PL_numeric_standard (*Perl_Inumeric_standard_ptr(aTHXo))
#undef PL_ofmt
***************
*** 456,461 ****
--- 458,469 ----
#define PL_psig_ptr (*Perl_Ipsig_ptr_ptr(aTHXo))
#undef PL_ptr_table
#define PL_ptr_table (*Perl_Iptr_table_ptr(aTHXo))
+ #undef PL_reentrant_buffer
+ #define PL_reentrant_buffer (*Perl_Ireentrant_buffer_ptr(aTHXo))
+ #undef PL_regex_pad
+ #define PL_regex_pad (*Perl_Iregex_pad_ptr(aTHXo))
+ #undef PL_regex_padav
+ #define PL_regex_padav (*Perl_Iregex_padav_ptr(aTHXo))
#undef PL_replgv
#define PL_replgv (*Perl_Ireplgv_ptr(aTHXo))
#undef PL_rsfp
***************
*** 772,777 ****
--- 780,787 ----
#define PL_regcomp_parse (*Perl_Tregcomp_parse_ptr(aTHXo))
#undef PL_regcomp_rx
#define PL_regcomp_rx (*Perl_Tregcomp_rx_ptr(aTHXo))
+ #undef PL_regcompat1
+ #define PL_regcompat1 (*Perl_Tregcompat1_ptr(aTHXo))
#undef PL_regcompp
#define PL_regcompp (*Perl_Tregcompp_ptr(aTHXo))
#undef PL_regdata
***************
*** 798,803 ****
--- 808,815 ----
#define PL_regint_string (*Perl_Tregint_string_ptr(aTHXo))
#undef PL_reginterp_cnt
#define PL_reginterp_cnt (*Perl_Treginterp_cnt_ptr(aTHXo))
+ #undef PL_reglastcloseparen
+ #define PL_reglastcloseparen (*Perl_Treglastcloseparen_ptr(aTHXo))
#undef PL_reglastparen
#define PL_reglastparen (*Perl_Treglastparen_ptr(aTHXo))
#undef PL_regnarrate
***************
*** 808,815 ****
#define PL_regnpar (*Perl_Tregnpar_ptr(aTHXo))
#undef PL_regprecomp
#define PL_regprecomp (*Perl_Tregprecomp_ptr(aTHXo))
- #undef PL_regprev
- #define PL_regprev (*Perl_Tregprev_ptr(aTHXo))
#undef PL_regprogram
#define PL_regprogram (*Perl_Tregprogram_ptr(aTHXo))
#undef PL_regsawback
--- 820,825 ----
diff -c 'perl-5.7.1/perlio.c' 'perl-5.7.2/perlio.c'
Index: ./perlio.c
*** ./perlio.c Sat Apr 7 18:41:40 2001
--- ./perlio.c Fri Jul 13 04:13:10 2001
***************
*** 7,12 ****
--- 7,23 ----
*
*/
+ /* If we have ActivePerl-like PERL_IMPLICIT_SYS then we need
+ a dTHX to get at the dispatch tables, even when we do not
+ need it for other reasons.
+ Invent a dSYS macro to abstract this out
+ */
+ #ifdef PERL_IMPLICIT_SYS
+ #define dSYS dTHX
+ #else
+ #define dSYS dNOOP
+ #endif
+
#define VOIDUSED 1
#ifdef PERL_MICRO
# include "uconfig.h"
***************
*** 28,33 ****
--- 39,46 ----
#define PERL_IN_PERLIO_C
#include "perl.h"
+ #include "XSUB.h"
+
#undef PerlMemShared_calloc
#define PerlMemShared_calloc(x,y) calloc(x,y)
#undef PerlMemShared_free
***************
*** 49,55 ****
--- 62,72 ----
return 0;
# else
dTHX;
+ #ifdef NETWARE
+ if (PerlLIO_setmode(fp, mode) != -1) {
+ #else
if (PerlLIO_setmode(fileno(fp), mode) != -1) {
+ #endif
# if defined(WIN32) && defined(__BORLANDC__)
/* The translation mode of the stream is maintained independent
* of the translation mode of the fd in the Borland RTL (heavy
***************
*** 101,107 ****
--- 118,128 ----
int
PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
{
+ #ifdef USE_SFIO
+ return 1;
+ #else
return perlsio_binmode(fp,iotype,mode);
+ #endif
}
/* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries */
***************
*** 120,126 ****
{
fd = PerlLIO_open3(name,imode,perm);
if (fd >= 0)
! return PerlIO_fdopen(fd,mode+1);
}
else if (old)
{
--- 141,147 ----
{
fd = PerlLIO_open3(name,imode,perm);
if (fd >= 0)
! return PerlIO_fdopen(fd,(char *)mode+1);
}
else if (old)
{
***************
*** 134,144 ****
}
else
{
! return PerlIO_fdopen(fd,mode);
}
return NULL;
}
#endif
--- 155,185 ----
}
else
{
! return PerlIO_fdopen(fd,(char *)mode);
}
return NULL;
}
+ XS(XS_PerlIO__Layer__find)
+ {
+ dXSARGS;
+ if (items < 2)
+ Perl_croak(aTHX_ "Usage class->find(name[,load])");
+ else
+ {
+ char *name = SvPV_nolen(ST(1));
+ ST(0) = (strEQ(name,"crlf") || strEQ(name,"raw")) ? &PL_sv_yes : &PL_sv_undef;
+ XSRETURN(1);
+ }
+ }
+
+
+ void
+ Perl_boot_core_PerlIO(pTHX)
+ {
+ newXS("PerlIO::Layer::find",XS_PerlIO__Layer__find,__FILE__);
+ }
+
#endif
***************
*** 195,200 ****
--- 236,263 ----
sfset(sfstdout,SF_SHARE,0);
}
+ PerlIO *
+ PerlIO_importFILE(FILE *stdio, int fl)
+ {
+ int fd = fileno(stdio);
+ PerlIO *r = PerlIO_fdopen(fd,"r+");
+ return r;
+ }
+
+ FILE *
+ PerlIO_findFILE(PerlIO *pio)
+ {
+ int fd = PerlIO_fileno(pio);
+ FILE *f = fdopen(fd,"r+");
+ PerlIO_flush(pio);
+ if (!f && errno == EINVAL)
+ f = fdopen(fd,"w");
+ if (!f && errno == EINVAL)
+ f = fdopen(fd,"r");
+ return f;
+ }
+
+
#else /* USE_SFIO */
/*======================================================================================*/
/* Implement all the PerlIO interface ourselves.
***************
*** 210,216 ****
#include <sys/mman.h>
#endif
- #include "XSUB.h"
void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
--- 273,278 ----
***************
*** 217,225 ****
void
PerlIO_debug(const char *fmt,...)
{
- dTHX;
static int dbg = 0;
va_list ap;
va_start(ap,fmt);
if (!dbg)
{
--- 279,287 ----
void
PerlIO_debug(const char *fmt,...)
{
static int dbg = 0;
va_list ap;
+ dSYS;
va_start(ap,fmt);
if (!dbg)
{
***************
*** 307,316 ****
}
}
! HV *PerlIO_layer_hv;
! AV *PerlIO_layer_av;
void
PerlIO_cleanup()
{
dTHX;
--- 369,440 ----
}
}
! PerlIO_list_t *PerlIO_known_layers;
! PerlIO_list_t *PerlIO_def_layerlist;
+ PerlIO_list_t *
+ PerlIO_list_alloc(void)
+ {
+ PerlIO_list_t *list;
+ Newz('L',list,1,PerlIO_list_t);
+ list->refcnt = 1;
+ return list;
+ }
+
void
+ PerlIO_list_free(PerlIO_list_t *list)
+ {
+ if (list)
+ {
+ if (--list->refcnt == 0)
+ {
+ if (list->array)
+ {
+ dTHX;
+ IV i;
+ for (i=0; i < list->cur; i++)
+ {
+ if (list->array[i].arg)
+ SvREFCNT_dec(list->array[i].arg);
+ }
+ Safefree(list->array);
+ }
+ Safefree(list);
+ }
+ }
+ }
+
+ void
+ PerlIO_list_push(PerlIO_list_t *list,PerlIO_funcs *funcs,SV *arg)
+ {
+ dTHX;
+ PerlIO_pair_t *p;
+ if (list->cur >= list->len)
+ {
+ list->len += 8;
+ if (list->array)
+ Renew(list->array,list->len,PerlIO_pair_t);
+ else
+ New('l',list->array,list->len,PerlIO_pair_t);
+ }
+ p = &(list->array[list->cur++]);
+ p->funcs = funcs;
+ if ((p->arg = arg)) {
+ SvREFCNT_inc(arg);
+ }
+ }
+
+
+ void
+ PerlIO_cleanup_layers(pTHXo_ void *data)
+ {
+ #if 0
+ PerlIO_known_layers = Nullhv;
+ PerlIO_def_layerlist = Nullav;
+ #endif
+ }
+
+ void
PerlIO_cleanup()
{
dTHX;
***************
*** 356,363 ****
{
PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
if (l->tab->Popped)
! (*l->tab->Popped)(f);
! *f = l->next;
PerlMemShared_free(l);
}
}
--- 480,493 ----
{
PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
if (l->tab->Popped)
! {
! /* If popped returns non-zero do not free its layer structure
! it has either done so itself, or it is shared and still in use
! */
! if ((*l->tab->Popped)(f) != 0)
! return;
! }
! *f = l->next;;
PerlMemShared_free(l);
}
}
***************
*** 365,380 ****
/*--------------------------------------------------------------------------------------*/
/* XS Interface for perl code */
! SV *
PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
{
! SV **svp;
! SV *sv;
if ((SSize_t) len <= 0)
len = strlen(name);
! svp = hv_fetch(PerlIO_layer_hv,name,len,0);
! if (!svp && load && PL_subname && PerlIO_layer_av && av_len(PerlIO_layer_av)+1 >= 2)
{
SV *pkgsv = newSVpvn("PerlIO",6);
SV *layer = newSVpvn(name,len);
ENTER;
--- 495,517 ----
/*--------------------------------------------------------------------------------------*/
/* XS Interface for perl code */
! PerlIO_funcs *
PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
{
! IV i;
if ((SSize_t) len <= 0)
len = strlen(name);
! for (i=0; i < PerlIO_known_layers->cur; i++)
{
+ PerlIO_funcs *f = PerlIO_known_layers->array[i].funcs;
+ if (memEQ(f->name,name,len))
+ {
+ PerlIO_debug("%.*s => %p\n",(int)len,name,f);
+ return f;
+ }
+ }
+ if (load && PL_subname && PerlIO_def_layerlist && PerlIO_def_layerlist->cur >= 2)
+ {
SV *pkgsv = newSVpvn("PerlIO",6);
SV *layer = newSVpvn(name,len);
ENTER;
***************
*** 381,397 ****
/* The two SVs are magically freed by load_module */
Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
LEAVE;
! /* Say this is lvalue so we get an 'undef' if still not there */
! svp = hv_fetch(PerlIO_layer_hv,name,len,1);
}
! if (svp && (sv = *svp))
! {
! if (SvROK(sv))
! return *svp;
! }
! return Nullsv;
}
static int
perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
--- 518,530 ----
/* The two SVs are magically freed by load_module */
Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
LEAVE;
! return PerlIO_find_layer(aTHX_ name,len,0);
}
! PerlIO_debug("Cannot find %.*s\n",(int)len,name);
! return NULL;
}
+ #ifdef USE_ATTRIBUTES_FOR_PERLIO
static int
perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
***************
*** 401,407 ****
IO *io = GvIOn((GV *)SvRV(sv));
PerlIO *ifp = IoIFP(io);
PerlIO *ofp = IoOFP(io);
- AV *av = (AV *) mg->mg_obj;
Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
}
return 0;
--- 534,539 ----
***************
*** 415,421 ****
IO *io = GvIOn((GV *)SvRV(sv));
PerlIO *ifp = IoIFP(io);
PerlIO *ofp = IoOFP(io);
- AV *av = (AV *) mg->mg_obj;
Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
}
return 0;
--- 547,552 ----
***************
*** 439,445 ****
perlio_mg_get,
perlio_mg_set,
NULL, /* len */
! NULL,
perlio_mg_free
};
--- 570,576 ----
perlio_mg_get,
perlio_mg_set,
NULL, /* len */
! perlio_mg_clear,
perlio_mg_free
};
***************
*** 451,459 ****
MAGIC *mg;
int count = 0;
int i;
! sv_magic(sv, (SV *)av, '~', NULL, 0);
SvRMAGICAL_off(sv);
! mg = mg_find(sv,'~');
mg->mg_virtual = &perlio_vtab;
mg_magical(sv);
Perl_warn(aTHX_ "attrib %"SVf,sv);
--- 582,590 ----
MAGIC *mg;
int count = 0;
int i;
! sv_magic(sv, (SV *)av, PERL_MAGIC_ext, NULL, 0);
SvRMAGICAL_off(sv);
! mg = mg_find(sv, PERL_MAGIC_ext);
mg->mg_virtual = &perlio_vtab;
mg_magical(sv);
Perl_warn(aTHX_ "attrib %"SVf,sv);
***************
*** 476,481 ****
--- 607,614 ----
XSRETURN(count);
}
+ #endif /* USE_ATTIBUTES_FOR_PERLIO */
+
SV *
PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
{
***************
*** 484,502 ****
return sv;
}
! void
! PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
{
! if (!PerlIO_layer_hv)
{
! PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
}
! hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),PerlIO_tab_sv(aTHX_ tab),0);
PerlIO_debug("define %s %p\n",tab->name,tab);
}
int
! PerlIO_parse_layers(pTHX_ AV *av, const char *names)
{
if (names)
{
--- 617,649 ----
return sv;
}
! XS(XS_PerlIO__Layer__find)
{
! dXSARGS;
! if (items < 2)
! Perl_croak(aTHX_ "Usage class->find(name[,load])");
! else
{
! STRLEN len = 0;
! char *name = SvPV(ST(1),len);
! bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
! PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ name, len, load);
! ST(0) = (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) : &PL_sv_undef;
! XSRETURN(1);
}
! }
!
! void
! PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
! {
! if (!PerlIO_known_layers)
! PerlIO_known_layers = PerlIO_list_alloc();
! PerlIO_list_push(PerlIO_known_layers,tab,Nullsv);
PerlIO_debug("define %s %p\n",tab->name,tab);
}
int
! PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
{
if (names)
{
***************
*** 560,570 ****
}
if (e > s)
{
! SV *layer = PerlIO_find_layer(aTHX_ s,llen,1);
if (layer)
{
! av_push(av,SvREFCNT_inc(layer));
! av_push(av,(as) ? newSVpvn(as,alen) : &PL_sv_undef);
}
else {
Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
--- 707,716 ----
}
if (e > s)
{
! PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ s,llen,1);
if (layer)
{
! PerlIO_list_push(av, layer, (as) ? newSVpvn(as,alen) : &PL_sv_undef);
}
else {
Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
***************
*** 579,585 ****
}
void
! PerlIO_default_buffer(pTHX_ AV *av)
{
PerlIO_funcs *tab = &PerlIO_perlio;
if (O_BINARY != O_TEXT)
--- 725,731 ----
}
void
! PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
{
PerlIO_funcs *tab = &PerlIO_perlio;
if (O_BINARY != O_TEXT)
***************
*** 594,638 ****
}
}
PerlIO_debug("Pushing %s\n",tab->name);
! av_push(av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ tab->name,0,0)));
! av_push(av,&PL_sv_undef);
}
SV *
! PerlIO_arg_fetch(pTHX_ AV *av,IV n)
{
! SV **svp = av_fetch(av,n,FALSE);
! return (svp) ? *svp : Nullsv;
}
PerlIO_funcs *
! PerlIO_layer_fetch(pTHX_ AV *av,IV n,PerlIO_funcs *def)
{
! SV **svp = av_fetch(av,n,FALSE);
! SV *layer;
! if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
{
! /* PerlIO_debug("Layer %d is %s\n",n/2,tab->name); */
! return INT2PTR(PerlIO_funcs *, SvIV(layer));
}
if (!def)
! Perl_croak(aTHX_ "panic:PerlIO layer array corrupt");
return def;
}
! AV *
PerlIO_default_layers(pTHX)
{
! IV len;
! if (!PerlIO_layer_av)
{
const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
! PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
#if 0
! newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
#endif
PerlIO_define_layer(aTHX_ &PerlIO_raw);
- PerlIO_define_layer(aTHX_ &PerlIO_unix);
PerlIO_define_layer(aTHX_ &PerlIO_perlio);
PerlIO_define_layer(aTHX_ &PerlIO_stdio);
PerlIO_define_layer(aTHX_ &PerlIO_crlf);
--- 740,783 ----
}
}
PerlIO_debug("Pushing %s\n",tab->name);
! PerlIO_list_push(av,PerlIO_find_layer(aTHX_ tab->name,0,0),&PL_sv_undef);
}
SV *
! PerlIO_arg_fetch(PerlIO_list_t *av,IV n)
{
! return av->array[n].arg;
}
PerlIO_funcs *
! PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av,IV n,PerlIO_funcs *def)
{
! if (n >= 0 && n < av->cur)
{
! PerlIO_debug("Layer %"IVdf" is %s\n",n,av->array[n].funcs->name);
! return av->array[n].funcs;
}
if (!def)
! Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
return def;
}
! PerlIO_list_t *
PerlIO_default_layers(pTHX)
{
! if (!PerlIO_def_layerlist)
{
const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
! PerlIO_funcs *osLayer = &PerlIO_unix;
! PerlIO_def_layerlist = PerlIO_list_alloc();
! PerlIO_define_layer(aTHX_ &PerlIO_unix);
! #ifdef WIN32
! PerlIO_define_layer(aTHX_ &PerlIO_win32);
#if 0
! osLayer = &PerlIO_win32;
#endif
+ #endif
PerlIO_define_layer(aTHX_ &PerlIO_raw);
PerlIO_define_layer(aTHX_ &PerlIO_perlio);
PerlIO_define_layer(aTHX_ &PerlIO_stdio);
PerlIO_define_layer(aTHX_ &PerlIO_crlf);
***************
*** 641,674 ****
#endif
PerlIO_define_layer(aTHX_ &PerlIO_utf8);
PerlIO_define_layer(aTHX_ &PerlIO_byte);
! av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ PerlIO_unix.name,0,0)));
! av_push(PerlIO_layer_av,&PL_sv_undef);
if (s)
{
! PerlIO_parse_layers(aTHX_ PerlIO_layer_av,s);
}
else
{
! PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
}
}
! len = av_len(PerlIO_layer_av)+1;
! if (len < 2)
{
! PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
! len = av_len(PerlIO_layer_av);
}
! return PerlIO_layer_av;
}
PerlIO_funcs *
PerlIO_default_layer(pTHX_ I32 n)
{
! AV *av = PerlIO_default_layers(aTHX);
! n *= 2;
if (n < 0)
! n += av_len(PerlIO_layer_av)+1;
return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio);
}
--- 786,823 ----
#endif
PerlIO_define_layer(aTHX_ &PerlIO_utf8);
PerlIO_define_layer(aTHX_ &PerlIO_byte);
! PerlIO_list_push(PerlIO_def_layerlist,PerlIO_find_layer(aTHX_ osLayer->name,0,0),&PL_sv_undef);
if (s)
{
! PerlIO_parse_layers(aTHX_ PerlIO_def_layerlist,s);
}
else
{
! PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
}
}
! if (PerlIO_def_layerlist->cur < 2)
{
! PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
}
! return PerlIO_def_layerlist;
}
+ void
+ Perl_boot_core_PerlIO(pTHX)
+ {
+ #ifdef USE_ATTRIBUTES_FOR_PERLIO
+ newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
+ #endif
+ newXS("PerlIO::Layer::find",XS_PerlIO__Layer__find,__FILE__);
+ }
PerlIO_funcs *
PerlIO_default_layer(pTHX_ I32 n)
{
! PerlIO_list_t *av = PerlIO_default_layers(aTHX);
if (n < 0)
! n += av->cur;
return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio);
}
***************
*** 732,738 ****
/* Pop back to bottom layer */
if (f && *f)
{
- int code = 0;
PerlIO_flush(f);
while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
{
--- 881,886 ----
***************
*** 757,765 ****
}
int
! PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, AV *layers, IV n)
{
! IV max = av_len(layers)+1;
int code = 0;
while (n < max)
{
--- 905,913 ----
}
int
! PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, PerlIO_list_t *layers, IV n)
{
! IV max = layers->cur;
int code = 0;
while (n < max)
{
***************
*** 772,778 ****
break;
}
}
! n += 2;
}
return code;
}
--- 920,926 ----
break;
}
}
! n++;
}
return code;
}
***************
*** 783,795 ****
int code = 0;
if (names)
{
! AV *layers = newAV();
code = PerlIO_parse_layers(aTHX_ layers,names);
if (code == 0)
{
code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
}
! SvREFCNT_dec((SV *) layers);
}
return code;
}
--- 931,943 ----
int code = 0;
if (names)
{
! PerlIO_list_t *layers = PerlIO_list_alloc();
code = PerlIO_parse_layers(aTHX_ layers,names);
if (code == 0)
{
code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
}
! PerlIO_list_free(layers);
}
return code;
}
***************
*** 806,813 ****
if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
{
PerlIO *top = f;
! PerlIOl *l;
! while (l = *top)
{
if (PerlIOBase(top)->tab == &PerlIO_crlf)
{
--- 954,960 ----
if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
{
PerlIO *top = f;
! while (*top)
{
if (PerlIOBase(top)->tab == &PerlIO_crlf)
{
***************
*** 825,831 ****
int
PerlIO__close(PerlIO *f)
{
! return (*PerlIOBase(f)->tab->Close)(f);
}
#undef PerlIO_fdupopen
--- 972,984 ----
int
PerlIO__close(PerlIO *f)
{
! if (f && *f)
! return (*PerlIOBase(f)->tab->Close)(f);
! else
! {
! SETERRNO(EBADF,SS$_IVCHAN);
! return -1;
! }
}
#undef PerlIO_fdupopen
***************
*** 832,846 ****
PerlIO *
PerlIO_fdupopen(pTHX_ PerlIO *f)
{
! char buf[8];
! int fd = PerlLIO_dup(PerlIO_fileno(f));
! PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
! if (new)
{
! Off_t posn = PerlIO_tell(f);
! PerlIO_seek(new,posn,SEEK_SET);
}
! return new;
}
#undef PerlIO_close
--- 985,1007 ----
PerlIO *
PerlIO_fdupopen(pTHX_ PerlIO *f)
{
! if (f && *f)
{
! char buf[8];
! int fd = PerlLIO_dup(PerlIO_fileno(f));
! PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
! if (new)
! {
! Off_t posn = PerlIO_tell(f);
! PerlIO_seek(new,posn,SEEK_SET);
! }
! return new;
}
! else
! {
! SETERRNO(EBADF,SS$_IVCHAN);
! return NULL;
! }
}
#undef PerlIO_close
***************
*** 864,870 ****
int
PerlIO_fileno(PerlIO *f)
{
! return (*PerlIOBase(f)->tab->Fileno)(f);
}
static const char *
--- 1025,1037 ----
int
PerlIO_fileno(PerlIO *f)
{
! if (f && *f)
! return (*PerlIOBase(f)->tab->Fileno)(f);
! else
! {
! SETERRNO(EBADF,SS$_IVCHAN);
! return -1;
! }
}
static const char *
***************
*** 893,899 ****
return type;
}
! static SV *
PerlIO_layer_from_ref(pTHX_ SV *sv)
{
/* For any scalar type load the handler which is bundled with perl */
--- 1060,1066 ----
return type;
}
! static PerlIO_funcs *
PerlIO_layer_from_ref(pTHX_ SV *sv)
{
/* For any scalar type load the handler which is bundled with perl */
***************
*** 912,924 ****
case SVt_PVGV:
return PerlIO_find_layer(aTHX_ "Glob",4, 0);
}
! return Nullsv;
}
! AV *
PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
{
! AV *def = PerlIO_default_layers(aTHX);
int incdef = 1;
if (!_perlio)
PerlIO_stdstreams(aTHX);
--- 1079,1091 ----
case SVt_PVGV:
return PerlIO_find_layer(aTHX_ "Glob",4, 0);
}
! return NULL;
}
! PerlIO_list_t *
PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
{
! PerlIO_list_t *def = PerlIO_default_layers(aTHX);
int incdef = 1;
if (!_perlio)
PerlIO_stdstreams(aTHX);
***************
*** 928,939 ****
/* If it is a reference but not an object see if we have a handler for it */
if (SvROK(arg) && !sv_isobject(arg))
{
! SV *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
if (handler)
{
! def = newAV();
! av_push(def,SvREFCNT_inc(handler));
! av_push(def,&PL_sv_undef);
incdef = 0;
}
/* Don't fail if handler cannot be found
--- 1095,1105 ----
/* If it is a reference but not an object see if we have a handler for it */
if (SvROK(arg) && !sv_isobject(arg))
{
! PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
if (handler)
{
! def = PerlIO_list_alloc();
! PerlIO_list_push(def,handler,&PL_sv_undef);
incdef = 0;
}
/* Don't fail if handler cannot be found
***************
*** 946,960 ****
layers = PerlIO_context_layers(aTHX_ mode);
if (layers && *layers)
{
! AV *av;
if (incdef)
{
! IV n = av_len(def)+1;
! av = newAV();
! while (n-- > 0)
{
! SV **svp = av_fetch(def,n,0);
! av_store(av,n,(svp) ? SvREFCNT_inc(*svp) : &PL_sv_undef);
}
}
else
--- 1112,1125 ----
layers = PerlIO_context_layers(aTHX_ mode);
if (layers && *layers)
{
! PerlIO_list_t *av;
if (incdef)
{
! IV i = def->cur;
! av = PerlIO_list_alloc();
! for (i=0; i < def->cur; i++)
{
! PerlIO_list_push(av,def->array[i].funcs,def->array[i].arg);
}
}
else
***************
*** 967,973 ****
else
{
if (incdef)
! SvREFCNT_inc(def);
return def;
}
}
--- 1132,1138 ----
else
{
if (incdef)
! def->refcnt++;
return def;
}
}
***************
*** 987,1006 ****
}
else
{
! AV *layera;
IV n;
! PerlIO_funcs *tab;
if (f && *f)
{
/* This is "reopen" - it is not tested as perl does not use it yet */
PerlIOl *l = *f;
! layera = newAV();
while (l)
{
SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
! av_unshift(layera,2);
! av_store(layera,0,PerlIO_tab_sv(aTHX_ l->tab));
! av_store(layera,1,arg);
l = *PerlIONext(&l);
}
}
--- 1152,1169 ----
}
else
{
! PerlIO_list_t *layera = NULL;
IV n;
! PerlIO_funcs *tab = NULL;
if (f && *f)
{
/* This is "reopen" - it is not tested as perl does not use it yet */
PerlIOl *l = *f;
! layera = PerlIO_list_alloc();
while (l)
{
SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
! PerlIO_list_push(layera,l->tab,arg);
l = *PerlIONext(&l);
}
}
***************
*** 1008,1014 ****
{
layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
}
! n = av_len(layera)-1;
while (n >= 0)
{
PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
--- 1171,1178 ----
{
layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
}
! /* Start at "top" of layer stack */
! n = layera->cur-1;
while (n >= 0)
{
PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
***************
*** 1017,1034 ****
tab = t;
break;
}
! n -= 2;
}
if (tab)
{
PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
tab->name,layers,mode,fd,imode,perm,f,narg,args);
f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
if (f)
{
! if (n+2 < av_len(layera)+1)
{
! if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+2) != 0)
{
f = NULL;
}
--- 1181,1200 ----
tab = t;
break;
}
! n--;
}
if (tab)
{
+ /* Found that layer 'n' can do opens - call it */
PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
tab->name,layers,mode,fd,imode,perm,f,narg,args);
f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
if (f)
{
! if (n+1 < layera->cur)
{
! /* More layers above the one that we used to open - apply them now */
! if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+1) != 0)
{
f = NULL;
}
***************
*** 1035,1041 ****
}
}
}
! SvREFCNT_dec(layera);
}
return f;
}
--- 1201,1207 ----
}
}
}
! PerlIO_list_free(layera);
}
return f;
}
***************
*** 1071,1077 ****
SSize_t
PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
{
! return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
}
#undef PerlIO_unread
--- 1237,1249 ----
SSize_t
PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
{
! if (f && *f)
! return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
! else
! {
! SETERRNO(EBADF,SS$_IVCHAN);
! return -1;
! }
}
#undef PerlIO_unread
***************
*** 1078,1084 ****
SSize_t
PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
{
! return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
}
#undef PerlIO_write
--- 1250,1262 ----
SSize_t
PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
{
! if (f && *f)
! return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
! else
! {
! SETERRNO(EBADF,SS$_IVCHAN);
! return -1;
! }
}
#undef PerlIO_write
***************
*** 1085,1091 ****
SSize_t
PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
{
! return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
}
#undef PerlIO_seek
--- 1263,1275 ----
SSize_t
PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
{
! if (f && *f)
! return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
! else
! {
! SETERRNO(EBADF,SS$_IVCHAN);
! return -1;
! }
}
#undef PerlIO_seek
***************
*** 1092,1098 ****
int
PerlIO_seek(PerlIO *f, Off_t offset, int whence)
{
! return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
}
#undef PerlIO_tell
--- 1276,1288 ----
int
PerlIO_seek(PerlIO *f, Off_t offset, int whence)
{
! if (f && *f)
! return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
! else
! {
! SETERRNO(EBADF,SS$_IVCHAN);
! return -1;
! }
}
#undef PerlIO_tell
***************
*** 1099,1105 ****
Off_t
PerlIO_tell(PerlIO *f)
{
! return (*PerlIOBase(f)->tab->Tell)(f);
}
#undef PerlIO_flush
--- 1289,1301 ----
Off_t
PerlIO_tell(PerlIO *f)
{
! if (f && *f)
! return (*PerlIOBase(f)->tab->Tell)(f);
! else
! {
! SETERRNO(EBADF,SS$_IVCHAN);
! return -1;
! }
}
#undef PerlIO_flush
***************
*** 1108,1127 ****
{
if (f)
{
! PerlIO_funcs *tab = PerlIOBase(f)->tab;
! if (tab && tab->Flush)
{
! return (*tab->Flush)(f);
}
else
{
! PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
! errno = EINVAL;
return -1;
}
}
else
{
PerlIO **table = &_perlio;
int code = 0;
while ((f = *table))
--- 1304,1338 ----
{
if (f)
{
! if (*f)
{
! PerlIO_funcs *tab = PerlIOBase(f)->tab;
! if (tab && tab->Flush)
! {
! return (*tab->Flush)(f);
! }
! else
! {
! PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
! SETERRNO(EBADF,SS$_IVCHAN);
! return -1;
! }
}
else
{
! PerlIO_debug("Cannot flush f=%p\n",f);
! SETERRNO(EBADF,SS$_IVCHAN);
return -1;
}
}
else
{
+ /* Is it good API design to do flush-all on NULL,
+ * a potentially errorneous input? Maybe some magical
+ * value (PerlIO* PERLIO_FLUSH_ALL = (PerlIO*)-1;)?
+ * Yes, stdio does similar things on fflush(NULL),
+ * but should we be bound by their design decisions?
+ * --jhi */
PerlIO **table = &_perlio;
int code = 0;
while ((f = *table))
***************
*** 1162,1168 ****
int
PerlIO_fill(PerlIO *f)
{
! return (*PerlIOBase(f)->tab->Fill)(f);
}
#undef PerlIO_isutf8
--- 1373,1385 ----
int
PerlIO_fill(PerlIO *f)
{
! if (f && *f)
! return (*PerlIOBase(f)->tab->Fill)(f);
! else
! {
! SETERRNO(EBADF,SS$_IVCHAN);
! return -1;
! }
}
#undef PerlIO_isutf8
***************
*** 1169,1175 ****
int
PerlIO_isutf8(PerlIO *f)
{
! return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
}
#undef PerlIO_eof
--- 1386,1398 ----
int
PerlIO_isutf8(PerlIO *f)
{
! if (f && *f)
! return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
! else
! {
! SETERRNO(EBADF,SS$_IVCHAN);
! return -1;
! }
}
#undef PerlIO_eof
***************
*** 1176,1182 ****
int
PerlIO_eof(PerlIO *f)
{
! return (*PerlIOBase(f)->tab->Eof)(f);
}
#undef PerlIO_error
--- 1399,1411 ----
int
PerlIO_eof(PerlIO *f)
{
! if (f && *f)
! return (*PerlIOBase(f)->tab->Eof)(f);
! else
! {
! SETERRNO(EBADF,SS$_IVCHAN);
! return -1;
! }
}
#undef PerlIO_error
***************
*** 1183,1189 ****
int
PerlIO_error(PerlIO *f)
{
! return (*PerlIOBase(f)->tab->Error)(f);
}
#undef PerlIO_clearerr
--- 1412,1424 ----
int
PerlIO_error(PerlIO *f)
{
! if (f && *f)
! return (*PerlIOBase(f)->tab->Error)(f);
! else
! {
! SETERRNO(EBADF,SS$_IVCHAN);
! return -1;
! }
}
#undef PerlIO_clearerr
***************
*** 1192,1197 ****
--- 1427,1434 ----
{
if (f && *f)
(*PerlIOBase(f)->tab->Clearerr)(f);
+ else
+ SETERRNO(EBADF,SS$_IVCHAN);
}
#undef PerlIO_setlinebuf
***************
*** 1198,1204 ****
void
PerlIO_setlinebuf(PerlIO *f)
{
! (*PerlIOBase(f)->tab->Setlinebuf)(f);
}
#undef PerlIO_has_base
--- 1435,1444 ----
void
PerlIO_setlinebuf(PerlIO *f)
{
! if (f && *f)
! (*PerlIOBase(f)->tab->Setlinebuf)(f);
! else
! SETERRNO(EBADF,SS$_IVCHAN);
}
#undef PerlIO_has_base
***************
*** 1205,1214 ****
int
PerlIO_has_base(PerlIO *f)
{
! if (f && *f)
! {
! return (PerlIOBase(f)->tab->Get_base != NULL);
! }
return 0;
}
--- 1445,1451 ----
int
PerlIO_has_base(PerlIO *f)
{
! if (f && *f) { return (PerlIOBase(f)->tab->Get_base != NULL); }
return 0;
}
***************
*** 1252,1258 ****
STDCHAR *
PerlIO_get_base(PerlIO *f)
{
! return (*PerlIOBase(f)->tab->Get_base)(f);
}
#undef PerlIO_get_bufsiz
--- 1489,1497 ----
STDCHAR *
PerlIO_get_base(PerlIO *f)
{
! if (f && *f)
! return (*PerlIOBase(f)->tab->Get_base)(f);
! return NULL;
}
#undef PerlIO_get_bufsiz
***************
*** 1259,1265 ****
int
PerlIO_get_bufsiz(PerlIO *f)
{
! return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
}
#undef PerlIO_get_ptr
--- 1498,1506 ----
int
PerlIO_get_bufsiz(PerlIO *f)
{
! if (f && *f)
! return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
! return 0;
}
#undef PerlIO_get_ptr
***************
*** 1379,1388 ****
};
PerlIO *
! PerlIORaw_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n,const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
{
PerlIO_funcs *tab = PerlIO_default_btm();
! return (*tab->Open)(aTHX_ tab,layers,n-2,mode,fd,imode,perm,old,narg,args);
}
PerlIO_funcs PerlIO_raw = {
--- 1620,1629 ----
};
PerlIO *
! PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n,const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
{
PerlIO_funcs *tab = PerlIO_default_btm();
! return (*tab->Open)(aTHX_ tab,layers,n-1,mode,fd,imode,perm,old,narg,args);
}
PerlIO_funcs PerlIO_raw = {
***************
*** 1461,1468 ****
--- 1702,1711 ----
PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
{
PerlIOl *l = PerlIOBase(f);
+ #if 0
const char *omode = mode;
char temp[8];
+ #endif
PerlIO_funcs *tab = PerlIOBase(f)->tab;
l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
***************
*** 1484,1490 ****
l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
break;
default:
! errno = EINVAL;
return -1;
}
while (*mode)
--- 1727,1733 ----
l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
break;
default:
! SETERRNO(EINVAL,LIB$_INVARG);
return -1;
}
while (*mode)
***************
*** 1501,1508 ****
l->flags |= PERLIO_F_CRLF;
break;
default:
! errno = EINVAL;
! return -1;
}
}
}
--- 1744,1751 ----
l->flags |= PERLIO_F_CRLF;
break;
default:
! SETERRNO(EINVAL,LIB$_INVARG);
! return -1;
}
}
}
***************
*** 1532,1542 ****
PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
{
dTHX;
Off_t old = PerlIO_tell(f);
SSize_t done;
PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
done = PerlIOBuf_unread(f,vbuf,count);
- PerlIOSelf(f,PerlIOBuf)->posn = old - done;
return done;
}
--- 1775,1786 ----
PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
{
dTHX;
+ /* Save the position as current head considers it */
Off_t old = PerlIO_tell(f);
SSize_t done;
PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
+ PerlIOSelf(f,PerlIOBuf)->posn = old;
done = PerlIOBuf_unread(f,vbuf,count);
return done;
}
***************
*** 1551,1557 ****
while (count > 0)
{
SSize_t avail = PerlIO_get_cnt(f);
! SSize_t take = (count < avail) ? count : avail;
if (take > 0)
{
STDCHAR *ptr = PerlIO_get_ptr(f);
--- 1795,1803 ----
while (count > 0)
{
SSize_t avail = PerlIO_get_cnt(f);
! SSize_t take = 0;
! if (avail > 0)
! take = (count < avail) ? count : avail;
if (take > 0)
{
STDCHAR *ptr = PerlIO_get_ptr(f);
***************
*** 1651,1656 ****
--- 1897,1904 ----
PerlIOUnix_oflags(const char *mode)
{
int oflags = -1;
+ if (*mode == 'I' || *mode == '#')
+ mode++;
switch(*mode)
{
case 'r':
***************
*** 1700,1706 ****
oflags |= O_BINARY;
if (*mode || oflags == -1)
{
! errno = EINVAL;
oflags = -1;
}
return oflags;
--- 1948,1954 ----
oflags |= O_BINARY;
if (*mode || oflags == -1)
{
! SETERRNO(EINVAL,LIB$_INVARG);
oflags = -1;
}
return oflags;
***************
*** 1727,1733 ****
}
PerlIO *
! PerlIOUnix_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
{
if (f)
{
--- 1975,1981 ----
}
PerlIO *
! PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
{
if (f)
{
***************
*** 1819,1825 ****
IV
PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
{
! dTHX;
Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
return (new == (Off_t) -1) ? -1 : 0;
--- 2067,2073 ----
IV
PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
{
! dSYS;
Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
return (new == (Off_t) -1) ? -1 : 0;
***************
*** 1828,1835 ****
Off_t
PerlIOUnix_tell(PerlIO *f)
{
! dTHX;
! Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
}
--- 2076,2082 ----
Off_t
PerlIOUnix_tell(PerlIO *f)
{
! dSYS;
return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
}
***************
*** 1895,1901 ****
IV
PerlIOStdio_fileno(PerlIO *f)
{
! dTHX;
return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
}
--- 2142,2148 ----
IV
PerlIOStdio_fileno(PerlIO *f)
{
! dSYS;
return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
}
***************
*** 1919,1927 ****
IV
PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
{
- dTHX;
if (*PerlIONext(f))
{
PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
char tmode[8];
FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
--- 2166,2174 ----
IV
PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
{
if (*PerlIONext(f))
{
+ dSYS;
PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
char tmode[8];
FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
***************
*** 1948,1954 ****
}
PerlIO *
! PerlIOStdio_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
{
char tmode[8];
if (f)
--- 2195,2201 ----
}
PerlIO *
! PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
{
char tmode[8];
if (f)
***************
*** 2026,2032 ****
SSize_t
PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
{
! dTHX;
FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
SSize_t got = 0;
if (count == 1)
--- 2273,2279 ----
SSize_t
PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
{
! dSYS;
FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
SSize_t got = 0;
if (count == 1)
***************
*** 2050,2056 ****
SSize_t
PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
{
! dTHX;
FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
SSize_t unread = 0;
--- 2297,2303 ----
SSize_t
PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
{
! dSYS;
FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
SSize_t unread = 0;
***************
*** 2068,2074 ****
SSize_t
PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
{
! dTHX;
return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
}
--- 2315,2321 ----
SSize_t
PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
{
! dSYS;
return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
}
***************
*** 2075,2081 ****
IV
PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
{
! dTHX;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return PerlSIO_fseek(stdio,offset,whence);
}
--- 2322,2328 ----
IV
PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
{
! dSYS;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return PerlSIO_fseek(stdio,offset,whence);
}
***************
*** 2083,2089 ****
Off_t
PerlIOStdio_tell(PerlIO *f)
{
! dTHX;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return PerlSIO_ftell(stdio);
}
--- 2330,2336 ----
Off_t
PerlIOStdio_tell(PerlIO *f)
{
! dSYS;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return PerlSIO_ftell(stdio);
}
***************
*** 2091,2104 ****
IV
PerlIOStdio_close(PerlIO *f)
{
! dTHX;
! #ifdef HAS_SOCKS5_INIT
! int optval, optlen = sizeof(int);
#endif
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return(
! #ifdef HAS_SOCKS5_INIT
! (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
PerlSIO_fclose(stdio) :
close(PerlIO_fileno(f))
#else
--- 2338,2352 ----
IV
PerlIOStdio_close(PerlIO *f)
{
! dSYS;
! #ifdef SOCKS5_VERSION_NAME
! int optval;
! Sock_size_t optlen = sizeof(int);
#endif
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return(
! #ifdef SOCKS5_VERSION_NAME
! (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
PerlSIO_fclose(stdio) :
close(PerlIO_fileno(f))
#else
***************
*** 2111,2117 ****
IV
PerlIOStdio_flush(PerlIO *f)
{
! dTHX;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
{
--- 2359,2365 ----
IV
PerlIOStdio_flush(PerlIO *f)
{
! dSYS;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
{
***************
*** 2137,2143 ****
IV
PerlIOStdio_fill(PerlIO *f)
{
! dTHX;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
int c;
/* fflush()ing read-only streams can cause trouble on some stdio-s */
--- 2385,2391 ----
IV
PerlIOStdio_fill(PerlIO *f)
{
! dSYS;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
int c;
/* fflush()ing read-only streams can cause trouble on some stdio-s */
***************
*** 2155,2161 ****
IV
PerlIOStdio_eof(PerlIO *f)
{
! dTHX;
return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
}
--- 2403,2409 ----
IV
PerlIOStdio_eof(PerlIO *f)
{
! dSYS;
return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
}
***************
*** 2162,2168 ****
IV
PerlIOStdio_error(PerlIO *f)
{
! dTHX;
return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
}
--- 2410,2416 ----
IV
PerlIOStdio_error(PerlIO *f)
{
! dSYS;
return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
}
***************
*** 2169,2175 ****
void
PerlIOStdio_clearerr(PerlIO *f)
{
! dTHX;
PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
}
--- 2417,2423 ----
void
PerlIOStdio_clearerr(PerlIO *f)
{
! dSYS;
PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
}
***************
*** 2176,2182 ****
void
PerlIOStdio_setlinebuf(PerlIO *f)
{
! dTHX;
#ifdef HAS_SETLINEBUF
PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
#else
--- 2424,2430 ----
void
PerlIOStdio_setlinebuf(PerlIO *f)
{
! dSYS;
#ifdef HAS_SETLINEBUF
PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
#else
***************
*** 2188,2194 ****
STDCHAR *
PerlIOStdio_get_base(PerlIO *f)
{
! dTHX;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return PerlSIO_get_base(stdio);
}
--- 2436,2442 ----
STDCHAR *
PerlIOStdio_get_base(PerlIO *f)
{
! dSYS;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return PerlSIO_get_base(stdio);
}
***************
*** 2196,2202 ****
Size_t
PerlIOStdio_get_bufsiz(PerlIO *f)
{
! dTHX;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return PerlSIO_get_bufsiz(stdio);
}
--- 2444,2450 ----
Size_t
PerlIOStdio_get_bufsiz(PerlIO *f)
{
! dSYS;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return PerlSIO_get_bufsiz(stdio);
}
***************
*** 2206,2212 ****
STDCHAR *
PerlIOStdio_get_ptr(PerlIO *f)
{
! dTHX;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return PerlSIO_get_ptr(stdio);
}
--- 2454,2460 ----
STDCHAR *
PerlIOStdio_get_ptr(PerlIO *f)
{
! dSYS;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return PerlSIO_get_ptr(stdio);
}
***************
*** 2214,2220 ****
SSize_t
PerlIOStdio_get_cnt(PerlIO *f)
{
! dTHX;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return PerlSIO_get_cnt(stdio);
}
--- 2462,2468 ----
SSize_t
PerlIOStdio_get_cnt(PerlIO *f)
{
! dSYS;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return PerlSIO_get_cnt(stdio);
}
***************
*** 2222,2229 ****
void
PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
{
- dTHX;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
if (ptr != NULL)
{
#ifdef STDIO_PTR_LVALUE
--- 2470,2477 ----
void
PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
{
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ dSYS;
if (ptr != NULL)
{
#ifdef STDIO_PTR_LVALUE
***************
*** 2345,2354 ****
IV
PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
{
PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
int fd = PerlIO_fileno(f);
Off_t posn;
- dTHX;
if (fd >= 0 && PerlLIO_isatty(fd))
{
PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
--- 2593,2602 ----
IV
PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
{
+ dSYS;
PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
int fd = PerlIO_fileno(f);
Off_t posn;
if (fd >= 0 && PerlLIO_isatty(fd))
{
PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
***************
*** 2362,2374 ****
}
PerlIO *
! PerlIOBuf_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
{
if (f)
{
PerlIO *next = PerlIONext(f);
! PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab);
! next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args);
if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
{
return NULL;
--- 2610,2622 ----
}
PerlIO *
! PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
{
if (f)
{
PerlIO *next = PerlIONext(f);
! PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIOBase(next)->tab);
! next = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,next,narg,args);
if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
{
return NULL;
***************
*** 2376,2392 ****
}
else
{
! PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm());
int init = 0;
if (*mode == 'I')
{
init = 1;
! mode++;
}
! f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
if (f)
{
! PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOBuf);
fd = PerlIO_fileno(f);
#if O_BINARY != O_TEXT
/* do something about failing setmode()? --jhi */
--- 2624,2640 ----
}
else
{
! PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIO_default_btm());
int init = 0;
if (*mode == 'I')
{
init = 1;
! /* mode++; */
}
! f = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,NULL,narg,args);
if (f)
{
! PerlIO_push(aTHX_ f,self,mode,PerlIOArg);
fd = PerlIO_fileno(f);
#if O_BINARY != O_TEXT
/* do something about failing setmode()? --jhi */
***************
*** 2551,2572 ****
{
if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
{
avail = (b->ptr - b->buf);
}
else
{
! avail = b->bufsiz;
b->end = b->buf + avail;
b->ptr = b->end;
PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
b->posn -= b->bufsiz;
}
if (avail > (SSize_t) count)
! avail = count;
if (avail > 0)
{
b->ptr -= avail;
buf -= avail;
if (buf != b->ptr)
{
Copy(buf,b->ptr,avail,STDCHAR);
--- 2799,2829 ----
{
if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
{
+ /* Buffer is already a read buffer, we can overwrite any chars
+ which have been read back to buffer start
+ */
avail = (b->ptr - b->buf);
}
else
{
! /* Buffer is idle, set it up so whole buffer is available for unread */
! avail = b->bufsiz;
b->end = b->buf + avail;
b->ptr = b->end;
PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
+ /* Buffer extends _back_ from where we are now */
b->posn -= b->bufsiz;
}
if (avail > (SSize_t) count)
! {
! /* If we have space for more than count, just move count */
! avail = count;
! }
if (avail > 0)
{
b->ptr -= avail;
buf -= avail;
+ /* In simple stdio-like ungetc() case chars will be already there */
if (buf != b->ptr)
{
Copy(buf,b->ptr,avail,STDCHAR);
***************
*** 2651,2659 ****
PerlIOBuf_tell(PerlIO *f)
{
PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
Off_t posn = b->posn;
if (b->buf)
! posn += (b->ptr - b->buf);
return posn;
}
--- 2908,2920 ----
PerlIOBuf_tell(PerlIO *f)
{
PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ /* b->posn is file position where b->buf was read, or will be written */
Off_t posn = b->posn;
if (b->buf)
! {
! /* If buffer is valid adjust position by amount in buffer */
! posn += (b->ptr - b->buf);
! }
return posn;
}
***************
*** 2660,2666 ****
IV
PerlIOBuf_close(PerlIO *f)
{
- dTHX;
IV code = PerlIOBase_close(f);
PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
if (b->buf && b->buf != (STDCHAR *) &b->oneword)
--- 2921,2926 ----
***************
*** 2699,2705 ****
PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
if (!b->buf)
{
- dTHX;
if (!b->bufsiz)
b->bufsiz = 4096;
b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
--- 2959,2964 ----
***************
*** 3013,3019 ****
else
{
int code;
- dTHX;
b->ptr++; /* say we have read it as far as flush() is concerned */
b->buf++; /* Leave space an front of buffer */
b->bufsiz--; /* Buffer is thus smaller */
--- 3272,3277 ----
***************
*** 3207,3213 ****
{
dTHX;
PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
- PerlIOBuf *b = &m->base;
IV flags = PerlIOBase(f)->flags;
IV code = 0;
if (m->len)
--- 3465,3470 ----
***************
*** 3498,3503 ****
--- 3755,3764 ----
void
PerlIO_init(void)
{
+ dTHX;
+ #ifndef WIN32
+ call_atexit(PerlIO_cleanup_layers, NULL);
+ #endif
if (!_perlio)
{
#ifndef WIN32
***************
*** 3549,3556 ****
PerlIO_getname(PerlIO *f, char *buf)
{
dTHX;
Perl_croak(aTHX_ "Don't know how to get file name");
! return NULL;
}
--- 3810,3823 ----
PerlIO_getname(PerlIO *f, char *buf)
{
dTHX;
+ char *name = NULL;
+ #ifdef VMS
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ if (stdio) name = fgetname(stdio, buf);
+ #else
Perl_croak(aTHX_ "Don't know how to get file name");
! #endif
! return name;
}
***************
*** 3713,3719 ****
if (f && len == sizeof(Off_t))
return PerlIO_seek(f,*posn,SEEK_SET);
}
! errno = EINVAL;
return -1;
}
#else
--- 3980,3986 ----
if (f && len == sizeof(Off_t))
return PerlIO_seek(f,*posn,SEEK_SET);
}
! SETERRNO(EINVAL,SS$_IVCHAN);
return -1;
}
#else
***************
*** 3735,3741 ****
#endif
}
}
! errno = EINVAL;
return -1;
}
#endif
--- 4002,4008 ----
#endif
}
}
! SETERRNO(EINVAL,SS$_IVCHAN);
return -1;
}
#endif
***************
*** 3817,3821 ****
--- 4084,4092 ----
return result;
}
#endif
+
+
+
+
diff -c 'perl-5.7.1/perlio.h' 'perl-5.7.2/perlio.h'
Index: ./perlio.h
*** ./perlio.h Thu Mar 29 18:01:15 2001
--- ./perlio.h Mon Jul 9 17:11:09 2001
***************
*** 30,38 ****
--- 30,40 ----
#if defined(PERL_IMPLICIT_SYS)
#ifndef USE_PERLIO
+ #ifndef NETWARE
# define USE_PERLIO
#endif
#endif
+ #endif
#ifndef USE_PERLIO
# define USE_STDIO
***************
*** 60,65 ****
--- 62,72 ----
#define fseek fseeko
#endif
+ /* BS2000 includes are sometimes a bit non standard :-( */
+ #if defined(POSIX_BC) && defined(O_BINARY) && !defined(O_TEXT)
+ #undef O_BINARY
+ #endif
+
#ifdef PERLIO_IS_STDIO
/* #define PerlIO_xxxx() as equivalent stdio function */
#include "perlsdio.h"
***************
*** 81,87 ****
#define PERLIO_LAYERS 1
extern void PerlIO_define_layer (pTHX_ PerlIO_funcs *tab);
! extern SV * PerlIO_find_layer (pTHX_ const char *name, STRLEN len, int load);
extern PerlIO * PerlIO_push (pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg);
extern void PerlIO_pop (pTHX_ PerlIO *f);
--- 88,94 ----
#define PERLIO_LAYERS 1
extern void PerlIO_define_layer (pTHX_ PerlIO_funcs *tab);
! extern PerlIO_funcs *PerlIO_find_layer (pTHX_ const char *name, STRLEN len, int load);
extern PerlIO * PerlIO_push (pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg);
extern void PerlIO_pop (pTHX_ PerlIO *f);
***************
*** 237,242 ****
--- 244,252 ----
#ifndef PerlIO_read
extern SSize_t PerlIO_read (PerlIO *,void *,Size_t);
#endif
+ #ifndef PerlIO_unread
+ extern SSize_t PerlIO_unread (PerlIO *,const void *,Size_t);
+ #endif
#ifndef PerlIO_write
extern SSize_t PerlIO_write (PerlIO *,const void *,Size_t);
#endif
***************
*** 325,330 ****
--- 335,343 ----
#endif
#ifndef PerlIO_binmode
extern int PerlIO_binmode (pTHX_ PerlIO *f, int iotype, int omode, const char *names);
+ #endif
+ #ifndef PerlIO_getname
+ extern char * PerlIO_getname (PerlIO *, char *);
#endif
extern void PerlIO_destruct(pTHX);
diff -c 'perl-5.7.1/perliol.h' 'perl-5.7.2/perliol.h'
Index: ./perliol.h
*** ./perliol.h Mon Mar 26 21:35:15 2001
--- ./perliol.h Mon Jul 9 17:11:09 2001
***************
*** 1,6 ****
--- 1,20 ----
#ifndef _PERLIOL_H
#define _PERLIOL_H
+ typedef struct
+ {
+ PerlIO_funcs *funcs;
+ SV *arg;
+ } PerlIO_pair_t;
+
+ typedef struct
+ {
+ IV refcnt;
+ IV cur;
+ IV len;
+ PerlIO_pair_t *array;
+ } PerlIO_list_t;
+
struct _PerlIO_funcs
{
char * name;
***************
*** 9,15 ****
IV (*Pushed)(PerlIO *f,const char *mode,SV *arg);
IV (*Popped)(PerlIO *f);
PerlIO * (*Open)(pTHX_ PerlIO_funcs *tab,
! AV *layers, IV n,
const char *mode,
int fd, int imode, int perm,
PerlIO *old,
--- 23,29 ----
IV (*Pushed)(PerlIO *f,const char *mode,SV *arg);
IV (*Popped)(PerlIO *f);
PerlIO * (*Open)(pTHX_ PerlIO_funcs *tab,
! PerlIO_list_t *layers, IV n,
const char *mode,
int fd, int imode, int perm,
PerlIO *old,
***************
*** 93,102 ****
#ifdef HAS_MMAP
EXT PerlIO_funcs PerlIO_mmap;
#endif
!
extern PerlIO *PerlIO_allocate(pTHX);
! extern SV *PerlIO_arg_fetch(pTHX_ AV *av,IV n);
! #define PerlIOArg PerlIO_arg_fetch(aTHX_ layers,n+1)
#if O_BINARY != O_TEXT
#define PERLIO_STDTEXT "t"
--- 107,118 ----
#ifdef HAS_MMAP
EXT PerlIO_funcs PerlIO_mmap;
#endif
! #ifdef WIN32
! EXT PerlIO_funcs PerlIO_win32;
! #endif
extern PerlIO *PerlIO_allocate(pTHX);
! extern SV *PerlIO_arg_fetch(PerlIO_list_t *av,IV n);
! #define PerlIOArg PerlIO_arg_fetch(layers,n)
#if O_BINARY != O_TEXT
#define PERLIO_STDTEXT "t"
***************
*** 115,122 ****
extern IV PerlIOBase_eof (PerlIO *f);
extern IV PerlIOBase_error (PerlIO *f);
extern void PerlIOBase_clearerr (PerlIO *f);
- extern IV PerlIOBase_flush (PerlIO *f);
- extern IV PerlIOBase_fill (PerlIO *f);
extern IV PerlIOBase_close (PerlIO *f);
extern void PerlIOBase_setlinebuf(PerlIO *f);
extern void PerlIOBase_flush_linebuf(void);
--- 131,136 ----
***************
*** 141,147 ****
IV oneword; /* Emergency buffer */
} PerlIOBuf;
! extern PerlIO * PerlIOBuf_open (pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args);
extern IV PerlIOBuf_pushed (PerlIO *f, const char *mode,SV *arg);
extern SSize_t PerlIOBuf_read (PerlIO *f, void *vbuf, Size_t count);
extern SSize_t PerlIOBuf_unread (PerlIO *f, const void *vbuf, Size_t count);
--- 155,161 ----
IV oneword; /* Emergency buffer */
} PerlIOBuf;
! extern PerlIO * PerlIOBuf_open (pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args);
extern IV PerlIOBuf_pushed (PerlIO *f, const char *mode,SV *arg);
extern SSize_t PerlIOBuf_read (PerlIO *f, void *vbuf, Size_t count);
extern SSize_t PerlIOBuf_unread (PerlIO *f, const void *vbuf, Size_t count);
***************
*** 156,161 ****
--- 170,177 ----
extern STDCHAR *PerlIOBuf_get_ptr (PerlIO *f);
extern SSize_t PerlIOBuf_get_cnt (PerlIO *f);
extern void PerlIOBuf_set_ptrcnt (PerlIO *f, STDCHAR *ptr, SSize_t cnt);
+
+ extern int PerlIOUnix_oflags (const char *mode);
/*--------------------------------------------------------------------------------------*/
diff -c 'perl-5.7.1/perlsdio.h' 'perl-5.7.2/perlsdio.h'
Index: ./perlsdio.h
*** ./perlsdio.h Tue Mar 6 04:06:19 2001
--- ./perlsdio.h Mon Jul 9 17:11:09 2001
***************
*** 1,4 ****
--- 1,9 ----
#ifdef PERLIO_IS_STDIO
+
+ #ifdef NETWARE
+ #include "nwstdio.h"
+ #else
+
/*
* This file #define-s the PerlIO_xxx abstraction onto stdio functions.
* Make this as close to original stdio as possible.
***************
*** 15,20 ****
--- 20,26 ----
#define PerlIO_stdoutf printf
#define PerlIO_vprintf(f,fmt,a) vfprintf(f,fmt,a)
#define PerlIO_write(f,buf,count) fwrite1(buf,1,count,f)
+ #define PerlIO_unread(f,buf,count) (-1)
#define PerlIO_open fopen
#define PerlIO_fdopen fdopen
#define PerlIO_reopen freopen
***************
*** 135,138 ****
--- 141,145 ----
#define PerlIO_get_bufsiz(f) (abort(),0)
#endif
+ #endif /* NETWARE */
#endif /* PERLIO_IS_STDIO */
diff -c 'perl-5.7.1/perlsfio.h' 'perl-5.7.2/perlsfio.h'
Index: ./perlsfio.h
*** ./perlsfio.h Tue Mar 6 04:06:19 2001
--- ./perlsfio.h Mon Jul 9 17:11:09 2001
***************
*** 1,4 ****
--- 1,7 ----
/* The next #ifdef should be redundant if Configure behaves ... */
+ #ifndef FILE
+ #define FILE FILE
+ #endif
#ifdef I_SFIO
#include <sfio.h>
#endif
***************
*** 47,55 ****
#define PerlIO_rewind(f) (void) sfseek((f),0L,0)
#define PerlIO_tmpfile() sftmp(0)
! #define PerlIO_importFILE(f,fl) Perl_croak(aTHX_ "Import from FILE * unimplemeted")
! #define PerlIO_exportFILE(f,fl) Perl_croak(aTHX_ "Export to FILE * unimplemeted")
#define PerlIO_findFILE(f) NULL
#define PerlIO_releaseFILE(p,f) Perl_croak(aTHX_ "Release of FILE * unimplemeted")
#define PerlIO_setlinebuf(f) sfset(f,SF_LINE,1)
--- 50,60 ----
#define PerlIO_rewind(f) (void) sfseek((f),0L,0)
#define PerlIO_tmpfile() sftmp(0)
! #if 0
! #define PerlIO_importFILE(f,fl) ((void) Perl_croak(aTHX_ "Import from FILE * unimplemeted"), NULL)
#define PerlIO_findFILE(f) NULL
+ #endif
+ #define PerlIO_exportFILE(f,fl) Perl_croak(aTHX_ "Export to FILE * unimplemeted")
#define PerlIO_releaseFILE(p,f) Perl_croak(aTHX_ "Release of FILE * unimplemeted")
#define PerlIO_setlinebuf(f) sfset(f,SF_LINE,1)
diff -c 'perl-5.7.1/perly.c' 'perl-5.7.2/perly.c'
Index: ./perly.c
Prereq: 1.8
*** ./perly.c Tue Mar 20 07:04:52 2001
--- ./perly.c Mon Jul 9 17:11:09 2001
***************
*** 1,5 ****
#ifndef lint
! static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91";
#endif
#define YYBYACC 1
#line 16 "perly.y"
--- 1,5 ----
#ifndef lint
! /* static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91"; */
#endif
#define YYBYACC 1
#line 16 "perly.y"
***************
*** 53,81 ****
#line 54 "perly.c"
#define YYERRCODE 256
static short yylhs[] = { -1,
! 50, 0, 8, 6, 9, 7, 10, 10, 10, 11,
! 11, 11, 11, 24, 24, 24, 24, 24, 24, 24,
! 14, 14, 14, 13, 13, 42, 42, 12, 12, 12,
! 12, 12, 12, 12, 26, 26, 27, 27, 28, 29,
! 30, 31, 32, 49, 49, 1, 1, 1, 1, 1,
! 2, 38, 38, 46, 51, 3, 4, 5, 39, 40,
! 40, 44, 44, 44, 45, 45, 41, 41, 52, 52,
! 54, 53, 15, 15, 15, 25, 25, 25, 36, 36,
! 36, 36, 36, 36, 36, 36, 55, 36, 37, 37,
17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
! 17, 16, 16, 16, 16, 16, 16, 16, 16, 16,
! 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
! 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
! 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
! 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
! 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
! 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
! 47, 47, 48, 48, 48, 48, 48, 33, 33, 34,
! 34, 34, 43, 23, 18, 19, 20, 21, 22, 35,
! 35, 35, 35,
};
static short yylen[] = { 2,
! 0, 2, 4, 0, 4, 0, 0, 2, 2, 2,
1, 2, 3, 1, 1, 3, 3, 3, 3, 3,
0, 2, 6, 7, 7, 0, 2, 8, 8, 10,
9, 8, 11, 3, 0, 1, 0, 1, 1, 1,
--- 53,81 ----
#line 54 "perly.c"
#define YYERRCODE 256
static short yylhs[] = { -1,
! 0, 9, 7, 6, 10, 8, 11, 11, 11, 12,
! 12, 12, 12, 25, 25, 25, 25, 25, 25, 25,
! 15, 15, 15, 14, 14, 43, 43, 13, 13, 13,
! 13, 13, 13, 13, 27, 27, 28, 28, 29, 30,
! 31, 32, 33, 54, 54, 1, 1, 1, 1, 1,
! 2, 39, 39, 47, 55, 3, 4, 5, 40, 41,
! 41, 45, 45, 45, 46, 46, 42, 42, 56, 56,
! 58, 57, 16, 16, 16, 26, 26, 26, 37, 37,
! 37, 37, 37, 37, 37, 37, 59, 37, 38, 38,
! 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
! 18, 50, 50, 50, 50, 50, 50, 50, 50, 50,
! 50, 50, 50, 50, 51, 51, 51, 51, 51, 51,
! 51, 51, 52, 52, 52, 52, 52, 53, 53, 53,
! 53, 53, 53, 17, 17, 17, 17, 17, 17, 17,
17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
! 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
! 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
! 17, 17, 17, 17, 48, 48, 49, 49, 49, 49,
! 49, 34, 34, 35, 35, 35, 44, 24, 19, 20,
! 21, 22, 23, 36, 36, 36, 36,
};
static short yylen[] = { 2,
! 2, 4, 0, 0, 4, 0, 0, 2, 2, 2,
1, 2, 3, 1, 1, 3, 3, 3, 3, 3,
0, 2, 6, 7, 7, 0, 2, 8, 8, 10,
9, 8, 11, 3, 0, 1, 0, 1, 1, 1,
***************
*** 86,864 ****
6, 3, 3, 5, 2, 4, 0, 5, 1, 1,
5, 4, 5, 4, 5, 6, 5, 4, 5, 4,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
! 3, 3, 3, 5, 3, 2, 2, 2, 2, 2,
! 2, 2, 2, 2, 1, 2, 3, 2, 3, 2,
! 4, 3, 5, 1, 1, 1, 1, 1, 1, 6,
! 5, 4, 5, 1, 1, 3, 4, 3, 2, 2,
! 4, 5, 4, 5, 1, 2, 2, 1, 2, 2,
! 2, 1, 3, 1, 3, 4, 4, 6, 1, 1,
! 3, 2, 3, 2, 1, 1, 1, 0, 1, 0,
! 1, 2, 1, 2, 2, 2, 2, 2, 2, 1,
! 1, 1, 1,
};
! static short yydefred[] = { 1,
0, 7, 0, 45, 58, 56, 0, 56, 56, 8,
46, 9, 11, 48, 0, 47, 49, 50, 0, 0,
! 0, 70, 71, 0, 14, 4, 169, 0, 0, 144,
! 0, 164, 0, 57, 57, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 12, 0, 0, 0, 0, 0, 0, 0, 10,
! 0, 0, 0, 0, 0, 136, 138, 0, 0, 0,
! 0, 170, 125, 52, 0, 59, 0, 69, 0, 0,
! 7, 190, 193, 192, 191, 0, 0, 0, 0, 0,
! 0, 4, 4, 4, 4, 4, 4, 0, 0, 0,
! 0, 0, 159, 0, 0, 0, 0, 85, 0, 188,
! 0, 150, 0, 0, 0, 0, 0, 0, 0, 175,
! 177, 176, 0, 184, 0, 0, 0, 0, 0, 0,
! 0, 0, 130, 0, 0, 0, 185, 186, 187, 189,
! 0, 34, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 121, 122, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 13, 0, 51, 61, 0,
! 0, 0, 0, 83, 0, 0, 87, 0, 0, 0,
! 0, 0, 0, 0, 4, 163, 165, 0, 0, 0,
! 0, 0, 0, 0, 132, 0, 148, 174, 0, 0,
! 171, 0, 0, 129, 27, 0, 0, 19, 0, 0,
! 0, 0, 73, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 89, 0,
! 0, 90, 0, 0, 101, 0, 0, 0, 0, 0,
! 0, 0, 146, 0, 0, 0, 0, 0, 0, 3,
! 0, 0, 167, 0, 0, 0, 42, 0, 43, 0,
! 0, 0, 0, 183, 0, 0, 36, 41, 0, 0,
! 0, 166, 182, 86, 0, 151, 0, 153, 0, 131,
! 173, 65, 0, 0, 0, 0, 98, 0, 0, 0,
! 0, 100, 94, 0, 92, 0, 142, 0, 147, 63,
! 68, 67, 55, 0, 54, 84, 0, 88, 133, 0,
! 0, 0, 0, 0, 0, 0, 0, 80, 152, 154,
! 141, 0, 0, 0, 99, 93, 0, 97, 95, 143,
! 91, 72, 168, 6, 0, 0, 0, 0, 0, 0,
! 0, 0, 140, 96, 81, 7, 28, 29, 0, 0,
! 24, 25, 0, 32, 0, 0, 0, 22, 0, 0,
! 0, 31, 5, 0, 30, 0, 0, 33, 0, 23,
};
static short yydgoto[] = { 1,
! 10, 11, 20, 100, 19, 91, 366, 94, 355, 3,
! 12, 13, 70, 371, 281, 72, 73, 74, 75, 76,
! 77, 78, 79, 287, 81, 288, 277, 279, 282, 290,
! 278, 280, 118, 210, 96, 82, 253, 85, 87, 190,
! 323, 152, 285, 267, 221, 14, 83, 133, 15, 2,
! 16, 17, 18, 89, 274,
};
static short yysindex[] = { 0,
! 0, 0, -199, 0, 0, 0, -53, 0, 0, 0,
! 0, 0, 0, 0, 646, 0, 0, 0, -217, -207,
! 44, 0, 0, -207, 0, 0, 0, -32, -32, 0,
! 66, 0, 2177, 0, 0, 69, 83, 93, 110, -35,
! 2177, 119, 121, 136, 1013, 973, -32, 1077, 1344, -146,
! 2177, 68, -32, 2177, 2177, 2177, 2177, 2177, 2177, 1384,
! 1424, 0, 2177, 2177, -32, -32, -32, -32, -152, 0,
! 470, 845, -13, -65, -63, 0, 0, 55, 137, 122,
! 138, 0, 0, 0, 60, 0, -70, 0, -66, -70,
! 0, 0, 0, 0, 0, 2177, 146, 2177, 1085, 60,
! -70, 0, 0, 0, 0, 0, 0, 152, 845, 153,
! 1464, 973, 0, 1085, 0, -65, 138, 0, 2177, 0,
! 160, 0, 1085, 2, 76, -52, 2177, 1085, 1524, 0,
! 0, 0, -96, 0, 138, -181, -181, -181, -112, -112,
! 123, -38, 0, -74, -181, -181, 0, 0, 0, 0,
! 60, 0, 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177,
! 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177,
! 2177, 2177, 2177, 0, 0, -16, 2177, 1731, 2177, 2177,
! 2177, 2177, 2177, 2177, 1791, 0, 2177, 0, 0, -88,
! -34, -88, 339, 0, 2177, 287, 0, -88, 2177, 2177,
! 2177, 2177, 173, 1850, 0, 0, 0, -33, 46, 180,
! 2177, 138, 1910, 2025, 0, 97, 0, 0, -31, -29,
! 0, 2177, 133, 0, 0, -237, -237, 0, -237, -237,
! -237, -69, 0, 1614, 1085, 684, 167, 107, 845, 3800,
! 1125, 405, 1164, 778, -228, -181, -181, 2177, 0, 2117,
! 2177, 0, 197, -48, 0, -9, -72, -45, -7, -42,
! 56, -36, 0, -4, 845, -10, -47, 2177, -47, 0,
! 216, 2177, 0, 2177, 60, -237, 0, 219, 0, 230,
! -237, 233, 237, 0, 242, 470, 0, 0, 246, 225,
! 2177, 0, 0, 0, 13, 0, 18, 0, 29, 0,
! 0, 0, 61, 2177, 2177, 54, 0, 32, 63, 2177,
! 165, 0, 0, 174, 0, 178, 0, 191, 0, 0,
! 0, 0, 0, 261, 0, 0, 350, 0, 0, 182,
! 182, 182, 182, 2177, 182, 2177, 281, 0, 0, 0,
! 0, 102, 1237, 202, 0, 0, 294, 0, 0, 0,
! 0, 0, 0, 0, -152, -152, -130, -130, 297, -152,
! 290, 182, 0, 0, 0, 0, 0, 0, 182, 318,
! 0, 0, 182, 0, 1850, -152, 407, 0, 2177, -152,
! 324, 0, 0, 326, 0, 182, 182, 0, -130, 0,
};
static short yyrindex[] = { 0,
! 0, 0, 243, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 236, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 36, 451, 0, 0, 2208, 2271, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 115, 0,
! -12, 939, 2325, 2385, 2463, 0, 0, 2510, 2561, 0,
! 1220, 0, 0, 0, 0, 0, -44, 0, 0, -44,
! 0, 0, 0, 0, 0, 2271, 0, 0, 3846, 0,
! -105, 0, 0, 0, 0, 0, 0, 0, 2612, 0,
! 0, 327, 0, 3883, 522, 583, 3032, 0, 0, 0,
! 2621, 0, 3893, 2385, 0, 0, 2271, 3930, 0, 0,
! 0, 0, 2667, 0, 3092, 3374, 3418, 3458, 3219, 3331,
! 2746, 0, 0, 0, 3496, 3567, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 2797, 0, 0, -23,
- 0, -23, 913, 0, 327, 0, 0, 247, 336, 0,
- 0, 0, 0, 333, 0, 0, 0, 0, 352, 0,
- 0, 3138, 0, 0, 0, 0, 0, 0, 0, 2857,
- 0, 0, 2903, 0, 0, -8, -2, 0, 7, 33,
- 42, 2255, 0, -28, 3968, 1822, 3732, 3769, 3023, 0,
- 4119, 4082, 4021, 4005, 1044, 3610, 3694, 0, 0, 0,
- 0, 0, 2949, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 3657, -21, 0, 345, 0, 0,
- 0, 0, 0, 2271, 0, 71, 0, 0, 0, 0,
- 364, 0, 0, 0, 0, 86, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 327,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 355, 0, 0, 0, 0,
! 0, 0, 2972, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 115, 115, 175, 175, 0, 115,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 374, 115, 913, 0, 0, 115,
! 0, 0, 0, 0, 0, 0, 0, 0, 175, 0,
};
static short yygindex[] = { 0,
! 0, 0, 164, 383, 0, 14, 0, 37, 655, -89,
! 0, 0, 0, -336, -15, 3415, 0, 2211, 368, 369,
! 0, 0, 0, 410, 916, 0, 0, 273, -163, 62,
! 94, 249, -71, -186, 634, 0, 0, 0, 428, -46,
! 184, 118, 0, -149, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0,
};
! #define YYTABLESIZE 4423
static short yytable[] = { 71,
! 65, 193, 223, 65, 107, 22, 216, 292, 271, 301,
! 311, 321, 111, 314, 60, 111, 316, 60, 224, 65,
! 313, 372, 318, 250, 194, 181, 178, 183, 15, 111,
! 111, 312, 18, 126, 111, 62, 319, 64, 39, 84,
! 289, 214, 269, 192, 142, 144, 15, 16, 275, 86,
! 18, 69, 390, 338, 198, 217, 39, 180, 339, 182,
! 163, 164, 158, 159, 111, 16, 4, 5, 6, 340,
! 7, 8, 345, 17, 251, 26, 155, 179, 60, 155,
! 172, 113, 20, 173, 122, 315, 174, 175, 176, 293,
! 26, 17, 181, 155, 155, 208, 209, 9, 155, 62,
! 20, 64, 88, 65, 67, 98, 248, 129, 102, 177,
! 127, 38, 344, 219, 26, 199, 200, 201, 202, 203,
! 204, 188, 103, 347, 180, 151, 40, 337, 155, 38,
! 173, 66, 104, 174, 175, 176, 197, 226, 227, 229,
! 230, 231, 232, 233, 15, 369, 370, 26, 317, 105,
! 26, 26, 26, 341, 26, 346, 26, 26, 110, 26,
! 111, 254, 256, 257, 258, 259, 260, 261, 262, 264,
! 359, 23, 24, 26, 21, 112, 185, 184, 26, 209,
! 186, 187, 26, 276, 227, 195, 227, 225, 286, 189,
! 191, 205, 60, 206, 363, 295, 324, 297, 299, 213,
! 215, 220, 328, 21, 176, 26, 303, 21, 65, 266,
! 21, 21, 21, 222, 21, 384, 21, 21, 291, 21,
! 294, 300, 268, 304, 92, 158, 159, 158, 159, 93,
! 302, 159, 306, 21, 308, 309, 310, 26, 21, 26,
! 26, 249, 2, 111, 111, 111, 111, 158, 159, 320,
! 111, 158, 159, 60, 158, 159, 326, 158, 159, 330,
! 106, 158, 159, 158, 159, 21, 158, 159, 158, 159,
! 331, 111, 111, 332, 111, 44, 377, 333, 44, 44,
! 44, 334, 44, 336, 44, 44, 335, 44, 342, 348,
! 158, 159, 158, 159, 209, 158, 159, 21, 349, 21,
! 21, 44, 350, 322, 354, 322, 44, 155, 155, 155,
! 155, 329, 158, 159, 155, 351, 155, 158, 159, 352,
! 276, 362, 155, 155, 155, 155, 364, 273, 158, 159,
! 272, 158, 159, 44, 365, 155, 155, 373, 155, 155,
! 155, 155, 155, 155, 155, 158, 159, 155, 375, 166,
! 155, 155, 155, 158, 159, 158, 159, 379, 53, 71,
! 158, 159, 158, 159, 386, 44, 387, 180, 44, 62,
! 26, 26, 26, 26, 26, 26, 37, 26, 26, 26,
! 26, 26, 26, 26, 26, 26, 26, 26, 26, 26,
! 353, 35, 181, 26, 26, 163, 26, 26, 26, 26,
! 26, 158, 159, 178, 40, 26, 26, 26, 26, 26,
! 26, 26, 166, 37, 35, 172, 26, 101, 173, 131,
! 132, 174, 175, 176, 80, 26, 228, 26, 26, 361,
! 21, 21, 21, 21, 21, 21, 381, 21, 21, 21,
! 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
! 283, 90, 325, 21, 21, 0, 21, 21, 21, 21,
! 21, 0, 0, 270, 0, 21, 21, 21, 21, 21,
! 21, 21, 367, 368, 0, 172, 21, 374, 173, 0,
! 0, 174, 175, 176, 0, 21, 0, 21, 21, 0,
! 0, 162, 0, 382, 162, 0, 0, 385, 44, 44,
! 44, 44, 44, 44, 0, 44, 44, 44, 162, 162,
! 0, 44, 0, 162, 44, 44, 44, 44, 0, 0,
! 0, 44, 44, 0, 44, 44, 44, 44, 44, 0,
! 0, 383, 0, 44, 44, 44, 44, 44, 44, 0,
! 0, 0, 0, 162, 44, 0, 0, 0, 0, 0,
! 0, 0, 0, 44, 190, 44, 44, 190, 190, 190,
! 0, 190, 169, 190, 190, 169, 190, 160, 0, 0,
! 0, 0, 0, 161, 162, 163, 164, 0, 0, 169,
! 169, 0, 0, 0, 169, 190, 0, 0, 0, 165,
! 167, 168, 169, 170, 171, 172, 0, 0, 173, 0,
! 0, 174, 175, 176, 4, 5, 6, 0, 7, 8,
! 0, 0, 190, 0, 169, 191, 0, 0, 191, 191,
! 191, 0, 191, 134, 191, 191, 134, 191, 0, 0,
! 160, 0, 0, 0, 0, 9, 161, 162, 163, 164,
! 134, 134, 0, 0, 0, 134, 191, 190, 0, 0,
! 0, 0, 165, 167, 168, 169, 170, 171, 172, 0,
! 0, 173, 97, 0, 174, 175, 176, 0, 0, 0,
! 0, 0, 4, 5, 6, 134, 7, 8, 55, 119,
! 120, 65, 67, 53, 0, 60, 134, 68, 64, 0,
! 63, 161, 162, 163, 164, 0, 0, 0, 147, 148,
! 149, 150, 0, 9, 62, 0, 0, 0, 191, 66,
! 169, 170, 171, 172, 0, 0, 173, 0, 0, 174,
! 175, 176, 162, 162, 162, 162, 0, 0, 0, 162,
! 0, 162, 0, 0, 0, 0, 61, 162, 162, 162,
! 162, 153, 154, 155, 156, 211, 0, 0, 157, 0,
! 162, 162, 0, 162, 162, 162, 162, 162, 162, 162,
! 0, 0, 162, 0, 0, 162, 162, 162, 26, 158,
! 159, 56, 0, 0, 0, 0, 0, 0, 190, 190,
! 190, 190, 190, 0, 190, 190, 190, 0, 0, 0,
! 190, 0, 0, 169, 169, 169, 169, 0, 0, 0,
! 169, 190, 169, 190, 190, 190, 190, 190, 169, 169,
! 169, 169, 190, 190, 190, 190, 190, 190, 0, 0,
! 0, 169, 169, 190, 169, 169, 169, 169, 169, 169,
! 169, 0, 190, 169, 190, 190, 169, 169, 169, 191,
! 191, 191, 191, 191, 0, 191, 191, 191, 0, 0,
! 0, 191, 0, 0, 134, 134, 134, 134, 0, 0,
! 0, 134, 191, 134, 191, 191, 191, 191, 191, 134,
! 134, 134, 134, 191, 191, 191, 191, 191, 191, 0,
! 0, 0, 134, 134, 191, 134, 134, 134, 134, 134,
! 134, 134, 0, 191, 134, 191, 191, 134, 134, 134,
! 0, 25, 27, 28, 29, 30, 31, 166, 32, 33,
! 34, 0, 0, 0, 35, 0, 0, 36, 37, 38,
! 39, 0, 0, 0, 40, 41, 0, 42, 43, 44,
! 45, 46, 0, 0, 0, 0, 47, 48, 49, 50,
! 51, 52, 0, 0, 0, 44, 0, 54, 44, 44,
! 44, 0, 44, 0, 44, 44, 57, 44, 58, 59,
! 0, 117, 0, 0, 0, 0, 0, 0, 0, 135,
! 161, 44, 163, 164, 0, 0, 44, 0, 0, 78,
! 0, 0, 78, 0, 0, 356, 357, 358, 0, 360,
! 0, 171, 172, 0, 0, 173, 78, 78, 174, 175,
! 176, 0, 0, 44, 0, 55, 0, 0, 65, 67,
! 53, 117, 60, 0, 68, 64, 376, 63, 0, 0,
! 0, 0, 0, 378, 0, 0, 0, 380, 0, 0,
! 0, 78, 0, 0, 212, 44, 66, 0, 44, 0,
! 388, 389, 117, 0, 0, 55, 0, 0, 65, 67,
! 53, 0, 60, 0, 68, 64, 0, 63, 0, 0,
! 0, 0, 0, 61, 161, 162, 163, 164, 0, 0,
! 0, 0, 0, 0, 0, 0, 66, 0, 0, 0,
! 0, 0, 0, 0, 106, 171, 172, 106, 0, 173,
! 0, 0, 174, 175, 176, 26, 0, 0, 56, 0,
! 0, 106, 106, 61, 0, 0, 106, 0, 0, 55,
! 0, 0, 65, 67, 53, 0, 60, 0, 68, 64,
! 0, 63, 0, 0, 0, 160, 0, 0, 0, 0,
! 0, 161, 162, 163, 164, 26, 106, 0, 56, 0,
! 66, 0, 0, 0, 0, 0, 0, 165, 167, 168,
! 169, 170, 171, 172, 0, 0, 173, 0, 0, 174,
! 175, 176, 0, 0, 0, 0, 0, 61, 44, 44,
! 44, 44, 44, 44, 0, 44, 44, 44, 0, 0,
! 0, 44, 0, 117, 44, 44, 44, 44, 0, 117,
! 0, 44, 44, 0, 44, 44, 44, 44, 44, 26,
! 0, 0, 56, 44, 44, 44, 44, 44, 44, 0,
! 78, 78, 78, 78, 44, 0, 0, 78, 0, 0,
! 0, 0, 0, 44, 0, 44, 44, 0, 0, 115,
! 28, 29, 30, 31, 93, 32, 33, 34, 78, 78,
! 0, 35, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 41, 0, 42, 43, 44, 45, 46, 0,
! 75, 0, 0, 47, 48, 49, 50, 51, 52, 27,
! 28, 29, 30, 31, 54, 32, 33, 34, 75, 0,
! 0, 35, 0, 57, 0, 58, 59, 0, 0, 0,
! 0, 0, 41, 0, 42, 43, 44, 45, 46, 166,
! 0, 0, 0, 47, 48, 49, 50, 51, 52, 0,
! 0, 0, 75, 0, 54, 106, 106, 106, 106, 0,
! 0, 0, 106, 57, 106, 58, 59, 0, 0, 0,
! 106, 106, 0, 121, 28, 29, 30, 31, 0, 32,
! 33, 34, 0, 106, 106, 35, 106, 106, 106, 106,
! 106, 106, 0, 0, 0, 0, 41, 0, 42, 43,
44, 45, 46, 0, 0, 0, 0, 47, 48, 49,
! 50, 51, 52, 163, 164, 0, 55, 0, 54, 65,
! 67, 53, 0, 60, 0, 68, 64, 57, 63, 58,
! 59, 0, 171, 172, 0, 0, 173, 0, 0, 174,
! 175, 176, 125, 0, 0, 0, 0, 66, 0, 0,
! 0, 161, 162, 163, 164, 0, 55, 0, 0, 65,
! 67, 53, 0, 60, 141, 68, 64, 0, 63, 168,
! 169, 170, 171, 172, 61, 0, 173, 0, 0, 174,
! 175, 176, 0, 0, 0, 0, 0, 66, 0, 0,
! 161, 162, 163, 164, 0, 0, 55, 0, 0, 65,
! 67, 53, 0, 60, 0, 68, 64, 0, 63, 56,
! 170, 171, 172, 0, 61, 173, 0, 0, 174, 175,
! 176, 0, 0, 0, 0, 0, 0, 66, 0, 0,
! 0, 75, 75, 75, 75, 0, 55, 0, 75, 65,
! 67, 53, 0, 60, 207, 68, 64, 0, 63, 56,
! 0, 0, 0, 0, 61, 0, 143, 160, 0, 75,
! 75, 0, 0, 161, 162, 163, 164, 66, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 167, 168, 169, 170, 171, 172, 0, 0, 173, 56,
! 0, 174, 175, 176, 61, 0, 55, 0, 0, 65,
! 67, 53, 0, 60, 218, 68, 64, 0, 63, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 66, 0, 56,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 27, 28, 29, 30, 31, 0, 32, 33, 34, 0,
! 0, 0, 35, 0, 61, 0, 0, 0, 0, 0,
! 0, 0, 0, 41, 0, 42, 43, 44, 45, 46,
0, 0, 0, 0, 47, 48, 49, 50, 51, 52,
! 27, 28, 29, 30, 31, 54, 32, 33, 34, 56,
! 0, 0, 35, 0, 57, 0, 58, 59, 0, 0,
! 0, 0, 0, 41, 0, 42, 43, 44, 45, 46,
! 0, 0, 0, 0, 47, 48, 49, 50, 51, 52,
! 27, 28, 29, 30, 31, 54, 32, 33, 34, 0,
! 0, 0, 35, 0, 57, 0, 58, 59, 0, 0,
! 0, 0, 0, 41, 0, 42, 43, 44, 45, 46,
! 0, 0, 0, 0, 47, 48, 49, 50, 51, 52,
! 27, 28, 29, 30, 31, 54, 32, 33, 34, 0,
! 0, 0, 35, 0, 57, 0, 58, 59, 0, 0,
! 0, 0, 0, 41, 0, 42, 43, 44, 45, 46,
! 0, 0, 0, 0, 47, 48, 49, 50, 51, 52,
! 0, 0, 0, 55, 0, 54, 65, 67, 53, 0,
! 60, 255, 68, 64, 57, 63, 58, 59, 0, 0,
27, 28, 29, 30, 31, 0, 32, 33, 34, 0,
0, 0, 35, 0, 66, 0, 0, 0, 0, 0,
0, 0, 0, 41, 0, 42, 43, 44, 45, 46,
0, 0, 0, 0, 47, 48, 49, 50, 51, 52,
0, 61, 0, 55, 0, 54, 65, 67, 53, 0,
! 60, 263, 68, 64, 57, 63, 58, 59, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 66, 0, 56, 0, 0, 0,
- 0, 0, 108, 0, 0, 108, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 108,
- 108, 61, 55, 0, 108, 65, 67, 53, 0, 60,
- 0, 68, 64, 0, 63, 0, 0, 0, 0, 0,
- 161, 162, 163, 164, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 66, 108, 0, 56, 167, 168, 169,
- 170, 171, 172, 0, 0, 173, 0, 0, 174, 175,
- 176, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 61, 0, 55, 0, 0, 65, 67, 53, 0, 60,
- 296, 68, 64, 0, 63, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 66, 0, 56, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 27, 28, 29,
30, 31, 0, 32, 33, 34, 0, 0, 0, 35,
! 61, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 41, 0, 42, 43, 44, 45, 46, 0, 0, 0,
! 0, 47, 48, 49, 50, 51, 52, 0, 0, 0,
! 0, 0, 54, 0, 0, 56, 0, 0, 0, 0,
0, 57, 0, 58, 59, 0, 0, 27, 28, 29,
! 30, 31, 0, 32, 33, 34, 0, 55, 0, 35,
! 65, 67, 53, 0, 60, 298, 68, 64, 0, 63,
41, 0, 42, 43, 44, 45, 46, 0, 0, 0,
! 0, 47, 48, 49, 50, 51, 52, 0, 66, 0,
! 0, 0, 54, 108, 108, 108, 108, 0, 0, 0,
! 108, 57, 108, 58, 59, 25, 27, 28, 29, 30,
! 31, 0, 32, 33, 34, 61, 0, 0, 35, 0,
! 0, 108, 108, 0, 108, 108, 108, 108, 108, 41,
! 0, 42, 43, 44, 45, 46, 0, 0, 0, 0,
! 47, 48, 49, 50, 51, 52, 0, 0, 0, 55,
! 56, 54, 65, 67, 53, 0, 60, 307, 68, 64,
! 57, 63, 58, 59, 0, 0, 27, 28, 29, 30,
! 31, 0, 32, 33, 34, 0, 0, 0, 35, 0,
! 66, 0, 0, 0, 0, 0, 0, 0, 0, 41,
! 0, 42, 43, 44, 45, 46, 0, 0, 0, 0,
! 47, 48, 49, 50, 51, 52, 0, 61, 0, 55,
! 0, 54, 65, 67, 53, 0, 60, 0, 68, 64,
! 57, 63, 58, 59, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 95, 95,
! 66, 0, 56, 0, 0, 0, 0, 0, 158, 0,
! 108, 158, 0, 0, 0, 0, 116, 95, 124, 0,
! 0, 0, 130, 95, 0, 158, 158, 61, 0, 0,
! 158, 0, 0, 0, 0, 95, 95, 95, 95, 0,
! 0, 27, 28, 29, 30, 31, 0, 32, 33, 34,
! 0, 0, 0, 35, 0, 74, 0, 0, 74, 0,
! 158, 0, 56, 0, 41, 0, 42, 43, 44, 45,
! 46, 178, 0, 74, 178, 47, 48, 49, 50, 51,
! 52, 0, 116, 0, 0, 0, 54, 0, 178, 178,
! 0, 0, 0, 178, 0, 57, 0, 58, 59, 0,
! 0, 0, 0, 0, 0, 0, 0, 74, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 178, 0, 139, 0, 0, 139, 0,
- 0, 0, 0, 27, 28, 29, 30, 31, 0, 32,
- 33, 34, 139, 139, 0, 35, 252, 139, 0, 0,
- 0, 0, 0, 0, 0, 0, 41, 0, 42, 43,
- 44, 45, 46, 0, 0, 0, 0, 47, 48, 49,
- 50, 51, 52, 284, 0, 0, 0, 139, 54, 0,
- 0, 0, 0, 0, 0, 134, 0, 57, 134, 58,
- 59, 0, 0, 27, 28, 29, 30, 31, 0, 32,
- 33, 34, 134, 134, 0, 35, 0, 134, 0, 0,
- 0, 0, 0, 0, 0, 0, 41, 0, 42, 43,
- 44, 45, 46, 0, 0, 0, 0, 47, 48, 49,
- 50, 51, 52, 0, 0, 0, 0, 134, 54, 158,
- 158, 158, 158, 0, 0, 0, 158, 57, 158, 58,
- 59, 0, 0, 0, 158, 158, 158, 158, 0, 0,
- 0, 0, 0, 137, 0, 0, 137, 158, 158, 0,
- 158, 158, 158, 158, 158, 158, 158, 0, 0, 158,
- 137, 137, 158, 158, 158, 137, 74, 74, 74, 74,
- 0, 0, 0, 74, 0, 0, 0, 0, 0, 0,
- 0, 0, 178, 178, 178, 178, 0, 0, 0, 178,
- 135, 178, 0, 135, 74, 137, 0, 178, 178, 178,
- 178, 0, 0, 0, 0, 0, 0, 135, 135, 0,
- 178, 178, 135, 178, 178, 178, 178, 178, 178, 178,
- 0, 0, 178, 0, 0, 178, 178, 178, 0, 0,
- 0, 0, 0, 0, 0, 0, 139, 139, 139, 139,
- 0, 145, 135, 139, 145, 139, 0, 0, 0, 0,
- 0, 139, 139, 139, 139, 0, 0, 0, 145, 145,
- 0, 0, 0, 145, 139, 139, 0, 139, 139, 139,
- 139, 139, 139, 139, 0, 0, 139, 0, 0, 139,
- 139, 139, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 156, 145, 0, 156, 134, 134, 134, 134,
- 0, 169, 0, 134, 169, 134, 0, 0, 0, 156,
- 156, 134, 134, 134, 134, 0, 0, 0, 169, 169,
- 0, 0, 0, 169, 134, 134, 0, 134, 134, 134,
- 134, 134, 134, 134, 0, 0, 134, 0, 0, 134,
- 134, 134, 0, 0, 156, 0, 0, 172, 0, 0,
- 172, 0, 0, 169, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 172, 172, 0, 0, 0, 172,
- 0, 0, 0, 0, 137, 137, 137, 137, 0, 0,
- 0, 137, 0, 137, 0, 0, 0, 0, 0, 137,
- 137, 137, 137, 0, 0, 0, 0, 0, 0, 172,
- 0, 0, 137, 137, 0, 137, 137, 137, 137, 137,
- 137, 137, 0, 0, 137, 0, 0, 137, 137, 137,
- 0, 135, 135, 135, 135, 0, 128, 0, 135, 128,
- 135, 0, 0, 0, 0, 0, 135, 135, 135, 135,
- 0, 0, 0, 128, 128, 0, 0, 0, 128, 135,
- 135, 0, 135, 135, 135, 135, 135, 135, 135, 0,
- 0, 135, 0, 0, 135, 135, 135, 0, 0, 0,
- 0, 0, 145, 145, 145, 145, 0, 76, 128, 145,
- 76, 145, 0, 0, 0, 0, 0, 145, 145, 145,
- 145, 0, 0, 0, 76, 76, 0, 0, 0, 76,
- 145, 145, 0, 145, 145, 145, 145, 145, 145, 145,
- 0, 0, 145, 0, 0, 145, 145, 145, 0, 0,
- 0, 0, 0, 156, 156, 156, 156, 0, 0, 76,
- 156, 0, 169, 169, 169, 169, 0, 66, 0, 169,
- 66, 169, 0, 0, 0, 0, 0, 169, 169, 169,
- 169, 156, 156, 0, 66, 66, 0, 0, 0, 66,
- 169, 169, 0, 169, 169, 169, 169, 169, 169, 169,
- 0, 0, 169, 0, 0, 169, 169, 169, 172, 172,
- 172, 172, 0, 127, 0, 172, 127, 172, 0, 66,
- 0, 0, 0, 172, 172, 172, 172, 0, 0, 0,
- 127, 127, 0, 0, 0, 127, 172, 172, 0, 172,
- 172, 172, 172, 172, 172, 172, 0, 0, 172, 0,
- 0, 172, 172, 172, 0, 0, 0, 0, 0, 82,
- 0, 0, 82, 0, 0, 127, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 82, 82, 0, 0,
- 0, 82, 114, 0, 0, 114, 0, 128, 128, 128,
- 128, 0, 0, 0, 128, 0, 128, 0, 0, 114,
- 114, 0, 128, 128, 128, 128, 0, 0, 0, 0,
- 0, 82, 0, 0, 0, 128, 128, 0, 128, 128,
- 128, 128, 128, 128, 128, 0, 0, 128, 0, 0,
- 128, 128, 128, 102, 114, 0, 102, 0, 76, 76,
- 76, 76, 179, 0, 0, 76, 0, 76, 0, 0,
- 102, 102, 0, 76, 76, 76, 76, 0, 0, 179,
- 179, 0, 0, 0, 179, 0, 76, 76, 0, 76,
- 76, 76, 76, 76, 76, 76, 0, 0, 76, 0,
- 0, 76, 76, 76, 0, 102, 0, 0, 0, 0,
- 0, 0, 0, 0, 179, 0, 0, 0, 66, 66,
- 66, 66, 157, 0, 0, 66, 0, 66, 0, 0,
- 0, 0, 0, 66, 66, 66, 66, 0, 0, 157,
- 157, 0, 0, 0, 157, 0, 66, 66, 0, 66,
- 66, 66, 66, 66, 66, 66, 0, 0, 66, 0,
- 0, 66, 66, 66, 127, 127, 127, 127, 79, 0,
- 0, 127, 0, 127, 157, 0, 0, 0, 0, 127,
- 127, 127, 127, 0, 0, 79, 79, 0, 0, 0,
- 79, 0, 127, 127, 0, 127, 127, 127, 127, 127,
- 127, 127, 0, 0, 127, 0, 0, 127, 127, 127,
- 82, 82, 82, 82, 0, 0, 0, 82, 0, 82,
- 79, 0, 0, 0, 0, 82, 82, 82, 82, 0,
- 0, 0, 0, 114, 114, 114, 114, 0, 82, 82,
- 114, 82, 82, 82, 82, 82, 82, 82, 0, 123,
- 82, 0, 123, 82, 82, 82, 0, 0, 0, 0,
- 0, 114, 114, 0, 114, 0, 123, 123, 0, 0,
- 0, 123, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 102, 102, 102, 102, 0, 0,
- 0, 102, 0, 179, 179, 179, 179, 0, 0, 0,
- 179, 123, 179, 0, 0, 0, 0, 0, 179, 179,
- 179, 179, 102, 102, 0, 0, 0, 0, 0, 0,
- 0, 179, 179, 0, 179, 179, 179, 179, 179, 179,
- 179, 0, 0, 179, 0, 0, 179, 179, 179, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 157, 157, 157, 157, 0, 0, 0,
! 157, 124, 157, 0, 124, 0, 0, 0, 157, 157,
! 157, 157, 0, 0, 0, 0, 0, 0, 124, 124,
! 0, 157, 157, 124, 157, 157, 157, 157, 157, 157,
! 157, 0, 0, 157, 0, 0, 157, 157, 157, 79,
! 79, 79, 79, 0, 118, 0, 79, 118, 79, 0,
! 0, 0, 0, 124, 79, 79, 79, 79, 0, 0,
! 0, 118, 118, 0, 0, 0, 118, 79, 79, 0,
! 79, 79, 79, 79, 79, 79, 79, 99, 0, 79,
! 0, 0, 79, 79, 79, 109, 0, 0, 119, 114,
! 0, 119, 123, 0, 0, 128, 118, 0, 0, 136,
! 137, 138, 139, 140, 0, 119, 119, 145, 146, 0,
! 119, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 123, 123, 123, 123, 0, 0, 0, 123, 120, 123,
! 0, 120, 0, 0, 0, 123, 123, 123, 123, 0,
! 119, 0, 196, 0, 0, 120, 120, 0, 123, 123,
! 120, 123, 123, 123, 123, 123, 123, 123, 0, 0,
! 123, 0, 0, 0, 0, 0, 116, 0, 0, 116,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 120, 0, 0, 116, 116, 0, 0, 0, 116, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 234, 235, 236, 237, 238, 239,
! 240, 241, 242, 243, 244, 245, 246, 247, 116, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 265, 124, 124, 124, 124, 0, 117, 0, 124,
! 117, 124, 0, 0, 0, 0, 0, 124, 124, 124,
! 124, 0, 0, 0, 117, 117, 0, 0, 0, 117,
! 124, 124, 0, 124, 124, 124, 124, 124, 124, 124,
! 0, 0, 124, 0, 0, 118, 118, 118, 118, 0,
! 115, 0, 118, 115, 118, 0, 0, 0, 0, 117,
! 118, 118, 118, 118, 0, 0, 0, 115, 115, 0,
! 0, 0, 115, 118, 118, 0, 118, 118, 118, 118,
! 118, 118, 118, 0, 0, 0, 327, 0, 0, 119,
! 119, 119, 119, 0, 0, 0, 119, 77, 119, 0,
! 77, 0, 115, 0, 119, 119, 119, 119, 0, 0,
! 0, 0, 0, 0, 77, 77, 0, 119, 119, 343,
! 119, 119, 119, 119, 119, 119, 119, 0, 0, 120,
! 120, 120, 120, 0, 103, 0, 120, 103, 120, 0,
! 0, 0, 0, 0, 120, 120, 120, 120, 0, 77,
! 0, 103, 103, 0, 0, 0, 103, 120, 120, 0,
! 120, 120, 120, 120, 120, 120, 120, 116, 116, 116,
! 116, 0, 104, 0, 116, 104, 116, 0, 0, 0,
! 0, 0, 116, 116, 116, 116, 103, 0, 0, 104,
! 104, 0, 0, 0, 104, 116, 116, 0, 116, 116,
! 116, 116, 116, 116, 116, 0, 0, 0, 0, 105,
! 0, 0, 105, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 104, 0, 105, 105, 0, 0,
! 0, 105, 0, 0, 0, 0, 0, 0, 117, 117,
! 117, 117, 0, 0, 0, 117, 0, 117, 0, 0,
! 0, 0, 0, 117, 117, 117, 117, 305, 0, 0,
! 0, 105, 166, 0, 0, 0, 117, 117, 0, 117,
! 117, 117, 117, 117, 117, 117, 0, 0, 0, 0,
! 0, 115, 115, 115, 115, 0, 161, 0, 115, 161,
! 115, 0, 0, 0, 0, 0, 115, 115, 115, 115,
! 0, 0, 0, 161, 161, 0, 0, 0, 161, 115,
! 115, 0, 115, 115, 115, 115, 115, 115, 115, 0,
! 0, 0, 0, 160, 0, 0, 160, 0, 77, 77,
! 77, 77, 0, 149, 0, 77, 149, 0, 161, 0,
! 160, 160, 0, 0, 0, 160, 0, 0, 0, 0,
! 149, 149, 0, 0, 0, 149, 77, 77, 0, 0,
! 0, 0, 0, 0, 0, 103, 103, 103, 103, 0,
! 126, 0, 103, 126, 103, 160, 0, 0, 0, 0,
! 103, 103, 103, 103, 0, 149, 0, 126, 126, 0,
! 0, 0, 126, 103, 103, 0, 103, 103, 103, 103,
! 103, 103, 103, 104, 104, 104, 104, 0, 107, 0,
! 104, 107, 104, 0, 0, 0, 0, 0, 104, 104,
! 104, 104, 126, 0, 0, 107, 107, 0, 0, 0,
! 107, 104, 104, 0, 104, 104, 104, 104, 104, 104,
! 105, 105, 105, 105, 0, 109, 0, 105, 109, 105,
! 0, 0, 0, 0, 0, 105, 105, 0, 105, 0,
! 107, 110, 109, 109, 110, 0, 0, 109, 105, 105,
! 0, 105, 105, 105, 105, 105, 105, 0, 110, 110,
! 160, 0, 0, 110, 0, 0, 161, 162, 163, 164,
! 0, 0, 0, 0, 0, 0, 0, 109, 0, 0,
! 0, 0, 165, 167, 168, 169, 170, 171, 172, 0,
! 0, 173, 0, 110, 174, 175, 176, 161, 161, 161,
! 161, 0, 112, 0, 161, 112, 161, 0, 0, 0,
! 0, 0, 161, 161, 0, 0, 0, 0, 0, 112,
! 112, 0, 0, 0, 112, 161, 161, 0, 161, 161,
! 161, 161, 161, 0, 160, 160, 160, 160, 0, 113,
! 0, 160, 113, 160, 149, 149, 149, 149, 0, 160,
! 160, 149, 0, 149, 112, 0, 113, 113, 0, 149,
! 149, 113, 160, 160, 0, 160, 160, 160, 160, 160,
! 0, 0, 149, 149, 0, 149, 149, 149, 149, 149,
! 0, 126, 126, 126, 126, 0, 0, 0, 126, 0,
! 126, 113, 0, 0, 0, 0, 126, 126, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 126,
! 126, 0, 126, 126, 126, 126, 126, 0, 0, 107,
! 107, 107, 107, 0, 0, 0, 107, 0, 107, 0,
! 0, 0, 0, 0, 0, 107, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 107, 107, 0,
! 107, 107, 107, 107, 107, 0, 109, 109, 109, 109,
! 0, 0, 0, 109, 0, 109, 0, 0, 0, 0,
! 0, 0, 110, 110, 110, 110, 0, 0, 0, 110,
! 0, 110, 0, 0, 109, 109, 0, 109, 109, 109,
! 109, 109, 0, 0, 0, 0, 0, 0, 0, 0,
! 110, 110, 0, 110, 110, 110, 110, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 112, 112, 112, 112, 0, 0, 0,
! 112, 0, 112, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 112, 112, 0, 112, 112, 112, 0, 0, 0,
! 113, 113, 113, 113, 0, 0, 0, 113, 0, 113,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 113, 113,
! 0, 113, 113,
};
static short yycheck[] = { 15,
! 36, 91, 41, 36, 40, 59, 59, 41, 195, 41,
! 59, 59, 41, 59, 59, 44, 59, 123, 93, 36,
! 93, 358, 59, 40, 96, 91, 40, 91, 41, 58,
! 59, 41, 41, 49, 63, 59, 41, 59, 41, 257,
! 204, 40, 192, 90, 60, 61, 59, 41, 198, 257,
! 59, 15, 389, 41, 101, 127, 59, 123, 41, 123,
! 289, 290, 300, 301, 93, 59, 266, 267, 268, 41,
! 270, 271, 41, 41, 91, 123, 41, 91, 123, 44,
! 309, 45, 41, 312, 48, 93, 315, 316, 317, 44,
! 123, 59, 91, 58, 59, 111, 112, 297, 63, 123,
! 59, 123, 59, 36, 37, 40, 123, 40, 40, 123,
! 257, 41, 59, 129, 0, 102, 103, 104, 105, 106,
! 107, 85, 40, 310, 123, 278, 41, 291, 93, 59,
! 312, 64, 40, 315, 316, 317, 100, 153, 154, 155,
! 156, 157, 158, 159, 59, 276, 277, 33, 93, 40,
! 36, 37, 38, 93, 40, 93, 42, 43, 40, 45,
! 40, 177, 178, 179, 180, 181, 182, 183, 184, 185,
! 334, 8, 9, 59, 0, 40, 40, 123, 64, 195,
! 59, 44, 123, 199, 200, 40, 202, 151, 204, 260,
! 257, 40, 298, 41, 93, 211, 268, 213, 214, 40,
! 125, 298, 274, 257, 317, 91, 222, 33, 36, 298,
! 36, 37, 38, 91, 40, 379, 42, 43, 205, 45,
! 41, 125, 257, 91, 257, 300, 301, 300, 301, 262,
! 260, 301, 248, 59, 250, 251, 40, 123, 64, 125,
! 126, 258, 0, 272, 273, 274, 275, 300, 301, 260,
! 279, 300, 301, 298, 300, 301, 41, 300, 301, 41,
! 296, 300, 301, 300, 301, 91, 300, 301, 300, 301,
! 41, 300, 301, 41, 303, 33, 366, 41, 36, 37,
! 38, 40, 40, 59, 42, 43, 41, 45, 304, 125,
! 300, 301, 300, 301, 310, 300, 301, 123, 125, 125,
! 126, 59, 125, 267, 123, 269, 64, 272, 273, 274,
! 275, 275, 300, 301, 279, 125, 281, 300, 301, 59,
! 336, 41, 287, 288, 289, 290, 125, 41, 300, 301,
! 44, 300, 301, 91, 41, 300, 301, 41, 303, 304,
! 305, 306, 307, 308, 309, 300, 301, 312, 59, 63,
! 315, 316, 317, 300, 301, 300, 301, 40, 123, 375,
! 300, 301, 300, 301, 41, 123, 41, 41, 126, 123,
! 256, 257, 258, 259, 260, 261, 41, 263, 264, 265,
! 266, 267, 268, 269, 270, 271, 272, 273, 274, 275,
! 41, 59, 41, 279, 280, 289, 282, 283, 284, 285,
! 286, 300, 301, 59, 41, 291, 292, 293, 294, 295,
! 296, 297, 63, 59, 41, 309, 302, 35, 312, 52,
! 52, 315, 316, 317, 15, 311, 154, 313, 314, 336,
! 256, 257, 258, 259, 260, 261, 375, 263, 264, 265,
! 266, 267, 268, 269, 270, 271, 272, 273, 274, 275,
! 202, 24, 269, 279, 280, -1, 282, 283, 284, 285,
! 286, -1, -1, 125, -1, 291, 292, 293, 294, 295,
! 296, 297, 355, 356, -1, 309, 302, 360, 312, -1,
! -1, 315, 316, 317, -1, 311, -1, 313, 314, -1,
! -1, 41, -1, 376, 44, -1, -1, 380, 256, 257,
! 258, 259, 260, 261, -1, 263, 264, 265, 58, 59,
! -1, 269, -1, 63, 272, 273, 274, 275, -1, -1,
! -1, 279, 280, -1, 282, 283, 284, 285, 286, -1,
! -1, 125, -1, 291, 292, 293, 294, 295, 296, -1,
! -1, -1, -1, 93, 302, -1, -1, -1, -1, -1,
! -1, -1, -1, 311, 33, 313, 314, 36, 37, 38,
! -1, 40, 41, 42, 43, 44, 45, 281, -1, -1,
! -1, -1, -1, 287, 288, 289, 290, -1, -1, 58,
! 59, -1, -1, -1, 63, 64, -1, -1, -1, 303,
! 304, 305, 306, 307, 308, 309, -1, -1, 312, -1,
! -1, 315, 316, 317, 266, 267, 268, -1, 270, 271,
! -1, -1, 91, -1, 93, 33, -1, -1, 36, 37,
! 38, -1, 40, 41, 42, 43, 44, 45, -1, -1,
! 281, -1, -1, -1, -1, 297, 287, 288, 289, 290,
! 58, 59, -1, -1, -1, 63, 64, 126, -1, -1,
! -1, -1, 303, 304, 305, 306, 307, 308, 309, -1,
! -1, 312, 29, -1, 315, 316, 317, -1, -1, -1,
! -1, -1, 266, 267, 268, 93, 270, 271, 33, 46,
! 47, 36, 37, 38, -1, 40, 53, 42, 43, -1,
! 45, 287, 288, 289, 290, -1, -1, -1, 65, 66,
! 67, 68, -1, 297, 59, -1, -1, -1, 126, 64,
306, 307, 308, 309, -1, -1, 312, -1, -1, 315,
! 316, 317, 272, 273, 274, 275, -1, -1, -1, 279,
! -1, 281, -1, -1, -1, -1, 91, 287, 288, 289,
! 290, 272, 273, 274, 275, 112, -1, -1, 279, -1,
! 300, 301, -1, 303, 304, 305, 306, 307, 308, 309,
! -1, -1, 312, -1, -1, 315, 316, 317, 123, 300,
! 301, 126, -1, -1, -1, -1, -1, -1, 257, 258,
! 259, 260, 261, -1, 263, 264, 265, -1, -1, -1,
! 269, -1, -1, 272, 273, 274, 275, -1, -1, -1,
! 279, 280, 281, 282, 283, 284, 285, 286, 287, 288,
! 289, 290, 291, 292, 293, 294, 295, 296, -1, -1,
! -1, 300, 301, 302, 303, 304, 305, 306, 307, 308,
! 309, -1, 311, 312, 313, 314, 315, 316, 317, 257,
! 258, 259, 260, 261, -1, 263, 264, 265, -1, -1,
! -1, 269, -1, -1, 272, 273, 274, 275, -1, -1,
! -1, 279, 280, 281, 282, 283, 284, 285, 286, 287,
! 288, 289, 290, 291, 292, 293, 294, 295, 296, -1,
! -1, -1, 300, 301, 302, 303, 304, 305, 306, 307,
! 308, 309, -1, 311, 312, 313, 314, 315, 316, 317,
! -1, 256, 257, 258, 259, 260, 261, 63, 263, 264,
265, -1, -1, -1, 269, -1, -1, 272, 273, 274,
! 275, -1, -1, -1, 279, 280, -1, 282, 283, 284,
! 285, 286, -1, -1, -1, -1, 291, 292, 293, 294,
! 295, 296, -1, -1, -1, 33, -1, 302, 36, 37,
! 38, -1, 40, -1, 42, 43, 311, 45, 313, 314,
! -1, 46, -1, -1, -1, -1, -1, -1, -1, 54,
! 287, 59, 289, 290, -1, -1, 64, -1, -1, 41,
! -1, -1, 44, -1, -1, 331, 332, 333, -1, 335,
! -1, 308, 309, -1, -1, 312, 58, 59, 315, 316,
! 317, -1, -1, 91, -1, 33, -1, -1, 36, 37,
! 38, 96, 40, -1, 42, 43, 362, 45, -1, -1,
! -1, -1, -1, 369, -1, -1, -1, 373, -1, -1,
! -1, 93, -1, -1, 119, 123, 64, -1, 126, -1,
! 386, 387, 127, -1, -1, 33, -1, -1, 36, 37,
! 38, -1, 40, -1, 42, 43, -1, 45, -1, -1,
! -1, -1, -1, 91, 287, 288, 289, 290, -1, -1,
! -1, -1, -1, -1, -1, -1, 64, -1, -1, -1,
! -1, -1, -1, -1, 41, 308, 309, 44, -1, 312,
! -1, -1, 315, 316, 317, 123, -1, -1, 126, -1,
! -1, 58, 59, 91, -1, -1, 63, -1, -1, 33,
! -1, -1, 36, 37, 38, -1, 40, -1, 42, 43,
! -1, 45, -1, -1, -1, 281, -1, -1, -1, -1,
! -1, 287, 288, 289, 290, 123, 93, -1, 126, -1,
! 64, -1, -1, -1, -1, -1, -1, 303, 304, 305,
! 306, 307, 308, 309, -1, -1, 312, -1, -1, 315,
! 316, 317, -1, -1, -1, -1, -1, 91, 256, 257,
! 258, 259, 260, 261, -1, 263, 264, 265, -1, -1,
! -1, 269, -1, 268, 272, 273, 274, 275, -1, 274,
! -1, 279, 280, -1, 282, 283, 284, 285, 286, 123,
! -1, -1, 126, 291, 292, 293, 294, 295, 296, -1,
! 272, 273, 274, 275, 302, -1, -1, 279, -1, -1,
! -1, -1, -1, 311, -1, 313, 314, -1, -1, 257,
! 258, 259, 260, 261, 262, 263, 264, 265, 300, 301,
! -1, 269, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, 280, -1, 282, 283, 284, 285, 286, -1,
! 41, -1, -1, 291, 292, 293, 294, 295, 296, 257,
! 258, 259, 260, 261, 302, 263, 264, 265, 59, -1,
! -1, 269, -1, 311, -1, 313, 314, -1, -1, -1,
! -1, -1, 280, -1, 282, 283, 284, 285, 286, 63,
! -1, -1, -1, 291, 292, 293, 294, 295, 296, -1,
! -1, -1, 93, -1, 302, 272, 273, 274, 275, -1,
! -1, -1, 279, 311, 281, 313, 314, -1, -1, -1,
! 287, 288, -1, 257, 258, 259, 260, 261, -1, 263,
! 264, 265, -1, 300, 301, 269, 303, 304, 305, 306,
! 307, 308, -1, -1, -1, -1, 280, -1, 282, 283,
284, 285, 286, -1, -1, -1, -1, 291, 292, 293,
! 294, 295, 296, 289, 290, -1, 33, -1, 302, 36,
! 37, 38, -1, 40, -1, 42, 43, 311, 45, 313,
! 314, -1, 308, 309, -1, -1, 312, -1, -1, 315,
! 316, 317, 59, -1, -1, -1, -1, 64, -1, -1,
! -1, 287, 288, 289, 290, -1, 33, -1, -1, 36,
! 37, 38, -1, 40, 41, 42, 43, -1, 45, 305,
! 306, 307, 308, 309, 91, -1, 312, -1, -1, 315,
! 316, 317, -1, -1, -1, -1, -1, 64, -1, -1,
! 287, 288, 289, 290, -1, -1, 33, -1, -1, 36,
! 37, 38, -1, 40, -1, 42, 43, -1, 45, 126,
! 307, 308, 309, -1, 91, 312, -1, -1, 315, 316,
! 317, -1, -1, -1, -1, -1, -1, 64, -1, -1,
! -1, 272, 273, 274, 275, -1, 33, -1, 279, 36,
! 37, 38, -1, 40, 41, 42, 43, -1, 45, 126,
! -1, -1, -1, -1, 91, -1, 93, 281, -1, 300,
! 301, -1, -1, 287, 288, 289, 290, 64, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 304, 305, 306, 307, 308, 309, -1, -1, 312, 126,
! -1, 315, 316, 317, 91, -1, 33, -1, -1, 36,
37, 38, -1, 40, 41, 42, 43, -1, 45, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, 64, -1, 126,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 257, 258, 259, 260, 261, -1, 263, 264, 265, -1,
! -1, -1, 269, -1, 91, -1, -1, -1, -1, -1,
! -1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
-1, -1, -1, -1, 291, 292, 293, 294, 295, 296,
! 257, 258, 259, 260, 261, 302, 263, 264, 265, 126,
! -1, -1, 269, -1, 311, -1, 313, 314, -1, -1,
! -1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
! -1, -1, -1, -1, 291, 292, 293, 294, 295, 296,
! 257, 258, 259, 260, 261, 302, 263, 264, 265, -1,
! -1, -1, 269, -1, 311, -1, 313, 314, -1, -1,
! -1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
! -1, -1, -1, -1, 291, 292, 293, 294, 295, 296,
! 257, 258, 259, 260, 261, 302, 263, 264, 265, -1,
! -1, -1, 269, -1, 311, -1, 313, 314, -1, -1,
! -1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
! -1, -1, -1, -1, 291, 292, 293, 294, 295, 296,
! -1, -1, -1, 33, -1, 302, 36, 37, 38, -1,
40, 41, 42, 43, 311, 45, 313, 314, -1, -1,
257, 258, 259, 260, 261, -1, 263, 264, 265, -1,
-1, -1, 269, -1, 64, -1, -1, -1, -1, -1,
--- 86,920 ----
6, 3, 3, 5, 2, 4, 0, 5, 1, 1,
5, 4, 5, 4, 5, 6, 5, 4, 5, 4,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
! 3, 3, 3, 3, 2, 2, 2, 2, 2, 2,
! 2, 2, 3, 2, 4, 3, 5, 2, 2, 4,
! 5, 4, 5, 1, 1, 1, 1, 5, 2, 1,
! 2, 3, 2, 1, 1, 1, 1, 1, 1, 6,
! 5, 4, 5, 1, 1, 3, 4, 3, 1, 2,
! 2, 1, 2, 2, 2, 1, 3, 1, 3, 4,
! 4, 6, 1, 1, 3, 2, 3, 2, 1, 1,
! 1, 0, 1, 0, 1, 2, 1, 2, 2, 2,
! 2, 2, 2, 1, 1, 1, 1,
};
! static short yydefred[] = { 4,
0, 7, 0, 45, 58, 56, 0, 56, 56, 8,
46, 9, 11, 48, 0, 47, 49, 50, 0, 0,
! 0, 70, 71, 0, 14, 3, 173, 0, 0, 154,
! 0, 168, 0, 57, 57, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 12, 0, 0, 0, 0, 0, 0, 0, 10,
! 0, 0, 0, 0, 0, 146, 148, 0, 0, 0,
! 0, 174, 140, 134, 135, 136, 137, 52, 0, 59,
! 0, 69, 0, 0, 7, 194, 197, 196, 195, 0,
! 0, 0, 0, 0, 0, 3, 3, 3, 3, 3,
! 3, 0, 0, 0, 0, 0, 163, 0, 0, 0,
! 0, 85, 0, 192, 0, 129, 0, 0, 0, 0,
! 0, 0, 0, 179, 181, 180, 0, 188, 0, 0,
! 0, 0, 0, 0, 0, 0, 124, 0, 0, 0,
! 189, 190, 191, 193, 0, 34, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 119, 120, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 13,
! 0, 51, 61, 0, 0, 0, 0, 83, 0, 0,
! 87, 0, 0, 0, 0, 0, 0, 0, 3, 167,
! 169, 0, 0, 0, 0, 0, 0, 0, 126, 0,
! 158, 178, 0, 0, 175, 0, 0, 123, 27, 0,
! 0, 19, 0, 0, 0, 0, 73, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 89, 0, 0, 90, 0, 0, 101, 0,
! 0, 0, 0, 0, 0, 0, 156, 0, 0, 0,
! 0, 0, 0, 2, 0, 0, 171, 0, 0, 0,
! 42, 0, 43, 0, 0, 0, 0, 187, 0, 0,
! 36, 41, 0, 0, 0, 170, 186, 86, 0, 130,
! 0, 132, 0, 125, 177, 65, 0, 0, 0, 0,
! 98, 0, 0, 0, 0, 100, 94, 0, 92, 0,
! 152, 0, 157, 63, 68, 67, 55, 0, 54, 84,
! 0, 88, 127, 0, 0, 0, 0, 0, 0, 0,
! 0, 80, 131, 133, 151, 0, 0, 0, 99, 93,
! 0, 97, 95, 153, 91, 72, 172, 6, 0, 0,
! 0, 0, 0, 0, 0, 0, 150, 96, 81, 7,
! 28, 29, 0, 0, 24, 25, 0, 32, 0, 0,
! 0, 22, 0, 0, 0, 31, 5, 0, 30, 0,
! 0, 33, 0, 23,
};
static short yydgoto[] = { 1,
! 10, 11, 20, 104, 19, 2, 95, 370, 98, 359,
! 3, 12, 13, 70, 375, 285, 72, 73, 74, 75,
! 76, 77, 78, 79, 291, 81, 292, 281, 283, 286,
! 294, 282, 284, 122, 214, 100, 82, 257, 89, 91,
! 194, 327, 156, 289, 271, 225, 14, 83, 137, 84,
! 85, 86, 87, 15, 16, 17, 18, 93, 278,
};
static short yysindex[] = { 0,
! 0, 0, -132, 0, 0, 0, -51, 0, 0, 0,
! 0, 0, 0, 0, 650, 0, 0, 0, -239, -215,
! 5, 0, 0, -215, 0, 0, 0, -31, -31, 0,
! -24, 0, 2181, 0, 0, 11, 16, 32, 46, -34,
! 2181, 49, 72, 76, 1017, 977, -31, 1081, 1348, -134,
! 2181, 85, -31, 2181, 2181, 2181, 2181, 2181, 2181, 1388,
! 1428, 0, 2181, 2181, -31, -31, -31, -31, -150, 0,
! 337, 849, -13, -58, -48, 0, 0, 8, 97, 92,
! 116, 0, 0, 0, 0, 0, 0, 0, 52, 0,
! -97, 0, -75, -97, 0, 0, 0, 0, 0, 2181,
! 146, 2181, 395, 52, -97, 0, 0, 0, 0, 0,
! 0, 150, 849, 153, 1468, 977, 0, 395, 0, -58,
! 116, 0, 2181, 0, 157, 0, 395, -8, 83, -52,
! 2181, 395, 1528, 0, 0, 0, -89, 0, 116, 107,
! 107, 107, -104, -104, 123, -37, 0, -73, 107, 107,
! 0, 0, 0, 0, 52, 0, 2181, 2181, 2181, 2181,
! 2181, 2181, 2181, 2181, 2181, 2181, 2181, 2181, 2181, 2181,
! 2181, 2181, 2181, 2181, 2181, 2181, 2181, 0, 0, -12,
! 2181, 1735, 2181, 2181, 2181, 2181, 2181, 2181, 1795, 0,
! 2181, 0, 0, -64, -32, -64, 411, 0, 2181, 291,
! 0, -64, 2181, 2181, 2181, 2181, 187, 1854, 0, 0,
! 0, -29, 58, 189, 2181, 116, 1914, 2029, 0, 111,
! 0, 0, -26, -19, 0, 2181, 165, 0, 0, -241,
! -241, 0, -241, -241, -241, -40, 0, 1618, 395, 1306,
! 185, 168, 849, 1235, 1129, 1169, 1268, 782, 235, 107,
! 107, 2181, 0, 2121, 2181, 0, 218, -46, 0, -3,
! -68, 61, 106, 65, 108, 68, 0, 17, 849, 26,
! -30, 2181, -30, 0, 236, 2181, 0, 2181, 52, -241,
! 0, 250, 0, 255, -241, 259, 260, 0, 248, 337,
! 0, 0, 262, 261, 2181, 0, 0, 0, 22, 0,
! 33, 0, 36, 0, 0, 0, 125, 2181, 2181, 71,
! 0, 50, 127, 2181, 182, 0, 0, 184, 0, 199,
! 0, 201, 0, 0, 0, 0, 0, 272, 0, 0,
! 354, 0, 0, 216, 216, 216, 216, 2181, 216, 2181,
! 301, 0, 0, 0, 0, 167, 2418, 228, 0, 0,
! 319, 0, 0, 0, 0, 0, 0, 0, -150, -150,
! -123, -123, 322, -150, 308, 216, 0, 0, 0, 0,
! 0, 0, 216, 334, 0, 0, 216, 0, 1854, -150,
! 449, 0, 2181, -150, 340, 0, 0, 355, 0, 216,
! 216, 0, -123, 0,
};
static short yyrindex[] = { 0,
! 0, 0, 247, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 274, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 40, 455, 0, 0, 2367, 2469, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 119, 0,
! 3, 943, 2515, 2603, 2653, 0, 0, 2708, 2754, 0,
! -6, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! -33, 0, 0, -33, 0, 0, 0, 0, 0, 2469,
! 0, 0, 3919, 0, -102, 0, 0, 0, 0, 0,
! 0, 0, 3216, 0, 0, 359, 0, 3955, 526, 587,
! 2276, 0, 0, 0, 2801, 0, 3999, 2603, 0, 0,
! 2469, 4043, 0, 0, 0, 0, 2858, 0, 3225, 3461,
! 3527, 3588, 3352, 3399, 2908, 0, 0, 0, 3635, 3680,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 2990, 0, 0, -28, 0, -28, 917, 0, 359, 0,
! 0, 295, 379, 0, 0, 0, 0, 370, 0, 0,
! 0, 0, 390, 0, 0, 3291, 0, 0, 0, 0,
! 0, 0, 0, 3056, 0, 0, 3113, 0, 0, 14,
! 35, 0, 55, 91, 117, 1991, 0, 4235, 4090, 1826,
! 3807, 3871, 3283, 0, -22, 4191, 4155, 4145, 1048, 3719,
! 3763, 0, 0, 0, 0, 0, 3163, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 4267, -10,
! 0, 375, 0, 0, 0, 0, 0, 2469, 0, 136,
! 0, 0, 0, 0, 400, 0, 0, 0, 0, 139,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 359, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 396,
! 0, 0, 0, 0, 0, 0, 4080, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 119, 119,
! 179, 179, 0, 119, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 415, 119,
! 917, 0, 0, 119, 0, 0, 0, 0, 0, 0,
! 0, 0, 179, 0,
};
static short yygindex[] = { 0,
! 0, 0, 196, 425, 0, 0, -2, 0, 37, 634,
! -94, 0, 0, 0, -323, -15, 2445, 0, 999, 414,
! 417, 0, 0, 0, 463, -43, 0, 0, 321, -198,
! 103, 147, 280, -91, -185, 1, 0, 0, 0, 464,
! -44, 222, 338, 0, -179, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0,
};
! #define YYTABLESIZE 4568
static short yytable[] = { 71,
! 197, 65, 121, 227, 65, 111, 220, 22, 198, 293,
! 139, 296, 315, 275, 305, 102, 273, 88, 113, 228,
! 60, 113, 279, 65, 317, 60, 182, 254, 325, 101,
! 62, 218, 185, 130, 75, 113, 113, 316, 376, 221,
! 113, 90, 187, 15, 146, 148, 123, 124, 64, 196,
! 106, 69, 75, 138, 18, 107, 121, 323, 162, 163,
! 202, 15, 342, 92, 184, 151, 152, 153, 154, 394,
! 113, 108, 18, 343, 186, 39, 344, 183, 255, 216,
! 159, 117, 185, 159, 126, 109, 75, 121, 114, 60,
! 349, 26, 26, 39, 62, 16, 341, 159, 159, 212,
! 213, 297, 159, 203, 204, 205, 206, 207, 208, 181,
! 252, 115, 64, 16, 184, 116, 215, 223, 26, 318,
! 65, 67, 131, 320, 133, 192, 322, 155, 351, 348,
! 188, 17, 159, 4, 5, 6, 189, 7, 8, 363,
! 201, 230, 231, 233, 234, 235, 236, 237, 66, 17,
! 190, 26, 373, 374, 26, 26, 26, 20, 26, 191,
! 26, 26, 193, 26, 9, 258, 260, 261, 262, 263,
! 264, 265, 266, 268, 26, 20, 38, 26, 21, 40,
! 328, 195, 26, 213, 388, 199, 332, 280, 231, 209,
! 231, 229, 290, 210, 38, 60, 217, 15, 319, 299,
! 321, 301, 303, 23, 24, 21, 295, 219, 224, 26,
! 307, 21, 180, 226, 21, 21, 21, 345, 21, 350,
! 21, 21, 65, 21, 272, 96, 162, 163, 121, 298,
! 97, 162, 163, 270, 121, 304, 310, 21, 312, 313,
! 306, 26, 21, 26, 26, 253, 1, 162, 163, 113,
! 113, 113, 113, 162, 163, 308, 113, 314, 113, 367,
! 163, 110, 162, 163, 60, 75, 75, 75, 75, 21,
! 162, 163, 75, 162, 163, 381, 330, 113, 113, 44,
! 113, 113, 44, 44, 44, 324, 44, 338, 44, 44,
! 334, 44, 346, 75, 75, 335, 162, 163, 213, 336,
! 337, 21, 339, 21, 21, 44, 352, 326, 353, 326,
! 44, 159, 159, 159, 159, 333, 162, 163, 159, 340,
! 159, 162, 163, 354, 280, 355, 159, 159, 159, 159,
! 356, 277, 162, 163, 276, 162, 163, 44, 358, 159,
! 159, 366, 159, 159, 159, 159, 159, 159, 159, 162,
! 163, 159, 368, 170, 159, 159, 159, 162, 163, 369,
! 162, 163, 377, 71, 162, 163, 379, 162, 163, 44,
! 162, 163, 44, 383, 26, 26, 26, 26, 26, 26,
! 390, 26, 26, 26, 26, 26, 26, 26, 26, 26,
! 26, 26, 26, 26, 357, 391, 53, 26, 26, 184,
! 26, 26, 26, 26, 26, 162, 163, 162, 163, 26,
! 26, 26, 26, 26, 26, 26, 170, 62, 177, 37,
! 26, 178, 179, 180, 162, 163, 162, 163, 35, 26,
! 185, 26, 26, 182, 21, 21, 21, 21, 21, 21,
! 40, 21, 21, 21, 21, 21, 21, 21, 21, 21,
! 21, 21, 21, 21, 37, 35, 167, 21, 21, 105,
! 21, 21, 21, 21, 21, 135, 162, 163, 136, 21,
! 21, 21, 21, 21, 21, 21, 176, 80, 232, 177,
! 21, 385, 178, 179, 180, 287, 365, 94, 0, 21,
! 0, 21, 21, 176, 329, 166, 177, 0, 166, 178,
! 179, 180, 44, 44, 44, 44, 44, 44, 0, 44,
! 44, 44, 166, 166, 0, 44, 0, 166, 44, 44,
! 44, 44, 0, 167, 168, 44, 44, 0, 44, 44,
! 44, 44, 44, 0, 0, 274, 0, 44, 44, 44,
! 44, 44, 44, 176, 0, 0, 177, 166, 44, 178,
! 179, 180, 0, 0, 0, 0, 0, 44, 194, 44,
! 44, 194, 194, 194, 0, 194, 173, 194, 194, 173,
! 194, 164, 0, 387, 0, 0, 0, 165, 166, 167,
! 168, 0, 0, 173, 173, 0, 0, 0, 173, 194,
! 0, 0, 0, 169, 171, 172, 173, 174, 175, 176,
! 0, 0, 177, 0, 0, 178, 179, 180, 157, 158,
! 159, 160, 0, 0, 0, 161, 194, 0, 173, 195,
! 0, 0, 195, 195, 195, 0, 195, 144, 195, 195,
! 144, 195, 0, 0, 164, 0, 162, 163, 0, 0,
! 165, 166, 167, 168, 144, 144, 0, 0, 0, 144,
! 195, 194, 0, 0, 0, 0, 169, 171, 172, 173,
! 174, 175, 176, 0, 0, 177, 0, 0, 178, 179,
! 180, 0, 0, 0, 0, 0, 4, 5, 6, 144,
! 7, 8, 55, 167, 168, 65, 67, 53, 0, 60,
! 0, 68, 64, 0, 63, 0, 371, 372, 0, 0,
! 0, 378, 175, 176, 0, 0, 177, 9, 62, 178,
! 179, 180, 195, 66, 4, 5, 6, 386, 7, 8,
! 0, 389, 0, 0, 0, 0, 166, 166, 166, 166,
! 0, 0, 0, 166, 0, 166, 0, 0, 0, 0,
! 61, 166, 166, 166, 166, 9, 0, 0, 0, 0,
! 0, 0, 0, 0, 166, 166, 0, 166, 166, 166,
! 166, 166, 166, 166, 0, 0, 166, 0, 0, 166,
! 166, 166, 26, 0, 0, 56, 0, 0, 0, 0,
! 0, 0, 194, 194, 194, 194, 194, 0, 194, 194,
! 194, 0, 0, 0, 194, 0, 0, 173, 173, 173,
! 173, 0, 0, 0, 173, 194, 173, 194, 194, 194,
! 194, 194, 173, 173, 173, 173, 194, 194, 194, 194,
! 194, 194, 0, 0, 0, 173, 173, 194, 173, 173,
! 173, 173, 173, 173, 173, 0, 194, 173, 194, 194,
! 173, 173, 173, 195, 195, 195, 195, 195, 0, 195,
! 195, 195, 0, 0, 0, 195, 0, 0, 144, 144,
! 144, 144, 0, 0, 0, 144, 195, 144, 195, 195,
! 195, 195, 195, 144, 144, 144, 144, 195, 195, 195,
! 195, 195, 195, 0, 0, 0, 144, 144, 195, 144,
! 144, 144, 144, 144, 144, 144, 0, 195, 144, 195,
! 195, 144, 144, 144, 0, 25, 27, 28, 29, 30,
! 31, 170, 32, 33, 34, 0, 0, 0, 35, 0,
! 0, 36, 37, 38, 39, 0, 0, 0, 40, 41,
! 0, 42, 43, 44, 45, 46, 0, 0, 0, 0,
! 47, 48, 49, 50, 51, 52, 0, 0, 0, 44,
! 0, 54, 44, 44, 44, 0, 44, 0, 44, 44,
! 57, 44, 58, 59, 0, 0, 0, 0, 360, 361,
! 362, 0, 364, 0, 0, 44, 0, 0, 0, 0,
! 44, 0, 0, 78, 0, 0, 78, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 380,
! 78, 78, 0, 0, 0, 0, 382, 44, 0, 55,
! 384, 0, 65, 67, 53, 0, 60, 0, 68, 64,
! 0, 63, 0, 392, 393, 0, 99, 99, 0, 0,
! 0, 0, 0, 0, 0, 78, 0, 0, 112, 44,
! 66, 0, 44, 0, 120, 99, 128, 0, 0, 55,
! 134, 99, 65, 67, 53, 0, 60, 0, 68, 64,
! 0, 63, 0, 99, 99, 99, 99, 61, 165, 166,
! 167, 168, 0, 0, 0, 0, 0, 0, 0, 0,
! 66, 0, 0, 0, 0, 0, 0, 0, 106, 175,
! 176, 106, 0, 177, 0, 0, 178, 179, 180, 26,
! 0, 0, 56, 0, 0, 106, 106, 61, 0, 0,
! 106, 0, 0, 55, 120, 0, 65, 67, 53, 0,
! 60, 0, 68, 64, 0, 63, 0, 0, 0, 164,
! 0, 0, 0, 0, 0, 165, 166, 167, 168, 26,
! 106, 0, 56, 0, 66, 0, 0, 0, 0, 0,
! 0, 169, 171, 172, 173, 174, 175, 176, 0, 0,
! 177, 0, 0, 178, 179, 180, 0, 0, 0, 0,
! 0, 61, 44, 44, 44, 44, 44, 44, 256, 44,
! 44, 44, 0, 0, 0, 44, 0, 0, 44, 44,
! 44, 44, 0, 0, 0, 44, 44, 0, 44, 44,
! 44, 44, 44, 26, 0, 288, 56, 44, 44, 44,
! 44, 44, 44, 0, 78, 78, 78, 78, 44, 0,
! 0, 78, 0, 0, 0, 0, 0, 44, 0, 44,
! 44, 0, 0, 119, 28, 29, 30, 31, 97, 32,
! 33, 34, 78, 78, 0, 35, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 41, 0, 42, 43,
44, 45, 46, 0, 0, 0, 0, 47, 48, 49,
! 50, 51, 52, 27, 28, 29, 30, 31, 54, 32,
! 33, 34, 0, 0, 0, 35, 0, 57, 0, 58,
! 59, 0, 309, 0, 0, 0, 41, 170, 42, 43,
! 44, 45, 46, 0, 0, 0, 0, 47, 48, 49,
! 50, 51, 52, 0, 0, 0, 0, 0, 54, 106,
! 106, 106, 106, 0, 0, 0, 106, 57, 106, 58,
! 59, 0, 0, 0, 106, 106, 0, 125, 28, 29,
! 30, 31, 0, 32, 33, 34, 0, 106, 106, 35,
! 106, 106, 106, 106, 106, 106, 0, 0, 0, 0,
! 41, 0, 42, 43, 44, 45, 46, 0, 0, 0,
! 0, 47, 48, 49, 50, 51, 52, 0, 0, 0,
! 55, 0, 54, 65, 67, 53, 0, 60, 0, 68,
! 64, 57, 63, 58, 59, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 129, 0, 0, 0,
! 0, 66, 0, 0, 0, 165, 166, 167, 168, 0,
! 55, 0, 0, 65, 67, 53, 0, 60, 145, 68,
! 64, 0, 63, 172, 173, 174, 175, 176, 61, 0,
! 177, 0, 0, 178, 179, 180, 0, 0, 0, 0,
! 0, 66, 0, 0, 0, 165, 166, 167, 168, 0,
! 55, 0, 0, 65, 67, 53, 0, 60, 0, 68,
! 64, 0, 63, 56, 173, 174, 175, 176, 61, 0,
! 177, 0, 0, 178, 179, 180, 0, 0, 0, 0,
! 0, 66, 0, 0, 0, 0, 0, 0, 0, 0,
! 55, 0, 0, 65, 67, 53, 0, 60, 211, 68,
! 64, 0, 63, 56, 0, 164, 0, 0, 61, 0,
! 147, 165, 166, 167, 168, 0, 0, 0, 0, 0,
! 0, 66, 0, 0, 0, 0, 0, 169, 171, 172,
! 173, 174, 175, 176, 0, 0, 177, 0, 0, 178,
! 179, 180, 0, 56, 165, 166, 167, 168, 61, 0,
! 55, 0, 0, 65, 67, 53, 0, 60, 222, 68,
! 64, 0, 63, 0, 174, 175, 176, 0, 0, 177,
! 0, 0, 178, 179, 180, 0, 0, 0, 0, 0,
! 0, 66, 165, 56, 167, 168, 0, 0, 0, 0,
! 0, 0, 0, 0, 27, 28, 29, 30, 31, 0,
! 32, 33, 34, 175, 176, 0, 35, 177, 61, 0,
! 178, 179, 180, 0, 0, 0, 0, 41, 0, 42,
! 43, 44, 45, 46, 0, 0, 0, 0, 47, 48,
! 49, 50, 51, 52, 27, 28, 29, 30, 31, 54,
! 32, 33, 34, 56, 0, 0, 35, 0, 57, 0,
! 58, 59, 0, 0, 0, 0, 0, 41, 0, 42,
! 43, 44, 45, 46, 0, 0, 0, 0, 47, 48,
! 49, 50, 51, 52, 27, 28, 29, 30, 31, 54,
! 32, 33, 34, 0, 0, 0, 35, 0, 57, 0,
! 58, 59, 0, 0, 0, 0, 0, 41, 0, 42,
! 43, 44, 45, 46, 0, 0, 0, 0, 47, 48,
! 49, 50, 51, 52, 27, 28, 29, 30, 31, 54,
! 32, 33, 34, 0, 0, 0, 35, 0, 57, 0,
! 58, 59, 0, 0, 0, 0, 0, 41, 0, 42,
! 43, 44, 45, 46, 0, 0, 0, 0, 47, 48,
! 49, 50, 51, 52, 0, 0, 0, 55, 0, 54,
! 65, 67, 53, 0, 60, 259, 68, 64, 57, 63,
! 58, 59, 0, 0, 27, 28, 29, 30, 31, 0,
! 32, 33, 34, 0, 0, 0, 35, 0, 66, 0,
! 0, 0, 0, 0, 0, 0, 0, 41, 0, 42,
! 43, 44, 45, 46, 0, 0, 0, 0, 47, 48,
! 49, 50, 51, 52, 0, 61, 0, 55, 0, 54,
! 65, 67, 53, 0, 60, 267, 68, 64, 57, 63,
! 58, 59, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 66, 0,
! 56, 0, 0, 0, 0, 0, 108, 0, 0, 108,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 108, 108, 61, 55, 0, 108, 65,
! 67, 53, 0, 60, 0, 68, 64, 0, 63, 0,
! 0, 0, 0, 0, 165, 166, 167, 168, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 66, 108, 0,
! 56, 171, 172, 173, 174, 175, 176, 0, 0, 177,
! 0, 0, 178, 179, 180, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 61, 0, 55, 0, 0, 65,
! 67, 53, 0, 60, 300, 68, 64, 0, 63, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 66, 0, 56,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 27, 28, 29, 30, 31, 0, 32, 33, 34,
! 0, 0, 0, 35, 61, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 41, 0, 42, 43, 44, 45,
! 46, 0, 0, 0, 0, 47, 48, 49, 50, 51,
! 52, 74, 0, 0, 74, 0, 54, 0, 0, 56,
! 0, 0, 0, 0, 0, 57, 0, 58, 59, 74,
! 0, 27, 28, 29, 30, 31, 0, 32, 33, 34,
! 0, 55, 0, 35, 65, 67, 53, 0, 60, 302,
! 68, 64, 0, 63, 41, 0, 42, 43, 44, 45,
! 46, 0, 0, 74, 0, 47, 48, 49, 50, 51,
! 52, 0, 66, 0, 0, 0, 54, 108, 108, 108,
! 108, 0, 0, 0, 108, 57, 108, 58, 59, 25,
! 27, 28, 29, 30, 31, 0, 32, 33, 34, 61,
! 0, 0, 35, 0, 0, 108, 108, 0, 108, 108,
! 108, 108, 108, 41, 0, 42, 43, 44, 45, 46,
0, 0, 0, 0, 47, 48, 49, 50, 51, 52,
! 0, 0, 0, 55, 56, 54, 65, 67, 53, 0,
! 60, 311, 68, 64, 57, 63, 58, 59, 0, 0,
27, 28, 29, 30, 31, 0, 32, 33, 34, 0,
0, 0, 35, 0, 66, 0, 0, 0, 0, 0,
0, 0, 0, 41, 0, 42, 43, 44, 45, 46,
0, 0, 0, 0, 47, 48, 49, 50, 51, 52,
0, 61, 0, 55, 0, 54, 65, 67, 53, 0,
! 60, 0, 68, 64, 57, 63, 58, 59, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 66, 0, 56, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 74, 74, 74, 74, 0, 0, 0, 74,
! 0, 61, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 27, 28, 29, 30, 31,
! 74, 32, 33, 34, 0, 0, 0, 35, 0, 0,
! 0, 0, 0, 0, 0, 0, 56, 0, 41, 0,
! 42, 43, 44, 45, 46, 0, 183, 0, 0, 47,
! 48, 49, 50, 51, 52, 0, 0, 0, 0, 0,
! 54, 0, 0, 183, 183, 0, 0, 0, 183, 57,
! 0, 58, 59, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 183, 0,
0, 0, 0, 0, 0, 0, 0, 27, 28, 29,
30, 31, 0, 32, 33, 34, 0, 0, 0, 35,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 41, 0, 42, 43, 44, 45, 46, 162, 0, 0,
! 162, 47, 48, 49, 50, 51, 52, 0, 0, 0,
! 0, 0, 54, 0, 162, 162, 0, 0, 0, 162,
0, 57, 0, 58, 59, 0, 0, 27, 28, 29,
! 30, 31, 0, 32, 33, 34, 0, 0, 0, 35,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 162,
41, 0, 42, 43, 44, 45, 46, 0, 0, 0,
! 0, 47, 48, 49, 50, 51, 52, 103, 0, 0,
! 170, 0, 54, 0, 0, 113, 0, 0, 0, 118,
! 0, 57, 127, 58, 59, 132, 0, 0, 0, 140,
! 141, 142, 143, 144, 0, 0, 0, 149, 150, 182,
! 0, 0, 182, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 182, 182, 0, 0,
! 0, 182, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 200, 183, 183, 183,
! 183, 0, 0, 0, 183, 149, 183, 0, 149, 0,
! 0, 182, 183, 183, 183, 183, 0, 0, 0, 0,
! 0, 0, 149, 149, 0, 183, 183, 149, 183, 183,
! 183, 183, 183, 183, 183, 0, 0, 183, 0, 0,
! 183, 183, 183, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 149, 238, 239,
! 240, 241, 242, 243, 244, 245, 246, 247, 248, 249,
! 250, 251, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 269, 0, 0, 162, 162,
! 162, 162, 0, 144, 0, 162, 144, 162, 0, 0,
! 0, 0, 0, 162, 162, 162, 162, 0, 0, 0,
! 144, 144, 0, 0, 0, 144, 162, 162, 0, 162,
! 162, 162, 162, 162, 162, 162, 0, 0, 162, 0,
! 0, 162, 162, 162, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 147, 0, 144, 147, 0, 164, 0,
! 0, 0, 0, 0, 165, 166, 167, 168, 0, 0,
! 147, 147, 0, 0, 0, 147, 0, 0, 0, 0,
! 331, 171, 172, 173, 174, 175, 176, 0, 0, 177,
! 0, 0, 178, 179, 180, 0, 0, 0, 0, 0,
! 182, 182, 182, 182, 0, 147, 0, 182, 145, 182,
! 0, 145, 0, 347, 0, 182, 182, 182, 182, 0,
! 0, 0, 0, 0, 0, 145, 145, 0, 182, 182,
! 145, 182, 182, 182, 182, 182, 182, 182, 0, 0,
! 182, 0, 0, 182, 182, 182, 149, 149, 149, 149,
! 0, 0, 0, 149, 155, 149, 0, 155, 0, 0,
! 145, 149, 149, 149, 149, 0, 0, 0, 0, 0,
! 0, 155, 155, 0, 149, 149, 155, 149, 149, 149,
! 149, 149, 149, 149, 0, 0, 149, 0, 0, 149,
! 149, 149, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 173, 0, 0, 173, 0, 155, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 173, 173,
! 0, 0, 0, 173, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 144, 144, 144, 144, 0, 0,
! 0, 144, 0, 144, 0, 0, 0, 0, 0, 144,
! 144, 144, 144, 173, 0, 0, 0, 0, 176, 0,
! 0, 176, 144, 144, 0, 144, 144, 144, 144, 144,
! 144, 144, 0, 0, 144, 176, 176, 144, 144, 144,
! 176, 0, 0, 0, 147, 147, 147, 147, 0, 0,
! 0, 147, 0, 147, 0, 0, 0, 0, 0, 147,
! 147, 147, 147, 0, 0, 0, 0, 0, 143, 0,
! 176, 143, 147, 147, 0, 147, 147, 147, 147, 147,
! 147, 147, 0, 0, 147, 143, 143, 147, 147, 147,
! 143, 0, 0, 0, 0, 0, 0, 0, 0, 145,
! 145, 145, 145, 0, 0, 0, 145, 0, 145, 0,
! 0, 0, 0, 0, 145, 145, 145, 145, 0, 0,
! 143, 0, 0, 0, 0, 0, 0, 145, 145, 0,
! 145, 145, 145, 145, 145, 145, 145, 0, 0, 145,
! 0, 0, 145, 145, 145, 155, 155, 155, 155, 0,
! 76, 0, 155, 76, 155, 0, 0, 0, 0, 0,
! 155, 155, 155, 155, 0, 0, 0, 76, 76, 0,
! 0, 0, 76, 155, 155, 0, 155, 155, 155, 155,
! 155, 155, 155, 0, 0, 155, 0, 0, 155, 155,
! 155, 0, 173, 173, 173, 173, 0, 0, 0, 173,
! 0, 173, 76, 0, 0, 0, 0, 173, 173, 173,
! 173, 0, 0, 0, 0, 0, 66, 0, 0, 66,
! 173, 173, 0, 173, 173, 173, 173, 173, 173, 173,
! 0, 0, 173, 66, 66, 173, 173, 173, 66, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 176,
! 176, 176, 176, 0, 0, 0, 176, 0, 176, 0,
! 0, 0, 0, 0, 176, 176, 176, 176, 66, 0,
! 0, 0, 0, 142, 0, 0, 142, 176, 176, 0,
! 176, 176, 176, 176, 176, 176, 176, 0, 0, 176,
! 142, 142, 176, 176, 176, 142, 0, 0, 0, 143,
! 143, 143, 143, 0, 0, 0, 143, 0, 143, 0,
! 0, 0, 0, 0, 143, 143, 143, 143, 0, 0,
! 0, 0, 0, 82, 0, 142, 82, 143, 143, 0,
! 143, 143, 143, 143, 143, 143, 143, 0, 0, 143,
! 82, 82, 143, 143, 143, 82, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 82, 160, 0, 0, 160,
! 0, 76, 76, 76, 76, 161, 0, 0, 76, 0,
! 76, 0, 0, 160, 160, 0, 76, 76, 76, 76,
! 0, 0, 161, 161, 0, 0, 0, 161, 0, 76,
! 76, 0, 76, 76, 76, 76, 76, 76, 76, 0,
! 0, 76, 0, 0, 76, 76, 76, 0, 160, 0,
! 0, 0, 0, 0, 0, 0, 0, 161, 0, 0,
! 0, 0, 0, 102, 0, 0, 102, 66, 66, 66,
! 66, 79, 0, 0, 66, 0, 66, 0, 0, 0,
! 102, 102, 66, 66, 66, 66, 0, 0, 79, 79,
! 0, 0, 0, 79, 0, 66, 66, 0, 66, 66,
! 66, 66, 66, 66, 66, 0, 0, 66, 0, 0,
! 66, 66, 66, 0, 0, 102, 0, 0, 0, 0,
! 0, 0, 0, 79, 142, 142, 142, 142, 0, 0,
! 0, 142, 121, 142, 0, 121, 0, 0, 0, 142,
! 142, 142, 142, 0, 0, 0, 0, 0, 0, 121,
! 121, 0, 142, 142, 121, 142, 142, 142, 142, 142,
! 142, 142, 0, 0, 142, 0, 0, 142, 142, 142,
! 0, 0, 0, 0, 82, 82, 82, 82, 0, 122,
! 0, 82, 122, 82, 121, 0, 0, 0, 0, 82,
! 82, 82, 82, 0, 0, 0, 122, 122, 0, 0,
! 0, 122, 82, 82, 0, 82, 82, 82, 82, 82,
! 82, 82, 0, 0, 82, 0, 0, 82, 82, 82,
! 0, 0, 0, 0, 0, 0, 0, 160, 160, 160,
! 160, 122, 0, 0, 160, 0, 161, 161, 161, 161,
! 0, 117, 0, 161, 117, 161, 0, 0, 0, 0,
! 0, 161, 161, 161, 161, 160, 160, 0, 117, 117,
! 0, 0, 0, 117, 161, 161, 0, 161, 161, 161,
! 161, 161, 161, 161, 0, 0, 161, 0, 0, 161,
! 161, 161, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 117, 102, 102, 102, 102, 0, 0,
! 0, 102, 79, 79, 79, 79, 0, 118, 0, 79,
! 118, 79, 0, 0, 0, 0, 0, 79, 79, 79,
! 79, 0, 102, 102, 118, 118, 0, 0, 0, 118,
! 79, 79, 0, 79, 79, 79, 79, 79, 79, 79,
! 0, 0, 79, 0, 0, 79, 79, 79, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 118,
! 0, 0, 0, 121, 121, 121, 121, 0, 139, 0,
! 121, 139, 121, 0, 0, 0, 0, 0, 121, 121,
! 121, 121, 0, 0, 0, 139, 139, 0, 0, 0,
! 139, 121, 121, 0, 121, 121, 121, 121, 121, 121,
! 121, 0, 0, 121, 0, 0, 0, 0, 0, 0,
! 122, 122, 122, 122, 0, 115, 0, 122, 115, 122,
! 139, 0, 0, 0, 0, 122, 122, 122, 122, 0,
! 0, 0, 115, 115, 0, 0, 0, 115, 122, 122,
! 0, 122, 122, 122, 122, 122, 122, 122, 0, 0,
! 122, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 116, 0, 0, 116, 0, 0, 0, 115, 0, 0,
! 0, 0, 117, 117, 117, 117, 0, 116, 116, 117,
! 0, 117, 116, 0, 0, 0, 0, 117, 117, 117,
! 117, 0, 0, 0, 0, 0, 0, 0, 0, 114,
! 117, 117, 114, 117, 117, 117, 117, 117, 117, 117,
! 0, 0, 116, 0, 0, 0, 114, 114, 0, 0,
! 0, 114, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 118, 118,
! 118, 118, 0, 103, 0, 118, 103, 118, 0, 0,
! 0, 114, 0, 118, 118, 118, 118, 0, 0, 0,
! 103, 103, 0, 0, 0, 103, 118, 118, 0, 118,
! 118, 118, 118, 118, 118, 118, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 104, 0, 0,
! 104, 0, 0, 0, 0, 103, 0, 0, 0, 139,
! 139, 139, 139, 0, 104, 104, 139, 0, 139, 104,
! 0, 0, 0, 0, 139, 139, 139, 139, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 139, 139, 0,
! 139, 139, 139, 139, 139, 139, 139, 0, 0, 104,
! 0, 0, 0, 0, 0, 0, 115, 115, 115, 115,
! 0, 105, 0, 115, 105, 115, 0, 0, 0, 0,
! 0, 115, 115, 115, 115, 0, 0, 0, 105, 105,
! 0, 0, 0, 105, 115, 115, 0, 115, 115, 115,
! 115, 115, 115, 115, 0, 0, 0, 0, 0, 0,
! 0, 116, 116, 116, 116, 0, 0, 0, 116, 165,
! 116, 0, 165, 105, 0, 0, 116, 116, 116, 116,
! 0, 0, 0, 0, 0, 0, 165, 165, 0, 116,
! 116, 165, 116, 116, 116, 116, 116, 116, 116, 0,
! 114, 114, 114, 114, 0, 164, 0, 114, 164, 114,
! 0, 0, 0, 0, 0, 114, 114, 114, 114, 0,
! 0, 165, 164, 164, 0, 0, 0, 164, 114, 114,
! 0, 114, 114, 114, 114, 114, 114, 114, 0, 0,
! 0, 0, 0, 0, 103, 103, 103, 103, 0, 128,
! 0, 103, 128, 103, 0, 0, 0, 164, 0, 103,
! 103, 103, 103, 0, 0, 0, 128, 128, 0, 0,
! 0, 128, 103, 103, 0, 103, 103, 103, 103, 103,
! 103, 103, 0, 0, 0, 0, 0, 0, 104, 104,
! 104, 104, 0, 141, 0, 104, 141, 104, 0, 0,
! 0, 128, 0, 104, 104, 104, 104, 0, 0, 0,
! 141, 141, 0, 0, 0, 141, 104, 104, 0, 104,
! 104, 104, 104, 104, 104, 0, 0, 0, 0, 0,
! 138, 0, 0, 138, 0, 0, 0, 0, 0, 0,
! 107, 0, 0, 107, 0, 141, 0, 138, 138, 0,
! 0, 0, 105, 105, 105, 105, 0, 107, 107, 105,
! 0, 105, 107, 0, 0, 0, 0, 105, 105, 0,
! 105, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 105, 105, 138, 105, 105, 105, 105, 105, 105, 0,
! 0, 0, 107, 0, 0, 109, 0, 0, 109, 0,
! 165, 165, 165, 165, 0, 110, 0, 165, 110, 165,
! 0, 0, 109, 109, 0, 165, 165, 109, 0, 0,
! 0, 0, 110, 110, 0, 0, 0, 110, 165, 165,
! 0, 165, 165, 165, 165, 165, 164, 164, 164, 164,
! 0, 112, 0, 164, 112, 164, 0, 109, 0, 0,
! 0, 164, 164, 0, 0, 0, 0, 110, 112, 112,
! 0, 0, 0, 112, 164, 164, 0, 164, 164, 164,
! 164, 164, 0, 0, 0, 0, 0, 0, 0, 0,
! 128, 128, 128, 128, 0, 111, 0, 128, 111, 128,
! 0, 0, 0, 112, 0, 128, 128, 0, 0, 0,
! 0, 0, 111, 111, 0, 0, 0, 111, 128, 128,
! 0, 128, 128, 128, 128, 128, 0, 77, 0, 0,
! 77, 0, 0, 0, 141, 141, 141, 141, 0, 0,
! 0, 141, 0, 141, 77, 77, 0, 111, 0, 141,
! 141, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 141, 141, 0, 141, 141, 141, 141, 141,
! 0, 138, 138, 138, 138, 0, 0, 0, 138, 77,
! 0, 107, 107, 107, 107, 0, 0, 0, 107, 0,
! 107, 0, 0, 0, 0, 0, 0, 107, 0, 138,
! 138, 0, 138, 0, 0, 0, 0, 0, 0, 107,
! 107, 0, 107, 107, 107, 107, 107, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 109, 109, 109, 109,
! 0, 0, 0, 109, 0, 109, 110, 110, 110, 110,
! 0, 0, 0, 110, 0, 110, 0, 0, 0, 0,
! 0, 0, 0, 0, 109, 109, 0, 109, 109, 109,
! 109, 109, 0, 0, 110, 110, 0, 110, 110, 110,
! 110, 0, 112, 112, 112, 112, 0, 0, 0, 112,
! 0, 112, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 112, 112, 0, 112, 112, 112, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 111, 111, 111, 111,
! 0, 0, 0, 111, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 111, 111, 0, 111, 77, 77,
! 77, 77, 0, 0, 0, 77, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 77, 77,
};
static short yycheck[] = { 15,
! 95, 36, 46, 41, 36, 40, 59, 59, 100, 208,
! 54, 41, 59, 199, 41, 40, 196, 257, 41, 93,
! 123, 44, 202, 36, 93, 59, 40, 40, 59, 29,
! 59, 40, 91, 49, 41, 58, 59, 41, 362, 131,
! 63, 257, 91, 41, 60, 61, 46, 47, 59, 94,
! 40, 15, 59, 53, 41, 40, 100, 41, 300, 301,
! 105, 59, 41, 59, 123, 65, 66, 67, 68, 393,
! 93, 40, 59, 41, 123, 41, 41, 91, 91, 123,
! 41, 45, 91, 44, 48, 40, 93, 131, 40, 123,
! 41, 123, 123, 59, 123, 41, 295, 58, 59, 115,
! 116, 44, 63, 106, 107, 108, 109, 110, 111, 123,
! 123, 40, 123, 59, 123, 40, 116, 133, 0, 59,
! 36, 37, 257, 59, 40, 89, 59, 278, 314, 59,
! 123, 41, 93, 266, 267, 268, 40, 270, 271, 338,
! 104, 157, 158, 159, 160, 161, 162, 163, 64, 59,
! 59, 33, 276, 277, 36, 37, 38, 41, 40, 44,
! 42, 43, 260, 45, 297, 181, 182, 183, 184, 185,
! 186, 187, 188, 189, 123, 59, 41, 59, 0, 41,
! 272, 257, 64, 199, 383, 40, 278, 203, 204, 40,
! 206, 155, 208, 41, 59, 298, 40, 59, 93, 215,
! 93, 217, 218, 8, 9, 257, 209, 125, 298, 91,
! 226, 33, 317, 91, 36, 37, 38, 93, 40, 93,
! 42, 43, 36, 45, 257, 257, 300, 301, 272, 41,
! 262, 300, 301, 298, 278, 125, 252, 59, 254, 255,
! 260, 123, 64, 125, 126, 258, 0, 300, 301, 272,
! 273, 274, 275, 300, 301, 91, 279, 40, 281, 93,
! 301, 296, 300, 301, 298, 272, 273, 274, 275, 91,
! 300, 301, 279, 300, 301, 370, 41, 300, 301, 33,
! 303, 304, 36, 37, 38, 260, 40, 40, 42, 43,
! 41, 45, 308, 300, 301, 41, 300, 301, 314, 41,
! 41, 123, 41, 125, 126, 59, 125, 271, 125, 273,
! 64, 272, 273, 274, 275, 279, 300, 301, 279, 59,
! 281, 300, 301, 125, 340, 125, 287, 288, 289, 290,
! 59, 41, 300, 301, 44, 300, 301, 91, 123, 300,
! 301, 41, 303, 304, 305, 306, 307, 308, 309, 300,
! 301, 312, 125, 63, 315, 316, 317, 300, 301, 41,
! 300, 301, 41, 379, 300, 301, 59, 300, 301, 123,
! 300, 301, 126, 40, 256, 257, 258, 259, 260, 261,
! 41, 263, 264, 265, 266, 267, 268, 269, 270, 271,
! 272, 273, 274, 275, 41, 41, 123, 279, 280, 41,
! 282, 283, 284, 285, 286, 300, 301, 300, 301, 291,
! 292, 293, 294, 295, 296, 297, 63, 123, 312, 41,
! 302, 315, 316, 317, 300, 301, 300, 301, 59, 311,
! 41, 313, 314, 59, 256, 257, 258, 259, 260, 261,
! 41, 263, 264, 265, 266, 267, 268, 269, 270, 271,
! 272, 273, 274, 275, 59, 41, 289, 279, 280, 35,
! 282, 283, 284, 285, 286, 52, 300, 301, 52, 291,
! 292, 293, 294, 295, 296, 297, 309, 15, 158, 312,
! 302, 379, 315, 316, 317, 206, 340, 24, -1, 311,
! -1, 313, 314, 309, 273, 41, 312, -1, 44, 315,
! 316, 317, 256, 257, 258, 259, 260, 261, -1, 263,
! 264, 265, 58, 59, -1, 269, -1, 63, 272, 273,
! 274, 275, -1, 289, 290, 279, 280, -1, 282, 283,
! 284, 285, 286, -1, -1, 125, -1, 291, 292, 293,
! 294, 295, 296, 309, -1, -1, 312, 93, 302, 315,
! 316, 317, -1, -1, -1, -1, -1, 311, 33, 313,
! 314, 36, 37, 38, -1, 40, 41, 42, 43, 44,
! 45, 281, -1, 125, -1, -1, -1, 287, 288, 289,
! 290, -1, -1, 58, 59, -1, -1, -1, 63, 64,
! -1, -1, -1, 303, 304, 305, 306, 307, 308, 309,
! -1, -1, 312, -1, -1, 315, 316, 317, 272, 273,
! 274, 275, -1, -1, -1, 279, 91, -1, 93, 33,
! -1, -1, 36, 37, 38, -1, 40, 41, 42, 43,
! 44, 45, -1, -1, 281, -1, 300, 301, -1, -1,
! 287, 288, 289, 290, 58, 59, -1, -1, -1, 63,
! 64, 126, -1, -1, -1, -1, 303, 304, 305, 306,
! 307, 308, 309, -1, -1, 312, -1, -1, 315, 316,
! 317, -1, -1, -1, -1, -1, 266, 267, 268, 93,
! 270, 271, 33, 289, 290, 36, 37, 38, -1, 40,
! -1, 42, 43, -1, 45, -1, 359, 360, -1, -1,
! -1, 364, 308, 309, -1, -1, 312, 297, 59, 315,
! 316, 317, 126, 64, 266, 267, 268, 380, 270, 271,
! -1, 384, -1, -1, -1, -1, 272, 273, 274, 275,
! -1, -1, -1, 279, -1, 281, -1, -1, -1, -1,
! 91, 287, 288, 289, 290, 297, -1, -1, -1, -1,
! -1, -1, -1, -1, 300, 301, -1, 303, 304, 305,
306, 307, 308, 309, -1, -1, 312, -1, -1, 315,
! 316, 317, 123, -1, -1, 126, -1, -1, -1, -1,
! -1, -1, 257, 258, 259, 260, 261, -1, 263, 264,
265, -1, -1, -1, 269, -1, -1, 272, 273, 274,
! 275, -1, -1, -1, 279, 280, 281, 282, 283, 284,
! 285, 286, 287, 288, 289, 290, 291, 292, 293, 294,
! 295, 296, -1, -1, -1, 300, 301, 302, 303, 304,
! 305, 306, 307, 308, 309, -1, 311, 312, 313, 314,
! 315, 316, 317, 257, 258, 259, 260, 261, -1, 263,
! 264, 265, -1, -1, -1, 269, -1, -1, 272, 273,
! 274, 275, -1, -1, -1, 279, 280, 281, 282, 283,
! 284, 285, 286, 287, 288, 289, 290, 291, 292, 293,
! 294, 295, 296, -1, -1, -1, 300, 301, 302, 303,
! 304, 305, 306, 307, 308, 309, -1, 311, 312, 313,
! 314, 315, 316, 317, -1, 256, 257, 258, 259, 260,
! 261, 63, 263, 264, 265, -1, -1, -1, 269, -1,
! -1, 272, 273, 274, 275, -1, -1, -1, 279, 280,
! -1, 282, 283, 284, 285, 286, -1, -1, -1, -1,
! 291, 292, 293, 294, 295, 296, -1, -1, -1, 33,
! -1, 302, 36, 37, 38, -1, 40, -1, 42, 43,
! 311, 45, 313, 314, -1, -1, -1, -1, 335, 336,
! 337, -1, 339, -1, -1, 59, -1, -1, -1, -1,
! 64, -1, -1, 41, -1, -1, 44, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, 366,
! 58, 59, -1, -1, -1, -1, 373, 91, -1, 33,
! 377, -1, 36, 37, 38, -1, 40, -1, 42, 43,
! -1, 45, -1, 390, 391, -1, 28, 29, -1, -1,
! -1, -1, -1, -1, -1, 93, -1, -1, 40, 123,
! 64, -1, 126, -1, 46, 47, 48, -1, -1, 33,
! 52, 53, 36, 37, 38, -1, 40, -1, 42, 43,
! -1, 45, -1, 65, 66, 67, 68, 91, 287, 288,
! 289, 290, -1, -1, -1, -1, -1, -1, -1, -1,
! 64, -1, -1, -1, -1, -1, -1, -1, 41, 308,
! 309, 44, -1, 312, -1, -1, 315, 316, 317, 123,
! -1, -1, 126, -1, -1, 58, 59, 91, -1, -1,
! 63, -1, -1, 33, 116, -1, 36, 37, 38, -1,
! 40, -1, 42, 43, -1, 45, -1, -1, -1, 281,
! -1, -1, -1, -1, -1, 287, 288, 289, 290, 123,
! 93, -1, 126, -1, 64, -1, -1, -1, -1, -1,
! -1, 303, 304, 305, 306, 307, 308, 309, -1, -1,
! 312, -1, -1, 315, 316, 317, -1, -1, -1, -1,
! -1, 91, 256, 257, 258, 259, 260, 261, 180, 263,
! 264, 265, -1, -1, -1, 269, -1, -1, 272, 273,
! 274, 275, -1, -1, -1, 279, 280, -1, 282, 283,
! 284, 285, 286, 123, -1, 207, 126, 291, 292, 293,
! 294, 295, 296, -1, 272, 273, 274, 275, 302, -1,
! -1, 279, -1, -1, -1, -1, -1, 311, -1, 313,
! 314, -1, -1, 257, 258, 259, 260, 261, 262, 263,
! 264, 265, 300, 301, -1, 269, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 280, -1, 282, 283,
284, 285, 286, -1, -1, -1, -1, 291, 292, 293,
! 294, 295, 296, 257, 258, 259, 260, 261, 302, 263,
! 264, 265, -1, -1, -1, 269, -1, 311, -1, 313,
! 314, -1, 58, -1, -1, -1, 280, 63, 282, 283,
! 284, 285, 286, -1, -1, -1, -1, 291, 292, 293,
! 294, 295, 296, -1, -1, -1, -1, -1, 302, 272,
! 273, 274, 275, -1, -1, -1, 279, 311, 281, 313,
! 314, -1, -1, -1, 287, 288, -1, 257, 258, 259,
! 260, 261, -1, 263, 264, 265, -1, 300, 301, 269,
! 303, 304, 305, 306, 307, 308, -1, -1, -1, -1,
! 280, -1, 282, 283, 284, 285, 286, -1, -1, -1,
! -1, 291, 292, 293, 294, 295, 296, -1, -1, -1,
! 33, -1, 302, 36, 37, 38, -1, 40, -1, 42,
! 43, 311, 45, 313, 314, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 59, -1, -1, -1,
! -1, 64, -1, -1, -1, 287, 288, 289, 290, -1,
! 33, -1, -1, 36, 37, 38, -1, 40, 41, 42,
! 43, -1, 45, 305, 306, 307, 308, 309, 91, -1,
! 312, -1, -1, 315, 316, 317, -1, -1, -1, -1,
! -1, 64, -1, -1, -1, 287, 288, 289, 290, -1,
! 33, -1, -1, 36, 37, 38, -1, 40, -1, 42,
! 43, -1, 45, 126, 306, 307, 308, 309, 91, -1,
! 312, -1, -1, 315, 316, 317, -1, -1, -1, -1,
! -1, 64, -1, -1, -1, -1, -1, -1, -1, -1,
! 33, -1, -1, 36, 37, 38, -1, 40, 41, 42,
! 43, -1, 45, 126, -1, 281, -1, -1, 91, -1,
! 93, 287, 288, 289, 290, -1, -1, -1, -1, -1,
! -1, 64, -1, -1, -1, -1, -1, 303, 304, 305,
! 306, 307, 308, 309, -1, -1, 312, -1, -1, 315,
! 316, 317, -1, 126, 287, 288, 289, 290, 91, -1,
! 33, -1, -1, 36, 37, 38, -1, 40, 41, 42,
! 43, -1, 45, -1, 307, 308, 309, -1, -1, 312,
! -1, -1, 315, 316, 317, -1, -1, -1, -1, -1,
! -1, 64, 287, 126, 289, 290, -1, -1, -1, -1,
! -1, -1, -1, -1, 257, 258, 259, 260, 261, -1,
! 263, 264, 265, 308, 309, -1, 269, 312, 91, -1,
! 315, 316, 317, -1, -1, -1, -1, 280, -1, 282,
! 283, 284, 285, 286, -1, -1, -1, -1, 291, 292,
! 293, 294, 295, 296, 257, 258, 259, 260, 261, 302,
! 263, 264, 265, 126, -1, -1, 269, -1, 311, -1,
! 313, 314, -1, -1, -1, -1, -1, 280, -1, 282,
! 283, 284, 285, 286, -1, -1, -1, -1, 291, 292,
! 293, 294, 295, 296, 257, 258, 259, 260, 261, 302,
! 263, 264, 265, -1, -1, -1, 269, -1, 311, -1,
! 313, 314, -1, -1, -1, -1, -1, 280, -1, 282,
! 283, 284, 285, 286, -1, -1, -1, -1, 291, 292,
! 293, 294, 295, 296, 257, 258, 259, 260, 261, 302,
! 263, 264, 265, -1, -1, -1, 269, -1, 311, -1,
! 313, 314, -1, -1, -1, -1, -1, 280, -1, 282,
! 283, 284, 285, 286, -1, -1, -1, -1, 291, 292,
! 293, 294, 295, 296, -1, -1, -1, 33, -1, 302,
! 36, 37, 38, -1, 40, 41, 42, 43, 311, 45,
! 313, 314, -1, -1, 257, 258, 259, 260, 261, -1,
! 263, 264, 265, -1, -1, -1, 269, -1, 64, -1,
! -1, -1, -1, -1, -1, -1, -1, 280, -1, 282,
! 283, 284, 285, 286, -1, -1, -1, -1, 291, 292,
! 293, 294, 295, 296, -1, 91, -1, 33, -1, 302,
! 36, 37, 38, -1, 40, 41, 42, 43, 311, 45,
! 313, 314, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 64, -1,
! 126, -1, -1, -1, -1, -1, 41, -1, -1, 44,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, 58, 59, 91, 33, -1, 63, 36,
! 37, 38, -1, 40, -1, 42, 43, -1, 45, -1,
! -1, -1, -1, -1, 287, 288, 289, 290, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 64, 93, -1,
! 126, 304, 305, 306, 307, 308, 309, -1, -1, 312,
! -1, -1, 315, 316, 317, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 91, -1, 33, -1, -1, 36,
37, 38, -1, 40, 41, 42, 43, -1, 45, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, 64, -1, 126,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 257, 258, 259, 260, 261, -1, 263, 264, 265,
! -1, -1, -1, 269, 91, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 280, -1, 282, 283, 284, 285,
! 286, -1, -1, -1, -1, 291, 292, 293, 294, 295,
! 296, 41, -1, -1, 44, -1, 302, -1, -1, 126,
! -1, -1, -1, -1, -1, 311, -1, 313, 314, 59,
! -1, 257, 258, 259, 260, 261, -1, 263, 264, 265,
! -1, 33, -1, 269, 36, 37, 38, -1, 40, 41,
! 42, 43, -1, 45, 280, -1, 282, 283, 284, 285,
! 286, -1, -1, 93, -1, 291, 292, 293, 294, 295,
! 296, -1, 64, -1, -1, -1, 302, 272, 273, 274,
! 275, -1, -1, -1, 279, 311, 281, 313, 314, 256,
! 257, 258, 259, 260, 261, -1, 263, 264, 265, 91,
! -1, -1, 269, -1, -1, 300, 301, -1, 303, 304,
! 305, 306, 307, 280, -1, 282, 283, 284, 285, 286,
-1, -1, -1, -1, 291, 292, 293, 294, 295, 296,
! -1, -1, -1, 33, 126, 302, 36, 37, 38, -1,
40, 41, 42, 43, 311, 45, 313, 314, -1, -1,
257, 258, 259, 260, 261, -1, 263, 264, 265, -1,
-1, -1, 269, -1, 64, -1, -1, -1, -1, -1,
***************
*** 865,1130 ****
-1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
-1, -1, -1, -1, 291, 292, 293, 294, 295, 296,
-1, 91, -1, 33, -1, 302, 36, 37, 38, -1,
! 40, 41, 42, 43, 311, 45, 313, 314, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, 64, -1, 126, -1, -1, -1,
- -1, -1, 41, -1, -1, 44, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 58,
- 59, 91, 33, -1, 63, 36, 37, 38, -1, 40,
- -1, 42, 43, -1, 45, -1, -1, -1, -1, -1,
- 287, 288, 289, 290, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, 64, 93, -1, 126, 304, 305, 306,
- 307, 308, 309, -1, -1, 312, -1, -1, 315, 316,
- 317, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 91, -1, 33, -1, -1, 36, 37, 38, -1, 40,
- 41, 42, 43, -1, 45, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, 64, -1, 126, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, 257, 258, 259,
260, 261, -1, 263, 264, 265, -1, -1, -1, 269,
! 91, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 280, -1, 282, 283, 284, 285, 286, -1, -1, -1,
! -1, 291, 292, 293, 294, 295, 296, -1, -1, -1,
! -1, -1, 302, -1, -1, 126, -1, -1, -1, -1,
-1, 311, -1, 313, 314, -1, -1, 257, 258, 259,
! 260, 261, -1, 263, 264, 265, -1, 33, -1, 269,
! 36, 37, 38, -1, 40, 41, 42, 43, -1, 45,
280, -1, 282, 283, 284, 285, 286, -1, -1, -1,
! -1, 291, 292, 293, 294, 295, 296, -1, 64, -1,
! -1, -1, 302, 272, 273, 274, 275, -1, -1, -1,
! 279, 311, 281, 313, 314, 256, 257, 258, 259, 260,
! 261, -1, 263, 264, 265, 91, -1, -1, 269, -1,
! -1, 300, 301, -1, 303, 304, 305, 306, 307, 280,
! -1, 282, 283, 284, 285, 286, -1, -1, -1, -1,
! 291, 292, 293, 294, 295, 296, -1, -1, -1, 33,
! 126, 302, 36, 37, 38, -1, 40, 41, 42, 43,
! 311, 45, 313, 314, -1, -1, 257, 258, 259, 260,
! 261, -1, 263, 264, 265, -1, -1, -1, 269, -1,
! 64, -1, -1, -1, -1, -1, -1, -1, -1, 280,
! -1, 282, 283, 284, 285, 286, -1, -1, -1, -1,
! 291, 292, 293, 294, 295, 296, -1, 91, -1, 33,
! -1, 302, 36, 37, 38, -1, 40, -1, 42, 43,
! 311, 45, 313, 314, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 28, 29,
! 64, -1, 126, -1, -1, -1, -1, -1, 41, -1,
! 40, 44, -1, -1, -1, -1, 46, 47, 48, -1,
! -1, -1, 52, 53, -1, 58, 59, 91, -1, -1,
! 63, -1, -1, -1, -1, 65, 66, 67, 68, -1,
! -1, 257, 258, 259, 260, 261, -1, 263, 264, 265,
! -1, -1, -1, 269, -1, 41, -1, -1, 44, -1,
! 93, -1, 126, -1, 280, -1, 282, 283, 284, 285,
! 286, 41, -1, 59, 44, 291, 292, 293, 294, 295,
! 296, -1, 112, -1, -1, -1, 302, -1, 58, 59,
! -1, -1, -1, 63, -1, 311, -1, 313, 314, -1,
! -1, -1, -1, -1, -1, -1, -1, 93, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, 93, -1, 41, -1, -1, 44, -1,
! -1, -1, -1, 257, 258, 259, 260, 261, -1, 263,
! 264, 265, 58, 59, -1, 269, 176, 63, -1, -1,
! -1, -1, -1, -1, -1, -1, 280, -1, 282, 283,
! 284, 285, 286, -1, -1, -1, -1, 291, 292, 293,
! 294, 295, 296, 203, -1, -1, -1, 93, 302, -1,
! -1, -1, -1, -1, -1, 41, -1, 311, 44, 313,
! 314, -1, -1, 257, 258, 259, 260, 261, -1, 263,
! 264, 265, 58, 59, -1, 269, -1, 63, -1, -1,
! -1, -1, -1, -1, -1, -1, 280, -1, 282, 283,
! 284, 285, 286, -1, -1, -1, -1, 291, 292, 293,
! 294, 295, 296, -1, -1, -1, -1, 93, 302, 272,
! 273, 274, 275, -1, -1, -1, 279, 311, 281, 313,
! 314, -1, -1, -1, 287, 288, 289, 290, -1, -1,
! -1, -1, -1, 41, -1, -1, 44, 300, 301, -1,
! 303, 304, 305, 306, 307, 308, 309, -1, -1, 312,
! 58, 59, 315, 316, 317, 63, 272, 273, 274, 275,
! -1, -1, -1, 279, -1, -1, -1, -1, -1, -1,
! -1, -1, 272, 273, 274, 275, -1, -1, -1, 279,
! 41, 281, -1, 44, 300, 93, -1, 287, 288, 289,
! 290, -1, -1, -1, -1, -1, -1, 58, 59, -1,
! 300, 301, 63, 303, 304, 305, 306, 307, 308, 309,
! -1, -1, 312, -1, -1, 315, 316, 317, -1, -1,
! -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
! -1, 41, 93, 279, 44, 281, -1, -1, -1, -1,
! -1, 287, 288, 289, 290, -1, -1, -1, 58, 59,
! -1, -1, -1, 63, 300, 301, -1, 303, 304, 305,
306, 307, 308, 309, -1, -1, 312, -1, -1, 315,
316, 317, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, 41, 93, -1, 44, 272, 273, 274, 275,
! -1, 41, -1, 279, 44, 281, -1, -1, -1, 58,
! 59, 287, 288, 289, 290, -1, -1, -1, 58, 59,
! -1, -1, -1, 63, 300, 301, -1, 303, 304, 305,
! 306, 307, 308, 309, -1, -1, 312, -1, -1, 315,
! 316, 317, -1, -1, 93, -1, -1, 41, -1, -1,
! 44, -1, -1, 93, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 58, 59, -1, -1, -1, 63,
-1, -1, -1, -1, 272, 273, 274, 275, -1, -1,
-1, 279, -1, 281, -1, -1, -1, -1, -1, 287,
! 288, 289, 290, -1, -1, -1, -1, -1, -1, 93,
! -1, -1, 300, 301, -1, 303, 304, 305, 306, 307,
! 308, 309, -1, -1, 312, -1, -1, 315, 316, 317,
! -1, 272, 273, 274, 275, -1, 41, -1, 279, 44,
! 281, -1, -1, -1, -1, -1, 287, 288, 289, 290,
! -1, -1, -1, 58, 59, -1, -1, -1, 63, 300,
! 301, -1, 303, 304, 305, 306, 307, 308, 309, -1,
! -1, 312, -1, -1, 315, 316, 317, -1, -1, -1,
! -1, -1, 272, 273, 274, 275, -1, 41, 93, 279,
! 44, 281, -1, -1, -1, -1, -1, 287, 288, 289,
! 290, -1, -1, -1, 58, 59, -1, -1, -1, 63,
300, 301, -1, 303, 304, 305, 306, 307, 308, 309,
! -1, -1, 312, -1, -1, 315, 316, 317, -1, -1,
! -1, -1, -1, 272, 273, 274, 275, -1, -1, 93,
! 279, -1, 272, 273, 274, 275, -1, 41, -1, 279,
! 44, 281, -1, -1, -1, -1, -1, 287, 288, 289,
! 290, 300, 301, -1, 58, 59, -1, -1, -1, 63,
! 300, 301, -1, 303, 304, 305, 306, 307, 308, 309,
! -1, -1, 312, -1, -1, 315, 316, 317, 272, 273,
! 274, 275, -1, 41, -1, 279, 44, 281, -1, 93,
! -1, -1, -1, 287, 288, 289, 290, -1, -1, -1,
! 58, 59, -1, -1, -1, 63, 300, 301, -1, 303,
! 304, 305, 306, 307, 308, 309, -1, -1, 312, -1,
! -1, 315, 316, 317, -1, -1, -1, -1, -1, 41,
! -1, -1, 44, -1, -1, 93, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 58, 59, -1, -1,
! -1, 63, 41, -1, -1, 44, -1, 272, 273, 274,
! 275, -1, -1, -1, 279, -1, 281, -1, -1, 58,
! 59, -1, 287, 288, 289, 290, -1, -1, -1, -1,
! -1, 93, -1, -1, -1, 300, 301, -1, 303, 304,
! 305, 306, 307, 308, 309, -1, -1, 312, -1, -1,
! 315, 316, 317, 41, 93, -1, 44, -1, 272, 273,
! 274, 275, 41, -1, -1, 279, -1, 281, -1, -1,
! 58, 59, -1, 287, 288, 289, 290, -1, -1, 58,
! 59, -1, -1, -1, 63, -1, 300, 301, -1, 303,
! 304, 305, 306, 307, 308, 309, -1, -1, 312, -1,
! -1, 315, 316, 317, -1, 93, -1, -1, -1, -1,
! -1, -1, -1, -1, 93, -1, -1, -1, 272, 273,
! 274, 275, 41, -1, -1, 279, -1, 281, -1, -1,
! -1, -1, -1, 287, 288, 289, 290, -1, -1, 58,
! 59, -1, -1, -1, 63, -1, 300, 301, -1, 303,
! 304, 305, 306, 307, 308, 309, -1, -1, 312, -1,
! -1, 315, 316, 317, 272, 273, 274, 275, 41, -1,
! -1, 279, -1, 281, 93, -1, -1, -1, -1, 287,
! 288, 289, 290, -1, -1, 58, 59, -1, -1, -1,
! 63, -1, 300, 301, -1, 303, 304, 305, 306, 307,
! 308, 309, -1, -1, 312, -1, -1, 315, 316, 317,
! 272, 273, 274, 275, -1, -1, -1, 279, -1, 281,
! 93, -1, -1, -1, -1, 287, 288, 289, 290, -1,
! -1, -1, -1, 272, 273, 274, 275, -1, 300, 301,
! 279, 303, 304, 305, 306, 307, 308, 309, -1, 41,
! 312, -1, 44, 315, 316, 317, -1, -1, -1, -1,
! -1, 300, 301, -1, 303, -1, 58, 59, -1, -1,
! -1, 63, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 272, 273, 274, 275, -1, -1,
! -1, 279, -1, 272, 273, 274, 275, -1, -1, -1,
! 279, 93, 281, -1, -1, -1, -1, -1, 287, 288,
! 289, 290, 300, 301, -1, -1, -1, -1, -1, -1,
! -1, 300, 301, -1, 303, 304, 305, 306, 307, 308,
! 309, -1, -1, 312, -1, -1, 315, 316, 317, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, 272, 273, 274, 275, -1, -1, -1,
- 279, 41, 281, -1, 44, -1, -1, -1, 287, 288,
- 289, 290, -1, -1, -1, -1, -1, -1, 58, 59,
- -1, 300, 301, 63, 303, 304, 305, 306, 307, 308,
- 309, -1, -1, 312, -1, -1, 315, 316, 317, 272,
- 273, 274, 275, -1, 41, -1, 279, 44, 281, -1,
- -1, -1, -1, 93, 287, 288, 289, 290, -1, -1,
- -1, 58, 59, -1, -1, -1, 63, 300, 301, -1,
- 303, 304, 305, 306, 307, 308, 309, 33, -1, 312,
- -1, -1, 315, 316, 317, 41, -1, -1, 41, 45,
- -1, 44, 48, -1, -1, 51, 93, -1, -1, 55,
- 56, 57, 58, 59, -1, 58, 59, 63, 64, -1,
- 63, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 272, 273, 274, 275, -1, -1, -1, 279, 41, 281,
- -1, 44, -1, -1, -1, 287, 288, 289, 290, -1,
- 93, -1, 98, -1, -1, 58, 59, -1, 300, 301,
- 63, 303, 304, 305, 306, 307, 308, 309, -1, -1,
- 312, -1, -1, -1, -1, -1, 41, -1, -1, 44,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 93, -1, -1, 58, 59, -1, -1, -1, 63, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 160, 161, 162, 163, 164, 165,
! 166, 167, 168, 169, 170, 171, 172, 173, 93, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 187, 272, 273, 274, 275, -1, 41, -1, 279,
44, 281, -1, -1, -1, -1, -1, 287, 288, 289,
! 290, -1, -1, -1, 58, 59, -1, -1, -1, 63,
300, 301, -1, 303, 304, 305, 306, 307, 308, 309,
! -1, -1, 312, -1, -1, 272, 273, 274, 275, -1,
! 41, -1, 279, 44, 281, -1, -1, -1, -1, 93,
! 287, 288, 289, 290, -1, -1, -1, 58, 59, -1,
! -1, -1, 63, 300, 301, -1, 303, 304, 305, 306,
! 307, 308, 309, -1, -1, -1, 272, -1, -1, 272,
! 273, 274, 275, -1, -1, -1, 279, 41, 281, -1,
! 44, -1, 93, -1, 287, 288, 289, 290, -1, -1,
! -1, -1, -1, -1, 58, 59, -1, 300, 301, 305,
! 303, 304, 305, 306, 307, 308, 309, -1, -1, 272,
! 273, 274, 275, -1, 41, -1, 279, 44, 281, -1,
! -1, -1, -1, -1, 287, 288, 289, 290, -1, 93,
! -1, 58, 59, -1, -1, -1, 63, 300, 301, -1,
! 303, 304, 305, 306, 307, 308, 309, 272, 273, 274,
! 275, -1, 41, -1, 279, 44, 281, -1, -1, -1,
! -1, -1, 287, 288, 289, 290, 93, -1, -1, 58,
! 59, -1, -1, -1, 63, 300, 301, -1, 303, 304,
! 305, 306, 307, 308, 309, -1, -1, -1, -1, 41,
! -1, -1, 44, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 93, -1, 58, 59, -1, -1,
! -1, 63, -1, -1, -1, -1, -1, -1, 272, 273,
! 274, 275, -1, -1, -1, 279, -1, 281, -1, -1,
! -1, -1, -1, 287, 288, 289, 290, 58, -1, -1,
! -1, 93, 63, -1, -1, -1, 300, 301, -1, 303,
! 304, 305, 306, 307, 308, 309, -1, -1, -1, -1,
! -1, 272, 273, 274, 275, -1, 41, -1, 279, 44,
! 281, -1, -1, -1, -1, -1, 287, 288, 289, 290,
! -1, -1, -1, 58, 59, -1, -1, -1, 63, 300,
! 301, -1, 303, 304, 305, 306, 307, 308, 309, -1,
! -1, -1, -1, 41, -1, -1, 44, -1, 272, 273,
! 274, 275, -1, 41, -1, 279, 44, -1, 93, -1,
! 58, 59, -1, -1, -1, 63, -1, -1, -1, -1,
! 58, 59, -1, -1, -1, 63, 300, 301, -1, -1,
! -1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
! 41, -1, 279, 44, 281, 93, -1, -1, -1, -1,
! 287, 288, 289, 290, -1, 93, -1, 58, 59, -1,
! -1, -1, 63, 300, 301, -1, 303, 304, 305, 306,
! 307, 308, 309, 272, 273, 274, 275, -1, 41, -1,
279, 44, 281, -1, -1, -1, -1, -1, 287, 288,
! 289, 290, 93, -1, -1, 58, 59, -1, -1, -1,
63, 300, 301, -1, 303, 304, 305, 306, 307, 308,
272, 273, 274, 275, -1, 41, -1, 279, 44, 281,
! -1, -1, -1, -1, -1, 287, 288, -1, 290, -1,
! 93, 41, 58, 59, 44, -1, -1, 63, 300, 301,
! -1, 303, 304, 305, 306, 307, 308, -1, 58, 59,
! 281, -1, -1, 63, -1, -1, 287, 288, 289, 290,
! -1, -1, -1, -1, -1, -1, -1, 93, -1, -1,
! -1, -1, 303, 304, 305, 306, 307, 308, 309, -1,
! -1, 312, -1, 93, 315, 316, 317, 272, 273, 274,
! 275, -1, 41, -1, 279, 44, 281, -1, -1, -1,
! -1, -1, 287, 288, -1, -1, -1, -1, -1, 58,
! 59, -1, -1, -1, 63, 300, 301, -1, 303, 304,
! 305, 306, 307, -1, 272, 273, 274, 275, -1, 41,
! -1, 279, 44, 281, 272, 273, 274, 275, -1, 287,
! 288, 279, -1, 281, 93, -1, 58, 59, -1, 287,
! 288, 63, 300, 301, -1, 303, 304, 305, 306, 307,
-1, -1, 300, 301, -1, 303, 304, 305, 306, 307,
-1, 272, 273, 274, 275, -1, -1, -1, 279, -1,
! 281, 93, -1, -1, -1, -1, 287, 288, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, 300,
! 301, -1, 303, 304, 305, 306, 307, -1, -1, 272,
! 273, 274, 275, -1, -1, -1, 279, -1, 281, -1,
! -1, -1, -1, -1, -1, 288, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 300, 301, -1,
! 303, 304, 305, 306, 307, -1, 272, 273, 274, 275,
-1, -1, -1, 279, -1, 281, -1, -1, -1, -1,
! -1, -1, 272, 273, 274, 275, -1, -1, -1, 279,
! -1, 281, -1, -1, 300, 301, -1, 303, 304, 305,
! 306, 307, -1, -1, -1, -1, -1, -1, -1, -1,
! 300, 301, -1, 303, 304, 305, 306, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, 272, 273, 274, 275, -1, -1, -1,
! 279, -1, 281, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 300, 301, -1, 303, 304, 305, -1, -1, -1,
! 272, 273, 274, 275, -1, -1, -1, 279, -1, 281,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 300, 301,
! -1, 303, 304,
};
#define YYFINAL 1
#ifndef YYDEBUG
--- 921,1161 ----
-1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
-1, -1, -1, -1, 291, 292, 293, 294, 295, 296,
-1, 91, -1, 33, -1, 302, 36, 37, 38, -1,
! 40, -1, 42, 43, 311, 45, 313, 314, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, 64, -1, 126, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, 272, 273, 274, 275, -1, -1, -1, 279,
! -1, 91, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, 257, 258, 259, 260, 261,
! 300, 263, 264, 265, -1, -1, -1, 269, -1, -1,
! -1, -1, -1, -1, -1, -1, 126, -1, 280, -1,
! 282, 283, 284, 285, 286, -1, 41, -1, -1, 291,
! 292, 293, 294, 295, 296, -1, -1, -1, -1, -1,
! 302, -1, -1, 58, 59, -1, -1, -1, 63, 311,
! -1, 313, 314, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 93, -1,
-1, -1, -1, -1, -1, -1, -1, 257, 258, 259,
260, 261, -1, 263, 264, 265, -1, -1, -1, 269,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 280, -1, 282, 283, 284, 285, 286, 41, -1, -1,
! 44, 291, 292, 293, 294, 295, 296, -1, -1, -1,
! -1, -1, 302, -1, 58, 59, -1, -1, -1, 63,
-1, 311, -1, 313, 314, -1, -1, 257, 258, 259,
! 260, 261, -1, 263, 264, 265, -1, -1, -1, 269,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, 93,
280, -1, 282, 283, 284, 285, 286, -1, -1, -1,
! -1, 291, 292, 293, 294, 295, 296, 33, -1, -1,
! 63, -1, 302, -1, -1, 41, -1, -1, -1, 45,
! -1, 311, 48, 313, 314, 51, -1, -1, -1, 55,
! 56, 57, 58, 59, -1, -1, -1, 63, 64, 41,
! -1, -1, 44, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 58, 59, -1, -1,
! -1, 63, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 102, 272, 273, 274,
! 275, -1, -1, -1, 279, 41, 281, -1, 44, -1,
! -1, 93, 287, 288, 289, 290, -1, -1, -1, -1,
! -1, -1, 58, 59, -1, 300, 301, 63, 303, 304,
! 305, 306, 307, 308, 309, -1, -1, 312, -1, -1,
! 315, 316, 317, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 93, 164, 165,
! 166, 167, 168, 169, 170, 171, 172, 173, 174, 175,
! 176, 177, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, 191, -1, -1, 272, 273,
! 274, 275, -1, 41, -1, 279, 44, 281, -1, -1,
! -1, -1, -1, 287, 288, 289, 290, -1, -1, -1,
! 58, 59, -1, -1, -1, 63, 300, 301, -1, 303,
! 304, 305, 306, 307, 308, 309, -1, -1, 312, -1,
! -1, 315, 316, 317, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, 41, -1, 93, 44, -1, 281, -1,
! -1, -1, -1, -1, 287, 288, 289, 290, -1, -1,
! 58, 59, -1, -1, -1, 63, -1, -1, -1, -1,
! 276, 304, 305, 306, 307, 308, 309, -1, -1, 312,
! -1, -1, 315, 316, 317, -1, -1, -1, -1, -1,
! 272, 273, 274, 275, -1, 93, -1, 279, 41, 281,
! -1, 44, -1, 309, -1, 287, 288, 289, 290, -1,
! -1, -1, -1, -1, -1, 58, 59, -1, 300, 301,
! 63, 303, 304, 305, 306, 307, 308, 309, -1, -1,
! 312, -1, -1, 315, 316, 317, 272, 273, 274, 275,
! -1, -1, -1, 279, 41, 281, -1, 44, -1, -1,
! 93, 287, 288, 289, 290, -1, -1, -1, -1, -1,
! -1, 58, 59, -1, 300, 301, 63, 303, 304, 305,
306, 307, 308, 309, -1, -1, 312, -1, -1, 315,
316, 317, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 41, -1, -1, 44, -1, 93, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 58, 59,
! -1, -1, -1, 63, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, 272, 273, 274, 275, -1, -1,
-1, 279, -1, 281, -1, -1, -1, -1, -1, 287,
! 288, 289, 290, 93, -1, -1, -1, -1, 41, -1,
! -1, 44, 300, 301, -1, 303, 304, 305, 306, 307,
! 308, 309, -1, -1, 312, 58, 59, 315, 316, 317,
! 63, -1, -1, -1, 272, 273, 274, 275, -1, -1,
! -1, 279, -1, 281, -1, -1, -1, -1, -1, 287,
! 288, 289, 290, -1, -1, -1, -1, -1, 41, -1,
! 93, 44, 300, 301, -1, 303, 304, 305, 306, 307,
! 308, 309, -1, -1, 312, 58, 59, 315, 316, 317,
! 63, -1, -1, -1, -1, -1, -1, -1, -1, 272,
! 273, 274, 275, -1, -1, -1, 279, -1, 281, -1,
! -1, -1, -1, -1, 287, 288, 289, 290, -1, -1,
! 93, -1, -1, -1, -1, -1, -1, 300, 301, -1,
! 303, 304, 305, 306, 307, 308, 309, -1, -1, 312,
! -1, -1, 315, 316, 317, 272, 273, 274, 275, -1,
! 41, -1, 279, 44, 281, -1, -1, -1, -1, -1,
! 287, 288, 289, 290, -1, -1, -1, 58, 59, -1,
! -1, -1, 63, 300, 301, -1, 303, 304, 305, 306,
! 307, 308, 309, -1, -1, 312, -1, -1, 315, 316,
! 317, -1, 272, 273, 274, 275, -1, -1, -1, 279,
! -1, 281, 93, -1, -1, -1, -1, 287, 288, 289,
! 290, -1, -1, -1, -1, -1, 41, -1, -1, 44,
300, 301, -1, 303, 304, 305, 306, 307, 308, 309,
! -1, -1, 312, 58, 59, 315, 316, 317, 63, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, 272,
! 273, 274, 275, -1, -1, -1, 279, -1, 281, -1,
! -1, -1, -1, -1, 287, 288, 289, 290, 93, -1,
! -1, -1, -1, 41, -1, -1, 44, 300, 301, -1,
! 303, 304, 305, 306, 307, 308, 309, -1, -1, 312,
! 58, 59, 315, 316, 317, 63, -1, -1, -1, 272,
! 273, 274, 275, -1, -1, -1, 279, -1, 281, -1,
! -1, -1, -1, -1, 287, 288, 289, 290, -1, -1,
! -1, -1, -1, 41, -1, 93, 44, 300, 301, -1,
! 303, 304, 305, 306, 307, 308, 309, -1, -1, 312,
! 58, 59, 315, 316, 317, 63, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, 93, 41, -1, -1, 44,
! -1, 272, 273, 274, 275, 41, -1, -1, 279, -1,
! 281, -1, -1, 58, 59, -1, 287, 288, 289, 290,
! -1, -1, 58, 59, -1, -1, -1, 63, -1, 300,
! 301, -1, 303, 304, 305, 306, 307, 308, 309, -1,
! -1, 312, -1, -1, 315, 316, 317, -1, 93, -1,
! -1, -1, -1, -1, -1, -1, -1, 93, -1, -1,
! -1, -1, -1, 41, -1, -1, 44, 272, 273, 274,
! 275, 41, -1, -1, 279, -1, 281, -1, -1, -1,
! 58, 59, 287, 288, 289, 290, -1, -1, 58, 59,
! -1, -1, -1, 63, -1, 300, 301, -1, 303, 304,
! 305, 306, 307, 308, 309, -1, -1, 312, -1, -1,
! 315, 316, 317, -1, -1, 93, -1, -1, -1, -1,
! -1, -1, -1, 93, 272, 273, 274, 275, -1, -1,
! -1, 279, 41, 281, -1, 44, -1, -1, -1, 287,
! 288, 289, 290, -1, -1, -1, -1, -1, -1, 58,
! 59, -1, 300, 301, 63, 303, 304, 305, 306, 307,
! 308, 309, -1, -1, 312, -1, -1, 315, 316, 317,
! -1, -1, -1, -1, 272, 273, 274, 275, -1, 41,
! -1, 279, 44, 281, 93, -1, -1, -1, -1, 287,
! 288, 289, 290, -1, -1, -1, 58, 59, -1, -1,
! -1, 63, 300, 301, -1, 303, 304, 305, 306, 307,
! 308, 309, -1, -1, 312, -1, -1, 315, 316, 317,
! -1, -1, -1, -1, -1, -1, -1, 272, 273, 274,
! 275, 93, -1, -1, 279, -1, 272, 273, 274, 275,
! -1, 41, -1, 279, 44, 281, -1, -1, -1, -1,
! -1, 287, 288, 289, 290, 300, 301, -1, 58, 59,
! -1, -1, -1, 63, 300, 301, -1, 303, 304, 305,
! 306, 307, 308, 309, -1, -1, 312, -1, -1, 315,
! 316, 317, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, 93, 272, 273, 274, 275, -1, -1,
! -1, 279, 272, 273, 274, 275, -1, 41, -1, 279,
44, 281, -1, -1, -1, -1, -1, 287, 288, 289,
! 290, -1, 300, 301, 58, 59, -1, -1, -1, 63,
300, 301, -1, 303, 304, 305, 306, 307, 308, 309,
! -1, -1, 312, -1, -1, 315, 316, 317, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, 93,
! -1, -1, -1, 272, 273, 274, 275, -1, 41, -1,
279, 44, 281, -1, -1, -1, -1, -1, 287, 288,
! 289, 290, -1, -1, -1, 58, 59, -1, -1, -1,
63, 300, 301, -1, 303, 304, 305, 306, 307, 308,
+ 309, -1, -1, 312, -1, -1, -1, -1, -1, -1,
272, 273, 274, 275, -1, 41, -1, 279, 44, 281,
! 93, -1, -1, -1, -1, 287, 288, 289, 290, -1,
! -1, -1, 58, 59, -1, -1, -1, 63, 300, 301,
! -1, 303, 304, 305, 306, 307, 308, 309, -1, -1,
! 312, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 41, -1, -1, 44, -1, -1, -1, 93, -1, -1,
! -1, -1, 272, 273, 274, 275, -1, 58, 59, 279,
! -1, 281, 63, -1, -1, -1, -1, 287, 288, 289,
! 290, -1, -1, -1, -1, -1, -1, -1, -1, 41,
! 300, 301, 44, 303, 304, 305, 306, 307, 308, 309,
! -1, -1, 93, -1, -1, -1, 58, 59, -1, -1,
! -1, 63, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 272, 273,
! 274, 275, -1, 41, -1, 279, 44, 281, -1, -1,
! -1, 93, -1, 287, 288, 289, 290, -1, -1, -1,
! 58, 59, -1, -1, -1, 63, 300, 301, -1, 303,
! 304, 305, 306, 307, 308, 309, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 41, -1, -1,
! 44, -1, -1, -1, -1, 93, -1, -1, -1, 272,
! 273, 274, 275, -1, 58, 59, 279, -1, 281, 63,
! -1, -1, -1, -1, 287, 288, 289, 290, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 300, 301, -1,
! 303, 304, 305, 306, 307, 308, 309, -1, -1, 93,
! -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
! -1, 41, -1, 279, 44, 281, -1, -1, -1, -1,
! -1, 287, 288, 289, 290, -1, -1, -1, 58, 59,
! -1, -1, -1, 63, 300, 301, -1, 303, 304, 305,
! 306, 307, 308, 309, -1, -1, -1, -1, -1, -1,
! -1, 272, 273, 274, 275, -1, -1, -1, 279, 41,
! 281, -1, 44, 93, -1, -1, 287, 288, 289, 290,
! -1, -1, -1, -1, -1, -1, 58, 59, -1, 300,
! 301, 63, 303, 304, 305, 306, 307, 308, 309, -1,
! 272, 273, 274, 275, -1, 41, -1, 279, 44, 281,
! -1, -1, -1, -1, -1, 287, 288, 289, 290, -1,
! -1, 93, 58, 59, -1, -1, -1, 63, 300, 301,
! -1, 303, 304, 305, 306, 307, 308, 309, -1, -1,
! -1, -1, -1, -1, 272, 273, 274, 275, -1, 41,
! -1, 279, 44, 281, -1, -1, -1, 93, -1, 287,
! 288, 289, 290, -1, -1, -1, 58, 59, -1, -1,
! -1, 63, 300, 301, -1, 303, 304, 305, 306, 307,
! 308, 309, -1, -1, -1, -1, -1, -1, 272, 273,
! 274, 275, -1, 41, -1, 279, 44, 281, -1, -1,
! -1, 93, -1, 287, 288, 289, 290, -1, -1, -1,
! 58, 59, -1, -1, -1, 63, 300, 301, -1, 303,
! 304, 305, 306, 307, 308, -1, -1, -1, -1, -1,
! 41, -1, -1, 44, -1, -1, -1, -1, -1, -1,
! 41, -1, -1, 44, -1, 93, -1, 58, 59, -1,
! -1, -1, 272, 273, 274, 275, -1, 58, 59, 279,
! -1, 281, 63, -1, -1, -1, -1, 287, 288, -1,
! 290, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 300, 301, 93, 303, 304, 305, 306, 307, 308, -1,
! -1, -1, 93, -1, -1, 41, -1, -1, 44, -1,
! 272, 273, 274, 275, -1, 41, -1, 279, 44, 281,
! -1, -1, 58, 59, -1, 287, 288, 63, -1, -1,
! -1, -1, 58, 59, -1, -1, -1, 63, 300, 301,
! -1, 303, 304, 305, 306, 307, 272, 273, 274, 275,
! -1, 41, -1, 279, 44, 281, -1, 93, -1, -1,
! -1, 287, 288, -1, -1, -1, -1, 93, 58, 59,
! -1, -1, -1, 63, 300, 301, -1, 303, 304, 305,
! 306, 307, -1, -1, -1, -1, -1, -1, -1, -1,
! 272, 273, 274, 275, -1, 41, -1, 279, 44, 281,
! -1, -1, -1, 93, -1, 287, 288, -1, -1, -1,
! -1, -1, 58, 59, -1, -1, -1, 63, 300, 301,
! -1, 303, 304, 305, 306, 307, -1, 41, -1, -1,
! 44, -1, -1, -1, 272, 273, 274, 275, -1, -1,
! -1, 279, -1, 281, 58, 59, -1, 93, -1, 287,
! 288, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, 300, 301, -1, 303, 304, 305, 306, 307,
+ -1, 272, 273, 274, 275, -1, -1, -1, 279, 93,
-1, 272, 273, 274, 275, -1, -1, -1, 279, -1,
! 281, -1, -1, -1, -1, -1, -1, 288, -1, 300,
! 301, -1, 303, -1, -1, -1, -1, -1, -1, 300,
! 301, -1, 303, 304, 305, 306, 307, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
! -1, -1, -1, 279, -1, 281, 272, 273, 274, 275,
-1, -1, -1, 279, -1, 281, -1, -1, -1, -1,
! -1, -1, -1, -1, 300, 301, -1, 303, 304, 305,
! 306, 307, -1, -1, 300, 301, -1, 303, 304, 305,
! 306, -1, 272, 273, 274, 275, -1, -1, -1, 279,
! -1, 281, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 300, 301, -1, 303, 304, 305, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
+ -1, -1, -1, 279, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 300, 301, -1, 303, 272, 273,
! 274, 275, -1, -1, -1, 279, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 300, 301,
};
#define YYFINAL 1
#ifndef YYDEBUG
***************
*** 1151,1160 ****
};
static char *yyrule[] = {
"$accept : prog",
! "$$1 :",
! "prog : $$1 lineseq",
"block : '{' remember lineseq '}'",
"remember :",
"mblock : '{' mremember lineseq '}'",
"mremember :",
"lineseq :",
--- 1182,1191 ----
};
static char *yyrule[] = {
"$accept : prog",
! "prog : progstart lineseq",
"block : '{' remember lineseq '}'",
"remember :",
+ "progstart :",
"mblock : '{' mremember lineseq '}'",
"mremember :",
"lineseq :",
***************
*** 1221,1228 ****
"subbody : ';'",
"package : PACKAGE WORD ';'",
"package : PACKAGE ';'",
! "$$2 :",
! "use : USE startsub $$2 WORD WORD listexpr ';'",
"expr : expr ANDOP expr",
"expr : expr OROP expr",
"expr : argexpr",
--- 1252,1259 ----
"subbody : ';'",
"package : PACKAGE WORD ';'",
"package : PACKAGE ';'",
! "$$1 :",
! "use : USE startsub $$1 WORD WORD listexpr ';'",
"expr : expr ANDOP expr",
"expr : expr OROP expr",
"expr : argexpr",
***************
*** 1237,1244 ****
"listop : FUNCMETH indirob '(' listexprcom ')'",
"listop : LSTOP listexpr",
"listop : FUNC '(' listexprcom ')'",
! "$$3 :",
! "listop : LSTOPSUB startanonsub block $$3 listexpr",
"method : METHOD",
"method : scalar",
"subscripted : star '{' expr ';' '}'",
--- 1268,1275 ----
"listop : FUNCMETH indirob '(' listexprcom ')'",
"listop : LSTOP listexpr",
"listop : FUNC '(' listexprcom ')'",
! "$$2 :",
! "listop : LSTOPSUB startanonsub block $$2 listexpr",
"method : METHOD",
"method : scalar",
"subscripted : star '{' expr ';' '}'",
***************
*** 1252,1289 ****
"subscripted : term ARROW '(' expr ')'",
"subscripted : subscripted '(' expr ')'",
"subscripted : subscripted '(' ')'",
! "term : term ASSIGNOP term",
! "term : term POWOP term",
! "term : term MULOP term",
! "term : term ADDOP term",
! "term : term SHIFTOP term",
! "term : term RELOP term",
! "term : term EQOP term",
! "term : term BITANDOP term",
! "term : term BITOROP term",
! "term : term DOTDOT term",
! "term : term ANDAND term",
! "term : term OROR term",
"term : term '?' term ':' term",
- "term : term MATCHOP term",
- "term : '-' term",
- "term : '+' term",
- "term : '!' term",
- "term : '~' term",
"term : REFGEN term",
- "term : term POSTINC",
- "term : term POSTDEC",
- "term : PREINC term",
- "term : PREDEC term",
"term : myattrterm",
"term : LOCAL term",
"term : '(' expr ')'",
"term : '(' ')'",
- "term : '[' expr ']'",
- "term : '[' ']'",
- "term : HASHBRACK expr ';' '}'",
- "term : HASHBRACK ';' '}'",
- "term : ANONSUB startanonsub proto subattrlist block",
"term : scalar",
"term : star",
"term : hsh",
--- 1283,1330 ----
"subscripted : term ARROW '(' expr ')'",
"subscripted : subscripted '(' expr ')'",
"subscripted : subscripted '(' ')'",
! "termbinop : term ASSIGNOP term",
! "termbinop : term POWOP term",
! "termbinop : term MULOP term",
! "termbinop : term ADDOP term",
! "termbinop : term SHIFTOP term",
! "termbinop : term RELOP term",
! "termbinop : term EQOP term",
! "termbinop : term BITANDOP term",
! "termbinop : term BITOROP term",
! "termbinop : term DOTDOT term",
! "termbinop : term ANDAND term",
! "termbinop : term OROR term",
! "termbinop : term MATCHOP term",
! "termunop : '-' term",
! "termunop : '+' term",
! "termunop : '!' term",
! "termunop : '~' term",
! "termunop : term POSTINC",
! "termunop : term POSTDEC",
! "termunop : PREINC term",
! "termunop : PREDEC term",
! "anonymous : '[' expr ']'",
! "anonymous : '[' ']'",
! "anonymous : HASHBRACK expr ';' '}'",
! "anonymous : HASHBRACK ';' '}'",
! "anonymous : ANONSUB startanonsub proto subattrlist block",
! "termdo : DO term",
! "termdo : DO block",
! "termdo : DO WORD '(' ')'",
! "termdo : DO WORD '(' expr ')'",
! "termdo : DO scalar '(' ')'",
! "termdo : DO scalar '(' expr ')'",
! "term : termbinop",
! "term : termunop",
! "term : anonymous",
! "term : termdo",
"term : term '?' term ':' term",
"term : REFGEN term",
"term : myattrterm",
"term : LOCAL term",
"term : '(' expr ')'",
"term : '(' ')'",
"term : scalar",
"term : star",
"term : hsh",
***************
*** 1299,1310 ****
"term : amper '(' ')'",
"term : amper '(' expr ')'",
"term : NOAMP WORD listexpr",
- "term : DO term",
- "term : DO block",
- "term : DO WORD '(' ')'",
- "term : DO WORD '(' expr ')'",
- "term : DO scalar '(' ')'",
- "term : DO scalar '(' expr ')'",
"term : LOOPEX",
"term : LOOPEX term",
"term : NOTOP argexpr",
--- 1340,1345 ----
***************
*** 1360,1366 ****
#define YYMAXDEPTH 500
#endif
#endif
! #line 736 "perly.y"
/* PROGRAM */
/* more stuff added to make perly_c.diff easier to apply */
--- 1395,1401 ----
#define YYMAXDEPTH 500
#endif
#endif
! #line 793 "perly.y"
/* PROGRAM */
/* more stuff added to make perly_c.diff easier to apply */
***************
*** 1370,1376 ****
#endif
#define yyparse() Perl_yyparse(pTHX)
! #line 1446 "perly.c"
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
--- 1405,1411 ----
#endif
#define yyparse() Perl_yyparse(pTHX)
! #line 1409 "perly.c"
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
***************
*** 1400,1408 ****
ysave->oldyychar = yychar;
ysave->oldyyval = yyval;
ysave->oldyylval = yylval;
!
#if YYDEBUG
! if (yys = getenv("YYDEBUG"))
{
yyn = *yys;
if (yyn >= '0' && yyn <= '9')
--- 1435,1443 ----
ysave->oldyychar = yychar;
ysave->oldyyval = yyval;
ysave->oldyylval = yylval;
!
#if YYDEBUG
! if ((yys = getenv("YYDEBUG")))
{
yyn = *yys;
if (yyn >= '0' && yyn <= '9')
***************
*** 1429,1435 ****
*yyssp = yystate = 0;
yyloop:
! if (yyn = yydefred[yystate]) goto yyreduce;
if (yychar < 0)
{
if ((yychar = yylex()) < 0) yychar = 0;
--- 1464,1470 ----
*yyssp = yystate = 0;
yyloop:
! if ((yyn = yydefred[yystate])) goto yyreduce;
if (yychar < 0)
{
if ((yychar = yylex()) < 0) yychar = 0;
***************
*** 1464,1470 ****
ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE);
ysave->yyss = Renew(yyss, yystacksize, short);
if (!yyvs || !yyss)
! goto yyoverflow;
yyssp = yyss + yyps_index;
yyvsp = yyvs + yypv_index;
}
--- 1499,1505 ----
ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE);
ysave->yyss = Renew(yyss, yystacksize, short);
if (!yyvs || !yyss)
! goto yyoverflow;
yyssp = yyss + yyps_index;
yyvsp = yyvs + yypv_index;
}
***************
*** 1482,1495 ****
}
if (yyerrflag) goto yyinrecovery;
#ifdef lint
! goto yynewerror;
#endif
! yynewerror:
yyerror("syntax error");
#ifdef lint
! goto yyerrlab;
#endif
! yyerrlab:
++yynerrs;
yyinrecovery:
if (yyerrflag < 3)
--- 1517,1530 ----
}
if (yyerrflag) goto yyinrecovery;
#ifdef lint
!
#endif
!
yyerror("syntax error");
#ifdef lint
!
#endif
!
++yynerrs;
yyinrecovery:
if (yyerrflag < 3)
***************
*** 1517,1523 ****
ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE);
ysave->yyss = Renew(yyss, yystacksize, short);
if (!yyvs || !yyss)
! goto yyoverflow;
yyssp = yyss + yyps_index;
yyvsp = yyvs + yypv_index;
}
--- 1552,1558 ----
ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE);
ysave->yyss = Renew(yyss, yystacksize, short);
if (!yyvs || !yyss)
! goto yyoverflow;
yyssp = yyss + yyps_index;
yyvsp = yyvs + yypv_index;
}
***************
*** 1565,1612 ****
switch (yyn)
{
case 1:
! #line 128 "perly.y"
! {
! #if defined(YYDEBUG) && defined(DEBUGGING)
! yydebug = (DEBUG_p_TEST);
! #endif
! PL_expect = XSTATE;
! }
break;
case 2:
! #line 135 "perly.y"
! { newPROG(yyvsp[0].opval); }
! break;
! case 3:
! #line 139 "perly.y"
{ if (PL_copline > (line_t)yyvsp[-3].ival)
PL_copline = yyvsp[-3].ival;
yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); }
break;
! case 4:
! #line 145 "perly.y"
{ yyval.ival = block_start(TRUE); }
break;
case 5:
! #line 149 "perly.y"
{ if (PL_copline > (line_t)yyvsp[-3].ival)
PL_copline = yyvsp[-3].ival;
yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); }
break;
case 6:
! #line 155 "perly.y"
{ yyval.ival = block_start(FALSE); }
break;
case 7:
! #line 159 "perly.y"
{ yyval.opval = Nullop; }
break;
case 8:
! #line 161 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
case 9:
! #line 163 "perly.y"
{ yyval.opval = append_list(OP_LINESEQ,
(LISTOP*)yyvsp[-1].opval, (LISTOP*)yyvsp[0].opval);
PL_pad_reset_pending = TRUE;
--- 1600,1647 ----
switch (yyn)
{
case 1:
! #line 131 "perly.y"
! { yyval.ival = yyvsp[-1].ival; newPROG(block_end(yyvsp[-1].ival,yyvsp[0].opval)); }
break;
case 2:
! #line 136 "perly.y"
{ if (PL_copline > (line_t)yyvsp[-3].ival)
PL_copline = yyvsp[-3].ival;
yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); }
break;
! case 3:
! #line 142 "perly.y"
{ yyval.ival = block_start(TRUE); }
break;
+ case 4:
+ #line 146 "perly.y"
+ {
+ #if defined(YYDEBUG) && defined(DEBUGGING)
+ yydebug = (DEBUG_p_TEST);
+ #endif
+ PL_expect = XSTATE; yyval.ival = block_start(TRUE);
+ }
+ break;
case 5:
! #line 156 "perly.y"
{ if (PL_copline > (line_t)yyvsp[-3].ival)
PL_copline = yyvsp[-3].ival;
yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); }
break;
case 6:
! #line 162 "perly.y"
{ yyval.ival = block_start(FALSE); }
break;
case 7:
! #line 167 "perly.y"
{ yyval.opval = Nullop; }
break;
case 8:
! #line 169 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
case 9:
! #line 171 "perly.y"
{ yyval.opval = append_list(OP_LINESEQ,
(LISTOP*)yyvsp[-1].opval, (LISTOP*)yyvsp[0].opval);
PL_pad_reset_pending = TRUE;
***************
*** 1613,1623 ****
if (yyvsp[-1].opval && yyvsp[0].opval) PL_hints |= HINT_BLOCK_SCOPE; }
break;
case 10:
! #line 170 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); }
break;
case 12:
! #line 173 "perly.y"
{ if (yyvsp[-1].pval != Nullch) {
yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0));
}
--- 1648,1658 ----
if (yyvsp[-1].opval && yyvsp[0].opval) PL_hints |= HINT_BLOCK_SCOPE; }
break;
case 10:
! #line 179 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); }
break;
case 12:
! #line 182 "perly.y"
{ if (yyvsp[-1].pval != Nullch) {
yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0));
}
***************
*** 1628,1702 ****
PL_expect = XSTATE; }
break;
case 13:
! #line 182 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval, yyvsp[-1].opval);
PL_expect = XSTATE; }
break;
case 14:
! #line 187 "perly.y"
{ yyval.opval = Nullop; }
break;
case 15:
! #line 189 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 16:
! #line 191 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); }
break;
case 17:
! #line 193 "perly.y"
{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); }
break;
case 18:
! #line 195 "perly.y"
{ yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); }
break;
case 19:
! #line 197 "perly.y"
{ yyval.opval = newLOOPOP(OPf_PARENS, 1, yyvsp[0].opval, yyvsp[-2].opval);}
break;
case 20:
! #line 199 "perly.y"
{ yyval.opval = newFOROP(0, Nullch, yyvsp[-1].ival,
Nullop, yyvsp[0].opval, yyvsp[-2].opval, Nullop); }
break;
case 21:
! #line 204 "perly.y"
{ yyval.opval = Nullop; }
break;
case 22:
! #line 206 "perly.y"
{ (yyvsp[0].opval)->op_flags |= OPf_PARENS; yyval.opval = scope(yyvsp[0].opval); }
break;
case 23:
! #line 208 "perly.y"
{ PL_copline = yyvsp[-5].ival;
yyval.opval = newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval);
PL_hints |= HINT_BLOCK_SCOPE; }
break;
case 24:
! #line 214 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); }
break;
case 25:
! #line 218 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); }
break;
case 26:
! #line 224 "perly.y"
{ yyval.opval = Nullop; }
break;
case 27:
! #line 226 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
case 28:
! #line 230 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newSTATEOP(0, yyvsp[-7].pval,
--- 1663,1737 ----
PL_expect = XSTATE; }
break;
case 13:
! #line 191 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval, yyvsp[-1].opval);
PL_expect = XSTATE; }
break;
case 14:
! #line 197 "perly.y"
{ yyval.opval = Nullop; }
break;
case 15:
! #line 199 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 16:
! #line 201 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); }
break;
case 17:
! #line 203 "perly.y"
{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); }
break;
case 18:
! #line 205 "perly.y"
{ yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); }
break;
case 19:
! #line 207 "perly.y"
{ yyval.opval = newLOOPOP(OPf_PARENS, 1, yyvsp[0].opval, yyvsp[-2].opval);}
break;
case 20:
! #line 209 "perly.y"
{ yyval.opval = newFOROP(0, Nullch, yyvsp[-1].ival,
Nullop, yyvsp[0].opval, yyvsp[-2].opval, Nullop); }
break;
case 21:
! #line 215 "perly.y"
{ yyval.opval = Nullop; }
break;
case 22:
! #line 217 "perly.y"
{ (yyvsp[0].opval)->op_flags |= OPf_PARENS; yyval.opval = scope(yyvsp[0].opval); }
break;
case 23:
! #line 219 "perly.y"
{ PL_copline = yyvsp[-5].ival;
yyval.opval = newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval);
PL_hints |= HINT_BLOCK_SCOPE; }
break;
case 24:
! #line 226 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); }
break;
case 25:
! #line 230 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); }
break;
case 26:
! #line 237 "perly.y"
{ yyval.opval = Nullop; }
break;
case 27:
! #line 239 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
case 28:
! #line 244 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newSTATEOP(0, yyvsp[-7].pval,
***************
*** 1704,1710 ****
yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); }
break;
case 29:
! #line 236 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newSTATEOP(0, yyvsp[-7].pval,
--- 1739,1745 ----
yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); }
break;
case 29:
! #line 250 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newSTATEOP(0, yyvsp[-7].pval,
***************
*** 1712,1734 ****
yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); }
break;
case 30:
! #line 242 "perly.y"
{ yyval.opval = block_end(yyvsp[-6].ival,
newFOROP(0, yyvsp[-9].pval, yyvsp[-8].ival, yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 31:
! #line 245 "perly.y"
{ yyval.opval = block_end(yyvsp[-4].ival,
newFOROP(0, yyvsp[-8].pval, yyvsp[-7].ival, mod(yyvsp[-6].opval, OP_ENTERLOOP),
yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 32:
! #line 249 "perly.y"
{ yyval.opval = block_end(yyvsp[-4].ival,
newFOROP(0, yyvsp[-7].pval, yyvsp[-6].ival, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 33:
! #line 253 "perly.y"
{ OP *forop;
PL_copline = yyvsp[-9].ival;
forop = newSTATEOP(0, yyvsp[-10].pval,
--- 1747,1769 ----
yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); }
break;
case 30:
! #line 256 "perly.y"
{ yyval.opval = block_end(yyvsp[-6].ival,
newFOROP(0, yyvsp[-9].pval, yyvsp[-8].ival, yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 31:
! #line 259 "perly.y"
{ yyval.opval = block_end(yyvsp[-4].ival,
newFOROP(0, yyvsp[-8].pval, yyvsp[-7].ival, mod(yyvsp[-6].opval, OP_ENTERLOOP),
yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 32:
! #line 263 "perly.y"
{ yyval.opval = block_end(yyvsp[-4].ival,
newFOROP(0, yyvsp[-7].pval, yyvsp[-6].ival, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 33:
! #line 267 "perly.y"
{ OP *forop;
PL_copline = yyvsp[-9].ival;
forop = newSTATEOP(0, yyvsp[-10].pval,
***************
*** 1745,1841 ****
yyval.opval = block_end(yyvsp[-7].ival, forop); }
break;
case 34:
! #line 268 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval,
newWHILEOP(0, 1, (LOOP*)Nullop,
NOLINE, Nullop, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 35:
! #line 274 "perly.y"
{ yyval.opval = Nullop; }
break;
case 37:
! #line 279 "perly.y"
{ (void)scan_num("1", &yylval); yyval.opval = yylval.opval; }
break;
case 39:
! #line 284 "perly.y"
{ yyval.opval = invert(scalar(yyvsp[0].opval)); }
break;
case 40:
! #line 288 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 41:
! #line 292 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 42:
! #line 296 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 43:
! #line 300 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 44:
! #line 304 "perly.y"
{ yyval.pval = Nullch; }
break;
case 46:
! #line 309 "perly.y"
{ yyval.ival = 0; }
break;
case 47:
! #line 311 "perly.y"
{ yyval.ival = 0; }
break;
case 48:
! #line 313 "perly.y"
{ yyval.ival = 0; }
break;
case 49:
! #line 315 "perly.y"
{ yyval.ival = 0; }
break;
case 50:
! #line 317 "perly.y"
{ yyval.ival = 0; }
break;
case 51:
! #line 321 "perly.y"
{ newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 52:
! #line 324 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 53:
! #line 325 "perly.y"
{ yyval.opval = Nullop; }
break;
case 54:
! #line 329 "perly.y"
{ newMYSUB(yyvsp[-4].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 55:
! #line 333 "perly.y"
{ newATTRSUB(yyvsp[-4].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 56:
! #line 337 "perly.y"
{ yyval.ival = start_subparse(FALSE, 0); }
break;
case 57:
! #line 341 "perly.y"
{ yyval.ival = start_subparse(FALSE, CVf_ANON); }
break;
case 58:
! #line 345 "perly.y"
{ yyval.ival = start_subparse(TRUE, 0); }
break;
case 59:
! #line 348 "perly.y"
{ STRLEN n_a; char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv,n_a);
if (strEQ(name, "BEGIN") || strEQ(name, "END")
|| strEQ(name, "INIT") || strEQ(name, "CHECK"))
--- 1780,1876 ----
yyval.opval = block_end(yyvsp[-7].ival, forop); }
break;
case 34:
! #line 282 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval,
newWHILEOP(0, 1, (LOOP*)Nullop,
NOLINE, Nullop, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 35:
! #line 289 "perly.y"
{ yyval.opval = Nullop; }
break;
case 37:
! #line 295 "perly.y"
{ (void)scan_num("1", &yylval); yyval.opval = yylval.opval; }
break;
case 39:
! #line 301 "perly.y"
{ yyval.opval = invert(scalar(yyvsp[0].opval)); }
break;
case 40:
! #line 306 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 41:
! #line 310 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 42:
! #line 314 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 43:
! #line 318 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 44:
! #line 323 "perly.y"
{ yyval.pval = Nullch; }
break;
case 46:
! #line 329 "perly.y"
{ yyval.ival = 0; }
break;
case 47:
! #line 331 "perly.y"
{ yyval.ival = 0; }
break;
case 48:
! #line 333 "perly.y"
{ yyval.ival = 0; }
break;
case 49:
! #line 335 "perly.y"
{ yyval.ival = 0; }
break;
case 50:
! #line 337 "perly.y"
{ yyval.ival = 0; }
break;
case 51:
! #line 341 "perly.y"
{ newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 52:
! #line 344 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 53:
! #line 345 "perly.y"
{ yyval.opval = Nullop; }
break;
case 54:
! #line 350 "perly.y"
{ newMYSUB(yyvsp[-4].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 55:
! #line 355 "perly.y"
{ newATTRSUB(yyvsp[-4].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 56:
! #line 359 "perly.y"
{ yyval.ival = start_subparse(FALSE, 0); }
break;
case 57:
! #line 363 "perly.y"
{ yyval.ival = start_subparse(FALSE, CVf_ANON); }
break;
case 58:
! #line 367 "perly.y"
{ yyval.ival = start_subparse(TRUE, 0); }
break;
case 59:
! #line 371 "perly.y"
{ STRLEN n_a; char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv,n_a);
if (strEQ(name, "BEGIN") || strEQ(name, "END")
|| strEQ(name, "INIT") || strEQ(name, "CHECK"))
***************
*** 1843,1923 ****
yyval.opval = yyvsp[0].opval; }
break;
case 60:
! #line 356 "perly.y"
{ yyval.opval = Nullop; }
break;
case 62:
! #line 361 "perly.y"
{ yyval.opval = Nullop; }
break;
case 63:
! #line 363 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 64:
! #line 365 "perly.y"
{ yyval.opval = Nullop; }
break;
case 65:
! #line 369 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 66:
! #line 371 "perly.y"
{ yyval.opval = Nullop; }
break;
case 67:
! #line 374 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 68:
! #line 375 "perly.y"
{ yyval.opval = Nullop; PL_expect = XSTATE; }
break;
case 69:
! #line 379 "perly.y"
{ package(yyvsp[-1].opval); }
break;
case 70:
! #line 381 "perly.y"
{ package(Nullop); }
break;
case 71:
! #line 385 "perly.y"
{ CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ }
break;
case 72:
! #line 387 "perly.y"
{ utilize(yyvsp[-6].ival, yyvsp[-5].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); }
break;
case 73:
! #line 391 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 74:
! #line 393 "perly.y"
{ yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 76:
! #line 398 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
case 77:
! #line 400 "perly.y"
{ yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 79:
! #line 405 "perly.y"
{ yyval.opval = convert(yyvsp[-2].ival, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF(yyvsp[-2].ival,yyvsp[-1].opval), yyvsp[0].opval) ); }
break;
case 80:
! #line 408 "perly.y"
{ yyval.opval = convert(yyvsp[-4].ival, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF(yyvsp[-4].ival,yyvsp[-2].opval), yyvsp[-1].opval) ); }
break;
case 81:
! #line 411 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, scalar(yyvsp[-5].opval), yyvsp[-1].opval),
--- 1878,1958 ----
yyval.opval = yyvsp[0].opval; }
break;
case 60:
! #line 380 "perly.y"
{ yyval.opval = Nullop; }
break;
case 62:
! #line 386 "perly.y"
{ yyval.opval = Nullop; }
break;
case 63:
! #line 388 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 64:
! #line 390 "perly.y"
{ yyval.opval = Nullop; }
break;
case 65:
! #line 395 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 66:
! #line 397 "perly.y"
{ yyval.opval = Nullop; }
break;
case 67:
! #line 401 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 68:
! #line 402 "perly.y"
{ yyval.opval = Nullop; PL_expect = XSTATE; }
break;
case 69:
! #line 406 "perly.y"
{ package(yyvsp[-1].opval); }
break;
case 70:
! #line 408 "perly.y"
{ package(Nullop); }
break;
case 71:
! #line 412 "perly.y"
{ CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ }
break;
case 72:
! #line 414 "perly.y"
{ utilize(yyvsp[-6].ival, yyvsp[-5].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); }
break;
case 73:
! #line 419 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 74:
! #line 421 "perly.y"
{ yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 76:
! #line 427 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
case 77:
! #line 429 "perly.y"
{ yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 79:
! #line 435 "perly.y"
{ yyval.opval = convert(yyvsp[-2].ival, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF(yyvsp[-2].ival,yyvsp[-1].opval), yyvsp[0].opval) ); }
break;
case 80:
! #line 438 "perly.y"
{ yyval.opval = convert(yyvsp[-4].ival, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF(yyvsp[-4].ival,yyvsp[-2].opval), yyvsp[-1].opval) ); }
break;
case 81:
! #line 441 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, scalar(yyvsp[-5].opval), yyvsp[-1].opval),
***************
*** 1924,1936 ****
newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); }
break;
case 82:
! #line 416 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, scalar(yyvsp[-2].opval),
newUNOP(OP_METHOD, 0, yyvsp[0].opval))); }
break;
case 83:
! #line 420 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-1].opval, yyvsp[0].opval),
--- 1959,1971 ----
newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); }
break;
case 82:
! #line 446 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, scalar(yyvsp[-2].opval),
newUNOP(OP_METHOD, 0, yyvsp[0].opval))); }
break;
case 83:
! #line 450 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-1].opval, yyvsp[0].opval),
***************
*** 1937,1943 ****
newUNOP(OP_METHOD, 0, yyvsp[-2].opval))); }
break;
case 84:
! #line 425 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-3].opval, yyvsp[-1].opval),
--- 1972,1978 ----
newUNOP(OP_METHOD, 0, yyvsp[-2].opval))); }
break;
case 84:
! #line 455 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-3].opval, yyvsp[-1].opval),
***************
*** 1944,1993 ****
newUNOP(OP_METHOD, 0, yyvsp[-4].opval))); }
break;
case 85:
! #line 430 "perly.y"
{ yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
case 86:
! #line 432 "perly.y"
{ yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
case 87:
! #line 434 "perly.y"
{ yyvsp[0].opval = newANONATTRSUB(yyvsp[-1].ival, 0, Nullop, yyvsp[0].opval); }
break;
case 88:
! #line 436 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval), yyvsp[-4].opval)); }
break;
case 91:
! #line 446 "perly.y"
{ yyval.opval = newBINOP(OP_GELEM, 0, yyvsp[-4].opval, scalar(yyvsp[-2].opval)); }
break;
case 92:
! #line 448 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); }
break;
case 93:
! #line 450 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0,
ref(newAVREF(yyvsp[-4].opval),OP_RV2AV),
scalar(yyvsp[-1].opval));}
break;
case 94:
! #line 454 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0,
ref(newAVREF(yyvsp[-3].opval),OP_RV2AV),
scalar(yyvsp[-1].opval));}
break;
case 95:
! #line 458 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval));
PL_expect = XOPERATOR; }
break;
case 96:
! #line 461 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-5].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
--- 1979,2028 ----
newUNOP(OP_METHOD, 0, yyvsp[-4].opval))); }
break;
case 85:
! #line 460 "perly.y"
{ yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
case 86:
! #line 462 "perly.y"
{ yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
case 87:
! #line 464 "perly.y"
{ yyvsp[0].opval = newANONATTRSUB(yyvsp[-1].ival, 0, Nullop, yyvsp[0].opval); }
break;
case 88:
! #line 466 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval), yyvsp[-4].opval)); }
break;
case 91:
! #line 480 "perly.y"
{ yyval.opval = newBINOP(OP_GELEM, 0, yyvsp[-4].opval, scalar(yyvsp[-2].opval)); }
break;
case 92:
! #line 482 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); }
break;
case 93:
! #line 484 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0,
ref(newAVREF(yyvsp[-4].opval),OP_RV2AV),
scalar(yyvsp[-1].opval));}
break;
case 94:
! #line 488 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0,
ref(newAVREF(yyvsp[-3].opval),OP_RV2AV),
scalar(yyvsp[-1].opval));}
break;
case 95:
! #line 492 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval));
PL_expect = XOPERATOR; }
break;
case 96:
! #line 495 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-5].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
***************
*** 1994,2000 ****
PL_expect = XOPERATOR; }
break;
case 97:
! #line 466 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-4].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
--- 2029,2035 ----
PL_expect = XOPERATOR; }
break;
case 97:
! #line 500 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-4].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
***************
*** 2001,2195 ****
PL_expect = XOPERATOR; }
break;
case 98:
! #line 471 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar(yyvsp[-3].opval))); }
break;
case 99:
! #line 474 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval,
newCVREF(0, scalar(yyvsp[-4].opval)))); }
break;
case 100:
! #line 479 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval,
newCVREF(0, scalar(yyvsp[-3].opval)))); }
break;
case 101:
! #line 483 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar(yyvsp[-2].opval))); }
break;
case 102:
! #line 489 "perly.y"
{ yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); }
break;
case 103:
! #line 491 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 104:
! #line 493 "perly.y"
{ if (yyvsp[-1].ival != OP_REPEAT)
scalar(yyvsp[-2].opval);
yyval.opval = newBINOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, scalar(yyvsp[0].opval)); }
break;
case 105:
! #line 497 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 106:
! #line 499 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 107:
! #line 501 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 108:
! #line 503 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 109:
! #line 505 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 110:
! #line 507 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 111:
! #line 509 "perly.y"
{ yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));}
break;
case 112:
! #line 511 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 113:
! #line 513 "perly.y"
{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 114:
! #line 515 "perly.y"
! { yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); }
! break;
! case 115:
! #line 517 "perly.y"
{ yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); }
break;
! case 116:
! #line 520 "perly.y"
{ yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); }
break;
! case 117:
! #line 522 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 118:
! #line 524 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
! case 119:
! #line 526 "perly.y"
{ yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));}
break;
! case 120:
! #line 528 "perly.y"
! { yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); }
! break;
! case 121:
! #line 530 "perly.y"
{ yyval.opval = newUNOP(OP_POSTINC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTINC)); }
break;
! case 122:
! #line 533 "perly.y"
{ yyval.opval = newUNOP(OP_POSTDEC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); }
break;
! case 123:
! #line 536 "perly.y"
{ yyval.opval = newUNOP(OP_PREINC, 0,
mod(scalar(yyvsp[0].opval), OP_PREINC)); }
break;
! case 124:
! #line 539 "perly.y"
{ yyval.opval = newUNOP(OP_PREDEC, 0,
mod(scalar(yyvsp[0].opval), OP_PREDEC)); }
break;
case 125:
! #line 542 "perly.y"
! { yyval.opval = yyvsp[0].opval; }
break;
case 126:
! #line 544 "perly.y"
! { yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); }
break;
case 127:
! #line 546 "perly.y"
! { yyval.opval = sawparens(yyvsp[-1].opval); }
break;
case 128:
! #line 548 "perly.y"
! { yyval.opval = sawparens(newNULLLIST()); }
break;
case 129:
! #line 550 "perly.y"
! { yyval.opval = newANONLIST(yyvsp[-1].opval); }
break;
case 130:
! #line 552 "perly.y"
! { yyval.opval = newANONLIST(Nullop); }
break;
case 131:
! #line 554 "perly.y"
! { yyval.opval = newANONHASH(yyvsp[-2].opval); }
break;
case 132:
! #line 556 "perly.y"
! { yyval.opval = newANONHASH(Nullop); }
break;
case 133:
! #line 558 "perly.y"
! { yyval.opval = newANONATTRSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
break;
! case 134:
! #line 560 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 135:
! #line 562 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 136:
! #line 564 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 137:
! #line 566 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 138:
! #line 568 "perly.y"
{ yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));}
break;
! case 139:
! #line 570 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 140:
! #line 572 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); }
break;
! case 141:
! #line 574 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); }
break;
! case 142:
! #line 576 "perly.y"
{ yyval.opval = prepend_elem(OP_ASLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_ASLICE, 0,
--- 2036,2272 ----
PL_expect = XOPERATOR; }
break;
case 98:
! #line 505 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar(yyvsp[-3].opval))); }
break;
case 99:
! #line 508 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval,
newCVREF(0, scalar(yyvsp[-4].opval)))); }
break;
case 100:
! #line 513 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval,
newCVREF(0, scalar(yyvsp[-3].opval)))); }
break;
case 101:
! #line 517 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar(yyvsp[-2].opval))); }
break;
case 102:
! #line 523 "perly.y"
{ yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); }
break;
case 103:
! #line 525 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 104:
! #line 527 "perly.y"
{ if (yyvsp[-1].ival != OP_REPEAT)
scalar(yyvsp[-2].opval);
yyval.opval = newBINOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, scalar(yyvsp[0].opval)); }
break;
case 105:
! #line 531 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 106:
! #line 533 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 107:
! #line 535 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 108:
! #line 537 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 109:
! #line 539 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 110:
! #line 541 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 111:
! #line 543 "perly.y"
{ yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));}
break;
case 112:
! #line 545 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 113:
! #line 547 "perly.y"
{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 114:
! #line 549 "perly.y"
{ yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); }
break;
! case 115:
! #line 554 "perly.y"
{ yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); }
break;
! case 116:
! #line 556 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 117:
! #line 558 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
! case 118:
! #line 560 "perly.y"
{ yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));}
break;
! case 119:
! #line 562 "perly.y"
{ yyval.opval = newUNOP(OP_POSTINC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTINC)); }
break;
! case 120:
! #line 565 "perly.y"
{ yyval.opval = newUNOP(OP_POSTDEC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); }
break;
! case 121:
! #line 568 "perly.y"
{ yyval.opval = newUNOP(OP_PREINC, 0,
mod(scalar(yyvsp[0].opval), OP_PREINC)); }
break;
! case 122:
! #line 571 "perly.y"
{ yyval.opval = newUNOP(OP_PREDEC, 0,
mod(scalar(yyvsp[0].opval), OP_PREDEC)); }
break;
+ case 123:
+ #line 578 "perly.y"
+ { yyval.opval = newANONLIST(yyvsp[-1].opval); }
+ break;
+ case 124:
+ #line 580 "perly.y"
+ { yyval.opval = newANONLIST(Nullop); }
+ break;
case 125:
! #line 582 "perly.y"
! { yyval.opval = newANONHASH(yyvsp[-2].opval); }
break;
case 126:
! #line 584 "perly.y"
! { yyval.opval = newANONHASH(Nullop); }
break;
case 127:
! #line 586 "perly.y"
! { yyval.opval = newANONATTRSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 128:
! #line 592 "perly.y"
! { yyval.opval = dofile(yyvsp[0].opval); }
break;
case 129:
! #line 594 "perly.y"
! { yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); }
break;
case 130:
! #line 596 "perly.y"
! { yyval.opval = newUNOP(OP_ENTERSUB,
! OPf_SPECIAL|OPf_STACKED,
! prepend_elem(OP_LIST,
! scalar(newCVREF(
! (OPpENTERSUB_AMPER<<8),
! scalar(yyvsp[-2].opval)
! )),Nullop)); dep();}
break;
case 131:
! #line 604 "perly.y"
! { yyval.opval = newUNOP(OP_ENTERSUB,
! OPf_SPECIAL|OPf_STACKED,
! append_elem(OP_LIST,
! yyvsp[-1].opval,
! scalar(newCVREF(
! (OPpENTERSUB_AMPER<<8),
! scalar(yyvsp[-3].opval)
! )))); dep();}
break;
case 132:
! #line 613 "perly.y"
! { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
! prepend_elem(OP_LIST,
! scalar(newCVREF(0,scalar(yyvsp[-2].opval))), Nullop)); dep();}
break;
case 133:
! #line 617 "perly.y"
! { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
! prepend_elem(OP_LIST,
! yyvsp[-1].opval,
! scalar(newCVREF(0,scalar(yyvsp[-3].opval))))); dep();}
break;
! case 138:
! #line 629 "perly.y"
! { yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); }
! break;
! case 139:
! #line 631 "perly.y"
! { yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); }
! break;
! case 140:
! #line 633 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 141:
! #line 635 "perly.y"
! { yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); }
! break;
! case 142:
! #line 637 "perly.y"
! { yyval.opval = sawparens(yyvsp[-1].opval); }
! break;
! case 143:
! #line 639 "perly.y"
! { yyval.opval = sawparens(newNULLLIST()); }
! break;
! case 144:
! #line 641 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 145:
! #line 643 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 146:
! #line 645 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 147:
! #line 647 "perly.y"
! { yyval.opval = yyvsp[0].opval; }
! break;
! case 148:
! #line 649 "perly.y"
{ yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));}
break;
! case 149:
! #line 651 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 150:
! #line 653 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); }
break;
! case 151:
! #line 655 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); }
break;
! case 152:
! #line 657 "perly.y"
{ yyval.opval = prepend_elem(OP_ASLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_ASLICE, 0,
***************
*** 2196,2203 ****
list(yyvsp[-1].opval),
ref(yyvsp[-3].opval, OP_ASLICE))); }
break;
! case 143:
! #line 582 "perly.y"
{ yyval.opval = prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_HSLICE, 0,
--- 2273,2280 ----
list(yyvsp[-1].opval),
ref(yyvsp[-3].opval, OP_ASLICE))); }
break;
! case 153:
! #line 663 "perly.y"
{ yyval.opval = prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_HSLICE, 0,
***************
*** 2205,2426 ****
ref(oopsHV(yyvsp[-4].opval), OP_HSLICE)));
PL_expect = XOPERATOR; }
break;
! case 144:
! #line 589 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 145:
! #line 591 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); }
break;
! case 146:
! #line 593 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); }
break;
! case 147:
! #line 595 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); }
break;
! case 148:
! #line 598 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
break;
! case 149:
! #line 601 "perly.y"
! { yyval.opval = dofile(yyvsp[0].opval); }
! break;
! case 150:
! #line 603 "perly.y"
! { yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); }
! break;
! case 151:
! #line 605 "perly.y"
! { yyval.opval = newUNOP(OP_ENTERSUB,
! OPf_SPECIAL|OPf_STACKED,
! prepend_elem(OP_LIST,
! scalar(newCVREF(
! (OPpENTERSUB_AMPER<<8),
! scalar(yyvsp[-2].opval)
! )),Nullop)); dep();}
! break;
! case 152:
! #line 613 "perly.y"
! { yyval.opval = newUNOP(OP_ENTERSUB,
! OPf_SPECIAL|OPf_STACKED,
! append_elem(OP_LIST,
! yyvsp[-1].opval,
! scalar(newCVREF(
! (OPpENTERSUB_AMPER<<8),
! scalar(yyvsp[-3].opval)
! )))); dep();}
! break;
! case 153:
! #line 622 "perly.y"
! { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
! prepend_elem(OP_LIST,
! scalar(newCVREF(0,scalar(yyvsp[-2].opval))), Nullop)); dep();}
! break;
! case 154:
! #line 626 "perly.y"
! { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
! prepend_elem(OP_LIST,
! yyvsp[-1].opval,
! scalar(newCVREF(0,scalar(yyvsp[-3].opval))))); dep();}
! break;
! case 155:
! #line 631 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL);
PL_hints |= HINT_BLOCK_SCOPE; }
break;
! case 156:
! #line 634 "perly.y"
{ yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); }
break;
! case 157:
! #line 636 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
! case 158:
! #line 638 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
! case 159:
! #line 640 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
! case 160:
! #line 642 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
! case 161:
! #line 644 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
break;
! case 162:
! #line 647 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
! case 163:
! #line 649 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, 0); }
break;
! case 164:
! #line 651 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
scalar(yyvsp[0].opval)); }
break;
! case 165:
! #line 654 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); }
break;
! case 166:
! #line 656 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
! case 167:
! #line 658 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); }
break;
! case 168:
! #line 660 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); }
break;
! case 171:
! #line 666 "perly.y"
{ yyval.opval = my_attrs(yyvsp[-1].opval,yyvsp[0].opval); }
break;
! case 172:
! #line 668 "perly.y"
{ yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); }
break;
! case 173:
! #line 672 "perly.y"
{ yyval.opval = sawparens(yyvsp[-1].opval); }
break;
! case 174:
! #line 674 "perly.y"
{ yyval.opval = sawparens(newNULLLIST()); }
break;
! case 175:
! #line 676 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 176:
! #line 678 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 177:
! #line 680 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 178:
! #line 684 "perly.y"
{ yyval.opval = Nullop; }
break;
! case 179:
! #line 686 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 180:
! #line 690 "perly.y"
{ yyval.opval = Nullop; }
break;
! case 181:
! #line 692 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 182:
! #line 694 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
! case 183:
! #line 698 "perly.y"
{ PL_in_my = 0; yyval.opval = my(yyvsp[0].opval); }
break;
! case 184:
! #line 702 "perly.y"
{ yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); }
break;
! case 185:
! #line 706 "perly.y"
{ yyval.opval = newSVREF(yyvsp[0].opval); }
break;
! case 186:
! #line 710 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
! case 187:
! #line 714 "perly.y"
{ yyval.opval = newHVREF(yyvsp[0].opval); }
break;
! case 188:
! #line 718 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
! case 189:
! #line 722 "perly.y"
{ yyval.opval = newGVREF(0,yyvsp[0].opval); }
break;
! case 190:
! #line 726 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
! case 191:
! #line 728 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
! case 192:
! #line 730 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
! case 193:
! #line 733 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! #line 2442 "perly.c"
}
yyssp -= yym;
yystate = *yyssp;
--- 2282,2461 ----
ref(oopsHV(yyvsp[-4].opval), OP_HSLICE)));
PL_expect = XOPERATOR; }
break;
! case 154:
! #line 670 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 155:
! #line 672 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); }
break;
! case 156:
! #line 674 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); }
break;
! case 157:
! #line 676 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); }
break;
! case 158:
! #line 679 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
break;
! case 159:
! #line 682 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL);
PL_hints |= HINT_BLOCK_SCOPE; }
break;
! case 160:
! #line 685 "perly.y"
{ yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); }
break;
! case 161:
! #line 687 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
! case 162:
! #line 689 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
! case 163:
! #line 691 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
! case 164:
! #line 693 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
! case 165:
! #line 695 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
break;
! case 166:
! #line 698 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
! case 167:
! #line 700 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, 0); }
break;
! case 168:
! #line 702 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
scalar(yyvsp[0].opval)); }
break;
! case 169:
! #line 705 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); }
break;
! case 170:
! #line 707 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
! case 171:
! #line 709 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); }
break;
! case 172:
! #line 711 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); }
break;
! case 175:
! #line 718 "perly.y"
{ yyval.opval = my_attrs(yyvsp[-1].opval,yyvsp[0].opval); }
break;
! case 176:
! #line 720 "perly.y"
{ yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); }
break;
! case 177:
! #line 725 "perly.y"
{ yyval.opval = sawparens(yyvsp[-1].opval); }
break;
! case 178:
! #line 727 "perly.y"
{ yyval.opval = sawparens(newNULLLIST()); }
break;
! case 179:
! #line 729 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 180:
! #line 731 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 181:
! #line 733 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 182:
! #line 738 "perly.y"
{ yyval.opval = Nullop; }
break;
! case 183:
! #line 740 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 184:
! #line 744 "perly.y"
{ yyval.opval = Nullop; }
break;
! case 185:
! #line 746 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 186:
! #line 748 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
! case 187:
! #line 754 "perly.y"
{ PL_in_my = 0; yyval.opval = my(yyvsp[0].opval); }
break;
! case 188:
! #line 758 "perly.y"
{ yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); }
break;
! case 189:
! #line 762 "perly.y"
{ yyval.opval = newSVREF(yyvsp[0].opval); }
break;
! case 190:
! #line 766 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
! case 191:
! #line 770 "perly.y"
{ yyval.opval = newHVREF(yyvsp[0].opval); }
break;
! case 192:
! #line 774 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
! case 193:
! #line 778 "perly.y"
{ yyval.opval = newGVREF(0,yyvsp[0].opval); }
break;
! case 194:
! #line 783 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
! case 195:
! #line 785 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
! case 196:
! #line 787 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
! case 197:
! #line 790 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! #line 2459 "perly.c"
}
yyssp -= yym;
yystate = *yyssp;
***************
*** 2475,2481 ****
ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE);
ysave->yyss = Renew(yyss, yystacksize, short);
if (!yyvs || !yyss)
! goto yyoverflow;
yyssp = yyss + yyps_index;
yyvsp = yyvs + yypv_index;
}
--- 2510,2516 ----
ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE);
ysave->yyss = Renew(yyss, yystacksize, short);
if (!yyvs || !yyss)
! goto yyoverflow;
yyssp = yyss + yyps_index;
yyvsp = yyvs + yypv_index;
}
diff -c 'perl-5.7.1/perly.fixer' 'perl-5.7.2/perly.fixer'
Index: ./perly.fixer
*** ./perly.fixer Wed Mar 14 06:41:43 2001
--- ./perly.fixer Mon Jul 9 17:11:09 2001
***************
*** 2,8 ****
# Fix up yacc output to allow dynamic allocation. Since perly.c
# is now provided with the perl source, this should not be necessary.
! #
# However, if the user wishes to use byacc, or wishes to try another
# compiler compiler (e.g. bison or yacc), this script will get run.
# See makefile run_byacc target for more details.
--- 2,8 ----
# Fix up yacc output to allow dynamic allocation. Since perly.c
# is now provided with the perl source, this should not be necessary.
! #
# However, if the user wishes to use byacc, or wishes to try another
# compiler compiler (e.g. bison or yacc), this script will get run.
# See makefile run_byacc target for more details.
***************
*** 14,19 ****
--- 14,22 ----
#
# Additional information to make the BSD section work with SunOS 4.0.2
# tdinger@East.Sun.COM (Tom Dinger) 4/15/1991
+ #
+ # Also edit some practices gcc -Wall finds questionable.
+ #
input=$1
output=$2
***************
*** 41,46 ****
--- 44,54 ----
-e '/^static static/s/^static //' \
-e '/^#define.WORD/,/^#define.ARROW/d' \
-e '/^int.yydebug/,/^#define.yystacksize/d' \
+ -e 's/^yyerrlab:$//' \
+ -e 's/^ goto yyerrlab;//' \
+ -e 's/^yynewerror:$//' \
+ -e 's/^ goto yynewerror;//' \
+ -e 's|^static char yysccsid\(.*\)|/* static char yysccsid\1 */|' \
< $output > $tmp && mv -f $tmp $output || exit 1
rm -rf $input
echo "If you need to debug perly.c, you need to fix up the #line"
***************
*** 56,61 ****
--- 64,74 ----
-e '/^static static/s/^static //' \
-e '/^#define.WORD/,/^#define.ARROW/d' \
-e '/^int.yydebug/,/^#define.yystacksize/d' \
+ -e 's/^yyerrlab:$//' \
+ -e 's/^ goto yyerrlab;//' \
+ -e 's/^yynewerror:$//' \
+ -e 's/^ goto yynewerror;//' \
+ -e 's|^static char yysccsid\(.*\)|/* static char yysccsid\1 */|' \
< $output > $tmp && mv -f $tmp $output || exit 1
rm -rf $input
echo "If you need to debug perly.c, you need to fix up the #line"
diff -c 'perl-5.7.1/perly.y' 'perl-5.7.2/perly.y'
Index: ./perly.y
*** ./perly.y Mon Mar 19 23:31:58 2001
--- ./perly.y Mon Jul 9 17:11:09 2001
***************
*** 83,89 ****
%token COLONATTR
%type <ival> prog decl format startsub startanonsub startformsub
! %type <ival> remember mremember '&'
%type <opval> block mblock lineseq line loop cond else
%type <opval> expr term subscripted scalar ary hsh arylen star amper sideff
%type <opval> argexpr nexpr texpr iexpr mexpr mnexpr mtexpr miexpr
--- 83,89 ----
%token COLONATTR
%type <ival> prog decl format startsub startanonsub startformsub
! %type <ival> progstart remember mremember '&'
%type <opval> block mblock lineseq line loop cond else
%type <opval> expr term subscripted scalar ary hsh arylen star amper sideff
%type <opval> argexpr nexpr texpr iexpr mexpr mnexpr mtexpr miexpr
***************
*** 90,95 ****
--- 90,96 ----
%type <opval> listexpr listexprcom indirob listop method
%type <opval> formname subname proto subbody cont my_scalar
%type <opval> subattrlist myattrlist mysubrout myattrterm myterm
+ %type <opval> termbinop termunop anonymous termdo
%type <pval> label
%nonassoc PREC_LOW
***************
*** 124,140 ****
%% /* RULES */
! prog : /* NULL */
! {
! #if defined(YYDEBUG) && defined(DEBUGGING)
! yydebug = (DEBUG_p_TEST);
! #endif
! PL_expect = XSTATE;
! }
/*CONTINUED*/ lineseq
! { newPROG($2); }
;
block : '{' remember lineseq '}'
{ if (PL_copline > (line_t)$1)
PL_copline = $1;
--- 125,137 ----
%% /* RULES */
! /* The whole program */
! prog : progstart
/*CONTINUED*/ lineseq
! { $$ = $1; newPROG(block_end($1,$2)); }
;
+ /* An ordinary block */
block : '{' remember lineseq '}'
{ if (PL_copline > (line_t)$1)
PL_copline = $1;
***************
*** 145,150 ****
--- 142,157 ----
{ $$ = block_start(TRUE); }
;
+ progstart:
+ {
+ #if defined(YYDEBUG) && defined(DEBUGGING)
+ yydebug = (DEBUG_p_TEST);
+ #endif
+ PL_expect = XSTATE; $$ = block_start(TRUE);
+ }
+ ;
+
+
mblock : '{' mremember lineseq '}'
{ if (PL_copline > (line_t)$1)
PL_copline = $1;
***************
*** 155,160 ****
--- 162,168 ----
{ $$ = block_start(FALSE); }
;
+ /* A collection of "lines" in the program */
lineseq : /* NULL */
{ $$ = Nullop; }
| lineseq decl
***************
*** 166,171 ****
--- 174,180 ----
if ($1 && $2) PL_hints |= HINT_BLOCK_SCOPE; }
;
+ /* A "line" in the program */
line : label cond
{ $$ = newSTATEOP(0, $1, $2); }
| loop /* loops add their own labels */
***************
*** 183,188 ****
--- 192,198 ----
PL_expect = XSTATE; }
;
+ /* An expression which may have a side-effect */
sideff : error
{ $$ = Nullop; }
| expr
***************
*** 200,205 ****
--- 210,216 ----
Nullop, $3, $1, Nullop); }
;
+ /* else and elsif blocks */
else : /* NULL */
{ $$ = Nullop; }
| ELSE mblock
***************
*** 210,215 ****
--- 221,227 ----
PL_hints |= HINT_BLOCK_SCOPE; }
;
+ /* Real conditional expressions */
cond : IF '(' remember mexpr ')' mblock else
{ PL_copline = $1;
$$ = block_end($3,
***************
*** 220,225 ****
--- 232,238 ----
newCONDOP(0, $4, scope($6), $7)); }
;
+ /* Continue blocks */
cont : /* NULL */
{ $$ = Nullop; }
| CONTINUE block
***************
*** 226,231 ****
--- 239,245 ----
{ $$ = scope($2); }
;
+ /* Loops: while, until, for, and a bare block */
loop : label WHILE '(' remember mtexpr ')' mblock cont
{ PL_copline = $2;
$$ = block_end($4,
***************
*** 270,289 ****
--- 284,307 ----
NOLINE, Nullop, $2, $3)); }
;
+ /* Normal expression */
nexpr : /* NULL */
{ $$ = Nullop; }
| sideff
;
+ /* Boolean expression */
texpr : /* NULL means true */
{ (void)scan_num("1", &yylval); $$ = yylval.opval; }
| expr
;
+ /* Inverted boolean expression */
iexpr : expr
{ $$ = invert(scalar($1)); }
;
+ /* Expression with its own lexical scope */
mexpr : expr
{ $$ = $1; intro_my(); }
;
***************
*** 300,310 ****
--- 318,330 ----
{ $$ = $1; intro_my(); }
;
+ /* Optional "MAIN:"-style loop labels */
label : /* empty */
{ $$ = Nullch; }
| LABEL
;
+ /* Some kind of declaration - does not take part in the parse tree */
decl : format
{ $$ = 0; }
| subrout
***************
*** 325,334 ****
--- 345,356 ----
| /* NULL */ { $$ = Nullop; }
;
+ /* Unimplemented "my sub foo { }" */
mysubrout: MYSUB startsub subname proto subattrlist subbody
{ newMYSUB($2, $3, $4, $5, $6); }
;
+ /* Subroutine definition */
subrout : SUB startsub subname proto subattrlist subbody
{ newATTRSUB($2, $3, $4, $5, $6); }
;
***************
*** 345,350 ****
--- 367,373 ----
{ $$ = start_subparse(TRUE, 0); }
;
+ /* Name of a subroutine - must be a bareword, could be special */
subname : WORD { STRLEN n_a; char *name = SvPV(((SVOP*)$1)->op_sv,n_a);
if (strEQ(name, "BEGIN") || strEQ(name, "END")
|| strEQ(name, "INIT") || strEQ(name, "CHECK"))
***************
*** 352,362 ****
--- 375,387 ----
$$ = $1; }
;
+ /* Subroutine prototype */
proto : /* NULL */
{ $$ = Nullop; }
| THING
;
+ /* Optional list of subroutine attributes */
subattrlist: /* NULL */
{ $$ = Nullop; }
| COLONATTR THING
***************
*** 365,370 ****
--- 390,396 ----
{ $$ = Nullop; }
;
+ /* List of attributes for a "my" variable declaration */
myattrlist: COLONATTR THING
{ $$ = $2; }
| COLONATTR
***************
*** 371,376 ****
--- 397,403 ----
{ $$ = Nullop; }
;
+ /* Subroutine body - either null or a block */
subbody : block { $$ = $1; }
| ';' { $$ = Nullop; PL_expect = XSTATE; }
;
***************
*** 387,392 ****
--- 414,420 ----
{ utilize($1, $2, $4, $5, $6); }
;
+ /* Ordinary expressions; logical combinations */
expr : expr ANDOP expr
{ $$ = newLOGOP(OP_AND, 0, $1, $3); }
| expr OROP expr
***************
*** 394,399 ****
--- 422,428 ----
| argexpr %prec PREC_LOW
;
+ /* Expressions are a list of terms joined by commas */
argexpr : argexpr ','
{ $$ = $1; }
| argexpr ',' term
***************
*** 401,543 ****
| term %prec PREC_LOW
;
! listop : LSTOP indirob argexpr
{ $$ = convert($1, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF($1,$2), $3) ); }
! | FUNC '(' indirob expr ')'
{ $$ = convert($1, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF($1,$3), $4) ); }
! | term ARROW method '(' listexprcom ')'
{ $$ = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, scalar($1), $5),
newUNOP(OP_METHOD, 0, $3))); }
! | term ARROW method
{ $$ = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, scalar($1),
newUNOP(OP_METHOD, 0, $3))); }
! | METHOD indirob listexpr
{ $$ = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, $2, $3),
newUNOP(OP_METHOD, 0, $1))); }
! | FUNCMETH indirob '(' listexprcom ')'
{ $$ = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, $2, $4),
newUNOP(OP_METHOD, 0, $1))); }
! | LSTOP listexpr
{ $$ = convert($1, 0, $2); }
! | FUNC '(' listexprcom ')'
{ $$ = convert($1, 0, $3); }
! | LSTOPSUB startanonsub block
{ $3 = newANONATTRSUB($2, 0, Nullop, $3); }
! listexpr %prec LSTOP
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, $3, $5), $1)); }
;
method : METHOD
| scalar
;
! subscripted: star '{' expr ';' '}'
{ $$ = newBINOP(OP_GELEM, 0, $1, scalar($3)); }
! | scalar '[' expr ']'
{ $$ = newBINOP(OP_AELEM, 0, oopsAV($1), scalar($3)); }
! | term ARROW '[' expr ']'
{ $$ = newBINOP(OP_AELEM, 0,
ref(newAVREF($1),OP_RV2AV),
scalar($4));}
! | subscripted '[' expr ']'
{ $$ = newBINOP(OP_AELEM, 0,
ref(newAVREF($1),OP_RV2AV),
scalar($3));}
! | scalar '{' expr ';' '}'
{ $$ = newBINOP(OP_HELEM, 0, oopsHV($1), jmaybe($3));
PL_expect = XOPERATOR; }
! | term ARROW '{' expr ';' '}'
{ $$ = newBINOP(OP_HELEM, 0,
ref(newHVREF($1),OP_RV2HV),
jmaybe($4));
PL_expect = XOPERATOR; }
! | subscripted '{' expr ';' '}'
{ $$ = newBINOP(OP_HELEM, 0,
ref(newHVREF($1),OP_RV2HV),
jmaybe($3));
PL_expect = XOPERATOR; }
! | term ARROW '(' ')'
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar($1))); }
! | term ARROW '(' expr ')'
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, $4,
newCVREF(0, scalar($1)))); }
! | subscripted '(' expr ')'
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, $3,
newCVREF(0, scalar($1)))); }
! | subscripted '(' ')'
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar($1))); }
!
!
! term : term ASSIGNOP term
{ $$ = newASSIGNOP(OPf_STACKED, $1, $2, $3); }
! | term POWOP term
{ $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
! | term MULOP term
{ if ($2 != OP_REPEAT)
scalar($1);
$$ = newBINOP($2, 0, $1, scalar($3)); }
! | term ADDOP term
{ $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
! | term SHIFTOP term
{ $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
! | term RELOP term
{ $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
! | term EQOP term
{ $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
! | term BITANDOP term
{ $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
! | term BITOROP term
{ $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
! | term DOTDOT term
{ $$ = newRANGE($2, scalar($1), scalar($3));}
! | term ANDAND term
{ $$ = newLOGOP(OP_AND, 0, $1, $3); }
! | term OROR term
{ $$ = newLOGOP(OP_OR, 0, $1, $3); }
! | term '?' term ':' term
! { $$ = newCONDOP(0, $1, $3, $5); }
! | term MATCHOP term
{ $$ = bind_match($2, $1, $3); }
! | '-' term %prec UMINUS
{ $$ = newUNOP(OP_NEGATE, 0, scalar($2)); }
! | '+' term %prec UMINUS
{ $$ = $2; }
! | '!' term
{ $$ = newUNOP(OP_NOT, 0, scalar($2)); }
! | '~' term
{ $$ = newUNOP(OP_COMPLEMENT, 0, scalar($2));}
! | REFGEN term
! { $$ = newUNOP(OP_REFGEN, 0, mod($2,OP_REFGEN)); }
! | term POSTINC
{ $$ = newUNOP(OP_POSTINC, 0,
mod(scalar($1), OP_POSTINC)); }
! | term POSTDEC
{ $$ = newUNOP(OP_POSTDEC, 0,
mod(scalar($1), OP_POSTDEC)); }
! | PREINC term
{ $$ = newUNOP(OP_PREINC, 0,
mod(scalar($2), OP_PREINC)); }
! | PREDEC term
{ $$ = newUNOP(OP_PREDEC, 0,
mod(scalar($2), OP_PREDEC)); }
| myattrterm %prec UNIOP
{ $$ = $1; }
| LOCAL term %prec UNIOP
--- 430,634 ----
| term %prec PREC_LOW
;
! /* List operators */
! listop : LSTOP indirob argexpr /* print $fh @args */
{ $$ = convert($1, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF($1,$2), $3) ); }
! | FUNC '(' indirob expr ')' /* print ($fh @args */
{ $$ = convert($1, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF($1,$3), $4) ); }
! | term ARROW method '(' listexprcom ')' /* $foo->bar(list) */
{ $$ = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, scalar($1), $5),
newUNOP(OP_METHOD, 0, $3))); }
! | term ARROW method /* $foo->bar */
{ $$ = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, scalar($1),
newUNOP(OP_METHOD, 0, $3))); }
! | METHOD indirob listexpr /* new Class @args */
{ $$ = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, $2, $3),
newUNOP(OP_METHOD, 0, $1))); }
! | FUNCMETH indirob '(' listexprcom ')' /* method $object (@args) */
{ $$ = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, $2, $4),
newUNOP(OP_METHOD, 0, $1))); }
! | LSTOP listexpr /* print @args */
{ $$ = convert($1, 0, $2); }
! | FUNC '(' listexprcom ')' /* print (@args) */
{ $$ = convert($1, 0, $3); }
! | LSTOPSUB startanonsub block /* map { foo } ... */
{ $3 = newANONATTRSUB($2, 0, Nullop, $3); }
! listexpr %prec LSTOP /* ... @bar */
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, $3, $5), $1)); }
;
+ /* Names of methods. May use $object->$methodname */
method : METHOD
| scalar
;
! /* Some kind of subscripted expression */
! subscripted: star '{' expr ';' '}' /* *main::{something} */
! /* In this and all the hash accessors, ';' is
! * provided by the tokeniser */
{ $$ = newBINOP(OP_GELEM, 0, $1, scalar($3)); }
! | scalar '[' expr ']' /* $array[$element] */
{ $$ = newBINOP(OP_AELEM, 0, oopsAV($1), scalar($3)); }
! | term ARROW '[' expr ']' /* somearef->[$element] */
{ $$ = newBINOP(OP_AELEM, 0,
ref(newAVREF($1),OP_RV2AV),
scalar($4));}
! | subscripted '[' expr ']' /* $foo->[$bar]->[$baz] */
{ $$ = newBINOP(OP_AELEM, 0,
ref(newAVREF($1),OP_RV2AV),
scalar($3));}
! | scalar '{' expr ';' '}' /* $foo->{bar();} */
{ $$ = newBINOP(OP_HELEM, 0, oopsHV($1), jmaybe($3));
PL_expect = XOPERATOR; }
! | term ARROW '{' expr ';' '}' /* somehref->{bar();} */
{ $$ = newBINOP(OP_HELEM, 0,
ref(newHVREF($1),OP_RV2HV),
jmaybe($4));
PL_expect = XOPERATOR; }
! | subscripted '{' expr ';' '}' /* $foo->[bar]->{baz;} */
{ $$ = newBINOP(OP_HELEM, 0,
ref(newHVREF($1),OP_RV2HV),
jmaybe($3));
PL_expect = XOPERATOR; }
! | term ARROW '(' ')' /* $subref->() */
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar($1))); }
! | term ARROW '(' expr ')' /* $subref->(@args) */
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, $4,
newCVREF(0, scalar($1)))); }
! | subscripted '(' expr ')' /* $foo->{bar}->(@args) */
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, $3,
newCVREF(0, scalar($1)))); }
! | subscripted '(' ')' /* $foo->{bar}->() */
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar($1))); }
+ ;
! /* Binary operators between terms */
! termbinop : term ASSIGNOP term /* $x = $y */
{ $$ = newASSIGNOP(OPf_STACKED, $1, $2, $3); }
! | term POWOP term /* $x ** $y */
{ $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
! | term MULOP term /* $x * $y, $x x $y */
{ if ($2 != OP_REPEAT)
scalar($1);
$$ = newBINOP($2, 0, $1, scalar($3)); }
! | term ADDOP term /* $x + $y */
{ $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
! | term SHIFTOP term /* $x >> $y, $x << $y */
{ $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
! | term RELOP term /* $x > $y, etc. */
{ $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
! | term EQOP term /* $x == $y, $x eq $y */
{ $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
! | term BITANDOP term /* $x & $y */
{ $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
! | term BITOROP term /* $x | $y */
{ $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
! | term DOTDOT term /* $x..$y, $x...$y */
{ $$ = newRANGE($2, scalar($1), scalar($3));}
! | term ANDAND term /* $x && $y */
{ $$ = newLOGOP(OP_AND, 0, $1, $3); }
! | term OROR term /* $x || $y */
{ $$ = newLOGOP(OP_OR, 0, $1, $3); }
! | term MATCHOP term /* $x =~ /$y/ */
{ $$ = bind_match($2, $1, $3); }
+ ;
! /* Unary operators and terms */
! termunop : '-' term %prec UMINUS /* -$x */
{ $$ = newUNOP(OP_NEGATE, 0, scalar($2)); }
! | '+' term %prec UMINUS /* +$x */
{ $$ = $2; }
! | '!' term /* !$x */
{ $$ = newUNOP(OP_NOT, 0, scalar($2)); }
! | '~' term /* ~$x */
{ $$ = newUNOP(OP_COMPLEMENT, 0, scalar($2));}
! | term POSTINC /* $x++ */
{ $$ = newUNOP(OP_POSTINC, 0,
mod(scalar($1), OP_POSTINC)); }
! | term POSTDEC /* $x-- */
{ $$ = newUNOP(OP_POSTDEC, 0,
mod(scalar($1), OP_POSTDEC)); }
! | PREINC term /* ++$x */
{ $$ = newUNOP(OP_PREINC, 0,
mod(scalar($2), OP_PREINC)); }
! | PREDEC term /* --$x */
{ $$ = newUNOP(OP_PREDEC, 0,
mod(scalar($2), OP_PREDEC)); }
+
+ ;
+
+ /* Constructors for anonymous data */
+ anonymous: '[' expr ']'
+ { $$ = newANONLIST($2); }
+ | '[' ']'
+ { $$ = newANONLIST(Nullop); }
+ | HASHBRACK expr ';' '}' %prec '(' /* { foo => "Bar" } */
+ { $$ = newANONHASH($2); }
+ | HASHBRACK ';' '}' %prec '(' /* { } (';' by tokener) */
+ { $$ = newANONHASH(Nullop); }
+ | ANONSUB startanonsub proto subattrlist block %prec '('
+ { $$ = newANONATTRSUB($2, $3, $4, $5); }
+
+ ;
+
+ /* Things called with "do" */
+ termdo : DO term %prec UNIOP /* do $filename */
+ { $$ = dofile($2); }
+ | DO block %prec '(' /* do { code */
+ { $$ = newUNOP(OP_NULL, OPf_SPECIAL, scope($2)); }
+ | DO WORD '(' ')' /* do somesub() */
+ { $$ = newUNOP(OP_ENTERSUB,
+ OPf_SPECIAL|OPf_STACKED,
+ prepend_elem(OP_LIST,
+ scalar(newCVREF(
+ (OPpENTERSUB_AMPER<<8),
+ scalar($2)
+ )),Nullop)); dep();}
+ | DO WORD '(' expr ')' /* do somesub(@args) */
+ { $$ = newUNOP(OP_ENTERSUB,
+ OPf_SPECIAL|OPf_STACKED,
+ append_elem(OP_LIST,
+ $4,
+ scalar(newCVREF(
+ (OPpENTERSUB_AMPER<<8),
+ scalar($2)
+ )))); dep();}
+ | DO scalar '(' ')' /* do $subref () */
+ { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
+ prepend_elem(OP_LIST,
+ scalar(newCVREF(0,scalar($2))), Nullop)); dep();}
+ | DO scalar '(' expr ')' /* do $subref (@args) */
+ { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
+ prepend_elem(OP_LIST,
+ $4,
+ scalar(newCVREF(0,scalar($2))))); dep();}
+
+ ;
+
+ term : termbinop
+ | termunop
+ | anonymous
+ | termdo
+ | term '?' term ':' term
+ { $$ = newCONDOP(0, $1, $3, $5); }
+ | REFGEN term /* \$x, \@y, \%z */
+ { $$ = newUNOP(OP_REFGEN, 0, mod($2,OP_REFGEN)); }
| myattrterm %prec UNIOP
{ $$ = $1; }
| LOCAL term %prec UNIOP
***************
*** 546,561 ****
{ $$ = sawparens($2); }
| '(' ')'
{ $$ = sawparens(newNULLLIST()); }
- | '[' expr ']'
- { $$ = newANONLIST($2); }
- | '[' ']'
- { $$ = newANONLIST(Nullop); }
- | HASHBRACK expr ';' '}' %prec '('
- { $$ = newANONHASH($2); }
- | HASHBRACK ';' '}' %prec '('
- { $$ = newANONHASH(Nullop); }
- | ANONSUB startanonsub proto subattrlist block %prec '('
- { $$ = newANONATTRSUB($2, $3, $4, $5); }
| scalar %prec '('
{ $$ = $1; }
| star %prec '('
--- 637,642 ----
***************
*** 564,584 ****
{ $$ = $1; }
| ary %prec '('
{ $$ = $1; }
! | arylen %prec '('
{ $$ = newUNOP(OP_AV2ARYLEN, 0, ref($1, OP_AV2ARYLEN));}
| subscripted
{ $$ = $1; }
! | '(' expr ')' '[' expr ']'
{ $$ = newSLICEOP(0, $5, $2); }
! | '(' ')' '[' expr ']'
{ $$ = newSLICEOP(0, $4, Nullop); }
! | ary '[' expr ']'
{ $$ = prepend_elem(OP_ASLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_ASLICE, 0,
list($3),
ref($1, OP_ASLICE))); }
! | ary '{' expr ';' '}'
{ $$ = prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_HSLICE, 0,
--- 645,665 ----
{ $$ = $1; }
| ary %prec '('
{ $$ = $1; }
! | arylen %prec '(' /* $#x, $#{ something } */
{ $$ = newUNOP(OP_AV2ARYLEN, 0, ref($1, OP_AV2ARYLEN));}
| subscripted
{ $$ = $1; }
! | '(' expr ')' '[' expr ']' /* list slice */
{ $$ = newSLICEOP(0, $5, $2); }
! | '(' ')' '[' expr ']' /* empty list slice! */
{ $$ = newSLICEOP(0, $4, Nullop); }
! | ary '[' expr ']' /* array slice */
{ $$ = prepend_elem(OP_ASLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_ASLICE, 0,
list($3),
ref($1, OP_ASLICE))); }
! | ary '{' expr ';' '}' /* @hash{@keys} */
{ $$ = prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_HSLICE, 0,
***************
*** 587,667 ****
PL_expect = XOPERATOR; }
| THING %prec '('
{ $$ = $1; }
! | amper
{ $$ = newUNOP(OP_ENTERSUB, 0, scalar($1)); }
! | amper '(' ')'
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar($1)); }
! | amper '(' expr ')'
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, $3, scalar($1))); }
! | NOAMP WORD listexpr
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, $3, scalar($2))); }
! | DO term %prec UNIOP
! { $$ = dofile($2); }
! | DO block %prec '('
! { $$ = newUNOP(OP_NULL, OPf_SPECIAL, scope($2)); }
! | DO WORD '(' ')'
! { $$ = newUNOP(OP_ENTERSUB,
! OPf_SPECIAL|OPf_STACKED,
! prepend_elem(OP_LIST,
! scalar(newCVREF(
! (OPpENTERSUB_AMPER<<8),
! scalar($2)
! )),Nullop)); dep();}
! | DO WORD '(' expr ')'
! { $$ = newUNOP(OP_ENTERSUB,
! OPf_SPECIAL|OPf_STACKED,
! append_elem(OP_LIST,
! $4,
! scalar(newCVREF(
! (OPpENTERSUB_AMPER<<8),
! scalar($2)
! )))); dep();}
! | DO scalar '(' ')'
! { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
! prepend_elem(OP_LIST,
! scalar(newCVREF(0,scalar($2))), Nullop)); dep();}
! | DO scalar '(' expr ')'
! { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
! prepend_elem(OP_LIST,
! $4,
! scalar(newCVREF(0,scalar($2))))); dep();}
! | LOOPEX
{ $$ = newOP($1, OPf_SPECIAL);
PL_hints |= HINT_BLOCK_SCOPE; }
| LOOPEX term
{ $$ = newLOOPEX($1,$2); }
! | NOTOP argexpr
{ $$ = newUNOP(OP_NOT, 0, scalar($2)); }
! | UNIOP
{ $$ = newOP($1, 0); }
! | UNIOP block
{ $$ = newUNOP($1, 0, $2); }
! | UNIOP term
{ $$ = newUNOP($1, 0, $2); }
! | UNIOPSUB term
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, $2, scalar($1))); }
! | FUNC0
{ $$ = newOP($1, 0); }
| FUNC0 '(' ')'
{ $$ = newOP($1, 0); }
! | FUNC0SUB
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
scalar($1)); }
! | FUNC1 '(' ')'
{ $$ = newOP($1, OPf_SPECIAL); }
! | FUNC1 '(' expr ')'
{ $$ = newUNOP($1, 0, $3); }
! | PMFUNC '(' term ')'
{ $$ = pmruntime($1, $3, Nullop); }
! | PMFUNC '(' term ',' term ')'
{ $$ = pmruntime($1, $3, $5); }
| WORD
| listop
;
myattrterm: MY myterm myattrlist
{ $$ = my_attrs($2,$3); }
| MY myterm
--- 668,719 ----
PL_expect = XOPERATOR; }
| THING %prec '('
{ $$ = $1; }
! | amper /* &foo; */
{ $$ = newUNOP(OP_ENTERSUB, 0, scalar($1)); }
! | amper '(' ')' /* &foo() */
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar($1)); }
! | amper '(' expr ')' /* &foo(@args) */
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, $3, scalar($1))); }
! | NOAMP WORD listexpr /* foo(@args) */
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, $3, scalar($2))); }
! | LOOPEX /* loop exiting command (goto, last, dump, etc) */
{ $$ = newOP($1, OPf_SPECIAL);
PL_hints |= HINT_BLOCK_SCOPE; }
| LOOPEX term
{ $$ = newLOOPEX($1,$2); }
! | NOTOP argexpr /* not $foo */
{ $$ = newUNOP(OP_NOT, 0, scalar($2)); }
! | UNIOP /* Unary op, $_ implied */
{ $$ = newOP($1, 0); }
! | UNIOP block /* eval { foo }, I *think* */
{ $$ = newUNOP($1, 0, $2); }
! | UNIOP term /* Unary op */
{ $$ = newUNOP($1, 0, $2); }
! | UNIOPSUB term /* Sub treated as unop */
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, $2, scalar($1))); }
! | FUNC0 /* Nullary operator */
{ $$ = newOP($1, 0); }
| FUNC0 '(' ')'
{ $$ = newOP($1, 0); }
! | FUNC0SUB /* Sub treated as nullop */
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
scalar($1)); }
! | FUNC1 '(' ')' /* not () */
{ $$ = newOP($1, OPf_SPECIAL); }
! | FUNC1 '(' expr ')' /* not($foo) */
{ $$ = newUNOP($1, 0, $3); }
! | PMFUNC '(' term ')' /* split (/foo/) */
{ $$ = pmruntime($1, $3, Nullop); }
! | PMFUNC '(' term ',' term ')' /* split (/foo/,$bar) */
{ $$ = pmruntime($1, $3, $5); }
| WORD
| listop
;
+ /* "my" declarations, with optional attributes */
myattrterm: MY myterm myattrlist
{ $$ = my_attrs($2,$3); }
| MY myterm
***************
*** 668,673 ****
--- 720,726 ----
{ $$ = localize($2,$1); }
;
+ /* Things that can be "my"'d */
myterm : '(' expr ')'
{ $$ = sawparens($2); }
| '(' ')'
***************
*** 680,685 ****
--- 733,739 ----
{ $$ = $1; }
;
+ /* Basic list expressions */
listexpr: /* NULL */ %prec PREC_LOW
{ $$ = Nullop; }
| argexpr %prec PREC_LOW
***************
*** 694,699 ****
--- 748,755 ----
{ $$ = $1; }
;
+ /* A little bit of trickery to make "for my $foo (@bar)" actually be
+ lexical */
my_scalar: scalar
{ PL_in_my = 0; $$ = my($1); }
;
***************
*** 722,727 ****
--- 778,784 ----
{ $$ = newGVREF(0,$2); }
;
+ /* Indirect objects */
indirob : WORD
{ $$ = scalar($1); }
| scalar %prec PREC_LOW
diff -c 'perl-5.7.1/perly_c.diff' 'perl-5.7.2/perly_c.diff'
Index: ./perly_c.diff
*** ./perly_c.diff Wed Mar 14 04:26:42 2001
--- ./perly_c.diff Mon Jul 9 17:11:09 2001
***************
*** 1,189 ****
! *** y.tab.c.orig Thu Aug 26 22:31:26 1999
! --- y.tab.c Thu Aug 26 22:32:22 1999
! ***************
! *** 1448,1457 ****
! yyparse()
! {
! register int yym, yyn, yystate;
! #if YYDEBUG
! register char *yys;
! ! extern char *getenv();
!
! if (yys = getenv("YYDEBUG"))
! {
! yyn = *yys;
! --- 1448,1477 ----
! yyparse()
! {
! register int yym, yyn, yystate;
! + register short *yyssp;
! + register YYSTYPE *yyvsp;
! + short* yyss;
! + YYSTYPE* yyvs;
! + unsigned yystacksize = YYSTACKSIZE;
! + int retval = 0;
! #if YYDEBUG
! register char *yys;
! ! #endif
!
! + struct ysv *ysave;
! + #ifdef USE_ITHREADS
! + ENTER; /* force yydestruct() before we return */
! + #endif
! + New(73, ysave, 1, struct ysv);
! + SAVEDESTRUCTOR_X(yydestruct, ysave);
! + ysave->oldyydebug = yydebug;
! + ysave->oldyynerrs = yynerrs;
! + ysave->oldyyerrflag = yyerrflag;
! + ysave->oldyychar = yychar;
! + ysave->oldyyval = yyval;
! + ysave->oldyylval = yylval;
! +
! + #if YYDEBUG
! if (yys = getenv("YYDEBUG"))
! {
! yyn = *yys;
! ***************
! *** 1464,1469 ****
! --- 1484,1499 ----
! yyerrflag = 0;
! yychar = (-1);
!
! + /*
! + ** Initialize private stacks (yyparse may be called from an action)
! + */
! + New(73, yyss, yystacksize, short);
! + New(73, yyvs, yystacksize, YYSTYPE);
! + ysave->yyss = yyss;
! + ysave->yyvs = yyvs;
! + if (!yyvs || !yyss)
! + goto yyoverflow;
! +
! yyssp = yyss;
! yyvsp = yyvs;
! *yyssp = yystate = 0;
! ***************
! *** 1494,1500 ****
! #endif
! if (yyssp >= yyss + yystacksize - 1)
! {
! ! goto yyoverflow;
! }
! *++yyssp = yystate = yytable[yyn];
! *++yyvsp = yylval;
! --- 1524,1542 ----
! #endif
! if (yyssp >= yyss + yystacksize - 1)
! {
! ! /*
! ! ** reallocate and recover. Note that pointers
! ! ** have to be reset, or bad things will happen
! ! */
! ! int yyps_index = (yyssp - yyss);
! ! int yypv_index = (yyvsp - yyvs);
! ! yystacksize += YYSTACKSIZE;
! ! ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE);
! ! ysave->yyss = Renew(yyss, yystacksize, short);
! ! if (!yyvs || !yyss)
! ! goto yyoverflow;
! ! yyssp = yyss + yyps_index;
! ! yyvsp = yyvs + yypv_index;
! }
! *++yyssp = yystate = yytable[yyn];
! *++yyvsp = yylval;
! ***************
! *** 1535,1541 ****
! #endif
! if (yyssp >= yyss + yystacksize - 1)
! {
! ! goto yyoverflow;
! }
! *++yyssp = yystate = yytable[yyn];
! *++yyvsp = yylval;
! --- 1577,1595 ----
! #endif
! if (yyssp >= yyss + yystacksize - 1)
! {
! ! /*
! ! ** reallocate and recover. Note that pointers
! ! ** have to be reset, or bad things will happen
! ! */
! ! int yyps_index = (yyssp - yyss);
! ! int yypv_index = (yyvsp - yyvs);
! ! yystacksize += YYSTACKSIZE;
! ! ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE);
! ! ysave->yyss = Renew(yyss, yystacksize, short);
! ! if (!yyvs || !yyss)
! ! goto yyoverflow;
! ! yyssp = yyss + yyps_index;
! ! yyvsp = yyvs + yypv_index;
! }
! *++yyssp = yystate = yytable[yyn];
! *++yyvsp = yylval;
! ***************
! *** 2481,2495 ****
! #endif
! if (yyssp >= yyss + yystacksize - 1)
! {
! ! goto yyoverflow;
! }
! *++yyssp = yystate;
! *++yyvsp = yyval;
! goto yyloop;
! yyoverflow:
! ! yyerror("yacc stack overflow");
! yyabort:
! ! return (1);
! yyaccept:
! ! return (0);
! }
! --- 2535,2583 ----
! #endif
! if (yyssp >= yyss + yystacksize - 1)
! {
! ! /*
! ! ** reallocate and recover. Note that pointers
! ! ** have to be reset, or bad things will happen
! ! */
! ! int yyps_index = (yyssp - yyss);
! ! int yypv_index = (yyvsp - yyvs);
! ! yystacksize += YYSTACKSIZE;
! ! ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE);
! ! ysave->yyss = Renew(yyss, yystacksize, short);
! ! if (!yyvs || !yyss)
! ! goto yyoverflow;
! ! yyssp = yyss + yyps_index;
! ! yyvsp = yyvs + yypv_index;
! }
! *++yyssp = yystate;
! *++yyvsp = yyval;
! goto yyloop;
! yyoverflow:
! ! yyerror("Out of memory for yacc stack");
! yyabort:
! ! retval = 1;
! yyaccept:
! ! #ifdef USE_ITHREADS
! ! LEAVE; /* force yydestruct() before we return */
! ! #endif
! ! return retval;
! ! }
! !
! ! #ifdef PERL_OBJECT
! ! #include "XSUB.h"
! ! #endif
! !
! ! static void
! ! yydestruct(pTHXo_ void *ptr)
! ! {
! ! struct ysv* ysave = (struct ysv*)ptr;
! ! if (ysave->yyss) Safefree(ysave->yyss);
! ! if (ysave->yyvs) Safefree(ysave->yyvs);
! ! yydebug = ysave->oldyydebug;
! ! yynerrs = ysave->oldyynerrs;
! ! yyerrflag = ysave->oldyyerrflag;
! ! yychar = ysave->oldyychar;
! ! yyval = ysave->oldyyval;
! ! yylval = ysave->oldyylval;
! ! Safefree(ysave);
! }
--- 1,450 ----
! --- perly.c.orig Tue Jun 19 08:39:52 2001
! +++ perly.c Tue Jun 19 08:39:24 2001
! @@ -1,5 +1,5 @@
! #ifndef lint
! -static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91";
! +/* static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91"; */
! #endif
! #define YYBYACC 1
! #line 16 "perly.y"
! @@ -50,70 +50,9 @@
! #define yylex yylex_r
! #endif
!
! -#line 54 "y.tab.c"
! -#define WORD 257
! -#define METHOD 258
! -#define FUNCMETH 259
! -#define THING 260
! -#define PMFUNC 261
! -#define PRIVATEREF 262
! -#define FUNC0SUB 263
! -#define UNIOPSUB 264
! -#define LSTOPSUB 265
! -#define LABEL 266
! -#define FORMAT 267
! -#define SUB 268
! -#define ANONSUB 269
! -#define PACKAGE 270
! -#define USE 271
! -#define WHILE 272
! -#define UNTIL 273
! -#define IF 274
! -#define UNLESS 275
! -#define ELSE 276
! -#define ELSIF 277
! -#define CONTINUE 278
! -#define FOR 279
! -#define LOOPEX 280
! -#define DOTDOT 281
! -#define FUNC0 282
! -#define FUNC1 283
! -#define FUNC 284
! -#define UNIOP 285
! -#define LSTOP 286
! -#define RELOP 287
! -#define EQOP 288
! -#define MULOP 289
! -#define ADDOP 290
! -#define DOLSHARP 291
! -#define DO 292
! -#define HASHBRACK 293
! -#define NOAMP 294
! -#define LOCAL 295
! -#define MY 296
! -#define MYSUB 297
! -#define COLONATTR 298
! -#define PREC_LOW 299
! -#define OROP 300
! -#define ANDOP 301
! -#define NOTOP 302
! -#define ASSIGNOP 303
! -#define OROR 304
! -#define ANDAND 305
! -#define BITOROP 306
! -#define BITANDOP 307
! -#define SHIFTOP 308
! -#define MATCHOP 309
! -#define UMINUS 310
! -#define REFGEN 311
! -#define POWOP 312
! -#define PREINC 313
! -#define PREDEC 314
! -#define POSTINC 315
! -#define POSTDEC 316
! -#define ARROW 317
! +#line 54 "perly.c"
! #define YYERRCODE 256
! -short yylhs[] = { -1,
! +static short yylhs[] = { -1,
! 0, 9, 7, 6, 10, 8, 11, 11, 11, 12,
! 12, 12, 12, 25, 25, 25, 25, 25, 25, 25,
! 15, 15, 15, 14, 14, 43, 43, 13, 13, 13,
! @@ -135,7 +74,7 @@
! 49, 34, 34, 35, 35, 35, 44, 24, 19, 20,
! 21, 22, 23, 36, 36, 36, 36,
! };
! -short yylen[] = { 2,
! +static short yylen[] = { 2,
! 2, 4, 0, 0, 4, 0, 0, 2, 2, 2,
! 1, 2, 3, 1, 1, 3, 3, 3, 3, 3,
! 0, 2, 6, 7, 7, 0, 2, 8, 8, 10,
! @@ -157,7 +96,7 @@
! 1, 0, 1, 0, 1, 2, 1, 2, 2, 2,
! 2, 2, 2, 1, 1, 1, 1,
! };
! -short yydefred[] = { 4,
! +static short yydefred[] = { 4,
! 0, 7, 0, 45, 58, 56, 0, 56, 56, 8,
! 46, 9, 11, 48, 0, 47, 49, 50, 0, 0,
! 0, 70, 71, 0, 14, 3, 173, 0, 0, 154,
! @@ -199,7 +138,7 @@
! 0, 22, 0, 0, 0, 31, 5, 0, 30, 0,
! 0, 33, 0, 23,
! };
! -short yydgoto[] = { 1,
! +static short yydgoto[] = { 1,
! 10, 11, 20, 104, 19, 2, 95, 370, 98, 359,
! 3, 12, 13, 70, 375, 285, 72, 73, 74, 75,
! 76, 77, 78, 79, 291, 81, 292, 281, 283, 286,
! @@ -207,7 +146,7 @@
! 194, 327, 156, 289, 271, 225, 14, 83, 137, 84,
! 85, 86, 87, 15, 16, 17, 18, 93, 278,
! };
! -short yysindex[] = { 0,
! +static short yysindex[] = { 0,
! 0, 0, -132, 0, 0, 0, -51, 0, 0, 0,
! 0, 0, 0, 0, 650, 0, 0, 0, -239, -215,
! 5, 0, 0, -215, 0, 0, 0, -31, -31, 0,
! @@ -249,7 +188,7 @@
! 449, 0, 2181, -150, 340, 0, 0, 355, 0, 216,
! 216, 0, -123, 0,
! };
! -short yyrindex[] = { 0,
! +static short yyrindex[] = { 0,
! 0, 0, 247, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 274, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! @@ -291,7 +230,7 @@
! 917, 0, 0, 119, 0, 0, 0, 0, 0, 0,
! 0, 0, 179, 0,
! };
! -short yygindex[] = { 0,
! +static short yygindex[] = { 0,
! 0, 0, 196, 425, 0, 0, -2, 0, 37, 634,
! -94, 0, 0, 0, -323, -15, 2445, 0, 999, 414,
! 417, 0, 0, 0, 463, -43, 0, 0, 321, -198,
! @@ -300,7 +239,7 @@
! 0, 0, 0, 0, 0, 0, 0, 0, 0,
! };
! #define YYTABLESIZE 4568
! -short yytable[] = { 71,
! +static short yytable[] = { 71,
! 197, 65, 121, 227, 65, 111, 220, 22, 198, 293,
! 139, 296, 315, 275, 305, 102, 273, 88, 113, 228,
! 60, 113, 279, 65, 317, 60, 182, 254, 325, 101,
! @@ -759,7 +698,7 @@
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 77, 77,
! };
! -short yycheck[] = { 15,
! +static short yycheck[] = { 15,
! 95, 36, 46, 41, 36, 40, 59, 59, 100, 208,
! 54, 41, 59, 199, 41, 40, 196, 257, 41, 93,
! 123, 44, 202, 36, 93, 59, 40, 40, 59, 29,
! @@ -1224,7 +1163,7 @@
! #endif
! #define YYMAXTOKEN 317
! #if YYDEBUG
! -char *yyname[] = {
! +static char *yyname[] = {
! "end-of-file",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
! "'!'",0,0,"'$'","'%'","'&'",0,"'('","')'","'*'","'+'","','","'-'",0,0,0,0,0,0,0,
! 0,0,0,0,0,"':'","';'",0,0,0,"'?'","'@'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
! @@ -1241,7 +1180,7 @@
! "ANDAND","BITOROP","BITANDOP","SHIFTOP","MATCHOP","UMINUS","REFGEN","POWOP",
! "PREINC","PREDEC","POSTINC","POSTDEC","ARROW",
! };
! -char *yyrule[] = {
! +static char *yyrule[] = {
! "$accept : prog",
! "prog : progstart lineseq",
! "block : '{' remember lineseq '}'",
! @@ -1456,17 +1395,6 @@
! #define YYMAXDEPTH 500
! #endif
! #endif
! -int yydebug;
! -int yynerrs;
! -int yyerrflag;
! -int yychar;
! -short *yyssp;
! -YYSTYPE *yyvsp;
! -YYSTYPE yyval;
! -YYSTYPE yylval;
! -short yyss[YYSTACKSIZE];
! -YYSTYPE yyvs[YYSTACKSIZE];
! -#define yystacksize YYSTACKSIZE
! #line 793 "perly.y"
! /* PROGRAM */
!
! @@ -1477,7 +1405,7 @@
! #endif
! #define yyparse() Perl_yyparse(pTHX)
!
! -#line 1481 "y.tab.c"
! +#line 1409 "perly.c"
! #define YYABORT goto yyabort
! #define YYACCEPT goto yyaccept
! #define YYERROR goto yyerrlab
! @@ -1485,11 +1413,31 @@
! yyparse()
! {
! register int yym, yyn, yystate;
! + register short *yyssp;
! + register YYSTYPE *yyvsp;
! + short* yyss;
! + YYSTYPE* yyvs;
! + unsigned yystacksize = YYSTACKSIZE;
! + int retval = 0;
! #if YYDEBUG
! register char *yys;
! - extern char *getenv();
! +#endif
! +
! + struct ysv *ysave;
! +#ifdef USE_ITHREADS
! + ENTER; /* force yydestruct() before we return */
! +#endif
! + New(73, ysave, 1, struct ysv);
! + SAVEDESTRUCTOR_X(yydestruct, ysave);
! + ysave->oldyydebug = yydebug;
! + ysave->oldyynerrs = yynerrs;
! + ysave->oldyyerrflag = yyerrflag;
! + ysave->oldyychar = yychar;
! + ysave->oldyyval = yyval;
! + ysave->oldyylval = yylval;
!
! - if (yys = getenv("YYDEBUG"))
! +#if YYDEBUG
! + if ((yys = getenv("YYDEBUG")))
! {
! yyn = *yys;
! if (yyn >= '0' && yyn <= '9')
! @@ -1501,12 +1449,22 @@
! yyerrflag = 0;
! yychar = (-1);
!
! + /*
! + ** Initialize private stacks (yyparse may be called from an action)
! + */
! + New(73, yyss, yystacksize, short);
! + New(73, yyvs, yystacksize, YYSTYPE);
! + ysave->yyss = yyss;
! + ysave->yyvs = yyvs;
! + if (!yyvs || !yyss)
! + goto yyoverflow;
! +
! yyssp = yyss;
! yyvsp = yyvs;
! *yyssp = yystate = 0;
!
! yyloop:
! - if (yyn = yydefred[yystate]) goto yyreduce;
! + if ((yyn = yydefred[yystate])) goto yyreduce;
! if (yychar < 0)
! {
! if ((yychar = yylex()) < 0) yychar = 0;
! @@ -1516,7 +1474,7 @@
! yys = 0;
! if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
! if (!yys) yys = "illegal-symbol";
! - printf("yydebug: state %d, reading %d (%s)\n", yystate,
! + PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", yystate,
! yychar, yys);
! }
! #endif
! @@ -1526,12 +1484,24 @@
! {
! #if YYDEBUG
! if (yydebug)
! - printf("yydebug: state %d, shifting to state %d\n",
! + PerlIO_printf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n",
! yystate, yytable[yyn]);
! #endif
! if (yyssp >= yyss + yystacksize - 1)
! {
! + /*
! + ** reallocate and recover. Note that pointers
! + ** have to be reset, or bad things will happen
! + */
! + int yyps_index = (yyssp - yyss);
! + int yypv_index = (yyvsp - yyvs);
! + yystacksize += YYSTACKSIZE;
! + ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE);
! + ysave->yyss = Renew(yyss, yystacksize, short);
! + if (!yyvs || !yyss)
! goto yyoverflow;
! + yyssp = yyss + yyps_index;
! + yyvsp = yyvs + yypv_index;
! }
! *++yyssp = yystate = yytable[yyn];
! *++yyvsp = yylval;
! @@ -1547,14 +1517,14 @@
! }
! if (yyerrflag) goto yyinrecovery;
! #ifdef lint
! - goto yynewerror;
! +
! #endif
! -yynewerror:
! +
! yyerror("syntax error");
! #ifdef lint
! - goto yyerrlab;
! +
! #endif
! -yyerrlab:
! +
! ++yynerrs;
! yyinrecovery:
! if (yyerrflag < 3)
! @@ -1567,12 +1537,24 @@
! {
! #if YYDEBUG
! if (yydebug)
! - printf("yydebug: state %d, error recovery shifting\
! + PerlIO_printf(Perl_debug_log, "yydebug: state %d, error recovery shifting\
! to state %d\n", *yyssp, yytable[yyn]);
! #endif
! if (yyssp >= yyss + yystacksize - 1)
! {
! + /*
! + ** reallocate and recover. Note that pointers
! + ** have to be reset, or bad things will happen
! + */
! + int yyps_index = (yyssp - yyss);
! + int yypv_index = (yyvsp - yyvs);
! + yystacksize += YYSTACKSIZE;
! + ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE);
! + ysave->yyss = Renew(yyss, yystacksize, short);
! + if (!yyvs || !yyss)
! goto yyoverflow;
! + yyssp = yyss + yyps_index;
! + yyvsp = yyvs + yypv_index;
! }
! *++yyssp = yystate = yytable[yyn];
! *++yyvsp = yylval;
! @@ -1582,7 +1564,7 @@
! {
! #if YYDEBUG
! if (yydebug)
! - printf("yydebug: error recovery discarding state %d\n",
! + PerlIO_printf(Perl_debug_log, "yydebug: error recovery discarding state %d\n",
! *yyssp);
! #endif
! if (yyssp <= yyss) goto yyabort;
! @@ -1600,7 +1582,7 @@
! yys = 0;
! if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
! if (!yys) yys = "illegal-symbol";
! - printf("yydebug: state %d, error recovery discards token %d (%s)\n",
! + PerlIO_printf(Perl_debug_log, "yydebug: state %d, error recovery discards token %d (%s)\n",
! yystate, yychar, yys);
! }
! #endif
! @@ -1610,7 +1592,7 @@
! yyreduce:
! #if YYDEBUG
! if (yydebug)
! - printf("yydebug: state %d, reducing by rule %d (%s)\n",
! + PerlIO_printf(Perl_debug_log, "yydebug: state %d, reducing by rule %d (%s)\n",
! yystate, yyn, yyrule[yyn]);
! #endif
! yym = yylen[yyn];
! @@ -2473,7 +2455,7 @@
! #line 790 "perly.y"
! { yyval.opval = yyvsp[0].opval; }
! break;
! -#line 2477 "y.tab.c"
! +#line 2459 "perly.c"
! }
! yyssp -= yym;
! yystate = *yyssp;
! @@ -2483,7 +2465,7 @@
! {
! #if YYDEBUG
! if (yydebug)
! - printf("yydebug: after reduction, shifting from state 0 to\
! + PerlIO_printf(Perl_debug_log, "yydebug: after reduction, shifting from state 0 to\
! state %d\n", YYFINAL);
! #endif
! yystate = YYFINAL;
! @@ -2498,7 +2480,7 @@
! yys = 0;
! if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
! if (!yys) yys = "illegal-symbol";
! - printf("yydebug: state %d, reading %d (%s)\n",
! + PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n",
! YYFINAL, yychar, yys);
! }
! #endif
! @@ -2513,20 +2495,54 @@
! yystate = yydgoto[yym];
! #if YYDEBUG
! if (yydebug)
! - printf("yydebug: after reduction, shifting from state %d \
! + PerlIO_printf(Perl_debug_log, "yydebug: after reduction, shifting from state %d \
! to state %d\n", *yyssp, yystate);
! #endif
! if (yyssp >= yyss + yystacksize - 1)
! {
! + /*
! + ** reallocate and recover. Note that pointers
! + ** have to be reset, or bad things will happen
! + */
! + int yyps_index = (yyssp - yyss);
! + int yypv_index = (yyvsp - yyvs);
! + yystacksize += YYSTACKSIZE;
! + ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE);
! + ysave->yyss = Renew(yyss, yystacksize, short);
! + if (!yyvs || !yyss)
! goto yyoverflow;
! + yyssp = yyss + yyps_index;
! + yyvsp = yyvs + yypv_index;
! }
! *++yyssp = yystate;
! *++yyvsp = yyval;
! goto yyloop;
! yyoverflow:
! - yyerror("yacc stack overflow");
! + yyerror("Out of memory for yacc stack");
! yyabort:
! - return (1);
! + retval = 1;
! yyaccept:
! - return (0);
! +#ifdef USE_ITHREADS
! + LEAVE; /* force yydestruct() before we return */
! +#endif
! + return retval;
! +}
! +
! +#ifdef PERL_OBJECT
! +#include "XSUB.h"
! +#endif
! +
! +static void
! +yydestruct(pTHXo_ void *ptr)
! +{
! + struct ysv* ysave = (struct ysv*)ptr;
! + if (ysave->yyss) Safefree(ysave->yyss);
! + if (ysave->yyvs) Safefree(ysave->yyvs);
! + yydebug = ysave->oldyydebug;
! + yynerrs = ysave->oldyynerrs;
! + yyerrflag = ysave->oldyyerrflag;
! + yychar = ysave->oldyychar;
! + yyval = ysave->oldyyval;
! + yylval = ysave->oldyylval;
! + Safefree(ysave);
! }
diff -c /dev/null 'perl-5.7.2/perlyline.pl'
Index: ./perlyline.pl
*** ./perlyline.pl Thu Jan 1 02:00:00 1970
--- ./perlyline.pl Mon Jul 9 17:11:09 2001
***************
*** 0 ****
--- 1,11 ----
+ $line = 1;
+ while (<>)
+ {
+ $line++;
+ # 1st correct #line directives for perly.c itself
+ s/^(#line\s+)\d+(\s*"perly\.c"\s*)$/$1$line$2/;
+ # now add () round things gcc dislikes
+ s/if \(yyn = yydefred\[yystate\]\)/if ((yyn = yydefred[yystate]))/;
+ s/if \(yys = getenv\("YYDEBUG"\)\)/if ((yys = getenv("YYDEBUG")))/;
+ print;
+ }
diff -c 'perl-5.7.1/plan9/mkfile' 'perl-5.7.2/plan9/mkfile'
Index: ./plan9/mkfile
*** ./plan9/mkfile Tue Mar 6 04:06:20 2001
--- ./plan9/mkfile Mon Jul 9 17:11:10 2001
***************
*** 20,26 ****
installman1dir = /sys/man/1
installman3dir = /sys/man/2
! podnames = perl perlbook perlbot perlcall perldata perldebug perldiag perldsc perlembed perlform perlfunc perlguts perlipc perllol perlmod perlobj perlop perlpod perlre perlref perlrun perlsec perlstyle perlsub perlsyn perltie perltoc perltrap perlvar perlxs perlxstut
libpods = ${podnames:%=pod/%.pod}
--- 20,29 ----
installman1dir = /sys/man/1
installman3dir = /sys/man/2
! podnames = perl perlbook perlboot perlbot perldata perldebtut perldiag perldsc perlform perlfunc perlipc perllol perlmod perlmodlib perlmodinstall perlnewmod perlop perlopentut perlpod perlrequick perlretut perlref perlreftut perlrun perlsec perlstyle perlsub perlsyn perltie perltoc perltoot perltootc perltrap perlutil perlvar
! faqpodnames = perlfaq perlfaq1 perlfaq2 perlfaq3 perlfaq4 perlfaq5 perlfaq6 perlfaq7 perlfaq8 perlfaq9
! advpodnames = perlapi perlapio perlcall perlclib perlcompile perldebguts perldbmfilter perldebug perldelta perldiag perlebcdic perlembed perlfilter perlfor perlguts perlhack perlhist perlintern perliol perlnumber perlobj perlre perlthrtut perltodo perlunicode perlxs perlxs perlxstut
! archpodnames = perlaix perlapollo perlamiga perlbs2000 perlcygwin perldgux perldos perlepoc perlhpux perlhurd perlmachten perlmacos perlmint perlmpeix perlos2 perlos390 perlqnx perlsolaris perltru64 perlvmesa perlvms perlvos perlwin32
libpods = ${podnames:%=pod/%.pod}
***************
*** 133,139 ****
man:V: $perlpods pod/pod2man.PL perl
perl pod/pod2man.PL
for (i in $podnames) pod/pod2man pod/$i.pod > $installman3dir/$i
! pod/pod2man plan9/perlplan9.pod > $installman3dir/perlplan9
nuke clean:V:
rm -f *.$O $extensions^.pm config.sh $perllib config.h $perlshr perlmain.c perl miniperl $archlib/Config.pm $ext_c
--- 136,144 ----
man:V: $perlpods pod/pod2man.PL perl
perl pod/pod2man.PL
for (i in $podnames) pod/pod2man pod/$i.pod > $installman3dir/$i
! for (i in $faqpodnames) pod/pod2man pod/$i.pod > $installman3dir/$i
! for (i in $advpodnames) pod/pod2man pod/$i.pod > $installman3dir/$i
! for (i in $archpodnames) pod/pod2man pod/$i.pod > $installman3dir/$i
nuke clean:V:
rm -f *.$O $extensions^.pm config.sh $perllib config.h $perlshr perlmain.c perl miniperl $archlib/Config.pm $ext_c
diff -c 'perl-5.7.1/pod/Makefile.SH' 'perl-5.7.2/pod/Makefile.SH'
Index: ./pod/Makefile.SH
*** ./pod/Makefile.SH Tue Mar 6 04:06:21 2001
--- ./pod/Makefile.SH Mon Jul 9 17:11:10 2001
***************
*** 1,4 ****
! case $CONFIG in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
--- 1,4 ----
! case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
***************
*** 84,90 ****
tex: pod2latex $(TEX)
! toc: buildtoc
$(PERLILIB) buildtoc
.SUFFIXES: .pm .pod
--- 84,90 ----
tex: pod2latex $(TEX)
! toc perltoc.pod: buildtoc
$(PERLILIB) buildtoc
.SUFFIXES: .pm .pod
***************
*** 157,171 ****
podselect: podselect.PL ../lib/Config.pm
$(PERL) -I ../lib podselect.PL
! perlmodlib.pod: $(PERL) perlmodlib.PL ../mv-if-diff
rm -f perlmodlib.tmp
$(PERL) -I ../lib perlmodlib.PL
sh ../mv-if-diff perlmodlib.tmp perlmodlib.pod
compile: all
! $(REALPERL) -I../lib ../utils/perlcc -o pod2latex.exe pod2latex -log ../compilelog
! $(REALPERL) -I../lib ../utils/perlcc -o pod2man.exe pod2man -log ../compilelog
! $(REALPERL) -I../lib ../utils/perlcc -o pod2text.exe pod2text -log ../compilelog
! $(REALPERL) -I../lib ../utils/perlcc -o checkpods.exe checkpods -log ../compilelog
!NO!SUBS!
--- 157,171 ----
podselect: podselect.PL ../lib/Config.pm
$(PERL) -I ../lib podselect.PL
! perlmodlib.pod: $(PERL) perlmodlib.PL ../mv-if-diff ../MANIFEST
rm -f perlmodlib.tmp
$(PERL) -I ../lib perlmodlib.PL
sh ../mv-if-diff perlmodlib.tmp perlmodlib.pod
compile: all
! $(REALPERL) -I../lib ../utils/perlcc -I .. -L .. -o pod2latex.exe pod2latex -log ../compilelog
! $(REALPERL) -I../lib ../utils/perlcc -I .. -L .. -o pod2man.exe pod2man -log ../compilelog
! $(REALPERL) -I../lib ../utils/perlcc -I .. -L .. -o pod2text.exe pod2text -log ../compilelog
! $(REALPERL) -I../lib ../utils/perlcc -I .. -L .. -o checkpods.exe checkpods -log ../compilelog
!NO!SUBS!
diff -c 'perl-5.7.1/pod/buildtoc.PL' 'perl-5.7.2/pod/buildtoc.PL'
Index: ./pod/buildtoc.PL
*** ./pod/buildtoc.PL Sun Apr 8 19:48:52 2001
--- ./pod/buildtoc.PL Thu Jul 12 22:05:00 2001
***************
*** 59,65 ****
die "$0: failed to chdir('pod'): $!\n" unless chdir("pod");
}
! @pods = qw(
perl
perlfaq
perltoc
--- 59,98 ----
die "$0: failed to chdir('pod'): $!\n" unless chdir("pod");
}
! @ARCHPODS = qw(
! perlaix
! perlapollo
! perlamiga
! perlbeos
! perlbs2000
! perlcygwin
! perldgux
! perldos
! perlepoc
! perlhpux
! perlhurd
! perlmachten
! perlmacos
! perlmint
! perlmpeix
! perlnetware
! perlos2
! perlos390
! perlqnx
! perlplan9
! perlsolaris
! perltru64
! perluts
! perlvmesa
! perlvms
! perlvos
! perlwin32
! );
!
! @pods =
! (
! qw(
!
perl
perlfaq
perltoc
***************
*** 148,153 ****
--- 181,187 ----
perlhist
perldelta
+ perl572delta
perl571delta
perl570delta
perl56delta
***************
*** 154,197 ****
perl5005delta
perl5004delta
! perlaix
! perlamiga
! perlbs2000
! perlcygwin
! perldos
! perlepoc
! perlhpux
! perlmachten
! perlmacos
! perlmpeix
! perlos2
! perlos390
! perlsolaris
! perlvmesa
! perlvms
! perlvos
! perlwin32
! );
! @ARCHPODS = qw(
! perlaix
! perlamiga
! perlbs2000
! perlcygwin
! perldos
! perlepoc
! perlhpux
! perlmachten
! perlmacos
! perlmpeix
! perlos2
! perlos390
! perlsolaris
! perlvmesa
! perlvms
! perlvos
! perlwin32
! );
for (@ARCHPODS) { s/$/.pod/ }
@ARCHPODS{@ARCHPODS} = ();
--- 188,199 ----
perl5005delta
perl5004delta
! ),
! @ARCHPODS
!
! );
!
for (@ARCHPODS) { s/$/.pod/ }
@ARCHPODS{@ARCHPODS} = ();
***************
*** 279,284 ****
--- 281,287 ----
return if /(.*)\.pm$/ && -f "$1.pod";
my $file = $File::Find::name;
return if $file eq '../lib/Pod/Functions.pm'; # Used only by pod itself
+ return if $file =~ m!lib/Attribute/Handlers/demo/!;
die "tut $name" if $file =~ /TUT/;
unless (open (F, "< $_\0")) {
diff -c 'perl-5.7.1/pod/checkpods.PL' 'perl-5.7.2/pod/checkpods.PL'
Index: ./pod/checkpods.PL
*** ./pod/checkpods.PL Tue Mar 6 04:06:21 2001
--- ./pod/checkpods.PL Mon Jul 9 17:11:10 2001
***************
*** 64,70 ****
$exit = $last_unempty = 0;
while (<>) {
! chomp;
if (/^=(\S+)/ && $directive{$1} && $last_unempty) {
printf "%s: line %5d, no blank line preceeding directive =%s\n",
$ARGV, $., $1;
--- 64,70 ----
$exit = $last_unempty = 0;
while (<>) {
! s/(\012|\015\012|\015)$//;
if (/^=(\S+)/ && $directive{$1} && $last_unempty) {
printf "%s: line %5d, no blank line preceeding directive =%s\n",
$ARGV, $., $1;
diff -c 'perl-5.7.1/pod/perl.pod' 'perl-5.7.2/pod/perl.pod'
Index: ./pod/perl.pod
*** ./pod/perl.pod Sat Apr 7 21:32:17 2001
--- ./pod/perl.pod Thu Jul 12 22:03:51 2001
***************
*** 102,107 ****
--- 102,108 ----
perlhist Perl history records
perldelta Perl changes since previous version
+ perl572delta Perl changes in version 5.7.2
perl571delta Perl changes in version 5.7.1
perl570delta Perl changes in version 5.7.0
perl56delta Perl changes in version 5.6
***************
*** 109,126 ****
perl5004delta Perl changes in version 5.004
perlaix Perl notes for AIX
! perlamiga Perl notes for Amiga
perlbs2000 Perl notes for POSIX-BC BS2000
perlcygwin Perl notes for Cygwin
perldos Perl notes for DOS
perlepoc Perl notes for EPOC
perlhpux Perl notes for HP-UX
perlmachten Perl notes for Power MachTen
perlmacos Perl notes for Mac OS (Classic)
perlmpeix Perl notes for MPE/iX
perlos2 Perl notes for OS/2
perlos390 Perl notes for OS/390
perlsolaris Perl notes for Solaris
perlvmesa Perl notes for VM/ESA
perlvms Perl notes for VMS
perlvos Perl notes for Stratus VOS
--- 110,137 ----
perl5004delta Perl changes in version 5.004
perlaix Perl notes for AIX
! perlamiga Perl notes for AmigaOS
! perlapollo Perl notes for Apollo DomainOS
! perlbeos Perl notes for BeOS
perlbs2000 Perl notes for POSIX-BC BS2000
perlcygwin Perl notes for Cygwin
+ perldgux Perl notes for DG/UX
perldos Perl notes for DOS
perlepoc Perl notes for EPOC
perlhpux Perl notes for HP-UX
+ perlhurd Perl notes for Hurd
perlmachten Perl notes for Power MachTen
perlmacos Perl notes for Mac OS (Classic)
+ perlmint Perl notes for MiNT
perlmpeix Perl notes for MPE/iX
+ perlnetware Perl notes for NetWare
perlos2 Perl notes for OS/2
perlos390 Perl notes for OS/390
+ perlplan9 Perl notes for Plan 9
+ perlqnx Perl notes for QNX
perlsolaris Perl notes for Solaris
+ perltru64 Perl notes for Tru64
+ perluts Perl notes for UTS
perlvmesa Perl notes for VM/ESA
perlvms Perl notes for VMS
perlvos Perl notes for Stratus VOS
diff -c 'perl-5.7.1/pod/perl5005delta.pod' 'perl-5.7.2/pod/perl5005delta.pod'
Index: ./pod/perl5005delta.pod
*** ./pod/perl5005delta.pod Fri Mar 16 04:51:59 2001
--- ./pod/perl5005delta.pod Mon Jul 9 17:11:10 2001
***************
*** 145,151 ****
General Public License or the Artistic License (at the user's choice).
Now much of the documentation unambiguously states the terms under which
it may be distributed. Those terms are in general much less restrictive
! than the GNU GPL. See L<perl> and the individual perl man pages listed
therein.
=head1 Core Changes
--- 145,151 ----
General Public License or the Artistic License (at the user's choice).
Now much of the documentation unambiguously states the terms under which
it may be distributed. Those terms are in general much less restrictive
! than the GNU GPL. See L<perl> and the individual perl manpages listed
therein.
=head1 Core Changes
diff -c 'perl-5.7.1/pod/perl570delta.pod' 'perl-5.7.2/pod/perl570delta.pod'
Index: ./pod/perl570delta.pod
*** ./pod/perl570delta.pod Sat Apr 7 21:17:54 2001
--- ./pod/perl570delta.pod Mon Jul 9 17:11:10 2001
***************
*** 114,120 ****
=item *
! my __PACKAGE__ now works.
=item *
--- 114,120 ----
=item *
! my __PACKAGE__ $obj now works.
=item *
diff -c 'perl-5.7.1/pod/perl571delta.pod' 'perl-5.7.2/pod/perl571delta.pod'
Index: ./pod/perl571delta.pod
*** ./pod/perl571delta.pod Mon Apr 9 23:53:39 2001
--- ./pod/perl571delta.pod Mon Jul 9 17:11:10 2001
***************
*** 8,14 ****
5.7.1 release.
(To view the differences between the 5.6.0 release and the 5.7.0
! release, see L<perl570delta>).
=head1 Security Vulnerability Closed
--- 8,14 ----
5.7.1 release.
(To view the differences between the 5.6.0 release and the 5.7.0
! release, see L<perl570delta>.)
=head1 Security Vulnerability Closed
***************
*** 62,74 ****
=head1 Core Enhancements
! =over 4
- =item *
-
AUTOLOAD is now lvaluable, meaning that you can add the :lvalue attribute
to AUTOLOAD subroutines and you can assign to the AUTOLOAD return value.
=item *
IO is now by default done via PerlIO rather than system's "stdio".
--- 62,76 ----
=head1 Core Enhancements
! =head2 AUTOLOAD Is Now Lvaluable
AUTOLOAD is now lvaluable, meaning that you can add the :lvalue attribute
to AUTOLOAD subroutines and you can assign to the AUTOLOAD return value.
+ =head2 PerlIO is Now The Default
+
+ =over 4
+
=item *
IO is now by default done via PerlIO rather than system's "stdio".
***************
*** 191,196 ****
--- 193,203 ----
C<\s> doesn't.)
=back
+
+ =head2 Signals Are Now Safe
+
+ Perl used to be fragile in that signals arriving at inopportune moments
+ could corrupt Perl's internal state.
=head1 Modules and Pragmata
diff -c /dev/null 'perl-5.7.2/pod/perl572delta.pod'
Index: ./pod/perl572delta.pod
*** ./pod/perl572delta.pod Thu Jan 1 02:00:00 1970
--- ./pod/perl572delta.pod Fri Jul 13 02:57:23 2001
***************
*** 0 ****
--- 1,819 ----
+ =head1 NAME
+
+ perl572delta - what's new for perl v5.7.2
+
+ =head1 DESCRIPTION
+
+ This document describes differences between the 5.7.1 release and the
+ 5.7.2 release.
+
+ (To view the differences between the 5.6.0 release and the 5.7.0
+ release, see L<perl570delta>. To view the differences between the
+ 5.7.0 release and the 5.7.1 release, see L<perl571delta>.)
+
+ =head1 Security Vulnerability Closed
+
+ (This change was already made in 5.7.0 but bears repeating here.)
+
+ A security vulnerability affecting all Perl versions prior to 5.6.1
+ was found in August 2000. The vulnerability does not affect default
+ installations and as far as is known affects only the Linux platform.
+
+ You should upgrade your Perl to 5.6.1 as soon as possible. Patches
+ for earlier releases exist but using the patches require full
+ recompilation from the source code anyway, so 5.6.1 is your best
+ choice.
+
+ See http://www.cpan.org/src/5.0/sperl-2000-08-05/sperl-2000-08-05.txt
+ for more information.
+
+ =head1 Incompatible Changes
+
+ =head2 64-bit platforms and malloc
+
+ If your pointers are 64 bits wide, the Perl malloc is no more being
+ used because it simply does not work with 8-byte pointers. Also,
+ usually the system malloc on such platforms are much better optimized
+ for such large memory models than the Perl malloc.
+
+ =head2 AIX Dynaloading
+
+ The AIX dynaloading now uses in AIX releases 4.3 and newer the native
+ dlopen interface of AIX instead of the old emulated interface. This
+ change will probably break backward compatibility with compiled
+ modules. The change was made to make Perl more compliant with other
+ applications like modperl which are using the AIX native interface.
+
+ =head2 Socket Extension Dynamic in VMS
+
+ The Socket extension is now dynamically loaded instead of being
+ statically built in. This may or may not be a problem with ancient
+ TCP/IP stacks of VMS: we do not know since we weren't able to test
+ Perl in such configurations.
+
+ =head2 Different Definition of the Unicode Character Classes \p{In...}
+
+ As suggested by the Unicode consortium, the Unicode character classes
+ now prefer I<scripts> as opposed to I<blocks> (as defined by Unicode);
+ in Perl, when the C<\p{In....}> and the C<\p{In....}> regular expression
+ constructs are used. This has changed the definition of some of those
+ character classes.
+
+ The difference between scripts and blocks is that scripts are the
+ glyphs used by a language or a group of languages, while the blocks
+ are more artificial groupings of 256 characters based on the Unicode
+ numbering.
+
+ In general this change results in more inclusive Unicode character
+ classes, but changes to the other direction also do take place:
+ for example while the script C<Latin> includes all the Latin
+ characters and their various diacritic-adorned versions, it
+ does not include the various punctuation or digits (since they
+ are not solely C<Latin>).
+
+ Changes in the character class semantics may have happened if a script
+ and a block happen to have the same name, for example C<Hebrew>.
+ In such cases the script wins and C<\p{InHebrew}> now means the script
+ definition of Hebrew. The block definition in still available,
+ though, by appending C<Block> to the name: C<\p{InHebrewBlock}> means
+ what C<\p{InHebrew}> meant in perl 5.6.0. For the full list
+ of affected character classes, see L<perlunicode/Blocks>.
+
+ =head2 Deprecations
+
+ The current user-visible implementation of pseudo-hashes (the weird
+ use of the first array element) is deprecated starting from Perl 5.8.0
+ and will be removed in Perl 5.10.0, and the feature will be
+ implemented differently. Not only is the current interface rather
+ ugly, but the current implementation slows down normal array and hash
+ use quite noticeably. The C<fields> pragma interface will remain
+ available.
+
+ The syntaxes C<@a->[...]> and C<@h->{...}> have now been deprecated.
+
+ The suidperl is also considered to be too much a risk to continue
+ maintaining and the suidperl code is likely to be removed in a future
+ release.
+
+ The C<package;> syntax (C<package> without an argument has been
+ deprecated. Its semantics were never that clear and its
+ implementation even less so. If you have used that feature to
+ disallow all but fully qualified variables, C<use strict;> instead.
+
+ =head1 Core Enhancements
+
+ In general a lot of fixing has happened in the area of Perl's
+ understanding of numbers, both integer and floating point. Since in
+ many systems the standard number parsing functions like C<strtoul()>
+ and C<atof()> seem to have bugs, Perl tries to work around their
+ deficiencies. This results hopefully in more accurate numbers.
+
+ =over 4
+
+ =item *
+
+ The rules for allowing underscores (underbars) in numeric constants
+ have been relaxed and simplified: now you can have an underscore
+ B<between digits>.
+
+ =item *
+
+ GMAGIC (right-hand side magic) could in many cases such as string
+ concatenation be invoked too many times.
+
+ =item *
+
+ Lexicals I: lexicals outside an eval "" weren't resolved
+ correctly inside a subroutine definition inside the eval "" if they
+ were not already referenced in the top level of the eval""ed code.
+
+ =item *
+
+ Lexicals II: lexicals leaked at file scope into subroutines that
+ were declared before the lexicals.
+
+ =item *
+
+ Lvalue subroutines can now return C<undef> in list context.
+
+ =item *
+
+ The C<op_clear> and C<op_null> are now exported.
+
+ =item *
+
+ A new special regular expression variable has been introduced:
+ C<$^N>, which contains the most-recently closed group (submatch).
+
+ =item *
+
+ L<utime> now supports C<utime undef, undef, @files> to change the
+ file timestamps to the current time.
+
+ =item *
+
+ The Perl parser has been stress tested using both random input and
+ Markov chain input.
+
+ =item *
+
+ C<eval "v200"> now works.
+
+ =item *
+
+ VMS now works under PerlIO.
+
+ =back
+
+ =head1 Modules and Pragmata
+
+ =head2 New Modules and Distributions
+
+ =over 4
+
+ =item *
+
+ L<Attribute::Handlers> - Simpler definition of attribute handlers
+
+ =item *
+
+ L<ExtUtils::Constant> - generate XS code to import C header constants
+
+ =item *
+
+ L<I18N::Langinfo> - query locale information
+
+ =item *
+
+ L<I18N::LangTags> - functions for dealing with RFC3066-style language tags
+
+ =item *
+
+ L<libnet> - a collection of perl5 modules related to network programming
+
+ Perl installation leaves libnet unconfigured, use F<libnetcfg> to configure.
+
+ =item *
+
+ L<List::Util> - selection of general-utility list subroutines
+
+ =item *
+
+ L<Locale::Maketext> - framework for localization
+
+ =item *
+
+ L<Memoize> - Make your functions faster by trading space for time
+
+ =item *
+
+ L<NEXT> - pseudo-class for method redispatch
+
+ =item *
+
+ L<Scalar::Util> - selection of general-utility scalar subroutines
+
+ =item *
+
+ L<Test::More> - yet another framework for writing test scripts
+
+ =item *
+
+ L<Test::Simple> - Basic utilities for writing tests
+
+ =item *
+
+ L<Time::HiRes> - high resolution ualarm, usleep, and gettimeofday
+
+ =item *
+
+ L<Time::Piece> - Object Oriented time objects
+
+ (Previously known as L<Time::Object>.)
+
+ =item *
+
+ L<Time::Seconds> - a simple API to convert seconds to other date values
+
+ =item *
+
+ L<UnicodeCD> - Unicode Character Database
+
+ =back
+
+ =head2 Updated And Improved Modules and Pragmata
+
+ =over 4
+
+ =item *
+
+ L<B::Deparse> module has been significantly enhanced. It now
+ can deparse almost all of the standard test suite (so that the
+ tests still succeed). There is a make target "test.deparse"
+ for trying this out.
+
+ =item *
+
+ L<Class::Struct> now assigns the array/hash element if the accessor
+ is called with an array/hash element as the B<sole> argument.
+
+ =item *
+
+ L<Cwd> extension is now (even) faster.
+
+ =item *
+
+ L<DB_File> extension has been updated to version 1.77.
+
+ =item *
+
+ L<Fcntl>, L<Socket>, and L<Sys::Syslog> have been rewritten to use the
+ new-style constant dispatch section (see L<ExtUtils::Constant>).
+
+ =item *
+
+ L<File::Find> is now (again) reentrant. It also has been made
+ more portable.
+
+ =item *
+
+ L<File::Glob> now supports C<GLOB_LIMIT> constant to limit the
+ size of the returned list of filenames.
+
+ =item *
+
+ L<IO::Socket::INET> now supports C<LocalPort> of zero (usually meaning
+ that the operating system will make one up.)
+
+ =item *
+
+ The L<vars> pragma now supports declaring fully qualified variables.
+ (Something that C<our()> does not and will not support.)
+
+ =back
+
+ =head1 Utility Changes
+
+ =over 4
+
+ =item *
+
+ The F<emacs/e2ctags.pl> is now much faster.
+
+ =item *
+
+ L<h2ph> now supports C trigraphs.
+
+ =item *
+
+ L<h2xs> uses the new L<ExtUtils::Constant> module which will affect
+ newly created extensions that define constants. Since the new code is
+ more correct (if you have two constants where the first one is a
+ prefix of the second one, the first constant B<never> gets defined),
+ less lossy (it uses integers for integer constant, as opposed to the
+ old code that used floating point numbers even for integer constants),
+ and slightly faster, you might want to consider regenerating your
+ extension code (the new scheme makes regenerating easy).
+ L<h2xs> now also supports C trigraphs.
+
+ =item *
+
+ L<libnetcfg> has been added to configure the libnet.
+
+ =item *
+
+ The F<Pod::Html> (and thusly L<pod2html>) now allows specifying
+ a cache directory.
+
+ =back
+
+ =head1 New Documentation
+
+ =over 4
+
+ =item *
+
+ L<Locale::Maketext::TPJ13> is an article about software localization,
+ originally published in The Perl Journal #13, republished here with
+ kind permission.
+
+ =item *
+
+ More README.$PLATFORM files have been converted into pod, which also
+ means that they also be installed as perl$PLATFORM documentation
+ files. The new files are L<perlapollo>, L<perlbeos>, L<perldgux>,
+ L<perlhurd>, L<perlmint>, L<perlnetware>, L<perlplan9>, L<perlqnx>,
+ and L<perltru64>.
+
+ =item *
+
+ The F<Todo> and F<Todo-5.6> files have been merged into L<perltodo>.
+
+ =item *
+
+ Use of the F<gprof> tool to profile Perl has been documented in
+ L<perlhack>. There is a make target "perl.gprof" for generating a
+ gprofiled Perl executable.
+
+ =back
+
+ =head1 Installation and Configuration Improvements
+
+ =head2 New Or Improved Platforms
+
+ =over 4
+
+ =item *
+
+ AIX should now work better with gcc, threads, and 64-bitness. Also the
+ long doubles support in AIX should be better now. See L<perlaix>.
+
+ =item *
+
+ AtheOS (http://www.atheos.cx/) is a new platform.
+
+ =item *
+
+ DG/UX platform now supports the 5.005-style threads. See L<perldgux>.
+
+ =item *
+
+ DYNIX/ptx platform (a.k.a. dynixptx) is supported at or near osvers 4.5.2.
+
+ =item *
+
+ Several MacOS (Classic) portability patches have been applied. We
+ hope to get a fully working port by 5.8.0. (The remaining problems
+ relate to the changed IO model of Perl.) See L<perlmacos>.
+
+ =item *
+
+ MacOS X (or Darwin) should now be able to build Perl even on HFS+
+ filesystems. (The case-insensitivity confused the Perl build process.)
+
+ =item *
+
+ NetWare from Novell is now supported. See L<perlnetware>.
+
+ =item *
+
+ The Amdahl UTS UNIX mainframe platform is now supported.
+
+ =back
+
+ =head2 Generic Improvements
+
+ =over 4
+
+ =item *
+
+ In AFS installations one can configure the root of the AFS to be
+ somewhere else than the default F</afs> by using the Configure
+ parameter C<-Dafsroot=/some/where/else>.
+
+ =item *
+
+ The version of Berkeley DB used when the Perl (and, presumably, the
+ DB_File extension) was built is now available as
+ C<@Config{qw(db_version_major db_version_minor db_version_patch)}>
+ from Perl and as C<DB_VERSION_MAJOR_CFG DB_VERSION_MINOR_CFG
+ DB_VERSION_PATCH_CFG> from C.
+
+ =item *
+
+ The Thread extension is now not built at all under ithreads
+ (C<Configure -Duseithreads>) because it wouldn't work anyway (the
+ Thread extension requires being Configured with C<-Duse5005threads>).
+
+ =item *
+
+ The C<B::Deparse> compiler backend has been so significantly improved
+ that almost the whole Perl test suite passes after being deparsed. A
+ make target has been added to help in further testing: C<make test.deparse>.
+
+ =back
+
+ =head1 Selected Bug Fixes
+
+ =over 5
+
+ =item *
+
+ The autouse pragma didn't work for Multi::Part::Function::Names.
+
+ =item *
+
+ The behaviour of non-decimal but numeric string constants such as
+ "0x23" was platform-dependent: in some platforms that was seen as 35,
+ in some as 0, in some as a floating point number (don't ask). This
+ was caused by Perl using the operating system libraries in a situation
+ where the result of the string to number conversion is undefined: now
+ Perl consistently handles such strings as zero in numeric contexts.
+
+ =item *
+
+ L<dprofpp> -R didn't work.
+
+ =item *
+
+ PERL5OPT with embedded spaces didn't work.
+
+ =item *
+
+ L<Sys::Syslog> ignored the C<LOG_AUTH> constant.
+
+ =back
+
+ =head2 Platform Specific Changes and Fixes
+
+ =over 4
+
+ =item *
+
+ Some versions of glibc have a broken modfl(). This affects builds
+ with C<-Duselongdouble>. This version of Perl detects this brokenness
+ and has a workaround for it. The glibc release 2.2.2 is known to have
+ fixed the modfl() bug.
+
+ =back
+
+ =head1 New or Changed Diagnostics
+
+ =over 4
+
+ =item *
+
+ In the regular expression diagnostics the C<E<lt>E<lt> HERE> marker
+ introduced in 5.7.0 has been changed to be C<E<lt>-- HERE> since too
+ many people found the C<E<lt>E<lt>> to be too similar to here-document
+ starters.
+
+ =item *
+
+ If you try to L<perlfunc/pack> a number less than 0 or larger than 255
+ using the C<"C"> format you will get an optional warning. Similarly
+ for the C<"c"> format and a number less than -128 or more than 127.
+
+ =item *
+
+ Certain regex modifiers such as C<(?o)> make sense only if applied to
+ the entire regex. You will an optional warning if you try to do otherwise.
+
+ =item *
+
+ Using arrays or hashes as references (e.g. C<%foo->{bar}> has been
+ deprecated for a while. Now you will get an optional warning.
+
+ =back
+
+ =head1 Source Code Enhancements
+
+ =head2 MAGIC constants
+
+ The MAGIC constants (e.g. C<'P'>) have been macrofied
+ (e.g. C<PERL_MAGIC_TIED>) for better source code readability
+ and maintainability.
+
+ =head2 Better commented code
+
+ F<perly.c>, F<sv.c>, and F<sv.h> have now been extensively commented.
+
+ =head2 Regex pre-/post-compilation items matched up
+
+ The regex compiler now maintains a structure that identifies nodes in
+ the compiled bytecode with the corresponding syntactic features of the
+ original regex expression. The information is attached to the new
+ C<offsets> member of the C<struct regexp>. See L<perldebguts> for more
+ complete information.
+
+ =head2 gcc -Wall
+
+ The C code has been made much more C<gcc -Wall> clean. Some warning
+ messages still remain, though, so if you are compiling with gcc you
+ will see some warnings about dubious practices. The warnings are
+ being worked on.
+
+ =head1 New Tests
+
+ Several new tests have been added, especially for the F<lib> subsection.
+
+ The tests are now reported in a different order than in earlier Perls.
+ (This happens because the test scripts from under t/lib have been moved
+ to be closer to the library/extension they are testing.)
+
+ =head1 Known Problems
+
+ Note that unlike other sections in this document (which describe
+ changes since 5.7.0) this section is cumulative containing known
+ problems for all the 5.7 releases.
+
+ =head2 AIX
+
+ =over 4
+
+ =item *
+
+ In AIX 4.2 Perl extensions that use C++ functions that use statics
+ may have problems in that the statics are not getting initialized.
+ In newer AIX releases this has been solved by linking Perl with
+ the libC_r library, but unfortunately in AIX 4.2 the said library
+ has an obscure bug where the various functions related to time
+ (such as time() and gettimeofday()) return broken values, and
+ therefore in AIX 4.2 Perl is not linked against the libC_r.
+
+ =item *
+
+ vac 5.0.0.0 May Produce Buggy Code For Perl
+
+ The AIX C compiler vac version 5.0.0.0 may produce buggy code,
+ resulting in few random tests failing, but when the failing tests
+ are run by hand, they succeed. We suggest upgrading to at least
+ vac version 5.0.1.0, that has been known to compile Perl correctly.
+ "lslpp -L|grep vac.C" will tell you the vac version.
+
+ =back
+
+ =head2 Amiga Perl Invoking Mystery
+
+ One cannot call Perl using the C<volume:> syntax, that is, C<perl -v>
+ works, but for example C<bin:perl -v> doesn't. The exact reason is
+ known but the current suspect is the F<ixemul> library.
+
+ =head2 lib/ftmp-security tests warn 'system possibly insecure'
+
+ Don't panic. Read INSTALL 'make test' section instead.
+
+ =head2 Cygwin intermittent failures of lib/Memoize/t/expire_file 11 and 12
+
+ The subtests 11 and 12 sometimes fail and sometimes work.
+
+ =head2 HP-UX lib/io_multihomed Fails When LP64-Configur
+
+ The lib/io_multihomed test may hang in HP-UX if Perl has been
+ configured to be 64-bit. Because other 64-bit platforms do not hang in
+ this test, HP-UX is suspect. All other tests pass in 64-bit HP-UX. The
+ test attempts to create and connect to "multihomed" sockets (sockets
+ which have multiple IP addresses).
+
+ =head2 HP-UX lib/posix Subtest 9 Fails When LP64-Configured
+
+ If perl is configured with -Duse64bitall, the successful result of the
+ subtest 10 of lib/posix may arrive before the successful result of the
+ subtest 9, which confuses the test harness so much that it thinks the
+ subtest 9 failed.
+
+ =head2 Linux With Sfio Fails op/misc Test 48
+
+ No known fix.
+
+ =head2 OS/390
+
+ OS/390 has rather many test failures but the situation is actually
+ better than it was in 5.6.0, it's just that so many new modules and
+ tests have been added.
+
+ Failed Test Stat Wstat Total Fail Failed List of Failed
+ -----------------------------------------------------------------------------
+ ../ext/B/Deparse.t 14 1 7.14% 14
+ ../ext/B/Showlex.t 1 1 100.00% 1
+ ../ext/Encode/Encode/Tcl.t 610 13 2.13% 592 594 596 598
+ 600 602 604-610
+ ../ext/IO/lib/IO/t/io_unix.t 113 28928 5 3 60.00% 3-5
+ ../ext/POSIX/POSIX.t 29 1 3.45% 14
+ ../ext/Storable/t/lock.t 255 65280 5 3 60.00% 3-5
+ ../lib/locale.t 129 33024 117 19 16.24% 99-117
+ ../lib/warnings.t 434 1 0.23% 75
+ ../lib/ExtUtils.t 27 1 3.70% 25
+ ../lib/Math/BigInt/t/bigintpm.t 1190 1 0.08% 1145
+ ../lib/Unicode/UCD.t 81 48 59.26% 1-16 49-64 66-81
+ ../lib/User/pwent.t 9 1 11.11% 4
+ op/pat.t 660 6 0.91% 242-243 424-425
+ 626-627
+ op/split.t 0 9 ?? ?? % ??
+ op/taint.t 174 3 1.72% 156 162 168
+ op/tr.t 70 3 4.29% 50 58-59
+ Failed 16/422 test scripts, 96.21% okay. 105/23251 subtests failed, 99.55% okay.
+
+ =head2 op/sprintf tests 129 and 130
+
+ The op/sprintf tests 129 and 130 are known to fail on some platforms.
+ Examples include any platform using sfio, and Compaq/Tandem's NonStop-UX.
+ The failing platforms do not comply with the ANSI C Standard, line
+ 19ff on page 134 of ANSI X3.159 1989 to be exact. (They produce
+ something other than "1" and "-1" when formatting 0.6 and -0.6 using
+ the printf format "%.0f", most often they produce "0" and "-0".)
+
+ =head2 Failure of Thread tests
+
+ B<Note that support for 5.005-style threading remains experimental.>
+
+ The following tests are known to fail due to fundamental problems in
+ the 5.005 threading implementation. These are not new failures--Perl
+ 5.005_0x has the same bugs, but didn't have these tests.
+
+ lib/autouse.t 4
+ t/lib/thr5005.t 19-20
+
+ =head2 UNICOS
+
+ =over 4
+
+ =item *
+
+ ext/POSIX/sigaction subtests 6 and 13 may fail.
+
+ =item *
+
+ lib/ExtUtils may spuriously claim that subtest 28 failed,
+ which is interesting since the test only has 27 tests.
+
+ =item *
+
+ Numerous numerical test failures
+
+ op/numconvert 209,210,217,218
+ op/override 7
+ ext/Time/HiRes/HiRes 9
+ lib/Math/BigInt/t/bigintpm 1145
+ lib/Math/Trig 25
+
+ These tests fail because of yet unresolved floating point inaccuracies.
+
+ =back
+
+ =head2 UTS
+
+ There are a few known test failures, see L<perluts>.
+
+ =head2 VMS
+
+ Rather many tests are failing in VMS but that actually more tests
+ succeed in VMS than they used to, it's just that there are many,
+ many more tests than there used to be.
+
+ Here are the known failures from some compiler/platform combinations.
+
+ DEC C V5.3-006 on OpenVMS VAX V6.2
+
+ [-.ext.list.util.t]tainted..............FAILED on test 3
+ [-.ext.posix]sigaction..................FAILED on test 7
+ [-.ext.time.hires]hires.................FAILED on test 14
+ [-.lib.file.find]taint..................FAILED on test 17
+ [-.lib.math.bigint.t]bigintpm...........FAILED on test 1183
+ [-.lib.test.simple.t]exit...............FAILED on test 1
+ [.lib]vmsish............................FAILED on test 13
+ [.op]sprintf............................FAILED on test 12
+ Failed 8/399 tests, 91.23% okay.
+
+ DEC C V6.0-001 on OpenVMS Alpha V7.2-1 and
+ Compaq C V6.2-008 on OpenVMS Alpha V7.1
+
+ [-.ext.list.util.t]tainted..............FAILED on test 3
+ [-.lib.file.find]taint..................FAILED on test 17
+ [-.lib.test.simple.t]exit...............FAILED on test 1
+ [.lib]vmsish............................FAILED on test 13
+ Failed 4/399 tests, 92.48% okay.
+
+ Compac C V6.4-005 on OpenVMS Alpha 7.2.1
+
+ [-.ext.b]showlex........................FAILED on test 1
+ [-.ext.list.util.t]tainted..............FAILED on test 3
+ [-.lib.file.find]taint..................FAILED on test 17
+ [-.lib.test.simple.t]exit...............FAILED on test 1
+ [.lib]vmsish............................FAILED on test 13
+ [.op]misc...............................FAILED on test 49
+ Failed 6/401 tests, 92.77% okay.
+
+ =head2 Win32
+
+ In multi-CPU boxes there are some problems with the I/O buffering:
+ some output may appear twice.
+
+ =head2 Localising a Tied Variable Leaks Memory
+
+ use Tie::Hash;
+ tie my %tie_hash => 'Tie::StdHash';
+
+ ...
+
+ local($tie_hash{Foo}) = 1; # leaks
+
+ Code like the above is known to leak memory every time the local()
+ is executed.
+
+ =head2 Self-tying of Arrays and Hashes Is Forbidden
+
+ Self-tying of arrays and hashes is broken in rather deep and
+ hard-to-fix ways. As a stop-gap measure to avoid people from getting
+ frustrated at the mysterious results (core dumps, most often) it is
+ for now forbidden (you will get a fatal error even from an attempt).
+
+ =head2 Variable Attributes are not Currently Usable for Tieing
+
+ This limitation will hopefully be fixed in future. (Subroutine
+ attributes work fine for tieing, see L<Attribute::Handlers>).
+
+ =head2 Building Extensions Can Fail Because Of Largefiles
+
+ Some extensions like mod_perl are known to have issues with
+ `largefiles', a change brought by Perl 5.6.0 in which file offsets
+ default to 64 bits wide, where supported. Modules may fail to compile
+ at all or compile and work incorrectly. Currently there is no good
+ solution for the problem, but Configure now provides appropriate
+ non-largefile ccflags, ldflags, libswanted, and libs in the %Config
+ hash (e.g., $Config{ccflags_nolargefiles}) so the extensions that are
+ having problems can try configuring themselves without the
+ largefileness. This is admittedly not a clean solution, and the
+ solution may not even work at all. One potential failure is whether
+ one can (or, if one can, whether it's a good idea) link together at
+ all binaries with different ideas about file offsets, all this is
+ platform-dependent.
+
+ =head2 The Compiler Suite Is Still Experimental
+
+ The compiler suite is slowly getting better but is nowhere near
+ working order yet.
+
+ =head2 The Long Double Support is Still Experimental
+
+ The ability to configure Perl's numbers to use "long doubles",
+ floating point numbers of hopefully better accuracy, is still
+ experimental. The implementations of long doubles are not yet
+ widespread and the existing implementations are not quite mature
+ or standardised, therefore trying to support them is a rare
+ and moving target. The gain of more precision may also be offset
+ by slowdown in computations (more bits to move around, and the
+ operations are more likely to be executed by less optimised
+ libraries).
+
+ =head1 Reporting Bugs
+
+ If you find what you think is a bug, you might check the articles
+ recently posted to the comp.lang.perl.misc newsgroup and the perl
+ bug database at http://bugs.perl.org. There may also be
+ information at http://www.perl.com/perl/, the Perl Home Page.
+
+ If you believe you have an unreported bug, please run the B<perlbug>
+ program included with your release. Be sure to trim your bug down
+ to a tiny but sufficient test case. Your bug report, along with the
+ output of C<perl -V>, will be sent off to perlbug@perl.org to be
+ analysed by the Perl porting team.
+
+ =head1 SEE ALSO
+
+ The F<Changes> file for exhaustive details on what changed.
+
+ The F<INSTALL> file for how to build Perl.
+
+ The F<README> file for general stuff.
+
+ The F<Artistic> and F<Copying> files for copyright information.
+
+ =head1 HISTORY
+
+ Written by Jarkko Hietaniemi <F<jhi@iki.fi>>, with many contributions
+ from The Perl Porters and Perl Users submitting feedback and patches.
+
+ Send omissions or corrections to <F<perlbug@perl.org>>.
+
+ =cut
diff -c 'perl-5.7.1/pod/perlapi.pod' 'perl-5.7.2/pod/perlapi.pod'
Index: ./pod/perlapi.pod
*** ./pod/perlapi.pod Fri Apr 6 16:42:04 2001
--- ./pod/perlapi.pod Thu Jul 12 21:34:45 2001
***************
*** 182,187 ****
--- 182,198 ----
=for hackers
Found in file av.c
+ =item ax
+
+ Variable which is setup by C<xsubpp> to indicate the stack base offset,
+ used by the C<ST>, C<XSprePUSH> and C<XSRETURN> macros. The C<dMARK> macro
+ must be called prior to setup the C<MARK> variable.
+
+ I32 ax
+
+ =for hackers
+ Found in file XSUB.h
+
=item bytes_from_utf8
Converts a string C<s> of length C<len> from UTF8 into byte encoding.
***************
*** 320,325 ****
--- 331,356 ----
=for hackers
Found in file op.c
+ =item dAX
+
+ Sets up the C<ax> variable.
+ This is usually handled automatically by C<xsubpp> by calling C<dXSARGS>.
+
+ dAX;
+
+ =for hackers
+ Found in file XSUB.h
+
+ =item dITEMS
+
+ Sets up the C<items> variable.
+ This is usually handled automatically by C<xsubpp> by calling C<dXSARGS>.
+
+ dITEMS;
+
+ =for hackers
+ Found in file XSUB.h
+
=item dMARK
Declare a stack marker variable, C<mark>, for the XSUB. See C<MARK> and
***************
*** 351,359 ****
=item dXSARGS
! Sets up stack and mark pointers for an XSUB, calling dSP and dMARK. This
! is usually handled automatically by C<xsubpp>. Declares the C<items>
! variable to indicate the number of items on the stack.
dXSARGS;
--- 382,390 ----
=item dXSARGS
! Sets up stack and mark pointers for an XSUB, calling dSP and dMARK.
! Sets up the C<ax> and C<items> variables by calling C<dAX> and C<dITEMS>.
! This is usually handled automatically by C<xsubpp>.
dXSARGS;
***************
*** 444,449 ****
--- 475,489 ----
=for hackers
Found in file scope.h
+ =item getcwd_sv
+
+ Fill the sv with current working directory
+
+ int getcwd_sv(SV* sv)
+
+ =for hackers
+ Found in file util.c
+
=item get_av
Returns the AV of the specified Perl array. If C<create> is set and the
***************
*** 519,524 ****
--- 559,598 ----
=for hackers
Found in file op.h
+ =item grok_number
+
+ Recognise (or not) a number. The type of the number is returned
+ (0 if unrecognised), otherwise it is a bit-ORed combination of
+ IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT,
+ IS_NUMBER_NEG, IS_NUMBER_INFINITY (defined in perl.h).
+
+ If the value of the number can fit an in UV, it is returned in the *valuep
+ IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV
+ will never be set unless *valuep is valid, but *valuep may have been assigned
+ to during processing even though IS_NUMBER_IN_UV is not set on return.
+ If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when
+ valuep is non-NULL, but no actual assignment (or SEGV) will occur.
+
+ IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were
+ seen (in which case *valuep gives the true value truncated to an integer), and
+ IS_NUMBER_NEG if the number is negative (in which case *valuep holds the
+ absolute value). IS_NUMBER_IN_UV is not set if e notation was used or the
+ number is larger than a UV.
+
+ int grok_number(const char *pv, STRLEN len, UV *valuep)
+
+ =for hackers
+ Found in file numeric.c
+
+ =item grok_numeric_radix
+
+ Scan and skip for a numeric decimal separator (radix).
+
+ bool grok_numeric_radix(const char **sp, const char *send)
+
+ =for hackers
+ Found in file numeric.c
+
=item GvSV
Return the SV from the GV.
***************
*** 532,538 ****
Returns the glob with the given C<name> and a defined subroutine or
C<NULL>. The glob lives in the given C<stash>, or in the stashes
! accessible via @ISA and @UNIVERSAL.
The argument C<level> should be either 0 or -1. If C<level==0>, as a
side-effect creates a glob with the given C<name> in the given C<stash>
--- 606,612 ----
Returns the glob with the given C<name> and a defined subroutine or
C<NULL>. The glob lives in the given C<stash>, or in the stashes
! accessible via @ISA and UNIVERSAL::.
The argument C<level> should be either 0 or -1. If C<level==0>, as a
side-effect creates a glob with the given C<name> in the given C<stash>
***************
*** 952,958 ****
compute it. The return value is the new hash entry so created. It will be
NULL if the operation failed or if the value did not need to be actually
stored within the hash (as in the case of tied hashes). Otherwise the
! contents of the return value can be accessed using the C<He???> macros
described here. Note that the caller is responsible for suitably
incrementing the reference count of C<val> before the call, and
decrementing it if the function returned NULL.
--- 1026,1032 ----
compute it. The return value is the new hash entry so created. It will be
NULL if the operation failed or if the value did not need to be actually
stored within the hash (as in the case of tied hashes). Otherwise the
! contents of the return value can be accessed using the C<He?> macros
described here. Note that the caller is responsible for suitably
incrementing the reference count of C<val> before the call, and
decrementing it if the function returned NULL.
***************
*** 1104,1112 ****
=item looks_like_number
! Test if an the content of an SV looks like a number (or is a
! number). C<Inf> and C<Infinity> are treated as numbers (so will not
! issue a non-numeric warning), even if your atof() doesn't grok them.
I32 looks_like_number(SV* sv)
--- 1178,1186 ----
=item looks_like_number
! Test if the content of an SV looks like a number (or is a number).
! C<Inf> and C<Infinity> are treated as numbers (so will not issue a
! non-numeric warning), even if your atof() doesn't grok them.
I32 looks_like_number(SV* sv)
***************
*** 1283,1288 ****
--- 1357,1373 ----
=for hackers
Found in file handy.h
+ =item newSV
+
+ Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
+ with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
+ macro.
+
+ SV* newSV(STRLEN len)
+
+ =for hackers
+ Found in file sv.c
+
=item newSViv
Creates a new SV and copies an integer into it. The reference count for the
***************
*** 1316,1322 ****
=item newSVpvf
! Creates a new SV an initialize it with the string formatted like
C<sprintf>.
SV* newSVpvf(const char* pat, ...)
--- 1401,1407 ----
=item newSVpvf
! Creates a new SV and initializes it with the string formatted like
C<sprintf>.
SV* newSVpvf(const char* pat, ...)
***************
*** 1338,1348 ****
=item newSVpvn_share
! Creates a new SV and populates it with a string from
! the string table. Turns on READONLY and FAKE.
! The idea here is that as string table is used for shared hash
! keys these strings will have SvPVX == HeKEY and hash lookup
! will avoid string compare.
SV* newSVpvn_share(const char* s, I32 len, U32 hash)
--- 1423,1435 ----
=item newSVpvn_share
! Creates a new SV with its SvPVX pointing to a shared string in the string
! table. If the string does not already exist in the table, it is created
! first. Turns on READONLY and FAKE. The string's hash is stored in the UV
! slot of the SV; if the C<hash> parameter is non-zero, that value is used;
! otherwise the hash is computed. The idea here is that as the string table
! is used for shared hash keys these strings will have SvPVX == HeKEY and
! hash lookup will avoid string compare.
SV* newSVpvn_share(const char* s, I32 len, U32 hash)
***************
*** 1364,1369 ****
--- 1451,1457 ----
=item newSVsv
Creates a new SV which is an exact duplicate of the original SV.
+ (Uses C<sv_setsv>).
SV* newSVsv(SV* old)
***************
*** 1456,1461 ****
--- 1544,1558 ----
=for hackers
Found in file perl.c
+ =item perl_clone
+
+ Create and return a new interpreter by cloning the current one.
+
+ PerlInterpreter* perl_clone(PerlInterpreter* interp, UV flags)
+
+ =for hackers
+ Found in file sv.c
+
=item perl_construct
Initializes a new Perl interpreter. See L<perlembed>.
***************
*** 1934,1940 ****
NUL character). Calls C<sv_grow> to perform the expansion if necessary.
Returns a pointer to the character buffer.
! void SvGROW(SV* sv, STRLEN len)
=for hackers
Found in file sv.h
--- 2031,2037 ----
NUL character). Calls C<sv_grow> to perform the expansion if necessary.
Returns a pointer to the character buffer.
! char * SvGROW(SV* sv, STRLEN len)
=for hackers
Found in file sv.h
***************
*** 2014,2020 ****
=item SvIV
! Coerces the given SV to an integer and returns it.
IV SvIV(SV* sv)
--- 2111,2118 ----
=item SvIV
! Coerces the given SV to an integer and returns it. See C<SvIVx> for a
! version which guarantees to evaluate sv only once.
IV SvIV(SV* sv)
***************
*** 2021,2030 ****
=for hackers
Found in file sv.h
=item SvIVX
! Returns the integer which is stored in the SV, assuming SvIOK is
! true.
IV SvIVX(SV* sv)
--- 2119,2138 ----
=for hackers
Found in file sv.h
+ =item SvIVx
+
+ Coerces the given SV to an integer and returns it. Guarantees to evaluate
+ sv only once. Use the more efficent C<SvIV> otherwise.
+
+ IV SvIVx(SV* sv)
+
+ =for hackers
+ Found in file sv.h
+
=item SvIVX
! Returns the raw value in the SV's IV slot, without checks or conversions.
! Only use when you are sure SvIOK is true. See also C<SvIV()>.
IV SvIVX(SV* sv)
***************
*** 2118,2124 ****
=item SvNV
! Coerce the given SV to a double and return it.
NV SvNV(SV* sv)
--- 2226,2233 ----
=item SvNV
! Coerce the given SV to a double and return it. See C<SvNVx> for a version
! which guarantees to evaluate sv only once.
NV SvNV(SV* sv)
***************
*** 2125,2134 ****
=for hackers
Found in file sv.h
=item SvNVX
! Returns the double which is stored in the SV, assuming SvNOK is
! true.
NV SvNVX(SV* sv)
--- 2234,2253 ----
=for hackers
Found in file sv.h
+ =item SvNVx
+
+ Coerces the given SV to a double and returns it. Guarantees to evaluate
+ sv only once. Use the more efficent C<SvNV> otherwise.
+
+ NV SvNVx(SV* sv)
+
+ =for hackers
+ Found in file sv.h
+
=item SvNVX
! Returns the raw value in the SV's NV slot, without checks or conversions.
! Only use when you are sure SvNOK is true. See also C<SvNV()>.
NV SvNVX(SV* sv)
***************
*** 2208,2214 ****
Tells an SV that it is a string and disables all other OK bits,
and leaves the UTF8 status as it was.
!
void SvPOK_only_UTF8(SV* sv)
=for hackers
--- 2327,2333 ----
Tells an SV that it is a string and disables all other OK bits,
and leaves the UTF8 status as it was.
!
void SvPOK_only_UTF8(SV* sv)
=for hackers
***************
*** 2217,2223 ****
=item SvPV
Returns a pointer to the string in the SV, or a stringified form of the SV
! if the SV does not contain a string. Handles 'get' magic.
char* SvPV(SV* sv, STRLEN len)
--- 2336,2343 ----
=item SvPV
Returns a pointer to the string in the SV, or a stringified form of the SV
! if the SV does not contain a string. Handles 'get' magic. See also
! C<SvPVx> for a version which guarantees to evaluate sv only once.
char* SvPV(SV* sv, STRLEN len)
***************
*** 2224,2232 ****
=for hackers
Found in file sv.h
=item SvPVX
! Returns a pointer to the string in the SV. The SV must contain a
string.
char* SvPVX(SV* sv)
--- 2344,2460 ----
=for hackers
Found in file sv.h
+ =item SvPVbyte
+
+ Like C<SvPV>, but converts sv to byte representation first if necessary.
+
+ char* SvPVbyte(SV* sv, STRLEN len)
+
+ =for hackers
+ Found in file sv.h
+
+ =item SvPVbytex
+
+ Like C<SvPV>, but converts sv to byte representation first if necessary.
+ Guarantees to evalute sv only once; use the more efficient C<SvPVbyte>
+ otherwise.
+
+
+ char* SvPVbytex(SV* sv, STRLEN len)
+
+ =for hackers
+ Found in file sv.h
+
+ =item SvPVbytex_force
+
+ Like C<SvPV_force>, but converts sv to byte representation first if necessary.
+ Guarantees to evalute sv only once; use the more efficient C<SvPVbyte_force>
+ otherwise.
+
+ char* SvPVbytex_force(SV* sv, STRLEN len)
+
+ =for hackers
+ Found in file sv.h
+
+ =item SvPVbyte_force
+
+ Like C<SvPV_force>, but converts sv to byte representation first if necessary.
+
+ char* SvPVbyte_force(SV* sv, STRLEN len)
+
+ =for hackers
+ Found in file sv.h
+
+ =item SvPVbyte_nolen
+
+ Like C<SvPV_nolen>, but converts sv to byte representation first if necessary.
+
+ char* SvPVbyte_nolen(SV* sv, STRLEN len)
+
+ =for hackers
+ Found in file sv.h
+
+ =item SvPVutf8
+
+ Like C<SvPV>, but converts sv to uft8 first if necessary.
+
+ char* SvPVutf8(SV* sv, STRLEN len)
+
+ =for hackers
+ Found in file sv.h
+
+ =item SvPVutf8x
+
+ Like C<SvPV>, but converts sv to uft8 first if necessary.
+ Guarantees to evalute sv only once; use the more efficient C<SvPVutf8>
+ otherwise.
+
+ char* SvPVutf8x(SV* sv, STRLEN len)
+
+ =for hackers
+ Found in file sv.h
+
+ =item SvPVutf8x_force
+
+ Like C<SvPV_force>, but converts sv to uft8 first if necessary.
+ Guarantees to evalute sv only once; use the more efficient C<SvPVutf8_force>
+ otherwise.
+
+ char* SvPVutf8x_force(SV* sv, STRLEN len)
+
+ =for hackers
+ Found in file sv.h
+
+ =item SvPVutf8_force
+
+ Like C<SvPV_force>, but converts sv to uft8 first if necessary.
+
+ char* SvPVutf8_force(SV* sv, STRLEN len)
+
+ =for hackers
+ Found in file sv.h
+
+ =item SvPVutf8_nolen
+
+ Like C<SvPV_nolen>, but converts sv to uft8 first if necessary.
+
+ char* SvPVutf8_nolen(SV* sv, STRLEN len)
+
+ =for hackers
+ Found in file sv.h
+
+ =item SvPVx
+
+ A version of C<SvPV> which guarantees to evaluate sv only once.
+
+ char* SvPVx(SV* sv, STRLEN len)
+
+ =for hackers
+ Found in file sv.h
+
=item SvPVX
! Returns a pointer to the physical string in the SV. The SV must contain a
string.
char* SvPVX(SV* sv)
***************
*** 2244,2249 ****
--- 2472,2487 ----
=for hackers
Found in file sv.h
+ =item SvPV_force_nomg
+
+ Like <SvPV> but will force the SV into becoming a string (SvPOK). You want
+ force if you are going to update the SvPVX directly. Doesn't process magic.
+
+ char* SvPV_force_nomg(SV* sv, STRLEN len)
+
+ =for hackers
+ Found in file sv.h
+
=item SvPV_nolen
Returns a pointer to the string in the SV, or a stringified form of the SV
***************
*** 2327,2332 ****
--- 2565,2588 ----
=for hackers
Found in file sv.h
+ =item SvSetMagicSV
+
+ Like C<SvSetSV>, but does any set magic required afterwards.
+
+ void SvSetMagicSV(SV* dsb, SV* ssv)
+
+ =for hackers
+ Found in file sv.h
+
+ =item SvSetMagicSV_nosteal
+
+ Like C<SvSetMagicSV>, but does any set magic required afterwards.
+
+ void SvSetMagicSV_nosteal(SV* dsv, SV* ssv)
+
+ =for hackers
+ Found in file sv.h
+
=item SvSetSV
Calls C<sv_setsv> if dsv is not the same as ssv. May evaluate arguments
***************
*** 2523,2529 ****
=item SvUV
! Coerces the given SV to an unsigned integer and returns it.
UV SvUV(SV* sv)
--- 2779,2786 ----
=item SvUV
! Coerces the given SV to an unsigned integer and returns it. See C<SvUVx>
! for a version which guarantees to evaluate sv only once.
UV SvUV(SV* sv)
***************
*** 2532,2539 ****
=item SvUVX
! Returns the unsigned integer which is stored in the SV, assuming SvIOK is
! true.
UV SvUVX(SV* sv)
--- 2789,2796 ----
=item SvUVX
! Returns the raw value in the SV's UV slot, without checks or conversions.
! Only use when you are sure SvIOK is true. See also C<SvUV()>.
UV SvUVX(SV* sv)
***************
*** 2540,2549 ****
=for hackers
Found in file sv.h
=item sv_2mortal
! Marks an SV as mortal. The SV will be destroyed when the current context
! ends.
SV* sv_2mortal(SV* sv)
--- 2797,2857 ----
=for hackers
Found in file sv.h
+ =item SvUVx
+
+ Coerces the given SV to an unsigned integer and returns it. Guarantees to
+ evaluate sv only once. Use the more efficent C<SvUV> otherwise.
+
+ UV SvUVx(SV* sv)
+
+ =for hackers
+ Found in file sv.h
+
+ =item sv_2bool
+
+ This function is only called on magical items, and is only used by
+ sv_true() or its macro equivalent.
+
+ bool sv_2bool(SV* sv)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_2cv
+
+ Using various gambits, try to get a CV from an SV; in addition, try if
+ possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
+
+ CV* sv_2cv(SV* sv, HV** st, GV** gvp, I32 lref)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_2io
+
+ Using various gambits, try to get an IO from an SV: the IO slot if its a
+ GV; or the recursive result if we're an RV; or the IO slot of the symbol
+ named after the PV if we're a string.
+
+ IO* sv_2io(SV* sv)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_2iv
+
+ Return the integer value of an SV, doing any necessary string conversion,
+ magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
+
+ IV sv_2iv(SV* sv)
+
+ =for hackers
+ Found in file sv.c
+
=item sv_2mortal
! Marks an existing SV as mortal. The SV will be destroyed when the current
! context ends. See also C<sv_newmortal> and C<sv_mortalcopy>.
SV* sv_2mortal(SV* sv)
***************
*** 2550,2555 ****
--- 2858,2966 ----
=for hackers
Found in file sv.c
+ =item sv_2nv
+
+ Return the num value of an SV, doing any necessary string or integer
+ conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
+ macros.
+
+ NV sv_2nv(SV* sv)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_2pvbyte
+
+ Return a pointer to the byte-encoded representation of the SV, and set *lp
+ to its length. May cause the SV to be downgraded from UTF8 as a
+ side-effect.
+
+ Usually accessed via the C<SvPVbyte> macro.
+
+ char* sv_2pvbyte(SV* sv, STRLEN* lp)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_2pvbyte_nolen
+
+ Return a pointer to the byte-encoded representation of the SV.
+ May cause the SV to be downgraded from UTF8 as a side-effect.
+
+ Usually accessed via the C<SvPVbyte_nolen> macro.
+
+ char* sv_2pvbyte_nolen(SV* sv)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_2pvutf8
+
+ Return a pointer to the UTF8-encoded representation of the SV, and set *lp
+ to its length. May cause the SV to be upgraded to UTF8 as a side-effect.
+
+ Usually accessed via the C<SvPVutf8> macro.
+
+ char* sv_2pvutf8(SV* sv, STRLEN* lp)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_2pvutf8_nolen
+
+ Return a pointer to the UTF8-encoded representation of the SV.
+ May cause the SV to be upgraded to UTF8 as a side-effect.
+
+ Usually accessed via the C<SvPVutf8_nolen> macro.
+
+ char* sv_2pvutf8_nolen(SV* sv)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_2pv_flags
+
+ Returns a pointer to the string value of an SV, and sets *lp to its length.
+ If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
+ if necessary.
+ Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
+ usually end up here too.
+
+ char* sv_2pv_flags(SV* sv, STRLEN* lp, I32 flags)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_2pv_nolen
+
+ Like C<sv_2pv()>, but doesn't return the length too. You should usually
+ use the macro wrapper C<SvPV_nolen(sv)> instead.
+ char* sv_2pv_nolen(SV* sv)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_2uv
+
+ Return the unsigned integer value of an SV, doing any necessary string
+ conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
+ macros.
+
+ UV sv_2uv(SV* sv)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_backoff
+
+ Remove any string offset. You should normally use the C<SvOOK_off> macro
+ wrapper instead.
+
+ int sv_backoff(SV* sv)
+
+ =for hackers
+ Found in file sv.c
+
=item sv_bless
Blesses an SV into a specified package. The SV must be an RV. The package
***************
*** 2608,2613 ****
--- 3019,3038 ----
=for hackers
Found in file sv.c
+ =item sv_catpvn_flags
+
+ Concatenates the string onto the end of the string which is in the SV. The
+ C<len> indicates number of bytes to copy. If the SV has the UTF8
+ status set, then the bytes appended should be valid UTF8.
+ If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
+ appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
+ in terms of this function.
+
+ void sv_catpvn_flags(SV* sv, const char* ptr, STRLEN len, I32 flags)
+
+ =for hackers
+ Found in file sv.c
+
=item sv_catpvn_mg
Like C<sv_catpvn>, but also handles 'set' magic.
***************
*** 2637,2642 ****
--- 3062,3079 ----
=for hackers
Found in file sv.c
+ =item sv_catsv_flags
+
+ Concatenates the string from SV C<ssv> onto the end of the string in
+ SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
+ bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
+ and C<sv_catsv_nomg> are implemented in terms of this function.
+
+ void sv_catsv_flags(SV* dsv, SV* ssv, I32 flags)
+
+ =for hackers
+ Found in file sv.c
+
=item sv_catsv_mg
Like C<sv_catsv>, but also handles 'set' magic.
***************
*** 2651,2657 ****
Efficient removal of characters from the beginning of the string buffer.
SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
the string buffer. The C<ptr> becomes the first character of the adjusted
! string.
void sv_chop(SV* sv, char* ptr)
--- 3088,3094 ----
Efficient removal of characters from the beginning of the string buffer.
SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
the string buffer. The C<ptr> becomes the first character of the adjusted
! string. Uses the "OOK hack".
void sv_chop(SV* sv, char* ptr)
***************
*** 2660,2667 ****
=item sv_clear
! Clear an SV, making it empty. Does not free the memory used by the SV
! itself.
void sv_clear(SV* sv)
--- 3097,3109 ----
=item sv_clear
! Clear an SV: call any destructors, free up any memory used by the body,
! and free the body itself. The SV's head is I<not> freed, although
! its type is set to all 1's so that it won't inadvertently be assumed
! to be live during global destruction etc.
! This function should only be called when REFCNT is zero. Most of the time
! you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
! instead.
void sv_clear(SV* sv)
***************
*** 2672,2678 ****
Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
string in C<sv1> is less than, equal to, or greater than the string in
! C<sv2>.
I32 sv_cmp(SV* sv1, SV* sv2)
--- 3114,3121 ----
Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
string in C<sv1> is less than, equal to, or greater than the string in
! C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
! coerce its args to strings if necessary. See also C<sv_cmp_locale>.
I32 sv_cmp(SV* sv1, SV* sv2)
***************
*** 2681,2688 ****
=item sv_cmp_locale
! Compares the strings in two SVs in a locale-aware manner. See
! L</sv_cmp_locale>
I32 sv_cmp_locale(SV* sv1, SV* sv2)
--- 3124,3132 ----
=item sv_cmp_locale
! Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
! 'use bytes' aware, handles get magic, and will coerce its args to strings
! if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
I32 sv_cmp_locale(SV* sv1, SV* sv2)
***************
*** 2689,2697 ****
=for hackers
Found in file sv.c
=item sv_dec
! Auto-decrement of the value in the SV.
void sv_dec(SV* sv)
--- 3133,3156 ----
=for hackers
Found in file sv.c
+ =item sv_collxfrm
+
+ Add Collate Transform magic to an SV if it doesn't already have it.
+
+ Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
+ scalar data of the variable, but transformed to such a format that a normal
+ memory comparison can be used to compare the data according to the locale
+ settings.
+
+ char* sv_collxfrm(SV* sv, STRLEN* nxp)
+
+ =for hackers
+ Found in file sv.c
+
=item sv_dec
! Auto-decrement of the value in the SV, doing string to numeric conversion
! if necessary. Handles 'get' magic.
void sv_dec(SV* sv)
***************
*** 2712,2718 ****
=item sv_eq
Returns a boolean indicating whether the strings in the two SVs are
! identical.
I32 sv_eq(SV* sv1, SV* sv2)
--- 3171,3178 ----
=item sv_eq
Returns a boolean indicating whether the strings in the two SVs are
! identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
! coerce its args to strings if necessary.
I32 sv_eq(SV* sv1, SV* sv2)
***************
*** 2719,2727 ****
=for hackers
Found in file sv.c
=item sv_free
! Free the memory used by an SV.
void sv_free(SV* sv)
--- 3179,3213 ----
=for hackers
Found in file sv.c
+ =item sv_force_normal
+
+ Undo various types of fakery on an SV: if the PV is a shared string, make
+ a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
+ an xpvmg. See also C<sv_force_normal_flags>.
+
+ void sv_force_normal(SV *sv)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_force_normal_flags
+
+ Undo various types of fakery on an SV: if the PV is a shared string, make
+ a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
+ an xpvmg. The C<flags> parameter gets passed to C<sv_unref_flags()>
+ when unrefing. C<sv_force_normal> calls this function with flags set to 0.
+
+ void sv_force_normal_flags(SV *sv, U32 flags)
+
+ =for hackers
+ Found in file sv.c
+
=item sv_free
! Decrement an SV's reference count, and if it drops to zero, call
! C<sv_clear> to invoke destructors and free up any memory used by
! the body; finally, deallocate the SV's head itself.
! Normally called via a wrapper macro C<SvREFCNT_dec>.
void sv_free(SV* sv)
***************
*** 2740,2748 ****
=item sv_grow
! Expands the character buffer in the SV. This will use C<sv_unref> and will
! upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
! Use C<SvGROW>.
char* sv_grow(SV* sv, STRLEN newlen)
--- 3226,3234 ----
=item sv_grow
! Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
! upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
! Use the C<SvGROW> wrapper instead.
char* sv_grow(SV* sv, STRLEN newlen)
***************
*** 2751,2757 ****
=item sv_inc
! Auto-increment of the value in the SV.
void sv_inc(SV* sv)
--- 3237,3244 ----
=item sv_inc
! Auto-increment of the value in the SV, doing string to numeric conversion
! if necessary. Handles 'get' magic.
void sv_inc(SV* sv)
***************
*** 2790,2798 ****
=for hackers
Found in file sv.c
=item sv_len
! Returns the length of the string in the SV. See also C<SvCUR>.
STRLEN sv_len(SV* sv)
--- 3277,3296 ----
=for hackers
Found in file sv.c
+ =item sv_iv
+
+ A private implementation of the C<SvIVx> macro for compilers which can't
+ cope with complex macro expressions. Always use the macro instead.
+
+ IV sv_iv(SV* sv)
+
+ =for hackers
+ Found in file sv.c
+
=item sv_len
! Returns the length of the string in the SV. Handles magic and type
! coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
STRLEN sv_len(SV* sv)
***************
*** 2802,2808 ****
=item sv_len_utf8
Returns the number of characters in the string in an SV, counting wide
! UTF8 bytes as a single character.
STRLEN sv_len_utf8(SV* sv)
--- 3300,3306 ----
=item sv_len_utf8
Returns the number of characters in the string in an SV, counting wide
! UTF8 bytes as a single character. Handles magic and type coercion.
STRLEN sv_len_utf8(SV* sv)
***************
*** 2811,2818 ****
=item sv_magic
! Adds magic to an SV.
void sv_magic(SV* sv, SV* obj, int how, const char* name, I32 namlen)
=for hackers
--- 3309,3319 ----
=item sv_magic
! Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
! then adds a new magic item of type C<how> to the head of the magic list.
+ C<name> is assumed to contain an C<SV*> if C<(name && namelen == HEf_SVKEY)>
+
void sv_magic(SV* sv, SV* obj, int how, const char* name, I32 namlen)
=for hackers
***************
*** 2820,2827 ****
=item sv_mortalcopy
! Creates a new SV which is a copy of the original SV. The new SV is marked
! as mortal.
SV* sv_mortalcopy(SV* oldsv)
--- 3321,3329 ----
=item sv_mortalcopy
! Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
! The new SV is marked as mortal. It will be destroyed when the current
! context ends. See also C<sv_newmortal> and C<sv_2mortal>.
SV* sv_mortalcopy(SV* oldsv)
***************
*** 2830,2836 ****
=item sv_newmortal
! Creates a new SV which is mortal. The reference count of the SV is set to 1.
SV* sv_newmortal()
--- 3332,3340 ----
=item sv_newmortal
! Creates a new null SV which is mortal. The reference count of the SV is
! set to 1. It will be destroyed when the current context ends. See
! also C<sv_mortalcopy> and C<sv_2mortal>.
SV* sv_newmortal()
***************
*** 2837,2845 ****
--- 3341,3448 ----
=for hackers
Found in file sv.c
+ =item sv_newref
+
+ Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
+ instead.
+
+ SV* sv_newref(SV* sv)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_nv
+
+ A private implementation of the C<SvNVx> macro for compilers which can't
+ cope with complex macro expressions. Always use the macro instead.
+
+ NV sv_nv(SV* sv)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_pos_b2u
+
+ Converts the value pointed to by offsetp from a count of bytes from the
+ start of the string, to a count of the equivalent number of UTF8 chars.
+ Handles magic and type coercion.
+
+ void sv_pos_b2u(SV* sv, I32* offsetp)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_pos_u2b
+
+ Converts the value pointed to by offsetp from a count of UTF8 chars from
+ the start of the string, to a count of the equivalent number of bytes; if
+ lenp is non-zero, it does the same to lenp, but this time starting from
+ the offset, rather than from the start of the string. Handles magic and
+ type coercion.
+
+ void sv_pos_u2b(SV* sv, I32* offsetp, I32* lenp)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_pv
+
+ A private implementation of the C<SvPV_nolen> macro for compilers which can't
+ cope with complex macro expressions. Always use the macro instead.
+
+ char* sv_pv(SV *sv)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_pvbyte
+
+ A private implementation of the C<SvPVbyte_nolen> macro for compilers
+ which can't cope with complex macro expressions. Always use the macro
+ instead.
+
+ char* sv_pvbyte(SV *sv)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_pvbyten
+
+ A private implementation of the C<SvPVbyte> macro for compilers
+ which can't cope with complex macro expressions. Always use the macro
+ instead.
+
+ char* sv_pvbyten(SV *sv, STRLEN *len)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_pvbyten_force
+
+ A private implementation of the C<SvPVbytex_force> macro for compilers
+ which can't cope with complex macro expressions. Always use the macro
+ instead.
+
+ char* sv_pvbyten_force(SV* sv, STRLEN* lp)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_pvn
+
+ A private implementation of the C<SvPV> macro for compilers which can't
+ cope with complex macro expressions. Always use the macro instead.
+
+ char* sv_pvn(SV *sv, STRLEN *len)
+
+ =for hackers
+ Found in file sv.c
+
=item sv_pvn_force
Get a sensible string out of the SV somehow.
+ A private implementation of the C<SvPV_force> macro for compilers which
+ can't cope with complex macro expressions. Always use the macro instead.
char* sv_pvn_force(SV* sv, STRLEN* lp)
***************
*** 2846,2855 ****
=for hackers
Found in file sv.c
=item sv_pvutf8n_force
! Get a sensible UTF8-encoded string out of the SV somehow. See
! L</sv_pvn_force>.
char* sv_pvutf8n_force(SV* sv, STRLEN* lp)
--- 3449,3495 ----
=for hackers
Found in file sv.c
+ =item sv_pvn_force_flags
+
+ Get a sensible string out of the SV somehow.
+ If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
+ appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
+ implemented in terms of this function.
+ You normally want to use the various wrapper macros instead: see
+ C<SvPV_force> and C<SvPV_force_nomg>
+
+ char* sv_pvn_force_flags(SV* sv, STRLEN* lp, I32 flags)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_pvutf8
+
+ A private implementation of the C<SvPVutf8_nolen> macro for compilers
+ which can't cope with complex macro expressions. Always use the macro
+ instead.
+
+ char* sv_pvutf8(SV *sv)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_pvutf8n
+
+ A private implementation of the C<SvPVutf8> macro for compilers
+ which can't cope with complex macro expressions. Always use the macro
+ instead.
+
+ char* sv_pvutf8n(SV *sv, STRLEN *len)
+
+ =for hackers
+ Found in file sv.c
+
=item sv_pvutf8n_force
! A private implementation of the C<SvPVutf8_force> macro for compilers
! which can't cope with complex macro expressions. Always use the macro
! instead.
char* sv_pvutf8n_force(SV* sv, STRLEN* lp)
***************
*** 2868,2873 ****
--- 3508,3518 ----
=item sv_replace
Make the first argument a copy of the second, then delete the original.
+ The target SV physically takes over ownership of the body of the source SV
+ and inherits its flags; however, the target keeps any magic it owns,
+ and any magic in the source is discarded.
+ Note that this is a rather specialist SV copying operation; most of the
+ time you'll want to use C<sv_setsv> or one of its many macro front-ends.
void sv_replace(SV* sv, SV* nsv)
***************
*** 2874,2882 ****
=for hackers
Found in file sv.c
=item sv_rvweaken
! Weaken a reference.
SV* sv_rvweaken(SV *sv)
--- 3519,3549 ----
=for hackers
Found in file sv.c
+ =item sv_report_used
+
+ Dump the contents of all SVs not yet freed. (Debugging aid).
+
+ void sv_report_used()
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_reset
+
+ Underlying implementation for the C<reset> Perl function.
+ Note that the perl-level function is vaguely deprecated.
+
+ void sv_reset(char* s, HV* stash)
+
+ =for hackers
+ Found in file sv.c
+
=item sv_rvweaken
! Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
! referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
! push a back-reference to this RV onto the array of backreferences
! associated with that magic.
SV* sv_rvweaken(SV *sv)
***************
*** 2885,2892 ****
=item sv_setiv
! Copies an integer into the given SV. Does not handle 'set' magic. See
! C<sv_setiv_mg>.
void sv_setiv(SV* sv, IV num)
--- 3552,3559 ----
=item sv_setiv
! Copies an integer into the given SV, upgrading first if necessary.
! Does not handle 'set' magic. See also C<sv_setiv_mg>.
void sv_setiv(SV* sv, IV num)
***************
*** 2904,2911 ****
=item sv_setnv
! Copies a double into the given SV. Does not handle 'set' magic. See
! C<sv_setnv_mg>.
void sv_setnv(SV* sv, NV num)
--- 3571,3578 ----
=item sv_setnv
! Copies a double into the given SV, upgrading first if necessary.
! Does not handle 'set' magic. See also C<sv_setnv_mg>.
void sv_setnv(SV* sv, NV num)
***************
*** 3073,3088 ****
=item sv_setsv
! Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
! The source SV may be destroyed if it is mortal. Does not handle 'set'
! magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
! C<sv_setsv_mg>.
void sv_setsv(SV* dsv, SV* ssv)
=for hackers
Found in file sv.c
=item sv_setsv_mg
Like C<sv_setsv>, but also handles 'set' magic.
--- 3740,3784 ----
=item sv_setsv
! Copies the contents of the source SV C<ssv> into the destination SV
! C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
! function if the source SV needs to be reused. Does not handle 'set' magic.
! Loosely speaking, it performs a copy-by-value, obliterating any previous
! content of the destination.
+ You probably want to use one of the assortment of wrappers, such as
+ C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
+ C<SvSetMagicSV_nosteal>.
+
+
void sv_setsv(SV* dsv, SV* ssv)
=for hackers
Found in file sv.c
+ =item sv_setsv_flags
+
+ Copies the contents of the source SV C<ssv> into the destination SV
+ C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
+ function if the source SV needs to be reused. Does not handle 'set' magic.
+ Loosely speaking, it performs a copy-by-value, obliterating any previous
+ content of the destination.
+ If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
+ C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
+ implemented in terms of this function.
+
+ You probably want to use one of the assortment of wrappers, such as
+ C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
+ C<SvSetMagicSV_nosteal>.
+
+ This is the primary function for copying scalars, and most other
+ copy-ish functions and macros use this underneath.
+
+ void sv_setsv_flags(SV* dsv, SV* ssv, I32 flags)
+
+ =for hackers
+ Found in file sv.c
+
=item sv_setsv_mg
Like C<sv_setsv>, but also handles 'set' magic.
***************
*** 3094,3101 ****
=item sv_setuv
! Copies an unsigned integer into the given SV. Does not handle 'set' magic.
! See C<sv_setuv_mg>.
void sv_setuv(SV* sv, UV num)
--- 3790,3797 ----
=item sv_setuv
! Copies an unsigned integer into the given SV, upgrading first if necessary.
! Does not handle 'set' magic. See also C<sv_setuv_mg>.
void sv_setuv(SV* sv, UV num)
***************
*** 3111,3119 ****
--- 3807,3833 ----
=for hackers
Found in file sv.c
+ =item sv_taint
+
+ Taint an SV. Use C<SvTAINTED_on> instead.
+ void sv_taint(SV* sv)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_tainted
+
+ Test an SV for taintedness. Use C<SvTAINTED> instead.
+ bool sv_tainted(SV* sv)
+
+ =for hackers
+ Found in file sv.c
+
=item sv_true
Returns true if the SV has a true value by Perl's rules.
+ Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
+ instead use an in-line version.
I32 sv_true(SV *sv)
***************
*** 3122,3128 ****
=item sv_unmagic
! Removes magic from an SV.
int sv_unmagic(SV* sv, int type)
--- 3836,3842 ----
=item sv_unmagic
! Removes all magic of type C<type> from an SV.
int sv_unmagic(SV* sv, int type)
***************
*** 3156,3165 ****
=for hackers
Found in file sv.c
=item sv_upgrade
! Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
! C<svtype>.
bool sv_upgrade(SV* sv, U32 mt)
--- 3870,3888 ----
=for hackers
Found in file sv.c
+ =item sv_untaint
+
+ Untaint an SV. Use C<SvTAINTED_off> instead.
+ void sv_untaint(SV* sv)
+
+ =for hackers
+ Found in file sv.c
+
=item sv_upgrade
! Upgrade an SV to a more complex form. Generally adds a new body type to the
! SV, then copies across as much information as possible from the old body.
! You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
bool sv_upgrade(SV* sv, U32 mt)
***************
*** 3193,3199 ****
=item sv_utf8_decode
Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
! turn of SvUTF8 if needed so that we see characters. Used as a building block
for decode_utf8 in Encode.xs
NOTE: this function is experimental and may change or be
--- 3916,3922 ----
=item sv_utf8_decode
Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
! turn off SvUTF8 if needed so that we see characters. Used as a building block
for decode_utf8 in Encode.xs
NOTE: this function is experimental and may change or be
***************
*** 3233,3239 ****
=item sv_utf8_upgrade
Convert the PV of an SV to its UTF8-encoded form.
! Forces the SV to string form it it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
if all the bytes have hibit clear.
--- 3956,3962 ----
=item sv_utf8_upgrade
Convert the PV of an SV to its UTF8-encoded form.
! Forces the SV to string form if it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
if all the bytes have hibit clear.
***************
*** 3242,3247 ****
--- 3965,3994 ----
=for hackers
Found in file sv.c
+ =item sv_utf8_upgrade_flags
+
+ Convert the PV of an SV to its UTF8-encoded form.
+ Forces the SV to string form if it is not already.
+ Always sets the SvUTF8 flag to avoid future validity checks even
+ if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
+ will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
+ C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
+
+ STRLEN sv_utf8_upgrade_flags(SV *sv, I32 flags)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_uv
+
+ A private implementation of the C<SvUVx> macro for compilers which can't
+ cope with complex macro expressions. Always use the macro instead.
+
+ UV sv_uv(SV* sv)
+
+ =for hackers
+ Found in file sv.c
+
=item sv_vcatpvfn
Processes its arguments like C<vsprintf> and appends the formatted output
***************
*** 3250,3255 ****
--- 3997,4004 ----
C<maybe_tainted> if results are untrustworthy (often due to the use of
locales).
+ Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
+
void sv_vcatpvfn(SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted)
=for hackers
***************
*** 3259,3264 ****
--- 4008,4015 ----
Works like C<vcatpvfn> but copies the text into the SV instead of
appending it.
+
+ Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
void sv_vsetpvfn(SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted)
diff -c 'perl-5.7.1/pod/perlbook.pod' 'perl-5.7.2/pod/perlbook.pod'
Index: ./pod/perlbook.pod
*** ./pod/perlbook.pod Tue Mar 6 04:06:23 2001
--- ./pod/perlbook.pod Mon Jul 9 17:11:11 2001
***************
*** 4,10 ****
=head1 DESCRIPTION
! The Camel Book, officially known as I<Programming Perl, Second Edition>,
by Larry Wall et al, is the definitive reference work covering nearly
all of Perl. You can order it and other Perl books from O'Reilly &
Associates, 1-800-998-9938. Local/overseas is +1 707 829 0515. If you
--- 4,10 ----
=head1 DESCRIPTION
! The Camel Book, officially known as I<Programming Perl, Third Edition>,
by Larry Wall et al, is the definitive reference work covering nearly
all of Perl. You can order it and other Perl books from O'Reilly &
Associates, 1-800-998-9938. Local/overseas is +1 707 829 0515. If you
diff -c 'perl-5.7.1/pod/perldata.pod' 'perl-5.7.2/pod/perldata.pod'
Index: ./pod/perldata.pod
*** ./pod/perldata.pod Fri Mar 9 03:16:24 2001
--- ./pod/perldata.pod Mon Jul 9 17:11:11 2001
***************
*** 271,281 ****
12345
12345.67
.23E-10 # a very small number
! 4_294_967_296 # underline for legibility
0xff # hex
0377 # octal
0b011011 # binary
String literals are usually delimited by either single or double
quotes. They work much like quotes in the standard Unix shells:
double-quoted string literals are subject to backslash and variable
--- 271,288 ----
12345
12345.67
.23E-10 # a very small number
! 3.14_15_92 # a very important number
! 4_294_967_296 # underscore for legibility
0xff # hex
+ 0xdead_beef # more hex
0377 # octal
0b011011 # binary
+ You are allowed to use underscores (underbars) in numeric literals
+ between digits for legibility. You could, for example, group binary
+ digits by threes (as for a Unix-style mode argument such as 0b110_100_100)
+ or by fours (to represent nibbles, as in 0b1010_0110) or in other groups.
+
String literals are usually delimited by either single or double
quotes. They work much like quotes in the standard Unix shells:
double-quoted string literals are subject to backslash and variable
***************
*** 558,564 ****
array had been interpolated at that point.
This interpolation combines with the facts that the opening
! and closing parentheses are optional (except necessary for
precedence) and lists may end with an optional comma to mean that
multiple commas within lists are legal syntax. The list C<1,,3> is a
concatenation of two lists, C<1,> and C<3>, the first of which ends
--- 565,571 ----
array had been interpolated at that point.
This interpolation combines with the facts that the opening
! and closing parentheses are optional (except when necessary for
precedence) and lists may end with an optional comma to mean that
multiple commas within lists are legal syntax. The list C<1,,3> is a
concatenation of two lists, C<1,> and C<3>, the first of which ends
***************
*** 604,610 ****
context, because most list functions return a null list when finished,
which when assigned produces a 0, which is interpreted as FALSE.
! The final element may be an array or a hash:
($a, $b, @rest) = split;
my($a, $b, %rest) = @_;
--- 611,637 ----
context, because most list functions return a null list when finished,
which when assigned produces a 0, which is interpreted as FALSE.
! It's also the source of a useful idiom for executing a function or
! performing an operation in list context and then counting the number of
! return values, by assigning to an empty list and then using that
! assignment in scalar context. For example, this code:
!
! $count = () = $string =~ /\d+/g;
!
! will place into $count the number of digit groups found in $string.
! This happens because the pattern match is in list context (since it
! is being assigned to the empty list), and will therefore return a list
! of all matching parts of the string. The list assignment in scalar
! context will translate that into the number of elements (here, the
! number of times the pattern matched) and assign that to $count. Note
! that simply using
!
! $count = $string =~ /\d+/g;
!
! would not have worked, since a pattern match in scalar context will
! only return true or false, rather than a count of matches.
!
! The final element of a list assignment may be an array or a hash:
($a, $b, @rest) = split;
my($a, $b, %rest) = @_;
diff -c 'perl-5.7.1/pod/perldebguts.pod' 'perl-5.7.2/pod/perldebguts.pod'
Index: ./pod/perldebguts.pod
*** ./pod/perldebguts.pod Tue Mar 6 04:06:24 2001
--- ./pod/perldebguts.pod Mon Jul 9 17:11:11 2001
***************
*** 364,396 ****
The debugging output at compile time looks like this:
! compiling RE `[bc]d(ef*g)+h[ij]k$'
! size 43 first at 1
! 1: ANYOF(11)
! 11: EXACT <d>(13)
! 13: CURLYX {1,32767}(27)
! 15: OPEN1(17)
! 17: EXACT <e>(19)
! 19: STAR(22)
! 20: EXACT <f>(0)
! 22: EXACT <g>(24)
! 24: CLOSE1(26)
! 26: WHILEM(0)
! 27: NOTHING(28)
! 28: EXACT <h>(30)
! 30: ANYOF(40)
! 40: EXACT <k>(42)
! 42: EOL(43)
! 43: END(0)
! anchored `de' at 1 floating `gh' at 3..2147483647 (checking floating)
! stclass `ANYOF' minlen 7
The first line shows the pre-compiled form of the regex. The second
shows the size of the compiled form (in arbitrary units, usually
! 4-byte words) and the label I<id> of the first node that does a
! match.
! The last line (split into two lines above) contains optimizer
information. In the example shown, the optimizer found that the match
should contain a substring C<de> at offset 1, plus substring C<gh>
at some offset between 3 and infinity. Moreover, when checking for
--- 364,411 ----
The debugging output at compile time looks like this:
! Compiling REx `[bc]d(ef*g)+h[ij]k$'
! size 45 Got 364 bytes for offset annotations.
! first at 1
! rarest char g at 0
! rarest char d at 0
! 1: ANYOF[bc](12)
! 12: EXACT <d>(14)
! 14: CURLYX[0] {1,32767}(28)
! 16: OPEN1(18)
! 18: EXACT <e>(20)
! 20: STAR(23)
! 21: EXACT <f>(0)
! 23: EXACT <g>(25)
! 25: CLOSE1(27)
! 27: WHILEM[1/1](0)
! 28: NOTHING(29)
! 29: EXACT <h>(31)
! 31: ANYOF[ij](42)
! 42: EXACT <k>(44)
! 44: EOL(45)
! 45: END(0)
! anchored `de' at 1 floating `gh' at 3..2147483647 (checking floating)
! stclass `ANYOF[bc]' minlen 7
! Offsets: [45]
! 1[4] 0[0] 0[0] 0[0] 0[0] 0[0] 0[0] 0[0] 0[0] 0[0] 0[0] 5[1]
! 0[0] 12[1] 0[0] 6[1] 0[0] 7[1] 0[0] 9[1] 8[1] 0[0] 10[1] 0[0]
! 11[1] 0[0] 12[0] 12[0] 13[1] 0[0] 14[4] 0[0] 0[0] 0[0] 0[0]
! 0[0] 0[0] 0[0] 0[0] 0[0] 0[0] 18[1] 0[0] 19[1] 20[0]
! Omitting $` $& $' support.
The first line shows the pre-compiled form of the regex. The second
shows the size of the compiled form (in arbitrary units, usually
! 4-byte words) and the total number of bytes allocated for the
! offset/length table, usually 4+C<size>*8. The next line shows the
! label I<id> of the first node that does a match.
! The
!
! anchored `de' at 1 floating `gh' at 3..2147483647 (checking floating)
! stclass `ANYOF[bc]' minlen 7
!
! line (split into two lines above) contains optimizer
information. In the example shown, the optimizer found that the match
should contain a substring C<de> at offset 1, plus substring C<gh>
at some offset between 3 and infinity. Moreover, when checking for
***************
*** 397,406 ****
these substrings (to abandon impossible matches quickly), Perl will check
for the substring C<gh> before checking for the substring C<de>. The
optimizer may also use the knowledge that the match starts (at the
! C<first> I<id>) with a character class, and the match cannot be
! shorter than 7 chars.
! The fields of interest which may appear in the last line are
=over 4
--- 412,421 ----
these substrings (to abandon impossible matches quickly), Perl will check
for the substring C<gh> before checking for the substring C<de>. The
optimizer may also use the knowledge that the match starts (at the
! C<first> I<id>) with a character class, and no string
! shorter than 7 characters can possibly match.
! The fields of interest which may appear in this line are
=over 4
***************
*** 428,434 ****
=item C<isall>
! Means that the optimizer info is all that the regular
expression contains, and thus one does not need to enter the regex engine at
all.
--- 443,449 ----
=item C<isall>
! Means that the optimizer information is all that the regular
expression contains, and thus one does not need to enter the regex engine at
all.
***************
*** 459,470 ****
If a substring is known to match at end-of-line only, it may be
followed by C<$>, as in C<floating `k'$>.
! The optimizer-specific info is used to avoid entering (a slow) regex
! engine on strings that will not definitely match. If C<isall> flag
is set, a call to the regex engine may be avoided even when the optimizer
found an appropriate place for the match.
! The rest of the output contains the list of I<nodes> of the compiled
form of the regex. Each line has format
C< >I<id>: I<TYPE> I<OPTIONAL-INFO> (I<next-id>)
--- 474,485 ----
If a substring is known to match at end-of-line only, it may be
followed by C<$>, as in C<floating `k'$>.
! The optimizer-specific information is used to avoid entering (a slow) regex
! engine on strings that will not definitely match. If the C<isall> flag
is set, a call to the regex engine may be avoided even when the optimizer
found an appropriate place for the match.
! Above the optimizer section is the list of I<nodes> of the compiled
form of the regex. Each line has format
C< >I<id>: I<TYPE> I<OPTIONAL-INFO> (I<next-id>)
***************
*** 582,587 ****
--- 597,632 ----
# This is not really a node, but an optimized away piece of a "long" node.
# To simplify debugging output, we mark it as if it were a node
OPTIMIZED off Placeholder for dump.
+
+ =for unprinted-credits
+ Next section M-J. Dominus (mjd-perl-patch+@plover.com) 20010421
+
+ Following the optimizer information is a dump of the offset/length
+ table, here split across several lines:
+
+ Offsets: [45]
+ 1[4] 0[0] 0[0] 0[0] 0[0] 0[0] 0[0] 0[0] 0[0] 0[0] 0[0] 5[1]
+ 0[0] 12[1] 0[0] 6[1] 0[0] 7[1] 0[0] 9[1] 8[1] 0[0] 10[1] 0[0]
+ 11[1] 0[0] 12[0] 12[0] 13[1] 0[0] 14[4] 0[0] 0[0] 0[0] 0[0]
+ 0[0] 0[0] 0[0] 0[0] 0[0] 0[0] 18[1] 0[0] 19[1] 20[0]
+
+ The first line here indicates that the offset/length table contains 45
+ entries. Each entry is a pair of integers, denoted by C<offset[length]>.
+ Entries are numbered starting with, so entry #1 here is C<1[4]> and
+ entry #12 is C<5[1]>. C<1[4]> indicates that the node labeled C<1:>
+ (the C<1: ANYOF[bc]>) begins at character position 1 in the
+ pre-compiled form of the regex, and has a length of 4 characters.
+ C<5[1]> in position 12
+ indicates that the node labeled C<12:>
+ (the C<< 12: EXACT <d> >>) begins at character position 5 in the
+ pre-compiled form of the regex, and has a length of 1 character.
+ C<12[1]> in position 14
+ indicates that the node labeled C<14:>
+ (the C<< 14: CURLYX[0] {1,32767} >>) begins at character position 12 in the
+ pre-compiled form of the regex, and has a length of 1 character---that
+ is, it corresponds to the C<+> symbol in the precompiled regex.
+
+ C<0[0]> items indicate that there is no corresponding node.
=head2 Run-time output
diff -c 'perl-5.7.1/pod/perldebtut.pod' 'perl-5.7.2/pod/perldebtut.pod'
Index: ./pod/perldebtut.pod
*** ./pod/perldebtut.pod Fri Mar 16 04:51:59 2001
--- ./pod/perldebtut.pod Mon Jul 9 17:11:11 2001
***************
*** 666,672 ****
You don't have to do this all on the command line, though, there are a few GUI
options out there. The nice thing about these is you can wave a mouse over a
! variable and a dump of it's data will appear in an appropriate window, or in a
popup balloon, no more tiresome typing of 'x $varname' :-)
In particular have a hunt around for the following:
--- 666,672 ----
You don't have to do this all on the command line, though, there are a few GUI
options out there. The nice thing about these is you can wave a mouse over a
! variable and a dump of its data will appear in an appropriate window, or in a
popup balloon, no more tiresome typing of 'x $varname' :-)
In particular have a hunt around for the following:
diff -c 'perl-5.7.1/pod/perldebug.pod' 'perl-5.7.2/pod/perldebug.pod'
Index: ./pod/perldebug.pod
*** ./pod/perldebug.pod Sun Apr 1 22:02:11 2001
--- ./pod/perldebug.pod Mon Jul 9 17:11:11 2001
***************
*** 182,191 ****
--- 182,193 ----
=item /pattern/
Search forwards for pattern (a Perl regex); final / is optional.
+ The search is case-insensitive by default.
=item ?pattern?
Search backwards for pattern; final ? is optional.
+ The search is case-insensitive by default.
=item L
***************
*** 554,559 ****
--- 556,565 ----
Length to truncate the argument list when the C<frame> option's
bit 4 is set.
+
+ =item C<windowSize>
+
+ Change the size of code list window (default is 10 lines).
=back
diff -c 'perl-5.7.1/pod/perldiag.pod' 'perl-5.7.2/pod/perldiag.pod'
Index: ./pod/perldiag.pod
*** ./pod/perldiag.pod Thu Apr 5 07:05:18 2001
--- ./pod/perldiag.pod Thu Jul 12 08:23:11 2001
***************
*** 72,78 ****
imported with the C<use subs> pragma).
To silently interpret it as the Perl operator, use the C<CORE::> prefix
! on the operator (e.g. C<CORE::log($x)>) or by declaring the subroutine
to be an object method (see L<perlsub/"Subroutine Attributes"> or
L<attributes>).
--- 72,78 ----
imported with the C<use subs> pragma).
To silently interpret it as the Perl operator, use the C<CORE::> prefix
! on the operator (e.g. C<CORE::log($x)>) or declare the subroutine
to be an object method (see L<perlsub/"Subroutine Attributes"> or
L<attributes>).
***************
*** 112,119 ****
=item Applying %s to %s will act on scalar(%s)
! (W misc) The pattern match (//), substitution (s///), and
! transliteration (tr///) operators work on scalar values. If you apply
one of them to an array or a hash, it will convert the array or hash to
a scalar value -- the length of an array, or the population info of a
hash -- and then work on that scalar value. This is probably not what
--- 112,119 ----
=item Applying %s to %s will act on scalar(%s)
! (W misc) The pattern match (C<//>), substitution (C<s///>), and
! transliteration (C<tr///>) operators work on scalar values. If you apply
one of them to an array or a hash, it will convert the array or hash to
a scalar value -- the length of an array, or the population info of a
hash -- and then work on that scalar value. This is probably not what
***************
*** 184,190 ****
=item Negative offset to vec in lvalue context
! (F) When vec is called in an lvalue context, the second argument must be
greater than or equal to zero.
=item Attempt to bless into a reference
--- 184,190 ----
=item Negative offset to vec in lvalue context
! (F) When C<vec> is called in an lvalue context, the second argument must be
greater than or equal to zero.
=item Attempt to bless into a reference
***************
*** 270,276 ****
=item Bad evalled substitution pattern
! (F) You've used the /e switch to evaluate the replacement for a
substitution, but perl found a syntax error in the code to evaluate,
most likely an unexpected right brace '}'.
--- 270,276 ----
=item Bad evalled substitution pattern
! (F) You've used the C</e> switch to evaluate the replacement for a
substitution, but perl found a syntax error in the code to evaluate,
most likely an unexpected right brace '}'.
***************
*** 567,576 ****
characters and Perl was unable to create a unique filename during
inplace editing with the B<-i> switch. The file was ignored.
! =item Can't do {n,m} with n > m before << HERE in regex m/%s/
(F) Minima must be less than or equal to maxima. If you really want your
! regexp to match something 0 times, just put {0}. The << HERE shows in the
regular expression about where the problem was discovered. See L<perlre>.
=item Can't do setegid!
--- 567,576 ----
characters and Perl was unable to create a unique filename during
inplace editing with the B<-i> switch. The file was ignored.
! =item Can't do {n,m} with n > m in regex; marked by <-- HERE in m/%s/
(F) Minima must be less than or equal to maxima. If you really want your
! regexp to match something 0 times, just put {0}. The <-- HERE shows in the
regular expression about where the problem was discovered. See L<perlre>.
=item Can't do setegid!
***************
*** 628,633 ****
--- 628,640 ----
(F) A string of a form C<CORE::word> was given to prototype(), but there
is no builtin with the name C<word>.
+ =item Can't find %s character property "%s"
+
+ (F) You used C<\p{}> or C<\P{}> but the character property by that name
+ could not be find. Maybe you mispelled the name of the property
+ (remember that the names of character properties consist only of
+ alphanumeric characters), or maybe you forgot the C<Is> or C<In> prefix?
+
=item Can't find label %s
(F) You said to goto a label that isn't mentioned anywhere that it's
***************
*** 868,874 ****
redirection, and couldn't open the pipe into which to send data destined
for stdout.
! =item Can't open perl script "%s": %s
(F) The script you specified can't be opened for the indicated reason.
--- 875,881 ----
redirection, and couldn't open the pipe into which to send data destined
for stdout.
! =item Can't open perl script%s: %s
(F) The script you specified can't be opened for the indicated reason.
***************
*** 994,999 ****
--- 1001,1012 ----
(F) A value used as either a hard reference or a symbolic reference must
be a defined value. This helps to delurk some insidious errors.
+ =item Can't use anonymous symbol table for method lookup
+
+ (P) The internal routine that does method lookup was handed a symbol
+ table that doesn't have a name. Symbol tables can become anonymous
+ for example by undefining stashes: C<undef %Some::Package::>.
+
=item Can't use bareword ("%s") as %s ref while "strict refs" in use
(F) Only hard references are allowed by "strict refs". Symbolic
***************
*** 1063,1078 ****
with an assignment operator, which implies modifying the value itself.
Perhaps you need to copy the value to a temporary, and repeat that.
! =item chmod() mode argument is missing initial 0
! (W chmod) A novice will sometimes say
! chmod 777, $filename
! not realizing that 777 will be interpreted as a decimal number,
! equivalent to 01411. Octal constants are introduced with a leading 0 in
! Perl, as in C.
=item close() on unopened filehandle %s
(W unopened) You tried to close a filehandle that was never opened.
--- 1076,1111 ----
with an assignment operator, which implies modifying the value itself.
Perhaps you need to copy the value to a temporary, and repeat that.
! =item Character in "C" format wrapped
! (W pack) You said
! pack("C", $x)
! where $x is either less than 0 or more than 255; the C<"C"> format is
! only for encoding native operating system characters (ASCII, EBCDIC,
! and so on) and not for Unicode characters, so Perl behaved as if you meant
+ pack("C", $x & 255)
+
+ If you actually want to pack Unicode codepoints, use the C<"U"> format
+ instead.
+
+ =item Character in "c" format wrapped
+
+ (W pack) You said
+
+ pack("c", $x)
+
+ where $x is either less than -128 or more than 127; the C<"c"> format
+ is only for encoding native operating system characters (ASCII, EBCDIC,
+ and so on) and not for Unicode characters, so Perl behaved as if you meant
+
+ pack("c", $x & 255);
+
+ If you actually want to pack Unicode codepoints, use the C<"U"> format
+ instead.
+
=item close() on unopened filehandle %s
(W unopened) You tried to close a filehandle that was never opened.
***************
*** 1350,1361 ****
END subroutine. Processing of the remainder of the queue of such
routines has been prematurely ended.
! =item false [] range "%s" in regexp
(W regexp) A character class range must start and end at a literal
! character, not another character class like C<\d> or C<[:alpha:]>. The
! "-" in your false range is interpreted as a literal "-". Consider
! quoting the "-", "\-". See L<perlre>.
=item Fatal VMS error at %s, line %d
--- 1383,1395 ----
END subroutine. Processing of the remainder of the queue of such
routines has been prematurely ended.
! =item False [] range "%s" in regex; marked by <-- HERE in m/%s/
(W regexp) A character class range must start and end at a literal
! character, not another character class like C<\d> or C<[:alpha:]>. The "-"
! in your false range is interpreted as a literal "-". Consider quoting the
! "-", "\-". The <-- HERE shows in the regular expression about where the
! problem was discovered. See L<perlre>.
=item Fatal VMS error at %s, line %d
***************
*** 1404,1414 ****
filehandles. Are you attempting to call flock() on a dirhandle by the
same name?
! =item Quantifier follows nothing before << HERE in regex m/%s/
(F) You started a regular expression with a quantifier. Backslash it if you
! meant it literally. The << HERE shows in the regular expression about where the
! problem was discovered. See L<perlre>.
=item Format not terminated
--- 1438,1450 ----
filehandles. Are you attempting to call flock() on a dirhandle by the
same name?
! =item Quantifier follows nothing in regex;
+ marked by <-- HERE in m/%s/
+
(F) You started a regular expression with a quantifier. Backslash it if you
! meant it literally. The <-- HERE shows in the regular expression about
! where the problem was discovered. See L<perlre>.
=item Format not terminated
***************
*** 1654,1663 ****
internally--subject to loss of precision errors in subsequent
operations.
! =item Internal disaster before << HERE in regex m/%s/
(P) Something went badly wrong in the regular expression parser.
! The << HERE shows in the regular expression about where the problem was
discovered.
--- 1690,1699 ----
internally--subject to loss of precision errors in subsequent
operations.
! =item Internal disaster in regex; marked by <-- HERE in m/%s/
(P) Something went badly wrong in the regular expression parser.
! The <-- HERE shows in the regular expression about where the problem was
discovered.
***************
*** 1670,1679 ****
Perl is making a guess and treating this C<exec> as a request to
terminate the Perl script and execute the specified command.
! =item Internal urp before << HERE in regex m/%s/
! (P) Something went badly awry in the regular expression parser. The <<<HERE
! shows in the regular expression about where the problem was discovered.
=item %s (...) interpreted as function
--- 1706,1716 ----
Perl is making a guess and treating this C<exec> as a request to
terminate the Perl script and execute the specified command.
! =item Internal urp in regex; marked by <-- HERE in m/%s/
! (P) Something went badly awry in the regular expression parser. The
! <-- HERE shows in the regular expression about where the problem was
! discovered.
=item %s (...) interpreted as function
***************
*** 1698,1709 ****
(W printf) Perl does not understand the given format conversion. See
L<perlfunc/sprintf>.
! =item invalid [] range "%s" in regexp
(F) The range specified in a character class had a minimum character
! greater than the maximum character. See L<perlre>.
! =item invalid [] range "%s" in transliteration operator
(F) The range specified in the tr/// or y/// operator had a minimum
character greater than the maximum character. See L<perlop>.
--- 1735,1749 ----
(W printf) Perl does not understand the given format conversion. See
L<perlfunc/sprintf>.
! =item Invalid [] range "%s" in regex; marked by <-- HERE in m/%s/
(F) The range specified in a character class had a minimum character
! greater than the maximum character. One possibility is that you forgot the
! C<{}> from your ending C<\x{}> - C<\x> without the curly braces can go only
! up to C<ff>. The <-- HERE shows in the regular expression about where the
! problem was discovered. See L<perlre>.
! =item Invalid [] range "%s" in transliteration operator
(F) The range specified in the tr/// or y/// operator had a minimum
character greater than the maximum character. See L<perlop>.
***************
*** 1798,1808 ****
values cannot be returned in subroutines used in lvalue context. See
L<perlsub/"Lvalue subroutines">.
! =item Lookbehind longer than %d not implemented before << HERE %s
(F) There is currently a limit on the length of string which lookbehind can
! handle. This restriction may be eased in a future release. The << HERE shows in
! the regular expression about where the problem was discovered.
=item Malformed PERLLIB_PREFIX
--- 1838,1850 ----
values cannot be returned in subroutines used in lvalue context. See
L<perlsub/"Lvalue subroutines">.
! =item Lookbehind longer than %d not implemented in regex;
+ marked by <-- HERE in m/%s/
+
(F) There is currently a limit on the length of string which lookbehind can
! handle. This restriction may be eased in a future release. The <-- HERE
! shows in the regular expression about where the problem was discovered.
=item Malformed PERLLIB_PREFIX
***************
*** 1828,1838 ****
Perl thought it was reading UTF-16 encoded character data but while
doing it Perl met a malformed Unicode surrogate.
! =item %s matches null string many times
(W regexp) The pattern you've specified would be an infinite loop if the
! regular expression engine didn't specifically check for that. See
! L<perlre>.
=item % may only be used in unpack
--- 1870,1883 ----
Perl thought it was reading UTF-16 encoded character data but while
doing it Perl met a malformed Unicode surrogate.
! =item %s matches null string many times in regex;
+ marked by <-- HERE in m/%s/
+
(W regexp) The pattern you've specified would be an infinite loop if the
! regular expression engine didn't specifically check for that. The <-- HERE
! shows in the regular expression about where the problem was discovered.
! See L<perlre>.
=item % may only be used in unpack
***************
*** 1857,1863 ****
=item Misplaced _ in number
! (W syntax) An underline in a decimal constant wasn't on a 3-digit boundary.
=item Missing %sbrace%s on \N{}
--- 1902,1909 ----
=item Misplaced _ in number
! (W syntax) An underscore (underbar) in a numeric constant did not
! separate two digits.
=item Missing %sbrace%s on \N{}
***************
*** 1992,2007 ****
(F) You tried to do a read/write/send/recv operation with a buffer
length that is less than 0. This is difficult to imagine.
! =item Nested quantifiers before << HERE in regex m/%s/
(F) You can't quantify a quantifier without intervening parentheses. So
! things like ** or +* or ?* are illegal. The << HERE shows in the regular
expression about where the problem was discovered.
! Note, however, that the minimal matching quantifiers, C<*?>, C<+?>, and
C<??> appear to be nested quantifiers, but aren't. See L<perlre>.
-
=item %s never introduced
(S internal) The symbol in question was declared but somehow went out of
--- 2038,2052 ----
(F) You tried to do a read/write/send/recv operation with a buffer
length that is less than 0. This is difficult to imagine.
! =item Nested quantifiers in regex; marked by <-- HERE in m/%s/
(F) You can't quantify a quantifier without intervening parentheses. So
! things like ** or +* or ?* are illegal. The <-- HERE shows in the regular
expression about where the problem was discovered.
! Note that the minimal matching quantifiers, C<*?>, C<+?>, and
C<??> appear to be nested quantifiers, but aren't. See L<perlre>.
=item %s never introduced
(S internal) The symbol in question was declared but somehow went out of
***************
*** 2642,2676 ****
process which isn't a subprocess of the current process. While this is
fine from VMS' perspective, it's probably not what you intended.
! =item POSIX syntax [%s] belongs inside character classes
(W unsafe) The character class constructs [: :], [= =], and [. .] go
! I<inside> character classes, the [] are part of the construct, for
! example: /[012[:alpha:]345]/. Note that [= =] and [. .] are not
! currently implemented; they are simply placeholders for future
! extensions and will cause fatal errors.
! =item POSIX syntax [. .] is reserved for future extensions
(F regexp) Within regular expression character classes ([]) the syntax
! beginning with "[." and ending with ".]" is reserved for future
! extensions. If you need to represent those character sequences inside
! a regular expression character class, just quote the square brackets
! with the backslash: "\[." and ".\]".
! =item POSIX syntax [= =] is reserved for future extensions
! (F) Within regular expression character classes ([]) the syntax
! beginning with "[=" and ending with "=]" is reserved for future
! extensions. If you need to represent those character sequences inside
! a regular expression character class, just quote the square brackets
! with the backslash: "\[=" and "=\]".
! =item POSIX class [:%s:] unknown
! (F) The class in the character class [: :] syntax is unknown. See
! L<perlre>.
=item POSIX getpgrp can't take an argument
(F) Your system has POSIX getpgrp(), which takes no argument, unlike
--- 2687,2733 ----
process which isn't a subprocess of the current process. While this is
fine from VMS' perspective, it's probably not what you intended.
! =item POSIX syntax [%s] belongs inside character classes in regex;
+ marked by <-- HERE in m/%s/
+
(W unsafe) The character class constructs [: :], [= =], and [. .] go
! I<inside> character classes, the [] are part of the construct, for example:
! /[012[:alpha:]345]/. Note that [= =] and [. .] are not currently
! implemented; they are simply placeholders for future extensions and will
! cause fatal errors. The <-- HERE shows in the regular expression about
! where the problem was discovered. See L<perlre>.
! =item POSIX syntax [. .] is reserved for future extensions in regex;
+ marked by <-- HERE in m/%s/
+
(F regexp) Within regular expression character classes ([]) the syntax
! beginning with "[." and ending with ".]" is reserved for future extensions.
! If you need to represent those character sequences inside a regular
! expression character class, just quote the square brackets with the
! backslash: "\[." and ".\]". The <-- HERE shows in the regular expression
! about where the problem was discovered. See L<perlre>.
! =item POSIX syntax [= =] is reserved for future extensions in regex;
! marked by <-- HERE in m/%s/
! (F) Within regular expression character classes ([]) the syntax beginning
! with "[=" and ending with "=]" is reserved for future extensions. If you
! need to represent those character sequences inside a regular expression
! character class, just quote the square brackets with the backslash: "\[="
! and "=\]". The <-- HERE shows in the regular expression about where the
! problem was discovered. See L<perlre>.
! =item POSIX class [:%s:] unknown in regex;
+ marked by <-- HERE in m/%s/
+
+ (F) The class in the character class [: :] syntax is unknown. The <-- HERE
+ shows in the regular expression about where the problem was discovered.
+ See L<perlre>.
+
=item POSIX getpgrp can't take an argument
(F) Your system has POSIX getpgrp(), which takes no argument, unlike
***************
*** 2735,2741 ****
=item pragma "attrs" is deprecated, use "sub NAME : ATTRS" instead
! (W deprecated) You have written something like this:
sub doit
{
--- 2792,2798 ----
=item pragma "attrs" is deprecated, use "sub NAME : ATTRS" instead
! (D deprecated) You have written something like this:
sub doit
{
***************
*** 2793,2806 ****
(S unsafe) The subroutine being declared or defined had previously been
declared or defined with a different function prototype.
! =item Quantifier in {,} bigger than %d before << HERE in regex m/%s/
(F) There is currently a limit to the size of the min and max values of the
! {min,max} construct. The << HERE shows in the regular expression about where
the problem was discovered. See L<perlre>.
! =item Quantifier unexpected on zero-length expression before << HERE %s
(W regexp) You applied a regular expression quantifier in a place where
it makes no sense, such as on a zero-width assertion. Try putting the
quantifier inside the assertion instead. For example, the way to match
--- 2850,2867 ----
(S unsafe) The subroutine being declared or defined had previously been
declared or defined with a different function prototype.
! =item Quantifier in {,} bigger than %d in regex;
+ marked by <-- HERE in m/%s/
+
(F) There is currently a limit to the size of the min and max values of the
! {min,max} construct. The <-- HERE shows in the regular expression about where
the problem was discovered. See L<perlre>.
! =item Quantifier unexpected on zero-length expression;
+ marked by <-- HERE in m/%s/
+
(W regexp) You applied a regular expression quantifier in a place where
it makes no sense, such as on a zero-width assertion. Try putting the
quantifier inside the assertion instead. For example, the way to match
***************
*** 2807,2812 ****
--- 2868,2876 ----
"abc" provided that it is followed by three repetitions of "xyz" is
C</abc(?=(?:xyz){3})/>, not C</abc(?=xyz){3}/>.
+ The <-- HERE shows in the regular expression about where the problem was
+ discovered.
+
=item Range iterator outside integer range
(F) One (or both) of the numeric arguments to the range operator ".."
***************
*** 2867,2880 ****
(W internal) The internal sv_replace() function was handed a new SV with
a reference count of other than 1.
! =item Reference to nonexistent group before << HERE in regex m/%s/
(F) You used something like C<\7> in your regular expression, but there are
not at least seven sets of capturing parentheses in the expression. If you
wanted to have the character with value 7 inserted into the regular expression,
prepend a zero to make the number at least two digits: C<\07>
! The << HERE shows in the regular expression about where the problem was
discovered.
=item regexp memory corruption
--- 2931,2946 ----
(W internal) The internal sv_replace() function was handed a new SV with
a reference count of other than 1.
! =item Reference to nonexistent group in regex;
+ marked by <-- HERE in m/%s/
+
(F) You used something like C<\7> in your regular expression, but there are
not at least seven sets of capturing parentheses in the expression. If you
wanted to have the character with value 7 inserted into the regular expression,
prepend a zero to make the number at least two digits: C<\07>
! The <-- HERE shows in the regular expression about where the problem was
discovered.
=item regexp memory corruption
***************
*** 2991,3024 ****
(W closed) The socket you're sending to got itself closed sometime
before now. Check your control flow.
! =item Sequence (? incomplete before << HERE mark in regex m/%s/
! (F) A regular expression ended with an incomplete extension (?. The <<<HERE
shows in the regular expression about where the problem was discovered. See
L<perlre>.
! =item Sequence (?{...}) not terminated or not {}-balanced in %s
(F) If the contents of a (?{...}) clause contains braces, they must balance
! for Perl to properly detect the end of the clause. See L<perlre>.
! =item Sequence (?%s...) not implemented before << HERE mark in %s
(F) A proposed regular expression extension has the character reserved but
! has not yet been written. The << HERE shows in the regular expression about
where the problem was discovered. See L<perlre>.
! =item Sequence (?%s...) not recognized before << HERE mark in %s
! (F) You used a regular expression extension that doesn't make sense.
! The << HERE shows in the regular expression about
! where the problem was discovered.
! See L<perlre>.
! =item Sequence (?#... not terminated in regex m/%s/
(F) A regular expression comment must be terminated by a closing
! parenthesis. Embedded parentheses aren't allowed. See L<perlre>.
=item 500 Server error
--- 3057,3101 ----
(W closed) The socket you're sending to got itself closed sometime
before now. Check your control flow.
! =item Sequence (? incomplete in regex; marked by <-- HERE in m/%s/
! (F) A regular expression ended with an incomplete extension (?. The <-- HERE
shows in the regular expression about where the problem was discovered. See
L<perlre>.
! =item Sequence (?{...}) not terminated or not {}-balanced in regex;
+ marked by <-- HERE in m/%s/
+
(F) If the contents of a (?{...}) clause contains braces, they must balance
! for Perl to properly detect the end of the clause. The <-- HERE shows in
! the regular expression about where the problem was discovered. See
! L<perlre>.
! =item Sequence (?%s...) not implemented in regex;
+ marked by <-- HERE in m/%s/
+
(F) A proposed regular expression extension has the character reserved but
! has not yet been written. The <-- HERE shows in the regular expression about
where the problem was discovered. See L<perlre>.
! =item Sequence (?%s...) not recognized in regex;
! marked by <-- HERE in m/%s/
! (F) You used a regular expression extension that doesn't make sense. The
! <-- HERE shows in the regular expression about where the problem was
! discovered. See L<perlre>.
+ =item Sequence (?#... not terminated in regex;
+
+ marked by <-- HERE in m/%s/
+
(F) A regular expression comment must be terminated by a closing
! parenthesis. Embedded parentheses aren't allowed. The <-- HERE shows in
! the regular expression about where the problem was discovered. See
! L<perlre>.
=item 500 Server error
***************
*** 3199,3206 ****
(F) Your Perl was compiled with B<-D>SETUID_SCRIPTS_ARE_SECURE_NOW, but
a version of the setuid emulator somehow got run anyway.
! =item Switch (?(condition)... contains too many branches before << HE%s
(F) A (?(condition)if-clause|else-clause) construct can have at most two
branches (the if-clause and the else-clause). If you want one or both to
contain alternation, such as using C<this|that|other>, enclose it in
--- 3276,3285 ----
(F) Your Perl was compiled with B<-D>SETUID_SCRIPTS_ARE_SECURE_NOW, but
a version of the setuid emulator somehow got run anyway.
! =item Switch (?(condition)... contains too many branches in regex;
+ marked by <-- HERE in m/%s/
+
(F) A (?(condition)if-clause|else-clause) construct can have at most two
branches (the if-clause and the else-clause). If you want one or both to
contain alternation, such as using C<this|that|other>, enclose it in
***************
*** 3208,3220 ****
(?(condition)(?:this|that|other)|else-clause)
! The << HERE shows in the regular expression about where the problem was
discovered. See L<perlre>.
! =item Switch condition not recognized before << HERE in regex m/%s/
(F) If the argument to the (?(...)if-clause|else-clause) construct is a
! number, it can be only a number. The << HERE shows in the regular expression
about where the problem was discovered. See L<perlre>.
=item switching effective %s is not implemented
--- 3287,3301 ----
(?(condition)(?:this|that|other)|else-clause)
! The <-- HERE shows in the regular expression about where the problem was
discovered. See L<perlre>.
! =item Switch condition not recognized in regex;
+ marked by <-- HERE in m/%s/
+
(F) If the argument to the (?(...)if-clause|else-clause) construct is a
! number, it can be only a number. The <-- HERE shows in the regular expression
about where the problem was discovered. See L<perlre>.
=item switching effective %s is not implemented
***************
*** 3378,3384 ****
=item Too many ('s
! =item trailing \ in regexp
(F) The regular expression ends with an unbackslashed backslash.
Backslash it. See L<perlre>.
--- 3459,3465 ----
=item Too many ('s
! =item Trailing \ in regex m/%s/
(F) The regular expression ends with an unbackslashed backslash.
Backslash it. See L<perlre>.
***************
*** 3406,3416 ****
%NAME or C<%{EXPR}>. No implicit dereferencing is allowed--use the
{EXPR} forms as an explicit dereference. See L<perlref>.
- =item umask: argument is missing initial 0
-
- (W umask) A umask of 222 is incorrect. It should be 0222, because octal
- literals always start with 0 in Perl, as in C.
-
=item umask not implemented
(F) Your machine doesn't implement the umask function and you tried to
--- 3487,3492 ----
***************
*** 3492,3506 ****
(F) There are no byte-swapping functions for a machine with this byte
order.
! =item Unknown switch condition (?(%.2s before << HERE in regex m/%s/
! (F) The condition of a (?(condition)if-clause|else-clause) construct is not
! known. The condition may be lookaround (the condition is true if the
! lookaround is true), a (?{...}) construct (the condition is true if the
! code evaluates to a true value), or a number (the condition is true if the
! set of capturing parentheses named by the number is defined).
! The << HERE shows in the regular expression about where the problem was
discovered. See L<perlre>.
=item Unknown open() mode '%s'
--- 3568,3589 ----
(F) There are no byte-swapping functions for a machine with this byte
order.
! =item Unknown "re" subpragma '%s' (known ones are: %s)
! You tried to use an unknown subpragma of the "re" pragma.
! =item Unknown switch condition (?(%.2s in regex;
!
! marked by <-- HERE in m/%s/
!
! (F) The condition part of a (?(condition)if-clause|else-clause) construct
! is not known. The condition may be lookahead or lookbehind (the condition
! is true if the lookahead or lookbehind is true), a (?{...}) construct (the
! condition is true if the code evaluates to a true value), or a number (the
! condition is true if the set of capturing parentheses named by the number
! matched).
!
! The <-- HERE shows in the regular expression about where the problem was
discovered. See L<perlre>.
=item Unknown open() mode '%s'
***************
*** 3516,3533 ****
data Perl expected. Someone's very confused, or perhaps trying to
subvert Perl's population of %ENV for nefarious purposes.
! =item unmatched [ before << HERE mark in regex m/%s/
(F) The brackets around a character class must match. If you wish to
include a closing bracket in a character class, backslash it or put it
! first. See L<perlre>. The << HERE shows in the regular expression about
! where the escape was discovered.
! =item unmatched ( in regexp before << HERE mark in regex m/%s/
(F) Unbackslashed parentheses must always be balanced in regular
! expressions. If you're a vi user, the % key is valuable for finding the
! matching parenthesis. See L<perlre>.
=item Unmatched right %s bracket
--- 3599,3617 ----
data Perl expected. Someone's very confused, or perhaps trying to
subvert Perl's population of %ENV for nefarious purposes.
! =item unmatched [ in regex; marked by <-- HERE in m/%s/
(F) The brackets around a character class must match. If you wish to
include a closing bracket in a character class, backslash it or put it
! first. The <-- HERE shows in the regular expression about where the problem
! was discovered. See L<perlre>.
! =item unmatched ( in regex; marked by <-- HERE in m/%s/
(F) Unbackslashed parentheses must always be balanced in regular
! expressions. If you're a vi user, the % key is valuable for finding the
! matching parenthesis. The <-- HERE shows in the regular expression about
! where the problem was discovered. See L<perlre>.
=item Unmatched right %s bracket
***************
*** 3555,3569 ****
recognized by Perl inside character classes. The character was
understood literally.
! =item Unrecognized escape \\%c passed through before << HERE in m/%s/
(W regexp) You used a backslash-character combination which is not
recognized by Perl. This combination appears in an interpolated variable or
a C<'>-delimited regular expression. The character was understood
! literally. The << HERE shows in the regular expression about where the escape
! was discovered.
-
=item Unrecognized escape \\%c passed through
(W misc) You used a backslash-character combination which is not
--- 3639,3654 ----
recognized by Perl inside character classes. The character was
understood literally.
! =item Unrecognized escape \\%c passed through in regex;
+ marked by <-- HERE in m/%s/
+
(W regexp) You used a backslash-character combination which is not
recognized by Perl. This combination appears in an interpolated variable or
a C<'>-delimited regular expression. The character was understood
! literally. The <-- HERE shows in the regular expression about where the
! escape was discovered.
=item Unrecognized escape \\%c passed through
(W misc) You used a backslash-character combination which is not
***************
*** 3646,3651 ****
--- 3731,3768 ----
(W untie) A copy of the object returned from C<tie> (or C<tied>) was
still valid when C<untie> was called.
+ =item Useless (?%s) - use /%s modifier in regex;
+
+ marked by <-- HERE in m/%s/
+
+ (W regexp) You have used an internal modifier such as (?o) that has no
+ meaning unless applied to the entire regexp:
+
+ if ($string =~ /(?o)$pattern/) { ... }
+
+ must be written as
+
+ if ($string =~ /$pattern/o) { ... }
+
+ The <-- HERE shows in the regular expression about
+ where the problem was discovered. See L<perlre>.
+
+ =item Useless (?-%s) - don't use /%s modifier in regex;
+
+ marked by <-- HERE in m/%s/
+
+ (W regexp) You have used an internal modifier such as (?-o) that has no
+ meaning unless removed from the entire regexp:
+
+ if ($string =~ /(?-o)$pattern/o) { ... }
+
+ must be written as
+
+ if ($string =~ /$pattern/) { ... }
+
+ The <-- HERE shows in the regular expression about
+ where the problem was discovered. See L<perlre>.
+
=item Useless use of %s in void context
(W void) You did something without a side effect in a context that does
***************
*** 3678,3683 ****
--- 3795,3808 ----
throws away the left argument, which is not what you want. See
L<perlref> for more on this.
+ This warning will not be issued for numerical constants equal to 0 or 1
+ since they are often used in statements like
+
+ 1 while sub_with_side_effects() ;
+
+ String constants that would normally evaluate to 0 or 1 are warned
+ about.
+
=item Useless use of "re" pragma
(W) You did C<use re;> without any arguments. That isn't very useful.
***************
*** 3731,3736 ****
--- 3856,3868 ----
you should remove AutoLoader from @ISA and change C<use AutoLoader;> to
C<use AutoLoader 'AUTOLOAD';>.
+ =item Use of "package" with no arguments is deprecated
+
+ (D deprecated) You used the C<package> keyword without specifying a package
+ name. So no namespace is current at all. Using this can cause many
+ otherwise reasonable constructs to fail in baffling ways. C<use strict;>
+ instead.
+
=item Use of %s in printf format not supported
(F) You attempted to use a feature of printf that is accessible from
***************
*** 3754,3767 ****
(D deprecated) This was an ill-advised attempt to emulate a poorly
defined B<awk> feature. Use an explicit printf() or sprintf() instead.
! =item Use of reference "%s" in array index
(W) You tried to use a reference as an array index; this probably
! isn't what you mean, because references tend to be huge numbers which
! take you out of memory, and so usually indicates programmer error.
If you really do mean it, explicitly numify your reference, like so:
! C<$array[0+$ref]>
=item Use of reserved word "%s" is deprecated
--- 3886,3901 ----
(D deprecated) This was an ill-advised attempt to emulate a poorly
defined B<awk> feature. Use an explicit printf() or sprintf() instead.
! =item Use of reference "%s" as array index
(W) You tried to use a reference as an array index; this probably
! isn't what you mean, because references in numerical context tend
! to be huge numbers, and so usually indicates programmer error.
If you really do mean it, explicitly numify your reference, like so:
! C<$array[0+$ref]>. This warning is not given for overloaded objects,
! either, because you can overload the numification and stringification
! operators and then you assumedly know what you are doing.
=item Use of reserved word "%s" is deprecated
***************
*** 3786,3791 ****
--- 3920,3939 ----
the C<concatenation (.)> operator, even though there is no C<.> in your
program.
+ =item Using a hash as a reference is deprecated
+
+ (D deprecated) You tried to use a hash as a reference, as in
+ C<< %foo->{"bar"} >> or C<< %$ref->{"hello"} >>. Versions of perl <= 5.6.1
+ used to allow this syntax, but shouldn't have. It is now deprecated, and will
+ be removed in a future version.
+
+ =item Using an array as a reference is deprecated
+
+ (D deprecated) You tried to use an array as a reference, as in
+ C<< @foo->[23] >> or C<< @$ref->[99] >>. Versions of perl <= 5.6.1 used to
+ allow this syntax, but shouldn't have. It is now deprecated, and will be
+ removed in a future version.
+
=item Value of %s can be "0"; test with defined()
(W misc) In a conditional expression, you used <HANDLE>, <*> (glob),
***************
*** 3866,3876 ****
reference variables in outer subroutines are called or referenced, they
are automatically rebound to the current values of such variables.
! =item Variable length lookbehind not implemented before << HERE in %s
(F) Lookbehind is allowed only for subexpressions whose length is fixed and
! known at compile time. The << HERE shows in the regular expression about where
! the problem was discovered.
=item Version number must be a constant number
--- 4014,4026 ----
reference variables in outer subroutines are called or referenced, they
are automatically rebound to the current values of such variables.
! =item Variable length lookbehind not implemented in regex;
+ marked by <-- HERE in m/%s/
+
(F) Lookbehind is allowed only for subexpressions whose length is fixed and
! known at compile time. The <-- HERE shows in the regular expression about
! where the problem was discovered. See L<perlre>.
=item Version number must be a constant number
***************
*** 3947,3954 ****
(F) And you probably never will, because you probably don't have the
sources to your kernel, and your vendor probably doesn't give a rip
! about what you want. Your best bet is to use the wrapsuid script in the
! eg directory to put a setuid C wrapper around your script.
=item You need to quote "%s"
--- 4097,4104 ----
(F) And you probably never will, because you probably don't have the
sources to your kernel, and your vendor probably doesn't give a rip
! about what you want. Your best bet is to put a setuid C wrapper around
! your script.
=item You need to quote "%s"
diff -c 'perl-5.7.1/pod/perlebcdic.pod' 'perl-5.7.2/pod/perlebcdic.pod'
Index: ./pod/perlebcdic.pod
*** ./pod/perlebcdic.pod Tue Mar 6 04:06:29 2001
--- ./pod/perlebcdic.pod Mon Jul 9 17:11:11 2001
***************
*** 6,12 ****
An exploration of some of the issues facing Perl programmers
on EBCDIC based computers. We do not cover localization,
! internationalization, or multi byte character set issues (yet).
Portions that are still incomplete are marked with XXX.
--- 6,13 ----
An exploration of some of the issues facing Perl programmers
on EBCDIC based computers. We do not cover localization,
! internationalization, or multi byte character set issues other
! than some discussion of UTF-8 and UTF-EBCDIC.
Portions that are still incomplete are marked with XXX.
***************
*** 44,50 ****
accented Latin characters. Languages that can employ ISO 8859-1
include all the languages covered by ASCII as well as Afrikaans,
Albanian, Basque, Catalan, Danish, Faroese, Finnish, Norwegian,
! Portugese, Spanish, and Swedish. Dutch is covered albeit without
the ij ligature. French is covered too but without the oe ligature.
German can use ISO 8859-1 but must do so without German-style
quotation marks. This set is based on Western European extensions
--- 45,51 ----
accented Latin characters. Languages that can employ ISO 8859-1
include all the languages covered by ASCII as well as Afrikaans,
Albanian, Basque, Catalan, Danish, Faroese, Finnish, Norwegian,
! Portuguese, Spanish, and Swedish. Dutch is covered albeit without
the ij ligature. French is covered too but without the oe ligature.
German can use ISO 8859-1 but must do so without German-style
quotation marks. This set is based on Western European extensions
***************
*** 54,60 ****
=head2 EBCDIC
! The Extended Binary Coded Decimal Interchange Code refers to a
large collection of slightly different single and multi byte
coded character sets that are different from ASCII or ISO 8859-1
and typically run on host computers. The EBCDIC encodings derive
--- 55,61 ----
=head2 EBCDIC
! The Extended Binary Coded Decimal Interchange Code refers to a
large collection of slightly different single and multi byte
coded character sets that are different from ASCII or ISO 8859-1
and typically run on host computers. The EBCDIC encodings derive
***************
*** 88,95 ****
Character code set ID 1047 is also a mapping of the ASCII plus
Latin-1 characters (i.e. ISO 8859-1) to an EBCDIC set. 1047 is
! used under Unix System Services for OS/390, and OpenEdition for VM/ESA.
! CCSID 1047 differs from CCSID 0037 in eight places.
=head2 POSIX-BC
--- 89,96 ----
Character code set ID 1047 is also a mapping of the ASCII plus
Latin-1 characters (i.e. ISO 8859-1) to an EBCDIC set. 1047 is
! used under Unix System Services for OS/390 or z/OS, and OpenEdition
! for VM/ESA. CCSID 1047 differs from CCSID 0037 in eight places.
=head2 POSIX-BC
***************
*** 96,101 ****
--- 97,109 ----
The EBCDIC code page in use on Siemens' BS2000 system is distinct from
1047 and 0037. It is identified below as the POSIX-BC set.
+ =head2 Unicode and UTF
+
+ UTF is a Unicode Transformation Format. UTF-8 is a Unicode conforming
+ representation of the Unicode standard that looks very much like ASCII.
+ UTF-EBCDIC is an attempt to represent Unicode characters in an EBCDIC
+ transparent manner.
+
=head1 SINGLE OCTET TABLES
The following tables list the ASCII and Latin 1 ordered sets including
***************
*** 103,109 ****
C1 controls (80..9f), and Latin-1 (a.k.a. ISO 8859-1) (a0..ff). In the
table non-printing control character names as well as the Latin 1
extensions to ASCII have been labelled with character names roughly
! corresponding to I<The Unicode Standard, Version 2.0> albeit with
substitutions such as s/LATIN// and s/VULGAR// in all cases,
s/CAPITAL LETTER// in some cases, and s/SMALL LETTER ([A-Z])/\l$1/
in some other cases (the C<charnames> pragma names unfortunately do
--- 111,117 ----
C1 controls (80..9f), and Latin-1 (a.k.a. ISO 8859-1) (a0..ff). In the
table non-printing control character names as well as the Latin 1
extensions to ASCII have been labelled with character names roughly
! corresponding to I<The Unicode Standard, Version 3.0> albeit with
substitutions such as s/LATIN// and s/VULGAR// in all cases,
s/CAPITAL LETTER// in some cases, and s/SMALL LETTER ([A-Z])/\l$1/
in some other cases (the C<charnames> pragma names unfortunately do
***************
*** 123,409 ****
=back
perl -ne 'if(/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/)' \
! -e '{printf("%s%-9o%-9o%-9o%-9o\n",$1,$2,$3,$4,$5)}' perlebcdic.pod
If you would rather see this table listing hexadecimal values then
run the table through:
=over 4
! =item recipe 1
=back
perl -ne 'if(/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/)' \
! -e '{printf("%s%-9X%-9X%-9X%-9X\n",$1,$2,$3,$4,$5)}' perlebcdic.pod
! 8859-1
! chr 0819 0037 1047 POSIX-BC
! ----------------------------------------------------------------
! <NULL> 0 0 0 0
! <START OF HEADING> 1 1 1 1
! <START OF TEXT> 2 2 2 2
! <END OF TEXT> 3 3 3 3
! <END OF TRANSMISSION> 4 55 55 55
! <ENQUIRY> 5 45 45 45
! <ACKNOWLEDGE> 6 46 46 46
! <BELL> 7 47 47 47
! <BACKSPACE> 8 22 22 22
! <HORIZONTAL TABULATION> 9 5 5 5
! <LINE FEED> 10 37 21 21 ***
! <VERTICAL TABULATION> 11 11 11 11
! <FORM FEED> 12 12 12 12
! <CARRIAGE RETURN> 13 13 13 13
! <SHIFT OUT> 14 14 14 14
! <SHIFT IN> 15 15 15 15
! <DATA LINK ESCAPE> 16 16 16 16
! <DEVICE CONTROL ONE> 17 17 17 17
! <DEVICE CONTROL TWO> 18 18 18 18
! <DEVICE CONTROL THREE> 19 19 19 19
! <DEVICE CONTROL FOUR> 20 60 60 60
! <NEGATIVE ACKNOWLEDGE> 21 61 61 61
! <SYNCHRONOUS IDLE> 22 50 50 50
! <END OF TRANSMISSION BLOCK> 23 38 38 38
! <CANCEL> 24 24 24 24
! <END OF MEDIUM> 25 25 25 25
! <SUBSTITUTE> 26 63 63 63
! <ESCAPE> 27 39 39 39
! <FILE SEPARATOR> 28 28 28 28
! <GROUP SEPARATOR> 29 29 29 29
! <RECORD SEPARATOR> 30 30 30 30
! <UNIT SEPARATOR> 31 31 31 31
! <SPACE> 32 64 64 64
! ! 33 90 90 90
! " 34 127 127 127
! # 35 123 123 123
! $ 36 91 91 91
! % 37 108 108 108
! & 38 80 80 80
! ' 39 125 125 125
! ( 40 77 77 77
! ) 41 93 93 93
! * 42 92 92 92
! + 43 78 78 78
! , 44 107 107 107
! - 45 96 96 96
! . 46 75 75 75
! / 47 97 97 97
! 0 48 240 240 240
! 1 49 241 241 241
! 2 50 242 242 242
! 3 51 243 243 243
! 4 52 244 244 244
! 5 53 245 245 245
! 6 54 246 246 246
! 7 55 247 247 247
! 8 56 248 248 248
! 9 57 249 249 249
! : 58 122 122 122
! ; 59 94 94 94
! < 60 76 76 76
! = 61 126 126 126
! > 62 110 110 110
! ? 63 111 111 111
! @ 64 124 124 124
! A 65 193 193 193
! B 66 194 194 194
! C 67 195 195 195
! D 68 196 196 196
! E 69 197 197 197
! F 70 198 198 198
! G 71 199 199 199
! H 72 200 200 200
! I 73 201 201 201
! J 74 209 209 209
! K 75 210 210 210
! L 76 211 211 211
! M 77 212 212 212
! N 78 213 213 213
! O 79 214 214 214
! P 80 215 215 215
! Q 81 216 216 216
! R 82 217 217 217
! S 83 226 226 226
! T 84 227 227 227
! U 85 228 228 228
! V 86 229 229 229
! W 87 230 230 230
! X 88 231 231 231
! Y 89 232 232 232
! Z 90 233 233 233
! [ 91 186 173 187 *** ###
! \ 92 224 224 188 ###
! ] 93 187 189 189 ***
! ^ 94 176 95 106 *** ###
! _ 95 109 109 109
! ` 96 121 121 74 ###
! a 97 129 129 129
! b 98 130 130 130
! c 99 131 131 131
! d 100 132 132 132
! e 101 133 133 133
! f 102 134 134 134
! g 103 135 135 135
! h 104 136 136 136
! i 105 137 137 137
! j 106 145 145 145
! k 107 146 146 146
! l 108 147 147 147
! m 109 148 148 148
! n 110 149 149 149
! o 111 150 150 150
! p 112 151 151 151
! q 113 152 152 152
! r 114 153 153 153
! s 115 162 162 162
! t 116 163 163 163
! u 117 164 164 164
! v 118 165 165 165
! w 119 166 166 166
! x 120 167 167 167
! y 121 168 168 168
! z 122 169 169 169
! { 123 192 192 251 ###
! | 124 79 79 79
! } 125 208 208 253 ###
! ~ 126 161 161 255 ###
! <DELETE> 127 7 7 7
! <C1 0> 128 32 32 32
! <C1 1> 129 33 33 33
! <C1 2> 130 34 34 34
! <C1 3> 131 35 35 35
! <C1 4> 132 36 36 36
! <C1 5> 133 21 37 37 ***
! <C1 6> 134 6 6 6
! <C1 7> 135 23 23 23
! <C1 8> 136 40 40 40
! <C1 9> 137 41 41 41
! <C1 10> 138 42 42 42
! <C1 11> 139 43 43 43
! <C1 12> 140 44 44 44
! <C1 13> 141 9 9 9
! <C1 14> 142 10 10 10
! <C1 15> 143 27 27 27
! <C1 16> 144 48 48 48
! <C1 17> 145 49 49 49
! <C1 18> 146 26 26 26
! <C1 19> 147 51 51 51
! <C1 20> 148 52 52 52
! <C1 21> 149 53 53 53
! <C1 22> 150 54 54 54
! <C1 23> 151 8 8 8
! <C1 24> 152 56 56 56
! <C1 25> 153 57 57 57
! <C1 26> 154 58 58 58
! <C1 27> 155 59 59 59
! <C1 28> 156 4 4 4
! <C1 29> 157 20 20 20
! <C1 30> 158 62 62 62
! <C1 31> 159 255 255 95 ###
! <NON-BREAKING SPACE> 160 65 65 65
! <INVERTED EXCLAMATION MARK> 161 170 170 170
! <CENT SIGN> 162 74 74 176 ###
! <POUND SIGN> 163 177 177 177
! <CURRENCY SIGN> 164 159 159 159
! <YEN SIGN> 165 178 178 178
! <BROKEN BAR> 166 106 106 208 ###
! <SECTION SIGN> 167 181 181 181
! <DIAERESIS> 168 189 187 121 *** ###
! <COPYRIGHT SIGN> 169 180 180 180
! <FEMININE ORDINAL INDICATOR> 170 154 154 154
! <LEFT POINTING GUILLEMET> 171 138 138 138
! <NOT SIGN> 172 95 176 186 *** ###
! <SOFT HYPHEN> 173 202 202 202
! <REGISTERED TRADE MARK SIGN> 174 175 175 175
! <MACRON> 175 188 188 161 ###
! <DEGREE SIGN> 176 144 144 144
! <PLUS-OR-MINUS SIGN> 177 143 143 143
! <SUPERSCRIPT TWO> 178 234 234 234
! <SUPERSCRIPT THREE> 179 250 250 250
! <ACUTE ACCENT> 180 190 190 190
! <MICRO SIGN> 181 160 160 160
! <PARAGRAPH SIGN> 182 182 182 182
! <MIDDLE DOT> 183 179 179 179
! <CEDILLA> 184 157 157 157
! <SUPERSCRIPT ONE> 185 218 218 218
! <MASC. ORDINAL INDICATOR> 186 155 155 155
! <RIGHT POINTING GUILLEMET> 187 139 139 139
! <FRACTION ONE QUARTER> 188 183 183 183
! <FRACTION ONE HALF> 189 184 184 184
! <FRACTION THREE QUARTERS> 190 185 185 185
! <INVERTED QUESTION MARK> 191 171 171 171
! <A WITH GRAVE> 192 100 100 100
! <A WITH ACUTE> 193 101 101 101
! <A WITH CIRCUMFLEX> 194 98 98 98
! <A WITH TILDE> 195 102 102 102
! <A WITH DIAERESIS> 196 99 99 99
! <A WITH RING ABOVE> 197 103 103 103
! <CAPITAL LIGATURE AE> 198 158 158 158
! <C WITH CEDILLA> 199 104 104 104
! <E WITH GRAVE> 200 116 116 116
! <E WITH ACUTE> 201 113 113 113
! <E WITH CIRCUMFLEX> 202 114 114 114
! <E WITH DIAERESIS> 203 115 115 115
! <I WITH GRAVE> 204 120 120 120
! <I WITH ACUTE> 205 117 117 117
! <I WITH CIRCUMFLEX> 206 118 118 118
! <I WITH DIAERESIS> 207 119 119 119
! <CAPITAL LETTER ETH> 208 172 172 172
! <N WITH TILDE> 209 105 105 105
! <O WITH GRAVE> 210 237 237 237
! <O WITH ACUTE> 211 238 238 238
! <O WITH CIRCUMFLEX> 212 235 235 235
! <O WITH TILDE> 213 239 239 239
! <O WITH DIAERESIS> 214 236 236 236
! <MULTIPLICATION SIGN> 215 191 191 191
! <O WITH STROKE> 216 128 128 128
! <U WITH GRAVE> 217 253 253 224 ###
! <U WITH ACUTE> 218 254 254 254
! <U WITH CIRCUMFLEX> 219 251 251 221 ###
! <U WITH DIAERESIS> 220 252 252 252
! <Y WITH ACUTE> 221 173 186 173 *** ###
! <CAPITAL LETTER THORN> 222 174 174 174
! <SMALL LETTER SHARP S> 223 89 89 89
! <a WITH GRAVE> 224 68 68 68
! <a WITH ACUTE> 225 69 69 69
! <a WITH CIRCUMFLEX> 226 66 66 66
! <a WITH TILDE> 227 70 70 70
! <a WITH DIAERESIS> 228 67 67 67
! <a WITH RING ABOVE> 229 71 71 71
! <SMALL LIGATURE ae> 230 156 156 156
! <c WITH CEDILLA> 231 72 72 72
! <e WITH GRAVE> 232 84 84 84
! <e WITH ACUTE> 233 81 81 81
! <e WITH CIRCUMFLEX> 234 82 82 82
! <e WITH DIAERESIS> 235 83 83 83
! <i WITH GRAVE> 236 88 88 88
! <i WITH ACUTE> 237 85 85 85
! <i WITH CIRCUMFLEX> 238 86 86 86
! <i WITH DIAERESIS> 239 87 87 87
! <SMALL LETTER eth> 240 140 140 140
! <n WITH TILDE> 241 73 73 73
! <o WITH GRAVE> 242 205 205 205
! <o WITH ACUTE> 243 206 206 206
! <o WITH CIRCUMFLEX> 244 203 203 203
! <o WITH TILDE> 245 207 207 207
! <o WITH DIAERESIS> 246 204 204 204
! <DIVISION SIGN> 247 225 225 225
! <o WITH STROKE> 248 112 112 112
! <u WITH GRAVE> 249 221 221 192 ###
! <u WITH ACUTE> 250 222 222 222
! <u WITH CIRCUMFLEX> 251 219 219 219
! <u WITH DIAERESIS> 252 220 220 220
! <y WITH ACUTE> 253 141 141 141
! <SMALL LETTER thorn> 254 142 142 142
! <y WITH DIAERESIS> 255 223 223 223
If you would rather see the above table in CCSID 0037 order rather than
ASCII + Latin-1 order then run the table through:
=over 4
! =item recipe 2
=back
--- 131,465 ----
=back
perl -ne 'if(/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/)' \
! -e '{printf("%s%-9o%-9o%-9o%o\n",$1,$2,$3,$4,$5)}' perlebcdic.pod
+ If you want to retain the UTF-x code points then in script form you
+ might want to write:
+
+ =over 4
+
+ =item recipe 1
+
+ =back
+
+ open(FH,"<perlebcdic.pod") or die "Could not open perlebcdic.pod: $!";
+ while (<FH>) {
+ if (/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\.?(\d*)\s+(\d+)\.?(\d*)/) {
+ if ($7 ne '' && $9 ne '') {
+ printf("%s%-9o%-9o%-9o%-9o%-3o.%-5o%-3o.%o\n",$1,$2,$3,$4,$5,$6,$7,$8,$9);
+ }
+ elsif ($7 ne '') {
+ printf("%s%-9o%-9o%-9o%-9o%-3o.%-5o%o\n",$1,$2,$3,$4,$5,$6,$7,$8);
+ }
+ else {
+ printf("%s%-9o%-9o%-9o%-9o%-9o%o\n",$1,$2,$3,$4,$5,$6,$8);
+ }
+ }
+ }
+
If you would rather see this table listing hexadecimal values then
run the table through:
=over 4
! =item recipe 2
=back
perl -ne 'if(/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/)' \
! -e '{printf("%s%-9X%-9X%-9X%X\n",$1,$2,$3,$4,$5)}' perlebcdic.pod
+ Or, in order to retain the UTF-x code points in hexadecimal:
! =over 4
+ =item recipe 3
+
+ =back
+
+ open(FH,"<perlebcdic.pod") or die "Could not open perlebcdic.pod: $!";
+ while (<FH>) {
+ if (/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\.?(\d*)\s+(\d+)\.?(\d*)/) {
+ if ($7 ne '' && $9 ne '') {
+ printf("%s%-9X%-9X%-9X%-9X%-2X.%-6X%-2X.%X\n",$1,$2,$3,$4,$5,$6,$7,$8,$9);
+ }
+ elsif ($7 ne '') {
+ printf("%s%-9X%-9X%-9X%-9X%-2X.%-6X%X\n",$1,$2,$3,$4,$5,$6,$7,$8);
+ }
+ else {
+ printf("%s%-9X%-9X%-9X%-9X%-9X%X\n",$1,$2,$3,$4,$5,$6,$8);
+ }
+ }
+ }
+
+
+ incomp- incomp-
+ 8859-1 lete lete
+ chr 0819 0037 1047 POSIX-BC UTF-8 UTF-EBCDIC
+ ------------------------------------------------------------------------------------
+ <NULL> 0 0 0 0 0 0
+ <START OF HEADING> 1 1 1 1 1 1
+ <START OF TEXT> 2 2 2 2 2 2
+ <END OF TEXT> 3 3 3 3 3 3
+ <END OF TRANSMISSION> 4 55 55 55 4 55
+ <ENQUIRY> 5 45 45 45 5 45
+ <ACKNOWLEDGE> 6 46 46 46 6 46
+ <BELL> 7 47 47 47 7 47
+ <BACKSPACE> 8 22 22 22 8 22
+ <HORIZONTAL TABULATION> 9 5 5 5 9 5
+ <LINE FEED> 10 37 21 21 10 21 ***
+ <VERTICAL TABULATION> 11 11 11 11 11 11
+ <FORM FEED> 12 12 12 12 12 12
+ <CARRIAGE RETURN> 13 13 13 13 13 13
+ <SHIFT OUT> 14 14 14 14 14 14
+ <SHIFT IN> 15 15 15 15 15 15
+ <DATA LINK ESCAPE> 16 16 16 16 16 16
+ <DEVICE CONTROL ONE> 17 17 17 17 17 17
+ <DEVICE CONTROL TWO> 18 18 18 18 18 18
+ <DEVICE CONTROL THREE> 19 19 19 19 19 19
+ <DEVICE CONTROL FOUR> 20 60 60 60 20 60
+ <NEGATIVE ACKNOWLEDGE> 21 61 61 61 21 61
+ <SYNCHRONOUS IDLE> 22 50 50 50 22 50
+ <END OF TRANSMISSION BLOCK> 23 38 38 38 23 38
+ <CANCEL> 24 24 24 24 24 24
+ <END OF MEDIUM> 25 25 25 25 25 25
+ <SUBSTITUTE> 26 63 63 63 26 63
+ <ESCAPE> 27 39 39 39 27 39
+ <FILE SEPARATOR> 28 28 28 28 28 28
+ <GROUP SEPARATOR> 29 29 29 29 29 29
+ <RECORD SEPARATOR> 30 30 30 30 30 30
+ <UNIT SEPARATOR> 31 31 31 31 31 31
+ <SPACE> 32 64 64 64 32 64
+ ! 33 90 90 90 33 90
+ " 34 127 127 127 34 127
+ # 35 123 123 123 35 123
+ $ 36 91 91 91 36 91
+ % 37 108 108 108 37 108
+ & 38 80 80 80 38 80
+ ' 39 125 125 125 39 125
+ ( 40 77 77 77 40 77
+ ) 41 93 93 93 41 93
+ * 42 92 92 92 42 92
+ + 43 78 78 78 43 78
+ , 44 107 107 107 44 107
+ - 45 96 96 96 45 96
+ . 46 75 75 75 46 75
+ / 47 97 97 97 47 97
+ 0 48 240 240 240 48 240
+ 1 49 241 241 241 49 241
+ 2 50 242 242 242 50 242
+ 3 51 243 243 243 51 243
+ 4 52 244 244 244 52 244
+ 5 53 245 245 245 53 245
+ 6 54 246 246 246 54 246
+ 7 55 247 247 247 55 247
+ 8 56 248 248 248 56 248
+ 9 57 249 249 249 57 249
+ : 58 122 122 122 58 122
+ ; 59 94 94 94 59 94
+ < 60 76 76 76 60 76
+ = 61 126 126 126 61 126
+ > 62 110 110 110 62 110
+ ? 63 111 111 111 63 111
+ @ 64 124 124 124 64 124
+ A 65 193 193 193 65 193
+ B 66 194 194 194 66 194
+ C 67 195 195 195 67 195
+ D 68 196 196 196 68 196
+ E 69 197 197 197 69 197
+ F 70 198 198 198 70 198
+ G 71 199 199 199 71 199
+ H 72 200 200 200 72 200
+ I 73 201 201 201 73 201
+ J 74 209 209 209 74 209
+ K 75 210 210 210 75 210
+ L 76 211 211 211 76 211
+ M 77 212 212 212 77 212
+ N 78 213 213 213 78 213
+ O 79 214 214 214 79 214
+ P 80 215 215 215 80 215
+ Q 81 216 216 216 81 216
+ R 82 217 217 217 82 217
+ S 83 226 226 226 83 226
+ T 84 227 227 227 84 227
+ U 85 228 228 228 85 228
+ V 86 229 229 229 86 229
+ W 87 230 230 230 87 230
+ X 88 231 231 231 88 231
+ Y 89 232 232 232 89 232
+ Z 90 233 233 233 90 233
+ [ 91 186 173 187 91 173 *** ###
+ \ 92 224 224 188 92 224 ###
+ ] 93 187 189 189 93 189 ***
+ ^ 94 176 95 106 94 95 *** ###
+ _ 95 109 109 109 95 109
+ ` 96 121 121 74 96 121 ###
+ a 97 129 129 129 97 129
+ b 98 130 130 130 98 130
+ c 99 131 131 131 99 131
+ d 100 132 132 132 100 132
+ e 101 133 133 133 101 133
+ f 102 134 134 134 102 134
+ g 103 135 135 135 103 135
+ h 104 136 136 136 104 136
+ i 105 137 137 137 105 137
+ j 106 145 145 145 106 145
+ k 107 146 146 146 107 146
+ l 108 147 147 147 108 147
+ m 109 148 148 148 109 148
+ n 110 149 149 149 110 149
+ o 111 150 150 150 111 150
+ p 112 151 151 151 112 151
+ q 113 152 152 152 113 152
+ r 114 153 153 153 114 153
+ s 115 162 162 162 115 162
+ t 116 163 163 163 116 163
+ u 117 164 164 164 117 164
+ v 118 165 165 165 118 165
+ w 119 166 166 166 119 166
+ x 120 167 167 167 120 167
+ y 121 168 168 168 121 168
+ z 122 169 169 169 122 169
+ { 123 192 192 251 123 192 ###
+ | 124 79 79 79 124 79
+ } 125 208 208 253 125 208 ###
+ ~ 126 161 161 255 126 161 ###
+ <DELETE> 127 7 7 7 127 7
+ <C1 0> 128 32 32 32 194.128 32
+ <C1 1> 129 33 33 33 194.129 33
+ <C1 2> 130 34 34 34 194.130 34
+ <C1 3> 131 35 35 35 194.131 35
+ <C1 4> 132 36 36 36 194.132 36
+ <C1 5> 133 21 37 37 194.133 37 ***
+ <C1 6> 134 6 6 6 194.134 6
+ <C1 7> 135 23 23 23 194.135 23
+ <C1 8> 136 40 40 40 194.136 40
+ <C1 9> 137 41 41 41 194.137 41
+ <C1 10> 138 42 42 42 194.138 42
+ <C1 11> 139 43 43 43 194.139 43
+ <C1 12> 140 44 44 44 194.140 44
+ <C1 13> 141 9 9 9 194.141 9
+ <C1 14> 142 10 10 10 194.142 10
+ <C1 15> 143 27 27 27 194.143 27
+ <C1 16> 144 48 48 48 194.144 48
+ <C1 17> 145 49 49 49 194.145 49
+ <C1 18> 146 26 26 26 194.146 26
+ <C1 19> 147 51 51 51 194.147 51
+ <C1 20> 148 52 52 52 194.148 52
+ <C1 21> 149 53 53 53 194.149 53
+ <C1 22> 150 54 54 54 194.150 54
+ <C1 23> 151 8 8 8 194.151 8
+ <C1 24> 152 56 56 56 194.152 56
+ <C1 25> 153 57 57 57 194.153 57
+ <C1 26> 154 58 58 58 194.154 58
+ <C1 27> 155 59 59 59 194.155 59
+ <C1 28> 156 4 4 4 194.156 4
+ <C1 29> 157 20 20 20 194.157 20
+ <C1 30> 158 62 62 62 194.158 62
+ <C1 31> 159 255 255 95 194.159 255 ###
+ <NON-BREAKING SPACE> 160 65 65 65 194.160 128.65
+ <INVERTED EXCLAMATION MARK> 161 170 170 170 194.161 128.66
+ <CENT SIGN> 162 74 74 176 194.162 128.67 ###
+ <POUND SIGN> 163 177 177 177 194.163 128.68
+ <CURRENCY SIGN> 164 159 159 159 194.164 128.69
+ <YEN SIGN> 165 178 178 178 194.165 128.70
+ <BROKEN BAR> 166 106 106 208 194.166 128.71 ###
+ <SECTION SIGN> 167 181 181 181 194.167 128.72
+ <DIAERESIS> 168 189 187 121 194.168 128.73 *** ###
+ <COPYRIGHT SIGN> 169 180 180 180 194.169 128.74
+ <FEMININE ORDINAL INDICATOR> 170 154 154 154 194.170 128.81
+ <LEFT POINTING GUILLEMET> 171 138 138 138 194.171 128.82
+ <NOT SIGN> 172 95 176 186 194.172 128.83 *** ###
+ <SOFT HYPHEN> 173 202 202 202 194.173 128.84
+ <REGISTERED TRADE MARK SIGN> 174 175 175 175 194.174 128.85
+ <MACRON> 175 188 188 161 194.175 128.86 ###
+ <DEGREE SIGN> 176 144 144 144 194.176 128.87
+ <PLUS-OR-MINUS SIGN> 177 143 143 143 194.177 128.88
+ <SUPERSCRIPT TWO> 178 234 234 234 194.178 128.89
+ <SUPERSCRIPT THREE> 179 250 250 250 194.179 128.98
+ <ACUTE ACCENT> 180 190 190 190 194.180 128.99
+ <MICRO SIGN> 181 160 160 160 194.181 128.100
+ <PARAGRAPH SIGN> 182 182 182 182 194.182 128.101
+ <MIDDLE DOT> 183 179 179 179 194.183 128.102
+ <CEDILLA> 184 157 157 157 194.184 128.103
+ <SUPERSCRIPT ONE> 185 218 218 218 194.185 128.104
+ <MASC. ORDINAL INDICATOR> 186 155 155 155 194.186 128.105
+ <RIGHT POINTING GUILLEMET> 187 139 139 139 194.187 128.106
+ <FRACTION ONE QUARTER> 188 183 183 183 194.188 128.112
+ <FRACTION ONE HALF> 189 184 184 184 194.189 128.113
+ <FRACTION THREE QUARTERS> 190 185 185 185 194.190 128.114
+ <INVERTED QUESTION MARK> 191 171 171 171 194.191 128.115
+ <A WITH GRAVE> 192 100 100 100 195.128 138.65
+ <A WITH ACUTE> 193 101 101 101 195.129 138.66
+ <A WITH CIRCUMFLEX> 194 98 98 98 195.130 138.67
+ <A WITH TILDE> 195 102 102 102 195.131 138.68
+ <A WITH DIAERESIS> 196 99 99 99 195.132 138.69
+ <A WITH RING ABOVE> 197 103 103 103 195.133 138.70
+ <CAPITAL LIGATURE AE> 198 158 158 158 195.134 138.71
+ <C WITH CEDILLA> 199 104 104 104 195.135 138.72
+ <E WITH GRAVE> 200 116 116 116 195.136 138.73
+ <E WITH ACUTE> 201 113 113 113 195.137 138.74
+ <E WITH CIRCUMFLEX> 202 114 114 114 195.138 138.81
+ <E WITH DIAERESIS> 203 115 115 115 195.139 138.82
+ <I WITH GRAVE> 204 120 120 120 195.140 138.83
+ <I WITH ACUTE> 205 117 117 117 195.141 138.84
+ <I WITH CIRCUMFLEX> 206 118 118 118 195.142 138.85
+ <I WITH DIAERESIS> 207 119 119 119 195.143 138.86
+ <CAPITAL LETTER ETH> 208 172 172 172 195.144 138.87
+ <N WITH TILDE> 209 105 105 105 195.145 138.88
+ <O WITH GRAVE> 210 237 237 237 195.146 138.89
+ <O WITH ACUTE> 211 238 238 238 195.147 138.98
+ <O WITH CIRCUMFLEX> 212 235 235 235 195.148 138.99
+ <O WITH TILDE> 213 239 239 239 195.149 138.100
+ <O WITH DIAERESIS> 214 236 236 236 195.150 138.101
+ <MULTIPLICATION SIGN> 215 191 191 191 195.151 138.102
+ <O WITH STROKE> 216 128 128 128 195.152 138.103
+ <U WITH GRAVE> 217 253 253 224 195.153 138.104 ###
+ <U WITH ACUTE> 218 254 254 254 195.154 138.105
+ <U WITH CIRCUMFLEX> 219 251 251 221 195.155 138.106 ###
+ <U WITH DIAERESIS> 220 252 252 252 195.156 138.112
+ <Y WITH ACUTE> 221 173 186 173 195.157 138.113 *** ###
+ <CAPITAL LETTER THORN> 222 174 174 174 195.158 138.114
+ <SMALL LETTER SHARP S> 223 89 89 89 195.159 138.115
+ <a WITH GRAVE> 224 68 68 68 195.160 139.65
+ <a WITH ACUTE> 225 69 69 69 195.161 139.66
+ <a WITH CIRCUMFLEX> 226 66 66 66 195.162 139.67
+ <a WITH TILDE> 227 70 70 70 195.163 139.68
+ <a WITH DIAERESIS> 228 67 67 67 195.164 139.69
+ <a WITH RING ABOVE> 229 71 71 71 195.165 139.70
+ <SMALL LIGATURE ae> 230 156 156 156 195.166 139.71
+ <c WITH CEDILLA> 231 72 72 72 195.167 139.72
+ <e WITH GRAVE> 232 84 84 84 195.168 139.73
+ <e WITH ACUTE> 233 81 81 81 195.169 139.74
+ <e WITH CIRCUMFLEX> 234 82 82 82 195.170 139.81
+ <e WITH DIAERESIS> 235 83 83 83 195.171 139.82
+ <i WITH GRAVE> 236 88 88 88 195.172 139.83
+ <i WITH ACUTE> 237 85 85 85 195.173 139.84
+ <i WITH CIRCUMFLEX> 238 86 86 86 195.174 139.85
+ <i WITH DIAERESIS> 239 87 87 87 195.175 139.86
+ <SMALL LETTER eth> 240 140 140 140 195.176 139.87
+ <n WITH TILDE> 241 73 73 73 195.177 139.88
+ <o WITH GRAVE> 242 205 205 205 195.178 139.89
+ <o WITH ACUTE> 243 206 206 206 195.179 139.98
+ <o WITH CIRCUMFLEX> 244 203 203 203 195.180 139.99
+ <o WITH TILDE> 245 207 207 207 195.181 139.100
+ <o WITH DIAERESIS> 246 204 204 204 195.182 139.101
+ <DIVISION SIGN> 247 225 225 225 195.183 139.102
+ <o WITH STROKE> 248 112 112 112 195.184 139.103
+ <u WITH GRAVE> 249 221 221 192 195.185 139.104 ###
+ <u WITH ACUTE> 250 222 222 222 195.186 139.105
+ <u WITH CIRCUMFLEX> 251 219 219 219 195.187 139.106
+ <u WITH DIAERESIS> 252 220 220 220 195.188 139.112
+ <y WITH ACUTE> 253 141 141 141 195.189 139.113
+ <SMALL LETTER thorn> 254 142 142 142 195.190 139.114
+ <y WITH DIAERESIS> 255 223 223 223 195.191 139.115
+
If you would rather see the above table in CCSID 0037 order rather than
ASCII + Latin-1 order then run the table through:
=over 4
! =item recipe 4
=back
***************
*** 410,416 ****
perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)'\
-e '{push(@l,$_)}' \
-e 'END{print map{$_->[0]}' \
! -e ' sort{$a->[1] <=> $b->[1]}' \
-e ' map{[$_,substr($_,42,3)]}@l;}' perlebcdic.pod
If you would rather see it in CCSID 1047 order then change the digit
--- 466,472 ----
perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)'\
-e '{push(@l,$_)}' \
-e 'END{print map{$_->[0]}' \
! -e ' sort{$a->[1] <=> $b->[1]}' \
-e ' map{[$_,substr($_,42,3)]}@l;}' perlebcdic.pod
If you would rather see it in CCSID 1047 order then change the digit
***************
*** 418,424 ****
=over 4
! =item recipe 3
=back
--- 474,480 ----
=over 4
! =item recipe 5
=back
***************
*** 425,431 ****
perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)'\
-e '{push(@l,$_)}' \
-e 'END{print map{$_->[0]}' \
! -e ' sort{$a->[1] <=> $b->[1]}' \
-e ' map{[$_,substr($_,51,3)]}@l;}' perlebcdic.pod
If you would rather see it in POSIX-BC order then change the digit
--- 481,487 ----
perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)'\
-e '{push(@l,$_)}' \
-e 'END{print map{$_->[0]}' \
! -e ' sort{$a->[1] <=> $b->[1]}' \
-e ' map{[$_,substr($_,51,3)]}@l;}' perlebcdic.pod
If you would rather see it in POSIX-BC order then change the digit
***************
*** 433,439 ****
=over 4
! =item recipe 4
=back
--- 489,495 ----
=over 4
! =item recipe 6
=back
***************
*** 440,446 ****
perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)'\
-e '{push(@l,$_)}' \
-e 'END{print map{$_->[0]}' \
! -e ' sort{$a->[1] <=> $b->[1]}' \
-e ' map{[$_,substr($_,60,3)]}@l;}' perlebcdic.pod
--- 496,502 ----
perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)'\
-e '{push(@l,$_)}' \
-e 'END{print map{$_->[0]}' \
! -e ' sort{$a->[1] <=> $b->[1]}' \
-e ' map{[$_,substr($_,60,3)]}@l;}' perlebcdic.pod
***************
*** 541,555 ****
available from the shell or from the C library. Consult your system's
documentation for information on iconv.
! On OS/390 see the iconv(1) man page. One way to invoke the iconv
shell utility from within perl would be to:
! # OS/390 example
$ascii_data = `echo '$ebcdic_data'| iconv -f IBM-1047 -t ISO8859-1`
or the inverse map:
! # OS/390 example
$ebcdic_data = `echo '$ascii_data'| iconv -f ISO8859-1 -t IBM-1047`
For other perl based conversion options see the Convert::* modules on CPAN.
--- 597,611 ----
available from the shell or from the C library. Consult your system's
documentation for information on iconv.
! On OS/390 or z/OS see the iconv(1) manpage. One way to invoke the iconv
shell utility from within perl would be to:
! # OS/390 or z/OS example
$ascii_data = `echo '$ebcdic_data'| iconv -f IBM-1047 -t ISO8859-1`
or the inverse map:
! # OS/390 or z/OS example
$ebcdic_data = `echo '$ascii_data'| iconv -f ISO8859-1 -t IBM-1047`
For other perl based conversion options see the Convert::* modules on CPAN.
***************
*** 556,562 ****
=head2 C RTL
! The OS/390 C run time library provides _atoe() and _etoa() functions.
=head1 OPERATOR DIFFERENCES
--- 612,618 ----
=head2 C RTL
! The OS/390 and z/OS C run time libraries provide _atoe() and _etoa() functions.
=head1 OPERATOR DIFFERENCES
***************
*** 675,682 ****
print "Content-type:\ttext/html\015\012\015\012";
# this may be wrong on EBCDIC
! Under the IBM OS/390 USS Web Server for example you should instead
! write that as:
print "Content-type:\ttext/html\r\n\r\n"; # OK for DGW et alia
--- 731,738 ----
print "Content-type:\ttext/html\015\012\015\012";
# this may be wrong on EBCDIC
! Under the IBM OS/390 USS Web Server or WebSphere on z/OS for example
! you should instead write that as:
print "Content-type:\ttext/html\r\n\r\n"; # OK for DGW et alia
***************
*** 909,915 ****
This strategy can employ a network connection. As such
it would be computationally expensive.
! =head1 TRANFORMATION FORMATS
There are a variety of ways of transforming data with an intra character set
mapping that serve a variety of purposes. Sorting was discussed in the
--- 965,971 ----
This strategy can employ a network connection. As such
it would be computationally expensive.
! =head1 TRANSFORMATION FORMATS
There are a variety of ways of transforming data with an intra character set
mapping that serve a variety of purposes. Sorting was discussed in the
***************
*** 1073,1079 ****
$string =~ s/=([0-9A-Fa-f][0-9A-Fa-f])/chr $a2e[hex $1]/ge;
$string =~ s/=[\n\r]+$//;
! =head2 Caesarian cyphers
The practice of shifting an alphabet one or more characters for encipherment
dates back thousands of years and was explicitly detailed by Gaius Julius
--- 1129,1135 ----
$string =~ s/=([0-9A-Fa-f][0-9A-Fa-f])/chr $a2e[hex $1]/ge;
$string =~ s/=[\n\r]+$//;
! =head2 Caesarian ciphers
The practice of shifting an alphabet one or more characters for encipherment
dates back thousands of years and was explicitly detailed by Gaius Julius
***************
*** 1100,1105 ****
--- 1156,1164 ----
=head1 Hashing order and checksums
+ To the extent that it is possible to write code that depends on
+ hashing order there may be differences between hashes as stored
+ on an ASCII based machine and hashes stored on an EBCDIC based machine.
XXX
=head1 I18N AND L10N
***************
*** 1110,1117 ****
=head1 MULTI OCTET CHARACTER SETS
! Multi byte EBCDIC code pages; Unicode, UTF-8, UTF-EBCDIC, XXX.
=head1 OS ISSUES
There may be a few system dependent issues
--- 1169,1180 ----
=head1 MULTI OCTET CHARACTER SETS
! Perl may work with an internal UTF-EBCDIC encoding form for wide characters
! on EBCDIC platforms in a manner analogous to the way that it works with
! the UTF-8 internal encoding form on ASCII based platforms.
+ Legacy multi byte EBCDIC code pages XXX.
+
=head1 OS ISSUES
There may be a few system dependent issues
***************
*** 1129,1135 ****
=back
! =head2 OS/390
Perl runs under Unix Systems Services or USS.
--- 1192,1198 ----
=back
! =head2 OS/390, z/OS
Perl runs under Unix Systems Services or USS.
***************
*** 1152,1158 ****
See also the OS390::Stdio module on CPAN.
! =item OS/390 iconv
B<iconv> is supported as both a shell utility and a C RTL routine.
See also the iconv(1) and iconv(3) manual pages.
--- 1215,1221 ----
See also the OS390::Stdio module on CPAN.
! =item OS/390, z/OS iconv
B<iconv> is supported as both a shell utility and a C RTL routine.
See also the iconv(1) and iconv(3) manual pages.
***************
*** 1159,1166 ****
=item locales
! On OS/390 see L<locale> for information on locales. The L10N files
! are in F</usr/nls/locale>. $Config{d_setlocale} is 'define' on OS/390.
=back
--- 1222,1230 ----
=item locales
! On OS/390 or z/OS see L<locale> for information on locales. The L10N files
! are in F</usr/nls/locale>. $Config{d_setlocale} is 'define' on OS/390
! or z/OS.
=back
***************
*** 1179,1196 ****
was known to strip accented characters to their unaccented counterparts
while attempting to view this document through the B<pod2man> program
(for example, you may see a plain C<y> rather than one with a diaeresis
! as in E<yuml>). Another nroff truncated the resultant man page at
! the first occurence of 8 bit characters.
Not all shells will allow multiple C<-e> string arguments to perl to
! be concatenated together properly as recipes 2, 3, and 4 might seem
! to imply.
- Perl does not yet work with any Unicode features on EBCDIC platforms.
-
=head1 SEE ALSO
! L<perllocale>, L<perlfunc>.
=head1 REFERENCES
--- 1243,1258 ----
was known to strip accented characters to their unaccented counterparts
while attempting to view this document through the B<pod2man> program
(for example, you may see a plain C<y> rather than one with a diaeresis
! as in E<yuml>). Another nroff truncated the resultant manpage at
! the first occurrence of 8 bit characters.
Not all shells will allow multiple C<-e> string arguments to perl to
! be concatenated together properly as recipes 0, 2, 4, 5, and 6 might
! seem to imply.
=head1 SEE ALSO
! L<perllocale>, L<perlfunc>, L<perlunicode>, L<utf8>.
=head1 REFERENCES
***************
*** 1204,1213 ****
B<ASCII: American Standard Code for Information Infiltration> Tom Jennings,
September 1999.
! B<The Unicode Standard Version 2.0> The Unicode Consortium,
! ISBN 0-201-48345-9, Addison Wesley Developers Press, July 1996.
!
! B<The Unicode Standard Version 3.0> The Unicode Consortium, Lisa Moore ed.,
ISBN 0-201-61633-5, Addison Wesley Developers Press, February 2000.
B<CDRA: IBM - Character Data Representation Architecture -
--- 1266,1272 ----
B<ASCII: American Standard Code for Information Infiltration> Tom Jennings,
September 1999.
! B<The Unicode Standard, Version 3.0> The Unicode Consortium, Lisa Moore ed.,
ISBN 0-201-61633-5, Addison Wesley Developers Press, February 2000.
B<CDRA: IBM - Character Data Representation Architecture -
***************
*** 1220,1225 ****
--- 1279,1291 ----
B<Codes, Ciphers, and Other Cryptic and Clandestine Communication>
Fred B. Wrixon, ISBN 1-57912-040-7, Black Dog & Leventhal Publishers,
1998.
+
+ http://www.bobbemer.com/P-BIT.HTM
+ B<IBM - EBCDIC and the P-bit; The biggest Computer Goof Ever> Robert Bemer.
+
+ =head1 HISTORY
+
+ 15 April 2001: added UTF-8 and UTF-EBCDIC to main table, pvhp.
=head1 AUTHOR
diff -c 'perl-5.7.1/pod/perlfaq.pod' 'perl-5.7.2/pod/perlfaq.pod'
Index: ./pod/perlfaq.pod
*** ./pod/perlfaq.pod Tue Mar 6 04:06:29 2001
--- ./pod/perlfaq.pod Mon Jul 9 17:11:12 2001
***************
*** 692,697 ****
--- 692,701 ----
=item *
+ All I want to do is append a small amount of text to the end of a file. Do I still have to use locking?
+
+ =item *
+
How do I randomly update a binary file?
=item *
diff -c 'perl-5.7.1/pod/perlfaq1.pod' 'perl-5.7.2/pod/perlfaq1.pod'
Index: ./pod/perlfaq1.pod
*** ./pod/perlfaq1.pod Sun Apr 1 22:11:25 2001
--- ./pod/perlfaq1.pod Mon Jul 9 17:11:12 2001
***************
*** 259,268 ****
Over a hundred quips by Larry, from postings of his or source code,
can be found at http://www.perl.com/CPAN/misc/lwall-quotes.txt.gz .
- Newer examples can be found by perusing Larry's postings:
-
- http://x1.dejanews.com/dnquery.xp?QRY=*&DBS=2&ST=PS&defaultOp=AND&LNG=ALL&format=terse&showsort=date&maxhits=100&subjects=&groups=&authors=larry@*wall.org&fromdate=&todate=
-
=head2 How can I convince my sysadmin/supervisor/employees to use version 5/5.005/Perl instead of some other language?
If your manager or employees are wary of unsupported software, or
--- 259,264 ----
***************
*** 310,315 ****
--- 306,315 ----
found in the optional 'suidperl' (not built or installed by default)
in all the Perl branches 5.6, 5.005, and 5.004, see
http://www.cpan.org/src/5.0/sperl-2000-08-05/
+ Perl maintenance releases 5.6.1 and 5.8.0 have this security hole closed.
+ Most, if not all, Linux distribution have patches for this
+ vulnerability available, see http://www.linuxsecurity.com/advisories/ ,
+ but the most recommendable way is to upgrade to at least Perl 5.6.1.
=head1 AUTHOR AND COPYRIGHT
diff -c 'perl-5.7.1/pod/perlfaq2.pod' 'perl-5.7.2/pod/perlfaq2.pod'
Index: ./pod/perlfaq2.pod
*** ./pod/perlfaq2.pod Tue Mar 6 04:06:29 2001
--- ./pod/perlfaq2.pod Mon Jul 9 17:11:12 2001
***************
*** 41,47 ****
Some URLs that might help you are:
http://www.cpan.org/ports/
! http://language.perl.com/info/software.html
Someone looking for a Perl for Win16 might look to Laszlo Molnar's djgpp
port in http://www.cpan.org/ports/#msdos , which comes with clear
--- 41,47 ----
Some URLs that might help you are:
http://www.cpan.org/ports/
! http://www.perl.com/pub/language/info/software.html
Someone looking for a Perl for Win16 might look to Laszlo Molnar's djgpp
port in http://www.cpan.org/ports/#msdos , which comes with clear
***************
*** 224,253 ****
ISBN 1-56592-243-3 [1st Edition August 1998]
http://perl.oreilly.com/cookbook/
! If you're already a hard-core systems programmer, then the Camel Book
! might suffice for you to learn Perl from. If you're not, check out
! Learning Perl (the "Llama Book"):
! by Randal Schwartz and Tom Christiansen
! with Foreword by Larry Wall
! ISBN 1-56592-284-0 [2nd Edition July 1997]
! http://www.oreilly.com/catalog/lperl2/
! Despite the picture at the URL above, the second edition of "Llama
! Book" really has a blue cover and was updated for the 5.004 release
! of Perl. Various foreign language editions are available, including
! I<Learning Perl on Win32 Systems> (the "Gecko Book").
! If you're not an accidental programmer, but a more serious and possibly
! even degreed computer scientist who doesn't need as much hand-holding as
! we try to provide in the Llama or its defurred cousin the Gecko, please
! check out the delightful book, I<Perl: The Programmer's Companion>,
! written by Nigel Chapman.
Addison-Wesley (http://www.awlonline.com/) and Manning
(http://www.manning.com/) are also publishers of some fine Perl books
! such as Object Oriented Programming with Perl by Damian Conway and
! Network Programming with Perl by Lincoln Stein.
An excellent technical book discounter is Bookpool at
http://www.bookpool.com/ where a 30% discount or more is not unusual.
--- 224,262 ----
ISBN 1-56592-243-3 [1st Edition August 1998]
http://perl.oreilly.com/cookbook/
! If you're already a seasoned programmer, then the Camel Book might
! suffice for you to learn Perl from. If you're not, check out the
! Llama book:
! Learning Perl (the "Llama Book")
! by Randal L. Schwartz and Tom Phoenix
! ISBN 0-596-00132-0 [3rd edition July 2001]
! http://www.oreilly.com/catalog/lperl3/
! If you're not an accidental programmer, but a more serious and
! possibly even degreed computer scientist who doesn't need as much
! hand-holding as we try to provide in the Llama, please check out the
! delightful book
! Perl: The Programmer's Companion
! by Nigel Chapman
! ISBN 0-471-97563-X [1997, 3rd printing Spring 1998]
! http://www.wiley.com/compbooks/catalog/97563-X.htm
! http://www.wiley.com/compbooks/chapman/perl/perltpc.html (errata etc)
+ If you are more at home in Windows the following is available
+ (though unfortunately rather dated).
+
+ Learning Perl on Win32 Systems (the "Gecko Book")
+ by Randal L. Schwartz, Erik Olson, and Tom Christiansen,
+ with foreword by Larry Wall
+ ISBN 1-56592-324-3 [1st edition August 1997]
+ http://www.oreilly.com/catalog/lperlwin/
+
Addison-Wesley (http://www.awlonline.com/) and Manning
(http://www.manning.com/) are also publishers of some fine Perl books
! such as I<Object Oriented Programming with Perl> by Damian Conway and
! I<Network Programming with Perl> by Lincoln Stein.
An excellent technical book discounter is Bookpool at
http://www.bookpool.com/ where a 30% discount or more is not unusual.
***************
*** 284,293 ****
http://www.manning.com/Johnson/
Learning Perl
! by Randal L. Schwartz and Tom Christiansen
! with foreword by Larry Wall
! ISBN 1-56592-284-0 [2nd edition July 1997]
! http://www.oreilly.com/catalog/lperl2/
Learning Perl on Win32 Systems
by Randal L. Schwartz, Erik Olson, and Tom Christiansen,
--- 293,301 ----
http://www.manning.com/Johnson/
Learning Perl
! by Randal L. Schwartz and Tom Phoenix
! ISBN 0-596-00132-0 [3rd edition July 2001]
! http://www.oreilly.com/catalog/lperl3/
Learning Perl on Win32 Systems
by Randal L. Schwartz, Erik Olson, and Tom Christiansen,
***************
*** 297,304 ****
Perl: The Programmer's Companion
by Nigel Chapman
! ISBN 0-471-97563-X [1st edition October 1997]
! http://catalog.wiley.com/title.cgi?isbn=047197563X
Cross-Platform Perl
by Eric Foster-Johnson
--- 305,313 ----
Perl: The Programmer's Companion
by Nigel Chapman
! ISBN 0-471-97563-X [1997, 3rd printing Spring 1998]
! http://www.wiley.com/compbooks/catalog/97563-X.htm
! http://www.wiley.com/compbooks/chapman/perl/perltpc.html (errata etc)
Cross-Platform Perl
by Eric Foster-Johnson
***************
*** 358,376 ****
=head2 Perl in Magazines
The first and only periodical devoted to All Things Perl, I<The
! Perl Journal> contained tutorials, demonstrations, case studies,
! announcements, contests, and much more. I<TPJ> had columns on web
development, databases, Win32 Perl, graphical programming, regular
expressions, and networking, and sponsored the Obfuscated Perl
! Contest. Sadly, this publication is no longer in circulation, but
! should it be resurrected, it will most likely be announced on
! http://use.perl.org/ .
Beyond this, magazines that frequently carry high-quality articles
on Perl are I<Web Techniques> (see http://www.webtechniques.com/),
I<Performance Computing> (http://www.performance-computing.com/), and Usenix's
newsletter/magazine to its members, I<login:>, at http://www.usenix.org/.
! Randal's Web Technique's columns are available on the web at
http://www.stonehenge.com/merlyn/WebTechniques/ .
=head2 Perl on the Net: FTP and WWW Access
--- 367,384 ----
=head2 Perl in Magazines
The first and only periodical devoted to All Things Perl, I<The
! Perl Journal> contains tutorials, demonstrations, case studies,
! announcements, contests, and much more. I<TPJ> has columns on web
development, databases, Win32 Perl, graphical programming, regular
expressions, and networking, and sponsored the Obfuscated Perl
! Contest. For more details on I<The Perl Journal>, see
! http://www.tpj.com/
Beyond this, magazines that frequently carry high-quality articles
on Perl are I<Web Techniques> (see http://www.webtechniques.com/),
I<Performance Computing> (http://www.performance-computing.com/), and Usenix's
newsletter/magazine to its members, I<login:>, at http://www.usenix.org/.
! Randal's Web Techniques columns are available on the web at
http://www.stonehenge.com/merlyn/WebTechniques/ .
=head2 Perl on the Net: FTP and WWW Access
***************
*** 395,400 ****
--- 403,409 ----
One may also use xx.cpan.org where "xx" is the 2-letter country code
for your domain; e.g. Australia would use au.cpan.org.
+ [Note: This only applies to countries that host at least one mirror.]
=head2 What mailing lists are there for Perl?
***************
*** 406,428 ****
=head2 Archives of comp.lang.perl.misc
! Have you tried Deja or AltaVista? Those are the
! best archives. Just look up "*perl*" as a newsgroup.
! http://www.deja.com/dnquery.xp?QRY=&DBS=2&ST=PS&defaultOp=AND&LNG=ALL&format=terse&showsort=date&maxhits=25&subjects=&groups=*perl*&authors=&fromdate=&todate=
! You might want to trim that down a bit, though.
- You'll probably want more a sophisticated query and retrieval mechanism
- than a file listing, preferably one that allows you to retrieve
- articles using a fast-access indices, keyed on at least author, date,
- subject, thread (as in "trn") and probably keywords. The best
- solution the FAQ authors know of is the MH pick command, but it is
- very slow to select on 18000 articles.
-
- If you have, or know where can be found, the missing sections, please
- let perlfaq-suggestions@perl.com know.
-
=head2 Where can I buy a commercial version of Perl?
In a real sense, Perl already I<is> commercial software: it has a license
--- 415,430 ----
=head2 Archives of comp.lang.perl.misc
! The Google search engine now carries archived and searchable newsgroup
! content.
! http://groups.google.com/groups?hl=en&lr=&safe=off&group=comp.lang.perl.misc
! If you have a question, you can be sure someone has already asked the
! same question at some point on c.l.p.m. It requires some time and patience
! to sift through all the content but often you will find the answer you
! seek.
=head2 Where can I buy a commercial version of Perl?
In a real sense, Perl already I<is> commercial software: it has a license
***************
*** 486,498 ****
=head2 What is perl.com? Perl Mongers? pm.org? perl.org?
! The Perl Home Page at http://www.perl.com/ is currently hosted on a
! T3 line courtesy of Songline Systems, a software-oriented subsidiary of
! O'Reilly and Associates. Other starting points include
!
! http://language.perl.com/
! http://conference.perl.com/
! http://reference.perl.com/
Perl Mongers is an advocacy organization for the Perl language which
maintains the web site http://www.perl.org/ as a general advocacy
--- 488,495 ----
=head2 What is perl.com? Perl Mongers? pm.org? perl.org?
! The Perl Home Page at http://www.perl.com/ is currently hosted by
! The O'Reilly Network, a subsidiary of O'Reilly and Associates.
Perl Mongers is an advocacy organization for the Perl language which
maintains the web site http://www.perl.org/ as a general advocacy
diff -c 'perl-5.7.1/pod/perlfaq3.pod' 'perl-5.7.2/pod/perlfaq3.pod'
Index: ./pod/perlfaq3.pod
*** ./pod/perlfaq3.pod Fri Apr 6 17:50:45 2001
--- ./pod/perlfaq3.pod Mon Jul 9 17:11:12 2001
***************
*** 11,17 ****
Have you looked at CPAN (see L<perlfaq2>)? The chances are that
someone has already written a module that can solve your problem.
! Have you read the appropriate man pages? Here's a brief index:
Basics perldata, perlvar, perlsyn, perlop, perlsub
Execution perlrun, perldebug
--- 11,17 ----
Have you looked at CPAN (see L<perlfaq2>)? The chances are that
someone has already written a module that can solve your problem.
! Have you read the appropriate manpages? Here's a brief index:
Basics perldata, perlvar, perlsyn, perlop, perlsub
Execution perlrun, perldebug
***************
*** 25,36 ****
Various http://www.perl.com/CPAN/doc/FMTEYEWTK/index.html
(not a man-page but still useful)
! A crude table of contents for the Perl man page set is found in L<perltoc>.
=head2 How can I use Perl interactively?
The typical approach uses the Perl debugger, described in the
! perldebug(1) man page, on an ``empty'' program, like this:
perl -de 42
--- 25,36 ----
Various http://www.perl.com/CPAN/doc/FMTEYEWTK/index.html
(not a man-page but still useful)
! A crude table of contents for the Perl manpage set is found in L<perltoc>.
=head2 How can I use Perl interactively?
The typical approach uses the Perl debugger, described in the
! perldebug(1) manpage, on an ``empty'' program, like this:
perl -de 42
***************
*** 163,202 ****
philosophy is the philosophy of several small tools that each do one
thing and do it well. It's like a carpenter's toolbox.
! If you want a Windows IDE, check the following:
=over 4
- =item CodeMagicCD
-
- http://www.codemagiccd.com/
-
=item Komodo
! ActiveState's cross-platform, multi-language IDE has Perl support,
! including a regular expression debugger and remote debugging
! (http://www.ActiveState.com/Products/Komodo/index.html).
! (Visual Perl, a Visual Studio.NET plug-in is currently (early 2001)
! in beta (http://www.ActiveState.com/Products/VisualPerl/index.html)).
=item The Object System
(http://www.castlelink.co.uk/object_system/) is a Perl web
! applications development IDE.
=item PerlBuilder
(http://www.solutionsoft.com/perl.htm) is an integrated development
environment for Windows that supports Perl development.
! =item Perl code magic
! (http://www.petes-place.com/codemagic.html).
! =item visiPerl+
! http://helpconsulting.net/visiperl/, from Help Consulting.
=back
For editors: if you're on Unix you probably have vi or a vi clone already,
--- 163,217 ----
philosophy is the philosophy of several small tools that each do one
thing and do it well. It's like a carpenter's toolbox.
! If you want an IDE, check the following:
=over 4
=item Komodo
! ActiveState's cross-platform (as of April 2001 Windows and Linux),
! multi-language IDE has Perl support, including a regular expression
! debugger and remote debugging
! (http://www.ActiveState.com/Products/Komodo/index.html). (Visual
! Perl, a Visual Studio.NET plug-in is currently (early 2001) in beta
! (http://www.ActiveState.com/Products/VisualPerl/index.html)).
=item The Object System
(http://www.castlelink.co.uk/object_system/) is a Perl web
! applications development IDE, apparently for any platform
! that runs Perl.
+ =item Open Perl IDE
+
+ ( http://open-perl-ide.sourceforge.net/ )
+ Open Perl IDE is an integrated development environment for writing
+ and debugging Perl scripts with ActiveState's ActivePerl distribution
+ under Windows 95/98/NT/2000.
+
=item PerlBuilder
(http://www.solutionsoft.com/perl.htm) is an integrated development
environment for Windows that supports Perl development.
! =item visiPerl+
! ( http://helpconsulting.net/visiperl/ )
! From Help Consulting, for Windows.
! =back
! For Windows there's also the
+ =over 4
+
+ =item CodeMagicCD
+
+ ( http://www.codemagiccd.com/ ) Collection of various programming
+ tools for Windows: Perl (5.005_03), TclTk, Python, GNU programming
+ tools, REBOL, wxWindows toolkit, the MinGW GNU C/C++ compiler, DJGPP
+ GNU C/C++ compiler, Cint C interpreter, YaBasic.
+
=back
For editors: if you're on Unix you probably have vi or a vi clone already,
***************
*** 398,404 ****
on optimization, too. Advice on benchmarking boils down to: benchmark
and profile to make sure you're optimizing the right part, look for
better algorithms instead of microtuning your code, and when all else
! fails consider just buying faster hardware.
A different approach is to autoload seldom-used Perl code. See the
AutoSplit and AutoLoader modules in the standard distribution for
--- 413,421 ----
on optimization, too. Advice on benchmarking boils down to: benchmark
and profile to make sure you're optimizing the right part, look for
better algorithms instead of microtuning your code, and when all else
! fails consider just buying faster hardware. You will probably want to
! read the answer to the earlier question ``How do I profile my Perl programs?''
! if you haven't done so already.
A different approach is to autoload seldom-used Perl code. See the
AutoSplit and AutoLoader modules in the standard distribution for
***************
*** 557,570 ****
source. Security through obscurity, the name for hiding your bugs
instead of fixing them, is little security indeed.
! You can try using encryption via source filters (Filter::* from CPAN),
! but any decent programmer will be able to decrypt it. You can try using
! the byte code compiler and interpreter described below, but the curious
! might still be able to de-compile it. You can try using the native-code
! compiler described below, but crackers might be able to disassemble it.
! These pose varying degrees of difficulty to people wanting to get at
! your code, but none can definitively conceal it (true of every
! language, not just Perl).
If you're concerned about people profiting from your code, then the
bottom line is that nothing but a restrictive license will give you
--- 574,588 ----
source. Security through obscurity, the name for hiding your bugs
instead of fixing them, is little security indeed.
! You can try using encryption via source filters (Starting from Perl
! 5.8 the Filter::Simple and Filter::Util::Call modules are included in
! the standard distribution), but any decent programmer will be able to
! decrypt it. You can try using the byte code compiler and interpreter
! described below, but the curious might still be able to de-compile it.
! You can try using the native-code compiler described below, but
! crackers might be able to disassemble it. These pose varying degrees
! of difficulty to people wanting to get at your code, but none can
! definitively conceal it (true of every language, not just Perl).
If you're concerned about people profiting from your code, then the
bottom line is that nothing but a restrictive license will give you
diff -c 'perl-5.7.1/pod/perlfaq4.pod' 'perl-5.7.2/pod/perlfaq4.pod'
Index: ./pod/perlfaq4.pod
*** ./pod/perlfaq4.pod Tue Mar 6 04:06:29 2001
--- ./pod/perlfaq4.pod Fri Jul 13 04:07:07 2001
***************
*** 39,44 ****
--- 39,49 ----
(part of the standard Perl distribution), but mathematical operations
are consequently slower.
+ If precision is important, such as when dealing with money, it's good
+ to work with integers and then divide at the last possible moment.
+ For example, work in pennies (1995) instead of dollars and cents
+ (19.95) and divide by 100 at the end.
+
To get rid of the superfluous digits, just use a format (eg,
C<printf("%.2f", 19.95)>) to get the required precision.
See L<perlop/"Floating-point Arithmetic">.
***************
*** 46,64 ****
=head2 Why isn't my octal data interpreted correctly?
Perl only understands octal and hex numbers as such when they occur
! as literals in your program. If they are read in from somewhere and
! assigned, no automatic conversion takes place. You must explicitly
! use oct() or hex() if you want the values converted. oct() interprets
both hex ("0x350") numbers and octal ones ("0350" or even without the
leading "0", like "377"), while hex() only converts hexadecimal ones,
with or without a leading "0x", like "0x255", "3A", "ff", or "deadbeef".
This problem shows up most often when people try using chmod(), mkdir(),
! umask(), or sysopen(), which all want permissions in octal.
! chmod(644, $file); # WRONG -- perl -w catches this
chmod(0644, $file); # right
=head2 Does Perl have a round() function? What about ceil() and floor()? Trig functions?
Remember that int() merely truncates toward 0. For rounding to a
--- 51,86 ----
=head2 Why isn't my octal data interpreted correctly?
Perl only understands octal and hex numbers as such when they occur
! as literals in your program. Octal literals in perl must start with
! a leading "0" and hexadecimal literals must start with a leading "0x".
! If they are read in from somewhere and assigned, no automatic
! conversion takes place. You must explicitly use oct() or hex() if you
! want the values converted to decimal. oct() interprets
both hex ("0x350") numbers and octal ones ("0350" or even without the
leading "0", like "377"), while hex() only converts hexadecimal ones,
with or without a leading "0x", like "0x255", "3A", "ff", or "deadbeef".
+ The inverse mapping from decimal to octal can be done with either the
+ "%o" or "%O" sprintf() formats. To get from decimal to hex try either
+ the "%x" or the "%X" formats to sprintf().
This problem shows up most often when people try using chmod(), mkdir(),
! umask(), or sysopen(), which by widespread tradition typically take
! permissions in octal.
! chmod(644, $file); # WRONG
chmod(0644, $file); # right
+ Note the mistake in the first line was specifying the decimal literal
+ 644, rather than the intended octal literal 0644. The problem can
+ be seen with:
+
+ printf("%#o",644); # prints 01204
+
+ Surely you had not intended C<chmod(01204, $file);> - did you? If you
+ want to use numeric literals as arguments to chmod() et al. then please
+ try to express them as octal constants, that is with a leading zero and
+ with the following digits restricted to the set 0..7.
+
=head2 Does Perl have a round() function? What about ceil() and floor()? Trig functions?
Remember that int() merely truncates toward 0. For rounding to a
***************
*** 227,248 ****
$day_of_year = (localtime(time()))[7];
! or more legibly (in 5.004 or higher):
! use Time::localtime;
! $day_of_year = localtime(time())->yday;
! You can find the week of the year by dividing this by 7:
! $week_of_year = int($day_of_year / 7);
! Of course, this believes that weeks start at zero. The Date::Calc
! module from CPAN has a lot of date calculation functions, including
! day of the year, week of the year, and so on. Note that not
! all businesses consider ``week 1'' to be the same; for example,
! American businesses often consider the first week with a Monday
! in it to be Work Week #1, despite ISO 8601, which considers
! WW1 to be the first week with a Thursday in it.
=head2 How do I find the current century or millennium?
--- 249,270 ----
$day_of_year = (localtime(time()))[7];
! or more legibly (in 5.7.1 or higher):
! use Time::Piece;
! $day_of_year = localtime->day_of_year();
! You can find the week of the year by using Time::Piece's strftime():
! $week_of_year = localtime->strftime("%U");
! $iso_week = localtime->strftime("%V");
! The difference between %U and %V is that %U assumes that the first day
! of week 1 is the first Sunday of the year, whereas ISO 8601:1988 uses
! the first week that has at least 4 days in the current year, and with
! Monday as the first day of the week. You can also use %W, which will
! return the week of the year with Monday as the first day of week 1. See
! your strftime(3) man page for more details.
=head2 How do I find the current century or millennium?
***************
*** 273,278 ****
--- 295,304 ----
Date::Calc modules from CPAN before you go hacking up your own parsing
routine to handle arbitrary date formats.
+ Also note that the core module Time::Piece overloads the addition and
+ subtraction operators to provide date calculation options. See
+ L<Time::Piece/Date Calculations>.
+
=head2 How can I take a string and turn it into epoch seconds?
If it's a regular enough string that it always has the same format,
***************
*** 282,305 ****
=head2 How can I find the Julian Day?
! Use the Time::JulianDay module (part of the Time-modules bundle
! available from CPAN.)
! Before you immerse yourself too deeply in this, be sure to verify that it
! is the I<Julian> Day you really want. Are you really just interested in
! a way of getting serial days so that they can do date arithmetic? If you
are interested in performing date arithmetic, this can be done using
! either Date::Manip or Date::Calc, without converting to Julian Day first.
! There is too much confusion on this issue to cover in this FAQ, but the
! term is applied (correctly) to a calendar now supplanted by the Gregorian
! Calendar, with the Julian Calendar failing to adjust properly for leap
! years on centennial years (among other annoyances). The term is also used
! (incorrectly) to mean: [1] days in the Gregorian Calendar; and [2] days
! since a particular starting time or `epoch', usually 1970 in the Unix
! world and 1980 in the MS-DOS/Windows world. If you find that it is not
! the first meaning that you really want, then check out the Date::Manip
! and Date::Calc modules. (Thanks to David Cassell for most of this text.)
=head2 How do I find yesterday's date?
--- 308,337 ----
=head2 How can I find the Julian Day?
! Use Time::Piece as follows:
! use Time::Piece;
! my $julian_day = localtime->julian_day;
! my $mjd = localtime->mjd; # modified julian day
!
! Before you immerse yourself too deeply in this, be sure to verify that
! it is the I<Julian> Day you really want. Are you interested in a way
! of getting serial days so that you just can tell how many days they
! are apart or so that you can do also other date arithmetic? If you
are interested in performing date arithmetic, this can be done using
! Time::Piece (standard module since Perl 5.8), or by modules
! Date::Manip or Date::Calc.
! There is too many details and much confusion on this issue to cover in
! this FAQ, but the term is applied (correctly) to a calendar now
! supplanted by the Gregorian Calendar, with the Julian Calendar failing
! to adjust properly for leap years on centennial years (among other
! annoyances). The term is also used (incorrectly) to mean: [1] days in
! the Gregorian Calendar; and [2] days since a particular starting time
! or `epoch', usually 1970 in the Unix world and 1980 in the
! MS-DOS/Windows world. If you find that it is not the first meaning
! that you really want, then check out the Date::Manip and Date::Calc
! modules. (Thanks to David Cassell for most of this text.)
=head2 How do I find yesterday's date?
***************
*** 311,316 ****
--- 343,356 ----
Then you can pass this to C<localtime()> and get the individual year,
month, day, hour, minute, seconds values.
+ Alternatively, you can use Time::Piece to subtract a day from the value
+ returned from C<localtime()>:
+
+ use Time::Piece;
+ use Time::Seconds; # imports seconds constants, like ONE_DAY
+ my $today = localtime();
+ my $yesterday = $today - ONE_DAY;
+
Note very carefully that the code above assumes that your days are
twenty-four hours each. For most people, there are two days a year
when they aren't: the switch to and from summer time throws this off.
***************
*** 446,452 ****
If you are serious about writing a parser, there are a number of
modules or oddities that will make your life a lot easier. There are
the CPAN modules Parse::RecDescent, Parse::Yapp, and Text::Balanced;
! and the byacc program.
One simple destructive, inside-out approach that you might try is to
pull out the smallest nesting parts one at a time:
--- 486,493 ----
If you are serious about writing a parser, there are a number of
modules or oddities that will make your life a lot easier. There are
the CPAN modules Parse::RecDescent, Parse::Yapp, and Text::Balanced;
! and the byacc program. Starting from perl 5.8 the Text::Balanced
! is part of the standard distribution.
One simple destructive, inside-out approach that you might try is to
pull out the smallest nesting parts one at a time:
***************
*** 994,1000 ****
But perhaps you should have been using a hash all along, eh?
! =head2 How can I tell whether a list or array contains a certain element?
Hearing the word "in" is an I<in>dication that you probably should have
used a hash, not a list or array, to store your data. Hashes are
--- 1035,1041 ----
But perhaps you should have been using a hash all along, eh?
! =head2 How can I tell whether a certain element is contained in a list or array?
Hearing the word "in" is an I<in>dication that you probably should have
used a hash, not a list or array, to store your data. Hashes are
***************
*** 1762,1768 ****
For some specific applications, you can use one of the DBM modules.
See L<AnyDBM_File>. More generically, you should consult the FreezeThaw,
! Storable, or Class::Eroot modules from CPAN. Here's one example using
Storable's C<store> and C<retrieve> functions:
use Storable;
--- 1803,1810 ----
For some specific applications, you can use one of the DBM modules.
See L<AnyDBM_File>. More generically, you should consult the FreezeThaw,
! Storable, or Class::Eroot modules from CPAN. Starting from Perl 5.8
! Storable is part of the standard distribution. Here's one example using
Storable's C<store> and C<retrieve> functions:
use Storable;
diff -c 'perl-5.7.1/pod/perlfaq5.pod' 'perl-5.7.2/pod/perlfaq5.pod'
Index: ./pod/perlfaq5.pod
*** ./pod/perlfaq5.pod Tue Mar 6 04:06:29 2001
--- ./pod/perlfaq5.pod Mon Jul 9 17:11:12 2001
***************
*** 469,475 ****
Use the <> (glob()) operator, documented in L<perlfunc>. Older
versions of Perl require that you have a shell installed that groks
tildes. Recent perl versions have this feature built in. The
! Glob::KGlob module (available from CPAN) gives more portable glob
functionality.
Within Perl, you may use this directly:
--- 469,475 ----
Use the <> (glob()) operator, documented in L<perlfunc>. Older
versions of Perl require that you have a shell installed that groks
tildes. Recent perl versions have this feature built in. The
! File::KGlob module (available from CPAN) gives more portable glob
functionality.
Within Perl, you may use this directly:
***************
*** 569,575 ****
have this problem, but their users may be surprised by it.
To get around this, either upgrade to Perl v5.6.0 or later, do the glob
! yourself with readdir() and patterns, or use a module like Glob::KGlob,
one that doesn't use the shell to do globbing.
=head2 Is there a leak/bug in glob()?
--- 569,575 ----
have this problem, but their users may be surprised by it.
To get around this, either upgrade to Perl v5.6.0 or later, do the glob
! yourself with readdir() and patterns, or use a module like File::KGlob,
one that doesn't use the shell to do globbing.
=head2 Is there a leak/bug in glob()?
***************
*** 723,728 ****
--- 723,756 ----
If the count doesn't impress your friends, then the code might. :-)
+ =head2 All I want to do is append a small amount of text to the end of a file. Do I still have to use locking?
+
+ If you are on a system that correctly implements flock() and you use the
+ example appending code from "perldoc -f flock" everything will be OK
+ even if the OS you are on doesn't implement append mode correctly (if
+ such a system exists.) So if you are happy to restrict yourself to OSs
+ that implement flock() (and that's not really much of a restriction)
+ then that is what you should do.
+
+ If you know you are only going to use a system that does correctly
+ implement appending (i.e. not Win32) then you can omit the seek() from
+ the above code.
+
+ If you know you are only writing code to run on an OS and filesystem that
+ does implement append mode correctly (a local filesystem on a modern
+ Unix for example), and you keep the file in block-buffered mode and you
+ write less than one buffer-full of output between each manual flushing
+ of the buffer then each bufferload is almost garanteed to be written to
+ the end of the file in one chunk without getting intermingled with
+ anyone else's output. You can also use the syswrite() function which is
+ simply a wrapper around your systems write(2) system call.
+
+ There is still a small theoretical chance that a signal will interrupt
+ the system level write() operation before completion. There is also a
+ possibility that some STDIO implementations may call multiple system
+ level write()s even if the buffer was empty to start. There may be some
+ systems where this probability is reduced to zero.
+
=head2 How do I randomly update a binary file?
If you're just trying to patch a binary, in many cases something as
***************
*** 954,1005 ****
ReadMode "normal";
printf "\nYou said %s, char number %03d\n",
$key, ord $key;
-
- For legacy DOS systems, Dan Carson <dbc@tc.fluke.COM> reports the following:
-
- To put the PC in "raw" mode, use ioctl with some magic numbers gleaned
- from msdos.c (Perl source file) and Ralf Brown's interrupt list (comes
- across the net every so often):
-
- $old_ioctl = ioctl(STDIN,0,0); # Gets device info
- $old_ioctl &= 0xff;
- ioctl(STDIN,1,$old_ioctl | 32); # Writes it back, setting bit 5
-
- Then to read a single character:
-
- sysread(STDIN,$c,1); # Read a single character
-
- And to put the PC back to "cooked" mode:
-
- ioctl(STDIN,1,$old_ioctl); # Sets it back to cooked mode.
-
- So now you have $c. If C<ord($c) == 0>, you have a two byte code, which
- means you hit a special key. Read another byte with C<sysread(STDIN,$c,1)>,
- and that value tells you what combination it was according to this
- table:
-
- # PC 2-byte keycodes = ^@ + the following:
-
- # HEX KEYS
- # --- ----
- # 0F SHF TAB
- # 10-19 ALT QWERTYUIOP
- # 1E-26 ALT ASDFGHJKL
- # 2C-32 ALT ZXCVBNM
- # 3B-44 F1-F10
- # 47-49 HOME,UP,PgUp
- # 4B LEFT
- # 4D RIGHT
- # 4F-53 END,DOWN,PgDn,Ins,Del
- # 54-5D SHF F1-F10
- # 5E-67 CTR F1-F10
- # 68-71 ALT F1-F10
- # 73-77 CTR LEFT,RIGHT,END,PgDn,HOME
- # 78-83 ALT 1234567890-=
- # 84 CTR PgUp
-
- This is all trial and error I did a long time ago; I hope I'm reading the
- file that worked...
=head2 How can I tell whether there's a character waiting on a filehandle?
--- 982,987 ----
diff -c 'perl-5.7.1/pod/perlfaq6.pod' 'perl-5.7.2/pod/perlfaq6.pod'
Index: ./pod/perlfaq6.pod
*** ./pod/perlfaq6.pod Tue Mar 6 04:06:29 2001
--- ./pod/perlfaq6.pod Mon Jul 9 17:11:12 2001
***************
*** 115,121 ****
undef $/; # read in whole file, not just one line or paragraph
while ( <> ) {
! while ( /START(.*?)END/sm ) { # /s makes . cross line boundaries
print "$1\n";
}
}
--- 115,121 ----
undef $/; # read in whole file, not just one line or paragraph
while ( <> ) {
! while ( /START(.*?)END/sgm ) { # /s makes . cross line boundaries
print "$1\n";
}
}
***************
*** 211,216 ****
--- 211,231 ----
This prints:
this is a SUcCESS case
+
+ As an alternative, to keep the case of the replacement word if it is
+ longer than the original, you can use this code, by Jeff Pinyan:
+
+ sub preserve_case {
+ my ($from, $to) = @_;
+ my ($lf, $lt) = map length, @_;
+
+ if ($lt < $lf) { $from = substr $from, 0, $lt }
+ else { $from .= substr $to, $lf }
+
+ return uc $to | ($from ^ uc $from);
+ }
+
+ This changes the sentence to "this is a SUcCess case."
Just to show that C programmers can write C in any programming language,
if you prefer a more C-like solution, the following script makes the
diff -c 'perl-5.7.1/pod/perlfaq7.pod' 'perl-5.7.2/pod/perlfaq7.pod'
Index: ./pod/perlfaq7.pod
*** ./pod/perlfaq7.pod Tue Mar 6 04:06:30 2001
--- ./pod/perlfaq7.pod Mon Jul 9 17:11:12 2001
***************
*** 657,668 ****
This is explained in more depth in the L<perlsyn>. Briefly, there's
no official case statement, because of the variety of tests possible
in Perl (numeric comparison, string comparison, glob comparison,
! regex matching, overloaded comparisons, ...). Larry couldn't decide
! how best to do this, so he left it out, even though it's been on the
! wish list since perl1.
! The general answer is to write a construct like this:
for ($variable_to_test) {
if (/pat1/) { } # do something
elsif (/pat2/) { } # do something else
--- 657,678 ----
This is explained in more depth in the L<perlsyn>. Briefly, there's
no official case statement, because of the variety of tests possible
in Perl (numeric comparison, string comparison, glob comparison,
! regex matching, overloaded comparisons, ...).
! Larry couldn't decide how best to do this, so he left it out, even
! though it's been on the wish list since perl1.
! Starting from Perl 5.8 to get switch and case one can use the
! Switch extension and say:
+ use Switch;
+
+ after which one has switch and case. It is not as fast as it could be
+ because it's not really part of the language (it's done using source
+ filters) but it is available, and it's very flexible.
+
+ But if one wants to use pure Perl, the general answer is to write a
+ construct like this:
+
for ($variable_to_test) {
if (/pat1/) { } # do something
elsif (/pat2/) { } # do something else
***************
*** 784,790 ****
L<perlobj>.
Make sure to read about creating modules in L<perlmod> and
! the perils of indirect objects in L<perlobj/"WARNING">.
=head2 How can I find out my current package?
--- 794,800 ----
L<perlobj>.
Make sure to read about creating modules in L<perlmod> and
! the perils of indirect objects in L<perlobj/"Method Invocation">.
=head2 How can I find out my current package?
diff -c 'perl-5.7.1/pod/perlfaq8.pod' 'perl-5.7.2/pod/perlfaq8.pod'
Index: ./pod/perlfaq8.pod
*** ./pod/perlfaq8.pod Tue Mar 6 04:06:30 2001
--- ./pod/perlfaq8.pod Mon Jul 9 17:11:12 2001
***************
*** 447,458 ****
If you want finer granularity than the 1 second that the sleep()
function provides, the easiest way is to use the select() function as
documented in L<perlfunc/"select">. Try the Time::HiRes and
! the BSD::Itimer modules (available from CPAN).
=head2 How can I measure time under a second?
In general, you may not be able to. The Time::HiRes module (available
! from CPAN) provides this functionality for some systems.
If your system supports both the syscall() function in Perl as well as
a system call like gettimeofday(2), then you may be able to do
--- 447,460 ----
If you want finer granularity than the 1 second that the sleep()
function provides, the easiest way is to use the select() function as
documented in L<perlfunc/"select">. Try the Time::HiRes and
! the BSD::Itimer modules (available from CPAN, and starting from
! Perl 5.8 Time::HiRes is part of the standard distribution).
=head2 How can I measure time under a second?
In general, you may not be able to. The Time::HiRes module (available
! from CPAN, and starting from Perl 5.8 part of the standard distribution)
! provides this functionality for some systems.
If your system supports both the syscall() function in Perl as well as
a system call like gettimeofday(2), then you may be able to do
diff -c 'perl-5.7.1/pod/perlfilter.pod' 'perl-5.7.2/pod/perlfilter.pod'
Index: ./pod/perlfilter.pod
*** ./pod/perlfilter.pod Tue Mar 6 04:06:30 2001
--- ./pod/perlfilter.pod Mon Jul 9 17:11:12 2001
***************
*** 557,562 ****
--- 557,567 ----
CPAN/modules/by-module/Filter
+ Starting from Perl 5.8 Filter::Util::Call (the core part of the
+ Source Filters distribution) is part of the standard Perl distribution.
+ Also included is a friendlier interface called Filter::Simple, by
+ Damian Conway.
+
=head1 AUTHOR
Paul Marquess E<lt>Paul.Marquess@btinternet.comE<gt>
diff -c 'perl-5.7.1/pod/perlfunc.pod' 'perl-5.7.2/pod/perlfunc.pod'
Index: ./pod/perlfunc.pod
*** ./pod/perlfunc.pod Fri Apr 6 01:53:29 2001
--- ./pod/perlfunc.pod Wed Jul 11 04:29:25 2001
***************
*** 398,405 ****
For delays of finer granularity than one second, you may use Perl's
four-argument version of select() leaving the first three arguments
undefined, or you might be able to use the C<syscall> interface to
! access setitimer(2) if your system supports it. The Time::HiRes module
! from CPAN may also prove useful.
It is usually a mistake to intermix C<alarm> and C<sleep> calls.
(C<sleep> may be internally implemented in your system with C<alarm>)
--- 398,406 ----
For delays of finer granularity than one second, you may use Perl's
four-argument version of select() leaving the first three arguments
undefined, or you might be able to use the C<syscall> interface to
! access setitimer(2) if your system supports it. The Time::HiRes
! module (from CPAN, and starting from Perl 5.8 part of the standard
! distribution) may also prove useful.
It is usually a mistake to intermix C<alarm> and C<sleep> calls.
(C<sleep> may be internally implemented in your system with C<alarm>)
***************
*** 474,490 ****
platforms the external representation of C<\n> is made up of more than
one character.
! Mac OS and all variants of Unix use a single character to end each line
! in the external representation of text (even though that single
! character is not necessarily the same across these platforms).
! Consequently binmode() has no effect on these operating systems. In
! other systems like VMS, MS-DOS and the various flavors of MS-Windows
! your program sees a C<\n> as a simple C<\cJ>, but what's stored in text
! files are the two characters C<\cM\cJ>. That means that, if you don't
! use binmode() on these systems, C<\cM\cJ> sequences on disk will be
! converted to C<\n> on input, and any C<\n> in your program will be
! converted back to C<\cM\cJ> on output. This is what you want for text
! files, but it can be disastrous for binary files.
Another consequence of using binmode() (on some systems) is that
special end-of-file markers will be seen as part of the data stream.
--- 475,491 ----
platforms the external representation of C<\n> is made up of more than
one character.
! Mac OS, all variants of Unix, and Stream_LF files on VMS use a single
! character to end each line in the external representation of text (even
! though that single character is CARRIAGE RETURN on Mac OS and LINE FEED
! on Unix and most VMS files). Consequently binmode() has no effect on
! these operating systems. In other systems like OS/2, DOS and the various
! flavors of MS-Windows your program sees a C<\n> as a simple C<\cJ>, but
! what's stored in text files are the two characters C<\cM\cJ>. That means
! that, if you don't use binmode() on these systems, C<\cM\cJ> sequences on
! disk will be converted to C<\n> on input, and any C<\n> in your program
! will be converted back to C<\cM\cJ> on output. This is what you want for
! text files, but it can be disastrous for binary files.
Another consequence of using binmode() (on some systems) is that
special end-of-file markers will be seen as part of the data stream.
***************
*** 2628,2642 ****
automatically convert strings into numbers as needed, this automatic
conversion assumes base 10.)
- =item open FILEHANDLE,MODE,LIST
-
=item open FILEHANDLE,EXPR
=item open FILEHANDLE
Opens the file whose filename is given by EXPR, and associates it with
! FILEHANDLE. If FILEHANDLE is an expression, its value is used as the
! name of the real filehandle wanted. (This is considered a symbolic
reference, so C<use strict 'refs'> should I<not> be in effect.)
If EXPR is omitted, the scalar
--- 2629,2646 ----
automatically convert strings into numbers as needed, this automatic
conversion assumes base 10.)
=item open FILEHANDLE,EXPR
+ =item open FILEHANDLE,MODE,EXPR
+
+ =item open FILEHANDLE,MODE,EXPR,LIST
+
=item open FILEHANDLE
Opens the file whose filename is given by EXPR, and associates it with
! FILEHANDLE. If FILEHANDLE is an undefined lexical (C<my>) variable the variable is
! assigned a reference to a new anonymous filehandle, otherwise if FILEHANDLE is an expression,
! its value is used as the name of the real filehandle wanted. (This is considered a symbolic
reference, so C<use strict 'refs'> should I<not> be in effect.)
If EXPR is omitted, the scalar
***************
*** 2646,2652 ****
to open.) See L<perlopentut> for a kinder, gentler explanation of opening
files.
! If MODE is C<< '<' >> or nothing, the file is opened for input.
If MODE is C<< '>' >>, the file is truncated and opened for
output, being created if necessary. If MODE is C<<< '>>' >>>,
the file is opened for appending, again being created if necessary.
--- 2650,2657 ----
to open.) See L<perlopentut> for a kinder, gentler explanation of opening
files.
! If three or more arguments are specified then the mode of opening and the file name
! are separate. If MODE is C<< '<' >> or nothing, the file is opened for input.
If MODE is C<< '>' >>, the file is truncated and opened for
output, being created if necessary. If MODE is C<<< '>>' >>>,
the file is opened for appending, again being created if necessary.
***************
*** 2663,2669 ****
In the 2-arguments (and 1-argument) form of the call the mode and
filename should be concatenated (in this order), possibly separated by
! spaces. It is possible to omit the mode if the mode is C<< '<' >>.
If the filename begins with C<'|'>, the filename is interpreted as a
command to which output is to be piped, and if the filename ends with a
--- 2668,2675 ----
In the 2-arguments (and 1-argument) form of the call the mode and
filename should be concatenated (in this order), possibly separated by
! spaces. It is possible to omit the mode in these forms if the mode is
! C<< '<' >>.
If the filename begins with C<'|'>, the filename is interpreted as a
command to which output is to be piped, and if the filename ends with a
***************
*** 2674,2680 ****
and L<perlipc/"Bidirectional Communication with Another Process">
for alternatives.)
! If MODE is C<'|-'>, the filename is interpreted as a
command to which output is to be piped, and if MODE is
C<'-|'>, the filename is interpreted as a command which pipes output to
us. In the 2-arguments (and 1-argument) form one should replace dash
--- 2680,2686 ----
and L<perlipc/"Bidirectional Communication with Another Process">
for alternatives.)
! For three or more arguments if MODE is C<'|-'>, the filename is interpreted as a
command to which output is to be piped, and if MODE is
C<'-|'>, the filename is interpreted as a command which pipes output to
us. In the 2-arguments (and 1-argument) form one should replace dash
***************
*** 2681,2687 ****
(C<'-'>) with the command. See L<perlipc/"Using open() for IPC">
for more examples of this. (You are not allowed to C<open> to a command
that pipes both in I<and> out, but see L<IPC::Open2>, L<IPC::Open3>,
! and L<perlipc/"Bidirectional Communication"> for alternatives.)
In the 2-arguments (and 1-argument) form opening C<'-'> opens STDIN
and opening C<< '>-' >> opens STDOUT.
--- 2687,2697 ----
(C<'-'>) with the command. See L<perlipc/"Using open() for IPC">
for more examples of this. (You are not allowed to C<open> to a command
that pipes both in I<and> out, but see L<IPC::Open2>, L<IPC::Open3>,
! and L<perlipc/"Bidirectional Communication"> for alternatives.) In 3+ arg form of
! pipe opens then if LIST is specified (extra arguments after the command name) then
! LIST becomes arguments to the command invoked if the platform supports it.
! The meaning of C<open> with more than three arguments for non-pipe modes
! is not yet specified. Experimental "layers" may give extra LIST arguments meaning.
In the 2-arguments (and 1-argument) form opening C<'-'> opens STDIN
and opening C<< '>-' >> opens STDOUT.
***************
*** 2699,2704 ****
--- 2709,2718 ----
Plan9, which delimit lines with a single character, and which encode that
character in C as C<"\n">, do not need C<binmode>. The rest need it.
+ In the three argument form MODE may also contain a list of IO "layers" (see L<open> and
+ L<PerlIO> for more details) to be applied to the handle. This can be used to achieve the
+ effect of C<binmode> as well as more complex behaviours.
+
When opening a file, it's usually a bad idea to continue normal execution
if the request failed, so C<open> is frequently used in connection with
C<die>. Even if C<die> won't do what you want (say, in a CGI script,
***************
*** 2714,2719 ****
--- 2728,2734 ----
opens a filehandle to an anonymous temporary file.
+
Examples:
$ARTICLE = 100;
***************
*** 2797,2815 ****
print STDOUT "stdout 2\n";
print STDERR "stderr 2\n";
! If you specify C<< '<&=N' >>, where C<N> is a number, then Perl will do an
! equivalent of C's C<fdopen> of that file descriptor; this is more
! parsimonious of file descriptors. For example:
open(FILEHANDLE, "<&=$fd")
or
open(FILEHANDLE, "<&=", $fd)
! Note that if perl is using the standard C libaries fdopen() then on many UNIX systems,
! fdopen() is known to fail when file descriptors
exceed a certain value, typically 255. If you need more file
descriptors than that, consider rebuilding Perl to use the C<PerlIO>.
If you open a pipe on the command C<'-'>, i.e., either C<'|-'> or C<'-|'>
with 2-arguments (or 1-argument) form of open(), then
there is an implicit fork done, and the return value of open is the pid
--- 2812,2836 ----
print STDOUT "stdout 2\n";
print STDERR "stderr 2\n";
! If you specify C<< '<&=N' >>, where C<N> is a number, then Perl will
! do an equivalent of C's C<fdopen> of that file descriptor; this is
! more parsimonious of file descriptors. For example:
open(FILEHANDLE, "<&=$fd")
+
or
+
open(FILEHANDLE, "<&=", $fd)
! Note that if Perl is using the standard C libraries' fdopen() then on
! many UNIX systems, fdopen() is known to fail when file descriptors
exceed a certain value, typically 255. If you need more file
descriptors than that, consider rebuilding Perl to use the C<PerlIO>.
+ You can see whether Perl has been compiled with PerlIO or not by
+ running C<perl -V> and looking for C<useperlio=> line. If C<useperlio>
+ is C<define>, you have PerlIO, otherwise you don't.
+
If you open a pipe on the command C<'-'>, i.e., either C<'|-'> or C<'-|'>
with 2-arguments (or 1-argument) form of open(), then
there is an implicit fork done, and the return value of open is the pid
***************
*** 2934,2939 ****
--- 2955,2962 ----
=item our EXPR
+ =item our EXPR : ATTRIBUTES
+
An C<our> declares the listed variables to be valid globals within
the enclosing block, file, or C<eval>. That is, it has the same
scoping rules as a "my" declaration, but does not create a local
***************
*** 2972,2977 ****
--- 2995,3022 ----
our $bar; # emits warning
+ An C<our> declaration may also have a list of attributes associated
+ with it. B<WARNING>: This is an experimental feature that may be
+ changed or removed in future releases of Perl. It should not be
+ relied upon.
+
+ The only currently recognized attribute is C<unique> which indicates
+ that a single copy of the global is to be used by all interpreters
+ should the program happen to be running in a multi-interpreter
+ environment. (The default behaviour would be for each interpreter to
+ have its own copy of the global.) In such an environment, this
+ attribute also has the effect of making the global readonly.
+ Examples:
+
+ our @EXPORT : unique = qw(foo);
+ our %EXPORT_TAGS : unique = (bar => [qw(aa bb cc)]);
+ our $VERSION : unique = "1.00";
+
+ Multi-interpreter environments can come to being either through the
+ fork() emulation on Windows platforms, or by embedding perl in a
+ multi-threaded application. The C<unique> attribute does nothing in
+ all other environments.
+
=item pack TEMPLATE,LIST
Takes a LIST of values and converts it into a string using the rules
***************
*** 3202,3208 ****
The integer formats C<s>, C<S>, C<i>, C<I>, C<l>, and C<L>
are inherently non-portable between processors and operating systems
because they obey the native byteorder and endianness. For example a
! 4-byte integer 0x12345678 (305419896 decimal) be ordered natively
(arranged in and handled by the CPU registers) into bytes as
0x12 0x34 0x56 0x78 # big-endian
--- 3247,3253 ----
The integer formats C<s>, C<S>, C<i>, C<I>, C<l>, and C<L>
are inherently non-portable between processors and operating systems
because they obey the native byteorder and endianness. For example a
! 4-byte integer 0x12345678 (305419896 decimal) would be ordered natively
(arranged in and handled by the CPU registers) into bytes as
0x12 0x34 0x56 0x78 # big-endian
***************
*** 3211,3217 ****
Basically, the Intel and VAX CPUs are little-endian, while everybody
else, for example Motorola m68k/88k, PPC, Sparc, HP PA, Power, and
Cray are big-endian. Alpha and MIPS can be either: Digital/Compaq
! used/uses them in little-endian mode; SGI/Cray uses them in big-endian mode.
The names `big-endian' and `little-endian' are comic references to
the classic "Gulliver's Travels" (via the paper "On Holy Wars and a
--- 3256,3263 ----
Basically, the Intel and VAX CPUs are little-endian, while everybody
else, for example Motorola m68k/88k, PPC, Sparc, HP PA, Power, and
Cray are big-endian. Alpha and MIPS can be either: Digital/Compaq
! used/uses them in little-endian mode; SGI/Cray uses them in big-endian
! mode.
The names `big-endian' and `little-endian' are comic references to
the classic "Gulliver's Travels" (via the paper "On Holy Wars and a
***************
*** 3238,3244 ****
and C<'87654321'> are big-endian.
If you want portable packed integers use the formats C<n>, C<N>,
! C<v>, and C<V>, their byte endianness and size is known.
See also L<perlport>.
=item *
--- 3284,3290 ----
and C<'87654321'> are big-endian.
If you want portable packed integers use the formats C<n>, C<N>,
! C<v>, and C<V>, their byte endianness and size are known.
See also L<perlport>.
=item *
***************
*** 3358,3365 ****
still seen in older code).
If NAMESPACE is omitted, then there is no current package, and all
! identifiers must be fully qualified or lexicals. This is stricter
! than C<use strict>, since it also extends to function names.
See L<perlmod/"Packages"> for more information about packages, modules,
and classes. See L<perlsub> for other scoping issues.
--- 3404,3413 ----
still seen in older code).
If NAMESPACE is omitted, then there is no current package, and all
! identifiers must be fully qualified or lexicals. However, you are
! strongly advised not to make use of this feature. Its use can cause
! unexpected behaviour, even crashing some versions of Perl. It is
! deprecated, and will be removed from a future release.
See L<perlmod/"Packages"> for more information about packages, modules,
and classes. See L<perlsub> for other scoping issues.
***************
*** 3506,3514 ****
Returns a random fractional number greater than or equal to C<0> and less
than the value of EXPR. (EXPR should be positive.) If EXPR is
! omitted, the value C<1> is used. Automatically calls C<srand> unless
! C<srand> has already been called. See also C<srand>.
(Note: If your rand function consistently returns numbers that are too
large or too small, then your version of Perl was probably compiled
with the wrong number of RANDBITS.)
--- 3554,3569 ----
Returns a random fractional number greater than or equal to C<0> and less
than the value of EXPR. (EXPR should be positive.) If EXPR is
! omitted, or a C<0>, the value C<1> is used. Automatically calls C<srand>
! unless C<srand> has already been called. See also C<srand>.
+ Apply C<int()> to the value returned by C<rand()> if you want random
+ integers instead of random fractional numbers. For example,
+
+ int(rand(10))
+
+ returns a random integer between C<0> and C<9>, inclusive.
+
(Note: If your rand function consistently returns numbers that are too
large or too small, then your version of Perl was probably compiled
with the wrong number of RANDBITS.)
***************
*** 4013,4026 ****
=item semop KEY,OPSTRING
Calls the System V IPC function semop to perform semaphore operations
! such as signaling and waiting. OPSTRING must be a packed array of
semop structures. Each semop structure can be generated with
! C<pack("sss", $semnum, $semop, $semflag)>. The number of semaphore
operations is implied by the length of OPSTRING. Returns true if
successful, or false if there is an error. As an example, the
following code waits on semaphore $semnum of semaphore id $semid:
! $semop = pack("sss", $semnum, -1, 0);
die "Semaphore trouble: $!\n" unless semop($semid, $semop);
To signal the semaphore, replace C<-1> with C<1>. See also
--- 4068,4081 ----
=item semop KEY,OPSTRING
Calls the System V IPC function semop to perform semaphore operations
! such as signalling and waiting. OPSTRING must be a packed array of
semop structures. Each semop structure can be generated with
! C<pack("s!3", $semnum, $semop, $semflag)>. The number of semaphore
operations is implied by the length of OPSTRING. Returns true if
successful, or false if there is an error. As an example, the
following code waits on semaphore $semnum of semaphore id $semid:
! $semop = pack("s!3", $semnum, -1, 0);
die "Semaphore trouble: $!\n" unless semop($semid, $semop);
To signal the semaphore, replace C<-1> with C<1>. See also
***************
*** 4151,4158 ****
For delays of finer granularity than one second, you may use Perl's
C<syscall> interface to access setitimer(2) if your system supports
! it, or else see L</select> above. The Time::HiRes module from CPAN
! may also help.
See also the POSIX module's C<pause> function.
--- 4206,4214 ----
For delays of finer granularity than one second, you may use Perl's
C<syscall> interface to access setitimer(2) if your system supports
! it, or else see L</select> above. The Time::HiRes module (from CPAN,
! and starting from Perl 5.8 part of the standard distribution) may also
! help.
See also the POSIX module's C<pause> function.
***************
*** 4243,4248 ****
--- 4299,4310 ----
When C<use locale> is in effect, C<sort LIST> sorts LIST according to the
current collation locale. See L<perllocale>.
+ Perl does B<not> guarantee that sort is stable. (A I<stable> sort
+ preserves the input order of elements that compare equal.) 5.7 and
+ 5.8 happen to use a stable mergesort, but 5.6 and earlier used quicksort,
+ which is not stable. Do not assume that future perls will continue to
+ use a stable sort.
+
Examples:
# sort lexically
***************
*** 4399,4409 ****
matching PATTERN is taken to be a delimiter separating the fields. (Note
that the delimiter may be longer than one character.)
! If LIMIT is specified and positive, splits into no more than that
! many fields (though it may split into fewer). If LIMIT is unspecified
! or zero, trailing null fields are stripped (which potential users
! of C<pop> would do well to remember). If LIMIT is negative, it is
! treated as if an arbitrarily large LIMIT had been specified.
A pattern matching the null string (not to be confused with
a null pattern C<//>, which is just one member of the set of patterns
--- 4461,4475 ----
matching PATTERN is taken to be a delimiter separating the fields. (Note
that the delimiter may be longer than one character.)
! If LIMIT is specified and positive, it represents the maximum number
! of fields the EXPR will be split into, though the actual number of
! fields returned depends on the number of times PATTERN matches within
! EXPR. If LIMIT is unspecified or zero, trailing null fields are
! stripped (which potential users of C<pop> would do well to remember).
! If LIMIT is negative, it is treated as if an arbitrarily large LIMIT
! had been specified. Note that splitting an EXPR that evaluates to the
! empty string always returns the empty list, regardless of the LIMIT
! specified.
A pattern matching the null string (not to be confused with
a null pattern C<//>, which is just one member of the set of patterns
***************
*** 5271,5276 ****
--- 5337,5344 ----
($user,$system,$cuser,$csystem) = times;
+ In scalar context, C<times> returns C<$user>.
+
=item tr///
The transliteration operator. Same as C<y///>. See L<perlop>.
***************
*** 5452,5458 ****
depending on how you look at it. Prepends list to the front of the
array, and returns the new number of elements in the array.
! unshift(ARGV, '-e') unless $ARGV[0] =~ /^-/;
Note the LIST is prepended whole, not one element at a time, so the
prepended elements stay in the same order. Use C<reverse> to do the
--- 5520,5526 ----
depending on how you look at it. Prepends list to the front of the
array, and returns the new number of elements in the array.
! unshift(@ARGV, '-e') unless $ARGV[0] =~ /^-/;
Note the LIST is prepended whole, not one element at a time, so the
prepended elements stay in the same order. Use C<reverse> to do the
***************
*** 5563,5568 ****
--- 5631,5643 ----
#!/usr/bin/perl
$now = time;
utime $now, $now, @ARGV;
+
+ If the first two elements of the list are C<undef>, then the utime(2)
+ function in the C library will be called with a null second argument.
+ On most systems, this will set the file's access and modification
+ times to the current time. (i.e. equivalent to the example above.)
+
+ utime undef, undef, @ARGV;
=item values HASH
diff -c 'perl-5.7.1/pod/perlguts.pod' 'perl-5.7.2/pod/perlguts.pod'
Index: ./pod/perlguts.pod
*** ./pod/perlguts.pod Fri Apr 6 16:20:16 2001
--- ./pod/perlguts.pod Wed Jul 11 04:32:07 2001
***************
*** 77,83 ****
the format.
STRLEN is an integer type (Size_t, usually defined as size_t in
! config.h) guaranteed to be large enough to represent the size of
any string that perl can handle.
The C<sv_set*()> functions are not generic enough to operate on values
--- 77,83 ----
the format.
STRLEN is an integer type (Size_t, usually defined as size_t in
! config.h) guaranteed to be large enough to represent the size of
any string that perl can handle.
The C<sv_set*()> functions are not generic enough to operate on values
***************
*** 224,230 ****
(offset OK) to signal to other functions that the offset hack is in
effect, and it puts the number of bytes chopped off into the IV field
of the SV. It then moves the PV pointer (called C<SvPVX>) forward that
! many bytes, and adjusts C<SvCUR> and C<SvLEN>.
Hence, at this point, the start of the buffer that we allocated lives
at C<SvPVX(sv) - SvIV(sv)> in memory and the PV pointer is pointing
--- 224,230 ----
(offset OK) to signal to other functions that the offset hack is in
effect, and it puts the number of bytes chopped off into the IV field
of the SV. It then moves the PV pointer (called C<SvPVX>) forward that
! many bytes, and adjusts C<SvCUR> and C<SvLEN>.
Hence, at this point, the start of the buffer that we allocated lives
at C<SvPVX(sv) - SvIV(sv)> in memory and the PV pointer is pointing
***************
*** 274,279 ****
--- 274,287 ----
These will tell you if you truly have an integer, double, or string pointer
stored in your SV. The "p" stands for private.
+ The are various ways in which the private and public flags may differ.
+ For example, a tied SV may have a valid underlying value in the IV slot
+ (so SvIOKp is true), but the data should be accessed via the FETCH
+ routine rather than directly, so SvIOK is false. Another is when
+ numeric conversion has occured and precision has been lost: only the
+ private flag is set on 'lossy' values. So when an NV is converted to an
+ IV with loss, SvIOKp, SvNOKp and SvNOK will be set, while SvIOK wont be.
+
In general, though, it's best to use the C<Sv*V> macros.
=head2 Working with AVs
***************
*** 571,577 ****
bool sv_derived_from(SV* sv, const char* name);
! To check if you've got an object derived from a specific class you have
to write:
if (sv_isobject(sv) && sv_derived_from(sv, class)) { ... }
--- 579,585 ----
bool sv_derived_from(SV* sv, const char* name);
! To check if you've got an object derived from a specific class you have
to write:
if (sv_isobject(sv) && sv_derived_from(sv, class)) { ... }
***************
*** 650,658 ****
However, if you mortalize a variable twice, the reference count will
later be decremented twice.
! You should be careful about creating mortal variables. Strange things
! can happen if you make the same value mortal within multiple contexts,
! or if you make a variable mortal multiple times.
To create a mortal variable, use the functions:
--- 658,668 ----
However, if you mortalize a variable twice, the reference count will
later be decremented twice.
! "Mortal" SVs are mainly used for SVs that are placed on perl's stack.
! For example an SV which is created just to pass a number to a called sub
! is made mortal to have it cleaned up automatically when stack is popped.
! Similarly results returned by XSUBs (which go in the stack) are often
! made mortal.
To create a mortal variable, use the functions:
***************
*** 660,669 ****
SV* sv_2mortal(SV*)
SV* sv_mortalcopy(SV*)
! The first call creates a mortal SV, the second converts an existing
SV to a mortal SV (and thus defers a call to C<SvREFCNT_dec>), and the
third creates a mortal copy of an existing SV.
The mortal routines are not just for SVs -- AVs and HVs can be
made mortal by passing their address (type-casted to C<SV*>) to the
C<sv_2mortal> or C<sv_mortalcopy> routines.
--- 670,698 ----
SV* sv_2mortal(SV*)
SV* sv_mortalcopy(SV*)
! The first call creates a mortal SV (with no value), the second converts an existing
SV to a mortal SV (and thus defers a call to C<SvREFCNT_dec>), and the
third creates a mortal copy of an existing SV.
+ Because C<sv_newmortal> gives the new SV no value,it must normally be given one
+ via C<sv_setpv>, C<sv_setiv> etc. :
+ SV *tmp = sv_newmortal();
+ sv_setiv(tmp, an_integer);
+
+ As that is multiple C statements it is quite common so see this idiom instead:
+
+ SV *tmp = sv_2mortal(newSViv(an_integer));
+
+
+ You should be careful about creating mortal variables. Strange things
+ can happen if you make the same value mortal within multiple contexts,
+ or if you make a variable mortal multiple times. Thinking of "Mortalization"
+ as deferred C<SvREFCNT_dec> should help to minimize such problems.
+ For example if you are passing an SV which you I<know> has high enough REFCNT
+ to survive its use on the stack you need not do any mortalization.
+ If you are not sure then doing an C<SvREFCNT_inc> and C<sv_2mortal>, or
+ making a C<sv_mortalcopy> is safer.
+
The mortal routines are not just for SVs -- AVs and HVs can be
made mortal by passing their address (type-casted to C<SV*>) to the
C<sv_2mortal> or C<sv_mortalcopy> routines.
***************
*** 796,806 ****
feature.
If C<sv> is not already magical, Perl uses the C<SvUPGRADE> macro to
! set the C<SVt_PVMG> flag for the C<sv>. Perl then continues by adding
! it to the beginning of the linked list of magical features. Any prior
! entry of the same type of magic is deleted. Note that this can be
! overridden, and multiple instances of the same type of magic can be
! associated with an SV.
The C<name> and C<namlen> arguments are used to associate a string with
the magic, typically the name of a variable. C<namlen> is stored in the
--- 825,835 ----
feature.
If C<sv> is not already magical, Perl uses the C<SvUPGRADE> macro to
! convert C<sv> to type C<SVt_PVMG>. Perl then continues by adding new magic
! to the beginning of the linked list of magical features. Any prior entry
! of the same type of magic is deleted. Note that this can be overridden,
! and multiple instances of the same type of magic can be associated with an
! SV.
The C<name> and C<namlen> arguments are used to associate a string with
the magic, typically the name of a variable. C<namlen> is stored in the
***************
*** 810,822 ****
The sv_magic function uses C<how> to determine which, if any, predefined
"Magic Virtual Table" should be assigned to the C<mg_virtual> field.
See the "Magic Virtual Table" section below. The C<how> argument is also
! stored in the C<mg_type> field.
The C<obj> argument is stored in the C<mg_obj> field of the C<MAGIC>
structure. If it is not the same as the C<sv> argument, the reference
count of the C<obj> object is incremented. If it is the same, or if
! the C<how> argument is "#", or if it is a NULL pointer, then C<obj> is
! merely stored, without the reference count being incremented.
There is also a function to add magic to an C<HV>:
--- 839,855 ----
The sv_magic function uses C<how> to determine which, if any, predefined
"Magic Virtual Table" should be assigned to the C<mg_virtual> field.
See the "Magic Virtual Table" section below. The C<how> argument is also
! stored in the C<mg_type> field. The value of C<how> should be chosen
! from the set of macros C<PERL_MAGIC_foo> found perl.h. Note that before
! these macros were added, Perl internals used to directly use character
! literals, so you may occasionally come across old code or documentation
! referrring to 'U' magic rather than C<PERL_MAGIC_uvar> for example.
The C<obj> argument is stored in the C<mg_obj> field of the C<MAGIC>
structure. If it is not the same as the C<sv> argument, the reference
count of the C<obj> object is incremented. If it is the same, or if
! the C<how> argument is C<PERL_MAGIC_arylen>, or if it is a NULL pointer,
! then C<obj> is merely stored, without the reference count being incremented.
There is also a function to add magic to an C<HV>:
***************
*** 860,926 ****
svt_free Free any extra storage associated with the SV.
For instance, the MGVTBL structure called C<vtbl_sv> (which corresponds
! to an C<mg_type> of '\0') contains:
{ magic_get, magic_set, magic_len, 0, 0 }
! Thus, when an SV is determined to be magical and of type '\0', if a get
! operation is being performed, the routine C<magic_get> is called. All
! the various routines for the various magical types begin with C<magic_>.
! NOTE: the magic routines are not considered part of the Perl API, and may
! not be exported by the Perl library.
The current kinds of Magic Virtual Tables are:
! mg_type MGVTBL Type of magic
! ------- ------ ----------------------------
! \0 vtbl_sv Special scalar variable
! A vtbl_amagic %OVERLOAD hash
! a vtbl_amagicelem %OVERLOAD hash element
! c (none) Holds overload table (AMT) on stash
! B vtbl_bm Boyer-Moore (fast string search)
! D vtbl_regdata Regex match position data (@+ and @- vars)
! d vtbl_regdatum Regex match position data element
! E vtbl_env %ENV hash
! e vtbl_envelem %ENV hash element
! f vtbl_fm Formline ('compiled' format)
! g vtbl_mglob m//g target / study()ed string
! I vtbl_isa @ISA array
! i vtbl_isaelem @ISA array element
! k vtbl_nkeys scalar(keys()) lvalue
! L (none) Debugger %_<filename
! l vtbl_dbline Debugger %_<filename element
! o vtbl_collxfrm Locale transformation
! P vtbl_pack Tied array or hash
! p vtbl_packelem Tied array or hash element
! q vtbl_packelem Tied scalar or handle
! S vtbl_sig %SIG hash
! s vtbl_sigelem %SIG hash element
! t vtbl_taint Taintedness
! U vtbl_uvar Available for use by extensions
! v vtbl_vec vec() lvalue
! x vtbl_substr substr() lvalue
! y vtbl_defelem Shadow "foreach" iterator variable /
! smart parameter vivification
! * vtbl_glob GV (typeglob)
! # vtbl_arylen Array length ($#ary)
! . vtbl_pos pos() lvalue
! ~ (none) Available for use by extensions
When an uppercase and lowercase letter both exist in the table, then the
uppercase letter is used to represent some kind of composite type (a list
or a hash), and the lowercase letter is used to represent an element of
! that composite type.
! The '~' and 'U' magic types are defined specifically for use by
! extensions and will not be used by perl itself. Extensions can use
! '~' magic to 'attach' private information to variables (typically
! objects). This is especially useful because there is no way for
! normal perl code to corrupt this private information (unlike using
! extra elements of a hash object).
! Similarly, 'U' magic can be used much like tie() to call a C function
! any time a scalar's value is used or changed. The C<MAGIC>'s
C<mg_ptr> field points to a C<ufuncs> structure:
struct ufuncs {
--- 893,968 ----
svt_free Free any extra storage associated with the SV.
For instance, the MGVTBL structure called C<vtbl_sv> (which corresponds
! to an C<mg_type> of C<PERL_MAGIC_sv>) contains:
{ magic_get, magic_set, magic_len, 0, 0 }
! Thus, when an SV is determined to be magical and of type C<PERL_MAGIC_sv>,
! if a get operation is being performed, the routine C<magic_get> is
! called. All the various routines for the various magical types begin
! with C<magic_>. NOTE: the magic routines are not considered part of
! the Perl API, and may not be exported by the Perl library.
The current kinds of Magic Virtual Tables are:
! mg_type
! (old-style char and macro) MGVTBL Type of magic
! -------------------------- ------ ----------------------------
! \0 PERL_MAGIC_sv vtbl_sv Special scalar variable
! A PERL_MAGIC_overload vtbl_amagic %OVERLOAD hash
! a PERL_MAGIC_overload_elem vtbl_amagicelem %OVERLOAD hash element
! c PERL_MAGIC_overload_table (none) Holds overload table (AMT)
! on stash
! B PERL_MAGIC_bm vtbl_bm Boyer-Moore (fast string search)
! D PERL_MAGIC_regdata vtbl_regdata Regex match position data
! (@+ and @- vars)
! d PERL_MAGIC_regdatum vtbl_regdatum Regex match position data
! element
! E PERL_MAGIC_env vtbl_env %ENV hash
! e PERL_MAGIC_envelem vtbl_envelem %ENV hash element
! f PERL_MAGIC_fm vtbl_fm Formline ('compiled' format)
! g PERL_MAGIC_regex_global vtbl_mglob m//g target / study()ed string
! I PERL_MAGIC_isa vtbl_isa @ISA array
! i PERL_MAGIC_isaelem vtbl_isaelem @ISA array element
! k PERL_MAGIC_nkeys vtbl_nkeys scalar(keys()) lvalue
! L PERL_MAGIC_dbfile (none) Debugger %_<filename
! l PERL_MAGIC_dbline vtbl_dbline Debugger %_<filename element
! m PERL_MAGIC_mutex vtbl_mutex ???
! o PERL_MAGIC_collxfrm vtbl_collxfrm Locale collate transformation
! P PERL_MAGIC_tied vtbl_pack Tied array or hash
! p PERL_MAGIC_tiedelem vtbl_packelem Tied array or hash element
! q PERL_MAGIC_tiedscalar vtbl_packelem Tied scalar or handle
! r PERL_MAGIC_qr vtbl_qr precompiled qr// regex
! S PERL_MAGIC_sig vtbl_sig %SIG hash
! s PERL_MAGIC_sigelem vtbl_sigelem %SIG hash element
! t PERL_MAGIC_taint vtbl_taint Taintedness
! U PERL_MAGIC_uvar vtbl_uvar Available for use by extensions
! v PERL_MAGIC_vec vtbl_vec vec() lvalue
! x PERL_MAGIC_substr vtbl_substr substr() lvalue
! y PERL_MAGIC_defelem vtbl_defelem Shadow "foreach" iterator
! variable / smart parameter
! vivification
! * PERL_MAGIC_glob vtbl_glob GV (typeglob)
! # PERL_MAGIC_arylen vtbl_arylen Array length ($#ary)
! . PERL_MAGIC_pos vtbl_pos pos() lvalue
! < PERL_MAGIC_backref vtbl_backref ???
! ~ PERL_MAGIC_ext (none) Available for use by extensions
When an uppercase and lowercase letter both exist in the table, then the
uppercase letter is used to represent some kind of composite type (a list
or a hash), and the lowercase letter is used to represent an element of
! that composite type. Some internals code makes use of this case
! relationship.
! The C<PERL_MAGIC_ext> and C<PERL_MAGIC_uvar> magic types are defined
! specifically for use by extensions and will not be used by perl itself.
! Extensions can use C<PERL_MAGIC_ext> magic to 'attach' private information
! to variables (typically objects). This is especially useful because
! there is no way for normal perl code to corrupt this private information
! (unlike using extra elements of a hash object).
! Similarly, C<PERL_MAGIC_uvar> magic can be used much like tie() to call a
! C function any time a scalar's value is used or changed. The C<MAGIC>'s
C<mg_ptr> field points to a C<ufuncs> structure:
struct ufuncs {
***************
*** 930,937 ****
};
When the SV is read from or written to, the C<uf_val> or C<uf_set>
! function will be called with C<uf_index> as the first arg and a
! pointer to the SV as the second. A simple example of how to add 'U'
magic is shown below. Note that the ufuncs structure is copied by
sv_magic, so you can safely allocate it on the stack.
--- 972,979 ----
};
When the SV is read from or written to, the C<uf_val> or C<uf_set>
! function will be called with C<uf_index> as the first arg and a pointer to
! the SV as the second. A simple example of how to add C<PERL_MAGIC_uvar>
magic is shown below. Note that the ufuncs structure is copied by
sv_magic, so you can safely allocate it on the stack.
***************
*** 944,957 ****
uf.uf_val = &my_get_fn;
uf.uf_set = &my_set_fn;
uf.uf_index = 0;
! sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf));
! Note that because multiple extensions may be using '~' or 'U' magic,
! it is important for extensions to take extra care to avoid conflict.
! Typically only using the magic on objects blessed into the same class
! as the extension is sufficient. For '~' magic, it may also be
! appropriate to add an I32 'signature' at the top of the private data
! area and check that.
Also note that the C<sv_set*()> and C<sv_cat*()> functions described
earlier do B<not> invoke 'set' magic on their targets. This must
--- 986,999 ----
uf.uf_val = &my_get_fn;
uf.uf_set = &my_set_fn;
uf.uf_index = 0;
! sv_magic(sv, 0, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
! Note that because multiple extensions may be using C<PERL_MAGIC_ext>
! or C<PERL_MAGIC_uvar> magic, it is important for extensions to take
! extra care to avoid conflict. Typically only using the magic on
! objects blessed into the same class as the extension is sufficient.
! For C<PERL_MAGIC_ext> magic, it may also be appropriate to add an I32
! 'signature' at the top of the private data area and check that.
Also note that the C<sv_set*()> and C<sv_cat*()> functions described
earlier do B<not> invoke 'set' magic on their targets. This must
***************
*** 981,987 ****
=head2 Understanding the Magic of Tied Hashes and Arrays
! Tied hashes and arrays are magical beasts of the 'P' magic type.
WARNING: As of the 5.004 release, proper usage of the array and hash
access functions requires understanding a few caveats. Some
--- 1023,1030 ----
=head2 Understanding the Magic of Tied Hashes and Arrays
! Tied hashes and arrays are magical beasts of the C<PERL_MAGIC_tied>
! magic type.
WARNING: As of the 5.004 release, proper usage of the array and hash
access functions requires understanding a few caveats. Some
***************
*** 1012,1018 ****
tie = newRV_noinc((SV*)newHV());
stash = gv_stashpv("MyTie", TRUE);
sv_bless(tie, stash);
! hv_magic(hash, tie, 'P');
RETVAL = newRV_noinc(hash);
OUTPUT:
RETVAL
--- 1055,1061 ----
tie = newRV_noinc((SV*)newHV());
stash = gv_stashpv("MyTie", TRUE);
sv_bless(tie, stash);
! hv_magic(hash, (GV*)tie, PERL_MAGIC_tied);
RETVAL = newRV_noinc(hash);
OUTPUT:
RETVAL
***************
*** 1184,1190 ****
The following API list contains functions, thus one needs to
provide pointers to the modifiable data explicitly (either C pointers,
! or Perlish C<GV *>s). Where the above macros take C<int>, a similar
function takes C<int *>.
=over 4
--- 1227,1233 ----
The following API list contains functions, thus one needs to
provide pointers to the modifiable data explicitly (either C pointers,
! or Perlish C<GV *>s). Where the above macros take C<int>, a similar
function takes C<int *>.
=over 4
***************
*** 1253,1265 ****
where C<SP> is the macro that represents the local copy of the stack pointer,
and C<num> is the number of elements the stack should be extended by.
! Now that there is room on the stack, values can be pushed on it using the
! macros to push IVs, doubles, strings, and SV pointers respectively:
! PUSHi(IV)
! PUSHn(double)
! PUSHp(char*, I32)
! PUSHs(SV*)
And now the Perl program calling C<tzname>, the two values will be assigned
as in:
--- 1296,1307 ----
where C<SP> is the macro that represents the local copy of the stack pointer,
and C<num> is the number of elements the stack should be extended by.
! Now that there is room on the stack, values can be pushed on it using C<PUSHs>
! macro. The values pushed will often need to be "mortal" (See L</Reference Counts and Mortality>).
! PUSHs(sv_2mortal(newSViv(an_integer)))
! PUSHs(sv_2mortal(newSVpv("Some String",0)))
! PUSHs(sv_2mortal(newSVnv(3.141592)))
And now the Perl program calling C<tzname>, the two values will be assigned
as in:
***************
*** 1267,1283 ****
($standard_abbrev, $summer_abbrev) = POSIX::tzname;
An alternate (and possibly simpler) method to pushing values on the stack is
! to use the macros:
- XPUSHi(IV)
- XPUSHn(double)
- XPUSHp(char*, I32)
XPUSHs(SV*)
! These macros automatically adjust the stack for you, if needed. Thus, you
do not need to call C<EXTEND> to extend the stack.
- However, see L</Putting a C value on Perl stack>
For more information, consult L<perlxs> and L<perlxstut>.
=head2 Calling Perl Routines from within C Programs
--- 1309,1325 ----
($standard_abbrev, $summer_abbrev) = POSIX::tzname;
An alternate (and possibly simpler) method to pushing values on the stack is
! to use the macro:
XPUSHs(SV*)
! This macro automatically adjust the stack for you, if needed. Thus, you
do not need to call C<EXTEND> to extend the stack.
+ Despite their suggestions in earlier versions of this document the macros
+ C<PUSHi>, C<PUSHn> and C<PUSHp> are I<not> suited to XSUBs which return
+ multiple results, see L</Putting a C value on Perl stack>.
+
For more information, consult L<perlxs> and L<perlxstut>.
=head2 Calling Perl Routines from within C Programs
***************
*** 1421,1427 ****
On a related note, if you do use C<(X)PUSH[npi]>, then you're going to
need a C<dTARG> in your variable declarations so that the C<*PUSH*>
! macros can make use of the local variable C<TARG>.
=head2 Scratchpads
--- 1463,1469 ----
On a related note, if you do use C<(X)PUSH[npi]>, then you're going to
need a C<dTARG> in your variable declarations so that the C<*PUSH*>
! macros can make use of the local variable C<TARG>.
=head2 Scratchpads
***************
*** 1625,1630 ****
--- 1667,1689 ----
done in the subroutine peep(). Optimizations performed at this stage
are subject to the same restrictions as in the pass 2.
+ =head2 Pluggable runops
+
+ The compile tree is executed in a runops function. There are two runops
+ functions in F<run.c>. C<Perl_runops_debug> is used with DEBUGGING and
+ C<Perl_runops_standard> is used otherwise. For fine control over the
+ execution of the compile tree it is possible to provide your own runops
+ function.
+
+ It's probably best to copy one of the existing runops functions and
+ change it to suit your needs. Then, in the BOOT section of your XS
+ file, add the line:
+
+ PL_runops = my_runops;
+
+ This function should be as efficient as possible to keep your programs
+ running as fast as possible.
+
=head1 Examining internal data structures with the C<dump> functions
To aid debugging, the source file F<dump.c> contains a number of
***************
*** 1633,1639 ****
The most commonly used of these functions is C<Perl_sv_dump>; it's used
for dumping SVs, AVs, HVs, and CVs. The C<Devel::Peek> module calls
C<sv_dump> to produce debugging output from Perl-space, so users of that
! module should already be familiar with its format.
C<Perl_op_dump> can be used to dump an C<OP> structure or any of its
derivatives, and produces output similiar to C<perl -Dx>; in fact,
--- 1692,1698 ----
The most commonly used of these functions is C<Perl_sv_dump>; it's used
for dumping SVs, AVs, HVs, and CVs. The C<Devel::Peek> module calls
C<sv_dump> to produce debugging output from Perl-space, so users of that
! module should already be familiar with its format.
C<Perl_op_dump> can be used to dump an C<OP> structure or any of its
derivatives, and produces output similiar to C<perl -Dx>; in fact,
***************
*** 1690,1702 ****
use of macros and subroutine naming conventions.
First problem: deciding which functions will be public API functions and
! which will be private. All functions whose names begin C<S_> are private
(think "S" for "secret" or "static"). All other functions begin with
"Perl_", but just because a function begins with "Perl_" does not mean it is
! part of the API. (See L</Internal Functions>.) The easiest way to be B<sure> a
! function is part of the API is to find its entry in L<perlapi>.
! If it exists in L<perlapi>, it's part of the API. If it doesn't, and you
! think it should be (i.e., you need it for your extension), send mail via
L<perlbug> explaining why you think it should be.
Second problem: there must be a syntax so that the same subroutine
--- 1749,1761 ----
use of macros and subroutine naming conventions.
First problem: deciding which functions will be public API functions and
! which will be private. All functions whose names begin C<S_> are private
(think "S" for "secret" or "static"). All other functions begin with
"Perl_", but just because a function begins with "Perl_" does not mean it is
! part of the API. (See L</Internal Functions>.) The easiest way to be B<sure> a
! function is part of the API is to find its entry in L<perlapi>.
! If it exists in L<perlapi>, it's part of the API. If it doesn't, and you
! think it should be (i.e., you need it for your extension), send mail via
L<perlbug> explaining why you think it should be.
Second problem: there must be a syntax so that the same subroutine
***************
*** 2006,2012 ****
=item M
! This function is part of the experimental development API, and may change
or disappear without notice.
=item o
--- 2065,2071 ----
=item M
! This function is part of the experimental development API, and may change
or disappear without notice.
=item o
diff -c 'perl-5.7.1/pod/perlhack.pod' 'perl-5.7.2/pod/perlhack.pod'
Index: ./pod/perlhack.pod
*** ./pod/perlhack.pod Fri Mar 30 21:14:47 2001
--- ./pod/perlhack.pod Mon Jul 9 17:11:13 2001
***************
*** 273,279 ****
"Rsync uses rsh or ssh for communication. It does not need to be
setuid and requires no special privileges for installation. It
! does not require a inetd entry or a deamon. You must, however,
have a working rsh or ssh system. Using ssh is recommended for
its security features."
--- 273,279 ----
"Rsync uses rsh or ssh for communication. It does not need to be
setuid and requires no special privileges for installation. It
! does not require an inetd entry or a daemon. You must, however,
have a working rsh or ssh system. Using ssh is recommended for
its security features."
***************
*** 434,440 ****
=item Finding the source of misbehaviour
When you keep in sync with bleadperl, the pumpking would love to
! I<see> that the community efforts realy work. So after each of his
sync points, you are to 'make test' to check if everything is still
in working order. If it is, you do 'make ok', which will send an OK
report to perlbug@perl.org. (If you do not have access to a mailer
--- 434,440 ----
=item Finding the source of misbehaviour
When you keep in sync with bleadperl, the pumpking would love to
! I<see> that the community efforts really work. So after each of his
sync points, you are to 'make test' to check if everything is still
in working order. If it is, you do 'make ok', which will send an OK
report to perlbug@perl.org. (If you do not have access to a mailer
***************
*** 442,448 ****
do 'make okfile', which creates the file C<perl.ok>, which you can
than take to your favourite mailer and mail yourself).
! But of course, as always, things will not allways lead to a success
path, and one or more test do not pass the 'make test'. Before
sending in a bug report (using 'make nok' or 'make nokfile'), check
the mailing list if someone else has reported the bug already and if
--- 442,448 ----
do 'make okfile', which creates the file C<perl.ok>, which you can
than take to your favourite mailer and mail yourself).
! But of course, as always, things will not always lead to a success
path, and one or more test do not pass the 'make test'. Before
sending in a bug report (using 'make nok' or 'make nokfile'), check
the mailing list if someone else has reported the bug already and if
***************
*** 1387,1392 ****
--- 1387,1395 ----
files. Sure enough, C<pp_pack> is in F<pp.c>. Since we're going to be
altering this file, let's copy it to F<pp.c~>.
+ [Well, it was in F<pp.c> when this tutorial was written. It has now been
+ split off with C<pp_unpack> to its own file, F<pp_pack.c>]
+
Now let's look over C<pp_pack>: we take a pattern into C<pat>, and then
loop over the pattern, taking each format character in turn into
C<datum_type>. Then for each possible format character, we swallow up
***************
*** 1686,1703 ****
"perl.third" and "test.third".
The short story is that with "atom" you can instrument the Perl
! executable to create a new executable called "perl.third". When the
instrumented executable is run, it creates a log of dubious memory
! traffic in file called "perl.3log". See the manual pages of atom and
third for more information. The most extensive Third Degree
documentation is available in the Compaq "Tru64 UNIX Programmer's
Guide", chapter "Debugging Programs with Third Degree".
! The "test.third" leaves a lot of files named perl.3log.* in the t/
subdirectory. There is a problem with these files: Third Degree is so
effective that it finds problems also in the system libraries.
! Therefore there are certain types of errors that you should ignore
! in your debugging. Errors with stack traces matching
__actual_atof|__catgets|_doprnt|__exc_|__exec|_findio|__localtime|setlocale|__sia_|__strxfrm
--- 1689,1706 ----
"perl.third" and "test.third".
The short story is that with "atom" you can instrument the Perl
! executable to create a new executable called F<perl.third>. When the
instrumented executable is run, it creates a log of dubious memory
! traffic in file called F<perl.3log>. See the manual pages of atom and
third for more information. The most extensive Third Degree
documentation is available in the Compaq "Tru64 UNIX Programmer's
Guide", chapter "Debugging Programs with Third Degree".
! The "test.third" leaves a lot of files named F<perl.3log.*> in the t/
subdirectory. There is a problem with these files: Third Degree is so
effective that it finds problems also in the system libraries.
! Therefore there are certain types of errors that you should ignore in
! your debugging. Errors with stack traces matching
__actual_atof|__catgets|_doprnt|__exc_|__exec|_findio|__localtime|setlocale|__sia_|__strxfrm
***************
*** 1728,1733 ****
--- 1731,1782 ----
PERL_DESTRUCT_LEVEL=2 ./perl.third t/foo/bar.t
+ =head2 Gprof Profiling
+
+ gprof is a profiling tool available in many UNIX platforms.
+ The profiling is based on statistical time-sampling; this means that
+ some routines, especially those executing really fast, may be missed.
+
+ You can build a profiled version of perl called "perl.gprof" by
+ invoking the make target "perl.gprof". Running the profiled version
+ of Perl will create an output file called F<gmon.out> is created which
+ contains the profiling data collected during the execution.
+
+ The gprof tool can then display the collected data in various ways.
+ Usually gprof understands the following options:
+
+ =over 4
+
+ =item -a
+
+ Suppress statically defined functions from the profile.
+
+ =item -b
+
+ Suppress the verbose descriptions in the profile.
+
+ =item -e routine
+
+ Exclude the given routine and its descendants from the profile.
+
+ =item -f routine
+
+ Display only the given routine and its descendants in the profile.
+
+ =item -s
+
+ Generate a summary file called F<gmon.sum> which then may be given
+ to subsequent gprof runs to accumulate data over several runs.
+
+ =item -z
+
+ Display routines that have zero usage.
+
+ =back
+
+ For more detailed explanation of the available commands and output
+ formats, see your own local documentation of gprof.
+
=head2 Pixie Profiling
Pixie is a profiling tool available on IRIX and Tru64
***************
*** 1735,1743 ****
using "basic-block counting". A basic block is a program region that
is entered only at the beginning and exited only at the end.
! You can build a profiled version of perl called "perl.pixie" by
invoking the make target "perl.pixie" (in Tru64 a file called
! "perl.Addrs" will also be silently created, this file contains the
addresses of the basic blocks). Running the profiled version of Perl
will create a new file called "perl.Counts" which contains the counts
for the basic block for that particular program execution.
--- 1784,1792 ----
using "basic-block counting". A basic block is a program region that
is entered only at the beginning and exited only at the end.
! You can build a profiled version of perl called F<perl.pixie> by
invoking the make target "perl.pixie" (in Tru64 a file called
! F<perl.Addrs> will also be silently created, this file contains the
addresses of the basic blocks). Running the profiled version of Perl
will create a new file called "perl.Counts" which contains the counts
for the basic block for that particular program execution.
***************
*** 1767,1789 ****
=over 4
! =item -p
! Procecures sorted in descending order by the number of cycles executed
in each procedure. Useful for finding the hotspot procedures.
(This is the default option.)
! =item -h
Lines sorted in descending order by the number of cycles executed in
each line. Useful for finding the hotspot lines.
! =item -i
The called procedures are sorted in descending order by number of calls
made to the procedures. Useful for finding the most used procedures.
! =item -l
Grouped by procedure, sorted by cycles executed per procedure.
Useful for finding the hotspots of procedures.
--- 1816,1838 ----
=over 4
! =item -p[rocedures]
! Procedures sorted in descending order by the number of cycles executed
in each procedure. Useful for finding the hotspot procedures.
(This is the default option.)
! =item -h[eavy]
Lines sorted in descending order by the number of cycles executed in
each line. Useful for finding the hotspot lines.
! =item -i[nvocations]
The called procedures are sorted in descending order by number of calls
made to the procedures. Useful for finding the most used procedures.
! =item -l[ines]
Grouped by procedure, sorted by cycles executed per procedure.
Useful for finding the hotspots of procedures.
***************
*** 1792,1798 ****
The compiler emitted code for these lines, but the code was unexecuted.
! =item -zero
Unexecuted procedures.
--- 1841,1847 ----
The compiler emitted code for these lines, but the code was unexecuted.
! =item -z[ero]
Unexecuted procedures.
diff -c 'perl-5.7.1/pod/perlhist.pod' 'perl-5.7.2/pod/perlhist.pod'
Index: ./pod/perlhist.pod
Prereq: 1.2
*** ./pod/perlhist.pod Tue Apr 10 04:51:46 2001
--- ./pod/perlhist.pod Fri Jul 13 17:10:55 2001
***************
*** 347,352 ****
--- 347,353 ----
Jarkko 5.7.0 2000-Sep-02 The 5.7 track: Development.
5.7.1 2001-Apr-09
+ 5.7.2 2001-Jul-13 virtual release candidate 0
=head2 SELECTED RELEASE SIZES
diff -c 'perl-5.7.1/pod/perlintern.pod' 'perl-5.7.2/pod/perlintern.pod'
Index: ./pod/perlintern.pod
*** ./pod/perlintern.pod Fri Apr 6 16:42:04 2001
--- ./pod/perlintern.pod Thu Jul 12 21:34:45 2001
***************
*** 118,123 ****
--- 118,132 ----
=for hackers
Found in file thrdvar.h
+ =item report_uninit
+
+ Print appropriate "Use of uninitialized variable" warning
+
+ void report_uninit()
+
+ =for hackers
+ Found in file sv.c
+
=item start_glob
Function called by C<do_readline> to spawn a glob (or do the glob inside
***************
*** 129,134 ****
--- 138,183 ----
=for hackers
Found in file doio.c
+
+ =item sv_add_arena
+
+ Given a chunk of memory, link it to the head of the list of arenas,
+ and split it into a list of free SVs.
+
+ void sv_add_arena(char* ptr, U32 size, U32 flags)
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_clean_all
+
+ Decrement the refcnt of each remaining SV, possibly triggering a
+ cleanup. This function may have to be called multiple times to free
+ SVs which are in complex self-referential hierarchies.
+
+ I32 sv_clean_all()
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_clean_objs
+
+ Attempt to destroy all objects not yet freed
+
+ void sv_clean_objs()
+
+ =for hackers
+ Found in file sv.c
+
+ =item sv_free_arenas
+
+ Deallocate the memory used by all arenas. Note that all the individual SV
+ heads and bodies within the arenas must already have been freed.
+
+ void sv_free_arenas()
+
+ =for hackers
+ Found in file sv.c
=back
diff -c 'perl-5.7.1/pod/perllexwarn.pod' 'perl-5.7.2/pod/perllexwarn.pod'
Index: ./pod/perllexwarn.pod
*** ./pod/perllexwarn.pod Fri Mar 16 04:52:00 2001
--- ./pod/perllexwarn.pod Thu Jul 12 08:23:10 2001
***************
*** 207,214 ****
all -+
|
- +- chmod
- |
+- closure
|
+- exiting
--- 207,212 ----
***************
*** 284,291 ****
| +- semicolon
|
+- taint
- |
- +- umask
|
+- uninitialized
|
--- 282,287 ----
diff -c 'perl-5.7.1/pod/perllocale.pod' 'perl-5.7.2/pod/perllocale.pod'
Index: ./pod/perllocale.pod
*** ./pod/perllocale.pod Fri Mar 16 04:52:00 2001
--- ./pod/perllocale.pod Mon Jul 9 17:11:14 2001
***************
*** 427,432 ****
--- 427,457 ----
}
print "\n";
+ =head2 I18N::Langinfo
+
+ Another interface for querying locale-dependent information is the
+ I18N::Langinfo::langinfo() function, available at least in UNIX-like
+ systems and VMS.
+
+ The following example will import the langinfo() function itself and
+ three constants to be used as arguments to langinfo(): a constant for
+ the abbreviated first day of the week (the numbering starts from
+ Sunday = 1) and two more constants for the affirmative and negative
+ answers for a yes/no question in the current locale.
+
+ use I18N::Langinfo qw(langinfo ABDAY_1 YESSTR NOSTR);
+
+ my ($abday_1, $yesstr, $nostr) = map { langinfo } qw(ABDAY_1 YESSTR NOSTR);
+
+ print "$abday_1? [$yesstr/$nostr] ";
+
+ In other words, in the "C" (or English) locale the above will probably
+ print something like:
+
+ Sun? [yes/no]
+
+ See L<I18N::Langinfo> for more information.
+
=head1 LOCALE CATEGORIES
The following subsections describe basic locale categories. Beyond these,
***************
*** 574,579 ****
--- 599,606 ----
print "DECIMAL POINT IS COMMA\n"
if $n == (strtod("2,5"))[0]; # Locale-dependent conversion
+ See also L<I18N::Langinfo> and C<RADIXCHAR>.
+
=head2 Category LC_MONETARY: Formatting of monetary amounts
The C standard defines the C<LC_MONETARY> category, but no function
***************
*** 587,592 ****
--- 614,621 ----
does not quite meet your requirements: currency formatting is a hard nut
to crack.
+ See also L<I18N::Langinfo> and C<CRNCYSTR>.
+
=head2 LC_TIME
Output produced by POSIX::strftime(), which builds a formatted
***************
*** 606,611 ****
--- 635,643 ----
exists only to generate locale-dependent results, strftime() always
obeys the current C<LC_TIME> locale.
+ See also L<I18N::Langinfo> and C<ABDAY_1>..C<ABDAY_7>, C<DAY_1>..C<DAY_7>,
+ C<ABMON_1>..C<ABMON_12>, and C<ABMON_1>..C<ABMON_12>; and L<Time::Piece>.
+
=head2 Other categories
The remaining locale category, C<LC_MESSAGES> (possibly supplemented
***************
*** 964,975 ****
=head1 SEE ALSO
! L<POSIX/isalnum>, L<POSIX/isalpha>, L<POSIX/isdigit>,
! L<POSIX/isgraph>, L<POSIX/islower>, L<POSIX/isprint>,
! L<POSIX/ispunct>, L<POSIX/isspace>, L<POSIX/isupper>,
! L<POSIX/isxdigit>, L<POSIX/localeconv>, L<POSIX/setlocale>,
! L<POSIX/strcoll>, L<POSIX/strftime>, L<POSIX/strtod>,
! L<POSIX/strxfrm>.
=head1 HISTORY
--- 996,1007 ----
=head1 SEE ALSO
! L<I18N::Langinfo>, L<POSIX/isalnum>, L<POSIX/isalpha>,
! L<POSIX/isdigit>, L<POSIX/isgraph>, L<POSIX/islower>,
! L<POSIX/isprint>, L<POSIX/ispunct>, L<POSIX/isspace>,
! L<POSIX/isupper>, L<POSIX/isxdigit>, L<POSIX/localeconv>,
! L<POSIX/setlocale>, L<POSIX/strcoll>, L<POSIX/strftime>,
! L<POSIX/strtod>, L<POSIX/strxfrm>.
=head1 HISTORY
diff -c 'perl-5.7.1/pod/perlmod.pod' 'perl-5.7.2/pod/perlmod.pod'
Index: ./pod/perlmod.pod
*** ./pod/perlmod.pod Fri Mar 16 04:52:00 2001
--- ./pod/perlmod.pod Mon Jul 9 17:11:14 2001
***************
*** 443,448 ****
--- 443,465 ----
although the POSIX module happens to do both dynamic loading and
autoloading, the user can say just C<use POSIX> to get it all.
+ =head2 Making your module threadsafe
+
+ Perl has since 5.6.0 support for a new type of threads called
+ interpreter threads. These threads can be used explicitly and implicitly.
+
+ Ithreads work by cloning the data tree so that no data is shared
+ between different threads. These threads can be used using the threads
+ module or by doing fork() on win32 (fake fork() support). When a thread is
+ cloned all perl data is cloned, however non perl data cannot be cloned.
+ Perl after 5.7.2 has support for the C<CLONE> keyword. C<CLONE> will be
+ executed once for every package that has it defined (or inherits it).
+ It will be called in the context of the new thread, so all modifications
+ are made in the new area.
+
+ If you want to CLONE all objects you will need to keep track of them per
+ package. This is simply done using a hash and Scalar::Util::weaken().
+
=head1 SEE ALSO
See L<perlmodlib> for general style issues related to building Perl
diff -c 'perl-5.7.1/pod/perlmodlib.PL' 'perl-5.7.2/pod/perlmodlib.PL'
Index: ./pod/perlmodlib.PL
*** ./pod/perlmodlib.PL Sun Apr 8 21:07:51 2001
--- ./pod/perlmodlib.PL Mon Jul 9 17:11:14 2001
***************
*** 1,17 ****
#!../miniperl
open (OUT, ">perlmodlib.tmp") or die $!;
! my (@pragma, @mod);
open (MANIFEST, "../MANIFEST") or die $!;
while (<MANIFEST>) {
my $filename;
next unless s|^lib/|| or m|^ext/|;
! ($filename) = /(\S+)/;
$filename =~ s|^[^/]+/|| if $filename =~ s|^ext/||;
! next unless $filename =~ /\.p(m|od)$/;
next unless open (MOD, "../lib/$filename");
my ($name, $thing);
my $foundit=0;
{
--- 1,20 ----
#!../miniperl
+ $ENV{LC_ALL} = 'C';
+
open (OUT, ">perlmodlib.tmp") or die $!;
! my (@pragma, @mod, @MANIFEST);
open (MANIFEST, "../MANIFEST") or die $!;
while (<MANIFEST>) {
my $filename;
next unless s|^lib/|| or m|^ext/|;
! ($filename) = m|^(\S+)|;
$filename =~ s|^[^/]+/|| if $filename =~ s|^ext/||;
! next unless $filename =~ m!\.p(m|od)$!;
next unless open (MOD, "../lib/$filename");
+
my ($name, $thing);
my $foundit=0;
{
***************
*** 23,29 ****
}
}
unless ($foundit) {
! warn "$filename missing head1\n";
next;
}
my $title = <MOD>;
--- 26,32 ----
}
}
unless ($foundit) {
! warn "$filename missing =head1 NAME (okay if there is respective .pod)\n";
next;
}
my $title = <MOD>;
***************
*** 42,54 ****
next;
}
$thing =~ s/^perl pragma to //i;
$thing = ucfirst($thing);
$title = "=item $perlname\n\n$thing\n\n";
! # print "$perlname $thing\n";
!
! if ($filename=~/[A-Z]/) {
push @mod, $title;
} else {
push @pragma, $title;
--- 45,56 ----
next;
}
+
$thing =~ s/^perl pragma to //i;
$thing = ucfirst($thing);
$title = "=item $perlname\n\n$thing\n\n";
! if ($filename =~ /[A-Z]/) {
push @mod, $title;
} else {
push @pragma, $title;
diff -c 'perl-5.7.1/pod/perlmodlib.pod' 'perl-5.7.2/pod/perlmodlib.pod'
Index: ./pod/perlmodlib.pod
*** ./pod/perlmodlib.pod Sun Apr 8 21:06:14 2001
--- ./pod/perlmodlib.pod Fri Jul 13 07:36:51 2001
***************
*** 132,144 ****
Predeclare sub names
- =item unicode::distinct
-
- Strictly distinguish UTF8 data and non-UTF data.
-
=item utf8
! Enable/disable UTF-8 in source code
=item vars
--- 132,140 ----
Predeclare sub names
=item utf8
! Enable/disable UTF-8 (or UTF-EBCDIC) in source code
=item vars
***************
*** 166,171 ****
--- 162,171 ----
Provide framework for multiple DBMs
+ =item Attribute::Handlers
+
+ Simpler definition of attribute handlers
+
=item AutoLoader
Load subroutines only on demand
***************
*** 374,379 ****
--- 374,383 ----
Utilities to replace common UNIX commands in Makefiles etc.
+ =item ExtUtils::Constant
+
+ Generate XS code to import C header constants
+
=item ExtUtils::Embed
Utilities for embedding Perl in C/C++ applications
***************
*** 394,399 ****
--- 398,407 ----
Methods to override UN*X behaviour in ExtUtils::MakeMaker
+ =item ExtUtils::MM_NW5
+
+ Methods to override UN*X behaviour in ExtUtils::MakeMaker
+
=item ExtUtils::MM_OS2
Methods to override UN*X behaviour in ExtUtils::MakeMaker
***************
*** 538,543 ****
--- 546,559 ----
Compare 8-bit scalar data according to the current locale
+ =item I18N::LangTags
+
+ Functions for dealing with RFC3066-style language tags
+
+ =item I18N::LangTags::List
+
+ Tags and names for human languages
+
=item IO
Load various IO modules
***************
*** 566,579 ****
ISO two letter codes for language identification (ISO 639)
=item Math::BigFloat
! Arbitrary length float math package
=item Math::BigInt
Arbitrary size integer math package
=item Math::Complex
Complex numbers and associated mathematical functions
--- 582,607 ----
ISO two letter codes for language identification (ISO 639)
+ =item Locale::Maketext
+
+ Framework for localization
+
+ =item Locale::Maketext::TPJ13
+
+ Article about software localization
+
=item Math::BigFloat
! Arbitrary size floating point math package
=item Math::BigInt
Arbitrary size integer math package
+ =item Math::BigInt::Calc
+
+ Pure Perl module to support Math::BigInt
+
=item Math::Complex
Complex numbers and associated mathematical functions
***************
*** 582,599 ****
--- 610,707 ----
Trigonometric functions
+ =item Memoize
+
+ Make your functions faster by trading space for time
+
+ =item Memoize::AnyDBM_File
+
+ Glue to provide EXISTS for AnyDBM_File for Storable use
+
+ =item Memoize::Expire
+
+ Plug-in module for automatic expiration of memoized values
+
+ =item Memoize::ExpireFile
+
+ Test for Memoize expiration semantics
+
+ =item Memoize::ExpireTest
+
+ Test for Memoize expiration semantics
+
+ =item Memoize::NDBM_File
+
+ Glue to provide EXISTS for NDBM_File for Storable use
+
+ =item Memoize::SDBM_File
+
+ Glue to provide EXISTS for SDBM_File for Storable use
+
+ =item Memoize::Saves
+
+ Plug-in module to specify which return values should be memoized
+
+ =item Memoize::Storable
+
+ Store Memoized data in Storable database
+
=item NDBM_File
Tied access to ndbm files
+ =item NEXT
+
+ Provide a pseudo-class NEXT that allows method redispatch
+
+ =item Net::Cmd
+
+ Network Command class (as used by FTP, SMTP etc)
+
+ =item Net::Config
+
+ Local configuration data for libnet
+
+ =item Net::Domain
+
+ Attempt to evaluate the current host's internet name and domain
+
+ =item Net::FTP
+
+ FTP Client class
+
+ =item Net::NNTP
+
+ NNTP Client class
+
+ =item Net::Netrc
+
+ OO interface to users netrc file
+
+ =item Net::POP3
+
+ Post Office Protocol 3 Client class (RFC1081)
+
=item Net::Ping
Check a remote host for reachability
+ =item Net::SMTP
+
+ Simple Mail Transfer Protocol Client
+
+ =item Net::Time
+
+ Time and daytime network client interface
+
=item Net::hostent
By-name interface to Perl's built-in gethost*() functions
+ =item Net::libnetFAQ
+
+ Libnet Frequently Asked Questions
+
=item Net::netent
By-name interface to Perl's built-in getnet*() functions
***************
*** 750,755 ****
--- 858,871 ----
Run perl standard test scripts with statistics
+ =item Test::More
+
+ Yet another framework for writing test scripts
+
+ =item Test::Simple
+
+ Basic utilities for writing tests.
+
=item Text::Abbrev
Create an abbreviation table from a list
***************
*** 774,779 ****
--- 890,915 ----
Line wrapping to form simple paragraphs
+ =item Thread
+
+ Manipulate threads in Perl (EXPERIMENTAL, subject to change)
+
+ =item Thread::Queue
+
+ Thread-safe queues
+
+ =item Thread::Semaphore
+
+ Thread-safe semaphores
+
+ =item Thread::Signal
+
+ Start a thread which runs signal handlers reliably
+
+ =item Thread::Specific
+
+ Thread-specific keys
+
=item Tie::Array
Base class for tied arrays
***************
*** 817,822 ****
--- 953,962 ----
=item UNIVERSAL
Base class for ALL classes (blessed references)
+
+ =item UnicodeCD
+
+ Unicode character database
=item User::grent
diff -c 'perl-5.7.1/pod/perlnewmod.pod' 'perl-5.7.2/pod/perlnewmod.pod'
Index: ./pod/perlnewmod.pod
*** ./pod/perlnewmod.pod Tue Mar 6 04:06:35 2001
--- ./pod/perlnewmod.pod Mon Jul 9 17:11:14 2001
***************
*** 239,256 ****
list about it. The best way to do this is to email them a line in the
style of the modules list, like this:
! Net::Acme bdpO Interface to Acme Frobnicator servers FOOBAR
! ^ ^^^^ ^ ^
! | |||| Module description Your ID
! | ||||
! | |||\- Interface: (O)OP, (r)eferences, (h)ybrid, (f)unctions
! | |||
! | ||\-- Language: (p)ure Perl, C(+)+, (h)ybrid, (C), (o)ther
! | ||
! Module |\--- Support: (d)eveloper, (m)ailing list, (u)senet, (n)one
! Name |
! \---- Maturity: (i)dea, (c)onstructions, (a)lpha, (b)eta,
! (R)eleased, (M)ature, (S)tandard
plus a description of the module and why you think it should be
included. If you hear nothing back, that means your module will
--- 239,259 ----
list about it. The best way to do this is to email them a line in the
style of the modules list, like this:
! Net::Acme bdpOP Interface to Acme Frobnicator servers FOOBAR
! ^ ^^^^^ ^ ^
! | ||||| Module description Your ID
! | |||||
! | ||||\-Public Licence: (p)standard Perl, (g)GPL, (b)BSD,
! | |||| (l)LGPL, (a)rtistic, (o)ther
! | ||||
! | |||\- Interface: (O)OP, (r)eferences, (h)ybrid, (f)unctions
! | |||
! | ||\-- Language: (p)ure Perl, C(+)+, (h)ybrid, (C), (o)ther
! | ||
! Module |\--- Support: (d)eveloper, (m)ailing list, (u)senet, (n)one
! Name |
! \---- Development: (i)dea, (c)onstructions, (a)lpha, (b)eta,
! (R)eleased, (M)ature, (S)tandard
plus a description of the module and why you think it should be
included. If you hear nothing back, that means your module will
diff -c 'perl-5.7.1/pod/perlobj.pod' 'perl-5.7.2/pod/perlobj.pod'
Index: ./pod/perlobj.pod
*** ./pod/perlobj.pod Tue Apr 10 03:34:51 2001
--- ./pod/perlobj.pod Mon Jul 9 17:11:14 2001
***************
*** 361,375 ****
C<isa> returns I<true> if its object is blessed into a subclass of C<CLASS>
! C<isa> is also exportable and can be called as a sub with two arguments. This
! allows the ability to check what a reference points to. Example
! use UNIVERSAL qw(isa);
!
! if(isa($ref, 'ARRAY')) {
#...
}
=item can(METHOD)
C<can> checks to see if its object has a method called C<METHOD>,
--- 361,379 ----
C<isa> returns I<true> if its object is blessed into a subclass of C<CLASS>
! You can also call C<UNIVERSAL::isa> as a subroutine with two arguments.
! The first does not need to be an object or even a reference. This
! allows you to check what a reference points to, or whether
! something is a reference of a given type. Example
! if(UNIVERSAL::isa($ref, 'ARRAY')) {
#...
}
+ To determine if a reference is a blessed object, you can write
+
+ print "It's an object\n" if UNIVERSAL::isa($val, 'UNIVERSAL');
+
=item can(METHOD)
C<can> checks to see if its object has a method called C<METHOD>,
***************
*** 376,381 ****
--- 380,401 ----
if it does then a reference to the sub is returned, if it does not then
I<undef> is returned.
+ C<UNIVERSAL::can> can also be called as a subroutine with two arguments.
+ It'll always return I<undef> if its first argument isn't an object or a
+ class name. So here's another way to check if a reference is a
+ blessed object
+
+ print "It's still an object\n" if UNIVERSAL::can($val, 'can');
+
+ You can also use the C<blessed> function of Scalar::Util:
+
+ use Scalar::Util 'blessed';
+
+ my $blessing = blessed $suspected_object;
+
+ C<blessed> returns the name of the package the argument has been
+ blessed into, or C<undef>.
+
=item VERSION( [NEED] )
C<VERSION> returns the version number of the class (package). If the
***************
*** 397,404 ****
You may add other methods to the UNIVERSAL class via Perl or XS code.
You do not need to C<use UNIVERSAL> to make these methods
! available to your program. This is necessary only if you wish to
! have C<isa> available as a plain subroutine in the current package.
=head2 Destructors
--- 417,423 ----
You may add other methods to the UNIVERSAL class via Perl or XS code.
You do not need to C<use UNIVERSAL> to make these methods
! available to your program (and you should not do so).
=head2 Destructors
diff -c 'perl-5.7.1/pod/perlop.pod' 'perl-5.7.2/pod/perlop.pod'
Index: ./pod/perlop.pod
*** ./pod/perlop.pod Sat Mar 31 18:46:53 2001
--- ./pod/perlop.pod Mon Jul 9 17:11:14 2001
***************
*** 233,238 ****
--- 233,250 ----
the number of bits specified by the right argument. Arguments should
be integers. (See also L<Integer Arithmetic>.)
+ Note that both "<<" and ">>" in Perl are implemented directly using
+ "<<" and ">>" in C. If C<use integer> (see L<Integer Arithmetic>) is
+ in force then signed C integers are used, else unsigned C integers are
+ used. Either way, the implementation isn't going to generate results
+ larger than the size of the integer type Perl was built with (32 bits
+ or 64 bits).
+
+ The result of overflowing the range of the integers is undefined
+ because it is undefined also in C. In other words, using 32-bit
+ integers, C<< 1 << 32 >> is undefined. Shifting by a negative number
+ of bits is also undefined.
+
=head2 Named Unary Operators
The various named unary operators are treated as functions with one
***************
*** 646,658 ****
Customary Generic Meaning Interpolates
'' q{} Literal no
"" qq{} Literal yes
! `` qx{} Command yes (unless '' is delimiter)
qw{} Word list no
! // m{} Pattern match yes (unless '' is delimiter)
! qr{} Pattern yes (unless '' is delimiter)
! s{}{} Substitution yes (unless '' is delimiter)
tr{}{} Transliteration no (but see below)
Non-bracketing delimiters use the same character fore and aft, but the four
sorts of brackets (round, angle, square, curly) will all nest, which means
that
--- 658,672 ----
Customary Generic Meaning Interpolates
'' q{} Literal no
"" qq{} Literal yes
! `` qx{} Command yes*
qw{} Word list no
! // m{} Pattern match yes*
! qr{} Pattern yes*
! s{}{} Substitution yes*
tr{}{} Transliteration no (but see below)
+ * unless the delimiter is ''.
+
Non-bracketing delimiters use the same character fore and aft, but the four
sorts of brackets (round, angle, square, curly) will all nest, which means
that
***************
*** 667,674 ****
$s = q{ if($a eq "}") ... }; # WRONG
! is a syntax error. The C<Text::Balanced> module on CPAN is able to do this
! properly.
There can be whitespace between the operator and the quoting
characters, except when C<#> is being used as the quoting character.
--- 681,689 ----
$s = q{ if($a eq "}") ... }; # WRONG
! is a syntax error. The C<Text::Balanced> module (from CPAN, and
! starting from Perl 5.8 part of the standard distribution) is able
! to do this properly.
There can be whitespace between the operator and the quoting
characters, except when C<#> is being used as the quoting character.
***************
*** 679,687 ****
s {foo} # Replace foo
{bar} # with bar.
! For constructs that do interpolate, variables beginning with "C<$>"
! or "C<@>" are interpolated, as are the following escape sequences. Within
! a transliteration, the first eleven of these sequences may be used.
\t tab (HT, TAB)
\n newline (NL)
--- 694,701 ----
s {foo} # Replace foo
{bar} # with bar.
! The following escape sequences are available in constructs that interpolate
! and in transliterations.
\t tab (HT, TAB)
\n newline (NL)
***************
*** 696,701 ****
--- 710,718 ----
\c[ control char (ESC)
\N{name} named char
+ The following escape sequences are available in constructs that interpolate
+ but not in transliterations.
+
\l lowercase next char
\u uppercase next char
\L lowercase till \E
***************
*** 721,726 ****
--- 738,753 ----
C<"\015">. If you get in the habit of using C<"\n"> for networking,
you may be burned some day.
+ For constructs that do interpolate, variables beginning with "C<$>"
+ or "C<@>" are interpolated. Subscripted variables such as C<$a[3]> or
+ C<$href->{key}[0]> are also interpolated, as are array and hash slices.
+ But method calls such as C<$obj->meth> are not.
+
+ Interpolating an array or slice interpolates the elements in order,
+ separated by the value of C<$">, so is equivalent to interpolating
+ C<join $", @array>. "Punctuation" arrays such as C<@+> are only
+ interpolated if the name is enclosed in braces C<@{+}>.
+
You cannot include a literal C<$> or C<@> within a C<\Q> sequence.
An unescaped C<$> or C<@> interpolates the corresponding variable,
while escaping will cause the literal string C<\$> to be inserted.
***************
*** 1701,1707 ****
If you call it again after this, it will assume you are processing another
@ARGV list, and if you haven't set @ARGV, will read input from STDIN.
! If angle brackets contain is a simple scalar variable (e.g.,
<$foo>), then that variable contains the name of the
filehandle to input from, or its typeglob, or a reference to the
same. For example:
--- 1728,1734 ----
If you call it again after this, it will assume you are processing another
@ARGV list, and if you haven't set @ARGV, will read input from STDIN.
! If what the angle brackets contain is a simple scalar variable (e.g.,
<$foo>), then that variable contains the name of the
filehandle to input from, or its typeglob, or a reference to the
same. For example:
***************
*** 1765,1771 ****
because the latter will alternate between returning a filename and
returning false.
! It you're trying to do variable interpolation, it's definitely better
to use the glob() function, because the older notation can cause people
to become confused with the indirect filehandle notation.
--- 1792,1798 ----
because the latter will alternate between returning a filename and
returning false.
! If you're trying to do variable interpolation, it's definitely better
to use the glob() function, because the older notation can cause people
to become confused with the indirect filehandle notation.
diff -c 'perl-5.7.1/pod/perlport.pod' 'perl-5.7.2/pod/perlport.pod'
Index: ./pod/perlport.pod
*** ./pod/perlport.pod Sun Apr 8 19:58:21 2001
--- ./pod/perlport.pod Wed Jul 11 04:38:05 2001
***************
*** 229,236 ****
One can circumnavigate both these problems in two ways. Either
transfer and store numbers always in text format, instead of raw
binary, or else consider using modules like Data::Dumper (included in
! the standard distribution as of Perl 5.005) and Storable. Keeping
! all data as text significantly simplifies matters.
=head2 Files and Filesystems
--- 229,236 ----
One can circumnavigate both these problems in two ways. Either
transfer and store numbers always in text format, instead of raw
binary, or else consider using modules like Data::Dumper (included in
! the standard distribution as of Perl 5.005) and Storable (included as
! of perl 5.8). Keeping all data as text significantly simplifies matters.
=head2 Files and Filesystems
***************
*** 595,601 ****
Linux linux ppc-linux
HP-UX hpux PA-RISC1.1
IRIX irix irix
! Mac OS X rhapsody rhapsody
MachTen PPC machten powerpc-machten
NeXT 3 next next-fat
NeXT 4 next OPENSTEP-Mach
--- 595,601 ----
Linux linux ppc-linux
HP-UX hpux PA-RISC1.1
IRIX irix irix
! Mac OS X darwin darwin
MachTen PPC machten powerpc-machten
NeXT 3 next next-fat
NeXT 4 next OPENSTEP-Mach
***************
*** 784,798 ****
$is_ppc = $MacPerl::Architecture eq 'MacPPC';
$is_68k = $MacPerl::Architecture eq 'Mac68K';
! S<Mac OS X> and S<Mac OS X Server>, based on NeXT's OpenStep OS, will
! (in theory) be able to run MacPerl natively, under the "Classic"
! environment. The new "Cocoa" environment (formerly called the "Yellow Box")
! may run a slightly modified version of MacPerl, using the Carbon interfaces.
- S<Mac OS X Server> and its Open Source version, Darwin, both run Unix
- perl natively (with a few patches). Full support for these
- is slated for perl 5.6.
-
Also see:
=over 4
--- 784,794 ----
$is_ppc = $MacPerl::Architecture eq 'MacPPC';
$is_68k = $MacPerl::Architecture eq 'Mac68K';
! S<Mac OS X>, based on NeXT's OpenStep OS, runs MacPerl natively, under the
! "Classic" environment. There is no "Carbon" version of MacPerl to run
! under the primary Mac OS X environment. S<Mac OS X> and its Open Source
! version, Darwin, both run Unix perl natively.
Also see:
=over 4
***************
*** 874,883 ****
non-VMS platforms and can be helpful for conversions to and from RMS
native formats.
! What C<\n> represents depends on the type of file opened. It could
! be C<\015>, C<\012>, C<\015\012>, or nothing. The VMS::Stdio module
! provides access to the special fopen() requirements of files with unusual
! attributes on VMS.
TCP/IP stacks are optional on VMS, so socket routines might not be
implemented. UDP sockets may not be supported.
--- 870,880 ----
non-VMS platforms and can be helpful for conversions to and from RMS
native formats.
! What C<\n> represents depends on the type of file opened. It usually
! represents C<\012> but it could also be C<\015>, C<\012>, C<\015\012>,
! C<\000>, C<\040>, or nothing depending on the file organiztion and
! record format. The VMS::Stdio module provides access to the
! special fopen() requirements of files with unusual attributes on VMS.
TCP/IP stacks are optional on VMS, so socket routines might not be
implemented. UDP sockets may not be supported.
***************
*** 1896,1902 ****
AIX
AmigaOS
! Darwin (Rhapsody)
DG/UX
DOS DJGPP 1)
DYNIX/ptx
--- 1893,1899 ----
AIX
AmigaOS
! Darwin (Mac OS X)
DG/UX
DOS DJGPP 1)
DYNIX/ptx
***************
*** 2042,2069 ****
=head1 SEE ALSO
! L<perlaix>, L<perlamiga>, L<perlcygwin>, L<perldos>, L<perlepoc>,
! L<perlebcdic>, L<perlhpux>, L<perlos2>, L<perlos390>, L<perlbs2000>,
! L<perlwin32>, L<perlvms>, L<perlvos>, and L<Win32>.
=head1 AUTHORS / CONTRIBUTORS
! Abigail <abigail@fnx.com>,
Charles Bailey <bailey@newman.upenn.edu>,
Graham Barr <gbarr@pobox.com>,
Tom Christiansen <tchrist@perl.com>,
! Nicholas Clark <Nicholas.Clark@liverpool.ac.uk>,
Thomas Dorner <Thomas.Dorner@start.de>,
! Andy Dougherty <doughera@lafcol.lafayette.edu>,
! Dominic Dunlop <domo@vo.lu>,
! Neale Ferguson <neale@mailbox.tabnsw.com.au>,
David J. Fiander <davidf@mks.com>,
Paul Green <Paul_Green@stratus.com>,
! M.J.T. Guy <mjtg@cus.cam.ac.uk>,
Jarkko Hietaniemi <jhi@iki.fi>,
Luther Huffman <lutherh@stratcom.com>,
! Nick Ing-Simmons <nick@ni-s.u-net.com>,
! Andreas J. KE<ouml>nig <koenig@kulturbox.de>,
Markus Laker <mlaker@contax.co.uk>,
Andrew M. Langmead <aml@world.std.com>,
Larry Moore <ljmoore@freespace.net>,
--- 2039,2069 ----
=head1 SEE ALSO
! L<perlaix>, L<perlapollo>, L<perlamiga>, L<perlbeos>, L<perlbs200>,
! L<perlcygwin>, L<perldgux>, L<perldos>, L<perlepoc>, L<perlebcdic>,
! L<perlhurd>, L<perlhpux>, L<perlmachten>, L<perlmacos>, L<perlmint>,
! L<perlmpeix>, L<perlnetware>, L<perlos2>, L<perlos390>, L<perlplan9>,
! L<perlqnx>, L<perlsolaris>, L<perltru64>, L<perlunicode>,
! L<perlvmesa>, L<perlvms>, L<perlvos>, L<perlwin32>, and L<Win32>.
=head1 AUTHORS / CONTRIBUTORS
! Abigail <abigail@foad.org>,
Charles Bailey <bailey@newman.upenn.edu>,
Graham Barr <gbarr@pobox.com>,
Tom Christiansen <tchrist@perl.com>,
! Nicholas Clark <nick@ccl4.org>,
Thomas Dorner <Thomas.Dorner@start.de>,
! Andy Dougherty <doughera@lafayette.edu>,
! Dominic Dunlop <domo@computer.org>,
! Neale Ferguson <neale@vma.tabnsw.com.au>,
David J. Fiander <davidf@mks.com>,
Paul Green <Paul_Green@stratus.com>,
! M.J.T. Guy <mjtg@cam.ac.uk>,
Jarkko Hietaniemi <jhi@iki.fi>,
Luther Huffman <lutherh@stratcom.com>,
! Nick Ing-Simmons <nick@ing-simmons.net>,
! Andreas J. KE<ouml>nig <a.koenig@mind.de>,
Markus Laker <mlaker@contax.co.uk>,
Andrew M. Langmead <aml@world.std.com>,
Larry Moore <ljmoore@freespace.net>,
***************
*** 2078,2089 ****
Gurusamy Sarathy <gsar@activestate.com>,
Paul J. Schinder <schinder@pobox.com>,
Michael G Schwern <schwern@pobox.com>,
! Dan Sugalski <sugalskd@ous.edu>,
Nathan Torkington <gnat@frii.com>.
- This document is maintained by Chris Nandor
- <pudge@pobox.com>.
-
=head1 VERSION
! Version 1.47, last modified 22 March 2000
--- 2078,2086 ----
Gurusamy Sarathy <gsar@activestate.com>,
Paul J. Schinder <schinder@pobox.com>,
Michael G Schwern <schwern@pobox.com>,
! Dan Sugalski <dan@sidhe.org>,
Nathan Torkington <gnat@frii.com>.
=head1 VERSION
! Version 1.50, last modified 10 Jul 2001
diff -c 'perl-5.7.1/pod/perlre.pod' 'perl-5.7.2/pod/perlre.pod'
Index: ./pod/perlre.pod
*** ./pod/perlre.pod Tue Mar 6 04:06:36 2001
--- ./pod/perlre.pod Mon Jul 9 17:11:14 2001
***************
*** 268,274 ****
=item print
! Any alphanumeric or punctuation (special) character or space.
=item punct
--- 268,274 ----
=item print
! Any alphanumeric or punctuation (special) character or the space character.
=item punct
***************
*** 784,790 ****
got <d is under the >
Here's another example: let's say you'd like to match a number at the end
! of a string, and you also want to keep the preceding part the match.
So you write this:
$_ = "I have 2 numbers: 53147";
--- 784,790 ----
got <d is under the >
Here's another example: let's say you'd like to match a number at the end
! of a string, and you also want to keep the preceding of part the match.
So you write this:
$_ = "I have 2 numbers: 53147";
***************
*** 850,856 ****
But that isn't going to match; at least, not the way you're hoping. It
claims that there is no 123 in the string. Here's a clearer picture of
! why it that pattern matches, contrary to popular expectations:
$x = 'ABC123' ;
$y = 'ABC445' ;
--- 850,856 ----
But that isn't going to match; at least, not the way you're hoping. It
claims that there is no 123 in the string. Here's a clearer picture of
! why that pattern matches, contrary to popular expectations:
$x = 'ABC123' ;
$y = 'ABC445' ;
diff -c 'perl-5.7.1/pod/perlref.pod' 'perl-5.7.2/pod/perlref.pod'
Index: ./pod/perlref.pod
*** ./pod/perlref.pod Tue Mar 6 04:06:37 2001
--- ./pod/perlref.pod Mon Jul 9 17:11:15 2001
***************
*** 538,543 ****
--- 538,550 ----
B<WARNING>: This section describes an experimental feature. Details may
change without notice in future versions.
+ B<NOTE>: The current user-visible implementation of pseudo-hashes
+ (the weird use of the first array element) is deprecated starting from
+ Perl 5.8.0 and will be removed in Perl 5.10.0, and the feature will be
+ implemented differently. Not only is the current interface rather ugly,
+ but the current implementation slows down normal array and hash use quite
+ noticeably. The 'fields' pragma interface will remain available.
+
Beginning with release 5.005 of Perl, you may use an array reference
in some contexts that would normally require a hash reference. This
allows you to access array elements using symbolic names, as if they
diff -c 'perl-5.7.1/pod/perlretut.pod' 'perl-5.7.2/pod/perlretut.pod'
Index: ./pod/perlretut.pod
*** ./pod/perlretut.pod Wed Mar 7 02:12:34 2001
--- ./pod/perlretut.pod Mon Jul 9 17:11:15 2001
***************
*** 710,718 ****
/(ab(cd|ef)((gi)|j))/;
1 2 34
! so that if the regexp matched, e.g., C<$2> would contain 'cd' or 'ef'.
! For convenience, perl sets C<$+> to the highest numbered C<$1>, C<$2>,
! ... that got assigned.
Closely associated with the matching variables C<$1>, C<$2>, ... are
the B<backreferences> C<\1>, C<\2>, ... . Backreferences are simply
--- 710,721 ----
/(ab(cd|ef)((gi)|j))/;
1 2 34
! so that if the regexp matched, e.g., C<$2> would contain 'cd' or 'ef'. For
! convenience, perl sets C<$+> to the string held by the highest numbered
! C<$1>, C<$2>, ... that got assigned (and, somewhat related, C<$^N> to the
! value of the C<$1>, C<$2>, ... most-recently assigned; i.e. the C<$1>,
! C<$2>, ... associated with the rightmost closing parenthesis used in the
! match).
Closely associated with the matching variables C<$1>, C<$2>, ... are
the B<backreferences> C<\1>, C<\2>, ... . Backreferences are simply
***************
*** 1745,1752 ****
C<\P>, like C<\p{L}> for Unicode 'letters', or C<\p{Lu}> for uppercase
letters, or C<\P{Nd}> for non-digits. If a C<name> is just one
letter, the braces can be dropped. For instance, C<\pM> is the
! character class of Unicode 'marks'.
C<\X> is an abbreviation for a character class sequence that includes
the Unicode 'combining character sequences'. A 'combining character
sequence' is a base character followed by any number of combining
--- 1748,1761 ----
C<\P>, like C<\p{L}> for Unicode 'letters', or C<\p{Lu}> for uppercase
letters, or C<\P{Nd}> for non-digits. If a C<name> is just one
letter, the braces can be dropped. For instance, C<\pM> is the
! character class of Unicode 'marks', for example accent marks.
! For the full list see L<perlunicode>.
+ The Unicode has also been separated into various sets of charaters
+ which you can test with C<\p{In...}> (in) and C<\P{In...}> (not in),
+ for example C<\p{InLatin}>, C<\p{InGreek}>, or C<\P{InKatakana}>.
+ For the full list see L<perlunicode>.
+
C<\X> is an abbreviation for a character class sequence that includes
the Unicode 'combining character sequences'. A 'combining character
sequence' is a base character followed by any number of combining
***************
*** 1756,1761 ****
--- 1765,1773 ----
S<C<COMBINING RING> >, which translates in Danish to A with the circle
atop it, as in the word Angstrom. C<\X> is equivalent to C<\PM\pM*}>,
i.e., a non-mark followed by one or more marks.
+
+ For the the full and latest information about Unicode see the latest
+ Unicode standard, or the Unicode Consortium's website http://www.unicode.org/
As if all those classes weren't enough, Perl also defines POSIX style
character classes. These have the form C<[:name:]>, with C<name> the
diff -c 'perl-5.7.1/pod/perlsec.pod' 'perl-5.7.2/pod/perlsec.pod'
Index: ./pod/perlsec.pod
*** ./pod/perlsec.pod Tue Mar 6 04:06:37 2001
--- ./pod/perlsec.pod Mon Jul 9 17:11:15 2001
***************
*** 44,51 ****
=item *
! If you pass a list of arguments to either C<system> or C<exec>,
! the elements of that list are B<not> checked for taintedness.
=item *
--- 44,51 ----
=item *
! If you pass more than one argument to either C<system> or C<exec>,
! the arguments are B<not> checked for taintedness.
=item *
***************
*** 53,61 ****
=back
! Any variable set to a value
! derived from tainted data will itself be tainted, even if it is
! logically impossible for the tainted data to alter the variable.
Because taintedness is associated with each scalar value, some
elements of an array can be tainted and others not.
--- 53,62 ----
=back
! The value of an expression containing tainted data will itself be
! tainted, even if it is logically impossible for the tainted data to
! affect the value.
!
Because taintedness is associated with each scalar value, some
elements of an array can be tainted and others not.
***************
*** 95,101 ****
unlink $data, $arg; # Insecure
umask $arg; # Insecure
! exec "echo $arg"; # Insecure
exec "echo", $arg; # Secure (doesn't use the shell)
exec "sh", '-c', $arg; # Considered secure, alas!
--- 96,102 ----
unlink $data, $arg; # Insecure
umask $arg; # Insecure
! exec "echo $arg"; # Insecure (uses the shell)
exec "echo", $arg; # Secure (doesn't use the shell)
exec "sh", '-c', $arg; # Considered secure, alas!
***************
*** 102,107 ****
--- 103,116 ----
@files = <*.c>; # insecure (uses readdir() or similar)
@files = glob('*.c'); # insecure (uses readdir() or similar)
+ # In Perl releases older than 5.6.0 the <*.c> and glob('*.c') would
+ # have used an external program to do the filename expansion; but in
+ # either case the result is tainted since the list of filenames comes
+ # from outside of the program.
+
+ $bad = ($arg, 23); # $bad will be tainted
+ $arg, `true`; # Insecure (although it isn't really)
+
If you try to do something insecure, you will get a fatal error saying
something like "Insecure dependency" or "Insecure $ENV{PATH}". Note that you
can still write an insecure B<system> or B<exec>, but only by explicitly
***************
*** 109,118 ****
=head2 Laundering and Detecting Tainted Data
! To test whether a variable contains tainted data, and whose use would thus
! trigger an "Insecure dependency" message, check your nearby CPAN mirror
! for the F<Taint.pm> module, which should become available around November
! 1997. Or you may be able to use the following I<is_tainted()> function.
sub is_tainted {
return ! eval {
--- 118,128 ----
=head2 Laundering and Detecting Tainted Data
! To test whether a variable contains tainted data, and whose use would
! thus trigger an "Insecure dependency" message, you can use the
! tainted() function of the Scalar::Util module, available in your
! nearby CPAN mirror, and included in Perl starting from the release 5.8.0.
! Or you may be able to use the following I<is_tainted()> function.
sub is_tainted {
return ! eval {
***************
*** 343,352 ****
source. Security through obscurity, the name for hiding your bugs
instead of fixing them, is little security indeed.
! You can try using encryption via source filters (Filter::* from CPAN).
! But crackers might be able to decrypt it. You can try using the
! byte code compiler and interpreter described below, but crackers might
! be able to de-compile it. You can try using the native-code compiler
described below, but crackers might be able to disassemble it. These
pose varying degrees of difficulty to people wanting to get at your
code, but none can definitively conceal it (this is true of every
--- 353,363 ----
source. Security through obscurity, the name for hiding your bugs
instead of fixing them, is little security indeed.
! You can try using encryption via source filters (Filter::* from CPAN,
! or Filter::Util::Call and Filter::Simple since Perl 5.8).
! But crackers might be able to decrypt it. You can try using the byte
! code compiler and interpreter described below, but crackers might be
! able to de-compile it. You can try using the native-code compiler
described below, but crackers might be able to disassemble it. These
pose varying degrees of difficulty to people wanting to get at your
code, but none can definitively conceal it (this is true of every
diff -c 'perl-5.7.1/pod/perlsub.pod' 'perl-5.7.2/pod/perlsub.pod'
Index: ./pod/perlsub.pod
*** ./pod/perlsub.pod Tue Mar 6 04:06:37 2001
--- ./pod/perlsub.pod Mon Jul 9 17:11:15 2001
***************
*** 207,214 ****
function in all capitals is a loosely-held convention meaning it
will be called indirectly by the run-time system itself, usually
due to a triggered event. Functions that do special, pre-defined
! things include C<BEGIN>, C<CHECK>, C<INIT>, C<END>, C<AUTOLOAD>, and
! C<DESTROY>--plus all functions mentioned in L<perltie>.
=head2 Private Variables via my()
--- 207,214 ----
function in all capitals is a loosely-held convention meaning it
will be called indirectly by the run-time system itself, usually
due to a triggered event. Functions that do special, pre-defined
! things include C<BEGIN>, C<CHECK>, C<INIT>, C<END>, C<AUTOLOAD>,
! C<CLONE> and C<DESTROY>--plus all functions mentioned in L<perltie>.
=head2 Private Variables via my()
diff -c 'perl-5.7.1/pod/perlsyn.pod' 'perl-5.7.2/pod/perlsyn.pod'
Index: ./pod/perlsyn.pod
*** ./pod/perlsyn.pod Wed Mar 7 17:01:02 2001
--- ./pod/perlsyn.pod Mon Jul 9 17:11:15 2001
***************
*** 393,400 ****
}
There is no official C<switch> statement in Perl, because there are
! already several ways to write the equivalent. In addition to the
! above, you could write
SWITCH: {
$abc = 1, last SWITCH if /^abc/;
--- 393,410 ----
}
There is no official C<switch> statement in Perl, because there are
! already several ways to write the equivalent.
!
! However, starting from Perl 5.8 to get switch and case one can use
! the Switch extension and say:
!
! use Switch;
!
! after which one has switch and case. It is not as fast as it could be
! because it's not really part of the language (it's done using source
! filters) but it is available, and it's very flexible.
!
! In addition to the above BLOCK construct, you could write
SWITCH: {
$abc = 1, last SWITCH if /^abc/;
diff -c 'perl-5.7.1/pod/perltie.pod' 'perl-5.7.2/pod/perltie.pod'
Index: ./pod/perltie.pod
*** ./pod/perltie.pod Tue Mar 6 04:06:38 2001
--- ./pod/perltie.pod Mon Jul 9 17:11:15 2001
***************
*** 1081,1084 ****
UNTIE by Nick Ing-Simmons <F<nick@ing-simmons.net>>
! Tying Arrays by Casey Tweten <F<crt@kiski.net>>
--- 1081,1084 ----
UNTIE by Nick Ing-Simmons <F<nick@ing-simmons.net>>
! Tying Arrays by Casey West <F<casey@geeknest.com>>
diff -c 'perl-5.7.1/pod/perltoc.pod' 'perl-5.7.2/pod/perltoc.pod'
Index: ./pod/perltoc.pod
*** ./pod/perltoc.pod Tue Apr 10 04:59:17 2001
--- ./pod/perltoc.pod Fri Jul 13 07:36:42 2001
***************
*** 361,381 ****
mkdir FILENAME,MASK, mkdir FILENAME, msgctl ID,CMD,ARG, msgget KEY,FLAGS,
msgrcv ID,VAR,SIZE,TYPE,FLAGS, msgsnd ID,MSG,FLAGS, my EXPR, my EXPR :
ATTRIBUTES, next LABEL, next, no Module LIST, oct EXPR, oct, open
! FILEHANDLE,MODE,LIST, open FILEHANDLE,EXPR, open FILEHANDLE, opendir
! DIRHANDLE,EXPR, ord EXPR, ord, our EXPR, pack TEMPLATE,LIST, package
! NAMESPACE, package, pipe READHANDLE,WRITEHANDLE, pop ARRAY, pop, pos
! SCALAR, pos, print FILEHANDLE LIST, print LIST, print, printf FILEHANDLE
! FORMAT, LIST, printf FORMAT, LIST, prototype FUNCTION, push ARRAY,LIST,
! q/STRING/, qq/STRING/, qr/STRING/, qx/STRING/, qw/STRING/, quotemeta EXPR,
! quotemeta, rand EXPR, rand, read FILEHANDLE,SCALAR,LENGTH,OFFSET, read
! FILEHANDLE,SCALAR,LENGTH, readdir DIRHANDLE, readline EXPR, readlink EXPR,
! readlink, readpipe EXPR, recv SOCKET,SCALAR,LENGTH,FLAGS, redo LABEL, redo,
! ref EXPR, ref, rename OLDNAME,NEWNAME, require VERSION, require EXPR,
! require, reset EXPR, reset, return EXPR, return, reverse LIST, rewinddir
! DIRHANDLE, rindex STR,SUBSTR,POSITION, rindex STR,SUBSTR, rmdir FILENAME,
! rmdir, s///, scalar EXPR, seek FILEHANDLE,POSITION,WHENCE, seekdir
! DIRHANDLE,POS, select FILEHANDLE, select, select RBITS,WBITS,EBITS,TIMEOUT,
! semctl ID,SEMNUM,CMD,ARG, semget KEY,NSEMS,FLAGS, semop KEY,OPSTRING, send
SOCKET,MSG,FLAGS,TO, send SOCKET,MSG,FLAGS, setpgrp PID,PGRP, setpriority
WHICH,WHO,PRIORITY, setsockopt SOCKET,LEVEL,OPTNAME,OPTVAL, shift ARRAY,
shift, shmctl ID,CMD,ARG, shmget KEY,SIZE,FLAGS, shmread ID,VAR,POS,SIZE,
--- 361,382 ----
mkdir FILENAME,MASK, mkdir FILENAME, msgctl ID,CMD,ARG, msgget KEY,FLAGS,
msgrcv ID,VAR,SIZE,TYPE,FLAGS, msgsnd ID,MSG,FLAGS, my EXPR, my EXPR :
ATTRIBUTES, next LABEL, next, no Module LIST, oct EXPR, oct, open
! FILEHANDLE,EXPR, open FILEHANDLE,MODE,EXPR, open FILEHANDLE,MODE,EXPR,LIST,
! open FILEHANDLE, opendir DIRHANDLE,EXPR, ord EXPR, ord, our EXPR, our EXPR
! : ATTRIBUTES, pack TEMPLATE,LIST, package NAMESPACE, package, pipe
! READHANDLE,WRITEHANDLE, pop ARRAY, pop, pos SCALAR, pos, print FILEHANDLE
! LIST, print LIST, print, printf FILEHANDLE FORMAT, LIST, printf FORMAT,
! LIST, prototype FUNCTION, push ARRAY,LIST, q/STRING/, qq/STRING/,
! qr/STRING/, qx/STRING/, qw/STRING/, quotemeta EXPR, quotemeta, rand EXPR,
! rand, read FILEHANDLE,SCALAR,LENGTH,OFFSET, read FILEHANDLE,SCALAR,LENGTH,
! readdir DIRHANDLE, readline EXPR, readlink EXPR, readlink, readpipe EXPR,
! recv SOCKET,SCALAR,LENGTH,FLAGS, redo LABEL, redo, ref EXPR, ref, rename
! OLDNAME,NEWNAME, require VERSION, require EXPR, require, reset EXPR, reset,
! return EXPR, return, reverse LIST, rewinddir DIRHANDLE, rindex
! STR,SUBSTR,POSITION, rindex STR,SUBSTR, rmdir FILENAME, rmdir, s///, scalar
! EXPR, seek FILEHANDLE,POSITION,WHENCE, seekdir DIRHANDLE,POS, select
! FILEHANDLE, select, select RBITS,WBITS,EBITS,TIMEOUT, semctl
! ID,SEMNUM,CMD,ARG, semget KEY,NSEMS,FLAGS, semop KEY,OPSTRING, send
SOCKET,MSG,FLAGS,TO, send SOCKET,MSG,FLAGS, setpgrp PID,PGRP, setpriority
WHICH,WHO,PRIORITY, setsockopt SOCKET,LEVEL,OPTNAME,OPTVAL, shift ARRAY,
shift, shmctl ID,CMD,ARG, shmget KEY,SIZE,FLAGS, shmread ID,VAR,POS,SIZE,
***************
*** 838,847 ****
C<recallCommand>, C<ShellBang>, C<pager>, C<tkRunning>, C<signalLevel>,
C<warnLevel>, C<dieLevel>, C<AutoTrace>, C<LineInfo>, C<inhibit_exit>,
! C<PrintRet>, C<ornaments>, C<frame>, C<maxTraceLen>, C<arrayDepth>,
! C<hashDepth>, C<compactDump>, C<veryCompact>, C<globPrint>, C<DumpDBFiles>,
! C<DumpPackages>, C<DumpReused>, C<quote>, C<HighBit>, C<undefPrint>,
! C<UsageOnly>, C<TTY>, C<noTTY>, C<ReadLine>, C<NonStop>
=item Debugger input/output
--- 839,848 ----
C<recallCommand>, C<ShellBang>, C<pager>, C<tkRunning>, C<signalLevel>,
C<warnLevel>, C<dieLevel>, C<AutoTrace>, C<LineInfo>, C<inhibit_exit>,
! C<PrintRet>, C<ornaments>, C<frame>, C<maxTraceLen>, C<windowSize>,
! C<arrayDepth>, C<hashDepth>, C<compactDump>, C<veryCompact>, C<globPrint>,
! C<DumpDBFiles>, C<DumpPackages>, C<DumpReused>, C<quote>, C<HighBit>,
! C<undefPrint>, C<UsageOnly>, C<TTY>, C<noTTY>, C<ReadLine>, C<NonStop>
=item Debugger input/output
***************
*** 880,887 ****
=item Predefined Names
! $ARG, $_, $<I<digits>>, $MATCH, $&, $PREMATCH, $`, $POSTMATCH, $',
! $LAST_PAREN_MATCH, $+, @LAST_MATCH_END, @+, $MULTILINE_MATCHING, $*,
input_line_number HANDLE EXPR, $INPUT_LINE_NUMBER, $NR, $,
input_record_separator HANDLE EXPR, $INPUT_RECORD_SEPARATOR, $RS, $/,
autoflush HANDLE EXPR, $OUTPUT_AUTOFLUSH, $|, output_field_separator HANDLE
--- 881,888 ----
=item Predefined Names
! $ARG, $_, $a, $b, $<I<digits>>, $MATCH, $&, $PREMATCH, $`, $POSTMATCH, $',
! $LAST_PAREN_MATCH, $+, $^N, @LAST_MATCH_END, @+, $MULTILINE_MATCHING, $*,
input_line_number HANDLE EXPR, $INPUT_LINE_NUMBER, $NR, $,
input_record_separator HANDLE EXPR, $INPUT_RECORD_SEPARATOR, $RS, $/,
autoflush HANDLE EXPR, $OUTPUT_AUTOFLUSH, $|, output_field_separator HANDLE
***************
*** 907,914 ****
$OSNAME, $^O, $PERLDB, $^P, 0x01, 0x02, 0x04, 0x08, 0x10, 0x20, 0x40, 0x80,
0x100, 0x200, $LAST_REGEXP_CODE_RESULT, $^R, $EXCEPTIONS_BEING_CAUGHT, $^S,
$BASETIME, $^T, $PERL_VERSION, $^V, $WARNING, $^W, ${^WARNING_BITS},
! ${^WIDE_SYSTEM_CALLS}, $EXECUTABLE_NAME, $^X, $ARGV, @ARGV, @INC, @_, %INC,
! %ENV, $ENV{expr}, %SIG, $SIG{expr}
=item Error Indicators
--- 908,915 ----
$OSNAME, $^O, $PERLDB, $^P, 0x01, 0x02, 0x04, 0x08, 0x10, 0x20, 0x40, 0x80,
0x100, 0x200, $LAST_REGEXP_CODE_RESULT, $^R, $EXCEPTIONS_BEING_CAUGHT, $^S,
$BASETIME, $^T, $PERL_VERSION, $^V, $WARNING, $^W, ${^WARNING_BITS},
! ${^WIDE_SYSTEM_CALLS}, $EXECUTABLE_NAME, $^X, $ARGV, @ARGV, @F, @INC, @_,
! %INC, %ENV, $ENV{expr}, %SIG, $SIG{expr}
=item Error Indicators
***************
*** 1917,1922 ****
--- 1918,1925 ----
=item The localeconv function
+ =item I18N::Langinfo
+
=back
=item LOCALE CATEGORIES
***************
*** 1995,2000 ****
--- 1998,2007 ----
=item Effects of character semantics
+ =item Scripts
+
+ =item Blocks
+
=item Character encodings for input and output
=back
***************
*** 2031,2041 ****
=item POSIX-BC
=back
=item SINGLE OCTET TABLES
! recipe 0, recipe 1, recipe 2, recipe 3, recipe 4
=item IDENTIFYING CHARACTER CODE SETS
--- 2038,2050 ----
=item POSIX-BC
+ =item Unicode and UTF
+
=back
=item SINGLE OCTET TABLES
! recipe 0, recipe 1, recipe 2, recipe 3, recipe 4, recipe 5, recipe 6
=item IDENTIFYING CHARACTER CODE SETS
***************
*** 2075,2081 ****
=back
! =item TRANFORMATION FORMATS
=over 4
--- 2084,2090 ----
=back
! =item TRANSFORMATION FORMATS
=over 4
***************
*** 2085,2091 ****
=item Quoted-Printable encoding and decoding
! =item Caesarian cyphers
=back
--- 2094,2100 ----
=item Quoted-Printable encoding and decoding
! =item Caesarian ciphers
=back
***************
*** 2103,2111 ****
IFS access
! =item OS/390
! chcp, dataset access, OS/390 iconv, locales
=item VM/ESA?
--- 2112,2120 ----
IFS access
! =item OS/390, z/OS
! chcp, dataset access, OS/390, z/OS iconv, locales
=item VM/ESA?
***************
*** 2119,2124 ****
--- 2128,2135 ----
=item REFERENCES
+ =item HISTORY
+
=item AUTHOR
=back
***************
*** 2165,2170 ****
--- 2176,2183 ----
=item Perl Modules
+ =item Making your module threadsafe
+
=back
=item SEE ALSO
***************
*** 2190,2227 ****
=item Standard Modules
! AnyDBM_File, AutoLoader, AutoSplit, B, B::Asmdata, B::Assembler, B::Bblock,
! B::Bytecode, B::C, B::CC, B::Concise, B::Debug, B::Deparse,
! B::Disassembler, B::Lint, B::Showlex, B::Stackobj, B::Stash, B::Terse,
! B::Xref, Benchmark, ByteLoader, CGI, CGI::Apache, CGI::Carp, CGI::Cookie,
! CGI::Fast, CGI::Pretty, CGI::Push, CGI::Switch, CGI::Util, CPAN,
! CPAN::FirstTime, CPAN::Nox, Carp, Carp::Heavy, Class::ISA, Class::Struct,
! Cwd, DB, DB_File, Devel::SelfStubber, Digest, DirHandle, Dumpvalue, Encode,
! Encode::EncodeFormat, Encode::Tcl, English, Env, Exporter, Exporter::Heavy,
! ExtUtils::Command, ExtUtils::Embed, ExtUtils::Install, ExtUtils::Installed,
! ExtUtils::Liblist, ExtUtils::MM_Cygwin, ExtUtils::MM_OS2,
! ExtUtils::MM_Unix, ExtUtils::MM_VMS, ExtUtils::MM_Win32,
! ExtUtils::MakeMaker, ExtUtils::Manifest, ExtUtils::Mkbootstrap,
! ExtUtils::Mksymlists, ExtUtils::Packlist, ExtUtils::testlib, Fatal, Fcntl,
! File::Basename, File::CheckTree, File::Compare, File::Copy, File::DosGlob,
! File::Find, File::Path, File::Spec, File::Spec::Epoc,
! File::Spec::Functions, File::Spec::Mac, File::Spec::OS2, File::Spec::Unix,
! File::Spec::VMS, File::Spec::Win32, File::Temp, File::stat, FileCache,
! FileHandle, Filter::Simple, FindBin, Getopt::Long, Getopt::Std,
! I18N::Collate, IO, IPC::Open2, IPC::Open3, Locale::Constants,
! Locale::Country, Locale::Currency, Locale::Language, Math::BigFloat,
! Math::BigInt, Math::Complex, Math::Trig, NDBM_File, Net::Ping,
! Net::hostent, Net::netent, Net::protoent, Net::servent, O, ODBM_File,
! Opcode, POSIX, PerlIO, Pod::Checker, Pod::Find, Pod::Html,
! Pod::InputObjects, Pod::LaTeX, Pod::Man, Pod::ParseUtils, Pod::Parser,
! Pod::Plainer, Pod::Select, Pod::Text, Pod::Text::Color,
! Pod::Text::Overstrike, Pod::Text::Termcap, Pod::Usage, SDBM_File, Safe,
! Search::Dict, SelectSaver, SelfLoader, Shell, Socket, Storable, Switch,
! Symbol, Term::ANSIColor, Term::Cap, Term::Complete, Term::ReadLine, Test,
! Test::Harness, Text::Abbrev, Text::Balanced, Text::ParseWords,
Text::Soundex, Text::Tabs, Text::Wrap, Tie::Array, Tie::Handle, Tie::Hash,
Tie::RefHash, Tie::Scalar, Tie::SubstrHash, Time::Local, Time::gmtime,
! Time::localtime, Time::tm, UNIVERSAL, User::grent, User::pwent, Win32
=item Extension Modules
--- 2203,2248 ----
=item Standard Modules
! AnyDBM_File, Attribute::Handlers, AutoLoader, AutoSplit, B, B::Asmdata,
! B::Assembler, B::Bblock, B::Bytecode, B::C, B::CC, B::Concise, B::Debug,
! B::Deparse, B::Disassembler, B::Lint, B::Showlex, B::Stackobj, B::Stash,
! B::Terse, B::Xref, Benchmark, ByteLoader, CGI, CGI::Apache, CGI::Carp,
! CGI::Cookie, CGI::Fast, CGI::Pretty, CGI::Push, CGI::Switch, CGI::Util,
! CPAN, CPAN::FirstTime, CPAN::Nox, Carp, Carp::Heavy, Class::ISA,
! Class::Struct, Cwd, DB, DB_File, Devel::SelfStubber, Digest, DirHandle,
! Dumpvalue, Encode, Encode::EncodeFormat, Encode::Tcl, English, Env,
! Exporter, Exporter::Heavy, ExtUtils::Command, ExtUtils::Constant,
! ExtUtils::Embed, ExtUtils::Install, ExtUtils::Installed, ExtUtils::Liblist,
! ExtUtils::MM_Cygwin, ExtUtils::MM_NW5, ExtUtils::MM_OS2, ExtUtils::MM_Unix,
! ExtUtils::MM_VMS, ExtUtils::MM_Win32, ExtUtils::MakeMaker,
! ExtUtils::Manifest, ExtUtils::Mkbootstrap, ExtUtils::Mksymlists,
! ExtUtils::Packlist, ExtUtils::testlib, Fatal, Fcntl, File::Basename,
! File::CheckTree, File::Compare, File::Copy, File::DosGlob, File::Find,
! File::Path, File::Spec, File::Spec::Epoc, File::Spec::Functions,
! File::Spec::Mac, File::Spec::OS2, File::Spec::Unix, File::Spec::VMS,
! File::Spec::Win32, File::Temp, File::stat, FileCache, FileHandle,
! Filter::Simple, FindBin, Getopt::Long, Getopt::Std, I18N::Collate,
! I18N::LangTags, I18N::LangTags::List, IO, IPC::Open2, IPC::Open3,
! Locale::Constants, Locale::Country, Locale::Currency, Locale::Language,
! Locale::Maketext, Locale::Maketext::TPJ13, Math::BigFloat, Math::BigInt,
! Math::BigInt::Calc, Math::Complex, Math::Trig, Memoize,
! Memoize::AnyDBM_File, Memoize::Expire, Memoize::ExpireFile,
! Memoize::ExpireTest, Memoize::NDBM_File, Memoize::SDBM_File,
! Memoize::Saves, Memoize::Storable, NDBM_File, NEXT, Net::Cmd, Net::Config,
! Net::Domain, Net::FTP, Net::NNTP, Net::Netrc, Net::POP3, Net::Ping,
! Net::SMTP, Net::Time, Net::hostent, Net::libnetFAQ, Net::netent,
! Net::protoent, Net::servent, O, ODBM_File, Opcode, POSIX, PerlIO,
! Pod::Checker, Pod::Find, Pod::Html, Pod::InputObjects, Pod::LaTeX,
! Pod::Man, Pod::ParseUtils, Pod::Parser, Pod::Plainer, Pod::Select,
! Pod::Text, Pod::Text::Color, Pod::Text::Overstrike, Pod::Text::Termcap,
! Pod::Usage, SDBM_File, Safe, Search::Dict, SelectSaver, SelfLoader, Shell,
! Socket, Storable, Switch, Symbol, Term::ANSIColor, Term::Cap,
! Term::Complete, Term::ReadLine, Test, Test::Harness, Test::More,
! Test::Simple, Text::Abbrev, Text::Balanced, Text::ParseWords,
Text::Soundex, Text::Tabs, Text::Wrap, Tie::Array, Tie::Handle, Tie::Hash,
Tie::RefHash, Tie::Scalar, Tie::SubstrHash, Time::Local, Time::gmtime,
! Time::localtime, Time::tm, UNIVERSAL, UnicodeCD, User::grent, User::pwent,
! Win32
=item Extension Modules
***************
*** 2455,2462 ****
=item Is there an IDE or Windows Perl Editor?
! CodeMagicCD, Komodo, The Object System, PerlBuilder, Perl code magic,
! visiPerl+, GNU Emacs, MicroEMACS, XEmacs, Elvis, Vile, Vim, Codewright,
MultiEdit, SlickEdit, Bash, Ksh, Tcsh, Zsh, BBEdit and BBEdit Lite, Alpha
=item Where can I get Perl macros for vi?
--- 2476,2483 ----
=item Is there an IDE or Windows Perl Editor?
! Komodo, The Object System, Open Perl IDE, PerlBuilder, visiPerl+,
! CodeMagicCD, GNU Emacs, MicroEMACS, XEmacs, Elvis, Vile, Vim, Codewright,
MultiEdit, SlickEdit, Bash, Ksh, Tcsh, Zsh, BBEdit and BBEdit Lite, Alpha
=item Where can I get Perl macros for vi?
***************
*** 2630,2636 ****
a), b), c), d), e)
! =item How can I tell whether a list or array contains a certain element?
=item How do I compute the difference of two arrays? How do I compute the
intersection of two arrays?
--- 2651,2658 ----
a), b), c), d), e)
! =item How can I tell whether a certain element is contained in a list or
! array?
=item How do I compute the difference of two arrays? How do I compute the
intersection of two arrays?
***************
*** 2772,2777 ****
--- 2794,2802 ----
=item I still don't get locking. I just want to increment the number in
the file. How can I do this?
+ =item All I want to do is append a small amount of text to the end of a
+ file. Do I still have to use locking?
+
=item How do I randomly update a binary file?
=item How do I get a file's timestamp in perl?
***************
*** 3450,3456 ****
=item The CLEANUP: Keyword
! =item The POST_CALL: Keyword
=item The BOOT: Keyword
--- 3475,3481 ----
=item The CLEANUP: Keyword
! =item The POSTCALL: Keyword
=item The BOOT: Keyword
***************
*** 3623,3628 ****
--- 3648,3655 ----
=item Compile pass 3: peephole optimization
+ =item Pluggable runops
+
=back
=item Examining internal data structures with the C<dump> functions
***************
*** 3786,3791 ****
--- 3813,3822 ----
L<a2p|a2p>, L<s2p|s2p>, L<find2perl|find2perl>
+ =item Administration
+
+ L<libnetcfg|libnetcfg>
+
=item Development
L<perlbug|perlbug>, L<h2ph|h2ph>, L<c2ph|c2ph> and L<pstruct|pstruct>,
***************
*** 3864,3886 ****
AvFILL, av_clear, av_delete, av_exists, av_extend, av_fetch, av_fill,
av_len, av_make, av_pop, av_push, av_shift, av_store, av_undef, av_unshift,
! bytes_from_utf8, bytes_to_utf8, call_argv, call_method, call_pv, call_sv,
! CLASS, Copy, croak, CvSTASH, cv_const_sv, dMARK, dORIGMARK, dSP, dXSARGS,
! dXSI32, ENTER, eval_pv, eval_sv, EXTEND, fbm_compile, fbm_instr, FREETMPS,
! get_av, get_cv, get_hv, get_sv, GIMME, GIMME_V, GvSV, gv_fetchmeth,
! gv_fetchmethod, gv_fetchmethod_autoload, gv_stashpv, gv_stashsv, G_ARRAY,
! G_DISCARD, G_EVAL, G_NOARGS, G_SCALAR, G_VOID, HEf_SVKEY, HeHASH, HeKEY,
! HeKLEN, HePV, HeSVKEY, HeSVKEY_force, HeSVKEY_set, HeVAL, HvNAME, hv_clear,
! hv_delete, hv_delete_ent, hv_exists, hv_exists_ent, hv_fetch, hv_fetch_ent,
! hv_iterinit, hv_iterkey, hv_iterkeysv, hv_iternext, hv_iternextsv,
! hv_iterval, hv_magic, hv_store, hv_store_ent, hv_undef, isALNUM, isALPHA,
! isDIGIT, isLOWER, isSPACE, isUPPER, is_utf8_char, is_utf8_string, items,
! ix, LEAVE, load_module, looks_like_number, MARK, mg_clear, mg_copy,
! mg_find, mg_free, mg_get, mg_length, mg_magical, mg_set, Move, New, newAV,
! Newc, newCONSTSUB, newHV, newRV_inc, newRV_noinc, NEWSV, newSViv, newSVnv,
! newSVpv, newSVpvf, newSVpvn, newSVpvn_share, newSVrv, newSVsv, newSVuv,
! newXS, newXSproto, Newz, Nullav, Nullch, Nullcv, Nullhv, Nullsv, ORIGMARK,
! perl_alloc, perl_construct, perl_destruct, perl_free, perl_parse, perl_run,
PL_modglobal, PL_na, PL_sv_no, PL_sv_undef, PL_sv_yes, POPi, POPl, POPn,
POPp, POPpbytex, POPpx, POPs, PUSHi, PUSHMARK, PUSHn, PUSHp, PUSHs, PUSHu,
PUTBACK, Renew, Renewc, require_pv, RETVAL, Safefree, savepv, savepvn,
--- 3895,3919 ----
AvFILL, av_clear, av_delete, av_exists, av_extend, av_fetch, av_fill,
av_len, av_make, av_pop, av_push, av_shift, av_store, av_undef, av_unshift,
! ax, bytes_from_utf8, bytes_to_utf8, call_argv, call_method, call_pv,
! call_sv, CLASS, Copy, croak, CvSTASH, cv_const_sv, dAX, dITEMS, dMARK,
! dORIGMARK, dSP, dXSARGS, dXSI32, ENTER, eval_pv, eval_sv, EXTEND,
! fbm_compile, fbm_instr, FREETMPS, getcwd_sv, get_av, get_cv, get_hv,
! get_sv, GIMME, GIMME_V, grok_number, grok_numeric_radix, GvSV,
! gv_fetchmeth, gv_fetchmethod, gv_fetchmethod_autoload, gv_stashpv,
! gv_stashsv, G_ARRAY, G_DISCARD, G_EVAL, G_NOARGS, G_SCALAR, G_VOID,
! HEf_SVKEY, HeHASH, HeKEY, HeKLEN, HePV, HeSVKEY, HeSVKEY_force,
! HeSVKEY_set, HeVAL, HvNAME, hv_clear, hv_delete, hv_delete_ent, hv_exists,
! hv_exists_ent, hv_fetch, hv_fetch_ent, hv_iterinit, hv_iterkey,
! hv_iterkeysv, hv_iternext, hv_iternextsv, hv_iterval, hv_magic, hv_store,
! hv_store_ent, hv_undef, isALNUM, isALPHA, isDIGIT, isLOWER, isSPACE,
! isUPPER, is_utf8_char, is_utf8_string, items, ix, LEAVE, load_module,
! looks_like_number, MARK, mg_clear, mg_copy, mg_find, mg_free, mg_get,
! mg_length, mg_magical, mg_set, Move, New, newAV, Newc, newCONSTSUB, newHV,
! newRV_inc, newRV_noinc, newSV, NEWSV, newSViv, newSVnv, newSVpv, newSVpvf,
! newSVpvn, newSVpvn_share, newSVrv, newSVsv, newSVuv, newXS, newXSproto,
! Newz, Nullav, Nullch, Nullcv, Nullhv, Nullsv, ORIGMARK, perl_alloc,
! perl_clone, perl_construct, perl_destruct, perl_free, perl_parse, perl_run,
PL_modglobal, PL_na, PL_sv_no, PL_sv_undef, PL_sv_yes, POPi, POPl, POPn,
POPp, POPpbytex, POPpx, POPs, PUSHi, PUSHMARK, PUSHn, PUSHp, PUSHs, PUSHu,
PUTBACK, Renew, Renewc, require_pv, RETVAL, Safefree, savepv, savepvn,
***************
*** 3887,3918 ****
SAVETMPS, SP, SPAGAIN, ST, strEQ, strGE, strGT, strLE, strLT, strNE,
strnEQ, strnNE, StructCopy, SvCUR, SvCUR_set, SvEND, SvGETMAGIC, SvGROW,
SvIOK, SvIOKp, SvIOK_notUV, SvIOK_off, SvIOK_on, SvIOK_only, SvIOK_only_UV,
! SvIOK_UV, SvIV, SvIVX, SvLEN, SvNIOK, SvNIOKp, SvNIOK_off, SvNOK, SvNOKp,
! SvNOK_off, SvNOK_on, SvNOK_only, SvNV, SvNVX, SvOK, SvOOK, SvPOK, SvPOKp,
! SvPOK_off, SvPOK_on, SvPOK_only, SvPOK_only_UTF8, SvPV, SvPVX, SvPV_force,
! SvPV_nolen, SvREFCNT, SvREFCNT_dec, SvREFCNT_inc, SvROK, SvROK_off,
! SvROK_on, SvRV, SvSETMAGIC, SvSetSV, SvSetSV_nosteal, SvSTASH, SvTAINT,
! SvTAINTED, SvTAINTED_off, SvTAINTED_on, SvTRUE, SvTYPE, svtype, SVt_IV,
! SVt_NV, SVt_PV, SVt_PVAV, SVt_PVCV, SVt_PVHV, SVt_PVMG, SvUOK, SvUPGRADE,
! SvUTF8, SvUTF8_off, SvUTF8_on, SvUV, SvUVX, sv_2mortal, sv_bless, sv_catpv,
! sv_catpvf, sv_catpvf_mg, sv_catpvn, sv_catpvn_mg, sv_catpv_mg, sv_catsv,
! sv_catsv_mg, sv_chop, sv_clear, sv_cmp, sv_cmp_locale, sv_dec,
! sv_derived_from, sv_eq, sv_free, sv_gets, sv_grow, sv_inc, sv_insert,
! sv_isa, sv_isobject, sv_len, sv_len_utf8, sv_magic, sv_mortalcopy,
! sv_newmortal, sv_pvn_force, sv_pvutf8n_force, sv_reftype, sv_replace,
sv_rvweaken, sv_setiv, sv_setiv_mg, sv_setnv, sv_setnv_mg, sv_setpv,
sv_setpvf, sv_setpvf_mg, sv_setpviv, sv_setpviv_mg, sv_setpvn,
sv_setpvn_mg, sv_setpv_mg, sv_setref_iv, sv_setref_nv, sv_setref_pv,
! sv_setref_pvn, sv_setref_uv, sv_setsv, sv_setsv_mg, sv_setuv, sv_setuv_mg,
! sv_true, sv_unmagic, sv_unref, sv_unref_flags, sv_upgrade, sv_usepvn,
! sv_usepvn_mg, sv_utf8_decode, sv_utf8_downgrade, sv_utf8_encode,
! sv_utf8_upgrade, sv_vcatpvfn, sv_vsetpvfn, THIS, toLOWER, toUPPER,
! utf8n_to_uvchr, utf8n_to_uvuni, utf8_distance, utf8_hop, utf8_length,
! utf8_to_bytes, utf8_to_uvchr, utf8_to_uvuni, uvchr_to_utf8, uvuni_to_utf8,
! warn, XPUSHi, XPUSHn, XPUSHp, XPUSHs, XPUSHu, XS, XSRETURN, XSRETURN_EMPTY,
! XSRETURN_IV, XSRETURN_NO, XSRETURN_NV, XSRETURN_PV, XSRETURN_UNDEF,
! XSRETURN_YES, XST_mIV, XST_mNO, XST_mNV, XST_mPV, XST_mUNDEF, XST_mYES,
! XS_VERSION, XS_VERSION_BOOTCHECK, Zero
=item AUTHORS
--- 3920,3961 ----
SAVETMPS, SP, SPAGAIN, ST, strEQ, strGE, strGT, strLE, strLT, strNE,
strnEQ, strnNE, StructCopy, SvCUR, SvCUR_set, SvEND, SvGETMAGIC, SvGROW,
SvIOK, SvIOKp, SvIOK_notUV, SvIOK_off, SvIOK_on, SvIOK_only, SvIOK_only_UV,
! SvIOK_UV, SvIV, SvIVX, SvIVx, SvLEN, SvNIOK, SvNIOKp, SvNIOK_off, SvNOK,
! SvNOKp, SvNOK_off, SvNOK_on, SvNOK_only, SvNV, SvNVx, SvNVX, SvOK, SvOOK,
! SvPOK, SvPOKp, SvPOK_off, SvPOK_on, SvPOK_only, SvPOK_only_UTF8, SvPV,
! SvPVbyte, SvPVbytex, SvPVbytex_force, SvPVbyte_force, SvPVbyte_nolen,
! SvPVutf8, SvPVutf8x, SvPVutf8x_force, SvPVutf8_force, SvPVutf8_nolen,
! SvPVX, SvPVx, SvPV_force, SvPV_force_nomg, SvPV_nolen, SvREFCNT,
! SvREFCNT_dec, SvREFCNT_inc, SvROK, SvROK_off, SvROK_on, SvRV, SvSETMAGIC,
! SvSetMagicSV, SvSetMagicSV_nosteal, SvSetSV, SvSetSV_nosteal, SvSTASH,
! SvTAINT, SvTAINTED, SvTAINTED_off, SvTAINTED_on, SvTRUE, svtype, SvTYPE,
! SVt_IV, SVt_NV, SVt_PV, SVt_PVAV, SVt_PVCV, SVt_PVHV, SVt_PVMG, SvUOK,
! SvUPGRADE, SvUTF8, SvUTF8_off, SvUTF8_on, SvUV, SvUVX, SvUVx, sv_2bool,
! sv_2cv, sv_2io, sv_2iv, sv_2mortal, sv_2nv, sv_2pvbyte, sv_2pvbyte_nolen,
! sv_2pvutf8, sv_2pvutf8_nolen, sv_2pv_flags, sv_2pv_nolen, sv_2uv,
! sv_backoff, sv_bless, sv_catpv, sv_catpvf, sv_catpvf_mg, sv_catpvn,
! sv_catpvn_flags, sv_catpvn_mg, sv_catpv_mg, sv_catsv, sv_catsv_flags,
! sv_catsv_mg, sv_chop, sv_clear, sv_cmp, sv_cmp_locale, sv_collxfrm, sv_dec,
! sv_derived_from, sv_eq, sv_force_normal, sv_force_normal_flags, sv_free,
! sv_gets, sv_grow, sv_inc, sv_insert, sv_isa, sv_isobject, sv_iv, sv_len,
! sv_len_utf8, sv_magic, sv_mortalcopy, sv_newmortal, sv_newref, sv_nv,
! sv_pos_b2u, sv_pos_u2b, sv_pv, sv_pvbyte, sv_pvbyten, sv_pvbyten_force,
! sv_pvn, sv_pvn_force, sv_pvn_force_flags, sv_pvutf8, sv_pvutf8n,
! sv_pvutf8n_force, sv_reftype, sv_replace, sv_report_used, sv_reset,
sv_rvweaken, sv_setiv, sv_setiv_mg, sv_setnv, sv_setnv_mg, sv_setpv,
sv_setpvf, sv_setpvf_mg, sv_setpviv, sv_setpviv_mg, sv_setpvn,
sv_setpvn_mg, sv_setpv_mg, sv_setref_iv, sv_setref_nv, sv_setref_pv,
! sv_setref_pvn, sv_setref_uv, sv_setsv, sv_setsv_flags, sv_setsv_mg,
! sv_setuv, sv_setuv_mg, sv_taint, sv_tainted, sv_true, sv_unmagic, sv_unref,
! sv_unref_flags, sv_untaint, sv_upgrade, sv_usepvn, sv_usepvn_mg,
! sv_utf8_decode, sv_utf8_downgrade, sv_utf8_encode, sv_utf8_upgrade,
! sv_utf8_upgrade_flags, sv_uv, sv_vcatpvfn, sv_vsetpvfn, THIS, toLOWER,
! toUPPER, utf8n_to_uvchr, utf8n_to_uvuni, utf8_distance, utf8_hop,
! utf8_length, utf8_to_bytes, utf8_to_uvchr, utf8_to_uvuni, uvchr_to_utf8,
! uvuni_to_utf8, warn, XPUSHi, XPUSHn, XPUSHp, XPUSHs, XPUSHu, XS, XSRETURN,
! XSRETURN_EMPTY, XSRETURN_IV, XSRETURN_NO, XSRETURN_NV, XSRETURN_PV,
! XSRETURN_UNDEF, XSRETURN_YES, XST_mIV, XST_mNO, XST_mNV, XST_mPV,
! XST_mUNDEF, XST_mYES, XS_VERSION, XS_VERSION_BOOTCHECK, Zero
=item AUTHORS
***************
*** 3928,3934 ****
=item DESCRIPTION
djSP, is_gv_magical, LVRET, PL_DBsingle, PL_DBsub, PL_DBtrace, PL_dowarn,
! PL_last_in_gv, PL_ofs_sv, PL_rs, start_glob
=item AUTHORS
--- 3971,3978 ----
=item DESCRIPTION
djSP, is_gv_magical, LVRET, PL_DBsingle, PL_DBsub, PL_DBtrace, PL_dowarn,
! PL_last_in_gv, PL_ofs_sv, PL_rs, report_uninit, start_glob, sv_add_arena,
! sv_clean_all, sv_clean_objs, sv_free_arenas
=item AUTHORS
***************
*** 4046,4326 ****
=item DESCRIPTION
! =item Infrastructure
=over 4
! =item Mailing list archives
! =item Bug tracking system
! =item Regression Tests
! Coverage, Regression, __DIE__, suidperl, The 25% slowdown from perl4 to
! perl5
! =back
! =item Configure
! =over 4
! =item Install HTML
! =back
! =item Perl Language
! =over 4
! =item 64-bit Perl
! =item Prototypes
! Named prototypes, Indirect objects, Method calls, Context, Scoped subs
! =back
! =item Perl Internals
! =over 4
! =item magic_setisa
! =item Garbage Collection
! =item Reliable signals
! Alternate runops() for signal despatch, Figure out how to die() in delayed
! sighandler, Add tests for Thread::Signal, Automatic tests against CPAN
! =item Interpolated regex performance bugs
! =item Memory leaks from failed eval/regcomp
! =item Make XS easier to use
! =item Make embedded Perl easier to use
! =item Namespace cleanup
! =item MULTIPLICITY
! =item MacPerl
=back
! =item Documentation
=over 4
! =item A clear division into tutorial and reference
! =item Remove the artificial distinction between operators and functions
! =item More tutorials
! Regular expressions, I/O, pack/unpack, Debugging
! =item Include a search tool
! =item Include a locate tool
! =item Separate function manpages by default
! =item Users can't find the manpages
! =item Install ALL Documentation
! =item Outstanding issues to be documented
! =item Adapt www.linuxhq.com for Perl
! =item Replace man with a perl program
! =item Unicode tutorial
! =back
! =item Modules
! =over 4
! =item Update the POSIX extension to conform with the POSIX 1003.1 Edition 2
! =item Module versions
! =item New modules
! =item Profiler
! =item Tie Modules
! VecArray, SubstrArray, VirtualArray, ShiftSplice
! =item Procedural options
! =item RPC
! =item y2k localtime/gmtime
! =item Export File::Find variables
! =item Ioctl
! =item Debugger attach/detach
! =item Regular Expression debugger
! =item Alternative RE Syntax
! =item Bundled modules
! =item Expect
! =item GUI::Native
! =item Update semibroken auxiliary tools; h2ph, a2p, etc.
! =item pod2html
! =item Podchecker
! =back
! =item Tom's Wishes
! =over 4
! =item Webperl
! =item Mobile agents
! =item POSIX on non-POSIX
! =item Portable installations
=back
! =item Win32 Stuff
=over 4
! =item Rename new headers to be consistent with the rest
! =item Sort out the spawnvp() mess
! =item Work out DLL versioning
! =item Style-check
! =back
! =item Would be nice to have
! C<pack "(stuff)*">, Contiguous bitfields in pack/unpack, lexperl, Bundled
! perl preprocessor, Use posix calls internally where possible, format
! BOTTOM, -i rename file only when successfully changed, All ARGV input
! should act like <>, report HANDLE [formats], support in perlmain to rerun
! debugger, lvalue functions
! =item Possible pragmas
=over 4
! =item 'less'
=back
! =item Optimizations
=over 4
! =item constant function cache
! =item foreach(reverse...)
! =item Cache eval tree
! =item rcatmaybe
! =item Shrink opcode tables
! =item Cache hash value
! =item Optimize away @_ where possible
! =item Optimize sort by { $a <=> $b }
! =item Rewrite regexp parser for better integrated optimization
! =back
! =item Vague possibilities
! ref function in list context, make tr/// return histogram in list context?,
! Loop control on do{} et al, Explicit switch statements, compile to real
! threaded code, structured types, Modifiable $1 et al
! =item To Do Or Not To Do
! =over 4
! =item Making my() work on "package" variables
! =item "or" testing defined not truth
! =item "dynamic" lexicals
! =item "class"-based, rather than package-based "lexicals"
! =back
! =item Threading
! =over 4
! =item Modules
! =item Testing
! =item $AUTOLOAD
! =item exit/die
! =item External threads
! =item Thread::Pool
! =item thread-safety
! =item Per-thread GVs
=back
! =item Compiler
=over 4
! =item Optimization
! =item Byteperl
! =item Precompiled modules
! =item Executables
! =item Typed lexicals
! =item Win32
! =item END blocks
! =item _AUTOLOAD
! =item comppadlist
! =item Cached compilation
=back
--- 4090,4416 ----
=item DESCRIPTION
! =item To do during 5.6.x
=over 4
! =item Support for I/O disciplines
! =item Eliminate need for "use utf8";
! =item Create a char *sv_pvprintify(sv, STRLEN *lenp, UV flags)
! =item Autoload byte.pm
! =item Make "\u{XXXX}" et al work
! =item Overloadable regex assertions
! =item Unicode collation and normalization
! =item Unicode case mappings
! =item Unicode regular expression character classes
! =item use Thread for iThreads
! =item make perl_clone optionally clone ops
! =item Work out exit/die semantics for threads
! =item Typed lexicals for compiler
! =item Compiler workarounds for Win32
! =item AUTOLOADing in the compiler
! =item Fixing comppadlist when compiling
! =item Cleaning up exported namespace
! =item Complete signal handling
! =item Out-of-source builds
! =item POSIX realtime support
! =item UNIX98 support
! =item IPv6 Support
! =item Long double conversion
! =item Locales
! =item Thread-safe regexes
! =item Arithmetic on non-Arabic numerals
! =item POSIX Unicode character classes
! =item Factoring out common suffices/prefices in regexps (trie optimization)
+ =item Security audit shipped utilities
+
+ =item Custom opcodes
+
+ =item spawnvp() on Win32
+
+ =item DLL Versioning
+
+ =item Introduce @( and @)
+
+ =item Floating point handling
+
+ =item IV/UV preservation
+
+ =item Replace pod2html with something using Pod::Parser
+
+ =item Automate module testing on CPAN
+
+ =item sendmsg and recvmsg
+
+ =item Rewrite perlre documentation
+
+ =item Convert example code to IO::Handle filehandles
+
+ =item Document Win32 choices
+
+ =item Check new modules
+
+ =item Make roffitall find pods and libs itself
+
=back
! =item To do at some point
=over 4
! =item Remove regular expression recursion
! =item Memory leaks after failed eval
! =item pack "(stuff)*"
! =item bitfields in pack
! =item Cross compilation
! =item Perl preprocessor / macros
! =item Perl lexer in Perl
! =item Using POSIX calls internally
! =item -i rename file when changed
! =item All ARGV input should act like E<lt>E<gt>
! =item Support for rerunning debugger
! =item Test Suite for the Debugger
! =item my sub foo { }
! =item One-pass global destruction
! =item Rewrite regexp parser
! =item Cache recently used regexps
! =item Re-entrant functions
! =item Cross-compilation support
! =item Bit-shifting bitvectors
! =item debugger pragma
! =item use less pragma
! =item switch structures
! =item Cache eval tree
! =item rcatmaybe
! =item Shrink opcode tables
! =item Optimize away @_
! =item Prototypes versus indirect objects
! =item Install HMTL
! =item Prototype method calls
! =item Return context prototype declarations
! =item magic_setisa
! =item Garbage collection
! =item IO tutorial
! =item pack/unpack tutorial
! =item Rewrite perldoc
! =item Install .3p manpages
! =item Unicode tutorial
! =item Update POSIX.pm for 1003.1-2
! =item Retargetable installation
! =item POSIX emulation on non-POSIX systems
! =item Rename Win32 headers
! =item Finish off lvalue functions
! =item Update sprintf documentation
+ =item Use fchown/fchmod internally
+
=back
! =item Vague ideas
=over 4
! =item ref() in list context
! =item Make tr/// return histogram
! =item Compile to real threaded code
! =item Structured types
! =item Modifiable $1 et al.
! =item Procedural interfaces for IO::*, etc.
! =item RPC modules
! =item Attach/detach debugger from running program
+ =item Alternative RE syntax module
+
+ =item GUI::Native
+
+ =item foreach(reverse ...)
+
+ =item Constant function cache
+
+ =item Approximate regular expression matching
+
+ =back
+
+ =item Ongoing
+
=over 4
! =item Update guts documentation
+ =item Add more tests
+
+ =item Update auxiliary tools
+
=back
! =item Recently done things
=over 4
! =item Safe signal handling
! =item Tie Modules
! =item gettimeofday
! =item setitimer and getimiter
! =item Testing __DIE__ hook
! =item CPP equivalent in Perl
! =item Explicit switch statements
! =item autocroak
! =item UTF/EBCDIC
! =item UTF Regexes
! =item perlcc to produce executable
! =item END blocks saved in compiled output
! =item Secure temporary file module
! =item Integrate Time::HiRes
! =item Turn Cwd into XS
! =item Mmap for input
! =item Byte to/from UTF8 and UTF8 to/from local conversion
! =item Add sockatmark support
! =item Mailing list archives
! =item Bug tracking
! =item Integrate MacPerl
! =item Web "nerve center" for Perl
! =item Regular expression tutorial
! =item Debugging Tutorial
! =item Integrate new modules
! =item Integrate profiler
! =item Y2K error detection
! =item Regular expression debugger
! =item POD checker
+ =item "Dynamic" lexicals
+
+ =item Cache precompiled modules
+
=back
! =item Deprecated Wishes
=over 4
! =item Loop control on do{}
! =item Lexically scoped typeglobs
! =item format BOTTOM
! =item report HANDLE
! =item Generalised want()/caller())
! =item Named prototypes
! =item Built-in globbing
! =item Regression tests for suidperl
! =item Cached hash values
! =item Add compression modules
=item Reorganise documentation into tutorials/references
***************
*** 4322,4347 ****
=item Cached compilation
! =back
! =item Recently Finished Tasks
! =over 4
! =item Figure a way out of $^(capital letter)
! =item Filenames
! =item Foreign lines
! =item Namespace cleanup
! =item ISA.pm
! =item gettimeofday
! =item autocroak?
=back
=back
--- 4412,4439 ----
=item Add compression modules
! =item Reorganise documentation into tutorials/references
! =item Remove distinction between functions and operators
! =item Make XS easier to use
! =item Make embedding easier to use
! =item man for perl
! =item my $Package::variable
! =item "or" tests defined, not truth
! =item "class"-based lexicals
! =item byteperl
! =item Lazy evaluation / tail recursion removal
+ =item Make "use utf8" the default
+
=back
=back
***************
*** 4423,4431 ****
=item PERL_DESTRUCT_LEVEL
=item Pixie Profiling
! -h, -l, -p, -h, -i, -l, -testcoverage, -zero
=item CONCLUSION
--- 4515,4528 ----
=item PERL_DESTRUCT_LEVEL
+ =item Gprof Profiling
+
+ -a, -b, -e routine, -f routine, -s, -z
+
=item Pixie Profiling
! -h, -l, -p[rocedures], -h[eavy], -i[nvocations], -l[ines], -testcoverage,
! -z[ero]
=item CONCLUSION
***************
*** 4481,4486 ****
--- 4578,4713 ----
=back
+ =head2 perl572delta - what's new for perl v5.7.2
+
+ =over 4
+
+ =item DESCRIPTION
+
+ =item Security Vulnerability Closed
+
+ =item Incompatible Changes
+
+ =over 4
+
+ =item 64-bit platforms and malloc
+
+ =item AIX Dynaloading
+
+ =item Socket Extension Dynamic in VMS
+
+ =item Different Definition of the Unicode Character Classes \p{In...}
+
+ =item Deprecations
+
+ =back
+
+ =item Core Enhancements
+
+ =item Modules and Pragmata
+
+ =over 4
+
+ =item New Modules and Distributions
+
+ =item Updated And Improved Modules and Pragmata
+
+ =back
+
+ =item Utility Changes
+
+ =item New Documentation
+
+ =item Installation and Configuration Improvements
+
+ =over 4
+
+ =item New Or Improved Platforms
+
+ =item Generic Improvements
+
+ =back
+
+ =item Selected Bug Fixes
+
+ =over 4
+
+ =item Platform Specific Changes and Fixes
+
+ =back
+
+ =item New or Changed Diagnostics
+
+ =item Source Code Enhancements
+
+ =over 4
+
+ =item MAGIC constants
+
+ =item Better commented code
+
+ =item Regex pre-/post-compilation items matched up
+
+ =item gcc -Wall
+
+ =back
+
+ =item New Tests
+
+ =item Known Problems
+
+ =over 4
+
+ =item AIX
+
+ =item Amiga Perl Invoking Mystery
+
+ =item lib/ftmp-security tests warn 'system possibly insecure'
+
+ =item Cygwin intermittent failures of lib/Memoize/t/expire_file 11 and 12
+
+ =item HP-UX lib/io_multihomed Fails When LP64-Configur
+
+ =item HP-UX lib/posix Subtest 9 Fails When LP64-Configured
+
+ =item Linux With Sfio Fails op/misc Test 48
+
+ =item OS/390
+
+ =item op/sprintf tests 129 and 130
+
+ =item Failure of Thread tests
+
+ =item UNICOS
+
+ =item UTS
+
+ =item VMS
+
+ =item Win32
+
+ =item Localising a Tied Variable Leaks Memory
+
+ =item Self-tying of Arrays and Hashes Is Forbidden
+
+ =item Variable Attributes are not Currently Usable for Tieing
+
+ =item Building Extensions Can Fail Because Of Largefiles
+
+ =item The Compiler Suite Is Still Experimental
+
+ =item The Long Double Support is Still Experimental
+
+ =back
+
+ =item Reporting Bugs
+
+ =item SEE ALSO
+
+ =item HISTORY
+
+ =back
+
=head2 perl571delta - what's new for perl v5.7.1
=over 4
***************
*** 4493,4498 ****
--- 4720,4735 ----
=item Core Enhancements
+ =over 4
+
+ =item AUTOLOAD Is Now Lvaluable
+
+ =item PerlIO is Now The Default
+
+ =item Signals Are Now Safe
+
+ =back
+
=item Modules and Pragmata
=over 4
***************
*** 5463,5472 ****
=item 64-bit Perl
! =item GDBM and Threads
- =item NFS filesystems and utime(2)
-
=back
=item AUTHOR
--- 5700,5707 ----
=item 64-bit Perl
! =item AIX 4.2 and extensions using C++ with statics
=back
=item AUTHOR
***************
*** 5475,5480 ****
--- 5710,5725 ----
=back
+ =head2 perlapollo, README.apollo - Perl version 5 on Apollo DomainOS
+
+ =over 4
+
+ =item DESCRIPTION
+
+ =item AUTHOR
+
+ =back
+
=head2 perlamiga - Perl under Amiga OS
=over 4
***************
*** 5489,5495 ****
=over 4
! =item Prerequisites
B<Unix emulation for AmigaOS: ixemul.library>, B<Version of Amiga OS>
--- 5734,5740 ----
=over 4
! =item Prerequisites for Compiling Perl on AmigaOS
B<Unix emulation for AmigaOS: ixemul.library>, B<Version of Amiga OS>
***************
*** 5505,5536 ****
=over 4
! =item Manpages
! =item B<HTML>
! =item B<GNU> C<info> files
! =item C<LaTeX> docs
=back
! =item BUILD
=over 4
! =item Prerequisites
! =item Getting the perl source
! =item Making
! sh Configure -Dprefix=/ade -Dloclibpth=/ade/lib
! =item Testing
- =item Installing the built perl
-
=back
=item AUTHORS
--- 5750,5779 ----
=over 4
! =item Manpages for Perl on AmigaOS
! =item Perl HTML Documentation on AmigaOS
! =item Perl GNU Info Files on AmigaOS
! =item Perl LaTeX Documentation on AmigaOS
=back
! =item BUILDING PERL ON AMIGAOS
=over 4
! =item Build Prerequisites for Perl on AmigaOS
! =item Getting the Perl Source for AmigaOS
! =item Making Perl on AmigaOS
! =item Testing Perl on AmigaOS
! =item Installing the built Perl on AmigaOS
=back
=item AUTHORS
***************
*** 5539,5544 ****
--- 5782,5807 ----
=back
+ =head2 perlbeos, README.beos - Perl version 5 on BeOS
+
+ =over 4
+
+ =item DESCRIPTION
+
+ =over 4
+
+ =item General Issues with Perl on BeOS
+
+ =item BeOS Release-specific Notes
+
+ R4 x86, R4 PPC
+
+ =item Contact Information
+
+ =back
+
+ =back
+
=head2 perlbs2000, README.BS2000 - building and installing Perl for BS2000.
=over 4
***************
*** 5549,5571 ****
=over 4
! =item gzip
! =item bison
! =item Unpacking
! =item Compiling
! =item Testing
! =item Install
! =item Using Perl in the Posix-Shell
=item Using Perl in "native" BS2000
! =item Floating point anomalies
=back
--- 5812,5834 ----
=over 4
! =item gzip on BS2000
! =item bison on BS2000
! =item Unpacking Perl Distribution on BS2000
! =item Compiling Perl on BS2000
! =item Testing Perl on BS2000
! =item Installing Perl on BS2000
! =item Using Perl in the Posix-Shell of BS2000
=item Using Perl in "native" BS2000
! =item Floating point anomalies on BS2000
=back
***************
*** 5589,5595 ****
=item SYNOPSIS
! =item PREREQUISITES
=over 4
--- 5852,5858 ----
=item SYNOPSIS
! =item PREREQUISITES FOR COMPILING PERL ON CYGWIN
=over 4
***************
*** 5601,5666 ****
=back
! =item CONFIGURE
=over 4
! =item Strip Binaries
! =item Optional Libraries
C<-lcrypt>, C<-lgdbm> (C<use GDBM_File>), C<-ldb> (C<use DB_File>),
C<-lcygipc> (C<use IPC::SysV>)
! =item Configure-time Options
C<-Uusedl>, C<-Uusemymalloc>, C<-Dusemultiplicity>, C<-Duseperlio>,
C<-Duse64bitint>, C<-Duselongdouble>, C<-Dusethreads>, C<-Duselargefiles>
! =item Suspicious Warnings
I<dlsym()>, Win9x and C<d_eofnblk>, Compiler/Preprocessor defines
=back
! =item MAKE
=over 4
! =item Warnings
! =item ld2
=back
! =item TEST
=over 4
! =item File Permissions
! =item Hard Links
! =item Filetime Granularity
! =item Tainting Checks
! =item /etc/group
! =item Script Portability
Pathnames, Text/Binary, F<.exe>, chown(), Miscellaneous
=back
! =item INSTALL
! =item MANIFEST
Documentation, Build, Configure, Make, Install, Tests, Compiled Perl
Source, Compiled Module Source, Perl Modules/Scripts
! =item BUGS
=item AUTHORS
--- 5864,5929 ----
=back
! =item CONFIGURE PERL ON CYGWIN
=over 4
! =item Stripping Perl Binaries on Cygwin
! =item Optional Libraries for Perl on Cygwin
C<-lcrypt>, C<-lgdbm> (C<use GDBM_File>), C<-ldb> (C<use DB_File>),
C<-lcygipc> (C<use IPC::SysV>)
! =item Configure-time Options for Perl on Cygwin
C<-Uusedl>, C<-Uusemymalloc>, C<-Dusemultiplicity>, C<-Duseperlio>,
C<-Duse64bitint>, C<-Duselongdouble>, C<-Dusethreads>, C<-Duselargefiles>
! =item Suspicious Warnings on Cygwin
I<dlsym()>, Win9x and C<d_eofnblk>, Compiler/Preprocessor defines
=back
! =item MAKE ON CYGWIN
=over 4
! =item Warnings on Cygwin
! =item ld2 on Cygwin
=back
! =item TEST ON CYGWIN
=over 4
! =item File Permissions on Cygwin
! =item Hard Links on Cygwin
! =item Filetime Granularity on Cygwin
! =item Tainting Checks on Cygwin
! =item /etc/group on Cygwin
! =item Script Portability on Cygwin
Pathnames, Text/Binary, F<.exe>, chown(), Miscellaneous
=back
! =item INSTALL PERL ON CYGWIN
! =item MANIFEST ON CYGWIN
Documentation, Build, Configure, Make, Install, Tests, Compiled Perl
Source, Compiled Module Source, Perl Modules/Scripts
! =item BUGS ON CYGWIN
=item AUTHORS
***************
*** 5668,5673 ****
--- 5931,5968 ----
=back
+ =head2 perldgux - Perl under DG/UX.
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =back
+
+ =over 4
+
+ =item DESCRIPTION
+
+ =item BUILDING PERL ON DG/UX
+
+ =over 4
+
+ =item Non-threaded Perl on DG/UX
+
+ =item Threaded Perl on DG/UX
+
+ =item Testing Perl on DG/UX
+
+ =item Installing the built perl on DG/UX
+
+ =back
+
+ =item AUTHOR
+
+ =item SEE ALSO
+
+ =back
+
=head2 perlepoc, README.epoc - Perl for EPOC
=over 4
***************
*** 5686,5706 ****
=over 4
! =item I/O Redirection
! =item PATH Names
! =item Editors
! =item Features
! =item Restrictions
=item Compiling Perl 5 on the EPOC cross compiling environment
=back
! =item SUPPORT STATUS
=item AUTHOR
--- 5981,6001 ----
=over 4
! =item I/O Redirection on Epoc
! =item PATH Names on Epoc
! =item Editors on Epoc
! =item Features of Perl on Epoc
! =item Restrictions of Perl on Epoc
=item Compiling Perl 5 on the EPOC cross compiling environment
=back
! =item SUPPORT STATUS OF PERL ON EPOC
=item AUTHOR
***************
*** 5729,5750 ****
=item Portability Between PA-RISC Versions
=item Building Dynamic Extensions on HP-UX
=item The HP ANSI C Compiler
! =item Using Large Files with Perl
! =item Threaded Perl
! =item 64-bit Perl
! =item GDBM and Threads
! =item NFS filesystems and utime(2)
! =item perl -P and //
=back
=item AUTHOR
--- 6024,6049 ----
=item Portability Between PA-RISC Versions
+ =item Itanium Processor Family and HP-UX
+
=item Building Dynamic Extensions on HP-UX
=item The HP ANSI C Compiler
! =item Using Large Files with Perl on HP-UX
! =item Threaded Perl on HP-UX
! =item 64-bit Perl on HP-UX
! =item GDBM and Threads on HP-UX
! =item NFS filesystems and utime(2) on HP-UX
! =item perl -P and // and HP-UX
+ =item HP-UX Kernel Parameters (maxdsiz) for Compiling Perl
+
=back
=item AUTHOR
***************
*** 5753,5758 ****
--- 6052,6073 ----
=back
+ =head2 perlhurd, README.hurd - Perl version 5 on Hurd
+
+ =over 4
+
+ =item DESCRIPTION
+
+ =over 4
+
+ =item Known Problems with Perl on Hurd
+
+ =back
+
+ =item AUTHOR
+
+ =back
+
=head2 perlmachten, README.machten - Perl version 5 on Power MachTen
systems
***************
*** 5764,5774 ****
=item Compiling Perl 5 on MachTen
! =item Failures during C<make test>
op/lexassign.t, pragma/warnings.t
! =item Building external modules
=back
--- 6079,6089 ----
=item Compiling Perl 5 on MachTen
! =item Failures during C<make test> on MachTen
op/lexassign.t, pragma/warnings.t
! =item Building external modules on MachTen
=back
***************
*** 5792,5821 ****
=back
! =head2 perlmpeix, README.mpeix - Perl/iX for HP e3000 MPE
! =head1 SYNOPSIS
=over 4
! =item What's New
! =item System Requirements
=item How to Obtain Perl/iX
! =item Distribution Contents Highlights
! README, public_html/feedback.cgi, 4, 6
=item Getting Started with Perl/iX
=item MPE/iX Implementation Considerations
! =item Change History
=back
=head2 perlos2 - Perl under OS/2, DOS, Win0.3*, Win0.95 and WinNT.
=over 4
--- 6107,6197 ----
=back
! =head2 perlmint, README.mint - Perl version 5 on Atari MiNT
! =over 4
+ =item DESCRIPTION
+
+ =item Known problems with Perl on MiNT
+
+ =item AUTHOR
+
+ =back
+
+ =head2 perlmpeix, README.mpeix - Perl/iX for HP e3000 MPE
+
=over 4
! =item SYNOPSIS
! =item NOTE
+ =item What's New in Perl ffor MPE/iX
+
+ =item Welcome to Perl/iX
+
+ =item System Requirements for Perl/iX
+
=item How to Obtain Perl/iX
! =item Perl/iX Distribution Contents Highlights
! README, INSTALL, LIBSHP3K, PERL, .cpan/, lib/, man/,
! public_html/feedback.cgi, src/perl-5.6.0-mpe
+ =item How to Compile Perl/iX
+
+ 4, 6
+
=item Getting Started with Perl/iX
=item MPE/iX Implementation Considerations
! =item Known Perl/iX Bugs Under Investigation
+ =item Perl/iX To-Do List
+
+ =item Perl/iX Change History
+
+ =item AUTHOR
+
+ =item Name
+
+ =item Description
+
+ =item Build
+
+ =over 4
+
+ =item Tools & SDK
+
+ =item Setup
+
+ Buildtype.bat, SetNWBld.bat, MPKBuild.bat
+
+ =item Make
+
+ =item Interpreter
+
+ =item Extensions
+
=back
+ =item Install
+
+ =item Build new extensions
+
+ =item Known Issues
+
+ =item Acknowledgements
+
+ =item Author
+
+ =item Date
+
+ =back
+
=head2 perlos2 - Perl under OS/2, DOS, Win0.3*, Win0.95 and WinNT.
=over 4
***************
*** 6040,6047 ****
=item Priorities
! =item DLL name mangling
=item Threading
=item Calls to external programs
--- 6416,6430 ----
=item Priorities
! =item DLL name mangling: pre 5.6.2
+ =item DLL name mangling: 5.6.2 and beyond
+
+ Global DLLs, specific DLLs, C<BEGINLIBPATH> and C<ENDLIBPATH>, F<.> from
+ C<LIBPATH>
+
+ =item DLL forwarder generation
+
=item Threading
=item Calls to external programs
***************
*** 6054,6059 ****
--- 6437,6444 ----
=back
+ =item BUGS
+
=back
=over 4
***************
*** 6074,6098 ****
=over 4
! =item Unpacking
! =item Setup and utilities
! =item Configure
! =item Build, test, install
! =item build anomalies
! =item testing anomalies
! =item installation anomalies
! =item Usage Hints
! =item Floating point anomalies
! =item Modules and Extensions
=back
--- 6459,6483 ----
=over 4
! =item Unpacking Perl distribution on OS/390
! =item Setup and utilities for Perl on OS/390
! =item Configure Perl on OS/390
! =item Build, Test, Install Perl on OS/390
! =item Build Anomalies with Perl on OS/390
! =item Testing Anomalies with Perl on OS/390
! =item Installation Anomalies with Perl on OS/390
! =item Usage Hints for Perl on OS/390
! =item Floating Point Anomalies with Perl on OS/390
! =item Modules and Extensions for Perl on OS/390
=back
***************
*** 6102,6108 ****
=over 4
! =item Mailing list
=back
--- 6487,6493 ----
=over 4
! =item Mailing list for Perl on OS/390
=back
***************
*** 6110,6115 ****
--- 6495,6562 ----
=back
+ =head2 perlqnx, README.qnx - Perl version 5 on QNX
+
+ =over 4
+
+ =item DESCRIPTION
+
+ =over 4
+
+ =item Required Software for Compiling Perl on QNX4
+
+ /bin/sh, ar, nm, cpp, make
+
+ =item Outstanding Issues with Perl on QNX4
+
+ =item QNX auxiliary files
+
+ qnx/ar, qnx/cpp
+
+ =item Outstanding issues with perl under QNX6
+
+ =back
+
+ =item AUTHOR
+
+ =back
+
+ =head2 perlplan9 - Plan 9-specific documentation for Perl
+
+ =over 4
+
+ =item DESCRIPTION
+
+ =over 4
+
+ =item Invoking Perl
+
+ =item What's in Plan 9 Perl
+
+ =item What's not in Plan 9 Perl
+
+ =item Perl5 Functions not currently supported in Plan 9 Perl
+
+ =item Signals in Plan 9 Perl
+
+ =back
+
+ =item COMPILING AND INSTALLING PERL ON PLAN 9
+
+ =over 4
+
+ =item Installing Perl Documentation on Plan 9
+
+ =back
+
+ =item BUGS
+
+ =item Revision date
+
+ =item AUTHOR
+
+ =back
+
=head2 perlsolaris, README.solaris - Perl version 5 on Solaris systems
=over 4
***************
*** 6130,6140 ****
=over 4
! =item File Extraction Problems.
! =item Compiler and Related Tools.
! =item Environment
=back
--- 6577,6587 ----
=over 4
! =item File Extraction Problems on Solaris.
! =item Compiler and Related Tools on Solaris.
! =item Environment for Compiling Perl on Solaris
=back
***************
*** 6142,6152 ****
=over 4
! =item 64-bit Issues.
! =item Threads.
! =item Malloc Issues.
=back
--- 6589,6599 ----
=over 4
! =item 64-bit Issues with Perl on Solaris.
! =item Threads in Perl on Solaris.
! =item Malloc Issues with Perl on Solaris.
=back
***************
*** 6160,6176 ****
=over 4
! =item op/stat.t test 4
=back
! =item PREBUILT BINARIES.
! =item RUNTIME ISSUES.
=over 4
! =item Limits on Numbers of Open Files.
=back
--- 6607,6623 ----
=over 4
! =item op/stat.t test 4 in Solaris
=back
! =item PREBUILT BINARIES OF PERL FOR SOLARIS.
! =item RUNTIME ISSUES FOR PERL ON SOLARIS.
=over 4
! =item Limits on Numbers of Open Files on Solaris.
=back
***************
*** 6180,6190 ****
=over 4
! =item Proc::ProcessTable
! =item BSD::Resource
! =item Net::SSLeay
=back
--- 6627,6637 ----
=over 4
! =item Proc::ProcessTable on Solaris
! =item BSD::Resource on Solaris
! =item Net::SSLeay on Solaris
=back
***************
*** 6194,6230 ****
=back
! =head2 perlvmesa, README.vmesa - building and installing Perl for VM/ESA.
=over 4
=item SYNOPSIS
=item DESCRIPTION
=over 4
! =item Unpacking
! =item Setup and utilities
! =item Configure
! Don't turn on the compiler optimization flag "-O". There's a bug in the
! compiler (APAR PQ18812) that generates some bad code the optimizer is on,
! As VM/ESA doesn't fully support the fork() API programs relying on this
! call will not work. I've replaced fork()/exec() with spawn() and the
! standalone exec() with spawn(). This has a side effect when opening unnamed
! pipes in a shell script: there is no child process generated under
! =item testing anomalies
! =item Usage Hints
! When using perl on VM/ESA please keep in mind that the EBCDIC and ASCII
! character sets are different. Perl builtin functions that may behave
! differently under EBCDIC are mentioned in the perlport.pod document.
=back
=item AUTHORS
--- 6641,6711 ----
=back
! =head2 perltru64, README.tru64 - Perl version 5 on Tru64 (formerly known as
! Digital UNIX formerly known as DEC OSF/1) systems
=over 4
+ =item DESCRIPTION
+
+ =over 4
+
+ =item Compiling Perl 5 on Tru64
+
+ =item Using Large Files with Perl on Tru64
+
+ =item Threaded Perl on Tru64
+
+ =item Long Doubles on Tru64
+
+ =item 64-bit Perl on Tru64
+
+ =item Warnings about floating-point overflow when compiling Perl on Tru64
+
+ =back
+
+ =item Testing Perl on Tru64
+
+ =item AUTHOR
+
+ =back
+
+ =head2 perluts - Perl under UTS
+
+ =over 4
+
=item SYNOPSIS
=item DESCRIPTION
+ =item BUILDING PERL ON UTS
+
+ =item Installing the built perl on UTS
+
+ =item AUTHOR
+
+ =back
+
+ =head2 perlvmesa, README.vmesa - building and installing Perl for VM/ESA.
+
=over 4
! =item SYNOPSIS
! =item DESCRIPTION
! =over 4
! =item Unpacking Perl Distribution on VM/ESA
! =item Setup Perl and utilities on VM/ESA
! =item Configure Perl on VM/ESA
! =item Testing Anomalies of Perl on VM/ESA
+ =item Usage Hints for Perl on VM/ESA
+
=back
=item AUTHORS
***************
*** 6233,6239 ****
=over 4
! =item Mailing list
=back
--- 6714,6720 ----
=over 4
! =item Mailing list for Perl on VM/ESA
=back
***************
*** 6296,6302 ****
=item Perl variables
! %ENV, CRTL_ENV, CLISYM_[LOCAL], Any other string, $!, $^E, $?, $^S, $|
=item Standard modules with VMS-specific differences
--- 6777,6783 ----
=item Perl variables
! %ENV, CRTL_ENV, CLISYM_[LOCAL], Any other string, $!, $^E, $?, $|
=item Standard modules with VMS-specific differences
***************
*** 6338,6346 ****
=over 4
! =item Unimplemented Features
! =item Restrictions
=back
--- 6819,6827 ----
=over 4
! =item Unimplemented Features of Perl on VOS
! =item Restrictions of Perl on VOS
=back
***************
*** 6826,6844 ****
=back
- =head2 unicode::distinct - Perl pragma to strictly distinguish UTF8 data
- and non-UTF data.
-
- =over 4
-
- =item SYNOPSIS
-
- =item DESCRIPTION
-
- =item SEE ALSO
-
- =back
-
=head2 utf8 - Perl pragma to enable/disable UTF-8 (or UTF-EBCDIC) in source
code
--- 7307,7312 ----
***************
*** 6911,6916 ****
--- 7379,7427 ----
=back
+ =head2 Attribute::Handlers - Simpler definition of attribute handlers
+
+ =over 4
+
+ =item VERSION
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ [0], [1], [2], [3], [4], [5]
+
+ =over 4
+
+ =item Typed lexicals
+
+ =item Type-specific attribute handlers
+
+ =item Non-interpretive attribute handlers
+
+ =item Phase-specific attribute handlers
+
+ =item Attributes as C<tie> interfaces
+
+ =back
+
+ =item EXAMPLES
+
+ =item DIAGNOSTICS
+
+ C<Bad attribute type: ATTR(%s)>, C<Attribute handler %s doesn't handle %s
+ attributes>, C<Declaration of %s attribute in package %s may clash with
+ future reserved word>, C<Can't have two ATTR specifiers on one subroutine>,
+ C<Can't autotie a %s>, C<Internal error: %s symbol went missing>
+
+ =item AUTHOR
+
+ =item BUGS
+
+ =item COPYRIGHT
+
+ =back
+
=head2 AutoLoader - load subroutines only on demand
=over 4
***************
*** 7086,7093 ****
main_cv, init_av, main_root, main_start, comppadlist, sv_undef, sv_yes,
sv_no, amagic_generation, walkoptree(OP, METHOD), walkoptree_debug(DEBUG),
! walksymtable(SYMREF, METHOD, RECURSE), svref_2object(SV), ppname(OPNUM),
! hash(STR), cast_I32(I), minus_c, cstring(STR), class(OBJ), threadsv_names
=item AUTHOR
--- 7597,7605 ----
main_cv, init_av, main_root, main_start, comppadlist, sv_undef, sv_yes,
sv_no, amagic_generation, walkoptree(OP, METHOD), walkoptree_debug(DEBUG),
! walksymtable(SYMREF, METHOD, RECURSE, PREFIX), svref_2object(SV),
! ppname(OPNUM), hash(STR), cast_I32(I), minus_c, cstring(STR), class(OBJ),
! threadsv_names
=item AUTHOR
***************
*** 7244,7249 ****
--- 7756,7763 ----
=back
+ =item Using B::Concise outside of the O framework
+
=item AUTHOR
=back
***************
*** 7270,7276 ****
=item OPTIONS
! B<-l>, B<-p>, B<-q>, B<-u>I<PACKAGE>, B<-s>I<LETTERS>, B<C>, B<i>I<NUMBER>,
B<T>, B<v>I<STRING>B<.>, B<-x>I<LEVEL>
=item USING B::Deparse AS A MODULE
--- 7784,7790 ----
=item OPTIONS
! B<-l>, B<-p>, B<-q>, B<-f>I<FILE>, B<-s>I<LETTERS>, B<C>, B<i>I<NUMBER>,
B<T>, B<v>I<STRING>B<.>, B<-x>I<LEVEL>
=item USING B::Deparse AS A MODULE
***************
*** 7283,7288 ****
--- 7797,7806 ----
=item new
+ =item ambient_pragmas
+
+ strict, $[, bytes, utf8, integer, re, warnings, hint_bits, warning_bits
+
=item coderef2text
=back
***************
*** 8162,8170 ****
=item a
! C<afs>, C<alignbytes>, C<ansi2knr>, C<aphostname>, C<api_revision>,
! C<api_subversion>, C<api_version>, C<api_versionstring>, C<ar>, C<archlib>,
! C<archlibexp>, C<archname64>, C<archname>, C<archobjs>, C<awk>
=item b
--- 8680,8689 ----
=item a
! C<afs>, C<afsroot>, C<alignbytes>, C<ansi2knr>, C<aphostname>,
! C<api_revision>, C<api_subversion>, C<api_version>, C<api_versionstring>,
! C<ar>, C<archlib>, C<archlibexp>, C<archname64>, C<archname>, C<archobjs>,
! C<awk>
=item b
***************
*** 8176,8189 ****
C<c>, C<castflags>, C<cat>, C<cc>, C<cccdlflags>, C<ccdlflags>, C<ccflags>,
C<ccflags_uselargefiles>, C<ccname>, C<ccsymbols>, C<ccversion>, C<cf_by>,
C<cf_email>, C<cf_time>, C<charsize>, C<chgrp>, C<chmod>, C<chown>,
! C<clocktype>, C<comm>, C<compress>
- =item C
-
- C<CONFIGDOTSH>, C<contains>, C<cp>, C<cpio>, C<cpp>, C<cpp_stuff>,
- C<cppccsymbols>, C<cppflags>, C<cpplast>, C<cppminus>, C<cpprun>,
- C<cppstdin>, C<cppsymbols>, C<crosscompile>, C<cryptlib>, C<csh>
-
=item d
C<d__fwalk>, C<d_access>, C<d_accessx>, C<d_alarm>, C<d_archlib>,
--- 8695,8704 ----
C<c>, C<castflags>, C<cat>, C<cc>, C<cccdlflags>, C<ccdlflags>, C<ccflags>,
C<ccflags_uselargefiles>, C<ccname>, C<ccsymbols>, C<ccversion>, C<cf_by>,
C<cf_email>, C<cf_time>, C<charsize>, C<chgrp>, C<chmod>, C<chown>,
! C<clocktype>, C<comm>, C<compress>, C<contains>, C<cp>, C<cpio>, C<cpp>,
! C<cpp_stuff>, C<cppccsymbols>, C<cppflags>, C<cpplast>, C<cppminus>,
! C<cpprun>, C<cppstdin>, C<cppsymbols>, C<cryptlib>, C<csh>
=item d
C<d__fwalk>, C<d_access>, C<d_accessx>, C<d_alarm>, C<d_archlib>,
***************
*** 8191,8211 ****
C<d_bincompat5005>, C<d_bsd>, C<d_bsdgetpgrp>, C<d_bsdsetpgrp>, C<d_bzero>,
C<d_casti32>, C<d_castneg>, C<d_charvspr>, C<d_chown>, C<d_chroot>,
C<d_chsize>, C<d_closedir>, C<d_cmsghdr_s>, C<d_const>, C<d_crypt>,
! C<d_csh>, C<d_cuserid>, C<d_dbl_dig>, C<d_difftime>, C<d_dirnamlen>,
! C<d_dlerror>, C<d_dlopen>, C<d_dlsymun>, C<d_dosuid>, C<d_drand48proto>,
! C<d_dup2>, C<d_eaccess>, C<d_endgrent>, C<d_endhent>, C<d_endnent>,
! C<d_endpent>, C<d_endpwent>, C<d_endsent>, C<d_eofnblk>, C<d_eunice>,
! C<d_fchmod>, C<d_fchown>, C<d_fcntl>, C<d_fcntl_can_lock>, C<d_fd_macros>,
! C<d_fd_set>, C<d_fds_bits>, C<d_fgetpos>, C<d_flexfnam>, C<d_flock>,
! C<d_fork>, C<d_fpathconf>, C<d_fpos64_t>, C<d_frexpl>, C<d_fs_data_s>,
! C<d_fseeko>, C<d_fsetpos>, C<d_fstatfs>, C<d_fstatvfs>, C<d_fsync>,
! C<d_ftello>, C<d_ftime>, C<d_Gconvert>, C<d_getcwd>, C<d_getespwnam>,
! C<d_getfsstat>, C<d_getgrent>, C<d_getgrps>, C<d_gethbyaddr>,
! C<d_gethbyname>, C<d_gethent>, C<d_gethname>, C<d_gethostprotos>,
! C<d_getitimer>, C<d_getlogin>, C<d_getmnt>, C<d_getmntent>,
! C<d_getnbyaddr>, C<d_getnbyname>, C<d_getnent>, C<d_getnetprotos>,
! C<d_getpagsz>, C<d_getpbyname>, C<d_getpbynumber>, C<d_getpent>,
! C<d_getpgid>, C<d_getpgrp2>, C<d_getpgrp>, C<d_getppid>, C<d_getprior>,
C<d_getprotoprotos>, C<d_getprpwnam>, C<d_getpwent>, C<d_getsbyname>,
C<d_getsbyport>, C<d_getsent>, C<d_getservprotos>, C<d_getspnam>,
C<d_gettimeod>, C<d_gnulibc>, C<d_grpasswd>, C<d_hasmntopt>, C<d_htonl>,
--- 8706,8727 ----
C<d_bincompat5005>, C<d_bsd>, C<d_bsdgetpgrp>, C<d_bsdsetpgrp>, C<d_bzero>,
C<d_casti32>, C<d_castneg>, C<d_charvspr>, C<d_chown>, C<d_chroot>,
C<d_chsize>, C<d_closedir>, C<d_cmsghdr_s>, C<d_const>, C<d_crypt>,
! C<d_csh>, C<d_cuserid>, C<d_dbl_dig>, C<d_dbminitproto>, C<d_difftime>,
! C<d_dirnamlen>, C<d_dlerror>, C<d_dlopen>, C<d_dlsymun>, C<d_dosuid>,
! C<d_drand48proto>, C<d_dup2>, C<d_eaccess>, C<d_endgrent>, C<d_endhent>,
! C<d_endnent>, C<d_endpent>, C<d_endpwent>, C<d_endsent>, C<d_eofnblk>,
! C<d_eunice>, C<d_fchdir>, C<d_fchmod>, C<d_fchown>, C<d_fcntl>,
! C<d_fcntl_can_lock>, C<d_fd_macros>, C<d_fd_set>, C<d_fds_bits>,
! C<d_fgetpos>, C<d_flexfnam>, C<d_flock>, C<d_flockproto>, C<d_fork>,
! C<d_fpathconf>, C<d_fpos64_t>, C<d_frexpl>, C<d_fs_data_s>, C<d_fseeko>,
! C<d_fsetpos>, C<d_fstatfs>, C<d_fstatvfs>, C<d_fsync>, C<d_ftello>,
! C<d_ftime>, C<d_Gconvert>, C<d_getcwd>, C<d_getespwnam>, C<d_getfsstat>,
! C<d_getgrent>, C<d_getgrps>, C<d_gethbyaddr>, C<d_gethbyname>,
! C<d_gethent>, C<d_gethname>, C<d_gethostprotos>, C<d_getitimer>,
! C<d_getlogin>, C<d_getmnt>, C<d_getmntent>, C<d_getnbyaddr>,
! C<d_getnbyname>, C<d_getnent>, C<d_getnetprotos>, C<d_getpagsz>,
! C<d_getpbyname>, C<d_getpbynumber>, C<d_getpent>, C<d_getpgid>,
! C<d_getpgrp2>, C<d_getpgrp>, C<d_getppid>, C<d_getprior>,
C<d_getprotoprotos>, C<d_getprpwnam>, C<d_getpwent>, C<d_getsbyname>,
C<d_getsbyport>, C<d_getsent>, C<d_getservprotos>, C<d_getspnam>,
C<d_gettimeod>, C<d_gnulibc>, C<d_grpasswd>, C<d_hasmntopt>, C<d_htonl>,
***************
*** 8215,8261 ****
C<d_lseekproto>, C<d_lstat>, C<d_madvise>, C<d_mblen>, C<d_mbstowcs>,
C<d_mbtowc>, C<d_memchr>, C<d_memcmp>, C<d_memcpy>, C<d_memmove>,
C<d_memset>, C<d_mkdir>, C<d_mkdtemp>, C<d_mkfifo>, C<d_mkstemp>,
! C<d_mkstemps>, C<d_mktime>, C<d_mmap>, C<d_modfl>, C<d_mprotect>, C<d_msg>,
! C<d_msg_ctrunc>, C<d_msg_dontroute>, C<d_msg_oob>, C<d_msg_peek>,
! C<d_msg_proxy>, C<d_msgctl>, C<d_msgget>, C<d_msghdr_s>, C<d_msgrcv>,
! C<d_msgsnd>, C<d_msync>, C<d_munmap>, C<d_mymalloc>, C<d_nice>,
! C<d_nv_preserves_uv>, C<d_nv_preserves_uv_bits>, C<d_off64_t>,
! C<d_old_pthread_create_joinable>, C<d_oldpthreads>, C<d_oldsock>,
! C<d_open3>, C<d_pathconf>, C<d_pause>, C<d_perl_otherlibdirs>,
! C<d_phostname>, C<d_pipe>, C<d_poll>, C<d_portable>, C<d_PRId64>,
! C<d_PRIeldbl>, C<d_PRIEUldbl>, C<d_PRIfldbl>, C<d_PRIFUldbl>,
! C<d_PRIgldbl>, C<d_PRIGUldbl>, C<d_PRIi64>, C<d_PRIo64>, C<d_PRIu64>,
! C<d_PRIx64>, C<d_PRIXU64>, C<d_pthread_yield>, C<d_pwage>, C<d_pwchange>,
! C<d_pwclass>, C<d_pwcomment>, C<d_pwexpire>, C<d_pwgecos>, C<d_pwpasswd>,
! C<d_pwquota>, C<d_qgcvt>, C<d_quad>, C<d_readdir>, C<d_readlink>,
! C<d_readv>, C<d_recvmsg>, C<d_rename>, C<d_rewinddir>, C<d_rmdir>,
! C<d_safebcpy>, C<d_safemcpy>, C<d_sanemcmp>, C<d_sbrkproto>,
! C<d_sched_yield>, C<d_scm_rights>, C<d_SCNfldbl>, C<d_seekdir>,
! C<d_select>, C<d_sem>, C<d_semctl>, C<d_semctl_semid_ds>,
! C<d_semctl_semun>, C<d_semget>, C<d_semop>, C<d_sendmsg>, C<d_setegid>,
! C<d_seteuid>, C<d_setgrent>, C<d_setgrps>, C<d_sethent>, C<d_setitimer>,
! C<d_setlinebuf>, C<d_setlocale>, C<d_setnent>, C<d_setpent>, C<d_setpgid>,
! C<d_setpgrp2>, C<d_setpgrp>, C<d_setprior>, C<d_setproctitle>,
! C<d_setpwent>, C<d_setregid>, C<d_setresgid>, C<d_setresuid>,
! C<d_setreuid>, C<d_setrgid>, C<d_setruid>, C<d_setsent>, C<d_setsid>,
! C<d_setvbuf>, C<d_sfio>, C<d_shm>, C<d_shmat>, C<d_shmatprototype>,
! C<d_shmctl>, C<d_shmdt>, C<d_shmget>, C<d_sigaction>, C<d_sigprocmask>,
! C<d_sigsetjmp>, C<d_sockatmark>, C<d_socket>, C<d_socklen_t>,
! C<d_sockpair>, C<d_socks5_init>, C<d_sqrtl>, C<d_statblks>,
! C<d_statfs_f_flags>, C<d_statfs_s>, C<d_statvfs>, C<d_stdio_cnt_lval>,
! C<d_stdio_ptr_lval>, C<d_stdio_ptr_lval_nochange_cnt>,
C<d_stdio_ptr_lval_sets_cnt>, C<d_stdio_stream_array>, C<d_stdiobase>,
C<d_stdstdio>, C<d_strchr>, C<d_strcoll>, C<d_strctcpy>, C<d_strerrm>,
! C<d_strerror>, C<d_strtod>, C<d_strtol>, C<d_strtold>, C<d_strtoll>,
! C<d_strtoq>, C<d_strtoul>, C<d_strtoull>, C<d_strtouq>, C<d_strxfrm>,
! C<d_suidsafe>, C<d_symlink>, C<d_syscall>, C<d_sysconf>, C<d_sysernlst>,
! C<d_syserrlst>, C<d_system>, C<d_tcgetpgrp>, C<d_tcsetpgrp>, C<d_telldir>,
! C<d_telldirproto>, C<d_time>, C<d_times>, C<d_truncate>, C<d_tzname>,
! C<d_u32align>, C<d_ualarm>, C<d_umask>, C<d_uname>, C<d_union_semun>,
! C<d_usleep>, C<d_ustat>, C<d_vendorarch>, C<d_vendorbin>, C<d_vendorlib>,
! C<d_vfork>, C<d_void_closedir>, C<d_voidsig>, C<d_voidtty>, C<d_volatile>,
C<d_vprintf>, C<d_wait4>, C<d_waitpid>, C<d_wcstombs>, C<d_wctomb>,
C<d_writev>, C<d_xenix>, C<date>, C<db_hashtype>, C<db_prefixtype>,
C<defvoidused>, C<direntrytype>, C<dlext>, C<dlsrc>, C<doublesize>,
C<drand01>, C<dynamic_ext>
--- 8731,8780 ----
C<d_lseekproto>, C<d_lstat>, C<d_madvise>, C<d_mblen>, C<d_mbstowcs>,
C<d_mbtowc>, C<d_memchr>, C<d_memcmp>, C<d_memcpy>, C<d_memmove>,
C<d_memset>, C<d_mkdir>, C<d_mkdtemp>, C<d_mkfifo>, C<d_mkstemp>,
! C<d_mkstemps>, C<d_mktime>, C<d_mmap>, C<d_modfl>, C<d_modfl_pow32_bug>,
! C<d_mprotect>, C<d_msg>, C<d_msg_ctrunc>, C<d_msg_dontroute>, C<d_msg_oob>,
! C<d_msg_peek>, C<d_msg_proxy>, C<d_msgctl>, C<d_msgget>, C<d_msghdr_s>,
! C<d_msgrcv>, C<d_msgsnd>, C<d_msync>, C<d_munmap>, C<d_mymalloc>,
! C<d_nice>, C<d_nl_langinfo>, C<d_nv_preserves_uv>,
! C<d_nv_preserves_uv_bits>, C<d_off64_t>, C<d_old_pthread_create_joinable>,
! C<d_oldpthreads>, C<d_oldsock>, C<d_open3>, C<d_pathconf>, C<d_pause>,
! C<d_perl_otherlibdirs>, C<d_phostname>, C<d_pipe>, C<d_poll>,
! C<d_portable>, C<d_PRId64>, C<d_PRIeldbl>, C<d_PRIEUldbl>, C<d_PRIfldbl>,
! C<d_PRIFUldbl>, C<d_PRIgldbl>, C<d_PRIGUldbl>, C<d_PRIi64>, C<d_PRIo64>,
! C<d_PRIu64>, C<d_PRIx64>, C<d_PRIXU64>, C<d_pthread_atfork>,
! C<d_pthread_yield>, C<d_pwage>, C<d_pwchange>, C<d_pwclass>,
! C<d_pwcomment>, C<d_pwexpire>, C<d_pwgecos>, C<d_pwpasswd>, C<d_pwquota>,
! C<d_qgcvt>, C<d_quad>, C<d_readdir>, C<d_readlink>, C<d_readv>,
! C<d_recvmsg>, C<d_rename>, C<d_rewinddir>, C<d_rmdir>, C<d_safebcpy>,
! C<d_safemcpy>, C<d_sanemcmp>, C<d_sbrkproto>, C<d_sched_yield>,
! C<d_scm_rights>, C<d_SCNfldbl>, C<d_seekdir>, C<d_select>, C<d_sem>,
! C<d_semctl>, C<d_semctl_semid_ds>, C<d_semctl_semun>, C<d_semget>,
! C<d_semop>, C<d_sendmsg>, C<d_setegid>, C<d_seteuid>, C<d_setgrent>,
! C<d_setgrps>, C<d_sethent>, C<d_setitimer>, C<d_setlinebuf>,
! C<d_setlocale>, C<d_setnent>, C<d_setpent>, C<d_setpgid>, C<d_setpgrp2>,
! C<d_setpgrp>, C<d_setprior>, C<d_setproctitle>, C<d_setpwent>,
! C<d_setregid>, C<d_setresgid>, C<d_setresuid>, C<d_setreuid>, C<d_setrgid>,
! C<d_setruid>, C<d_setsent>, C<d_setsid>, C<d_setvbuf>, C<d_sfio>, C<d_shm>,
! C<d_shmat>, C<d_shmatprototype>, C<d_shmctl>, C<d_shmdt>, C<d_shmget>,
! C<d_sigaction>, C<d_sigprocmask>, C<d_sigsetjmp>, C<d_sockatmark>,
! C<d_sockatmarkproto>, C<d_socket>, C<d_socklen_t>, C<d_sockpair>,
! C<d_socks5_init>, C<d_sqrtl>, C<d_sresgproto>, C<d_sresuproto>,
! C<d_statblks>, C<d_statfs_f_flags>, C<d_statfs_s>, C<d_statvfs>,
! C<d_stdio_cnt_lval>, C<d_stdio_ptr_lval>, C<d_stdio_ptr_lval_nochange_cnt>,
C<d_stdio_ptr_lval_sets_cnt>, C<d_stdio_stream_array>, C<d_stdiobase>,
C<d_stdstdio>, C<d_strchr>, C<d_strcoll>, C<d_strctcpy>, C<d_strerrm>,
! C<d_strerror>, C<d_strftime>, C<d_strtod>, C<d_strtol>, C<d_strtold>,
! C<d_strtoll>, C<d_strtoq>, C<d_strtoul>, C<d_strtoull>, C<d_strtouq>,
! C<d_strxfrm>, C<d_suidsafe>, C<d_symlink>, C<d_syscall>, C<d_syscallproto>,
! C<d_sysconf>, C<d_sysernlst>, C<d_syserrlst>, C<d_system>, C<d_tcgetpgrp>,
! C<d_tcsetpgrp>, C<d_telldir>, C<d_telldirproto>, C<d_time>, C<d_times>,
! C<d_truncate>, C<d_tzname>, C<d_u32align>, C<d_ualarm>, C<d_umask>,
! C<d_uname>, C<d_union_semun>, C<d_usleep>, C<d_usleepproto>, C<d_ustat>,
! C<d_vendorarch>, C<d_vendorbin>, C<d_vendorlib>, C<d_vfork>,
! C<d_void_closedir>, C<d_voidsig>, C<d_voidtty>, C<d_volatile>,
C<d_vprintf>, C<d_wait4>, C<d_waitpid>, C<d_wcstombs>, C<d_wctomb>,
C<d_writev>, C<d_xenix>, C<date>, C<db_hashtype>, C<db_prefixtype>,
+ C<db_version_major>, C<db_version_minor>, C<db_version_patch>,
C<defvoidused>, C<direntrytype>, C<dlext>, C<dlsrc>, C<doublesize>,
C<drand01>, C<dynamic_ext>
***************
*** 8267,8273 ****
=item f
C<fflushall>, C<fflushNULL>, C<find>, C<firstmakefile>, C<flex>,
! C<fpossize>, C<fpostype>, C<freetype>, C<full_ar>, C<full_csh>, C<full_sed>
=item g
--- 8786,8793 ----
=item f
C<fflushall>, C<fflushNULL>, C<find>, C<firstmakefile>, C<flex>,
! C<fpossize>, C<fpostype>, C<freetype>, C<from>, C<full_ar>, C<full_csh>,
! C<full_sed>
=item g
***************
*** 8283,8291 ****
C<i16size>, C<i16type>, C<i32size>, C<i32type>, C<i64size>, C<i64type>,
C<i8size>, C<i8type>, C<i_arpainet>, C<i_bsdioctl>, C<i_db>, C<i_dbm>,
C<i_dirent>, C<i_dld>, C<i_dlfcn>, C<i_fcntl>, C<i_float>, C<i_gdbm>,
! C<i_grp>, C<i_iconv>, C<i_ieeefp>, C<i_inttypes>, C<i_libutil>,
! C<i_limits>, C<i_locale>, C<i_machcthr>, C<i_malloc>, C<i_math>,
! C<i_memory>, C<i_mntent>, C<i_ndbm>, C<i_netdb>, C<i_neterrno>,
C<i_netinettcp>, C<i_niin>, C<i_poll>, C<i_prot>, C<i_pthread>, C<i_pwd>,
C<i_rpcsvcdbm>, C<i_sfio>, C<i_sgtty>, C<i_shadow>, C<i_socks>,
C<i_stdarg>, C<i_stddef>, C<i_stdlib>, C<i_string>, C<i_sunmath>,
--- 8803,8811 ----
C<i16size>, C<i16type>, C<i32size>, C<i32type>, C<i64size>, C<i64type>,
C<i8size>, C<i8type>, C<i_arpainet>, C<i_bsdioctl>, C<i_db>, C<i_dbm>,
C<i_dirent>, C<i_dld>, C<i_dlfcn>, C<i_fcntl>, C<i_float>, C<i_gdbm>,
! C<i_grp>, C<i_iconv>, C<i_ieeefp>, C<i_inttypes>, C<i_langinfo>,
! C<i_libutil>, C<i_limits>, C<i_locale>, C<i_machcthr>, C<i_malloc>,
! C<i_math>, C<i_memory>, C<i_mntent>, C<i_ndbm>, C<i_netdb>, C<i_neterrno>,
C<i_netinettcp>, C<i_niin>, C<i_poll>, C<i_prot>, C<i_pthread>, C<i_pwd>,
C<i_rpcsvcdbm>, C<i_sfio>, C<i_sgtty>, C<i_shadow>, C<i_socks>,
C<i_stdarg>, C<i_stddef>, C<i_stdlib>, C<i_string>, C<i_sunmath>,
***************
*** 8344,8350 ****
=item p
C<package>, C<pager>, C<passcat>, C<patchlevel>, C<path_sep>, C<perl5>,
! C<perl>
=item P
--- 8864,8870 ----
=item p
C<package>, C<pager>, C<passcat>, C<patchlevel>, C<path_sep>, C<perl5>,
! C<perl>, C<perl_patchlevel>
=item P
***************
*** 8360,8366 ****
=item r
C<randbits>, C<randfunc>, C<randseedtype>, C<ranlib>, C<rd_nodata>,
! C<revision>, C<rm>, C<rmail>, C<runnm>
=item s
--- 8880,8886 ----
=item r
C<randbits>, C<randfunc>, C<randseedtype>, C<ranlib>, C<rd_nodata>,
! C<revision>, C<rm>, C<rmail>, C<run>, C<runnm>
=item s
***************
*** 8381,8388 ****
=item t
! C<tail>, C<tar>, C<tbl>, C<tee>, C<test>, C<timeincl>, C<timetype>,
! C<touch>, C<tr>, C<trnl>, C<troff>
=item u
--- 8901,8908 ----
=item t
! C<tail>, C<tar>, C<targetarch>, C<tbl>, C<tee>, C<test>, C<timeincl>,
! C<timetype>, C<to>, C<touch>, C<tr>, C<trnl>, C<troff>
=item u
***************
*** 8389,8406 ****
C<u16size>, C<u16type>, C<u32size>, C<u32type>, C<u64size>, C<u64type>,
C<u8size>, C<u8type>, C<uidformat>, C<uidsign>, C<uidsize>, C<uidtype>,
C<uname>, C<uniq>, C<uquadtype>, C<use5005threads>, C<use64bitall>,
! C<use64bitint>, C<usedl>, C<useithreads>, C<uselargefiles>,
! C<uselongdouble>, C<usemorebits>, C<usemultiplicity>, C<usemymalloc>,
! C<usenm>, C<useopcode>, C<useperlio>, C<useposix>, C<usesfio>,
! C<useshrplib>, C<usesocks>, C<usethreads>, C<usevendorprefix>, C<usevfork>,
! C<usrinc>, C<uuname>, C<uvoformat>, C<uvsize>, C<uvtype>, C<uvuformat>,
! C<uvxformat>, C<uvXUformat>
=item v
C<vendorarch>, C<vendorarchexp>, C<vendorbin>, C<vendorbinexp>,
C<vendorlib>, C<vendorlib_stem>, C<vendorlibexp>, C<vendorprefix>,
! C<vendorprefixexp>, C<version>, C<versiononly>, C<vi>, C<voidflags>
=item x
--- 8909,8927 ----
C<u16size>, C<u16type>, C<u32size>, C<u32type>, C<u64size>, C<u64type>,
C<u8size>, C<u8type>, C<uidformat>, C<uidsign>, C<uidsize>, C<uidtype>,
C<uname>, C<uniq>, C<uquadtype>, C<use5005threads>, C<use64bitall>,
! C<use64bitint>, C<usecrosscompile>, C<usedl>, C<useithreads>,
! C<uselargefiles>, C<uselongdouble>, C<usemorebits>, C<usemultiplicity>,
! C<usemymalloc>, C<usenm>, C<useopcode>, C<useperlio>, C<useposix>,
! C<usereentrant>, C<usesfio>, C<useshrplib>, C<usesocks>, C<usethreads>,
! C<usevendorprefix>, C<usevfork>, C<usrinc>, C<uuname>, C<uvoformat>,
! C<uvsize>, C<uvtype>, C<uvuformat>, C<uvxformat>, C<uvXUformat>
=item v
C<vendorarch>, C<vendorarchexp>, C<vendorbin>, C<vendorbinexp>,
C<vendorlib>, C<vendorlib_stem>, C<vendorlibexp>, C<vendorprefix>,
! C<vendorprefixexp>, C<version>, C<version_patchlevel_string>,
! C<versiononly>, C<vi>, C<voidflags>
=item x
***************
*** 8428,8433 ****
--- 8949,8956 ----
=item DESCRIPTION
+ =item NOTES
+
=back
=head2 DB - programmatic interface to the Perl debugging API (draft,
***************
*** 8528,8534 ****
=item Extra RECNO Methods
B<$X-E<gt>push(list) ;>, B<$value = $X-E<gt>pop ;>, B<$X-E<gt>shift>,
! B<$X-E<gt>unshift(list) ;>, B<$X-E<gt>length>
=item Another Example
--- 9051,9058 ----
=item Extra RECNO Methods
B<$X-E<gt>push(list) ;>, B<$value = $X-E<gt>pop ;>, B<$X-E<gt>shift>,
! B<$X-E<gt>unshift(list) ;>, B<$X-E<gt>length>, B<$X-E<gt>splice(offset,
! length, elements);>
=item Another Example
***************
*** 8792,8797 ****
--- 9316,9323 ----
=item DESCRIPTION
+ =item NOTES
+
=back
=head2 Dumpvalue - provides screen dump of Perl data.
***************
*** 8917,8923 ****
=item Encoding How to ...
IO with mixed content (faking iso-2020-*), MIME's Content-Length:, UTF-8
! strings in binary data, perl/Encode wrappers on non-Unicode XS modules
=item Messing with Perl's Internals
--- 9443,9449 ----
=item Encoding How to ...
IO with mixed content (faking iso-2020-*), MIME's Content-Length:, UTF-8
! strings in binary data, Perl/Encode wrappers on non-Unicode XS modules
=item Messing with Perl's Internals
***************
*** 9095,9100 ****
--- 9621,9674 ----
=back
+ =head2 ExtUtils::Constant - generate XS code to import C header constants
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =item USAGE
+
+ IV, UV, NV, PV, PVN, PVN, YES, NO, UNDEF
+
+ =item FUNCTIONS
+
+ =back
+
+ C_stringify NAME
+
+ constant_types
+
+ memEQ_clause NAME, CHECKED_AT, INDENT
+
+ assign INDENT, TYPE, PRE, POST, VALUE..
+
+ return_clause
+
+ switch_clause INDENT, NAMELEN, ITEMHASH, ITEM..
+
+ params WHAT
+
+ dump_names
+
+ C_constant, name, type, value, macro, default, pre, post, def_pre =item
+ def_post
+
+ XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME
+
+ autoload PACKAGE, VERSION, AUTOLOADER
+
+ WriteConstants ATTRIBUTE =E<gt> VALUE [, ...], NAME, DEFAULT_TYPE,
+ BREAKOUT_AT, NAMES, C_FILE, XS_FILE, SUBNAME, C_SUBNAME
+
+ =over 4
+
+ =item AUTHOR
+
+ =back
+
=head2 ExtUtils::Embed - Utilities for embedding Perl in C/C++ applications
=over 4
***************
*** 9196,9201 ****
--- 9770,9822 ----
=back
+ =head2 ExtUtils::MM_NW5 - methods to override UN*X behaviour in
+ ExtUtils::MakeMaker
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =back
+
+ catfile
+
+ constants (o)
+
+ static_lib (o)
+
+ dynamic_bs (o)
+
+ dynamic_lib (o)
+
+ canonpath
+
+ perl_script
+
+ pm_to_blib
+
+ test_via_harness (o)
+
+ tool_autosplit (override)
+
+ tools_other (o)
+
+ xs_o (o)
+
+ top_targets (o)
+
+ htmlifypods (o)
+
+ manifypods (o)
+
+ dist_ci (o)
+
+ dist_core (o)
+
+ pasthru (o)
+
=head2 ExtUtils::MM_OS2 - methods to override UN*X behaviour in
ExtUtils::MakeMaker
***************
*** 9623,9632 ****
INST_EXE, INST_HTMLLIBDIR, INST_HTMLSCRIPTDIR, INST_LIB, INST_MAN1DIR,
INST_MAN3DIR, INST_SCRIPT, LDFROM, LIB, LIBPERL_A, LIBS, LINKTYPE,
MAKEAPERL, MAKEFILE, MAN1PODS, MAN3PODS, MAP_TARGET, MYEXTLIB, NAME,
! NEEDS_LINKING, NOECHO, NORECURS, NO_VC, OBJECT, OPTIMIZE, PERL, PERLMAINCC,
! PERL_ARCHLIB, PERL_LIB, PERL_MALLOC_OK, PERL_SRC, PERM_RW, PERM_RWX,
! PL_FILES, PM, PMLIBDIRS, PM_FILTER, POLLUTE, PPM_INSTALL_EXEC,
! PPM_INSTALL_SCRIPT, PREFIX, PREREQ_PM, SKIP, TYPEMAPS, VERSION,
VERSION_FROM, XS, XSOPT, XSPROTOARG, XS_VERSION
=item Additional lowercase attributes
--- 10244,10253 ----
INST_EXE, INST_HTMLLIBDIR, INST_HTMLSCRIPTDIR, INST_LIB, INST_MAN1DIR,
INST_MAN3DIR, INST_SCRIPT, LDFROM, LIB, LIBPERL_A, LIBS, LINKTYPE,
MAKEAPERL, MAKEFILE, MAN1PODS, MAN3PODS, MAP_TARGET, MYEXTLIB, NAME,
! NEEDS_LINKING, NOECHO, NORECURS, NO_VC, OBJECT, OPTIMIZE, PERL, PERL_CORE,
! PERLMAINCC, PERL_ARCHLIB, PERL_LIB, PERL_MALLOC_OK, PERLRUN, PERM_RW,
! PERM_RWX, PL_FILES, PM, PMLIBDIRS, PM_FILTER, POLLUTE, PPM_INSTALL_EXEC,
! PPM_INSTALL_SCRIPT, PREFIX, PREREQ_PM, SKIP, TEST_LIBS, VERSION,
VERSION_FROM, XS, XSOPT, XSPROTOARG, XS_VERSION
=item Additional lowercase attributes
***************
*** 9840,9845 ****
--- 10461,10468 ----
=item RETURN
+ =item NOTES
+
=item AUTHOR
=back
***************
*** 9873,9883 ****
=item DESCRIPTION
C<wanted>, C<bydepth>, C<preprocess>, C<postprocess>, C<follow>,
! C<follow_fast>, C<follow_skip>, C<no_chdir>, C<untaint>,
! C<untaint_pattern>, C<untaint_skip>
=item CAVEAT
=back
=head2 File::Glob - Perl extension for BSD glob routine
--- 10496,10510 ----
=item DESCRIPTION
C<wanted>, C<bydepth>, C<preprocess>, C<postprocess>, C<follow>,
! C<follow_fast>, C<follow_skip>, C<dangling_symlinks>, C<no_chdir>,
! C<untaint>, C<untaint_pattern>, C<untaint_skip>
=item CAVEAT
+ =item NOTES
+
+ =item HISTORY
+
=back
=head2 File::Glob - Perl extension for BSD glob routine
***************
*** 9888,9896 ****
=item DESCRIPTION
! C<GLOB_ERR>, C<GLOB_MARK>, C<GLOB_NOCASE>, C<GLOB_NOCHECK>, C<GLOB_NOSORT>,
! C<GLOB_BRACE>, C<GLOB_NOMAGIC>, C<GLOB_QUOTE>, C<GLOB_TILDE>, C<GLOB_CSH>,
! C<GLOB_ALPHASORT>
=item DIAGNOSTICS
--- 10515,10523 ----
=item DESCRIPTION
! C<GLOB_ERR>, C<GLOB_LIMIT>, C<GLOB_MARK>, C<GLOB_NOCASE>, C<GLOB_NOCHECK>,
! C<GLOB_NOSORT>, C<GLOB_BRACE>, C<GLOB_NOMAGIC>, C<GLOB_QUOTE>,
! C<GLOB_TILDE>, C<GLOB_CSH>, C<GLOB_ALPHASORT>
=item DIAGNOSTICS
***************
*** 10324,10329 ****
--- 10951,10960 ----
=item A Solution
+ =item Disabling or changing <no> behaviour
+
+ =item All-in-one interface
+
=item How it works
=back
***************
*** 10527,10532 ****
--- 11158,11370 ----
=back
+ =head2 I18N::LangTags - functions for dealing with RFC3066-style language
+ tags
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =back
+
+ the function is_language_tag($lang1)
+
+ the function extract_language_tags($whatever)
+
+ the function same_language_tag($lang1, $lang2)
+
+ the function similarity_language_tag($lang1, $lang2)
+
+ the function is_dialect_of($lang1, $lang2)
+
+ the function super_languages($lang1)
+
+ the function locale2language_tag($locale_identifier)
+
+ the function encode_language_tag($lang1)
+
+ the function alternate_language_tags($lang1)
+
+ the function @langs = panic_languages(@accept_languages)
+
+ =over 4
+
+ =item ABOUT LOWERCASING
+
+ =item ABOUT UNICODE PLAINTEXT LANGUAGE TAGS
+
+ =item SEE ALSO
+
+ =item COPYRIGHT
+
+ =item AUTHOR
+
+ =back
+
+ =head2 I18N::LangTags::List -- tags and names for human languages
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =item ABOUT LANGUAGE TAGS
+
+ =item LIST OF LANGUAGES
+
+ {ab} : Abkhazian, {ace} : Achinese, {ach} : Acoli, {ada} : Adangme, {aa} :
+ Afar, {afh} : Afrihili, {af} : Afrikaans, [{afa} : Afro-Asiatic (Other)],
+ {aka} : Akan, {akk} : Akkadian, {sq} : Albanian, {ale} : Aleut, [{alg} :
+ Algonquian languages], [{tut} : Altaic (Other)], {am} : Amharic, {i-ami} :
+ Ami, [{apa} : Apache languages], {ar} : Arabic, {arc} : Aramaic, {arp} :
+ Arapaho, {arn} : Araucanian, {arw} : Arawak, {hy} : Armenian, [{art} :
+ Artificial (Other)], {as} : Assamese, [{ath} : Athapascan languages],
+ [{aus} : Australian languages], [{map} : Austronesian (Other)], {ava} :
+ Avaric, {ae} : Avestan, {awa} : Awadhi, {ay} : Aymara, {az} : Azerbaijani,
+ {ban} : Balinese, [{bat} : Baltic (Other)], {bal} : Baluchi, {bam} :
+ Bambara, [{bai} : Bamileke languages], {bad} : Banda, [{bnt} : Bantu
+ (Other)], {bas} : Basa, {ba} : Bashkir, {eu} : Basque, {btk} : Batak
+ (Indonesia), {bej} : Beja, {be} : Belarusian, {bem} : Bemba, {bn} :
+ Bengali, [{ber} : Berber (Other)], {bho} : Bhojpuri, {bh} : Bihari, {bik} :
+ Bikol, {bin} : Bini, {bi} : Bislama, {bs} : Bosnian, {bra} : Braj, {br} :
+ Breton, {bug} : Buginese, {bg} : Bulgarian, {i-bnn} : Bunun, {bua} :
+ Buriat, {my} : Burmese, {cad} : Caddo, {car} : Carib, {ca} : Catalan,
+ [{cau} : Caucasian (Other)], {ceb} : Cebuano, [{cel} : Celtic (Other)],
+ [{cai} : Central American Indian (Other)], {chg} : Chagatai, [{cmc} :
+ Chamic languages], {ch} : Chamorro, {ce} : Chechen, {chr} : Cherokee, {chy}
+ : Cheyenne, {chb} : Chibcha, {ny} : Chichewa, {zh} : Chinese, {chn} :
+ Chinook Jargon, {chp} : Chipewyan, {cho} : Choctaw, {cu} : Church Slavic,
+ {chk} : Chuukese, {cv} : Chuvash, {cop} : Coptic, {kw} : Cornish, {co} :
+ Corsican, {cre} : Cree, {mus} : Creek, [{cpe} : English-based Creoles and
+ pidgins (Other)], [{cpf} : French-based Creoles and pidgins (Other)],
+ [{cpp} : Portuguese-based Creoles and pidgins (Other)], [{crp} : Creoles
+ and pidgins (Other)], {hr} : Croatian, [{cus} : Cushitic (Other)], {cs} :
+ Czech, {dak} : Dakota, {da} : Danish, {day} : Dayak, {i-default} : Default
+ (Fallthru) Language, {del} : Delaware, {din} : Dinka, {div} : Divehi, {doi}
+ : Dogri, {dgr} : Dogrib, [{dra} : Dravidian (Other)], {dua} : Duala, {nl} :
+ Dutch, {dum} : Middle Dutch (ca.1050-1350), {dyu} : Dyula, {dz} : Dzongkha,
+ {efi} : Efik, {egy} : Ancient Egyptian, {eka} : Ekajuk, {elx} : Elamite,
+ {en} : English, {enm} : Old English (1100-1500), {ang} : Old English
+ (ca.450-1100), {eo} : Esperanto, {et} : Estonian, {ewe} : Ewe, {ewo} :
+ Ewondo, {fan} : Fang, {fat} : Fanti, {fo} : Faroese, {fj} : Fijian, {fi} :
+ Finnish, [{fiu} : Finno-Ugrian (Other)], {fon} : Fon, {fr} : French, {frm}
+ : Middle French (ca.1400-1600), {fro} : Old French (842-ca.1400), {fy} :
+ Frisian, {fur} : Friulian, {ful} : Fulah, {gaa} : Ga, {gd} : Scots Gaelic,
+ {gl} : Gallegan, {lug} : Ganda, {gay} : Gayo, {gba} : Gbaya, {gez} : Geez,
+ {ka} : Georgian, {de} : German, {gmh} : Middle High German (ca.1050-1500),
+ {goh} : Old High German (ca.750-1050), [{gem} : Germanic (Other)], {gil} :
+ Gilbertese, {gon} : Gondi, {gor} : Gorontalo, {got} : Gothic, {grb} :
+ Grebo, {grc} : Ancient Greek, {el} : Modern Greek, {gn} : Guarani, {gu} :
+ Gujarati, {gwi} : Gwich'in, {hai} : Haida, {ha} : Hausa, {haw} : Hawaiian,
+ {he} : Hebrew, {hz} : Herero, {hil} : Hiligaynon, {him} : Himachali, {hi} :
+ Hindi, {ho} : Hiri Motu, {hit} : Hittite, {hmn} : Hmong, {hu} : Hungarian,
+ {hup} : Hupa, {iba} : Iban, {is} : Icelandic, {ibo} : Igbo, {ijo} : Ijo,
+ {ilo} : Iloko, [{inc} : Indic (Other)], [{ine} : Indo-European (Other)],
+ {id} : Indonesian, {ia} : Interlingua (International Auxiliary Language
+ Association), {ie} : Interlingue, {iu} : Inuktitut, {ik} : Inupiaq, [{ira}
+ : Iranian (Other)], {ga} : Irish, {mga} : Middle Irish (900-1200), {sga} :
+ Old Irish (to 900), [{iro} : Iroquoian languages], {it} : Italian, {ja} :
+ Japanese, {jw} : Javanese, {jrb} : Judeo-Arabic, {jpr} : Judeo-Persian,
+ {kab} : Kabyle, {kac} : Kachin, {kl} : Kalaallisut, {kam} : Kamba, {kn} :
+ Kannada, {kau} : Kanuri, {kaa} : Kara-Kalpak, {kar} : Karen, {ks} :
+ Kashmiri, {kaw} : Kawi, {kk} : Kazakh, {kha} : Khasi, {km} : Khmer, [{khi}
+ : Khoisan (Other)], {kho} : Khotanese, {ki} : Kikuyu, {kmb} : Kimbundu,
+ {rw} : Kinyarwanda, {ky} : Kirghiz, {i-klingon} : Klingon, {kv} : Komi,
+ {kon} : Kongo, {kok} : Konkani, {ko} : Korean, {kos} : Kosraean, {kpe} :
+ Kpelle, {kro} : Kru, {kj} : Kuanyama, {kum} : Kumyk, {ku} : Kurdish, {kru}
+ : Kurukh, {kut} : Kutenai, {lad} : Ladino, {lah} : Lahnda, {lam} : Lamba,
+ {lo} : Lao, {la} : Latin, {lv} : Latvian, {lb} : Letzeburgesch, {lez} :
+ Lezghian, {ln} : Lingala, {lt} : Lithuanian, {nds} : Low German, {loz} :
+ Lozi, {lub} : Luba-Katanga, {lua} : Luba-Lulua, {lui} : Luiseno, {lun} :
+ Lunda, {luo} : Luo (Kenya and Tanzania), {lus} : Lushai, {mk} : Macedonian,
+ {mad} : Madurese, {mag} : Magahi, {mai} : Maithili, {mak} : Makasar, {mg} :
+ Malagasy, {ms} : Malay, {ml} : Malayalam, {mt} : Maltese, {mnc} : Manchu,
+ {mdr} : Mandar, {man} : Mandingo, {mni} : Manipuri, [{mno} : Manobo
+ languages], {gv} : Manx, {mi} : Maori, {mr} : Marathi, {chm} : Mari, {mh} :
+ Marshall, {mwr} : Marwari, {mas} : Masai, [{myn} : Mayan languages], {men}
+ : Mende, {mic} : Micmac, {min} : Minangkabau, {i-mingo} : Mingo, [{mis} :
+ Miscellaneous languages], {moh} : Mohawk, {mo} : Moldavian, [{mkh} :
+ Mon-Khmer (Other)], {lol} : Mongo, {mn} : Mongolian, {mos} : Mossi, [{mul}
+ : Multiple languages], [{mun} : Munda languages], {nah} : Nahuatl, {na} :
+ Nauru, {nv} : Navajo, {nd} : North Ndebele, {nr} : South Ndebele, {ng} :
+ Ndonga, {ne} : Nepali, {new} : Newari, {nia} : Nias, [{nic} :
+ Niger-Kordofanian (Other)], [{ssa} : Nilo-Saharan (Other)], {niu} : Niuean,
+ {non} : Old Norse, [{nai} : North American Indian], {se} : Northern Sami,
+ {no} : Norwegian, {nb} : Norwegian Bokmal, {nn} : Norwegian Nynorsk, [{nub}
+ : Nubian languages], {nym} : Nyamwezi, {nyn} : Nyankole, {nyo} : Nyoro,
+ {nzi} : Nzima, {oc} : Occitan (post 1500), {oji} : Ojibwa, {or} : Oriya,
+ {om} : Oromo, {osa} : Osage, {os} : Ossetian; Ossetic, [{oto} : Otomian
+ languages], {pal} : Pahlavi, {i-pwn} : Paiwan, {pau} : Palauan, {pi} :
+ Pali, {pam} : Pampanga, {pag} : Pangasinan, {pa} : Panjabi, {pap} :
+ Papiamento, [{paa} : Papuan (Other)], {fa} : Persian, {peo} : Old Persian
+ (ca.600-400 B.C.), [{phi} : Philippine (Other)], {phn} : Phoenician, {pon}
+ : Pohnpeian, {pl} : Polish, {pt} : Portuguese, [{pra} : Prakrit languages],
+ {pro} : Old Provencal (to 1500), {ps} : Pushto, {qu} : Quechua, {rm} :
+ Raeto-Romance, {raj} : Rajasthani, {rap} : Rapanui, {rar} : Rarotongan,
+ [{qaa - qtz} : Reserved for local use.], [{roa} : Romance (Other)], {ro} :
+ Romanian, {rom} : Romany, {rn} : Rundi, {ru} : Russian, [{sal} : Salishan
+ languages], {sam} : Samaritan Aramaic, [{smi} : Sami languages (Other)],
+ {sm} : Samoan, {sad} : Sandawe, {sg} : Sango, {sa} : Sanskrit, {sat} :
+ Santali, {sc} : Sardinian, {sas} : Sasak, {sco} : Scots, {sel} : Selkup,
+ [{sem} : Semitic (Other)], {sr} : Serbian, {srr} : Serer, {shn} : Shan,
+ {sn} : Shona, {sid} : Sidamo, {sgn-...} : Sign Languages, {bla} : Siksika,
+ {sd} : Sindhi, {si} : Sinhalese, [{sit} : Sino-Tibetan (Other)], [{sio} :
+ Siouan languages], {den} : Slave (Athapascan), [{sla} : Slavic (Other)],
+ {sk} : Slovak, {sl} : Slovenian, {sog} : Sogdian, {so} : Somali, {son} :
+ Songhai, {snk} : Soninke, {wen} : Sorbian languages, {nso} : Northern
+ Sotho, {st} : Southern Sotho, [{sai} : South American Indian (Other)], {es}
+ : Spanish, {suk} : Sukuma, {sux} : Sumerian, {su} : Sundanese, {sus} :
+ Susu, {sw} : Swahili, {ss} : Swati, {sv} : Swedish, {syr} : Syriac, {tl} :
+ Tagalog, {ty} : Tahitian, [{tai} : Tai (Other)], {tg} : Tajik, {tmh} :
+ Tamashek, {ta} : Tamil, {i-tao} : Tao, {tt} : Tatar, {i-tay} : Tayal, {te}
+ : Telugu, {ter} : Tereno, {tet} : Tetum, {th} : Thai, {bo} : Tibetan, {tig}
+ : Tigre, {ti} : Tigrinya, {tem} : Timne, {tiv} : Tiv, {tli} : Tlingit,
+ {tpi} : Tok Pisin, {tkl} : Tokelau, {tog} : Tonga (Nyasa), {to} : Tonga
+ (Tonga Islands), {tsi} : Tsimshian, {ts} : Tsonga, {i-tsu} : Tsou, {tn} :
+ Tswana, {tum} : Tumbuka, {tr} : Turkish, {ota} : Ottoman Turkish
+ (1500-1928), {tk} : Turkmen, {tvl} : Tuvalu, {tyv} : Tuvinian, {tw} : Twi,
+ {uga} : Ugaritic, {ug} : Uighur, {uk} : Ukrainian, {umb} : Umbundu, {und} :
+ Undetermined, {ur} : Urdu, {uz} : Uzbek, {vai} : Vai, {ven} : Venda, {vi} :
+ Vietnamese, {vo} : Volapuk, {vot} : Votic, [{wak} : Wakashan languages],
+ {wal} : Walamo, {war} : Waray, {was} : Washo, {cy} : Welsh, {wo} : Wolof,
+ {x-...} : Unregistered (Semi-Private Use), {xh} : Xhosa, {sah} : Yakut,
+ {yao} : Yao, {yap} : Yapese, {yi} : Yiddish, {yo} : Yoruba, [{ypk} : Yupik
+ languages], {znd} : Zande, [{zap} : Zapotec], {zen} : Zenaga, {za} :
+ Zhuang, {zu} : Zulu, {zun} : Zuni
+
+ =item SEE ALSO
+
+ =item COPYRIGHT AND DISCLAIMER
+
+ =item AUTHOR
+
+ =back
+
+ =head2 I18N::Langinfo - query locale information
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =over 4
+
+ =item EXPORT
+
+ =back
+
+ =item SEE ALSO
+
+ =item AUTHOR
+
+ =item COPYRIGHT AND LICENSE
+
+ =back
+
=head2 IO - load various IO modules
=over 4
***************
*** 10660,10667 ****
=item DESCRIPTION
! $io->getpos, $io->setpos, $io->setpos ( POS, WHENCE ), WHENCE=0 (SEEK_SET),
! WHENCE=1 (SEEK_CUR), WHENCE=1 (SEEK_END), $io->sysseek( POS, WHENCE ),
$io->tell
=item SEE ALSO
--- 11498,11505 ----
=item DESCRIPTION
! $io->getpos, $io->setpos, $io->seek ( POS, WHENCE ), WHENCE=0 (SEEK_SET),
! WHENCE=1 (SEEK_CUR), WHENCE=2 (SEEK_END), $io->sysseek( POS, WHENCE ),
$io->tell
=item SEE ALSO
***************
*** 10900,10907 ****
=item DESCRIPTION
! $io->getpos, $io->setpos, $io->setpos ( POS, WHENCE ), WHENCE=0 (SEEK_SET),
! WHENCE=1 (SEEK_CUR), WHENCE=1 (SEEK_END), $io->sysseek( POS, WHENCE ),
$io->tell
=item SEE ALSO
--- 11738,11745 ----
=item DESCRIPTION
! $io->getpos, $io->setpos, $io->seek ( POS, WHENCE ), WHENCE=0 (SEEK_SET),
! WHENCE=1 (SEEK_CUR), WHENCE=2 (SEEK_END), $io->sysseek( POS, WHENCE ),
$io->tell
=item SEE ALSO
***************
*** 11154,11159 ****
--- 11992,12076 ----
=back
+ =head2 Langinfo - Perl extension for blah blah blah
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =over 4
+
+ =item EXPORT
+
+ =item Exportable constants
+
+ =back
+
+ =item HISTORY
+
+ =item SEE ALSO
+
+ =item AUTHOR
+
+ =item COPYRIGHT AND LICENSE
+
+ =back
+
+ =head2 List::Util - A selection of general-utility list subroutines
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ first BLOCK LIST, max LIST, maxstr LIST, min LIST, minstr LIST, reduce
+ BLOCK LIST, sum LIST
+
+ =item SUGGESTED ADDITIONS
+
+ =item COPYRIGHT
+
+ =back
+
+ =head2 List::Utilib::List::Util, List::Util - A selection of
+ general-utility list subroutines
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ first BLOCK LIST, max LIST, maxstr LIST, min LIST, minstr LIST, reduce
+ BLOCK LIST, sum LIST
+
+ =item SUGGESTED ADDITIONS
+
+ =item COPYRIGHT
+
+ =back
+
+ =head2 List::Utilib::Scalar::Util, Scalar::Util - A selection of
+ general-utility scalar subroutines
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ blessed EXPR, dualvar NUM, STRING, isweak EXPR, readonly SCALAR, reftype
+ EXPR, tainted EXPR, weaken REF
+
+ =item COPYRIGHT
+
+ =item BLATANT PLUG
+
+ =back
+
=head2 Locale::Constants - constants for Locale codes
=over 4
***************
*** 11331,11336 ****
--- 12248,12342 ----
=back
+ =head2 Locale::Maketext -- framework for localization
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =item QUICK OVERVIEW
+
+ =item METHODS
+
+ =over 4
+
+ =item Construction Methods
+
+ =item The "maketext" Method
+
+ $lh->fail_with I<or> $lh->fail_with(I<PARAM>), $lh->failure_handler_auto
+
+ =item Utility Methods
+
+ $language->quant($number, $singular), $language->quant($number, $singular,
+ $plural), $language->quant($number, $singular, $plural, $negative),
+ $language->numf($number), $language->sprintf($format, @items),
+ $language->language_tag(), $language->encoding()
+
+ =item Language Handle Attributes and Internals
+
+ =back
+
+ =item LANGUAGE CLASS HIERARCHIES
+
+ =item ENTRIES IN EACH LEXICON
+
+ =item BRACKET NOTATION
+
+ =item AUTO LEXICONS
+
+ =item CONTROLLING LOOKUP FAILURE
+
+ =item HOW TO USE MAKETEXT
+
+ =item SEE ALSO
+
+ =item COPYRIGHT AND DISCLAIMER
+
+ =item AUTHOR
+
+ =back
+
+ =head2 Locale::Maketext::TPJ13 -- article about software localization
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =item Localization and Perl: gettext breaks, Maketext fixes
+
+ =over 4
+
+ =item A Localization Horror Story: It Could Happen To You
+
+ =item The Linguistic View
+
+ =item Breaking gettext
+
+ =item Replacing gettext
+
+ =item Buzzwords: Abstraction and Encapsulation
+
+ =item Buzzword: Isomorphism
+
+ =item Buzzword: Inheritance
+
+ =item Buzzword: Concision
+
+ =item The Devil in the Details
+
+ =item The Proof in the Pudding: Localizing Web Sites
+
+ =item References
+
+ =back
+
+ =back
+
=head2 MIME::Base64 - Encoding and decoding of base64 strings
=over 4
***************
*** 11381,11387 ****
=back
! =head2 Math::BigFloat - Arbitrary length float math package
=over 4
--- 12387,12393 ----
=back
! =head2 Math::BigFloat - Arbitrary size floating point math package
=over 4
***************
*** 11389,11401 ****
=item DESCRIPTION
! number format, Error returns 'NaN', Division is computed to, Rounding is
! performed
=item BUGS
! =item AUTHOR
=back
=head2 Math::BigInt - Arbitrary size integer math package
--- 12395,12450 ----
=item DESCRIPTION
! =over 4
+ =item Canonical notation
+
+ =item Output
+
+ =item C<mantissa()>, C<exponent()> and C<parts()>
+
+ =item Accuracy vs. Precision
+
+ =item Rounding
+
+ ffround ( +$scale ), ffround ( -$scale ), ffround ( 0 ), fround ( +$scale
+ ), fround ( -$scale ) and fround ( 0 )
+
+ =back
+
+ =item EXAMPLES
+
+ use Math::BigFloat qw(bstr bint);
+ # not ready yet
+ $x = bstr("1234") # string "1234"
+ $x = "$x"; # same as bstr()
+ $x = bneg("1234") # BigFloat "-1234"
+ $x = Math::BigFloat->bneg("1234"); # BigFloat "1234"
+ $x = Math::BigFloat->babs("-12345"); # BigFloat "12345"
+ $x = Math::BigFloat->bnorm("-0 00"); # BigFloat "0"
+ $x = bint(1) + bint(2); # BigFloat "3"
+ $x = bint(1) + "2"; # ditto (auto-BigFloatify of "2")
+ $x = bint(1); # BigFloat "1"
+ $x = $x + 5 / 2; # BigFloat "3"
+ $x = $x ** 3; # BigFloat "27"
+ $x *= 2; # BigFloat "54"
+ $x = new Math::BigFloat; # BigFloat "0"
+ $x--; # BigFloat "-1"
+
+ =item Autocreating constants
+
+ =item PERFORMANCE
+
=item BUGS
! =item CAVEAT
+ stringify, bstr(), bdiv, Modifying and =, bpow
+
+ =item LICENSE
+
+ =item AUTHORS
+
=back
=head2 Math::BigInt - Arbitrary size integer math package
***************
*** 11408,11423 ****
Canonical notation, Input, Output
=item EXAMPLES
=item Autocreating constants
=item BUGS
! =item AUTHOR
=back
=head2 Math::Complex - complex numbers and associated mathematical
functions
--- 12457,12559 ----
Canonical notation, Input, Output
+ =item ACCURACY and PRECISION
+
+ =over 4
+
+ =item Precision P
+
+ =item Accuracy A
+
+ =item Fallback F
+
+ =item Rounding mode R
+
+ 'trunc', 'even', 'odd', '+inf', '-inf', 'zero', Precision, Accuracy
+ (significant digits), Setting/Accessing, Creating numbers, Usage,
+ Precedence, Overriding globals, Local settings, Rounding, Default values,
+ Remarks
+
+ =back
+
+ =item INTERNALS
+
+ =over 4
+
+ =item mantissa(), exponent() and parts()
+
+ =back
+
=item EXAMPLES
+ use Math::BigInt qw(bstr bint);
+ $x = bstr("1234") # string "1234"
+ $x = "$x"; # same as bstr()
+ $x = bneg("1234") # Bigint "-1234"
+ $x = Math::BigInt->bneg("1234"); # Bigint "-1234"
+ $x = Math::BigInt->babs("-12345"); # Bigint "12345"
+ $x = Math::BigInt->bnorm("-0 00"); # BigInt "0"
+ $x = bint(1) + bint(2); # BigInt "3"
+ $x = bint(1) + "2"; # ditto (auto-BigIntify of "2")
+ $x = bint(1); # BigInt "1"
+ $x = $x + 5 / 2; # BigInt "3"
+ $x = $x ** 3; # BigInt "27"
+ $x *= 2; # BigInt "54"
+ $x = new Math::BigInt; # BigInt "0"
+ $x--; # BigInt "-1"
+ $x = Math::BigInt->badd(4,5) # BigInt "9"
+ $x = Math::BigInt::badd(4,5) # BigInt "9"
+ print $x->bsstr(); # 9e+0
+
=item Autocreating constants
+ =item PERFORMANCE
+
+ =over 4
+
+ =item Replacing the math library
+
+ =back
+
=item BUGS
! :constant and eval()
+ =item CAVEATS
+
+ stringify, bstr(), bsstr() and 'cmp', int(), bdiv, Modifying and =, bpow,
+ Overloading -$x, Mixing different object types, bsqrt()
+
+ =item LICENSE
+
+ =item SEE ALSO
+
+ =item AUTHORS
+
=back
+ =head2 Math::BigInt::Calc - Pure Perl module to support Math::BigInt
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =item EXPORT
+
+ =item LICENSE
+
+ This program is free software; you may redistribute it and/or modify it
+ under
+ the same terms as Perl itself.
+
+ =item AUTHORS
+
+ =item SEE ALSO
+
+ =back
+
=head2 Math::Complex - complex numbers and associated mathematical
functions
***************
*** 11502,11507 ****
--- 12638,12786 ----
=back
+ =head2 Memoize - Make your functions faster by trading space for time
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =item DETAILS
+
+ =item OPTIONS
+
+ =over 4
+
+ =item INSTALL
+
+ =item NORMALIZER
+
+ =item C<SCALAR_CACHE>, C<LIST_CACHE>
+
+ C<MEMORY>, C<HASH>, C<TIE>, C<FAULT>, C<MERGE>
+
+ =back
+
+ =item OTHER FACILITIES
+
+ =over 4
+
+ =item C<unmemoize>
+
+ =item C<flush_cache>
+
+ =back
+
+ =item CAVEATS
+
+ =item PERSISTENT CACHE SUPPORT
+
+ =item EXPIRATION SUPPORT
+
+ =item BUGS
+
+ =item MAILING LIST
+
+ =item AUTHOR
+
+ =item COPYRIGHT AND LICENSE
+
+ =item THANK YOU
+
+ =back
+
+ =head2 Memoize::AnyDBM_File - glue to provide EXISTS for AnyDBM_File for
+ Storable use
+
+ =over 4
+
+ =item DESCRIPTION
+
+ =back
+
+ =head2 Memoize::Expire - Plug-in module for automatic expiration of
+ memoized values
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =item INTERFACE
+
+ TIEHASH, EXISTS, STORE
+
+ =item ALTERNATIVES
+
+ =item CAVEATS
+
+ =item AUTHOR
+
+ =item SEE ALSO
+
+ =back
+
+ =head2 Memoize::ExpireFile - test for Memoize expiration semantics
+
+ =over 4
+
+ =item DESCRIPTION
+
+ =back
+
+ =head2 Memoize::ExpireTest - test for Memoize expiration semantics
+
+ =over 4
+
+ =item DESCRIPTION
+
+ =back
+
+ =head2 Memoize::NDBM_File - glue to provide EXISTS for NDBM_File for
+ Storable use
+
+ =over 4
+
+ =item DESCRIPTION
+
+ =back
+
+ =head2 Memoize::SDBM_File - glue to provide EXISTS for SDBM_File for
+ Storable use
+
+ =over 4
+
+ =item DESCRIPTION
+
+ =back
+
+ =head2 Memoize::Saves - Plug-in module to specify which return values
+ should be memoized
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =item CAVEATS
+
+ =item AUTHOR
+
+ =item SEE ALSO
+
+ =back
+
+ =head2 Memoize::Storable - store Memoized data in Storable database
+
+ =over 4
+
+ =item DESCRIPTION
+
+ =back
+
=head2 NDBM_File - Tied access to ndbm files
=over 4
***************
*** 11524,11529 ****
--- 12803,13025 ----
=back
+ =head2 NEXT - Provide a pseudo-class NEXT that allows method redispatch
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =item AUTHOR
+
+ =item BUGS AND IRRITATIONS
+
+ =item COPYRIGHT
+
+ =back
+
+ =head2 Net::Cmd - Network Command class (as used by FTP, SMTP etc)
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =item USER METHODS
+
+ debug ( VALUE ), message (), code (), ok (), status (), datasend ( DATA ),
+ dataend ()
+
+ =item CLASS METHODS
+
+ debug_print ( DIR, TEXT ), debug_text ( TEXT ), command ( CMD [, ARGS, ...
+ ]), unsupported (), response (), parse_response ( TEXT ), getline (),
+ ungetline ( TEXT ), read_until_dot ()
+
+ =item EXPORTS
+
+ =item AUTHOR
+
+ =item COPYRIGHT
+
+ =back
+
+ =head2 Net::Config - Local configuration data for libnet
+
+ =over 4
+
+ =item SYNOPSYS
+
+ =item DESCRIPTION
+
+ =item METHODS
+
+ requires_firewall HOST
+
+ =item NetConfig VALUES
+
+ nntp_hosts, snpp_hosts, pop3_hosts, smtp_hosts, ph_hosts, daytime_hosts,
+ time_hosts, inet_domain, ftp_firewall, ftp_ext_passive, ftp_int_pasive,
+ local_netmask, test_hosts, test_exists
+
+ =back
+
+ =head2 Net::Domain - Attempt to evaluate the current host's internet name
+ and domain
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ hostfqdn (), hostname (), hostdomain ()
+
+ =item AUTHOR
+
+ =item COPYRIGHT
+
+ =back
+
+ =head2 Net::FTP - FTP Client class
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =item OVERVIEW
+
+ =item CONSTRUCTOR
+
+ new (HOST [,OPTIONS])
+
+ =item METHODS
+
+ login ([LOGIN [,PASSWORD [, ACCOUNT] ] ]), authorize ( [AUTH [, RESP]]),
+ site (ARGS), type (TYPE [, ARGS]), ascii ([ARGS]) binary([ARGS])
+ ebcdic([ARGS]) byte([ARGS]), rename ( OLDNAME, NEWNAME ), delete ( FILENAME
+ ), cwd ( [ DIR ] ), cdup (), pwd (), rmdir ( DIR ), mkdir ( DIR [, RECURSE
+ ]), ls ( [ DIR ] ), dir ( [ DIR ] ), get ( REMOTE_FILE [, LOCAL_FILE [,
+ WHERE]] ), put ( LOCAL_FILE [, REMOTE_FILE ] ), put_unique ( LOCAL_FILE [,
+ REMOTE_FILE ] ), append ( LOCAL_FILE [, REMOTE_FILE ] ), unique_name (),
+ mdtm ( FILE ), size ( FILE ), supported ( CMD ), hash (
+ [FILEHANDLE_GLOB_REF],[ BYTES_PER_HASH_MARK] ), nlst ( [ DIR ] ), list ( [
+ DIR ] ), retr ( FILE ), stor ( FILE ), stou ( FILE ), appe ( FILE ), port (
+ [ PORT ] ), pasv (), pasv_xfer ( SRC_FILE, DEST_SERVER [, DEST_FILE ] ),
+ pasv_xfer_unique ( SRC_FILE, DEST_SERVER [, DEST_FILE ] ), pasv_wait (
+ NON_PASV_SERVER ), abort (), quit ()
+
+ =over 4
+
+ =item Methods for the adventurous
+
+ quot (CMD [,ARGS])
+
+ =back
+
+ =item THE dataconn CLASS
+
+ read ( BUFFER, SIZE [, TIMEOUT ] ), write ( BUFFER, SIZE [, TIMEOUT ] ),
+ abort (), close ()
+
+ =item UNIMPLEMENTED
+
+ B<ALLO>, B<SMNT>, B<HELP>, B<MODE>, B<SYST>, B<STAT>, B<STRU>, B<REIN>
+
+ =item REPORTING BUGS
+
+ =item AUTHOR
+
+ =item SEE ALSO
+
+ =item CREDITS
+
+ =item COPYRIGHT
+
+ =back
+
+ =head2 Net::NNTP - NNTP Client class
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =item CONSTRUCTOR
+
+ new ( [ HOST ] [, OPTIONS ])
+
+ =item METHODS
+
+ article ( [ MSGID|MSGNUM ], [FH] ), body ( [ MSGID|MSGNUM ], [FH] ), head (
+ [ MSGID|MSGNUM ], [FH] ), nntpstat ( [ MSGID|MSGNUM ] ), group ( [ GROUP ]
+ ), ihave ( MSGID [, MESSAGE ]), last (), date (), postok (), authinfo (
+ USER, PASS ), list (), newgroups ( SINCE [, DISTRIBUTIONS ]), newnews (
+ SINCE [, GROUPS [, DISTRIBUTIONS ]]), next (), post ( [ MESSAGE ] ), slave
+ (), quit ()
+
+ =over 4
+
+ =item Extension methods
+
+ newsgroups ( [ PATTERN ] ), distributions (), subscriptions (),
+ overview_fmt (), active_times (), active ( [ PATTERN ] ), xgtitle ( PATTERN
+ ), xhdr ( HEADER, MESSAGE-SPEC ), xover ( MESSAGE-SPEC ), xpath (
+ MESSAGE-ID ), xpat ( HEADER, PATTERN, MESSAGE-SPEC), xrover, listgroup ( [
+ GROUP ] ), reader
+
+ =back
+
+ =item UNSUPPORTED
+
+ =item DEFINITIONS
+
+ MESSAGE-SPEC, PATTERN, Examples, C<[^]-]>, C<*bdc>, C<[0-9a-zA-Z]>, C<a??d>
+
+ =item SEE ALSO
+
+ =item AUTHOR
+
+ =item COPYRIGHT
+
+ =back
+
+ =head2 Net::POP3 - Post Office Protocol 3 Client class (RFC1081)
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =item EXAMPLES
+
+ =item CONSTRUCTOR
+
+ new ( [ HOST, ] [ OPTIONS ] )
+
+ =item METHODS
+
+ user ( USER ), pass ( PASS ), login ( [ USER [, PASS ]] ), apop ( USER,
+ PASS ), top ( MSGNUM [, NUMLINES ] ), list ( [ MSGNUM ] ), get ( MSGNUM [,
+ FH ] ), last (), popstat (), ping ( USER ), uidl ( [ MSGNUM ] ), delete (
+ MSGNUM ), reset (), quit ()
+
+ =item NOTES
+
+ =item SEE ALSO
+
+ =item AUTHOR
+
+ =item COPYRIGHT
+
+ =back
+
=head2 Net::Ping - check a remote host for reachability
=over 4
***************
*** 11532,11543 ****
=item DESCRIPTION
=over 4
=item Functions
Net::Ping->new([$proto [, $def_timeout [, $bytes]]]);, $p->ping($host [,
! $timeout]);, $p->close();, pingecho($host [, $timeout]);
=back
--- 13028,13041 ----
=item DESCRIPTION
+ icmp, udp, tcp, stream, external
+
=over 4
=item Functions
Net::Ping->new([$proto [, $def_timeout [, $bytes]]]);, $p->ping($host [,
! $timeout]);, $p->open($host);, $p->close();, pingecho($host [, $timeout]);
=back
***************
*** 11545,11550 ****
--- 13043,13095 ----
=back
+ =head2 Net::SMTP - Simple Mail Transfer Protocol Client
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =item EXAMPLES
+
+ =item CONSTRUCTOR
+
+ new Net::SMTP [ HOST, ] [ OPTIONS ]
+
+ =item METHODS
+
+ banner (), domain (), hello ( DOMAIN ), etrn ( DOMAIN ), mail ( ADDRESS [,
+ OPTIONS] ), send ( ADDRESS ), send_or_mail ( ADDRESS ), send_and_mail (
+ ADDRESS ), reset (), recipient ( ADDRESS [, ADDRESS [ ...]] [, OPTIONS ] ),
+ to ( ADDRESS [, ADDRESS [...]] ), data ( [ DATA ] ), expand ( ADDRESS ),
+ verify ( ADDRESS ), help ( [ $subject ] ), quit ()
+
+ =item SEE ALSO
+
+ =item AUTHOR
+
+ =item COPYRIGHT
+
+ =back
+
+ =head2 Net::Time - time and daytime network client interface
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ inet_time ( [HOST [, PROTOCOL [, TIMEOUT]]]), inet_daytime ( [HOST [,
+ PROTOCOL [, TIMEOUT]]])
+
+ =item AUTHOR
+
+ =item COPYRIGHT
+
+ =back
+
=head2 Net::hostent - by-name interface to Perl's built-in gethost*()
functions
***************
*** 11562,11567 ****
--- 13107,13213 ----
=back
+ =head2 Net::libnetFAQ, libnetFAQ - libnet Frequently Asked Questions
+
+ =over 4
+
+ =item DESCRIPTION
+
+ =over 4
+
+ =item Where to get this document
+
+ =item How to contribute to this document
+
+ =back
+
+ =item Author and Copyright Information
+
+ =over 4
+
+ =item Disclaimer
+
+ =back
+
+ =item Obtaining and installing libnet
+
+ =over 4
+
+ =item What is libnet ?
+
+ =item Which version of perl do I need ?
+
+ =item What other modules do I need ?
+
+ =item What machines support libnet ?
+
+ =item Where can I get the latest libnet release
+
+ =back
+
+ =item Using Net::FTP
+
+ =over 4
+
+ =item How do I download files from a FTP server ?
+
+ =item How do I transfer files in binary mode ?
+
+ =item How can I get the size of a file on a remote FTP server ?
+
+ =item How can I get the modification time of a file on a remote FTP server
+ ?
+
+ =item How can I change the permissions of a file on a remote server ?
+
+ =item Can I do a reget operation like the ftp command ?
+
+ =item How do I get a directory listing from a FTP server ?
+
+ =item Changeing directory to "" does not fail ?
+
+ =item I am behind a SOCKS firewall, but the Firewall option does not work ?
+
+ =item I am behind a FTP proxy firewall, but cannot access machines outside
+ ?
+
+ =item My ftp proxy firewall does not listen on port 21
+
+ =item Is it possible to change the file permissions of a file on an FTP
+ server ?
+
+ =item I have seen scripts call a method message, but cannot find it
+ documented ?
+
+ =item Why does Net::FTP not implement mput and mget methods
+
+ =back
+
+ =item Using Net::SMTP
+
+ =over 4
+
+ =item Why can't the part of an Email address after the @ be used as the
+ hostname ?
+
+ =item Why does Net::SMTP not do DNS MX lookups ?
+
+ =item The verify method always returns true ?
+
+ =back
+
+ =item Debugging scripts
+
+ =over 4
+
+ =item How can I debug my scripts that use Net::* modules ?
+
+ =back
+
+ =item AUTHOR AND COPYRIGHT
+
+ =back
+
=head2 Net::netent - by-name interface to Perl's built-in getnet*()
functions
***************
*** 11611,11616 ****
--- 13257,13291 ----
=back
+ =head2 Netrc, Net::Netrc - OO interface to users netrc file
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =item THE .netrc FILE
+
+ machine name, default, login name, password string, account string, macdef
+ name
+
+ =item CONSTRUCTOR
+
+ lookup ( MACHINE [, LOGIN ])
+
+ =item METHODS
+
+ login (), password (), account (), lpa ()
+
+ =item AUTHOR
+
+ =item SEE ALSO
+
+ =item COPYRIGHT
+
+ =back
+
=head2 O - Generic interface to Perl Compiler backends
=over 4
***************
*** 12058,12066 ****
=item ARGUMENTS
! backlink, css, flush, header, help, htmldir, htmlroot, index, infile,
! libpods, netscape, outfile, podpath, podroot, quiet, recurse, title,
! verbose
=item EXAMPLE
--- 13733,13741 ----
=item ARGUMENTS
! backlink, cachedir, css, flush, header, help, htmldir, htmlroot, index,
! infile, libpods, netscape, outfile, podpath, podroot, quiet, recurse,
! title, verbose
=item EXAMPLE
***************
*** 12437,12444 ****
roff font should be 1 or 2 chars, not "%s", Invalid link %s, Invalid quote
specification "%s", %s:%d: Unknown command paragraph "%s", Unknown escape
! EE<lt>%sE<gt>, Unknown sequence %s, %s: Unknown command paragraph "%s" on
! line %d, Unmatched =back
=item BUGS
--- 14112,14118 ----
roff font should be 1 or 2 chars, not "%s", Invalid link %s, Invalid quote
specification "%s", %s:%d: Unknown command paragraph "%s", Unknown escape
! EE<lt>%sE<gt>, Unknown sequence %s, Unmatched =back
=item BUGS
***************
*** 12446,12451 ****
--- 14120,14127 ----
=item AUTHOR
+ =item COPYRIGHT AND LICENSE
+
=back
=head2 Pod::ParseUtils - helpers for POD parsing and conversion
***************
*** 12942,12947 ****
--- 14618,14625 ----
=item AUTHOR
+ =item COPYRIGHT AND LICENSE
+
=back
=head2 Pod::Text::Color - Convert POD data to formatted color ASCII text
***************
*** 12958,12963 ****
--- 14636,14643 ----
=item AUTHOR
+ =item COPYRIGHT AND LICENSE
+
=back
=head2 Pod::Text::Overstrike - Convert POD data to formatted overstrike
***************
*** 12975,12980 ****
--- 14655,14662 ----
=item AUTHOR
+ =item COPYRIGHT AND LICENSE
+
=back
=head2 Pod::Text::Termcap, Pod::Text::Color - Convert POD data to ASCII
***************
*** 12990,12995 ****
--- 14672,14679 ----
=item AUTHOR
+ =item COPYRIGHT AND LICENSE
+
=back
=head2 Pod::Usage, pod2usage() - print a usage message from embedded pod
***************
*** 13077,13082 ****
--- 14761,14783 ----
=back
+ =head2 Scalar::Util - A selection of general-utility scalar subroutines
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ blessed EXPR, dualvar NUM, STRING, isweak EXPR, readonly SCALAR, reftype
+ EXPR, tainted EXPR, weaken REF
+
+ =item COPYRIGHT
+
+ =item BLATANT PLUG
+
+ =back
+
=head2 Search::Dict, look - search for key in dictionary file
=over 4
***************
*** 13320,13335 ****
=item DIAGNOSTICS
! Invalid attribute name %s, Name "%s" used only once: possible typo, No
! comma allowed after filehandle, Bareword "%s" not allowed while "strict
! subs" in use
=item RESTRICTIONS
=item NOTES
=item AUTHORS
=back
=head2 Term::Cap - Perl termcap interface
--- 15021,15044 ----
=item DIAGNOSTICS
! Bad escape sequence %s, Bareword "%s" not allowed while "strict subs" in
! use, Invalid attribute name %s, Name "%s" used only once: possible typo, No
! comma allowed after filehandle, No name for escape sequence %s
+ =item ENVIRONMENT
+
+ ANSI_COLORS_DISABLED
+
=item RESTRICTIONS
=item NOTES
+ =item SEE ALSO
+
=item AUTHORS
+ =item LICENSE
+
=back
=head2 Term::Cap - Perl termcap interface
***************
*** 13396,13409 ****
=item DESCRIPTION
=item TEST TYPES
NORMAL TESTS, SKIPPED TESTS, TODO TESTS
- =item RETURN VALUE
-
=item ONFAIL
=item SEE ALSO
=item AUTHOR
--- 15105,15136 ----
=item DESCRIPTION
+ =over 4
+
+ =item Functions
+
+ B<plan>
+
+ =back
+
+ =back
+
+ B<_to_value>
+
+ B<ok>
+
+ =over 4
+
=item TEST TYPES
NORMAL TESTS, SKIPPED TESTS, TODO TESTS
=item ONFAIL
+ =item BUGS and CAVEATS
+
+ =item TODO
+
=item SEE ALSO
=item AUTHOR
***************
*** 13424,13433 ****
B<'1..M'>, B<'ok', 'not ok'. Ok?>, B<test numbers>,
B<$Test::Harness::verbose>, B<$Test::Harness::switches>, B<Skipping tests>,
! B<Todo tests>, B<Bail out!>, B<Comments>
=back
=item EXPORT
=item DIAGNOSTICS
--- 15151,15179 ----
B<'1..M'>, B<'ok', 'not ok'. Ok?>, B<test numbers>,
B<$Test::Harness::verbose>, B<$Test::Harness::switches>, B<Skipping tests>,
! B<Todo tests>, B<Bail out!>, B<Comments>, B<Anything else>
+ =item Failure
+
+ B<Failed Test>, B<Stat>, B<Wstat>, B<Total>, B<Fail>, B<Failed>, B<List of
+ Failed>
+
+ =item Functions
+
+ B<runtests>
+
=back
+ =back
+
+ B<_globdir>
+
+ B<_run_all_tests>
+
+ B<_mk_leader>
+
+ =over 4
+
=item EXPORT
=item DIAGNOSTICS
***************
*** 13443,13456 ****
--- 15189,15311 ----
C<HARNESS_FILELEAK_IN_DIR>, C<HARNESS_PERL_SWITCHES>, C<HARNESS_COLUMNS>,
C<HARNESS_ACTIVE>
+ =item EXAMPLE
+
=item SEE ALSO
=item AUTHORS
+ =item TODO
+
=item BUGS
=back
+ =head2 Test::More - yet another framework for writing test scripts
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =over 4
+
+ =item I love it when a plan comes together
+
+ =item Test names
+
+ =item I'm ok, you're not ok.
+
+ B<ok>
+
+ =back
+
+ =back
+
+ B<is>, B<isnt>
+
+ B<like>
+
+ B<pass>, B<fail>
+
+ =over 4
+
+ =item Module tests
+
+ B<use_ok>, B<require_ok>
+
+ =back
+
+ =over 4
+
+ =item Conditional tests
+
+ B<skip> * UNIMPLEMENTED *
+
+ =back
+
+ B<todo> * UNIMPLEMENTED *
+
+ =over 4
+
+ =item Comparision functions
+
+ B<eq_array>
+
+ =back
+
+ B<eq_hash>
+
+ B<eq_set>
+
+ =over 4
+
+ =item BUGS and CAVEATS
+
+ =item AUTHOR
+
+ =item HISTORY
+
+ =item SEE ALSO
+
+ =back
+
+ =head2 Test::Simple - Basic utilities for writing tests.
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ B<ok>
+
+ =back
+
+ B<_sanity_check>
+
+ B<_whoa>
+
+ B<_my_exit>
+
+ =over 4
+
+ =item EXAMPLE
+
+ =item CAVEATS
+
+ =item HISTORY
+
+ =item AUTHOR
+
+ =item SEE ALSO
+
+ L<Test::More>, L<Test>, L<Test::Unit>, L<Pod::Tests>, L<SelfTest>,
+ L<Test::Harness>
+
+ =back
+
=head2 Text::Abbrev, abbrev - create an abbreviation table from a list
=over 4
***************
*** 13773,13778 ****
--- 15628,15660 ----
=back
+ =head2 Time::HiRes - High resolution ualarm, usleep, and gettimeofday
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ gettimeofday (), usleep ( $useconds ), ualarm ( $useconds [,
+ $interval_useconds ] ), tv_interval, time (), sleep ( $floating_seconds ),
+ alarm ( $floating_seconds [, $interval_floating_seconds ] ), setitimer,
+ getitimer ( $which )
+
+ =item EXAMPLES
+
+ =item C API
+
+ =item CAVEATS
+
+ =item AUTHORS
+
+ =item REVISION
+
+ =item COPYRIGHT
+
+ =back
+
=head2 Time::Local - efficiently compute time from local and GMT time
=over 4
***************
*** 13787,13792 ****
--- 15669,15758 ----
=back
+ =head2 Time::Piece - Object Oriented time objects
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =item USAGE
+
+ =over 4
+
+ =item Local Locales
+
+ =item Date Calculations
+
+ =item Date Comparisons
+
+ =item YYYY-MM-DDThh:mm:ss
+
+ =item Week Number
+
+ =item strftime method
+
+ %%, %a, %A, %b, %B, %c, %C, %d, %D, %e, %h, %H, %I, %j, %m, %M, %n, %p, %r,
+ %R, %S, %t, %T, %u, %U, %V, %w, %W, %x, %y, %Y, %Z
+
+ =item strptime function
+
+ =item Global Overriding
+
+ =back
+
+ =item SEE ALSO
+
+ =item AUTHOR
+
+ =over 4
+
+ =item License
+
+ =item Bugs
+
+ =back
+
+ =back
+
+ =head2 Time::Piece::Seconds, Time::Seconds - a simple API to convert
+ seconds to other date values
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =item METHODS
+
+ =item AUTHOR
+
+ =item LICENSE
+
+ =item Bugs
+
+ =back
+
+ =head2 Time::Seconds - a simple API to convert seconds to other date values
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =item METHODS
+
+ =item AUTHOR
+
+ =item LICENSE
+
+ =item Bugs
+
+ =back
+
=head2 Time::gmtime - by-name interface to Perl's built-in gmtime()
function
***************
*** 13839,13844 ****
--- 15805,15898 ----
isa ( TYPE ), can ( METHOD ), VERSION ( [ REQUIRE ] ), UNIVERSAL::isa (
VAL, TYPE ), UNIVERSAL::can ( VAL, METHOD )
+
+ =back
+
+ =head2 UnicodeCD - Unicode character database
+
+ =over 4
+
+ =item SYNOPSIS
+
+ =item DESCRIPTION
+
+ =back
+
+ =over 4
+
+ =item charinfo
+
+ =back
+
+ =over 4
+
+ =item charblock
+
+ =back
+
+ =over 4
+
+ =item charscript
+
+ =back
+
+ =over 4
+
+ =item charblocks
+
+ =back
+
+ =over 4
+
+ =item charscripts
+
+ =back
+
+ =over 4
+
+ =item Blocks versus Scripts
+
+ =item Matching Scripts and Blocks
+
+ =item Code Point Arguments
+
+ =item charinrange
+
+ =back
+
+ =over 4
+
+ =item compexcl
+
+ =back
+
+ =over 4
+
+ =item casefold
+
+ =back
+
+ =over 4
+
+ =item casespec
+
+ =back
+
+ =over 4
+
+ =item UnicodeCD::UnicodeVersion
+
+ =back
+
+ =over 4
+
+ =item Implementation Note
+
+ =back
+
+ =over 4
+
+ =item AUTHOR
=back
diff -c 'perl-5.7.1/pod/perltodo.pod' 'perl-5.7.2/pod/perltodo.pod'
Index: ./pod/perltodo.pod
*** ./pod/perltodo.pod Tue Mar 6 04:06:39 2001
--- ./pod/perltodo.pod Mon Jul 9 17:11:16 2001
***************
*** 4,11 ****
=head1 DESCRIPTION
! This is a list of wishes for Perl. It is maintained by Nathan
! Torkington for the Perl porters. Send updates to
I<perl5-porters@perl.org>. If you want to work on any of these
projects, be sure to check the perl5-porters archives for past ideas,
flames, and propaganda. This will save you time and also prevent you
--- 4,10 ----
=head1 DESCRIPTION
! This is a list of wishes for Perl. Send updates to
I<perl5-porters@perl.org>. If you want to work on any of these
projects, be sure to check the perl5-porters archives for past ideas,
flames, and propaganda. This will save you time and also prevent you
***************
*** 14,414 ****
http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/
! =head1 Infrastructure
! =head2 Mailing list archives
! Chaim suggests contacting egroup and asking them to archive the other
! perl.org mailing lists. Probably not advocacy, but definitely
! perl6-porters, etc.
! =head2 Bug tracking system
! Richard Foley I<richard@perl.org> is writing one. We looked at
! several, like gnats and the Debian system, but at the time we
! investigated them, none met our needs. Since then, Jitterbug has
! matured, and may be worth reinvestigation.
! The system we've developed is the recipient of perlbug mail, and any
! followups it generates from perl5-porters. New bugs are entered
! into a mysql database, and sent on to
! perl5-porters with the subject line rewritten to include a "ticket
! number" (unique ID for the new bug). If the incoming message already
! had a ticket number in the subject line, then the message is logged
! against that bug. There is a separate email interface (not forwarding
! to p5p) that permits porters to claim, categorize, and close tickets.
! There is also a web interface to the system at http://bugs.perl.org.
! The current delay in implementation is caused by perl.org lockups.
! One suspect is the mail handling system, possibly going into loops.
! We still desperately need a bugmaster, someone who will look at
! every new "bug" and kill those that we already know about, those
! that are not bugs at all, etc.
! =head2 Regression Tests
! The test suite for Perl serves two needs: ensuring features work, and
! ensuring old bugs have not been reintroduced. Both need work.
! Brent LaVelle (lavelle@metronet.com) has stepped forward to work on
! performance tests and improving the size of the test suite.
! =over 4
! =item Coverage
! Do the tests that come with Perl exercise every line (or every block,
! or ...) of the Perl interpreter, and if not then how can we make them
! do so?
! =item Regression
! No bug fixes should be made without a corresponding testsuite addition.
! This needs a dedicated enforcer, as the current pumpking is either too
! lazy or too stupid or both and lets enforcement wander all over the
! map. :-)
! =item __DIE__
! Tests that fail need to be of a form that can be readily mailed
! to perlbug and diagnosed with minimal back-and-forth's to determine
! which test failed, due to what cause, etc.
! =item suidperl
! We need regression/sanity tests for suidperl
! =item The 25% slowdown from perl4 to perl5
! This value may or may not be accurate, but it certainly is
! eye-catching. For some things perl5 is faster than perl4, but often
! the reliability and extensibility have come at a cost of speed. The
! benchmark suite that Gisle released earlier has been hailed as both a
! fantastic solution and as a source of entirely meaningless figures.
! Do we need to test "real applications"? Can you do so? Anyone have
! machines to dedicate to the task? Identify the things that have grown
! slower, and see if there's a way to make them faster.
! =back
! =head1 Configure
! Andy Dougherty maintain(ed|s) a list of "todo" items for the configure
! that comes with Perl. See Porting/pumpkin.pod in the latest
! source release.
! =head2 Install HTML
! Have "make install" give you the option to install HTML as well. This
! would be part of Configure. Andy Wardley (certified Perl studmuffin)
! will look into the current problems of HTML installation--is
! 'installhtml' preventing this from happening cleanly, or is pod2html
! the problem? If the latter, Brad Appleton's pod work may fix the
! problem for free.
! =head1 Perl Language
! =head2 64-bit Perl
! Verify complete 64 bit support so that the value of sysseek, or C<-s>, or
! stat(), or tell can fit into a perl number without losing precision.
! Work with the perl-64bit mailing list on perl.org.
! =head2 Prototypes
! =over 4
! =item Named prototypes
! Add proper named prototypes that actually work usefully.
! =item Indirect objects
! Fix prototype bug that forgets indirect objects.
! =item Method calls
! Prototypes for method calls.
! =item Context
! Return context prototype declarations.
! =item Scoped subs
! lexically-scoped subs, e.g. my sub
! =back
! =head1 Perl Internals
! =head2 magic_setisa
! C<magic_setisa> should be made to update %FIELDS [???]
! =head2 Garbage Collection
! There was talk of a mark-and-sweep garbage collector at TPC2, but the
! (to users) unpredictable nature of its behaviour put some off.
! Sarathy, I believe, did the work. Here's what he has to say:
! Yeah, I hope to implement it someday too. The points that were
! raised in TPC2 were all to do with calling DESTROY() methods, but
! I think we can accommodate that by extending bless() to stash
! extra information for objects so we track their lifetime accurately
! for those that want their DESTROY() to be predictable (this will be
! a speed hit, naturally, and will therefore be optional, naturally. :)
! [N.B. Don't even ask me about this now! When I have the time to
! write a cogent summary, I'll post it.]
! =head2 Reliable signals
! Sarathy and Dan Sugalski are working on this. Chip posted a patch
! earlier, but it was not accepted into 5.005. The issue is tricky,
! because it has the potential to greatly slow down the core.
! There are at least three things to consider:
! =over 4
! =item Alternate runops() for signal despatch
! Sarathy and Dan are discussed this on perl5-porters.
! =item Figure out how to die() in delayed sighandler
! =item Add tests for Thread::Signal
! =item Automatic tests against CPAN
! Is there some way to automatically build all/most of CPAN with
! the new Perl and check that the modules there pass all the tests?
! =back
! =head2 Interpolated regex performance bugs
! while (<>) {
! $found = 0;
! foreach $pat (@patterns) {
! $found++ if /$pat/o;
! }
! print if $found;
! }
! The qr// syntax added in 5.005 has solved this problem, but
! it needs more thorough documentation.
! =head2 Memory leaks from failed eval/regcomp
! The only known memory leaks in Perl are in failed code or regexp
! compilation. Fix this. Hugo Van Der Sanden will attempt this but
! won't have tuits until January 1999.
! =head2 Make XS easier to use
! There was interest in SWIG from porters, but nothing has happened
! lately.
! =head2 Make embedded Perl easier to use
! This is probably difficult for the same reasons that "XS For Dummies"
! will be difficult.
! =head2 Namespace cleanup
! CPP-space: restrict CPP symbols exported from headers
! header-space: move into CORE/perl/
! API-space: begin list of things that constitute public api
! env-space: Configure should use PERL_CONFIG instead of CONFIG etc.
! =head2 MULTIPLICITY
! Complete work on safe recursive interpreters C<Perl-E<gt>new()>.
! Sarathy says that a reference implementation exists.
! =head2 MacPerl
! Chris Nandor and Matthias Neeracher are working on better integrating
! MacPerl into the Perl distribution.
! =head1 Documentation
! There's a lot of documentation that comes with Perl. The quantity of
! documentation makes it difficult for users to know which section of
! which manpage to read in order to solve their problem. Tom
! Christiansen has done much of the documentation work in the past.
! =head2 A clear division into tutorial and reference
! Some manpages (e.g., perltoot and perlreftut) clearly set out to
! educate the reader about a subject. Other manpages (e.g., perlsub)
! are references for which there is no tutorial, or are references with
! a slight tutorial bent. If things are either tutorial or reference,
! then the reader knows which manpage to read to learn about a subject,
! and which manpage to read to learn all about an aspect of that
! subject. Part of the solution to this is:
! =head2 Remove the artificial distinction between operators and functions
! History shows us that users, and often porters, aren't clear on the
! operator-function distinction. The present split in reference
! material between perlfunc and perlop hinders user navigation. Given
! that perlfunc is by far the larger of the two, move operator reference
! into perlfunc.
! =head2 More tutorials
! More documents of a tutorial nature could help. Here are some
! candidates:
! =over 4
! =item Regular expressions
! Robin Berjon (r.berjon@ltconsulting.net) has volunteered.
! =item I/O
! Mark-Jason Dominus (mjd@plover.com) has an outline for perliotut.
! =item pack/unpack
! This is badly needed. There has been some discussion on the
! subject on perl5-porters.
! =item Debugging
! Ronald Kimball (rjk@linguist.dartmouth.edu) has volunteered.
! =back
! =head2 Include a search tool
! perldoc should be able to 'grep' fulltext indices of installed POD
! files. This would let people say:
! perldoc -find printing numbers with commas
! and get back the perlfaq entry on 'commify'.
! This solution, however, requires documentation to contain the keywords
! the user is searching for. Even when the users know what they're
! looking for, often they can't spell it.
! =head2 Include a locate tool
! perldoc should be able to help people find the manpages on a
! particular high-level subject:
! perldoc -find web
! would tell them manpages, web pages, and books with material on web
! programming. Similarly C<perldoc -find databases>, C<perldoc -find
! references> and so on.
! We need something in the vicinity of:
! % perl -help random stuff
! No documentation for perl function `random stuff' found
! The following entry in perlfunc.pod matches /random/a:
! =item rand EXPR
! =item rand
! Returns a random fractional number greater than or equal to C<0> and less
! than the value of EXPR. (EXPR should be positive.) If EXPR is
! omitted, the value C<1> is used. Automatically calls C<srand()> unless
! C<srand()> has already been called. See also C<srand()>.
! (Note: If your rand function consistently returns numbers that are too
! large or too small, then your version of Perl was probably compiled
! with the wrong number of RANDBITS.)
! The following pod pages seem to have /stuff/a:
! perlfunc.pod (7 hits)
! perlfaq7.pod (6 hits)
! perlmod.pod (4 hits)
! perlsyn.pod (3 hits)
! perlfaq8.pod (2 hits)
! perlipc.pod (2 hits)
! perl5004delta.pod (1 hit)
! perl5005delta.pod (1 hit)
! perlcall.pod (1 hit)
! perldelta.pod (1 hit)
! perlfaq3.pod (1 hit)
! perlfaq5.pod (1 hit)
! perlhist.pod (1 hit)
! perlref.pod (1 hit)
! perltoc.pod (1 hit)
! perltrap.pod (1 hit)
! Proceed to open perlfunc.pod? [y] n
! Do you want to speak perl interactively? [y] n
! Should I dial 911? [y] n
! Do you need psychiatric help? [y] y
! <PELIZA> Hi, what bothers you today?
! A Python programmer in the next cubby is driving me nuts!
! <PELIZA> Hmm, thats fixable. Just [rest censored]
! =head2 Separate function manpages by default
! Perl should install 'manpages' for every function/operator into the
! 3pl or 3p manual section. By default. The splitman program in the
! Perl source distribution does the work of turning big perlfunc into
! little 3p pages.
! =head2 Users can't find the manpages
! Make C<perldoc> tell users what they need to add to their .login or
! .cshrc to set their MANPATH correctly.
! =head2 Install ALL Documentation
! Make the standard documentation kit include the VMS, OS/2, Win32,
! Threads, etc information. installperl and pod/Makefile should know
! enough to copy README.foo to perlfoo.pod before building everything,
! when appropriate.
! =head2 Outstanding issues to be documented
! Tom has a list of 5.005_5* features or changes that require
! documentation.
! Create one document that coherently explains the delta between the
! last camel release and the current release. perldelta was supposed
! to be that, but no longer. The things in perldelta never seemed to
! get placed in the right places in the real manpages, either. This
! needs work.
! =head2 Adapt www.linuxhq.com for Perl
! This should help glorify documentation and get more people involved in
! perl development.
! =head2 Replace man with a perl program
! Can we reimplement man in Perl? Tom has a start. I believe some of
! the Linux systems distribute a manalike. Alternatively, build on
! perldoc to remove the unfeatures like "is slow" and "has no apropos".
! =head2 Unicode tutorial
! We could use more work on helping people understand Perl's new
! Unicode support that Larry has created.
! =head1 Modules
! =head2 Update the POSIX extension to conform with the POSIX 1003.1 Edition 2
! The current state of the POSIX extension is as of Edition 1, 1991,
! whereas the Edition 2 came out in 1996. ISO/IEC 9945:1-1996(E),
! ANSI/IEEE Std 1003.1, 1996 Edition. ISBN 1-55937-573-6. The updates
! were legion: threads, IPC, and real time extensions.
! =head2 Module versions
Automate the checking of versions in the standard distribution so
it's easy for a pumpking to check whether CPAN has a newer version
--- 13,387 ----
http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/
+ =head1 To do during 5.6.x
! =head2 Support for I/O disciplines
! C<perlio> provides this, but the interface could be a lot more
! straightforward.
! =head2 Eliminate need for "use utf8";
! While the C<utf8> pragma is autoloaded when necessary, it's still needed
! for things like Unicode characters in a source file. The UTF8 hint can
! always be set to true, but it needs to be set to false when F<utf8.pm>
! is being compiled. (To stop Perl trying to autoload the C<utf8>
! pragma...)
! =head2 Create a char *sv_pvprintify(sv, STRLEN *lenp, UV flags)
! For displaying PVs with control characters, embedded nulls, and Unicode.
! This would be useful for printing warnings, or data and regex dumping,
! not_a_number(), and so on.
! Requirements: should handle both byte and UTF8 strings. isPRINT()
! characters printed as-is, character less than 256 as \xHH, Unicode
! characters as \x{HHH}. Don't assume ASCII-like, either, get somebody
! on EBCDIC to test the output.
! Possible options, controlled by the flags:
! - whitespace (other than ' ' of isPRINT()) printed as-is
! - use isPRINT_LC() instead of isPRINT()
! - print control characters like this: "\cA"
! - print control characters like this: "^A"
! - non-PRINTables printed as '.' instead of \xHH
! - use \OOO instead of \xHH
! - use the C/Perl-metacharacters like \n, \t
! - have a maximum length for the produced string (read it from *lenp)
! - append a "..." to the produced string if the maximum length is exceeded
! - really fancy: print unicode characters as \N{...}
! =head2 Autoload byte.pm
! When the lexer sees, for instance, C<bytes::length>, it should
! automatically load the C<bytes> pragma.
! =head2 Make "\u{XXXX}" et al work
! Danger, Will Robinson! Discussing the semantics of C<"\x{F00}">,
! C<"\xF00"> and C<"\U{F00}"> on P5P I<will> lead to a long and boring
! flamewar.
! =head2 Overloadable regex assertions
! This may or may not be possible with the current regular expression
! engine. The idea is that, for instance, C<\b> needs to be
! algorithmically computed if you're dealing with Thai text. Hence, the
! B<\b> assertion wants to be overloaded by a function.
! =head2 Unicode collation and normalization
! Simon Cozens promises to work on this.
! Collation? http://www.unicode.org/unicode/reports/tr10/
! Normalization? http://www.unicode.org/unicode/reports/tr15/
! =head2 Unicode case mappings
! Case Mappings? http://www.unicode.org/unicode/reports/tr21/
! =head2 Unicode regular expression character classes
! They have some tricks Perl doesn't yet implement like character
! class subtraction.
! http://www.unicode.org/unicode/reports/tr18/
! =head2 use Thread for iThreads
! Artur Bergman's C<iThreads> module is a start on this, but needs to
! be more mature.
! =head2 make perl_clone optionally clone ops
! So that pseudoforking, mod_perl, iThreads and nvi will work properly
! (but not as efficiently) until the regex engine is fixed to be threadsafe.
! =head2 Work out exit/die semantics for threads
! =head2 Typed lexicals for compiler
! =head2 Compiler workarounds for Win32
! =head2 AUTOLOADing in the compiler
! =head2 Fixing comppadlist when compiling
! =head2 Cleaning up exported namespace
! =head2 Complete signal handling
! Add C<PERL_ASYNC_CHECK> to opcodes which loop; replace C<sigsetjmp> with
! C<sigjmp>; check C<wait> for signal safety.
! =head2 Out-of-source builds
! This was done for 5.6.0, but needs reworking for 5.7.x
! =head2 POSIX realtime support
! POSIX 1003.1 1996 Edition support--realtime stuff: POSIX semaphores,
! message queues, shared memory, realtime clocks, timers, signals (the
! metaconfig units mostly already exist for these)
! =head2 UNIX98 support
! Reader-writer locks, realtime/asynchronous IO
! =head2 IPv6 Support
! There are non-core modules, such as C<Net::IPv6>, but these will need
! integrating when IPv6 actually starts to really happen. See RFC 2292
! and RFC 2553.
! =head2 Long double conversion
! Floating point formatting is still causing some weird test failures.
! =head2 Locales
! Locales and Unicode interact with each other in unpleasant ways.
! One possible solution would be to adopt/support ICU:
! http://oss.software.ibm.com/developerworks/opensource/icu/project/
! =head2 Thread-safe regexes
! The regular expression engine is currently non-threadsafe.
! =head2 Arithmetic on non-Arabic numerals
! C<[1234567890]> aren't the only numerals any more.
! =head2 POSIX Unicode character classes
! ([=a=] for equivalance classes, [.ch.] for collation.)
! These are dependent on Unicode normalization and collation.
! =head2 Factoring out common suffices/prefices in regexps (trie optimization)
! Currently, the user has to optimize C<foo|far> and C<foo|goo> into
! C<f(?:oo|ar)> and C<[fg]oo> by hand; this could be done automatically.
! =head2 Security audit shipped utilities
! All the code we ship with Perl needs to be sensible about temporary file
! handling, locking, input validation, and so on.
! =head2 Custom opcodes
! Have a way to introduce user-defined opcodes without the subroutine call
! overhead of an XSUB; the user should be able to create PP code. Simon
! Cozens has some ideas on this.
! =head2 spawnvp() on Win32
! Win32 has problems spawning processes, particularly when the arguments
! to the child process contain spaces, quotes or tab characters.
! =head2 DLL Versioning
! Windows needs a way to know what version of a XS or C<libperl> DLL it's
! loading.
! =head2 Introduce @( and @)
! C<$(> may return "foo bar baz". Unfortunately, since groups can
! theoretically have spaces in their names, this could be one, two or
! three groups.
! =head2 Floating point handling
! C<NaN> and C<inf> support is particularly troublesome.
! (fp_classify(), fp_class(), fp_class_d(), class(), isinf(),
! isfinite(), finite(), isnormal(), unordered(), <ieeefp.h>,
! <fp_class.h> (there are metaconfig units for all these) (I think),
! fp_setmask(), fp_getmask(), fp_setround(), fp_getround()
! (no metaconfig units yet for these). Don't forget finitel(), fp_classl(),
! fp_class_l(), (yes, both do, unfortunately, exist), and unorderedl().)
! As of Perl 5.6.1 is a Perl macro, Perl_isnan().
! =head2 IV/UV preservation
! Nicholas Clark has done a lot of work on this, but work is continuing.
! C<+>, C<-> and C<*> work, but guards need to be in place for C<%>, C</>,
! C<&>, C<oct>, C<hex> and C<pack>.
! =head2 Replace pod2html with something using Pod::Parser
! The CPAN module C<Malik::Pod::Html> may be a more suitable basis for a
! C<pod2html> convertor; the current one duplicates the functionality
! abstracted in C<Pod::Parser>, which makes updating the POD language
! difficult.
! =head2 Automate module testing on CPAN
! When a new Perl is being beta tested, porters have to manually grab
! their favourite CPAN modules and test them - this should be done
! automatically.
! =head2 sendmsg and recvmsg
! We have all the other BSD socket functions but these. There are
! metaconfig units for these functions which can be added. To avoid these
! being new opcodes, a solution similar to the way C<sockatmark> was added
! would be preferable. (Autoload the C<IO::whatever> module.)
! =head2 Rewrite perlre documentation
! The new-style patterns need full documentation, and the whole document
! needs to be a lot clearer.
! =head2 Convert example code to IO::Handle filehandles
! =head2 Document Win32 choices
! =head2 Check new modules
! =head2 Make roffitall find pods and libs itself
! Simon Cozens has done some work on this but it needs a rethink.
! =head1 To do at some point
! These are ideas that have been regularly tossed around, that most
! people believe should be done maybe during 5.8.x
! =head2 Remove regular expression recursion
! Because the regular expression engine is recursive, badly designed
! expressions can lead to lots of recursion filling up the stack. Ilya
! claims that it is easy to convert the engine to being iterative, but
! this has still not yet been done. There may be a regular expression
! engine hit squad meeting at TPC5.
! =head2 Memory leaks after failed eval
! Perl will leak memory if you C<eval "hlagh hlagh hlagh hlagh">. This is
! partially because it attempts to build up an op tree for that code and
! doesn't properly free it. The same goes for non-syntactically-correct
! regular expressions. Hugo looked into this, but decided it needed a
! mark-and-sweep GC implementation.
! Alan notes that: The basic idea was to extend the parser token stack
! (C<YYSTYPE>) to include a type field so we knew what sort of thing each
! element of the stack was. The F<<perly.c> code would then have to be
! postprocessed to record the type of each entry on the stack as it was
! created, and the parser patched so that it could unroll the stack
! properly on error.
! This is possible to do, but would be pretty messy to implement, as it
! would rely on even more sed hackery in F<perly.fixer>.
! =head2 pack "(stuff)*"
! That's to say, C<pack "(sI)40"> would be the same as C<pack "sI"x40>
! =head2 bitfields in pack
! =head2 Cross compilation
! Make Perl buildable with a cross-compiler. This will play havoc with
! Configure, which needs to how how the target system will respond to
! its tests; maybe C<microperl> will be a good starting point here.
! (Indeed, Bart Schuller reports that he compiled up C<microperl> for
! the Agenda PDA and it works fine.) A really big spanner in the works
! is the bootstrapping build process of Perl: if the filesystem the
! target systems sees is not the same what the build host sees, various
! input, output, and (Perl) library files need to be copied back and forth.
! =head2 Perl preprocessor / macros
! Source filters help with this, but do not get us all the way. For
! instance, it should be possible to implement the C<??> operator somehow;
! source filters don't (quite) cut it.
! =head2 Perl lexer in Perl
! Damian Conway is planning to work on this, but it hasn't happened yet.
! =head2 Using POSIX calls internally
! When faced with a BSD vs. SySV -style interface to some library or
! system function, perl's roots show in that it typically prefers the BSD
! interface (but falls back to the SysV one). One example is getpgrp().
! Other examples include C<memcpy> vs. C<bcopy>. There are others, mostly in
! F<<pp_sys.c>.
! Mostly, this item is a suggestion for which way to start a journey into
! an C<#ifdef> forest. It is not primarily a suggestion to eliminate any of
! the C<#ifdef> forests.
! POSIX calls are perhaps more likely to be portable to unexpected
! architectures. They are also perhaps more likely to be actively
! maintained by a current vendor. They are also perhaps more likely to be
! available in thread-safe versions, if appropriate.
! =head2 -i rename file when changed
! It's only necessary to rename a file when inplace editing when the file
! has changed. Detecting a change is perhaps the difficult bit.
! =head2 All ARGV input should act like E<lt>E<gt>
! =head2 Support for rerunning debugger
! There should be a way of restarting the debugger on demand.
! =head2 Test Suite for the Debugger
! The debugger is a complex piece of software and fixing something
! here may inadvertently break something else over there. To tame
! this chaotic behaviour, a test suite is necessary.
! =head2 my sub foo { }
! The basic principle is sound, but there are problems with the semantics
! of self-referential and mutually referential lexical subs: how to
! declare the subs?
! =head2 One-pass global destruction
! Sweeping away all the allocated memory in one go is a laudable goal, but
! it's difficult and in most cases, it's easier to let the memory get
! freed by exiting.
! =head2 Rewrite regexp parser
! There has been talk recently of rewriting the regular expression parser
! to produce an optree instead of a chain of opcodes; it's unclear whether
! or not this would be a win.
! =head2 Cache recently used regexps
! This is to speed up
! for my $re (@regexps) {
! $matched++ if /$re/
! }
! C<qr//> already gives us a way of saving compiled regexps, but it should
! be done automatically.
! =head2 Re-entrant functions
! Add configure probes for C<_r> forms of system calls and fit them to the
! core. Unfortunately, calling conventions for these functions and not
! standardised.
! =head2 Cross-compilation support
! Bart Schuller reports that using C<microperl> and a cross-compiler, he
! got Perl working on the Agenda PDA. However, one cannot build a full
! Perl because Configure needs to get the results for the target platform,
! for the host.
! =head2 Bit-shifting bitvectors
! Given:
! vec($v, 1000, 1) = 1;
One should be able to do
***************
*** 410,746 ****
=head2 Module versions
! Automate the checking of versions in the standard distribution so
! it's easy for a pumpking to check whether CPAN has a newer version
! that we should be including?
! =head2 New modules
! Which modules should be added to the standard distribution? This ties
! in with the SDK discussed on the perl-sdk list at perl.org.
! =head2 Profiler
! Make the profiler (Devel::DProf) part of the standard release, and
! document it well.
! =head2 Tie Modules
! =over 4
! =item VecArray
! Implement array using vec(). Nathan Torkington has working code to
! do this.
! =item SubstrArray
! Implement array using substr()
! =item VirtualArray
! Implement array using a file
! =item ShiftSplice
! Defines shift et al in terms of splice method
! =back
! =head2 Procedural options
! Support procedural interfaces for the common cases of Perl's
! gratuitously OOO modules. Tom objects to "use IO::File" reading many
! thousands of lines of code.
! =head2 RPC
! Write a module for transparent, portable remote procedure calls. (Not
! core). This touches on the CORBA and ILU work.
! =head2 y2k localtime/gmtime
! Write a module, Y2k::Catch, which overloads localtime and gmtime's
! returned year value and catches "bad" attempts to use it.
! =head2 Export File::Find variables
! Make File::Find export C<$name> etc manually, at least if asked to.
! =head2 Ioctl
! Finish a proper Ioctl module.
! =head2 Debugger attach/detach
! Permit a user to debug an already-running program.
! =head2 Regular Expression debugger
! Create a visual profiler/debugger tool that stepped you through the
! execution of a regular expression point by point. Ilya has a module
! to color-code and display regular expression parses and executions.
! There's something at http://tkworld.org/ that might be a good start,
! it's a Tk/Tcl RE wizard, that builds regexen of many flavours.
! =head2 Alternative RE Syntax
! Make an alternative regular expression syntax that is accessed through
! a module. For instance,
! use RE;
! $re = start_of_line()
! ->literal("1998/10/08")
! ->optional( whitespace() )
! ->literal("[")
! ->remember( many( or( "-", digit() ) ) );
! if (/$re/) {
! print "time is $1\n";
! }
! Newbies to regular expressions typically only use a subset of the full
! language. Perhaps you wouldn't have to implement the full feature set.
! =head2 Bundled modules
! Nicholas Clark (nick@flirble.org) had a patch for storing modules in
! zipped format. This needs exploring and concluding.
! =head2 Expect
! Adopt IO::Tty, make it as portable as Don Libes' "expect" (can we link
! against expect code?), and perfect a Perl version of expect. IO::Tty
! and expect could then be distributed as part of the core distribution,
! replacing Comm.pl and other hacks.
! =head2 GUI::Native
! A simple-to-use interface to native graphical abilities would
! be welcomed. Oh, Perl's access Tk is nice enough, and reasonably
! portable, but it's not particularly as fast as one would like.
! Simple access to the mouse's cut buffer or mouse-presses shouldn't
! required loading a few terabytes of Tk code.
! =head2 Update semibroken auxiliary tools; h2ph, a2p, etc.
! Kurt Starsinic is working on h2ph. mjd has fixed bugs in a2p in the
! past. a2p apparently doesn't work on nawk and gawk extensions.
! Graham Barr has an Include module that does h2ph work at runtime.
! =head2 pod2html
! A short-term fix: pod2html generates absolute HTML links. Make it
! generate relative links.
! =head2 Podchecker
! Something like lint for Pod would be good. Something that catches
! common errors as well as gross ones. Brad Appleton is putting
! together something as part of his PodParser work.
! =head1 Tom's Wishes
! =head2 Webperl
! Design a webperl environment that's as tightly integrated and as
! easy-to-use as Perl's current command-line environment.
! =head2 Mobile agents
! More work on a safe and secure execution environment for mobile
! agents would be neat; the Safe.pm module is a start, but there's a
! still a lot to be done in that area. Adopt Penguin?
! =head2 POSIX on non-POSIX
! Standard programming constructs for non-POSIX systems would help a
! lot of programmers stuck on primitive, legacy systems. For example,
! Microsoft still hasn't made a usable POSIX interface on their clunky
! systems, which means that standard operations such as alarm() and
! fork(), both critical for sophisticated client-server programming,
! must both be kludged around.
! I'm unsure whether Tom means to emulate alarm( )and fork(), or merely
! to provide a document like perlport.pod to say which features are
! portable and which are not.
! =head2 Portable installations
! Figure out a portable semi-gelled installation, that is, one without
! full paths. Larry has said that he's thinking about this. Ilya
! pointed out that perllib_mangle() is good for this.
! =head1 Win32 Stuff
! =head2 Rename new headers to be consistent with the rest
! =head2 Sort out the spawnvp() mess
! =head2 Work out DLL versioning
! =head2 Style-check
! =head1 Would be nice to have
! =over 4
! =item C<pack "(stuff)*">
! =item Contiguous bitfields in pack/unpack
! =item lexperl
! =item Bundled perl preprocessor
! =item Use posix calls internally where possible
! =item format BOTTOM
! =item -i rename file only when successfully changed
! =item All ARGV input should act like <>
! =item report HANDLE [formats].
! =item support in perlmain to rerun debugger
! =item lvalue functions
! Tuomas Lukka, on behalf of the PDL project, greatly desires this and
! Ilya has a patch for it (probably against an older version of Perl).
! Tuomas points out that what PDL really wants is lvalue I<methods>,
! not just subs.
! =back
! =head1 Possible pragmas
! =head2 'less'
! (use less memory, CPU)
! =head1 Optimizations
! =head2 constant function cache
! =head2 foreach(reverse...)
! =head2 Cache eval tree
! Unless lexical outer scope used (mark in &compiling?).
! =head2 rcatmaybe
! =head2 Shrink opcode tables
! Via multiple implementations selected in peep.
! =head2 Cache hash value
! Not a win, according to Guido.
! =head2 Optimize away @_ where possible
! =head2 Optimize sort by { $a <=> $b }
! Greg Bacon added several more sort optimizations. These have
! made it into 5.005_55, thanks to Hans Mulder.
! =head2 Rewrite regexp parser for better integrated optimization
! The regexp parser was rewritten for 5.005. Ilya's the regexp guru.
! =head1 Vague possibilities
! =over 4
! =item ref function in list context
! This seems impossible to do without substantially breaking code.
! =item make tr/// return histogram in list context?
! =item Loop control on do{} et al
! =item Explicit switch statements
! Nobody has yet managed to come up with a switch syntax that would
! allow for mixed hash, constant, regexp checks. Submit implementation
! with syntax, please.
! =item compile to real threaded code
! =item structured types
! =item Modifiable $1 et al
! The intent is for this to be a means of editing the matched portions of
! the target string.
! =back
! =head1 To Do Or Not To Do
! These are things that have been discussed in the past and roundly
! criticized for being of questionable value.
! =head2 Making my() work on "package" variables
! Being able to say my($Foo::Bar), something that sounds ludicrous and
! the 5.6 pumpking has mocked.
! =head2 "or" testing defined not truth
! We tell people that C<||> can be used to give a default value to a
! variable:
! $children = shift || 5; # default is 5 children
! which is almost (but not):
! $children = shift;
! $children = 5 unless $children;
! but if the first argument was given and is "0", then it will be
! considered false by C<||> and C<5> used instead. Really we want
! an C<||>-like operator that behaves like:
! $children = shift;
! $children = 5 unless defined $children;
! Namely, a C<||> that tests defined-ness rather than truth. One was
! discussed, and a patch submitted, but the objections were many. While
! there were objections, many still feel the need. At least it was
! decided that C<??> is the best name for the operator.
! =head2 "dynamic" lexicals
! my $x;
! sub foo {
! local $x;
! }
! Localizing, as Tim Bunce points out, is a separate concept from
! whether the variable is global or lexical. Chip Salzenberg had
! an implementation once, but Larry thought it had potential to
! confuse.
! =head2 "class"-based, rather than package-based "lexicals"
! This is like what the Alias module provides, but the variables would
! be lexicals reserved by perl at compile-time, which really are indices
! pointing into the pseudo-hash object visible inside every method so
! declared.
! =head1 Threading
! =head2 Modules
! Which of the standard modules are thread-safe? Which CPAN modules?
! How easy is it to fix those non-safe modules?
! =head2 Testing
Threading is still experimental. Every reproducible bug identifies
something else for us to fix. Find and submit more of these problems.
--- 383,689 ----
vec($v, 1000, 1) = 1;
! One should be able to do
! $v <<= 1;
! and have the 999'th bit set.
! Currently if you try with shift bitvectors you shift the NV/UV, instead
! of the bits in the PV. Not very logical.
! =head2 debugger pragma
! The debugger is implemented in Perl in F<perl5db.pl>; turning it into a
! pragma should be easy, but making it work lexically might be more
! difficult. Fiddling with C<$^P> would be necessary.
! =head2 use less pragma
! Identify areas where speed/memory tradeoffs can be made and have a hint
! to switch between them.
! =head2 switch structures
! Although we have C<Switch.pm> in core, Larry points to the dormant
! C<nswitch> and C<cswitch> ops in F<pp.c>; using these opcodes would be
! much faster.
! =head2 Cache eval tree
! =head2 rcatmaybe
! =head2 Shrink opcode tables
! =head2 Optimize away @_
! Look at the "reification" code in C<av.c>
! =head2 Prototypes versus indirect objects
! Currently, indirect object syntax bypasses prototype checks.
! =head2 Install HMTL
! HTML versions of the documentation need to be installed by default; a
! call to C<installhtml> from C<installperl> may be all that's necessary.
! =head2 Prototype method calls
! =head2 Return context prototype declarations
! =head2 magic_setisa
! =head2 Garbage collection
! There have been persistent mumblings about putting a mark-and-sweep
! garbage detector into Perl; Alan Burlison has some ideas about this.
! =head2 IO tutorial
! Mark-Jason Dominus has the beginnings of one of these.
! =head2 pack/unpack tutorial
! Simon Cozens has the beginnings of one of these.
! =head2 Rewrite perldoc
! There are a few suggestions for what to do with C<perldoc>: maybe a
! full-text search, an index function, locating pages on a particular
! high-level subject, and so on.
! =head2 Install .3p manpages
! This is a bone of contention; we can create C<.3p> manpages for each
! built-in function, but should we install them by default? Tcl does this,
! and it clutters up C<apropos>.
! =head2 Unicode tutorial
! Simon Cozens promises to do this before he gets old.
! =head2 Update POSIX.pm for 1003.1-2
! =head2 Retargetable installation
! Allow C<@INC> to be changed after Perl is built.
! =head2 POSIX emulation on non-POSIX systems
! Make C<POSIX.pm> behave as POSIXly as possible everywhere, meaning we
! have to implement POSIX equivalents for some functions if necessary.
! =head2 Rename Win32 headers
! =head2 Finish off lvalue functions
! They don't work in the debugger, and they don't work for list or hash
! slices.
! =head2 Update sprintf documentation
! Hugo van der Sanden plans to look at this.
! =head2 Use fchown/fchmod internally
! This has been done in places, but needs a thorough code review.
! Also fchdir is available in some platforms.
! =head1 Vague ideas
! Ideas which have been discussed, and which may or may not happen.
! =head2 ref() in list context
! It's unclear what this should do or how to do it without breaking old
! code.
! =head2 Make tr/// return histogram
! There is a patch for this, but it may require Unicodification.
! =head2 Compile to real threaded code
! =head2 Structured types
! =head2 Modifiable $1 et al.
! ($x = "elephant") =~ /e(ph)/;
! $1 = "g"; # $x = "elegant"
! What happens if there are multiple (nested?) brackets? What if the
! string changes between the match and the assignment?
! =head2 Procedural interfaces for IO::*, etc.
! Some core modules have been accused of being overly-OO. Adding
! procedural interfaces could demystify them.
! =head2 RPC modules
! =head2 Attach/detach debugger from running program
! With C<gdb>, you can attach the debugger to a running program if you
! pass the process ID. It would be good to do this with the Perl debugger
! on a running Perl program, although I'm not sure how it would be done.
! =head2 Alternative RE syntax module
! use Regex::Newbie;
! $re = Regex::Newbie->new
! ->start
! ->match("foo")
! ->repeat(Regex::Newbie->class("char"),3)
! ->end;
! /$re/;
! =head2 GUI::Native
! A non-core module that would use "native" GUI to create graphical
! applications.
! =head2 foreach(reverse ...)
! Currently
! foreach (reverse @_) { ... }
! puts C<@_> on the stack, reverses it putting the reversed version on the
! stack, then iterates forwards. Instead, it could be special-cased to put
! C<@_> on the stack then iterate backwards.
! =head2 Constant function cache
! =head2 Approximate regular expression matching
! =head1 Ongoing
! These items B<always> need doing:
! =head2 Update guts documentation
! Simon Cozens tries to do this when possible, and contributions to the
! C<perlapi> documentation is welcome.
! =head2 Add more tests
! Michael Schwern will donate $500 to Yet Another Society when all core
! modules have tests.
! =head2 Update auxiliary tools
! The code we ship with Perl should look like good Perl 5.
! =head1 Recently done things
! These are things which have been on the todo lists in previous releases
! but have recently been completed.
! =head2 Safe signal handling
! A new signal model went into 5.7.1 without much fanfare. Operations and
! C<malloc>s are no longer interrupted by signals, which are handled
! between opcodes. This means that C<PERL_ASYNC_CHECK> now actually does
! something. However, there are still a few things that need to be done.
! =head2 Tie Modules
! Modules which implement arrays in terms of strings, substrings or files
! can be found on the CPAN.
! =head2 gettimeofday
! C<Time::Hires> has been integrated into the core.
! =head2 setitimer and getimiter
! Adding C<Time::Hires> got us this too.
! =head2 Testing __DIE__ hook
! Tests have been added.
! =head2 CPP equivalent in Perl
! A C Yardley will probably have done this by the time you can read this.
! This allows for a generalization of the C constant detection used in
! building C<Errno.pm>.
! =head2 Explicit switch statements
! C<Switch.pm> has been integrated into the core to give you all manner of
! C<switch...case> semantics.
! =head2 autocroak
! This is C<Fatal.pm>.
! =head2 UTF/EBCDIC
! Nick Ing-Simmons has made UTF-EBCDIC (UTR13) work with Perl.
! EBCDIC? http://www.unicode.org/unicode/reports/tr16/
! =head2 UTF Regexes
! Although there are probably some small bugs to be rooted out, Jarkko
! Hietaniemi has made regular expressions polymorphic between bytes and
! characters.
! =head2 perlcc to produce executable
! C<perlcc> was recently rewritten, and can now produce standalone
! executables.
! =head2 END blocks saved in compiled output
! =head2 Secure temporary file module
! Tim Jenness' C<File::Temp> is now in core.
! =head2 Integrate Time::HiRes
! This module is now part of core.
! =head2 Turn Cwd into XS
! Benjamin Sugars has done this.
! =head2 Mmap for input
! Nick Ing-Simmons' C<perlio> supports an C<mmap> IO method.
! =head2 Byte to/from UTF8 and UTF8 to/from local conversion
! C<Encode> provides this.
! =head2 Add sockatmark support
! Added in 5.7.1
! =head2 Mailing list archives
! http://lists.perl.org/, http://archive.develooper.com/
! =head2 Bug tracking
! Richard Foley has written the bug tracking system at http://bugs.perl.org/
! =head2 Integrate MacPerl
! Chris Nandor and Matthias Neeracher have integrated the MacPerl changes
! into 5.6.0.
! =head2 Web "nerve center" for Perl
! http://use.perl.org/ is what you're looking for.
! =head2 Regular expression tutorial
! C<perlretut>, provided by Mark Kvale.
! =head2 Debugging Tutorial
C<perldebtut>, written by Richard Foley.
***************
*** 742,858 ****
=head2 Testing
! Threading is still experimental. Every reproducible bug identifies
! something else for us to fix. Find and submit more of these problems.
! =head2 $AUTOLOAD
! =head2 exit/die
! Consistent semantics for exit/die in threads.
! =head2 External threads
! Better support for externally created threads.
! =head2 Thread::Pool
! =head2 thread-safety
! Spot-check globals like statcache and global GVs for thread-safety.
! "B<Part done>", says Sarathy.
! =head2 Per-thread GVs
! According to Sarathy, this would make @_ be the same in threaded
! and non-threaded, as well as helping solve problems like filehandles
! (the same filehandle currently cannot be used in two threads).
! =head1 Compiler
! =head2 Optimization
! The compiler's back-end code-generators for creating bytecode or
! compilable C code could use optimization work.
! =head2 Byteperl
! Figure out how and where byteperl will be built for the various
! platforms.
! =head2 Precompiled modules
! Save byte-compiled modules on disk.
! =head2 Executables
! Auto-produce executable.
! =head2 Typed lexicals
! Typed lexicals should affect B::CC::load_pad.
! =head2 Win32
! Workarounds to help Win32 dynamic loading.
! =head2 END blocks
! END blocks need saving in compiled output, now that CHECK blocks
! are available.
! =head2 _AUTOLOAD
! _AUTOLOAD prodding.
! =head2 comppadlist
! Fix comppadlist (names in comppad_name can have fake SvCUR
! from where newASSIGNOP steals the field).
! =head2 Cached compilation
! Can we install modules as bytecode?
! =head1 Recently Finished Tasks
! =head2 Figure a way out of $^(capital letter)
! Figure out a clean way to extend $^(capital letter) beyond
! the 26 alphabets. (${^WORD} maybe?)
! Mark-Jason Dominus sent a patch which went into 5.005_56.
! =head2 Filenames
! Keep filenames in the distribution and in the standard module set
! be 8.3 friendly where feasible. Good luck changing the standard
! modules, though.
! =head2 Foreign lines
! Perl should be more generous in accepting foreign line terminations.
! Mostly B<done> in 5.005.
! =head2 Namespace cleanup
! symbol-space: "pl_" prefix for all global vars
! "Perl_" prefix for all functions
! CPP-space: stop malloc()/free() pollution unless asked
! =head2 ISA.pm
! Rename and alter ISA.pm. B<Done>. It is now base.pm.
! =head2 gettimeofday
! See Time::HiRes.
! =head2 autocroak?
! This is the Fatal.pm module, so any builtin that does
! not return success automatically die()s. If you're feeling brave, tie
! this in with the unified exceptions scheme.
! =cut
--- 685,812 ----
=head2 Debugging Tutorial
! C<perldebtut>, written by Richard Foley.
! =head2 Integrate new modules
! Jarkko has been integrating madly into 5.7.x
! =head2 Integrate profiler
! C<Devel::DProf> is now a core module.
! =head2 Y2K error detection
! There's a configure option to detect unsafe concatenation with "19", and
! a CPAN module. (C<D'oh::Year>)
! =head2 Regular expression debugger
! While not part of core, Mark-Jason Dominus has written C<Rx> and has
! also come up with a generalised strategy for regular expression
! debugging.
! =head2 POD checker
! That's, uh, F<podchecker>
! =head2 "Dynamic" lexicals
! =head2 Cache precompiled modules
! =head1 Deprecated Wishes
! These are items which used to be in the todo file, but have been
! deprecated for some reason.
! =head2 Loop control on do{}
! This would break old code; use C<do{{ }}> instead.
! =head2 Lexically scoped typeglobs
! Not needed now we have lexical IO handles.
! =head2 format BOTTOM
! =head2 report HANDLE
! Damian Conway's text formatting modules seem to be the Way To Go.
! =head2 Generalised want()/caller())
! =head2 Named prototypes
! These both seem to be delayed until Perl 6.
! =head2 Built-in globbing
! The C<File::Glob> module has been used to replace the C<glob> function.
! =head2 Regression tests for suidperl
! C<suidperl> is deprecated in favour of common sense.
! =head2 Cached hash values
! We have shared hash keys, which perform the same job.
! =head2 Add compression modules
! The compression modules are a little heavy; meanwhile, Nick Clark is
! working on experimental pragmata to do transparent decompression on
! input.
! =head2 Reorganise documentation into tutorials/references
! Could not get consensus on P5P about this.
! =head2 Remove distinction between functions and operators
! Caution: highly flammable.
! =head2 Make XS easier to use
! Use C<Inline> instead, or SWIG.
! =head2 Make embedding easier to use
! Use C<Inline::CPR>.
! =head2 man for perl
! See the Perl Power Tools. (http://language.perl.com/ppt/)
! =head2 my $Package::variable
! Use C<our> instead.
! =head2 "or" tests defined, not truth
! Suggesting this on P5P B<will> cause a boring and interminable flamewar.
! =head2 "class"-based lexicals
! Use flyweight objects, secure hashes or, dare I say it, pseudo-hashes instead.
! =head2 byteperl
!
! C<ByteLoader> covers this.
!
! =head2 Lazy evaluation / tail recursion removal
!
! C<List::Util> in core gives some of these; tail recursion removal is
! done manually, with C<goto &whoami;>. (However, MJD has found that
! C<goto &whoami> introduces a performance penalty, so maybe there should
! be a way to do this after all: C<sub foo {START: ... goto START;> is
! better.)
!
! =head2 Make "use utf8" the default
!
! There is a patch available for this, search p5p archives for
! the Subject "[EXPERIMENTAL PATCH] make unicode (utf8) default"
! but this would be unacceptable because of backward compatibility:
! scripts could not contain B<any legacy eight-bit data>. Also would
! introduce a measurable slowdown of at least few percentages since all
! regular expression operations would be done in full UTF-8.
!
diff -c 'perl-5.7.1/pod/perlunicode.pod' 'perl-5.7.2/pod/perlunicode.pod'
Index: ./pod/perlunicode.pod
*** ./pod/perlunicode.pod Mon Apr 9 16:25:57 2001
--- ./pod/perlunicode.pod Mon Jul 9 17:11:16 2001
***************
*** 9,21 ****
WARNING: While the implementation of Unicode support in Perl is now fairly
complete it is still evolving to some extent.
! In particular the way Unicode is handled on EBCDIC platforms is still rather
! experimental. On such a platform references to UTF-8 encoding in this
! document and elsewhere should be read as meaning UTF-EBCDIC as specified
! in Unicode Technical Report 16 unless ASCII vs EBCDIC issues are specifically
! discussed. There is no C<utfebcdic> pragma or ":utfebcdic" layer, rather
! "utf8" and ":utf8" are re-used to mean platform's "natural" 8-bit encoding
! of Unicode. See L<perlebcdic> for more discussion of the issues.
The following areas are still under development.
--- 9,22 ----
WARNING: While the implementation of Unicode support in Perl is now fairly
complete it is still evolving to some extent.
! In particular the way Unicode is handled on EBCDIC platforms is still
! rather experimental. On such a platform references to UTF-8 encoding
! in this document and elsewhere should be read as meaning UTF-EBCDIC as
! specified in Unicode Technical Report 16 unless ASCII vs EBCDIC issues
! are specifically discussed. There is no C<utfebcdic> pragma or
! ":utfebcdic" layer, rather "utf8" and ":utf8" are re-used to mean
! platform's "natural" 8-bit encoding of Unicode. See L<perlebcdic> for
! more discussion of the issues.
The following areas are still under development.
***************
*** 23,54 ****
=item Input and Output Disciplines
! A filehandle can be marked as containing perl's internal Unicode encoding
! (UTF-8 or UTF-EBCDIC) by opening it with the ":utf8" layer.
Other encodings can be converted to perl's encoding on input, or from
! perl's encoding on output by use of the ":encoding()" layer.
! There is not yet a clean way to mark the perl source itself as being
! in an particular encoding.
=item Regular Expressions
The regular expression compiler does now attempt to produce
polymorphic opcodes. That is the pattern should now adapt to the data
! and automatically switch to the Unicode character scheme when presented
! with Unicode data, or a traditional byte scheme when presented with
! byte data. The implementation is still new and (particularly on
! EBCDIC platforms) may need further work.
=item C<use utf8> still needed to enable a few features
! The C<utf8> pragma implements the tables used for Unicode support. These
! tables are automatically loaded on demand, so the C<utf8> pragma need not
! normally be used.
! However, as a compatibility measure, this pragma must be explicitly used
! to enable recognition of UTF-8 encoded literals and identifiers in the
! source text on ASCII based machines or recognize UTF-EBCDIC encoded literals
! and identifiers on EBCDIC based machines.
=back
--- 24,55 ----
=item Input and Output Disciplines
! A filehandle can be marked as containing perl's internal Unicode
! encoding (UTF-8 or UTF-EBCDIC) by opening it with the ":utf8" layer.
Other encodings can be converted to perl's encoding on input, or from
! perl's encoding on output by use of the ":encoding()" layer. There is
! not yet a clean way to mark the Perl source itself as being in an
! particular encoding.
=item Regular Expressions
The regular expression compiler does now attempt to produce
polymorphic opcodes. That is the pattern should now adapt to the data
! and automatically switch to the Unicode character scheme when
! presented with Unicode data, or a traditional byte scheme when
! presented with byte data. The implementation is still new and
! (particularly on EBCDIC platforms) may need further work.
=item C<use utf8> still needed to enable a few features
! The C<utf8> pragma implements the tables used for Unicode support.
! These tables are automatically loaded on demand, so the C<utf8> pragma
! need not normally be used.
! However, as a compatibility measure, this pragma must be explicitly
! used to enable recognition of UTF-8 encoded literals and identifiers
! in the source text on ASCII based machines or recognize UTF-EBCDIC
! encoded literals and identifiers on EBCDIC based machines.
=back
***************
*** 58,73 ****
represent strings internally. This internal representation of strings
uses either the UTF-8 or the UTF-EBCDIC encoding.
! In future, Perl-level operations can be expected to work with characters
! rather than bytes, in general.
! However, as strictly an interim compatibility measure, Perl v5.6 aims to
! provide a safe migration path from byte semantics to character semantics
! for programs. For operations where Perl can unambiguously decide that the
! input data is characters, Perl now switches to character semantics.
! For operations where this determination cannot be made without additional
! information from the user, Perl decides in favor of compatibility, and
! chooses to use byte semantics.
This behavior preserves compatibility with earlier versions of Perl,
which allowed byte semantics in Perl operations, but only as long as
--- 59,74 ----
represent strings internally. This internal representation of strings
uses either the UTF-8 or the UTF-EBCDIC encoding.
! In future, Perl-level operations can be expected to work with
! characters rather than bytes, in general.
! However, as strictly an interim compatibility measure, Perl aims to
! provide a safe migration path from byte semantics to character
! semantics for programs. For operations where Perl can unambiguously
! decide that the input data is characters, Perl now switches to
! character semantics. For operations where this determination cannot
! be made without additional information from the user, Perl decides in
! favor of compatibility, and chooses to use byte semantics.
This behavior preserves compatibility with earlier versions of Perl,
which allowed byte semantics in Perl operations, but only as long as
***************
*** 76,95 ****
external programs, from information provided by the system (such as %ENV),
or from literals and constants in the source text.
! If the C<-C> command line switch is used, (or the ${^WIDE_SYSTEM_CALLS}
! global flag is set to C<1>), all system calls will use the
! corresponding wide character APIs. This is currently only implemented
! on Windows since UNIXes lack API standard on this area.
! Regardless of the above, the C<bytes> pragma can always be used to force
! byte semantics in a particular lexical scope. See L<bytes>.
The C<utf8> pragma is primarily a compatibility device that enables
! recognition of UTF-(8|EBCDIC) in literals encountered by the parser. It may also
! be used for enabling some of the more experimental Unicode support features.
! Note that this pragma is only required until a future version of Perl
! in which character semantics will become the default. This pragma may
! then become a no-op. See L<utf8>.
Unless mentioned otherwise, Perl operators will use character semantics
when they are dealing with Unicode data, and byte semantics otherwise.
--- 77,97 ----
external programs, from information provided by the system (such as %ENV),
or from literals and constants in the source text.
! If the C<-C> command line switch is used, (or the
! ${^WIDE_SYSTEM_CALLS} global flag is set to C<1>), all system calls
! will use the corresponding wide character APIs. Note that this is
! currently only implemented on Windows since other platforms API
! standard on this area.
! Regardless of the above, the C<bytes> pragma can always be used to
! force byte semantics in a particular lexical scope. See L<bytes>.
The C<utf8> pragma is primarily a compatibility device that enables
! recognition of UTF-(8|EBCDIC) in literals encountered by the parser.
! It may also be used for enabling some of the more experimental Unicode
! support features. Note that this pragma is only required until a
! future version of Perl in which character semantics will become the
! default. This pragma may then become a no-op. See L<utf8>.
Unless mentioned otherwise, Perl operators will use character semantics
when they are dealing with Unicode data, and byte semantics otherwise.
***************
*** 101,118 ****
on Unicode data, the C<bytes> pragma should be used.
Under character semantics, many operations that formerly operated on
! bytes change to operating on characters. For ASCII data this makes
! no difference, because UTF-8 stores ASCII in single bytes, but for
! any character greater than C<chr(127)>, the character may be stored in
a sequence of two or more bytes, all of which have the high bit set.
- For C1 controls or Latin 1 characters on an EBCDIC platform the character
- may be stored in a UTF-EBCDIC multi byte sequence.
- But by and large, the user need not worry about this, because Perl
- hides it from the user. A character in Perl is logically just a number
- ranging from 0 to 2**32 or so. Larger characters encode to longer
- sequences of bytes internally, but again, this is just an internal
- detail which is hidden at the Perl level.
=head2 Effects of character semantics
Character semantics have the following effects:
--- 103,121 ----
on Unicode data, the C<bytes> pragma should be used.
Under character semantics, many operations that formerly operated on
! bytes change to operating on characters. For ASCII data this makes no
! difference, because UTF-8 stores ASCII in single bytes, but for any
! character greater than C<chr(127)>, the character B<may> be stored in
a sequence of two or more bytes, all of which have the high bit set.
+ For C1 controls or Latin 1 characters on an EBCDIC platform the
+ character may be stored in a UTF-EBCDIC multi byte sequence. But by
+ and large, the user need not worry about this, because Perl hides it
+ from the user. A character in Perl is logically just a number ranging
+ from 0 to 2**32 or so. Larger characters encode to longer sequences
+ of bytes internally, but again, this is just an internal detail which
+ is hidden at the Perl level.
+
=head2 Effects of character semantics
Character semantics have the following effects:
***************
*** 124,156 ****
Strings and patterns may contain characters that have an ordinal value
larger than 255.
! Presuming you use a Unicode editor to edit your program, such characters
! will typically occur directly within the literal strings as UTF-(8|EBCDIC)
! characters, but you can also specify a particular character with an
! extension of the C<\x> notation. UTF-X characters are specified by
! putting the hexadecimal code within curlies after the C<\x>. For instance,
! a Unicode smiley face is C<\x{263A}>.
=item *
Identifiers within the Perl script may contain Unicode alphanumeric
characters, including ideographs. (You are currently on your own when
! it comes to using the canonical forms of characters--Perl doesn't (yet)
! attempt to canonicalize variable names for you.)
=item *
Regular expressions match characters instead of bytes. For instance,
"." matches a character instead of a byte. (However, the C<\C> pattern
! is provided to force a match a single byte ("C<char>" in C, hence
! C<\C>).)
=item *
Character classes in regular expressions match characters instead of
bytes, and match against the character properties specified in the
! Unicode properties database. So C<\w> can be used to match an ideograph,
! for instance.
=item *
--- 127,159 ----
Strings and patterns may contain characters that have an ordinal value
larger than 255.
! Presuming you use a Unicode editor to edit your program, such
! characters will typically occur directly within the literal strings as
! UTF-8 (or UTF-EBCDIC on EBCDIC platforms) characters, but you can also
! specify a particular character with an extension of the C<\x>
! notation. UTF-X characters are specified by putting the hexadecimal
! code within curlies after the C<\x>. For instance, a Unicode smiley
! face is C<\x{263A}>.
=item *
Identifiers within the Perl script may contain Unicode alphanumeric
characters, including ideographs. (You are currently on your own when
! it comes to using the canonical forms of characters--Perl doesn't
! (yet) attempt to canonicalize variable names for you.)
=item *
Regular expressions match characters instead of bytes. For instance,
"." matches a character instead of a byte. (However, the C<\C> pattern
! is provided to force a match a single byte ("C<char>" in C, hence C<\C>).)
=item *
Character classes in regular expressions match characters instead of
bytes, and match against the character properties specified in the
! Unicode properties database. So C<\w> can be used to match an
! ideograph, for instance.
=item *
***************
*** 158,167 ****
classes via the new C<\p{}> (matches property) and C<\P{}> (doesn't
match property) constructs. For instance, C<\p{Lu}> matches any
character with the Unicode uppercase property, while C<\p{M}> matches
! any mark character. Single letter properties may omit the brackets, so
! that can be written C<\pM> also. Many predefined character classes are
! available, such as C<\p{IsMirrored}> and C<\p{InTibetan}>.
=item *
The special pattern C<\X> match matches any extended Unicode sequence
--- 161,409 ----
classes via the new C<\p{}> (matches property) and C<\P{}> (doesn't
match property) constructs. For instance, C<\p{Lu}> matches any
character with the Unicode uppercase property, while C<\p{M}> matches
! any mark character. Single letter properties may omit the brackets,
! so that can be written C<\pM> also. Many predefined character classes
! are available, such as C<\p{IsMirrored}> and C<\p{InTibetan}>. The
! names of the C<In> classes are the official Unicode script and block
! names but with all non-alphanumeric characters removed, for example
! the block name C<"Latin-1 Supplement"> becomes C<\p{InLatin1Supplement}>.
+ Here is the list as of Unicode 3.1.0 (the two-letter classes) and
+ as defined by Perl (the one-letter classes) (in Unicode materials
+ what Perl calls C<L> is often called C<L&>):
+
+ L Letter
+ Lu Letter, Uppercase
+ Ll Letter, Lowercase
+ Lt Letter, Titlecase
+ Lm Letter, Modifier
+ Lo Letter, Other
+ M Mark
+ Mn Mark, Non-Spacing
+ Mc Mark, Spacing Combining
+ Me Mark, Enclosing
+ N Number
+ Nd Number, Decimal Digit
+ Nl Number, Letter
+ No Number, Other
+ P Punctuation
+ Pc Punctuation, Connector
+ Pd Punctuation, Dash
+ Ps Punctuation, Open
+ Pe Punctuation, Close
+ Pi Punctuation, Initial quote
+ (may behave like Ps or Pe depending on usage)
+ Pf Punctuation, Final quote
+ (may behave like Ps or Pe depending on usage)
+ Po Punctuation, Other
+ S Symbol
+ Sm Symbol, Math
+ Sc Symbol, Currency
+ Sk Symbol, Modifier
+ So Symbol, Other
+ Z Separator
+ Zs Separator, Space
+ Zl Separator, Line
+ Zp Separator, Paragraph
+ C Other
+ Cc Other, Control
+ Cf Other, Format
+ Cs Other, Surrogate
+ Co Other, Private Use
+ Cn Other, Not Assigned (Unicode defines no Cn characters)
+
+ Additionally, because scripts differ in their directionality
+ (for example Hebrew is written right to left), all characters
+ have their directionality defined:
+
+ BidiL Left-to-Right
+ BidiLRE Left-to-Right Embedding
+ BidiLRO Left-to-Right Override
+ BidiR Right-to-Left
+ BidiAL Right-to-Left Arabic
+ BidiRLE Right-to-Left Embedding
+ BidiRLO Right-to-Left Override
+ BidiPDF Pop Directional Format
+ BidiEN European Number
+ BidiES European Number Separator
+ BidiET European Number Terminator
+ BidiAN Arabic Number
+ BidiCS Common Number Separator
+ BidiNSM Non-Spacing Mark
+ BidiBN Boundary Neutral
+ BidiB Paragraph Separator
+ BidiS Segment Separator
+ BidiWS Whitespace
+ BidiON Other Neutrals
+
+ =head2 Scripts
+
+ The scripts available for C<\p{In...}> and C<\P{In...}>, for example
+ \p{InCyrillic>, are as follows, for example C<\p{InLatin}> or C<\P{InHan}>:
+
+ Latin
+ Greek
+ Cyrillic
+ Armenian
+ Hebrew
+ Arabic
+ Syriac
+ Thaana
+ Devanagari
+ Bengali
+ Gurmukhi
+ Gujarati
+ Oriya
+ Tamil
+ Telugu
+ Kannada
+ Malayalam
+ Sinhala
+ Thai
+ Lao
+ Tibetan
+ Myanmar
+ Georgian
+ Hangul
+ Ethiopic
+ Cherokee
+ CanadianAboriginal
+ Ogham
+ Runic
+ Khmer
+ Mongolian
+ Hiragana
+ Katakana
+ Bopomofo
+ Han
+ Yi
+ OldItalic
+ Gothic
+ Deseret
+ Inherited
+
+ =head2 Blocks
+
+ In addition to B<scripts>, Unicode also defines B<blocks> of
+ characters. The difference between scripts and blocks is that the
+ former concept is closer to natural languages, while the latter
+ concept is more an artificial grouping based on groups of 256 Unicode
+ characters. For example, the C<Latin> script contains letters from
+ many blocks, but it does not contain all the characters from those
+ blocks, it does not for example contain digits.
+
+ For more about scripts see the UTR #24:
+ http://www.unicode.org/unicode/reports/tr24/
+ For more about blocks see
+ http://www.unicode.org/Public/UNIDATA/Blocks.txt
+
+ Because there are overlaps in naming (there are, for example, both
+ a script called C<Katakana> and a block called C<Katakana>, the block
+ version has C<Block> appended to its name, C<\p{InKatakanaBlock}>.
+
+ Notice that this definition was introduced in Perl 5.8.0: in Perl
+ 5.6.0 only the blocks were used; in Perl 5.8.0 scripts became the
+ preferential character class definition; this meant that the
+ definitions of some character classes changed (the ones in the
+ below list that have the C<Block> appended).
+
+ BasicLatin
+ Latin1Supplement
+ LatinExtendedA
+ LatinExtendedB
+ IPAExtensions
+ SpacingModifierLetters
+ CombiningDiacriticalMarks
+ GreekBlock
+ CyrillicBlock
+ ArmenianBlock
+ HebrewBlock
+ ArabicBlock
+ SyriacBlock
+ ThaanaBlock
+ DevanagariBlock
+ BengaliBlock
+ GurmukhiBlock
+ GujaratiBlock
+ OriyaBlock
+ TamilBlock
+ TeluguBlock
+ KannadaBlock
+ MalayalamBlock
+ SinhalaBlock
+ ThaiBlock
+ LaoBlock
+ TibetanBlock
+ MyanmarBlock
+ GeorgianBlock
+ HangulJamo
+ EthiopicBlock
+ CherokeeBlock
+ UnifiedCanadianAboriginalSyllabics
+ OghamBlock
+ RunicBlock
+ KhmerBlock
+ MongolianBlock
+ LatinExtendedAdditional
+ GreekExtended
+ GeneralPunctuation
+ SuperscriptsandSubscripts
+ CurrencySymbols
+ CombiningMarksforSymbols
+ LetterlikeSymbols
+ NumberForms
+ Arrows
+ MathematicalOperators
+ MiscellaneousTechnical
+ ControlPictures
+ OpticalCharacterRecognition
+ EnclosedAlphanumerics
+ BoxDrawing
+ BlockElements
+ GeometricShapes
+ MiscellaneousSymbols
+ Dingbats
+ BraillePatterns
+ CJKRadicalsSupplement
+ KangxiRadicals
+ IdeographicDescriptionCharacters
+ CJKSymbolsandPunctuation
+ HiraganaBlock
+ KatakanaBlock
+ BopomofoBlock
+ HangulCompatibilityJamo
+ Kanbun
+ BopomofoExtended
+ EnclosedCJKLettersandMonths
+ CJKCompatibility
+ CJKUnifiedIdeographsExtensionA
+ CJKUnifiedIdeographs
+ YiSyllables
+ YiRadicals
+ HangulSyllables
+ HighSurrogates
+ HighPrivateUseSurrogates
+ LowSurrogates
+ PrivateUse
+ CJKCompatibilityIdeographs
+ AlphabeticPresentationForms
+ ArabicPresentationFormsA
+ CombiningHalfMarks
+ CJKCompatibilityForms
+ SmallFormVariants
+ ArabicPresentationFormsB
+ Specials
+ HalfwidthandFullwidthForms
+ OldItalicBlock
+ GothicBlock
+ DeseretBlock
+ ByzantineMusicalSymbols
+ MusicalSymbols
+ MathematicalAlphanumericSymbols
+ CJKUnifiedIdeographsExtensionB
+ CJKCompatibilityIdeographsSupplement
+ Tags
+
=item *
The special pattern C<\X> match matches any extended Unicode sequence
***************
*** 188,200 ****
=item *
Most operators that deal with positions or lengths in the string will
! automatically switch to using character positions, including C<chop()>,
! C<substr()>, C<pos()>, C<index()>, C<rindex()>, C<sprintf()>,
! C<write()>, and C<length()>. Operators that specifically don't switch
! include C<vec()>, C<pack()>, and C<unpack()>. Operators that really
! don't care include C<chomp()>, as well as any other operator that
! treats a string as a bucket of bits, such as C<sort()>, and the
! operators dealing with filenames.
=item *
--- 430,442 ----
=item *
Most operators that deal with positions or lengths in the string will
! automatically switch to using character positions, including
! C<chop()>, C<substr()>, C<pos()>, C<index()>, C<rindex()>,
! C<sprintf()>, C<write()>, and C<length()>. Operators that
! specifically don't switch include C<vec()>, C<pack()>, and
! C<unpack()>. Operators that really don't care include C<chomp()>, as
! well as any other operator that treats a string as a bucket of bits,
! such as C<sort()>, and the operators dealing with filenames.
=item *
***************
*** 215,226 ****
The bit string operators C<& | ^ ~> can operate on character data.
However, for backward compatibility reasons (bit string operations
! when the characters all are less than 256 in ordinal value) one cannot
! mix C<~> (the bit complement) and characters both less than 256 and
equal or greater than 256. Most importantly, the DeMorgan's laws
(C<~($x|$y) eq ~$x&~$y>, C<~($x&$y) eq ~$x|~$y>) won't hold.
Another way to look at this is that the complement cannot return
! B<both> the 8-bit (byte) wide bit complement, and the full character
wide bit complement.
=item *
--- 457,468 ----
The bit string operators C<& | ^ ~> can operate on character data.
However, for backward compatibility reasons (bit string operations
! when the characters all are less than 256 in ordinal value) one should
! not mix C<~> (the bit complement) and characters both less than 256 and
equal or greater than 256. Most importantly, the DeMorgan's laws
(C<~($x|$y) eq ~$x&~$y>, C<~($x&$y) eq ~$x|~$y>) won't hold.
Another way to look at this is that the complement cannot return
! B<both> the 8-bit (byte) wide bit complement B<and> the full character
wide bit complement.
=item *
***************
*** 250,255 ****
=head1 SEE ALSO
! L<bytes>, L<utf8>, L<perlvar/"${^WIDE_SYSTEM_CALLS}">
=cut
--- 492,497 ----
=head1 SEE ALSO
! L<bytes>, L<utf8>, L<perlretut>, L<perlvar/"${^WIDE_SYSTEM_CALLS}">
=cut
diff -c 'perl-5.7.1/pod/perlutil.pod' 'perl-5.7.2/pod/perlutil.pod'
Index: ./pod/perlutil.pod
*** ./pod/perlutil.pod Mon Apr 9 23:55:24 2001
--- ./pod/perlutil.pod Mon Jul 9 17:11:16 2001
***************
*** 29,35 ****
If it's run from a terminal, F<perldoc> will usually call F<pod2man> to
translate POD (Plain Old Documentation - see L<perlpod> for an
! explanation) into a man page, and then run F<man> to display it; if
F<man> isn't available, F<pod2text> will be used instead and the output
piped through your favourite pager.
--- 29,35 ----
If it's run from a terminal, F<perldoc> will usually call F<pod2man> to
translate POD (Plain Old Documentation - see L<perlpod> for an
! explanation) into a manpage, and then run F<man> to display it; if
F<man> isn't available, F<pod2text> will be used instead and the output
piped through your favourite pager.
***************
*** 122,127 ****
--- 122,137 ----
As well as these filters for converting other languages, the
L<pl2pm|pl2pm> utility will help you convert old-style Perl 4 libraries to
new-style Perl5 modules.
+
+ =head2 Administration
+
+ =over 3
+
+ =item L<libnetcfg|libnetcfg>
+
+ To display and change the libnet configuration run the libnetcfg command.
+
+ =back
=head2 Development
diff -c 'perl-5.7.1/pod/perlvar.pod' 'perl-5.7.2/pod/perlvar.pod'
Index: ./pod/perlvar.pod
*** ./pod/perlvar.pod Tue Mar 27 17:42:05 2001
--- ./pod/perlvar.pod Mon Jul 9 17:11:16 2001
***************
*** 111,116 ****
--- 111,131 ----
=over 8
+ =item $a
+
+ =item $b
+
+ Special package variables when using sort(), see L<perlfunc/sort>.
+ Because of this specialness $a and $b don't need to be declared
+ (using local(), use vars, or our()) even when using the strict
+ vars pragma. Don't lexicalize them with C<my $a> or C<my $b>
+ if you want to be able to use them in the sort() comparison block
+ or function.
+
+ =back
+
+ =over 8
+
=item $<I<digits>>
Contains the subpattern from the corresponding set of capturing
***************
*** 165,173 ****
=item $+
! The last bracket matched by the last search pattern. This is useful if
! you don't know which one of a set of alternative patterns matched. For
! example:
/Version: (.*)|Revision: (.*)/ && ($rev = $+);
--- 180,188 ----
=item $+
! The text matched by the last bracket of the last successful search pattern.
! This is useful if you don't know which one of a set of alternative patterns
! matched. For example:
/Version: (.*)|Revision: (.*)/ && ($rev = $+);
***************
*** 174,179 ****
--- 189,212 ----
(Mnemonic: be positive and forward looking.)
This variable is read-only and dynamically scoped to the current BLOCK.
+ =item $^N
+
+ The text matched by the used group most-recently closed (i.e. the group
+ with the rightmost closing parenthesis) of the last successful search
+ pattern. (Mnemonic: the (possibly) Nested parenthesis that most
+ recently closed.)
+
+ This is primarly used inside C<(?{...})> blocks for examining text
+ recently matched. For example, to effectively capture text to a variable
+ (in addition to C<$1>, C<$2>, etc.), replace C<(...)> with
+
+ (?:(...)(?{ $var = $^N }))
+
+ By setting and then using C<$var> in this way relieves you from having to
+ worry about exactly which numbered set of parentheses they are.
+
+ This variable is dynamically scoped to the current BLOCK.
+
=item @LAST_MATCH_END
=item @+
***************
*** 596,605 ****
=item $@
! The Perl syntax error message from the last eval() operator. If null, the
! last eval() parsed and executed correctly (although the operations you
! invoked may have failed in the normal fashion). (Mnemonic: Where was
! the syntax error "at"?)
Warning messages are not collected in this variable. You can,
however, set up a routine to process warnings by setting C<$SIG{__WARN__}>
--- 629,638 ----
=item $@
! The Perl syntax error message from the last eval() operator.
! If $@ is the null string, the last eval() parsed and executed
! correctly (although the operations you invoked may have failed in the
! normal fashion). (Mnemonic: Where was the syntax error "at"?)
Warning messages are not collected in this variable. You can,
however, set up a routine to process warnings by setting C<$SIG{__WARN__}>
***************
*** 996,1001 ****
--- 1029,1041 ----
the script. C<$#ARGV> is generally the number of arguments minus
one, because C<$ARGV[0]> is the first argument, I<not> the program's
command name itself. See C<$0> for the command name.
+
+ =item @F
+
+ The array @F contains the fields of each line read in when autosplit
+ mode is turned on. See L<perlrun> for the B<-a> switch. This array
+ is package-specific, and must be declared or given a full package name
+ if not in package main when running under C<strict 'vars'>.
=item @INC
diff -c 'perl-5.7.1/pod/perlxs.pod' 'perl-5.7.2/pod/perlxs.pod'
Index: ./pod/perlxs.pod
*** ./pod/perlxs.pod Fri Mar 16 04:52:01 2001
--- ./pod/perlxs.pod Mon Jul 9 17:11:16 2001
***************
*** 398,404 ****
NO_OUTPUT int
delete_file(char *name)
! POST_CALL:
if (RETVAL != 0)
croak("Error %d while deleting file '%s'", RETVAL, name);
--- 398,404 ----
NO_OUTPUT int
delete_file(char *name)
! POSTCALL:
if (RETVAL != 0)
croak("Error %d while deleting file '%s'", RETVAL, name);
***************
*** 1053,1059 ****
OUTPUT:
RETVAL
! In fact, one can put this check into a POST_CALL: section as well. Together
with PREINIT: simplifications, this leads to:
int
--- 1053,1059 ----
OUTPUT:
RETVAL
! In fact, one can put this check into a POSTCALL: section as well. Together
with PREINIT: simplifications, this leads to:
int
***************
*** 1060,1066 ****
rpcb_gettime(host)
char *host
time_t timep;
! POST_CALL:
if (RETVAL == 0)
XSRETURN_UNDEF;
--- 1060,1066 ----
rpcb_gettime(host)
char *host
time_t timep;
! POSTCALL:
if (RETVAL == 0)
XSRETURN_UNDEF;
***************
*** 1081,1094 ****
code specified for the cleanup block will be added as the last statements
in the XSUB.
! =head2 The POST_CALL: Keyword
This keyword can be used when an XSUB requires special procedures
! executed after the C subroutine call is performed. When the POST_CALL:
keyword is used it must precede OUTPUT: and CLEANUP: blocks which are
present in the XSUB.
! The POST_CALL: block does not make a lot of sense when the C subroutine
call is supplied by user by providing either CODE: or PPCODE: section.
=head2 The BOOT: Keyword
--- 1081,1096 ----
code specified for the cleanup block will be added as the last statements
in the XSUB.
! =head2 The POSTCALL: Keyword
This keyword can be used when an XSUB requires special procedures
! executed after the C subroutine call is performed. When the POSTCALL:
keyword is used it must precede OUTPUT: and CLEANUP: blocks which are
present in the XSUB.
! See examples in L<"The NO_OUTPUT Keyword"> and L<"Returning Undef And Empty Lists">.
!
! The POSTCALL: block does not make a lot of sense when the C subroutine
call is supplied by user by providing either CODE: or PPCODE: section.
=head2 The BOOT: Keyword
***************
*** 1371,1377 ****
=head2 Inserting POD, Comments and C Preprocessor Directives
C preprocessor directives are allowed within BOOT:, PREINIT: INIT:, CODE:,
! PPCODE:, POST_CALL:, and CLEANUP: blocks, as well as outside the functions.
Comments are allowed anywhere after the MODULE keyword. The compiler will
pass the preprocessor directives through untouched and will remove the
commented lines. POD documentation is allowed at any point, both in the
--- 1373,1379 ----
=head2 Inserting POD, Comments and C Preprocessor Directives
C preprocessor directives are allowed within BOOT:, PREINIT: INIT:, CODE:,
! PPCODE:, POSTCALL:, and CLEANUP: blocks, as well as outside the functions.
Comments are allowed anywhere after the MODULE keyword. The compiler will
pass the preprocessor directives through untouched and will remove the
commented lines. POD documentation is allowed at any point, both in the
***************
*** 1532,1538 ****
candidates to return undef or an empty list in case of failure. If the
failure may be detected without a call to the C function, you may want to use
an INIT: section to report the failure. For failures detectable after the C
! function returns one may want to use a POST_CALL: section to process the
failure. In more complicated cases use CODE: or PPCODE: sections.
If many functions use the same failure indication based on the return value,
--- 1534,1540 ----
candidates to return undef or an empty list in case of failure. If the
failure may be detected without a call to the C function, you may want to use
an INIT: section to report the failure. For failures detectable after the C
! function returns one may want to use a POSTCALL: section to process the
failure. In more complicated cases use CODE: or PPCODE: sections.
If many functions use the same failure indication based on the return value,
diff -c 'perl-5.7.1/pod/perlxstut.pod' 'perl-5.7.2/pod/perlxstut.pod'
Index: ./pod/perlxstut.pod
*** ./pod/perlxstut.pod Fri Mar 16 04:52:01 2001
--- ./pod/perlxstut.pod Mon Jul 9 17:11:16 2001
***************
*** 915,923 ****
There is absolutely no excuse for not documenting your extension.
Documentation belongs in the .pm file. This file will be fed to pod2man,
! and the embedded documentation will be converted to the man page format,
! then placed in the blib directory. It will be copied to Perl's man
! page directory when the extension is installed.
You may intersperse documentation and Perl code within the .pm file.
In fact, if you want to use method autoloading, you must do this,
--- 915,923 ----
There is absolutely no excuse for not documenting your extension.
Documentation belongs in the .pm file. This file will be fed to pod2man,
! and the embedded documentation will be converted to the manpage format,
! then placed in the blib directory. It will be copied to Perl's
! manpage directory when the extension is installed.
You may intersperse documentation and Perl code within the .pm file.
In fact, if you want to use method autoloading, you must do this,
diff -c 'perl-5.7.1/pod/pod2man.PL' 'perl-5.7.2/pod/pod2man.PL'
Index: ./pod/pod2man.PL
Prereq: 1.4
*** ./pod/pod2man.PL Tue Mar 6 04:06:41 2001
--- ./pod/pod2man.PL Tue Jul 10 17:16:57 2001
***************
*** 36,46 ****
print OUT <<'!NO!SUBS!';
# pod2man -- Convert POD data to formatted *roff input.
! # $Id: pod2man.PL,v 1.4 2000/11/19 05:47:46 eagle Exp $
#
! # Copyright 1999, 2000 by Russ Allbery <rra@stanford.edu>
#
! # This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
require 5.004;
--- 36,46 ----
print OUT <<'!NO!SUBS!';
# pod2man -- Convert POD data to formatted *roff input.
! # $Id: pod2man.PL,v 1.6 2001/07/10 11:23:46 eagle Exp $
#
! # Copyright 1999, 2000, 2001 by Russ Allbery <rra@stanford.edu>
#
! # This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.
require 5.004;
***************
*** 57,64 ****
my $stdin;
@ARGV = map { $_ eq '-' && !$stdin++ ? ('--', $_) : $_ } @ARGV;
! # Parse our options, trying to retain backwards compatibility with pod2man
! # but allowing short forms as well. --lax is currently ignored.
my %options;
Getopt::Long::config ('bundling_override');
GetOptions (\%options, 'section|s=s', 'release|r=s', 'center|c=s',
--- 57,64 ----
my $stdin;
@ARGV = map { $_ eq '-' && !$stdin++ ? ('--', $_) : $_ } @ARGV;
! # Parse our options, trying to retain backwards compatibility with pod2man but
! # allowing short forms as well. --lax is currently ignored.
my %options;
Getopt::Long::config ('bundling_override');
GetOptions (\%options, 'section|s=s', 'release|r=s', 'center|c=s',
***************
*** 72,79 ****
$options{center} = 'Perl Programmers Reference Guide';
}
! # Initialize and run the formatter, pulling a pair of input and output off
! # at a time.
my $parser = Pod::Man->new (%options);
my @files;
do {
--- 72,79 ----
$options{center} = 'Perl Programmers Reference Guide';
}
! # Initialize and run the formatter, pulling a pair of input and output off at
! # a time.
my $parser = Pod::Man->new (%options);
my @files;
do {
***************
*** 80,86 ****
@files = splice (@ARGV, 0, 2);
$parser->parse_from_file (@files);
} while (@ARGV);
!
__END__
=head1 NAME
--- 80,86 ----
@files = splice (@ARGV, 0, 2);
$parser->parse_from_file (@files);
} while (@ARGV);
!
__END__
=head1 NAME
***************
*** 423,428 ****
--- 423,431 ----
appropriate. You may need to use the C<LE<lt>...|...E<gt>> syntax to keep
B<pod2man> and B<pod2text> from being too verbose; see perlpod(1).
+ If the package has a mailing list, include a URL or subscription
+ instructions here.
+
If the package has a web site, include a URL here.
=item AUTHOR
***************
*** 433,442 ****
program documentation tends to roam the wild for far longer than you expect
and pick an e-mail address that's likely to last if possible.
=item HISTORY
! Programs derived from other sources sometimes have this, or you might keep a
! modification log here.
=back
--- 436,463 ----
program documentation tends to roam the wild for far longer than you expect
and pick an e-mail address that's likely to last if possible.
+ =item COPYRIGHT AND LICENSE
+
+ For copyright
+
+ Copyright YEAR(s) by YOUR NAME(s)
+
+ (No, (C) is not needed. No, "all rights reserved" is not needed.)
+
+ For licensing the easiest way is to use the same licensing as Perl itself:
+
+ This library is free software; you may redistribute it and/or modify
+ it under the same terms as Perl itself.
+
+ This makes it easy for people to use your module with Perl. Note that
+ this licensing is neither an endorsement or a requirement, you are of
+ course free to choose any licensing.
+
=item HISTORY
! Programs derived from other sources sometimes have this, or you might keep
! a modification log here. If the log gets overly long or detailed,
! consider maintaining it in a separate file, though.
=back
***************
*** 447,456 ****
use CONSTRUCTORS and METHODS sections for detailed documentation of the
parts of the library and save the DESCRIPTION section for an overview; other
large modules may use FUNCTIONS for similar reasons. Some people use
! OVERVIEW to summarize the description if it's quite long. Sometimes there's
! an additional COPYRIGHT section at the bottom, for licensing terms.
! AVAILABILITY is sometimes added, giving the canonical download site for the
! software or a URL for updates.
Section ordering varies, although NAME should I<always> be the first section
(you'll break some man page systems otherwise), and NAME, SYNOPSIS,
--- 468,474 ----
use CONSTRUCTORS and METHODS sections for detailed documentation of the
parts of the library and save the DESCRIPTION section for an overview; other
large modules may use FUNCTIONS for similar reasons. Some people use
! OVERVIEW to summarize the description if it's quite long.
Section ordering varies, although NAME should I<always> be the first section
(you'll break some man page systems otherwise), and NAME, SYNOPSIS,
***************
*** 481,490 ****
=head1 AUTHOR
! Russ Allbery E<lt>rra@stanford.eduE<gt>, based I<very> heavily on the
! original B<pod2man> by Larry Wall and Tom Christiansen. Large portions of
! this documentation, particularly the sections on the anatomy of a proper man
page, are taken from the B<pod2man> documentation by Tom.
=cut
!NO!SUBS!
--- 499,515 ----
=head1 AUTHOR
! Russ Allbery <rra@stanford.edu>, based I<very> heavily on the original
! B<pod2man> by Larry Wall and Tom Christiansen. Large portions of this
! documentation, particularly the sections on the anatomy of a proper man
page, are taken from the B<pod2man> documentation by Tom.
+
+ =head1 COPYRIGHT AND LICENSE
+
+ Copyright 1999, 2000, 2001 by Russ Allbery <rra@stanford.edu>.
+
+ This program is free software; you may redistribute it and/or modify it
+ under the same terms as Perl itself.
=cut
!NO!SUBS!
diff -c 'perl-5.7.1/pod/pod2text.PL' 'perl-5.7.2/pod/pod2text.PL'
Index: ./pod/pod2text.PL
*** ./pod/pod2text.PL Tue Mar 6 04:06:42 2001
--- ./pod/pod2text.PL Tue Jul 10 17:16:58 2001
***************
*** 39,45 ****
#
# Copyright 1999, 2000 by Russ Allbery <rra@stanford.edu>
#
! # This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
# The driver script for Pod::Text, Pod::Text::Termcap, and Pod::Text::Color,
--- 39,45 ----
#
# Copyright 1999, 2000 by Russ Allbery <rra@stanford.edu>
#
! # This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.
#
# The driver script for Pod::Text, Pod::Text::Termcap, and Pod::Text::Color,
***************
*** 243,249 ****
=head1 AUTHOR
! Russ Allbery E<lt>rra@stanford.eduE<gt>.
=cut
!NO!SUBS!
--- 243,256 ----
=head1 AUTHOR
! Russ Allbery <rra@stanford.edu>.
!
! =head1 COPYRIGHT AND LICENSE
!
! Copyright 1999, 2000, 2001 by Russ Allbery <rra@stanford.edu>.
!
! This program is free software; you may redistribute it and/or modify it
! under the same terms as Perl itself.
=cut
!NO!SUBS!
diff -c 'perl-5.7.1/pp.c' 'perl-5.7.2/pp.c'
Index: ./pp.c
*** ./pp.c Fri Apr 6 01:15:53 2001
--- ./pp.c Mon Jul 9 17:11:17 2001
***************
*** 16,85 ****
#define PERL_IN_PP_C
#include "perl.h"
- /*
- * The compiler on Concurrent CX/UX systems has a subtle bug which only
- * seems to show up when compiling pp.c - it generates the wrong double
- * precision constant value for (double)UV_MAX when used inline in the body
- * of the code below, so this makes a static variable up front (which the
- * compiler seems to get correct) and uses it in place of UV_MAX below.
- */
- #ifdef CXUX_BROKEN_CONSTANT_CONVERT
- static double UV_MAX_cxux = ((double)UV_MAX);
- #endif
-
- /*
- * Offset for integer pack/unpack.
- *
- * On architectures where I16 and I32 aren't really 16 and 32 bits,
- * which for now are all Crays, pack and unpack have to play games.
- */
-
- /*
- * These values are required for portability of pack() output.
- * If they're not right on your machine, then pack() and unpack()
- * wouldn't work right anyway; you'll need to apply the Cray hack.
- * (I'd like to check them with #if, but you can't use sizeof() in
- * the preprocessor.) --???
- */
- /*
- The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
- defines are now in config.h. --Andy Dougherty April 1998
- */
- #define SIZE16 2
- #define SIZE32 4
-
- /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
- --jhi Feb 1999 */
-
- #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
- # define PERL_NATINT_PACK
- #endif
-
- #if LONGSIZE > 4 && defined(_CRAY)
- # if BYTEORDER == 0x12345678
- # define OFF16(p) (char*)(p)
- # define OFF32(p) (char*)(p)
- # else
- # if BYTEORDER == 0x87654321
- # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
- # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
- # else
- }}}} bad cray byte order
- # endif
- # endif
- # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
- # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
- # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
- # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
- # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
- #else
- # define COPY16(s,p) Copy(s, p, SIZE16, char)
- # define COPY32(s,p) Copy(s, p, SIZE32, char)
- # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
- # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
- # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
- #endif
-
/* variations on pp_null */
/* XXX I can't imagine anyone who doesn't have this actually _needs_
--- 16,21 ----
***************
*** 341,347 ****
if (!sv) {
AvARYLEN(av) = sv = NEWSV(0,0);
sv_upgrade(sv, SVt_IV);
! sv_magic(sv, (SV*)av, '#', Nullch, 0);
}
SETs(sv);
RETURN;
--- 277,283 ----
if (!sv) {
AvARYLEN(av) = sv = NEWSV(0,0);
sv_upgrade(sv, SVt_IV);
! sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
}
SETs(sv);
RETURN;
***************
*** 354,360 ****
if (PL_op->op_flags & OPf_MOD || LVRET) {
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
! sv_magic(TARG, Nullsv, '.', Nullch, 0);
}
LvTYPE(TARG) = '.';
--- 290,296 ----
if (PL_op->op_flags & OPf_MOD || LVRET) {
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
! sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
}
LvTYPE(TARG) = '.';
***************
*** 370,376 ****
MAGIC* mg;
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
! mg = mg_find(sv, 'g');
if (mg && mg->mg_len >= 0) {
I32 i = mg->mg_len;
if (DO_UTF8(sv))
--- 306,312 ----
MAGIC* mg;
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
! mg = mg_find(sv, PERL_MAGIC_regex_global);
if (mg && mg->mg_len >= 0) {
I32 i = mg->mg_len;
if (DO_UTF8(sv))
***************
*** 448,457 ****
else if (n && str[0] == ';' && seen_question)
goto set; /* XXXX system, exec */
if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
! && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
str[n++] = '\\';
}
- /* What to do with R ((un)tie, tied, (sys)read, recv)? */
str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
oa = oa >> 4;
}
--- 384,395 ----
else if (n && str[0] == ';' && seen_question)
goto set; /* XXXX system, exec */
if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
! && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
! /* But globs are already references (kinda) */
! && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
! ) {
str[n++] = '\\';
}
str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
oa = oa >> 4;
}
***************
*** 713,719 ****
}
SvSCREAM_on(sv);
! sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
RETPUSHYES;
}
--- 651,658 ----
}
SvSCREAM_on(sv);
! /* piggyback on m//g magic */
! sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
RETPUSHYES;
}
***************
*** 781,791 ****
RETPUSHNO;
switch (SvTYPE(sv)) {
case SVt_PVAV:
! if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
RETPUSHYES;
break;
case SVt_PVHV:
! if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
RETPUSHYES;
break;
case SVt_PVCV:
--- 720,732 ----
RETPUSHNO;
switch (SvTYPE(sv)) {
case SVt_PVAV:
! if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
! || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
RETPUSHYES;
break;
case SVt_PVHV:
! if (HvARRAY(sv) || SvGMAGICAL(sv)
! || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
RETPUSHYES;
break;
case SVt_PVCV:
***************
*** 1002,1008 ****
/* 2s complement assumption that (UV)-IV_MIN is correct. */
/* -ve result, which could overflow an IV */
SP--;
! SETi( -product );
RETURN;
} /* else drop to NVs below. */
} else {
--- 943,949 ----
/* 2s complement assumption that (UV)-IV_MIN is correct. */
/* -ve result, which could overflow an IV */
SP--;
! SETi( -(IV)product );
RETURN;
} /* else drop to NVs below. */
} else {
***************
*** 1039,1045 ****
/* 2s complement assumption again */
/* -ve result, which could overflow an IV */
SP--;
! SETi( -product_low );
RETURN;
} /* else drop to NVs below. */
}
--- 980,986 ----
/* 2s complement assumption again */
/* -ve result, which could overflow an IV */
SP--;
! SETi( -(IV)product_low );
RETURN;
} /* else drop to NVs below. */
}
***************
*** 1088,1100 ****
{
dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
{
! UV left;
! UV right;
bool left_neg;
bool right_neg;
bool use_double = 0;
! NV dright;
! NV dleft;
if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
IV i = SvIVX(POPs);
--- 1029,1041 ----
{
dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
{
! UV left = 0;
! UV right = 0;
bool left_neg;
bool right_neg;
bool use_double = 0;
! NV dright = 0.0;
! NV dleft = 0.0;
if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
IV i = SvIVX(POPs);
***************
*** 1260,1267 ****
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
! register UV auv;
! bool auvok;
bool a_valid = 0;
if (!useleft) {
--- 1201,1208 ----
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
! register UV auv = 0;
! bool auvok = FALSE;
bool a_valid = 0;
if (!useleft) {
***************
*** 1906,1912 ****
dSP; tryAMAGICbinSET(slt,0);
{
dPOPTOPssrl;
! int cmp = ((PL_op->op_private & OPpLOCALE)
? sv_cmp_locale(left, right)
: sv_cmp(left, right));
SETs(boolSV(cmp < 0));
--- 1847,1853 ----
dSP; tryAMAGICbinSET(slt,0);
{
dPOPTOPssrl;
! int cmp = (IN_LOCALE_RUNTIME
? sv_cmp_locale(left, right)
: sv_cmp(left, right));
SETs(boolSV(cmp < 0));
***************
*** 1919,1925 ****
dSP; tryAMAGICbinSET(sgt,0);
{
dPOPTOPssrl;
! int cmp = ((PL_op->op_private & OPpLOCALE)
? sv_cmp_locale(left, right)
: sv_cmp(left, right));
SETs(boolSV(cmp > 0));
--- 1860,1866 ----
dSP; tryAMAGICbinSET(sgt,0);
{
dPOPTOPssrl;
! int cmp = (IN_LOCALE_RUNTIME
? sv_cmp_locale(left, right)
: sv_cmp(left, right));
SETs(boolSV(cmp > 0));
***************
*** 1932,1938 ****
dSP; tryAMAGICbinSET(sle,0);
{
dPOPTOPssrl;
! int cmp = ((PL_op->op_private & OPpLOCALE)
? sv_cmp_locale(left, right)
: sv_cmp(left, right));
SETs(boolSV(cmp <= 0));
--- 1873,1879 ----
dSP; tryAMAGICbinSET(sle,0);
{
dPOPTOPssrl;
! int cmp = (IN_LOCALE_RUNTIME
? sv_cmp_locale(left, right)
: sv_cmp(left, right));
SETs(boolSV(cmp <= 0));
***************
*** 1945,1951 ****
dSP; tryAMAGICbinSET(sge,0);
{
dPOPTOPssrl;
! int cmp = ((PL_op->op_private & OPpLOCALE)
? sv_cmp_locale(left, right)
: sv_cmp(left, right));
SETs(boolSV(cmp >= 0));
--- 1886,1892 ----
dSP; tryAMAGICbinSET(sge,0);
{
dPOPTOPssrl;
! int cmp = (IN_LOCALE_RUNTIME
? sv_cmp_locale(left, right)
: sv_cmp(left, right));
SETs(boolSV(cmp >= 0));
***************
*** 1976,1990 ****
PP(pp_scmp)
{
dSP; dTARGET; tryAMAGICbin(scmp,0);
- #ifndef NV_PRESERVES_UV
- if (SvROK(TOPs) && SvROK(TOPm1s)) {
- SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
- RETURN;
- }
- #endif
{
dPOPTOPssrl;
! int cmp = ((PL_op->op_private & OPpLOCALE)
? sv_cmp_locale(left, right)
: sv_cmp(left, right));
SETi( cmp );
--- 1917,1925 ----
PP(pp_scmp)
{
dSP; dTARGET; tryAMAGICbin(scmp,0);
{
dPOPTOPssrl;
! int cmp = (IN_LOCALE_RUNTIME
? sv_cmp_locale(left, right)
: sv_cmp(left, right));
SETi( cmp );
***************
*** 2599,2605 ****
--- 2534,2549 ----
SETu(U_V(value));
} else {
#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
+ # ifdef HAS_MODFL_POW32_BUG
+ /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
+ {
+ NV offset = Perl_modf(value, &value);
+ (void)Perl_modf(offset, &offset);
+ value += offset;
+ }
+ # else
(void)Perl_modf(value, &value);
+ # endif
#else
double tmp = (double)value;
(void)Perl_modf(tmp, &tmp);
***************
*** 2613,2619 ****
--- 2557,2572 ----
SETi(I_V(value));
} else {
#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
+ # ifdef HAS_MODFL_POW32_BUG
+ /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
+ {
+ NV offset = Perl_modf(-value, &value);
+ (void)Perl_modf(offset, &offset);
+ value += offset;
+ }
+ # else
(void)Perl_modf(-value, &value);
+ # endif
value = -value;
#else
double tmp = (double)value;
***************
*** 2717,2723 ****
{
dSP; dTARGET;
SV *sv;
! I32 len;
STRLEN curlen;
STRLEN utf8_curlen;
I32 pos;
--- 2670,2676 ----
{
dSP; dTARGET;
SV *sv;
! I32 len = 0;
STRLEN curlen;
STRLEN utf8_curlen;
I32 pos;
***************
*** 2812,2817 ****
--- 2765,2773 ----
sv_pos_u2b(sv, &pos, &rem);
tmps += pos;
sv_setpvn(TARG, tmps, rem);
+ #ifdef USE_LOCALE_COLLATE
+ sv_unmagic(TARG, PERL_MAGIC_collxfrm);
+ #endif
if (utf8_curlen)
SvUTF8_on(TARG);
if (repl) {
***************
*** 2846,2852 ****
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
! sv_magic(TARG, Nullsv, 'x', Nullch, 0);
}
LvTYPE(TARG) = 'x';
--- 2802,2808 ----
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
! sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
}
LvTYPE(TARG) = 'x';
***************
*** 2876,2882 ****
if (lvalue) { /* it's an lvalue! */
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
! sv_magic(TARG, Nullsv, 'v', Nullch, 0);
}
LvTYPE(TARG) = 'v';
if (LvTARG(TARG) != src) {
--- 2832,2838 ----
if (lvalue) { /* it's an lvalue! */
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
! sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
}
LvTYPE(TARG) = 'v';
if (LvTARG(TARG) != src) {
***************
*** 2999,3005 ****
(void)SvUPGRADE(TARG,SVt_PV);
! if (value > 255 && !IN_BYTE) {
SvGROW(TARG, UNISKIP(value)+1);
tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
SvCUR_set(TARG, tmps - SvPVX(TARG));
--- 2955,2961 ----
(void)SvUPGRADE(TARG,SVt_PV);
! if (value > 255 && !IN_BYTES) {
SvGROW(TARG, UNISKIP(value)+1);
tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
SvCUR_set(TARG, tmps - SvPVX(TARG));
***************
*** 3052,3058 ****
U8 *tend;
UV uv;
! if (PL_op->op_private & OPpLOCALE) {
TAINT;
SvTAINTED_on(sv);
uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
--- 3008,3014 ----
U8 *tend;
UV uv;
! if (IN_LOCALE_RUNTIME) {
TAINT;
SvTAINTED_on(sv);
uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
***************
*** 3084,3090 ****
}
s = (U8*)SvPV_force(sv, slen);
if (*s) {
! if (PL_op->op_private & OPpLOCALE) {
TAINT;
SvTAINTED_on(sv);
*s = toUPPER_LC(*s);
--- 3040,3046 ----
}
s = (U8*)SvPV_force(sv, slen);
if (*s) {
! if (IN_LOCALE_RUNTIME) {
TAINT;
SvTAINTED_on(sv);
*s = toUPPER_LC(*s);
***************
*** 3111,3117 ****
U8 *tend;
UV uv;
! if (PL_op->op_private & OPpLOCALE) {
TAINT;
SvTAINTED_on(sv);
uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
--- 3067,3073 ----
U8 *tend;
UV uv;
! if (IN_LOCALE_RUNTIME) {
TAINT;
SvTAINTED_on(sv);
uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
***************
*** 3143,3149 ****
}
s = (U8*)SvPV_force(sv, slen);
if (*s) {
! if (PL_op->op_private & OPpLOCALE) {
TAINT;
SvTAINTED_on(sv);
*s = toLOWER_LC(*s);
--- 3099,3105 ----
}
s = (U8*)SvPV_force(sv, slen);
if (*s) {
! if (IN_LOCALE_RUNTIME) {
TAINT;
SvTAINTED_on(sv);
*s = toLOWER_LC(*s);
***************
*** 3182,3188 ****
(void)SvPOK_only(TARG);
d = (U8*)SvPVX(TARG);
send = s + len;
! if (PL_op->op_private & OPpLOCALE) {
TAINT;
SvTAINTED_on(TARG);
while (s < send) {
--- 3138,3144 ----
(void)SvPOK_only(TARG);
d = (U8*)SvPVX(TARG);
send = s + len;
! if (IN_LOCALE_RUNTIME) {
TAINT;
SvTAINTED_on(TARG);
while (s < send) {
***************
*** 3214,3220 ****
if (len) {
register U8 *send = s + len;
! if (PL_op->op_private & OPpLOCALE) {
TAINT;
SvTAINTED_on(sv);
for (; s < send; s++)
--- 3170,3176 ----
if (len) {
register U8 *send = s + len;
! if (IN_LOCALE_RUNTIME) {
TAINT;
SvTAINTED_on(sv);
for (; s < send; s++)
***************
*** 3256,3262 ****
(void)SvPOK_only(TARG);
d = (U8*)SvPVX(TARG);
send = s + len;
! if (PL_op->op_private & OPpLOCALE) {
TAINT;
SvTAINTED_on(TARG);
while (s < send) {
--- 3212,3218 ----
(void)SvPOK_only(TARG);
d = (U8*)SvPVX(TARG);
send = s + len;
! if (IN_LOCALE_RUNTIME) {
TAINT;
SvTAINTED_on(TARG);
while (s < send) {
***************
*** 3289,3295 ****
if (len) {
register U8 *send = s + len;
! if (PL_op->op_private & OPpLOCALE) {
TAINT;
SvTAINTED_on(sv);
for (; s < send; s++)
--- 3245,3251 ----
if (len) {
register U8 *send = s + len;
! if (IN_LOCALE_RUNTIME) {
TAINT;
SvTAINTED_on(sv);
for (; s < send; s++)
***************
*** 3561,3567 ****
while (++MARK <= SP) {
SV *keysv = *MARK;
SV **svp;
! I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
if (realhv) {
HE *he = hv_fetch_ent(hv, keysv, lval, 0);
svp = he ? &HeVAL(he) : 0;
--- 3517,3525 ----
while (++MARK <= SP) {
SV *keysv = *MARK;
SV **svp;
! I32 preeminent = SvRMAGICAL(hv) ? 1 :
! realhv ? hv_exists_ent(hv, keysv, 0)
! : avhv_exists_ent((AV*)hv, keysv, 0);
if (realhv) {
HE *he = hv_fetch_ent(hv, keysv, lval, 0);
svp = he ? &HeVAL(he) : 0;
***************
*** 3709,3715 ****
SV **tmparyval = 0;
MAGIC *mg;
! if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
*MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
--- 3667,3673 ----
SV **tmparyval = 0;
MAGIC *mg;
! if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
*MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
***************
*** 3903,3909 ****
register SV *sv = &PL_sv_undef;
MAGIC *mg;
! if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
*MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
--- 3861,3867 ----
register SV *sv = &PL_sv_undef;
MAGIC *mg;
! if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
*MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
***************
*** 3959,3965 ****
register I32 i = 0;
MAGIC *mg;
! if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
*MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
--- 3917,3923 ----
register I32 i = 0;
MAGIC *mg;
! if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
*MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
***************
*** 4049,5786 ****
RETURN;
}
- STATIC SV *
- S_mul128(pTHX_ SV *sv, U8 m)
- {
- STRLEN len;
- char *s = SvPV(sv, len);
- char *t;
- U32 i = 0;
-
- if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
- SV *tmpNew = newSVpvn("0000000000", 10);
-
- sv_catsv(tmpNew, sv);
- SvREFCNT_dec(sv); /* free old sv */
- sv = tmpNew;
- s = SvPV(sv, len);
- }
- t = s + len - 1;
- while (!*t) /* trailing '\0'? */
- t--;
- while (t > s) {
- i = ((*t - '0') << 7) + m;
- *(t--) = '0' + (i % 10);
- m = i / 10;
- }
- return (sv);
- }
-
- /* Explosives and implosives. */
-
- #if 'I' == 73 && 'J' == 74
- /* On an ASCII/ISO kind of system */
- #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
- #else
- /*
- Some other sort of character set - use memchr() so we don't match
- the null byte.
- */
- #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
- #endif
-
-
- PP(pp_unpack)
- {
- dSP;
- dPOPPOPssrl;
- I32 start_sp_offset = SP - PL_stack_base;
- I32 gimme = GIMME_V;
- SV *sv;
- STRLEN llen;
- STRLEN rlen;
- register char *pat = SvPV(left, llen);
- #ifdef PACKED_IS_OCTETS
- /* Packed side is assumed to be octets - so force downgrade if it
- has been UTF-8 encoded by accident
- */
- register char *s = SvPVbyte(right, rlen);
- #else
- register char *s = SvPV(right, rlen);
- #endif
- char *strend = s + rlen;
- char *strbeg = s;
- register char *patend = pat + llen;
- I32 datumtype;
- register I32 len;
- register I32 bits;
- register char *str;
-
- /* These must not be in registers: */
- short ashort;
- int aint;
- long along;
- #ifdef HAS_QUAD
- Quad_t aquad;
- #endif
- U16 aushort;
- unsigned int auint;
- U32 aulong;
- #ifdef HAS_QUAD
- Uquad_t auquad;
- #endif
- char *aptr;
- float afloat;
- double adouble;
- I32 checksum = 0;
- register U32 culong;
- NV cdouble;
- int commas = 0;
- int star;
- #ifdef PERL_NATINT_PACK
- int natint; /* native integer */
- int unatint; /* unsigned native integer */
- #endif
-
- if (gimme != G_ARRAY) { /* arrange to do first one only */
- /*SUPPRESS 530*/
- for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
- if (strchr("aAZbBhHP", *patend) || *pat == '%') {
- patend++;
- while (isDIGIT(*patend) || *patend == '*')
- patend++;
- }
- else
- patend++;
- }
- while (pat < patend) {
- reparse:
- datumtype = *pat++ & 0xFF;
- #ifdef PERL_NATINT_PACK
- natint = 0;
- #endif
- if (isSPACE(datumtype))
- continue;
- if (datumtype == '#') {
- while (pat < patend && *pat != '\n')
- pat++;
- continue;
- }
- if (*pat == '!') {
- char *natstr = "sSiIlL";
-
- if (strchr(natstr, datumtype)) {
- #ifdef PERL_NATINT_PACK
- natint = 1;
- #endif
- pat++;
- }
- else
- DIE(aTHX_ "'!' allowed only after types %s", natstr);
- }
- star = 0;
- if (pat >= patend)
- len = 1;
- else if (*pat == '*') {
- len = strend - strbeg; /* long enough */
- pat++;
- star = 1;
- }
- else if (isDIGIT(*pat)) {
- len = *pat++ - '0';
- while (isDIGIT(*pat)) {
- len = (len * 10) + (*pat++ - '0');
- if (len < 0)
- DIE(aTHX_ "Repeat count in unpack overflows");
- }
- }
- else
- len = (datumtype != '@');
- redo_switch:
- switch(datumtype) {
- default:
- DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
- case ',': /* grandfather in commas but with a warning */
- if (commas++ == 0 && ckWARN(WARN_UNPACK))
- Perl_warner(aTHX_ WARN_UNPACK,
- "Invalid type in unpack: '%c'", (int)datumtype);
- break;
- case '%':
- if (len == 1 && pat[-1] != '1')
- len = 16;
- checksum = len;
- culong = 0;
- cdouble = 0;
- if (pat < patend)
- goto reparse;
- break;
- case '@':
- if (len > strend - strbeg)
- DIE(aTHX_ "@ outside of string");
- s = strbeg + len;
- break;
- case 'X':
- if (len > s - strbeg)
- DIE(aTHX_ "X outside of string");
- s -= len;
- break;
- case 'x':
- if (len > strend - s)
- DIE(aTHX_ "x outside of string");
- s += len;
- break;
- case '/':
- if (start_sp_offset >= SP - PL_stack_base)
- DIE(aTHX_ "/ must follow a numeric type");
- datumtype = *pat++;
- if (*pat == '*')
- pat++; /* ignore '*' for compatibility with pack */
- if (isDIGIT(*pat))
- DIE(aTHX_ "/ cannot take a count" );
- len = POPi;
- star = 0;
- goto redo_switch;
- case 'A':
- case 'Z':
- case 'a':
- if (len > strend - s)
- len = strend - s;
- if (checksum)
- goto uchar_checksum;
- sv = NEWSV(35, len);
- sv_setpvn(sv, s, len);
- s += len;
- if (datumtype == 'A' || datumtype == 'Z') {
- aptr = s; /* borrow register */
- if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
- s = SvPVX(sv);
- while (*s)
- s++;
- }
- else { /* 'A' strips both nulls and spaces */
- s = SvPVX(sv) + len - 1;
- while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
- s--;
- *++s = '\0';
- }
- SvCUR_set(sv, s - SvPVX(sv));
- s = aptr; /* unborrow register */
- }
- XPUSHs(sv_2mortal(sv));
- break;
- case 'B':
- case 'b':
- if (star || len > (strend - s) * 8)
- len = (strend - s) * 8;
- if (checksum) {
- if (!PL_bitcount) {
- Newz(601, PL_bitcount, 256, char);
- for (bits = 1; bits < 256; bits++) {
- if (bits & 1) PL_bitcount[bits]++;
- if (bits & 2) PL_bitcount[bits]++;
- if (bits & 4) PL_bitcount[bits]++;
- if (bits & 8) PL_bitcount[bits]++;
- if (bits & 16) PL_bitcount[bits]++;
- if (bits & 32) PL_bitcount[bits]++;
- if (bits & 64) PL_bitcount[bits]++;
- if (bits & 128) PL_bitcount[bits]++;
- }
- }
- while (len >= 8) {
- culong += PL_bitcount[*(unsigned char*)s++];
- len -= 8;
- }
- if (len) {
- bits = *s;
- if (datumtype == 'b') {
- while (len-- > 0) {
- if (bits & 1) culong++;
- bits >>= 1;
- }
- }
- else {
- while (len-- > 0) {
- if (bits & 128) culong++;
- bits <<= 1;
- }
- }
- }
- break;
- }
- sv = NEWSV(35, len + 1);
- SvCUR_set(sv, len);
- SvPOK_on(sv);
- str = SvPVX(sv);
- if (datumtype == 'b') {
- aint = len;
- for (len = 0; len < aint; len++) {
- if (len & 7) /*SUPPRESS 595*/
- bits >>= 1;
- else
- bits = *s++;
- *str++ = '0' + (bits & 1);
- }
- }
- else {
- aint = len;
- for (len = 0; len < aint; len++) {
- if (len & 7)
- bits <<= 1;
- else
- bits = *s++;
- *str++ = '0' + ((bits & 128) != 0);
- }
- }
- *str = '\0';
- XPUSHs(sv_2mortal(sv));
- break;
- case 'H':
- case 'h':
- if (star || len > (strend - s) * 2)
- len = (strend - s) * 2;
- sv = NEWSV(35, len + 1);
- SvCUR_set(sv, len);
- SvPOK_on(sv);
- str = SvPVX(sv);
- if (datumtype == 'h') {
- aint = len;
- for (len = 0; len < aint; len++) {
- if (len & 1)
- bits >>= 4;
- else
- bits = *s++;
- *str++ = PL_hexdigit[bits & 15];
- }
- }
- else {
- aint = len;
- for (len = 0; len < aint; len++) {
- if (len & 1)
- bits <<= 4;
- else
- bits = *s++;
- *str++ = PL_hexdigit[(bits >> 4) & 15];
- }
- }
- *str = '\0';
- XPUSHs(sv_2mortal(sv));
- break;
- case 'c':
- if (len > strend - s)
- len = strend - s;
- if (checksum) {
- while (len-- > 0) {
- aint = *s++;
- if (aint >= 128) /* fake up signed chars */
- aint -= 256;
- culong += aint;
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0) {
- aint = *s++;
- if (aint >= 128) /* fake up signed chars */
- aint -= 256;
- sv = NEWSV(36, 0);
- sv_setiv(sv, (IV)aint);
- PUSHs(sv_2mortal(sv));
- }
- }
- break;
- case 'C':
- if (len > strend - s)
- len = strend - s;
- if (checksum) {
- uchar_checksum:
- while (len-- > 0) {
- auint = *s++ & 255;
- culong += auint;
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0) {
- auint = *s++ & 255;
- sv = NEWSV(37, 0);
- sv_setiv(sv, (IV)auint);
- PUSHs(sv_2mortal(sv));
- }
- }
- break;
- case 'U':
- if (len > strend - s)
- len = strend - s;
- if (checksum) {
- while (len-- > 0 && s < strend) {
- STRLEN alen;
- auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
- along = alen;
- s += along;
- if (checksum > 32)
- cdouble += (NV)auint;
- else
- culong += auint;
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0 && s < strend) {
- STRLEN alen;
- auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
- along = alen;
- s += along;
- sv = NEWSV(37, 0);
- sv_setuv(sv, (UV)auint);
- PUSHs(sv_2mortal(sv));
- }
- }
- break;
- case 's':
- #if SHORTSIZE == SIZE16
- along = (strend - s) / SIZE16;
- #else
- along = (strend - s) / (natint ? sizeof(short) : SIZE16);
- #endif
- if (len > along)
- len = along;
- if (checksum) {
- #if SHORTSIZE != SIZE16
- if (natint) {
- short ashort;
- while (len-- > 0) {
- COPYNN(s, &ashort, sizeof(short));
- s += sizeof(short);
- culong += ashort;
-
- }
- }
- else
- #endif
- {
- while (len-- > 0) {
- COPY16(s, &ashort);
- #if SHORTSIZE > SIZE16
- if (ashort > 32767)
- ashort -= 65536;
- #endif
- s += SIZE16;
- culong += ashort;
- }
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- #if SHORTSIZE != SIZE16
- if (natint) {
- short ashort;
- while (len-- > 0) {
- COPYNN(s, &ashort, sizeof(short));
- s += sizeof(short);
- sv = NEWSV(38, 0);
- sv_setiv(sv, (IV)ashort);
- PUSHs(sv_2mortal(sv));
- }
- }
- else
- #endif
- {
- while (len-- > 0) {
- COPY16(s, &ashort);
- #if SHORTSIZE > SIZE16
- if (ashort > 32767)
- ashort -= 65536;
- #endif
- s += SIZE16;
- sv = NEWSV(38, 0);
- sv_setiv(sv, (IV)ashort);
- PUSHs(sv_2mortal(sv));
- }
- }
- }
- break;
- case 'v':
- case 'n':
- case 'S':
- #if SHORTSIZE == SIZE16
- along = (strend - s) / SIZE16;
- #else
- unatint = natint && datumtype == 'S';
- along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
- #endif
- if (len > along)
- len = along;
- if (checksum) {
- #if SHORTSIZE != SIZE16
- if (unatint) {
- unsigned short aushort;
- while (len-- > 0) {
- COPYNN(s, &aushort, sizeof(unsigned short));
- s += sizeof(unsigned short);
- culong += aushort;
- }
- }
- else
- #endif
- {
- while (len-- > 0) {
- COPY16(s, &aushort);
- s += SIZE16;
- #ifdef HAS_NTOHS
- if (datumtype == 'n')
- aushort = PerlSock_ntohs(aushort);
- #endif
- #ifdef HAS_VTOHS
- if (datumtype == 'v')
- aushort = vtohs(aushort);
- #endif
- culong += aushort;
- }
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- #if SHORTSIZE != SIZE16
- if (unatint) {
- unsigned short aushort;
- while (len-- > 0) {
- COPYNN(s, &aushort, sizeof(unsigned short));
- s += sizeof(unsigned short);
- sv = NEWSV(39, 0);
- sv_setiv(sv, (UV)aushort);
- PUSHs(sv_2mortal(sv));
- }
- }
- else
- #endif
- {
- while (len-- > 0) {
- COPY16(s, &aushort);
- s += SIZE16;
- sv = NEWSV(39, 0);
- #ifdef HAS_NTOHS
- if (datumtype == 'n')
- aushort = PerlSock_ntohs(aushort);
- #endif
- #ifdef HAS_VTOHS
- if (datumtype == 'v')
- aushort = vtohs(aushort);
- #endif
- sv_setiv(sv, (UV)aushort);
- PUSHs(sv_2mortal(sv));
- }
- }
- }
- break;
- case 'i':
- along = (strend - s) / sizeof(int);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s, &aint, 1, int);
- s += sizeof(int);
- if (checksum > 32)
- cdouble += (NV)aint;
- else
- culong += aint;
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0) {
- Copy(s, &aint, 1, int);
- s += sizeof(int);
- sv = NEWSV(40, 0);
- #ifdef __osf__
- /* Without the dummy below unpack("i", pack("i",-1))
- * return 0xFFffFFff instead of -1 for Digital Unix V4.0
- * cc with optimization turned on.
- *
- * The bug was detected in
- * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
- * with optimization (-O4) turned on.
- * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
- * does not have this problem even with -O4.
- *
- * This bug was reported as DECC_BUGS 1431
- * and tracked internally as GEM_BUGS 7775.
- *
- * The bug is fixed in
- * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
- * UNIX V4.0F support: DEC C V5.9-006 or later
- * UNIX V4.0E support: DEC C V5.8-011 or later
- * and also in DTK.
- *
- * See also few lines later for the same bug.
- */
- (aint) ?
- sv_setiv(sv, (IV)aint) :
- #endif
- sv_setiv(sv, (IV)aint);
- PUSHs(sv_2mortal(sv));
- }
- }
- break;
- case 'I':
- along = (strend - s) / sizeof(unsigned int);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s, &auint, 1, unsigned int);
- s += sizeof(unsigned int);
- if (checksum > 32)
- cdouble += (NV)auint;
- else
- culong += auint;
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0) {
- Copy(s, &auint, 1, unsigned int);
- s += sizeof(unsigned int);
- sv = NEWSV(41, 0);
- #ifdef __osf__
- /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
- * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
- * See details few lines earlier. */
- (auint) ?
- sv_setuv(sv, (UV)auint) :
- #endif
- sv_setuv(sv, (UV)auint);
- PUSHs(sv_2mortal(sv));
- }
- }
- break;
- case 'l':
- #if LONGSIZE == SIZE32
- along = (strend - s) / SIZE32;
- #else
- along = (strend - s) / (natint ? sizeof(long) : SIZE32);
- #endif
- if (len > along)
- len = along;
- if (checksum) {
- #if LONGSIZE != SIZE32
- if (natint) {
- while (len-- > 0) {
- COPYNN(s, &along, sizeof(long));
- s += sizeof(long);
- if (checksum > 32)
- cdouble += (NV)along;
- else
- culong += along;
- }
- }
- else
- #endif
- {
- while (len-- > 0) {
- #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
- I32 along;
- #endif
- COPY32(s, &along);
- #if LONGSIZE > SIZE32
- if (along > 2147483647)
- along -= 4294967296;
- #endif
- s += SIZE32;
- if (checksum > 32)
- cdouble += (NV)along;
- else
- culong += along;
- }
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- #if LONGSIZE != SIZE32
- if (natint) {
- while (len-- > 0) {
- COPYNN(s, &along, sizeof(long));
- s += sizeof(long);
- sv = NEWSV(42, 0);
- sv_setiv(sv, (IV)along);
- PUSHs(sv_2mortal(sv));
- }
- }
- else
- #endif
- {
- while (len-- > 0) {
- #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
- I32 along;
- #endif
- COPY32(s, &along);
- #if LONGSIZE > SIZE32
- if (along > 2147483647)
- along -= 4294967296;
- #endif
- s += SIZE32;
- sv = NEWSV(42, 0);
- sv_setiv(sv, (IV)along);
- PUSHs(sv_2mortal(sv));
- }
- }
- }
- break;
- case 'V':
- case 'N':
- case 'L':
- #if LONGSIZE == SIZE32
- along = (strend - s) / SIZE32;
- #else
- unatint = natint && datumtype == 'L';
- along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
- #endif
- if (len > along)
- len = along;
- if (checksum) {
- #if LONGSIZE != SIZE32
- if (unatint) {
- unsigned long aulong;
- while (len-- > 0) {
- COPYNN(s, &aulong, sizeof(unsigned long));
- s += sizeof(unsigned long);
- if (checksum > 32)
- cdouble += (NV)aulong;
- else
- culong += aulong;
- }
- }
- else
- #endif
- {
- while (len-- > 0) {
- COPY32(s, &aulong);
- s += SIZE32;
- #ifdef HAS_NTOHL
- if (datumtype == 'N')
- aulong = PerlSock_ntohl(aulong);
- #endif
- #ifdef HAS_VTOHL
- if (datumtype == 'V')
- aulong = vtohl(aulong);
- #endif
- if (checksum > 32)
- cdouble += (NV)aulong;
- else
- culong += aulong;
- }
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- #if LONGSIZE != SIZE32
- if (unatint) {
- unsigned long aulong;
- while (len-- > 0) {
- COPYNN(s, &aulong, sizeof(unsigned long));
- s += sizeof(unsigned long);
- sv = NEWSV(43, 0);
- sv_setuv(sv, (UV)aulong);
- PUSHs(sv_2mortal(sv));
- }
- }
- else
- #endif
- {
- while (len-- > 0) {
- COPY32(s, &aulong);
- s += SIZE32;
- #ifdef HAS_NTOHL
- if (datumtype == 'N')
- aulong = PerlSock_ntohl(aulong);
- #endif
- #ifdef HAS_VTOHL
- if (datumtype == 'V')
- aulong = vtohl(aulong);
- #endif
- sv = NEWSV(43, 0);
- sv_setuv(sv, (UV)aulong);
- PUSHs(sv_2mortal(sv));
- }
- }
- }
- break;
- case 'p':
- along = (strend - s) / sizeof(char*);
- if (len > along)
- len = along;
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0) {
- if (sizeof(char*) > strend - s)
- break;
- else {
- Copy(s, &aptr, 1, char*);
- s += sizeof(char*);
- }
- sv = NEWSV(44, 0);
- if (aptr)
- sv_setpv(sv, aptr);
- PUSHs(sv_2mortal(sv));
- }
- break;
- case 'w':
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- {
- UV auv = 0;
- U32 bytes = 0;
-
- while ((len > 0) && (s < strend)) {
- auv = (auv << 7) | (*s & 0x7f);
- /* UTF8_IS_XXXXX not right here - using constant 0x80 */
- if ((U8)(*s++) < 0x80) {
- bytes = 0;
- sv = NEWSV(40, 0);
- sv_setuv(sv, auv);
- PUSHs(sv_2mortal(sv));
- len--;
- auv = 0;
- }
- else if (++bytes >= sizeof(UV)) { /* promote to string */
- char *t;
- STRLEN n_a;
-
- sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
- while (s < strend) {
- sv = mul128(sv, *s & 0x7f);
- if (!(*s++ & 0x80)) {
- bytes = 0;
- break;
- }
- }
- t = SvPV(sv, n_a);
- while (*t == '0')
- t++;
- sv_chop(sv, t);
- PUSHs(sv_2mortal(sv));
- len--;
- auv = 0;
- }
- }
- if ((s >= strend) && bytes)
- DIE(aTHX_ "Unterminated compressed integer");
- }
- break;
- case 'P':
- EXTEND(SP, 1);
- if (sizeof(char*) > strend - s)
- break;
- else {
- Copy(s, &aptr, 1, char*);
- s += sizeof(char*);
- }
- sv = NEWSV(44, 0);
- if (aptr)
- sv_setpvn(sv, aptr, len);
- PUSHs(sv_2mortal(sv));
- break;
- #ifdef HAS_QUAD
- case 'q':
- along = (strend - s) / sizeof(Quad_t);
- if (len > along)
- len = along;
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0) {
- if (s + sizeof(Quad_t) > strend)
- aquad = 0;
- else {
- Copy(s, &aquad, 1, Quad_t);
- s += sizeof(Quad_t);
- }
- sv = NEWSV(42, 0);
- if (aquad >= IV_MIN && aquad <= IV_MAX)
- sv_setiv(sv, (IV)aquad);
- else
- sv_setnv(sv, (NV)aquad);
- PUSHs(sv_2mortal(sv));
- }
- break;
- case 'Q':
- along = (strend - s) / sizeof(Quad_t);
- if (len > along)
- len = along;
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0) {
- if (s + sizeof(Uquad_t) > strend)
- auquad = 0;
- else {
- Copy(s, &auquad, 1, Uquad_t);
- s += sizeof(Uquad_t);
- }
- sv = NEWSV(43, 0);
- if (auquad <= UV_MAX)
- sv_setuv(sv, (UV)auquad);
- else
- sv_setnv(sv, (NV)auquad);
- PUSHs(sv_2mortal(sv));
- }
- break;
- #endif
- /* float and double added gnb@melba.bby.oz.au 22/11/89 */
- case 'f':
- case 'F':
- along = (strend - s) / sizeof(float);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s, &afloat, 1, float);
- s += sizeof(float);
- cdouble += afloat;
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0) {
- Copy(s, &afloat, 1, float);
- s += sizeof(float);
- sv = NEWSV(47, 0);
- sv_setnv(sv, (NV)afloat);
- PUSHs(sv_2mortal(sv));
- }
- }
- break;
- case 'd':
- case 'D':
- along = (strend - s) / sizeof(double);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s, &adouble, 1, double);
- s += sizeof(double);
- cdouble += adouble;
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0) {
- Copy(s, &adouble, 1, double);
- s += sizeof(double);
- sv = NEWSV(48, 0);
- sv_setnv(sv, (NV)adouble);
- PUSHs(sv_2mortal(sv));
- }
- }
- break;
- case 'u':
- /* MKS:
- * Initialise the decode mapping. By using a table driven
- * algorithm, the code will be character-set independent
- * (and just as fast as doing character arithmetic)
- */
- if (PL_uudmap['M'] == 0) {
- int i;
-
- for (i = 0; i < sizeof(PL_uuemap); i += 1)
- PL_uudmap[(U8)PL_uuemap[i]] = i;
- /*
- * Because ' ' and '`' map to the same value,
- * we need to decode them both the same.
- */
- PL_uudmap[' '] = 0;
- }
-
- along = (strend - s) * 3 / 4;
- sv = NEWSV(42, along);
- if (along)
- SvPOK_on(sv);
- while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
- I32 a, b, c, d;
- char hunk[4];
-
- hunk[3] = '\0';
- len = PL_uudmap[*(U8*)s++] & 077;
- while (len > 0) {
- if (s < strend && ISUUCHAR(*s))
- a = PL_uudmap[*(U8*)s++] & 077;
- else
- a = 0;
- if (s < strend && ISUUCHAR(*s))
- b = PL_uudmap[*(U8*)s++] & 077;
- else
- b = 0;
- if (s < strend && ISUUCHAR(*s))
- c = PL_uudmap[*(U8*)s++] & 077;
- else
- c = 0;
- if (s < strend && ISUUCHAR(*s))
- d = PL_uudmap[*(U8*)s++] & 077;
- else
- d = 0;
- hunk[0] = (a << 2) | (b >> 4);
- hunk[1] = (b << 4) | (c >> 2);
- hunk[2] = (c << 6) | d;
- sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
- len -= 3;
- }
- if (*s == '\n')
- s++;
- else if (s[1] == '\n') /* possible checksum byte */
- s += 2;
- }
- XPUSHs(sv_2mortal(sv));
- break;
- }
- if (checksum) {
- sv = NEWSV(42, 0);
- if (strchr("fFdD", datumtype) ||
- (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
- NV trouble;
-
- adouble = 1.0;
- while (checksum >= 16) {
- checksum -= 16;
- adouble *= 65536.0;
- }
- while (checksum >= 4) {
- checksum -= 4;
- adouble *= 16.0;
- }
- while (checksum--)
- adouble *= 2.0;
- along = (1 << checksum) - 1;
- while (cdouble < 0.0)
- cdouble += adouble;
- cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
- sv_setnv(sv, cdouble);
- }
- else {
- if (checksum < 32) {
- aulong = (1 << checksum) - 1;
- culong &= aulong;
- }
- sv_setuv(sv, (UV)culong);
- }
- XPUSHs(sv_2mortal(sv));
- checksum = 0;
- }
- }
- if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
- PUSHs(&PL_sv_undef);
- RETURN;
- }
-
- STATIC void
- S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
- {
- char hunk[5];
-
- *hunk = PL_uuemap[len];
- sv_catpvn(sv, hunk, 1);
- hunk[4] = '\0';
- while (len > 2) {
- hunk[0] = PL_uuemap[(077 & (*s >> 2))];
- hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
- hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
- hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
- sv_catpvn(sv, hunk, 4);
- s += 3;
- len -= 3;
- }
- if (len > 0) {
- char r = (len > 1 ? s[1] : '\0');
- hunk[0] = PL_uuemap[(077 & (*s >> 2))];
- hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
- hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
- hunk[3] = PL_uuemap[0];
- sv_catpvn(sv, hunk, 4);
- }
- sv_catpvn(sv, "\n", 1);
- }
-
- STATIC SV *
- S_is_an_int(pTHX_ char *s, STRLEN l)
- {
- STRLEN n_a;
- SV *result = newSVpvn(s, l);
- char *result_c = SvPV(result, n_a); /* convenience */
- char *out = result_c;
- bool skip = 1;
- bool ignore = 0;
-
- while (*s) {
- switch (*s) {
- case ' ':
- break;
- case '+':
- if (!skip) {
- SvREFCNT_dec(result);
- return (NULL);
- }
- break;
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- skip = 0;
- if (!ignore) {
- *(out++) = *s;
- }
- break;
- case '.':
- ignore = 1;
- break;
- default:
- SvREFCNT_dec(result);
- return (NULL);
- }
- s++;
- }
- *(out++) = '\0';
- SvCUR_set(result, out - result_c);
- return (result);
- }
-
- /* pnum must be '\0' terminated */
- STATIC int
- S_div128(pTHX_ SV *pnum, bool *done)
- {
- STRLEN len;
- char *s = SvPV(pnum, len);
- int m = 0;
- int r = 0;
- char *t = s;
-
- *done = 1;
- while (*t) {
- int i;
-
- i = m * 10 + (*t - '0');
- m = i & 0x7F;
- r = (i >> 7); /* r < 10 */
- if (r) {
- *done = 0;
- }
- *(t++) = '0' + r;
- }
- *(t++) = '\0';
- SvCUR_set(pnum, (STRLEN) (t - s));
- return (m);
- }
-
-
- PP(pp_pack)
- {
- dSP; dMARK; dORIGMARK; dTARGET;
- register SV *cat = TARG;
- register I32 items;
- STRLEN fromlen;
- register char *pat = SvPVx(*++MARK, fromlen);
- char *patcopy;
- register char *patend = pat + fromlen;
- register I32 len;
- I32 datumtype;
- SV *fromstr;
- /*SUPPRESS 442*/
- static char null10[] = {0,0,0,0,0,0,0,0,0,0};
- static char *space10 = " ";
-
- /* These must not be in registers: */
- char achar;
- I16 ashort;
- int aint;
- unsigned int auint;
- I32 along;
- U32 aulong;
- #ifdef HAS_QUAD
- Quad_t aquad;
- Uquad_t auquad;
- #endif
- char *aptr;
- float afloat;
- double adouble;
- int commas = 0;
- #ifdef PERL_NATINT_PACK
- int natint; /* native integer */
- #endif
-
- items = SP - MARK;
- MARK++;
- sv_setpvn(cat, "", 0);
- patcopy = pat;
- while (pat < patend) {
- SV *lengthcode = Nullsv;
- #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
- datumtype = *pat++ & 0xFF;
- #ifdef PERL_NATINT_PACK
- natint = 0;
- #endif
- if (isSPACE(datumtype)) {
- patcopy++;
- continue;
- }
- #ifndef PACKED_IS_OCTETS
- if (datumtype == 'U' && pat == patcopy+1)
- SvUTF8_on(cat);
- #endif
- if (datumtype == '#') {
- while (pat < patend && *pat != '\n')
- pat++;
- continue;
- }
- if (*pat == '!') {
- char *natstr = "sSiIlL";
-
- if (strchr(natstr, datumtype)) {
- #ifdef PERL_NATINT_PACK
- natint = 1;
- #endif
- pat++;
- }
- else
- DIE(aTHX_ "'!' allowed only after types %s", natstr);
- }
- if (*pat == '*') {
- len = strchr("@Xxu", datumtype) ? 0 : items;
- pat++;
- }
- else if (isDIGIT(*pat)) {
- len = *pat++ - '0';
- while (isDIGIT(*pat)) {
- len = (len * 10) + (*pat++ - '0');
- if (len < 0)
- DIE(aTHX_ "Repeat count in pack overflows");
- }
- }
- else
- len = 1;
- if (*pat == '/') {
- ++pat;
- if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
- DIE(aTHX_ "/ must be followed by a*, A* or Z*");
- lengthcode = sv_2mortal(newSViv(sv_len(items > 0
- ? *MARK : &PL_sv_no)
- + (*pat == 'Z' ? 1 : 0)));
- }
- switch(datumtype) {
- default:
- DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
- case ',': /* grandfather in commas but with a warning */
- if (commas++ == 0 && ckWARN(WARN_PACK))
- Perl_warner(aTHX_ WARN_PACK,
- "Invalid type in pack: '%c'", (int)datumtype);
- break;
- case '%':
- DIE(aTHX_ "%% may only be used in unpack");
- case '@':
- len -= SvCUR(cat);
- if (len > 0)
- goto grow;
- len = -len;
- if (len > 0)
- goto shrink;
- break;
- case 'X':
- shrink:
- if (SvCUR(cat) < len)
- DIE(aTHX_ "X outside of string");
- SvCUR(cat) -= len;
- *SvEND(cat) = '\0';
- break;
- case 'x':
- grow:
- while (len >= 10) {
- sv_catpvn(cat, null10, 10);
- len -= 10;
- }
- sv_catpvn(cat, null10, len);
- break;
- case 'A':
- case 'Z':
- case 'a':
- fromstr = NEXTFROM;
- aptr = SvPV(fromstr, fromlen);
- if (pat[-1] == '*') {
- len = fromlen;
- if (datumtype == 'Z')
- ++len;
- }
- if (fromlen >= len) {
- sv_catpvn(cat, aptr, len);
- if (datumtype == 'Z')
- *(SvEND(cat)-1) = '\0';
- }
- else {
- sv_catpvn(cat, aptr, fromlen);
- len -= fromlen;
- if (datumtype == 'A') {
- while (len >= 10) {
- sv_catpvn(cat, space10, 10);
- len -= 10;
- }
- sv_catpvn(cat, space10, len);
- }
- else {
- while (len >= 10) {
- sv_catpvn(cat, null10, 10);
- len -= 10;
- }
- sv_catpvn(cat, null10, len);
- }
- }
- break;
- case 'B':
- case 'b':
- {
- register char *str;
- I32 saveitems;
-
- fromstr = NEXTFROM;
- saveitems = items;
- str = SvPV(fromstr, fromlen);
- if (pat[-1] == '*')
- len = fromlen;
- aint = SvCUR(cat);
- SvCUR(cat) += (len+7)/8;
- SvGROW(cat, SvCUR(cat) + 1);
- aptr = SvPVX(cat) + aint;
- if (len > fromlen)
- len = fromlen;
- aint = len;
- items = 0;
- if (datumtype == 'B') {
- for (len = 0; len++ < aint;) {
- items |= *str++ & 1;
- if (len & 7)
- items <<= 1;
- else {
- *aptr++ = items & 0xff;
- items = 0;
- }
- }
- }
- else {
- for (len = 0; len++ < aint;) {
- if (*str++ & 1)
- items |= 128;
- if (len & 7)
- items >>= 1;
- else {
- *aptr++ = items & 0xff;
- items = 0;
- }
- }
- }
- if (aint & 7) {
- if (datumtype == 'B')
- items <<= 7 - (aint & 7);
- else
- items >>= 7 - (aint & 7);
- *aptr++ = items & 0xff;
- }
- str = SvPVX(cat) + SvCUR(cat);
- while (aptr <= str)
- *aptr++ = '\0';
-
- items = saveitems;
- }
- break;
- case 'H':
- case 'h':
- {
- register char *str;
- I32 saveitems;
-
- fromstr = NEXTFROM;
- saveitems = items;
- str = SvPV(fromstr, fromlen);
- if (pat[-1] == '*')
- len = fromlen;
- aint = SvCUR(cat);
- SvCUR(cat) += (len+1)/2;
- SvGROW(cat, SvCUR(cat) + 1);
- aptr = SvPVX(cat) + aint;
- if (len > fromlen)
- len = fromlen;
- aint = len;
- items = 0;
- if (datumtype == 'H') {
- for (len = 0; len++ < aint;) {
- if (isALPHA(*str))
- items |= ((*str++ & 15) + 9) & 15;
- else
- items |= *str++ & 15;
- if (len & 1)
- items <<= 4;
- else {
- *aptr++ = items & 0xff;
- items = 0;
- }
- }
- }
- else {
- for (len = 0; len++ < aint;) {
- if (isALPHA(*str))
- items |= (((*str++ & 15) + 9) & 15) << 4;
- else
- items |= (*str++ & 15) << 4;
- if (len & 1)
- items >>= 4;
- else {
- *aptr++ = items & 0xff;
- items = 0;
- }
- }
- }
- if (aint & 1)
- *aptr++ = items & 0xff;
- str = SvPVX(cat) + SvCUR(cat);
- while (aptr <= str)
- *aptr++ = '\0';
-
- items = saveitems;
- }
- break;
- case 'C':
- case 'c':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aint = SvIV(fromstr);
- achar = aint;
- sv_catpvn(cat, &achar, sizeof(char));
- }
- break;
- case 'U':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- auint = SvUV(fromstr);
- SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
- SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
- - SvPVX(cat));
- }
- *SvEND(cat) = '\0';
- break;
- /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
- case 'f':
- case 'F':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- afloat = (float)SvNV(fromstr);
- sv_catpvn(cat, (char *)&afloat, sizeof (float));
- }
- break;
- case 'd':
- case 'D':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- adouble = (double)SvNV(fromstr);
- sv_catpvn(cat, (char *)&adouble, sizeof (double));
- }
- break;
- case 'n':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- ashort = (I16)SvIV(fromstr);
- #ifdef HAS_HTONS
- ashort = PerlSock_htons(ashort);
- #endif
- CAT16(cat, &ashort);
- }
- break;
- case 'v':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- ashort = (I16)SvIV(fromstr);
- #ifdef HAS_HTOVS
- ashort = htovs(ashort);
- #endif
- CAT16(cat, &ashort);
- }
- break;
- case 'S':
- #if SHORTSIZE != SIZE16
- if (natint) {
- unsigned short aushort;
-
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aushort = SvUV(fromstr);
- sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
- }
- }
- else
- #endif
- {
- U16 aushort;
-
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aushort = (U16)SvUV(fromstr);
- CAT16(cat, &aushort);
- }
-
- }
- break;
- case 's':
- #if SHORTSIZE != SIZE16
- if (natint) {
- short ashort;
-
- while (len-- > 0) {
- fromstr = NEXTFROM;
- ashort = SvIV(fromstr);
- sv_catpvn(cat, (char *)&ashort, sizeof(short));
- }
- }
- else
- #endif
- {
- while (len-- > 0) {
- fromstr = NEXTFROM;
- ashort = (I16)SvIV(fromstr);
- CAT16(cat, &ashort);
- }
- }
- break;
- case 'I':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- auint = SvUV(fromstr);
- sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
- }
- break;
- case 'w':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- adouble = Perl_floor(SvNV(fromstr));
-
- if (adouble < 0)
- DIE(aTHX_ "Cannot compress negative numbers");
-
- if (
- #if UVSIZE > 4 && UVSIZE >= NVSIZE
- adouble <= 0xffffffff
- #else
- # ifdef CXUX_BROKEN_CONSTANT_CONVERT
- adouble <= UV_MAX_cxux
- # else
- adouble <= UV_MAX
- # endif
- #endif
- )
- {
- char buf[1 + sizeof(UV)];
- char *in = buf + sizeof(buf);
- UV auv = U_V(adouble);
-
- do {
- *--in = (auv & 0x7f) | 0x80;
- auv >>= 7;
- } while (auv);
- buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
- sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
- }
- else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
- char *from, *result, *in;
- SV *norm;
- STRLEN len;
- bool done;
-
- /* Copy string and check for compliance */
- from = SvPV(fromstr, len);
- if ((norm = is_an_int(from, len)) == NULL)
- DIE(aTHX_ "can compress only unsigned integer");
-
- New('w', result, len, char);
- in = result + len;
- done = FALSE;
- while (!done)
- *--in = div128(norm, &done) | 0x80;
- result[len - 1] &= 0x7F; /* clear continue bit */
- sv_catpvn(cat, in, (result + len) - in);
- Safefree(result);
- SvREFCNT_dec(norm); /* free norm */
- }
- else if (SvNOKp(fromstr)) {
- char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
- char *in = buf + sizeof(buf);
-
- do {
- double next = floor(adouble / 128);
- *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
- if (in <= buf) /* this cannot happen ;-) */
- DIE(aTHX_ "Cannot compress integer");
- in--;
- adouble = next;
- } while (adouble > 0);
- buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
- sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
- }
- else
- DIE(aTHX_ "Cannot compress non integer");
- }
- break;
- case 'i':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aint = SvIV(fromstr);
- sv_catpvn(cat, (char*)&aint, sizeof(int));
- }
- break;
- case 'N':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aulong = SvUV(fromstr);
- #ifdef HAS_HTONL
- aulong = PerlSock_htonl(aulong);
- #endif
- CAT32(cat, &aulong);
- }
- break;
- case 'V':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aulong = SvUV(fromstr);
- #ifdef HAS_HTOVL
- aulong = htovl(aulong);
- #endif
- CAT32(cat, &aulong);
- }
- break;
- case 'L':
- #if LONGSIZE != SIZE32
- if (natint) {
- unsigned long aulong;
-
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aulong = SvUV(fromstr);
- sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
- }
- }
- else
- #endif
- {
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aulong = SvUV(fromstr);
- CAT32(cat, &aulong);
- }
- }
- break;
- case 'l':
- #if LONGSIZE != SIZE32
- if (natint) {
- long along;
-
- while (len-- > 0) {
- fromstr = NEXTFROM;
- along = SvIV(fromstr);
- sv_catpvn(cat, (char *)&along, sizeof(long));
- }
- }
- else
- #endif
- {
- while (len-- > 0) {
- fromstr = NEXTFROM;
- along = SvIV(fromstr);
- CAT32(cat, &along);
- }
- }
- break;
- #ifdef HAS_QUAD
- case 'Q':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- auquad = (Uquad_t)SvUV(fromstr);
- sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
- }
- break;
- case 'q':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aquad = (Quad_t)SvIV(fromstr);
- sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
- }
- break;
- #endif
- case 'P':
- len = 1; /* assume SV is correct length */
- /* FALL THROUGH */
- case 'p':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- if (fromstr == &PL_sv_undef)
- aptr = NULL;
- else {
- STRLEN n_a;
- /* XXX better yet, could spirit away the string to
- * a safe spot and hang on to it until the result
- * of pack() (and all copies of the result) are
- * gone.
- */
- if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
- || (SvPADTMP(fromstr)
- && !SvREADONLY(fromstr))))
- {
- Perl_warner(aTHX_ WARN_PACK,
- "Attempt to pack pointer to temporary value");
- }
- if (SvPOK(fromstr) || SvNIOK(fromstr))
- aptr = SvPV(fromstr,n_a);
- else
- aptr = SvPV_force(fromstr,n_a);
- }
- sv_catpvn(cat, (char*)&aptr, sizeof(char*));
- }
- break;
- case 'u':
- fromstr = NEXTFROM;
- aptr = SvPV(fromstr, fromlen);
- SvGROW(cat, fromlen * 4 / 3);
- if (len <= 1)
- len = 45;
- else
- len = len / 3 * 3;
- while (fromlen > 0) {
- I32 todo;
-
- if (fromlen > len)
- todo = len;
- else
- todo = fromlen;
- doencodes(cat, aptr, todo);
- fromlen -= todo;
- aptr += todo;
- }
- break;
- }
- }
- SvSETMAGIC(cat);
- SP = ORIGMARK;
- PUSHs(cat);
- RETURN;
- }
- #undef NEXTFROM
-
-
PP(pp_split)
{
dSP; dTARG;
--- 4007,4012 ----
***************
*** 5816,5822 ****
#endif
if (!pm || !s)
DIE(aTHX_ "panic: pp_split");
! rx = pm->op_pmregexp;
TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
(pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
--- 4042,4048 ----
#endif
if (!pm || !s)
DIE(aTHX_ "panic: pp_split");
! rx = PM_GETRE(pm);
TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
(pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
***************
*** 5842,5848 ****
av_extend(ary,0);
av_clear(ary);
SPAGAIN;
! if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)ary, mg));
}
--- 4068,4074 ----
av_extend(ary,0);
av_clear(ary);
SPAGAIN;
! if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)ary, mg));
}
***************
*** 6089,6095 ****
void
Perl_unlock_condpair(pTHX_ void *svv)
{
! MAGIC *mg = mg_find((SV*)svv, 'm');
if (!mg)
Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
--- 4315,4321 ----
void
Perl_unlock_condpair(pTHX_ void *svv)
{
! MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
if (!mg)
Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
***************
*** 6099,6105 ****
MgOWNER(mg) = 0;
COND_SIGNAL(MgOWNERCONDP(mg));
DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
! PTR2UV(thr), PTR2UV(svv));)
MUTEX_UNLOCK(MgMUTEXP(mg));
}
#endif /* USE_THREADS */
--- 4325,4331 ----
MgOWNER(mg) = 0;
COND_SIGNAL(MgOWNERCONDP(mg));
DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
! PTR2UV(thr), PTR2UV(svv)));
MUTEX_UNLOCK(MgMUTEXP(mg));
}
#endif /* USE_THREADS */
diff -c 'perl-5.7.1/pp.h' 'perl-5.7.2/pp.h'
Index: ./pp.h
*** ./pp.h Tue Mar 6 04:06:42 2001
--- ./pp.h Mon Jul 9 17:11:17 2001
***************
*** 344,349 ****
--- 344,350 ----
if (PL_amagic_generation) { \
SV* tmpsv; \
SV* arg= sp[shift]; \
+ if(0) goto am_again; /* shut up unused warning */ \
am_again: \
if ((SvAMAGIC(arg))&&\
(tmpsv=AMG_CALLun(arg,meth))) {\
diff -c 'perl-5.7.1/pp.sym' 'perl-5.7.2/pp.sym'
Index: ./pp.sym
*** ./pp.sym Thu Apr 5 20:48:11 2001
--- ./pp.sym Thu Jul 12 07:16:43 2001
***************
*** 16,22 ****
Perl_ck_exit
Perl_ck_ftst
Perl_ck_fun
- Perl_ck_fun_locale
Perl_ck_glob
Perl_ck_grep
Perl_ck_index
--- 16,21 ----
***************
*** 34,40 ****
Perl_ck_rfun
Perl_ck_rvconst
Perl_ck_sassign
- Perl_ck_scmp
Perl_ck_select
Perl_ck_shift
Perl_ck_sort
--- 33,38 ----
diff -c 'perl-5.7.1/pp_ctl.c' 'perl-5.7.2/pp_ctl.c'
Index: ./pp_ctl.c
*** ./pp_ctl.c Fri Apr 6 16:20:21 2001
--- ./pp_ctl.c Wed Jul 11 04:30:22 2001
***************
*** 86,114 ****
SV *tmpstr;
STRLEN len;
MAGIC *mg = Null(MAGIC*);
!
tmpstr = POPs;
if (SvROK(tmpstr)) {
SV *sv = SvRV(tmpstr);
if(SvMAGICAL(sv))
! mg = mg_find(sv, 'r');
}
if (mg) {
regexp *re = (regexp *)mg->mg_obj;
! ReREFCNT_dec(pm->op_pmregexp);
! pm->op_pmregexp = ReREFCNT_inc(re);
}
else {
t = SvPV(tmpstr, len);
/* Check against the last compiled regexp. */
! if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
! pm->op_pmregexp->prelen != len ||
! memNE(pm->op_pmregexp->precomp, t, len))
{
! if (pm->op_pmregexp) {
! ReREFCNT_dec(pm->op_pmregexp);
! pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
}
if (PL_op->op_flags & OPf_SPECIAL)
PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
--- 86,121 ----
SV *tmpstr;
STRLEN len;
MAGIC *mg = Null(MAGIC*);
!
tmpstr = POPs;
+
+ /* prevent recompiling under /o and ithreads. */
+ #if defined(USE_ITHREADS) || defined(USE_THREADS)
+ if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
+ RETURN;
+ #endif
+
if (SvROK(tmpstr)) {
SV *sv = SvRV(tmpstr);
if(SvMAGICAL(sv))
! mg = mg_find(sv, PERL_MAGIC_qr);
}
if (mg) {
regexp *re = (regexp *)mg->mg_obj;
! ReREFCNT_dec(PM_GETRE(pm));
! PM_SETRE(pm, ReREFCNT_inc(re));
}
else {
t = SvPV(tmpstr, len);
/* Check against the last compiled regexp. */
! if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
! PM_GETRE(pm)->prelen != len ||
! memNE(PM_GETRE(pm)->precomp, t, len))
{
! if (PM_GETRE(pm)) {
! ReREFCNT_dec(PM_GETRE(pm));
! PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
}
if (PL_op->op_flags & OPf_SPECIAL)
PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
***************
*** 121,127 ****
if (pm->op_pmdynflags & PMdf_UTF8)
t = (char*)bytes_to_utf8((U8*)t, &len);
}
! pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
Safefree(t);
PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
--- 128,134 ----
if (pm->op_pmdynflags & PMdf_UTF8)
t = (char*)bytes_to_utf8((U8*)t, &len);
}
! PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
Safefree(t);
PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
***************
*** 138,147 ****
}
#endif
! if (!pm->op_pmregexp->prelen && PL_curpm)
pm = PL_curpm;
! else if (strEQ("\\s+", pm->op_pmregexp->precomp))
pm->op_pmflags |= PMf_WHITE;
/* XXX runtime compiled output needs to move to the pad */
if (pm->op_pmflags & PMf_KEEP) {
--- 145,156 ----
}
#endif
! if (!PM_GETRE(pm)->prelen && PL_curpm)
pm = PL_curpm;
! else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
pm->op_pmflags |= PMf_WHITE;
+ else
+ pm->op_pmflags &= ~PMf_WHITE;
/* XXX runtime compiled output needs to move to the pad */
if (pm->op_pmflags & PMf_KEEP) {
***************
*** 227,235 ****
I32 i;
if (SvTYPE(sv) < SVt_PVMG)
(void)SvUPGRADE(sv, SVt_PVMG);
! if (!(mg = mg_find(sv, 'g'))) {
! sv_magic(sv, Nullsv, 'g', Nullch, 0);
! mg = mg_find(sv, 'g');
}
i = m - orig;
if (DO_UTF8(sv))
--- 236,244 ----
I32 i;
if (SvTYPE(sv) < SVt_PVMG)
(void)SvUPGRADE(sv, SVt_PVMG);
! if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
! sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
! mg = mg_find(sv, PERL_MAGIC_regex_global);
}
i = m - orig;
if (DO_UTF8(sv))
***************
*** 312,329 ****
register char *s;
register char *send;
register I32 arg;
! register SV *sv;
! char *item;
! I32 itemsize;
! I32 fieldsize;
I32 lines = 0;
bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
! char *chophere;
! char *linemark;
NV value;
! bool gotsome;
STRLEN len;
! STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1;
bool item_is_utf = FALSE;
if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
--- 321,338 ----
register char *s;
register char *send;
register I32 arg;
! register SV *sv = Nullsv;
! char *item = Nullch;
! I32 itemsize = 0;
! I32 fieldsize = 0;
I32 lines = 0;
bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
! char *chophere = Nullch;
! char *linemark = Nullch;
NV value;
! bool gotsome = FALSE;
STRLEN len;
! STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
bool item_is_utf = FALSE;
if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
***************
*** 373,379 ****
PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
else
PerlIO_printf(Perl_debug_log, "%-16s\n", name);
! } )
switch (*fpc++) {
case FF_LINEMARK:
linemark = t;
--- 382,388 ----
PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
else
PerlIO_printf(Perl_debug_log, "%-16s\n", name);
! } );
switch (*fpc++) {
case FF_LINEMARK:
linemark = t;
***************
*** 887,893 ****
register I32 max;
HV *stash;
GV *gv;
! CV *cv;
I32 gimme = GIMME;
OP* nextop = PL_op->op_next;
I32 overloading = 0;
--- 896,902 ----
register I32 max;
HV *stash;
GV *gv;
! CV *cv = 0;
I32 gimme = GIMME;
OP* nextop = PL_op->op_next;
I32 overloading = 0;
***************
*** 1031,1037 ****
? ( (PL_op->op_private & OPpSORT_INTEGER)
? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
: ( overloading ? amagic_ncmp : sv_ncmp))
! : ( (PL_op->op_private & OPpLOCALE)
? ( overloading
? amagic_cmp_locale
: sv_cmp_locale_static)
--- 1040,1046 ----
? ( (PL_op->op_private & OPpSORT_INTEGER)
? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
: ( overloading ? amagic_ncmp : sv_ncmp))
! : ( IN_LOCALE_RUNTIME
? ( overloading
? amagic_cmp_locale
: sv_cmp_locale_static)
***************
*** 1079,1085 ****
if (PL_op->op_private & OPpFLIP_LINENUM) {
struct io *gp_io;
flip = PL_last_in_gv
! && (gp_io = GvIOp(PL_last_in_gv))
&& SvIV(sv) == (IV)IoLINES(gp_io);
} else {
flip = SvTRUE(sv);
--- 1088,1094 ----
if (PL_op->op_private & OPpFLIP_LINENUM) {
struct io *gp_io;
flip = PL_last_in_gv
! && (gp_io = GvIO(PL_last_in_gv))
&& SvIV(sv) == (IV)IoLINES(gp_io);
} else {
flip = SvTRUE(sv);
***************
*** 1160,1166 ****
SV *targ = PAD_SV(cUNOP->op_first->op_targ);
sv_inc(targ);
if ((PL_op->op_private & OPpFLIP_LINENUM)
! ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
: SvTRUE(sv) ) {
sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
sv_catpv(targ, "E0");
--- 1169,1176 ----
SV *targ = PAD_SV(cUNOP->op_first->op_targ);
sv_inc(targ);
if ((PL_op->op_private & OPpFLIP_LINENUM)
! ? (GvIO(PL_last_in_gv)
! && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
: SvTRUE(sv) ) {
sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
sv_catpv(targ, "E0");
***************
*** 1433,1442 ****
}
else {
sv_setpvn(ERRSV, message, msglen);
- if (PL_hints & HINT_UTF8)
- SvUTF8_on(ERRSV);
- else
- SvUTF8_off(ERRSV);
}
}
else
--- 1443,1448 ----
***************
*** 1545,1551 ****
if (MAXARG)
count = POPi;
! EXTEND(SP, 10);
for (;;) {
/* we may be in a higher stacklevel, so dig down deeper */
while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
--- 1551,1557 ----
if (MAXARG)
count = POPi;
!
for (;;) {
/* we may be in a higher stacklevel, so dig down deeper */
while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
***************
*** 1554,1561 ****
cxix = dopoptosub_at(ccstack, top_si->si_cxix);
}
if (cxix < 0) {
! if (GIMME != G_ARRAY)
RETPUSHUNDEF;
RETURN;
}
if (PL_DBsub && cxix >= 0 &&
--- 1560,1569 ----
cxix = dopoptosub_at(ccstack, top_si->si_cxix);
}
if (cxix < 0) {
! if (GIMME != G_ARRAY) {
! EXTEND(SP, 1);
RETPUSHUNDEF;
+ }
RETURN;
}
if (PL_DBsub && cxix >= 0 &&
***************
*** 1577,1582 ****
--- 1585,1591 ----
stashname = CopSTASHPV(cx->blk_oldcop);
if (GIMME != G_ARRAY) {
+ EXTEND(SP, 1);
if (!stashname)
PUSHs(&PL_sv_undef);
else {
***************
*** 1587,1592 ****
--- 1596,1603 ----
RETURN;
}
+ EXTEND(SP, 10);
+
if (!stashname)
PUSHs(&PL_sv_undef);
else
***************
*** 2835,2840 ****
--- 2846,2854 ----
PL_compcv = (CV*)NEWSV(1104,0);
sv_upgrade((SV *)PL_compcv, SVt_PVCV);
CvEVAL_on(PL_compcv);
+ assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
+ cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
+
#ifdef USE_THREADS
CvOWNER(PL_compcv) = 0;
New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
***************
*** 3019,3025 ****
SV *sv;
char *name;
STRLEN len;
! char *tryname;
SV *namesv = Nullsv;
SV** svp;
I32 gimme = GIMME_V;
--- 3033,3039 ----
SV *sv;
char *name;
STRLEN len;
! char *tryname = Nullch;
SV *namesv = Nullsv;
SV** svp;
I32 gimme = GIMME_V;
***************
*** 3032,3038 ****
sv = POPs;
if (SvNIOKp(sv)) {
! if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
UV rev = 0, ver = 0, sver = 0;
STRLEN len;
U8 *s = (U8*)SvPVX(sv);
--- 3046,3052 ----
sv = POPs;
if (SvNIOKp(sv)) {
! if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
UV rev = 0, ver = 0, sver = 0;
STRLEN len;
U8 *s = (U8*)SvPVX(sv);
***************
*** 3592,3605 ****
STRLEN len;
register char *s = SvPV_force(sv, len);
register char *send = s + len;
! register char *base;
register I32 skipspaces = 0;
! bool noblank;
! bool repeat;
bool postspace = FALSE;
U16 *fops;
register U16 *fpc;
! U16 *linepc;
register I32 arg;
bool ischop;
--- 3606,3619 ----
STRLEN len;
register char *s = SvPV_force(sv, len);
register char *send = s + len;
! register char *base = Nullch;
register I32 skipspaces = 0;
! bool noblank = FALSE;
! bool repeat = FALSE;
bool postspace = FALSE;
U16 *fops;
register U16 *fpc;
! U16 *linepc = 0;
register I32 arg;
bool ischop;
***************
*** 3778,3784 ****
}
Copy(fops, s, arg, U16);
Safefree(fops);
! sv_magic(sv, Nullsv, 'f', Nullch, 0);
SvCOMPILED_on(sv);
}
--- 3792,3798 ----
}
Copy(fops, s, arg, U16);
Safefree(fops);
! sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
SvCOMPILED_on(sv);
}
diff -c 'perl-5.7.1/pp_hot.c' 'perl-5.7.2/pp_hot.c'
Index: ./pp_hot.c
*** ./pp_hot.c Sat Mar 31 08:26:25 2001
--- ./pp_hot.c Mon Jul 9 17:11:17 2001
***************
*** 142,186 ****
dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
{
dPOPTOPssrl;
! SV* rcopy = Nullsv;
! if (SvGMAGICAL(left))
! mg_get(left);
! if (TARG == right && SvGMAGICAL(right))
! mg_get(right);
! if (TARG == right && left != right)
! /* Clone since otherwise we cannot prepend. */
! rcopy = sv_2mortal(newSVsv(right));
!
! if (TARG != left)
! sv_setsv(TARG, left);
!
! if (TARG == right) {
! if (left == right) {
! /* $right = $right . $right; */
! STRLEN rlen;
! char *rpv = SvPV(right, rlen);
!
! sv_catpvn(TARG, rpv, rlen);
! }
! else /* $right = $left . $right; */
! sv_catsv(TARG, rcopy);
}
! else {
! if (!SvOK(TARG)) /* Avoid warning when concatenating to undef. */
! sv_setpv(TARG, "");
! /* $other = $left . $right; */
! /* $left = $left . $right; */
! sv_catsv(TARG, right);
}
#if defined(PERL_Y2KWARN)
! if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) {
! STRLEN n;
! char *s = SvPV(TARG,n);
! if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
! && (n == 2 || !isDIGIT(s[n-3])))
{
Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
"about to append an integer to '19'");
--- 142,181 ----
dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
{
dPOPTOPssrl;
! STRLEN llen;
! char* lpv;
! bool lbyte;
! STRLEN rlen;
! char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
! bool rbyte = !SvUTF8(right);
! if (TARG == right && right != left) {
! right = sv_2mortal(newSVpvn(rpv, rlen));
! rpv = SvPV(right, rlen); /* no point setting UTF8 here */
! }
! if (TARG != left) {
! lpv = SvPV(left, llen); /* mg_get(left) may happen here */
! lbyte = !SvUTF8(left);
! sv_setpvn(TARG, lpv, llen);
! if (!lbyte)
! SvUTF8_on(TARG);
! else
! SvUTF8_off(TARG);
}
! else { /* TARG == left */
! if (SvGMAGICAL(left))
! mg_get(left); /* or mg_get(left) may happen here */
! if (!SvOK(TARG))
! sv_setpv(left, "");
! lpv = SvPV_nomg(left, llen);
! lbyte = !SvUTF8(left);
}
#if defined(PERL_Y2KWARN)
! if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
! if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
! && (llen == 2 || !isDIGIT(lpv[llen - 3])))
{
Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
"about to append an integer to '19'");
***************
*** 188,193 ****
--- 183,198 ----
}
#endif
+ if (lbyte != rbyte) {
+ if (lbyte)
+ sv_utf8_upgrade_nomg(TARG);
+ else {
+ sv_utf8_upgrade_nomg(right);
+ rpv = SvPV(right, rlen);
+ }
+ }
+ sv_catpvn_nomg(TARG, rpv, rlen);
+
SETTARG;
RETURN;
}
***************
*** 390,397 ****
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
! register UV auv;
! bool auvok;
bool a_valid = 0;
if (!useleft) {
--- 395,402 ----
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
! register UV auv = 0;
! bool auvok = FALSE;
bool a_valid = 0;
if (!useleft) {
***************
*** 553,559 ****
gv = (GV*)*++MARK;
else
gv = PL_defoutgv;
! if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
had_magic:
if (MARK == ORIGMARK) {
/* If using default handle then we need to make space to
--- 558,564 ----
gv = (GV*)*++MARK;
else
gv = PL_defoutgv;
! if ((mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
had_magic:
if (MARK == ORIGMARK) {
/* If using default handle then we need to make space to
***************
*** 577,583 ****
RETURN;
}
if (!(io = GvIO(gv))) {
! if ((GvEGV(gv)) && (mg = SvTIED_mg((SV*)GvEGV(gv),'q')))
goto had_magic;
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
--- 582,589 ----
RETURN;
}
if (!(io = GvIO(gv))) {
! if ((GvEGV(gv))
! && (mg = SvTIED_mg((SV*)GvEGV(gv), PERL_MAGIC_tiedscalar)))
goto had_magic;
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
***************
*** 1184,1190 ****
register PMOP *pm = cPMOP;
SV *rv = sv_newmortal();
SV *sv = newSVrv(rv, "Regexp");
! sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0);
RETURNX(PUSHs(rv));
}
--- 1190,1196 ----
register PMOP *pm = cPMOP;
SV *rv = sv_newmortal();
SV *sv = newSVrv(rv, "Regexp");
! sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
RETURNX(PUSHs(rv));
}
***************
*** 1198,1204 ****
I32 global;
I32 r_flags = REXEC_CHECKED;
char *truebase; /* Start of string */
! register REGEXP *rx = pm->op_pmregexp;
bool rxtainted;
I32 gimme = GIMME;
STRLEN len;
--- 1204,1210 ----
I32 global;
I32 r_flags = REXEC_CHECKED;
char *truebase; /* Start of string */
! register REGEXP *rx = PM_GETRE(pm);
bool rxtainted;
I32 gimme = GIMME;
STRLEN len;
***************
*** 1232,1238 ****
if (!rx->prelen && PL_curpm) {
pm = PL_curpm;
! rx = pm->op_pmregexp;
}
if (rx->minlen > len) goto failure;
--- 1238,1244 ----
if (!rx->prelen && PL_curpm) {
pm = PL_curpm;
! rx = PM_GETRE(pm);
}
if (rx->minlen > len) goto failure;
***************
*** 1242,1248 ****
if ((global = pm->op_pmflags & PMf_GLOBAL)) {
rx->startp[0] = -1;
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
! MAGIC* mg = mg_find(TARG, 'g');
if (mg && mg->mg_len >= 0) {
if (!(rx->reganch & ROPT_GPOS_SEEN))
rx->endp[0] = rx->startp[0] = mg->mg_len;
--- 1248,1254 ----
if ((global = pm->op_pmflags & PMf_GLOBAL)) {
rx->startp[0] = -1;
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
! MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
if (mg && mg->mg_len >= 0) {
if (!(rx->reganch & ROPT_GPOS_SEEN))
rx->endp[0] = rx->startp[0] = mg->mg_len;
***************
*** 1276,1281 ****
--- 1282,1288 ----
}
if (rx->reganch & RE_USE_INTUIT &&
DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
+ PL_bostr = truebase;
s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
if (!s)
***************
*** 1341,1350 ****
if (global) {
MAGIC* mg = 0;
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
! mg = mg_find(TARG, 'g');
if (!mg) {
! sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
! mg = mg_find(TARG, 'g');
}
if (rx->startp[0] != -1) {
mg->mg_len = rx->endp[0];
--- 1348,1357 ----
if (global) {
MAGIC* mg = 0;
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
! mg = mg_find(TARG, PERL_MAGIC_regex_global);
if (!mg) {
! sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
! mg = mg_find(TARG, PERL_MAGIC_regex_global);
}
if (rx->startp[0] != -1) {
mg->mg_len = rx->endp[0];
***************
*** 1403,1409 ****
ret_no:
if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
! MAGIC* mg = mg_find(TARG, 'g');
if (mg)
mg->mg_len = -1;
}
--- 1410,1416 ----
ret_no:
if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
! MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
if (mg)
mg->mg_len = -1;
}
***************
*** 1427,1433 ****
I32 gimme = GIMME_V;
MAGIC *mg;
! if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
PUTBACK;
--- 1434,1440 ----
I32 gimme = GIMME_V;
MAGIC *mg;
! if ((mg = SvTIED_mg((SV*)PL_last_in_gv, PERL_MAGIC_tiedscalar))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
PUTBACK;
***************
*** 1621,1627 ****
U32 defer = PL_op->op_private & OPpLVAL_DEFER;
SV *sv;
U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
! I32 preeminent;
if (SvTYPE(hv) == SVt_PVHV) {
if (PL_op->op_private & OPpLVAL_INTRO)
--- 1628,1634 ----
U32 defer = PL_op->op_private & OPpLVAL_DEFER;
SV *sv;
U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
! I32 preeminent = 0;
if (SvTYPE(hv) == SVt_PVHV) {
if (PL_op->op_private & OPpLVAL_INTRO)
***************
*** 1648,1654 ****
lv = sv_newmortal();
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
! sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
SvREFCNT_dec(key2); /* sv_magic() increments refcount */
LvTARG(lv) = SvREFCNT_inc(hv);
LvTARGLEN(lv) = 1;
--- 1655,1661 ----
lv = sv_newmortal();
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
! sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
SvREFCNT_dec(key2); /* sv_magic() increments refcount */
LvTARG(lv) = SvREFCNT_inc(hv);
LvTARGLEN(lv) = 1;
***************
*** 1712,1723 ****
SP = newsp;
else if (gimme == G_SCALAR) {
MARK = newsp + 1;
! if (MARK <= SP)
if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
*MARK = TOPs;
else
*MARK = sv_mortalcopy(TOPs);
! else {
MEXTEND(mark,0);
*MARK = &PL_sv_undef;
}
--- 1719,1730 ----
SP = newsp;
else if (gimme == G_SCALAR) {
MARK = newsp + 1;
! if (MARK <= SP) {
if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
*MARK = TOPs;
else
*MARK = sv_mortalcopy(TOPs);
! } else {
MEXTEND(mark,0);
*MARK = &PL_sv_undef;
}
***************
*** 1811,1823 ****
SvREFCNT_dec(*itersvp);
! if ((sv = SvMAGICAL(av)
! ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
! : AvARRAY(av)[++cx->blk_loop.iterix]))
SvTEMP_off(sv);
else
sv = &PL_sv_undef;
! if (av != PL_curstack && SvIMMORTAL(sv)) {
SV *lv = cx->blk_loop.iterlval;
if (lv && SvREFCNT(lv) > 1) {
SvREFCNT_dec(lv);
--- 1818,1838 ----
SvREFCNT_dec(*itersvp);
! if (SvMAGICAL(av) || AvREIFY(av)) {
! SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
! if (svp)
! sv = *svp;
! else
! sv = Nullsv;
! }
! else {
! sv = AvARRAY(av)[++cx->blk_loop.iterix];
! }
! if (sv)
SvTEMP_off(sv);
else
sv = &PL_sv_undef;
! if (av != PL_curstack && sv == &PL_sv_undef) {
SV *lv = cx->blk_loop.iterlval;
if (lv && SvREFCNT(lv) > 1) {
SvREFCNT_dec(lv);
***************
*** 1829,1835 ****
lv = cx->blk_loop.iterlval = NEWSV(26, 0);
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
! sv_magic(lv, Nullsv, 'y', Nullch, 0);
}
LvTARG(lv) = SvREFCNT_inc(av);
LvTARGOFF(lv) = cx->blk_loop.iterix;
--- 1844,1850 ----
lv = cx->blk_loop.iterlval = NEWSV(26, 0);
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
! sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
}
LvTARG(lv) = SvREFCNT_inc(av);
LvTARGOFF(lv) = cx->blk_loop.iterix;
***************
*** 1860,1866 ****
bool rxtainted;
char *orig;
I32 r_flags;
! register REGEXP *rx = pm->op_pmregexp;
STRLEN len;
int force_on_match = 0;
I32 oldsave = PL_savestack_ix;
--- 1875,1881 ----
bool rxtainted;
char *orig;
I32 r_flags;
! register REGEXP *rx = PM_GETRE(pm);
STRLEN len;
int force_on_match = 0;
I32 oldsave = PL_savestack_ix;
***************
*** 1906,1912 ****
if (!rx->prelen && PL_curpm) {
pm = PL_curpm;
! rx = pm->op_pmregexp;
}
r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
? REXEC_COPY_STR : 0;
--- 1921,1927 ----
if (!rx->prelen && PL_curpm) {
pm = PL_curpm;
! rx = PM_GETRE(pm);
}
r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
? REXEC_COPY_STR : 0;
***************
*** 1918,1923 ****
--- 1933,1939 ----
}
orig = m = s;
if (rx->reganch & RE_USE_INTUIT) {
+ PL_bostr = orig;
s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
if (!s)
***************
*** 2299,2305 ****
else if (gimme == G_ARRAY) {
EXTEND_MORTAL(SP - newsp);
for (mark = newsp + 1; mark <= SP; mark++) {
! if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
/* Might be flattened array after $#array = */
PUTBACK;
POPSUB(cx,sv);
--- 2315,2322 ----
else if (gimme == G_ARRAY) {
EXTEND_MORTAL(SP - newsp);
for (mark = newsp + 1; mark <= SP; mark++) {
! if (*mark != &PL_sv_undef
! && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
/* Might be flattened array after $#array = */
PUTBACK;
POPSUB(cx,sv);
***************
*** 2306,2316 ****
PL_curpm = newpm;
LEAVE;
LEAVESUB(sv);
! DIE(aTHX_ "Can't return %s from lvalue subroutine",
! (*mark != &PL_sv_undef)
! ? (SvREADONLY(TOPs)
! ? "a readonly value" : "a temporary")
! : "an uninitialized value");
}
else {
/* Can be a localized value subject to deletion. */
--- 2323,2330 ----
PL_curpm = newpm;
LEAVE;
LEAVESUB(sv);
! DIE(aTHX_ "Can't return a %s from lvalue subroutine",
! SvREADONLY(TOPs) ? "readonly value" : "temporary");
}
else {
/* Can be a localized value subject to deletion. */
***************
*** 2553,2559 ****
COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
MgOWNER(mg) = thr;
DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
! thr, sv);)
MUTEX_UNLOCK(MgMUTEXP(mg));
SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
}
--- 2567,2573 ----
COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
MgOWNER(mg) = thr;
DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
! thr, sv));
MUTEX_UNLOCK(MgMUTEXP(mg));
SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
}
***************
*** 2637,2643 ****
}
DEBUG_S(if (CvDEPTH(cv) != 0)
PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
! CvDEPTH(cv)););
SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
}
}
--- 2651,2657 ----
}
DEBUG_S(if (CvDEPTH(cv) != 0)
PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
! CvDEPTH(cv)));
SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
}
}
***************
*** 2889,2895 ****
lv = sv_newmortal();
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
! sv_magic(lv, Nullsv, 'y', Nullch, 0);
LvTARG(lv) = SvREFCNT_inc(av);
LvTARGOFF(lv) = elem;
LvTARGLEN(lv) = 1;
--- 2903,2909 ----
lv = sv_newmortal();
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
! sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
LvTARG(lv) = SvREFCNT_inc(av);
LvTARGOFF(lv) = elem;
LvTARGLEN(lv) = 1;
***************
*** 2975,2981 ****
HV* stash;
char* name;
STRLEN namelen;
! char* packname;
STRLEN packlen;
name = SvPV(meth, namelen);
--- 2989,2995 ----
HV* stash;
char* name;
STRLEN namelen;
! char* packname = 0;
STRLEN packlen;
name = SvPV(meth, namelen);
***************
*** 2985,2996 ****
Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
if (SvGMAGICAL(sv))
! mg_get(sv);
if (SvROK(sv))
ob = (SV*)SvRV(sv);
else {
GV* iogv;
packname = Nullch;
if (!SvOK(sv) ||
!(packname = SvPV(sv, packlen)) ||
--- 2999,3011 ----
Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
if (SvGMAGICAL(sv))
! mg_get(sv);
if (SvROK(sv))
ob = (SV*)SvRV(sv);
else {
GV* iogv;
+ /* this isn't a reference */
packname = Nullch;
if (!SvOK(sv) ||
!(packname = SvPV(sv, packlen)) ||
***************
*** 2997,3002 ****
--- 3012,3018 ----
!(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
!(ob=(SV*)GvIO(iogv)))
{
+ /* this isn't the name of a filehandle either */
if (!packname ||
((UTF8_IS_START(*packname) && DO_UTF8(sv))
? !isIDFIRST_utf8((U8*)packname)
***************
*** 3007,3018 ****
SvOK(sv) ? "without a package or object reference"
: "on an undefined value");
}
! stash = gv_stashpvn(packname, packlen, TRUE);
goto fetch;
}
*(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
}
if (!ob || !(SvOBJECT(ob)
|| (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
&& SvOBJECT(ob))))
--- 3023,3037 ----
SvOK(sv) ? "without a package or object reference"
: "on an undefined value");
}
! /* assume it's a package name */
! stash = gv_stashpvn(packname, packlen, FALSE);
goto fetch;
}
+ /* it _is_ a filehandle name -- replace with a reference */
*(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
}
+ /* if we got here, ob should be a reference or a glob */
if (!ob || !(SvOBJECT(ob)
|| (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
&& SvOBJECT(ob))))
***************
*** 3024,3029 ****
--- 3043,3051 ----
stash = SvSTASH(ob);
fetch:
+ /* NOTE: stash may be null, hope hv_fetch_ent and
+ gv_fetchmethod can cope (it seems they can) */
+
/* shortcut for simple names */
if (hashp) {
HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
***************
*** 3036,3046 ****
}
gv = gv_fetchmethod(stash, name);
if (!gv) {
char* leaf = name;
char* sep = Nullch;
char* p;
- GV* gv;
for (p = name; *p; p++) {
if (*p == '\'')
--- 3058,3075 ----
}
gv = gv_fetchmethod(stash, name);
+
if (!gv) {
+ /* This code tries to figure out just what went wrong with
+ gv_fetchmethod. It therefore needs to duplicate a lot of
+ the internals of that function. We can't move it inside
+ Perl_gv_fetchmethod_autoload(), however, since that would
+ cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
+ don't want that.
+ */
char* leaf = name;
char* sep = Nullch;
char* p;
for (p = name; *p; p++) {
if (*p == '\'')
***************
*** 3049,3072 ****
sep = p, leaf = p + 2;
}
if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
! packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
packlen = strlen(packname);
}
else {
packname = name;
packlen = sep - name;
}
! gv = gv_fetchpv(packname, 0, SVt_PVHV);
! if (gv && isGV(gv)) {
Perl_croak(aTHX_
! "Can't locate object method \"%s\" via package \"%s\"",
! leaf, packname);
}
else {
Perl_croak(aTHX_
! "Can't locate object method \"%s\" via package \"%s\""
! " (perhaps you forgot to load \"%s\"?)",
! leaf, packname, packname);
}
}
return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
--- 3078,3105 ----
sep = p, leaf = p + 2;
}
if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
! /* the method name is unqualified or starts with SUPER:: */
! packname = sep ? CopSTASHPV(PL_curcop) :
! stash ? HvNAME(stash) : packname;
packlen = strlen(packname);
}
else {
+ /* the method name is qualified */
packname = name;
packlen = sep - name;
}
!
! /* we're relying on gv_fetchmethod not autovivifying the stash */
! if (gv_stashpvn(packname, packlen, FALSE)) {
Perl_croak(aTHX_
! "Can't locate object method \"%s\" via package \"%.*s\"",
! leaf, (int)packlen, packname);
}
else {
Perl_croak(aTHX_
! "Can't locate object method \"%s\" via package \"%.*s\""
! " (perhaps you forgot to load \"%.*s\"?)",
! leaf, (int)packlen, packname, (int)packlen, packname);
}
}
return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
***************
*** 3083,3089 ****
MUTEX_LOCK(CvMUTEXP(cv));
DEBUG_S(if (CvDEPTH(cv) != 0)
PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
! CvDEPTH(cv)););
assert(thr == CvOWNER(cv));
CvOWNER(cv) = 0;
MUTEX_UNLOCK(CvMUTEXP(cv));
--- 3116,3122 ----
MUTEX_LOCK(CvMUTEXP(cv));
DEBUG_S(if (CvDEPTH(cv) != 0)
PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
! CvDEPTH(cv)));
assert(thr == CvOWNER(cv));
CvOWNER(cv) = 0;
MUTEX_UNLOCK(CvMUTEXP(cv));
diff -c /dev/null 'perl-5.7.2/pp_pack.c'
Index: ./pp_pack.c
*** ./pp_pack.c Thu Jan 1 02:00:00 1970
--- ./pp_pack.c Mon Jul 9 17:11:17 2001
***************
*** 0 ****
--- 1,1824 ----
+ /* pp_pack.c
+ *
+ * Copyright (c) 1991-2001, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+ #include "EXTERN.h"
+ #define PERL_IN_PP_PACK_C
+ #include "perl.h"
+
+ /*
+ * The compiler on Concurrent CX/UX systems has a subtle bug which only
+ * seems to show up when compiling pp.c - it generates the wrong double
+ * precision constant value for (double)UV_MAX when used inline in the body
+ * of the code below, so this makes a static variable up front (which the
+ * compiler seems to get correct) and uses it in place of UV_MAX below.
+ */
+ #ifdef CXUX_BROKEN_CONSTANT_CONVERT
+ static double UV_MAX_cxux = ((double)UV_MAX);
+ #endif
+
+ /*
+ * Offset for integer pack/unpack.
+ *
+ * On architectures where I16 and I32 aren't really 16 and 32 bits,
+ * which for now are all Crays, pack and unpack have to play games.
+ */
+
+ /*
+ * These values are required for portability of pack() output.
+ * If they're not right on your machine, then pack() and unpack()
+ * wouldn't work right anyway; you'll need to apply the Cray hack.
+ * (I'd like to check them with #if, but you can't use sizeof() in
+ * the preprocessor.) --???
+ */
+ /*
+ The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
+ defines are now in config.h. --Andy Dougherty April 1998
+ */
+ #define SIZE16 2
+ #define SIZE32 4
+
+ /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
+ --jhi Feb 1999 */
+
+ #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
+ # define PERL_NATINT_PACK
+ #endif
+
+ #if LONGSIZE > 4 && defined(_CRAY)
+ # if BYTEORDER == 0x12345678
+ # define OFF16(p) (char*)(p)
+ # define OFF32(p) (char*)(p)
+ # else
+ # if BYTEORDER == 0x87654321
+ # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
+ # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
+ # else
+ }}}} bad cray byte order
+ # endif
+ # endif
+ # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
+ # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
+ # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
+ # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
+ # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
+ #else
+ # define COPY16(s,p) Copy(s, p, SIZE16, char)
+ # define COPY32(s,p) Copy(s, p, SIZE32, char)
+ # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
+ # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
+ # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
+ #endif
+
+ STATIC SV *
+ S_mul128(pTHX_ SV *sv, U8 m)
+ {
+ STRLEN len;
+ char *s = SvPV(sv, len);
+ char *t;
+ U32 i = 0;
+
+ if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
+ SV *tmpNew = newSVpvn("0000000000", 10);
+
+ sv_catsv(tmpNew, sv);
+ SvREFCNT_dec(sv); /* free old sv */
+ sv = tmpNew;
+ s = SvPV(sv, len);
+ }
+ t = s + len - 1;
+ while (!*t) /* trailing '\0'? */
+ t--;
+ while (t > s) {
+ i = ((*t - '0') << 7) + m;
+ *(t--) = '0' + (i % 10);
+ m = i / 10;
+ }
+ return (sv);
+ }
+
+ /* Explosives and implosives. */
+
+ #if 'I' == 73 && 'J' == 74
+ /* On an ASCII/ISO kind of system */
+ #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
+ #else
+ /*
+ Some other sort of character set - use memchr() so we don't match
+ the null byte.
+ */
+ #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
+ #endif
+
+
+ PP(pp_unpack)
+ {
+ dSP;
+ dPOPPOPssrl;
+ I32 start_sp_offset = SP - PL_stack_base;
+ I32 gimme = GIMME_V;
+ SV *sv;
+ STRLEN llen;
+ STRLEN rlen;
+ register char *pat = SvPV(left, llen);
+ #ifdef PACKED_IS_OCTETS
+ /* Packed side is assumed to be octets - so force downgrade if it
+ has been UTF-8 encoded by accident
+ */
+ register char *s = SvPVbyte(right, rlen);
+ #else
+ register char *s = SvPV(right, rlen);
+ #endif
+ char *strend = s + rlen;
+ char *strbeg = s;
+ register char *patend = pat + llen;
+ I32 datumtype;
+ register I32 len;
+ register I32 bits = 0;
+ register char *str;
+
+ /* These must not be in registers: */
+ short ashort;
+ int aint;
+ long along;
+ #ifdef HAS_QUAD
+ Quad_t aquad;
+ #endif
+ U16 aushort;
+ unsigned int auint;
+ U32 aulong;
+ #ifdef HAS_QUAD
+ Uquad_t auquad;
+ #endif
+ char *aptr;
+ float afloat;
+ double adouble;
+ I32 checksum = 0;
+ register U32 culong = 0;
+ NV cdouble = 0.0;
+ int commas = 0;
+ int star;
+ #ifdef PERL_NATINT_PACK
+ int natint; /* native integer */
+ int unatint; /* unsigned native integer */
+ #endif
+
+ if (gimme != G_ARRAY) { /* arrange to do first one only */
+ /*SUPPRESS 530*/
+ for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
+ if (strchr("aAZbBhHP", *patend) || *pat == '%') {
+ patend++;
+ while (isDIGIT(*patend) || *patend == '*')
+ patend++;
+ }
+ else
+ patend++;
+ }
+ while (pat < patend) {
+ reparse:
+ datumtype = *pat++ & 0xFF;
+ #ifdef PERL_NATINT_PACK
+ natint = 0;
+ #endif
+ if (isSPACE(datumtype))
+ continue;
+ if (datumtype == '#') {
+ while (pat < patend && *pat != '\n')
+ pat++;
+ continue;
+ }
+ if (*pat == '!') {
+ char *natstr = "sSiIlL";
+
+ if (strchr(natstr, datumtype)) {
+ #ifdef PERL_NATINT_PACK
+ natint = 1;
+ #endif
+ pat++;
+ }
+ else
+ DIE(aTHX_ "'!' allowed only after types %s", natstr);
+ }
+ star = 0;
+ if (pat >= patend)
+ len = 1;
+ else if (*pat == '*') {
+ len = strend - strbeg; /* long enough */
+ pat++;
+ star = 1;
+ }
+ else if (isDIGIT(*pat)) {
+ len = *pat++ - '0';
+ while (isDIGIT(*pat)) {
+ len = (len * 10) + (*pat++ - '0');
+ if (len < 0)
+ DIE(aTHX_ "Repeat count in unpack overflows");
+ }
+ }
+ else
+ len = (datumtype != '@');
+ redo_switch:
+ switch(datumtype) {
+ default:
+ DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
+ case ',': /* grandfather in commas but with a warning */
+ if (commas++ == 0 && ckWARN(WARN_UNPACK))
+ Perl_warner(aTHX_ WARN_UNPACK,
+ "Invalid type in unpack: '%c'", (int)datumtype);
+ break;
+ case '%':
+ if (len == 1 && pat[-1] != '1')
+ len = 16;
+ checksum = len;
+ culong = 0;
+ cdouble = 0;
+ if (pat < patend)
+ goto reparse;
+ break;
+ case '@':
+ if (len > strend - strbeg)
+ DIE(aTHX_ "@ outside of string");
+ s = strbeg + len;
+ break;
+ case 'X':
+ if (len > s - strbeg)
+ DIE(aTHX_ "X outside of string");
+ s -= len;
+ break;
+ case 'x':
+ if (len > strend - s)
+ DIE(aTHX_ "x outside of string");
+ s += len;
+ break;
+ case '/':
+ if (start_sp_offset >= SP - PL_stack_base)
+ DIE(aTHX_ "/ must follow a numeric type");
+ datumtype = *pat++;
+ if (*pat == '*')
+ pat++; /* ignore '*' for compatibility with pack */
+ if (isDIGIT(*pat))
+ DIE(aTHX_ "/ cannot take a count" );
+ len = POPi;
+ star = 0;
+ goto redo_switch;
+ case 'A':
+ case 'Z':
+ case 'a':
+ if (len > strend - s)
+ len = strend - s;
+ if (checksum)
+ goto uchar_checksum;
+ sv = NEWSV(35, len);
+ sv_setpvn(sv, s, len);
+ s += len;
+ if (datumtype == 'A' || datumtype == 'Z') {
+ aptr = s; /* borrow register */
+ if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
+ s = SvPVX(sv);
+ while (*s)
+ s++;
+ }
+ else { /* 'A' strips both nulls and spaces */
+ s = SvPVX(sv) + len - 1;
+ while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
+ s--;
+ *++s = '\0';
+ }
+ SvCUR_set(sv, s - SvPVX(sv));
+ s = aptr; /* unborrow register */
+ }
+ XPUSHs(sv_2mortal(sv));
+ break;
+ case 'B':
+ case 'b':
+ if (star || len > (strend - s) * 8)
+ len = (strend - s) * 8;
+ if (checksum) {
+ if (!PL_bitcount) {
+ Newz(601, PL_bitcount, 256, char);
+ for (bits = 1; bits < 256; bits++) {
+ if (bits & 1) PL_bitcount[bits]++;
+ if (bits & 2) PL_bitcount[bits]++;
+ if (bits & 4) PL_bitcount[bits]++;
+ if (bits & 8) PL_bitcount[bits]++;
+ if (bits & 16) PL_bitcount[bits]++;
+ if (bits & 32) PL_bitcount[bits]++;
+ if (bits & 64) PL_bitcount[bits]++;
+ if (bits & 128) PL_bitcount[bits]++;
+ }
+ }
+ while (len >= 8) {
+ culong += PL_bitcount[*(unsigned char*)s++];
+ len -= 8;
+ }
+ if (len) {
+ bits = *s;
+ if (datumtype == 'b') {
+ while (len-- > 0) {
+ if (bits & 1) culong++;
+ bits >>= 1;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ if (bits & 128) culong++;
+ bits <<= 1;
+ }
+ }
+ }
+ break;
+ }
+ sv = NEWSV(35, len + 1);
+ SvCUR_set(sv, len);
+ SvPOK_on(sv);
+ str = SvPVX(sv);
+ if (datumtype == 'b') {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 7) /*SUPPRESS 595*/
+ bits >>= 1;
+ else
+ bits = *s++;
+ *str++ = '0' + (bits & 1);
+ }
+ }
+ else {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 7)
+ bits <<= 1;
+ else
+ bits = *s++;
+ *str++ = '0' + ((bits & 128) != 0);
+ }
+ }
+ *str = '\0';
+ XPUSHs(sv_2mortal(sv));
+ break;
+ case 'H':
+ case 'h':
+ if (star || len > (strend - s) * 2)
+ len = (strend - s) * 2;
+ sv = NEWSV(35, len + 1);
+ SvCUR_set(sv, len);
+ SvPOK_on(sv);
+ str = SvPVX(sv);
+ if (datumtype == 'h') {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 1)
+ bits >>= 4;
+ else
+ bits = *s++;
+ *str++ = PL_hexdigit[bits & 15];
+ }
+ }
+ else {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 1)
+ bits <<= 4;
+ else
+ bits = *s++;
+ *str++ = PL_hexdigit[(bits >> 4) & 15];
+ }
+ }
+ *str = '\0';
+ XPUSHs(sv_2mortal(sv));
+ break;
+ case 'c':
+ if (len > strend - s)
+ len = strend - s;
+ if (checksum) {
+ while (len-- > 0) {
+ aint = *s++;
+ if (aint >= 128) /* fake up signed chars */
+ aint -= 256;
+ culong += aint;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ aint = *s++;
+ if (aint >= 128) /* fake up signed chars */
+ aint -= 256;
+ sv = NEWSV(36, 0);
+ sv_setiv(sv, (IV)aint);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'C':
+ if (len > strend - s)
+ len = strend - s;
+ if (checksum) {
+ uchar_checksum:
+ while (len-- > 0) {
+ auint = *s++ & 255;
+ culong += auint;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ auint = *s++ & 255;
+ sv = NEWSV(37, 0);
+ sv_setiv(sv, (IV)auint);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'U':
+ if (len > strend - s)
+ len = strend - s;
+ if (checksum) {
+ while (len-- > 0 && s < strend) {
+ STRLEN alen;
+ auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
+ along = alen;
+ s += along;
+ if (checksum > 32)
+ cdouble += (NV)auint;
+ else
+ culong += auint;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0 && s < strend) {
+ STRLEN alen;
+ auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
+ along = alen;
+ s += along;
+ sv = NEWSV(37, 0);
+ sv_setuv(sv, (UV)auint);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 's':
+ #if SHORTSIZE == SIZE16
+ along = (strend - s) / SIZE16;
+ #else
+ along = (strend - s) / (natint ? sizeof(short) : SIZE16);
+ #endif
+ if (len > along)
+ len = along;
+ if (checksum) {
+ #if SHORTSIZE != SIZE16
+ if (natint) {
+ short ashort;
+ while (len-- > 0) {
+ COPYNN(s, &ashort, sizeof(short));
+ s += sizeof(short);
+ culong += ashort;
+
+ }
+ }
+ else
+ #endif
+ {
+ while (len-- > 0) {
+ COPY16(s, &ashort);
+ #if SHORTSIZE > SIZE16
+ if (ashort > 32767)
+ ashort -= 65536;
+ #endif
+ s += SIZE16;
+ culong += ashort;
+ }
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ #if SHORTSIZE != SIZE16
+ if (natint) {
+ short ashort;
+ while (len-- > 0) {
+ COPYNN(s, &ashort, sizeof(short));
+ s += sizeof(short);
+ sv = NEWSV(38, 0);
+ sv_setiv(sv, (IV)ashort);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ else
+ #endif
+ {
+ while (len-- > 0) {
+ COPY16(s, &ashort);
+ #if SHORTSIZE > SIZE16
+ if (ashort > 32767)
+ ashort -= 65536;
+ #endif
+ s += SIZE16;
+ sv = NEWSV(38, 0);
+ sv_setiv(sv, (IV)ashort);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ }
+ break;
+ case 'v':
+ case 'n':
+ case 'S':
+ #if SHORTSIZE == SIZE16
+ along = (strend - s) / SIZE16;
+ #else
+ unatint = natint && datumtype == 'S';
+ along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
+ #endif
+ if (len > along)
+ len = along;
+ if (checksum) {
+ #if SHORTSIZE != SIZE16
+ if (unatint) {
+ unsigned short aushort;
+ while (len-- > 0) {
+ COPYNN(s, &aushort, sizeof(unsigned short));
+ s += sizeof(unsigned short);
+ culong += aushort;
+ }
+ }
+ else
+ #endif
+ {
+ while (len-- > 0) {
+ COPY16(s, &aushort);
+ s += SIZE16;
+ #ifdef HAS_NTOHS
+ if (datumtype == 'n')
+ aushort = PerlSock_ntohs(aushort);
+ #endif
+ #ifdef HAS_VTOHS
+ if (datumtype == 'v')
+ aushort = vtohs(aushort);
+ #endif
+ culong += aushort;
+ }
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ #if SHORTSIZE != SIZE16
+ if (unatint) {
+ unsigned short aushort;
+ while (len-- > 0) {
+ COPYNN(s, &aushort, sizeof(unsigned short));
+ s += sizeof(unsigned short);
+ sv = NEWSV(39, 0);
+ sv_setiv(sv, (UV)aushort);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ else
+ #endif
+ {
+ while (len-- > 0) {
+ COPY16(s, &aushort);
+ s += SIZE16;
+ sv = NEWSV(39, 0);
+ #ifdef HAS_NTOHS
+ if (datumtype == 'n')
+ aushort = PerlSock_ntohs(aushort);
+ #endif
+ #ifdef HAS_VTOHS
+ if (datumtype == 'v')
+ aushort = vtohs(aushort);
+ #endif
+ sv_setiv(sv, (UV)aushort);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ }
+ break;
+ case 'i':
+ along = (strend - s) / sizeof(int);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &aint, 1, int);
+ s += sizeof(int);
+ if (checksum > 32)
+ cdouble += (NV)aint;
+ else
+ culong += aint;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ Copy(s, &aint, 1, int);
+ s += sizeof(int);
+ sv = NEWSV(40, 0);
+ #ifdef __osf__
+ /* Without the dummy below unpack("i", pack("i",-1))
+ * return 0xFFffFFff instead of -1 for Digital Unix V4.0
+ * cc with optimization turned on.
+ *
+ * The bug was detected in
+ * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
+ * with optimization (-O4) turned on.
+ * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
+ * does not have this problem even with -O4.
+ *
+ * This bug was reported as DECC_BUGS 1431
+ * and tracked internally as GEM_BUGS 7775.
+ *
+ * The bug is fixed in
+ * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
+ * UNIX V4.0F support: DEC C V5.9-006 or later
+ * UNIX V4.0E support: DEC C V5.8-011 or later
+ * and also in DTK.
+ *
+ * See also few lines later for the same bug.
+ */
+ (aint) ?
+ sv_setiv(sv, (IV)aint) :
+ #endif
+ sv_setiv(sv, (IV)aint);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'I':
+ along = (strend - s) / sizeof(unsigned int);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &auint, 1, unsigned int);
+ s += sizeof(unsigned int);
+ if (checksum > 32)
+ cdouble += (NV)auint;
+ else
+ culong += auint;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ Copy(s, &auint, 1, unsigned int);
+ s += sizeof(unsigned int);
+ sv = NEWSV(41, 0);
+ #ifdef __osf__
+ /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
+ * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
+ * See details few lines earlier. */
+ (auint) ?
+ sv_setuv(sv, (UV)auint) :
+ #endif
+ sv_setuv(sv, (UV)auint);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'l':
+ #if LONGSIZE == SIZE32
+ along = (strend - s) / SIZE32;
+ #else
+ along = (strend - s) / (natint ? sizeof(long) : SIZE32);
+ #endif
+ if (len > along)
+ len = along;
+ if (checksum) {
+ #if LONGSIZE != SIZE32
+ if (natint) {
+ while (len-- > 0) {
+ COPYNN(s, &along, sizeof(long));
+ s += sizeof(long);
+ if (checksum > 32)
+ cdouble += (NV)along;
+ else
+ culong += along;
+ }
+ }
+ else
+ #endif
+ {
+ while (len-- > 0) {
+ #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
+ I32 along;
+ #endif
+ COPY32(s, &along);
+ #if LONGSIZE > SIZE32
+ if (along > 2147483647)
+ along -= 4294967296;
+ #endif
+ s += SIZE32;
+ if (checksum > 32)
+ cdouble += (NV)along;
+ else
+ culong += along;
+ }
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ #if LONGSIZE != SIZE32
+ if (natint) {
+ while (len-- > 0) {
+ COPYNN(s, &along, sizeof(long));
+ s += sizeof(long);
+ sv = NEWSV(42, 0);
+ sv_setiv(sv, (IV)along);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ else
+ #endif
+ {
+ while (len-- > 0) {
+ #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
+ I32 along;
+ #endif
+ COPY32(s, &along);
+ #if LONGSIZE > SIZE32
+ if (along > 2147483647)
+ along -= 4294967296;
+ #endif
+ s += SIZE32;
+ sv = NEWSV(42, 0);
+ sv_setiv(sv, (IV)along);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ }
+ break;
+ case 'V':
+ case 'N':
+ case 'L':
+ #if LONGSIZE == SIZE32
+ along = (strend - s) / SIZE32;
+ #else
+ unatint = natint && datumtype == 'L';
+ along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
+ #endif
+ if (len > along)
+ len = along;
+ if (checksum) {
+ #if LONGSIZE != SIZE32
+ if (unatint) {
+ unsigned long aulong;
+ while (len-- > 0) {
+ COPYNN(s, &aulong, sizeof(unsigned long));
+ s += sizeof(unsigned long);
+ if (checksum > 32)
+ cdouble += (NV)aulong;
+ else
+ culong += aulong;
+ }
+ }
+ else
+ #endif
+ {
+ while (len-- > 0) {
+ COPY32(s, &aulong);
+ s += SIZE32;
+ #ifdef HAS_NTOHL
+ if (datumtype == 'N')
+ aulong = PerlSock_ntohl(aulong);
+ #endif
+ #ifdef HAS_VTOHL
+ if (datumtype == 'V')
+ aulong = vtohl(aulong);
+ #endif
+ if (checksum > 32)
+ cdouble += (NV)aulong;
+ else
+ culong += aulong;
+ }
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ #if LONGSIZE != SIZE32
+ if (unatint) {
+ unsigned long aulong;
+ while (len-- > 0) {
+ COPYNN(s, &aulong, sizeof(unsigned long));
+ s += sizeof(unsigned long);
+ sv = NEWSV(43, 0);
+ sv_setuv(sv, (UV)aulong);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ else
+ #endif
+ {
+ while (len-- > 0) {
+ COPY32(s, &aulong);
+ s += SIZE32;
+ #ifdef HAS_NTOHL
+ if (datumtype == 'N')
+ aulong = PerlSock_ntohl(aulong);
+ #endif
+ #ifdef HAS_VTOHL
+ if (datumtype == 'V')
+ aulong = vtohl(aulong);
+ #endif
+ sv = NEWSV(43, 0);
+ sv_setuv(sv, (UV)aulong);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ }
+ break;
+ case 'p':
+ along = (strend - s) / sizeof(char*);
+ if (len > along)
+ len = along;
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ if (sizeof(char*) > strend - s)
+ break;
+ else {
+ Copy(s, &aptr, 1, char*);
+ s += sizeof(char*);
+ }
+ sv = NEWSV(44, 0);
+ if (aptr)
+ sv_setpv(sv, aptr);
+ PUSHs(sv_2mortal(sv));
+ }
+ break;
+ case 'w':
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ {
+ UV auv = 0;
+ U32 bytes = 0;
+
+ while ((len > 0) && (s < strend)) {
+ auv = (auv << 7) | (*s & 0x7f);
+ /* UTF8_IS_XXXXX not right here - using constant 0x80 */
+ if ((U8)(*s++) < 0x80) {
+ bytes = 0;
+ sv = NEWSV(40, 0);
+ sv_setuv(sv, auv);
+ PUSHs(sv_2mortal(sv));
+ len--;
+ auv = 0;
+ }
+ else if (++bytes >= sizeof(UV)) { /* promote to string */
+ char *t;
+ STRLEN n_a;
+
+ sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
+ while (s < strend) {
+ sv = mul128(sv, *s & 0x7f);
+ if (!(*s++ & 0x80)) {
+ bytes = 0;
+ break;
+ }
+ }
+ t = SvPV(sv, n_a);
+ while (*t == '0')
+ t++;
+ sv_chop(sv, t);
+ PUSHs(sv_2mortal(sv));
+ len--;
+ auv = 0;
+ }
+ }
+ if ((s >= strend) && bytes)
+ DIE(aTHX_ "Unterminated compressed integer");
+ }
+ break;
+ case 'P':
+ EXTEND(SP, 1);
+ if (sizeof(char*) > strend - s)
+ break;
+ else {
+ Copy(s, &aptr, 1, char*);
+ s += sizeof(char*);
+ }
+ sv = NEWSV(44, 0);
+ if (aptr)
+ sv_setpvn(sv, aptr, len);
+ PUSHs(sv_2mortal(sv));
+ break;
+ #ifdef HAS_QUAD
+ case 'q':
+ along = (strend - s) / sizeof(Quad_t);
+ if (len > along)
+ len = along;
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ if (s + sizeof(Quad_t) > strend)
+ aquad = 0;
+ else {
+ Copy(s, &aquad, 1, Quad_t);
+ s += sizeof(Quad_t);
+ }
+ sv = NEWSV(42, 0);
+ if (aquad >= IV_MIN && aquad <= IV_MAX)
+ sv_setiv(sv, (IV)aquad);
+ else
+ sv_setnv(sv, (NV)aquad);
+ PUSHs(sv_2mortal(sv));
+ }
+ break;
+ case 'Q':
+ along = (strend - s) / sizeof(Quad_t);
+ if (len > along)
+ len = along;
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ if (s + sizeof(Uquad_t) > strend)
+ auquad = 0;
+ else {
+ Copy(s, &auquad, 1, Uquad_t);
+ s += sizeof(Uquad_t);
+ }
+ sv = NEWSV(43, 0);
+ if (auquad <= UV_MAX)
+ sv_setuv(sv, (UV)auquad);
+ else
+ sv_setnv(sv, (NV)auquad);
+ PUSHs(sv_2mortal(sv));
+ }
+ break;
+ #endif
+ /* float and double added gnb@melba.bby.oz.au 22/11/89 */
+ case 'f':
+ case 'F':
+ along = (strend - s) / sizeof(float);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &afloat, 1, float);
+ s += sizeof(float);
+ cdouble += afloat;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ Copy(s, &afloat, 1, float);
+ s += sizeof(float);
+ sv = NEWSV(47, 0);
+ sv_setnv(sv, (NV)afloat);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'd':
+ case 'D':
+ along = (strend - s) / sizeof(double);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &adouble, 1, double);
+ s += sizeof(double);
+ cdouble += adouble;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ Copy(s, &adouble, 1, double);
+ s += sizeof(double);
+ sv = NEWSV(48, 0);
+ sv_setnv(sv, (NV)adouble);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'u':
+ /* MKS:
+ * Initialise the decode mapping. By using a table driven
+ * algorithm, the code will be character-set independent
+ * (and just as fast as doing character arithmetic)
+ */
+ if (PL_uudmap['M'] == 0) {
+ int i;
+
+ for (i = 0; i < sizeof(PL_uuemap); i += 1)
+ PL_uudmap[(U8)PL_uuemap[i]] = i;
+ /*
+ * Because ' ' and '`' map to the same value,
+ * we need to decode them both the same.
+ */
+ PL_uudmap[' '] = 0;
+ }
+
+ along = (strend - s) * 3 / 4;
+ sv = NEWSV(42, along);
+ if (along)
+ SvPOK_on(sv);
+ while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
+ I32 a, b, c, d;
+ char hunk[4];
+
+ hunk[3] = '\0';
+ len = PL_uudmap[*(U8*)s++] & 077;
+ while (len > 0) {
+ if (s < strend && ISUUCHAR(*s))
+ a = PL_uudmap[*(U8*)s++] & 077;
+ else
+ a = 0;
+ if (s < strend && ISUUCHAR(*s))
+ b = PL_uudmap[*(U8*)s++] & 077;
+ else
+ b = 0;
+ if (s < strend && ISUUCHAR(*s))
+ c = PL_uudmap[*(U8*)s++] & 077;
+ else
+ c = 0;
+ if (s < strend && ISUUCHAR(*s))
+ d = PL_uudmap[*(U8*)s++] & 077;
+ else
+ d = 0;
+ hunk[0] = (a << 2) | (b >> 4);
+ hunk[1] = (b << 4) | (c >> 2);
+ hunk[2] = (c << 6) | d;
+ sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
+ len -= 3;
+ }
+ if (*s == '\n')
+ s++;
+ else if (s[1] == '\n') /* possible checksum byte */
+ s += 2;
+ }
+ XPUSHs(sv_2mortal(sv));
+ break;
+ }
+ if (checksum) {
+ sv = NEWSV(42, 0);
+ if (strchr("fFdD", datumtype) ||
+ (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
+ NV trouble;
+
+ adouble = 1.0;
+ while (checksum >= 16) {
+ checksum -= 16;
+ adouble *= 65536.0;
+ }
+ while (checksum >= 4) {
+ checksum -= 4;
+ adouble *= 16.0;
+ }
+ while (checksum--)
+ adouble *= 2.0;
+ along = (1 << checksum) - 1;
+ while (cdouble < 0.0)
+ cdouble += adouble;
+ cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
+ sv_setnv(sv, cdouble);
+ }
+ else {
+ if (checksum < 32) {
+ aulong = (1 << checksum) - 1;
+ culong &= aulong;
+ }
+ sv_setuv(sv, (UV)culong);
+ }
+ XPUSHs(sv_2mortal(sv));
+ checksum = 0;
+ }
+ }
+ if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
+ PUSHs(&PL_sv_undef);
+ RETURN;
+ }
+
+ STATIC void
+ S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
+ {
+ char hunk[5];
+
+ *hunk = PL_uuemap[len];
+ sv_catpvn(sv, hunk, 1);
+ hunk[4] = '\0';
+ while (len > 2) {
+ hunk[0] = PL_uuemap[(077 & (*s >> 2))];
+ hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
+ hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
+ hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
+ sv_catpvn(sv, hunk, 4);
+ s += 3;
+ len -= 3;
+ }
+ if (len > 0) {
+ char r = (len > 1 ? s[1] : '\0');
+ hunk[0] = PL_uuemap[(077 & (*s >> 2))];
+ hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
+ hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
+ hunk[3] = PL_uuemap[0];
+ sv_catpvn(sv, hunk, 4);
+ }
+ sv_catpvn(sv, "\n", 1);
+ }
+
+ STATIC SV *
+ S_is_an_int(pTHX_ char *s, STRLEN l)
+ {
+ STRLEN n_a;
+ SV *result = newSVpvn(s, l);
+ char *result_c = SvPV(result, n_a); /* convenience */
+ char *out = result_c;
+ bool skip = 1;
+ bool ignore = 0;
+
+ while (*s) {
+ switch (*s) {
+ case ' ':
+ break;
+ case '+':
+ if (!skip) {
+ SvREFCNT_dec(result);
+ return (NULL);
+ }
+ break;
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ skip = 0;
+ if (!ignore) {
+ *(out++) = *s;
+ }
+ break;
+ case '.':
+ ignore = 1;
+ break;
+ default:
+ SvREFCNT_dec(result);
+ return (NULL);
+ }
+ s++;
+ }
+ *(out++) = '\0';
+ SvCUR_set(result, out - result_c);
+ return (result);
+ }
+
+ /* pnum must be '\0' terminated */
+ STATIC int
+ S_div128(pTHX_ SV *pnum, bool *done)
+ {
+ STRLEN len;
+ char *s = SvPV(pnum, len);
+ int m = 0;
+ int r = 0;
+ char *t = s;
+
+ *done = 1;
+ while (*t) {
+ int i;
+
+ i = m * 10 + (*t - '0');
+ m = i & 0x7F;
+ r = (i >> 7); /* r < 10 */
+ if (r) {
+ *done = 0;
+ }
+ *(t++) = '0' + r;
+ }
+ *(t++) = '\0';
+ SvCUR_set(pnum, (STRLEN) (t - s));
+ return (m);
+ }
+
+
+ PP(pp_pack)
+ {
+ dSP; dMARK; dORIGMARK; dTARGET;
+ register SV *cat = TARG;
+ register I32 items;
+ STRLEN fromlen;
+ register char *pat = SvPVx(*++MARK, fromlen);
+ char *patcopy;
+ register char *patend = pat + fromlen;
+ register I32 len;
+ I32 datumtype;
+ SV *fromstr;
+ /*SUPPRESS 442*/
+ static char null10[] = {0,0,0,0,0,0,0,0,0,0};
+ static char *space10 = " ";
+
+ /* These must not be in registers: */
+ char achar;
+ I16 ashort;
+ int aint;
+ unsigned int auint;
+ I32 along;
+ U32 aulong;
+ #ifdef HAS_QUAD
+ Quad_t aquad;
+ Uquad_t auquad;
+ #endif
+ char *aptr;
+ float afloat;
+ double adouble;
+ int commas = 0;
+ #ifdef PERL_NATINT_PACK
+ int natint; /* native integer */
+ #endif
+
+ items = SP - MARK;
+ MARK++;
+ sv_setpvn(cat, "", 0);
+ patcopy = pat;
+ while (pat < patend) {
+ SV *lengthcode = Nullsv;
+ #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
+ datumtype = *pat++ & 0xFF;
+ #ifdef PERL_NATINT_PACK
+ natint = 0;
+ #endif
+ if (isSPACE(datumtype)) {
+ patcopy++;
+ continue;
+ }
+ #ifndef PACKED_IS_OCTETS
+ if (datumtype == 'U' && pat == patcopy+1)
+ SvUTF8_on(cat);
+ #endif
+ if (datumtype == '#') {
+ while (pat < patend && *pat != '\n')
+ pat++;
+ continue;
+ }
+ if (*pat == '!') {
+ char *natstr = "sSiIlL";
+
+ if (strchr(natstr, datumtype)) {
+ #ifdef PERL_NATINT_PACK
+ natint = 1;
+ #endif
+ pat++;
+ }
+ else
+ DIE(aTHX_ "'!' allowed only after types %s", natstr);
+ }
+ if (*pat == '*') {
+ len = strchr("@Xxu", datumtype) ? 0 : items;
+ pat++;
+ }
+ else if (isDIGIT(*pat)) {
+ len = *pat++ - '0';
+ while (isDIGIT(*pat)) {
+ len = (len * 10) + (*pat++ - '0');
+ if (len < 0)
+ DIE(aTHX_ "Repeat count in pack overflows");
+ }
+ }
+ else
+ len = 1;
+ if (*pat == '/') {
+ ++pat;
+ if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
+ DIE(aTHX_ "/ must be followed by a*, A* or Z*");
+ lengthcode = sv_2mortal(newSViv(sv_len(items > 0
+ ? *MARK : &PL_sv_no)
+ + (*pat == 'Z' ? 1 : 0)));
+ }
+ switch(datumtype) {
+ default:
+ DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
+ case ',': /* grandfather in commas but with a warning */
+ if (commas++ == 0 && ckWARN(WARN_PACK))
+ Perl_warner(aTHX_ WARN_PACK,
+ "Invalid type in pack: '%c'", (int)datumtype);
+ break;
+ case '%':
+ DIE(aTHX_ "%% may only be used in unpack");
+ case '@':
+ len -= SvCUR(cat);
+ if (len > 0)
+ goto grow;
+ len = -len;
+ if (len > 0)
+ goto shrink;
+ break;
+ case 'X':
+ shrink:
+ if (SvCUR(cat) < len)
+ DIE(aTHX_ "X outside of string");
+ SvCUR(cat) -= len;
+ *SvEND(cat) = '\0';
+ break;
+ case 'x':
+ grow:
+ while (len >= 10) {
+ sv_catpvn(cat, null10, 10);
+ len -= 10;
+ }
+ sv_catpvn(cat, null10, len);
+ break;
+ case 'A':
+ case 'Z':
+ case 'a':
+ fromstr = NEXTFROM;
+ aptr = SvPV(fromstr, fromlen);
+ if (pat[-1] == '*') {
+ len = fromlen;
+ if (datumtype == 'Z')
+ ++len;
+ }
+ if (fromlen >= len) {
+ sv_catpvn(cat, aptr, len);
+ if (datumtype == 'Z')
+ *(SvEND(cat)-1) = '\0';
+ }
+ else {
+ sv_catpvn(cat, aptr, fromlen);
+ len -= fromlen;
+ if (datumtype == 'A') {
+ while (len >= 10) {
+ sv_catpvn(cat, space10, 10);
+ len -= 10;
+ }
+ sv_catpvn(cat, space10, len);
+ }
+ else {
+ while (len >= 10) {
+ sv_catpvn(cat, null10, 10);
+ len -= 10;
+ }
+ sv_catpvn(cat, null10, len);
+ }
+ }
+ break;
+ case 'B':
+ case 'b':
+ {
+ register char *str;
+ I32 saveitems;
+
+ fromstr = NEXTFROM;
+ saveitems = items;
+ str = SvPV(fromstr, fromlen);
+ if (pat[-1] == '*')
+ len = fromlen;
+ aint = SvCUR(cat);
+ SvCUR(cat) += (len+7)/8;
+ SvGROW(cat, SvCUR(cat) + 1);
+ aptr = SvPVX(cat) + aint;
+ if (len > fromlen)
+ len = fromlen;
+ aint = len;
+ items = 0;
+ if (datumtype == 'B') {
+ for (len = 0; len++ < aint;) {
+ items |= *str++ & 1;
+ if (len & 7)
+ items <<= 1;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ else {
+ for (len = 0; len++ < aint;) {
+ if (*str++ & 1)
+ items |= 128;
+ if (len & 7)
+ items >>= 1;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ if (aint & 7) {
+ if (datumtype == 'B')
+ items <<= 7 - (aint & 7);
+ else
+ items >>= 7 - (aint & 7);
+ *aptr++ = items & 0xff;
+ }
+ str = SvPVX(cat) + SvCUR(cat);
+ while (aptr <= str)
+ *aptr++ = '\0';
+
+ items = saveitems;
+ }
+ break;
+ case 'H':
+ case 'h':
+ {
+ register char *str;
+ I32 saveitems;
+
+ fromstr = NEXTFROM;
+ saveitems = items;
+ str = SvPV(fromstr, fromlen);
+ if (pat[-1] == '*')
+ len = fromlen;
+ aint = SvCUR(cat);
+ SvCUR(cat) += (len+1)/2;
+ SvGROW(cat, SvCUR(cat) + 1);
+ aptr = SvPVX(cat) + aint;
+ if (len > fromlen)
+ len = fromlen;
+ aint = len;
+ items = 0;
+ if (datumtype == 'H') {
+ for (len = 0; len++ < aint;) {
+ if (isALPHA(*str))
+ items |= ((*str++ & 15) + 9) & 15;
+ else
+ items |= *str++ & 15;
+ if (len & 1)
+ items <<= 4;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ else {
+ for (len = 0; len++ < aint;) {
+ if (isALPHA(*str))
+ items |= (((*str++ & 15) + 9) & 15) << 4;
+ else
+ items |= (*str++ & 15) << 4;
+ if (len & 1)
+ items >>= 4;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ if (aint & 1)
+ *aptr++ = items & 0xff;
+ str = SvPVX(cat) + SvCUR(cat);
+ while (aptr <= str)
+ *aptr++ = '\0';
+
+ items = saveitems;
+ }
+ break;
+ case 'C':
+ case 'c':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ switch (datumtype) {
+ case 'C':
+ aint = SvIV(fromstr);
+ if ((aint < 0 || aint > 255) &&
+ ckWARN(WARN_PACK))
+ Perl_warner(aTHX_ WARN_PACK,
+ "Character in \"C\" format wrapped");
+ achar = aint & 255;
+ sv_catpvn(cat, &achar, sizeof(char));
+ break;
+ case 'c':
+ aint = SvIV(fromstr);
+ if ((aint < -128 || aint > 127) &&
+ ckWARN(WARN_PACK))
+ Perl_warner(aTHX_ WARN_PACK,
+ "Character in \"c\" format wrapped");
+ achar = aint & 255;
+ sv_catpvn(cat, &achar, sizeof(char));
+ break;
+ }
+ }
+ break;
+ case 'U':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ auint = SvUV(fromstr);
+ SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
+ SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
+ - SvPVX(cat));
+ }
+ *SvEND(cat) = '\0';
+ break;
+ /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
+ case 'f':
+ case 'F':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ afloat = (float)SvNV(fromstr);
+ sv_catpvn(cat, (char *)&afloat, sizeof (float));
+ }
+ break;
+ case 'd':
+ case 'D':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ adouble = (double)SvNV(fromstr);
+ sv_catpvn(cat, (char *)&adouble, sizeof (double));
+ }
+ break;
+ case 'n':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (I16)SvIV(fromstr);
+ #ifdef HAS_HTONS
+ ashort = PerlSock_htons(ashort);
+ #endif
+ CAT16(cat, &ashort);
+ }
+ break;
+ case 'v':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (I16)SvIV(fromstr);
+ #ifdef HAS_HTOVS
+ ashort = htovs(ashort);
+ #endif
+ CAT16(cat, &ashort);
+ }
+ break;
+ case 'S':
+ #if SHORTSIZE != SIZE16
+ if (natint) {
+ unsigned short aushort;
+
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aushort = SvUV(fromstr);
+ sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
+ }
+ }
+ else
+ #endif
+ {
+ U16 aushort;
+
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aushort = (U16)SvUV(fromstr);
+ CAT16(cat, &aushort);
+ }
+
+ }
+ break;
+ case 's':
+ #if SHORTSIZE != SIZE16
+ if (natint) {
+ short ashort;
+
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = SvIV(fromstr);
+ sv_catpvn(cat, (char *)&ashort, sizeof(short));
+ }
+ }
+ else
+ #endif
+ {
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (I16)SvIV(fromstr);
+ CAT16(cat, &ashort);
+ }
+ }
+ break;
+ case 'I':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ auint = SvUV(fromstr);
+ sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
+ }
+ break;
+ case 'w':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ adouble = Perl_floor(SvNV(fromstr));
+
+ if (adouble < 0)
+ DIE(aTHX_ "Cannot compress negative numbers");
+
+ if (
+ #if UVSIZE > 4 && UVSIZE >= NVSIZE
+ adouble <= 0xffffffff
+ #else
+ # ifdef CXUX_BROKEN_CONSTANT_CONVERT
+ adouble <= UV_MAX_cxux
+ # else
+ adouble <= UV_MAX
+ # endif
+ #endif
+ )
+ {
+ char buf[1 + sizeof(UV)];
+ char *in = buf + sizeof(buf);
+ UV auv = U_V(adouble);
+
+ do {
+ *--in = (auv & 0x7f) | 0x80;
+ auv >>= 7;
+ } while (auv);
+ buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
+ sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
+ }
+ else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
+ char *from, *result, *in;
+ SV *norm;
+ STRLEN len;
+ bool done;
+
+ /* Copy string and check for compliance */
+ from = SvPV(fromstr, len);
+ if ((norm = is_an_int(from, len)) == NULL)
+ DIE(aTHX_ "can compress only unsigned integer");
+
+ New('w', result, len, char);
+ in = result + len;
+ done = FALSE;
+ while (!done)
+ *--in = div128(norm, &done) | 0x80;
+ result[len - 1] &= 0x7F; /* clear continue bit */
+ sv_catpvn(cat, in, (result + len) - in);
+ Safefree(result);
+ SvREFCNT_dec(norm); /* free norm */
+ }
+ else if (SvNOKp(fromstr)) {
+ char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
+ char *in = buf + sizeof(buf);
+
+ do {
+ double next = floor(adouble / 128);
+ *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
+ if (in <= buf) /* this cannot happen ;-) */
+ DIE(aTHX_ "Cannot compress integer");
+ adouble = next;
+ } while (adouble > 0);
+ buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
+ sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
+ }
+ else
+ DIE(aTHX_ "Cannot compress non integer");
+ }
+ break;
+ case 'i':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aint = SvIV(fromstr);
+ sv_catpvn(cat, (char*)&aint, sizeof(int));
+ }
+ break;
+ case 'N':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = SvUV(fromstr);
+ #ifdef HAS_HTONL
+ aulong = PerlSock_htonl(aulong);
+ #endif
+ CAT32(cat, &aulong);
+ }
+ break;
+ case 'V':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = SvUV(fromstr);
+ #ifdef HAS_HTOVL
+ aulong = htovl(aulong);
+ #endif
+ CAT32(cat, &aulong);
+ }
+ break;
+ case 'L':
+ #if LONGSIZE != SIZE32
+ if (natint) {
+ unsigned long aulong;
+
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = SvUV(fromstr);
+ sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
+ }
+ }
+ else
+ #endif
+ {
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = SvUV(fromstr);
+ CAT32(cat, &aulong);
+ }
+ }
+ break;
+ case 'l':
+ #if LONGSIZE != SIZE32
+ if (natint) {
+ long along;
+
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ along = SvIV(fromstr);
+ sv_catpvn(cat, (char *)&along, sizeof(long));
+ }
+ }
+ else
+ #endif
+ {
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ along = SvIV(fromstr);
+ CAT32(cat, &along);
+ }
+ }
+ break;
+ #ifdef HAS_QUAD
+ case 'Q':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ auquad = (Uquad_t)SvUV(fromstr);
+ sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
+ }
+ break;
+ case 'q':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aquad = (Quad_t)SvIV(fromstr);
+ sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
+ }
+ break;
+ #endif
+ case 'P':
+ len = 1; /* assume SV is correct length */
+ /* FALL THROUGH */
+ case 'p':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ if (fromstr == &PL_sv_undef)
+ aptr = NULL;
+ else {
+ STRLEN n_a;
+ /* XXX better yet, could spirit away the string to
+ * a safe spot and hang on to it until the result
+ * of pack() (and all copies of the result) are
+ * gone.
+ */
+ if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
+ || (SvPADTMP(fromstr)
+ && !SvREADONLY(fromstr))))
+ {
+ Perl_warner(aTHX_ WARN_PACK,
+ "Attempt to pack pointer to temporary value");
+ }
+ if (SvPOK(fromstr) || SvNIOK(fromstr))
+ aptr = SvPV(fromstr,n_a);
+ else
+ aptr = SvPV_force(fromstr,n_a);
+ }
+ sv_catpvn(cat, (char*)&aptr, sizeof(char*));
+ }
+ break;
+ case 'u':
+ fromstr = NEXTFROM;
+ aptr = SvPV(fromstr, fromlen);
+ SvGROW(cat, fromlen * 4 / 3);
+ if (len <= 1)
+ len = 45;
+ else
+ len = len / 3 * 3;
+ while (fromlen > 0) {
+ I32 todo;
+
+ if (fromlen > len)
+ todo = len;
+ else
+ todo = fromlen;
+ doencodes(cat, aptr, todo);
+ fromlen -= todo;
+ aptr += todo;
+ }
+ break;
+ }
+ }
+ SvSETMAGIC(cat);
+ SP = ORIGMARK;
+ PUSHs(cat);
+ RETURN;
+ }
+ #undef NEXTFROM
+
diff -c 'perl-5.7.1/pp_proto.h' 'perl-5.7.2/pp_proto.h'
Index: ./pp_proto.h
*** ./pp_proto.h Thu Apr 5 20:48:11 2001
--- ./pp_proto.h Thu Jul 12 07:16:43 2001
***************
*** 15,21 ****
PERL_CKDEF(Perl_ck_exit)
PERL_CKDEF(Perl_ck_ftst)
PERL_CKDEF(Perl_ck_fun)
- PERL_CKDEF(Perl_ck_fun_locale)
PERL_CKDEF(Perl_ck_glob)
PERL_CKDEF(Perl_ck_grep)
PERL_CKDEF(Perl_ck_index)
--- 15,20 ----
***************
*** 33,39 ****
PERL_CKDEF(Perl_ck_rfun)
PERL_CKDEF(Perl_ck_rvconst)
PERL_CKDEF(Perl_ck_sassign)
- PERL_CKDEF(Perl_ck_scmp)
PERL_CKDEF(Perl_ck_select)
PERL_CKDEF(Perl_ck_shift)
PERL_CKDEF(Perl_ck_sort)
--- 32,37 ----
diff -c 'perl-5.7.1/pp_sys.c' 'perl-5.7.2/pp_sys.c'
Index: ./pp_sys.c
*** ./pp_sys.c Tue Apr 3 01:27:10 2001
--- ./pp_sys.c Thu Jul 12 04:36:35 2001
***************
*** 49,54 ****
--- 49,58 ----
# include <sys/resource.h>
#endif
+ #ifdef NETWARE
+ NETDB_DEFINE_CONTEXT
+ #endif
+
#ifdef HAS_SELECT
# ifdef I_SYS_SELECT
# include <sys/select.h>
***************
*** 70,77 ****
--- 74,83 ----
# ifdef I_PWD
# include <pwd.h>
# else
+ # if !defined(VMS)
struct passwd *getpwnam (char *);
struct passwd *getpwuid (Uid_t);
+ # endif
# endif
# ifdef HAS_GETPWENT
struct passwd *getpwent (void);
***************
*** 272,277 ****
--- 278,286 ----
#endif
#if !defined(PERL_EFF_ACCESS_R_OK)
+ /* With it or without it: anyway you get a warning: either that
+ it is unused, or it is declared static and never defined.
+ */
STATIC int
S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
{
***************
*** 508,514 ****
if (GvIOp(gv))
IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
! if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
/* Method's args are same as ours ... */
/* ... except handle is replaced by the object */
*MARK-- = SvTIED_obj((SV*)gv, mg);
--- 517,523 ----
if (GvIOp(gv))
IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
! if ((mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
/* Method's args are same as ours ... */
/* ... except handle is replaced by the object */
*MARK-- = SvTIED_obj((SV*)gv, mg);
***************
*** 551,557 ****
else
gv = (GV*)POPs;
! if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
PUTBACK;
--- 560,566 ----
else
gv = (GV*)POPs;
! if ((mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
PUTBACK;
***************
*** 568,575 ****
PP(pp_pipe_op)
{
- dSP;
#ifdef HAS_PIPE
GV *rgv;
GV *wgv;
register IO *rstio;
--- 577,584 ----
PP(pp_pipe_op)
{
#ifdef HAS_PIPE
+ dSP;
GV *rgv;
GV *wgv;
register IO *rstio;
***************
*** 633,639 ****
RETPUSHUNDEF;
gv = (GV*)POPs;
! if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
PUTBACK;
--- 642,648 ----
RETPUSHUNDEF;
gv = (GV*)POPs;
! if (gv && (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
PUTBACK;
***************
*** 660,668 ****
PP(pp_umask)
{
dSP; dTARGET;
Mode_t anum;
- #ifdef HAS_UMASK
if (MAXARG < 1) {
anum = PerlLIO_umask(0);
(void)PerlLIO_umask(anum);
--- 669,677 ----
PP(pp_umask)
{
dSP; dTARGET;
+ #ifdef HAS_UMASK
Mode_t anum;
if (MAXARG < 1) {
anum = PerlLIO_umask(0);
(void)PerlLIO_umask(anum);
***************
*** 690,697 ****
PerlIO *fp;
MAGIC *mg;
SV *discp = Nullsv;
- STRLEN len = 0;
- char *names = NULL;
if (MAXARG < 1)
RETPUSHUNDEF;
--- 699,704 ----
***************
*** 701,707 ****
gv = (GV*)POPs;
! if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
if (discp)
--- 708,714 ----
gv = (GV*)POPs;
! if (gv && (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
if (discp)
***************
*** 721,730 ****
RETPUSHUNDEF;
}
- if (discp) {
- names = SvPV(discp,len);
- }
-
if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
(discp) ? SvPV_nolen(discp) : Nullch))
RETPUSHYES;
--- 728,733 ----
***************
*** 742,748 ****
SV *sv;
I32 markoff = MARK - PL_stack_base;
char *methname;
! int how = 'P';
U32 items;
STRLEN n_a;
--- 745,751 ----
SV *sv;
I32 markoff = MARK - PL_stack_base;
char *methname;
! int how = PERL_MAGIC_tied;
U32 items;
STRLEN n_a;
***************
*** 755,771 ****
methname = "TIEARRAY";
break;
case SVt_PVGV:
! #ifdef GV_SHARED_CHECK
! if (GvSHARED((GV*)varsv)) {
! Perl_croak(aTHX_ "Attempt to tie shared GV");
}
#endif
methname = "TIEHANDLE";
! how = 'q';
break;
default:
methname = "TIESCALAR";
! how = 'q';
break;
}
items = SP - MARK++;
--- 758,774 ----
methname = "TIEARRAY";
break;
case SVt_PVGV:
! #ifdef GV_UNIQUE_CHECK
! if (GvUNIQUE((GV*)varsv)) {
! Perl_croak(aTHX_ "Attempt to tie unique GV");
}
#endif
methname = "TIEHANDLE";
! how = PERL_MAGIC_tiedscalar;
break;
default:
methname = "TIESCALAR";
! how = PERL_MAGIC_tiedscalar;
break;
}
items = SP - MARK++;
***************
*** 821,827 ****
{
dSP;
SV *sv = POPs;
! char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
MAGIC * mg ;
if ((mg = SvTIED_mg(sv, how))) {
--- 824,831 ----
{
dSP;
SV *sv = POPs;
! char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
! ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
MAGIC * mg ;
if ((mg = SvTIED_mg(sv, how))) {
***************
*** 854,860 ****
{
dSP;
SV *sv = POPs;
! char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
MAGIC *mg;
if ((mg = SvTIED_mg(sv, how))) {
--- 858,865 ----
{
dSP;
SV *sv = POPs;
! char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
! ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
MAGIC *mg;
if ((mg = SvTIED_mg(sv, how))) {
***************
*** 917,924 ****
}
if (sv_isobject(TOPs)) {
! sv_unmagic((SV *) hv, 'P');
! sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
}
LEAVE;
RETURN;
--- 922,929 ----
}
if (sv_isobject(TOPs)) {
! sv_unmagic((SV *) hv, PERL_MAGIC_tied);
! sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, Nullch, 0);
}
LEAVE;
RETURN;
***************
*** 931,938 ****
PP(pp_sselect)
{
- dSP; dTARGET;
#ifdef HAS_SELECT
register I32 i;
register I32 j;
register char *s;
--- 936,943 ----
PP(pp_sselect)
{
#ifdef HAS_SELECT
+ dSP; dTARGET;
register I32 i;
register I32 j;
register char *s;
***************
*** 1125,1131 ****
else
gv = (GV*)POPs;
! if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
I32 gimme = GIMME_V;
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
--- 1130,1136 ----
else
gv = (GV*)POPs;
! if ((mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
I32 gimme = GIMME_V;
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
***************
*** 1382,1388 ****
else
gv = PL_defoutgv;
! if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
if (MARK == ORIGMARK) {
MEXTEND(SP, 1);
++MARK;
--- 1387,1393 ----
else
gv = PL_defoutgv;
! if ((mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
if (MARK == ORIGMARK) {
MEXTEND(SP, 1);
++MARK;
***************
*** 1501,1507 ****
gv = (GV*)*++MARK;
if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
! (mg = SvTIED_mg((SV*)gv, 'q')))
{
SV *sv;
--- 1506,1512 ----
gv = (GV*)*++MARK;
if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
! (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar)))
{
SV *sv;
***************
*** 1531,1537 ****
io = GvIO(gv);
if (!io || !IoIFP(io))
goto say_undef;
! if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTE) {
buffer = SvPVutf8_force(bufsv, blen);
/* UTF8 may not have been set if they are all low bytes */
SvUTF8_on(bufsv);
--- 1536,1542 ----
io = GvIO(gv);
if (!io || !IoIFP(io))
goto say_undef;
! if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
buffer = SvPVutf8_force(bufsv, blen);
/* UTF8 may not have been set if they are all low bytes */
SvUTF8_on(bufsv);
***************
*** 1659,1665 ****
SvCUR_set(bufsv, count+(buffer - SvPVX(bufsv)));
*SvEND(bufsv) = '\0';
(void)SvPOK_only(bufsv);
! if (fp_utf8 && !IN_BYTE) {
/* Look at utf8 we got back and count the characters */
char *bend = buffer + count;
while (buffer < bend) {
--- 1664,1670 ----
SvCUR_set(bufsv, count+(buffer - SvPVX(bufsv)));
*SvEND(bufsv) = '\0';
(void)SvPOK_only(bufsv);
! if (fp_utf8 && !IN_BYTES) {
/* Look at utf8 we got back and count the characters */
char *bend = buffer + count;
while (buffer < bend) {
***************
*** 1727,1733 ****
MAGIC *mg;
gv = (GV*)*++MARK;
! if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
SV *sv;
PUSHMARK(MARK-1);
--- 1732,1740 ----
MAGIC *mg;
gv = (GV*)*++MARK;
! if (PL_op->op_type == OP_SYSWRITE
! && (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar)))
! {
SV *sv;
PUSHMARK(MARK-1);
***************
*** 1872,1878 ****
else
gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
! if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
PUTBACK;
--- 1879,1885 ----
else
gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
! if (gv && (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
PUTBACK;
***************
*** 1898,1904 ****
else
gv = PL_last_in_gv = (GV*)POPs;
! if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
PUTBACK;
--- 1905,1911 ----
else
gv = PL_last_in_gv = (GV*)POPs;
! if (gv && (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
PUTBACK;
***************
*** 1936,1942 ****
gv = PL_last_in_gv = (GV*)POPs;
! if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
#if LSEEKSIZE > IVSIZE
--- 1943,1949 ----
gv = PL_last_in_gv = (GV*)POPs;
! if (gv && (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
#if LSEEKSIZE > IVSIZE
***************
*** 1982,1990 ****
* at least as wide as size_t, so using an off_t should be okay. */
/* XXX Configure probe for the length type of *truncate() needed XXX */
Off_t len;
- int result = 1;
- GV *tmpgv;
- STRLEN n_a;
#if Size_t_size > IVSIZE
len = (Off_t)POPn;
--- 1989,1994 ----
***************
*** 1996,2055 ****
/* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
SETERRNO(0,0);
#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
! if (PL_op->op_flags & OPf_SPECIAL) {
! tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
! do_ftruncate:
! TAINT_PROPER("truncate");
! if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
! result = 0;
! else {
! PerlIO_flush(IoIFP(GvIOp(tmpgv)));
#ifdef HAS_TRUNCATE
! if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
#else
! if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
#endif
! result = 0;
}
! }
! else {
! SV *sv = POPs;
! char *name;
! STRLEN n_a;
! if (SvTYPE(sv) == SVt_PVGV) {
! tmpgv = (GV*)sv; /* *main::FRED for example */
! goto do_ftruncate;
! }
! else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
! tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
! goto do_ftruncate;
! }
!
! name = SvPV(sv, n_a);
! TAINT_PROPER("truncate");
#ifdef HAS_TRUNCATE
! if (truncate(name, len) < 0)
! result = 0;
#else
! {
! int tmpfd;
! if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
! result = 0;
! else {
! if (my_chsize(tmpfd, len) < 0)
result = 0;
! PerlLIO_close(tmpfd);
}
- }
#endif
! }
! if (result)
! RETPUSHYES;
! if (!errno)
! SETERRNO(EBADF,RMS$_IFI);
! RETPUSHUNDEF;
#else
DIE(aTHX_ "truncate not implemented");
#endif
--- 2000,2066 ----
/* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
SETERRNO(0,0);
#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
! {
! STRLEN n_a;
! int result = 1;
! GV *tmpgv;
!
! if (PL_op->op_flags & OPf_SPECIAL) {
! tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
!
! do_ftruncate:
! TAINT_PROPER("truncate");
! if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
! result = 0;
! else {
! PerlIO_flush(IoIFP(GvIOp(tmpgv)));
#ifdef HAS_TRUNCATE
! if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
#else
! if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
#endif
! result = 0;
! }
}
! else {
! SV *sv = POPs;
! char *name;
!
! if (SvTYPE(sv) == SVt_PVGV) {
! tmpgv = (GV*)sv; /* *main::FRED for example */
! goto do_ftruncate;
! }
! else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
! tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
! goto do_ftruncate;
! }
! name = SvPV(sv, n_a);
! TAINT_PROPER("truncate");
#ifdef HAS_TRUNCATE
! if (truncate(name, len) < 0)
! result = 0;
#else
! {
! int tmpfd;
!
! if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
result = 0;
! else {
! if (my_chsize(tmpfd, len) < 0)
! result = 0;
! PerlLIO_close(tmpfd);
! }
}
#endif
! }
! if (result)
! RETPUSHYES;
! if (!errno)
! SETERRNO(EBADF,RMS$_IFI);
! RETPUSHUNDEF;
! }
#else
DIE(aTHX_ "truncate not implemented");
#endif
***************
*** 2064,2070 ****
{
dSP; dTARGET;
SV *argsv = POPs;
! unsigned int func = U_I(POPn);
int optype = PL_op->op_type;
char *s;
IV retval;
--- 2075,2081 ----
{
dSP; dTARGET;
SV *argsv = POPs;
! unsigned int func = POPu;
int optype = PL_op->op_type;
char *s;
IV retval;
***************
*** 2135,2140 ****
--- 2146,2152 ----
PP(pp_flock)
{
+ #ifdef FLOCK
dSP; dTARGET;
I32 value;
int argtype;
***************
*** 2142,2148 ****
IO *io = NULL;
PerlIO *fp;
- #ifdef FLOCK
argtype = POPi;
if (MAXARG == 0)
gv = PL_last_in_gv;
--- 2154,2159 ----
***************
*** 2175,2182 ****
PP(pp_socket)
{
- dSP;
#ifdef HAS_SOCKET
GV *gv;
register IO *io;
int protocol = POPi;
--- 2186,2193 ----
PP(pp_socket)
{
#ifdef HAS_SOCKET
+ dSP;
GV *gv;
register IO *io;
int protocol = POPi;
***************
*** 2228,2235 ****
PP(pp_sockpair)
{
- dSP;
#ifdef HAS_SOCKETPAIR
GV *gv1;
GV *gv2;
register IO *io1;
--- 2239,2246 ----
PP(pp_sockpair)
{
#ifdef HAS_SOCKETPAIR
+ dSP;
GV *gv1;
GV *gv2;
register IO *io1;
***************
*** 2293,2303 ****
PP(pp_bind)
{
- dSP;
#ifdef HAS_SOCKET
#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
! extern GETPRIVMODE();
! extern GETUSERMODE();
#endif
SV *addrsv = POPs;
char *addr;
--- 2304,2314 ----
PP(pp_bind)
{
#ifdef HAS_SOCKET
+ dSP;
#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
! extern void GETPRIVMODE();
! extern void GETUSERMODE();
#endif
SV *addrsv = POPs;
char *addr;
***************
*** 2352,2359 ****
PP(pp_connect)
{
- dSP;
#ifdef HAS_SOCKET
SV *addrsv = POPs;
char *addr;
GV *gv = (GV*)POPs;
--- 2363,2370 ----
PP(pp_connect)
{
#ifdef HAS_SOCKET
+ dSP;
SV *addrsv = POPs;
char *addr;
GV *gv = (GV*)POPs;
***************
*** 2382,2389 ****
PP(pp_listen)
{
- dSP;
#ifdef HAS_SOCKET
int backlog = POPi;
GV *gv = (GV*)POPs;
register IO *io = gv ? GvIOn(gv) : NULL;
--- 2393,2400 ----
PP(pp_listen)
{
#ifdef HAS_SOCKET
+ dSP;
int backlog = POPi;
GV *gv = (GV*)POPs;
register IO *io = gv ? GvIOn(gv) : NULL;
***************
*** 2408,2415 ****
PP(pp_accept)
{
- dSP; dTARGET;
#ifdef HAS_SOCKET
GV *ngv;
GV *ggv;
register IO *nstio;
--- 2419,2426 ----
PP(pp_accept)
{
#ifdef HAS_SOCKET
+ dSP; dTARGET;
GV *ngv;
GV *ggv;
register IO *nstio;
***************
*** 2473,2480 ****
PP(pp_shutdown)
{
- dSP; dTARGET;
#ifdef HAS_SOCKET
int how = POPi;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
--- 2484,2491 ----
PP(pp_shutdown)
{
#ifdef HAS_SOCKET
+ dSP; dTARGET;
int how = POPi;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
***************
*** 2506,2513 ****
PP(pp_ssockopt)
{
- dSP;
#ifdef HAS_SOCKET
int optype = PL_op->op_type;
SV *sv;
int fd;
--- 2517,2524 ----
PP(pp_ssockopt)
{
#ifdef HAS_SOCKET
+ dSP;
int optype = PL_op->op_type;
SV *sv;
int fd;
***************
*** 2587,2594 ****
PP(pp_getpeername)
{
- dSP;
#ifdef HAS_SOCKET
int optype = PL_op->op_type;
SV *sv;
int fd;
--- 2598,2605 ----
PP(pp_getpeername)
{
#ifdef HAS_SOCKET
+ dSP;
int optype = PL_op->op_type;
SV *sv;
int fd;
***************
*** 3294,3300 ****
#else
else if (*s & 128) {
#ifdef USE_LOCALE
! if ((PL_op->op_private & OPpLOCALE) && isALPHA_LC(*s))
continue;
#endif
/* utf8 characters don't count as odd */
--- 3305,3311 ----
#else
else if (*s & 128) {
#ifdef USE_LOCALE
! if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
continue;
#endif
/* utf8 characters don't count as odd */
***************
*** 3375,3399 ****
PP(pp_chown)
{
- dSP; dMARK; dTARGET;
- I32 value;
#ifdef HAS_CHOWN
! value = (I32)apply(PL_op->op_type, MARK, SP);
SP = MARK;
PUSHi(value);
RETURN;
#else
! DIE(aTHX_ PL_no_func, "Unsupported function chown");
#endif
}
PP(pp_chroot)
{
- dSP; dTARGET;
- char *tmps;
#ifdef HAS_CHROOT
STRLEN n_a;
! tmps = POPpx;
TAINT_PROPER("chroot");
PUSHi( chroot(tmps) >= 0 );
RETURN;
--- 3386,3409 ----
PP(pp_chown)
{
#ifdef HAS_CHOWN
! dSP; dMARK; dTARGET;
! I32 value = (I32)apply(PL_op->op_type, MARK, SP);
!
SP = MARK;
PUSHi(value);
RETURN;
#else
! DIE(aTHX_ PL_no_func, "chown");
#endif
}
PP(pp_chroot)
{
#ifdef HAS_CHROOT
+ dSP; dTARGET;
STRLEN n_a;
! char *tmps = POPpx;
TAINT_PROPER("chroot");
PUSHi( chroot(tmps) >= 0 );
RETURN;
***************
*** 3461,3483 ****
PP(pp_link)
{
! dSP; dTARGET;
#ifdef HAS_LINK
STRLEN n_a;
char *tmps2 = POPpx;
char *tmps = SvPV(TOPs, n_a);
TAINT_PROPER("link");
SETi( PerlLIO_link(tmps, tmps2) >= 0 );
#else
! DIE(aTHX_ PL_no_func, "Unsupported function link");
#endif
- RETURN;
}
PP(pp_symlink)
{
- dSP; dTARGET;
#ifdef HAS_SYMLINK
STRLEN n_a;
char *tmps2 = POPpx;
char *tmps = SvPV(TOPs, n_a);
--- 3471,3494 ----
PP(pp_link)
{
! dSP;
#ifdef HAS_LINK
+ dTARGET;
STRLEN n_a;
char *tmps2 = POPpx;
char *tmps = SvPV(TOPs, n_a);
TAINT_PROPER("link");
SETi( PerlLIO_link(tmps, tmps2) >= 0 );
+ RETURN;
#else
! DIE(aTHX_ PL_no_func, "link");
#endif
}
PP(pp_symlink)
{
#ifdef HAS_SYMLINK
+ dSP; dTARGET;
STRLEN n_a;
char *tmps2 = POPpx;
char *tmps = SvPV(TOPs, n_a);
***************
*** 3491,3498 ****
PP(pp_readlink)
{
! dSP; dTARGET;
#ifdef HAS_SYMLINK
char *tmps;
char buf[MAXPATHLEN];
int len;
--- 3502,3510 ----
PP(pp_readlink)
{
! dSP;
#ifdef HAS_SYMLINK
+ dTARGET;
char *tmps;
char buf[MAXPATHLEN];
int len;
***************
*** 3502,3508 ****
TAINT;
#endif
tmps = POPpx;
! len = readlink(tmps, buf, sizeof buf);
EXTEND(SP, 1);
if (len < 0)
RETPUSHUNDEF;
--- 3514,3520 ----
TAINT;
#endif
tmps = POPpx;
! len = readlink(tmps, buf, sizeof(buf) - 1);
EXTEND(SP, 1);
if (len < 0)
RETPUSHUNDEF;
***************
*** 3668,3675 ****
PP(pp_open_dir)
{
- dSP;
#if defined(Direntry_t) && defined(HAS_READDIR)
STRLEN n_a;
char *dirname = POPpx;
GV *gv = (GV*)POPs;
--- 3680,3687 ----
PP(pp_open_dir)
{
#if defined(Direntry_t) && defined(HAS_READDIR)
+ dSP;
STRLEN n_a;
char *dirname = POPpx;
GV *gv = (GV*)POPs;
***************
*** 3695,3703 ****
PP(pp_readdir)
{
- dSP;
#if defined(Direntry_t) && defined(HAS_READDIR)
! #ifndef I_DIRENT
Direntry_t *readdir (DIR *);
#endif
register Direntry_t *dp;
--- 3707,3715 ----
PP(pp_readdir)
{
#if defined(Direntry_t) && defined(HAS_READDIR)
! dSP;
! #if !defined(I_DIRENT) && !defined(VMS)
Direntry_t *readdir (DIR *);
#endif
register Direntry_t *dp;
***************
*** 3753,3760 ****
PP(pp_telldir)
{
- dSP; dTARGET;
#if defined(HAS_TELLDIR) || defined(telldir)
/* XXX does _anyone_ need this? --AD 2/20/1998 */
/* XXX netbsd still seemed to.
XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
--- 3765,3772 ----
PP(pp_telldir)
{
#if defined(HAS_TELLDIR) || defined(telldir)
+ dSP; dTARGET;
/* XXX does _anyone_ need this? --AD 2/20/1998 */
/* XXX netbsd still seemed to.
XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
***************
*** 3781,3788 ****
PP(pp_seekdir)
{
- dSP;
#if defined(HAS_SEEKDIR) || defined(seekdir)
long along = POPl;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
--- 3793,3800 ----
PP(pp_seekdir)
{
#if defined(HAS_SEEKDIR) || defined(seekdir)
+ dSP;
long along = POPl;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
***************
*** 3804,3811 ****
PP(pp_rewinddir)
{
- dSP;
#if defined(HAS_REWINDDIR) || defined(rewinddir)
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
--- 3816,3823 ----
PP(pp_rewinddir)
{
#if defined(HAS_REWINDDIR) || defined(rewinddir)
+ dSP;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
***************
*** 3825,3832 ****
PP(pp_closedir)
{
- dSP;
#if defined(Direntry_t) && defined(HAS_READDIR)
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
--- 3837,3844 ----
PP(pp_closedir)
{
#if defined(Direntry_t) && defined(HAS_READDIR)
+ dSP;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
***************
*** 3888,3894 ****
PUSHi(childpid);
RETURN;
# else
! DIE(aTHX_ PL_no_func, "Unsupported function fork");
# endif
#endif
}
--- 3900,3906 ----
PUSHi(childpid);
RETURN;
# else
! DIE(aTHX_ PL_no_func, "fork");
# endif
#endif
}
***************
*** 3900,3906 ****
--- 3912,3924 ----
Pid_t childpid;
int argflags;
+ #ifdef PERL_OLD_SIGNALS
childpid = wait4pid(-1, &argflags, 0);
+ #else
+ while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && errno == EINTR) {
+ PERL_ASYNC_CHECK();
+ }
+ #endif
# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
/* 0 and -1 are both error returns (the former applies to WNOHANG case) */
STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
***************
*** 3910,3916 ****
XPUSHi(childpid);
RETURN;
#else
! DIE(aTHX_ PL_no_func, "Unsupported function wait");
#endif
}
--- 3928,3934 ----
XPUSHi(childpid);
RETURN;
#else
! DIE(aTHX_ PL_no_func, "wait");
#endif
}
***************
*** 3924,3930 ****
--- 3942,3954 ----
optype = POPi;
childpid = TOPi;
+ #ifdef PERL_OLD_SIGNALS
childpid = wait4pid(childpid, &argflags, optype);
+ #else
+ while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 && errno == EINTR) {
+ PERL_ASYNC_CHECK();
+ }
+ #endif
# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
/* 0 and -1 are both error returns (the former applies to WNOHANG case) */
STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
***************
*** 3934,3940 ****
SETi(childpid);
RETURN;
#else
! DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
#endif
}
--- 3958,3964 ----
SETi(childpid);
RETURN;
#else
! DIE(aTHX_ PL_no_func, "waitpid");
#endif
}
***************
*** 3942,4024 ****
{
dSP; dMARK; dORIGMARK; dTARGET;
I32 value;
- Pid_t childpid;
- int result;
- int status;
- Sigsave_t ihand,qhand; /* place to save signals during system() */
STRLEN n_a;
! I32 did_pipes = 0;
int pp[2];
if (SP - MARK == 1) {
if (PL_tainting) {
! char *junk = SvPV(TOPs, n_a);
TAINT_ENV();
TAINT_PROPER("system");
}
}
PERL_FLUSHALL_FOR_CHILD;
! #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__) || defined(PERL_MICRO)
! if (PerlProc_pipe(pp) >= 0)
! did_pipes = 1;
! while ((childpid = vfork()) == -1) {
! if (errno != EAGAIN) {
! value = -1;
! SP = ORIGMARK;
! PUSHi(value);
! if (did_pipes) {
! PerlLIO_close(pp[0]);
! PerlLIO_close(pp[1]);
! }
! RETURN;
! }
! sleep(5);
! }
! if (childpid > 0) {
! if (did_pipes)
! PerlLIO_close(pp[1]);
#ifndef PERL_MICRO
! rsignal_save(SIGINT, SIG_IGN, &ihand);
! rsignal_save(SIGQUIT, SIG_IGN, &qhand);
#endif
! do {
! result = wait4pid(childpid, &status, 0);
! } while (result == -1 && errno == EINTR);
#ifndef PERL_MICRO
! (void)rsignal_restore(SIGINT, &ihand);
! (void)rsignal_restore(SIGQUIT, &qhand);
#endif
! STATUS_NATIVE_SET(result == -1 ? -1 : status);
! do_execfree(); /* free any memory child malloced on vfork */
! SP = ORIGMARK;
! if (did_pipes) {
! int errkid;
! int n = 0, n1;
!
! while (n < sizeof(int)) {
! n1 = PerlLIO_read(pp[0],
! (void*)(((char*)&errkid)+n),
! (sizeof(int)) - n);
! if (n1 <= 0)
! break;
! n += n1;
! }
! PerlLIO_close(pp[0]);
! if (n) { /* Error */
! if (n != sizeof(int))
! DIE(aTHX_ "panic: kid popen errno read");
! errno = errkid; /* Propagate errno from kid */
! STATUS_CURRENT = -1;
! }
! }
! PUSHi(STATUS_CURRENT);
! RETURN;
! }
! if (did_pipes) {
! PerlLIO_close(pp[0]);
#if defined(HAS_FCNTL) && defined(F_SETFD)
! fcntl(pp[1], F_SETFD, FD_CLOEXEC);
#endif
}
if (PL_op->op_flags & OPf_STACKED) {
SV *really = *++MARK;
--- 3966,4051 ----
{
dSP; dMARK; dORIGMARK; dTARGET;
I32 value;
STRLEN n_a;
! int result;
int pp[2];
+ I32 did_pipes = 0;
if (SP - MARK == 1) {
if (PL_tainting) {
! (void)SvPV_nolen(TOPs); /* stringify for taint check */
TAINT_ENV();
TAINT_PROPER("system");
}
}
PERL_FLUSHALL_FOR_CHILD;
! #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
! {
! Pid_t childpid;
! int status;
! Sigsave_t ihand,qhand; /* place to save signals during system() */
!
! if (PerlProc_pipe(pp) >= 0)
! did_pipes = 1;
! while ((childpid = vfork()) == -1) {
! if (errno != EAGAIN) {
! value = -1;
! SP = ORIGMARK;
! PUSHi(value);
! if (did_pipes) {
! PerlLIO_close(pp[0]);
! PerlLIO_close(pp[1]);
! }
! RETURN;
! }
! sleep(5);
! }
! if (childpid > 0) {
! if (did_pipes)
! PerlLIO_close(pp[1]);
#ifndef PERL_MICRO
! rsignal_save(SIGINT, SIG_IGN, &ihand);
! rsignal_save(SIGQUIT, SIG_IGN, &qhand);
#endif
! do {
! result = wait4pid(childpid, &status, 0);
! } while (result == -1 && errno == EINTR);
#ifndef PERL_MICRO
! (void)rsignal_restore(SIGINT, &ihand);
! (void)rsignal_restore(SIGQUIT, &qhand);
#endif
! STATUS_NATIVE_SET(result == -1 ? -1 : status);
! do_execfree(); /* free any memory child malloced on vfork */
! SP = ORIGMARK;
! if (did_pipes) {
! int errkid;
! int n = 0, n1;
!
! while (n < sizeof(int)) {
! n1 = PerlLIO_read(pp[0],
! (void*)(((char*)&errkid)+n),
! (sizeof(int)) - n);
! if (n1 <= 0)
! break;
! n += n1;
! }
! PerlLIO_close(pp[0]);
! if (n) { /* Error */
! if (n != sizeof(int))
! DIE(aTHX_ "panic: kid popen errno read");
! errno = errkid; /* Propagate errno from kid */
! STATUS_CURRENT = -1;
! }
! }
! PUSHi(STATUS_CURRENT);
! RETURN;
! }
! if (did_pipes) {
! PerlLIO_close(pp[0]);
#if defined(HAS_FCNTL) && defined(F_SETFD)
! fcntl(pp[1], F_SETFD, FD_CLOEXEC);
#endif
+ }
}
if (PL_op->op_flags & OPf_STACKED) {
SV *really = *++MARK;
***************
*** 4078,4084 ****
#endif
else {
if (PL_tainting) {
! char *junk = SvPV(*SP, n_a);
TAINT_ENV();
TAINT_PROPER("exec");
}
--- 4105,4111 ----
#endif
else {
if (PL_tainting) {
! (void)SvPV_nolen(*SP); /* stringify for taint check */
TAINT_ENV();
TAINT_PROPER("exec");
}
***************
*** 4094,4104 ****
#endif
}
- #if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
- if (value >= 0)
- my_exit(value);
- #endif
-
SP = ORIGMARK;
PUSHi(value);
RETURN;
--- 4121,4126 ----
***************
*** 4106,4120 ****
PP(pp_kill)
{
dSP; dMARK; dTARGET;
I32 value;
- #ifdef HAS_KILL
value = (I32)apply(PL_op->op_type, MARK, SP);
SP = MARK;
PUSHi(value);
RETURN;
#else
! DIE(aTHX_ PL_no_func, "Unsupported function kill");
#endif
}
--- 4128,4142 ----
PP(pp_kill)
{
+ #ifdef HAS_KILL
dSP; dMARK; dTARGET;
I32 value;
value = (I32)apply(PL_op->op_type, MARK, SP);
SP = MARK;
PUSHi(value);
RETURN;
#else
! DIE(aTHX_ PL_no_func, "kill");
#endif
}
***************
*** 4188,4199 ****
PP(pp_getpriority)
{
- dSP; dTARGET;
- int which;
- int who;
#ifdef HAS_GETPRIORITY
! who = POPi;
! which = TOPi;
SETi( getpriority(which, who) );
RETURN;
#else
--- 4210,4219 ----
PP(pp_getpriority)
{
#ifdef HAS_GETPRIORITY
! dSP; dTARGET;
! int who = POPi;
! int which = TOPi;
SETi( getpriority(which, who) );
RETURN;
#else
***************
*** 4203,4216 ****
PP(pp_setpriority)
{
- dSP; dTARGET;
- int which;
- int who;
- int niceval;
#ifdef HAS_SETPRIORITY
! niceval = POPi;
! who = POPi;
! which = TOPi;
TAINT_PROPER("setpriority");
SETi( setpriority(which, who, niceval) >= 0 );
RETURN;
--- 4223,4233 ----
PP(pp_setpriority)
{
#ifdef HAS_SETPRIORITY
! dSP; dTARGET;
! int niceval = POPi;
! int who = POPi;
! int which = TOPi;
TAINT_PROPER("setpriority");
SETi( setpriority(which, who, niceval) >= 0 );
RETURN;
***************
*** 4250,4262 ****
PP(pp_tms)
{
dSP;
-
- #ifndef HAS_TIMES
- DIE(aTHX_ "times not implemented");
- #else
EXTEND(SP, 4);
-
#ifndef VMS
(void)PerlProc_times(&PL_timesbuf);
#else
--- 4267,4275 ----
PP(pp_tms)
{
+ #ifdef HAS_TIMES
dSP;
EXTEND(SP, 4);
#ifndef VMS
(void)PerlProc_times(&PL_timesbuf);
#else
***************
*** 4272,4277 ****
--- 4285,4292 ----
PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
}
RETURN;
+ #else
+ DIE(aTHX_ "times not implemented");
#endif /* HAS_TIMES */
}
***************
*** 4303,4312 ****
else
tmbuf = gmtime(&when);
- EXTEND(SP, 9);
- EXTEND_MORTAL(9);
if (GIMME != G_ARRAY) {
SV *tsv;
if (!tmbuf)
RETPUSHUNDEF;
tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
--- 4318,4327 ----
else
tmbuf = gmtime(&when);
if (GIMME != G_ARRAY) {
SV *tsv;
+ EXTEND(SP, 1);
+ EXTEND_MORTAL(1);
if (!tmbuf)
RETPUSHUNDEF;
tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
***************
*** 4320,4326 ****
PUSHs(sv_2mortal(tsv));
}
else if (tmbuf) {
! PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
--- 4335,4343 ----
PUSHs(sv_2mortal(tsv));
}
else if (tmbuf) {
! EXTEND(SP, 9);
! EXTEND_MORTAL(9);
! PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
***************
*** 4335,4343 ****
PP(pp_alarm)
{
dSP; dTARGET;
int anum;
- #ifdef HAS_ALARM
anum = POPi;
anum = alarm((unsigned int)anum);
EXTEND(SP, 1);
--- 4352,4360 ----
PP(pp_alarm)
{
+ #ifdef HAS_ALARM
dSP; dTARGET;
int anum;
anum = POPi;
anum = alarm((unsigned int)anum);
EXTEND(SP, 1);
***************
*** 4346,4352 ****
PUSHi(anum);
RETURN;
#else
! DIE(aTHX_ PL_no_func, "Unsupported function alarm");
#endif
}
--- 4363,4369 ----
PUSHi(anum);
RETURN;
#else
! DIE(aTHX_ PL_no_func, "alarm");
#endif
}
***************
*** 4509,4516 ****
PP(pp_ghostent)
{
- dSP;
#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
I32 which = PL_op->op_type;
register char **elem;
register SV *sv;
--- 4526,4533 ----
PP(pp_ghostent)
{
#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
+ dSP;
I32 which = PL_op->op_type;
register char **elem;
register SV *sv;
***************
*** 4618,4625 ****
PP(pp_gnetent)
{
- dSP;
#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
I32 which = PL_op->op_type;
register char **elem;
register SV *sv;
--- 4635,4642 ----
PP(pp_gnetent)
{
#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
+ dSP;
I32 which = PL_op->op_type;
register char **elem;
register SV *sv;
***************
*** 4640,4646 ****
else if (which == OP_GNBYADDR) {
#ifdef HAS_GETNETBYADDR
int addrtype = POPi;
! Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
nent = PerlSock_getnetbyaddr(addr, addrtype);
#else
DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
--- 4657,4663 ----
else if (which == OP_GNBYADDR) {
#ifdef HAS_GETNETBYADDR
int addrtype = POPi;
! Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
nent = PerlSock_getnetbyaddr(addr, addrtype);
#else
DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
***************
*** 4706,4713 ****
PP(pp_gprotoent)
{
- dSP;
#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
I32 which = PL_op->op_type;
register char **elem;
register SV *sv;
--- 4723,4730 ----
PP(pp_gprotoent)
{
#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
+ dSP;
I32 which = PL_op->op_type;
register char **elem;
register SV *sv;
***************
*** 4789,4796 ****
PP(pp_gservent)
{
- dSP;
#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
I32 which = PL_op->op_type;
register char **elem;
register SV *sv;
--- 4806,4813 ----
PP(pp_gservent)
{
#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
+ dSP;
I32 which = PL_op->op_type;
register char **elem;
register SV *sv;
***************
*** 4879,4886 ****
PP(pp_shostent)
{
- dSP;
#ifdef HAS_SETHOSTENT
PerlSock_sethostent(TOPi);
RETSETYES;
#else
--- 4896,4903 ----
PP(pp_shostent)
{
#ifdef HAS_SETHOSTENT
+ dSP;
PerlSock_sethostent(TOPi);
RETSETYES;
#else
***************
*** 4890,4897 ****
PP(pp_snetent)
{
- dSP;
#ifdef HAS_SETNETENT
PerlSock_setnetent(TOPi);
RETSETYES;
#else
--- 4907,4914 ----
PP(pp_snetent)
{
#ifdef HAS_SETNETENT
+ dSP;
PerlSock_setnetent(TOPi);
RETSETYES;
#else
***************
*** 4901,4908 ****
PP(pp_sprotoent)
{
- dSP;
#ifdef HAS_SETPROTOENT
PerlSock_setprotoent(TOPi);
RETSETYES;
#else
--- 4918,4925 ----
PP(pp_sprotoent)
{
#ifdef HAS_SETPROTOENT
+ dSP;
PerlSock_setprotoent(TOPi);
RETSETYES;
#else
***************
*** 4912,4919 ****
PP(pp_sservent)
{
- dSP;
#ifdef HAS_SETSERVENT
PerlSock_setservent(TOPi);
RETSETYES;
#else
--- 4929,4936 ----
PP(pp_sservent)
{
#ifdef HAS_SETSERVENT
+ dSP;
PerlSock_setservent(TOPi);
RETSETYES;
#else
***************
*** 4923,4930 ****
PP(pp_ehostent)
{
- dSP;
#ifdef HAS_ENDHOSTENT
PerlSock_endhostent();
EXTEND(SP,1);
RETPUSHYES;
--- 4940,4947 ----
PP(pp_ehostent)
{
#ifdef HAS_ENDHOSTENT
+ dSP;
PerlSock_endhostent();
EXTEND(SP,1);
RETPUSHYES;
***************
*** 4935,4942 ****
PP(pp_enetent)
{
- dSP;
#ifdef HAS_ENDNETENT
PerlSock_endnetent();
EXTEND(SP,1);
RETPUSHYES;
--- 4952,4959 ----
PP(pp_enetent)
{
#ifdef HAS_ENDNETENT
+ dSP;
PerlSock_endnetent();
EXTEND(SP,1);
RETPUSHYES;
***************
*** 4947,4954 ****
PP(pp_eprotoent)
{
- dSP;
#ifdef HAS_ENDPROTOENT
PerlSock_endprotoent();
EXTEND(SP,1);
RETPUSHYES;
--- 4964,4971 ----
PP(pp_eprotoent)
{
#ifdef HAS_ENDPROTOENT
+ dSP;
PerlSock_endprotoent();
EXTEND(SP,1);
RETPUSHYES;
***************
*** 4959,4966 ****
PP(pp_eservent)
{
- dSP;
#ifdef HAS_ENDSERVENT
PerlSock_endservent();
EXTEND(SP,1);
RETPUSHYES;
--- 4976,4983 ----
PP(pp_eservent)
{
#ifdef HAS_ENDSERVENT
+ dSP;
PerlSock_endservent();
EXTEND(SP,1);
RETPUSHYES;
***************
*** 4989,4996 ****
PP(pp_gpwent)
{
- dSP;
#ifdef HAS_PASSWD
I32 which = PL_op->op_type;
register SV *sv;
STRLEN n_a;
--- 5006,5013 ----
PP(pp_gpwent)
{
#ifdef HAS_PASSWD
+ dSP;
I32 which = PL_op->op_type;
register SV *sv;
STRLEN n_a;
***************
*** 5203,5210 ****
PP(pp_spwent)
{
- dSP;
#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
setpwent();
RETPUSHYES;
#else
--- 5220,5227 ----
PP(pp_spwent)
{
#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
+ dSP;
setpwent();
RETPUSHYES;
#else
***************
*** 5214,5221 ****
PP(pp_epwent)
{
- dSP;
#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
endpwent();
RETPUSHYES;
#else
--- 5231,5238 ----
PP(pp_epwent)
{
#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
+ dSP;
endpwent();
RETPUSHYES;
#else
***************
*** 5243,5250 ****
PP(pp_ggrent)
{
- dSP;
#ifdef HAS_GROUP
I32 which = PL_op->op_type;
register char **elem;
register SV *sv;
--- 5260,5267 ----
PP(pp_ggrent)
{
#ifdef HAS_GROUP
+ dSP;
I32 which = PL_op->op_type;
register char **elem;
register SV *sv;
***************
*** 5302,5309 ****
PP(pp_sgrent)
{
- dSP;
#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
setgrent();
RETPUSHYES;
#else
--- 5319,5326 ----
PP(pp_sgrent)
{
#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
+ dSP;
setgrent();
RETPUSHYES;
#else
***************
*** 5313,5320 ****
PP(pp_egrent)
{
- dSP;
#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
endgrent();
RETPUSHYES;
#else
--- 5330,5337 ----
PP(pp_egrent)
{
#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
+ dSP;
endgrent();
RETPUSHYES;
#else
***************
*** 5324,5331 ****
PP(pp_getlogin)
{
- dSP; dTARGET;
#ifdef HAS_GETLOGIN
char *tmps;
EXTEND(SP, 1);
if (!(tmps = PerlProc_getlogin()))
--- 5341,5348 ----
PP(pp_getlogin)
{
#ifdef HAS_GETLOGIN
+ dSP; dTARGET;
char *tmps;
EXTEND(SP, 1);
if (!(tmps = PerlProc_getlogin()))
diff -c 'perl-5.7.1/proto.h' 'perl-5.7.2/proto.h'
Index: ./proto.h
*** ./proto.h Fri Apr 6 16:42:02 2001
--- ./proto.h Thu Jul 12 21:34:38 2001
***************
*** 24,34 ****
# endif
#endif
- #if defined(MYMALLOC)
PERL_CALLCONV Malloc_t Perl_malloc(MEM_SIZE nbytes);
PERL_CALLCONV Malloc_t Perl_calloc(MEM_SIZE elements, MEM_SIZE size);
PERL_CALLCONV Malloc_t Perl_realloc(Malloc_t where, MEM_SIZE nbytes);
PERL_CALLCONV Free_t Perl_mfree(Malloc_t where);
PERL_CALLCONV MEM_SIZE Perl_malloced_size(void *p);
#endif
--- 24,34 ----
# endif
#endif
PERL_CALLCONV Malloc_t Perl_malloc(MEM_SIZE nbytes);
PERL_CALLCONV Malloc_t Perl_calloc(MEM_SIZE elements, MEM_SIZE size);
PERL_CALLCONV Malloc_t Perl_realloc(Malloc_t where, MEM_SIZE nbytes);
PERL_CALLCONV Free_t Perl_mfree(Malloc_t where);
+ #if defined(MYMALLOC)
PERL_CALLCONV MEM_SIZE Perl_malloced_size(void *p);
#endif
***************
*** 91,96 ****
--- 91,97 ----
PERL_CALLCONV I32 Perl_block_gimme(pTHX);
PERL_CALLCONV int Perl_block_start(pTHX_ int full);
PERL_CALLCONV void Perl_boot_core_UNIVERSAL(pTHX);
+ PERL_CALLCONV void Perl_boot_core_PerlIO(pTHX);
PERL_CALLCONV void Perl_call_list(pTHX_ I32 oldscope, AV* av_list);
PERL_CALLCONV bool Perl_cando(pTHX_ Mode_t mode, Uid_t effective, Stat_t* statbufp);
PERL_CALLCONV U32 Perl_cast_ulong(pTHX_ NV f);
***************
*** 333,338 ****
--- 334,340 ----
PERL_CALLCONV bool Perl_ingroup(pTHX_ Gid_t testgid, Uid_t effective);
PERL_CALLCONV void Perl_init_debugger(pTHX);
PERL_CALLCONV void Perl_init_stacks(pTHX);
+ PERL_CALLCONV void Perl_init_tm(pTHX_ struct tm *ptm);
PERL_CALLCONV U32 Perl_intro_my(pTHX);
PERL_CALLCONV char* Perl_instr(pTHX_ const char* big, const char* little);
PERL_CALLCONV bool Perl_io_close(pTHX_ IO* io, bool not_implicit);
***************
*** 395,400 ****
--- 397,404 ----
PERL_CALLCONV void Perl_leave_scope(pTHX_ I32 base);
PERL_CALLCONV void Perl_lex_end(pTHX);
PERL_CALLCONV void Perl_lex_start(pTHX_ SV* line);
+ PERL_CALLCONV void Perl_op_null(pTHX_ OP* o);
+ PERL_CALLCONV void Perl_op_clear(pTHX_ OP* o);
PERL_CALLCONV OP* Perl_linklist(pTHX_ OP* o);
PERL_CALLCONV OP* Perl_list(pTHX_ OP* o);
PERL_CALLCONV OP* Perl_listkids(pTHX_ OP* o);
***************
*** 402,407 ****
--- 406,413 ----
PERL_CALLCONV void Perl_vload_module(pTHX_ U32 flags, SV* name, SV* ver, va_list* args);
PERL_CALLCONV OP* Perl_localize(pTHX_ OP* arg, I32 lexical);
PERL_CALLCONV I32 Perl_looks_like_number(pTHX_ SV* sv);
+ PERL_CALLCONV int Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep);
+ PERL_CALLCONV bool Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send);
PERL_CALLCONV int Perl_magic_clearenv(pTHX_ SV* sv, MAGIC* mg);
PERL_CALLCONV int Perl_magic_clear_all_env(pTHX_ SV* sv, MAGIC* mg);
PERL_CALLCONV int Perl_magic_clearpack(pTHX_ SV* sv, MAGIC* mg);
***************
*** 475,486 ****
PERL_CALLCONV void Perl_mg_magical(pTHX_ SV* sv);
PERL_CALLCONV int Perl_mg_set(pTHX_ SV* sv);
PERL_CALLCONV I32 Perl_mg_size(pTHX_ SV* sv);
PERL_CALLCONV OP* Perl_mod(pTHX_ OP* o, I32 type);
PERL_CALLCONV int Perl_mode_from_discipline(pTHX_ SV* discp);
PERL_CALLCONV char* Perl_moreswitches(pTHX_ char* s);
PERL_CALLCONV OP* Perl_my(pTHX_ OP* o);
PERL_CALLCONV NV Perl_my_atof(pTHX_ const char *s);
! #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
PERL_CALLCONV char* Perl_my_bcopy(const char* from, char* to, I32 len);
#endif
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
--- 481,493 ----
PERL_CALLCONV void Perl_mg_magical(pTHX_ SV* sv);
PERL_CALLCONV int Perl_mg_set(pTHX_ SV* sv);
PERL_CALLCONV I32 Perl_mg_size(pTHX_ SV* sv);
+ PERL_CALLCONV void Perl_mini_mktime(pTHX_ struct tm *pm);
PERL_CALLCONV OP* Perl_mod(pTHX_ OP* o, I32 type);
PERL_CALLCONV int Perl_mode_from_discipline(pTHX_ SV* discp);
PERL_CALLCONV char* Perl_moreswitches(pTHX_ char* s);
PERL_CALLCONV OP* Perl_my(pTHX_ OP* o);
PERL_CALLCONV NV Perl_my_atof(pTHX_ const char *s);
! #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
PERL_CALLCONV char* Perl_my_bcopy(const char* from, char* to, I32 len);
#endif
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
***************
*** 503,508 ****
--- 510,516 ----
#endif
PERL_CALLCONV void Perl_my_setenv(pTHX_ char* nam, char* val);
PERL_CALLCONV I32 Perl_my_stat(pTHX);
+ PERL_CALLCONV char * Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst);
#if defined(MYSWAP)
PERL_CALLCONV short Perl_my_swap(pTHX_ short s);
PERL_CALLCONV long Perl_my_htonl(pTHX_ long l);
***************
*** 747,752 ****
--- 755,761 ----
PERL_CALLCONV char* Perl_sv_collxfrm(pTHX_ SV* sv, STRLEN* nxp);
#endif
PERL_CALLCONV OP* Perl_sv_compile_2op(pTHX_ SV* sv, OP** startp, char* code, AV** avp);
+ PERL_CALLCONV int Perl_getcwd_sv(pTHX_ SV* sv);
PERL_CALLCONV void Perl_sv_dec(pTHX_ SV* sv);
PERL_CALLCONV void Perl_sv_dump(pTHX_ SV* sv);
PERL_CALLCONV bool Perl_sv_derived_from(pTHX_ SV* sv, const char* name);
***************
*** 805,811 ****
PERL_CALLCONV void Perl_sv_vsetpvfn(pTHX_ SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted);
PERL_CALLCONV NV Perl_str_to_version(pTHX_ SV *sv);
PERL_CALLCONV SV* Perl_swash_init(pTHX_ char* pkg, char* name, SV* listsv, I32 minbits, I32 none);
! PERL_CALLCONV UV Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr);
PERL_CALLCONV void Perl_taint_env(pTHX);
PERL_CALLCONV void Perl_taint_proper(pTHX_ const char* f, const char* s);
PERL_CALLCONV UV Perl_to_utf8_lower(pTHX_ U8 *p);
--- 814,820 ----
PERL_CALLCONV void Perl_sv_vsetpvfn(pTHX_ SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted);
PERL_CALLCONV NV Perl_str_to_version(pTHX_ SV *sv);
PERL_CALLCONV SV* Perl_swash_init(pTHX_ char* pkg, char* name, SV* listsv, I32 minbits, I32 none);
! PERL_CALLCONV UV Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr, bool do_utf8);
PERL_CALLCONV void Perl_taint_env(pTHX);
PERL_CALLCONV void Perl_taint_proper(pTHX_ const char* f, const char* s);
PERL_CALLCONV UV Perl_to_utf8_lower(pTHX_ U8 *p);
***************
*** 947,963 ****
PERL_CALLCONV OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs);
PERL_CALLCONV void Perl_boot_core_xsutils(pTHX);
#if defined(USE_ITHREADS)
! PERL_CALLCONV PERL_CONTEXT* Perl_cx_dup(pTHX_ PERL_CONTEXT* cx, I32 ix, I32 max);
! PERL_CALLCONV PERL_SI* Perl_si_dup(pTHX_ PERL_SI* si);
! PERL_CALLCONV ANY* Perl_ss_dup(pTHX_ PerlInterpreter* proto_perl);
PERL_CALLCONV void* Perl_any_dup(pTHX_ void* v, PerlInterpreter* proto_perl);
! PERL_CALLCONV HE* Perl_he_dup(pTHX_ HE* e, bool shared);
! PERL_CALLCONV REGEXP* Perl_re_dup(pTHX_ REGEXP* r);
PERL_CALLCONV PerlIO* Perl_fp_dup(pTHX_ PerlIO* fp, char type);
PERL_CALLCONV DIR* Perl_dirp_dup(pTHX_ DIR* dp);
! PERL_CALLCONV GP* Perl_gp_dup(pTHX_ GP* gp);
! PERL_CALLCONV MAGIC* Perl_mg_dup(pTHX_ MAGIC* mg);
! PERL_CALLCONV SV* Perl_sv_dup(pTHX_ SV* sstr);
#if defined(HAVE_INTERP_INTERN)
PERL_CALLCONV void Perl_sys_intern_dup(pTHX_ struct interp_intern* src, struct interp_intern* dst);
#endif
--- 956,972 ----
PERL_CALLCONV OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs);
PERL_CALLCONV void Perl_boot_core_xsutils(pTHX);
#if defined(USE_ITHREADS)
! PERL_CALLCONV PERL_CONTEXT* Perl_cx_dup(pTHX_ PERL_CONTEXT* cx, I32 ix, I32 max, clone_params* param);
! PERL_CALLCONV PERL_SI* Perl_si_dup(pTHX_ PERL_SI* si, clone_params* param);
! PERL_CALLCONV ANY* Perl_ss_dup(pTHX_ PerlInterpreter* proto_perl, clone_params* param);
PERL_CALLCONV void* Perl_any_dup(pTHX_ void* v, PerlInterpreter* proto_perl);
! PERL_CALLCONV HE* Perl_he_dup(pTHX_ HE* e, bool shared, clone_params* param);
! PERL_CALLCONV REGEXP* Perl_re_dup(pTHX_ REGEXP* r, clone_params* param);
PERL_CALLCONV PerlIO* Perl_fp_dup(pTHX_ PerlIO* fp, char type);
PERL_CALLCONV DIR* Perl_dirp_dup(pTHX_ DIR* dp);
! PERL_CALLCONV GP* Perl_gp_dup(pTHX_ GP* gp, clone_params* param);
! PERL_CALLCONV MAGIC* Perl_mg_dup(pTHX_ MAGIC* mg, clone_params* param);
! PERL_CALLCONV SV* Perl_sv_dup(pTHX_ SV* sstr, clone_params* param);
#if defined(HAVE_INTERP_INTERN)
PERL_CALLCONV void Perl_sys_intern_dup(pTHX_ struct interp_intern* src, struct interp_intern* dst);
#endif
***************
*** 1024,1031 ****
STATIC OP* S_scalarboolean(pTHX_ OP *o);
STATIC OP* S_too_few_arguments(pTHX_ OP *o, char* name);
STATIC OP* S_too_many_arguments(pTHX_ OP *o, char* name);
- STATIC void S_op_clear(pTHX_ OP* o);
- STATIC void S_null(pTHX_ OP* o);
STATIC PADOFFSET S_pad_addlex(pTHX_ SV* name);
STATIC PADOFFSET S_pad_findlex(pTHX_ char* name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval, U32 flags);
STATIC OP* S_newDEFSVOP(pTHX);
--- 1033,1038 ----
***************
*** 1081,1089 ****
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
- STATIC void S_doencodes(pTHX_ SV* sv, char* s, I32 len);
STATIC SV* S_refto(pTHX_ SV* sv);
STATIC U32 S_seed(pTHX);
STATIC SV* S_mul128(pTHX_ SV *sv, U8 m);
STATIC SV* S_is_an_int(pTHX_ char *s, STRLEN l);
STATIC int S_div128(pTHX_ SV *pnum, bool *done);
--- 1088,1099 ----
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
STATIC SV* S_refto(pTHX_ SV* sv);
STATIC U32 S_seed(pTHX);
+ #endif
+
+ #if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
+ STATIC void S_doencodes(pTHX_ SV* sv, char* s, I32 len);
STATIC SV* S_mul128(pTHX_ SV *sv, U8 m);
STATIC SV* S_is_an_int(pTHX_ char *s, STRLEN l);
STATIC int S_div128(pTHX_ SV *pnum, bool *done);
***************
*** 1138,1145 ****
--- 1148,1157 ----
STATIC void S_regtail(pTHX_ struct RExC_state_t*, regnode *, regnode *);
STATIC char* S_regwhite(pTHX_ char *, char *);
STATIC char* S_nextchar(pTHX_ struct RExC_state_t*);
+ # ifdef DEBUGGING
STATIC regnode* S_dumpuntil(pTHX_ regnode *start, regnode *node, regnode *last, SV* sv, I32 l);
STATIC void S_put_byte(pTHX_ SV* sv, int c);
+ # endif
STATIC void S_scan_commit(pTHX_ struct RExC_state_t*, struct scan_data_t *data);
STATIC void S_cl_anything(pTHX_ struct RExC_state_t*, struct regnode_charclass_class *cl);
STATIC int S_cl_is_anything(pTHX_ struct regnode_charclass_class *cl);
***************
*** 1172,1178 ****
--- 1184,1193 ----
#endif
#if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
+ # ifdef DEBUGGING
+ STATIC CV* S_deb_curcv(pTHX_ I32 ix);
STATIC void S_debprof(pTHX_ OP *o);
+ # endif
#endif
#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
***************
*** 1224,1234 ****
STATIC I32 S_visit(pTHX_ SVFUNC_t f);
STATIC void S_sv_add_backref(pTHX_ SV *tsv, SV *sv);
STATIC void S_sv_del_backref(pTHX_ SV *sv);
! # if defined(DEBUGGING)
STATIC void S_del_sv(pTHX_ SV *p);
# endif
# if !defined(NV_PRESERVES_UV)
- STATIC int S_sv_2inuv_non_preserve(pTHX_ SV *sv, I32 numtype);
STATIC int S_sv_2iuv_non_preserve(pTHX_ SV *sv, I32 numtype);
# endif
STATIC I32 S_expect_number(pTHX_ char** pattern);
--- 1239,1248 ----
STATIC I32 S_visit(pTHX_ SVFUNC_t f);
STATIC void S_sv_add_backref(pTHX_ SV *tsv, SV *sv);
STATIC void S_sv_del_backref(pTHX_ SV *sv);
! # ifdef DEBUGGING
STATIC void S_del_sv(pTHX_ SV *p);
# endif
# if !defined(NV_PRESERVES_UV)
STATIC int S_sv_2iuv_non_preserve(pTHX_ SV *sv, I32 numtype);
# endif
STATIC I32 S_expect_number(pTHX_ char** pattern);
***************
*** 1244,1249 ****
--- 1258,1264 ----
STATIC char* S_force_version(pTHX_ char *start);
STATIC char* S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack, int allow_tick);
STATIC SV* S_tokeq(pTHX_ SV *sv);
+ STATIC int S_pending_ident(pTHX);
STATIC char* S_scan_const(pTHX_ char *start);
STATIC char* S_scan_formline(pTHX_ char *s);
STATIC char* S_scan_heredoc(pTHX_ char *s);
***************
*** 1271,1277 ****
--- 1286,1294 ----
STATIC char * S_filter_gets(pTHX_ SV *sv, PerlIO *fp, STRLEN append);
STATIC HV * S_find_in_my_stash(pTHX_ char *pkgname, I32 len);
STATIC SV* S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, const char *type);
+ # if defined(DEBUGGING)
STATIC void S_tokereport(pTHX_ char *thing, char *s, I32 rv);
+ # endif
STATIC int S_ao(pTHX_ int toketype);
STATIC void S_depcom(pTHX);
STATIC char* S_incl_perldb(pTHX);
***************
*** 1291,1298 ****
STATIC SV* S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level);
#endif
! #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
STATIC char* S_stdize_locale(pTHX_ char* locs);
STATIC SV* S_mess_alloc(pTHX);
# if defined(LEAKTEST)
STATIC void S_xstat(pTHX_ int);
--- 1308,1319 ----
STATIC SV* S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level);
#endif
! #if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT)
STATIC char* S_stdize_locale(pTHX_ char* locs);
+ #endif
+
+ #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
+ STATIC COP* S_closest_cop(pTHX_ COP *cop, OP *o);
STATIC SV* S_mess_alloc(pTHX);
# if defined(LEAKTEST)
STATIC void S_xstat(pTHX_ int);
***************
*** 1302,1304 ****
--- 1323,1338 ----
#if defined(PERL_OBJECT)
};
#endif
+
+ START_EXTERN_C
+
+ PERL_CALLCONV void Perl_sv_setsv_flags(pTHX_ SV* dsv, SV* ssv, I32 flags);
+ PERL_CALLCONV void Perl_sv_catpvn_flags(pTHX_ SV* sv, const char* ptr, STRLEN len, I32 flags);
+ PERL_CALLCONV void Perl_sv_catsv_flags(pTHX_ SV* dsv, SV* ssv, I32 flags);
+ PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade_flags(pTHX_ SV *sv, I32 flags);
+ PERL_CALLCONV char* Perl_sv_pvn_force_flags(pTHX_ SV* sv, STRLEN* lp, I32 flags);
+ PERL_CALLCONV char* Perl_sv_2pv_flags(pTHX_ SV* sv, STRLEN* lp, I32 flags);
+ PERL_CALLCONV char* Perl_my_atof2(pTHX_ const char *s, NV* value);
+
+ END_EXTERN_C
+
diff -c 'perl-5.7.1/regcomp.c' 'perl-5.7.2/regcomp.c'
Index: ./regcomp.c
*** ./regcomp.c Sat Mar 31 08:26:26 2001
--- ./regcomp.c Thu Jul 12 21:45:38 2001
***************
*** 115,123 ****
--- 115,125 ----
U16 flags16; /* are we folding, multilining? */
char *precomp; /* uncompiled string. */
regexp *rx;
+ char *start; /* Start of input for compile */
char *end; /* End of input for compile */
char *parse; /* Input-scan pointer. */
I32 whilem_seen; /* number of WHILEM in this expr */
+ regnode *emit_start; /* Start of emitted-code area */
regnode *emit; /* Code-emit pointer; ®dummy = don't = compiling */
I32 naughty; /* How bad is this pattern? */
I32 sawback; /* Did we see \1, ...? */
***************
*** 137,146 ****
--- 139,151 ----
#define RExC_flags16 (pRExC_state->flags16)
#define RExC_precomp (pRExC_state->precomp)
#define RExC_rx (pRExC_state->rx)
+ #define RExC_start (pRExC_state->start)
#define RExC_end (pRExC_state->end)
#define RExC_parse (pRExC_state->parse)
#define RExC_whilem_seen (pRExC_state->whilem_seen)
+ #define RExC_offsets (pRExC_state->rx->offsets) /* I am not like the others */
#define RExC_emit (pRExC_state->emit)
+ #define RExC_emit_start (pRExC_state->emit_start)
#define RExC_naughty (pRExC_state->naughty)
#define RExC_sawback (pRExC_state->sawback)
#define RExC_seen (pRExC_state->seen)
***************
*** 245,254 ****
* of t/op/regmesg.t, the tests in t/op/re_tests, and those in
* op/pragma/warn/regcomp.
*/
! #define MARKER1 "HERE" /* marker as it appears in the description */
! #define MARKER2 " << HERE " /* marker as it appears within the regex */
! #define REPORT_LOCATION " before " MARKER1 " mark in regex m/%.*s" MARKER2 "%s/"
/*
* Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
--- 250,259 ----
* of t/op/regmesg.t, the tests in t/op/re_tests, and those in
* op/pragma/warn/regcomp.
*/
! #define MARKER1 "<-- HERE" /* marker as it appears in the description */
! #define MARKER2 " <-- HERE " /* marker as it appears within the regex */
! #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
/*
* Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
***************
*** 388,394 ****
--- 393,407 ----
m, (int)offset, RExC_precomp, RExC_precomp + offset); \
} STMT_END \
+ #define vWARNdep(loc,m) \
+ STMT_START { \
+ unsigned offset = strlen(RExC_precomp)-(RExC_end-(loc)); \
+ int warn_cat = ckWARN(WARN_REGEXP) ? WARN_REGEXP : WARN_DEPRECATED; \
+ Perl_warner(aTHX_ warn_cat, "%s" REPORT_LOCATION,\
+ m, (int)offset, RExC_precomp, RExC_precomp + offset); \
+ } STMT_END \
+
#define vWARN2(loc, m, a1) \
STMT_START { \
unsigned offset = strlen(RExC_precomp)-(RExC_end-(loc)); \
***************
*** 413,422 ****
(int)offset, RExC_precomp, RExC_precomp + offset); \
} STMT_END
/* Allow for side effects in s */
! #define REGC(c,s) STMT_START { if (!SIZE_ONLY) *(s) = (c); else (s);} STMT_END
static void clear_re(pTHXo_ void *r);
/* Mark that we cannot extend a found fixed substring at this point.
--- 426,488 ----
(int)offset, RExC_precomp, RExC_precomp + offset); \
} STMT_END
+ /* used for the parse_flags section for (?c) -- japhy */
+ #define vWARN5(loc, m, a1, a2, a3, a4) \
+ STMT_START { \
+ unsigned offset = strlen(RExC_precomp)-(RExC_end-(loc)); \
+ Perl_warner(aTHX_ WARN_REGEXP, m REPORT_LOCATION, \
+ a1, a2, a3, a4, \
+ (int)offset, RExC_precomp, RExC_precomp + offset); \
+ } STMT_END
+
/* Allow for side effects in s */
! #define REGC(c,s) STMT_START { if (!SIZE_ONLY) *(s) = (c); else (void)(s);} STMT_END
+ /* Macros for recording node offsets. 20001227 mjd@plover.com
+ * Nodes are numbered 1, 2, 3, 4. Node #n's position is recorded in
+ * element 2*n-1 of the array. Element #2n holds the byte length node #n.
+ * Element 0 holds the number n.
+ */
+
+ #define MJD_OFFSET_DEBUG(x)
+ /* #define MJD_OFFSET_DEBUG(x) fprintf x */
+
+
+ # define Set_Node_Offset_To_R(node,byte) \
+ STMT_START { \
+ if (! SIZE_ONLY) { \
+ if((node) < 0) { \
+ Perl_croak(aTHX_ "value of node is %d in Offset macro", node); \
+ } else { \
+ RExC_offsets[2*(node)-1] = (byte); \
+ } \
+ } \
+ } STMT_END
+
+ # define Set_Node_Offset(node,byte) Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
+ # define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
+
+ # define Set_Node_Length_To_R(node,len) \
+ STMT_START { \
+ if (! SIZE_ONLY) { \
+ MJD_OFFSET_DEBUG((stderr, "** (%d) size of node %d is %d.\n", __LINE__, (node), (len))); \
+ if((node) < 0) { \
+ Perl_croak(aTHX_ "value of node is %d in Length macro", node); \
+ } else { \
+ RExC_offsets[2*(node)] = (len); \
+ } \
+ } \
+ } STMT_END
+
+ # define Set_Node_Length(node,len) Set_Node_Length_To_R((node)-RExC_emit_start, len)
+ # define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
+ # define Set_Node_Cur_Length(node) Set_Node_Length(node, RExC_parse - parse_start)
+
+ /* Get offsets and lengths */
+ #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
+ #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
+
static void clear_re(pTHXo_ void *r);
/* Mark that we cannot extend a found fixed substring at this point.
***************
*** 828,837 ****
int compat = 1;
if (uc >= 0x100 ||
! !(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
&& !ANYOF_BITMAP_TEST(data->start_class, uc)
&& (!(data->start_class->flags & ANYOF_FOLD)
|| !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
compat = 0;
ANYOF_CLASS_ZERO(data->start_class);
ANYOF_BITMAP_ZERO(data->start_class);
--- 894,904 ----
int compat = 1;
if (uc >= 0x100 ||
! (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
&& !ANYOF_BITMAP_TEST(data->start_class, uc)
&& (!(data->start_class->flags & ANYOF_FOLD)
|| !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
+ )
compat = 0;
ANYOF_CLASS_ZERO(data->start_class);
ANYOF_BITMAP_ZERO(data->start_class);
***************
*** 872,880 ****
int compat = 1;
if (uc >= 0x100 ||
! !(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
&& !ANYOF_BITMAP_TEST(data->start_class, uc)
! && !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc]))
compat = 0;
ANYOF_CLASS_ZERO(data->start_class);
ANYOF_BITMAP_ZERO(data->start_class);
--- 939,947 ----
int compat = 1;
if (uc >= 0x100 ||
! (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
&& !ANYOF_BITMAP_TEST(data->start_class, uc)
! && !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
compat = 0;
ANYOF_CLASS_ZERO(data->start_class);
ANYOF_BITMAP_ZERO(data->start_class);
***************
*** 899,905 ****
flags &= ~SCF_DO_STCLASS;
}
else if (strchr((char*)PL_varies,OP(scan))) {
! I32 mincount, maxcount, minnext, deltanext, fl;
I32 f = flags, pos_before = 0;
regnode *oscan = scan;
struct regnode_charclass_class this_class;
--- 966,972 ----
flags &= ~SCF_DO_STCLASS;
}
else if (strchr((char*)PL_varies,OP(scan))) {
! I32 mincount, maxcount, minnext, deltanext, fl = 0;
I32 f = flags, pos_before = 0;
regnode *oscan = scan;
struct regnode_charclass_class this_class;
***************
*** 1009,1016 ****
}
if (!scan) /* It was not CURLYX, but CURLY. */
scan = next;
! if (ckWARN(WARN_REGEXP) && (minnext + deltanext == 0)
! && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
&& maxcount <= REG_INFTY/3) /* Complement check for big count */
{
vWARN(RExC_parse,
--- 1076,1084 ----
}
if (!scan) /* It was not CURLYX, but CURLY. */
scan = next;
! if (ckWARN(WARN_REGEXP)
! && (minnext == 0) && (deltanext == 0)
! && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
&& maxcount <= REG_INFTY/3) /* Complement check for big count */
{
vWARN(RExC_parse,
***************
*** 1031,1037 ****
&& !deltanext && minnext == 1 ) {
/* Try to optimize to CURLYN. */
regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
! regnode *nxt1 = nxt, *nxt2;
/* Skip open. */
nxt = regnext(nxt);
--- 1099,1108 ----
&& !deltanext && minnext == 1 ) {
/* Try to optimize to CURLYN. */
regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
! regnode *nxt1 = nxt;
! #ifdef DEBUGGING
! regnode *nxt2;
! #endif
/* Skip open. */
nxt = regnext(nxt);
***************
*** 1039,1045 ****
--- 1110,1118 ----
&& !(PL_regkind[(U8)OP(nxt)] == EXACT
&& STR_LEN(nxt) == 1))
goto nogo;
+ #ifdef DEBUGGING
nxt2 = nxt;
+ #endif
nxt = regnext(nxt);
if (OP(nxt) != CLOSE)
goto nogo;
***************
*** 1210,1216 ****
}
}
else if (strchr((char*)PL_simple,OP(scan))) {
! int value;
if (flags & SCF_DO_SUBSTR) {
scan_commit(pRExC_state,data);
--- 1283,1289 ----
}
}
else if (strchr((char*)PL_simple,OP(scan))) {
! int value = 0;
if (flags & SCF_DO_SUBSTR) {
scan_commit(pRExC_state,data);
***************
*** 1614,1619 ****
--- 1687,1693 ----
/* First pass: determine size, legality. */
RExC_parse = exp;
+ RExC_start = exp;
RExC_end = xend;
RExC_naughty = 0;
RExC_npar = 1;
***************
*** 1660,1665 ****
--- 1734,1748 ----
r->startp = 0; /* Useful during FAIL. */
r->endp = 0; /* Useful during FAIL. */
+ Newz(1304, r->offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
+ if (r->offsets) {
+ r->offsets[0] = RExC_size;
+ }
+ DEBUG_r(PerlIO_printf(Perl_debug_log,
+ "%s %"UVuf" bytes for offset annotations.\n",
+ r->offsets ? "Got" : "Couldn't get",
+ (UV)((2*RExC_size+1) * sizeof(U32))));
+
RExC_rx = r;
/* Second pass: emit code. */
***************
*** 1667,1672 ****
--- 1750,1756 ----
RExC_end = xend;
RExC_naughty = 0;
RExC_npar = 1;
+ RExC_emit_start = r->program;
RExC_emit = r->program;
/* Store the count of eval-groups for security checks: */
RExC_emit->next_off = ((RExC_seen_evals > U16_MAX) ? U16_MAX : RExC_seen_evals);
***************
*** 1853,1859 ****
if ((!r->anchored_substr || r->anchored_offset) && stclass_flag
&& !(data.start_class->flags & ANYOF_EOS)
&& !cl_is_anything(data.start_class)) {
- SV *sv;
I32 n = add_data(pRExC_state, 1, "f");
New(1006, RExC_rx->data->data[n], 1,
--- 1937,1942 ----
***************
*** 1864,1873 ****
r->regstclass = (regnode*)RExC_rx->data->data[n];
r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */
PL_regdata = r->data; /* for regprop() */
! DEBUG_r((sv = sv_newmortal(),
! regprop(sv, (regnode*)data.start_class),
! PerlIO_printf(Perl_debug_log, "synthetic stclass `%s'.\n",
! SvPVX(sv))));
}
/* A temporary algorithm prefers floated substr to fixed one to dig more info. */
--- 1947,1957 ----
r->regstclass = (regnode*)RExC_rx->data->data[n];
r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */
PL_regdata = r->data; /* for regprop() */
! DEBUG_r({ SV *sv = sv_newmortal();
! regprop(sv, (regnode*)data.start_class);
! PerlIO_printf(Perl_debug_log,
! "synthetic stclass `%s'.\n",
! SvPVX(sv));});
}
/* A temporary algorithm prefers floated substr to fixed one to dig more info. */
***************
*** 1905,1911 ****
r->check_substr = r->anchored_substr = r->float_substr = Nullsv;
if (!(data.start_class->flags & ANYOF_EOS)
&& !cl_is_anything(data.start_class)) {
- SV *sv;
I32 n = add_data(pRExC_state, 1, "f");
New(1006, RExC_rx->data->data[n], 1,
--- 1989,1994 ----
***************
*** 1915,1924 ****
struct regnode_charclass_class);
r->regstclass = (regnode*)RExC_rx->data->data[n];
r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */
! DEBUG_r((sv = sv_newmortal(),
! regprop(sv, (regnode*)data.start_class),
! PerlIO_printf(Perl_debug_log, "synthetic stclass `%s'.\n",
! SvPVX(sv))));
}
}
--- 1998,2008 ----
struct regnode_charclass_class);
r->regstclass = (regnode*)RExC_rx->data->data[n];
r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */
! DEBUG_r({ SV* sv = sv_newmortal();
! regprop(sv, (regnode*)data.start_class);
! PerlIO_printf(Perl_debug_log,
! "synthetic stclass `%s'.\n",
! SvPVX(sv));});
}
}
***************
*** 1957,1970 ****
register regnode *ender = 0;
register I32 parno = 0;
I32 flags, oregflags = RExC_flags16, have_branch = 0, open = 0;
char *oregcomp_parse = RExC_parse;
char c;
*flagp = 0; /* Tentatively. */
/* Make an OPEN node, if parenthesized. */
if (paren) {
! if (*RExC_parse == '?') {
U16 posflags = 0, negflags = 0;
U16 *flagsp = &posflags;
int logical = 0;
--- 2041,2066 ----
register regnode *ender = 0;
register I32 parno = 0;
I32 flags, oregflags = RExC_flags16, have_branch = 0, open = 0;
+
+ /* for (?g), (?gc), and (?o) warnings; warning
+ about (?c) will warn about (?g) -- japhy */
+
+ I32 wastedflags = 0x00,
+ wasted_o = 0x01,
+ wasted_g = 0x02,
+ wasted_gc = 0x02 | 0x04,
+ wasted_c = 0x04;
+
+ char * parse_start = RExC_parse; /* MJD */
char *oregcomp_parse = RExC_parse;
char c;
*flagp = 0; /* Tentatively. */
+
/* Make an OPEN node, if parenthesized. */
if (paren) {
! if (*RExC_parse == '?') { /* (?...) */
U16 posflags = 0, negflags = 0;
U16 *flagsp = &posflags;
int logical = 0;
***************
*** 1974,1980 ****
paren = *RExC_parse++;
ret = NULL; /* For look-ahead/behind. */
switch (paren) {
! case '<':
RExC_seen |= REG_SEEN_LOOKBEHIND;
if (*RExC_parse == '!')
paren = ',';
--- 2070,2076 ----
paren = *RExC_parse++;
ret = NULL; /* For look-ahead/behind. */
switch (paren) {
! case '<': /* (?<...) */
RExC_seen |= REG_SEEN_LOOKBEHIND;
if (*RExC_parse == '!')
paren = ',';
***************
*** 1981,1997 ****
if (*RExC_parse != '=' && *RExC_parse != '!')
goto unknown;
RExC_parse++;
! case '=':
! case '!':
RExC_seen_zerolen++;
! case ':':
! case '>':
break;
! case '$':
! case '@':
vFAIL2("Sequence (?%c...) not implemented", (int)paren);
break;
! case '#':
while (*RExC_parse && *RExC_parse != ')')
RExC_parse++;
if (*RExC_parse != ')')
--- 2077,2093 ----
if (*RExC_parse != '=' && *RExC_parse != '!')
goto unknown;
RExC_parse++;
! case '=': /* (?=...) */
! case '!': /* (?!...) */
RExC_seen_zerolen++;
! case ':': /* (?:...) */
! case '>': /* (?>...) */
break;
! case '$': /* (?$...) */
! case '@': /* (?@...) */
vFAIL2("Sequence (?%c...) not implemented", (int)paren);
break;
! case '#': /* (?#...) */
while (*RExC_parse && *RExC_parse != ')')
RExC_parse++;
if (*RExC_parse != ')')
***************
*** 1999,2013 ****
nextchar(pRExC_state);
*flagp = TRYAGAIN;
return NULL;
! case 'p':
! if (SIZE_ONLY)
! vWARN(RExC_parse, "(?p{}) is deprecated - use (??{})");
/* FALL THROUGH*/
! case '?':
logical = 1;
paren = *RExC_parse++;
/* FALL THROUGH */
! case '{':
{
I32 count = 1, n = 0;
char c;
--- 2095,2109 ----
nextchar(pRExC_state);
*flagp = TRYAGAIN;
return NULL;
! case 'p': /* (?p...) */
! if (SIZE_ONLY && ckWARN2(WARN_DEPRECATED, WARN_REGEXP))
! vWARNdep(RExC_parse, "(?p{}) is deprecated - use (??{})");
/* FALL THROUGH*/
! case '?': /* (??...) */
logical = 1;
paren = *RExC_parse++;
/* FALL THROUGH */
! case '{': /* (?{...}) */
{
I32 count = 1, n = 0;
char c;
***************
*** 2056,2062 ****
/* No compiled RE interpolated, has runtime
components ===> unsafe. */
FAIL("Eval-group not allowed at runtime, use re 'eval'");
! if (PL_tainted)
FAIL("Eval-group in insecure regular expression");
}
--- 2152,2158 ----
/* No compiled RE interpolated, has runtime
components ===> unsafe. */
FAIL("Eval-group not allowed at runtime, use re 'eval'");
! if (PL_tainting && PL_tainted)
FAIL("Eval-group in insecure regular expression");
}
***************
*** 2066,2078 ****
if (!SIZE_ONLY)
ret->flags = 2;
regtail(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
return ret;
}
return reganode(pRExC_state, EVAL, n);
}
! case '(':
{
! if (RExC_parse[0] == '?') {
if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
|| RExC_parse[1] == '<'
|| RExC_parse[1] == '{') { /* Lookahead or eval. */
--- 2162,2175 ----
if (!SIZE_ONLY)
ret->flags = 2;
regtail(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
+ /* deal with the length of this later - MJD */
return ret;
}
return reganode(pRExC_state, EVAL, n);
}
! case '(': /* (?(?{...})...) and (?(?=...)...) */
{
! if (RExC_parse[0] == '?') { /* (?(?...)) */
if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
|| RExC_parse[1] == '<'
|| RExC_parse[1] == '{') { /* Lookahead or eval. */
***************
*** 2086,2096 ****
}
}
else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
parno = atoi(RExC_parse++);
while (isDIGIT(*RExC_parse))
RExC_parse++;
! ret = reganode(pRExC_state, GROUPP, parno);
if ((c = *nextchar(pRExC_state)) != ')')
vFAIL("Switch condition not recognized");
insert_if:
--- 2183,2195 ----
}
}
else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
+ /* (?(1)...) */
parno = atoi(RExC_parse++);
while (isDIGIT(*RExC_parse))
RExC_parse++;
! ret = reganode(pRExC_state, GROUPP, parno);
!
if ((c = *nextchar(pRExC_state)) != ')')
vFAIL("Switch condition not recognized");
insert_if:
***************
*** 2135,2148 ****
break;
default:
--RExC_parse;
! parse_flags:
while (*RExC_parse && strchr("iogcmsx", *RExC_parse)) {
! if (*RExC_parse != 'o')
! pmflag(flagsp, *RExC_parse);
++RExC_parse;
}
if (*RExC_parse == '-') {
flagsp = &negflags;
++RExC_parse;
goto parse_flags;
}
--- 2234,2280 ----
break;
default:
--RExC_parse;
! parse_flags: /* (?i) */
while (*RExC_parse && strchr("iogcmsx", *RExC_parse)) {
! /* (?g), (?gc) and (?o) are useless here
! and must be globally applied -- japhy */
!
! if (*RExC_parse == 'o' || *RExC_parse == 'g') {
! if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
! I32 wflagbit = *RExC_parse == 'o' ? wasted_o : wasted_g;
! if (! (wastedflags & wflagbit) ) {
! wastedflags |= wflagbit;
! vWARN5(
! RExC_parse + 1,
! "Useless (%s%c) - %suse /%c modifier",
! flagsp == &negflags ? "?-" : "?",
! *RExC_parse,
! flagsp == &negflags ? "don't " : "",
! *RExC_parse
! );
! }
! }
! }
! else if (*RExC_parse == 'c') {
! if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
! if (! (wastedflags & wasted_c) ) {
! wastedflags |= wasted_gc;
! vWARN3(
! RExC_parse + 1,
! "Useless (%sc) - %suse /gc modifier",
! flagsp == &negflags ? "?-" : "?",
! flagsp == &negflags ? "don't " : ""
! );
! }
! }
! }
! else { pmflag(flagsp, *RExC_parse); }
!
++RExC_parse;
}
if (*RExC_parse == '-') {
flagsp = &negflags;
+ wastedflags = 0; /* reset so (?g-c) warns twice */
++RExC_parse;
goto parse_flags;
}
***************
*** 2163,2180 ****
return NULL;
}
}
! else {
parno = RExC_npar;
RExC_npar++;
ret = reganode(pRExC_state, OPEN, parno);
open = 1;
}
}
! else
ret = NULL;
/* Pick up the branches, linking them together. */
br = regbranch(pRExC_state, &flags, 1);
if (br == NULL)
return(NULL);
if (*RExC_parse == '|') {
--- 2295,2317 ----
return NULL;
}
}
! else { /* (...) */
parno = RExC_npar;
RExC_npar++;
ret = reganode(pRExC_state, OPEN, parno);
+ Set_Node_Length(ret, 1); /* MJD */
+ Set_Node_Offset(ret, RExC_parse); /* MJD */
open = 1;
}
}
! else /* ! paren */
ret = NULL;
/* Pick up the branches, linking them together. */
+ parse_start = RExC_parse; /* MJD */
br = regbranch(pRExC_state, &flags, 1);
+ /* branch_len = (paren != 0); */
+
if (br == NULL)
return(NULL);
if (*RExC_parse == '|') {
***************
*** 2181,2188 ****
if (!SIZE_ONLY && RExC_extralen) {
reginsert(pRExC_state, BRANCHJ, br);
}
! else
reginsert(pRExC_state, BRANCH, br);
have_branch = 1;
if (SIZE_ONLY)
RExC_extralen += 1; /* For BRANCHJ-BRANCH. */
--- 2318,2328 ----
if (!SIZE_ONLY && RExC_extralen) {
reginsert(pRExC_state, BRANCHJ, br);
}
! else { /* MJD */
reginsert(pRExC_state, BRANCH, br);
+ Set_Node_Length(br, paren != 0);
+ Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
+ }
have_branch = 1;
if (SIZE_ONLY)
RExC_extralen += 1; /* For BRANCHJ-BRANCH. */
***************
*** 2208,2213 ****
--- 2348,2354 ----
RExC_extralen += 2; /* Account for LONGJMP. */
nextchar(pRExC_state);
br = regbranch(pRExC_state, &flags, 0);
+
if (br == NULL)
return(NULL);
regtail(pRExC_state, lastbr, br); /* BRANCH -> BRANCH. */
***************
*** 2225,2230 ****
--- 2366,2373 ----
break;
case 1:
ender = reganode(pRExC_state, CLOSE, parno);
+ Set_Node_Offset(ender,RExC_parse+1); /* MJD */
+ Set_Node_Length(ender,1); /* MJD */
break;
case '<':
case ',':
***************
*** 2304,2311 ****
else {
if (!SIZE_ONLY && RExC_extralen)
ret = reganode(pRExC_state, BRANCHJ,0);
! else
ret = reg_node(pRExC_state, BRANCH);
}
if (!first && SIZE_ONLY)
--- 2447,2456 ----
else {
if (!SIZE_ONLY && RExC_extralen)
ret = reganode(pRExC_state, BRANCHJ,0);
! else {
ret = reg_node(pRExC_state, BRANCH);
+ Set_Node_Length(ret, 1);
+ }
}
if (!first && SIZE_ONLY)
***************
*** 2367,2372 ****
--- 2512,2518 ----
char *maxpos;
I32 min;
I32 max = REG_INFTY;
+ char *parse_start;
ret = regatom(pRExC_state, &flags);
if (ret == NULL) {
***************
*** 2378,2383 ****
--- 2524,2530 ----
op = *RExC_parse;
if (op == '{' && regcurly(RExC_parse)) {
+ parse_start = RExC_parse; /* MJD */
next = RExC_parse + 1;
maxpos = Nullch;
while (isDIGIT(*next) || *next == ',') {
***************
*** 2410,2415 ****
--- 2557,2564 ----
if ((flags&SIMPLE)) {
RExC_naughty += 2 + RExC_naughty / 2;
reginsert(pRExC_state, CURLY, ret);
+ Set_Node_Offset(ret, parse_start+1); /* MJD */
+ Set_Node_Cur_Length(ret);
}
else {
regnode *w = reg_node(pRExC_state, WHILEM);
***************
*** 2422,2427 ****
--- 2571,2581 ----
NEXT_OFF(ret) = 3; /* Go over LONGJMP. */
}
reginsert(pRExC_state, CURLYX,ret);
+ /* MJD hk */
+ Set_Node_Offset(ret, parse_start+1);
+ Set_Node_Length(ret,
+ op == '{' ? (RExC_parse - parse_start) : 1);
+
if (!SIZE_ONLY && RExC_extralen)
NEXT_OFF(ret) = 3; /* Go over NOTHING to LONGJMP. */
regtail(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
***************
*** 2467,2472 ****
--- 2621,2627 ----
vFAIL("Regexp *+ operand could be empty");
#endif
+ parse_start = RExC_parse;
nextchar(pRExC_state);
*flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
***************
*** 2528,2533 ****
--- 2683,2689 ----
{
register regnode *ret = 0;
I32 flags;
+ char *parse_start = 0;
*flagp = WORST; /* Tentatively. */
***************
*** 2542,2547 ****
--- 2698,2704 ----
ret = reg_node(pRExC_state, SBOL);
else
ret = reg_node(pRExC_state, BOL);
+ Set_Node_Length(ret, 1); /* MJD */
break;
case '$':
nextchar(pRExC_state);
***************
*** 2553,2558 ****
--- 2710,2716 ----
ret = reg_node(pRExC_state, SEOL);
else
ret = reg_node(pRExC_state, EOL);
+ Set_Node_Length(ret, 1); /* MJD */
break;
case '.':
nextchar(pRExC_state);
***************
*** 2562,2567 ****
--- 2720,2726 ----
ret = reg_node(pRExC_state, REG_ANY);
*flagp |= HASWIDTH|SIMPLE;
RExC_naughty++;
+ Set_Node_Length(ret, 1); /* MJD */
break;
case '[':
{
***************
*** 2573,2578 ****
--- 2732,2738 ----
}
nextchar(pRExC_state);
*flagp |= HASWIDTH|SIMPLE;
+ Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
break;
}
case '(':
***************
*** 2619,2624 ****
--- 2779,2785 ----
ret = reg_node(pRExC_state, SBOL);
*flagp |= SIMPLE;
nextchar(pRExC_state);
+ Set_Node_Length(ret, 2); /* MJD */
break;
case 'G':
ret = reg_node(pRExC_state, GPOS);
***************
*** 2625,2630 ****
--- 2786,2792 ----
RExC_seen |= REG_SEEN_GPOS;
*flagp |= SIMPLE;
nextchar(pRExC_state);
+ Set_Node_Length(ret, 2); /* MJD */
break;
case 'Z':
ret = reg_node(pRExC_state, SEOL);
***************
*** 2636,2641 ****
--- 2798,2804 ----
*flagp |= SIMPLE;
RExC_seen_zerolen++; /* Do not optimize RE away */
nextchar(pRExC_state);
+ Set_Node_Length(ret, 2); /* MJD */
break;
case 'C':
ret = reg_node(pRExC_state, SANY);
***************
*** 2642,2662 ****
--- 2805,2829 ----
RExC_seen |= REG_SEEN_SANY;
*flagp |= HASWIDTH|SIMPLE;
nextchar(pRExC_state);
+ Set_Node_Length(ret, 2); /* MJD */
break;
case 'X':
ret = reg_node(pRExC_state, CLUMP);
*flagp |= HASWIDTH;
nextchar(pRExC_state);
+ Set_Node_Length(ret, 2); /* MJD */
break;
case 'w':
ret = reg_node(pRExC_state, LOC ? ALNUML : ALNUM);
*flagp |= HASWIDTH|SIMPLE;
nextchar(pRExC_state);
+ Set_Node_Length(ret, 2); /* MJD */
break;
case 'W':
ret = reg_node(pRExC_state, LOC ? NALNUML : NALNUM);
*flagp |= HASWIDTH|SIMPLE;
nextchar(pRExC_state);
+ Set_Node_Length(ret, 2); /* MJD */
break;
case 'b':
RExC_seen_zerolen++;
***************
*** 2664,2669 ****
--- 2831,2837 ----
ret = reg_node(pRExC_state, LOC ? BOUNDL : BOUND);
*flagp |= SIMPLE;
nextchar(pRExC_state);
+ Set_Node_Length(ret, 2); /* MJD */
break;
case 'B':
RExC_seen_zerolen++;
***************
*** 2671,2703 ****
ret = reg_node(pRExC_state, LOC ? NBOUNDL : NBOUND);
*flagp |= SIMPLE;
nextchar(pRExC_state);
break;
case 's':
ret = reg_node(pRExC_state, LOC ? SPACEL : SPACE);
*flagp |= HASWIDTH|SIMPLE;
nextchar(pRExC_state);
break;
case 'S':
ret = reg_node(pRExC_state, LOC ? NSPACEL : NSPACE);
*flagp |= HASWIDTH|SIMPLE;
nextchar(pRExC_state);
break;
case 'd':
ret = reg_node(pRExC_state, DIGIT);
*flagp |= HASWIDTH|SIMPLE;
nextchar(pRExC_state);
break;
case 'D':
ret = reg_node(pRExC_state, NDIGIT);
*flagp |= HASWIDTH|SIMPLE;
nextchar(pRExC_state);
break;
case 'p':
case 'P':
! { /* a lovely hack--pretend we saw [\pX] instead */
char* oldregxend = RExC_end;
if (RExC_parse[1] == '{') {
RExC_end = strchr(RExC_parse, '}');
if (!RExC_end) {
RExC_parse += 2;
--- 2839,2878 ----
ret = reg_node(pRExC_state, LOC ? NBOUNDL : NBOUND);
*flagp |= SIMPLE;
nextchar(pRExC_state);
+ Set_Node_Length(ret, 2); /* MJD */
break;
case 's':
ret = reg_node(pRExC_state, LOC ? SPACEL : SPACE);
*flagp |= HASWIDTH|SIMPLE;
nextchar(pRExC_state);
+ Set_Node_Length(ret, 2); /* MJD */
break;
case 'S':
ret = reg_node(pRExC_state, LOC ? NSPACEL : NSPACE);
*flagp |= HASWIDTH|SIMPLE;
nextchar(pRExC_state);
+ Set_Node_Length(ret, 2); /* MJD */
break;
case 'd':
ret = reg_node(pRExC_state, DIGIT);
*flagp |= HASWIDTH|SIMPLE;
nextchar(pRExC_state);
+ Set_Node_Length(ret, 2); /* MJD */
break;
case 'D':
ret = reg_node(pRExC_state, NDIGIT);
*flagp |= HASWIDTH|SIMPLE;
nextchar(pRExC_state);
+ Set_Node_Length(ret, 2); /* MJD */
break;
case 'p':
case 'P':
! {
char* oldregxend = RExC_end;
+ char* parse_start = RExC_parse;
if (RExC_parse[1] == '{') {
+ /* a lovely hack--pretend we saw [\pX] instead */
RExC_end = strchr(RExC_parse, '}');
if (!RExC_end) {
RExC_parse += 2;
***************
*** 2714,2719 ****
--- 2889,2895 ----
RExC_end = oldregxend;
RExC_parse--;
+ Set_Node_Cur_Length(ret); /* MJD */
nextchar(pRExC_state);
*flagp |= HASWIDTH|SIMPLE;
}
***************
*** 2736,2741 ****
--- 2912,2918 ----
if (num > 9 && num >= RExC_npar)
goto defchar;
else {
+ char * parse_start = RExC_parse - 1; /* MJD */
while (isDIGIT(*RExC_parse))
RExC_parse++;
***************
*** 2746,2751 ****
--- 2923,2932 ----
? (LOC ? REFFL : REFF)
: REF, num);
*flagp |= HASWIDTH;
+
+ /* override incorrect value set in reganode MJD */
+ Set_Node_Offset(ret, parse_start+1);
+ Set_Node_Cur_Length(ret); /* MJD */
RExC_parse--;
nextchar(pRExC_state);
}
***************
*** 2777,2782 ****
--- 2958,2965 ----
char *oldp, *s;
STRLEN numlen;
+ parse_start = RExC_parse - 1;
+
RExC_parse++;
defchar:
***************
*** 2941,2946 ****
--- 3124,3130 ----
}
loopdone:
RExC_parse = p - 1;
+ Set_Node_Cur_Length(ret); /* MJD */
nextchar(pRExC_state);
{
/* len is STRLEN which is unsigned, need to copy to signed */
***************
*** 3145,3161 ****
S_regclass(pTHX_ RExC_state_t *pRExC_state)
{
register UV value;
! register IV lastvalue = OOB_UNICODE;
register IV range = 0;
register regnode *ret;
STRLEN numlen;
IV namedclass;
! char *rangebegin;
bool need_class = 0;
! SV *listsv;
register char *e;
UV n;
! bool dont_optimize_invert = FALSE;
ret = reganode(pRExC_state, ANYOF, 0);
--- 3329,3345 ----
S_regclass(pTHX_ RExC_state_t *pRExC_state)
{
register UV value;
! register IV prevvalue = OOB_UNICODE;
register IV range = 0;
register regnode *ret;
STRLEN numlen;
IV namedclass;
! char *rangebegin = 0;
bool need_class = 0;
! SV *listsv = Nullsv;
register char *e;
UV n;
! bool optimize_invert = TRUE;
ret = reganode(pRExC_state, ANYOF, 0);
***************
*** 3197,3204 ****
rangebegin = RExC_parse;
if (UTF) {
value = utf8n_to_uvchr((U8*)RExC_parse,
! RExC_end - RExC_parse,
! &numlen, 0);
RExC_parse += numlen;
}
else
--- 3381,3388 ----
rangebegin = RExC_parse;
if (UTF) {
value = utf8n_to_uvchr((U8*)RExC_parse,
! RExC_end - RExC_parse,
! &numlen, 0);
RExC_parse += numlen;
}
else
***************
*** 3308,3321 ****
RExC_parse - rangebegin,
RExC_parse - rangebegin,
rangebegin);
! if (lastvalue < 256) {
! ANYOF_BITMAP_SET(ret, lastvalue);
ANYOF_BITMAP_SET(ret, '-');
}
else {
ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
Perl_sv_catpvf(aTHX_ listsv,
! "%04"UVxf"\n%04"UVxf"\n", (UV)lastvalue, (UV) '-');
}
}
--- 3492,3505 ----
RExC_parse - rangebegin,
RExC_parse - rangebegin,
rangebegin);
! if (prevvalue < 256) {
! ANYOF_BITMAP_SET(ret, prevvalue);
ANYOF_BITMAP_SET(ret, '-');
}
else {
ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
Perl_sv_catpvf(aTHX_ listsv,
! "%04"UVxf"\n%04"UVxf"\n", (UV)prevvalue, (UV) '-');
}
}
***************
*** 3323,3328 ****
--- 3507,3514 ----
}
if (!SIZE_ONLY) {
+ if (namedclass > OOB_NAMEDCLASS)
+ optimize_invert = FALSE;
/* Possible truncation here but in some 64-bit environments
* the compiler gets heartburn about switch on 64-bit values.
* A similar issue a little earlier when switching on value.
***************
*** 3336,3342 ****
if (isALNUM(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsWord\n");
break;
case ANYOF_NALNUM:
--- 3522,3527 ----
***************
*** 3347,3353 ****
if (!isALNUM(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsWord\n");
break;
case ANYOF_ALNUMC:
--- 3532,3537 ----
***************
*** 3358,3364 ****
if (isALNUMC(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlnum\n");
break;
case ANYOF_NALNUMC:
--- 3542,3547 ----
***************
*** 3369,3375 ****
if (!isALNUMC(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlnum\n");
break;
case ANYOF_ALPHA:
--- 3552,3557 ----
***************
*** 3380,3386 ****
if (isALPHA(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlpha\n");
break;
case ANYOF_NALPHA:
--- 3562,3567 ----
***************
*** 3391,3397 ****
if (!isALPHA(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlpha\n");
break;
case ANYOF_ASCII:
--- 3572,3577 ----
***************
*** 3403,3420 ****
ANYOF_BITMAP_SET(ret, value);
#else /* EBCDIC */
for (value = 0; value < 256; value++) {
! if (PL_hints & HINT_RE_ASCIIR) {
! if (NATIVE_TO_ASCII(value) < 128)
! ANYOF_BITMAP_SET(ret, value);
! }
! else {
! if (isASCII(value))
! ANYOF_BITMAP_SET(ret, value);
! }
}
#endif /* EBCDIC */
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsASCII\n");
break;
case ANYOF_NASCII:
--- 3583,3593 ----
ANYOF_BITMAP_SET(ret, value);
#else /* EBCDIC */
for (value = 0; value < 256; value++) {
! if (isASCII(value))
! ANYOF_BITMAP_SET(ret, value);
}
#endif /* EBCDIC */
}
Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsASCII\n");
break;
case ANYOF_NASCII:
***************
*** 3426,3443 ****
ANYOF_BITMAP_SET(ret, value);
#else /* EBCDIC */
for (value = 0; value < 256; value++) {
! if (PL_hints & HINT_RE_ASCIIR) {
! if (NATIVE_TO_ASCII(value) >= 128)
! ANYOF_BITMAP_SET(ret, value);
! }
! else {
! if (!isASCII(value))
! ANYOF_BITMAP_SET(ret, value);
! }
}
#endif /* EBCDIC */
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsASCII\n");
break;
case ANYOF_BLANK:
--- 3599,3609 ----
ANYOF_BITMAP_SET(ret, value);
#else /* EBCDIC */
for (value = 0; value < 256; value++) {
! if (!isASCII(value))
! ANYOF_BITMAP_SET(ret, value);
}
#endif /* EBCDIC */
}
Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsASCII\n");
break;
case ANYOF_BLANK:
***************
*** 3448,3454 ****
if (isBLANK(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsBlank\n");
break;
case ANYOF_NBLANK:
--- 3614,3619 ----
***************
*** 3459,3465 ****
if (!isBLANK(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsBlank\n");
break;
case ANYOF_CNTRL:
--- 3624,3629 ----
***************
*** 3470,3476 ****
if (isCNTRL(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsCntrl\n");
break;
case ANYOF_NCNTRL:
--- 3634,3639 ----
***************
*** 3481,3487 ****
if (!isCNTRL(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsCntrl\n");
break;
case ANYOF_DIGIT:
--- 3644,3649 ----
***************
*** 3492,3498 ****
for (value = '0'; value <= '9'; value++)
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsDigit\n");
break;
case ANYOF_NDIGIT:
--- 3654,3659 ----
***************
*** 3505,3511 ****
for (value = '9' + 1; value < 256; value++)
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsDigit\n");
break;
case ANYOF_GRAPH:
--- 3666,3671 ----
***************
*** 3516,3522 ****
if (isGRAPH(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsGraph\n");
break;
case ANYOF_NGRAPH:
--- 3676,3681 ----
***************
*** 3527,3533 ****
if (!isGRAPH(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsGraph\n");
break;
case ANYOF_LOWER:
--- 3686,3691 ----
***************
*** 3538,3544 ****
if (isLOWER(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsLower\n");
break;
case ANYOF_NLOWER:
--- 3696,3701 ----
***************
*** 3549,3555 ****
if (!isLOWER(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsLower\n");
break;
case ANYOF_PRINT:
--- 3706,3711 ----
***************
*** 3560,3566 ****
if (isPRINT(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPrint\n");
break;
case ANYOF_NPRINT:
--- 3716,3721 ----
***************
*** 3571,3577 ****
if (!isPRINT(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPrint\n");
break;
case ANYOF_PSXSPC:
--- 3726,3731 ----
***************
*** 3582,3588 ****
if (isPSXSPC(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpace\n");
break;
case ANYOF_NPSXSPC:
--- 3736,3741 ----
***************
*** 3593,3599 ****
if (!isPSXSPC(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsSpace\n");
break;
case ANYOF_PUNCT:
--- 3746,3751 ----
***************
*** 3604,3610 ****
if (isPUNCT(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPunct\n");
break;
case ANYOF_NPUNCT:
--- 3756,3761 ----
***************
*** 3615,3621 ****
if (!isPUNCT(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPunct\n");
break;
case ANYOF_SPACE:
--- 3766,3771 ----
***************
*** 3626,3632 ****
if (isSPACE(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpacePerl\n");
break;
case ANYOF_NSPACE:
--- 3776,3781 ----
***************
*** 3637,3643 ****
if (!isSPACE(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsSpacePerl\n");
break;
case ANYOF_UPPER:
--- 3786,3791 ----
***************
*** 3648,3654 ****
if (isUPPER(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsUpper\n");
break;
case ANYOF_NUPPER:
--- 3796,3801 ----
***************
*** 3659,3665 ****
if (!isUPPER(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsUpper\n");
break;
case ANYOF_XDIGIT:
--- 3806,3811 ----
***************
*** 3670,3676 ****
if (isXDIGIT(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsXDigit\n");
break;
case ANYOF_NXDIGIT:
--- 3816,3821 ----
***************
*** 3681,3687 ****
if (!isXDIGIT(value))
ANYOF_BITMAP_SET(ret, value);
}
- dont_optimize_invert = TRUE;
Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsXDigit\n");
break;
default:
--- 3826,3831 ----
***************
*** 3695,3711 ****
} /* end of namedclass \blah */
if (range) {
! if (((lastvalue > value) && !(PL_hints & HINT_RE_ASCIIR)) ||
! ((NATIVE_TO_UNI(lastvalue) > NATIVE_TO_UNI(value)) && (PL_hints & HINT_RE_ASCIIR))) /* b-a */ {
Simple_vFAIL4("Invalid [] range \"%*.*s\"",
RExC_parse - rangebegin,
RExC_parse - rangebegin,
rangebegin);
}
- range = 0; /* not a true range */
}
else {
! lastvalue = value; /* save the beginning of the range */
if (*RExC_parse == '-' && RExC_parse+1 < RExC_end &&
RExC_parse[1] != ']') {
RExC_parse++;
--- 3839,3854 ----
} /* end of namedclass \blah */
if (range) {
! if (prevvalue > value) /* b-a */ {
Simple_vFAIL4("Invalid [] range \"%*.*s\"",
RExC_parse - rangebegin,
RExC_parse - rangebegin,
rangebegin);
+ range = 0; /* not a valid range */
}
}
else {
! prevvalue = value; /* save the beginning of the range */
if (*RExC_parse == '-' && RExC_parse+1 < RExC_end &&
RExC_parse[1] != ']') {
RExC_parse++;
***************
*** 3728,3755 ****
/* now is the next time */
if (!SIZE_ONLY) {
! if (lastvalue < 256 && value < 256) {
! #ifdef EBCDIC /* EBCDIC, for example. */
! if (PL_hints & HINT_RE_ASCIIR) {
! IV i;
! /* New style scheme for ranges:
! * after :
! * use re 'asciir';
! * do ranges in ASCII/Unicode space
! */
! for (i = NATIVE_TO_ASCII(lastvalue) ; i <= NATIVE_TO_ASCII(value); i++)
! ANYOF_BITMAP_SET(ret, ASCII_TO_NATIVE(i));
! }
! else if ((isLOWER(lastvalue) && isLOWER(value)) ||
! (isUPPER(lastvalue) && isUPPER(value)))
{
! IV i;
! if (isLOWER(lastvalue)) {
! for (i = lastvalue; i <= value; i++)
if (isLOWER(i))
ANYOF_BITMAP_SET(ret, i);
} else {
! for (i = lastvalue; i <= value; i++)
if (isUPPER(i))
ANYOF_BITMAP_SET(ret, i);
}
--- 3871,3891 ----
/* now is the next time */
if (!SIZE_ONLY) {
! IV i;
!
! if (prevvalue < 256) {
! IV ceilvalue = value < 256 ? value : 255;
!
! #ifdef EBCDIC
! if ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
! (isUPPER(prevvalue) && isUPPER(ceilvalue)))
{
! if (isLOWER(prevvalue)) {
! for (i = prevvalue; i <= ceilvalue; i++)
if (isLOWER(i))
ANYOF_BITMAP_SET(ret, i);
} else {
! for (i = prevvalue; i <= ceilvalue; i++)
if (isUPPER(i))
ANYOF_BITMAP_SET(ret, i);
}
***************
*** 3756,3769 ****
}
else
#endif
! for ( ; lastvalue <= value; lastvalue++)
! ANYOF_BITMAP_SET(ret, lastvalue);
! } else {
ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
! if (lastvalue < value)
Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
! (UV)lastvalue, (UV)value);
! else
Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
(UV)value);
}
--- 3892,3906 ----
}
else
#endif
! for (i = prevvalue; i <= ceilvalue; i++)
! ANYOF_BITMAP_SET(ret, i);
! }
! if (value > 255) {
ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
! if (prevvalue < value)
Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
! (UV)prevvalue, (UV)value);
! else if (prevvalue == value)
Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
(UV)value);
}
***************
*** 3773,3778 ****
--- 3910,3916 ----
}
if (need_class) {
+ ANYOF_FLAGS(ret) |= ANYOF_LARGE;
if (SIZE_ONLY)
RExC_size += ANYOF_CLASS_ADD_SKIP;
else
***************
*** 3781,3789 ****
/* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
if (!SIZE_ONLY &&
- (ANYOF_FLAGS(ret) &
/* If the only flag is folding (plus possibly inversion). */
! (ANYOF_FLAGS_ALL ^ ANYOF_INVERT) == ANYOF_FOLD)) {
for (value = 0; value < 256; ++value) {
if (ANYOF_BITMAP_TEST(ret, value)) {
IV fold = PL_fold[value];
--- 3919,3927 ----
/* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
if (!SIZE_ONLY &&
/* If the only flag is folding (plus possibly inversion). */
! ((ANYOF_FLAGS(ret) & (ANYOF_FLAGS_ALL ^ ANYOF_INVERT)) == ANYOF_FOLD)
! ) {
for (value = 0; value < 256; ++value) {
if (ANYOF_BITMAP_TEST(ret, value)) {
IV fold = PL_fold[value];
***************
*** 3796,3802 ****
}
/* optimize inverted simple patterns (e.g. [^a-z]) */
! if (!SIZE_ONLY && !dont_optimize_invert &&
/* If the only flag is inversion. */
(ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
--- 3934,3940 ----
}
/* optimize inverted simple patterns (e.g. [^a-z]) */
! if (!SIZE_ONLY && optimize_invert &&
/* If the only flag is inversion. */
(ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
***************
*** 3867,3872 ****
--- 4005,4022 ----
NODE_ALIGN_FILL(ret);
ptr = ret;
FILL_ADVANCE_NODE(ptr, op);
+ if (RExC_offsets) { /* MJD */
+ MJD_OFFSET_DEBUG((stderr, "%s:%u: (op %s) %s %u <- %u (len %u) (max %u).\n",
+ "reg_node", __LINE__,
+ reg_name[op],
+ RExC_emit - RExC_emit_start > RExC_offsets[0]
+ ? "Overwriting end of array!\n" : "OK",
+ RExC_emit - RExC_emit_start,
+ RExC_parse - RExC_start,
+ RExC_offsets[0]));
+ Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
+ }
+
RExC_emit = ptr;
return(ret);
***************
*** 3891,3896 ****
--- 4041,4057 ----
NODE_ALIGN_FILL(ret);
ptr = ret;
FILL_ADVANCE_NODE_ARG(ptr, op, arg);
+ if (RExC_offsets) { /* MJD */
+ MJD_OFFSET_DEBUG((stderr, "%s: %s %u <- %u (max %u).\n",
+ "reganode",
+ RExC_emit - RExC_emit_start > RExC_offsets[0] ?
+ "Overwriting end of array!\n" : "OK",
+ RExC_emit - RExC_emit_start,
+ RExC_parse - RExC_start,
+ RExC_offsets[0]));
+ Set_Cur_Node_Offset;
+ }
+
RExC_emit = ptr;
return(ret);
***************
*** 3928,3937 ****
src = RExC_emit;
RExC_emit += NODE_STEP_REGNODE + offset;
dst = RExC_emit;
! while (src > opnd)
StructCopy(--src, --dst, regnode);
place = opnd; /* Op node, where operand used to be. */
src = NEXTOPER(place);
FILL_ADVANCE_NODE(place, op);
Zero(src, offset, regnode);
--- 4089,4121 ----
src = RExC_emit;
RExC_emit += NODE_STEP_REGNODE + offset;
dst = RExC_emit;
! while (src > opnd) {
StructCopy(--src, --dst, regnode);
+ if (RExC_offsets) { /* MJD 20010112 */
+ MJD_OFFSET_DEBUG((stderr, "%s: %s copy %u -> %u (max %u).\n",
+ "reg_insert",
+ dst - RExC_emit_start > RExC_offsets[0]
+ ? "Overwriting end of array!\n" : "OK",
+ src - RExC_emit_start,
+ dst - RExC_emit_start,
+ RExC_offsets[0]));
+ Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
+ Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
+ }
+ }
+
place = opnd; /* Op node, where operand used to be. */
+ if (RExC_offsets) { /* MJD */
+ MJD_OFFSET_DEBUG((stderr, "%s: %s %u <- %u (max %u).\n",
+ "reginsert",
+ place - RExC_emit_start > RExC_offsets[0]
+ ? "Overwriting end of array!\n" : "OK",
+ place - RExC_emit_start,
+ RExC_parse - RExC_start,
+ RExC_offsets[0]));
+ Set_Node_Offset(place, RExC_parse);
+ }
src = NEXTOPER(place);
FILL_ADVANCE_NODE(place, op);
Zero(src, offset, regnode);
***************
*** 4007,4016 ****
}
STATIC regnode *
S_dumpuntil(pTHX_ regnode *start, regnode *node, regnode *last, SV* sv, I32 l)
{
- #ifdef DEBUGGING
register U8 op = EXACT; /* Arbitrary non-END op. */
register regnode *next;
--- 4191,4201 ----
}
+ #ifdef DEBUGGING
+
STATIC regnode *
S_dumpuntil(pTHX_ regnode *start, regnode *node, regnode *last, SV* sv, I32 l)
{
register U8 op = EXACT; /* Arbitrary non-END op. */
register regnode *next;
***************
*** 4057,4064 ****
node = dumpuntil(start, NEXTOPER(node), NEXTOPER(node) + 1, sv, l + 1);
}
else if (op == ANYOF) {
node = NEXTOPER(node);
- node += ANYOF_SKIP;
}
else if (PL_regkind[(U8)op] == EXACT) {
/* Literal string, where present. */
--- 4242,4251 ----
node = dumpuntil(start, NEXTOPER(node), NEXTOPER(node) + 1, sv, l + 1);
}
else if (op == ANYOF) {
+ /* arglen 1 + class block */
+ node += 1 + ((ANYOF_FLAGS(node) & ANYOF_LARGE)
+ ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
node = NEXTOPER(node);
}
else if (PL_regkind[(U8)op] == EXACT) {
/* Literal string, where present. */
***************
*** 4074,4083 ****
else if (op == WHILEM)
l--;
}
- #endif /* DEBUGGING */
return node;
}
/*
- regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
*/
--- 4261,4271 ----
else if (op == WHILEM)
l--;
}
return node;
}
+ #endif /* DEBUGGING */
+
/*
- regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
*/
***************
*** 4145,4153 ****
--- 4333,4353 ----
if (r->reganch & ROPT_EVAL_SEEN)
PerlIO_printf(Perl_debug_log, "with eval ");
PerlIO_printf(Perl_debug_log, "\n");
+ if (r->offsets) {
+ U32 i;
+ U32 len = r->offsets[0];
+ PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)r->offsets[0]);
+ for (i = 1; i <= len; i++)
+ PerlIO_printf(Perl_debug_log, "%"UVuf"[%"UVuf"] ",
+ (UV)r->offsets[i*2-1],
+ (UV)r->offsets[i*2]);
+ PerlIO_printf(Perl_debug_log, "\n");
+ }
#endif /* DEBUGGING */
}
+ #ifdef DEBUGGING
+
STATIC void
S_put_byte(pTHX_ SV *sv, int c)
{
***************
*** 4159,4164 ****
--- 4359,4366 ----
Perl_sv_catpvf(aTHX_ sv, "%c", c);
}
+ #endif /* DEBUGGING */
+
/*
- regprop - printable representation of opcode
*/
***************
*** 4274,4280 ****
for (i = 0; i <= 256; i++) { /* just the first 256 */
U8 *e = uvchr_to_utf8(s, i);
! if (i < 256 && swash_fetch(sw, s)) {
if (rangestart == -1)
rangestart = i;
} else if (rangestart != -1) {
--- 4476,4482 ----
for (i = 0; i <= 256; i++) { /* just the first 256 */
U8 *e = uvchr_to_utf8(s, i);
! if (i < 256 && swash_fetch(sw, s, TRUE)) {
if (rangestart == -1)
rangestart = i;
} else if (rangestart != -1) {
***************
*** 4366,4371 ****
--- 4568,4575 ----
if (r->precomp)
Safefree(r->precomp);
+ if (r->offsets) /* 20010421 MJD */
+ Safefree(r->offsets);
if (RX_MATCH_COPIED(r))
Safefree(r->subbeg);
if (r->substrs) {
***************
*** 4382,4387 ****
--- 4586,4592 ----
SV** old_curpad;
while (--n >= 0) {
+ /* If you add a ->what type here, update the comment in regcomp.h */
switch (r->data->what[n]) {
case 's':
SvREFCNT_dec((SV*)r->data->data[n]);
***************
*** 4507,4513 ****
SAVEVPTR(PL_regendp); /* Ditto for endp. */
SAVEVPTR(PL_reglastparen); /* Similarly for lastparen. */
SAVEPPTR(PL_regtill); /* How far we are required to go. */
- SAVEI8(PL_regprev); /* char before regbol, \n if none */
SAVEGENERICPV(PL_reg_start_tmp); /* from regexec.c */
PL_reg_start_tmp = 0;
SAVEI32(PL_reg_start_tmpl); /* from regexec.c */
--- 4712,4717 ----
***************
*** 4528,4533 ****
--- 4732,4738 ----
SAVEVPTR(PL_reg_oldcurpm); /* from regexec.c */
SAVEVPTR(PL_reg_curpm); /* from regexec.c */
SAVEI32(PL_regnpar); /* () count. */
+ SAVEI32(PL_regsize); /* from regexec.c */
#ifdef DEBUGGING
SAVEPPTR(PL_reg_starttry); /* from regexec.c */
#endif
diff -c 'perl-5.7.1/regcomp.h' 'perl-5.7.2/regcomp.h'
Index: ./regcomp.h
*** ./regcomp.h Sat Mar 10 23:14:40 2001
--- ./regcomp.h Thu Jul 12 21:45:38 2001
***************
*** 95,110 ****
U8 type;
U16 next_off;
U32 arg1;
! char bitmap[ANYOF_BITMAP_SIZE];
};
! struct regnode_charclass_class {
! U8 flags;
U8 type;
U16 next_off;
U32 arg1;
! char bitmap[ANYOF_BITMAP_SIZE];
! char classflags[ANYOF_CLASSBITMAP_SIZE];
};
/* XXX fix this description.
--- 95,110 ----
U8 type;
U16 next_off;
U32 arg1;
! char bitmap[ANYOF_BITMAP_SIZE]; /* only compile-time */
};
! struct regnode_charclass_class { /* has [[:blah:]] classes */
! U8 flags; /* should have ANYOF_CLASS here */
U8 type;
U16 next_off;
U32 arg1;
! char bitmap[ANYOF_BITMAP_SIZE]; /* both compile-time */
! char classflags[ANYOF_CLASSBITMAP_SIZE]; /* and run-time */
};
/* XXX fix this description.
***************
*** 132,137 ****
--- 132,141 ----
#define ARG_VALUE(arg) (arg)
#define ARG__SET(arg,val) ((arg) = (val))
+ #undef ARG
+ #undef ARG1
+ #undef ARG2
+
#define ARG(p) ARG_VALUE(ARG_LOC(p))
#define ARG1(p) ARG_VALUE(ARG1_LOC(p))
#define ARG2(p) ARG_VALUE(ARG2_LOC(p))
***************
*** 139,144 ****
--- 143,151 ----
#define ARG1_SET(p, val) ARG__SET(ARG1_LOC(p), (val))
#define ARG2_SET(p, val) ARG__SET(ARG2_LOC(p), (val))
+ #undef NEXT_OFF
+ #undef NODE_ALIGN
+
#ifndef lint
# define NEXT_OFF(p) ((p)->next_off)
# define NODE_ALIGN(node)
***************
*** 151,156 ****
--- 158,168 ----
#define SIZE_ALIGN NODE_ALIGN
+ #undef OP
+ #undef OPERAND
+ #undef MASK
+ #undef STRING
+
#define OP(p) ((p)->type)
#define OPERAND(p) (((struct regnode_string *)p)->string)
#define MASK(p) ((char*)OPERAND(p))
***************
*** 159,164 ****
--- 171,181 ----
#define STR_SZ(l) ((l + sizeof(regnode) - 1) / sizeof(regnode))
#define NODE_SZ_STR(p) (STR_SZ(STR_LEN(p))+1)
+ #undef NODE_ALIGN
+ #undef ARG_LOC
+ #undef NEXTOPER
+ #undef PREVOPER
+
#define NODE_ALIGN(node)
#define ARG_LOC(p) (((struct regnode_1 *)p)->arg1)
#define ARG1_LOC(p) (((struct regnode_2 *)p)->arg1)
***************
*** 182,188 ****
/* Flags for node->flags of ANYOF */
! #define ANYOF_CLASS 0x08
#define ANYOF_INVERT 0x04
#define ANYOF_FOLD 0x02
#define ANYOF_LOCALE 0x01
--- 199,205 ----
/* Flags for node->flags of ANYOF */
! #define ANYOF_CLASS 0x08 /* has [[:blah:]] classes */
#define ANYOF_INVERT 0x04
#define ANYOF_FOLD 0x02
#define ANYOF_LOCALE 0x01
***************
*** 194,199 ****
--- 211,219 ----
#define ANYOF_UNICODE 0x20
#define ANYOF_UNICODE_ALL 0x40 /* Can match any char past 0xff */
+ /* size of node is large (includes class pointer) */
+ #define ANYOF_LARGE 0x80
+
/* Are there any runtime flags on in this node? */
#define ANYOF_RUNTIME(s) (ANYOF_FLAGS(s) & 0x0f)
***************
*** 330,335 ****
--- 350,364 ----
I32 *scream_pos; /* Internal iterator of scream. */
} re_scream_pos_data;
+ /* .what is a character array with one character for each member of .data
+ * The character describes the function of the corresponding .data item:
+ * f - start-class data for regstclass optimization
+ * n - Root of op tree for (?{EVAL}) item
+ * o - Start op for (?{EVAL}) item
+ * p - Pad for (?{EVAL} item
+ * s - swash for unicode-style character class
+ * 20010712 mjd@plover.com
+ */
struct reg_data {
U32 count;
U8 *what;
diff -c 'perl-5.7.1/regexec.c' 'perl-5.7.2/regexec.c'
Index: ./regexec.c
*** ./regexec.c Sat Mar 31 08:26:26 2001
--- ./regexec.c Thu Jul 12 16:35:11 2001
***************
*** 116,121 ****
--- 116,130 ----
#define HOPc(pos,off) ((char*)HOP(pos,off))
#define HOPMAYBEc(pos,off) ((char*)HOPMAYBE(pos,off))
+ #define HOPBACK(pos, off) ( \
+ (UTF && DO_UTF8(PL_reg_sv)) \
+ ? reghopmaybe((U8*)pos, -off) \
+ : (pos - off >= PL_bostr) \
+ ? (U8*)(pos - off) \
+ : (U8*)NULL \
+ )
+ #define HOPBACKc(pos, off) (char*)HOPBACK(pos, off)
+
#define reghop3_c(pos,off,lim) ((char*)reghop3((U8*)pos, off, (U8*)lim))
#define reghopmaybe3_c(pos,off,lim) ((char*)reghopmaybe3((U8*)pos, off, (U8*)lim))
#define HOP3(pos,off,lim) (DO_UTF8(PL_reg_sv) ? reghop3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off))
***************
*** 135,141 ****
int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
int p;
! #define REGCP_OTHER_ELEMS 5
SSCHECK(paren_elems_to_push + REGCP_OTHER_ELEMS);
for (p = PL_regsize; p > parenfloor; p--) {
/* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
--- 144,153 ----
int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
int p;
! if (paren_elems_to_push < 0)
! Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
!
! #define REGCP_OTHER_ELEMS 6
SSCHECK(paren_elems_to_push + REGCP_OTHER_ELEMS);
for (p = PL_regsize; p > parenfloor; p--) {
/* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
***************
*** 147,152 ****
--- 159,165 ----
/* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
SSPUSHINT(PL_regsize);
SSPUSHINT(*PL_reglastparen);
+ SSPUSHINT(*PL_reglastcloseparen);
SSPUSHPTR(PL_reginput);
#define REGCP_FRAME_ELEMS 2
/* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
***************
*** 180,185 ****
--- 193,199 ----
assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
i = SSPOPINT; /* Parentheses elements to pop. */
input = (char *) SSPOPPTR;
+ *PL_reglastcloseparen = SSPOPINT;
*PL_reglastparen = SSPOPINT;
PL_regsize = SSPOPINT;
***************
*** 348,364 ****
Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
char *strend, U32 flags, re_scream_pos_data *data)
{
! register I32 start_shift;
/* Should be nonnegative! */
! register I32 end_shift;
register char *s;
register SV *check;
char *strbeg;
char *t;
I32 ml_anch;
- char *tmp;
register char *other_last = Nullch; /* other substr checked before this */
! char *check_at; /* check substr found at this pos */
#ifdef DEBUGGING
char *i_strpos = strpos;
#endif
--- 362,377 ----
Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
char *strend, U32 flags, re_scream_pos_data *data)
{
! register I32 start_shift = 0;
/* Should be nonnegative! */
! register I32 end_shift = 0;
register char *s;
register SV *check;
char *strbeg;
char *t;
I32 ml_anch;
register char *other_last = Nullch; /* other substr checked before this */
! char *check_at = Nullch; /* check substr found at this pos */
#ifdef DEBUGGING
char *i_strpos = strpos;
#endif
***************
*** 392,398 ****
&& !PL_multiline ) ); /* Check after \n? */
if (!ml_anch) {
! if ( !(prog->reganch & ROPT_ANCH_GPOS) /* Checked by the caller */
/* SvCUR is not set on references: SvRV and SvPVX overlap */
&& sv && !SvROK(sv)
&& (strpos != strbeg)) {
--- 405,412 ----
&& !PL_multiline ) ); /* Check after \n? */
if (!ml_anch) {
! if ( !(prog->reganch & (ROPT_ANCH_GPOS /* Checked by the caller */
! | ROPT_IMPLICIT)) /* not a real BOL */
/* SvCUR is not set on references: SvRV and SvPVX overlap */
&& sv && !SvROK(sv)
&& (strpos != strbeg)) {
***************
*** 765,771 ****
s = find_byclass(prog, prog->regstclass, s, endpos, startpos, 1);
if (!s) {
#ifdef DEBUGGING
! char *what;
#endif
if (endpos == strend) {
DEBUG_r( PerlIO_printf(Perl_debug_log,
--- 779,785 ----
s = find_byclass(prog, prog->regstclass, s, endpos, startpos, 1);
if (!s) {
#ifdef DEBUGGING
! char *what = 0;
#endif
if (endpos == strend) {
DEBUG_r( PerlIO_printf(Perl_debug_log,
***************
*** 826,838 ****
DEBUG_r( what = "floating" );
goto hop_and_restart;
}
! DEBUG_r( if (t != s)
! PerlIO_printf(Perl_debug_log,
"By STCLASS: moving %ld --> %ld\n",
! (long)(t - i_strpos), (long)(s - i_strpos));
! else
! PerlIO_printf(Perl_debug_log,
! "Does not contradict STCLASS...\n") );
}
giveup:
DEBUG_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
--- 840,856 ----
DEBUG_r( what = "floating" );
goto hop_and_restart;
}
! if (t != s) {
! DEBUG_r(PerlIO_printf(Perl_debug_log,
"By STCLASS: moving %ld --> %ld\n",
! (long)(t - i_strpos), (long)(s - i_strpos))
! );
! }
! else {
! DEBUG_r(PerlIO_printf(Perl_debug_log,
! "Does not contradict STCLASS...\n");
! );
! }
}
giveup:
DEBUG_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
***************
*** 945,956 ****
/* FALL THROUGH */
case BOUND:
if (do_utf8) {
! if (s == startpos)
tmp = '\n';
else {
U8 *r = reghop3((U8*)s, -1, (U8*)startpos);
! tmp = (I32)utf8n_to_uvchr(r, s - (char*)r, 0, 0);
}
tmp = ((OP(c) == BOUND ?
isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
--- 963,975 ----
/* FALL THROUGH */
case BOUND:
if (do_utf8) {
! if (s == PL_bostr)
tmp = '\n';
else {
U8 *r = reghop3((U8*)s, -1, (U8*)startpos);
! if (s > (char*)r)
! tmp = (I32)utf8n_to_uvchr(r, s - (char*)r, 0, 0);
}
tmp = ((OP(c) == BOUND ?
isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
***************
*** 957,963 ****
LOAD_UTF8_CHARCLASS(alnum,"a");
while (s < strend) {
if (tmp == !(OP(c) == BOUND ?
! swash_fetch(PL_utf8_alnum, (U8*)s) :
isALNUM_LC_utf8((U8*)s)))
{
tmp = !tmp;
--- 976,982 ----
LOAD_UTF8_CHARCLASS(alnum,"a");
while (s < strend) {
if (tmp == !(OP(c) == BOUND ?
! swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
isALNUM_LC_utf8((U8*)s)))
{
tmp = !tmp;
***************
*** 968,974 ****
}
}
else {
! tmp = (s != startpos) ? UCHARAT(s - 1) : '\n';
tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
while (s < strend) {
if (tmp ==
--- 987,993 ----
}
}
else {
! tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
while (s < strend) {
if (tmp ==
***************
*** 988,999 ****
/* FALL THROUGH */
case NBOUND:
if (do_utf8) {
! if (s == startpos)
tmp = '\n';
else {
U8 *r = reghop3((U8*)s, -1, (U8*)startpos);
! tmp = (I32)utf8n_to_uvchr(r, s - (char*)r, 0, 0);
}
tmp = ((OP(c) == NBOUND ?
isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
--- 1007,1019 ----
/* FALL THROUGH */
case NBOUND:
if (do_utf8) {
! if (s == PL_bostr)
tmp = '\n';
else {
U8 *r = reghop3((U8*)s, -1, (U8*)startpos);
! if (s > (char*)r)
! tmp = (I32)utf8n_to_uvchr(r, s - (char*)r, 0, 0);
}
tmp = ((OP(c) == NBOUND ?
isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
***************
*** 1000,1006 ****
LOAD_UTF8_CHARCLASS(alnum,"a");
while (s < strend) {
if (tmp == !(OP(c) == NBOUND ?
! swash_fetch(PL_utf8_alnum, (U8*)s) :
isALNUM_LC_utf8((U8*)s)))
tmp = !tmp;
else if ((norun || regtry(prog, s)))
--- 1020,1026 ----
LOAD_UTF8_CHARCLASS(alnum,"a");
while (s < strend) {
if (tmp == !(OP(c) == NBOUND ?
! swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
isALNUM_LC_utf8((U8*)s)))
tmp = !tmp;
else if ((norun || regtry(prog, s)))
***************
*** 1009,1015 ****
}
}
else {
! tmp = (s != startpos) ? UCHARAT(s - 1) : '\n';
tmp = ((OP(c) == NBOUND ?
isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
while (s < strend) {
--- 1029,1035 ----
}
}
else {
! tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
tmp = ((OP(c) == NBOUND ?
isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
while (s < strend) {
***************
*** 1028,1034 ****
if (do_utf8) {
LOAD_UTF8_CHARCLASS(alnum,"a");
while (s < strend) {
! if (swash_fetch(PL_utf8_alnum, (U8*)s)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
else
--- 1048,1054 ----
if (do_utf8) {
LOAD_UTF8_CHARCLASS(alnum,"a");
while (s < strend) {
! if (swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
else
***************
*** 1086,1092 ****
if (do_utf8) {
LOAD_UTF8_CHARCLASS(alnum,"a");
while (s < strend) {
! if (!swash_fetch(PL_utf8_alnum, (U8*)s)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
else
--- 1106,1112 ----
if (do_utf8) {
LOAD_UTF8_CHARCLASS(alnum,"a");
while (s < strend) {
! if (!swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
else
***************
*** 1144,1150 ****
if (do_utf8) {
LOAD_UTF8_CHARCLASS(space," ");
while (s < strend) {
! if (*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
else
--- 1164,1170 ----
if (do_utf8) {
LOAD_UTF8_CHARCLASS(space," ");
while (s < strend) {
! if (*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
else
***************
*** 1202,1208 ****
if (do_utf8) {
LOAD_UTF8_CHARCLASS(space," ");
while (s < strend) {
! if (!(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s))) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
else
--- 1222,1228 ----
if (do_utf8) {
LOAD_UTF8_CHARCLASS(space," ");
while (s < strend) {
! if (!(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8))) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
else
***************
*** 1260,1266 ****
if (do_utf8) {
LOAD_UTF8_CHARCLASS(digit,"0");
while (s < strend) {
! if (swash_fetch(PL_utf8_digit,(U8*)s)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
else
--- 1280,1286 ----
if (do_utf8) {
LOAD_UTF8_CHARCLASS(digit,"0");
while (s < strend) {
! if (swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
else
***************
*** 1318,1324 ****
if (do_utf8) {
LOAD_UTF8_CHARCLASS(digit,"0");
while (s < strend) {
! if (!swash_fetch(PL_utf8_digit,(U8*)s)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
else
--- 1338,1344 ----
if (do_utf8) {
LOAD_UTF8_CHARCLASS(digit,"0");
while (s < strend) {
! if (!swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
else
***************
*** 1428,1446 ****
if (strend - startpos < minlen) goto phooey;
}
- if (startpos == strbeg) /* is ^ valid at stringarg? */
- PL_regprev = '\n';
- else {
- if (prog->reganch & ROPT_UTF8 && do_utf8) {
- U8 *s = reghop3((U8*)stringarg, -1, (U8*)strbeg);
- PL_regprev = utf8n_to_uvchr(s, (U8*)stringarg - s, NULL, 0);
- }
- else
- PL_regprev = (U32)stringarg[-1];
- if (!PL_multiline && PL_regprev == '\n')
- PL_regprev = '\0'; /* force ^ to NOT match */
- }
-
/* Check validity of program. */
if (UCHARAT(prog->program) != REG_MAGIC) {
Perl_croak(aTHX_ "corrupted regexp program");
--- 1448,1453 ----
***************
*** 1477,1483 ****
PL_reg_ganch = startpos;
else if (sv && SvTYPE(sv) >= SVt_PVMG
&& SvMAGIC(sv)
! && (mg = mg_find(sv, 'g')) && mg->mg_len >= 0) {
PL_reg_ganch = strbeg + mg->mg_len; /* Defined pos() */
if (prog->reganch & ROPT_ANCH_GPOS) {
if (s > PL_reg_ganch)
--- 1484,1491 ----
PL_reg_ganch = startpos;
else if (sv && SvTYPE(sv) >= SVt_PVMG
&& SvMAGIC(sv)
! && (mg = mg_find(sv, PERL_MAGIC_regex_global))
! && mg->mg_len >= 0) {
PL_reg_ganch = strbeg + mg->mg_len; /* Defined pos() */
if (prog->reganch & ROPT_ANCH_GPOS) {
if (s > PL_reg_ganch)
***************
*** 1595,1603 ****
s++;
}
}
! DEBUG_r(did_match ||
PerlIO_printf(Perl_debug_log,
! "Did not find anchored character...\n"));
}
/*SUPPRESS 560*/
else if (do_utf8 == (UTF!=0) &&
--- 1603,1612 ----
s++;
}
}
! DEBUG_r(if (!did_match)
PerlIO_printf(Perl_debug_log,
! "Did not find anchored character...\n")
! );
}
/*SUPPRESS 560*/
else if (do_utf8 == (UTF!=0) &&
***************
*** 1661,1674 ****
}
}
}
! DEBUG_r(did_match ||
! PerlIO_printf(Perl_debug_log, "Did not find %s substr `%s%.*s%s'%s...\n",
((must == prog->anchored_substr)
? "anchored" : "floating"),
PL_colors[0],
(int)(SvCUR(must) - (SvTAIL(must)!=0)),
SvPVX(must),
! PL_colors[1], (SvTAIL(must) ? "$" : "")));
goto phooey;
}
else if ((c = prog->regstclass)) {
--- 1670,1685 ----
}
}
}
! DEBUG_r(if (!did_match)
! PerlIO_printf(Perl_debug_log,
! "Did not find %s substr `%s%.*s%s'%s...\n",
((must == prog->anchored_substr)
? "anchored" : "floating"),
PL_colors[0],
(int)(SvCUR(must) - (SvTAIL(must)!=0)),
SvPVX(must),
! PL_colors[1], (SvTAIL(must) ? "$" : ""))
! );
goto phooey;
}
else if ((c = prog->regstclass)) {
***************
*** 1828,1837 ****
}
if (!(SvTYPE(PL_reg_sv) >= SVt_PVMG && SvMAGIC(PL_reg_sv)
! && (mg = mg_find(PL_reg_sv, 'g')))) {
/* prepare for quick setting of pos */
! sv_magic(PL_reg_sv, (SV*)0, 'g', Nullch, 0);
! mg = mg_find(PL_reg_sv, 'g');
mg->mg_len = -1;
}
PL_reg_magic = mg;
--- 1839,1849 ----
}
if (!(SvTYPE(PL_reg_sv) >= SVt_PVMG && SvMAGIC(PL_reg_sv)
! && (mg = mg_find(PL_reg_sv, PERL_MAGIC_regex_global)))) {
/* prepare for quick setting of pos */
! sv_magic(PL_reg_sv, (SV*)0,
! PERL_MAGIC_regex_global, Nullch, 0);
! mg = mg_find(PL_reg_sv, PERL_MAGIC_regex_global);
mg->mg_len = -1;
}
PL_reg_magic = mg;
***************
*** 1838,1846 ****
PL_reg_oldpos = mg->mg_len;
SAVEDESTRUCTOR_X(restore_pos, 0);
}
! if (!PL_reg_curpm)
Newz(22,PL_reg_curpm, 1, PMOP);
! PL_reg_curpm->op_pmregexp = prog;
PL_reg_oldcurpm = PL_curpm;
PL_curpm = PL_reg_curpm;
if (RX_MATCH_COPIED(prog)) {
--- 1850,1867 ----
PL_reg_oldpos = mg->mg_len;
SAVEDESTRUCTOR_X(restore_pos, 0);
}
! if (!PL_reg_curpm) {
Newz(22,PL_reg_curpm, 1, PMOP);
! #ifdef USE_ITHREADS
! {
! SV* repointer = newSViv(0);
! av_push(PL_regex_padav,repointer);
! PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
! PL_regex_pad = AvARRAY(PL_regex_padav);
! }
! #endif
! }
! PM_SETRE(PL_reg_curpm, prog);
PL_reg_oldcurpm = PL_curpm;
PL_curpm = PL_reg_curpm;
if (RX_MATCH_COPIED(prog)) {
***************
*** 1861,1866 ****
--- 1882,1888 ----
PL_regstartp = prog->startp;
PL_regendp = prog->endp;
PL_reglastparen = &prog->lastparen;
+ PL_reglastcloseparen = &prog->lastcloseparen;
prog->lastparen = 0;
PL_regsize = 0;
DEBUG_r(PL_reg_starttry = startpos);
***************
*** 1958,1970 ****
register I32 nextchr; /* renamed nextchr - nextchar colides with
function of same name */
register I32 n; /* no or next */
! register I32 ln; /* len or last */
! register char *s; /* operand or save */
register char *locinput = PL_reginput;
! register I32 c1, c2, paren; /* case fold search, parenth */
int minmod = 0, sw = 0, logical = 0;
I32 unwind = 0;
I32 firstcp = PL_savestack_ix;
register bool do_utf8 = DO_UTF8(PL_reg_sv);
#ifdef DEBUGGING
--- 1980,1994 ----
register I32 nextchr; /* renamed nextchr - nextchar colides with
function of same name */
register I32 n; /* no or next */
! register I32 ln = 0; /* len or last */
! register char *s = Nullch; /* operand or save */
register char *locinput = PL_reginput;
! register I32 c1 = 0, c2 = 0, paren; /* case fold search, parenth */
int minmod = 0, sw = 0, logical = 0;
I32 unwind = 0;
+ #if 0
I32 firstcp = PL_savestack_ix;
+ #endif
register bool do_utf8 = DO_UTF8(PL_reg_sv);
#ifdef DEBUGGING
***************
*** 2043,2052 ****
switch (OP(scan)) {
case BOL:
! if (locinput == PL_bostr
! ? PL_regprev == '\n'
! : (PL_multiline &&
! (nextchr || locinput < PL_regeol) && locinput[-1] == '\n') )
{
/* regtill = regbol; */
break;
--- 2067,2074 ----
switch (OP(scan)) {
case BOL:
! if (locinput == PL_bostr || (PL_multiline &&
! (nextchr || locinput < PL_regeol) && locinput[-1] == '\n') )
{
/* regtill = regbol; */
break;
***************
*** 2053,2061 ****
}
sayNO;
case MBOL:
! if (locinput == PL_bostr
! ? PL_regprev == '\n'
! : ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n') )
{
break;
}
--- 2075,2082 ----
}
sayNO;
case MBOL:
! if (locinput == PL_bostr ||
! ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
{
break;
}
***************
*** 2212,2219 ****
if (!nextchr)
sayNO;
if (do_utf8) {
if (!(OP(scan) == ALNUM
! ? swash_fetch(PL_utf8_alnum, (U8*)locinput)
: isALNUM_LC_utf8((U8*)locinput)))
{
sayNO;
--- 2233,2241 ----
if (!nextchr)
sayNO;
if (do_utf8) {
+ LOAD_UTF8_CHARCLASS(alnum,"a");
if (!(OP(scan) == ALNUM
! ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
: isALNUM_LC_utf8((U8*)locinput)))
{
sayNO;
***************
*** 2236,2242 ****
if (do_utf8) {
LOAD_UTF8_CHARCLASS(alnum,"a");
if (OP(scan) == NALNUM
! ? swash_fetch(PL_utf8_alnum, (U8*)locinput)
: isALNUM_LC_utf8((U8*)locinput))
{
sayNO;
--- 2258,2264 ----
if (do_utf8) {
LOAD_UTF8_CHARCLASS(alnum,"a");
if (OP(scan) == NALNUM
! ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
: isALNUM_LC_utf8((U8*)locinput))
{
sayNO;
***************
*** 2258,2265 ****
case NBOUND:
/* was last char in word? */
if (do_utf8) {
! if (locinput == PL_regbol)
! ln = PL_regprev;
else {
U8 *r = reghop((U8*)locinput, -1);
--- 2280,2287 ----
case NBOUND:
/* was last char in word? */
if (do_utf8) {
! if (locinput == PL_bostr)
! ln = '\n';
else {
U8 *r = reghop((U8*)locinput, -1);
***************
*** 2268,2274 ****
if (OP(scan) == BOUND || OP(scan) == NBOUND) {
ln = isALNUM_uni(ln);
LOAD_UTF8_CHARCLASS(alnum,"a");
! n = swash_fetch(PL_utf8_alnum, (U8*)locinput);
}
else {
ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
--- 2290,2296 ----
if (OP(scan) == BOUND || OP(scan) == NBOUND) {
ln = isALNUM_uni(ln);
LOAD_UTF8_CHARCLASS(alnum,"a");
! n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
}
else {
ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
***************
*** 2276,2283 ****
}
}
else {
! ln = (locinput != PL_regbol) ?
! UCHARAT(locinput - 1) : PL_regprev;
if (OP(scan) == BOUND || OP(scan) == NBOUND) {
ln = isALNUM(ln);
n = isALNUM(nextchr);
--- 2298,2305 ----
}
}
else {
! ln = (locinput != PL_bostr) ?
! UCHARAT(locinput - 1) : '\n';
if (OP(scan) == BOUND || OP(scan) == NBOUND) {
ln = isALNUM(ln);
n = isALNUM(nextchr);
***************
*** 2301,2307 ****
if (UTF8_IS_CONTINUED(nextchr)) {
LOAD_UTF8_CHARCLASS(space," ");
if (!(OP(scan) == SPACE
! ? swash_fetch(PL_utf8_space, (U8*)locinput)
: isSPACE_LC_utf8((U8*)locinput)))
{
sayNO;
--- 2323,2329 ----
if (UTF8_IS_CONTINUED(nextchr)) {
LOAD_UTF8_CHARCLASS(space," ");
if (!(OP(scan) == SPACE
! ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
: isSPACE_LC_utf8((U8*)locinput)))
{
sayNO;
***************
*** 2331,2337 ****
if (do_utf8) {
LOAD_UTF8_CHARCLASS(space," ");
if (OP(scan) == NSPACE
! ? swash_fetch(PL_utf8_space, (U8*)locinput)
: isSPACE_LC_utf8((U8*)locinput))
{
sayNO;
--- 2353,2359 ----
if (do_utf8) {
LOAD_UTF8_CHARCLASS(space," ");
if (OP(scan) == NSPACE
! ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
: isSPACE_LC_utf8((U8*)locinput))
{
sayNO;
***************
*** 2354,2360 ****
if (do_utf8) {
LOAD_UTF8_CHARCLASS(digit,"0");
if (!(OP(scan) == DIGIT
! ? swash_fetch(PL_utf8_digit, (U8*)locinput)
: isDIGIT_LC_utf8((U8*)locinput)))
{
sayNO;
--- 2376,2382 ----
if (do_utf8) {
LOAD_UTF8_CHARCLASS(digit,"0");
if (!(OP(scan) == DIGIT
! ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
: isDIGIT_LC_utf8((U8*)locinput)))
{
sayNO;
***************
*** 2377,2383 ****
if (do_utf8) {
LOAD_UTF8_CHARCLASS(digit,"0");
if (OP(scan) == NDIGIT
! ? swash_fetch(PL_utf8_digit, (U8*)locinput)
: isDIGIT_LC_utf8((U8*)locinput))
{
sayNO;
--- 2399,2405 ----
if (do_utf8) {
LOAD_UTF8_CHARCLASS(digit,"0");
if (OP(scan) == NDIGIT
! ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
: isDIGIT_LC_utf8((U8*)locinput))
{
sayNO;
***************
*** 2393,2402 ****
break;
case CLUMP:
LOAD_UTF8_CHARCLASS(mark,"~");
! if (locinput >= PL_regeol || swash_fetch(PL_utf8_mark,(U8*)locinput))
sayNO;
locinput += PL_utf8skip[nextchr];
! while (locinput < PL_regeol && swash_fetch(PL_utf8_mark,(U8*)locinput))
locinput += UTF8SKIP(locinput);
if (locinput > PL_regeol)
sayNO;
--- 2415,2426 ----
break;
case CLUMP:
LOAD_UTF8_CHARCLASS(mark,"~");
! if (locinput >= PL_regeol ||
! swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
sayNO;
locinput += PL_utf8skip[nextchr];
! while (locinput < PL_regeol &&
! swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
locinput += UTF8SKIP(locinput);
if (locinput > PL_regeol)
sayNO;
***************
*** 2506,2512 ****
SV *sv = SvROK(ret) ? SvRV(ret) : ret;
if(SvMAGICAL(sv))
! mg = mg_find(sv, 'r');
}
if (mg) {
re = (regexp *)mg->mg_obj;
--- 2530,2536 ----
SV *sv = SvROK(ret) ? SvRV(ret) : ret;
if(SvMAGICAL(sv))
! mg = mg_find(sv, PERL_MAGIC_qr);
}
if (mg) {
re = (regexp *)mg->mg_obj;
***************
*** 2524,2530 ****
re = CALLREGCOMP(aTHX_ t, t + len, &pm);
if (!(SvFLAGS(ret)
& (SVs_TEMP | SVs_PADTMP | SVf_READONLY)))
! sv_magic(ret,(SV*)ReREFCNT_inc(re),'r',0,0);
PL_regprecomp = oprecomp;
PL_regsize = osize;
PL_regnpar = onpar;
--- 2548,2555 ----
re = CALLREGCOMP(aTHX_ t, t + len, &pm);
if (!(SvFLAGS(ret)
& (SVs_TEMP | SVs_PADTMP | SVf_READONLY)))
! sv_magic(ret,(SV*)ReREFCNT_inc(re),
! PERL_MAGIC_qr,0,0);
PL_regprecomp = oprecomp;
PL_regsize = osize;
PL_regnpar = onpar;
***************
*** 2549,2554 ****
--- 2574,2580 ----
cache_re(re);
state.ss = PL_savestack_ix;
*PL_reglastparen = 0;
+ *PL_reglastcloseparen = 0;
PL_reg_call_cc = &state;
PL_reginput = locinput;
***************
*** 2606,2611 ****
--- 2632,2638 ----
PL_regendp[n] = locinput - PL_bostr;
if (n > *PL_reglastparen)
*PL_reglastparen = n;
+ *PL_reglastcloseparen = n;
break;
case GROUPP:
n = ARG(scan); /* which paren pair */
***************
*** 2932,2938 ****
inner = NEXTOPER(scan);
do_branch:
{
- CHECKPOINT lastcp;
c1 = OP(scan);
if (OP(next) != c1) /* No choice. */
next = inner; /* Avoid recursion. */
--- 2959,2964 ----
***************
*** 3283,3289 ****
}
REGCP_SET(lastcp);
if (paren) {
! UV c;
while (n >= ln) {
if (c1 != -1000) {
if (do_utf8)
--- 3309,3315 ----
}
REGCP_SET(lastcp);
if (paren) {
! UV c = 0;
while (n >= ln) {
if (c1 != -1000) {
if (do_utf8)
***************
*** 3303,3309 ****
}
}
else {
! UV c;
while (n >= ln) {
if (c1 != -1000) {
if (do_utf8)
--- 3329,3335 ----
}
}
else {
! UV c = 0;
while (n >= ln) {
if (c1 != -1000) {
if (do_utf8)
***************
*** 3381,3400 ****
case UNLESSM:
n = 0;
if (scan->flags) {
! if (UTF) { /* XXXX This is absolutely
! broken, we read before
! start of string. */
! s = HOPMAYBEc(locinput, -scan->flags);
! if (!s)
! goto say_yes;
! PL_reginput = s;
! }
! else {
! if (locinput < PL_bostr + scan->flags)
! goto say_yes;
! PL_reginput = locinput - scan->flags;
! goto do_ifmatch;
! }
}
else
PL_reginput = locinput;
--- 3407,3416 ----
case UNLESSM:
n = 0;
if (scan->flags) {
! s = HOPBACKc(locinput, scan->flags);
! if (!s)
! goto say_yes;
! PL_reginput = s;
}
else
PL_reginput = locinput;
***************
*** 3402,3421 ****
case IFMATCH:
n = 1;
if (scan->flags) {
! if (UTF) { /* XXXX This is absolutely
! broken, we read before
! start of string. */
! s = HOPMAYBEc(locinput, -scan->flags);
! if (!s || s < PL_bostr)
! goto say_no;
! PL_reginput = s;
! }
! else {
! if (locinput < PL_bostr + scan->flags)
! goto say_no;
! PL_reginput = locinput - scan->flags;
! goto do_ifmatch;
! }
}
else
PL_reginput = locinput;
--- 3418,3427 ----
case IFMATCH:
n = 1;
if (scan->flags) {
! s = HOPBACKc(locinput, scan->flags);
! if (!s)
! goto say_no;
! PL_reginput = s;
}
else
PL_reginput = locinput;
***************
*** 3622,3628 ****
loceol = PL_regeol;
LOAD_UTF8_CHARCLASS(alnum,"a");
while (hardcount < max && scan < loceol &&
! swash_fetch(PL_utf8_alnum, (U8*)scan)) {
scan += UTF8SKIP(scan);
hardcount++;
}
--- 3628,3634 ----
loceol = PL_regeol;
LOAD_UTF8_CHARCLASS(alnum,"a");
while (hardcount < max && scan < loceol &&
! swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
scan += UTF8SKIP(scan);
hardcount++;
}
***************
*** 3650,3656 ****
loceol = PL_regeol;
LOAD_UTF8_CHARCLASS(alnum,"a");
while (hardcount < max && scan < loceol &&
! !swash_fetch(PL_utf8_alnum, (U8*)scan)) {
scan += UTF8SKIP(scan);
hardcount++;
}
--- 3656,3662 ----
loceol = PL_regeol;
LOAD_UTF8_CHARCLASS(alnum,"a");
while (hardcount < max && scan < loceol &&
! !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
scan += UTF8SKIP(scan);
hardcount++;
}
***************
*** 3678,3684 ****
loceol = PL_regeol;
LOAD_UTF8_CHARCLASS(space," ");
while (hardcount < max && scan < loceol &&
! (*scan == ' ' || swash_fetch(PL_utf8_space,(U8*)scan))) {
scan += UTF8SKIP(scan);
hardcount++;
}
--- 3684,3691 ----
loceol = PL_regeol;
LOAD_UTF8_CHARCLASS(space," ");
while (hardcount < max && scan < loceol &&
! (*scan == ' ' ||
! swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
scan += UTF8SKIP(scan);
hardcount++;
}
***************
*** 3706,3712 ****
loceol = PL_regeol;
LOAD_UTF8_CHARCLASS(space," ");
while (hardcount < max && scan < loceol &&
! !(*scan == ' ' || swash_fetch(PL_utf8_space,(U8*)scan))) {
scan += UTF8SKIP(scan);
hardcount++;
}
--- 3713,3720 ----
loceol = PL_regeol;
LOAD_UTF8_CHARCLASS(space," ");
while (hardcount < max && scan < loceol &&
! !(*scan == ' ' ||
! swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
scan += UTF8SKIP(scan);
hardcount++;
}
***************
*** 3734,3740 ****
loceol = PL_regeol;
LOAD_UTF8_CHARCLASS(digit,"0");
while (hardcount < max && scan < loceol &&
! swash_fetch(PL_utf8_digit,(U8*)scan)) {
scan += UTF8SKIP(scan);
hardcount++;
}
--- 3742,3748 ----
loceol = PL_regeol;
LOAD_UTF8_CHARCLASS(digit,"0");
while (hardcount < max && scan < loceol &&
! swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
scan += UTF8SKIP(scan);
hardcount++;
}
***************
*** 3748,3754 ****
loceol = PL_regeol;
LOAD_UTF8_CHARCLASS(digit,"0");
while (hardcount < max && scan < loceol &&
! !swash_fetch(PL_utf8_digit,(U8*)scan)) {
scan += UTF8SKIP(scan);
hardcount++;
}
--- 3756,3762 ----
loceol = PL_regeol;
LOAD_UTF8_CHARCLASS(digit,"0");
while (hardcount < max && scan < loceol &&
! !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
scan += UTF8SKIP(scan);
hardcount++;
}
***************
*** 3789,3795 ****
STATIC I32
S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp)
{
! register char *scan;
register char *start;
register char *loceol = PL_regeol;
I32 l = 0;
--- 3797,3803 ----
STATIC I32
S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp)
{
! register char *scan = Nullch;
register char *start;
register char *loceol = PL_regeol;
I32 l = 0;
***************
*** 3878,3889 ****
char flags = ANYOF_FLAGS(n);
bool match = FALSE;
UV c;
! STRLEN len;
! if (do_utf8)
! c = utf8_to_uvchr(p, &len);
! else
! c = *p;
if (do_utf8 || (flags & ANYOF_UNICODE)) {
if (do_utf8 && !ANYOF_RUNTIME(n)) {
--- 3886,3894 ----
char flags = ANYOF_FLAGS(n);
bool match = FALSE;
UV c;
! STRLEN len = 0;
! c = do_utf8 ? utf8_to_uvchr(p, &len) : *p;
if (do_utf8 || (flags & ANYOF_UNICODE)) {
if (do_utf8 && !ANYOF_RUNTIME(n)) {
***************
*** 3890,3902 ****
if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
match = TRUE;
}
! if (do_utf8 && flags & ANYOF_UNICODE_ALL && c >= 256)
match = TRUE;
if (!match) {
SV *sw = regclass_swash(n, TRUE, 0);
if (sw) {
! if (swash_fetch(sw, p))
match = TRUE;
else if (flags & ANYOF_FOLD) {
U8 tmpbuf[UTF8_MAXLEN+1];
--- 3895,3907 ----
if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
match = TRUE;
}
! if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
match = TRUE;
if (!match) {
SV *sw = regclass_swash(n, TRUE, 0);
if (sw) {
! if (swash_fetch(sw, p, do_utf8))
match = TRUE;
else if (flags & ANYOF_FOLD) {
U8 tmpbuf[UTF8_MAXLEN+1];
***************
*** 3907,3913 ****
}
else
uvchr_to_utf8(tmpbuf, toLOWER_utf8(p));
! if (swash_fetch(sw, tmpbuf))
match = TRUE;
}
}
--- 3912,3918 ----
}
else
uvchr_to_utf8(tmpbuf, toLOWER_utf8(p));
! if (swash_fetch(sw, tmpbuf, do_utf8))
match = TRUE;
}
}
***************
*** 3917,3923 ****
if (ANYOF_BITMAP_TEST(n, c))
match = TRUE;
else if (flags & ANYOF_FOLD) {
! I32 f;
if (flags & ANYOF_LOCALE) {
PL_reg_flags |= RF_tainted;
--- 3922,3928 ----
if (ANYOF_BITMAP_TEST(n, c))
match = TRUE;
else if (flags & ANYOF_FOLD) {
! I32 f;
if (flags & ANYOF_LOCALE) {
PL_reg_flags |= RF_tainted;
diff -c 'perl-5.7.1/regexp.h' 'perl-5.7.2/regexp.h'
Index: ./regexp.h
*** ./regexp.h Sat Mar 10 23:14:46 2001
--- ./regexp.h Mon Jul 9 17:11:20 2001
***************
*** 30,35 ****
--- 30,36 ----
struct reg_data *data; /* Additional data. */
char *subbeg; /* saved or original string
so \digit works forever. */
+ U32 *offsets; /* offset annotations 20001228 MJD */
I32 sublen; /* Length of string pointed by subbeg */
I32 refcnt;
I32 minlen; /* mininum possible length of $& */
***************
*** 36,41 ****
--- 37,43 ----
I32 prelen; /* length of precomp */
U32 nparens; /* number of parentheses */
U32 lastparen; /* last paren matched */
+ U32 lastcloseparen; /* last paren matched */
U32 reganch; /* Internal use only +
Tainted information used by regexec? */
regnode program[1]; /* Unwarranted chumminess with compiler. */
diff -c 'perl-5.7.1/run.c' 'perl-5.7.2/run.c'
Index: ./run.c
*** ./run.c Tue Mar 20 16:24:25 2001
--- ./run.c Mon Jul 9 17:11:20 2001
***************
*** 63,70 ****
Perl_debop(pTHX_ OP *o)
{
#ifdef DEBUGGING
SV *sv;
- SV **svp;
STRLEN n_a;
Perl_deb(aTHX_ "%s", PL_op_name[o->op_type]);
switch (o->op_type) {
--- 63,71 ----
Perl_debop(pTHX_ OP *o)
{
#ifdef DEBUGGING
+ AV *padlist, *comppad;
+ CV *cv;
SV *sv;
STRLEN n_a;
Perl_deb(aTHX_ "%s", PL_op_name[o->op_type]);
switch (o->op_type) {
***************
*** 86,97 ****
case OP_PADAV:
case OP_PADHV:
/* print the lexical's name */
! svp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
! if (svp)
! PerlIO_printf(Perl_debug_log, "(%s)", SvPV(*svp,n_a));
! else
PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
! break;
default:
break;
}
--- 87,104 ----
case OP_PADAV:
case OP_PADHV:
/* print the lexical's name */
! cv = deb_curcv(cxstack_ix);
! if (cv) {
! padlist = CvPADLIST(cv);
! comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
! sv = *av_fetch(comppad, o->op_targ, FALSE);
! } else
! sv = Nullsv;
! if (sv)
! PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen(sv));
! else
PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
! break;
default:
break;
}
***************
*** 100,105 ****
--- 107,132 ----
return 0;
}
+ #ifdef DEBUGGING
+
+ STATIC CV*
+ S_deb_curcv(pTHX_ I32 ix)
+ {
+ PERL_CONTEXT *cx = &cxstack[ix];
+ if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
+ return cx->blk_sub.cv;
+ else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
+ return PL_compcv;
+ else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
+ return PL_main_cv;
+ else if (ix <= 0)
+ return Nullcv;
+ else
+ return deb_curcv(ix - 1);
+ }
+
+ #endif /* DEBUGGING */
+
void
Perl_watch(pTHX_ char **addr)
{
***************
*** 111,125 ****
#endif /* DEBUGGING */
}
STATIC void
S_debprof(pTHX_ OP *o)
{
- #ifdef DEBUGGING
if (!PL_profiledata)
Newz(000, PL_profiledata, MAXO, U32);
++PL_profiledata[o->op_type];
- #endif /* DEBUGGING */
}
void
Perl_debprofdump(pTHX)
--- 138,154 ----
#endif /* DEBUGGING */
}
+ #ifdef DEBUGGING
+
STATIC void
S_debprof(pTHX_ OP *o)
{
if (!PL_profiledata)
Newz(000, PL_profiledata, MAXO, U32);
++PL_profiledata[o->op_type];
}
+
+ #endif /* DEBUGGING */
void
Perl_debprofdump(pTHX)
diff -c 'perl-5.7.1/scope.c' 'perl-5.7.2/scope.c'
Index: ./scope.c
*** ./scope.c Fri Apr 6 16:20:27 2001
--- ./scope.c Mon Jul 9 17:11:21 2001
***************
*** 197,208 ****
MAGIC* mg;
bool oldtainted = PL_tainted;
mg_get(osv); /* note, can croak! */
! if (PL_tainting && PL_tainted && (mg = mg_find(osv, 't'))) {
SAVESPTR(mg->mg_obj);
mg->mg_obj = osv;
}
SvFLAGS(osv) |= (SvFLAGS(osv) &
! (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
PL_tainted = oldtainted;
}
SvMAGIC(sv) = SvMAGIC(osv);
--- 197,209 ----
MAGIC* mg;
bool oldtainted = PL_tainted;
mg_get(osv); /* note, can croak! */
! if (PL_tainting && PL_tainted &&
! (mg = mg_find(osv, PERL_MAGIC_taint))) {
SAVESPTR(mg->mg_obj);
mg->mg_obj = osv;
}
SvFLAGS(osv) |= (SvFLAGS(osv) &
! (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
PL_tainted = oldtainted;
}
SvMAGIC(sv) = SvMAGIC(osv);
***************
*** 698,704 ****
SvTYPE(value) != SVt_PVGV)
{
SvFLAGS(value) |= (SvFLAGS(value) &
! (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
SvMAGICAL_off(value);
/* XXX this is a leak when we get here because the
* mg_get() in save_scalar_at() croaked */
--- 699,705 ----
SvTYPE(value) != SVt_PVGV)
{
SvFLAGS(value) |= (SvFLAGS(value) &
! (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
SvMAGICAL_off(value);
/* XXX this is a leak when we get here because the
* mg_get() in save_scalar_at() croaked */
***************
*** 901,907 ****
if (ptr) {
sv = *(SV**)ptr;
if (sv && sv != &PL_sv_undef) {
! if (SvTIED_mg((SV*)av, 'P'))
(void)SvREFCNT_inc(sv);
SvREFCNT_dec(av);
goto restore_sv;
--- 902,908 ----
if (ptr) {
sv = *(SV**)ptr;
if (sv && sv != &PL_sv_undef) {
! if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
(void)SvREFCNT_inc(sv);
SvREFCNT_dec(av);
goto restore_sv;
***************
*** 919,925 ****
SV *oval = HeVAL((HE*)ptr);
if (oval && oval != &PL_sv_undef) {
ptr = &HeVAL((HE*)ptr);
! if (SvTIED_mg((SV*)hv, 'P'))
(void)SvREFCNT_inc(*(SV**)ptr);
SvREFCNT_dec(hv);
SvREFCNT_dec(sv);
--- 920,926 ----
SV *oval = HeVAL((HE*)ptr);
if (oval && oval != &PL_sv_undef) {
ptr = &HeVAL((HE*)ptr);
! if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
(void)SvREFCNT_inc(*(SV**)ptr);
SvREFCNT_dec(hv);
SvREFCNT_dec(sv);
diff -c 'perl-5.7.1/sv.c' 'perl-5.7.2/sv.c'
Index: ./sv.c
*** ./sv.c Mon Apr 9 17:14:29 2001
--- ./sv.c Fri Jul 13 07:39:05 2001
***************
*** 5,30 ****
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
- */
-
- /*
* "I wonder what the Entish is for 'yes' and 'no'," he thought.
*/
#include "EXTERN.h"
#define PERL_IN_SV_C
#include "perl.h"
#define FCALL *f
#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
- static void do_report_used(pTHXo_ SV *sv);
- static void do_clean_objs(pTHXo_ SV *sv);
- #ifndef DISABLE_DESTRUCTOR_KLUDGE
- static void do_clean_named_objs(pTHXo_ SV *sv);
- #endif
- static void do_clean_all(pTHXo_ SV *sv);
/*
* "A time to plant, and a time to uproot what was planted..."
*/
--- 5,137 ----
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
* "I wonder what the Entish is for 'yes' and 'no'," he thought.
+ *
+ *
+ * This file contains the code that creates, manipulates and destroys
+ * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
+ * structure of an SV, so their creation and destruction is handled
+ * here; higher-level functions are in av.c, hv.c, and so on. Opcode
+ * level functions (eg. substr, split, join) for each of the types are
+ * in the pp*.c files.
*/
#include "EXTERN.h"
#define PERL_IN_SV_C
#include "perl.h"
+ #include "regcomp.h"
#define FCALL *f
#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
+ /* ============================================================================
+
+ =head1 Allocation and deallocation of SVs.
+
+ An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
+ av, hv...) contains type and reference count information, as well as a
+ pointer to the body (struct xrv, xpv, xpviv...), which contains fields
+ specific to each type.
+
+ Normally, this allocation is done using arenas, which are approximately
+ 1K chunks of memory parcelled up into N heads or bodies. The first slot
+ in each arena is reserved, and is used to hold a link to the next arena.
+ In the case of heads, the unused first slot also contains some flags and
+ a note of the number of slots. Snaked through each arena chain is a
+ linked list of free items; when this becomes empty, an extra arena is
+ allocated and divided up into N items which are threaded into the free
+ list.
+
+ The following global variables are associated with arenas:
+
+ PL_sv_arenaroot pointer to list of SV arenas
+ PL_sv_root pointer to list of free SV structures
+
+ PL_foo_arenaroot pointer to list of foo arenas,
+ PL_foo_root pointer to list of free foo bodies
+ ... for foo in xiv, xnv, xrv, xpv etc.
+
+ Note that some of the larger and more rarely used body types (eg xpvio)
+ are not allocated using arenas, but are instead just malloc()/free()ed as
+ required. Also, if PURIFY is defined, arenas are abandoned altogether,
+ with all items individually malloc()ed. In addition, a few SV heads are
+ not allocated from an arena, but are instead directly created as static
+ or auto variables, eg PL_sv_undef.
+
+ The SV arena serves the secondary purpose of allowing still-live SVs
+ to be located and destroyed during final cleanup.
+
+ At the lowest level, the macros new_SV() and del_SV() grab and free
+ an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
+ to return the SV to the free list with error checking.) new_SV() calls
+ more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
+ SVs in the free list have their SvTYPE field set to all ones.
+
+ Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
+ that allocate and return individual body types. Normally these are mapped
+ to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
+ instead mapped directly to malloc()/free() if PURIFY is defined. The
+ new/del functions remove from, or add to, the appropriate PL_foo_root
+ list, and call more_xiv() etc to add a new arena if the list is empty.
+
+ At the time of very final cleanup, sv_free_arenas() is called from
+ perl_destruct() to physically free all the arenas allocated since the
+ start of the interpreter. Note that this also clears PL_he_arenaroot,
+ which is otherwise dealt with in hv.c.
+
+ Manipulation of any of the PL_*root pointers is protected by enclosing
+ LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
+ if threads are enabled.
+
+ The function visit() scans the SV arenas list, and calls a specified
+ function for each SV it finds which is still live - ie which has an SvTYPE
+ other than all 1's, and a non-zero SvREFCNT. visit() is used by the
+ following functions (specified as [function that calls visit()] / [function
+ called by visit() for each SV]):
+
+ sv_report_used() / do_report_used()
+ dump all remaining SVs (debugging aid)
+
+ sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
+ Attempt to free all objects pointed to by RVs,
+ and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
+ try to do the same for all objects indirectly
+ referenced by typeglobs too. Called once from
+ perl_destruct(), prior to calling sv_clean_all()
+ below.
+
+ sv_clean_all() / do_clean_all()
+ SvREFCNT_dec(sv) each remaining SV, possibly
+ triggering an sv_free(). It also sets the
+ SVf_BREAK flag on the SV to indicate that the
+ refcnt has been artificially lowered, and thus
+ stopping sv_free() from giving spurious warnings
+ about SVs which unexpectedly have a refcnt
+ of zero. called repeatedly from perl_destruct()
+ until there are no SVs left.
+
+ =head2 Summary
+
+ Private API to rest of sv.c
+
+ new_SV(), del_SV(),
+
+ new_XIV(), del_XIV(),
+ new_XNV(), del_XNV(),
+ etc
+
+ Public API:
+
+ sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
+
+
+ =cut
+
+ ============================================================================ */
+
+
+
/*
* "A time to plant, and a time to uproot what was planted..."
*/
***************
*** 45,50 ****
--- 152,160 ----
++PL_sv_count; \
} STMT_END
+
+ /* new_SV(): return a new, empty SV head */
+
#define new_SV(p) \
STMT_START { \
LOCK_SV_MUTEX; \
***************
*** 58,63 ****
--- 168,176 ----
SvFLAGS(p) = 0; \
} STMT_END
+
+ /* del_SV(): return an empty SV head to the free list */
+
#ifdef DEBUGGING
#define del_SV(p) \
***************
*** 101,106 ****
--- 214,229 ----
#endif /* DEBUGGING */
+
+ /*
+ =for apidoc sv_add_arena
+
+ Given a chunk of memory, link it to the head of the list of arenas,
+ and split it into a list of free SVs.
+
+ =cut
+ */
+
void
Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
{
***************
*** 128,133 ****
--- 251,258 ----
SvFLAGS(sv) = SVTYPEMASK;
}
+ /* make some more SVs by adding another arena */
+
/* sv_mutex must be held while calling more_sv() */
STATIC SV*
S_more_sv(pTHX)
***************
*** 137,142 ****
--- 262,268 ----
if (PL_nice_chunk) {
sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
PL_nice_chunk = Nullch;
+ PL_nice_chunk_size = 0;
}
else {
char *chunk; /* must use New here to match call to */
***************
*** 147,152 ****
--- 273,280 ----
return sv;
}
+ /* visit(): call the named function for each non-free SV in the arenas. */
+
STATIC I32
S_visit(pTHX_ SVFUNC_t f)
{
***************
*** 167,172 ****
--- 295,319 ----
return visited;
}
+ /* called by sv_report_used() for each live SV */
+
+ static void
+ do_report_used(pTHXo_ SV *sv)
+ {
+ if (SvTYPE(sv) != SVTYPEMASK) {
+ PerlIO_printf(Perl_debug_log, "****\n");
+ sv_dump(sv);
+ }
+ }
+
+ /*
+ =for apidoc sv_report_used
+
+ Dump the contents of all SVs not yet freed. (Debugging aid).
+
+ =cut
+ */
+
void
Perl_sv_report_used(pTHX)
{
***************
*** 173,178 ****
--- 320,376 ----
visit(do_report_used);
}
+ /* called by sv_clean_objs() for each live SV */
+
+ static void
+ do_clean_objs(pTHXo_ SV *sv)
+ {
+ SV* rv;
+
+ if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
+ DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
+ if (SvWEAKREF(sv)) {
+ sv_del_backref(sv);
+ SvWEAKREF_off(sv);
+ SvRV(sv) = 0;
+ } else {
+ SvROK_off(sv);
+ SvRV(sv) = 0;
+ SvREFCNT_dec(rv);
+ }
+ }
+
+ /* XXX Might want to check arrays, etc. */
+ }
+
+ /* called by sv_clean_objs() for each live SV */
+
+ #ifndef DISABLE_DESTRUCTOR_KLUDGE
+ static void
+ do_clean_named_objs(pTHXo_ SV *sv)
+ {
+ if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
+ if ( SvOBJECT(GvSV(sv)) ||
+ (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
+ (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
+ (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
+ (GvCV(sv) && SvOBJECT(GvCV(sv))) )
+ {
+ DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
+ SvREFCNT_dec(sv);
+ }
+ }
+ }
+ #endif
+
+ /*
+ =for apidoc sv_clean_objs
+
+ Attempt to destroy all objects not yet freed
+
+ =cut
+ */
+
void
Perl_sv_clean_objs(pTHX)
{
***************
*** 185,190 ****
--- 383,408 ----
PL_in_clean_objs = FALSE;
}
+ /* called by sv_clean_all() for each live SV */
+
+ static void
+ do_clean_all(pTHXo_ SV *sv)
+ {
+ DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
+ SvFLAGS(sv) |= SVf_BREAK;
+ SvREFCNT_dec(sv);
+ }
+
+ /*
+ =for apidoc sv_clean_all
+
+ Decrement the refcnt of each remaining SV, possibly triggering a
+ cleanup. This function may have to be called multiple times to free
+ SVs which are in complex self-referential hierarchies.
+
+ =cut
+ */
+
I32
Perl_sv_clean_all(pTHX)
{
***************
*** 195,200 ****
--- 413,427 ----
return cleaned;
}
+ /*
+ =for apidoc sv_free_arenas
+
+ Deallocate the memory used by all arenas. Note that all the individual SV
+ heads and bodies within the arenas must already have been freed.
+
+ =cut
+ */
+
void
Perl_sv_free_arenas(pTHX)
{
***************
*** 300,305 ****
--- 527,540 ----
PL_sv_root = 0;
}
+ /*
+ =for apidoc report_uninit
+
+ Print appropriate "Use of uninitialized variable" warning
+
+ =cut
+ */
+
void
Perl_report_uninit(pTHX)
{
***************
*** 310,315 ****
--- 545,552 ----
Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
}
+ /* grab a new IV body from the free list, allocating more if necessary */
+
STATIC XPVIV*
S_new_xiv(pTHX)
{
***************
*** 326,331 ****
--- 563,570 ----
return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
}
+ /* return an IV body to the free list */
+
STATIC void
S_del_xiv(pTHX_ XPVIV *p)
{
***************
*** 336,341 ****
--- 575,582 ----
UNLOCK_SV_MUTEX;
}
+ /* allocate another arena's worth of IV bodies */
+
STATIC void
S_more_xiv(pTHX)
{
***************
*** 343,354 ****
register IV* xivend;
XPV* ptr;
New(705, ptr, 1008/sizeof(XPV), XPV);
! ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
PL_xiv_arenaroot = ptr; /* to keep Purify happy */
xiv = (IV*) ptr;
xivend = &xiv[1008 / sizeof(IV) - 1];
! xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
PL_xiv_root = xiv;
while (xiv < xivend) {
*(IV**)xiv = (IV *)(xiv + 1);
--- 584,595 ----
register IV* xivend;
XPV* ptr;
New(705, ptr, 1008/sizeof(XPV), XPV);
! ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
PL_xiv_arenaroot = ptr; /* to keep Purify happy */
xiv = (IV*) ptr;
xivend = &xiv[1008 / sizeof(IV) - 1];
! xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
PL_xiv_root = xiv;
while (xiv < xivend) {
*(IV**)xiv = (IV *)(xiv + 1);
***************
*** 357,362 ****
--- 598,605 ----
*(IV**)xiv = 0;
}
+ /* grab a new NV body from the free list, allocating more if necessary */
+
STATIC XPVNV*
S_new_xnv(pTHX)
{
***************
*** 370,375 ****
--- 613,620 ----
return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
}
+ /* return an NV body to the free list */
+
STATIC void
S_del_xnv(pTHX_ XPVNV *p)
{
***************
*** 380,385 ****
--- 625,632 ----
UNLOCK_SV_MUTEX;
}
+ /* allocate another arena's worth of NV bodies */
+
STATIC void
S_more_xnv(pTHX)
{
***************
*** 401,406 ****
--- 648,655 ----
*(NV**)xnv = 0;
}
+ /* grab a new struct xrv from the free list, allocating more if necessary */
+
STATIC XRV*
S_new_xrv(pTHX)
{
***************
*** 414,419 ****
--- 663,670 ----
return xrv;
}
+ /* return a struct xrv to the free list */
+
STATIC void
S_del_xrv(pTHX_ XRV *p)
{
***************
*** 423,428 ****
--- 674,681 ----
UNLOCK_SV_MUTEX;
}
+ /* allocate another arena's worth of struct xrv */
+
STATIC void
S_more_xrv(pTHX)
{
***************
*** 444,449 ****
--- 697,704 ----
xrv->xrv_rv = 0;
}
+ /* grab a new struct xpv from the free list, allocating more if necessary */
+
STATIC XPV*
S_new_xpv(pTHX)
{
***************
*** 457,462 ****
--- 712,719 ----
return xpv;
}
+ /* return a struct xpv to the free list */
+
STATIC void
S_del_xpv(pTHX_ XPV *p)
{
***************
*** 466,471 ****
--- 723,730 ----
UNLOCK_SV_MUTEX;
}
+ /* allocate another arena's worth of struct xpv */
+
STATIC void
S_more_xpv(pTHX)
{
***************
*** 484,489 ****
--- 743,750 ----
xpv->xpv_pv = 0;
}
+ /* grab a new struct xpviv from the free list, allocating more if necessary */
+
STATIC XPVIV*
S_new_xpviv(pTHX)
{
***************
*** 497,502 ****
--- 758,765 ----
return xpviv;
}
+ /* return a struct xpviv to the free list */
+
STATIC void
S_del_xpviv(pTHX_ XPVIV *p)
{
***************
*** 506,511 ****
--- 769,776 ----
UNLOCK_SV_MUTEX;
}
+ /* allocate another arena's worth of struct xpviv */
+
STATIC void
S_more_xpviv(pTHX)
{
***************
*** 524,529 ****
--- 789,796 ----
xpviv->xpv_pv = 0;
}
+ /* grab a new struct xpvnv from the free list, allocating more if necessary */
+
STATIC XPVNV*
S_new_xpvnv(pTHX)
{
***************
*** 537,542 ****
--- 804,811 ----
return xpvnv;
}
+ /* return a struct xpvnv to the free list */
+
STATIC void
S_del_xpvnv(pTHX_ XPVNV *p)
{
***************
*** 546,551 ****
--- 815,822 ----
UNLOCK_SV_MUTEX;
}
+ /* allocate another arena's worth of struct xpvnv */
+
STATIC void
S_more_xpvnv(pTHX)
{
***************
*** 564,569 ****
--- 835,842 ----
xpvnv->xpv_pv = 0;
}
+ /* grab a new struct xpvcv from the free list, allocating more if necessary */
+
STATIC XPVCV*
S_new_xpvcv(pTHX)
{
***************
*** 577,582 ****
--- 850,857 ----
return xpvcv;
}
+ /* return a struct xpvcv to the free list */
+
STATIC void
S_del_xpvcv(pTHX_ XPVCV *p)
{
***************
*** 586,591 ****
--- 861,868 ----
UNLOCK_SV_MUTEX;
}
+ /* allocate another arena's worth of struct xpvcv */
+
STATIC void
S_more_xpvcv(pTHX)
{
***************
*** 604,609 ****
--- 881,888 ----
xpvcv->xpv_pv = 0;
}
+ /* grab a new struct xpvav from the free list, allocating more if necessary */
+
STATIC XPVAV*
S_new_xpvav(pTHX)
{
***************
*** 617,622 ****
--- 896,903 ----
return xpvav;
}
+ /* return a struct xpvav to the free list */
+
STATIC void
S_del_xpvav(pTHX_ XPVAV *p)
{
***************
*** 626,631 ****
--- 907,914 ----
UNLOCK_SV_MUTEX;
}
+ /* allocate another arena's worth of struct xpvav */
+
STATIC void
S_more_xpvav(pTHX)
{
***************
*** 644,649 ****
--- 927,934 ----
xpvav->xav_array = 0;
}
+ /* grab a new struct xpvhv from the free list, allocating more if necessary */
+
STATIC XPVHV*
S_new_xpvhv(pTHX)
{
***************
*** 657,662 ****
--- 942,949 ----
return xpvhv;
}
+ /* return a struct xpvhv to the free list */
+
STATIC void
S_del_xpvhv(pTHX_ XPVHV *p)
{
***************
*** 666,671 ****
--- 953,960 ----
UNLOCK_SV_MUTEX;
}
+ /* allocate another arena's worth of struct xpvhv */
+
STATIC void
S_more_xpvhv(pTHX)
{
***************
*** 684,689 ****
--- 973,980 ----
xpvhv->xhv_array = 0;
}
+ /* grab a new struct xpvmg from the free list, allocating more if necessary */
+
STATIC XPVMG*
S_new_xpvmg(pTHX)
{
***************
*** 697,702 ****
--- 988,995 ----
return xpvmg;
}
+ /* return a struct xpvmg to the free list */
+
STATIC void
S_del_xpvmg(pTHX_ XPVMG *p)
{
***************
*** 706,711 ****
--- 999,1006 ----
UNLOCK_SV_MUTEX;
}
+ /* allocate another arena's worth of struct xpvmg */
+
STATIC void
S_more_xpvmg(pTHX)
{
***************
*** 724,729 ****
--- 1019,1026 ----
xpvmg->xpv_pv = 0;
}
+ /* grab a new struct xpvlv from the free list, allocating more if necessary */
+
STATIC XPVLV*
S_new_xpvlv(pTHX)
{
***************
*** 737,742 ****
--- 1034,1041 ----
return xpvlv;
}
+ /* return a struct xpvlv to the free list */
+
STATIC void
S_del_xpvlv(pTHX_ XPVLV *p)
{
***************
*** 746,751 ****
--- 1045,1052 ----
UNLOCK_SV_MUTEX;
}
+ /* allocate another arena's worth of struct xpvlv */
+
STATIC void
S_more_xpvlv(pTHX)
{
***************
*** 764,769 ****
--- 1065,1072 ----
xpvlv->xpv_pv = 0;
}
+ /* grab a new struct xpvbm from the free list, allocating more if necessary */
+
STATIC XPVBM*
S_new_xpvbm(pTHX)
{
***************
*** 777,782 ****
--- 1080,1087 ----
return xpvbm;
}
+ /* return a struct xpvbm to the free list */
+
STATIC void
S_del_xpvbm(pTHX_ XPVBM *p)
{
***************
*** 786,791 ****
--- 1091,1098 ----
UNLOCK_SV_MUTEX;
}
+ /* allocate another arena's worth of struct xpvbm */
+
STATIC void
S_more_xpvbm(pTHX)
{
***************
*** 902,909 ****
/*
=for apidoc sv_upgrade
! Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
! C<svtype>.
=cut
*/
--- 1209,1217 ----
/*
=for apidoc sv_upgrade
! Upgrade an SV to a more complex form. Generally adds a new body type to the
! SV, then copies across as much information as possible from the old body.
! You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
=cut
*/
***************
*** 1186,1191 ****
--- 1494,1508 ----
return TRUE;
}
+ /*
+ =for apidoc sv_backoff
+
+ Remove any string offset. You should normally use the C<SvOOK_off> macro
+ wrapper instead.
+
+ =cut
+ */
+
int
Perl_sv_backoff(pTHX_ register SV *sv)
{
***************
*** 1204,1212 ****
/*
=for apidoc sv_grow
! Expands the character buffer in the SV. This will use C<sv_unref> and will
! upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
! Use C<SvGROW>.
=cut
*/
--- 1521,1529 ----
/*
=for apidoc sv_grow
! Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
! upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
! Use the C<SvGROW> wrapper instead.
=cut
*/
***************
*** 1252,1259 ****
#endif
Renew(s,newlen,char);
}
! else
! New(703,s,newlen,char);
SvPV_set(sv, s);
SvLEN_set(sv, newlen);
}
--- 1569,1583 ----
#endif
Renew(s,newlen,char);
}
! else {
! /* sv_force_normal_flags() must not try to unshare the new
! PVX we allocate below. AMS 20010713 */
! if (SvREADONLY(sv) && SvFAKE(sv)) {
! SvFAKE_off(sv);
! SvREADONLY_off(sv);
! }
! New(703, s, newlen, char);
! }
SvPV_set(sv, s);
SvLEN_set(sv, newlen);
}
***************
*** 1263,1270 ****
/*
=for apidoc sv_setiv
! Copies an integer into the given SV. Does not handle 'set' magic. See
! C<sv_setiv_mg>.
=cut
*/
--- 1587,1594 ----
/*
=for apidoc sv_setiv
! Copies an integer into the given SV, upgrading first if necessary.
! Does not handle 'set' magic. See also C<sv_setiv_mg>.
=cut
*/
***************
*** 1317,1324 ****
/*
=for apidoc sv_setuv
! Copies an unsigned integer into the given SV. Does not handle 'set' magic.
! See C<sv_setuv_mg>.
=cut
*/
--- 1641,1648 ----
/*
=for apidoc sv_setuv
! Copies an unsigned integer into the given SV, upgrading first if necessary.
! Does not handle 'set' magic. See also C<sv_setuv_mg>.
=cut
*/
***************
*** 1375,1382 ****
/*
=for apidoc sv_setnv
! Copies a double into the given SV. Does not handle 'set' magic. See
! C<sv_setnv_mg>.
=cut
*/
--- 1699,1706 ----
/*
=for apidoc sv_setnv
! Copies a double into the given SV, upgrading first if necessary.
! Does not handle 'set' magic. See also C<sv_setnv_mg>.
=cut
*/
***************
*** 1425,1430 ****
--- 1749,1758 ----
SvSETMAGIC(sv);
}
+ /* Print an "isn't numeric" warning, using a cleaned-up,
+ * printable version of the offending string
+ */
+
STATIC void
S_not_a_number(pTHX_ SV *sv)
{
***************
*** 1485,1514 ****
"Argument \"%s\" isn't numeric", tmpbuf);
}
! /* the number can be converted to integer with atol() or atoll() although */
! #define IS_NUMBER_TO_INT_BY_ATOL 0x01 /* integer (may have decimals) */
! #define IS_NUMBER_TO_INT_BY_STRTOL 0x02 /* it may exceed IV_MAX */
! #define IS_NUMBER_TO_INT_BY_ATOF 0x04 /* seen something like 123e4 */
! #define IS_NUMBER_LONGER_THAN_IV_MAX 0x08 /* more digits than IV_MAX */
! #define IS_NUMBER_AS_LONG_AS_IV_MAX 0x10 /* may(be not) larger than IV_MAX */
! #define IS_NUMBER_NOT_INT 0x20 /* seen a decimal point or e */
! #define IS_NUMBER_NEG 0x40 /* seen a leading - */
! #define IS_NUMBER_INFINITY 0x80 /* /^\s*-?Infinity\s*$/i */
/* Actually, ISO C leaves conversion of UV to IV undefined, but
until proven guilty, assume that things are not that bad... */
! /* As 64 bit platforms often have an NV that doesn't preserve all bits of
an IV (an assumption perl has been based on to date) it becomes necessary
to remove the assumption that the NV always carries enough precision to
recreate the IV whenever needed, and that the NV is the canonical form.
Instead, IV/UV and NV need to be given equal rights. So as to not lose
! precision as an side effect of conversion (which would lead to insanity
and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1) to distinguish between IV/UV/NV slots that have cached a valid
conversion where precision was lost and IV/UV/NV slots that have a
valid conversion which has lost no precision
! 2) to ensure that if a numeric conversion to one form is request that
would lose precision, the precise conversion (or differently
imprecise conversion) is also performed and cached, to prevent
requests for different numeric formats on the same SV causing
--- 1813,1862 ----
"Argument \"%s\" isn't numeric", tmpbuf);
}
! /*
! =for apidoc looks_like_number
+ Test if the content of an SV looks like a number (or is a number).
+ C<Inf> and C<Infinity> are treated as numbers (so will not issue a
+ non-numeric warning), even if your atof() doesn't grok them.
+
+ =cut
+ */
+
+ I32
+ Perl_looks_like_number(pTHX_ SV *sv)
+ {
+ register char *sbegin;
+ STRLEN len;
+
+ if (SvPOK(sv)) {
+ sbegin = SvPVX(sv);
+ len = SvCUR(sv);
+ }
+ else if (SvPOKp(sv))
+ sbegin = SvPV(sv, len);
+ else
+ return 1; /* Historic. Wrong? */
+ return grok_number(sbegin, len, NULL);
+ }
+
/* Actually, ISO C leaves conversion of UV to IV undefined, but
until proven guilty, assume that things are not that bad... */
! /*
! NV_PRESERVES_UV:
!
! As 64 bit platforms often have an NV that doesn't preserve all bits of
an IV (an assumption perl has been based on to date) it becomes necessary
to remove the assumption that the NV always carries enough precision to
recreate the IV whenever needed, and that the NV is the canonical form.
Instead, IV/UV and NV need to be given equal rights. So as to not lose
! precision as a side effect of conversion (which would lead to insanity
and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1) to distinguish between IV/UV/NV slots that have cached a valid
conversion where precision was lost and IV/UV/NV slots that have a
valid conversion which has lost no precision
! 2) to ensure that if a numeric conversion to one form is requested that
would lose precision, the precise conversion (or differently
imprecise conversion) is also performed and cached, to prevent
requests for different numeric formats on the same SV causing
***************
*** 1523,1553 ****
SvNOK is true only if the NV value is accurate
so
! while converting from PV to NV check to see if converting that NV to an
IV(or UV) would lose accuracy over a direct conversion from PV to
IV(or UV). If it would, cache both conversions, return NV, but mark
SV as IOK NOKp (ie not NOK).
! while converting from PV to IV check to see if converting that IV to an
NV would lose accuracy over a direct conversion from PV to NV. If it
would, cache both conversions, flag similarly.
Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
correctly because if IV & NV were set NV *always* overruled.
! Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
! changes - now IV and NV together means that the two are interchangeable
SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
! The benefit of this is operations such as pp_add know that if SvIOK is
! true for both left and right operands, then integer addition can be
! used instead of floating point. (for cases where the result won't
! overflow) Before, floating point was always used, which could lead to
loss of precision compared with integer addition.
* making IV and NV equal status should make maths accurate on 64 bit
platforms
* may speed up maths somewhat if pp_add and friends start to use
! integers when possible instead of fp. (hopefully the overhead in
looking for SvIOK and checking for overflow will not outweigh the
fp to integer speedup)
* will slow down integer operations (callers of SvIV) on "inaccurate"
--- 1871,1901 ----
SvNOK is true only if the NV value is accurate
so
! while converting from PV to NV, check to see if converting that NV to an
IV(or UV) would lose accuracy over a direct conversion from PV to
IV(or UV). If it would, cache both conversions, return NV, but mark
SV as IOK NOKp (ie not NOK).
! While converting from PV to IV, check to see if converting that IV to an
NV would lose accuracy over a direct conversion from PV to NV. If it
would, cache both conversions, flag similarly.
Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
correctly because if IV & NV were set NV *always* overruled.
! Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
! changes - now IV and NV together means that the two are interchangeable:
SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
! The benefit of this is that operations such as pp_add know that if
! SvIOK is true for both left and right operands, then integer addition
! can be used instead of floating point (for cases where the result won't
! overflow). Before, floating point was always used, which could lead to
loss of precision compared with integer addition.
* making IV and NV equal status should make maths accurate on 64 bit
platforms
* may speed up maths somewhat if pp_add and friends start to use
! integers when possible instead of fp. (Hopefully the overhead in
looking for SvIOK and checking for overflow will not outweigh the
fp to integer speedup)
* will slow down integer operations (callers of SvIV) on "inaccurate"
***************
*** 1554,1662 ****
values, as the change from SvIOK to SvIOKp will cause a call into
sv_2iv each time rather than a macro access direct to the IV slot
* should speed up number->string conversion on integers as IV is
! favoured when IV and NV equally accurate
####################################################################
! You had better be using SvIOK_notUV if you want an IV for arithmetic
! SvIOK is true if (IV or UV), so you might be getting (IV)SvUV
! SvUOK is true iff UV.
####################################################################
! Your mileage will vary depending your CPUs relative fp to integer
performance ratio.
*/
#ifndef NV_PRESERVES_UV
! #define IS_NUMBER_UNDERFLOW_IV 1
! #define IS_NUMBER_UNDERFLOW_UV 2
! #define IS_NUMBER_IV_AND_UV 2
! #define IS_NUMBER_OVERFLOW_IV 4
! #define IS_NUMBER_OVERFLOW_UV 5
! /* Hopefully your optimiser will consider inlining these two functions. */
! STATIC int
! S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) {
! NV nv = SvNVX(sv); /* Code simpler and had compiler problems if */
! UV nv_as_uv = U_V(nv); /* these are not in simple variables. */
! DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), nv, (UV)numtype));
! if (nv_as_uv <= (UV)IV_MAX) {
! (void)SvIOKp_on(sv);
! (void)SvNOKp_on(sv);
! /* Within suitable range to fit in an IV, atol won't overflow */
! /* XXX quite sure? Is that your final answer? not really, I'm
! trusting that nv_as_uv to round down if NV is (IV_MAX + 1) */
! SvIVX(sv) = (IV)Atol(SvPVX(sv));
! if (numtype & IS_NUMBER_NOT_INT) {
! /* I believe that even if the original PV had decimals, they
! are lost beyond the limit of the FP precision.
! However, neither is canonical, so both only get p flags.
! NWC, 2000/11/25 */
! /* Both already have p flags, so do nothing */
! } else if (SvIVX(sv) == I_V(nv)) {
! SvNOK_on(sv);
! SvIOK_on(sv);
! } else {
! SvIOK_on(sv);
! /* It had no "." so it must be integer. assert (get in here from
! sv_2iv and sv_2uv only for ndef HAS_STRTOL and
! IS_NUMBER_AS_LONG_AS_IV_MAX) or my logic is faulty and all
! conversion routines need audit. */
! }
! return nv < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
! }
! /* between IV_MAX and NV(UV_MAX). Could be slightly> UV_MAX */
! (void)SvIOKp_on(sv);
! (void)SvNOKp_on(sv);
! #ifdef HAS_STRTOUL
! {
! int save_errno = errno;
! errno = 0;
! SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
! if (errno == 0) {
! if (numtype & IS_NUMBER_NOT_INT) {
! /* UV and NV both imprecise. */
! SvIsUV_on(sv);
! } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
! SvNOK_on(sv);
! SvIOK_on(sv);
! SvIsUV_on(sv);
! } else {
! SvIOK_on(sv);
! SvIsUV_on(sv);
! }
! errno = save_errno;
! return IS_NUMBER_OVERFLOW_IV;
! }
! errno = save_errno;
! SvNOK_on(sv);
! /* Must have just overflowed UV, but not enough that an NV could spot
! this.. */
! return IS_NUMBER_OVERFLOW_UV;
! }
! #else
! /* We've just lost integer precision, nothing we could do. */
! SvUVX(sv) = nv_as_uv;
! DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, (UV)numtype));
! /* UV and NV slots equally valid only if we have casting symmetry. */
! if (numtype & IS_NUMBER_NOT_INT) {
! SvIsUV_on(sv);
! } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
! /* UV_MAX can cast up to NV (UV_MAX+1), that NV casts down to UV_MAX
! UV_MAX ought to be 0xFF...FFF which won't preserve (We only
! get to this point if NVs don't preserve UVs) */
! SvNOK_on(sv);
! SvIOK_on(sv);
! SvIsUV_on(sv);
! } else {
! /* As above, I believe UV at least as good as NV */
! SvIsUV_on(sv);
! }
! #endif /* HAS_STRTOUL */
! return IS_NUMBER_OVERFLOW_IV;
! }
/* For sv_2nv these three cases are "SvNOK and don't bother casting" */
STATIC int
! S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
{
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
if (SvNVX(sv) < (NV)IV_MIN) {
--- 1902,1931 ----
values, as the change from SvIOK to SvIOKp will cause a call into
sv_2iv each time rather than a macro access direct to the IV slot
* should speed up number->string conversion on integers as IV is
! favoured when IV and NV are equally accurate
####################################################################
! You had better be using SvIOK_notUV if you want an IV for arithmetic:
! SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
! On the other hand, SvUOK is true iff UV.
####################################################################
! Your mileage will vary depending your CPU's relative fp to integer
performance ratio.
*/
#ifndef NV_PRESERVES_UV
! # define IS_NUMBER_UNDERFLOW_IV 1
! # define IS_NUMBER_UNDERFLOW_UV 2
! # define IS_NUMBER_IV_AND_UV 2
! # define IS_NUMBER_OVERFLOW_IV 4
! # define IS_NUMBER_OVERFLOW_UV 5
+ /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
+
/* For sv_2nv these three cases are "SvNOK and don't bother casting" */
STATIC int
! S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
{
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
if (SvNVX(sv) < (NV)IV_MIN) {
***************
*** 1672,1709 ****
SvUVX(sv) = UV_MAX;
return IS_NUMBER_OVERFLOW_UV;
}
! if (!(numtype & (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
! (void)SvIOKp_on(sv);
! (void)SvNOK_on(sv);
! /* Can't use strtol etc to convert this string */
! if (SvNVX(sv) <= (UV)IV_MAX) {
! SvIVX(sv) = I_V(SvNVX(sv));
! if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
! SvIOK_on(sv); /* Integer is precise. NOK, IOK */
! } else {
! /* Integer is imprecise. NOK, IOKp */
! }
! return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
! }
! SvIsUV_on(sv);
! SvUVX(sv) = U_V(SvNVX(sv));
! if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
! if (SvUVX(sv) == UV_MAX) {
! /* As we know that NVs don't preserve UVs, UV_MAX cannot
! possibly be preserved by NV. Hence, it must be overflow.
! NOK, IOKp */
! return IS_NUMBER_OVERFLOW_UV;
! }
! SvIOK_on(sv); /* Integer is precise. NOK, UOK */
! } else {
! /* Integer is imprecise. NOK, IOKp */
! }
! return IS_NUMBER_OVERFLOW_IV;
}
! return S_sv_2inuv_non_preserve(aTHX_ sv, numtype);
}
! #endif /* NV_PRESERVES_UV*/
IV
Perl_sv_2iv(pTHX_ register SV *sv)
{
--- 1941,1985 ----
SvUVX(sv) = UV_MAX;
return IS_NUMBER_OVERFLOW_UV;
}
! (void)SvIOKp_on(sv);
! (void)SvNOK_on(sv);
! /* Can't use strtol etc to convert this string. (See truth table in
! sv_2iv */
! if (SvNVX(sv) <= (UV)IV_MAX) {
! SvIVX(sv) = I_V(SvNVX(sv));
! if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
! SvIOK_on(sv); /* Integer is precise. NOK, IOK */
! } else {
! /* Integer is imprecise. NOK, IOKp */
! }
! return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
}
! SvIsUV_on(sv);
! SvUVX(sv) = U_V(SvNVX(sv));
! if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
! if (SvUVX(sv) == UV_MAX) {
! /* As we know that NVs don't preserve UVs, UV_MAX cannot
! possibly be preserved by NV. Hence, it must be overflow.
! NOK, IOKp */
! return IS_NUMBER_OVERFLOW_UV;
! }
! SvIOK_on(sv); /* Integer is precise. NOK, UOK */
! } else {
! /* Integer is imprecise. NOK, IOKp */
! }
! return IS_NUMBER_OVERFLOW_IV;
}
! #endif /* !NV_PRESERVES_UV*/
+ /*
+ =for apidoc sv_2iv
+
+ Return the integer value of an SV, doing any necessary string conversion,
+ magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
+
+ =cut
+ */
+
IV
Perl_sv_2iv(pTHX_ register SV *sv)
{
***************
*** 1730,1736 ****
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
! (SvRV(tmpstr) != SvRV(sv)))
return SvIV(tmpstr);
return PTR2IV(SvRV(sv));
}
--- 2006,2012 ----
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
! (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
return SvIV(tmpstr);
return PTR2IV(SvRV(sv));
}
***************
*** 1828,1838 ****
}
}
else if (SvPOKp(sv) && SvLEN(sv)) {
! I32 numtype = looks_like_number(sv);
!
/* We want to avoid a possible problem when we cache an IV which
may be later translated to an NV, and the resulting NV is not
! the translation of the initial data.
This means that if we cache such an IV, we need to cache the
NV as well. Moreover, we trade speed for space, and do not
--- 2104,2117 ----
}
}
else if (SvPOKp(sv) && SvLEN(sv)) {
! UV value;
! int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
/* We want to avoid a possible problem when we cache an IV which
may be later translated to an NV, and the resulting NV is not
! the same as the direct translation of the initial string
! (eg 123.456 can shortcut to the IV 123 with atol(), but we must
! be careful to ensure that the value with the .456 is around if the
! NV value is requested in the future).
This means that if we cache such an IV, we need to cache the
NV as well. Moreover, we trade speed for space, and do not
***************
*** 1839,1950 ****
cache the NV if we are sure it's not needed.
*/
! if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
! /* The NV may be reconstructed from IV - safe to cache IV,
! which may be calculated by atol(). */
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
(void)SvIOK_on(sv);
! SvIVX(sv) = Atol(SvPVX(sv));
! } else {
! #ifdef HAS_STRTOL
! IV i;
! int save_errno = errno;
! /* Is it an integer that we could convert with strtol?
! So try it, and if it doesn't set errno then it's pukka.
! This should be faster than going atof and then thinking. */
! if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
! == IS_NUMBER_TO_INT_BY_STRTOL)
! /* && is a sequence point. Without it not sure if I'm trying
! to do too much between sequence points and hence going
! undefined */
! && ((errno = 0), 1) /* , 1 so always true */
! && ((i = Strtol(SvPVX(sv), Null(char**), 10)), 1)
! && (errno == 0)) {
! if (SvTYPE(sv) < SVt_PVIV)
! sv_upgrade(sv, SVt_PVIV);
! (void)SvIOK_on(sv);
! SvIVX(sv) = i;
! errno = save_errno;
! } else
#endif
! {
! NV d;
! #ifdef HAS_STRTOL
! /* Hopefully trace flow will optimise this away where possible
! */
! errno = save_errno;
! #endif
! /* It wasn't an integer, or it overflowed, or we don't have
! strtol. Do things the slow way - check if it's a UV etc. */
! d = Atof(SvPVX(sv));
! if (SvTYPE(sv) < SVt_PVNV)
! sv_upgrade(sv, SVt_PVNV);
! SvNVX(sv) = d;
! if (! numtype && ckWARN(WARN_NUMERIC))
! not_a_number(sv);
#if defined(USE_LONG_DOUBLE)
! DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
! PTR2UV(sv), SvNVX(sv)));
#else
! DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
! PTR2UV(sv), SvNVX(sv)));
#endif
#ifdef NV_PRESERVES_UV
! (void)SvIOKp_on(sv);
! (void)SvNOK_on(sv);
! if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
! SvIVX(sv) = I_V(SvNVX(sv));
! if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
! SvIOK_on(sv);
! } else {
! /* Integer is imprecise. NOK, IOKp */
! }
! /* UV will not work better than IV */
} else {
! if (SvNVX(sv) > (NV)UV_MAX) {
SvIsUV_on(sv);
- /* Integer is inaccurate. NOK, IOKp, is UV */
- SvUVX(sv) = UV_MAX;
- SvIsUV_on(sv);
} else {
! SvUVX(sv) = U_V(SvNVX(sv));
! /* 0xFFFFFFFFFFFFFFFF not an issue in here */
! if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
! SvIOK_on(sv);
! SvIsUV_on(sv);
! } else {
! /* Integer is imprecise. NOK, IOKp, is UV */
! SvIsUV_on(sv);
! }
}
- goto ret_iv_max;
}
#else /* NV_PRESERVES_UV */
! if (((UV)1 << NV_PRESERVES_UV_BITS) >
! U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
! /* Small enough to preserve all bits. */
! (void)SvIOKp_on(sv);
! SvNOK_on(sv);
! SvIVX(sv) = I_V(SvNVX(sv));
! if ((NV)(SvIVX(sv)) == SvNVX(sv))
! SvIOK_on(sv);
! /* Assumption: first non-preserved integer is < IV_MAX,
! this NV is in the preserved range, therefore: */
! if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
! < (UV)IV_MAX)) {
! Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
! }
! } else if (sv_2iuv_non_preserve (sv, numtype)
! >= IS_NUMBER_OVERFLOW_IV)
! goto ret_iv_max;
#endif /* NV_PRESERVES_UV */
- }
}
} else {
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
--- 2118,2259 ----
cache the NV if we are sure it's not needed.
*/
! /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
! if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
! == IS_NUMBER_IN_UV) {
! /* It's definitely an integer, only upgrade to PVIV */
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
(void)SvIOK_on(sv);
! } else if (SvTYPE(sv) < SVt_PVNV)
! sv_upgrade(sv, SVt_PVNV);
!
! /* If NV preserves UV then we only use the UV value if we know that
! we aren't going to call atof() below. If NVs don't preserve UVs
! then the value returned may have more precision than atof() will
! return, even though value isn't perfectly accurate. */
! if ((numtype & (IS_NUMBER_IN_UV
! #ifdef NV_PRESERVES_UV
! | IS_NUMBER_NOT_INT
#endif
! )) == IS_NUMBER_IN_UV) {
! /* This won't turn off the public IOK flag if it was set above */
! (void)SvIOKp_on(sv);
! if (!(numtype & IS_NUMBER_NEG)) {
! /* positive */;
! if (value <= (UV)IV_MAX) {
! SvIVX(sv) = (IV)value;
! } else {
! SvUVX(sv) = value;
! SvIsUV_on(sv);
! }
! } else {
! /* 2s complement assumption */
! if (value <= (UV)IV_MIN) {
! SvIVX(sv) = -(IV)value;
! } else {
! /* Too negative for an IV. This is a double upgrade, but
! I'm assuming it will be be rare. */
! if (SvTYPE(sv) < SVt_PVNV)
! sv_upgrade(sv, SVt_PVNV);
! SvNOK_on(sv);
! SvIOK_off(sv);
! SvIOKp_on(sv);
! SvNVX(sv) = -(NV)value;
! SvIVX(sv) = IV_MIN;
! }
! }
! }
! /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
! will be in the previous block to set the IV slot, and the next
! block to set the NV slot. So no else here. */
!
! if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
! != IS_NUMBER_IN_UV) {
! /* It wasn't an (integer that doesn't overflow the UV). */
! SvNVX(sv) = Atof(SvPVX(sv));
! if (! numtype && ckWARN(WARN_NUMERIC))
! not_a_number(sv);
#if defined(USE_LONG_DOUBLE)
! DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
! PTR2UV(sv), SvNVX(sv)));
#else
! DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
! PTR2UV(sv), SvNVX(sv)));
#endif
#ifdef NV_PRESERVES_UV
! (void)SvIOKp_on(sv);
! (void)SvNOK_on(sv);
! if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
! SvIVX(sv) = I_V(SvNVX(sv));
! if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
! SvIOK_on(sv);
} else {
! /* Integer is imprecise. NOK, IOKp */
! }
! /* UV will not work better than IV */
! } else {
! if (SvNVX(sv) > (NV)UV_MAX) {
! SvIsUV_on(sv);
! /* Integer is inaccurate. NOK, IOKp, is UV */
! SvUVX(sv) = UV_MAX;
! SvIsUV_on(sv);
! } else {
! SvUVX(sv) = U_V(SvNVX(sv));
! /* 0xFFFFFFFFFFFFFFFF not an issue in here */
! if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
! SvIOK_on(sv);
SvIsUV_on(sv);
} else {
! /* Integer is imprecise. NOK, IOKp, is UV */
! SvIsUV_on(sv);
}
}
+ goto ret_iv_max;
+ }
#else /* NV_PRESERVES_UV */
! if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
! == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
! /* The IV slot will have been set from value returned by
! grok_number above. The NV slot has just been set using
! Atof. */
! SvNOK_on(sv);
! assert (SvIOKp(sv));
! } else {
! if (((UV)1 << NV_PRESERVES_UV_BITS) >
! U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
! /* Small enough to preserve all bits. */
! (void)SvIOKp_on(sv);
! SvNOK_on(sv);
! SvIVX(sv) = I_V(SvNVX(sv));
! if ((NV)(SvIVX(sv)) == SvNVX(sv))
! SvIOK_on(sv);
! /* Assumption: first non-preserved integer is < IV_MAX,
! this NV is in the preserved range, therefore: */
! if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
! < (UV)IV_MAX)) {
! Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
! }
! } else {
! /* IN_UV NOT_INT
! 0 0 already failed to read UV.
! 0 1 already failed to read UV.
! 1 0 you won't get here in this case. IV/UV
! slot set, public IOK, Atof() unneeded.
! 1 1 already read UV.
! so there's no point in sv_2iuv_non_preserve() attempting
! to use atol, strtol, strtoul etc. */
! if (sv_2iuv_non_preserve (sv, numtype)
! >= IS_NUMBER_OVERFLOW_IV)
! goto ret_iv_max;
! }
! }
#endif /* NV_PRESERVES_UV */
}
} else {
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
***************
*** 1959,1964 ****
--- 2268,2283 ----
return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
}
+ /*
+ =for apidoc sv_2uv
+
+ Return the unsigned integer value of an SV, doing any necessary string
+ conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
+ macros.
+
+ =cut
+ */
+
UV
Perl_sv_2uv(pTHX_ register SV *sv)
{
***************
*** 1984,1990 ****
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
! (SvRV(tmpstr) != SvRV(sv)))
return SvUV(tmpstr);
return PTR2UV(SvRV(sv));
}
--- 2303,2309 ----
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
! (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
return SvUV(tmpstr);
return PTR2UV(SvRV(sv));
}
***************
*** 2077,2083 ****
}
}
else if (SvPOKp(sv) && SvLEN(sv)) {
! I32 numtype = looks_like_number(sv);
/* We want to avoid a possible problem when we cache a UV which
may be later translated to an NV, and the resulting NV is not
--- 2396,2403 ----
}
}
else if (SvPOKp(sv) && SvLEN(sv)) {
! UV value;
! int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
/* We want to avoid a possible problem when we cache a UV which
may be later translated to an NV, and the resulting NV is not
***************
*** 2088,2223 ****
cache the NV if not needed.
*/
! if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
! /* The NV may be reconstructed from IV - safe to cache IV,
! which may be calculated by atol(). */
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
(void)SvIOK_on(sv);
! SvIVX(sv) = Atol(SvPVX(sv));
! } else {
! #ifdef HAS_STRTOUL
! UV u;
! char *num_begin = SvPVX(sv);
! int save_errno = errno;
!
! /* seems that strtoul taking numbers that start with - is
! implementation dependant, and can't be relied upon. */
! if (numtype & IS_NUMBER_NEG) {
! /* Not totally defensive. assumine that looks_like_num
! didn't lie about a - sign */
! while (isSPACE(*num_begin))
! num_begin++;
! if (*num_begin == '-')
! num_begin++;
! }
! /* Is it an integer that we could convert with strtoul?
! So try it, and if it doesn't set errno then it's pukka.
! This should be faster than going atof and then thinking. */
! if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
! == IS_NUMBER_TO_INT_BY_STRTOL)
! && ((errno = 0), 1) /* always true */
! && ((u = Strtoul(num_begin, Null(char**), 10)), 1) /* ditto */
! && (errno == 0)
! /* If known to be negative, check it didn't undeflow IV
! XXX possibly we should put more negative values as NVs
! direct rather than go via atof below */
! && ((numtype & IS_NUMBER_NEG) ? (u <= (UV)IV_MIN) : 1)) {
! errno = save_errno;
! if (SvTYPE(sv) < SVt_PVIV)
! sv_upgrade(sv, SVt_PVIV);
! (void)SvIOK_on(sv);
!
! /* If it's negative must use IV.
! IV-over-UV optimisation */
! if (numtype & IS_NUMBER_NEG) {
! SvIVX(sv) = -(IV)u;
! } else if (u <= (UV) IV_MAX) {
! SvIVX(sv) = (IV)u;
} else {
/* it didn't overflow, and it was positive. */
! SvUVX(sv) = u;
SvIsUV_on(sv);
}
! } else
! #endif
! {
! NV d;
! #ifdef HAS_STRTOUL
! /* Hopefully trace flow will optimise this away where possible
! */
! errno = save_errno;
! #endif
! /* It wasn't an integer, or it overflowed, or we don't have
! strtol. Do things the slow way - check if it's a IV etc. */
! d = Atof(SvPVX(sv));
! if (SvTYPE(sv) < SVt_PVNV)
! sv_upgrade(sv, SVt_PVNV);
! SvNVX(sv) = d;
!
! if (! numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
#if defined(USE_LONG_DOUBLE)
! DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
! PTR2UV(sv), SvNVX(sv)));
#else
! DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
! PTR2UV(sv), SvNVX(sv)));
#endif
#ifdef NV_PRESERVES_UV
! (void)SvIOKp_on(sv);
! (void)SvNOK_on(sv);
! if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
! SvIVX(sv) = I_V(SvNVX(sv));
! if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
! SvIOK_on(sv);
! } else {
! /* Integer is imprecise. NOK, IOKp */
! }
! /* UV will not work better than IV */
! } else {
! if (SvNVX(sv) > (NV)UV_MAX) {
! SvIsUV_on(sv);
! /* Integer is inaccurate. NOK, IOKp, is UV */
! SvUVX(sv) = UV_MAX;
! SvIsUV_on(sv);
! } else {
! SvUVX(sv) = U_V(SvNVX(sv));
! /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
! NV preservse UV so can do correct comparison. */
! if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
! SvIOK_on(sv);
! SvIsUV_on(sv);
! } else {
! /* Integer is imprecise. NOK, IOKp, is UV */
! SvIsUV_on(sv);
! }
! }
! }
#else /* NV_PRESERVES_UV */
! if (((UV)1 << NV_PRESERVES_UV_BITS) >
! U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
! /* Small enough to preserve all bits. */
! (void)SvIOKp_on(sv);
! SvNOK_on(sv);
! SvIVX(sv) = I_V(SvNVX(sv));
! if ((NV)(SvIVX(sv)) == SvNVX(sv))
! SvIOK_on(sv);
! /* Assumption: first non-preserved integer is < IV_MAX,
! this NV is in the preserved range, therefore: */
! if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
! < (UV)IV_MAX)) {
! Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
! }
! } else
! sv_2iuv_non_preserve (sv, numtype);
#endif /* NV_PRESERVES_UV */
- }
}
}
else {
--- 2408,2535 ----
cache the NV if not needed.
*/
! /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
! if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
! == IS_NUMBER_IN_UV) {
! /* It's definitely an integer, only upgrade to PVIV */
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
(void)SvIOK_on(sv);
! } else if (SvTYPE(sv) < SVt_PVNV)
! sv_upgrade(sv, SVt_PVNV);
! /* If NV preserves UV then we only use the UV value if we know that
! we aren't going to call atof() below. If NVs don't preserve UVs
! then the value returned may have more precision than atof() will
! return, even though it isn't accurate. */
! if ((numtype & (IS_NUMBER_IN_UV
! #ifdef NV_PRESERVES_UV
! | IS_NUMBER_NOT_INT
! #endif
! )) == IS_NUMBER_IN_UV) {
! /* This won't turn off the public IOK flag if it was set above */
! (void)SvIOKp_on(sv);
! if (!(numtype & IS_NUMBER_NEG)) {
! /* positive */;
! if (value <= (UV)IV_MAX) {
! SvIVX(sv) = (IV)value;
} else {
/* it didn't overflow, and it was positive. */
! SvUVX(sv) = value;
SvIsUV_on(sv);
}
! } else {
! /* 2s complement assumption */
! if (value <= (UV)IV_MIN) {
! SvIVX(sv) = -(IV)value;
! } else {
! /* Too negative for an IV. This is a double upgrade, but
! I'm assuming it will be be rare. */
! if (SvTYPE(sv) < SVt_PVNV)
! sv_upgrade(sv, SVt_PVNV);
! SvNOK_on(sv);
! SvIOK_off(sv);
! SvIOKp_on(sv);
! SvNVX(sv) = -(NV)value;
! SvIVX(sv) = IV_MIN;
! }
! }
! }
!
! if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
! != IS_NUMBER_IN_UV) {
! /* It wasn't an integer, or it overflowed the UV. */
! SvNVX(sv) = Atof(SvPVX(sv));
! if (! numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
#if defined(USE_LONG_DOUBLE)
! DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
! PTR2UV(sv), SvNVX(sv)));
#else
! DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
! PTR2UV(sv), SvNVX(sv)));
#endif
#ifdef NV_PRESERVES_UV
! (void)SvIOKp_on(sv);
! (void)SvNOK_on(sv);
! if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
! SvIVX(sv) = I_V(SvNVX(sv));
! if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
! SvIOK_on(sv);
! } else {
! /* Integer is imprecise. NOK, IOKp */
! }
! /* UV will not work better than IV */
! } else {
! if (SvNVX(sv) > (NV)UV_MAX) {
! SvIsUV_on(sv);
! /* Integer is inaccurate. NOK, IOKp, is UV */
! SvUVX(sv) = UV_MAX;
! SvIsUV_on(sv);
! } else {
! SvUVX(sv) = U_V(SvNVX(sv));
! /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
! NV preservse UV so can do correct comparison. */
! if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
! SvIOK_on(sv);
! SvIsUV_on(sv);
! } else {
! /* Integer is imprecise. NOK, IOKp, is UV */
! SvIsUV_on(sv);
! }
! }
! }
#else /* NV_PRESERVES_UV */
! if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
! == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
! /* The UV slot will have been set from value returned by
! grok_number above. The NV slot has just been set using
! Atof. */
! SvNOK_on(sv);
! assert (SvIOKp(sv));
! } else {
! if (((UV)1 << NV_PRESERVES_UV_BITS) >
! U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
! /* Small enough to preserve all bits. */
! (void)SvIOKp_on(sv);
! SvNOK_on(sv);
! SvIVX(sv) = I_V(SvNVX(sv));
! if ((NV)(SvIVX(sv)) == SvNVX(sv))
! SvIOK_on(sv);
! /* Assumption: first non-preserved integer is < IV_MAX,
! this NV is in the preserved range, therefore: */
! if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
! < (UV)IV_MAX)) {
! Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
! }
! } else
! sv_2iuv_non_preserve (sv, numtype);
! }
#endif /* NV_PRESERVES_UV */
}
}
else {
***************
*** 2236,2241 ****
--- 2548,2563 ----
return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
}
+ /*
+ =for apidoc sv_2nv
+
+ Return the num value of an SV, doing any necessary string or integer
+ conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
+ macros.
+
+ =cut
+ */
+
NV
Perl_sv_2nv(pTHX_ register SV *sv)
{
***************
*** 2246,2252 ****
if (SvNOKp(sv))
return SvNVX(sv);
if (SvPOKp(sv) && SvLEN(sv)) {
! if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
return Atof(SvPVX(sv));
}
--- 2568,2575 ----
if (SvNOKp(sv))
return SvNVX(sv);
if (SvPOKp(sv) && SvLEN(sv)) {
! if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
! !grok_number(SvPVX(sv), SvCUR(sv), NULL))
not_a_number(sv);
return Atof(SvPVX(sv));
}
***************
*** 2268,2274 ****
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
! (SvRV(tmpstr) != SvRV(sv)))
return SvNV(tmpstr);
return PTR2NV(SvRV(sv));
}
--- 2591,2597 ----
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
! (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
return SvNV(tmpstr);
return PTR2NV(SvRV(sv));
}
***************
*** 2286,2292 ****
sv_upgrade(sv, SVt_PVNV);
else
sv_upgrade(sv, SVt_NV);
! #if defined(USE_LONG_DOUBLE)
DEBUG_c({
STORE_NUMERIC_LOCAL_SET_STANDARD();
PerlIO_printf(Perl_debug_log,
--- 2609,2615 ----
sv_upgrade(sv, SVt_PVNV);
else
sv_upgrade(sv, SVt_NV);
! #ifdef USE_LONG_DOUBLE
DEBUG_c({
STORE_NUMERIC_LOCAL_SET_STANDARD();
PerlIO_printf(Perl_debug_log,
***************
*** 2305,2313 ****
}
else if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
! if (SvIOKp(sv) &&
! (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
! {
SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
#ifdef NV_PRESERVES_UV
SvNOK_on(sv);
--- 2628,2637 ----
}
else if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
! if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) {
! SvNOK_on(sv);
! }
! else if (SvIOKp(sv)) {
SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
#ifdef NV_PRESERVES_UV
SvNOK_on(sv);
***************
*** 2322,2333 ****
#endif
}
else if (SvPOKp(sv) && SvLEN(sv)) {
! if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
- SvNVX(sv) = Atof(SvPVX(sv));
#ifdef NV_PRESERVES_UV
SvNOK_on(sv);
#else
/* Only set the public NV OK flag if this NV preserves the value in
the PV at least as well as an IV/UV would.
Not sure how to do this 100% reliably. */
--- 2646,2665 ----
#endif
}
else if (SvPOKp(sv) && SvLEN(sv)) {
! UV value;
! int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
! if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
not_a_number(sv);
#ifdef NV_PRESERVES_UV
+ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+ == IS_NUMBER_IN_UV) {
+ /* It's definitely an integer */
+ SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
+ } else
+ SvNVX(sv) = Atof(SvPVX(sv));
SvNOK_on(sv);
#else
+ SvNVX(sv) = Atof(SvPVX(sv));
/* Only set the public NV OK flag if this NV preserves the value in
the PV at least as well as an IV/UV would.
Not sure how to do this 100% reliably. */
***************
*** 2335,2359 ****
wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
UV_BITS */
if (((UV)1 << NV_PRESERVES_UV_BITS) >
! U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
SvNOK_on(sv); /* Definitely small enough to preserve all bits */
! else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
! /* Definitely too large/small to fit in an integer, so no loss
! of precision going to integer in the future via NV */
! SvNOK_on(sv);
! } else {
! /* Is it something we can run through strtol etc (ie no
! trailing exponent part)? */
! int numtype = looks_like_number(sv);
! /* XXX probably should cache this if called above */
! if (!(numtype &
! (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
! /* Can't use strtol etc to convert this string, so don't try */
! SvNOK_on(sv);
! } else
! sv_2inuv_non_preserve (sv, numtype);
! }
#endif /* NV_PRESERVES_UV */
}
else {
--- 2667,2732 ----
wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
UV_BITS */
if (((UV)1 << NV_PRESERVES_UV_BITS) >
! U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
SvNOK_on(sv); /* Definitely small enough to preserve all bits */
! } else if (!(numtype & IS_NUMBER_IN_UV)) {
! /* Can't use strtol etc to convert this string, so don't try.
! sv_2iv and sv_2uv will use the NV to convert, not the PV. */
! SvNOK_on(sv);
! } else {
! /* value has been set. It may not be precise. */
! if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
! /* 2s complement assumption for (UV)IV_MIN */
! SvNOK_on(sv); /* Integer is too negative. */
! } else {
! SvNOKp_on(sv);
! SvIOKp_on(sv);
! if (numtype & IS_NUMBER_NEG) {
! SvIVX(sv) = -(IV)value;
! } else if (value <= (UV)IV_MAX) {
! SvIVX(sv) = (IV)value;
! } else {
! SvUVX(sv) = value;
! SvIsUV_on(sv);
! }
!
! if (numtype & IS_NUMBER_NOT_INT) {
! /* I believe that even if the original PV had decimals,
! they are lost beyond the limit of the FP precision.
! However, neither is canonical, so both only get p
! flags. NWC, 2000/11/25 */
! /* Both already have p flags, so do nothing */
! } else {
! NV nv = SvNVX(sv);
! if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
! if (SvIVX(sv) == I_V(nv)) {
! SvNOK_on(sv);
! SvIOK_on(sv);
! } else {
! SvIOK_on(sv);
! /* It had no "." so it must be integer. */
! }
! } else {
! /* between IV_MAX and NV(UV_MAX).
! Could be slightly > UV_MAX */
!
! if (numtype & IS_NUMBER_NOT_INT) {
! /* UV and NV both imprecise. */
! } else {
! UV nv_as_uv = U_V(nv);
!
! if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
! SvNOK_on(sv);
! SvIOK_on(sv);
! } else {
! SvIOK_on(sv);
! }
! }
! }
! }
! }
! }
#endif /* NV_PRESERVES_UV */
}
else {
***************
*** 2384,2414 ****
return SvNVX(sv);
}
STATIC IV
S_asIV(pTHX_ SV *sv)
{
! I32 numtype = looks_like_number(sv);
! NV d;
! if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
! return Atol(SvPVX(sv));
if (!numtype) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
! d = Atof(SvPVX(sv));
! return I_V(d);
}
STATIC UV
S_asUV(pTHX_ SV *sv)
{
! I32 numtype = looks_like_number(sv);
! #ifdef HAS_STRTOUL
! if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
! return Strtoul(SvPVX(sv), Null(char**), 10);
! #endif
if (!numtype) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
--- 2757,2804 ----
return SvNVX(sv);
}
+ /* asIV(): extract an integer from the string value of an SV.
+ * Caller must validate PVX */
+
STATIC IV
S_asIV(pTHX_ SV *sv)
{
! UV value;
! int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
! if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
! == IS_NUMBER_IN_UV) {
! /* It's definitely an integer */
! if (numtype & IS_NUMBER_NEG) {
! if (value < (UV)IV_MIN)
! return -(IV)value;
! } else {
! if (value < (UV)IV_MAX)
! return (IV)value;
! }
! }
if (!numtype) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
! return I_V(Atof(SvPVX(sv)));
}
+ /* asUV(): extract an unsigned integer from the string value of an SV
+ * Caller must validate PVX */
+
STATIC UV
S_asUV(pTHX_ SV *sv)
{
! UV value;
! int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
! if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
! == IS_NUMBER_IN_UV) {
! /* It's definitely an integer */
! if (!(numtype & IS_NUMBER_NEG))
! return value;
! }
if (!numtype) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
***************
*** 2417,2611 ****
}
/*
! * Returns a combination of (advisory only - can get false negatives)
! * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
! * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
! * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
! * 0 if does not look like number.
! *
! * (atol and strtol stop when they hit a decimal point. strtol will return
! * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
! * do this, and vendors have had 11 years to get it right.
! * However, will try to make it still work with only atol
! *
! * IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
! * IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
! * IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
! * IS_NUMBER_LONGER_THAN_IV_MAX lots of digits, don't bother with atol
! * IS_NUMBER_AS_LONG_AS_IV_MAX atol might hit LONG_MAX, might not.
! * IS_NUMBER_NOT_INT saw "." or "e"
! * IS_NUMBER_NEG
! * IS_NUMBER_INFINITY
! */
! /*
! =for apidoc looks_like_number
!
! Test if an the content of an SV looks like a number (or is a
! number). C<Inf> and C<Infinity> are treated as numbers (so will not
! issue a non-numeric warning), even if your atof() doesn't grok them.
!
=cut
*/
- I32
- Perl_looks_like_number(pTHX_ SV *sv)
- {
- register char *s;
- register char *send;
- register char *sbegin;
- register char *nbegin;
- I32 numtype = 0;
- I32 sawinf = 0;
- STRLEN len;
- #ifdef USE_LOCALE_NUMERIC
- bool specialradix = FALSE;
- #endif
-
- if (SvPOK(sv)) {
- sbegin = SvPVX(sv);
- len = SvCUR(sv);
- }
- else if (SvPOKp(sv))
- sbegin = SvPV(sv, len);
- else
- return 1;
- send = sbegin + len;
-
- s = sbegin;
- while (isSPACE(*s))
- s++;
- if (*s == '-') {
- s++;
- numtype = IS_NUMBER_NEG;
- }
- else if (*s == '+')
- s++;
-
- nbegin = s;
- /*
- * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
- * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
- * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
- * will need (int)atof().
- */
-
- /* next must be digit or the radix separator or beginning of infinity */
- if (isDIGIT(*s)) {
- do {
- s++;
- } while (isDIGIT(*s));
-
- /* Aaargh. long long really is irritating.
- In the gospel according to ANSI 1989, it is an axiom that "long"
- is the longest integer type, and that if you don't know how long
- something is you can cast it to long, and nothing will be lost
- (except possibly speed of execution if long is slower than the
- type is was).
- Now, one can't be sure if the old rules apply, or long long
- (or some other newfangled thing) is actually longer than the
- (formerly) longest thing.
- */
- /* This lot will work for 64 bit *as long as* either
- either long is 64 bit
- or we can find both strtol/strtoq and strtoul/strtouq
- If not, we really should refuse to let the user use 64 bit IVs
- By "64 bit" I really mean IVs that don't get preserved by NVs
- It also should work for 128 bit IVs. Can any lend me a machine to
- test this?
- */
- if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
- numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
- else if (s - nbegin < BIT_DIGITS(((sizeof (IV)>sizeof (long))
- ? sizeof(long) : sizeof (IV))*8-1))
- numtype |= IS_NUMBER_TO_INT_BY_ATOL;
- else
- /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
- digit less (IV_MAX= 9223372036854775807,
- UV_MAX= 18446744073709551615) so be cautious */
- numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
-
- if (*s == '.'
- #ifdef USE_LOCALE_NUMERIC
- || (specialradix = IS_NUMERIC_RADIX(s))
- #endif
- ) {
- #ifdef USE_LOCALE_NUMERIC
- if (specialradix)
- s += SvCUR(PL_numeric_radix);
- else
- #endif
- s++;
- numtype |= IS_NUMBER_NOT_INT;
- while (isDIGIT(*s)) /* optional digits after the radix */
- s++;
- }
- }
- else if (*s == '.'
- #ifdef USE_LOCALE_NUMERIC
- || (specialradix = IS_NUMERIC_RADIX(s))
- #endif
- ) {
- #ifdef USE_LOCALE_NUMERIC
- if (specialradix)
- s += SvCUR(PL_numeric_radix);
- else
- #endif
- s++;
- numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
- /* no digits before the radix means we need digits after it */
- if (isDIGIT(*s)) {
- do {
- s++;
- } while (isDIGIT(*s));
- }
- else
- return 0;
- }
- else if (*s == 'I' || *s == 'i') {
- s++; if (*s != 'N' && *s != 'n') return 0;
- s++; if (*s != 'F' && *s != 'f') return 0;
- s++; if (*s == 'I' || *s == 'i') {
- s++; if (*s != 'N' && *s != 'n') return 0;
- s++; if (*s != 'I' && *s != 'i') return 0;
- s++; if (*s != 'T' && *s != 't') return 0;
- s++; if (*s != 'Y' && *s != 'y') return 0;
- s++;
- }
- sawinf = 1;
- }
- else
- return 0;
-
- if (sawinf)
- numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign */
- | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
- else {
- /* we can have an optional exponent part */
- if (*s == 'e' || *s == 'E') {
- numtype &= IS_NUMBER_NEG;
- numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
- s++;
- if (*s == '+' || *s == '-')
- s++;
- if (isDIGIT(*s)) {
- do {
- s++;
- } while (isDIGIT(*s));
- }
- else
- return 0;
- }
- }
- while (isSPACE(*s))
- s++;
- if (s >= send)
- return numtype;
- if (len == 10 && memEQ(sbegin, "0 but true", 10))
- return IS_NUMBER_TO_INT_BY_ATOL;
- return 0;
- }
-
char *
Perl_sv_2pv_nolen(pTHX_ register SV *sv)
{
--- 2807,2819 ----
}
/*
! =for apidoc sv_2pv_nolen
! Like C<sv_2pv()>, but doesn't return the length too. You should usually
! use the macro wrapper C<SvPV_nolen(sv)> instead.
=cut
*/
char *
Perl_sv_2pv_nolen(pTHX_ register SV *sv)
{
***************
*** 2613,2619 ****
return sv_2pv(sv, &n_a);
}
! /* We assume that buf is at least TYPE_CHARS(UV) long. */
static char *
uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
{
--- 2821,2833 ----
return sv_2pv(sv, &n_a);
}
! /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
! * UV as a string towards the end of buf, and return pointers to start and
! * end of it.
! *
! * We assume that buf is at least TYPE_CHARS(UV) long.
! */
!
static char *
uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
{
***************
*** 2639,2647 ****
--- 2853,2883 ----
return ptr;
}
+ /* For backwards-compatibility only. sv_2pv() is normally #def'ed to
+ * C<sv_2pv_macro()>. See also C<sv_2pv_flags()>.
+ */
+
char *
Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
{
+ return sv_2pv_flags(sv, lp, SV_GMAGIC);
+ }
+
+ /*
+ =for apidoc sv_2pv_flags
+
+ Returns a pointer to the string value of an SV, and sets *lp to its length.
+ If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
+ if necessary.
+ Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
+ usually end up here too.
+
+ =cut
+ */
+
+ char *
+ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
+ {
register char *s;
int olderrno;
SV *tsv;
***************
*** 2653,2659 ****
return "";
}
if (SvGMAGICAL(sv)) {
! mg_get(sv);
if (SvPOKp(sv)) {
*lp = SvCUR(sv);
return SvPVX(sv);
--- 2889,2896 ----
return "";
}
if (SvGMAGICAL(sv)) {
! if (flags & SV_GMAGIC)
! mg_get(sv);
if (SvPOKp(sv)) {
*lp = SvCUR(sv);
return SvPVX(sv);
***************
*** 2684,2690 ****
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
! (SvRV(tmpstr) != SvRV(sv)))
return SvPV(tmpstr,*lp);
sv = (SV*)SvRV(sv);
if (!sv)
--- 2921,2927 ----
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
! (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
return SvPV(tmpstr,*lp);
sv = (SV*)SvRV(sv);
if (!sv)
***************
*** 2698,2704 ****
(SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
== (SVs_OBJECT|SVs_RMG))
&& strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
! && (mg = mg_find(sv, 'r'))) {
regexp *re = (regexp *)mg->mg_obj;
if (!mg->mg_ptr) {
--- 2935,2941 ----
(SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
== (SVs_OBJECT|SVs_RMG))
&& strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
! && (mg = mg_find(sv, PERL_MAGIC_qr))) {
regexp *re = (regexp *)mg->mg_obj;
if (!mg->mg_ptr) {
***************
*** 2884,2889 ****
--- 3121,3137 ----
}
}
+ /*
+ =for apidoc sv_2pvbyte_nolen
+
+ Return a pointer to the byte-encoded representation of the SV.
+ May cause the SV to be downgraded from UTF8 as a side-effect.
+
+ Usually accessed via the C<SvPVbyte_nolen> macro.
+
+ =cut
+ */
+
char *
Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
{
***************
*** 2891,2896 ****
--- 3139,3156 ----
return sv_2pvbyte(sv, &n_a);
}
+ /*
+ =for apidoc sv_2pvbyte
+
+ Return a pointer to the byte-encoded representation of the SV, and set *lp
+ to its length. May cause the SV to be downgraded from UTF8 as a
+ side-effect.
+
+ Usually accessed via the C<SvPVbyte> macro.
+
+ =cut
+ */
+
char *
Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
{
***************
*** 2898,2903 ****
--- 3158,3174 ----
return SvPV(sv,*lp);
}
+ /*
+ =for apidoc sv_2pvutf8_nolen
+
+ Return a pointer to the UTF8-encoded representation of the SV.
+ May cause the SV to be upgraded to UTF8 as a side-effect.
+
+ Usually accessed via the C<SvPVutf8_nolen> macro.
+
+ =cut
+ */
+
char *
Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
{
***************
*** 2905,2910 ****
--- 3176,3192 ----
return sv_2pvutf8(sv, &n_a);
}
+ /*
+ =for apidoc sv_2pvutf8
+
+ Return a pointer to the UTF8-encoded representation of the SV, and set *lp
+ to its length. May cause the SV to be upgraded to UTF8 as a side-effect.
+
+ Usually accessed via the C<SvPVutf8> macro.
+
+ =cut
+ */
+
char *
Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
{
***************
*** 2912,2918 ****
return SvPV(sv,*lp);
}
! /* This function is only called on magical items */
bool
Perl_sv_2bool(pTHX_ register SV *sv)
{
--- 3194,3208 ----
return SvPV(sv,*lp);
}
! /*
! =for apidoc sv_2bool
!
! This function is only called on magical items, and is only used by
! sv_true() or its macro equivalent.
!
! =cut
! */
!
bool
Perl_sv_2bool(pTHX_ register SV *sv)
{
***************
*** 2924,2930 ****
if (SvROK(sv)) {
SV* tmpsv;
if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
! (SvRV(tmpsv) != SvRV(sv)))
return SvTRUE(tmpsv);
return SvRV(sv) != 0;
}
--- 3214,3220 ----
if (SvROK(sv)) {
SV* tmpsv;
if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
! (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
return SvTRUE(tmpsv);
return SvRV(sv) != 0;
}
***************
*** 2954,2960 ****
=for apidoc sv_utf8_upgrade
Convert the PV of an SV to its UTF8-encoded form.
! Forces the SV to string form it it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
if all the bytes have hibit clear.
--- 3244,3250 ----
=for apidoc sv_utf8_upgrade
Convert the PV of an SV to its UTF8-encoded form.
! Forces the SV to string form if it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
if all the bytes have hibit clear.
***************
*** 2964,2969 ****
--- 3254,3278 ----
STRLEN
Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
{
+ return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
+ }
+
+ /*
+ =for apidoc sv_utf8_upgrade_flags
+
+ Convert the PV of an SV to its UTF8-encoded form.
+ Forces the SV to string form if it is not already.
+ Always sets the SvUTF8 flag to avoid future validity checks even
+ if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
+ will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
+ C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
+
+ =cut
+ */
+
+ STRLEN
+ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
+ {
U8 *s, *t, *e;
int hibit = 0;
***************
*** 2972,2978 ****
if (!SvPOK(sv)) {
STRLEN len = 0;
! (void) sv_2pv(sv,&len);
if (!SvPOK(sv))
return len;
}
--- 3281,3287 ----
if (!SvPOK(sv)) {
STRLEN len = 0;
! (void) sv_2pv_flags(sv,&len, flags);
if (!SvPOK(sv))
return len;
}
***************
*** 3037,3043 ****
if (fail_ok)
return FALSE;
#ifdef USE_BYTES_DOWNGRADES
! else if (IN_BYTE) {
U8 *d = s;
U8 *e = (U8 *) SvEND(sv);
int first = 1;
--- 3346,3352 ----
if (fail_ok)
return FALSE;
#ifdef USE_BYTES_DOWNGRADES
! else if (IN_BYTES) {
U8 *d = s;
U8 *e = (U8 *) SvEND(sv);
int first = 1;
***************
*** 3094,3107 ****
=for apidoc sv_utf8_decode
Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
! turn of SvUTF8 if needed so that we see characters. Used as a building block
for decode_utf8 in Encode.xs
=cut
*/
-
-
bool
Perl_sv_utf8_decode(pTHX_ register SV *sv)
{
--- 3403,3414 ----
=for apidoc sv_utf8_decode
Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
! turn off SvUTF8 if needed so that we see characters. Used as a building block
for decode_utf8 in Encode.xs
=cut
*/
bool
Perl_sv_utf8_decode(pTHX_ register SV *sv)
{
***************
*** 3109,3116 ****
U8 *c;
U8 *e;
! /* The octets may have got themselves encoded - get them back as bytes */
! if (!sv_utf8_downgrade(sv, TRUE))
return FALSE;
/* it is actually just a matter of turning the utf8 flag on, but
--- 3416,3425 ----
U8 *c;
U8 *e;
! /* The octets may have got themselves encoded - get them back as
! * bytes
! */
! if (!sv_utf8_downgrade(sv, TRUE))
return FALSE;
/* it is actually just a matter of turning the utf8 flag on, but
***************
*** 3131,3156 ****
return TRUE;
}
-
- /* Note: sv_setsv() should not be called with a source string that needs
- * to be reused, since it may destroy the source string if it is marked
- * as temporary.
- */
-
/*
=for apidoc sv_setsv
! Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
! The source SV may be destroyed if it is mortal. Does not handle 'set'
! magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
! C<sv_setsv_mg>.
=cut
*/
void
Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
{
register U32 sflags;
register int dtype;
register int stype;
--- 3440,3496 ----
return TRUE;
}
/*
=for apidoc sv_setsv
! Copies the contents of the source SV C<ssv> into the destination SV
! C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
! function if the source SV needs to be reused. Does not handle 'set' magic.
! Loosely speaking, it performs a copy-by-value, obliterating any previous
! content of the destination.
+ You probably want to use one of the assortment of wrappers, such as
+ C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
+ C<SvSetMagicSV_nosteal>.
+
+
=cut
*/
+ /* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
+ for binary compatibility only
+ */
void
Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
{
+ sv_setsv_flags(dstr, sstr, SV_GMAGIC);
+ }
+
+ /*
+ =for apidoc sv_setsv_flags
+
+ Copies the contents of the source SV C<ssv> into the destination SV
+ C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
+ function if the source SV needs to be reused. Does not handle 'set' magic.
+ Loosely speaking, it performs a copy-by-value, obliterating any previous
+ content of the destination.
+ If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
+ C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
+ implemented in terms of this function.
+
+ You probably want to use one of the assortment of wrappers, such as
+ C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
+ C<SvSetMagicSV_nosteal>.
+
+ This is the primary function for copying scalars, and most other
+ copy-ish functions and macros use this underneath.
+
+ =cut
+ */
+
+ void
+ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
+ {
register U32 sflags;
register int dtype;
register int stype;
***************
*** 3269,3275 ****
char *name = GvNAME(sstr);
STRLEN len = GvNAMELEN(sstr);
sv_upgrade(dstr, SVt_PVGV);
! sv_magic(dstr, dstr, '*', Nullch, 0);
GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
GvNAME(dstr) = savepvn(name, len);
GvNAMELEN(dstr) = len;
--- 3609,3615 ----
char *name = GvNAME(sstr);
STRLEN len = GvNAMELEN(sstr);
sv_upgrade(dstr, SVt_PVGV);
! sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
GvNAME(dstr) = savepvn(name, len);
GvNAMELEN(dstr) = len;
***************
*** 3281,3288 ****
Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
GvNAME(dstr));
! #ifdef GV_SHARED_CHECK
! if (GvSHARED((GV*)dstr)) {
Perl_croak(aTHX_ PL_no_modify);
}
#endif
--- 3621,3628 ----
Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
GvNAME(dstr));
! #ifdef GV_UNIQUE_CHECK
! if (GvUNIQUE((GV*)dstr)) {
Perl_croak(aTHX_ PL_no_modify);
}
#endif
***************
*** 3304,3310 ****
/* FALL THROUGH */
default:
! if (SvGMAGICAL(sstr)) {
mg_get(sstr);
if (SvTYPE(sstr) != stype) {
stype = SvTYPE(sstr);
--- 3644,3650 ----
/* FALL THROUGH */
default:
! if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
mg_get(sstr);
if (SvTYPE(sstr) != stype) {
stype = SvTYPE(sstr);
***************
*** 3327,3345 ****
SV *dref = 0;
int intro = GvINTRO(dstr);
! #ifdef GV_SHARED_CHECK
! if (GvSHARED((GV*)dstr)) {
Perl_croak(aTHX_ PL_no_modify);
}
#endif
if (intro) {
- GP *gp;
- gp_free((GV*)dstr);
GvINTRO_off(dstr); /* one-shot flag */
- Newz(602,gp, 1, GP);
- GvGP(dstr) = gp_ref(gp);
- GvSV(dstr) = NEWSV(72,0);
GvLINE(dstr) = CopLINE(PL_curcop);
GvEGV(dstr) = (GV*)dstr;
}
--- 3667,3680 ----
SV *dref = 0;
int intro = GvINTRO(dstr);
! #ifdef GV_UNIQUE_CHECK
! if (GvUNIQUE((GV*)dstr)) {
Perl_croak(aTHX_ PL_no_modify);
}
#endif
if (intro) {
GvINTRO_off(dstr); /* one-shot flag */
GvLINE(dstr) = CopLINE(PL_curcop);
GvEGV(dstr) = (GV*)dstr;
}
***************
*** 3500,3506 ****
SvREFCNT(sstr) == 1 && /* and no other references to it? */
!(sflags & SVf_OOK) && /* and not involved in OOK hack? */
SvLEN(sstr) && /* and really is a string */
! !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
{
if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
if (SvOOK(dstr)) {
--- 3835,3842 ----
SvREFCNT(sstr) == 1 && /* and no other references to it? */
!(sflags & SVf_OOK) && /* and not involved in OOK hack? */
SvLEN(sstr) && /* and really is a string */
! /* and won't be needed again, potentially */
! !(PL_op && PL_op->op_type == OP_AASSIGN))
{
if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
if (SvOOK(dstr)) {
***************
*** 3516,3531 ****
SvCUR_set(dstr, SvCUR(sstr));
SvTEMP_off(dstr);
! (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
SvPV_set(sstr, Nullch);
SvLEN_set(sstr, 0);
SvCUR_set(sstr, 0);
SvTEMP_off(sstr);
}
! else { /* have to copy actual string */
STRLEN len = SvCUR(sstr);
! SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
Move(SvPVX(sstr),SvPVX(dstr),len,char);
SvCUR_set(dstr, len);
*SvEND(dstr) = '\0';
--- 3852,3867 ----
SvCUR_set(dstr, SvCUR(sstr));
SvTEMP_off(dstr);
! (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
SvPV_set(sstr, Nullch);
SvLEN_set(sstr, 0);
SvCUR_set(sstr, 0);
SvTEMP_off(sstr);
}
! else { /* have to copy actual string */
STRLEN len = SvCUR(sstr);
! SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
Move(SvPVX(sstr),SvPVX(dstr),len,char);
SvCUR_set(dstr, len);
*SvEND(dstr) = '\0';
***************
*** 3626,3632 ****
else {
/* len is STRLEN which is unsigned, need to copy to signed */
IV iv = len;
! assert(iv >= 0);
}
(void)SvUPGRADE(sv, SVt_PV);
--- 3962,3969 ----
else {
/* len is STRLEN which is unsigned, need to copy to signed */
IV iv = len;
! if (iv < 0)
! Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
}
(void)SvUPGRADE(sv, SVt_PV);
***************
*** 3748,3753 ****
--- 4085,4101 ----
SvSETMAGIC(sv);
}
+ /*
+ =for apidoc sv_force_normal_flags
+
+ Undo various types of fakery on an SV: if the PV is a shared string, make
+ a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
+ an xpvmg. The C<flags> parameter gets passed to C<sv_unref_flags()>
+ when unrefing. C<sv_force_normal> calls this function with flags set to 0.
+
+ =cut
+ */
+
void
Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
{
***************
*** 3761,3767 ****
*SvEND(sv) = '\0';
SvFAKE_off(sv);
SvREADONLY_off(sv);
! unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
}
else if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
--- 4109,4115 ----
*SvEND(sv) = '\0';
SvFAKE_off(sv);
SvREADONLY_off(sv);
! unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
}
else if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
***************
*** 3772,3777 ****
--- 4120,4135 ----
sv_unglob(sv);
}
+ /*
+ =for apidoc sv_force_normal
+
+ Undo various types of fakery on an SV: if the PV is a shared string, make
+ a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
+ an xpvmg. See also C<sv_force_normal_flags>.
+
+ =cut
+ */
+
void
Perl_sv_force_normal(pTHX_ register SV *sv)
{
***************
*** 3784,3798 ****
Efficient removal of characters from the beginning of the string buffer.
SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
the string buffer. The C<ptr> becomes the first character of the adjusted
! string.
=cut
*/
void
! Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
!
!
{
register STRLEN delta;
--- 4142,4154 ----
Efficient removal of characters from the beginning of the string buffer.
SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
the string buffer. The C<ptr> becomes the first character of the adjusted
! string. Uses the "OOK hack".
=cut
*/
void
! Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
{
register STRLEN delta;
***************
*** 3832,3852 ****
=cut
*/
void
! Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
{
! STRLEN tlen;
! char *junk;
! junk = SvPV_force(sv, tlen);
! SvGROW(sv, tlen + len + 1);
! if (ptr == junk)
! ptr = SvPVX(sv);
! Move(ptr,SvPVX(sv)+tlen,len,char);
! SvCUR(sv) += len;
! *SvEND(sv) = '\0';
! (void)SvPOK_only_UTF8(sv); /* validate pointer */
! SvTAINT(sv);
}
/*
--- 4188,4230 ----
=cut
*/
+ /* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
+ for binary compatibility only
+ */
void
! Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
{
! sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
! }
! /*
! =for apidoc sv_catpvn_flags
!
! Concatenates the string onto the end of the string which is in the SV. The
! C<len> indicates number of bytes to copy. If the SV has the UTF8
! status set, then the bytes appended should be valid UTF8.
! If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
! appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
! in terms of this function.
!
! =cut
! */
!
! void
! Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
! {
! STRLEN dlen;
! char *dstr;
!
! dstr = SvPV_force_flags(dsv, dlen, flags);
! SvGROW(dsv, dlen + slen + 1);
! if (sstr == dstr)
! sstr = SvPVX(dsv);
! Move(sstr, SvPVX(dsv) + dlen, slen, char);
! SvCUR(dsv) += slen;
! *SvEND(dsv) = '\0';
! (void)SvPOK_only_UTF8(dsv); /* validate pointer */
! SvTAINT(dsv);
}
/*
***************
*** 3873,3908 ****
=cut */
void
! Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv)
{
char *spv;
STRLEN slen;
if (!ssv)
return;
if ((spv = SvPV(ssv, slen))) {
- bool dutf8 = DO_UTF8(dsv);
bool sutf8 = DO_UTF8(ssv);
! if (dutf8 == sutf8)
! sv_catpvn(dsv,spv,slen);
! else {
if (dutf8) {
/* Not modifying source SV, so taking a temporary copy. */
! SV* csv = sv_2mortal(newSVsv(ssv));
! char *cpv;
! STRLEN clen;
sv_utf8_upgrade(csv);
! cpv = SvPV(csv,clen);
! sv_catpvn(dsv,cpv,clen);
}
! else {
! sv_utf8_upgrade(dsv);
! sv_catpvn(dsv,spv,slen);
! SvUTF8_on(dsv); /* If dsv has no wide characters. */
! }
}
}
}
--- 4251,4302 ----
=cut */
+ /* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
+ for binary compatibility only
+ */
void
! Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
{
+ sv_catsv_flags(dstr, sstr, SV_GMAGIC);
+ }
+
+ /*
+ =for apidoc sv_catsv_flags
+
+ Concatenates the string from SV C<ssv> onto the end of the string in
+ SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
+ bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
+ and C<sv_catsv_nomg> are implemented in terms of this function.
+
+ =cut */
+
+ void
+ Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
+ {
char *spv;
STRLEN slen;
if (!ssv)
return;
if ((spv = SvPV(ssv, slen))) {
bool sutf8 = DO_UTF8(ssv);
+ bool dutf8;
! if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
! mg_get(dsv);
! dutf8 = DO_UTF8(dsv);
!
! if (dutf8 != sutf8) {
if (dutf8) {
/* Not modifying source SV, so taking a temporary copy. */
! SV* csv = sv_2mortal(newSVpvn(spv, slen));
sv_utf8_upgrade(csv);
! spv = SvPV(csv, slen);
}
! else
! sv_utf8_upgrade_nomg(dsv);
}
+ sv_catpvn_nomg(dsv, spv, slen);
}
}
***************
*** 3965,3970 ****
--- 4359,4374 ----
SvSETMAGIC(sv);
}
+ /*
+ =for apidoc newSV
+
+ Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
+ with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
+ macro.
+
+ =cut
+ */
+
SV *
Perl_newSV(pTHX_ STRLEN len)
{
***************
*** 3978,3990 ****
return sv;
}
- /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
-
/*
=for apidoc sv_magic
! Adds magic to an SV.
=cut
*/
--- 4382,4395 ----
return sv;
}
/*
=for apidoc sv_magic
! Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
! then adds a new magic item of type C<how> to the head of the magic list.
+ C<name> is assumed to contain an C<SV*> if C<(name && namelen == HEf_SVKEY)>
+
=cut
*/
***************
*** 3994,4005 ****
MAGIC* mg;
if (SvREADONLY(sv)) {
! if (PL_curcop != &PL_compiling && !strchr("gBf", how))
Perl_croak(aTHX_ PL_no_modify);
}
! if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
! if (how == 't')
mg->mg_len |= 1;
return;
}
--- 4399,4417 ----
MAGIC* mg;
if (SvREADONLY(sv)) {
! if (PL_curcop != &PL_compiling
! && how != PERL_MAGIC_regex_global
! && how != PERL_MAGIC_bm
! && how != PERL_MAGIC_fm
! && how != PERL_MAGIC_sv
! )
! {
Perl_croak(aTHX_ PL_no_modify);
+ }
}
! if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
! if (how == PERL_MAGIC_taint)
mg->mg_len |= 1;
return;
}
***************
*** 4011,4021 ****
mg->mg_moremagic = SvMAGIC(sv);
SvMAGIC(sv) = mg;
! /* Some magic sontains a reference loop, where the sv and object refer to
! each other. To prevent a avoid a reference loop that would prevent such
! objects being freed, we look for such loops and if we find one we avoid
incrementing the object refcount. */
! if (!obj || obj == sv || how == '#' || how == 'r' ||
(SvTYPE(obj) == SVt_PVGV &&
(GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
--- 4423,4435 ----
mg->mg_moremagic = SvMAGIC(sv);
SvMAGIC(sv) = mg;
! /* Some magic contains a reference loop, where the sv and object refer to
! each other. To avoid a reference loop that would prevent such objects
! being freed, we look for such loops and if we find one we avoid
incrementing the object refcount. */
! if (!obj || obj == sv ||
! how == PERL_MAGIC_arylen ||
! how == PERL_MAGIC_qr ||
(SvTYPE(obj) == SVt_PVGV &&
(GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
***************
*** 4037,4146 ****
}
switch (how) {
! case 0:
mg->mg_virtual = &PL_vtbl_sv;
break;
! case 'A':
mg->mg_virtual = &PL_vtbl_amagic;
break;
! case 'a':
mg->mg_virtual = &PL_vtbl_amagicelem;
break;
! case 'c':
mg->mg_virtual = &PL_vtbl_ovrld;
break;
! case 'B':
mg->mg_virtual = &PL_vtbl_bm;
break;
! case 'D':
mg->mg_virtual = &PL_vtbl_regdata;
break;
! case 'd':
mg->mg_virtual = &PL_vtbl_regdatum;
break;
! case 'E':
mg->mg_virtual = &PL_vtbl_env;
break;
! case 'f':
mg->mg_virtual = &PL_vtbl_fm;
break;
! case 'e':
mg->mg_virtual = &PL_vtbl_envelem;
break;
! case 'g':
mg->mg_virtual = &PL_vtbl_mglob;
break;
! case 'I':
mg->mg_virtual = &PL_vtbl_isa;
break;
! case 'i':
mg->mg_virtual = &PL_vtbl_isaelem;
break;
! case 'k':
mg->mg_virtual = &PL_vtbl_nkeys;
break;
! case 'L':
SvRMAGICAL_on(sv);
mg->mg_virtual = 0;
break;
! case 'l':
mg->mg_virtual = &PL_vtbl_dbline;
break;
#ifdef USE_THREADS
! case 'm':
mg->mg_virtual = &PL_vtbl_mutex;
break;
#endif /* USE_THREADS */
#ifdef USE_LOCALE_COLLATE
! case 'o':
mg->mg_virtual = &PL_vtbl_collxfrm;
break;
#endif /* USE_LOCALE_COLLATE */
! case 'P':
mg->mg_virtual = &PL_vtbl_pack;
break;
! case 'p':
! case 'q':
mg->mg_virtual = &PL_vtbl_packelem;
break;
! case 'r':
mg->mg_virtual = &PL_vtbl_regexp;
break;
! case 'S':
mg->mg_virtual = &PL_vtbl_sig;
break;
! case 's':
mg->mg_virtual = &PL_vtbl_sigelem;
break;
! case 't':
mg->mg_virtual = &PL_vtbl_taint;
mg->mg_len = 1;
break;
! case 'U':
mg->mg_virtual = &PL_vtbl_uvar;
break;
! case 'v':
mg->mg_virtual = &PL_vtbl_vec;
break;
! case 'x':
mg->mg_virtual = &PL_vtbl_substr;
break;
! case 'y':
mg->mg_virtual = &PL_vtbl_defelem;
break;
! case '*':
mg->mg_virtual = &PL_vtbl_glob;
break;
! case '#':
mg->mg_virtual = &PL_vtbl_arylen;
break;
! case '.':
mg->mg_virtual = &PL_vtbl_pos;
break;
! case '<':
mg->mg_virtual = &PL_vtbl_backref;
break;
! case '~': /* Reserved for use by extensions not perl internals. */
/* Useful for attaching extension internal data to perl vars. */
/* Note that multiple extensions may clash if magical scalars */
/* etc holding private data from one are passed to another. */
--- 4451,4561 ----
}
switch (how) {
! case PERL_MAGIC_sv:
mg->mg_virtual = &PL_vtbl_sv;
break;
! case PERL_MAGIC_overload:
mg->mg_virtual = &PL_vtbl_amagic;
break;
! case PERL_MAGIC_overload_elem:
mg->mg_virtual = &PL_vtbl_amagicelem;
break;
! case PERL_MAGIC_overload_table:
mg->mg_virtual = &PL_vtbl_ovrld;
break;
! case PERL_MAGIC_bm:
mg->mg_virtual = &PL_vtbl_bm;
break;
! case PERL_MAGIC_regdata:
mg->mg_virtual = &PL_vtbl_regdata;
break;
! case PERL_MAGIC_regdatum:
mg->mg_virtual = &PL_vtbl_regdatum;
break;
! case PERL_MAGIC_env:
mg->mg_virtual = &PL_vtbl_env;
break;
! case PERL_MAGIC_fm:
mg->mg_virtual = &PL_vtbl_fm;
break;
! case PERL_MAGIC_envelem:
mg->mg_virtual = &PL_vtbl_envelem;
break;
! case PERL_MAGIC_regex_global:
mg->mg_virtual = &PL_vtbl_mglob;
break;
! case PERL_MAGIC_isa:
mg->mg_virtual = &PL_vtbl_isa;
break;
! case PERL_MAGIC_isaelem:
mg->mg_virtual = &PL_vtbl_isaelem;
break;
! case PERL_MAGIC_nkeys:
mg->mg_virtual = &PL_vtbl_nkeys;
break;
! case PERL_MAGIC_dbfile:
SvRMAGICAL_on(sv);
mg->mg_virtual = 0;
break;
! case PERL_MAGIC_dbline:
mg->mg_virtual = &PL_vtbl_dbline;
break;
#ifdef USE_THREADS
! case PERL_MAGIC_mutex:
mg->mg_virtual = &PL_vtbl_mutex;
break;
#endif /* USE_THREADS */
#ifdef USE_LOCALE_COLLATE
! case PERL_MAGIC_collxfrm:
mg->mg_virtual = &PL_vtbl_collxfrm;
break;
#endif /* USE_LOCALE_COLLATE */
! case PERL_MAGIC_tied:
mg->mg_virtual = &PL_vtbl_pack;
break;
! case PERL_MAGIC_tiedelem:
! case PERL_MAGIC_tiedscalar:
mg->mg_virtual = &PL_vtbl_packelem;
break;
! case PERL_MAGIC_qr:
mg->mg_virtual = &PL_vtbl_regexp;
break;
! case PERL_MAGIC_sig:
mg->mg_virtual = &PL_vtbl_sig;
break;
! case PERL_MAGIC_sigelem:
mg->mg_virtual = &PL_vtbl_sigelem;
break;
! case PERL_MAGIC_taint:
mg->mg_virtual = &PL_vtbl_taint;
mg->mg_len = 1;
break;
! case PERL_MAGIC_uvar:
mg->mg_virtual = &PL_vtbl_uvar;
break;
! case PERL_MAGIC_vec:
mg->mg_virtual = &PL_vtbl_vec;
break;
! case PERL_MAGIC_substr:
mg->mg_virtual = &PL_vtbl_substr;
break;
! case PERL_MAGIC_defelem:
mg->mg_virtual = &PL_vtbl_defelem;
break;
! case PERL_MAGIC_glob:
mg->mg_virtual = &PL_vtbl_glob;
break;
! case PERL_MAGIC_arylen:
mg->mg_virtual = &PL_vtbl_arylen;
break;
! case PERL_MAGIC_pos:
mg->mg_virtual = &PL_vtbl_pos;
break;
! case PERL_MAGIC_backref:
mg->mg_virtual = &PL_vtbl_backref;
break;
! case PERL_MAGIC_ext:
! /* Reserved for use by extensions not perl internals. */
/* Useful for attaching extension internal data to perl vars. */
/* Note that multiple extensions may clash if magical scalars */
/* etc holding private data from one are passed to another. */
***************
*** 4147,4153 ****
SvRMAGICAL_on(sv);
break;
default:
! Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
}
mg_magical(sv);
if (SvGMAGICAL(sv))
--- 4562,4568 ----
SvRMAGICAL_on(sv);
break;
default:
! Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
}
mg_magical(sv);
if (SvGMAGICAL(sv))
***************
*** 4157,4163 ****
/*
=for apidoc sv_unmagic
! Removes magic from an SV.
=cut
*/
--- 4572,4578 ----
/*
=for apidoc sv_unmagic
! Removes all magic of type C<type> from an SV.
=cut
*/
***************
*** 4176,4182 ****
*mgp = mg->mg_moremagic;
if (vtbl && vtbl->svt_free)
CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
! if (mg->mg_ptr && mg->mg_type != 'g') {
if (mg->mg_len >= 0)
Safefree(mg->mg_ptr);
else if (mg->mg_len == HEf_SVKEY)
--- 4591,4597 ----
*mgp = mg->mg_moremagic;
if (vtbl && vtbl->svt_free)
CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
! if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
if (mg->mg_len >= 0)
Safefree(mg->mg_ptr);
else if (mg->mg_len == HEf_SVKEY)
***************
*** 4191,4197 ****
}
if (!SvMAGIC(sv)) {
SvMAGICAL_off(sv);
! SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
}
return 0;
--- 4606,4612 ----
}
if (!SvMAGIC(sv)) {
SvMAGICAL_off(sv);
! SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
}
return 0;
***************
*** 4200,4206 ****
/*
=for apidoc sv_rvweaken
! Weaken a reference.
=cut
*/
--- 4615,4624 ----
/*
=for apidoc sv_rvweaken
! Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
! referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
! push a back-reference to this RV onto the array of backreferences
! associated with that magic.
=cut
*/
***************
*** 4225,4245 ****
return sv;
}
STATIC void
S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
{
AV *av;
MAGIC *mg;
! if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
av = (AV*)mg->mg_obj;
else {
av = newAV();
! sv_magic(tsv, (SV*)av, '<', NULL, 0);
SvREFCNT_dec(av); /* for sv_magic */
}
av_push(av,sv);
}
STATIC void
S_sv_del_backref(pTHX_ SV *sv)
{
--- 4643,4671 ----
return sv;
}
+ /* Give tsv backref magic if it hasn't already got it, then push a
+ * back-reference to sv onto the array associated with the backref magic.
+ */
+
STATIC void
S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
{
AV *av;
MAGIC *mg;
! if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
av = (AV*)mg->mg_obj;
else {
av = newAV();
! sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
SvREFCNT_dec(av); /* for sv_magic */
}
av_push(av,sv);
}
+ /* delete a back-reference to ourselves from the backref magic associated
+ * with the SV we point to.
+ */
+
STATIC void
S_sv_del_backref(pTHX_ SV *sv)
{
***************
*** 4248,4254 ****
I32 i;
SV *tsv = SvRV(sv);
MAGIC *mg;
! if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
Perl_croak(aTHX_ "panic: del_backref");
av = (AV *)mg->mg_obj;
svp = AvARRAY(av);
--- 4674,4680 ----
I32 i;
SV *tsv = SvRV(sv);
MAGIC *mg;
! if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
Perl_croak(aTHX_ "panic: del_backref");
av = (AV *)mg->mg_obj;
svp = AvARRAY(av);
***************
*** 4359,4364 ****
--- 4785,4795 ----
=for apidoc sv_replace
Make the first argument a copy of the second, then delete the original.
+ The target SV physically takes over ownership of the body of the source SV
+ and inherits its flags; however, the target keeps any magic it owns,
+ and any magic in the source is discarded.
+ Note that this is a rather specialist SV copying operation; most of the
+ time you'll want to use C<sv_setsv> or one of its many macro front-ends.
=cut
*/
***************
*** 4392,4399 ****
/*
=for apidoc sv_clear
! Clear an SV, making it empty. Does not free the memory used by the SV
! itself.
=cut
*/
--- 4823,4835 ----
/*
=for apidoc sv_clear
! Clear an SV: call any destructors, free up any memory used by the body,
! and free the body itself. The SV's head is I<not> freed, although
! its type is set to all 1's so that it won't inadvertently be assumed
! to be live during global destruction etc.
! This function should only be called when REFCNT is zero. Most of the time
! you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
! instead.
=cut
*/
***************
*** 4454,4461 ****
--PL_sv_objcount; /* XXX Might want something more general */
}
}
! if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
! mg_free(sv);
stash = NULL;
switch (SvTYPE(sv)) {
case SVt_PVIO:
--- 4890,4901 ----
--PL_sv_objcount; /* XXX Might want something more general */
}
}
! if (SvTYPE(sv) >= SVt_PVMG) {
! if (SvMAGIC(sv))
! mg_free(sv);
! if (SvFLAGS(sv) & SVpad_TYPED)
! SvREFCNT_dec(SvSTASH(sv));
! }
stash = NULL;
switch (SvTYPE(sv)) {
case SVt_PVIO:
***************
*** 4514,4520 ****
else if (SvPVX(sv) && SvLEN(sv))
Safefree(SvPVX(sv));
else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
! unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
SvFAKE_off(sv);
}
break;
--- 4954,4962 ----
else if (SvPVX(sv) && SvLEN(sv))
Safefree(SvPVX(sv));
else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
! unsharepvn(SvPVX(sv),
! SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
! SvUVX(sv));
SvFAKE_off(sv);
}
break;
***************
*** 4585,4590 ****
--- 5027,5041 ----
SvFLAGS(sv) |= SVTYPEMASK;
}
+ /*
+ =for apidoc sv_newref
+
+ Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
+ instead.
+
+ =cut
+ */
+
SV *
Perl_sv_newref(pTHX_ SV *sv)
{
***************
*** 4596,4602 ****
/*
=for apidoc sv_free
! Free the memory used by an SV.
=cut
*/
--- 5047,5056 ----
/*
=for apidoc sv_free
! Decrement an SV's reference count, and if it drops to zero, call
! C<sv_clear> to invoke destructors and free up any memory used by
! the body; finally, deallocate the SV's head itself.
! Normally called via a wrapper macro C<SvREFCNT_dec>.
=cut
*/
***************
*** 4610,4615 ****
--- 5064,5071 ----
return;
if (SvREFCNT(sv) == 0) {
if (SvFLAGS(sv) & SVf_BREAK)
+ /* this SV's refcnt has been artificially decremented to
+ * trigger cleanup */
return;
if (PL_in_clean_all) /* All is fair */
return;
***************
*** 4647,4653 ****
/*
=for apidoc sv_len
! Returns the length of the string in the SV. See also C<SvCUR>.
=cut
*/
--- 5103,5110 ----
/*
=for apidoc sv_len
! Returns the length of the string in the SV. Handles magic and type
! coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
=cut
*/
***************
*** 4655,4661 ****
STRLEN
Perl_sv_len(pTHX_ register SV *sv)
{
- char *junk;
STRLEN len;
if (!sv)
--- 5112,5117 ----
***************
*** 4664,4670 ****
if (SvGMAGICAL(sv))
len = mg_length(sv);
else
! junk = SvPV(sv, len);
return len;
}
--- 5120,5126 ----
if (SvGMAGICAL(sv))
len = mg_length(sv);
else
! (void)SvPV(sv, len);
return len;
}
***************
*** 4672,4678 ****
=for apidoc sv_len_utf8
Returns the number of characters in the string in an SV, counting wide
! UTF8 bytes as a single character.
=cut
*/
--- 5128,5134 ----
=for apidoc sv_len_utf8
Returns the number of characters in the string in an SV, counting wide
! UTF8 bytes as a single character. Handles magic and type coercion.
=cut
*/
***************
*** 4694,4699 ****
--- 5150,5167 ----
}
}
+ /*
+ =for apidoc sv_pos_u2b
+
+ Converts the value pointed to by offsetp from a count of UTF8 chars from
+ the start of the string, to a count of the equivalent number of bytes; if
+ lenp is non-zero, it does the same to lenp, but this time starting from
+ the offset, rather than from the start of the string. Handles magic and
+ type coercion.
+
+ =cut
+ */
+
void
Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
{
***************
*** 4725,4730 ****
--- 5193,5208 ----
return;
}
+ /*
+ =for apidoc sv_pos_b2u
+
+ Converts the value pointed to by offsetp from a count of bytes from the
+ start of the string, to a count of the equivalent number of UTF8 chars.
+ Handles magic and type coercion.
+
+ =cut
+ */
+
void
Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
{
***************
*** 4759,4765 ****
=for apidoc sv_eq
Returns a boolean indicating whether the strings in the two SVs are
! identical.
=cut
*/
--- 5237,5244 ----
=for apidoc sv_eq
Returns a boolean indicating whether the strings in the two SVs are
! identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
! coerce its args to strings if necessary.
=cut
*/
***************
*** 4789,4799 ****
pv2 = SvPV(sv2, cur2);
/* do not utf8ize the comparands as a side-effect */
! if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
bool is_utf8 = TRUE;
/* UTF-8ness differs */
- if (PL_hints & HINT_UTF8_DISTINCT)
- return FALSE;
if (SvUTF8(sv1)) {
/* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
--- 5268,5276 ----
pv2 = SvPV(sv2, cur2);
/* do not utf8ize the comparands as a side-effect */
! if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
bool is_utf8 = TRUE;
/* UTF-8ness differs */
if (SvUTF8(sv1)) {
/* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
***************
*** 4827,4833 ****
Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
string in C<sv1> is less than, equal to, or greater than the string in
! C<sv2>.
=cut
*/
--- 5304,5311 ----
Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
string in C<sv1> is less than, equal to, or greater than the string in
! C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
! coerce its args to strings if necessary. See also C<sv_cmp_locale>.
=cut
*/
***************
*** 4856,4865 ****
pv2 = SvPV(sv2, cur2);
/* do not utf8ize the comparands as a side-effect */
! if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
! if (PL_hints & HINT_UTF8_DISTINCT)
! return SvUTF8(sv1) ? 1 : -1;
!
if (SvUTF8(sv1)) {
pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
pv2tmp = TRUE;
--- 5334,5340 ----
pv2 = SvPV(sv2, cur2);
/* do not utf8ize the comparands as a side-effect */
! if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
if (SvUTF8(sv1)) {
pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
pv2tmp = TRUE;
***************
*** 4897,4904 ****
/*
=for apidoc sv_cmp_locale
! Compares the strings in two SVs in a locale-aware manner. See
! L</sv_cmp_locale>
=cut
*/
--- 5372,5380 ----
/*
=for apidoc sv_cmp_locale
! Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
! 'use bytes' aware, handles get magic, and will coerce its args to strings
! if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
=cut
*/
***************
*** 4951,4969 ****
return sv_cmp(sv1, sv2);
}
#ifdef USE_LOCALE_COLLATE
/*
! * Any scalar variable may carry an 'o' magic that contains the
! * scalar data of the variable transformed to such a format that
! * a normal memory comparison can be used to compare the data
! * according to the locale settings.
! */
char *
Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
{
MAGIC *mg;
! mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
char *s, *xf;
STRLEN len, xlen;
--- 5427,5454 ----
return sv_cmp(sv1, sv2);
}
+
#ifdef USE_LOCALE_COLLATE
+
/*
! =for apidoc sv_collxfrm
!
! Add Collate Transform magic to an SV if it doesn't already have it.
!
! Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
! scalar data of the variable, but transformed to such a format that a normal
! memory comparison can be used to compare the data according to the locale
! settings.
!
! =cut
! */
!
char *
Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
{
MAGIC *mg;
! mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
char *s, *xf;
STRLEN len, xlen;
***************
*** 4978,4985 ****
return xf + sizeof(PL_collation_ix);
}
if (! mg) {
! sv_magic(sv, 0, 'o', 0, 0);
! mg = mg_find(sv, 'o');
assert(mg);
}
mg->mg_ptr = xf;
--- 5463,5470 ----
return xf + sizeof(PL_collation_ix);
}
if (! mg) {
! sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
! mg = mg_find(sv, PERL_MAGIC_collxfrm);
assert(mg);
}
mg->mg_ptr = xf;
***************
*** 5021,5027 ****
register STDCHAR rslast;
register STDCHAR *bp;
register I32 cnt;
! I32 i;
SV_CHECK_THINKFIRST(sv);
(void)SvUPGRADE(sv, SVt_PV);
--- 5506,5512 ----
register STDCHAR rslast;
register STDCHAR *bp;
register I32 cnt;
! I32 i = 0;
SV_CHECK_THINKFIRST(sv);
(void)SvUPGRADE(sv, SVt_PV);
***************
*** 5302,5312 ****
return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
}
-
/*
=for apidoc sv_inc
! Auto-increment of the value in the SV.
=cut
*/
--- 5787,5797 ----
return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
}
/*
=for apidoc sv_inc
! Auto-increment of the value in the SV, doing string to numeric conversion
! if necessary. Handles 'get' magic.
=cut
*/
***************
*** 5382,5388 ****
/* Got to punt this an an integer if needs be, but we don't issue
warnings. Probably ought to make the sv_iv_please() that does
the conversion if possible, and silently. */
! I32 numtype = looks_like_number(sv);
if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
/* Need to try really hard to see if it's an integer.
9.22337203685478e+18 is an integer.
--- 5867,5873 ----
/* Got to punt this an an integer if needs be, but we don't issue
warnings. Probably ought to make the sv_iv_please() that does
the conversion if possible, and silently. */
! int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
/* Need to try really hard to see if it's an integer.
9.22337203685478e+18 is an integer.
***************
*** 5458,5464 ****
/*
=for apidoc sv_dec
! Auto-decrement of the value in the SV.
=cut
*/
--- 5943,5950 ----
/*
=for apidoc sv_dec
! Auto-decrement of the value in the SV, doing string to numeric conversion
! if necessary. Handles 'get' magic.
=cut
*/
***************
*** 5525,5531 ****
}
#ifdef PERL_PRESERVE_IVUV
{
! I32 numtype = looks_like_number(sv);
if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
/* Need to try really hard to see if it's an integer.
9.22337203685478e+18 is an integer.
--- 6011,6017 ----
}
#ifdef PERL_PRESERVE_IVUV
{
! int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
/* Need to try really hard to see if it's an integer.
9.22337203685478e+18 is an integer.
***************
*** 5563,5570 ****
/*
=for apidoc sv_mortalcopy
! Creates a new SV which is a copy of the original SV. The new SV is marked
! as mortal.
=cut
*/
--- 6049,6057 ----
/*
=for apidoc sv_mortalcopy
! Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
! The new SV is marked as mortal. It will be destroyed when the current
! context ends. See also C<sv_newmortal> and C<sv_2mortal>.
=cut
*/
***************
*** 5590,5596 ****
/*
=for apidoc sv_newmortal
! Creates a new SV which is mortal. The reference count of the SV is set to 1.
=cut
*/
--- 6077,6085 ----
/*
=for apidoc sv_newmortal
! Creates a new null SV which is mortal. The reference count of the SV is
! set to 1. It will be destroyed when the current context ends. See
! also C<sv_mortalcopy> and C<sv_2mortal>.
=cut
*/
***************
*** 5610,5623 ****
/*
=for apidoc sv_2mortal
! Marks an SV as mortal. The SV will be destroyed when the current context
! ends.
=cut
*/
- /* same thing without the copying */
-
SV *
Perl_sv_2mortal(pTHX_ register SV *sv)
{
--- 6099,6110 ----
/*
=for apidoc sv_2mortal
! Marks an existing SV as mortal. The SV will be destroyed when the current
! context ends. See also C<sv_newmortal> and C<sv_mortalcopy>.
=cut
*/
SV *
Perl_sv_2mortal(pTHX_ register SV *sv)
{
***************
*** 5677,5687 ****
/*
=for apidoc newSVpvn_share
! Creates a new SV and populates it with a string from
! the string table. Turns on READONLY and FAKE.
! The idea here is that as string table is used for shared hash
! keys these strings will have SvPVX == HeKEY and hash lookup
! will avoid string compare.
=cut
*/
--- 6164,6176 ----
/*
=for apidoc newSVpvn_share
! Creates a new SV with its SvPVX pointing to a shared string in the string
! table. If the string does not already exist in the table, it is created
! first. Turns on READONLY and FAKE. The string's hash is stored in the UV
! slot of the SV; if the C<hash> parameter is non-zero, that value is used;
! otherwise the hash is computed. The idea here is that as the string table
! is used for shared hash keys these strings will have SvPVX == HeKEY and
! hash lookup will avoid string compare.
=cut
*/
***************
*** 5692,5702 ****
register SV *sv;
bool is_utf8 = FALSE;
if (len < 0) {
! len = -len;
is_utf8 = TRUE;
- }
- if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
- STRLEN tmplen = len;
/* See the note in hv.c:hv_fetch() --jhi */
src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
len = tmplen;
--- 6181,6188 ----
register SV *sv;
bool is_utf8 = FALSE;
if (len < 0) {
! STRLEN tmplen = -len;
is_utf8 = TRUE;
/* See the note in hv.c:hv_fetch() --jhi */
src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
len = tmplen;
***************
*** 5717,5723 ****
--- 6203,6216 ----
return sv;
}
+
#if defined(PERL_IMPLICIT_CONTEXT)
+
+ /* pTHX_ magic can't cope with varargs, so this is a no-context
+ * version of the main function, (which may itself be aliased to us).
+ * Don't access this version directly.
+ */
+
SV *
Perl_newSVpvf_nocontext(const char* pat, ...)
{
***************
*** 5734,5740 ****
/*
=for apidoc newSVpvf
! Creates a new SV an initialize it with the string formatted like
C<sprintf>.
=cut
--- 6227,6233 ----
/*
=for apidoc newSVpvf
! Creates a new SV and initializes it with the string formatted like
C<sprintf>.
=cut
***************
*** 5751,5756 ****
--- 6244,6251 ----
return sv;
}
+ /* backend for newSVpvf() and newSVpvf_nocontext() */
+
SV *
Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
{
***************
*** 5839,5845 ****
return sv;
}
! /* newRV_inc is #defined to newRV in sv.h */
SV *
Perl_newRV(pTHX_ SV *tmpRef)
{
--- 6334,6343 ----
return sv;
}
! /* newRV_inc is the official function name to use now.
! * newRV_inc is in fact #defined to newRV in sv.h
! */
!
SV *
Perl_newRV(pTHX_ SV *tmpRef)
{
***************
*** 5850,5861 ****
=for apidoc newSVsv
Creates a new SV which is an exact duplicate of the original SV.
=cut
*/
- /* make an exact duplicate of old */
-
SV *
Perl_newSVsv(pTHX_ register SV *old)
{
--- 6348,6358 ----
=for apidoc newSVsv
Creates a new SV which is an exact duplicate of the original SV.
+ (Uses C<sv_setsv>).
=cut
*/
SV *
Perl_newSVsv(pTHX_ register SV *old)
{
***************
*** 5879,5884 ****
--- 6376,6390 ----
return sv;
}
+ /*
+ =for apidoc sv_reset
+
+ Underlying implementation for the C<reset> Perl function.
+ Note that the perl-level function is vaguely deprecated.
+
+ =cut
+ */
+
void
Perl_sv_reset(pTHX_ register char *s, HV *stash)
{
***************
*** 5951,5956 ****
--- 6457,6472 ----
}
}
+ /*
+ =for apidoc sv_2io
+
+ Using various gambits, try to get an IO from an SV: the IO slot if its a
+ GV; or the recursive result if we're an RV; or the IO slot of the symbol
+ named after the PV if we're a string.
+
+ =cut
+ */
+
IO*
Perl_sv_2io(pTHX_ SV *sv)
{
***************
*** 5985,5990 ****
--- 6501,6515 ----
return io;
}
+ /*
+ =for apidoc sv_2cv
+
+ Using various gambits, try to get a CV from an SV; in addition, try if
+ possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
+
+ =cut
+ */
+
CV *
Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
{
***************
*** 6061,6066 ****
--- 6586,6593 ----
=for apidoc sv_true
Returns true if the SV has a true value by Perl's rules.
+ Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
+ instead use an in-line version.
=cut
*/
***************
*** 6091,6096 ****
--- 6618,6632 ----
}
}
+ /*
+ =for apidoc sv_iv
+
+ A private implementation of the C<SvIVx> macro for compilers which can't
+ cope with complex macro expressions. Always use the macro instead.
+
+ =cut
+ */
+
IV
Perl_sv_iv(pTHX_ register SV *sv)
{
***************
*** 6102,6107 ****
--- 6638,6652 ----
return sv_2iv(sv);
}
+ /*
+ =for apidoc sv_uv
+
+ A private implementation of the C<SvUVx> macro for compilers which can't
+ cope with complex macro expressions. Always use the macro instead.
+
+ =cut
+ */
+
UV
Perl_sv_uv(pTHX_ register SV *sv)
{
***************
*** 6113,6118 ****
--- 6658,6672 ----
return sv_2uv(sv);
}
+ /*
+ =for apidoc sv_nv
+
+ A private implementation of the C<SvNVx> macro for compilers which can't
+ cope with complex macro expressions. Always use the macro instead.
+
+ =cut
+ */
+
NV
Perl_sv_nv(pTHX_ register SV *sv)
{
***************
*** 6121,6126 ****
--- 6675,6689 ----
return sv_2nv(sv);
}
+ /*
+ =for apidoc sv_pv
+
+ A private implementation of the C<SvPV_nolen> macro for compilers which can't
+ cope with complex macro expressions. Always use the macro instead.
+
+ =cut
+ */
+
char *
Perl_sv_pv(pTHX_ SV *sv)
{
***************
*** 6132,6137 ****
--- 6695,6709 ----
return sv_2pv(sv, &n_a);
}
+ /*
+ =for apidoc sv_pvn
+
+ A private implementation of the C<SvPV> macro for compilers which can't
+ cope with complex macro expressions. Always use the macro instead.
+
+ =cut
+ */
+
char *
Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
{
***************
*** 6146,6151 ****
--- 6718,6725 ----
=for apidoc sv_pvn_force
Get a sensible string out of the SV somehow.
+ A private implementation of the C<SvPV_force> macro for compilers which
+ can't cope with complex macro expressions. Always use the macro instead.
=cut
*/
***************
*** 6153,6158 ****
--- 6727,6751 ----
char *
Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
{
+ return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
+ }
+
+ /*
+ =for apidoc sv_pvn_force_flags
+
+ Get a sensible string out of the SV somehow.
+ If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
+ appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
+ implemented in terms of this function.
+ You normally want to use the various wrapper macros instead: see
+ C<SvPV_force> and C<SvPV_force_nomg>
+
+ =cut
+ */
+
+ char *
+ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
+ {
char *s;
if (SvTHINKFIRST(sv) && !SvROK(sv))
***************
*** 6167,6173 ****
PL_op_name[PL_op->op_type]);
}
else
! s = sv_2pv(sv, lp);
if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
STRLEN len = *lp;
--- 6760,6766 ----
PL_op_name[PL_op->op_type]);
}
else
! s = sv_2pv_flags(sv, lp, flags);
if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
STRLEN len = *lp;
***************
*** 6189,6194 ****
--- 6782,6797 ----
return SvPVX(sv);
}
+ /*
+ =for apidoc sv_pvbyte
+
+ A private implementation of the C<SvPVbyte_nolen> macro for compilers
+ which can't cope with complex macro expressions. Always use the macro
+ instead.
+
+ =cut
+ */
+
char *
Perl_sv_pvbyte(pTHX_ SV *sv)
{
***************
*** 6196,6201 ****
--- 6799,6814 ----
return sv_pv(sv);
}
+ /*
+ =for apidoc sv_pvbyten
+
+ A private implementation of the C<SvPVbyte> macro for compilers
+ which can't cope with complex macro expressions. Always use the macro
+ instead.
+
+ =cut
+ */
+
char *
Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
{
***************
*** 6203,6208 ****
--- 6816,6831 ----
return sv_pvn(sv,lp);
}
+ /*
+ =for apidoc sv_pvbyten_force
+
+ A private implementation of the C<SvPVbytex_force> macro for compilers
+ which can't cope with complex macro expressions. Always use the macro
+ instead.
+
+ =cut
+ */
+
char *
Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
{
***************
*** 6210,6215 ****
--- 6833,6848 ----
return sv_pvn_force(sv,lp);
}
+ /*
+ =for apidoc sv_pvutf8
+
+ A private implementation of the C<SvPVutf8_nolen> macro for compilers
+ which can't cope with complex macro expressions. Always use the macro
+ instead.
+
+ =cut
+ */
+
char *
Perl_sv_pvutf8(pTHX_ SV *sv)
{
***************
*** 6217,6222 ****
--- 6850,6865 ----
return sv_pv(sv);
}
+ /*
+ =for apidoc sv_pvutf8n
+
+ A private implementation of the C<SvPVutf8> macro for compilers
+ which can't cope with complex macro expressions. Always use the macro
+ instead.
+
+ =cut
+ */
+
char *
Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
{
***************
*** 6227,6234 ****
/*
=for apidoc sv_pvutf8n_force
! Get a sensible UTF8-encoded string out of the SV somehow. See
! L</sv_pvn_force>.
=cut
*/
--- 6870,6878 ----
/*
=for apidoc sv_pvutf8n_force
! A private implementation of the C<SvPVutf8_force> macro for compilers
! which can't cope with complex macro expressions. Always use the macro
! instead.
=cut
*/
***************
*** 6530,6535 ****
--- 7174,7185 ----
return sv;
}
+ /* Downgrades a PVGV to a PVMG.
+ *
+ * XXX This function doesn't actually appear to be used anywhere
+ * DAPM 15-Jun-01
+ */
+
STATIC void
S_sv_unglob(pTHX_ SV *sv)
{
***************
*** 6543,6549 ****
SvREFCNT_dec(GvSTASH(sv));
GvSTASH(sv) = Nullhv;
}
! sv_unmagic(sv, '*');
Safefree(GvNAME(sv));
GvMULTI_off(sv);
--- 7193,7199 ----
SvREFCNT_dec(GvSTASH(sv));
GvSTASH(sv) = Nullhv;
}
! sv_unmagic(sv, PERL_MAGIC_glob);
Safefree(GvNAME(sv));
GvMULTI_off(sv);
***************
*** 6607,6633 ****
sv_unref_flags(sv, 0);
}
void
Perl_sv_taint(pTHX_ SV *sv)
{
! sv_magic((sv), Nullsv, 't', Nullch, 0);
}
void
Perl_sv_untaint(pTHX_ SV *sv)
{
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
! MAGIC *mg = mg_find(sv, 't');
if (mg)
mg->mg_len &= ~1;
}
}
bool
Perl_sv_tainted(pTHX_ SV *sv)
{
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
! MAGIC *mg = mg_find(sv, 't');
if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
return TRUE;
}
--- 7257,7304 ----
sv_unref_flags(sv, 0);
}
+ /*
+ =for apidoc sv_taint
+
+ Taint an SV. Use C<SvTAINTED_on> instead.
+ =cut
+ */
+
void
Perl_sv_taint(pTHX_ SV *sv)
{
! sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
}
+ /*
+ =for apidoc sv_untaint
+
+ Untaint an SV. Use C<SvTAINTED_off> instead.
+ =cut
+ */
+
void
Perl_sv_untaint(pTHX_ SV *sv)
{
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
! MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
if (mg)
mg->mg_len &= ~1;
}
}
+ /*
+ =for apidoc sv_tainted
+
+ Test an SV for taintedness. Use C<SvTAINTED> instead.
+ =cut
+ */
+
bool
Perl_sv_tainted(pTHX_ SV *sv)
{
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
! MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
return TRUE;
}
***************
*** 6653,6659 ****
sv_setpvn(sv, ptr, ebuf - ptr);
}
-
/*
=for apidoc sv_setpviv_mg
--- 7324,7329 ----
***************
*** 6674,6679 ****
--- 7344,7355 ----
}
#if defined(PERL_IMPLICIT_CONTEXT)
+
+ /* pTHX_ magic can't cope with varargs, so this is a no-context
+ * version of the main function, (which may itself be aliased to us).
+ * Don't access this version directly.
+ */
+
void
Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
{
***************
*** 6684,6689 ****
--- 7360,7369 ----
va_end(args);
}
+ /* pTHX_ magic can't cope with varargs, so this is a no-context
+ * version of the main function, (which may itself be aliased to us).
+ * Don't access this version directly.
+ */
void
Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
***************
*** 6714,6719 ****
--- 7394,7401 ----
va_end(args);
}
+ /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
+
void
Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
{
***************
*** 6737,6742 ****
--- 7419,7426 ----
va_end(args);
}
+ /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
+
void
Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
{
***************
*** 6745,6750 ****
--- 7429,7440 ----
}
#if defined(PERL_IMPLICIT_CONTEXT)
+
+ /* pTHX_ magic can't cope with varargs, so this is a no-context
+ * version of the main function, (which may itself be aliased to us).
+ * Don't access this version directly.
+ */
+
void
Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
{
***************
*** 6755,6760 ****
--- 7445,7455 ----
va_end(args);
}
+ /* pTHX_ magic can't cope with varargs, so this is a no-context
+ * version of the main function, (which may itself be aliased to us).
+ * Don't access this version directly.
+ */
+
void
Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
{
***************
*** 6788,6793 ****
--- 7483,7490 ----
va_end(args);
}
+ /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
+
void
Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
{
***************
*** 6811,6816 ****
--- 7508,7515 ----
va_end(args);
}
+ /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
+
void
Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
{
***************
*** 6824,6829 ****
--- 7523,7530 ----
Works like C<vcatpvfn> but copies the text into the SV instead of
appending it.
+ Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
+
=cut
*/
***************
*** 6834,6839 ****
--- 7535,7542 ----
sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
}
+ /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
+
STATIC I32
S_expect_number(pTHX_ char** pattern)
{
***************
*** 6858,6863 ****
--- 7561,7568 ----
C<maybe_tainted> if results are untrustworthy (often due to the use of
locales).
+ Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
+
=cut
*/
***************
*** 6870,6876 ****
STRLEN origlen;
I32 svix = 0;
static char nullstr[] = "(null)";
! SV *argsv;
/* no matter what, this is a string now */
(void)SvPV_force(sv, origlen);
--- 7575,7581 ----
STRLEN origlen;
I32 svix = 0;
static char nullstr[] = "(null)";
! SV *argsv = Nullsv;
/* no matter what, this is a string now */
(void)SvPV_force(sv, origlen);
***************
*** 6938,6944 ****
STRLEN veclen = 0;
char c;
int i;
! unsigned base;
IV iv;
UV uv;
NV nv;
--- 7643,7649 ----
STRLEN veclen = 0;
char c;
int i;
! unsigned base = 0;
IV iv;
UV uv;
NV nv;
***************
*** 7078,7084 ****
q++;
if (*q == '*') {
q++;
! if (EXPECT_NUMBER(q, epix) && *q++ != '$')
goto unknown;
if (args)
i = va_arg(*args, int);
--- 7783,7789 ----
q++;
if (*q == '*') {
q++;
! if (EXPECT_NUMBER(q, epix) && *q++ != '$') /* epix currently unused */
goto unknown;
if (args)
i = va_arg(*args, int);
***************
*** 7144,7150 ****
uv = args ? va_arg(*args, int) : SvIVx(argsv);
if ((uv > 255 ||
(!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
! && !IN_BYTE) {
eptr = (char*)utf8buf;
elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
is_utf = TRUE;
--- 7849,7855 ----
uv = args ? va_arg(*args, int) : SvIVx(argsv);
if ((uv > 255 ||
(!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
! && !IN_BYTES) {
eptr = (char*)utf8buf;
elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
is_utf = TRUE;
***************
*** 7591,7596 ****
--- 8296,8318 ----
}
}
+ /* =========================================================================
+
+ =head1 Cloning an interpreter
+
+ All the macros and functions in this section are for the private use of
+ the main function, perl_clone().
+
+ The foo_dup() functions make an exact copy of an existing foo thinngy.
+ During the course of a cloning, a hash table is used to map old addresses
+ to new addresses. The table is created and manipulated with the
+ ptr_table_* functions.
+
+ =cut
+
+ ============================================================================*/
+
+
#if defined(USE_ITHREADS)
#if defined(USE_THREADS)
***************
*** 7602,7628 ****
#endif
! #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
! #define av_dup(s) (AV*)sv_dup((SV*)s)
! #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
! #define hv_dup(s) (HV*)sv_dup((SV*)s)
! #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
! #define cv_dup(s) (CV*)sv_dup((SV*)s)
! #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
! #define io_dup(s) (IO*)sv_dup((SV*)s)
! #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
! #define gv_dup(s) (GV*)sv_dup((SV*)s)
! #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
#define SAVEPV(p) (p ? savepv(p) : Nullch)
#define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
REGEXP *
! Perl_re_dup(pTHX_ REGEXP *r)
{
! /* XXX fix when pmop->op_pmregexp becomes shared */
! return ReREFCNT_inc(r);
}
PerlIO *
Perl_fp_dup(pTHX_ PerlIO *fp, char type)
{
--- 8324,8441 ----
#endif
! #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
! #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
! #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
! #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
! #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
! #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
! #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
! #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
! #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
! #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
! #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
#define SAVEPV(p) (p ? savepv(p) : Nullch)
#define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
+
+ /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
+ regcomp.c. AMS 20010712 */
+
REGEXP *
! Perl_re_dup(pTHX_ REGEXP *r, clone_params *param)
{
! REGEXP *ret;
! int i, len, npar;
! struct reg_substr_datum *s;
!
! if (!r)
! return (REGEXP *)NULL;
!
! if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
! return ret;
!
! len = r->offsets[0];
! npar = r->nparens+1;
!
! Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
! Copy(r->program, ret->program, len+1, regnode);
!
! New(0, ret->startp, npar, I32);
! Copy(r->startp, ret->startp, npar, I32);
! New(0, ret->endp, npar, I32);
! Copy(r->startp, ret->startp, npar, I32);
!
! if (r->regstclass) {
! New(0, ret->regstclass, 1, regnode);
! ret->regstclass->flags = r->regstclass->flags;
! }
! else
! ret->regstclass = NULL;
!
! New(0, ret->substrs, 1, struct reg_substr_data);
! for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
! s->min_offset = r->substrs->data[i].min_offset;
! s->max_offset = r->substrs->data[i].max_offset;
! s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
! }
!
! if (r->data) {
! struct reg_data *d;
! int count = r->data->count;
!
! Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
! char, struct reg_data);
! New(0, d->what, count, U8);
!
! d->count = count;
! for (i = 0; i < count; i++) {
! d->what[i] = r->data->what[i];
! switch (d->what[i]) {
! case 's':
! d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
! break;
! case 'p':
! d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
! break;
! case 'f':
! /* This is cheating. */
! New(0, d->data[i], 1, struct regnode_charclass_class);
! StructCopy(r->data->data[i], d->data[i],
! struct regnode_charclass_class);
! break;
! case 'o':
! case 'n':
! d->data[i] = r->data->data[i];
! break;
! }
! }
!
! ret->data = d;
! }
! else
! ret->data = NULL;
!
! New(0, ret->offsets, 2*len+1, U32);
! Copy(r->offsets, ret->offsets, 2*len+1, U32);
!
! ret->precomp = SAVEPV(r->precomp);
! ret->subbeg = SAVEPV(r->subbeg);
! ret->sublen = r->sublen;
! ret->refcnt = r->refcnt;
! ret->minlen = r->minlen;
! ret->prelen = r->prelen;
! ret->nparens = r->nparens;
! ret->lastparen = r->lastparen;
! ret->lastcloseparen = r->lastcloseparen;
! ret->reganch = r->reganch;
!
! ptr_table_store(PL_ptr_table, r, ret);
! return ret;
}
+ /* duplicate a file handle */
+
PerlIO *
Perl_fp_dup(pTHX_ PerlIO *fp, char type)
{
***************
*** 7641,7646 ****
--- 8454,8461 ----
return ret;
}
+ /* duplicate a directory handle */
+
DIR *
Perl_dirp_dup(pTHX_ DIR *dp)
{
***************
*** 7650,7657 ****
return dp;
}
GP *
! Perl_gp_dup(pTHX_ GP *gp)
{
GP *ret;
if (!gp)
--- 8465,8474 ----
return dp;
}
+ /* duplicate a typeglob */
+
GP *
! Perl_gp_dup(pTHX_ GP *gp, clone_params* param)
{
GP *ret;
if (!gp)
***************
*** 7667,7679 ****
/* clone */
ret->gp_refcnt = 0; /* must be before any other dups! */
! ret->gp_sv = sv_dup_inc(gp->gp_sv);
! ret->gp_io = io_dup_inc(gp->gp_io);
! ret->gp_form = cv_dup_inc(gp->gp_form);
! ret->gp_av = av_dup_inc(gp->gp_av);
! ret->gp_hv = hv_dup_inc(gp->gp_hv);
! ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
! ret->gp_cv = cv_dup_inc(gp->gp_cv);
ret->gp_cvgen = gp->gp_cvgen;
ret->gp_flags = gp->gp_flags;
ret->gp_line = gp->gp_line;
--- 8484,8496 ----
/* clone */
ret->gp_refcnt = 0; /* must be before any other dups! */
! ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
! ret->gp_io = io_dup_inc(gp->gp_io, param);
! ret->gp_form = cv_dup_inc(gp->gp_form, param);
! ret->gp_av = av_dup_inc(gp->gp_av, param);
! ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
! ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
! ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
ret->gp_cvgen = gp->gp_cvgen;
ret->gp_flags = gp->gp_flags;
ret->gp_line = gp->gp_line;
***************
*** 7681,7688 ****
return ret;
}
MAGIC *
! Perl_mg_dup(pTHX_ MAGIC *mg)
{
MAGIC *mgprev = (MAGIC*)NULL;
MAGIC *mgret;
--- 8498,8507 ----
return ret;
}
+ /* duplicate a chain of magic */
+
MAGIC *
! Perl_mg_dup(pTHX_ MAGIC *mg, clone_params* param)
{
MAGIC *mgprev = (MAGIC*)NULL;
MAGIC *mgret;
***************
*** 7704,7733 ****
nmg->mg_private = mg->mg_private;
nmg->mg_type = mg->mg_type;
nmg->mg_flags = mg->mg_flags;
! if (mg->mg_type == 'r') {
! nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
}
else {
nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
! ? sv_dup_inc(mg->mg_obj)
! : sv_dup(mg->mg_obj);
}
nmg->mg_len = mg->mg_len;
nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
! if (mg->mg_ptr && mg->mg_type != 'g') {
if (mg->mg_len >= 0) {
nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
! if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
AMT *amtp = (AMT*)mg->mg_ptr;
AMT *namtp = (AMT*)nmg->mg_ptr;
I32 i;
for (i = 1; i < NofAMmeth; i++) {
! namtp->table[i] = cv_dup_inc(amtp->table[i]);
}
}
}
else if (mg->mg_len == HEf_SVKEY)
! nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
}
mgprev = nmg;
}
--- 8523,8566 ----
nmg->mg_private = mg->mg_private;
nmg->mg_type = mg->mg_type;
nmg->mg_flags = mg->mg_flags;
! if (mg->mg_type == PERL_MAGIC_qr) {
! nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
}
+ else if(mg->mg_type == PERL_MAGIC_backref) {
+ AV *av = (AV*) mg->mg_obj;
+ SV **svp;
+ I32 i;
+ nmg->mg_obj = (SV*)newAV();
+ svp = AvARRAY(av);
+ i = AvFILLp(av);
+ while (i >= 0) {
+ av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
+ i--;
+ }
+ }
else {
nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
! ? sv_dup_inc(mg->mg_obj, param)
! : sv_dup(mg->mg_obj, param);
}
nmg->mg_len = mg->mg_len;
nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
! if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
if (mg->mg_len >= 0) {
nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
! if (mg->mg_type == PERL_MAGIC_overload_table &&
! AMT_AMAGIC((AMT*)mg->mg_ptr))
! {
AMT *amtp = (AMT*)mg->mg_ptr;
AMT *namtp = (AMT*)nmg->mg_ptr;
I32 i;
for (i = 1; i < NofAMmeth; i++) {
! namtp->table[i] = cv_dup_inc(amtp->table[i], param);
}
}
}
else if (mg->mg_len == HEf_SVKEY)
! nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
}
mgprev = nmg;
}
***************
*** 7734,7739 ****
--- 8567,8574 ----
return mgret;
}
+ /* create a new pointer-mapping table */
+
PTR_TBL_t *
Perl_ptr_table_new(pTHX)
{
***************
*** 7745,7750 ****
--- 8580,8587 ----
return tbl;
}
+ /* map an existing pointer using a table */
+
void *
Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
{
***************
*** 7759,7764 ****
--- 8596,8603 ----
return (void*)NULL;
}
+ /* add a new entry to a pointer-mapping table */
+
void
Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
{
***************
*** 7788,7793 ****
--- 8627,8634 ----
ptr_table_split(tbl);
}
+ /* double the hash bucket size of an existing ptr table */
+
void
Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
{
***************
*** 7818,7823 ****
--- 8659,8666 ----
}
}
+ /* remove all the entries from a ptr table */
+
void
Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
{
***************
*** 7852,7857 ****
--- 8695,8702 ----
tbl->tbl_items = 0;
}
+ /* clear and free a ptr table */
+
void
Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
{
***************
*** 7867,7872 ****
--- 8712,8719 ----
char *PL_watch_pvx;
#endif
+ /* attempt to make everything in the typeglob readonly */
+
STATIC SV *
S_gv_share(pTHX_ SV *sstr)
{
***************
*** 7874,7880 ****
SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
if (GvIO(gv) || GvFORM(gv)) {
! GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
}
else if (!GvCV(gv)) {
GvCV(gv) = (CV*)sv;
--- 8721,8727 ----
SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
if (GvIO(gv) || GvFORM(gv)) {
! GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
}
else if (!GvCV(gv)) {
GvCV(gv) = (CV*)sv;
***************
*** 7882,7892 ****
else {
/* CvPADLISTs cannot be shared */
if (!CvXSUB(GvCV(gv))) {
! GvSHARED_off(gv);
}
}
! if (!GvSHARED(gv)) {
#if 0
PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
HvNAME(GvSTASH(gv)), GvNAME(gv));
--- 8729,8739 ----
else {
/* CvPADLISTs cannot be shared */
if (!CvXSUB(GvCV(gv))) {
! GvUNIQUE_off(gv);
}
}
! if (!GvUNIQUE(gv)) {
#if 0
PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
HvNAME(GvSTASH(gv)), GvNAME(gv));
***************
*** 7922,7929 ****
return sstr; /* he_dup() will SvREFCNT_inc() */
}
SV *
! Perl_sv_dup(pTHX_ SV *sstr)
{
SV *dstr;
--- 8769,8778 ----
return sstr; /* he_dup() will SvREFCNT_inc() */
}
+ /* duplicate an SV of any type (including AV, HV etc) */
+
SV *
! Perl_sv_dup(pTHX_ SV *sstr, clone_params* param)
{
SV *dstr;
***************
*** 7963,7969 ****
break;
case SVt_RV:
SvANY(dstr) = new_XRV();
! SvRV(dstr) = sv_dup_inc(SvRV(sstr));
break;
case SVt_PV:
SvANY(dstr) = new_XPV();
--- 8812,8820 ----
break;
case SVt_RV:
SvANY(dstr) = new_XRV();
! SvRV(dstr) = SvRV(sstr) && SvWEAKREF(sstr)
! ? sv_dup(SvRV(sstr), param)
! : sv_dup_inc(SvRV(sstr), param);
break;
case SVt_PV:
SvANY(dstr) = new_XPV();
***************
*** 7970,7976 ****
SvCUR(dstr) = SvCUR(sstr);
SvLEN(dstr) = SvLEN(sstr);
if (SvROK(sstr))
! SvRV(dstr) = sv_dup_inc(SvRV(sstr));
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
--- 8821,8829 ----
SvCUR(dstr) = SvCUR(sstr);
SvLEN(dstr) = SvLEN(sstr);
if (SvROK(sstr))
! SvRV(dstr) = SvWEAKREF(sstr)
! ? sv_dup(SvRV(sstr), param)
! : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
***************
*** 7982,7988 ****
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
if (SvROK(sstr))
! SvRV(dstr) = sv_dup_inc(SvRV(sstr));
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
--- 8835,8843 ----
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
if (SvROK(sstr))
! SvRV(dstr) = SvWEAKREF(sstr)
! ? sv_dup(SvRV(sstr), param)
! : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
***************
*** 7995,8001 ****
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
if (SvROK(sstr))
! SvRV(dstr) = sv_dup_inc(SvRV(sstr));
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
--- 8850,8858 ----
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
if (SvROK(sstr))
! SvRV(dstr) = SvWEAKREF(sstr)
! ? sv_dup(SvRV(sstr), param)
! : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
***************
*** 8007,8016 ****
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
! SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
! SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
if (SvROK(sstr))
! SvRV(dstr) = sv_dup_inc(SvRV(sstr));
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
--- 8864,8875 ----
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
! SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
! SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
! SvRV(dstr) = SvWEAKREF(sstr)
! ? sv_dup(SvRV(sstr), param)
! : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
***************
*** 8022,8031 ****
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
! SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
! SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
if (SvROK(sstr))
! SvRV(dstr) = sv_dup_inc(SvRV(sstr));
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
--- 8881,8892 ----
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
! SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
! SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
! SvRV(dstr) = SvWEAKREF(sstr)
! ? sv_dup(SvRV(sstr), param)
! : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
***************
*** 8040,8049 ****
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
! SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
! SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
if (SvROK(sstr))
! SvRV(dstr) = sv_dup_inc(SvRV(sstr));
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
--- 8901,8912 ----
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
! SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
! SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
! SvRV(dstr) = SvWEAKREF(sstr)
! ? sv_dup(SvRV(sstr), param)
! : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
***************
*** 8050,8060 ****
SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
LvTARGLEN(dstr) = LvTARGLEN(sstr);
! LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
LvTYPE(dstr) = LvTYPE(sstr);
break;
case SVt_PVGV:
! if (GvSHARED((GV*)sstr)) {
SV *share;
if ((share = gv_share(sstr))) {
del_SV(dstr);
--- 8913,8923 ----
SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
LvTARGLEN(dstr) = LvTARGLEN(sstr);
! LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
LvTYPE(dstr) = LvTYPE(sstr);
break;
case SVt_PVGV:
! if (GvUNIQUE((GV*)sstr)) {
SV *share;
if ((share = gv_share(sstr))) {
del_SV(dstr);
***************
*** 8071,8080 ****
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
! SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
! SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
if (SvROK(sstr))
! SvRV(dstr) = sv_dup_inc(SvRV(sstr));
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
--- 8934,8945 ----
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
! SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
! SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
! SvRV(dstr) = SvWEAKREF(sstr)
! ? sv_dup(SvRV(sstr), param)
! : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
***************
*** 8081,8089 ****
SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
GvNAMELEN(dstr) = GvNAMELEN(sstr);
GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
! GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
GvFLAGS(dstr) = GvFLAGS(sstr);
! GvGP(dstr) = gp_dup(GvGP(sstr));
(void)GpREFCNT_inc(GvGP(dstr));
break;
case SVt_PVIO:
--- 8946,8954 ----
SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
GvNAMELEN(dstr) = GvNAMELEN(sstr);
GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
! GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
GvFLAGS(dstr) = GvFLAGS(sstr);
! GvGP(dstr) = gp_dup(GvGP(sstr), param);
(void)GpREFCNT_inc(GvGP(dstr));
break;
case SVt_PVIO:
***************
*** 8092,8101 ****
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
! SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
! SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
if (SvROK(sstr))
! SvRV(dstr) = sv_dup_inc(SvRV(sstr));
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
--- 8957,8968 ----
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
! SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
! SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
! SvRV(dstr) = SvWEAKREF(sstr)
! ? sv_dup(SvRV(sstr), param)
! : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
***************
*** 8115,8125 ****
IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
! IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
! IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
! IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
IoTYPE(dstr) = IoTYPE(sstr);
IoFLAGS(dstr) = IoFLAGS(sstr);
--- 8982,8992 ----
IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
! IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
! IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
! IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
IoTYPE(dstr) = IoTYPE(sstr);
IoFLAGS(dstr) = IoFLAGS(sstr);
***************
*** 8130,8138 ****
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
! SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
! SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
! AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
if (AvARRAY((AV*)sstr)) {
SV **dst_ary, **src_ary;
--- 8997,9005 ----
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
! SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
! SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
! AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
if (AvARRAY((AV*)sstr)) {
SV **dst_ary, **src_ary;
***************
*** 8145,8155 ****
AvALLOC((AV*)dstr) = dst_ary;
if (AvREAL((AV*)sstr)) {
while (items-- > 0)
! *dst_ary++ = sv_dup_inc(*src_ary++);
}
else {
while (items-- > 0)
! *dst_ary++ = sv_dup(*src_ary++);
}
items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
while (items-- > 0) {
--- 9012,9022 ----
AvALLOC((AV*)dstr) = dst_ary;
if (AvREAL((AV*)sstr)) {
while (items-- > 0)
! *dst_ary++ = sv_dup_inc(*src_ary++, param);
}
else {
while (items-- > 0)
! *dst_ary++ = sv_dup(*src_ary++, param);
}
items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
while (items-- > 0) {
***************
*** 8167,8174 ****
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
! SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
! SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
if (HvARRAY((HV*)sstr)) {
STRLEN i = 0;
--- 9034,9041 ----
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
! SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
! SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
if (HvARRAY((HV*)sstr)) {
STRLEN i = 0;
***************
*** 8178,8187 ****
PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
while (i <= sxhv->xhv_max) {
((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
! !!HvSHAREKEYS(sstr));
++i;
}
! dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
}
else {
SvPVX(dstr) = Nullch;
--- 9045,9054 ----
PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
while (i <= sxhv->xhv_max) {
((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
! !!HvSHAREKEYS(sstr), param);
++i;
}
! dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr), param);
}
else {
SvPVX(dstr) = Nullch;
***************
*** 8189,8194 ****
--- 9056,9064 ----
}
HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
+ /* Record stashes for possible cloning in Perl_clone(). */
+ if(HvNAME((HV*)dstr))
+ av_push(param->stashes, dstr);
break;
case SVt_PVFM:
SvANY(dstr) = new_XPVFM();
***************
*** 8197,8234 ****
/* NOTREACHED */
case SVt_PVCV:
SvANY(dstr) = new_XPVCV();
! dup_pvcv:
SvCUR(dstr) = SvCUR(sstr);
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
! SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
! SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
! CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
CvSTART(dstr) = CvSTART(sstr);
CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
CvXSUB(dstr) = CvXSUB(sstr);
CvXSUBANY(dstr) = CvXSUBANY(sstr);
! CvGV(dstr) = gv_dup(CvGV(sstr));
! CvDEPTH(dstr) = CvDEPTH(sstr);
if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
/* XXX padlists are real, but pretend to be not */
AvREAL_on(CvPADLIST(sstr));
! CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
AvREAL_off(CvPADLIST(sstr));
AvREAL_off(CvPADLIST(dstr));
}
else
! CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
if (!CvANON(sstr) || CvCLONED(sstr))
! CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
else
! CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr));
CvFLAGS(dstr) = CvFLAGS(sstr);
break;
default:
Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
--- 9067,9109 ----
/* NOTREACHED */
case SVt_PVCV:
SvANY(dstr) = new_XPVCV();
! dup_pvcv:
SvCUR(dstr) = SvCUR(sstr);
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
! SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
! SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
! CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
CvSTART(dstr) = CvSTART(sstr);
CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
CvXSUB(dstr) = CvXSUB(sstr);
CvXSUBANY(dstr) = CvXSUBANY(sstr);
! CvGV(dstr) = gv_dup(CvGV(sstr), param);
! if (param->flags & CLONEf_COPY_STACKS) {
! CvDEPTH(dstr) = CvDEPTH(sstr);
! } else {
! CvDEPTH(dstr) = 0;
! }
if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
/* XXX padlists are real, but pretend to be not */
AvREAL_on(CvPADLIST(sstr));
! CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
AvREAL_off(CvPADLIST(sstr));
AvREAL_off(CvPADLIST(dstr));
}
else
! CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
if (!CvANON(sstr) || CvCLONED(sstr))
! CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param);
else
! CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param);
CvFLAGS(dstr) = CvFLAGS(sstr);
+ CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
break;
default:
Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
***************
*** 8239,8248 ****
++PL_sv_objcount;
return dstr;
! }
PERL_CONTEXT *
! Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
{
PERL_CONTEXT *ncxs;
--- 9114,9125 ----
++PL_sv_objcount;
return dstr;
! }
+ /* duplicate a context */
+
PERL_CONTEXT *
! Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, clone_params* param)
{
PERL_CONTEXT *ncxs;
***************
*** 8276,8287 ****
switch (CxTYPE(cx)) {
case CXt_SUB:
ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
! ? cv_dup_inc(cx->blk_sub.cv)
! : cv_dup(cx->blk_sub.cv));
ncx->blk_sub.argarray = (cx->blk_sub.hasargs
! ? av_dup_inc(cx->blk_sub.argarray)
: Nullav);
! ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray);
ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
ncx->blk_sub.lval = cx->blk_sub.lval;
--- 9153,9164 ----
switch (CxTYPE(cx)) {
case CXt_SUB:
ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
! ? cv_dup_inc(cx->blk_sub.cv, param)
! : cv_dup(cx->blk_sub.cv,param));
ncx->blk_sub.argarray = (cx->blk_sub.hasargs
! ? av_dup_inc(cx->blk_sub.argarray, param)
: Nullav);
! ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
ncx->blk_sub.lval = cx->blk_sub.lval;
***************
*** 8289,8297 ****
case CXt_EVAL:
ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
! ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
! ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
break;
case CXt_LOOP:
ncx->blk_loop.label = cx->blk_loop.label;
--- 9166,9174 ----
case CXt_EVAL:
ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
! ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);;
ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
! ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
break;
case CXt_LOOP:
ncx->blk_loop.label = cx->blk_loop.label;
***************
*** 8301,8320 ****
ncx->blk_loop.last_op = cx->blk_loop.last_op;
ncx->blk_loop.iterdata = (CxPADLOOP(cx)
? cx->blk_loop.iterdata
! : gv_dup((GV*)cx->blk_loop.iterdata));
ncx->blk_loop.oldcurpad
= (SV**)ptr_table_fetch(PL_ptr_table,
cx->blk_loop.oldcurpad);
! ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
! ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
! ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
ncx->blk_loop.iterix = cx->blk_loop.iterix;
ncx->blk_loop.itermax = cx->blk_loop.itermax;
break;
case CXt_FORMAT:
! ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
! ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
! ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
break;
case CXt_BLOCK:
--- 9178,9197 ----
ncx->blk_loop.last_op = cx->blk_loop.last_op;
ncx->blk_loop.iterdata = (CxPADLOOP(cx)
? cx->blk_loop.iterdata
! : gv_dup((GV*)cx->blk_loop.iterdata, param));
ncx->blk_loop.oldcurpad
= (SV**)ptr_table_fetch(PL_ptr_table,
cx->blk_loop.oldcurpad);
! ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
! ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
! ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
ncx->blk_loop.iterix = cx->blk_loop.iterix;
ncx->blk_loop.itermax = cx->blk_loop.itermax;
break;
case CXt_FORMAT:
! ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
! ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
! ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
break;
case CXt_BLOCK:
***************
*** 8327,8334 ****
return ncxs;
}
PERL_SI *
! Perl_si_dup(pTHX_ PERL_SI *si)
{
PERL_SI *nsi;
--- 9204,9213 ----
return ncxs;
}
+ /* duplicate a stack info structure */
+
PERL_SI *
! Perl_si_dup(pTHX_ PERL_SI *si, clone_params* param)
{
PERL_SI *nsi;
***************
*** 8344,8356 ****
Newz(56, nsi, 1, PERL_SI);
ptr_table_store(PL_ptr_table, si, nsi);
! nsi->si_stack = av_dup_inc(si->si_stack);
nsi->si_cxix = si->si_cxix;
nsi->si_cxmax = si->si_cxmax;
! nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
nsi->si_type = si->si_type;
! nsi->si_prev = si_dup(si->si_prev);
! nsi->si_next = si_dup(si->si_next);
nsi->si_markoff = si->si_markoff;
return nsi;
--- 9223,9235 ----
Newz(56, nsi, 1, PERL_SI);
ptr_table_store(PL_ptr_table, si, nsi);
! nsi->si_stack = av_dup_inc(si->si_stack, param);
nsi->si_cxix = si->si_cxix;
nsi->si_cxmax = si->si_cxmax;
! nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
nsi->si_type = si->si_type;
! nsi->si_prev = si_dup(si->si_prev, param);
! nsi->si_next = si_dup(si->si_next, param);
nsi->si_markoff = si->si_markoff;
return nsi;
***************
*** 8374,8379 ****
--- 9253,9262 ----
#define pv_dup(p) SAVEPV(p)
#define svp_dup_inc(p,pp) any_dup(p,pp)
+ /* map any object to the new equivent - either something in the
+ * ptr table, or something in the interpreter structure
+ */
+
void *
Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
{
***************
*** 8396,8403 ****
return ret;
}
ANY *
! Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
{
ANY *ss = proto_perl->Tsavestack;
I32 ix = proto_perl->Tsavestack_ix;
--- 9279,9288 ----
return ret;
}
+ /* duplicate the save stack */
+
ANY *
! Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, clone_params* param)
{
ANY *ss = proto_perl->Tsavestack;
I32 ix = proto_perl->Tsavestack_ix;
***************
*** 8426,8440 ****
switch (i) {
case SAVEt_ITEM: /* normal string */
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup_inc(sv);
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup_inc(sv);
break;
case SAVEt_SV: /* scalar reference */
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup_inc(sv);
gv = (GV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = gv_dup_inc(gv);
break;
case SAVEt_GENERIC_PVREF: /* generic char* */
c = (char*)POPPTR(ss,ix);
--- 9311,9325 ----
switch (i) {
case SAVEt_ITEM: /* normal string */
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup_inc(sv, param);
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup_inc(sv, param);
break;
case SAVEt_SV: /* scalar reference */
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup_inc(sv, param);
gv = (GV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = gv_dup_inc(gv, param);
break;
case SAVEt_GENERIC_PVREF: /* generic char* */
c = (char*)POPPTR(ss,ix);
***************
*** 8445,8465 ****
case SAVEt_GENERIC_SVREF: /* generic sv */
case SAVEt_SVREF: /* scalar reference */
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup_inc(sv);
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
break;
case SAVEt_AV: /* array reference */
av = (AV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = av_dup_inc(av);
gv = (GV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = gv_dup(gv);
break;
case SAVEt_HV: /* hash reference */
hv = (HV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = hv_dup_inc(hv);
gv = (GV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = gv_dup(gv);
break;
case SAVEt_INT: /* int reference */
ptr = POPPTR(ss,ix);
--- 9330,9350 ----
case SAVEt_GENERIC_SVREF: /* generic sv */
case SAVEt_SVREF: /* scalar reference */
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup_inc(sv, param);
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
break;
case SAVEt_AV: /* array reference */
av = (AV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = av_dup_inc(av, param);
gv = (GV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = gv_dup(gv, param);
break;
case SAVEt_HV: /* hash reference */
hv = (HV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = hv_dup_inc(hv, param);
gv = (GV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = gv_dup(gv, param);
break;
case SAVEt_INT: /* int reference */
ptr = POPPTR(ss,ix);
***************
*** 8491,8497 ****
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup(sv);
break;
case SAVEt_VPTR: /* random* reference */
ptr = POPPTR(ss,ix);
--- 9376,9382 ----
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup(sv, param);
break;
case SAVEt_VPTR: /* random* reference */
ptr = POPPTR(ss,ix);
***************
*** 8509,8532 ****
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
hv = (HV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = hv_dup(hv);
break;
case SAVEt_APTR: /* AV* reference */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
av = (AV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = av_dup(av);
break;
case SAVEt_NSTAB:
gv = (GV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = gv_dup(gv);
break;
case SAVEt_GP: /* scalar reference */
gp = (GP*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = gp = gp_dup(gp);
(void)GpREFCNT_inc(gp);
gv = (GV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = gv_dup_inc(c);
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = pv_dup(c);
iv = POPIV(ss,ix);
--- 9394,9417 ----
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
hv = (HV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = hv_dup(hv, param);
break;
case SAVEt_APTR: /* AV* reference */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
av = (AV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = av_dup(av, param);
break;
case SAVEt_NSTAB:
gv = (GV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = gv_dup(gv, param);
break;
case SAVEt_GP: /* scalar reference */
gp = (GP*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = gp = gp_dup(gp, param);
(void)GpREFCNT_inc(gp);
gv = (GV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = gv_dup_inc(c, param);
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = pv_dup(c);
iv = POPIV(ss,ix);
***************
*** 8537,8543 ****
case SAVEt_FREESV:
case SAVEt_MORTALIZESV:
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup_inc(sv);
break;
case SAVEt_FREEOP:
ptr = POPPTR(ss,ix);
--- 9422,9428 ----
case SAVEt_FREESV:
case SAVEt_MORTALIZESV:
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup_inc(sv, param);
break;
case SAVEt_FREEOP:
ptr = POPPTR(ss,ix);
***************
*** 8572,8578 ****
break;
case SAVEt_DELETE:
hv = (HV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = hv_dup_inc(hv);
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = pv_dup_inc(c);
i = POPINT(ss,ix);
--- 9457,9463 ----
break;
case SAVEt_DELETE:
hv = (HV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = hv_dup_inc(hv, param);
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = pv_dup_inc(c);
i = POPINT(ss,ix);
***************
*** 8602,8620 ****
break;
case SAVEt_AELEM: /* array element */
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup_inc(sv);
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
av = (AV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = av_dup_inc(av);
break;
case SAVEt_HELEM: /* hash element */
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup_inc(sv);
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup_inc(sv);
hv = (HV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = hv_dup_inc(hv);
break;
case SAVEt_OP:
ptr = POPPTR(ss,ix);
--- 9487,9505 ----
break;
case SAVEt_AELEM: /* array element */
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup_inc(sv, param);
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
av = (AV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = av_dup_inc(av, param);
break;
case SAVEt_HELEM: /* hash element */
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup_inc(sv, param);
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup_inc(sv, param);
hv = (HV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = hv_dup_inc(hv, param);
break;
case SAVEt_OP:
ptr = POPPTR(ss,ix);
***************
*** 8626,8632 ****
break;
case SAVEt_COMPPAD:
av = (AV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = av_dup(av);
break;
case SAVEt_PADSV:
longval = (long)POPLONG(ss,ix);
--- 9511,9517 ----
break;
case SAVEt_COMPPAD:
av = (AV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = av_dup(av, param);
break;
case SAVEt_PADSV:
longval = (long)POPLONG(ss,ix);
***************
*** 8634,8640 ****
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup(sv);
break;
default:
Perl_croak(aTHX_ "panic: ss_dup inconsistency");
--- 9519,9525 ----
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
sv = (SV*)POPPTR(ss,ix);
! TOPPTR(nss,ix) = sv_dup(sv, param);
break;
default:
Perl_croak(aTHX_ "panic: ss_dup inconsistency");
***************
*** 8648,8653 ****
--- 9533,9548 ----
#include "XSUB.h"
#endif
+ /*
+ =for apidoc perl_clone
+
+ Create and return a new interpreter by cloning the current one.
+
+ =cut
+ */
+
+ /* XXX the above needs expanding by someone who actually understands it ! */
+
PerlInterpreter *
perl_clone(PerlInterpreter *proto_perl, UV flags)
{
***************
*** 8656,8662 ****
#endif
#ifdef PERL_IMPLICIT_SYS
! return perl_clone_using(proto_perl, flags,
proto_perl->IMem,
proto_perl->IMemShared,
proto_perl->IMemParse,
--- 9551,9564 ----
#endif
#ifdef PERL_IMPLICIT_SYS
!
! /* perlhost.h so we need to call into it
! to clone the host, CPerlHost should have a c interface, sky */
!
! if (flags & CLONEf_CLONE_HOST) {
! return perl_clone_host(proto_perl,flags);
! }
! return perl_clone_using(proto_perl, flags,
proto_perl->IMem,
proto_perl->IMemShared,
proto_perl->IMemParse,
***************
*** 8681,8686 ****
--- 9583,9592 ----
* their pointers copied. */
IV i;
+ clone_params* param = (clone_params*) malloc(sizeof(clone_params));
+
+
+
# ifdef PERL_OBJECT
CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
ipD, ipS, ipP);
***************
*** 8713,8721 ****
--- 9619,9630 ----
# endif /* PERL_OBJECT */
#else /* !PERL_IMPLICIT_SYS */
IV i;
+ clone_params* param = (clone_params*) malloc(sizeof(clone_params));
PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
PERL_SET_THX(my_perl);
+
+
# ifdef DEBUGGING
memset(my_perl, 0xab, sizeof(PerlInterpreter));
PL_markstack = 0;
***************
*** 8727,8732 ****
--- 9636,9642 ----
Zero(my_perl, 1, PerlInterpreter);
# endif /* DEBUGGING */
#endif /* PERL_IMPLICIT_SYS */
+ param->flags = flags;
/* arena roots */
PL_xiv_arenaroot = NULL;
***************
*** 8764,8769 ****
--- 9674,9684 ----
PL_debug = proto_perl->Idebug;
+ #ifdef USE_REENTRANT_API
+ New(31337, PL_reentrant_buffer,1, REBUF);
+ New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
+ #endif
+
/* create SV map for pointer relocation */
PL_ptr_table = ptr_table_new();
***************
*** 8810,8818 ****
PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
if (!specialWARN(PL_compiling.cop_warnings))
! PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
if (!specialCopIO(PL_compiling.cop_io))
! PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
/* pseudo environmental stuff */
--- 9725,9733 ----
PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
if (!specialWARN(PL_compiling.cop_warnings))
! PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
if (!specialCopIO(PL_compiling.cop_io))
! PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
/* pseudo environmental stuff */
***************
*** 8823,8838 ****
while (i-- > 0) {
PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
}
! PL_envgv = gv_dup(proto_perl->Ienvgv);
! PL_incgv = gv_dup(proto_perl->Iincgv);
! PL_hintgv = gv_dup(proto_perl->Ihintgv);
PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
! PL_diehook = sv_dup_inc(proto_perl->Idiehook);
! PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
/* switches */
PL_minus_c = proto_perl->Iminus_c;
! PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
PL_localpatches = proto_perl->Ilocalpatches;
PL_splitstr = proto_perl->Isplitstr;
PL_preprocess = proto_perl->Ipreprocess;
--- 9738,9758 ----
while (i-- > 0) {
PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
}
!
!
! param->stashes = newAV(); /* Setup array of objects to call clone on */
!
!
! PL_envgv = gv_dup(proto_perl->Ienvgv, param);
! PL_incgv = gv_dup(proto_perl->Iincgv, param);
! PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
! PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
! PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
/* switches */
PL_minus_c = proto_perl->Iminus_c;
! PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
PL_localpatches = proto_perl->Ilocalpatches;
PL_splitstr = proto_perl->Isplitstr;
PL_preprocess = proto_perl->Ipreprocess;
***************
*** 8847,8853 ****
PL_sawampersand = proto_perl->Isawampersand;
PL_unsafe = proto_perl->Iunsafe;
PL_inplace = SAVEPV(proto_perl->Iinplace);
! PL_e_script = sv_dup_inc(proto_perl->Ie_script);
PL_perldb = proto_perl->Iperldb;
PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
--- 9767,9773 ----
PL_sawampersand = proto_perl->Isawampersand;
PL_unsafe = proto_perl->Iunsafe;
PL_inplace = SAVEPV(proto_perl->Iinplace);
! PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
PL_perldb = proto_perl->Iperldb;
PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
***************
*** 8854,8860 ****
/* magical thingies */
/* XXX time(&PL_basetime) when asked for? */
PL_basetime = proto_perl->Ibasetime;
! PL_formfeed = sv_dup(proto_perl->Iformfeed);
PL_maxsysfd = proto_perl->Imaxsysfd;
PL_multiline = proto_perl->Imultiline;
--- 9774,9780 ----
/* magical thingies */
/* XXX time(&PL_basetime) when asked for? */
PL_basetime = proto_perl->Ibasetime;
! PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
PL_maxsysfd = proto_perl->Imaxsysfd;
PL_multiline = proto_perl->Imultiline;
***************
*** 8863,8903 ****
PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
#endif
/* shortcuts to various I/O objects */
! PL_stdingv = gv_dup(proto_perl->Istdingv);
! PL_stderrgv = gv_dup(proto_perl->Istderrgv);
! PL_defgv = gv_dup(proto_perl->Idefgv);
! PL_argvgv = gv_dup(proto_perl->Iargvgv);
! PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
! PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack);
/* shortcuts to regexp stuff */
! PL_replgv = gv_dup(proto_perl->Ireplgv);
/* shortcuts to misc objects */
! PL_errgv = gv_dup(proto_perl->Ierrgv);
/* shortcuts to debugging objects */
! PL_DBgv = gv_dup(proto_perl->IDBgv);
! PL_DBline = gv_dup(proto_perl->IDBline);
! PL_DBsub = gv_dup(proto_perl->IDBsub);
! PL_DBsingle = sv_dup(proto_perl->IDBsingle);
! PL_DBtrace = sv_dup(proto_perl->IDBtrace);
! PL_DBsignal = sv_dup(proto_perl->IDBsignal);
! PL_lineary = av_dup(proto_perl->Ilineary);
! PL_dbargs = av_dup(proto_perl->Idbargs);
/* symbol tables */
! PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
! PL_curstash = hv_dup(proto_perl->Tcurstash);
! PL_debstash = hv_dup(proto_perl->Idebstash);
! PL_globalstash = hv_dup(proto_perl->Iglobalstash);
! PL_curstname = sv_dup_inc(proto_perl->Icurstname);
! PL_beginav = av_dup_inc(proto_perl->Ibeginav);
! PL_endav = av_dup_inc(proto_perl->Iendav);
! PL_checkav = av_dup_inc(proto_perl->Icheckav);
! PL_initav = av_dup_inc(proto_perl->Iinitav);
PL_sub_generation = proto_perl->Isub_generation;
--- 9783,9839 ----
PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
#endif
+ /* Clone the regex array */
+ PL_regex_padav = newAV();
+ {
+ I32 len = av_len((AV*)proto_perl->Iregex_padav);
+ SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
+ for(i = 0; i <= len; i++) {
+ av_push(PL_regex_padav,
+ SvREFCNT_inc(
+ newSViv((IV)re_dup((REGEXP *)
+ SvIVX(regexen[i]), param))
+ ));
+ }
+ }
+ PL_regex_pad = AvARRAY(PL_regex_padav);
+
/* shortcuts to various I/O objects */
! PL_stdingv = gv_dup(proto_perl->Istdingv, param);
! PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
! PL_defgv = gv_dup(proto_perl->Idefgv, param);
! PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
! PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
! PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
/* shortcuts to regexp stuff */
! PL_replgv = gv_dup(proto_perl->Ireplgv, param);
/* shortcuts to misc objects */
! PL_errgv = gv_dup(proto_perl->Ierrgv, param);
/* shortcuts to debugging objects */
! PL_DBgv = gv_dup(proto_perl->IDBgv, param);
! PL_DBline = gv_dup(proto_perl->IDBline, param);
! PL_DBsub = gv_dup(proto_perl->IDBsub, param);
! PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
! PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
! PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
! PL_lineary = av_dup(proto_perl->Ilineary, param);
! PL_dbargs = av_dup(proto_perl->Idbargs, param);
/* symbol tables */
! PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
! PL_curstash = hv_dup(proto_perl->Tcurstash, param);
! PL_nullstash = hv_dup(proto_perl->Inullstash, param);
! PL_debstash = hv_dup(proto_perl->Idebstash, param);
! PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
! PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
! PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
! PL_endav = av_dup_inc(proto_perl->Iendav, param);
! PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
! PL_initav = av_dup_inc(proto_perl->Iinitav, param);
PL_sub_generation = proto_perl->Isub_generation;
***************
*** 8905,8911 ****
PL_forkprocess = proto_perl->Iforkprocess;
/* subprocess state */
! PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
/* internal state */
PL_tainting = proto_perl->Itainting;
--- 9841,9847 ----
PL_forkprocess = proto_perl->Iforkprocess;
/* subprocess state */
! PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
/* internal state */
PL_tainting = proto_perl->Itainting;
***************
*** 8916,8922 ****
PL_op_mask = Nullch;
/* current interpreter roots */
! PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
PL_main_start = proto_perl->Imain_start;
PL_eval_root = proto_perl->Ieval_root;
--- 9852,9858 ----
PL_op_mask = Nullch;
/* current interpreter roots */
! PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
PL_main_start = proto_perl->Imain_start;
PL_eval_root = proto_perl->Ieval_root;
***************
*** 8933,8944 ****
PL_Cmd = Nullch;
PL_gensym = proto_perl->Igensym;
PL_preambled = proto_perl->Ipreambled;
! PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
PL_laststatval = proto_perl->Ilaststatval;
PL_laststype = proto_perl->Ilaststype;
PL_mess_sv = Nullsv;
! PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
PL_ofmt = SAVEPV(proto_perl->Iofmt);
/* interpreter atexit processing */
--- 9869,9880 ----
PL_Cmd = Nullch;
PL_gensym = proto_perl->Igensym;
PL_preambled = proto_perl->Ipreambled;
! PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
PL_laststatval = proto_perl->Ilaststatval;
PL_laststype = proto_perl->Ilaststype;
PL_mess_sv = Nullsv;
! PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
PL_ofmt = SAVEPV(proto_perl->Iofmt);
/* interpreter atexit processing */
***************
*** 8949,8964 ****
}
else
PL_exitlist = (PerlExitListEntry*)NULL;
! PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
PL_profiledata = NULL;
PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
/* PL_rsfp_filters entries have fake IoDIRP() */
! PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
! PL_compcv = cv_dup(proto_perl->Icompcv);
! PL_comppad = av_dup(proto_perl->Icomppad);
! PL_comppad_name = av_dup(proto_perl->Icomppad_name);
PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
--- 9885,9900 ----
}
else
PL_exitlist = (PerlExitListEntry*)NULL;
! PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
PL_profiledata = NULL;
PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
/* PL_rsfp_filters entries have fake IoDIRP() */
! PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
! PL_compcv = cv_dup(proto_perl->Icompcv, param);
! PL_comppad = av_dup(proto_perl->Icomppad, param);
! PL_comppad_name = av_dup(proto_perl->Icomppad_name, param);
PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
***************
*** 8970,8976 ****
/* more statics moved here */
PL_generation = proto_perl->Igeneration;
! PL_DBcv = cv_dup(proto_perl->IDBcv);
PL_in_clean_objs = proto_perl->Iin_clean_objs;
PL_in_clean_all = proto_perl->Iin_clean_all;
--- 9906,9912 ----
/* more statics moved here */
PL_generation = proto_perl->Igeneration;
! PL_DBcv = cv_dup(proto_perl->IDBcv, param);
PL_in_clean_objs = proto_perl->Iin_clean_objs;
PL_in_clean_all = proto_perl->Iin_clean_all;
***************
*** 9007,9014 ****
PL_lex_formbrack = proto_perl->Ilex_formbrack;
PL_lex_dojoin = proto_perl->Ilex_dojoin;
PL_lex_starts = proto_perl->Ilex_starts;
! PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
! PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
PL_lex_op = proto_perl->Ilex_op;
PL_lex_inpat = proto_perl->Ilex_inpat;
PL_lex_inwhat = proto_perl->Ilex_inwhat;
--- 9943,9950 ----
PL_lex_formbrack = proto_perl->Ilex_formbrack;
PL_lex_dojoin = proto_perl->Ilex_dojoin;
PL_lex_starts = proto_perl->Ilex_starts;
! PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
! PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
PL_lex_op = proto_perl->Ilex_op;
PL_lex_inpat = proto_perl->Ilex_inpat;
PL_lex_inwhat = proto_perl->Ilex_inwhat;
***************
*** 9023,9029 ****
Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
PL_nexttoke = proto_perl->Inexttoke;
! PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
--- 9959,9965 ----
Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
PL_nexttoke = proto_perl->Inexttoke;
! PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
***************
*** 9045,9051 ****
PL_error_count = proto_perl->Ierror_count;
PL_subline = proto_perl->Isubline;
! PL_subname = sv_dup_inc(proto_perl->Isubname);
PL_min_intro_pending = proto_perl->Imin_intro_pending;
PL_max_intro_pending = proto_perl->Imax_intro_pending;
--- 9981,9987 ----
PL_error_count = proto_perl->Ierror_count;
PL_subline = proto_perl->Isubline;
! PL_subname = sv_dup_inc(proto_perl->Isubname, param);
PL_min_intro_pending = proto_perl->Imin_intro_pending;
PL_max_intro_pending = proto_perl->Imax_intro_pending;
***************
*** 9059,9065 ****
PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
PL_last_lop_op = proto_perl->Ilast_lop_op;
PL_in_my = proto_perl->Iin_my;
! PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
#ifdef FCRYPT
PL_cryptseen = proto_perl->Icryptseen;
#endif
--- 9995,10001 ----
PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
PL_last_lop_op = proto_perl->Ilast_lop_op;
PL_in_my = proto_perl->Iin_my;
! PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
#ifdef FCRYPT
PL_cryptseen = proto_perl->Icryptseen;
#endif
***************
*** 9080,9106 ****
PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
PL_numeric_standard = proto_perl->Inumeric_standard;
PL_numeric_local = proto_perl->Inumeric_local;
! PL_numeric_radix = sv_dup_inc(proto_perl->Inumeric_radix);
#endif /* !USE_LOCALE_NUMERIC */
/* utf8 character classes */
! PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
! PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
! PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
! PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
! PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
! PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
! PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
! PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
! PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
! PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
! PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
! PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
! PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
! PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
! PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
! PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
! PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
/* swatch cache */
PL_last_swash_hv = Nullhv; /* reinits on demand */
--- 10016,10042 ----
PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
PL_numeric_standard = proto_perl->Inumeric_standard;
PL_numeric_local = proto_perl->Inumeric_local;
! PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
#endif /* !USE_LOCALE_NUMERIC */
/* utf8 character classes */
! PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
! PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
! PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
! PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
! PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
! PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
! PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
! PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
! PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
! PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
! PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
! PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
! PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
! PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
! PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
! PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
! PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
/* swatch cache */
PL_last_swash_hv = Nullhv; /* reinits on demand */
***************
*** 9133,9140 ****
Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
Newz(0, PL_psig_name, SIG_SIZE, SV*);
for (i = 1; i < SIG_SIZE; i++) {
! PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
! PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
}
}
else {
--- 10069,10076 ----
Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
Newz(0, PL_psig_name, SIG_SIZE, SV*);
for (i = 1; i < SIG_SIZE; i++) {
! PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
! PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
}
}
else {
***************
*** 9152,9158 ****
Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
i = 0;
while (i <= PL_tmps_ix) {
! PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
++i;
}
--- 10088,10094 ----
Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
i = 0;
while (i <= PL_tmps_ix) {
! PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
++i;
}
***************
*** 9181,9191 ****
Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
/* NOTE: si_dup() looks at PL_markstack */
! PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
/* PL_curstack = PL_curstackinfo->si_stack; */
! PL_curstack = av_dup(proto_perl->Tcurstack);
! PL_mainstack = av_dup(proto_perl->Tmainstack);
/* next PUSHs() etc. set *(PL_stack_sp+1) */
PL_stack_base = AvARRAY(PL_curstack);
--- 10117,10127 ----
Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
/* NOTE: si_dup() looks at PL_markstack */
! PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
/* PL_curstack = PL_curstackinfo->si_stack; */
! PL_curstack = av_dup(proto_perl->Tcurstack, param);
! PL_mainstack = av_dup(proto_perl->Tmainstack, param);
/* next PUSHs() etc. set *(PL_stack_sp+1) */
PL_stack_base = AvARRAY(PL_curstack);
***************
*** 9198,9204 ****
PL_savestack_ix = proto_perl->Tsavestack_ix;
PL_savestack_max = proto_perl->Tsavestack_max;
/*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
! PL_savestack = ss_dup(proto_perl);
}
else {
init_stacks();
--- 10134,10140 ----
PL_savestack_ix = proto_perl->Tsavestack_ix;
PL_savestack_max = proto_perl->Tsavestack_max;
/*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
! PL_savestack = ss_dup(proto_perl, param);
}
else {
init_stacks();
***************
*** 9216,9223 ****
PL_statbuf = proto_perl->Tstatbuf;
PL_statcache = proto_perl->Tstatcache;
! PL_statgv = gv_dup(proto_perl->Tstatgv);
! PL_statname = sv_dup_inc(proto_perl->Tstatname);
#ifdef HAS_TIMES
PL_timesbuf = proto_perl->Ttimesbuf;
#endif
--- 10152,10159 ----
PL_statbuf = proto_perl->Tstatbuf;
PL_statcache = proto_perl->Tstatcache;
! PL_statgv = gv_dup(proto_perl->Tstatgv, param);
! PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
#ifdef HAS_TIMES
PL_timesbuf = proto_perl->Ttimesbuf;
#endif
***************
*** 9224,9238 ****
PL_tainted = proto_perl->Ttainted;
PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
! PL_nrs = sv_dup_inc(proto_perl->Tnrs);
! PL_rs = sv_dup_inc(proto_perl->Trs);
! PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
! PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
! PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
! PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
! PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
! PL_formtarget = sv_dup(proto_perl->Tformtarget);
PL_restartop = proto_perl->Trestartop;
PL_in_eval = proto_perl->Tin_eval;
--- 10160,10174 ----
PL_tainted = proto_perl->Ttainted;
PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
! PL_nrs = sv_dup_inc(proto_perl->Tnrs, param);
! PL_rs = sv_dup_inc(proto_perl->Trs, param);
! PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
! PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
! PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
! PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
! PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
! PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
PL_restartop = proto_perl->Trestartop;
PL_in_eval = proto_perl->Tin_eval;
***************
*** 9243,9249 ****
#ifdef PERL_FLEXIBLE_EXCEPTIONS
PL_protect = proto_perl->Tprotect;
#endif
! PL_errors = sv_dup_inc(proto_perl->Terrors);
PL_av_fetch_sv = Nullsv;
PL_hv_fetch_sv = Nullsv;
Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
--- 10179,10185 ----
#ifdef PERL_FLEXIBLE_EXCEPTIONS
PL_protect = proto_perl->Tprotect;
#endif
! PL_errors = sv_dup_inc(proto_perl->Terrors, param);
PL_av_fetch_sv = Nullsv;
PL_hv_fetch_sv = Nullsv;
Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
***************
*** 9252,9260 ****
PL_dumpindent = proto_perl->Tdumpindent;
PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
! PL_sortstash = hv_dup(proto_perl->Tsortstash);
! PL_firstgv = gv_dup(proto_perl->Tfirstgv);
! PL_secondgv = gv_dup(proto_perl->Tsecondgv);
PL_sortcxix = proto_perl->Tsortcxix;
PL_efloatbuf = Nullch; /* reinits on demand */
PL_efloatsize = 0; /* reinits on demand */
--- 10188,10196 ----
PL_dumpindent = proto_perl->Tdumpindent;
PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
! PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
! PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
! PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
PL_sortcxix = proto_perl->Tsortcxix;
PL_efloatbuf = Nullch; /* reinits on demand */
PL_efloatsize = 0; /* reinits on demand */
***************
*** 9294,9300 ****
PL_regendp = (I32*)NULL;
PL_reglastparen = (U32*)NULL;
PL_regtill = Nullch;
- PL_regprev = '\n';
PL_reg_start_tmp = (char**)NULL;
PL_reg_start_tmpl = 0;
PL_regdata = (struct reg_data*)NULL;
--- 10230,10235 ----
***************
*** 9334,9340 ****
--- 10269,10297 ----
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
}
+
+ /* Call the ->CLONE method, if it exists, for each of the stashes
+ identified by sv_dup() above.
+ */
+ while(av_len(param->stashes) != -1) {
+ HV* stash = (HV*) av_shift(param->stashes);
+ GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
+ if (cloner && GvCV(cloner)) {
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
+ PUTBACK;
+ call_sv((SV*)GvCV(cloner), G_DISCARD);
+ FREETMPS;
+ LEAVE;
+ }
+ }
+ SvREFCNT_dec(param->stashes);
+ Safefree(param);
+
#ifdef PERL_OBJECT
return (PerlInterpreter*)pPerl;
#else
***************
*** 9349,9408 ****
#endif
#endif /* USE_ITHREADS */
-
- static void
- do_report_used(pTHXo_ SV *sv)
- {
- if (SvTYPE(sv) != SVTYPEMASK) {
- PerlIO_printf(Perl_debug_log, "****\n");
- sv_dump(sv);
- }
- }
-
- static void
- do_clean_objs(pTHXo_ SV *sv)
- {
- SV* rv;
-
- if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
- DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
- if (SvWEAKREF(sv)) {
- sv_del_backref(sv);
- SvWEAKREF_off(sv);
- SvRV(sv) = 0;
- } else {
- SvROK_off(sv);
- SvRV(sv) = 0;
- SvREFCNT_dec(rv);
- }
- }
-
- /* XXX Might want to check arrays, etc. */
- }
-
- #ifndef DISABLE_DESTRUCTOR_KLUDGE
- static void
- do_clean_named_objs(pTHXo_ SV *sv)
- {
- if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
- if ( SvOBJECT(GvSV(sv)) ||
- (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
- (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
- (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
- (GvCV(sv) && SvOBJECT(GvCV(sv))) )
- {
- DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
- SvREFCNT_dec(sv);
- }
- }
- }
- #endif
-
- static void
- do_clean_all(pTHXo_ SV *sv)
- {
- DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
- SvFLAGS(sv) |= SVf_BREAK;
- SvREFCNT_dec(sv);
- }
-
--- 10306,10308 ----
diff -c 'perl-5.7.1/sv.h' 'perl-5.7.2/sv.h'
Index: ./sv.h
*** ./sv.h Wed Mar 28 17:19:25 2001
--- ./sv.h Mon Jul 9 17:11:21 2001
***************
*** 61,67 ****
/* Using C's structural equivalence to help emulate C++ inheritance here... */
! struct STRUCT_SV {
void* sv_any; /* pointer to something */
U32 sv_refcnt; /* how many references to us */
U32 sv_flags; /* what we are */
--- 61,67 ----
/* Using C's structural equivalence to help emulate C++ inheritance here... */
! struct STRUCT_SV { /* struct sv { */
void* sv_any; /* pointer to something */
U32 sv_refcnt; /* how many references to us */
U32 sv_flags; /* what we are */
***************
*** 193,199 ****
#define SVf_FAKE 0x00100000 /* glob or lexical is just a copy */
#define SVf_OOK 0x00200000 /* has valid offset value */
! #define SVf_BREAK 0x00400000 /* refcnt is artificially low */
#define SVf_READONLY 0x00800000 /* may not be modified */
--- 193,200 ----
#define SVf_FAKE 0x00100000 /* glob or lexical is just a copy */
#define SVf_OOK 0x00200000 /* has valid offset value */
! #define SVf_BREAK 0x00400000 /* refcnt is artificially low - used
! * by SV's in final arena cleanup */
#define SVf_READONLY 0x00800000 /* may not be modified */
***************
*** 204,210 ****
#define SVf_UTF8 0x20000000 /* SvPVX is UTF-8 encoded */
! #define SVf_THINKFIRST (SVf_READONLY|SVf_ROK|SVf_FAKE|SVf_UTF8)
#define SVf_OK (SVf_IOK|SVf_NOK|SVf_POK|SVf_ROK| \
SVp_IOK|SVp_NOK|SVp_POK)
--- 205,211 ----
#define SVf_UTF8 0x20000000 /* SvPVX is UTF-8 encoded */
! #define SVf_THINKFIRST (SVf_READONLY|SVf_ROK|SVf_FAKE)
#define SVf_OK (SVf_IOK|SVf_NOK|SVf_POK|SVf_ROK| \
SVp_IOK|SVp_NOK|SVp_POK)
***************
*** 217,222 ****
--- 218,224 ----
/* SVpad_OUR may be set on SVt_PV{NV,MG,GV} types */
#define SVpad_OUR 0x80000000 /* pad name is "our" instead of "my" */
+ #define SVpad_TYPED 0x40000000 /* Typed Lexical */
#define SVf_IVisUV 0x80000000 /* use XPVUV instead of XPVIV */
***************
*** 499,517 ****
Dereferences an RV to return the SV.
=for apidoc Am|IV|SvIVX|SV* sv
! Returns the integer which is stored in the SV, assuming SvIOK is
! true.
=for apidoc Am|UV|SvUVX|SV* sv
! Returns the unsigned integer which is stored in the SV, assuming SvIOK is
! true.
=for apidoc Am|NV|SvNVX|SV* sv
! Returns the double which is stored in the SV, assuming SvNOK is
! true.
=for apidoc Am|char*|SvPVX|SV* sv
! Returns a pointer to the string in the SV. The SV must contain a
string.
=for apidoc Am|STRLEN|SvCUR|SV* sv
--- 501,519 ----
Dereferences an RV to return the SV.
=for apidoc Am|IV|SvIVX|SV* sv
! Returns the raw value in the SV's IV slot, without checks or conversions.
! Only use when you are sure SvIOK is true. See also C<SvIV()>.
=for apidoc Am|UV|SvUVX|SV* sv
! Returns the raw value in the SV's UV slot, without checks or conversions.
! Only use when you are sure SvIOK is true. See also C<SvUV()>.
=for apidoc Am|NV|SvNVX|SV* sv
! Returns the raw value in the SV's NV slot, without checks or conversions.
! Only use when you are sure SvNOK is true. See also C<SvNV()>.
=for apidoc Am|char*|SvPVX|SV* sv
! Returns a pointer to the physical string in the SV. The SV must contain a
string.
=for apidoc Am|STRLEN|SvCUR|SV* sv
***************
*** 594,600 ****
=for apidoc Am|void|SvPOK_only_UTF8|SV* sv
Tells an SV that it is a string and disables all other OK bits,
and leaves the UTF8 status as it was.
!
=cut
*/
--- 596,602 ----
=for apidoc Am|void|SvPOK_only_UTF8|SV* sv
Tells an SV that it is a string and disables all other OK bits,
and leaves the UTF8 status as it was.
!
=cut
*/
***************
*** 823,849 ****
Like <SvPV> but will force the SV into becoming a string (SvPOK). You want
force if you are going to update the SvPVX directly.
=for apidoc Am|char*|SvPV|SV* sv|STRLEN len
Returns a pointer to the string in the SV, or a stringified form of the SV
! if the SV does not contain a string. Handles 'get' magic.
=for apidoc Am|char*|SvPV_nolen|SV* sv
Returns a pointer to the string in the SV, or a stringified form of the SV
if the SV does not contain a string. Handles 'get' magic.
=for apidoc Am|IV|SvIV|SV* sv
! Coerces the given SV to an integer and returns it.
=for apidoc Am|NV|SvNV|SV* sv
! Coerce the given SV to a double and return it.
=for apidoc Am|UV|SvUV|SV* sv
! Coerces the given SV to an unsigned integer and returns it.
=for apidoc Am|bool|SvTRUE|SV* sv
Returns a boolean indicating whether Perl would evaluate the SV as true or
false, defined or undefined. Does not handle 'get' magic.
=cut
*/
--- 825,913 ----
Like <SvPV> but will force the SV into becoming a string (SvPOK). You want
force if you are going to update the SvPVX directly.
+ =for apidoc Am|char*|SvPV_force_nomg|SV* sv|STRLEN len
+ Like <SvPV> but will force the SV into becoming a string (SvPOK). You want
+ force if you are going to update the SvPVX directly. Doesn't process magic.
+
=for apidoc Am|char*|SvPV|SV* sv|STRLEN len
Returns a pointer to the string in the SV, or a stringified form of the SV
! if the SV does not contain a string. Handles 'get' magic. See also
! C<SvPVx> for a version which guarantees to evaluate sv only once.
+ =for apidoc Am|char*|SvPVx|SV* sv|STRLEN len
+ A version of C<SvPV> which guarantees to evaluate sv only once.
+
=for apidoc Am|char*|SvPV_nolen|SV* sv
Returns a pointer to the string in the SV, or a stringified form of the SV
if the SV does not contain a string. Handles 'get' magic.
=for apidoc Am|IV|SvIV|SV* sv
! Coerces the given SV to an integer and returns it. See C<SvIVx> for a
! version which guarantees to evaluate sv only once.
+ =for apidoc Am|IV|SvIVx|SV* sv
+ Coerces the given SV to an integer and returns it. Guarantees to evaluate
+ sv only once. Use the more efficent C<SvIV> otherwise.
+
=for apidoc Am|NV|SvNV|SV* sv
! Coerce the given SV to a double and return it. See C<SvNVx> for a version
! which guarantees to evaluate sv only once.
+ =for apidoc Am|NV|SvNVx|SV* sv
+ Coerces the given SV to a double and returns it. Guarantees to evaluate
+ sv only once. Use the more efficent C<SvNV> otherwise.
+
=for apidoc Am|UV|SvUV|SV* sv
! Coerces the given SV to an unsigned integer and returns it. See C<SvUVx>
! for a version which guarantees to evaluate sv only once.
+ =for apidoc Am|UV|SvUVx|SV* sv
+ Coerces the given SV to an unsigned integer and returns it. Guarantees to
+ evaluate sv only once. Use the more efficent C<SvUV> otherwise.
+
=for apidoc Am|bool|SvTRUE|SV* sv
Returns a boolean indicating whether Perl would evaluate the SV as true or
false, defined or undefined. Does not handle 'get' magic.
+ =for apidoc Am|char*|SvPVutf8_force|SV* sv|STRLEN len
+ Like C<SvPV_force>, but converts sv to uft8 first if necessary.
+
+ =for apidoc Am|char*|SvPVutf8|SV* sv|STRLEN len
+ Like C<SvPV>, but converts sv to uft8 first if necessary.
+
+ =for apidoc Am|char*|SvPVutf8_nolen|SV* sv|STRLEN len
+ Like C<SvPV_nolen>, but converts sv to uft8 first if necessary.
+
+ =for apidoc Am|char*|SvPVbyte_force|SV* sv|STRLEN len
+ Like C<SvPV_force>, but converts sv to byte representation first if necessary.
+
+ =for apidoc Am|char*|SvPVbyte|SV* sv|STRLEN len
+ Like C<SvPV>, but converts sv to byte representation first if necessary.
+
+ =for apidoc Am|char*|SvPVbyte_nolen|SV* sv|STRLEN len
+ Like C<SvPV_nolen>, but converts sv to byte representation first if necessary.
+
+ =for apidoc Am|char*|SvPVutf8x_force|SV* sv|STRLEN len
+ Like C<SvPV_force>, but converts sv to uft8 first if necessary.
+ Guarantees to evalute sv only once; use the more efficient C<SvPVutf8_force>
+ otherwise.
+
+ =for apidoc Am|char*|SvPVutf8x|SV* sv|STRLEN len
+ Like C<SvPV>, but converts sv to uft8 first if necessary.
+ Guarantees to evalute sv only once; use the more efficient C<SvPVutf8>
+ otherwise.
+
+ =for apidoc Am|char*|SvPVbytex_force|SV* sv|STRLEN len
+ Like C<SvPV_force>, but converts sv to byte representation first if necessary.
+ Guarantees to evalute sv only once; use the more efficient C<SvPVbyte_force>
+ otherwise.
+
+ =for apidoc Am|char*|SvPVbytex|SV* sv|STRLEN len
+ Like C<SvPV>, but converts sv to byte representation first if necessary.
+ Guarantees to evalute sv only once; use the more efficient C<SvPVbyte>
+ otherwise.
+
+
=cut
*/
***************
*** 890,905 ****
#undef SvNV
#define SvNV(sv) (SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv))
#undef SvPV
! #define SvPV(sv, lp) \
! ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
! ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv(sv, &lp))
#undef SvPV_force
! #define SvPV_force(sv, lp) \
((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
! ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force(sv, &lp))
#undef SvPV_nolen
#define SvPV_nolen(sv) \
--- 954,1004 ----
#undef SvNV
#define SvNV(sv) (SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv))
+ /* flag values for sv_*_flags functions */
+ #define SV_IMMEDIATE_UNREF 1
+ #define SV_GMAGIC 2
+
+ #define sv_setsv_macro(dsv, ssv) sv_setsv_flags(dsv, ssv, SV_GMAGIC)
+ #define sv_setsv_nomg(dsv, ssv) sv_setsv_flags(dsv, ssv, 0)
+ #define sv_catsv_macro(dsv, ssv) sv_catsv_flags(dsv, ssv, SV_GMAGIC)
+ #define sv_catsv_nomg(dsv, ssv) sv_catsv_flags(dsv, ssv, 0)
+ #define sv_catpvn_macro(dsv, sstr, slen) sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC)
+ #define sv_catpvn_nomg(dsv, sstr, slen) sv_catpvn_flags(dsv, sstr, slen, 0)
+ #define sv_2pv_macro(sv, lp) sv_2pv_flags(sv, lp, SV_GMAGIC)
+ #define sv_2pv_nomg(sv, lp) sv_2pv_flags(sv, lp, 0)
+ #define sv_pvn_force_macro(sv, lp) sv_pvn_force_flags(sv, lp, SV_GMAGIC)
+ #define sv_pvn_force_nomg(sv, lp) sv_pvn_force_flags(sv, lp, 0)
+ #define sv_utf8_upgrade_macro(sv) sv_utf8_upgrade_flags(sv, SV_GMAGIC)
+ #define sv_utf8_upgrade_nomg(sv) sv_utf8_upgrade_flags(sv, 0)
+
+ /* function style also available for bincompat */
+ #define sv_setsv(dsv, ssv) sv_setsv_macro(dsv, ssv)
+ #define sv_catsv(dsv, ssv) sv_catsv_macro(dsv, ssv)
+ #define sv_catpvn(dsv, sstr, slen) sv_catpvn_macro(dsv, sstr, slen)
+ #define sv_2pv(sv, lp) sv_2pv_macro(sv, lp)
+ #define sv_pvn_force(sv, lp) sv_pvn_force_macro(sv, lp)
+ #define sv_utf8_upgrade(sv) sv_utf8_upgrade_macro(sv)
+
#undef SvPV
! #define SvPV(sv, lp) SvPV_flags(sv, lp, SV_GMAGIC)
+ #undef SvPV_nomg
+ #define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0)
+ #undef SvPV_flags
+ #define SvPV_flags(sv, lp, flags) \
+ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags))
+
#undef SvPV_force
! #define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC)
! #undef SvPV_force_nomg
! #define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0)
!
! #undef SvPV_force_flags
! #define SvPV_force_flags(sv, lp, flags) \
((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
! ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags))
#undef SvPV_nolen
#define SvPV_nolen(sv) \
***************
*** 1053,1059 ****
Calls a non-destructive version of C<sv_setsv> if dsv is not the same as
ssv. May evaluate arguments more than once.
! =for apidoc Am|void|SvGROW|SV* sv|STRLEN len
Expands the character buffer in the SV so that it has room for the
indicated number of bytes (remember to reserve space for an extra trailing
NUL character). Calls C<sv_grow> to perform the expansion if necessary.
--- 1152,1164 ----
Calls a non-destructive version of C<sv_setsv> if dsv is not the same as
ssv. May evaluate arguments more than once.
! =for apidoc Am|void|SvSetMagicSV|SV* dsb|SV* ssv
! Like C<SvSetSV>, but does any set magic required afterwards.
!
! =for apidoc Am|void|SvSetMagicSV_nosteal|SV* dsv|SV* ssv
! Like C<SvSetMagicSV>, but does any set magic required afterwards.
!
! =for apidoc Am|char *|SvGROW|SV* sv|STRLEN len
Expands the character buffer in the SV so that it has room for the
indicated number of bytes (remember to reserve space for an extra trailing
NUL character). Calls C<sv_grow> to perform the expansion if necessary.
***************
*** 1108,1115 ****
#define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv))
#define Sv_Grow sv_grow
- #define SV_IMMEDIATE_UNREF 1
-
#define CLONEf_COPY_STACKS 1
#define CLONEf_KEEP_PTR_TABLE 2
--- 1213,1223 ----
#define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv))
#define Sv_Grow sv_grow
#define CLONEf_COPY_STACKS 1
#define CLONEf_KEEP_PTR_TABLE 2
+ #define CLONEf_CLONE_HOST 4
+ typedef struct {
+ AV* stashes;
+ UV flags;
+ } clone_params;
diff -c 'perl-5.7.1/t/TEST' 'perl-5.7.2/t/TEST'
Index: ./t/TEST
*** ./t/TEST Mon Mar 19 00:19:26 2001
--- ./t/TEST Mon Jul 9 17:11:21 2001
***************
*** 8,16 ****
# Cheesy version of Getopt::Std. Maybe we should replace it with that.
if ($#ARGV >= 0) {
foreach my $idx (0..$#ARGV) {
! next unless $ARGV[$idx] =~ /^-(\w+)$/;
$verbose = 1 if $1 eq 'v';
$with_utf= 1 if $1 eq 'utf8';
splice(@ARGV, $idx, 1);
}
}
--- 8,20 ----
# Cheesy version of Getopt::Std. Maybe we should replace it with that.
if ($#ARGV >= 0) {
foreach my $idx (0..$#ARGV) {
! next unless $ARGV[$idx] =~ /^-(\S+)$/;
$verbose = 1 if $1 eq 'v';
$with_utf= 1 if $1 eq 'utf8';
+ if ($1 =~ /^deparse(,.+)?$/) {
+ $deparse = 1;
+ $deparse_opts = $1;
+ }
splice(@ARGV, $idx, 1);
}
}
***************
*** 20,26 ****
die "You need to run \"make test\" first to set things up.\n"
unless -e 'perl' or -e 'perl.exe';
! if ($ENV{PERL_3LOG}) {
unless (-x 'perl.third') {
unless (-x '../perl.third') {
die "You need to run \"make perl.third first.\n";
--- 24,30 ----
die "You need to run \"make test\" first to set things up.\n"
unless -e 'perl' or -e 'perl.exe';
! if ($ENV{PERL_3LOG}) { # Tru64 third(1) tool, see perlhack
unless (-x 'perl.third') {
unless (-x '../perl.third') {
die "You need to run \"make perl.third first.\n";
***************
*** 40,66 ****
$ENV{EMXSHELL} = 'sh'; # For OS/2
! if ($#ARGV == -1) {
! @ARGV = split(/[ \n]/,
! `echo base/*.t comp/*.t cmd/*.t run/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t pod/*.t camel-III/*.t`);
}
# %infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 );
! _testprogs('perl', @ARGV);
! _testprogs('compile', @ARGV) if (-e "../testcompile");
sub _testprogs {
$type = shift @_;
@tests = @_;
-
print <<'EOT' if ($type eq 'compile');
! --------------------------------------------------------------------------------
TESTING COMPILER
! --------------------------------------------------------------------------------
EOT
$ENV{PERLCC_TIMEOUT} = 120
if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT});
--- 44,113 ----
$ENV{EMXSHELL} = 'sh'; # For OS/2
! # Roll your own File::Find!
! use TestInit;
! use File::Spec;
! my $curdir = File::Spec->curdir;
! my $updir = File::Spec->updir;
!
! sub _find_tests {
! my($dir) = @_;
! opendir DIR, $dir || die "Trouble opening $dir: $!";
! foreach my $f (sort { $a cmp $b } readdir DIR) {
! next if $f eq $curdir or $f eq $updir;
!
! my $fullpath = File::Spec->catdir($dir, $f);
!
! _find_tests($fullpath) if -d $fullpath;
! push @ARGV, $fullpath if $f =~ /\.t$/;
! }
}
+ unless (@ARGV) {
+ foreach my $dir (qw(base comp cmd run io op lib)) {
+ _find_tests($dir);
+ }
+ my $mani = File::Spec->catdir($updir, "MANIFEST");
+ if (open(MANI, $mani)) {
+ while (<MANI>) { # similar code in t/harness
+ if (m!^(ext/\S+/([^/]+\.t|test\.pl)|lib/\S+?(\.t|test\.pl))\s!) {
+ push @ARGV, $1;
+ $OVER{$1} = File::Spec->catdir($updir, $1);
+ }
+ }
+ } else {
+ warn "$0: cannot open $mani: $!\n";
+ }
+ _find_tests('pod');
+ }
+
+ # Tests known to cause infinite loops for the perlcc tests.
# %infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 );
+ %infinite = ();
! if ($deparse) {
! _testprogs('deparse', @ARGV);
! } else {
! _testprogs('perl', @ARGV);
! _testprogs('compile', @ARGV) if (-e "../testcompile");
! }
sub _testprogs {
$type = shift @_;
@tests = @_;
print <<'EOT' if ($type eq 'compile');
! ------------------------------------------------------------------------------
TESTING COMPILER
! ------------------------------------------------------------------------------
EOT
+ print <<'EOT' if ($type eq 'deparse');
+ ------------------------------------------------------------------------------
+ TESTING DEPARSER
+ ------------------------------------------------------------------------------
+ EOT
+
$ENV{PERLCC_TIMEOUT} = 120
if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT});
***************
*** 69,82 ****
$total = @tests;
$files = 0;
$totmax = 0;
! $maxlen = 0;
! foreach (@tests) {
! $len = length;
! $maxlen = $len if $len > $maxlen;
}
! # +3 : we want three dots between the test name and the "ok"
! # -2 : the .t suffix
! $dotdotdot = $maxlen + 3 - 2;
while ($test = shift @tests) {
if ( $infinite{$test} && $type eq 'compile' ) {
--- 116,132 ----
$total = @tests;
$files = 0;
$totmax = 0;
! my $maxlen = 0;
! my $maxsuflen = 0;
! foreach (@tests) { # The same code in lib/Test/Harness.pm:_run_all_tests
! my $suf = /\.(\w+)$/ ? $1 : '';
! my $len = length;
! my $suflen = length $suf;
! $maxlen = $len if $len > $maxlen;
! $maxsuflen = $suflen if $suflen > $maxsuflen;
}
! # + 3 : we want three dots between the test name and the "ok"
! $dotdotdot = $maxlen + 3 - $maxsuflen;
while ($test = shift @tests) {
if ( $infinite{$test} && $type eq 'compile' ) {
***************
*** 86,98 ****
if ($test =~ /^$/) {
next;
}
$te = $test;
! chop($te);
print "$te" . '.' x ($dotdotdot - length($te));
open(SCRIPT,"<$test") or die "Can't run $test.\n";
$_ = <SCRIPT>;
! close(SCRIPT);
if (/#!.*perl(.*)$/) {
$switch = $1;
if ($^O eq 'VMS') {
--- 136,160 ----
if ($test =~ /^$/) {
next;
}
+ if ($type eq 'deparse') {
+ if ($test eq "comp/redef.t") {
+ # Redefinition happens at compile time
+ next;
+ }
+ elsif ($test eq "lib/switch.t") {
+ # B::Deparse doesn't support source filtering
+ next;
+ }
+ }
$te = $test;
! $te =~ s/\.\w+$/./;
print "$te" . '.' x ($dotdotdot - length($te));
+ $test = $OVER{$test} if exists $OVER{$test};
+
open(SCRIPT,"<$test") or die "Can't run $test.\n";
$_ = <SCRIPT>;
! close(SCRIPT) unless ($type eq 'deparse');
if (/#!.*perl(.*)$/) {
$switch = $1;
if ($^O eq 'VMS') {
***************
*** 104,124 ****
$switch = '';
}
! my $utf = $with_utf ? '-I../lib -Mutf8'
! : '';
my $testswitch = '-I. -MTestInit'; # -T will strict . from @INC
! if ($type eq 'perl') {
! my $run = "./perl $testswitch $switch $utf $test |";
open(RESULTS,$run) or print "can't run '$run': $!.\n";
}
else {
my $compile =
"./perl $testswitch -I../lib ../utils/perlcc -o ".
! "./$test.plc $utf ./$test ".
! " && ./$test.plc |";
open(RESULTS, $compile)
or print "can't compile '$compile': $!.\n";
! unlink "./$test.plc";
}
$ok = 0;
--- 166,207 ----
$switch = '';
}
! my $file_opts = "";
! if ($type eq 'deparse') {
! # Look for #line directives which change the filename
! while (<SCRIPT>) {
! $file_opts .= ",-f$3$4"
! if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/;
! }
! close(SCRIPT);
! }
!
! $test = $OVER{$test} if exists $OVER{$test};
!
! my $utf = $with_utf ? '-I../lib -Mutf8' : '';
my $testswitch = '-I. -MTestInit'; # -T will strict . from @INC
! if ($type eq 'deparse') {
! my $deparse =
! "./perl $testswitch $switch -I../lib -MO=-qq,Deparse,".
! "-l$deparse_opts$file_opts ".
! "$test > $test.dp ".
! "&& ./perl $testswitch $switch -I../lib $test.dp |";
! open(RESULTS, $deparse)
! or print "can't deparse '$deparse': $!.\n";
! }
! elsif ($type eq 'perl') {
! my $perl = $ENV{PERL} || './perl';
! my $run = "$perl $testswitch $switch $utf $test |";
open(RESULTS,$run) or print "can't run '$run': $!.\n";
}
else {
my $compile =
"./perl $testswitch -I../lib ../utils/perlcc -o ".
! "$test.plc $utf $test ".
! " && $test.plc |";
open(RESULTS, $compile)
or print "can't compile '$compile': $!.\n";
! unlink "$test.plc";
}
$ok = 0;
***************
*** 128,135 ****
print $_;
}
unless (/^#/) {
! if (/^1\.\.([0-9]+)/) {
$max = $1;
$totmax += $max;
$files += 1;
$next = 1;
--- 211,219 ----
print $_;
}
unless (/^#/) {
! if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) {
$max = $1;
+ %todo = map { $_ => 1 } split / /, $3 if $3;
$totmax += $max;
$files += 1;
$next = 1;
***************
*** 141,146 ****
--- 225,231 ----
{
my($not, $num, $extra) = ($1, $2, $3);
my($istodo) = $extra =~ /^\s*#\s*TODO/ if $extra;
+ $istodo = 1 if $todo{$num};
if( $not && !$istodo ) {
$ok = 0;
***************
*** 161,171 ****
}
}
close RESULTS;
if ($ENV{PERL_3LOG}) {
my $tpp = $test;
$tpp =~ s:/:_:g;
$tpp =~ s:\.t$::;
! rename("perl.3log", "perl.3log.$tpp");
}
$next = $next - 1;
if ($ok && $next == $max) {
--- 246,261 ----
}
}
close RESULTS;
+ if ($type eq 'deparse') {
+ unlink "./$test.dp";
+ }
if ($ENV{PERL_3LOG}) {
my $tpp = $test;
+ $tpp =~ s:^../::;
$tpp =~ s:/:_:g;
$tpp =~ s:\.t$::;
! rename("perl.3log", "perl.3log.$tpp") ||
! die "rename: perl3.log to perl.3log.$tpp: $!\n";
}
$next = $next - 1;
if ($ok && $next == $max) {
diff -c 'perl-5.7.1/t/TestInit.pm' 'perl-5.7.2/t/TestInit.pm'
Index: ./t/TestInit.pm
*** ./t/TestInit.pm Tue Mar 6 04:06:48 2001
--- ./t/TestInit.pm Mon Jul 9 17:11:21 2001
***************
*** 11,17 ****
# (not require) in the test scripts.
#
# PS this is not POD because this should be a very minimalist module in
! # case of fundemental perl breakage.
chdir 't' if -d 't';
@INC = '../lib';
--- 11,20 ----
# (not require) in the test scripts.
#
# PS this is not POD because this should be a very minimalist module in
! # case of funaemental perl breakage.
chdir 't' if -d 't';
@INC = '../lib';
+ $0 =~ s/\.dp$//; # for the test.deparse make target
+ 1;
+
diff -c 'perl-5.7.1/t/base/lex.t' 'perl-5.7.2/t/base/lex.t'
Index: ./t/base/lex.t
*** ./t/base/lex.t Tue Mar 6 04:06:49 2001
--- ./t/base/lex.t Mon Jul 9 17:11:21 2001
***************
*** 1,6 ****
#!./perl
! print "1..51\n";
$x = 'x';
--- 1,6 ----
#!./perl
! print "1..54\n";
$x = 'x';
***************
*** 130,139 ****
if (eval "\$ {\cX}" != 17 or $@) { print "not " }
print "ok 32\n";
! eval "\$\cN = 24"; # Literal control character
! if ($@ or ${"\cN"} != 24) { print "not " }
print "ok 33\n";
! if ($^N != 24) { print "not " } # Control character escape sequence
print "ok 34\n";
# Does the old UNBRACED syntax still do what it used to?
--- 130,139 ----
if (eval "\$ {\cX}" != 17 or $@) { print "not " }
print "ok 32\n";
! eval "\$\cQ = 24"; # Literal control character
! if ($@ or ${"\cQ"} != 24) { print "not " }
print "ok 33\n";
! if ($^Q != 24) { print "not " } # Control character escape sequence
print "ok 34\n";
# Does the old UNBRACED syntax still do what it used to?
***************
*** 141,151 ****
print "ok 35\n";
sub XX () { 6 }
! $ {"\cN\cXX"} = 119;
! $^N = 5; # This should be an unused ^Var.
$N = 5;
# The second caret here should be interpreted as an xor
! if (($^N^XX) != 3) { print "not " }
print "ok 36\n";
# if (($N ^ XX()) != 3) { print "not " }
# print "ok 32\n";
--- 141,151 ----
print "ok 35\n";
sub XX () { 6 }
! $ {"\cQ\cXX"} = 119;
! $^Q = 5; # This should be an unused ^Var.
$N = 5;
# The second caret here should be interpreted as an xor
! if (($^Q^XX) != 3) { print "not " }
print "ok 36\n";
# if (($N ^ XX()) != 3) { print "not " }
# print "ok 32\n";
***************
*** 166,178 ****
# Now let's make sure that caret variables are all forced into the main package.
package Someother;
! $^N = 'Someother';
! $ {^Nostril} = 'Someother 2';
$ {^M} = 'Someother 3';
package main;
! print "not " unless $^N eq 'Someother';
print "ok 39\n";
! print "not " unless $ {^Nostril} eq 'Someother 2';
print "ok 40\n";
print "not " unless $ {^M} eq 'Someother 3';
print "ok 41\n";
--- 166,178 ----
# Now let's make sure that caret variables are all forced into the main package.
package Someother;
! $^Q = 'Someother';
! $ {^Quixote} = 'Someother 2';
$ {^M} = 'Someother 3';
package main;
! print "not " unless $^Q eq 'Someother';
print "ok 39\n";
! print "not " unless $ {^Quixote} eq 'Someother 2';
print "ok 40\n";
print "not " unless $ {^M} eq 'Someother 3';
print "ok 41\n";
***************
*** 245,247 ****
--- 245,262 ----
print "ok $test\n";
++$test;
}
+
+ # Tests 52-54
+ # => should only quote foo::bar if it isn't a real sub. AMS, 20010621
+
+ sub xyz::foo { "bar" }
+ my %str = (
+ foo => 1,
+ xyz::foo => 1,
+ xyz::bar => 1,
+ );
+
+ my $test = 52;
+ print ((exists $str{foo} ? "" : "not ")."ok $test\n"); ++$test;
+ print ((exists $str{bar} ? "" : "not ")."ok $test\n"); ++$test;
+ print ((exists $str{xyz::bar} ? "" : "not ")."ok $test\n"); ++$test;
diff -c 'perl-5.7.1/t/base/term.t' 'perl-5.7.2/t/base/term.t'
Index: ./t/base/term.t
*** ./t/base/term.t Tue Mar 6 04:06:49 2001
--- ./t/base/term.t Mon Jul 9 17:11:21 2001
***************
*** 11,18 ****
# check "" interpretation
$x = "\n";
! # 10 is ASCII/Iso Latin, 21 is EBCDIC.
if ($x eq chr(10)) { print "ok 1\n";}
elsif ($x eq chr(21)) { print "ok 1 # EBCDIC\n"; }
else {print "not ok 1\n";}
--- 11,19 ----
# check "" interpretation
$x = "\n";
! # 10 is ASCII/Iso Latin, 13 is Mac OS, 21 is EBCDIC.
if ($x eq chr(10)) { print "ok 1\n";}
+ elsif ($x eq chr(13)) { print "ok 1 # Mac OS\n"; }
elsif ($x eq chr(21)) { print "ok 1 # EBCDIC\n"; }
else {print "not ok 1\n";}
***************
*** 39,45 ****
# check <> pseudoliteral
! open(try, "/dev/null") || open(try,"nla0:") || (die "Can't open /dev/null.");
if (<try> eq '') {
print "ok 6\n";
}
--- 40,46 ----
# check <> pseudoliteral
! open(try, "/dev/null") || open(try,"Dev:Null") || open(try,"nla0:") || (die "Can't open /dev/null.");
if (<try> eq '') {
print "ok 6\n";
}
diff -c 'perl-5.7.1/t/cmd/for.t' 'perl-5.7.2/t/cmd/for.t'
Index: ./t/cmd/for.t
*** ./t/cmd/for.t Tue Mar 6 04:06:49 2001
--- ./t/cmd/for.t Mon Jul 9 17:11:21 2001
***************
*** 1,6 ****
#!./perl
! print "1..10\n";
for ($i = 0; $i <= 10; $i++) {
$x[$i] = $i;
--- 1,6 ----
#!./perl
! print "1..11\n";
for ($i = 0; $i <= 10; $i++) {
$x[$i] = $i;
***************
*** 55,57 ****
--- 55,68 ----
print foo(1) == 1 ? "ok" : "not ok", " 8\n";
print foo(2) == 2 ? "ok" : "not ok", " 9\n";
print foo(5) == 5 ? "ok" : "not ok", " 10\n";
+
+ sub bar {
+ return (1, 2, 4);
+ }
+
+ $a = 0;
+ foreach $b (bar()) {
+ $a += $b;
+ }
+ print $a == 7 ? "ok" : "not ok", " 11\n";
+
diff -c 'perl-5.7.1/t/comp/cpp.t' 'perl-5.7.2/t/comp/cpp.t'
Index: ./t/comp/cpp.t
*** ./t/comp/cpp.t Tue Mar 6 04:06:50 2001
--- ./t/comp/cpp.t Mon Jul 9 17:11:22 2001
***************
*** 8,14 ****
}
use Config;
! if ( $^O eq 'MSWin32' or
($Config{'cppstdin'} =~ /\bcppstdin\b/) and
( ! -x $Config{'binexp'} . "/cppstdin") ) {
print "1..0 # Skip: \$Config{cppstdin} unavailable\n";
--- 8,14 ----
}
use Config;
! if ( $^O eq 'MSWin32' or $^O eq 'MacOS' or
($Config{'cppstdin'} =~ /\bcppstdin\b/) and
( ! -x $Config{'binexp'} . "/cppstdin") ) {
print "1..0 # Skip: \$Config{cppstdin} unavailable\n";
diff -c 'perl-5.7.1/t/comp/multiline.t' 'perl-5.7.2/t/comp/multiline.t'
Index: ./t/comp/multiline.t
*** ./t/comp/multiline.t Tue Mar 6 04:06:50 2001
--- ./t/comp/multiline.t Mon Jul 9 17:11:22 2001
***************
*** 36,42 ****
if ($count == 7) {print "ok 3\n";} else {print "not ok 3\n";}
! $_ = ($^O eq 'MSWin32') ? `type Comp.try` : `cat Comp.try`;
if (/.*\n.*\n.*\n$/) {print "ok 4\n";} else {print "not ok 4\n";}
--- 36,44 ----
if ($count == 7) {print "ok 3\n";} else {print "not ok 3\n";}
! $_ = (($^O eq 'MSWin32') || $^O eq 'NetWare') ? `type Comp.try`
! : ($^O eq 'MacOS') ? `catenate Comp.try`
! : `cat Comp.try`;
if (/.*\n.*\n.*\n$/) {print "ok 4\n";} else {print "not ok 4\n";}
diff -c 'perl-5.7.1/t/comp/proto.t' 'perl-5.7.2/t/comp/proto.t'
Index: ./t/comp/proto.t
*** ./t/comp/proto.t Tue Mar 20 06:41:13 2001
--- ./t/comp/proto.t Mon Jul 9 17:11:22 2001
***************
*** 16,22 ****
use strict;
! print "1..124\n";
my $i = 1;
--- 16,22 ----
use strict;
! print "1..125\n";
my $i = 1;
***************
*** 492,498 ****
# string "parse error".
#
for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) {
! no warnings 'redefine';
my $eval = "sub evaled_subroutine $p { &void *; }";
eval $eval;
print "# eval[$eval]\nnot " unless $@ && $@ =~ /(parse|syntax) error/i;
--- 492,498 ----
# string "parse error".
#
for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) {
! no warnings 'prototype';
my $eval = "sub evaled_subroutine $p { &void *; }";
eval $eval;
print "# eval[$eval]\nnot " unless $@ && $@ =~ /(parse|syntax) error/i;
***************
*** 501,504 ****
--- 501,508 ----
# Not $$;$;$
print "not " unless prototype "CORE::substr" eq '$$;$$';
+ print "ok ", $i++, "\n";
+
+ # recv takes a scalar reference for its second argument
+ print "not " unless prototype "CORE::recv" eq '*\\$$$';
print "ok ", $i++, "\n";
diff -c 'perl-5.7.1/t/comp/script.t' 'perl-5.7.2/t/comp/script.t'
Index: ./t/comp/script.t
*** ./t/comp/script.t Tue Mar 6 04:06:50 2001
--- ./t/comp/script.t Mon Jul 9 17:11:22 2001
***************
*** 4,10 ****
print "1..3\n";
! $PERL = ($^O eq 'MSWin32') ? '.\perl' : './perl';
$x = `$PERL -le "print 'ok';"`;
if ($x eq "ok\n") {print "ok 1\n";} else {print "not ok 1\n";}
--- 4,12 ----
print "1..3\n";
! $PERL = ($^O eq 'MSWin32') ? '.\perl'
! : (($^O eq 'NetWare') ? 'perl'
! : ($^O eq 'MacOS') ? $^X : './perl');
$x = `$PERL -le "print 'ok';"`;
if ($x eq "ok\n") {print "ok 1\n";} else {print "not ok 1\n";}
diff -c 'perl-5.7.1/t/harness' 'perl-5.7.2/t/harness'
Index: ./t/harness
*** ./t/harness Tue Mar 6 04:06:51 2001
--- ./t/harness Mon Jul 9 17:11:22 2001
***************
*** 29,35 ****
op/runlevel.t 1
op/tie.t 1
op/lex_assign.t 1
- pragma/subs.t 1
);
foreach (keys %datahandle) {
--- 29,34 ----
***************
*** 36,43 ****
unlink "$_.t";
}
! @tests = @ARGV;
! @tests = <base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t lib/*.t camel-III/*.t> unless @tests;
Test::Harness::runtests @tests;
exit(0) unless -e "../testcompile";
--- 35,60 ----
unlink "$_.t";
}
! if (@ARGV) {
! @tests = @ARGV;
! } else {
! unless (@tests) {
! @tests = <base/*.t comp/*.t cmd/*.t run/*.t io/*.t op/*.t lib/*.t>;
! use File::Spec;
! my $updir = File::Spec->updir;
! my $mani = File::Spec->catdir(File::Spec->updir, "MANIFEST");
! if (open(MANI, $mani)) {
! while (<MANI>) { # similar code in t/TEST
! if (m!^(ext/\S+/([^/]+\.t|test\.pl)|lib/\S+?(\.t|test\.pl))\s!) {
! push @tests, File::Spec->catdir($updir, $1);
! }
! }
! } else {
! warn "$0: cannot open $mani: $!\n";
! }
! push @tests, <pod/*.t>;
! }
! }
Test::Harness::runtests @tests;
exit(0) unless -e "../testcompile";
diff -c 'perl-5.7.1/t/io/argv.t' 'perl-5.7.2/t/io/argv.t'
Index: ./t/io/argv.t
*** ./t/io/argv.t Tue Mar 6 04:06:51 2001
--- ./t/io/argv.t Mon Jul 9 17:11:22 2001
***************
*** 18,23 ****
--- 18,26 ----
if ($^O eq 'MSWin32') {
$x = `.\\perl -e "while (<>) {print \$.,\$_;}" Io_argv1.tmp Io_argv1.tmp`;
}
+ elsif ($^O eq 'NetWare') {
+ $x = `perl -e "while (<>) {print \$.,\$_;}" Io_argv1.tmp Io_argv1.tmp`;
+ }
else {
$x = `./perl -e 'while (<>) {print \$.,\$_;}' Io_argv1.tmp Io_argv1.tmp`;
}
***************
*** 26,31 ****
--- 29,37 ----
if ($^O eq 'MSWin32') {
$x = `.\\perl -le "print 'foo'" | .\\perl -e "while (<>) {print \$_;}" Io_argv1.tmp -`;
}
+ elsif ($^O eq 'NetWare') {
+ $x = `perl -le "print 'foo'" | perl -e "while (<>) {print \$_;}" Io_argv1.tmp -`;
+ }
else {
$x = `echo foo|./perl -e 'while (<>) {print $_;}' Io_argv1.tmp -`;
}
***************
*** 33,38 ****
--- 39,47 ----
if ($^O eq 'MSWin32') {
$x = `.\\perl -le "print 'foo'" |.\\perl -e "while (<>) {print \$_;}"`;
+ }
+ elsif ($^O eq 'NetWare') {
+ $x = `perl -le "print 'foo'" | perl -e "while (<>) {print \$_;}"`;
}
else {
$x = `echo foo|./perl -e 'while (<>) {print $_;}'`;
diff -c 'perl-5.7.1/t/io/dup.t' 'perl-5.7.2/t/io/dup.t'
Index: ./t/io/dup.t
*** ./t/io/dup.t Tue Mar 6 04:06:51 2001
--- ./t/io/dup.t Mon Jul 9 17:11:22 2001
***************
*** 28,34 ****
open(STDOUT,">&dupout");
open(STDERR,">&duperr");
! if ($^O eq 'MSWin32') { print `type Io.dup` }
else { system 'cat Io.dup' }
unlink 'Io.dup';
--- 28,34 ----
open(STDOUT,">&dupout");
open(STDERR,">&duperr");
! if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { print `type Io.dup` }
else { system 'cat Io.dup' }
unlink 'Io.dup';
diff -c /dev/null 'perl-5.7.2/t/io/fflush.t'
Index: ./t/io/fflush.t
*** ./t/io/fflush.t Thu Jan 1 02:00:00 1970
--- ./t/io/fflush.t Mon Jul 9 17:11:22 2001
***************
*** 0 ****
--- 1,131 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # Script to test auto flush on fork/exec/system/qx. The idea is to
+ # print "Pe" to a file from a parent process and "rl" to the same file
+ # from a child process. If buffers are flushed appropriately, the
+ # file should contain "Perl". We'll see...
+ use Config;
+ use warnings;
+ use strict;
+
+ # This attempts to mirror the #ifdef forest found in perl.h so that we
+ # know when to run these tests. If that forest ever changes, change
+ # it here too or expect test gratuitous test failures.
+ my $useperlio = defined $Config{useperlio} ? $Config{useperlio} eq 'define' ? 1 : 0 : 0;
+ my $fflushNULL = defined $Config{fflushNULL} ? $Config{fflushNULL} eq 'define' ? 1 : 0 : 0;
+ my $d_sfio = defined $Config{d_sfio} ? $Config{d_sfio} eq 'define' ? 1 : 0 : 0;
+ my $fflushall = defined $Config{fflushall} ? $Config{fflushall} eq 'define' ? 1 : 0 : 0;
+ my $d_fork = defined $Config{d_fork} ? $Config{d_fork} eq 'define' ? 1 : 0 : 0;
+
+ if ($useperlio || $fflushNULL || $d_sfio) {
+ print "1..4\n";
+ } else {
+ if ($fflushall) {
+ print "1..4\n";
+ } else {
+ print "1..0 # Skip: fflush(NULL) or equivalent not available\n";
+ exit;
+ }
+ }
+
+ my $runperl = qq{$^X "-I../lib"};
+ my @delete;
+
+ END {
+ for (@delete) {
+ unlink $_ or warn "unlink $_: $!";
+ }
+ }
+
+ sub file_eq {
+ my $f = shift;
+ my $val = shift;
+
+ open IN, $f or die "open $f: $!";
+ chomp(my $line = <IN>);
+ close IN;
+
+ print "# got $line\n";
+ print "# expected $val\n";
+ return $line eq $val;
+ }
+
+ # This script will be used as the command to execute from
+ # child processes
+ open PROG, "> ff-prog" or die "open ff-prog: $!";
+ print PROG <<'EOF';
+ my $f = shift;
+ my $str = shift;
+ open OUT, ">> $f" or die "open $f: $!";
+ print OUT $str;
+ close OUT;
+ EOF
+ ;
+ close PROG;
+ push @delete, "ff-prog";
+
+ $| = 0; # we want buffered output
+
+ # Test flush on fork/exec
+ if (!$d_fork) {
+ print "ok 1 # skipped: no fork\n";
+ } else {
+ my $f = "ff-fork-$$";
+ open OUT, "> $f" or die "open $f: $!";
+ print OUT "Pe";
+ my $pid = fork;
+ if ($pid) {
+ # Parent
+ wait;
+ close OUT or die "close $f: $!";
+ } elsif (defined $pid) {
+ # Kid
+ print OUT "r";
+ my $command = qq{$runperl "ff-prog" "$f" "l"};
+ print "# $command\n";
+ exec $command or die $!;
+ exit;
+ } else {
+ # Bang
+ die "fork: $!";
+ }
+
+ print file_eq($f, "Perl") ? "ok 1\n" : "not ok 1\n";
+ push @delete, $f;
+ }
+
+ # Test flush on system/qx/pipe open
+ my %subs = (
+ "system" => sub {
+ my $c = shift;
+ system $c;
+ },
+ "qx" => sub {
+ my $c = shift;
+ qx{$c};
+ },
+ "popen" => sub {
+ my $c = shift;
+ open PIPE, "$c|" or die "$c: $!";
+ close PIPE;
+ },
+ );
+ my $t = 2;
+ for (qw(system qx popen)) {
+ my $code = $subs{$_};
+ my $f = "ff-$_-$$";
+ my $command = qq{$runperl "ff-prog" "$f" "rl"};
+ open OUT, "> $f" or die "open $f: $!";
+ print OUT "Pe";
+ close OUT;
+ print "# $command\n";
+ $code->($command);
+ print file_eq($f, "Perl") ? "ok $t\n" : "not ok $t\n";
+ push @delete, $f;
+ ++$t;
+ }
diff -c 'perl-5.7.1/t/io/fs.t' 'perl-5.7.2/t/io/fs.t'
Index: ./t/io/fs.t
*** ./t/io/fs.t Fri Mar 30 17:35:44 2001
--- ./t/io/fs.t Mon Jul 9 17:11:22 2001
***************
*** 9,16 ****
use Config;
! $Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or
! $^O eq 'os2' or $^O eq 'mint');
if (defined &Win32::IsWinNT && Win32::IsWinNT()) {
$Is_Dosish = '' if Win32::FsType() eq 'NTFS';
--- 9,17 ----
use Config;
! $Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'NetWare' or $^O eq 'dos' or
! $^O eq 'os2' or $^O eq 'mint' or $^O eq 'cygwin' or
! $^O eq 'mpeix');
if (defined &Win32::IsWinNT && Win32::IsWinNT()) {
$Is_Dosish = '' if Win32::FsType() eq 'NTFS';
***************
*** 18,27 ****
print "1..29\n";
! $wd = (($^O eq 'MSWin32') ? `cd` : `pwd`);
chop($wd);
! if ($^O eq 'MSWin32') { `rmdir /s /q tmp 2>nul`; `mkdir tmp`; }
else { `rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`; }
chdir './tmp';
`/bin/rm -rf a b c x` if -x '/bin/rm';
--- 19,28 ----
print "1..29\n";
! $wd = ((($^O eq 'MSWin32') || ($^O eq 'NetWare')) ? `cd` : `pwd`);
chop($wd);
! if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { `rmdir /s /q tmp 2>nul`; `mkdir tmp`; }
else { `rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`; }
chdir './tmp';
`/bin/rm -rf a b c x` if -x '/bin/rm';
***************
*** 28,34 ****
umask(022);
! if ($^O eq 'MSWin32') { print "ok 1 # skipped: bogus umask()\n"; }
elsif ((umask(0)&0777) == 022) {print "ok 1\n";} else {print "not ok 1\n";}
open(fh,'>x') || die "Can't create x";
close(fh);
--- 29,35 ----
umask(022);
! if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { print "ok 1 # skipped: bogus umask()\n"; }
elsif ((umask(0)&0777) == 022) {print "ok 1\n";} else {print "not ok 1\n";}
open(fh,'>x') || die "Can't create x";
close(fh);
***************
*** 58,64 ****
{print "ok 5\n";}
else {print "not ok 5\n";}
! $newmode = $^O eq 'MSWin32' ? 0444 : 0777;
if ((chmod $newmode,'a') == 1) {print "ok 6\n";} else {print "not ok 6\n";}
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
--- 59,65 ----
{print "ok 5\n";}
else {print "not ok 5\n";}
! $newmode = (($^O eq 'MSWin32') || ($^O eq 'NetWare')) ? 0444 : 0777;
if ((chmod $newmode,'a') == 1) {print "ok 6\n";} else {print "not ok 6\n";}
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
***************
*** 68,74 ****
else {print "not ok 7\n";}
$newmode = 0700;
! if ($^O eq 'MSWin32') {
chmod 0444, 'x';
$newmode = 0666;
}
--- 69,75 ----
else {print "not ok 7\n";}
$newmode = 0700;
! if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) {
chmod 0444, 'x';
$newmode = 0666;
}
***************
*** 109,117 ****
if ($foo == 1) {print "ok 16\n";} else {print "not ok 16 $foo\n";}
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat('b');
! if ($^O eq 'MSWin32') { print "ok 17 # skipped: bogus (stat)[1]\n"; }
elsif ($ino) {print "ok 17\n";} else {print "not ok 17\n";}
! if ($wd =~ m#/afs/# || $^O eq 'amigaos' || $^O eq 'dos' || $^O eq 'MSWin32')
{print "ok 18 # skipped: granularity of the filetime\n";}
elsif ($atime == 500000000 && $mtime == 500000000 + $delta)
{print "ok 18\n";}
--- 110,118 ----
if ($foo == 1) {print "ok 16\n";} else {print "not ok 16 $foo\n";}
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat('b');
! if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) { print "ok 17 # skipped: bogus (stat)[1]\n"; }
elsif ($ino) {print "ok 17\n";} else {print "not ok 17\n";}
! if ($wd =~ m#$Config{'afsroot'}/# || $^O eq 'amigaos' || $^O eq 'dos' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'cygwin')
{print "ok 18 # skipped: granularity of the filetime\n";}
elsif ($atime == 500000000 && $mtime == 500000000 + $delta)
{print "ok 18\n";}
***************
*** 135,141 ****
chdir $wd || die "Can't cd back to $wd";
unlink 'c';
! if ($^O ne 'MSWin32' and `ls -l perl 2>/dev/null` =~ /^l.*->/) {
# we have symbolic links
system("cp TEST TEST$$");
# we have to copy because e.g. GNU grep gets huffy if we have
--- 136,142 ----
chdir $wd || die "Can't cd back to $wd";
unlink 'c';
! if ((($^O eq 'MSWin32') || ($^O eq 'NetWare')) and `ls -l perl 2>/dev/null` =~ /^l.*->/) {
# we have symbolic links
system("cp TEST TEST$$");
# we have to copy because e.g. GNU grep gets huffy if we have
diff -c 'perl-5.7.1/t/io/inplace.t' 'perl-5.7.2/t/io/inplace.t'
Index: ./t/io/inplace.t
*** ./t/io/inplace.t Tue Mar 6 04:06:51 2001
--- ./t/io/inplace.t Mon Jul 9 17:11:22 2001
***************
*** 13,18 ****
--- 13,24 ----
`.\\perl -le "print 'foo'" > .b`;
`.\\perl -le "print 'foo'" > .c`;
}
+ elsif ($^O eq 'NetWare') {
+ $CAT = 'perl -e "print<>"';
+ `perl -le "print 'foo'" > .a`;
+ `perl -le "print 'foo'" > .b`;
+ `perl -le "print 'foo'" > .c`;
+ }
elsif ($^O eq 'VMS') {
$CAT = 'MCR []perl. -e "print<>"';
`MCR []perl. -le "print 'foo'" > ./.a`;
diff -c 'perl-5.7.1/t/io/iprefix.t' 'perl-5.7.2/t/io/iprefix.t'
Index: ./t/io/iprefix.t
*** ./t/io/iprefix.t Tue Mar 6 04:06:51 2001
--- ./t/io/iprefix.t Mon Jul 9 17:11:22 2001
***************
*** 13,18 ****
--- 13,24 ----
`.\\perl -le "print 'foo'" > .b`;
`.\\perl -le "print 'foo'" > .c`;
}
+ elsif ($^O eq 'NetWare') {
+ $CAT = 'perl -e "print<>"';
+ `perl -le "print 'foo'" > .a`;
+ `perl -le "print 'foo'" > .b`;
+ `perl -le "print 'foo'" > .c`;
+ }
elsif ($^O eq 'VMS') {
$CAT = 'MCR []perl. -e "print<>"';
`MCR []perl. -le "print 'foo'" > ./.a`;
diff -c 'perl-5.7.1/t/io/tell.t' 'perl-5.7.2/t/io/tell.t'
Index: ./t/io/tell.t
*** ./t/io/tell.t Tue Mar 6 04:06:52 2001
--- ./t/io/tell.t Mon Jul 9 17:11:22 2001
***************
*** 6,12 ****
$TST = 'tst';
! $Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or
$^O eq 'os2' or $^O eq 'mint' or $^O eq 'cygwin');
open($TST, 'harness') || (die "Can't open harness");
--- 6,12 ----
$TST = 'tst';
! $Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'NetWare' or $^O eq 'dos' or
$^O eq 'os2' or $^O eq 'mint' or $^O eq 'cygwin');
open($TST, 'harness') || (die "Can't open harness");
***************
*** 50,56 ****
$curline = $.;
open(other, 'harness') || (die "Can't open harness: $!");
! binmode other if $^O eq 'MSWin32';
{
local($.);
--- 50,56 ----
$curline = $.;
open(other, 'harness') || (die "Can't open harness: $!");
! binmode other if (($^O eq 'MSWin32') || ($^O eq 'NetWare'));
{
local($.);
diff -c 'perl-5.7.1/t/io/utf8.t' 'perl-5.7.2/t/io/utf8.t'
Index: ./t/io/utf8.t
*** ./t/io/utf8.t Thu Apr 5 06:55:04 2001
--- ./t/io/utf8.t Mon Jul 9 17:11:22 2001
***************
*** 3,14 ****
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
! unless (exists $open::layers{'perlio'}) {
print "1..0 # Skip: not perlio\n";
exit 0;
}
}
$| = 1;
my $total_tests = 25;
if (ord('A') == 193) { $total_tests = 24; } # EBCDIC platforms do not warn on UTF-8
--- 3,16 ----
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
! unless (find PerlIO::Layer 'perlio') {
print "1..0 # Skip: not perlio\n";
exit 0;
}
}
+ no utf8; # so that the naked 8-bit chars won't gripe under use utf8
+
$| = 1;
my $total_tests = 25;
if (ord('A') == 193) { $total_tests = 24; } # EBCDIC platforms do not warn on UTF-8
***************
*** 175,179 ****
--- 177,182 ----
eval { sprintf "%vd\n", $x; }
}
+ close F;
unlink('a');
diff -c 'perl-5.7.1/t/lib/1_compile.t' 'perl-5.7.2/t/lib/1_compile.t'
Index: ./t/lib/1_compile.t
*** ./t/lib/1_compile.t Fri Mar 30 07:26:27 2001
--- ./t/lib/1_compile.t Fri Jul 13 07:36:00 2001
***************
*** 61,66 ****
--- 61,68 ----
delete_by_prefix('File::Spec::'); # File::Spec's domain
add_by_name('File::Spec::Functions'); # put this back
+ delete_by_prefix('Attribute::Handlers');# we test this, and we have demos
+
sub using_feature {
my $use = "use$_[0]";
exists $Config{$use} &&
***************
*** 73,81 ****
delete_by_prefix('Thread::');
}
delete_by_prefix('unicode::');
- add_by_name('unicode::distinct'); # put this back
# Okay, this is the list.
my @Core_Modules = sort keys %Core_Modules;
--- 75,93 ----
delete_by_prefix('Thread::');
}
+ unless (has_extension('NDBM_File')) {
+ delete_by_name('Memoize::NDBM_File');
+ }
+
delete_by_prefix('unicode::');
+ # Delete all modules which have their own tests.
+ # This makes this test a lot faster.
+ foreach my $mod (<DATA>) {
+ chomp $mod;
+ delete_by_name($mod);
+ }
+
# Okay, this is the list.
my @Core_Modules = sort keys %Core_Modules;
***************
*** 95,99 ****
sub compile_module {
my ($module) = $_[0];
! return scalar `$^X "-Ilib" t/lib/compmod.pl $module` =~ /^ok/;
}
--- 107,286 ----
sub compile_module {
my ($module) = $_[0];
! my $out = scalar `$^X "-Ilib" t/lib/compmod.pl $module`;
! print "# $out";
! return $out =~ /^ok/;
}
+
+ # Add here modules that have their own test scripts and therefore
+ # need not be test-compiled by 1_compile.t.
+ __DATA__
+ AnyDBM_File
+ Attribute::Handlers
+ AutoLoader
+ B
+ B::Debug
+ B::Deparse
+ B::ShowLex
+ B::Stash
+ Benchmark
+ CGI
+ CGI::Pretty
+ CGI::Util
+ Carp
+ Carp::Heavy
+ Class::ISA
+ Class::Struct
+ CPAN
+ Cwd
+ DB_File
+ Data::Dumper
+ Devel::DProf
+ Devel::Peek
+ Devel::SelfStubber
+ Digest
+ Digest::MD5
+ DirHandle
+ Dumpvalue
+ Encode
+ English
+ Env
+ Errno
+ Exporter
+ Exporter::Heavy
+ ExtUtils::Constant
+ ExtUtils::MakeMaker
+ Fatal
+ Fcntl
+ File::Basename
+ File::CheckTree
+ File::Compare
+ File::Copy
+ File::DosGlob
+ File::Find
+ File::Glob
+ File::Path
+ File::Spec
+ File::Spec::Functions
+ File::Temp
+ File::stat
+ FileCache
+ FileHandle
+ Filter::Simple
+ Filter::Util::Call
+ FindBin
+ GDBM_File
+ Getopt::Long
+ Getopt::Std
+ I18N::Langinfo
+ I18N::LangTags
+ I18N::LangTags::List
+ I18N::Collate
+ IO::Dir
+ IO::File
+ IO::Handle
+ IO::Pipe
+ IO::Poll
+ IO::Seekable
+ IO::Select
+ IO::Socket
+ IO::Socket::INET
+ IO::Socket::UNIX
+ IPC::Open2
+ IPC::Open3
+ IPC::SysV
+ List::Util
+ Locale::Constants
+ Locale::Country
+ Locale::Currency
+ Locale::Language
+ Locale::Maketext
+ MIME::Base64
+ MIME::QuotedPrint
+ Math::BigFloat
+ Math::BigInt
+ Math::BigInt::Calc
+ Math::Complex
+ Math::Trig
+ Memoize
+ Memoize::AnyDBM_File
+ Memoize::Expire
+ Memoize::ExpireFile
+ Memoize::ExpireTest
+ Memoize::NDBM_File
+ Memoize::SDBM_File
+ Memoize::Storable
+ NDBM_File
+ NEXT
+ Net::hostent
+ Net::netent
+ Net::protoent
+ Net::servent
+ ODBM_File
+ Opcode
+ PerlIO
+ POSIX
+ Pod::Checker
+ Pod::Find
+ Pod::Text
+ Pod::Usage
+ SDBM_File
+ Safe
+ Scalar::Util
+ Search::Dict
+ SelectSaver
+ SelfLoader
+ Socket
+ Storable
+ Switch
+ Symbol
+ Sys::Hostname
+ Sys::Syslog
+ Term::ANSIColor
+ Test
+ Test::Harness
+ Test::More
+ Test::Simple
+ Test::ParseWords
+ Text::Abbrev
+ Text::Balanced
+ Text::ParseWords
+ Text::Soundex
+ Text::Tabs
+ Text::Wrap
+ Thread
+ Tie::Array
+ Tie::Handle
+ Tie::Hash
+ Tie::RefHash
+ Tie::Scalar
+ Tie::SubstrHash
+ Time::HiRes
+ Time::Local
+ Time::Piece
+ Time::gmtime
+ Time::localtime
+ Time::tm
+ UnicodeCD
+ UNIVERSAL
+ User::grent
+ User::pwent
+ XS::Typemap
+ attributes
+ attrs
+ autouse
+ base
+ bytes
+ charnames
+ constant
+ diagnostics
+ fields
+ integer
+ locale
+ ops
+ overload
+ strict
+ subs
+ utf8
+ warnings
+ warnings::register
diff -c /dev/null 'perl-5.7.2/t/lib/MyFilter.pm'
Index: ./t/lib/MyFilter.pm
*** ./t/lib/MyFilter.pm Thu Jan 1 02:00:00 1970
--- ./t/lib/MyFilter.pm Mon Jul 9 17:11:22 2001
***************
*** 0 ****
--- 1,14 ----
+ package MyFilter;
+
+ BEGIN {
+ chdir('t') if -d 't';
+ @INC = '../lib';
+ }
+
+ use Filter::Simple sub {
+ while (my ($from, $to) = splice @_, 0, 2) {
+ s/$from/$to/g;
+ }
+ };
+
+ 1;
diff -c /dev/null 'perl-5.7.2/t/lib/Test/More/Catch.pm'
Index: ./t/lib/Test/More/Catch.pm
*** ./t/lib/Test/More/Catch.pm Thu Jan 1 02:00:00 1970
--- ./t/lib/Test/More/Catch.pm Mon Jul 9 17:11:23 2001
***************
*** 0 ****
--- 1,30 ----
+ # For testing Test::More;
+ package Catch;
+
+ my $out = tie *Test::Simple::TESTOUT, 'Catch';
+ tie *Test::More::TESTOUT, 'Catch', $out;
+ my $err = tie *Test::More::TESTERR, 'Catch';
+ tie *Test::Simple::TESTERR, 'Catch', $err;
+
+ # We have to use them to shut up a "used only once" warning.
+ () = (*Test::More::TESTOUT, *Test::More::TESTERR);
+
+ sub caught { return $out, $err }
+
+
+ sub PRINT {
+ my $self = shift;
+ $$self .= join '', @_;
+ }
+
+ sub TIEHANDLE {
+ my($class, $self) = @_;
+ my $foo = '';
+ $self = $self || \$foo;
+ return bless $self, $class;
+ }
+ sub READ {}
+ sub READLINE {}
+ sub GETC {}
+
+ 1;
diff -c /dev/null 'perl-5.7.2/t/lib/Test/Simple/Catch.pm'
Index: ./t/lib/Test/Simple/Catch.pm
*** ./t/lib/Test/Simple/Catch.pm Thu Jan 1 02:00:00 1970
--- ./t/lib/Test/Simple/Catch.pm Mon Jul 9 17:11:23 2001
***************
*** 0 ****
--- 1,29 ----
+ # For testing Test::Simple;
+ package Catch;
+
+ my $out = tie *Test::Simple::TESTOUT, 'Catch';
+ my $err = tie *Test::Simple::TESTERR, 'Catch';
+
+ # We have to use them to shut up a "used only once" warning.
+ () = (*Test::Simple::TESTOUT, *Test::Simple::TESTERR);
+
+ sub caught { return $out, $err }
+
+ # Prevent Test::Simple from exiting in its END block.
+ *Test::Simple::exit = sub {};
+
+ sub PRINT {
+ my $self = shift;
+ $$self .= join '', @_;
+ }
+
+ sub TIEHANDLE {
+ my $class = shift;
+ my $self = '';
+ return bless \$self, $class;
+ }
+ sub READ {}
+ sub READLINE {}
+ sub GETC {}
+
+ 1;
diff -c /dev/null 'perl-5.7.2/t/lib/Test/Simple/sample_tests/death.plx'
Index: ./t/lib/Test/Simple/sample_tests/death.plx
*** ./t/lib/Test/Simple/sample_tests/death.plx Thu Jan 1 02:00:00 1970
--- ./t/lib/Test/Simple/sample_tests/death.plx Mon Jul 9 17:11:23 2001
***************
*** 0 ****
--- 1,13 ----
+ require Test::Simple;
+
+ push @INC, 't', '.';
+ require Catch;
+ my($out, $err) = Catch::caught();
+
+ Test::Simple->import(tests => 5);
+ close STDERR;
+
+ ok(1);
+ ok(1);
+ ok(1);
+ die "Knife?";
diff -c /dev/null 'perl-5.7.2/t/lib/Test/Simple/sample_tests/death_in_eval.plx'
Index: ./t/lib/Test/Simple/sample_tests/death_in_eval.plx
*** ./t/lib/Test/Simple/sample_tests/death_in_eval.plx Thu Jan 1 02:00:00 1970
--- ./t/lib/Test/Simple/sample_tests/death_in_eval.plx Mon Jul 9 17:11:23 2001
***************
*** 0 ****
--- 1,22 ----
+ require Test::Simple;
+ use Carp;
+
+ push @INC, 't', '.';
+ require Catch;
+ my($out, $err) = Catch::caught();
+
+ Test::Simple->import(tests => 5);
+
+ ok(1);
+ ok(1);
+ ok(1);
+ eval {
+ die "Foo";
+ };
+ ok(1);
+ eval "die 'Bar'";
+ ok(1);
+
+ eval {
+ croak "Moo";
+ };
diff -c /dev/null 'perl-5.7.2/t/lib/Test/Simple/sample_tests/extras.plx'
Index: ./t/lib/Test/Simple/sample_tests/extras.plx
*** ./t/lib/Test/Simple/sample_tests/extras.plx Thu Jan 1 02:00:00 1970
--- ./t/lib/Test/Simple/sample_tests/extras.plx Mon Jul 9 17:11:23 2001
***************
*** 0 ****
--- 1,16 ----
+ require Test::Simple;
+
+ push @INC, 't', '.';
+ require Catch;
+ my($out, $err) = Catch::caught();
+
+ Test::Simple->import(tests => 5);
+
+
+ ok(1);
+ ok(1);
+ ok(1);
+ ok(1);
+ ok(0);
+ ok(1);
+ ok(0);
diff -c /dev/null 'perl-5.7.2/t/lib/Test/Simple/sample_tests/five_fail.plx'
Index: ./t/lib/Test/Simple/sample_tests/five_fail.plx
*** ./t/lib/Test/Simple/sample_tests/five_fail.plx Thu Jan 1 02:00:00 1970
--- ./t/lib/Test/Simple/sample_tests/five_fail.plx Mon Jul 9 17:11:23 2001
***************
*** 0 ****
--- 1,13 ----
+ require Test::Simple;
+
+ push @INC, 't', '.';
+ require Catch;
+ my($out, $err) = Catch::caught();
+
+ Test::Simple->import(tests => 5);
+
+ ok(0);
+ ok(0);
+ ok('');
+ ok(0);
+ ok(0);
diff -c /dev/null 'perl-5.7.2/t/lib/Test/Simple/sample_tests/last_minute_death.plx'
Index: ./t/lib/Test/Simple/sample_tests/last_minute_death.plx
*** ./t/lib/Test/Simple/sample_tests/last_minute_death.plx Thu Jan 1 02:00:00 1970
--- ./t/lib/Test/Simple/sample_tests/last_minute_death.plx Mon Jul 9 17:11:23 2001
***************
*** 0 ****
--- 1,16 ----
+ require Test::Simple;
+
+ push @INC, 't', '.';
+ require Catch;
+ my($out, $err) = Catch::caught();
+
+ Test::Simple->import(tests => 5);
+ close STDERR;
+
+ ok(1);
+ ok(1);
+ ok(1);
+ ok(1);
+ ok(1);
+
+ die "Almost there...";
diff -c /dev/null 'perl-5.7.2/t/lib/Test/Simple/sample_tests/one_fail.plx'
Index: ./t/lib/Test/Simple/sample_tests/one_fail.plx
*** ./t/lib/Test/Simple/sample_tests/one_fail.plx Thu Jan 1 02:00:00 1970
--- ./t/lib/Test/Simple/sample_tests/one_fail.plx Mon Jul 9 17:11:23 2001
***************
*** 0 ****
--- 1,14 ----
+ require Test::Simple;
+
+ push @INC, 't', '.';
+ require Catch;
+ my($out, $err) = Catch::caught();
+
+ Test::Simple->import(tests => 5);
+
+
+ ok(1);
+ ok(2);
+ ok(0);
+ ok(1);
+ ok(2);
diff -c /dev/null 'perl-5.7.2/t/lib/Test/Simple/sample_tests/require.plx'
Index: ./t/lib/Test/Simple/sample_tests/require.plx
*** ./t/lib/Test/Simple/sample_tests/require.plx Thu Jan 1 02:00:00 1970
--- ./t/lib/Test/Simple/sample_tests/require.plx Mon Jul 9 17:11:23 2001
***************
*** 0 ****
--- 1 ----
+ require Test::Simple;
diff -c /dev/null 'perl-5.7.2/t/lib/Test/Simple/sample_tests/success.plx'
Index: ./t/lib/Test/Simple/sample_tests/success.plx
*** ./t/lib/Test/Simple/sample_tests/success.plx Thu Jan 1 02:00:00 1970
--- ./t/lib/Test/Simple/sample_tests/success.plx Mon Jul 9 17:11:23 2001
***************
*** 0 ****
--- 1,13 ----
+ require Test::Simple;
+
+ push @INC, 't', '.';
+ require Catch;
+ my($out, $err) = Catch::caught();
+
+ Test::Simple->import(tests => 5);
+
+ ok(1);
+ ok(5, 'yep');
+ ok(3, 'beer');
+ ok("wibble", "wibble");
+ ok(1);
diff -c /dev/null 'perl-5.7.2/t/lib/Test/Simple/sample_tests/too_few.plx'
Index: ./t/lib/Test/Simple/sample_tests/too_few.plx
*** ./t/lib/Test/Simple/sample_tests/too_few.plx Thu Jan 1 02:00:00 1970
--- ./t/lib/Test/Simple/sample_tests/too_few.plx Mon Jul 9 17:11:23 2001
***************
*** 0 ****
--- 1,11 ----
+ require Test::Simple;
+
+ push @INC, 't', '.';
+ require Catch;
+ my($out, $err) = Catch::caught();
+
+ Test::Simple->import(tests => 5);
+
+
+ ok(1);
+ ok(0);
diff -c /dev/null 'perl-5.7.2/t/lib/Test/Simple/sample_tests/two_fail.plx'
Index: ./t/lib/Test/Simple/sample_tests/two_fail.plx
*** ./t/lib/Test/Simple/sample_tests/two_fail.plx Thu Jan 1 02:00:00 1970
--- ./t/lib/Test/Simple/sample_tests/two_fail.plx Mon Jul 9 17:11:23 2001
***************
*** 0 ****
--- 1,14 ----
+ require Test::Simple;
+
+ push @INC, 't', '.';
+ require Catch;
+ my($out, $err) = Catch::caught();
+
+ Test::Simple->import(tests => 5);
+
+
+ ok(0);
+ ok(1);
+ ok(1);
+ ok(0);
+ ok(1);
diff -c 'perl-5.7.1/t/lib/h2ph.h' 'perl-5.7.2/t/lib/h2ph.h'
Index: ./t/lib/h2ph.h
*** ./t/lib/h2ph.h Tue Mar 6 04:06:57 2001
--- ./t/lib/h2ph.h Mon Jul 9 17:11:23 2001
***************
*** 38,44 ****
#if !(defined __SOMETHING_MORE_IMPORTANT)
# warn Be careful...
#elif !(defined __SOMETHING_REALLY_REALLY_IMPORTANT)
! # error Nup, can't go on /* ' /* stupid font-lock-mode */
#else /* defined __SOMETHING_MORE_IMPORTANT && defined __SOMETHING_REALLY_REALLY_IMPORTANT */
# define EVERYTHING_IS_OK
#endif
--- 38,44 ----
#if !(defined __SOMETHING_MORE_IMPORTANT)
# warn Be careful...
#elif !(defined __SOMETHING_REALLY_REALLY_IMPORTANT)
! # error "Nup, can't go on" /* ' /* stupid font-lock-mode */
#else /* defined __SOMETHING_MORE_IMPORTANT && defined __SOMETHING_REALLY_REALLY_IMPORTANT */
# define EVERYTHING_IS_OK
#endif
***************
*** 81,85 ****
--- 81,101 ----
typedef enum _days_of_week { sun, mon, tue, wed, thu, fri, sat, Sun=0, Mon,
Tue, Wed, Thu, Fri, Sat } days_of_week;
+
+ /*
+ * Some moderate flexing of tri-graph pre substitution.
+ */
+ ??=ifndef _SOMETHING_TRIGRAPHIC
+ ??=define _SOMETHING_TRIGRAPHIC
+ ??= define SOMETHING_ELSE_TRIGRAPHIC_0 "??!" /* | ??!| || */
+ ??=define SOMETHING_ELSE_TRIGRAPHIC_1 "??'" /* | ??'| ^| */
+ ??= define SOMETHING_ELSE_TRIGRAPHIC_2 "??(" /* | ??(| [| */
+ ??= define SOMETHING_ELSE_TRIGRAPHIC_3 "??)" /* | ??)| ]| */
+ ??=define SOMETHING_ELSE_TRIGRAPHIC_4 "??-0" /* | ??-| ~| */
+ ??= define SOMETHING_ELSE_TRIGRAPHIC_5 "??/ " /* | ??/| \| */
+ ??= define SOMETHING_ELSE_TRIGRAPHIC_6 "??<" /* | ??<| {| */
+ ??=define SOMETHING_ELSE_TRIGRAPHIC_7 "??=" /* | ??=| #| */
+ ??= define SOMETHING_ELSE_TRIGRAPHIC_8 "??>" /* | ??>| }| */
+ ??=endif
#endif /* _H2PH_H_ */
diff -c 'perl-5.7.1/t/lib/h2ph.pht' 'perl-5.7.2/t/lib/h2ph.pht'
Index: ./t/lib/h2ph.pht
*** ./t/lib/h2ph.pht Tue Mar 6 04:06:57 2001
--- ./t/lib/h2ph.pht Mon Jul 9 17:11:23 2001
***************
*** 29,35 ****
if(!(defined (defined(&__SOMETHING_MORE_IMPORTANT) ? &__SOMETHING_MORE_IMPORTANT : 0))) {
}
elsif(!(defined (defined(&__SOMETHING_REALLY_REALLY_IMPORTANT) ? &__SOMETHING_REALLY_REALLY_IMPORTANT : 0))) {
! die("Nup\,\ can\'t\ go\ on\ ");
} else {
eval 'sub EVERYTHING_IS_OK () {1;}' unless defined(&EVERYTHING_IS_OK);
}
--- 29,35 ----
if(!(defined (defined(&__SOMETHING_MORE_IMPORTANT) ? &__SOMETHING_MORE_IMPORTANT : 0))) {
}
elsif(!(defined (defined(&__SOMETHING_REALLY_REALLY_IMPORTANT) ? &__SOMETHING_REALLY_REALLY_IMPORTANT : 0))) {
! die("Nup, can't go on");
} else {
eval 'sub EVERYTHING_IS_OK () {1;}' unless defined(&EVERYTHING_IS_OK);
}
***************
*** 67,71 ****
--- 67,83 ----
eval("sub Thu () { 4; }") unless defined(&Thu);
eval("sub Fri () { 5; }") unless defined(&Fri);
eval("sub Sat () { 6; }") unless defined(&Sat);
+ unless(defined(&_SOMETHING_TRIGRAPHIC)) {
+ eval 'sub _SOMETHING_TRIGRAPHIC () {1;}' unless defined(&_SOMETHING_TRIGRAPHIC);
+ eval 'sub SOMETHING_ELSE_TRIGRAPHIC_0 () {"|";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_0);
+ eval 'sub SOMETHING_ELSE_TRIGRAPHIC_1 () {"^";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_1);
+ eval 'sub SOMETHING_ELSE_TRIGRAPHIC_2 () {"[";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_2);
+ eval 'sub SOMETHING_ELSE_TRIGRAPHIC_3 () {"]";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_3);
+ eval 'sub SOMETHING_ELSE_TRIGRAPHIC_4 () {"~0";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_4);
+ eval 'sub SOMETHING_ELSE_TRIGRAPHIC_5 () {"\\ ";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_5);
+ eval 'sub SOMETHING_ELSE_TRIGRAPHIC_6 () {"{";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_6);
+ eval 'sub SOMETHING_ELSE_TRIGRAPHIC_7 () {"#";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_7);
+ eval 'sub SOMETHING_ELSE_TRIGRAPHIC_8 () {"}";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_8);
+ }
}
1;
diff -c /dev/null 'perl-5.7.2/t/lib/locale/latin1'
Index: ./t/lib/locale/latin1
*** ./t/lib/locale/latin1 Thu Jan 1 02:00:00 1970
--- ./t/lib/locale/latin1 Mon Jul 9 17:11:23 2001
***************
*** 0 ****
--- 1,10 ----
+ $locales .= <<EOF;
+ Catal� Catalan:ca:es:1 15
+ Fran�ais French:fr:be ca ch fr lu:1 15
+ G�idhlig Gaelic:gd:gb uk:1 14 15
+ F�royskt Faroese:fo:fo:1 15
+ �slensku Icelandic:is:is:1 15
+ S�mi Lappish:::4 6 13
+ Portugu�s Portuguese:po:po br:1 15
+ Espan�l Spanish:es:ar bo cl co cr do ec es gt hn mx ni pa pe py sv uy ve:1 15
+ EOF
diff -c /dev/null 'perl-5.7.2/t/lib/locale/utf8'
Index: ./t/lib/locale/utf8
*** ./t/lib/locale/utf8 Thu Jan 1 02:00:00 1970
--- ./t/lib/locale/utf8 Mon Jul 9 17:11:23 2001
***************
*** 0 ****
--- 1,10 ----
+ $locales .= <<EOF;
+ Catal�� Catalan:ca:es:1 15
+ Fran��ais French:fr:be ca ch fr lu:1 15
+ G��idhlig Gaelic:gd:gb uk:1 14 15
+ F��royskt Faroese:fo:fo:1 15
+ ��slensku Icelandic:is:is:1 15
+ S��mi Lappish:::4 6 13
+ Portugu��s Portuguese:po:po br:1 15
+ Espan��l Spanish:es:ar bo cl co cr do ec es gt hn mx ni pa pe py sv uy ve:1 15
+ EOF
diff -c /dev/null 'perl-5.7.2/t/lib/strict/refs'
Index: ./t/lib/strict/refs
*** ./t/lib/strict/refs Thu Jan 1 02:00:00 1970
--- ./t/lib/strict/refs Mon Jul 9 17:11:24 2001
***************
*** 0 ****
--- 1,297 ----
+ Check strict refs functionality
+
+ __END__
+
+ # no strict, should build & run ok.
+ my $fred ;
+ $b = "fred" ;
+ $a = $$b ;
+ $c = ${"def"} ;
+ $c = @{"def"} ;
+ $c = %{"def"} ;
+ $c = *{"def"} ;
+ $c = \&{"def"} ;
+ $c = def->[0];
+ $c = def->{xyz};
+ EXPECT
+
+ ########
+
+ # strict refs - error
+ use strict ;
+ my $fred ;
+ my $a = ${"fred"} ;
+ EXPECT
+ Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5.
+ ########
+
+ # strict refs - error
+ use strict 'refs' ;
+ my $fred ;
+ my $a = ${"fred"} ;
+ EXPECT
+ Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5.
+ ########
+
+ # strict refs - error
+ use strict 'refs' ;
+ my $fred ;
+ my $b = "fred" ;
+ my $a = $$b ;
+ EXPECT
+ Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 6.
+ ########
+
+ # strict refs - error
+ use strict 'refs' ;
+ my $b ;
+ my $a = $$b ;
+ EXPECT
+ Can't use an undefined value as a SCALAR reference at - line 5.
+ ########
+
+ # strict refs - error
+ use strict 'refs' ;
+ my $b ;
+ my $a = @$b ;
+ EXPECT
+ Can't use an undefined value as an ARRAY reference at - line 5.
+ ########
+
+ # strict refs - error
+ use strict 'refs' ;
+ my $b ;
+ my $a = %$b ;
+ EXPECT
+ Can't use an undefined value as a HASH reference at - line 5.
+ ########
+
+ # strict refs - error
+ use strict 'refs' ;
+ my $b ;
+ my $a = *$b ;
+ EXPECT
+ Can't use an undefined value as a symbol reference at - line 5.
+ ########
+
+ # strict refs - error
+ use strict 'refs' ;
+ my $a = fred->[0] ;
+ EXPECT
+ Can't use bareword ("fred") as an ARRAY ref while "strict refs" in use at - line 4.
+ ########
+
+ # strict refs - error
+ use strict 'refs' ;
+ my $a = fred->{barney} ;
+ EXPECT
+ Can't use bareword ("fred") as a HASH ref while "strict refs" in use at - line 4.
+ ########
+
+ # strict refs - no error
+ use strict ;
+ no strict 'refs' ;
+ my $fred ;
+ my $b = "fred" ;
+ my $a = $$b ;
+ use strict 'refs' ;
+ EXPECT
+
+ ########
+
+ # strict refs - no error
+ use strict qw(subs vars) ;
+ my $fred ;
+ my $b = "fred" ;
+ my $a = $$b ;
+ use strict 'refs' ;
+ EXPECT
+
+ ########
+
+ # strict refs - no error
+ my $fred ;
+ my $b = "fred" ;
+ my $a = $$b ;
+ use strict 'refs' ;
+ EXPECT
+
+ ########
+
+ # strict refs - no error
+ use strict 'refs' ;
+ my $fred ;
+ my $b = \$fred ;
+ my $a = $$b ;
+ EXPECT
+
+ ########
+
+ # Check runtime scope of strict refs pragma
+ use strict 'refs';
+ my $fred ;
+ my $b = "fred" ;
+ {
+ no strict ;
+ my $a = $$b ;
+ }
+ my $a = $$b ;
+ EXPECT
+ Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10.
+ ########
+
+ # Check runtime scope of strict refs pragma
+ no strict ;
+ my $fred ;
+ my $b = "fred" ;
+ {
+ use strict 'refs' ;
+ my $a = $$b ;
+ }
+ my $a = $$b ;
+ EXPECT
+ Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8.
+ ########
+
+ # Check runtime scope of strict refs pragma
+ no strict ;
+ my $fred ;
+ my $b = "fred" ;
+ {
+ use strict 'refs' ;
+ $a = sub { my $c = $$b ; }
+ }
+ &$a ;
+ EXPECT
+ Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8.
+ ########
+
+
+ --FILE-- abc
+ my $a = ${"Fred"} ;
+ 1;
+ --FILE--
+ use strict 'refs' ;
+ require "./abc";
+ EXPECT
+
+ ########
+
+ --FILE-- abc
+ use strict 'refs' ;
+ 1;
+ --FILE--
+ require "./abc";
+ my $a = ${"Fred"} ;
+ EXPECT
+
+ ########
+
+ --FILE-- abc
+ use strict 'refs' ;
+ my $a = ${"Fred"} ;
+ 1;
+ --FILE--
+ ${"Fred"} ;
+ require "./abc";
+ EXPECT
+ Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at ./abc line 2.
+ Compilation failed in require at - line 2.
+ ########
+
+ --FILE-- abc.pm
+ use strict 'refs' ;
+ my $a = ${"Fred"} ;
+ 1;
+ --FILE--
+ my $a = ${"Fred"} ;
+ use abc;
+ EXPECT
+ Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at abc.pm line 2.
+ Compilation failed in require at - line 2.
+ BEGIN failed--compilation aborted at - line 2.
+ ########
+
+ # Check scope of pragma with eval
+ no strict ;
+ eval {
+ my $a = ${"Fred"} ;
+ };
+ print STDERR $@ ;
+ my $a = ${"Fred"} ;
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ no strict ;
+ eval {
+ use strict 'refs' ;
+ my $a = ${"Fred"} ;
+ };
+ print STDERR $@ ;
+ my $a = ${"Fred"} ;
+ EXPECT
+ Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 6.
+ ########
+
+ # Check scope of pragma with eval
+ use strict 'refs' ;
+ eval {
+ my $a = ${"Fred"} ;
+ };
+ print STDERR $@ ;
+ EXPECT
+ Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 5.
+ ########
+
+ # Check scope of pragma with eval
+ use strict 'refs' ;
+ eval {
+ no strict ;
+ my $a = ${"Fred"} ;
+ };
+ print STDERR $@ ;
+ my $a = ${"Fred"} ;
+ EXPECT
+ Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 9.
+ ########
+
+ # Check scope of pragma with eval
+ no strict ;
+ eval '
+ my $a = ${"Fred"} ;
+ '; print STDERR $@ ;
+ my $a = ${"Fred"} ;
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ no strict ;
+ eval q[
+ use strict 'refs' ;
+ my $a = ${"Fred"} ;
+ ]; print STDERR $@;
+ EXPECT
+ Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 3.
+ ########
+
+ # Check scope of pragma with eval
+ use strict 'refs' ;
+ eval '
+ my $a = ${"Fred"} ;
+ '; print STDERR $@ ;
+ EXPECT
+ Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 2.
+ ########
+
+ # Check scope of pragma with eval
+ use strict 'refs' ;
+ eval '
+ no strict ;
+ my $a = ${"Fred"} ;
+ '; print STDERR $@;
+ my $a = ${"Fred"} ;
+ EXPECT
+ Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 8.
diff -c /dev/null 'perl-5.7.2/t/lib/strict/subs'
Index: ./t/lib/strict/subs
*** ./t/lib/strict/subs Thu Jan 1 02:00:00 1970
--- ./t/lib/strict/subs Mon Jul 9 17:11:24 2001
***************
*** 0 ****
--- 1,319 ----
+ Check strict subs functionality
+
+ __END__
+
+ # no strict, should build & run ok.
+ Fred ;
+ my $fred ;
+ $b = "fred" ;
+ $a = $$b ;
+ EXPECT
+
+ ########
+
+ use strict qw(refs vars);
+ Fred ;
+ EXPECT
+
+ ########
+
+ use strict ;
+ no strict 'subs' ;
+ Fred ;
+ EXPECT
+
+ ########
+
+ # strict subs - error
+ use strict 'subs' ;
+ Fred ;
+ EXPECT
+ Bareword "Fred" not allowed while "strict subs" in use at - line 4.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # strict subs - error
+ use strict 'subs' ;
+ my @a = (A..Z);
+ EXPECT
+ Bareword "Z" not allowed while "strict subs" in use at - line 4.
+ Bareword "A" not allowed while "strict subs" in use at - line 4.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # strict subs - error
+ use strict 'subs' ;
+ my $a = (B..Y);
+ EXPECT
+ Bareword "Y" not allowed while "strict subs" in use at - line 4.
+ Bareword "B" not allowed while "strict subs" in use at - line 4.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # strict subs - error
+ use strict ;
+ Fred ;
+ EXPECT
+ Bareword "Fred" not allowed while "strict subs" in use at - line 4.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # strict subs - no error
+ use strict 'subs' ;
+ sub Fred {}
+ Fred ;
+ EXPECT
+
+ ########
+
+ # Check compile time scope of strict subs pragma
+ use strict 'subs' ;
+ {
+ no strict ;
+ my $a = Fred ;
+ }
+ my $a = Fred ;
+ EXPECT
+ Bareword "Fred" not allowed while "strict subs" in use at - line 8.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # Check compile time scope of strict subs pragma
+ no strict;
+ {
+ use strict 'subs' ;
+ my $a = Fred ;
+ }
+ my $a = Fred ;
+ EXPECT
+ Bareword "Fred" not allowed while "strict subs" in use at - line 6.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # Check compile time scope of strict vars pragma
+ use strict 'vars' ;
+ {
+ no strict ;
+ $joe = 1 ;
+ }
+ $joe = 1 ;
+ EXPECT
+ Variable "$joe" is not imported at - line 8.
+ Global symbol "$joe" requires explicit package name at - line 8.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # Check compile time scope of strict vars pragma
+ no strict;
+ {
+ use strict 'vars' ;
+ $joe = 1 ;
+ }
+ $joe = 1 ;
+ EXPECT
+ Global symbol "$joe" requires explicit package name at - line 6.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # Check runtime scope of strict refs pragma
+ use strict 'refs';
+ my $fred ;
+ my $b = "fred" ;
+ {
+ no strict ;
+ my $a = $$b ;
+ }
+ my $a = $$b ;
+ EXPECT
+ Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10.
+ ########
+
+ # Check runtime scope of strict refs pragma
+ no strict ;
+ my $fred ;
+ my $b = "fred" ;
+ {
+ use strict 'refs' ;
+ my $a = $$b ;
+ }
+ my $a = $$b ;
+ EXPECT
+ Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8.
+ ########
+
+ # Check runtime scope of strict refs pragma
+ no strict ;
+ my $fred ;
+ my $b = "fred" ;
+ {
+ use strict 'refs' ;
+ $a = sub { my $c = $$b ; }
+ }
+ &$a ;
+ EXPECT
+ Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8.
+ ########
+
+ use strict 'subs' ;
+ my $a = Fred ;
+ EXPECT
+ Bareword "Fred" not allowed while "strict subs" in use at - line 3.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ --FILE-- abc
+ my $a = Fred ;
+ 1;
+ --FILE--
+ use strict 'subs' ;
+ require "./abc";
+ EXPECT
+
+ ########
+
+ --FILE-- abc
+ use strict 'subs' ;
+ 1;
+ --FILE--
+ require "./abc";
+ my $a = Fred ;
+ EXPECT
+
+ ########
+
+ --FILE-- abc
+ use strict 'subs' ;
+ my $a = Fred ;
+ 1;
+ --FILE--
+ Fred ;
+ require "./abc";
+ EXPECT
+ Bareword "Fred" not allowed while "strict subs" in use at ./abc line 2.
+ Compilation failed in require at - line 2.
+ ########
+
+ --FILE-- abc.pm
+ use strict 'subs' ;
+ my $a = Fred ;
+ 1;
+ --FILE--
+ Fred ;
+ use abc;
+ EXPECT
+ Bareword "Fred" not allowed while "strict subs" in use at abc.pm line 2.
+ Compilation failed in require at - line 2.
+ BEGIN failed--compilation aborted at - line 2.
+ ########
+
+ # Check scope of pragma with eval
+ no strict ;
+ eval {
+ my $a = Fred ;
+ };
+ print STDERR $@;
+ my $a = Fred ;
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ no strict ;
+ eval {
+ use strict 'subs' ;
+ my $a = Fred ;
+ };
+ print STDERR $@;
+ my $a = Fred ;
+ EXPECT
+ Bareword "Fred" not allowed while "strict subs" in use at - line 6.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # Check scope of pragma with eval
+ use strict 'subs' ;
+ eval {
+ my $a = Fred ;
+ };
+ print STDERR $@;
+ my $a = Fred ;
+ EXPECT
+ Bareword "Fred" not allowed while "strict subs" in use at - line 5.
+ Bareword "Fred" not allowed while "strict subs" in use at - line 8.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # Check scope of pragma with eval
+ use strict 'subs' ;
+ eval {
+ no strict ;
+ my $a = Fred ;
+ };
+ print STDERR $@;
+ my $a = Fred ;
+ EXPECT
+ Bareword "Fred" not allowed while "strict subs" in use at - line 9.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # Check scope of pragma with eval
+ no strict ;
+ eval '
+ Fred ;
+ '; print STDERR $@ ;
+ Fred ;
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ no strict ;
+ eval q[
+ use strict 'subs' ;
+ Fred ;
+ ]; print STDERR $@;
+ EXPECT
+ Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 3.
+ ########
+
+ # Check scope of pragma with eval
+ use strict 'subs' ;
+ eval '
+ Fred ;
+ '; print STDERR $@ ;
+ EXPECT
+ Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 2.
+ ########
+
+ # Check scope of pragma with eval
+ use strict 'subs' ;
+ eval '
+ no strict ;
+ my $a = Fred ;
+ '; print STDERR $@;
+ my $a = Fred ;
+ EXPECT
+ Bareword "Fred" not allowed while "strict subs" in use at - line 8.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # see if Foo->Bar(...) etc work under strictures
+ use strict;
+ package Foo; sub Bar { print "@_\n" }
+ Foo->Bar('a',1);
+ Bar Foo ('b',2);
+ Foo->Bar(qw/c 3/);
+ Bar Foo (qw/d 4/);
+ Foo::->Bar('A',1);
+ Bar Foo:: ('B',2);
+ Foo::->Bar(qw/C 3/);
+ Bar Foo:: (qw/D 4/);
+ EXPECT
+ Foo a 1
+ Foo b 2
+ Foo c 3
+ Foo d 4
+ Foo A 1
+ Foo B 2
+ Foo C 3
+ Foo D 4
diff -c /dev/null 'perl-5.7.2/t/lib/strict/vars'
Index: ./t/lib/strict/vars
*** ./t/lib/strict/vars Thu Jan 1 02:00:00 1970
--- ./t/lib/strict/vars Mon Jul 9 17:11:24 2001
***************
*** 0 ****
--- 1,410 ----
+ Check strict vars functionality
+
+ __END__
+
+ # no strict, should build & run ok.
+ Fred ;
+ my $fred ;
+ $b = "fred" ;
+ $a = $$b ;
+ EXPECT
+
+ ########
+
+ use strict qw(subs refs) ;
+ $fred ;
+ EXPECT
+
+ ########
+
+ use strict ;
+ no strict 'vars' ;
+ $fred ;
+ EXPECT
+
+ ########
+
+ # strict vars - no error
+ use strict 'vars' ;
+ use vars qw( $freddy) ;
+ BEGIN { *freddy = \$joe::shmoe; }
+ $freddy = 2 ;
+ EXPECT
+
+ ########
+
+ # strict vars - no error
+ use strict 'vars' ;
+ use vars qw( $freddy) ;
+ local $abc::joe ;
+ my $fred ;
+ my $b = \$fred ;
+ $Fred::ABC = 1 ;
+ $freddy = 2 ;
+ EXPECT
+
+ ########
+
+ # strict vars - error
+ use strict ;
+ $fred ;
+ EXPECT
+ Global symbol "$fred" requires explicit package name at - line 4.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # strict vars - error
+ use strict 'vars' ;
+ <$fred> ;
+ EXPECT
+ Global symbol "$fred" requires explicit package name at - line 4.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # strict vars - error
+ use strict 'vars' ;
+ local $fred ;
+ EXPECT
+ Global symbol "$fred" requires explicit package name at - line 4.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # Check compile time scope of strict vars pragma
+ use strict 'vars' ;
+ {
+ no strict ;
+ $joe = 1 ;
+ }
+ $joe = 1 ;
+ EXPECT
+ Variable "$joe" is not imported at - line 8.
+ Global symbol "$joe" requires explicit package name at - line 8.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # Check compile time scope of strict vars pragma
+ no strict;
+ {
+ use strict 'vars' ;
+ $joe = 1 ;
+ }
+ $joe = 1 ;
+ EXPECT
+ Global symbol "$joe" requires explicit package name at - line 6.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ --FILE-- abc
+ $joe = 1 ;
+ 1;
+ --FILE--
+ use strict 'vars' ;
+ require "./abc";
+ EXPECT
+
+ ########
+
+ --FILE-- abc
+ use strict 'vars' ;
+ 1;
+ --FILE--
+ require "./abc";
+ $joe = 1 ;
+ EXPECT
+
+ ########
+
+ --FILE-- abc
+ use strict 'vars' ;
+ $joe = 1 ;
+ 1;
+ --FILE--
+ $joe = 1 ;
+ require "./abc";
+ EXPECT
+ Variable "$joe" is not imported at ./abc line 2.
+ Global symbol "$joe" requires explicit package name at ./abc line 2.
+ Compilation failed in require at - line 2.
+ ########
+
+ --FILE-- abc.pm
+ use strict 'vars' ;
+ $joe = 1 ;
+ 1;
+ --FILE--
+ $joe = 1 ;
+ use abc;
+ EXPECT
+ Variable "$joe" is not imported at abc.pm line 2.
+ Global symbol "$joe" requires explicit package name at abc.pm line 2.
+ Compilation failed in require at - line 2.
+ BEGIN failed--compilation aborted at - line 2.
+ ########
+
+ --FILE-- abc.pm
+ package Burp;
+ use strict;
+ $a = 1;$f = 1;$k = 1; # just to get beyond the limit...
+ $b = 1;$g = 1;$l = 1;
+ $c = 1;$h = 1;$m = 1;
+ $d = 1;$i = 1;$n = 1;
+ $e = 1;$j = 1;$o = 1;
+ $p = 0b12;
+ --FILE--
+ use abc;
+ EXPECT
+ Global symbol "$f" requires explicit package name at abc.pm line 3.
+ Global symbol "$k" requires explicit package name at abc.pm line 3.
+ Global symbol "$g" requires explicit package name at abc.pm line 4.
+ Global symbol "$l" requires explicit package name at abc.pm line 4.
+ Global symbol "$c" requires explicit package name at abc.pm line 5.
+ Global symbol "$h" requires explicit package name at abc.pm line 5.
+ Global symbol "$m" requires explicit package name at abc.pm line 5.
+ Global symbol "$d" requires explicit package name at abc.pm line 6.
+ Global symbol "$i" requires explicit package name at abc.pm line 6.
+ Global symbol "$n" requires explicit package name at abc.pm line 6.
+ Global symbol "$e" requires explicit package name at abc.pm line 7.
+ Global symbol "$j" requires explicit package name at abc.pm line 7.
+ Global symbol "$o" requires explicit package name at abc.pm line 7.
+ Global symbol "$p" requires explicit package name at abc.pm line 8.
+ Illegal binary digit '2' at abc.pm line 8, at end of line
+ abc.pm has too many errors.
+ Compilation failed in require at - line 1.
+ BEGIN failed--compilation aborted at - line 1.
+ ########
+
+ # Check scope of pragma with eval
+ no strict ;
+ eval {
+ $joe = 1 ;
+ };
+ print STDERR $@;
+ $joe = 1 ;
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ no strict ;
+ eval {
+ use strict 'vars' ;
+ $joe = 1 ;
+ };
+ print STDERR $@;
+ $joe = 1 ;
+ EXPECT
+ Global symbol "$joe" requires explicit package name at - line 6.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # Check scope of pragma with eval
+ use strict 'vars' ;
+ eval {
+ $joe = 1 ;
+ };
+ print STDERR $@;
+ $joe = 1 ;
+ EXPECT
+ Global symbol "$joe" requires explicit package name at - line 5.
+ Global symbol "$joe" requires explicit package name at - line 8.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # Check scope of pragma with eval
+ use strict 'vars' ;
+ eval {
+ no strict ;
+ $joe = 1 ;
+ };
+ print STDERR $@;
+ $joe = 1 ;
+ EXPECT
+ Variable "$joe" is not imported at - line 9.
+ Global symbol "$joe" requires explicit package name at - line 9.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # Check scope of pragma with eval
+ no strict ;
+ eval '
+ $joe = 1 ;
+ '; print STDERR $@ ;
+ $joe = 1 ;
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ no strict ;
+ eval q[
+ use strict 'vars' ;
+ $joe = 1 ;
+ ]; print STDERR $@;
+ EXPECT
+ Global symbol "$joe" requires explicit package name at (eval 1) line 3.
+ ########
+
+ # Check scope of pragma with eval
+ use strict 'vars' ;
+ eval '
+ $joe = 1 ;
+ '; print STDERR $@ ;
+ EXPECT
+ Global symbol "$joe" requires explicit package name at (eval 1) line 2.
+ ########
+
+ # Check scope of pragma with eval
+ use strict 'vars' ;
+ eval '
+ no strict ;
+ $joe = 1 ;
+ '; print STDERR $@;
+ $joe = 1 ;
+ EXPECT
+ Global symbol "$joe" requires explicit package name at - line 8.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # Check if multiple evals produce same errors
+ use strict 'vars';
+ my $ret = eval q{ print $x; };
+ print $@;
+ print "ok 1\n" unless defined $ret;
+ $ret = eval q{ print $x; };
+ print $@;
+ print "ok 2\n" unless defined $ret;
+ EXPECT
+ Global symbol "$x" requires explicit package name at (eval 1) line 1.
+ ok 1
+ Global symbol "$x" requires explicit package name at (eval 2) line 1.
+ ok 2
+ ########
+
+ # strict vars with outer our - no error
+ use strict 'vars' ;
+ our $freddy;
+ local $abc::joe ;
+ my $fred ;
+ my $b = \$fred ;
+ $Fred::ABC = 1 ;
+ $freddy = 2 ;
+ EXPECT
+
+ ########
+
+ # strict vars with inner our - no error
+ use strict 'vars' ;
+ sub foo {
+ our $fred;
+ $fred;
+ }
+ EXPECT
+
+ ########
+
+ # strict vars with outer our, inner use - no error
+ use strict 'vars' ;
+ our $fred;
+ sub foo {
+ $fred;
+ }
+ EXPECT
+
+ ########
+
+ # strict vars with nested our - no error
+ use strict 'vars' ;
+ our $fred;
+ sub foo {
+ our $fred;
+ $fred;
+ }
+ $fred ;
+ EXPECT
+
+ ########
+
+ # strict vars with elapsed our - error
+ use strict 'vars' ;
+ sub foo {
+ our $fred;
+ $fred;
+ }
+ $fred ;
+ EXPECT
+ Variable "$fred" is not imported at - line 8.
+ Global symbol "$fred" requires explicit package name at - line 8.
+ Execution of - aborted due to compilation errors.
+ ########
+
+ # nested our with local - no error
+ $fred = 1;
+ use strict 'vars';
+ {
+ local our $fred = 2;
+ print $fred,"\n";
+ }
+ print our $fred,"\n";
+ EXPECT
+ 2
+ 1
+ ########
+
+ # "nailed" our declaration visibility across package boundaries
+ use strict 'vars';
+ our $foo;
+ $foo = 20;
+ package Foo;
+ print $foo, "\n";
+ EXPECT
+ 20
+ ########
+
+ # multiple our declarations in same scope, different packages, no warning
+ use strict 'vars';
+ use warnings;
+ our $foo;
+ ${foo} = 10;
+ package Foo;
+ our $foo = 20;
+ print $foo, "\n";
+ EXPECT
+ 20
+ ########
+
+ # multiple our declarations in same scope, same package, warning
+ use strict 'vars';
+ use warnings;
+ our $foo;
+ ${foo} = 10;
+ our $foo;
+ EXPECT
+ "our" variable $foo masks earlier declaration in same scope at - line 7.
+ ########
+
+ # multiple our declarations in same scope, same package, warning
+ use strict 'vars';
+ use warnings;
+ { our $x = 1 }
+ { our $x = 0 }
+ our $foo;
+ {
+ our $foo;
+ package Foo;
+ our $foo;
+ }
+ EXPECT
+ "our" variable $foo redeclared at - line 9.
+ (Did you mean "local" instead of "our"?)
+ Name "Foo::foo" used only once: possible typo at - line 11.
+ ########
+
+ # Make sure the strict vars failure still occurs
+ # now that the `@i should be written as \@i' failure does not occur
+ # 20000522 mjd@plover.com (MJD)
+ use strict 'vars';
+ no warnings;
+ "@i_like_crackers";
+ EXPECT
+ Global symbol "@i_like_crackers" requires explicit package name at - line 7.
+ Execution of - aborted due to compilation errors.
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/1global'
Index: ./t/lib/warnings/1global
*** ./t/lib/warnings/1global Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/1global Mon Jul 9 17:11:24 2001
***************
*** 0 ****
--- 1,189 ----
+ Check existing $^W functionality
+
+
+ __END__
+
+ # warnable code, warnings disabled
+ $a =+ 3 ;
+ EXPECT
+
+ ########
+ -w
+ # warnable code, warnings enabled via command line switch
+ $a =+ 3 ;
+ EXPECT
+ Reversed += operator at - line 3.
+ Name "main::a" used only once: possible typo at - line 3.
+ ########
+ #! perl -w
+ # warnable code, warnings enabled via #! line
+ $a =+ 3 ;
+ EXPECT
+ Reversed += operator at - line 3.
+ Name "main::a" used only once: possible typo at - line 3.
+ ########
+
+ # warnable code, warnings enabled via compile time $^W
+ BEGIN { $^W = 1 }
+ $a =+ 3 ;
+ EXPECT
+ Reversed += operator at - line 4.
+ Name "main::a" used only once: possible typo at - line 4.
+ ########
+
+ # compile-time warnable code, warnings enabled via runtime $^W
+ # so no warning printed.
+ $^W = 1 ;
+ $a =+ 3 ;
+ EXPECT
+
+ ########
+
+ # warnable code, warnings enabled via runtime $^W
+ $^W = 1 ;
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 4.
+ ########
+
+ # warnings enabled at compile time, disabled at run time
+ BEGIN { $^W = 1 }
+ $^W = 0 ;
+ my $b ; chop $b ;
+ EXPECT
+
+ ########
+
+ # warnings disabled at compile time, enabled at run time
+ BEGIN { $^W = 0 }
+ $^W = 1 ;
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 5.
+ ########
+ -w
+ --FILE-- abcd
+ my $b ; chop $b ;
+ 1 ;
+ --FILE--
+ require "./abcd";
+ EXPECT
+ Use of uninitialized value in scalar chop at ./abcd line 1.
+ ########
+
+ --FILE-- abcd
+ my $b ; chop $b ;
+ 1 ;
+ --FILE--
+ #! perl -w
+ require "./abcd";
+ EXPECT
+ Use of uninitialized value in scalar chop at ./abcd line 1.
+ ########
+
+ --FILE-- abcd
+ my $b ; chop $b ;
+ 1 ;
+ --FILE--
+ $^W =1 ;
+ require "./abcd";
+ EXPECT
+ Use of uninitialized value in scalar chop at ./abcd line 1.
+ ########
+
+ --FILE-- abcd
+ $^W = 0;
+ my $b ; chop $b ;
+ 1 ;
+ --FILE--
+ $^W =1 ;
+ require "./abcd";
+ EXPECT
+
+ ########
+
+ --FILE-- abcd
+ $^W = 1;
+ 1 ;
+ --FILE--
+ $^W =0 ;
+ require "./abcd";
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 3.
+ ########
+
+ $^W = 1;
+ eval 'my $b ; chop $b ;' ;
+ print $@ ;
+ EXPECT
+ Use of uninitialized value in scalar chop at (eval 1) line 1.
+ ########
+
+ eval '$^W = 1;' ;
+ print $@ ;
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 4.
+ ########
+
+ eval {$^W = 1;} ;
+ print $@ ;
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 4.
+ ########
+
+ {
+ local ($^W) = 1;
+ }
+ my $b ; chop $b ;
+ EXPECT
+
+ ########
+
+ my $a ; chop $a ;
+ {
+ local ($^W) = 1;
+ my $b ; chop $b ;
+ }
+ my $c ; chop $c ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 5.
+ ########
+ -w
+ -e undef
+ EXPECT
+ Use of uninitialized value in -e at - line 2.
+ ########
+
+ $^W = 1 + 2 ;
+ EXPECT
+
+ ########
+
+ $^W = $a ;
+ EXPECT
+
+ ########
+
+ sub fred {}
+ $^W = fred() ;
+ EXPECT
+
+ ########
+
+ sub fred { my $b ; chop $b ;}
+ { local $^W = 0 ;
+ fred() ;
+ }
+ EXPECT
+
+ ########
+
+ sub fred { my $b ; chop $b ;}
+ { local $^W = 1 ;
+ fred() ;
+ }
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 2.
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/2use'
Index: ./t/lib/warnings/2use
*** ./t/lib/warnings/2use Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/2use Mon Jul 9 17:11:24 2001
***************
*** 0 ****
--- 1,354 ----
+ Check lexical warnings functionality
+
+ TODO
+ check that the warning hierarchy works.
+
+ __END__
+
+ # check illegal category is caught
+ use warnings 'this-should-never-be-a-warning-category' ;
+ EXPECT
+ unknown warnings category 'this-should-never-be-a-warning-category' at - line 3
+ BEGIN failed--compilation aborted at - line 3.
+ ########
+
+ # Check compile time scope of pragma
+ use warnings 'syntax' ;
+ {
+ no warnings ;
+ my $a =+ 1 ;
+ }
+ my $a =+ 1 ;
+ EXPECT
+ Reversed += operator at - line 8.
+ ########
+
+ # Check compile time scope of pragma
+ no warnings;
+ {
+ use warnings 'syntax' ;
+ my $a =+ 1 ;
+ }
+ my $a =+ 1 ;
+ EXPECT
+ Reversed += operator at - line 6.
+ ########
+
+ # Check runtime scope of pragma
+ use warnings 'uninitialized' ;
+ {
+ no warnings ;
+ my $b ; chop $b ;
+ }
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 8.
+ ########
+
+ # Check runtime scope of pragma
+ no warnings ;
+ {
+ use warnings 'uninitialized' ;
+ my $b ; chop $b ;
+ }
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 6.
+ ########
+
+ # Check runtime scope of pragma
+ no warnings ;
+ {
+ use warnings 'uninitialized' ;
+ $a = sub { my $b ; chop $b ; }
+ }
+ &$a ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 6.
+ ########
+
+ use warnings 'syntax' ;
+ my $a =+ 1 ;
+ EXPECT
+ Reversed += operator at - line 3.
+ ########
+
+ --FILE-- abc
+ my $a =+ 1 ;
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ require "./abc";
+ EXPECT
+
+ ########
+
+ --FILE-- abc
+ use warnings 'syntax' ;
+ 1;
+ --FILE--
+ require "./abc";
+ my $a =+ 1 ;
+ EXPECT
+
+ ########
+
+ --FILE-- abc
+ use warnings 'syntax' ;
+ my $a =+ 1 ;
+ 1;
+ --FILE--
+ use warnings 'uninitialized' ;
+ require "./abc";
+ my $a ; chop $a ;
+ EXPECT
+ Reversed += operator at ./abc line 2.
+ Use of uninitialized value in scalar chop at - line 3.
+ ########
+
+ --FILE-- abc.pm
+ use warnings 'syntax' ;
+ my $a =+ 1 ;
+ 1;
+ --FILE--
+ use warnings 'uninitialized' ;
+ use abc;
+ my $a ; chop $a ;
+ EXPECT
+ Reversed += operator at abc.pm line 2.
+ Use of uninitialized value in scalar chop at - line 3.
+ ########
+
+ # Check scope of pragma with eval
+ use warnings;
+ {
+ no warnings ;
+ eval {
+ my $b ; chop $b ;
+ }; print STDERR $@ ;
+ my $b ; chop $b ;
+ }
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ use warnings;
+ {
+ no warnings ;
+ eval {
+ use warnings 'uninitialized' ;
+ my $b ; chop $b ;
+ }; print STDERR $@ ;
+ my $b ; chop $b ;
+ }
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 8.
+ ########
+
+ # Check scope of pragma with eval
+ no warnings;
+ {
+ use warnings 'uninitialized' ;
+ eval {
+ my $b ; chop $b ;
+ }; print STDERR $@ ;
+ my $b ; chop $b ;
+ }
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 7.
+ Use of uninitialized value in scalar chop at - line 9.
+ ########
+
+ # Check scope of pragma with eval
+ no warnings;
+ {
+ use warnings 'uninitialized' ;
+ eval {
+ no warnings ;
+ my $b ; chop $b ;
+ }; print STDERR $@ ;
+ my $b ; chop $b ;
+ }
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 10.
+ ########
+
+ # Check scope of pragma with eval
+ use warnings;
+ {
+ no warnings ;
+ eval {
+ my $a =+ 1 ;
+ }; print STDERR $@ ;
+ my $a =+ 1 ;
+ }
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ use warnings;
+ {
+ no warnings ;
+ eval {
+ use warnings 'syntax' ;
+ my $a =+ 1 ;
+ }; print STDERR $@ ;
+ my $a =+ 1 ;
+ }
+ EXPECT
+ Reversed += operator at - line 8.
+ ########
+
+ # Check scope of pragma with eval
+ no warnings;
+ {
+ use warnings 'syntax' ;
+ eval {
+ my $a =+ 1 ;
+ }; print STDERR $@ ;
+ my $a =+ 1 ;
+ }
+ EXPECT
+ Reversed += operator at - line 7.
+ Reversed += operator at - line 9.
+ ########
+
+ # Check scope of pragma with eval
+ no warnings;
+ {
+ use warnings 'syntax' ;
+ eval {
+ no warnings ;
+ my $a =+ 1 ;
+ }; print STDERR $@ ;
+ my $a =+ 1 ;
+ }
+ EXPECT
+ Reversed += operator at - line 10.
+ ########
+
+ # Check scope of pragma with eval
+ use warnings;
+ {
+ no warnings ;
+ eval '
+ my $b ; chop $b ;
+ '; print STDERR $@ ;
+ my $b ; chop $b ;
+ }
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ use warnings;
+ {
+ no warnings ;
+ eval q[
+ use warnings 'uninitialized' ;
+ my $b ; chop $b ;
+ ]; print STDERR $@;
+ my $b ; chop $b ;
+ }
+ EXPECT
+ Use of uninitialized value in scalar chop at (eval 1) line 3.
+ ########
+
+ # Check scope of pragma with eval
+ no warnings;
+ {
+ use warnings 'uninitialized' ;
+ eval '
+ my $b ; chop $b ;
+ '; print STDERR $@ ;
+ my $b ; chop $b ;
+ }
+ EXPECT
+ Use of uninitialized value in scalar chop at (eval 1) line 2.
+ Use of uninitialized value in scalar chop at - line 9.
+ ########
+
+ # Check scope of pragma with eval
+ no warnings;
+ {
+ use warnings 'uninitialized' ;
+ eval '
+ no warnings ;
+ my $b ; chop $b ;
+ '; print STDERR $@ ;
+ my $b ; chop $b ;
+ }
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 10.
+ ########
+
+ # Check scope of pragma with eval
+ use warnings;
+ {
+ no warnings ;
+ eval '
+ my $a =+ 1 ;
+ '; print STDERR $@ ;
+ my $a =+ 1 ;
+ }
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ use warnings;
+ {
+ no warnings ;
+ eval q[
+ use warnings 'syntax' ;
+ my $a =+ 1 ;
+ ]; print STDERR $@;
+ my $a =+ 1 ;
+ }
+ EXPECT
+ Reversed += operator at (eval 1) line 3.
+ ########
+
+ # Check scope of pragma with eval
+ no warnings;
+ {
+ use warnings 'syntax' ;
+ eval '
+ my $a =+ 1 ;
+ '; print STDERR $@;
+ my $a =+ 1 ;
+ }
+ EXPECT
+ Reversed += operator at - line 9.
+ Reversed += operator at (eval 1) line 2.
+ ########
+
+ # Check scope of pragma with eval
+ no warnings;
+ {
+ use warnings 'syntax' ;
+ eval '
+ no warnings ;
+ my $a =+ 1 ;
+ '; print STDERR $@;
+ my $a =+ 1 ;
+ }
+ EXPECT
+ Reversed += operator at - line 10.
+ ########
+
+ # Check the additive nature of the pragma
+ my $a =+ 1 ;
+ my $a ; chop $a ;
+ use warnings 'syntax' ;
+ $a =+ 1 ;
+ my $b ; chop $b ;
+ use warnings 'uninitialized' ;
+ my $c ; chop $c ;
+ no warnings 'syntax' ;
+ $a =+ 1 ;
+ EXPECT
+ Reversed += operator at - line 6.
+ Use of uninitialized value in scalar chop at - line 9.
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/3both'
Index: ./t/lib/warnings/3both
*** ./t/lib/warnings/3both Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/3both Mon Jul 9 17:11:24 2001
***************
*** 0 ****
--- 1,266 ----
+ Check interaction of $^W and lexical
+
+ __END__
+
+ # Check interaction of $^W and use warnings
+ sub fred {
+ use warnings ;
+ my $b ;
+ chop $b ;
+ }
+ { local $^W = 0 ;
+ fred() ;
+ }
+
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 6.
+ ########
+
+ # Check interaction of $^W and use warnings
+ sub fred {
+ use warnings ;
+ my $b ;
+ chop $b ;
+ }
+ { $^W = 0 ;
+ fred() ;
+ }
+
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 6.
+ ########
+
+ # Check interaction of $^W and use warnings
+ sub fred {
+ no warnings ;
+ my $b ;
+ chop $b ;
+ }
+ { local $^W = 1 ;
+ fred() ;
+ }
+
+ EXPECT
+
+ ########
+
+ # Check interaction of $^W and use warnings
+ sub fred {
+ no warnings ;
+ my $b ;
+ chop $b ;
+ }
+ { $^W = 1 ;
+ fred() ;
+ }
+
+ EXPECT
+
+ ########
+
+ # Check interaction of $^W and use warnings
+ use warnings ;
+ $^W = 1 ;
+ my $b ;
+ chop $b ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 6.
+ ########
+
+ # Check interaction of $^W and use warnings
+ $^W = 1 ;
+ use warnings ;
+ my $b ;
+ chop $b ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 6.
+ ########
+
+ # Check interaction of $^W and use warnings
+ $^W = 1 ;
+ no warnings ;
+ my $b ;
+ chop $b ;
+ EXPECT
+
+ ########
+
+ # Check interaction of $^W and use warnings
+ no warnings ;
+ $^W = 1 ;
+ my $b ;
+ chop $b ;
+ EXPECT
+
+ ########
+ -w
+ # Check interaction of $^W and use warnings
+ no warnings ;
+ my $b ;
+ chop $b ;
+ EXPECT
+
+ ########
+ -w
+ # Check interaction of $^W and use warnings
+ use warnings ;
+ my $b ;
+ chop $b ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 5.
+ ########
+
+ # Check interaction of $^W and use warnings
+ sub fred {
+ use warnings ;
+ my $b ;
+ chop $b ;
+ }
+ BEGIN { $^W = 0 }
+ fred() ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 6.
+ ########
+
+ # Check interaction of $^W and use warnings
+ sub fred {
+ no warnings ;
+ my $b ;
+ chop $b ;
+ }
+ BEGIN { $^W = 1 }
+ fred() ;
+
+ EXPECT
+
+ ########
+
+ # Check interaction of $^W and use warnings
+ use warnings ;
+ BEGIN { $^W = 1 }
+ my $b ;
+ chop $b ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 6.
+ ########
+
+ # Check interaction of $^W and use warnings
+ BEGIN { $^W = 1 }
+ use warnings ;
+ my $b ;
+ chop $b ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 6.
+ ########
+
+ # Check interaction of $^W and use warnings
+ BEGIN { $^W = 1 }
+ no warnings ;
+ my $b ;
+ chop $b ;
+ EXPECT
+
+ ########
+
+ # Check interaction of $^W and use warnings
+ no warnings ;
+ BEGIN { $^W = 1 }
+ my $b ;
+ chop $b ;
+ EXPECT
+
+ ########
+
+ # Check interaction of $^W and use warnings
+ BEGIN { $^W = 1 }
+ {
+ no warnings ;
+ my $b ;
+ chop $b ;
+ }
+ my $b ;
+ chop $b ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 10.
+ ########
+
+ # Check interaction of $^W and use warnings
+ BEGIN { $^W = 0 }
+ {
+ use warnings ;
+ my $b ;
+ chop $b ;
+ }
+ my $b ;
+ chop $b ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 7.
+ ########
+
+ # Check scope of pragma with eval
+ BEGIN { $^W = 1 }
+ {
+ no warnings ;
+ eval '
+ my $b ; chop $b ;
+ '; print STDERR $@ ;
+ my $b ; chop $b ;
+ }
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ BEGIN { $^W = 1 }
+ use warnings;
+ {
+ no warnings ;
+ eval q[
+ use warnings 'uninitialized' ;
+ my $b ; chop $b ;
+ ]; print STDERR $@;
+ my $b ; chop $b ;
+ }
+ EXPECT
+ Use of uninitialized value in scalar chop at (eval 1) line 3.
+ ########
+
+ # Check scope of pragma with eval
+ BEGIN { $^W = 0 }
+ {
+ use warnings 'uninitialized' ;
+ eval '
+ my $b ; chop $b ;
+ '; print STDERR $@ ;
+ my $b ; chop $b ;
+ }
+ EXPECT
+ Use of uninitialized value in scalar chop at (eval 1) line 2.
+ Use of uninitialized value in scalar chop at - line 9.
+ ########
+
+ # Check scope of pragma with eval
+ BEGIN { $^W = 0 }
+ {
+ use warnings 'uninitialized' ;
+ eval '
+ no warnings ;
+ my $b ; chop $b ;
+ '; print STDERR $@ ;
+ my $b ; chop $b ;
+ }
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 10.
+ ########
+
+ # Check scope of pragma with eval
+ BEGIN { $^W = 1 }
+ {
+ no warnings ;
+ eval '
+ my $a =+ 1 ;
+ '; print STDERR $@ ;
+ my $a =+ 1 ;
+ }
+ EXPECT
+
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/4lint'
Index: ./t/lib/warnings/4lint
*** ./t/lib/warnings/4lint Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/4lint Mon Jul 9 17:11:24 2001
***************
*** 0 ****
--- 1,216 ----
+ Check lint
+
+ __END__
+ -W
+ # lint: check compile time $^W is zapped
+ BEGIN { $^W = 0 ;}
+ $a = 1 ;
+ $a =+ 1 ;
+ close STDIN ; print STDIN "abc" ;
+ EXPECT
+ Reversed += operator at - line 5.
+ print() on closed filehandle STDIN at - line 6.
+ ########
+ -W
+ # lint: check runtime $^W is zapped
+ $^W = 0 ;
+ close STDIN ; print STDIN "abc" ;
+ EXPECT
+ print() on closed filehandle STDIN at - line 4.
+ ########
+ -W
+ # lint: check runtime $^W is zapped
+ {
+ $^W = 0 ;
+ close STDIN ; print STDIN "abc" ;
+ }
+ EXPECT
+ print() on closed filehandle STDIN at - line 5.
+ ########
+ -W
+ # lint: check "no warnings" is zapped
+ no warnings ;
+ $a = 1 ;
+ $a =+ 1 ;
+ close STDIN ; print STDIN "abc" ;
+ EXPECT
+ Reversed += operator at - line 5.
+ print() on closed filehandle STDIN at - line 6.
+ ########
+ -W
+ # lint: check "no warnings" is zapped
+ {
+ no warnings ;
+ close STDIN ; print STDIN "abc" ;
+ }
+ EXPECT
+ print() on closed filehandle STDIN at - line 5.
+ ########
+ -Ww
+ # lint: check combination of -w and -W
+ {
+ $^W = 0 ;
+ close STDIN ; print STDIN "abc" ;
+ }
+ EXPECT
+ print() on closed filehandle STDIN at - line 5.
+ ########
+ -W
+ --FILE-- abc.pm
+ no warnings 'syntax' ;
+ my $a = 0;
+ $a =+ 1 ;
+ 1;
+ --FILE--
+ no warnings 'uninitialized' ;
+ use abc;
+ my $a ; chop $a ;
+ EXPECT
+ Reversed += operator at abc.pm line 3.
+ Use of uninitialized value in scalar chop at - line 3.
+ ########
+ -W
+ --FILE-- abc
+ no warnings 'syntax' ;
+ my $a = 0;
+ $a =+ 1 ;
+ 1;
+ --FILE--
+ no warnings 'uninitialized' ;
+ require "./abc";
+ my $a ; chop $a ;
+ EXPECT
+ Reversed += operator at ./abc line 3.
+ Use of uninitialized value in scalar chop at - line 3.
+ ########
+ -W
+ --FILE-- abc.pm
+ BEGIN {$^W = 0}
+ my $a = 0 ;
+ $a =+ 1 ;
+ 1;
+ --FILE--
+ $^W = 0 ;
+ use abc;
+ my $a ; chop $a ;
+ EXPECT
+ Reversed += operator at abc.pm line 3.
+ Use of uninitialized value in scalar chop at - line 3.
+ ########
+ -W
+ --FILE-- abc
+ BEGIN {$^W = 0}
+ my $a = 0 ;
+ $a =+ 1 ;
+ 1;
+ --FILE--
+ $^W = 0 ;
+ require "./abc";
+ my $a ; chop $a ;
+ EXPECT
+ Reversed += operator at ./abc line 3.
+ Use of uninitialized value in scalar chop at - line 3.
+ ########
+ -W
+ # Check scope of pragma with eval
+ {
+ no warnings ;
+ eval '
+ my $b ; chop $b ;
+ '; print STDERR $@ ;
+ my $b ; chop $b ;
+ }
+ EXPECT
+ Use of uninitialized value in scalar chop at (eval 1) line 2.
+ Use of uninitialized value in scalar chop at - line 8.
+ ########
+ -W
+ # Check scope of pragma with eval
+ use warnings;
+ {
+ no warnings ;
+ eval q[
+ use warnings 'uninitialized' ;
+ my $b ; chop $b ;
+ ]; print STDERR $@;
+ my $b ; chop $b ;
+ }
+ EXPECT
+ Use of uninitialized value in scalar chop at (eval 1) line 3.
+ Use of uninitialized value in scalar chop at - line 10.
+ ########
+ -W
+ # Check scope of pragma with eval
+ no warnings;
+ {
+ use warnings 'uninitialized' ;
+ eval '
+ my $b ; chop $b ;
+ '; print STDERR $@ ;
+ my $b ; chop $b ;
+ }
+ EXPECT
+ Use of uninitialized value in scalar chop at (eval 1) line 2.
+ Use of uninitialized value in scalar chop at - line 9.
+ ########
+ -W
+ # Check scope of pragma with eval
+ no warnings;
+ {
+ use warnings 'uninitialized' ;
+ eval '
+ no warnings ;
+ my $b ; chop $b ;
+ '; print STDERR $@ ;
+ my $b ; chop $b ;
+ }
+ EXPECT
+ Use of uninitialized value in scalar chop at (eval 1) line 3.
+ Use of uninitialized value in scalar chop at - line 10.
+ ########
+ -W
+ # Check scope of pragma with eval
+ use warnings;
+ {
+ my $a = "1"; my $b = "2";
+ no warnings ;
+ eval q[
+ use warnings 'syntax' ;
+ $a =+ 1 ;
+ ]; print STDERR $@;
+ $a =+ 1 ;
+ }
+ EXPECT
+ Reversed += operator at - line 11.
+ Reversed += operator at (eval 1) line 3.
+ ########
+ -W
+ # Check scope of pragma with eval
+ no warnings;
+ {
+ my $a = "1"; my $b = "2";
+ use warnings 'syntax' ;
+ eval '
+ $a =+ 1 ;
+ '; print STDERR $@;
+ $a =+ 1 ;
+ }
+ EXPECT
+ Reversed += operator at - line 10.
+ Reversed += operator at (eval 1) line 2.
+ ########
+ -W
+ # Check scope of pragma with eval
+ no warnings;
+ {
+ my $a = "1"; my $b = "2";
+ use warnings 'syntax' ;
+ eval '
+ no warnings ;
+ $a =+ 1 ;
+ '; print STDERR $@;
+ $a =+ 1 ;
+ }
+ EXPECT
+ Reversed += operator at - line 11.
+ Reversed += operator at (eval 1) line 3.
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/5nolint'
Index: ./t/lib/warnings/5nolint
*** ./t/lib/warnings/5nolint Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/5nolint Mon Jul 9 17:11:24 2001
***************
*** 0 ****
--- 1,204 ----
+ syntax anti-lint
+
+ __END__
+ -X
+ # nolint: check compile time $^W is zapped
+ BEGIN { $^W = 1 ;}
+ $a = $b = 1 ;
+ $a =+ 1 ;
+ close STDIN ; print STDIN "abc" ;
+ EXPECT
+ ########
+ -X
+ # nolint: check runtime $^W is zapped
+ $^W = 1 ;
+ close STDIN ; print STDIN "abc" ;
+ EXPECT
+ ########
+ -X
+ # nolint: check runtime $^W is zapped
+ {
+ $^W = 1 ;
+ close STDIN ; print STDIN "abc" ;
+ }
+ EXPECT
+ ########
+ -X
+ # nolint: check "no warnings" is zapped
+ use warnings ;
+ $a = $b = 1 ;
+ $a =+ 1 ;
+ close STDIN ; print STDIN "abc" ;
+ EXPECT
+ ########
+ -X
+ # nolint: check "no warnings" is zapped
+ {
+ use warnings ;
+ close STDIN ; print STDIN "abc" ;
+ }
+ EXPECT
+ ########
+ -Xw
+ # nolint: check combination of -w and -X
+ {
+ $^W = 1 ;
+ close STDIN ; print STDIN "abc" ;
+ }
+ EXPECT
+ ########
+ -X
+ --FILE-- abc.pm
+ use warnings 'syntax' ;
+ my $a = 0;
+ $a =+ 1 ;
+ 1;
+ --FILE--
+ use warnings 'uninitialized' ;
+ use abc;
+ my $a ; chop $a ;
+ EXPECT
+ ########
+ -X
+ --FILE-- abc
+ use warnings 'syntax' ;
+ my $a = 0;
+ $a =+ 1 ;
+ 1;
+ --FILE--
+ use warnings 'uninitialized' ;
+ require "./abc";
+ my $a ; chop $a ;
+ EXPECT
+ ########
+ -X
+ --FILE-- abc.pm
+ BEGIN {$^W = 1}
+ my ($a, $b) = (0,0);
+ $a =+ 1 ;
+ 1;
+ --FILE--
+ $^W = 1 ;
+ use abc;
+ my $a ; chop $a ;
+ EXPECT
+ ########
+ -X
+ --FILE-- abc
+ BEGIN {$^W = 1}
+ my ($a, $b) = (0,0);
+ $a =+ 1 ;
+ 1;
+ --FILE--
+ $^W = 1 ;
+ require "./abc";
+ my $a ; chop $a ;
+ EXPECT
+ ########
+ -X
+ # Check scope of pragma with eval
+ use warnings;
+ {
+ no warnings ;
+ eval '
+ my $b ; chop $b ;
+ '; print STDERR $@ ;
+ my $b ; chop $b ;
+ }
+ EXPECT
+
+ ########
+ -X
+ # Check scope of pragma with eval
+ use warnings;
+ {
+ no warnings ;
+ eval q[
+ use warnings 'uninitialized' ;
+ my $b ; chop $b ;
+ ]; print STDERR $@;
+ my $b ; chop $b ;
+ }
+ EXPECT
+
+ ########
+ -X
+ # Check scope of pragma with eval
+ no warnings;
+ {
+ use warnings 'uninitialized' ;
+ eval '
+ my $b ; chop $b ;
+ '; print STDERR $@ ;
+ my $b ; chop $b ;
+ }
+ EXPECT
+
+ ########
+ -X
+ # Check scope of pragma with eval
+ no warnings;
+ {
+ use warnings 'uninitialized' ;
+ eval '
+ no warnings ;
+ my $b ; chop $b ;
+ '; print STDERR $@ ;
+ my $b ; chop $b ;
+ }
+ EXPECT
+
+ ########
+ -X
+ # Check scope of pragma with eval
+ use warnings;
+ {
+ no warnings ;
+ eval '
+ my $a =+ 1 ;
+ '; print STDERR $@ ;
+ my $a =+ 1 ;
+ }
+ EXPECT
+
+ ########
+ -X
+ # Check scope of pragma with eval
+ use warnings;
+ {
+ no warnings ;
+ eval q[
+ use warnings 'syntax' ;
+ my $a =+ 1 ;
+ ]; print STDERR $@;
+ my $a =+ 1 ;
+ }
+ EXPECT
+
+ ########
+ -X
+ # Check scope of pragma with eval
+ no warnings;
+ {
+ use warnings 'syntax' ;
+ eval '
+ my $a =+ 1 ;
+ '; print STDERR $@;
+ my $a =+ 1 ;
+ }
+ EXPECT
+
+ ########
+ -X
+ # Check scope of pragma with eval
+ no warnings;
+ {
+ use warnings 'syntax' ;
+ eval '
+ no warnings ;
+ my $a =+ 1 ;
+ '; print STDERR $@;
+ my $a =+ 1 ;
+ }
+ EXPECT
+
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/6default'
Index: ./t/lib/warnings/6default
*** ./t/lib/warnings/6default Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/6default Mon Jul 9 17:11:24 2001
***************
*** 0 ****
--- 1,121 ----
+ Check default warnings
+
+ __END__
+ # default warnings should be displayed if you don't add anything
+ # optional shouldn't
+ my $a = oct "7777777777777777777777777777777777779" ;
+ EXPECT
+ Integer overflow in octal number at - line 3.
+ ########
+ # no warnings should be displayed
+ no warnings ;
+ my $a = oct "7777777777777777777777777777777777778" ;
+ EXPECT
+ ########
+ # all warnings should be displayed
+ use warnings ;
+ my $a = oct "7777777777777777777777777777777777778" ;
+ EXPECT
+ Integer overflow in octal number at - line 3.
+ Illegal octal digit '8' ignored at - line 3.
+ Octal number > 037777777777 non-portable at - line 3.
+ ########
+ # check scope
+ use warnings ;
+ my $a = oct "7777777777777777777777777777777777778" ;
+ {
+ no warnings ;
+ my $a = oct "7777777777777777777777777777777777778" ;
+ }
+ my $c = oct "7777777777777777777777777777777777778" ;
+ EXPECT
+ Integer overflow in octal number at - line 3.
+ Illegal octal digit '8' ignored at - line 3.
+ Octal number > 037777777777 non-portable at - line 3.
+ Integer overflow in octal number at - line 8.
+ Illegal octal digit '8' ignored at - line 8.
+ Octal number > 037777777777 non-portable at - line 8.
+ ########
+ # all warnings should be displayed
+ use warnings ;
+ my $a = oct "0xfffffffffffffffffg" ;
+ EXPECT
+ Integer overflow in hexadecimal number at - line 3.
+ Illegal hexadecimal digit 'g' ignored at - line 3.
+ Hexadecimal number > 0xffffffff non-portable at - line 3.
+ ########
+ # all warnings should be displayed
+ use warnings ;
+ my $a = oct "0b111111111111111111111111111111111111111111111111111111111111111112";
+ EXPECT
+ Integer overflow in binary number at - line 3.
+ Illegal binary digit '2' ignored at - line 3.
+ Binary number > 0b11111111111111111111111111111111 non-portable at - line 3.
+ ########
+
+ # Check scope of pragma with eval
+ use warnings;
+ {
+ no warnings ;
+ eval '
+ my $a = oct "0xfffffffffffffffffg" ;
+ '; print STDERR $@ ;
+ my $a = oct "0xfffffffffffffffffg" ;
+ }
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ use warnings;
+ {
+ no warnings ;
+ eval q[
+ use warnings ;
+ my $a = oct "0xfffffffffffffffffg" ;
+ ]; print STDERR $@;
+ my $a = oct "0xfffffffffffffffffg" ;
+ }
+ EXPECT
+ Integer overflow in hexadecimal number at (eval 1) line 3.
+ Illegal hexadecimal digit 'g' ignored at (eval 1) line 3.
+ Hexadecimal number > 0xffffffff non-portable at (eval 1) line 3.
+ ########
+
+ # Check scope of pragma with eval
+ no warnings;
+ {
+ use warnings ;
+ eval '
+ my $a = oct "0xfffffffffffffffffg" ;
+ '; print STDERR $@ ;
+ }
+ EXPECT
+ Integer overflow in hexadecimal number at (eval 1) line 2.
+ Illegal hexadecimal digit 'g' ignored at (eval 1) line 2.
+ Hexadecimal number > 0xffffffff non-portable at (eval 1) line 2.
+ ########
+
+ # Check scope of pragma with eval
+ no warnings;
+ {
+ use warnings;
+ eval '
+ no warnings ;
+ my $a = oct "0xfffffffffffffffffg" ;
+ '; print STDERR $@ ;
+ }
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ no warnings;
+ {
+ use warnings 'deprecated' ;
+ eval '
+ my $a = oct "0xfffffffffffffffffg" ;
+ '; print STDERR $@;
+ }
+ EXPECT
+
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/7fatal'
Index: ./t/lib/warnings/7fatal
*** ./t/lib/warnings/7fatal Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/7fatal Mon Jul 9 17:11:24 2001
***************
*** 0 ****
--- 1,312 ----
+ Check FATAL functionality
+
+ __END__
+
+ # Check compile time warning
+ use warnings FATAL => 'syntax' ;
+ {
+ no warnings ;
+ $a =+ 1 ;
+ }
+ $a =+ 1 ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ Reversed += operator at - line 8.
+ ########
+
+ # Check compile time warning
+ use warnings FATAL => 'all' ;
+ {
+ no warnings ;
+ my $a =+ 1 ;
+ }
+ my $a =+ 1 ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ Reversed += operator at - line 8.
+ ########
+
+ # Check runtime scope of pragma
+ use warnings FATAL => 'uninitialized' ;
+ {
+ no warnings ;
+ my $b ; chop $b ;
+ }
+ my $b ; chop $b ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 8.
+ ########
+
+ # Check runtime scope of pragma
+ use warnings FATAL => 'all' ;
+ {
+ no warnings ;
+ my $b ; chop $b ;
+ }
+ my $b ; chop $b ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 8.
+ ########
+
+ # Check runtime scope of pragma
+ no warnings ;
+ {
+ use warnings FATAL => 'uninitialized' ;
+ $a = sub { my $b ; chop $b ; }
+ }
+ &$a ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 6.
+ ########
+
+ # Check runtime scope of pragma
+ no warnings ;
+ {
+ use warnings FATAL => 'all' ;
+ $a = sub { my $b ; chop $b ; }
+ }
+ &$a ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 6.
+ ########
+
+ --FILE-- abc
+ $a =+ 1 ;
+ 1;
+ --FILE--
+ use warnings FATAL => 'syntax' ;
+ require "./abc";
+ EXPECT
+
+ ########
+
+ --FILE-- abc
+ use warnings FATAL => 'syntax' ;
+ 1;
+ --FILE--
+ require "./abc";
+ $a =+ 1 ;
+ EXPECT
+
+ ########
+
+ --FILE-- abc
+ use warnings 'syntax' ;
+ $a =+ 1 ;
+ 1;
+ --FILE--
+ use warnings FATAL => 'uninitialized' ;
+ require "./abc";
+ my $a ; chop $a ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ Reversed += operator at ./abc line 2.
+ Use of uninitialized value in scalar chop at - line 3.
+ ########
+
+ --FILE-- abc.pm
+ use warnings 'syntax' ;
+ $a =+ 1 ;
+ 1;
+ --FILE--
+ use warnings FATAL => 'uninitialized' ;
+ use abc;
+ my $a ; chop $a ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ Reversed += operator at abc.pm line 2.
+ Use of uninitialized value in scalar chop at - line 3.
+ ########
+
+ # Check scope of pragma with eval
+ no warnings ;
+ eval {
+ use warnings FATAL => 'uninitialized' ;
+ my $b ; chop $b ;
+ }; print STDERR "-- $@" ;
+ my $b ; chop $b ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ -- Use of uninitialized value in scalar chop at - line 6.
+ The End.
+ ########
+
+ # Check scope of pragma with eval
+ use warnings FATAL => 'uninitialized' ;
+ eval {
+ my $b ; chop $b ;
+ }; print STDERR "-- $@" ;
+ my $b ; chop $b ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ -- Use of uninitialized value in scalar chop at - line 5.
+ Use of uninitialized value in scalar chop at - line 7.
+ ########
+
+ # Check scope of pragma with eval
+ use warnings FATAL => 'uninitialized' ;
+ eval {
+ no warnings ;
+ my $b ; chop $b ;
+ }; print STDERR $@ ;
+ my $b ; chop $b ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 8.
+ ########
+
+ # Check scope of pragma with eval
+ no warnings ;
+ eval {
+ use warnings FATAL => 'syntax' ;
+ $a =+ 1 ;
+ }; print STDERR "-- $@" ;
+ $a =+ 1 ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ Reversed += operator at - line 6.
+ ########
+
+ # Check scope of pragma with eval
+ use warnings FATAL => 'syntax' ;
+ eval {
+ $a =+ 1 ;
+ }; print STDERR "-- $@" ;
+ $a =+ 1 ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ Reversed += operator at - line 5.
+ ########
+
+ # Check scope of pragma with eval
+ use warnings FATAL => 'syntax' ;
+ eval {
+ no warnings ;
+ $a =+ 1 ;
+ }; print STDERR $@ ;
+ $a =+ 1 ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ Reversed += operator at - line 8.
+ ########
+
+ # Check scope of pragma with eval
+ no warnings ;
+ eval {
+ use warnings FATAL => 'syntax' ;
+ }; print STDERR $@ ;
+ $a =+ 1 ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ The End.
+ ########
+
+ # Check scope of pragma with eval
+ no warnings ;
+ eval q[
+ use warnings FATAL => 'uninitialized' ;
+ my $b ; chop $b ;
+ ]; print STDERR "-- $@";
+ my $b ; chop $b ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ -- Use of uninitialized value in scalar chop at (eval 1) line 3.
+ The End.
+ ########
+
+ # Check scope of pragma with eval
+ use warnings FATAL => 'uninitialized' ;
+ eval '
+ my $b ; chop $b ;
+ '; print STDERR "-- $@" ;
+ my $b ; chop $b ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ -- Use of uninitialized value in scalar chop at (eval 1) line 2.
+ Use of uninitialized value in scalar chop at - line 7.
+ ########
+
+ # Check scope of pragma with eval
+ use warnings FATAL => 'uninitialized' ;
+ eval '
+ no warnings ;
+ my $b ; chop $b ;
+ '; print STDERR $@ ;
+ my $b ; chop $b ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 8.
+ ########
+
+ # Check scope of pragma with eval
+ no warnings ;
+ eval q[
+ use warnings FATAL => 'syntax' ;
+ $a =+ 1 ;
+ ]; print STDERR "-- $@";
+ $a =+ 1 ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ -- Reversed += operator at (eval 1) line 3.
+ The End.
+ ########
+
+ # Check scope of pragma with eval
+ use warnings FATAL => 'syntax' ;
+ eval '
+ $a =+ 1 ;
+ '; print STDERR "-- $@";
+ print STDERR "The End.\n" ;
+ EXPECT
+ -- Reversed += operator at (eval 1) line 2.
+ The End.
+ ########
+
+ # Check scope of pragma with eval
+ use warnings FATAL => 'syntax' ;
+ eval '
+ no warnings ;
+ $a =+ 1 ;
+ '; print STDERR "-- $@";
+ $a =+ 1 ;
+ print STDERR "The End.\n" ;
+ EXPECT
+ Reversed += operator at - line 8.
+ ########
+
+ use warnings 'void' ;
+
+ time ;
+
+ {
+ use warnings FATAL => qw(void) ;
+ length "abc" ;
+ }
+
+ join "", 1,2,3 ;
+
+ print "done\n" ;
+ EXPECT
+ Useless use of time in void context at - line 4.
+ Useless use of length in void context at - line 8.
+ ########
+
+ use warnings ;
+
+ time ;
+
+ {
+ use warnings FATAL => qw(void) ;
+ length "abc" ;
+ }
+
+ join "", 1,2,3 ;
+
+ print "done\n" ;
+ EXPECT
+ Useless use of time in void context at - line 4.
+ Useless use of length in void context at - line 8.
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/8signal'
Index: ./t/lib/warnings/8signal
*** ./t/lib/warnings/8signal Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/8signal Mon Jul 9 17:11:24 2001
***************
*** 0 ****
--- 1,18 ----
+ Check interaction of __WARN__, __DIE__ & lexical Warnings
+
+ TODO
+
+ __END__
+ # 8signal
+ BEGIN { $| = 1; $SIG{__WARN__} = sub { print "WARN -- @_" } }
+ BEGIN { $SIG{__DIE__} = sub { print "DIE -- @_" } }
+ $a =+ 1 ;
+ use warnings qw(syntax) ;
+ $a =+ 1 ;
+ use warnings FATAL => qw(syntax) ;
+ $a =+ 1 ;
+ print "The End.\n" ;
+ EXPECT
+ WARN -- Reversed += operator at - line 6.
+ DIE -- Reversed += operator at - line 8.
+ Reversed += operator at - line 8.
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/9enabled'
Index: ./t/lib/warnings/9enabled
*** ./t/lib/warnings/9enabled Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/9enabled Mon Jul 9 17:11:24 2001
***************
*** 0 ****
--- 1,1162 ----
+ Check warnings::enabled & warnings::warn
+
+ __END__
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings "io" ;
+ print "ok1\n" if ! warnings::enabled('all') ;
+ print "ok2\n" if ! warnings::enabled("io") ;
+ 1;
+ --FILE--
+ no warnings;
+ use abc ;
+ EXPECT
+ ok1
+ ok2
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ no warnings ;
+ print "ok1\n" if !warnings::enabled('all') ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ use abc ;
+ EXPECT
+ ok1
+ ok2
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings 'syntax' ;
+ print "ok1\n" if warnings::enabled('io') ;
+ print "ok2\n" if ! warnings::enabled("syntax") ;
+ 1;
+ --FILE--
+ use warnings 'io' ;
+ use abc ;
+ EXPECT
+ ok1
+ ok2
+ ########
+
+ --FILE-- abc
+ no warnings ;
+ print "ok1\n" if !warnings::enabled('all') ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ require "abc" ;
+ EXPECT
+ ok1
+ ok2
+ ########
+
+ --FILE-- abc
+ use warnings 'syntax' ;
+ print "ok1\n" if ! warnings::enabled('all') ;
+ print "ok2\n" if ! warnings::enabled("syntax") ;
+ print "ok3\n" if warnings::enabled("io") ;
+ 1;
+ --FILE--
+ use warnings 'io' ;
+ require "abc" ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ no warnings ;
+ sub check {
+ print "ok1\n" if !warnings::enabled('all') ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ use abc ;
+ abc::check() ;
+ EXPECT
+ ok1
+ ok2
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings 'io' ;
+ sub check {
+ print "ok1\n" if ! warnings::enabled('all') ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok3\n" if ! warnings::enabled("io") ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ use abc ;
+ abc::check() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ########
+
+ --FILE-- abc
+ package abc ;
+ no warnings ;
+ sub check {
+ print "ok1\n" if !warnings::enabled('all') ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ require "abc" ;
+ abc::check() ;
+ EXPECT
+ ok1
+ ok2
+ ########
+
+ --FILE-- abc
+ package abc ;
+ use warnings 'io' ;
+ sub check {
+ print "ok1\n" if ! warnings::enabled('all') ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok3\n" if ! warnings::enabled("io") ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ require "abc" ;
+ abc::check() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings "io" ;
+ print "ok1\n" if ! warnings::enabled('all') ;
+ print "ok2\n" if ! warnings::enabled("io") ;
+ 1;
+ --FILE-- def.pm
+ no warnings;
+ use abc ;
+ 1;
+ --FILE--
+ use warnings;
+ use def ;
+ EXPECT
+ ok1
+ ok2
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ no warnings ;
+ print "ok1\n" if ! warnings::enabled('all') ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok3\n" if !warnings::enabled("io") ;
+ 1;
+ --FILE-- def.pm
+ use warnings 'syntax' ;
+ print "ok4\n" if !warnings::enabled('all') ;
+ print "ok5\n" if warnings::enabled("io") ;
+ use abc ;
+ 1;
+ --FILE--
+ use warnings 'io' ;
+ use def ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ok4
+ ok5
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ no warnings ;
+ sub check {
+ print "ok1\n" if !warnings::enabled('all') ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ use abc ;
+ eval { abc::check() ; };
+ print $@ ;
+ EXPECT
+ ok1
+ ok2
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings 'io' ;
+ sub check {
+ print "ok1\n" if ! warnings::enabled('all') ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok3\n" if ! warnings::enabled("io") ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ use abc ;
+ eval { abc::check() ; } ;
+ print $@ ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ########
+
+ --FILE-- abc
+ package abc ;
+ no warnings ;
+ sub check {
+ print "ok1\n" if !warnings::enabled('all') ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ require "abc" ;
+ eval { abc::check() ; } ;
+ print $@ ;
+ EXPECT
+ ok1
+ ok2
+ ########
+
+ --FILE-- abc
+ package abc ;
+ use warnings 'io' ;
+ sub check {
+ print "ok1\n" if !warnings::enabled('all') ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok3\n" if warnings::enabled("io") ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ require "abc" ;
+ eval { use warnings 'io' ; abc::check() ; };
+ abc::check() ;
+ print $@ ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ok1
+ ok2
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings 'io' ;
+ sub check {
+ print "ok1\n" if ! warnings::enabled('all') ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok3\n" if ! warnings::enabled("io") ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ use abc ;
+ sub fred { abc::check() }
+ fred() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings 'io' ;
+ sub check {
+ print "ok1\n" if ! warnings::enabled('all') ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ use abc ;
+ sub fred { no warnings ; abc::check() }
+ fred() ;
+ EXPECT
+ ok1
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings 'misc' ;
+ sub check {
+ print "ok1\n" if ! warnings::enabled('all') ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok3\n" if warnings::enabled("io") ;
+ print "ok4\n" if ! warnings::enabled("misc") ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ use abc ;
+ sub fred { use warnings 'io' ; abc::check() }
+ fred() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ok4
+ ########
+
+ # check warnings::warn
+ use warnings ;
+ eval { warnings::warn() } ;
+ print $@ ;
+ eval { warnings::warn("fred", "joe") } ;
+ print $@ ;
+ EXPECT
+ Usage: warnings::warn([category,] 'message') at - line 4
+ unknown warnings category 'fred' at - line 6
+ ########
+
+ # check warnings::warnif
+ use warnings ;
+ eval { warnings::warnif() } ;
+ print $@ ;
+ eval { warnings::warnif("fred", "joe") } ;
+ print $@ ;
+ EXPECT
+ Usage: warnings::warnif([category,] 'message') at - line 4
+ unknown warnings category 'fred' at - line 6
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings 'misc' ;
+ sub check { warnings::warn("io", "hello") }
+ 1;
+ --FILE--
+ use warnings "io" ;
+ use abc;
+ abc::check() ;
+ EXPECT
+ hello at - line 3
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings 'misc' ;
+ sub check { warnings::warn("misc", "hello") }
+ 1;
+ --FILE--
+ use warnings "io" ;
+ use abc;
+ abc::check() ;
+ EXPECT
+ hello at - line 3
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings 'misc' ;
+ sub check { warnings::warn("io", "hello") }
+ 1;
+ --FILE--
+ use warnings qw( FATAL deprecated ) ;
+ use abc;
+ eval { abc::check() ; } ;
+ print "[[$@]]\n";
+ EXPECT
+ hello at - line 3
+ eval {...} called at - line 3
+ [[]]
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings 'misc' ;
+ sub check { warnings::warn("io", "hello") }
+ 1;
+ --FILE--
+ use warnings qw( FATAL io ) ;
+ use abc;
+ eval { abc::check() ; } ;
+ print "[[$@]]\n";
+ EXPECT
+ [[hello at - line 3
+ eval {...} called at - line 3
+ ]]
+ ########
+ -W
+ --FILE-- abc.pm
+ package abc ;
+ use warnings "io" ;
+ print "ok1\n" if warnings::enabled("io") ;
+ print "ok2\n" if warnings::enabled("all") ;
+ 1;
+ --FILE--
+ no warnings;
+ use abc ;
+ EXPECT
+ ok1
+ ok2
+ ########
+ -X
+ --FILE-- abc.pm
+ package abc ;
+ use warnings "io" ;
+ print "ok1\n" if !warnings::enabled("io") ;
+ print "ok2\n" if !warnings::enabled("all") ;
+ 1;
+ --FILE--
+ use warnings;
+ use abc ;
+ EXPECT
+ ok1
+ ok2
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ no warnings ;
+ sub check {
+ print "ok\n" if ! warnings::enabled() ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ use abc ;
+ abc::check() ;
+ EXPECT
+ package 'abc' not registered for warnings at abc.pm line 4
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ no warnings ;
+ sub check {
+ warnings::warn("fred") ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ use abc ;
+ abc::check() ;
+ EXPECT
+ package 'abc' not registered for warnings at abc.pm line 4
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ no warnings ;
+ sub check {
+ warnings::warnif("fred") ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ use abc ;
+ abc::check() ;
+ EXPECT
+ package 'abc' not registered for warnings at abc.pm line 4
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings 'io' ;
+ use warnings::register ;
+ sub check {
+ print "ok1\n" if warnings::enabled ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok3\n" if !warnings::enabled("io") ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ use abc ;
+ use warnings 'abc' ;
+ abc::check() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings 'io' ;
+ use warnings::register ;
+ sub check {
+ print "ok1\n" if !warnings::enabled ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok3\n" if !warnings::enabled("io") ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ use abc ;
+ abc::check() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ no warnings ;
+ use warnings::register ;
+ sub check {
+ print "ok1\n" if warnings::enabled ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ use abc ;
+ use warnings 'abc' ;
+ eval { abc::check() ; };
+ print $@ ;
+ EXPECT
+ ok1
+ ok2
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings 'io' ;
+ use warnings::register ;
+ sub check {
+ print "ok1\n" if !warnings::enabled ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok3\n" if !warnings::enabled("io") ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ use abc ;
+ eval { abc::check() ; } ;
+ print $@ ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings 'io' ;
+ use warnings::register ;
+ sub check {
+ print "ok1\n" if warnings::enabled ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok3\n" if !warnings::enabled("io") ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ use abc ;
+ use warnings 'abc' ;
+ sub fred { abc::check() }
+ fred() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings 'io' ;
+ use warnings::register ;
+ sub check {
+ print "ok1\n" if ! warnings::enabled ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ use abc ;
+ sub fred { no warnings ; abc::check() }
+ fred() ;
+ EXPECT
+ ok1
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings 'misc' ;
+ use warnings::register;
+ sub check {
+ print "ok1\n" if warnings::enabled ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok3\n" if warnings::enabled("io") ;
+ print "ok4\n" if ! warnings::enabled("misc") ;
+ }
+ 1;
+ --FILE--
+ use warnings 'syntax' ;
+ use abc ;
+ use warnings 'abc' ;
+ sub fred { use warnings 'io' ; abc::check() }
+ fred() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ok4
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings 'misc' ;
+ use warnings::register;
+ sub check { warnings::warn("hello") }
+ 1;
+ --FILE--
+ use abc;
+ use warnings "abc" ;
+ abc::check() ;
+ EXPECT
+ hello at - line 3
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings::register;
+ sub check { warnings::warn("hello") }
+ 1;
+ --FILE--
+ use abc;
+ abc::check() ;
+ EXPECT
+ hello at - line 2
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings::register ;
+ sub check { warnings::warn("hello") }
+ 1;
+ --FILE--
+ use abc;
+ use warnings qw( FATAL deprecated ) ;
+ eval { abc::check() ; } ;
+ print "[[$@]]\n";
+ EXPECT
+ hello at - line 3
+ eval {...} called at - line 3
+ [[]]
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings::register ;
+ sub check { warnings::warn("hello") }
+ 1;
+ --FILE--
+ use abc;
+ use warnings qw( FATAL abc ) ;
+ eval { abc::check() ; } ;
+ print "[[$@]]\n";
+ EXPECT
+ [[hello at - line 3
+ eval {...} called at - line 3
+ ]]
+ ########
+ -W
+ --FILE-- abc.pm
+ package abc ;
+ use warnings "io" ;
+ use warnings::register ;
+ sub check {
+ print "ok1\n" if warnings::enabled() ;
+ print "ok2\n" if warnings::enabled("io") ;
+ print "ok3\n" if warnings::enabled("all") ;
+ }
+ 1;
+ --FILE--
+ no warnings;
+ use abc ;
+ abc::check() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ########
+ -X
+ --FILE-- abc.pm
+ package abc ;
+ use warnings "io" ;
+ use warnings::register ;
+ sub check {
+ print "ok1\n" if !warnings::enabled() ;
+ print "ok2\n" if !warnings::enabled("io") ;
+ print "ok3\n" if !warnings::enabled("all") ;
+ }
+ 1;
+ --FILE--
+ no warnings;
+ use abc ;
+ abc::check() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings "io" ;
+ use warnings::register ;
+ sub check {
+ print "ok1\n" if warnings::enabled() ;
+ print "ok2\n" if warnings::enabled("io") ;
+ print "ok3\n" if warnings::enabled("all") ;
+ }
+ 1;
+ --FILE--
+ use warnings 'all';
+ use abc ;
+ abc::check() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings "io" ;
+ use warnings::register ;
+ sub check {
+ print "ok1\n" if !warnings::enabled() ;
+ print "ok2\n" if !warnings::enabled("io") ;
+ print "ok3\n" if !warnings::enabled("all") ;
+ }
+ 1;
+ --FILE--
+ use abc ;
+ no warnings ;
+ abc::check() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings "io" ;
+ use warnings::register ;
+ sub check {
+ print "ok1\n" if !warnings::enabled() ;
+ print "ok2\n" if !warnings::enabled("io") ;
+ print "ok3\n" if !warnings::enabled("all") ;
+ warnings::warnif("my message 1") ;
+ warnings::warnif('abc', "my message 2") ;
+ warnings::warnif('io', "my message 3") ;
+ warnings::warnif('all', "my message 4") ;
+ }
+ 1;
+ --FILE--
+ use abc ;
+ use warnings 'abc';
+ no warnings ;
+ abc::check() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ use warnings "io" ;
+ use warnings::register ;
+ sub check {
+ print "abc self" . (warnings::enabled() ? "" : " not") . " enabled\n" ;
+ print "abc def" . (warnings::enabled('def') ? "" : " not") . " enabled\n" ;
+ print "abc all" . (warnings::enabled('all') ? "" : " not") . " enabled\n" ;
+ }
+ 1;
+ --FILE-- def.pm
+ package def ;
+ use warnings "io" ;
+ use warnings::register ;
+ sub check {
+ print "def self" . (warnings::enabled() ? "" : " not") . " enabled\n" ;
+ print "def abc" . (warnings::enabled('abc') ? "" : " not") . " enabled\n" ;
+ print "def all" . (warnings::enabled('all') ? "" : " not") . " enabled\n" ;
+ }
+ 1;
+ --FILE--
+ use abc ;
+ use def ;
+ use warnings 'abc';
+ abc::check() ;
+ def::check() ;
+ no warnings 'abc' ;
+ use warnings 'def' ;
+ abc::check() ;
+ def::check() ;
+ use warnings 'abc' ;
+ use warnings 'def' ;
+ abc::check() ;
+ def::check() ;
+ no warnings 'abc' ;
+ no warnings 'def' ;
+ abc::check() ;
+ def::check() ;
+ use warnings;
+ abc::check() ;
+ def::check() ;
+ no warnings 'abc' ;
+ abc::check() ;
+ def::check() ;
+ EXPECT
+ abc self enabled
+ abc def not enabled
+ abc all not enabled
+ def self not enabled
+ def abc enabled
+ def all not enabled
+ abc self not enabled
+ abc def enabled
+ abc all not enabled
+ def self enabled
+ def abc not enabled
+ def all not enabled
+ abc self enabled
+ abc def enabled
+ abc all not enabled
+ def self enabled
+ def abc enabled
+ def all not enabled
+ abc self not enabled
+ abc def not enabled
+ abc all not enabled
+ def self not enabled
+ def abc not enabled
+ def all not enabled
+ abc self enabled
+ abc def enabled
+ abc all enabled
+ def self enabled
+ def abc enabled
+ def all enabled
+ abc self not enabled
+ abc def enabled
+ abc all not enabled
+ def self enabled
+ def abc not enabled
+ def all not enabled
+ ########
+ -w
+ --FILE-- abc.pm
+ package abc ;
+ no warnings ;
+ use warnings::register ;
+ sub check {
+ print "ok1\n" if warnings::enabled() ;
+ print "ok2\n" if warnings::enabled("io") ;
+ print "ok3\n" if warnings::enabled("all") ;
+ }
+ 1;
+ --FILE--
+ use abc ;
+ abc::check() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ########
+ -w
+ --FILE-- abc.pm
+ package abc ;
+ no warnings ;
+ use warnings::register ;
+ sub check {
+ print "ok1\n" if !warnings::enabled() ;
+ print "ok2\n" if !warnings::enabled("io") ;
+ print "ok3\n" if !warnings::enabled("all") ;
+ }
+ 1;
+ --FILE--
+ use abc ;
+ use warnings 'abc';
+ no warnings ;
+ abc::check() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ no warnings ;
+ use warnings::register ;
+ sub check {
+ print "ok1\n" if !warnings::enabled() ;
+ print "ok2\n" if !warnings::enabled("io") ;
+ print "ok3\n" if !warnings::enabled("all") ;
+ warnings::warnif("my message 1") ;
+ warnings::warnif('abc', "my message 2") ;
+ warnings::warnif('io', "my message 3") ;
+ warnings::warnif('all', "my message 4") ;
+ }
+ 1;
+ --FILE--
+ use abc ;
+ use warnings 'abc';
+ no warnings ;
+ BEGIN { $^W = 1 ; }
+ abc::check() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ########
+
+ --FILE-- abc.pm
+ package abc ;
+ no warnings ;
+ use warnings::register ;
+ sub check {
+ print "ok1\n" if !warnings::enabled() ;
+ print "ok2\n" if !warnings::enabled("io") ;
+ print "ok3\n" if !warnings::enabled("all") ;
+ }
+ 1;
+ --FILE--
+ use abc ;
+ use warnings 'abc';
+ no warnings ;
+ $^W = 1 ;
+ abc::check() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ########
+
+ --FILE-- abc.pm
+ $| = 1;
+ package abc ;
+ no warnings ;
+ use warnings::register ;
+ sub check {
+ print "ok1\n" if warnings::enabled() ;
+ print "ok2\n" if !warnings::enabled("io") ;
+ print "ok3\n" if !warnings::enabled("all") ;
+ print "ok4\n" if warnings::enabled("abc") ;
+ warnings::warn("my message 1") ;
+ warnings::warnif("my message 2") ;
+ warnings::warnif('abc', "my message 3") ;
+ warnings::warnif('io', "my message 4") ;
+ warnings::warnif('all', "my message 5") ;
+ }
+ sub in2 { no warnings ; check() }
+ sub in1 { no warnings ; in2() }
+ 1;
+ --FILE--
+ use abc ;
+ use warnings 'abc';
+ abc::in1() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ok4
+ my message 1 at - line 3
+ my message 2 at - line 3
+ my message 3 at - line 3
+ ########
+
+ --FILE-- def.pm
+ package def ;
+ no warnings ;
+ use warnings::register ;
+ sub check {
+ print "ok1\n" if warnings::enabled() ;
+ print "ok2\n" if !warnings::enabled("io") ;
+ print "ok3\n" if !warnings::enabled("all") ;
+ print "ok4\n" if warnings::enabled("def") ;
+ warnings::warn("my message 1") ;
+ warnings::warnif("my message 2") ;
+ warnings::warnif('def', "my message 3") ;
+ warnings::warnif('io', "my message 4") ;
+ warnings::warnif('all', "my message 5") ;
+ }
+ sub in2 { no warnings ; check() }
+ sub in1 { no warnings ; in2() }
+ 1;
+ --FILE-- abc.pm
+ $| = 1;
+ package abc ;
+ use def ;
+ use warnings 'def';
+ sub in1 { def::in1() ; }
+ 1;
+ --FILE--
+ use abc ;
+ no warnings;
+ abc::in1() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ok4
+ my message 1 at abc.pm line 5
+ abc::in1() called at - line 3
+ my message 2 at abc.pm line 5
+ abc::in1() called at - line 3
+ my message 3 at abc.pm line 5
+ abc::in1() called at - line 3
+ ########
+
+ --FILE-- def.pm
+ $| = 1;
+ package def ;
+ no warnings ;
+ use warnings::register ;
+ require Exporter;
+ @ISA = qw( Exporter ) ;
+ @EXPORT = qw( in1 ) ;
+ sub check {
+ print "ok1\n" if warnings::enabled() ;
+ print "ok2\n" if !warnings::enabled("io") ;
+ print "ok3\n" if !warnings::enabled("all") ;
+ print "ok4\n" if warnings::enabled("abc") ;
+ print "ok5\n" if !warnings::enabled("def") ;
+ warnings::warn("my message 1") ;
+ warnings::warnif("my message 2") ;
+ warnings::warnif('abc', "my message 3") ;
+ warnings::warnif('def', "my message 4") ;
+ warnings::warnif('io', "my message 5") ;
+ warnings::warnif('all', "my message 6") ;
+ }
+ sub in2 { no warnings ; check() }
+ sub in1 { no warnings ; in2() }
+ 1;
+ --FILE-- abc.pm
+ package abc ;
+ use warnings::register ;
+ use def ;
+ #@ISA = qw(def) ;
+ 1;
+ --FILE--
+ use abc ;
+ no warnings;
+ use warnings 'abc';
+ abc::in1() ;
+ EXPECT
+ ok2
+ ok3
+ ok4
+ ok5
+ my message 1 at - line 4
+ my message 3 at - line 4
+ ########
+
+ --FILE-- def.pm
+ package def ;
+ no warnings ;
+ use warnings::register ;
+
+ sub new
+ {
+ my $class = shift ;
+ bless [], $class ;
+ }
+
+ sub check
+ {
+ my $self = shift ;
+ print "ok1\n" if !warnings::enabled() ;
+ print "ok2\n" if !warnings::enabled("io") ;
+ print "ok3\n" if !warnings::enabled("all") ;
+ print "ok4\n" if warnings::enabled("abc") ;
+ print "ok5\n" if !warnings::enabled("def") ;
+ print "ok6\n" if warnings::enabled($self) ;
+
+ warnings::warn("my message 1") ;
+ warnings::warn($self, "my message 2") ;
+
+ warnings::warnif("my message 3") ;
+ warnings::warnif('abc', "my message 4") ;
+ warnings::warnif('def', "my message 5") ;
+ warnings::warnif('io', "my message 6") ;
+ warnings::warnif('all', "my message 7") ;
+ warnings::warnif($self, "my message 8") ;
+ }
+ sub in2
+ {
+ no warnings ;
+ my $self = shift ;
+ $self->check() ;
+ }
+ sub in1
+ {
+ no warnings ;
+ my $self = shift ;
+ $self->in2();
+ }
+ 1;
+ --FILE-- abc.pm
+ $| = 1;
+ package abc ;
+ use warnings::register ;
+ use def ;
+ @ISA = qw(def) ;
+ sub new
+ {
+ my $class = shift ;
+ bless [], $class ;
+ }
+
+ 1;
+ --FILE--
+ use abc ;
+ no warnings;
+ use warnings 'abc';
+ $a = new abc ;
+ $a->in1() ;
+ print "**\n";
+ $b = new def ;
+ $b->in1() ;
+ EXPECT
+ ok1
+ ok2
+ ok3
+ ok4
+ ok5
+ ok6
+ my message 1 at - line 5
+ my message 2 at - line 5
+ my message 4 at - line 5
+ my message 8 at - line 5
+ **
+ ok1
+ ok2
+ ok3
+ ok4
+ ok5
+ my message 1 at - line 8
+ my message 2 at - line 8
+ my message 4 at - line 8
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/av'
Index: ./t/lib/warnings/av
*** ./t/lib/warnings/av Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/av Mon Jul 9 17:11:24 2001
***************
*** 0 ****
--- 1,9 ----
+ av.c
+
+ Mandatory Warnings ALL TODO
+ ------------------
+ av_reify called on tied array [av_reify]
+
+ Attempt to clear deleted array [av_clear]
+
+ __END__
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/doio'
Index: ./t/lib/warnings/doio
*** ./t/lib/warnings/doio Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/doio Thu Jul 12 04:36:35 2001
***************
*** 0 ****
--- 1,214 ----
+ doio.c
+
+ Can't open bidirectional pipe [Perl_do_open9]
+ open(F, "| true |");
+
+ Missing command in piped open [Perl_do_open9]
+ open(F, "| ");
+
+ Missing command in piped open [Perl_do_open9]
+ open(F, " |");
+
+ warn(warn_nl, "open"); [Perl_do_open9]
+ open(F, "true\ncd")
+
+ close() on unopened filehandle %s [Perl_do_close]
+ $a = "fred";close("$a")
+
+ tell() on closed filehandle [Perl_do_tell]
+ $a = "fred";$a = tell($a)
+
+ seek() on closed filehandle [Perl_do_seek]
+ $a = "fred";$a = seek($a,1,1)
+
+ sysseek() on closed filehandle [Perl_do_sysseek]
+ $a = "fred";$a = seek($a,1,1)
+
+ warn(warn_uninit); [Perl_do_print]
+ print $a ;
+
+ -x on closed filehandle %s [Perl_my_stat]
+ close STDIN ; -x STDIN ;
+
+ warn(warn_nl, "stat"); [Perl_my_stat]
+ stat "ab\ncd"
+
+ warn(warn_nl, "lstat"); [Perl_my_lstat]
+ lstat "ab\ncd"
+
+ Can't exec \"%s\": %s [Perl_do_aexec5]
+
+ Can't exec \"%s\": %s [Perl_do_exec3]
+
+ Filehandle %s opened only for output [Perl_do_eof]
+ my $a = eof STDOUT
+
+ Mandatory Warnings ALL TODO
+ ------------------
+ Can't do inplace edit: %s is not a regular file [Perl_nextargv]
+ edit a directory
+
+ Can't do inplace edit: %s would not be unique [Perl_nextargv]
+ Can't rename %s to %s: %s, skipping file [Perl_nextargv]
+ Can't rename %s to %s: %s, skipping file [Perl_nextargv]
+ Can't remove %s: %s, skipping file [Perl_nextargv]
+ Can't do inplace edit on %s: %s [Perl_nextargv]
+
+
+ __END__
+ # doio.c [Perl_do_open9]
+ use warnings 'io' ;
+ open(F, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|");
+ close(F);
+ no warnings 'io' ;
+ open(G, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|");
+ close(G);
+ EXPECT
+ Can't open bidirectional pipe at - line 3.
+ ########
+ # doio.c [Perl_do_open9]
+ use warnings 'io' ;
+ open(F, "| ");
+ no warnings 'io' ;
+ open(G, "| ");
+ EXPECT
+ Missing command in piped open at - line 3.
+ ########
+ # doio.c [Perl_do_open9]
+ use warnings 'io' ;
+ open(F, " |");
+ no warnings 'io' ;
+ open(G, " |");
+ EXPECT
+ Missing command in piped open at - line 3.
+ ########
+ # doio.c [Perl_do_open9]
+ use warnings 'io' ;
+ open(F, "<true\ncd");
+ no warnings 'io' ;
+ open(G, "<true\ncd");
+ EXPECT
+ Unsuccessful open on filename containing newline at - line 3.
+ ########
+ # doio.c [Perl_do_close] <<TODO
+ use warnings 'unopened' ;
+ close "fred" ;
+ no warnings 'unopened' ;
+ close "joe" ;
+ EXPECT
+ close() on unopened filehandle fred at - line 3.
+ ########
+ # doio.c [Perl_do_tell Perl_do_seek Perl_do_sysseek Perl_my_stat]
+ use warnings 'io' ;
+ close STDIN ;
+ tell(STDIN);
+ $a = seek(STDIN,1,1);
+ $a = sysseek(STDIN,1,1);
+ -x STDIN ;
+ stat(STDIN) ;
+ $a = "fred";
+ tell($a);
+ seek($a,1,1);
+ sysseek($a,1,1);
+ -x $a; # ok
+ stat($a); # ok
+ no warnings 'io' ;
+ close STDIN ;
+ tell(STDIN);
+ $a = seek(STDIN,1,1);
+ $a = sysseek(STDIN,1,1);
+ -x STDIN ;
+ stat(STDIN) ;
+ $a = "fred";
+ tell($a);
+ seek($a,1,1);
+ sysseek($a,1,1);
+ -x $a;
+ stat($a);
+ EXPECT
+ tell() on closed filehandle STDIN at - line 4.
+ seek() on closed filehandle STDIN at - line 5.
+ sysseek() on closed filehandle STDIN at - line 6.
+ -x on closed filehandle STDIN at - line 7.
+ stat() on closed filehandle STDIN at - line 8.
+ tell() on unopened filehandle at - line 10.
+ seek() on unopened filehandle at - line 11.
+ sysseek() on unopened filehandle at - line 12.
+ ########
+ # doio.c [Perl_do_print]
+ use warnings 'uninitialized' ;
+ print $a ;
+ no warnings 'uninitialized' ;
+ print $b ;
+ EXPECT
+ Use of uninitialized value in print at - line 3.
+ ########
+ # doio.c [Perl_my_stat Perl_my_lstat]
+ use warnings 'io' ;
+ stat "ab\ncd";
+ lstat "ab\ncd";
+ no warnings 'io' ;
+ stat "ab\ncd";
+ lstat "ab\ncd";
+ EXPECT
+ Unsuccessful stat on filename containing newline at - line 3.
+ Unsuccessful stat on filename containing newline at - line 4.
+ ########
+ # doio.c [Perl_do_aexec5]
+ use warnings 'io' ;
+ exec "lskdjfalksdjfdjfkls","" ;
+ no warnings 'io' ;
+ exec "lskdjfalksdjfdjfkls","" ;
+ EXPECT
+ OPTION regex
+ Can't exec "lskdjfalksdjfdjfkls": .+
+ ########
+ # doio.c [Perl_do_exec3]
+ use warnings 'io' ;
+ exec "lskdjfalksdjfdjfkls", "abc" ;
+ no warnings 'io' ;
+ exec "lskdjfalksdjfdjfkls", "abc" ;
+ EXPECT
+ OPTION regex
+ Can't exec "lskdjfalksdjfdjfkls(:? abc)?": .+
+ ########
+ # doio.c [win32_execvp]
+ use warnings 'exec' ;
+ exec $^X, "-e0" ;
+ EXPECT
+ ########
+ # doio.c [Perl_nextargv]
+ $^W = 0 ;
+ my $filename = "./temp.dir" ;
+ mkdir $filename, 0777
+ or die "Cannot create directory $filename: $!\n" ;
+ {
+ local (@ARGV) = ($filename) ;
+ local ($^I) = "" ;
+ my $x = <> ;
+ }
+ {
+ no warnings 'inplace' ;
+ local (@ARGV) = ($filename) ;
+ local ($^I) = "" ;
+ my $x = <> ;
+ }
+ {
+ use warnings 'inplace' ;
+ local (@ARGV) = ($filename) ;
+ local ($^I) = "" ;
+ my $x = <> ;
+ }
+ rmdir $filename ;
+ EXPECT
+ Can't do inplace edit: ./temp.dir is not a regular file at - line 9.
+ Can't do inplace edit: ./temp.dir is not a regular file at - line 21.
+
+ ########
+ # doio.c [Perl_do_eof]
+ use warnings 'io' ;
+ my $a = eof STDOUT ;
+ no warnings 'io' ;
+ $a = eof STDOUT ;
+ EXPECT
+ Filehandle STDOUT opened only for output at - line 3.
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/doop'
Index: ./t/lib/warnings/doop
*** ./t/lib/warnings/doop Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/doop Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,6 ----
+ # doop.c
+ use utf8 ;
+ $_ = "\x80 \xff" ;
+ chop ;
+ EXPECT
+ ########
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/gv'
Index: ./t/lib/warnings/gv
*** ./t/lib/warnings/gv Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/gv Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,54 ----
+ gv.c AOK
+
+ Can't locate package %s for @%s::ISA
+ @ISA = qw(Fred); joe()
+
+ Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated
+ sub Other::AUTOLOAD { 1 } sub Other::fred {}
+ @ISA = qw(Other) ;
+ fred() ;
+
+ Use of $# is deprecated
+ Use of $* is deprecated
+
+ $a = ${"#"} ;
+ $a = ${"*"} ;
+
+ Mandatory Warnings ALL TODO
+ ------------------
+
+ Had to create %s unexpectedly [gv_fetchpv]
+ Attempt to free unreferenced glob pointers [gp_free]
+
+ __END__
+ # gv.c
+ use warnings 'misc' ;
+ @ISA = qw(Fred); joe()
+ EXPECT
+ Can't locate package Fred for @main::ISA at - line 3.
+ Undefined subroutine &main::joe called at - line 3.
+ ########
+ # gv.c
+ no warnings 'misc' ;
+ @ISA = qw(Fred); joe()
+ EXPECT
+ Undefined subroutine &main::joe called at - line 3.
+ ########
+ # gv.c
+ sub Other::AUTOLOAD { 1 } sub Other::fred {}
+ @ISA = qw(Other) ;
+ use warnings 'deprecated' ;
+ fred() ;
+ EXPECT
+ Use of inherited AUTOLOAD for non-method main::fred() is deprecated at - line 5.
+ ########
+ # gv.c
+ use warnings 'deprecated' ;
+ $a = ${"#"};
+ $a = ${"*"};
+ no warnings 'deprecated' ;
+ $a = ${"#"};
+ $a = ${"*"};
+ EXPECT
+ Use of $# is deprecated at - line 3.
+ Use of $* is deprecated at - line 4.
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/hv'
Index: ./t/lib/warnings/hv
*** ./t/lib/warnings/hv Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/hv Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,8 ----
+ hv.c
+
+
+ Mandatory Warnings ALL TODO
+ ------------------
+ Attempt to free non-existent shared string [unsharepvn]
+
+ __END__
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/malloc'
Index: ./t/lib/warnings/malloc
*** ./t/lib/warnings/malloc Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/malloc Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,9 ----
+ malloc.c
+
+
+ Mandatory Warnings ALL TODO
+ ------------------
+ %s free() ignored [Perl_mfree]
+ %s", "Bad free() ignored [Perl_mfree]
+
+ __END__
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/mg'
Index: ./t/lib/warnings/mg
*** ./t/lib/warnings/mg Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/mg Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,44 ----
+ mg.c AOK
+
+ No such signal: SIG%s
+ $SIG{FRED} = sub {}
+
+ SIG%s handler \"%s\" not defined.
+ $SIG{"INT"} = "ok3"; kill "INT",$$;
+
+ Mandatory Warnings TODO
+ ------------------
+ Can't break at that line [magic_setdbline]
+
+ __END__
+ # mg.c
+ use warnings 'signal' ;
+ $SIG{FRED} = sub {};
+ EXPECT
+ No such signal: SIGFRED at - line 3.
+ ########
+ # mg.c
+ no warnings 'signal' ;
+ $SIG{FRED} = sub {};
+ EXPECT
+
+ ########
+ # mg.c
+ use warnings 'signal' ;
+ if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') {
+ print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit;
+ }
+ $|=1;
+ $SIG{"INT"} = "fred"; kill "INT",$$;
+ EXPECT
+ SIGINT handler "fred" not defined.
+ ########
+ # mg.c
+ no warnings 'signal' ;
+ if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') {
+ print "SKIPPED\n# win32, can't kill() to raise()\n"; exit;
+ }
+ $|=1;
+ $SIG{"INT"} = "fred"; kill "INT",$$;
+ EXPECT
+
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/op'
Index: ./t/lib/warnings/op
*** ./t/lib/warnings/op Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/op Thu Jul 12 07:01:20 2001
***************
*** 0 ****
--- 1,941 ----
+ op.c AOK
+
+ "my" variable %s masks earlier declaration in same scope
+ my $x;
+ my $x ;
+
+ Variable "%s" may be unavailable
+ sub x {
+ my $x;
+ sub y {
+ $x
+ }
+ }
+
+ Variable "%s" will not stay shared
+ sub x {
+ my $x;
+ sub y {
+ sub { $x }
+ }
+ }
+
+ Found = in conditional, should be ==
+ 1 if $a = 1 ;
+
+ Use of implicit split to @_ is deprecated
+ split ;
+
+ Use of implicit split to @_ is deprecated
+ $a = split ;
+
+ Useless use of time in void context
+ Useless use of a variable in void context
+ Useless use of a constant in void context
+ time ;
+ $a ;
+ "abc"
+
+ Applying %s to %s will act on scalar(%s)
+ my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;
+ @a =~ /abc/ ;
+ @a =~ s/a/b/ ;
+ @a =~ tr/a/b/ ;
+ @$b =~ /abc/ ;
+ @$b =~ s/a/b/ ;
+ @$b =~ tr/a/b/ ;
+ %a =~ /abc/ ;
+ %a =~ s/a/b/ ;
+ %a =~ tr/a/b/ ;
+ %$c =~ /abc/ ;
+ %$c =~ s/a/b/ ;
+ %$c =~ tr/a/b/ ;
+
+
+ Parentheses missing around "my" list at -e line 1.
+ my $a, $b = (1,2);
+
+ Parentheses missing around "local" list at -e line 1.
+ local $a, $b = (1,2);
+
+ Bareword found in conditional at -e line 1.
+ use warnings 'bareword'; my $x = print(ABC || 1);
+
+ Value of %s may be \"0\"; use \"defined\"
+ $x = 1 if $x = <FH> ;
+ $x = 1 while $x = <FH> ;
+
+ Subroutine fred redefined at -e line 1.
+ sub fred{1;} sub fred{1;}
+
+ Constant subroutine %s redefined
+ sub fred() {1;} sub fred() {1;}
+
+ Format FRED redefined at /tmp/x line 5.
+ format FRED =
+ .
+ format FRED =
+ .
+
+ Array @%s missing the @ in argument %d of %s()
+ push fred ;
+
+ Hash %%%s missing the %% in argument %d of %s()
+ keys joe ;
+
+ Statement unlikely to be reached
+ (Maybe you meant system() when you said exec()?
+ exec "true" ; my $a
+
+ defined(@array) is deprecated
+ (Maybe you should just omit the defined()?)
+ my @a ; defined @a ;
+ defined (@a = (1,2,3)) ;
+
+ defined(%hash) is deprecated
+ (Maybe you should just omit the defined()?)
+ my %h ; defined %h ;
+
+ /---/ should probably be written as "---"
+ join(/---/, @foo);
+
+ %s() called too early to check prototype [Perl_peep]
+ fred() ; sub fred ($$) {}
+
+
+ Use of "package" with no arguments is deprecated
+ package;
+
+ Mandatory Warnings
+ ------------------
+ Prototype mismatch: [cv_ckproto]
+ sub fred() ;
+ sub fred($) {}
+
+ %s never introduced [pad_leavemy] TODO
+ Runaway prototype [newSUB] TODO
+ oops: oopsAV [oopsAV] TODO
+ oops: oopsHV [oopsHV] TODO
+
+
+ __END__
+ # op.c
+ use warnings 'misc' ;
+ my $x ;
+ my $x ;
+ no warnings 'misc' ;
+ my $x ;
+ EXPECT
+ "my" variable $x masks earlier declaration in same scope at - line 4.
+ ########
+ # op.c
+ use warnings 'closure' ;
+ sub x {
+ my $x;
+ sub y {
+ $x
+ }
+ }
+ EXPECT
+ Variable "$x" will not stay shared at - line 7.
+ ########
+ # op.c
+ no warnings 'closure' ;
+ sub x {
+ my $x;
+ sub y {
+ $x
+ }
+ }
+ EXPECT
+
+ ########
+ # op.c
+ use warnings 'closure' ;
+ sub x {
+ our $x;
+ sub y {
+ $x
+ }
+ }
+ EXPECT
+
+ ########
+ # op.c
+ use warnings 'closure' ;
+ sub x {
+ my $x;
+ sub y {
+ sub { $x }
+ }
+ }
+ EXPECT
+ Variable "$x" may be unavailable at - line 6.
+ ########
+ # op.c
+ no warnings 'closure' ;
+ sub x {
+ my $x;
+ sub y {
+ sub { $x }
+ }
+ }
+ EXPECT
+
+ ########
+ # op.c
+ use warnings 'syntax' ;
+ 1 if $a = 1 ;
+ no warnings 'syntax' ;
+ 1 if $a = 1 ;
+ EXPECT
+ Found = in conditional, should be == at - line 3.
+ ########
+ # op.c
+ use warnings 'deprecated' ;
+ split ;
+ no warnings 'deprecated' ;
+ split ;
+ EXPECT
+ Use of implicit split to @_ is deprecated at - line 3.
+ ########
+ # op.c
+ use warnings 'deprecated' ;
+ $a = split ;
+ no warnings 'deprecated' ;
+ $a = split ;
+ EXPECT
+ Use of implicit split to @_ is deprecated at - line 3.
+ ########
+ # op.c
+ use warnings 'deprecated';
+ my (@foo, %foo);
+ %main::foo->{"bar"};
+ %foo->{"bar"};
+ @main::foo->[23];
+ @foo->[23];
+ $main::foo = {}; %$main::foo->{"bar"};
+ $foo = {}; %$foo->{"bar"};
+ $main::foo = []; @$main::foo->[34];
+ $foo = []; @$foo->[34];
+ no warnings 'deprecated';
+ %main::foo->{"bar"};
+ %foo->{"bar"};
+ @main::foo->[23];
+ @foo->[23];
+ $main::foo = {}; %$main::foo->{"bar"};
+ $foo = {}; %$foo->{"bar"};
+ $main::foo = []; @$main::foo->[34];
+ $foo = []; @$foo->[34];
+ EXPECT
+ Using a hash as a reference is deprecated at - line 4.
+ Using a hash as a reference is deprecated at - line 5.
+ Using an array as a reference is deprecated at - line 6.
+ Using an array as a reference is deprecated at - line 7.
+ Using a hash as a reference is deprecated at - line 8.
+ Using a hash as a reference is deprecated at - line 9.
+ Using an array as a reference is deprecated at - line 10.
+ Using an array as a reference is deprecated at - line 11.
+ ########
+ # op.c
+ use warnings 'void' ; close STDIN ;
+ 1 x 3 ; # OP_REPEAT
+ # OP_GVSV
+ wantarray ; # OP_WANTARRAY
+ # OP_GV
+ # OP_PADSV
+ # OP_PADAV
+ # OP_PADHV
+ # OP_PADANY
+ # OP_AV2ARYLEN
+ ref ; # OP_REF
+ \@a ; # OP_REFGEN
+ \$a ; # OP_SREFGEN
+ defined $a ; # OP_DEFINED
+ hex $a ; # OP_HEX
+ oct $a ; # OP_OCT
+ length $a ; # OP_LENGTH
+ substr $a,1 ; # OP_SUBSTR
+ vec $a,1,2 ; # OP_VEC
+ index $a,1,2 ; # OP_INDEX
+ rindex $a,1,2 ; # OP_RINDEX
+ sprintf $a ; # OP_SPRINTF
+ $a[0] ; # OP_AELEM
+ # OP_AELEMFAST
+ @a[0] ; # OP_ASLICE
+ #values %a ; # OP_VALUES
+ #keys %a ; # OP_KEYS
+ $a{0} ; # OP_HELEM
+ @a{0} ; # OP_HSLICE
+ unpack "a", "a" ; # OP_UNPACK
+ pack $a,"" ; # OP_PACK
+ join "" ; # OP_JOIN
+ (@a)[0,1] ; # OP_LSLICE
+ # OP_ANONLIST
+ # OP_ANONHASH
+ sort(1,2) ; # OP_SORT
+ reverse(1,2) ; # OP_REVERSE
+ # OP_RANGE
+ # OP_FLIP
+ (1 ..2) ; # OP_FLOP
+ caller ; # OP_CALLER
+ fileno STDIN ; # OP_FILENO
+ eof STDIN ; # OP_EOF
+ tell STDIN ; # OP_TELL
+ readlink 1; # OP_READLINK
+ time ; # OP_TIME
+ localtime ; # OP_LOCALTIME
+ gmtime ; # OP_GMTIME
+ eval { getgrnam 1 }; # OP_GGRNAM
+ eval { getgrgid 1 }; # OP_GGRGID
+ eval { getpwnam 1 }; # OP_GPWNAM
+ eval { getpwuid 1 }; # OP_GPWUID
+ EXPECT
+ Useless use of repeat (x) in void context at - line 3.
+ Useless use of wantarray in void context at - line 5.
+ Useless use of reference-type operator in void context at - line 12.
+ Useless use of reference constructor in void context at - line 13.
+ Useless use of single ref constructor in void context at - line 14.
+ Useless use of defined operator in void context at - line 15.
+ Useless use of hex in void context at - line 16.
+ Useless use of oct in void context at - line 17.
+ Useless use of length in void context at - line 18.
+ Useless use of substr in void context at - line 19.
+ Useless use of vec in void context at - line 20.
+ Useless use of index in void context at - line 21.
+ Useless use of rindex in void context at - line 22.
+ Useless use of sprintf in void context at - line 23.
+ Useless use of array element in void context at - line 24.
+ Useless use of array slice in void context at - line 26.
+ Useless use of hash element in void context at - line 29.
+ Useless use of hash slice in void context at - line 30.
+ Useless use of unpack in void context at - line 31.
+ Useless use of pack in void context at - line 32.
+ Useless use of join or string in void context at - line 33.
+ Useless use of list slice in void context at - line 34.
+ Useless use of sort in void context at - line 37.
+ Useless use of reverse in void context at - line 38.
+ Useless use of range (or flop) in void context at - line 41.
+ Useless use of caller in void context at - line 42.
+ Useless use of fileno in void context at - line 43.
+ Useless use of eof in void context at - line 44.
+ Useless use of tell in void context at - line 45.
+ Useless use of readlink in void context at - line 46.
+ Useless use of time in void context at - line 47.
+ Useless use of localtime in void context at - line 48.
+ Useless use of gmtime in void context at - line 49.
+ Useless use of getgrnam in void context at - line 50.
+ Useless use of getgrgid in void context at - line 51.
+ Useless use of getpwnam in void context at - line 52.
+ Useless use of getpwuid in void context at - line 53.
+ ########
+ # op.c
+ no warnings 'void' ; close STDIN ;
+ 1 x 3 ; # OP_REPEAT
+ # OP_GVSV
+ wantarray ; # OP_WANTARRAY
+ # OP_GV
+ # OP_PADSV
+ # OP_PADAV
+ # OP_PADHV
+ # OP_PADANY
+ # OP_AV2ARYLEN
+ ref ; # OP_REF
+ \@a ; # OP_REFGEN
+ \$a ; # OP_SREFGEN
+ defined $a ; # OP_DEFINED
+ hex $a ; # OP_HEX
+ oct $a ; # OP_OCT
+ length $a ; # OP_LENGTH
+ substr $a,1 ; # OP_SUBSTR
+ vec $a,1,2 ; # OP_VEC
+ index $a,1,2 ; # OP_INDEX
+ rindex $a,1,2 ; # OP_RINDEX
+ sprintf $a ; # OP_SPRINTF
+ $a[0] ; # OP_AELEM
+ # OP_AELEMFAST
+ @a[0] ; # OP_ASLICE
+ #values %a ; # OP_VALUES
+ #keys %a ; # OP_KEYS
+ $a{0} ; # OP_HELEM
+ @a{0} ; # OP_HSLICE
+ unpack "a", "a" ; # OP_UNPACK
+ pack $a,"" ; # OP_PACK
+ join "" ; # OP_JOIN
+ (@a)[0,1] ; # OP_LSLICE
+ # OP_ANONLIST
+ # OP_ANONHASH
+ sort(1,2) ; # OP_SORT
+ reverse(1,2) ; # OP_REVERSE
+ # OP_RANGE
+ # OP_FLIP
+ (1 ..2) ; # OP_FLOP
+ caller ; # OP_CALLER
+ fileno STDIN ; # OP_FILENO
+ eof STDIN ; # OP_EOF
+ tell STDIN ; # OP_TELL
+ readlink 1; # OP_READLINK
+ time ; # OP_TIME
+ localtime ; # OP_LOCALTIME
+ gmtime ; # OP_GMTIME
+ eval { getgrnam 1 }; # OP_GGRNAM
+ eval { getgrgid 1 }; # OP_GGRGID
+ eval { getpwnam 1 }; # OP_GPWNAM
+ eval { getpwuid 1 }; # OP_GPWUID
+ EXPECT
+ ########
+ # op.c
+ use warnings 'void' ;
+ for (@{[0]}) { "$_" } # check warning isn't duplicated
+ no warnings 'void' ;
+ for (@{[0]}) { "$_" } # check warning isn't duplicated
+ EXPECT
+ Useless use of string in void context at - line 3.
+ ########
+ # op.c
+ use warnings 'void' ;
+ use Config ;
+ BEGIN {
+ if ( ! $Config{d_telldir}) {
+ print <<EOM ;
+ SKIPPED
+ # telldir not present
+ EOM
+ exit
+ }
+ }
+ telldir 1 ; # OP_TELLDIR
+ no warnings 'void' ;
+ telldir 1 ; # OP_TELLDIR
+ EXPECT
+ Useless use of telldir in void context at - line 13.
+ ########
+ # op.c
+ use warnings 'void' ;
+ use Config ;
+ BEGIN {
+ if ( ! $Config{d_getppid}) {
+ print <<EOM ;
+ SKIPPED
+ # getppid not present
+ EOM
+ exit
+ }
+ }
+ getppid ; # OP_GETPPID
+ no warnings 'void' ;
+ getppid ; # OP_GETPPID
+ EXPECT
+ Useless use of getppid in void context at - line 13.
+ ########
+ # op.c
+ use warnings 'void' ;
+ use Config ;
+ BEGIN {
+ if ( ! $Config{d_getpgrp}) {
+ print <<EOM ;
+ SKIPPED
+ # getpgrp not present
+ EOM
+ exit
+ }
+ }
+ getpgrp ; # OP_GETPGRP
+ no warnings 'void' ;
+ getpgrp ; # OP_GETPGRP
+ EXPECT
+ Useless use of getpgrp in void context at - line 13.
+ ########
+ # op.c
+ use warnings 'void' ;
+ use Config ;
+ BEGIN {
+ if ( ! $Config{d_times}) {
+ print <<EOM ;
+ SKIPPED
+ # times not present
+ EOM
+ exit
+ }
+ }
+ times ; # OP_TMS
+ no warnings 'void' ;
+ times ; # OP_TMS
+ EXPECT
+ Useless use of times in void context at - line 13.
+ ########
+ # op.c
+ use warnings 'void' ;
+ use Config ;
+ BEGIN {
+ if ( ! $Config{d_getprior} or $^O eq 'os2') { # Locks before fixpak22
+ print <<EOM ;
+ SKIPPED
+ # getpriority not present
+ EOM
+ exit
+ }
+ }
+ getpriority 1,2; # OP_GETPRIORITY
+ no warnings 'void' ;
+ getpriority 1,2; # OP_GETPRIORITY
+ EXPECT
+ Useless use of getpriority in void context at - line 13.
+ ########
+ # op.c
+ use warnings 'void' ;
+ use Config ;
+ BEGIN {
+ if ( ! $Config{d_getlogin}) {
+ print <<EOM ;
+ SKIPPED
+ # getlogin not present
+ EOM
+ exit
+ }
+ }
+ getlogin ; # OP_GETLOGIN
+ no warnings 'void' ;
+ getlogin ; # OP_GETLOGIN
+ EXPECT
+ Useless use of getlogin in void context at - line 13.
+ ########
+ # op.c
+ use warnings 'void' ;
+ use Config ; BEGIN {
+ if ( ! $Config{d_socket}) {
+ print <<EOM ;
+ SKIPPED
+ # getsockname not present
+ # getpeername not present
+ # gethostbyname not present
+ # gethostbyaddr not present
+ # gethostent not present
+ # getnetbyname not present
+ # getnetbyaddr not present
+ # getnetent not present
+ # getprotobyname not present
+ # getprotobynumber not present
+ # getprotoent not present
+ # getservbyname not present
+ # getservbyport not present
+ # getservent not present
+ EOM
+ exit
+ } }
+ getsockname STDIN ; # OP_GETSOCKNAME
+ getpeername STDIN ; # OP_GETPEERNAME
+ gethostbyname 1 ; # OP_GHBYNAME
+ gethostbyaddr 1,2; # OP_GHBYADDR
+ gethostent ; # OP_GHOSTENT
+ getnetbyname 1 ; # OP_GNBYNAME
+ getnetbyaddr 1,2 ; # OP_GNBYADDR
+ getnetent ; # OP_GNETENT
+ getprotobyname 1; # OP_GPBYNAME
+ getprotobynumber 1; # OP_GPBYNUMBER
+ getprotoent ; # OP_GPROTOENT
+ getservbyname 1,2; # OP_GSBYNAME
+ getservbyport 1,2; # OP_GSBYPORT
+ getservent ; # OP_GSERVENT
+
+ no warnings 'void' ;
+ getsockname STDIN ; # OP_GETSOCKNAME
+ getpeername STDIN ; # OP_GETPEERNAME
+ gethostbyname 1 ; # OP_GHBYNAME
+ gethostbyaddr 1,2; # OP_GHBYADDR
+ gethostent ; # OP_GHOSTENT
+ getnetbyname 1 ; # OP_GNBYNAME
+ getnetbyaddr 1,2 ; # OP_GNBYADDR
+ getnetent ; # OP_GNETENT
+ getprotobyname 1; # OP_GPBYNAME
+ getprotobynumber 1; # OP_GPBYNUMBER
+ getprotoent ; # OP_GPROTOENT
+ getservbyname 1,2; # OP_GSBYNAME
+ getservbyport 1,2; # OP_GSBYPORT
+ getservent ; # OP_GSERVENT
+ INIT {
+ # some functions may not be there, so we exit without running
+ exit;
+ }
+ EXPECT
+ Useless use of getsockname in void context at - line 24.
+ Useless use of getpeername in void context at - line 25.
+ Useless use of gethostbyname in void context at - line 26.
+ Useless use of gethostbyaddr in void context at - line 27.
+ Useless use of gethostent in void context at - line 28.
+ Useless use of getnetbyname in void context at - line 29.
+ Useless use of getnetbyaddr in void context at - line 30.
+ Useless use of getnetent in void context at - line 31.
+ Useless use of getprotobyname in void context at - line 32.
+ Useless use of getprotobynumber in void context at - line 33.
+ Useless use of getprotoent in void context at - line 34.
+ Useless use of getservbyname in void context at - line 35.
+ Useless use of getservbyport in void context at - line 36.
+ Useless use of getservent in void context at - line 37.
+ ########
+ # op.c
+ use warnings 'void' ;
+ *a ; # OP_RV2GV
+ $a ; # OP_RV2SV
+ @a ; # OP_RV2AV
+ %a ; # OP_RV2HV
+ no warnings 'void' ;
+ *a ; # OP_RV2GV
+ $a ; # OP_RV2SV
+ @a ; # OP_RV2AV
+ %a ; # OP_RV2HV
+ EXPECT
+ Useless use of a variable in void context at - line 3.
+ Useless use of a variable in void context at - line 4.
+ Useless use of a variable in void context at - line 5.
+ Useless use of a variable in void context at - line 6.
+ ########
+ # op.c
+ use warnings 'void' ;
+ "abc"; # OP_CONST
+ 7 ; # OP_CONST
+ no warnings 'void' ;
+ "abc"; # OP_CONST
+ 7 ; # OP_CONST
+ EXPECT
+ Useless use of a constant in void context at - line 3.
+ Useless use of a constant in void context at - line 4.
+ ########
+ # op.c
+ #
+ use warnings 'misc' ;
+ my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;
+ @a =~ /abc/ ;
+ @a =~ s/a/b/ ;
+ @a =~ tr/a/b/ ;
+ @$b =~ /abc/ ;
+ @$b =~ s/a/b/ ;
+ @$b =~ tr/a/b/ ;
+ %a =~ /abc/ ;
+ %a =~ s/a/b/ ;
+ %a =~ tr/a/b/ ;
+ %$c =~ /abc/ ;
+ %$c =~ s/a/b/ ;
+ %$c =~ tr/a/b/ ;
+ {
+ no warnings 'misc' ;
+ my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;
+ @a =~ /abc/ ;
+ @a =~ s/a/b/ ;
+ @a =~ tr/a/b/ ;
+ @$b =~ /abc/ ;
+ @$b =~ s/a/b/ ;
+ @$b =~ tr/a/b/ ;
+ %a =~ /abc/ ;
+ %a =~ s/a/b/ ;
+ %a =~ tr/a/b/ ;
+ %$c =~ /abc/ ;
+ %$c =~ s/a/b/ ;
+ %$c =~ tr/a/b/ ;
+ }
+ EXPECT
+ Applying pattern match (m//) to @array will act on scalar(@array) at - line 5.
+ Applying substitution (s///) to @array will act on scalar(@array) at - line 6.
+ Applying transliteration (tr///) to @array will act on scalar(@array) at - line 7.
+ Applying pattern match (m//) to @array will act on scalar(@array) at - line 8.
+ Applying substitution (s///) to @array will act on scalar(@array) at - line 9.
+ Applying transliteration (tr///) to @array will act on scalar(@array) at - line 10.
+ Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 11.
+ Applying substitution (s///) to %hash will act on scalar(%hash) at - line 12.
+ Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 13.
+ Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 14.
+ Applying substitution (s///) to %hash will act on scalar(%hash) at - line 15.
+ Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 16.
+ Can't modify private array in substitution (s///) at - line 6, near "s/a/b/ ;"
+ BEGIN not safe after errors--compilation aborted at - line 18.
+ ########
+ # op.c
+ use warnings 'syntax' ;
+ my $a, $b = (1,2);
+ no warnings 'syntax' ;
+ my $c, $d = (1,2);
+ EXPECT
+ Parentheses missing around "my" list at - line 3.
+ ########
+ # op.c
+ use warnings 'syntax' ;
+ local $a, $b = (1,2);
+ no warnings 'syntax' ;
+ local $c, $d = (1,2);
+ EXPECT
+ Parentheses missing around "local" list at - line 3.
+ ########
+ # op.c
+ use warnings 'bareword' ;
+ print (ABC || 1) ;
+ no warnings 'bareword' ;
+ print (ABC || 1) ;
+ EXPECT
+ Bareword found in conditional at - line 3.
+ ########
+ --FILE-- abc
+
+ --FILE--
+ # op.c
+ use warnings 'misc' ;
+ open FH, "<abc" ;
+ $x = 1 if $x = <FH> ;
+ no warnings 'misc' ;
+ $x = 1 if $x = <FH> ;
+ EXPECT
+ Value of <HANDLE> construct can be "0"; test with defined() at - line 4.
+ ########
+ # op.c
+ use warnings 'misc' ;
+ opendir FH, "." ;
+ $x = 1 if $x = readdir FH ;
+ no warnings 'misc' ;
+ $x = 1 if $x = readdir FH ;
+ closedir FH ;
+ EXPECT
+ Value of readdir() operator can be "0"; test with defined() at - line 4.
+ ########
+ # op.c
+ use warnings 'misc' ;
+ $x = 1 if $x = <*> ;
+ no warnings 'misc' ;
+ $x = 1 if $x = <*> ;
+ EXPECT
+ Value of glob construct can be "0"; test with defined() at - line 3.
+ ########
+ # op.c
+ use warnings 'misc' ;
+ %a = (1,2,3,4) ;
+ $x = 1 if $x = each %a ;
+ no warnings 'misc' ;
+ $x = 1 if $x = each %a ;
+ EXPECT
+ Value of each() operator can be "0"; test with defined() at - line 4.
+ ########
+ # op.c
+ use warnings 'misc' ;
+ $x = 1 while $x = <*> and 0 ;
+ no warnings 'misc' ;
+ $x = 1 while $x = <*> and 0 ;
+ EXPECT
+ Value of glob construct can be "0"; test with defined() at - line 3.
+ ########
+ # op.c
+ use warnings 'misc' ;
+ opendir FH, "." ;
+ $x = 1 while $x = readdir FH and 0 ;
+ no warnings 'misc' ;
+ $x = 1 while $x = readdir FH and 0 ;
+ closedir FH ;
+ EXPECT
+ Value of readdir() operator can be "0"; test with defined() at - line 4.
+ ########
+ # op.c
+ use warnings 'redefine' ;
+ sub fred {}
+ sub fred {}
+ no warnings 'redefine' ;
+ sub fred {}
+ EXPECT
+ Subroutine fred redefined at - line 4.
+ ########
+ # op.c
+ use warnings 'redefine' ;
+ sub fred () { 1 }
+ sub fred () { 1 }
+ no warnings 'redefine' ;
+ sub fred () { 1 }
+ EXPECT
+ Constant subroutine fred redefined at - line 4.
+ ########
+ # op.c
+ no warnings 'redefine' ;
+ sub fred () { 1 }
+ sub fred () { 2 }
+ EXPECT
+ Constant subroutine fred redefined at - line 4.
+ ########
+ # op.c
+ no warnings 'redefine' ;
+ sub fred () { 1 }
+ *fred = sub () { 2 };
+ EXPECT
+ Constant subroutine fred redefined at - line 4.
+ ########
+ # op.c
+ use warnings 'redefine' ;
+ format FRED =
+ .
+ format FRED =
+ .
+ no warnings 'redefine' ;
+ format FRED =
+ .
+ EXPECT
+ Format FRED redefined at - line 5.
+ ########
+ # op.c
+ use warnings 'deprecated' ;
+ push FRED;
+ no warnings 'deprecated' ;
+ push FRED;
+ EXPECT
+ Array @FRED missing the @ in argument 1 of push() at - line 3.
+ ########
+ # op.c
+ use warnings 'deprecated' ;
+ @a = keys FRED ;
+ no warnings 'deprecated' ;
+ @a = keys FRED ;
+ EXPECT
+ Hash %FRED missing the % in argument 1 of keys() at - line 3.
+ ########
+ # op.c
+ use warnings 'syntax' ;
+ exec "$^X -e 1" ;
+ my $a
+ EXPECT
+ Statement unlikely to be reached at - line 4.
+ (Maybe you meant system() when you said exec()?)
+ ########
+ # op.c
+ use warnings 'deprecated' ;
+ my @a; defined(@a);
+ EXPECT
+ defined(@array) is deprecated at - line 3.
+ (Maybe you should just omit the defined()?)
+ ########
+ # op.c
+ use warnings 'deprecated' ;
+ defined(@a = (1,2,3));
+ EXPECT
+ defined(@array) is deprecated at - line 3.
+ (Maybe you should just omit the defined()?)
+ ########
+ # op.c
+ use warnings 'deprecated' ;
+ my %h; defined(%h);
+ EXPECT
+ defined(%hash) is deprecated at - line 3.
+ (Maybe you should just omit the defined()?)
+ ########
+ # op.c
+ no warnings 'syntax' ;
+ exec "$^X -e 1" ;
+ my $a
+ EXPECT
+
+ ########
+ # op.c
+ sub fred();
+ sub fred($) {}
+ EXPECT
+ Prototype mismatch: sub main::fred () vs ($) at - line 3.
+ ########
+ # op.c
+ $^W = 0 ;
+ sub fred() ;
+ sub fred($) {}
+ {
+ no warnings 'prototype' ;
+ sub Fred() ;
+ sub Fred($) {}
+ use warnings 'prototype' ;
+ sub freD() ;
+ sub freD($) {}
+ }
+ sub FRED() ;
+ sub FRED($) {}
+ EXPECT
+ Prototype mismatch: sub main::fred () vs ($) at - line 4.
+ Prototype mismatch: sub main::freD () vs ($) at - line 11.
+ Prototype mismatch: sub main::FRED () vs ($) at - line 14.
+ ########
+ # op.c
+ use warnings 'syntax' ;
+ join /---/, 'x', 'y', 'z';
+ EXPECT
+ /---/ should probably be written as "---" at - line 3.
+ ########
+ # op.c [Perl_peep]
+ use warnings 'prototype' ;
+ fred() ;
+ sub fred ($$) {}
+ no warnings 'prototype' ;
+ joe() ;
+ sub joe ($$) {}
+ EXPECT
+ main::fred() called too early to check prototype at - line 3.
+ ########
+ # op.c [Perl_newATTRSUB]
+ --FILE-- abc.pm
+ use warnings 'void' ;
+ BEGIN { $| = 1; print "in begin\n"; }
+ CHECK { print "in check\n"; }
+ INIT { print "in init\n"; }
+ END { print "in end\n"; }
+ print "in mainline\n";
+ 1;
+ --FILE--
+ use abc;
+ delete $INC{"abc.pm"};
+ require abc;
+ do "abc.pm";
+ EXPECT
+ in begin
+ in mainline
+ in check
+ in init
+ in begin
+ Too late to run CHECK block at abc.pm line 3.
+ Too late to run INIT block at abc.pm line 4.
+ in mainline
+ in begin
+ Too late to run CHECK block at abc.pm line 3.
+ Too late to run INIT block at abc.pm line 4.
+ in mainline
+ in end
+ in end
+ in end
+ ########
+ # op.c [Perl_newATTRSUB]
+ --FILE-- abc.pm
+ no warnings 'void' ;
+ BEGIN { $| = 1; print "in begin\n"; }
+ CHECK { print "in check\n"; }
+ INIT { print "in init\n"; }
+ END { print "in end\n"; }
+ print "in mainline\n";
+ 1;
+ --FILE--
+ require abc;
+ do "abc.pm";
+ EXPECT
+ in begin
+ in mainline
+ in begin
+ in mainline
+ in end
+ in end
+ ########
+ # op.c
+ my @x;
+ use warnings 'syntax' ;
+ push(@x);
+ unshift(@x);
+ no warnings 'syntax' ;
+ push(@x);
+ unshift(@x);
+ EXPECT
+ Useless use of push with no values at - line 4.
+ Useless use of unshift with no values at - line 5.
+ ########
+ # op.c
+ use warnings 'deprecated' ;
+ package;
+ no warnings 'deprecated' ;
+ package;
+ EXPECT
+ Use of "package" with no arguments is deprecated at - line 3.
+ Global symbol "BEGIN" requires explicit package name at - line 4.
+ BEGIN not safe after errors--compilation aborted at - line 4.
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/perl'
Index: ./t/lib/warnings/perl
*** ./t/lib/warnings/perl Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/perl Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,72 ----
+ perl.c AOK
+
+ gv_check(defstash)
+ Name \"%s::%s\" used only once: possible typo
+
+ Mandatory Warnings All TODO
+ ------------------
+ Recompile perl with -DDEBUGGING to use -D switch [moreswitches]
+ Unbalanced scopes: %ld more ENTERs than LEAVEs [perl_destruct]
+ Unbalanced saves: %ld more saves than restores [perl_destruct]
+ Unbalanced tmps: %ld more allocs than frees [perl_destruct]
+ Unbalanced context: %ld more PUSHes than POPs [perl_destruct]
+ Unbalanced string table refcount: (%d) for \"%s\" [perl_destruct]
+ Scalars leaked: %ld [perl_destruct]
+
+
+ __END__
+ # perl.c
+ no warnings 'once' ;
+ $x = 3 ;
+ use warnings 'once' ;
+ $z = 3 ;
+ EXPECT
+ Name "main::z" used only once: possible typo at - line 5.
+ ########
+ -w
+ # perl.c
+ $x = 3 ;
+ no warnings 'once' ;
+ $z = 3
+ EXPECT
+ Name "main::x" used only once: possible typo at - line 3.
+ ########
+ # perl.c
+ BEGIN { $^W =1 ; }
+ $x = 3 ;
+ no warnings 'once' ;
+ $z = 3
+ EXPECT
+ Name "main::x" used only once: possible typo at - line 3.
+ ########
+ -W
+ # perl.c
+ no warnings 'once' ;
+ $x = 3 ;
+ use warnings 'once' ;
+ $z = 3 ;
+ EXPECT
+ Name "main::z" used only once: possible typo at - line 6.
+ Name "main::x" used only once: possible typo at - line 4.
+ ########
+ -X
+ # perl.c
+ use warnings 'once' ;
+ $x = 3 ;
+ EXPECT
+ ########
+
+ # perl.c
+ { use warnings 'once' ; $x = 3 ; }
+ $y = 3 ;
+ EXPECT
+ Name "main::x" used only once: possible typo at - line 3.
+ ########
+
+ # perl.c
+ $z = 3 ;
+ BEGIN { $^W = 1 }
+ { no warnings 'once' ; $x = 3 ; }
+ $y = 3 ;
+ EXPECT
+ Name "main::y" used only once: possible typo at - line 6.
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/perlio'
Index: ./t/lib/warnings/perlio
*** ./t/lib/warnings/perlio Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/perlio Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,10 ----
+ perlio.c
+
+
+ Mandatory Warnings ALL TODO
+ ------------------
+ Setting cnt to %d
+ Setting ptr %p > end+1 %p
+ Setting cnt to %d, ptr implies %d
+
+ __END__
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/perly'
Index: ./t/lib/warnings/perly
*** ./t/lib/warnings/perly Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/perly Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,31 ----
+ perly.y AOK
+
+ dep() => deprecate("\"do\" to call subroutines")
+ Use of "do" to call subroutines is deprecated
+
+ sub fred {} do fred()
+ sub fred {} do fred(1)
+ sub fred {} $a = "fred" ; do $a()
+ sub fred {} $a = "fred" ; do $a(1)
+
+
+ __END__
+ # perly.y
+ use warnings 'deprecated' ;
+ sub fred {}
+ do fred() ;
+ do fred(1) ;
+ $a = "fred" ;
+ do $a() ;
+ do $a(1) ;
+ no warnings 'deprecated' ;
+ do fred() ;
+ do fred(1) ;
+ $a = "fred" ;
+ do $a() ;
+ do $a(1) ;
+ EXPECT
+ Use of "do" to call subroutines is deprecated at - line 4.
+ Use of "do" to call subroutines is deprecated at - line 5.
+ Use of "do" to call subroutines is deprecated at - line 7.
+ Use of "do" to call subroutines is deprecated at - line 8.
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/pp'
Index: ./t/lib/warnings/pp
*** ./t/lib/warnings/pp Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/pp Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,71 ----
+ pp.c TODO
+
+ substr outside of string
+ $a = "ab" ; $b = substr($a, 4,5) ;
+
+ Attempt to use reference as lvalue in substr
+ $a = "ab" ; $b = \$a ; substr($b, 1,1) = $b
+
+ uninitialized in pp_rv2gv()
+ my *b = *{ undef()}
+
+ uninitialized in pp_rv2sv()
+ my $a = undef ; my $b = $$a
+
+ Odd number of elements in hash list
+ my $a = { 1,2,3 } ;
+
+ Explicit blessing to '' (assuming package main)
+ bless \[], "";
+
+ Constant subroutine %s undefined <<<TODO
+ Constant subroutine (anonymous) undefined <<<TODO
+
+ __END__
+ # pp.c
+ use warnings 'substr' ;
+ $a = "ab" ;
+ $b = substr($a, 4,5) ;
+ no warnings 'substr' ;
+ $a = "ab" ;
+ $b = substr($a, 4,5) ;
+ EXPECT
+ substr outside of string at - line 4.
+ ########
+ # pp.c
+ use warnings 'substr' ;
+ $a = "ab" ;
+ $b = \$a ;
+ substr($b, 1,1) = "ab" ;
+ no warnings 'substr' ;
+ substr($b, 1,1) = "ab" ;
+ EXPECT
+ Attempt to use reference as lvalue in substr at - line 5.
+ ########
+ # pp.c
+ use warnings 'uninitialized' ;
+ # TODO
+ EXPECT
+
+ ########
+ # pp.c
+ use warnings 'misc' ;
+ my $a = { 1,2,3};
+ no warnings 'misc' ;
+ my $b = { 1,2,3};
+ EXPECT
+ Odd number of elements in hash assignment at - line 3.
+ ########
+ # pp.c
+ use warnings 'misc' ;
+ bless \[], "" ;
+ no warnings 'misc' ;
+ bless \[], "" ;
+ EXPECT
+ Explicit blessing to '' (assuming package main) at - line 3.
+ ########
+ # pp.c
+ use utf8 ;
+ $_ = "\x80 \xff" ;
+ reverse ;
+ EXPECT
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/pp_ctl'
Index: ./t/lib/warnings/pp_ctl
*** ./t/lib/warnings/pp_ctl Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/pp_ctl Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,230 ----
+ pp_ctl.c AOK
+
+ Not enough format arguments
+ format STDOUT =
+ @<<< @<<<
+ $a
+ .
+ write;
+
+
+ Exiting substitution via %s
+ $_ = "abc" ;
+ while ($i ++ == 0)
+ {
+ s/ab/last/e ;
+ }
+
+ Exiting subroutine via %s
+ sub fred { last }
+ { fred() }
+
+ Exiting eval via %s
+ { eval "last" }
+
+ Exiting pseudo-block via %s
+ @a = (1,2) ; @b = sort { last } @a ;
+
+ Exiting substitution via %s
+ $_ = "abc" ;
+ last fred:
+ while ($i ++ == 0)
+ {
+ s/ab/last fred/e ;
+ }
+
+
+ Exiting subroutine via %s
+ sub fred { last joe }
+ joe: { fred() }
+
+ Exiting eval via %s
+ fred: { eval "last fred" }
+
+ Exiting pseudo-block via %s
+ @a = (1,2) ; fred: @b = sort { last fred } @a ;
+
+
+ Deep recursion on subroutine \"%s\"
+ sub fred
+ {
+ fred() if $a++ < 200
+ }
+
+ fred()
+
+ (in cleanup) foo bar
+ package Foo;
+ DESTROY { die "foo bar" }
+ { bless [], 'Foo' for 1..10 }
+
+ __END__
+ # pp_ctl.c
+ use warnings 'syntax' ;
+ format STDOUT =
+ @<<< @<<<
+ 1
+ .
+ write;
+ EXPECT
+ Not enough format arguments at - line 5.
+ 1
+ ########
+ # pp_ctl.c
+ no warnings 'syntax' ;
+ format =
+ @<<< @<<<
+ 1
+ .
+ write ;
+ EXPECT
+ 1
+ ########
+ # pp_ctl.c
+ use warnings 'exiting' ;
+ $_ = "abc" ;
+
+ while ($i ++ == 0)
+ {
+ s/ab/last/e ;
+ }
+ no warnings 'exiting' ;
+ while ($i ++ == 0)
+ {
+ s/ab/last/e ;
+ }
+ EXPECT
+ Exiting substitution via last at - line 7.
+ ########
+ # pp_ctl.c
+ use warnings 'exiting' ;
+ sub fred { last }
+ { fred() }
+ no warnings 'exiting' ;
+ sub joe { last }
+ { joe() }
+ EXPECT
+ Exiting subroutine via last at - line 3.
+ ########
+ # pp_ctl.c
+ {
+ eval "use warnings 'exiting' ; last;"
+ }
+ print STDERR $@ ;
+ {
+ eval "no warnings 'exiting' ;last;"
+ }
+ print STDERR $@ ;
+ EXPECT
+ Exiting eval via last at (eval 1) line 1.
+ ########
+ # pp_ctl.c
+ use warnings 'exiting' ;
+ @a = (1,2) ;
+ @b = sort { last } @a ;
+ no warnings 'exiting' ;
+ @b = sort { last } @a ;
+ EXPECT
+ Exiting pseudo-block via last at - line 4.
+ Can't "last" outside a loop block at - line 4.
+ ########
+ # pp_ctl.c
+ use warnings 'exiting' ;
+ $_ = "abc" ;
+ fred:
+ while ($i ++ == 0)
+ {
+ s/ab/last fred/e ;
+ }
+ no warnings 'exiting' ;
+ while ($i ++ == 0)
+ {
+ s/ab/last fred/e ;
+ }
+ EXPECT
+ Exiting substitution via last at - line 7.
+ ########
+ # pp_ctl.c
+ use warnings 'exiting' ;
+ sub fred { last joe }
+ joe: { fred() }
+ no warnings 'exiting' ;
+ sub Fred { last Joe }
+ Joe: { Fred() }
+ EXPECT
+ Exiting subroutine via last at - line 3.
+ ########
+ # pp_ctl.c
+ joe:
+ { eval "use warnings 'exiting' ; last joe;" }
+ print STDERR $@ ;
+ Joe:
+ { eval "no warnings 'exiting' ; last Joe;" }
+ print STDERR $@ ;
+ EXPECT
+ Exiting eval via last at (eval 1) line 1.
+ ########
+ # pp_ctl.c
+ use warnings 'exiting' ;
+ @a = (1,2) ;
+ fred: @b = sort { last fred } @a ;
+ no warnings 'exiting' ;
+ Fred: @b = sort { last Fred } @a ;
+ EXPECT
+ Exiting pseudo-block via last at - line 4.
+ Label not found for "last fred" at - line 4.
+ ########
+ # pp_ctl.c
+ use warnings 'recursion' ;
+ BEGIN { warn "PREFIX\n" ;}
+ sub fred
+ {
+ fred() if $a++ < 200
+ }
+
+ fred()
+ EXPECT
+ Deep recursion on subroutine "main::fred" at - line 6.
+ ########
+ # pp_ctl.c
+ no warnings 'recursion' ;
+ BEGIN { warn "PREFIX\n" ;}
+ sub fred
+ {
+ fred() if $a++ < 200
+ }
+
+ fred()
+ EXPECT
+ ########
+ # pp_ctl.c
+ use warnings 'misc' ;
+ package Foo;
+ DESTROY { die "@{$_[0]} foo bar" }
+ { bless ['A'], 'Foo' for 1..10 }
+ { bless ['B'], 'Foo' for 1..10 }
+ EXPECT
+ (in cleanup) A foo bar at - line 4.
+ (in cleanup) B foo bar at - line 4.
+ ########
+ # pp_ctl.c
+ no warnings 'misc' ;
+ package Foo;
+ DESTROY { die "@{$_[0]} foo bar" }
+ { bless ['A'], 'Foo' for 1..10 }
+ { bless ['B'], 'Foo' for 1..10 }
+ EXPECT
+ ########
+ # pp_ctl.c
+ use warnings;
+ eval 'print $foo';
+ EXPECT
+ Use of uninitialized value in print at (eval 1) line 1.
+ ########
+ # pp_ctl.c
+ use warnings;
+ {
+ no warnings;
+ eval 'print $foo';
+ }
+ EXPECT
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/pp_hot'
Index: ./t/lib/warnings/pp_hot
*** ./t/lib/warnings/pp_hot Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/pp_hot Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,284 ----
+ pp_hot.c
+
+ print() on unopened filehandle abc [pp_print]
+ $f = $a = "abc" ; print $f $a
+
+ Filehandle %s opened only for input [pp_print]
+ print STDIN "abc" ;
+
+ Filehandle %s opened only for output [pp_print]
+ print <STDOUT> ;
+
+ print() on closed filehandle %s [pp_print]
+ close STDIN ; print STDIN "abc" ;
+
+ uninitialized [pp_rv2av]
+ my $a = undef ; my @b = @$a
+
+ uninitialized [pp_rv2hv]
+ my $a = undef ; my %b = %$a
+
+ Odd number of elements in hash list [pp_aassign]
+ %X = (1,2,3) ;
+
+ Reference found where even-sized list expected [pp_aassign]
+ $X = [ 1 ..3 ];
+
+ Filehandle %s opened only for output [Perl_do_readline]
+ open (FH, ">./xcv") ;
+ my $a = <FH> ;
+
+ glob failed (can't start child: %s) [Perl_do_readline] <<TODO
+
+ readline() on closed filehandle %s [Perl_do_readline]
+ close STDIN ; $a = <STDIN>;
+
+ readline() on closed filehandle %s [Perl_do_readline]
+ readline(NONESUCH);
+
+ glob failed (child exited with status %d%s) [Perl_do_readline] <<TODO
+
+ Deep recursion on subroutine \"%s\" [Perl_sub_crush_depth]
+ sub fred { fred() if $a++ < 200} fred()
+
+ Deep recursion on anonymous subroutine [Perl_sub_crush_depth]
+ $a = sub { &$a if $a++ < 200} &$a
+
+ Possible Y2K bug: about to append an integer to '19' [pp_concat]
+ $x = "19$yy\n";
+
+ Use of reference "%s" as array index [pp_aelem]
+ $x[\1]
+
+ __END__
+ # pp_hot.c [pp_print]
+ use warnings 'unopened' ;
+ $f = $a = "abc" ;
+ print $f $a;
+ no warnings 'unopened' ;
+ print $f $a;
+ EXPECT
+ print() on unopened filehandle abc at - line 4.
+ ########
+ # pp_hot.c [pp_print]
+ use warnings 'io' ;
+ print STDIN "anc";
+ print <STDOUT>;
+ print <STDERR>;
+ open(FOO, ">&STDOUT") and print <FOO>;
+ print getc(STDERR);
+ print getc(FOO);
+ ####################################################################
+ # The next test is known to fail on some systems (Linux+old glibc, #
+ # some *BSDs (including Mac OS X and NeXT), among others. #
+ # We skip it for now (on the grounds that it is "just" a warning). #
+ ####################################################################
+ #read(FOO,$_,1);
+ no warnings 'io' ;
+ print STDIN "anc";
+ EXPECT
+ Filehandle STDIN opened only for input at - line 3.
+ Filehandle STDOUT opened only for output at - line 4.
+ Filehandle STDERR opened only for output at - line 5.
+ Filehandle FOO opened only for output at - line 6.
+ Filehandle STDERR opened only for output at - line 7.
+ Filehandle FOO opened only for output at - line 8.
+ ########
+ # pp_hot.c [pp_print]
+ use warnings 'closed' ;
+ close STDIN ;
+ print STDIN "anc";
+ opendir STDIN, ".";
+ print STDIN "anc";
+ closedir STDIN;
+ no warnings 'closed' ;
+ print STDIN "anc";
+ opendir STDIN, ".";
+ print STDIN "anc";
+ EXPECT
+ print() on closed filehandle STDIN at - line 4.
+ print() on closed filehandle STDIN at - line 6.
+ (Are you trying to call print() on dirhandle STDIN?)
+ ########
+ # pp_hot.c [pp_rv2av]
+ use warnings 'uninitialized' ;
+ my $a = undef ;
+ my @b = @$a;
+ no warnings 'uninitialized' ;
+ my @c = @$a;
+ EXPECT
+ Use of uninitialized value in array dereference at - line 4.
+ ########
+ # pp_hot.c [pp_rv2hv]
+ use warnings 'uninitialized' ;
+ my $a = undef ;
+ my %b = %$a;
+ no warnings 'uninitialized' ;
+ my %c = %$a;
+ EXPECT
+ Use of uninitialized value in hash dereference at - line 4.
+ ########
+ # pp_hot.c [pp_aassign]
+ use warnings 'misc' ;
+ my %X ; %X = (1,2,3) ;
+ no warnings 'misc' ;
+ my %Y ; %Y = (1,2,3) ;
+ EXPECT
+ Odd number of elements in hash assignment at - line 3.
+ ########
+ # pp_hot.c [pp_aassign]
+ use warnings 'misc' ;
+ my %X ; %X = [1 .. 3] ;
+ no warnings 'misc' ;
+ my %Y ; %Y = [1 .. 3] ;
+ EXPECT
+ Reference found where even-sized list expected at - line 3.
+ ########
+ # pp_hot.c [Perl_do_readline]
+ use warnings 'closed' ;
+ close STDIN ; $a = <STDIN> ;
+ opendir STDIN, "." ; $a = <STDIN> ;
+ closedir STDIN;
+ no warnings 'closed' ;
+ opendir STDIN, "." ; $a = <STDIN> ;
+ $a = <STDIN> ;
+ EXPECT
+ readline() on closed filehandle STDIN at - line 3.
+ readline() on closed filehandle STDIN at - line 4.
+ (Are you trying to call readline() on dirhandle STDIN?)
+ ########
+ # pp_hot.c [Perl_do_readline]
+ use warnings 'io' ;
+ my $file = "./xcv" ; unlink $file ;
+ open (FH, ">./xcv") ;
+ my $a = <FH> ;
+ no warnings 'io' ;
+ $a = <FH> ;
+ close (FH) ;
+ unlink $file ;
+ EXPECT
+ Filehandle FH opened only for output at - line 5.
+ ########
+ # pp_hot.c [Perl_sub_crush_depth]
+ use warnings 'recursion' ;
+ sub fred
+ {
+ fred() if $a++ < 200
+ }
+ {
+ local $SIG{__WARN__} = sub {
+ die "ok\n" if $_[0] =~ /^Deep recursion on subroutine "main::fred"/
+ };
+ fred();
+ }
+ EXPECT
+ ok
+ ########
+ # pp_hot.c [Perl_sub_crush_depth]
+ no warnings 'recursion' ;
+ sub fred
+ {
+ fred() if $a++ < 200
+ }
+ {
+ local $SIG{__WARN__} = sub {
+ die "ok\n" if $_[0] =~ /^Deep recursion on subroutine "main::fred"/
+ };
+ fred();
+ }
+ EXPECT
+
+ ########
+ # pp_hot.c [Perl_sub_crush_depth]
+ use warnings 'recursion' ;
+ $b = sub
+ {
+ &$b if $a++ < 200
+ } ;
+
+ &$b ;
+ EXPECT
+ Deep recursion on anonymous subroutine at - line 5.
+ ########
+ # pp_hot.c [Perl_sub_crush_depth]
+ no warnings 'recursion' ;
+ $b = sub
+ {
+ &$b if $a++ < 200
+ } ;
+
+ &$b ;
+ EXPECT
+ ########
+ # pp_hot.c [pp_concat]
+ use warnings 'uninitialized';
+ my($x, $y);
+ sub a { shift }
+ a($x . "x"); # should warn once
+ a($x . $y); # should warn twice
+ $x .= $y; # should warn once
+ $y .= $y; # should warn once
+ EXPECT
+ Use of uninitialized value in concatenation (.) or string at - line 5.
+ Use of uninitialized value in concatenation (.) or string at - line 6.
+ Use of uninitialized value in concatenation (.) or string at - line 6.
+ Use of uninitialized value in concatenation (.) or string at - line 7.
+ Use of uninitialized value in concatenation (.) or string at - line 8.
+ ########
+ # pp_hot.c [pp_concat]
+ use warnings 'y2k';
+ use Config;
+ BEGIN {
+ unless ($Config{ccflags} =~ /Y2KWARN/) {
+ print "SKIPPED\n# perl not built with -DPERL_Y2KWARN";
+ exit 0;
+ }
+ }
+ my $x;
+ my $yy = 78;
+ $x = "19$yy\n";
+ $x = "19" . $yy . "\n";
+ $x = "319$yy\n";
+ $x = "319" . $yy . "\n";
+ $yy = 19;
+ $x = "ok $yy\n";
+ $yy = 9;
+ $x = 1 . $yy;
+ no warnings 'y2k';
+ $x = "19$yy\n";
+ $x = "19" . $yy . "\n";
+ EXPECT
+ Possible Y2K bug: about to append an integer to '19' at - line 12.
+ Possible Y2K bug: about to append an integer to '19' at - line 13.
+ ########
+ # pp_hot.c [pp_aelem]
+ {
+ use warnings 'misc';
+ print $x[\1];
+ }
+ {
+ no warnings 'misc';
+ print $x[\1];
+ }
+
+ EXPECT
+ OPTION regex
+ Use of reference ".*" as array index at - line 4.
+ ########
+ # pp_hot.c [pp_aelem]
+ package Foo;use overload q("") => sub {};package main;$a = bless {}, "Foo";
+ $b = {};
+ {
+ use warnings 'misc';
+ print $x[$a];
+ print $x[$b];
+ }
+ {
+ no warnings 'misc';
+ print $x[$a];
+ print $x[$b];
+ }
+
+ EXPECT
+ OPTION regex
+ Use of reference ".*" as array index at - line 7.
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/pp_pack'
Index: ./t/lib/warnings/pp_pack
*** ./t/lib/warnings/pp_pack Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/pp_pack Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,95 ----
+ pp.c TODO
+
+ Invalid type in unpack: '%c
+ my $A = pack ("A,A", 1,2) ;
+ my @A = unpack ("A,A", "22") ;
+
+ Attempt to pack pointer to temporary value
+ pack("p", "abc") ;
+
+ __END__
+ # pp_pack.c
+ use warnings 'pack' ;
+ use warnings 'unpack' ;
+ my @a = unpack ("A,A", "22") ;
+ my $a = pack ("A,A", 1,2) ;
+ no warnings 'pack' ;
+ no warnings 'unpack' ;
+ my @b = unpack ("A,A", "22") ;
+ my $b = pack ("A,A", 1,2) ;
+ EXPECT
+ Invalid type in unpack: ',' at - line 4.
+ Invalid type in pack: ',' at - line 5.
+ ########
+ # pp.c
+ use warnings 'uninitialized' ;
+ my $a = undef ;
+ my $b = $$a;
+ no warnings 'uninitialized' ;
+ my $c = $$a;
+ EXPECT
+ Use of uninitialized value in scalar dereference at - line 4.
+ ########
+ # pp_pack.c
+ use warnings 'pack' ;
+ sub foo { my $a = "a"; return $a . $a++ . $a++ }
+ my $a = pack("p", &foo) ;
+ no warnings 'pack' ;
+ my $b = pack("p", &foo) ;
+ EXPECT
+ Attempt to pack pointer to temporary value at - line 4.
+ ########
+ # pp.c
+ use warnings 'misc' ;
+ bless \[], "" ;
+ no warnings 'misc' ;
+ bless \[], "" ;
+ EXPECT
+ Explicit blessing to '' (assuming package main) at - line 3.
+ ########
+ # pp.c
+ use utf8 ;
+ $_ = "\x80 \xff" ;
+ reverse ;
+ EXPECT
+ ########
+ # pp_pack.c
+ use warnings 'pack' ;
+ print unpack("C", pack("C", -1)), "\n",
+ unpack("C", pack("C", 0)), "\n",
+ unpack("C", pack("C", 255)), "\n",
+ unpack("C", pack("C", 256)), "\n",
+ unpack("c", pack("c", -129)), "\n",
+ unpack("c", pack("c", -128)), "\n",
+ unpack("c", pack("c", 127)), "\n",
+ unpack("c", pack("c", 128)), "\n";
+ no warnings 'pack' ;
+ print unpack("C", pack("C", -1)), "\n";
+ print unpack("C", pack("C", 0)), "\n";
+ print unpack("C", pack("C", 255)), "\n";
+ print unpack("C", pack("C", 256)), "\n";
+ print unpack("c", pack("c", -129)), "\n";
+ print unpack("c", pack("c", -128)), "\n";
+ print unpack("c", pack("c", 127)), "\n";
+ print unpack("c", pack("c", 128)), "\n";
+ EXPECT
+ Character in "C" format wrapped at - line 3.
+ Character in "C" format wrapped at - line 3.
+ Character in "c" format wrapped at - line 3.
+ Character in "c" format wrapped at - line 3.
+ 255
+ 0
+ 255
+ 0
+ 127
+ -128
+ 127
+ -128
+ 255
+ 0
+ 255
+ 0
+ 127
+ -128
+ 127
+ -128
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/pp_sys'
Index: ./t/lib/warnings/pp_sys
*** ./t/lib/warnings/pp_sys Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/pp_sys Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,419 ----
+ pp_sys.c AOK
+
+ untie attempted while %d inner references still exist [pp_untie]
+ sub TIESCALAR { bless [] } ; tie $a, 'main'; untie $a ;
+
+ fileno() on unopened filehandle abc [pp_fileno]
+ $a = "abc"; fileno($a)
+
+ binmode() on unopened filehandle abc [pp_binmode]
+ $a = "abc"; fileno($a)
+
+ printf() on unopened filehandle abc [pp_prtf]
+ $a = "abc"; printf $a "fred"
+
+ Filehandle %s opened only for input [pp_leavewrite]
+ format STDIN =
+ .
+ write STDIN;
+
+ write() on closed filehandle %s [pp_leavewrite]
+ format STDIN =
+ .
+ close STDIN;
+ write STDIN ;
+
+ page overflow [pp_leavewrite]
+
+ printf() on unopened filehandle abc [pp_prtf]
+ $a = "abc"; printf $a "fred"
+
+ Filehandle %s opened only for input [pp_prtf]
+ $a = "abc";
+ printf $a "fred"
+
+ printf() on closed filehandle %s [pp_prtf]
+ close STDIN ;
+ printf STDIN "fred"
+
+ syswrite() on closed filehandle %s [pp_send]
+ close STDIN;
+ syswrite STDIN, "fred", 1;
+
+ send() on closed socket %s [pp_send]
+ close STDIN;
+ send STDIN, "fred", 1
+
+ bind() on closed socket %s [pp_bind]
+ close STDIN;
+ bind STDIN, "fred" ;
+
+
+ connect() on closed socket %s [pp_connect]
+ close STDIN;
+ connect STDIN, "fred" ;
+
+ listen() on closed socket %s [pp_listen]
+ close STDIN;
+ listen STDIN, 2;
+
+ accept() on closed socket %s [pp_accept]
+ close STDIN;
+ accept "fred", STDIN ;
+
+ shutdown() on closed socket %s [pp_shutdown]
+ close STDIN;
+ shutdown STDIN, 0;
+
+ setsockopt() on closed socket %s [pp_ssockopt]
+ getsockopt() on closed socket %s [pp_ssockopt]
+ close STDIN;
+ setsockopt STDIN, 1,2,3;
+ getsockopt STDIN, 1,2;
+
+ getsockname() on closed socket %s [pp_getpeername]
+ getpeername() on closed socket %s [pp_getpeername]
+ close STDIN;
+ getsockname STDIN;
+ getpeername STDIN;
+
+ flock() on closed socket %s [pp_flock]
+ flock() on closed socket [pp_flock]
+ close STDIN;
+ flock STDIN, 8;
+ flock $a, 8;
+
+ The stat preceding lstat() wasn't an lstat %s [pp_stat]
+ lstat(STDIN);
+
+ warn(warn_nl, "stat"); [pp_stat]
+
+ -T on closed filehandle %s
+ stat() on closed filehandle %s
+ close STDIN ; -T STDIN ; stat(STDIN) ;
+
+ warn(warn_nl, "open"); [pp_fttext]
+ -T "abc\ndef" ;
+
+ Filehandle %s opened only for output [pp_sysread]
+ my $file = "./xcv" ;
+ open(F, ">$file") ;
+ my $a = sysread(F, $a,10) ;
+
+
+
+ __END__
+ # pp_sys.c [pp_untie]
+ use warnings 'untie' ;
+ sub TIESCALAR { bless [] } ;
+ $b = tie $a, 'main';
+ untie $a ;
+ no warnings 'untie' ;
+ $c = tie $d, 'main';
+ untie $d ;
+ EXPECT
+ untie attempted while 1 inner references still exist at - line 5.
+ ########
+ # pp_sys.c [pp_leavewrite]
+ use warnings 'io' ;
+ format STDIN =
+ .
+ write STDIN;
+ no warnings 'io' ;
+ write STDIN;
+ EXPECT
+ Filehandle STDIN opened only for input at - line 5.
+ ########
+ # pp_sys.c [pp_leavewrite]
+ use warnings 'closed' ;
+ format STDIN =
+ .
+ close STDIN;
+ write STDIN;
+ opendir STDIN, ".";
+ write STDIN;
+ closedir STDIN;
+ no warnings 'closed' ;
+ write STDIN;
+ opendir STDIN, ".";
+ write STDIN;
+ EXPECT
+ write() on closed filehandle STDIN at - line 6.
+ write() on closed filehandle STDIN at - line 8.
+ (Are you trying to call write() on dirhandle STDIN?)
+ ########
+ # pp_sys.c [pp_leavewrite]
+ use warnings 'io' ;
+ format STDOUT_TOP =
+ abc
+ .
+ format STDOUT =
+ def
+ ghi
+ .
+ $= = 1 ;
+ $- =1 ;
+ open STDOUT, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ;
+ write ;
+ no warnings 'io' ;
+ write ;
+ EXPECT
+ page overflow at - line 13.
+ ########
+ # pp_sys.c [pp_prtf]
+ use warnings 'unopened' ;
+ $a = "abc";
+ printf $a "fred";
+ no warnings 'unopened' ;
+ printf $a "fred";
+ EXPECT
+ printf() on unopened filehandle abc at - line 4.
+ ########
+ # pp_sys.c [pp_prtf]
+ use warnings 'closed' ;
+ close STDIN ;
+ printf STDIN "fred";
+ opendir STDIN, ".";
+ printf STDIN "fred";
+ closedir STDIN;
+ no warnings 'closed' ;
+ printf STDIN "fred";
+ opendir STDIN, ".";
+ printf STDIN "fred";
+ EXPECT
+ printf() on closed filehandle STDIN at - line 4.
+ printf() on closed filehandle STDIN at - line 6.
+ (Are you trying to call printf() on dirhandle STDIN?)
+ ########
+ # pp_sys.c [pp_prtf]
+ use warnings 'io' ;
+ printf STDIN "fred";
+ no warnings 'io' ;
+ printf STDIN "fred";
+ EXPECT
+ Filehandle STDIN opened only for input at - line 3.
+ ########
+ # pp_sys.c [pp_send]
+ use warnings 'closed' ;
+ close STDIN;
+ syswrite STDIN, "fred", 1;
+ opendir STDIN, ".";
+ syswrite STDIN, "fred", 1;
+ closedir STDIN;
+ no warnings 'closed' ;
+ syswrite STDIN, "fred", 1;
+ opendir STDIN, ".";
+ syswrite STDIN, "fred", 1;
+ EXPECT
+ syswrite() on closed filehandle STDIN at - line 4.
+ syswrite() on closed filehandle STDIN at - line 6.
+ (Are you trying to call syswrite() on dirhandle STDIN?)
+ ########
+ # pp_sys.c [pp_flock]
+ use Config;
+ BEGIN {
+ if ( !$Config{d_flock} &&
+ !$Config{d_fcntl_can_lock} &&
+ !$Config{d_lockf} ) {
+ print <<EOM ;
+ SKIPPED
+ # flock not present
+ EOM
+ exit ;
+ }
+ }
+ use warnings qw(unopened closed);
+ close STDIN;
+ flock STDIN, 8;
+ opendir STDIN, ".";
+ flock STDIN, 8;
+ flock FOO, 8;
+ flock $a, 8;
+ no warnings qw(unopened closed);
+ flock STDIN, 8;
+ opendir STDIN, ".";
+ flock STDIN, 8;
+ flock FOO, 8;
+ flock $a, 8;
+ EXPECT
+ flock() on closed filehandle STDIN at - line 16.
+ flock() on closed filehandle STDIN at - line 18.
+ (Are you trying to call flock() on dirhandle STDIN?)
+ flock() on unopened filehandle FOO at - line 19.
+ flock() on unopened filehandle at - line 20.
+ ########
+ # pp_sys.c [pp_prtf pp_send pp_bind pp_connect pp_listen pp_accept pp_shutdown pp_ssockopt ppp_getpeername]
+ use warnings 'io' ;
+ use Config;
+ BEGIN {
+ if ( $^O ne 'VMS' and ! $Config{d_socket}) {
+ print <<EOM ;
+ SKIPPED
+ # send not present
+ # bind not present
+ # connect not present
+ # accept not present
+ # shutdown not present
+ # setsockopt not present
+ # getsockopt not present
+ # getsockname not present
+ # getpeername not present
+ EOM
+ exit ;
+ }
+ }
+ close STDIN;
+ send STDIN, "fred", 1;
+ bind STDIN, "fred" ;
+ connect STDIN, "fred" ;
+ listen STDIN, 2;
+ accept "fred", STDIN;
+ shutdown STDIN, 0;
+ setsockopt STDIN, 1,2,3;
+ getsockopt STDIN, 1,2;
+ getsockname STDIN;
+ getpeername STDIN;
+ opendir STDIN, ".";
+ send STDIN, "fred", 1;
+ bind STDIN, "fred" ;
+ connect STDIN, "fred" ;
+ listen STDIN, 2;
+ accept "fred", STDIN;
+ shutdown STDIN, 0;
+ setsockopt STDIN, 1,2,3;
+ getsockopt STDIN, 1,2;
+ getsockname STDIN;
+ getpeername STDIN;
+ closedir STDIN;
+ no warnings 'io' ;
+ send STDIN, "fred", 1;
+ bind STDIN, "fred" ;
+ connect STDIN, "fred" ;
+ listen STDIN, 2;
+ accept STDIN, "fred" ;
+ shutdown STDIN, 0;
+ setsockopt STDIN, 1,2,3;
+ getsockopt STDIN, 1,2;
+ getsockname STDIN;
+ getpeername STDIN;
+ opendir STDIN, ".";
+ send STDIN, "fred", 1;
+ bind STDIN, "fred" ;
+ connect STDIN, "fred" ;
+ listen STDIN, 2;
+ accept "fred", STDIN;
+ shutdown STDIN, 0;
+ setsockopt STDIN, 1,2,3;
+ getsockopt STDIN, 1,2;
+ getsockname STDIN;
+ getpeername STDIN;
+ EXPECT
+ send() on closed socket STDIN at - line 22.
+ bind() on closed socket STDIN at - line 23.
+ connect() on closed socket STDIN at - line 24.
+ listen() on closed socket STDIN at - line 25.
+ accept() on closed socket STDIN at - line 26.
+ shutdown() on closed socket STDIN at - line 27.
+ setsockopt() on closed socket STDIN at - line 28.
+ getsockopt() on closed socket STDIN at - line 29.
+ getsockname() on closed socket STDIN at - line 30.
+ getpeername() on closed socket STDIN at - line 31.
+ send() on closed socket STDIN at - line 33.
+ (Are you trying to call send() on dirhandle STDIN?)
+ bind() on closed socket STDIN at - line 34.
+ (Are you trying to call bind() on dirhandle STDIN?)
+ connect() on closed socket STDIN at - line 35.
+ (Are you trying to call connect() on dirhandle STDIN?)
+ listen() on closed socket STDIN at - line 36.
+ (Are you trying to call listen() on dirhandle STDIN?)
+ accept() on closed socket STDIN at - line 37.
+ (Are you trying to call accept() on dirhandle STDIN?)
+ shutdown() on closed socket STDIN at - line 38.
+ (Are you trying to call shutdown() on dirhandle STDIN?)
+ setsockopt() on closed socket STDIN at - line 39.
+ (Are you trying to call setsockopt() on dirhandle STDIN?)
+ getsockopt() on closed socket STDIN at - line 40.
+ (Are you trying to call getsockopt() on dirhandle STDIN?)
+ getsockname() on closed socket STDIN at - line 41.
+ (Are you trying to call getsockname() on dirhandle STDIN?)
+ getpeername() on closed socket STDIN at - line 42.
+ (Are you trying to call getpeername() on dirhandle STDIN?)
+ ########
+ # pp_sys.c [pp_stat]
+ use warnings 'newline' ;
+ stat "abc\ndef";
+ no warnings 'newline' ;
+ stat "abc\ndef";
+ EXPECT
+ Unsuccessful stat on filename containing newline at - line 3.
+ ########
+ # pp_sys.c [pp_stat]
+ use Config;
+ BEGIN {
+ if ($^O eq 'd_lstat') {
+ print <<EOM ;
+ SKIPPED
+ # lstat not present
+ EOM
+ exit ;
+ }
+ }
+ use warnings 'io' ;
+ lstat(STDIN) ;
+ no warnings 'io' ;
+ lstat(STDIN) ;
+ EXPECT
+ The stat preceding lstat() wasn't an lstat at - line 13.
+ ########
+ # pp_sys.c [pp_fttext]
+ use warnings qw(unopened closed) ;
+ close STDIN ;
+ -T STDIN ;
+ stat(STDIN) ;
+ -T HOCUS;
+ stat(POCUS);
+ no warnings qw(unopened closed) ;
+ -T STDIN ;
+ stat(STDIN);
+ -T HOCUS;
+ stat(POCUS);
+ EXPECT
+ -T on closed filehandle STDIN at - line 4.
+ stat() on closed filehandle STDIN at - line 5.
+ -T on unopened filehandle HOCUS at - line 6.
+ stat() on unopened filehandle POCUS at - line 7.
+ ########
+ # pp_sys.c [pp_fttext]
+ use warnings 'newline' ;
+ -T "abc\ndef" ;
+ no warnings 'newline' ;
+ -T "abc\ndef" ;
+ EXPECT
+ Unsuccessful open on filename containing newline at - line 3.
+ ########
+ # pp_sys.c [pp_sysread]
+ use warnings 'io' ;
+ if ($^O eq 'dos') {
+ print <<EOM ;
+ SKIPPED
+ # skipped on dos
+ EOM
+ exit ;
+ }
+ my $file = "./xcv" ;
+ open(F, ">$file") ;
+ my $a = sysread(F, $a,10) ;
+ no warnings 'io' ;
+ my $a = sysread(F, $a,10) ;
+ close F ;
+ unlink $file ;
+ EXPECT
+ Filehandle F opened only for output at - line 12.
+ ########
+ # pp_sys.c [pp_binmode]
+ use warnings 'unopened' ;
+ binmode(BLARG);
+ $a = "BLERG";binmode($a);
+ EXPECT
+ binmode() on unopened filehandle BLARG at - line 3.
+ binmode() on unopened filehandle at - line 4.
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/regcomp'
Index: ./t/lib/warnings/regcomp
*** ./t/lib/warnings/regcomp Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/regcomp Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,239 ----
+ regcomp.c AOK
+
+ Quantifier unexpected on zero-length expression [S_study_chunk]
+
+ (?p{}) is deprecated - use (??{}) [S_reg]
+ $a =~ /(?p{'x'})/ ;
+
+
+ Useless (%s%c) - %suse /%c modifier [S_reg]
+ Useless (%sc) - %suse /gc modifier [S_reg]
+
+
+
+ Strange *+?{} on zero-length expression [S_study_chunk]
+ /(?=a)?/
+
+ %.*s matches null string many times [S_regpiece]
+ $a = "ABC123" ; $a =~ /(?=a)*/'
+
+ /%.127s/: Unrecognized escape \\%c passed through [S_regatom]
+ $x = '\m' ; /$x/
+
+ POSIX syntax [%c %c] is reserved for future extensions [S_checkposixcc]
+
+
+ Character class [:%.*s:] unknown [S_regpposixcc]
+
+ Character class syntax [%c %c] belongs inside character classes [S_checkposixcc]
+
+ /%.127s/: false [] range \"%*.*s\" in regexp [S_regclass]
+
+ /%.127s/: false [] range \"%*.*s\" in regexp [S_regclassutf8]
+
+ /%.127s/: Unrecognized escape \\%c in character class passed through" [S_regclass]
+
+ /%.127s/: Unrecognized escape \\%c in character class passed through" [S_regclassutf8]
+
+ False [] range \"%*.*s\" [S_regclass]
+
+ __END__
+ # regcomp.c [S_regpiece]
+ use warnings 'regexp' ;
+ my $a = "ABC123" ;
+ $a =~ /(?=a)*/ ;
+ no warnings 'regexp' ;
+ $a =~ /(?=a)*/ ;
+ EXPECT
+ (?=a)* matches null string many times in regex; marked by <-- HERE in m/(?=a)* <-- HERE / at - line 4.
+ ########
+ # regcomp.c [S_study_chunk]
+ use warnings 'regexp' ;
+ $_ = "" ;
+ /(?=a)?/;
+ no warnings 'regexp' ;
+ /(?=a)?/;
+ EXPECT
+ Quantifier unexpected on zero-length expression in regex; marked by <-- HERE in m/(?=a)? <-- HERE / at - line 4.
+ ########
+ # regcomp.c [S_regatom]
+ $x = '\m' ;
+ use warnings 'regexp' ;
+ $a =~ /a$x/ ;
+ no warnings 'regexp' ;
+ $a =~ /a$x/ ;
+ EXPECT
+ Unrecognized escape \m passed through in regex; marked by <-- HERE in m/a\m <-- HERE / at - line 4.
+ ########
+ # regcomp.c [S_regpposixcc S_checkposixcc]
+ #
+ use warnings 'regexp' ;
+ $_ = "" ;
+ /[:alpha:]/;
+ /[:zog:]/;
+ /[[:zog:]]/;
+ no warnings 'regexp' ;
+ /[:alpha:]/;
+ /[:zog:]/;
+ /[[:zog:]]/;
+ EXPECT
+ POSIX syntax [: :] belongs inside character classes in regex; marked by <-- HERE in m/[:alpha:] <-- HERE / at - line 5.
+ POSIX syntax [: :] belongs inside character classes in regex; marked by <-- HERE in m/[:zog:] <-- HERE / at - line 6.
+ POSIX class [:zog:] unknown in regex; marked by <-- HERE in m/[[:zog:] <-- HERE ]/
+ ########
+ # regcomp.c [S_checkposixcc]
+ #
+ use warnings 'regexp' ;
+ $_ = "" ;
+ /[.zog.]/;
+ no warnings 'regexp' ;
+ /[.zog.]/;
+ EXPECT
+ POSIX syntax [. .] belongs inside character classes in regex; marked by <-- HERE in m/[.zog.] <-- HERE / at - line 5.
+ POSIX syntax [. .] is reserved for future extensions in regex; marked by <-- HERE in m/[.zog.] <-- HERE /
+ ########
+ # regcomp.c [S_checkposixcc]
+ #
+ use warnings 'regexp' ;
+ $_ = "" ;
+ /[[.zog.]]/;
+ no warnings 'regexp' ;
+ /[[.zog.]]/;
+ EXPECT
+ POSIX syntax [. .] is reserved for future extensions in regex; marked by <-- HERE in m/[[.zog.] <-- HERE ]/
+ ########
+ # regcomp.c [S_regclass]
+ $_ = "";
+ use warnings 'regexp' ;
+ /[a-b]/;
+ /[a-\d]/;
+ /[\d-b]/;
+ /[\s-\d]/;
+ /[\d-\s]/;
+ /[a-[:digit:]]/;
+ /[[:digit:]-b]/;
+ /[[:alpha:]-[:digit:]]/;
+ /[[:digit:]-[:alpha:]]/;
+ no warnings 'regexp' ;
+ /[a-b]/;
+ /[a-\d]/;
+ /[\d-b]/;
+ /[\s-\d]/;
+ /[\d-\s]/;
+ /[a-[:digit:]]/;
+ /[[:digit:]-b]/;
+ /[[:alpha:]-[:digit:]]/;
+ /[[:digit:]-[:alpha:]]/;
+ EXPECT
+ False [] range "a-\d" in regex; marked by <-- HERE in m/[a-\d <-- HERE ]/ at - line 5.
+ False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE b]/ at - line 6.
+ False [] range "\s-" in regex; marked by <-- HERE in m/[\s- <-- HERE \d]/ at - line 7.
+ False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE \s]/ at - line 8.
+ False [] range "a-[:digit:]" in regex; marked by <-- HERE in m/[a-[:digit:] <-- HERE ]/ at - line 9.
+ False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE b]/ at - line 10.
+ False [] range "[:alpha:]-" in regex; marked by <-- HERE in m/[[:alpha:]- <-- HERE [:digit:]]/ at - line 11.
+ False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE [:alpha:]]/ at - line 12.
+ ########
+ # regcomp.c [S_regclassutf8]
+ BEGIN {
+ if (ord("\t") == 5) {
+ print "SKIPPED\n# ebcdic regular expression ranges differ.";
+ exit 0;
+ }
+ }
+ use utf8;
+ $_ = "";
+ use warnings 'regexp' ;
+ /[a-b]/;
+ /[a-\d]/;
+ /[\d-b]/;
+ /[\s-\d]/;
+ /[\d-\s]/;
+ /[a-[:digit:]]/;
+ /[[:digit:]-b]/;
+ /[[:alpha:]-[:digit:]]/;
+ /[[:digit:]-[:alpha:]]/;
+ no warnings 'regexp' ;
+ /[a-b]/;
+ /[a-\d]/;
+ /[\d-b]/;
+ /[\s-\d]/;
+ /[\d-\s]/;
+ /[a-[:digit:]]/;
+ /[[:digit:]-b]/;
+ /[[:alpha:]-[:digit:]]/;
+ /[[:digit:]-[:alpha:]]/;
+ EXPECT
+ False [] range "a-\d" in regex; marked by <-- HERE in m/[a-\d <-- HERE ]/ at - line 12.
+ False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE b]/ at - line 13.
+ False [] range "\s-" in regex; marked by <-- HERE in m/[\s- <-- HERE \d]/ at - line 14.
+ False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE \s]/ at - line 15.
+ False [] range "a-[:digit:]" in regex; marked by <-- HERE in m/[a-[:digit:] <-- HERE ]/ at - line 16.
+ False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE b]/ at - line 17.
+ False [] range "[:alpha:]-" in regex; marked by <-- HERE in m/[[:alpha:]- <-- HERE [:digit:]]/ at - line 18.
+ False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE [:alpha:]]/ at - line 19.
+ ########
+ # regcomp.c [S_regclass S_regclassutf8]
+ use warnings 'regexp' ;
+ $a =~ /[a\zb]/ ;
+ no warnings 'regexp' ;
+ $a =~ /[a\zb]/ ;
+ EXPECT
+ Unrecognized escape \z in character class passed through in regex; marked by <-- HERE in m/[a\z <-- HERE b]/ at - line 3.
+
+ ########
+ # regcomp.c [S_study_chunk]
+ use warnings 'deprecated' ;
+ $a = "xx" ;
+ $a =~ /(?p{'x'})/ ;
+ no warnings ;
+ use warnings 'regexp' ;
+ $a =~ /(?p{'x'})/ ;
+ use warnings;
+ no warnings 'deprecated' ;
+ no warnings 'regexp' ;
+ $a =~ /(?p{'x'})/ ;
+ EXPECT
+ (?p{}) is deprecated - use (??{}) in regex; marked by <-- HERE in m/(?p <-- HERE {'x'})/ at - line 4.
+ (?p{}) is deprecated - use (??{}) in regex; marked by <-- HERE in m/(?p <-- HERE {'x'})/ at - line 7.
+ ########
+ # regcomp.c [S_reg]
+ use warnings 'regexp' ;
+ $a = qr/(?c)/;
+ $a = qr/(?-c)/;
+ $a = qr/(?g)/;
+ $a = qr/(?-g)/;
+ $a = qr/(?o)/;
+ $a = qr/(?-o)/;
+ $a = qr/(?g-o)/;
+ $a = qr/(?g-c)/;
+ $a = qr/(?o-cg)/; # (?c) means (?g) error won't be thrown
+ $a = qr/(?ogc)/;
+ no warnings 'regexp' ;
+ $a = qr/(?c)/;
+ $a = qr/(?-c)/;
+ $a = qr/(?g)/;
+ $a = qr/(?-g)/;
+ $a = qr/(?o)/;
+ $a = qr/(?-o)/;
+ $a = qr/(?g-o)/;
+ $a = qr/(?g-c)/;
+ $a = qr/(?o-cg)/; # (?c) means (?g) error won't be thrown
+ $a = qr/(?ogc)/;
+ #EXPECT
+ EXPECT
+ Useless (?c) - use /gc modifier in regex; marked by <-- HERE in m/(?c <-- HERE )/ at - line 3.
+ Useless (?-c) - don't use /gc modifier in regex; marked by <-- HERE in m/(?-c <-- HERE )/ at - line 4.
+ Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?g <-- HERE )/ at - line 5.
+ Useless (?-g) - don't use /g modifier in regex; marked by <-- HERE in m/(?-g <-- HERE )/ at - line 6.
+ Useless (?o) - use /o modifier in regex; marked by <-- HERE in m/(?o <-- HERE )/ at - line 7.
+ Useless (?-o) - don't use /o modifier in regex; marked by <-- HERE in m/(?-o <-- HERE )/ at - line 8.
+ Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?g <-- HERE -o)/ at - line 9.
+ Useless (?-o) - don't use /o modifier in regex; marked by <-- HERE in m/(?g-o <-- HERE )/ at - line 9.
+ Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?g <-- HERE -c)/ at - line 10.
+ Useless (?-c) - don't use /gc modifier in regex; marked by <-- HERE in m/(?g-c <-- HERE )/ at - line 10.
+ Useless (?o) - use /o modifier in regex; marked by <-- HERE in m/(?o <-- HERE -cg)/ at - line 11.
+ Useless (?-c) - don't use /gc modifier in regex; marked by <-- HERE in m/(?o-c <-- HERE g)/ at - line 11.
+ Useless (?o) - use /o modifier in regex; marked by <-- HERE in m/(?o <-- HERE gc)/ at - line 12.
+ Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?og <-- HERE c)/ at - line 12.
+ Useless (?c) - use /gc modifier in regex; marked by <-- HERE in m/(?ogc <-- HERE )/ at - line 12.
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/regexec'
Index: ./t/lib/warnings/regexec
*** ./t/lib/warnings/regexec Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/regexec Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,119 ----
+ regexec.c
+
+ This test generates "bad free" warnings when run under
+ PERL_DESTRUCT_LEVEL. This file merely serves as a placeholder
+ for investigation.
+
+ Complex regular subexpression recursion limit (%d) exceeded
+
+ $_ = 'a' x (2**15+1); /^()(a\1)*$/ ;
+ Complex regular subexpression recursion limit (%d) exceeded
+
+ $_ = 'a' x (2**15+1); /^()(a\1)*?$/ ;
+
+ (The actual value substituted for %d is masked in the tests so that
+ REG_INFTY configuration variable value does not affect outcome.)
+ __END__
+ # regexec.c
+ print("SKIPPED\n# most systems run into stacksize limits\n"),exit;
+ use warnings 'regexp' ;
+ $SIG{__WARN__} = sub{local ($m) = shift;
+ $m =~ s/\(\d+\)/(*MASKED*)/;
+ print STDERR $m};
+ $_ = 'a' x (2**15+1);
+ /^()(a\1)*$/ ;
+ #
+ # If this test fails with a segmentation violation or similar,
+ # you may have to increase the default stacksize limit in your
+ # shell. You may need superuser privileges.
+ #
+ # Under the sh, ksh, zsh:
+ # $ ulimit -s
+ # 8192
+ # $ ulimit -s 16000
+ #
+ # Under the csh:
+ # % limit stacksize
+ # stacksize 8192 kbytes
+ # % limit stacksize 16000
+ #
+ EXPECT
+ Complex regular subexpression recursion limit (*MASKED*) exceeded at - line 9.
+ ########
+ # regexec.c
+ print("SKIPPED\n# most systems run into stacksize limits\n"),exit;
+ no warnings 'regexp' ;
+ $SIG{__WARN__} = sub{local ($m) = shift;
+ $m =~ s/\(\d+\)/(*MASKED*)/;
+ print STDERR $m};
+ $_ = 'a' x (2**15+1);
+ /^()(a\1)*$/ ;
+ #
+ # If this test fails with a segmentation violation or similar,
+ # you may have to increase the default stacksize limit in your
+ # shell. You may need superuser privileges.
+ #
+ # Under the sh, ksh, zsh:
+ # $ ulimit -s
+ # 8192
+ # $ ulimit -s 16000
+ #
+ # Under the csh:
+ # % limit stacksize
+ # stacksize 8192 kbytes
+ # % limit stacksize 16000
+ #
+ EXPECT
+
+ ########
+ # regexec.c
+ print("SKIPPED\n# most systems run into stacksize limits\n"),exit;
+ use warnings 'regexp' ;
+ $SIG{__WARN__} = sub{local ($m) = shift;
+ $m =~ s/\(\d+\)/(*MASKED*)/;
+ print STDERR $m};
+ $_ = 'a' x (2**15+1);
+ /^()(a\1)*?$/ ;
+ #
+ # If this test fails with a segmentation violation or similar,
+ # you may have to increase the default stacksize limit in your
+ # shell. You may need superuser privileges.
+ #
+ # Under the sh, ksh, zsh:
+ # $ ulimit -s
+ # 8192
+ # $ ulimit -s 16000
+ #
+ # Under the csh:
+ # % limit stacksize
+ # stacksize 8192 kbytes
+ # % limit stacksize 16000
+ #
+ EXPECT
+ Complex regular subexpression recursion limit (*MASKED*) exceeded at - line 9.
+ ########
+ # regexec.c
+ print("SKIPPED\n# most systems run into stacksize limits\n"),exit;
+ no warnings 'regexp' ;
+ $SIG{__WARN__} = sub{local ($m) = shift;
+ $m =~ s/\(\d+\)/(*MASKED*)/;
+ print STDERR $m};
+ $_ = 'a' x (2**15+1);
+ /^()(a\1)*?$/ ;
+ #
+ # If this test fails with a segmentation violation or similar,
+ # you may have to increase the default stacksize limit in your
+ # shell. You may need superuser privileges.
+ #
+ # Under the sh, ksh, zsh:
+ # $ ulimit -s
+ # 8192
+ # $ ulimit -s 16000
+ #
+ # Under the csh:
+ # % limit stacksize
+ # stacksize 8192 kbytes
+ # % limit stacksize 16000
+ #
+ EXPECT
+
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/run'
Index: ./t/lib/warnings/run
*** ./t/lib/warnings/run Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/run Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,8 ----
+ run.c
+
+
+ Mandatory Warnings ALL TODO
+ ------------------
+ NULL OP IN RUN
+
+ __END__
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/sv'
Index: ./t/lib/warnings/sv
*** ./t/lib/warnings/sv Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/sv Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,320 ----
+ sv.c
+
+ warn(warn_uninit);
+
+ warn(warn_uninit);
+
+ warn(warn_uninit);
+
+ warn(warn_uninit);
+
+ not_a_number(sv);
+
+ not_a_number(sv);
+
+ warn(warn_uninit);
+
+ not_a_number(sv);
+
+ warn(warn_uninit);
+
+ not_a_number(sv);
+
+ not_a_number(sv);
+
+ warn(warn_uninit);
+
+ warn(warn_uninit);
+
+ Subroutine %s redefined
+
+ Invalid conversion in %s:
+
+ Undefined value assigned to typeglob
+
+ Possible Y2K bug: %d format string following '19'
+
+ Reference is already weak [Perl_sv_rvweaken] <<TODO
+
+ Mandatory Warnings
+ ------------------
+ Malformed UTF-8 character [sv_pos_b2u] (not tested: difficult to produce
+ with perl now)
+
+ Mandatory Warnings TODO
+ ------------------
+ Attempt to free non-arena SV: 0x%lx [del_sv]
+ Reference miscount in sv_replace() [sv_replace]
+ Attempt to free unreferenced scalar [sv_free]
+ Attempt to free temp prematurely: SV 0x%lx [sv_free]
+ semi-panic: attempt to dup freed string [newSVsv]
+
+
+ __END__
+ # sv.c
+ use integer ;
+ use warnings 'uninitialized' ;
+ $x = 1 + $a[0] ; # a
+ no warnings 'uninitialized' ;
+ $x = 1 + $b[0] ; # a
+ EXPECT
+ Use of uninitialized value in integer addition (+) at - line 4.
+ ########
+ # sv.c (sv_2iv)
+ package fred ;
+ sub TIESCALAR { my $x ; bless \$x}
+ sub FETCH { return undef }
+ sub STORE { return 1 }
+ package main ;
+ tie $A, 'fred' ;
+ use integer ;
+ use warnings 'uninitialized' ;
+ $A *= 2 ;
+ no warnings 'uninitialized' ;
+ $A *= 2 ;
+ EXPECT
+ Use of uninitialized value in integer multiplication (*) at - line 10.
+ ########
+ # sv.c
+ use integer ;
+ use warnings 'uninitialized' ;
+ my $x *= 2 ; #b
+ no warnings 'uninitialized' ;
+ my $y *= 2 ; #b
+ EXPECT
+ Use of uninitialized value in integer multiplication (*) at - line 4.
+ ########
+ # sv.c (sv_2uv)
+ package fred ;
+ sub TIESCALAR { my $x ; bless \$x}
+ sub FETCH { return undef }
+ sub STORE { return 1 }
+ package main ;
+ tie $A, 'fred' ;
+ use warnings 'uninitialized' ;
+ $B = 0 ;
+ $B |= $A ;
+ no warnings 'uninitialized' ;
+ $B = 0 ;
+ $B |= $A ;
+ EXPECT
+ Use of uninitialized value in bitwise or (|) at - line 10.
+ ########
+ # sv.c
+ use warnings 'uninitialized' ;
+ my $Y = 1 ;
+ my $x = 1 | $a[$Y] ;
+ no warnings 'uninitialized' ;
+ my $Y = 1 ;
+ $x = 1 | $b[$Y] ;
+ EXPECT
+ Use of uninitialized value in bitwise or (|) at - line 4.
+ ########
+ # sv.c
+ use warnings 'uninitialized' ;
+ my $x *= 1 ; # d
+ no warnings 'uninitialized' ;
+ my $y *= 1 ; # d
+ EXPECT
+ Use of uninitialized value in multiplication (*) at - line 3.
+ ########
+ # sv.c
+ use warnings 'uninitialized' ;
+ $x = 1 + $a[0] ; # e
+ no warnings 'uninitialized' ;
+ $x = 1 + $b[0] ; # e
+ EXPECT
+ Use of uninitialized value in addition (+) at - line 3.
+ ########
+ # sv.c (sv_2nv)
+ package fred ;
+ sub TIESCALAR { my $x ; bless \$x}
+ sub FETCH { return undef }
+ sub STORE { return 1 }
+ package main ;
+ tie $A, 'fred' ;
+ use warnings 'uninitialized' ;
+ $A *= 2 ;
+ no warnings 'uninitialized' ;
+ $A *= 2 ;
+ EXPECT
+ Use of uninitialized value in multiplication (*) at - line 9.
+ ########
+ # sv.c
+ use warnings 'uninitialized' ;
+ $x = $y + 1 ; # f
+ no warnings 'uninitialized' ;
+ $x = $z + 1 ; # f
+ EXPECT
+ Use of uninitialized value in addition (+) at - line 3.
+ ########
+ # sv.c
+ use warnings 'uninitialized' ;
+ $x = chop undef ; # g
+ no warnings 'uninitialized' ;
+ $x = chop undef ; # g
+ EXPECT
+ Modification of a read-only value attempted at - line 3.
+ ########
+ # sv.c
+ use warnings 'uninitialized' ;
+ $x = chop $y ; # h
+ no warnings 'uninitialized' ;
+ $x = chop $z ; # h
+ EXPECT
+ Use of uninitialized value in scalar chop at - line 3.
+ ########
+ # sv.c (sv_2pv)
+ package fred ;
+ sub TIESCALAR { my $x ; bless \$x}
+ sub FETCH { return undef }
+ sub STORE { return 1 }
+ package main ;
+ tie $A, 'fred' ;
+ use warnings 'uninitialized' ;
+ $B = "" ;
+ $B .= $A ;
+ no warnings 'uninitialized' ;
+ $C = "" ;
+ $C .= $A ;
+ EXPECT
+ Use of uninitialized value in concatenation (.) or string at - line 10.
+ ########
+ # sv.c
+ use warnings 'numeric' ;
+ sub TIESCALAR{bless[]} ;
+ sub FETCH {"def"} ;
+ tie $a,"main" ;
+ my $b = 1 + $a;
+ no warnings 'numeric' ;
+ my $c = 1 + $a;
+ EXPECT
+ Argument "def" isn't numeric in addition (+) at - line 6.
+ ########
+ # sv.c
+ use warnings 'numeric' ;
+ my $x = 1 + "def" ;
+ no warnings 'numeric' ;
+ my $z = 1 + "def" ;
+ EXPECT
+ Argument "def" isn't numeric in addition (+) at - line 3.
+ ########
+ # sv.c
+ use warnings 'numeric' ;
+ my $a = "def" ;
+ my $x = 1 + $a ;
+ no warnings 'numeric' ;
+ my $y = 1 + $a ;
+ EXPECT
+ Argument "def" isn't numeric in addition (+) at - line 4.
+ ########
+ # sv.c
+ use warnings 'numeric' ; use integer ;
+ my $a = "def" ;
+ my $x = 1 + $a ;
+ no warnings 'numeric' ;
+ my $z = 1 + $a ;
+ EXPECT
+ Argument "def" isn't numeric in integer addition (+) at - line 4.
+ ########
+ # sv.c
+ use warnings 'numeric' ;
+ my $x = 1 & "def" ;
+ no warnings 'numeric' ;
+ my $z = 1 & "def" ;
+ EXPECT
+ Argument "def" isn't numeric in bitwise and (&) at - line 3.
+ ########
+ # sv.c
+ use warnings 'numeric' ;
+ my $x = pack i => "def" ;
+ no warnings 'numeric' ;
+ my $z = pack i => "def" ;
+ EXPECT
+ Argument "def" isn't numeric in pack at - line 3.
+ ########
+ # sv.c
+ use warnings 'numeric' ;
+ my $a = "d\0f" ;
+ my $x = 1 + $a ;
+ no warnings 'numeric' ;
+ my $z = 1 + $a ;
+ EXPECT
+ Argument "d\0f" isn't numeric in addition (+) at - line 4.
+ ########
+ # sv.c
+ use warnings 'redefine' ;
+ sub fred {}
+ sub joe {}
+ *fred = \&joe ;
+ no warnings 'redefine' ;
+ sub jim {}
+ *jim = \&joe ;
+ EXPECT
+ Subroutine fred redefined at - line 5.
+ ########
+ # sv.c
+ use warnings 'printf' ;
+ open F, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ;
+ printf F "%z\n" ;
+ my $a = sprintf "%z" ;
+ printf F "%" ;
+ $a = sprintf "%" ;
+ printf F "%\x02" ;
+ $a = sprintf "%\x02" ;
+ no warnings 'printf' ;
+ printf F "%z\n" ;
+ $a = sprintf "%z" ;
+ printf F "%" ;
+ $a = sprintf "%" ;
+ printf F "%\x02" ;
+ $a = sprintf "%\x02" ;
+ EXPECT
+ Invalid conversion in sprintf: "%z" at - line 5.
+ Invalid conversion in sprintf: end of string at - line 7.
+ Invalid conversion in sprintf: "%\002" at - line 9.
+ Invalid conversion in printf: "%z" at - line 4.
+ Invalid conversion in printf: end of string at - line 6.
+ Invalid conversion in printf: "%\002" at - line 8.
+ ########
+ # sv.c
+ use warnings 'misc' ;
+ *a = undef ;
+ no warnings 'misc' ;
+ *b = undef ;
+ EXPECT
+ Undefined value assigned to typeglob at - line 3.
+ ########
+ # sv.c
+ use warnings 'y2k';
+ use Config;
+ BEGIN {
+ unless ($Config{ccflags} =~ /Y2KWARN/) {
+ print "SKIPPED\n# perl not built with -DPERL_Y2KWARN";
+ exit 0;
+ }
+ $|=1;
+ }
+ my $x;
+ my $yy = 78;
+ $x = printf "19%02d\n", $yy;
+ $x = sprintf "#19%02d\n", $yy;
+ $x = printf " 19%02d\n", 78;
+ $x = sprintf "19%02d\n", 78;
+ $x = printf "319%02d\n", $yy;
+ $x = sprintf "319%02d\n", $yy;
+ no warnings 'y2k';
+ $x = printf "19%02d\n", $yy;
+ $x = sprintf "19%02d\n", $yy;
+ $x = printf "19%02d\n", 78;
+ $x = sprintf "19%02d\n", 78;
+ EXPECT
+ Possible Y2K bug: %d format string following '19' at - line 16.
+ Possible Y2K bug: %d format string following '19' at - line 13.
+ 1978
+ Possible Y2K bug: %d format string following '19' at - line 14.
+ Possible Y2K bug: %d format string following '19' at - line 15.
+ 1978
+ 31978
+ 1978
+ 1978
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/taint'
Index: ./t/lib/warnings/taint
*** ./t/lib/warnings/taint Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/taint Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,49 ----
+ taint.c AOK
+
+ Insecure %s%s while running with -T switch
+
+ __END__
+ -T
+ --FILE-- abc
+ def
+ --FILE--
+ # taint.c
+ open(FH, "<abc") ;
+ $a = <FH> ;
+ close FH ;
+ chdir $a ;
+ print "xxx\n" ;
+ EXPECT
+ Insecure dependency in chdir while running with -T switch at - line 5.
+ ########
+ -TU
+ --FILE-- abc
+ def
+ --FILE--
+ # taint.c
+ open(FH, "<abc") ;
+ $a = <FH> ;
+ close FH ;
+ chdir $a ;
+ print "xxx\n" ;
+ EXPECT
+ xxx
+ ########
+ -TU
+ --FILE-- abc
+ def
+ --FILE--
+ # taint.c
+ open(FH, "<abc") ;
+ $a = <FH> ;
+ close FH ;
+ use warnings 'taint' ;
+ chdir $a ;
+ print "xxx\n" ;
+ no warnings 'taint' ;
+ chdir $a ;
+ print "yyy\n" ;
+ EXPECT
+ Insecure dependency in chdir while running with -T switch at - line 6.
+ xxx
+ yyy
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/toke'
Index: ./t/lib/warnings/toke
*** ./t/lib/warnings/toke Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/toke Thu Jul 12 08:23:10 2001
***************
*** 0 ****
--- 1,710 ----
+ toke.c AOK
+
+ we seem to have lost a few ambiguous warnings!!
+
+
+ $a = <<;
+ Use of comma-less variable list is deprecated
+ (called 3 times via depcom)
+
+ \1 better written as $1
+ use warnings 'syntax' ;
+ s/(abc)/\1/;
+
+ warn(warn_nosemi)
+ Semicolon seems to be missing
+ $a = 1
+ &time ;
+
+
+ Reversed %c= operator
+ my $a =+ 2 ;
+ $a =- 2 ;
+ $a =* 2 ;
+ $a =% 2 ;
+ $a =& 2 ;
+ $a =. 2 ;
+ $a =^ 2 ;
+ $a =| 2 ;
+ $a =< 2 ;
+ $a =/ 2 ;
+
+ Multidimensional syntax %.*s not supported
+ my $a = $a[1,2] ;
+
+ You need to quote \"%s\""
+ sub fred {} ; $SIG{TERM} = fred;
+
+ Scalar value %.*s better written as $%.*s"
+ @a[3] = 2;
+ @a{3} = 2;
+
+ Can't use \\%c to mean $%c in expression
+ $_ = "ab" ; s/(ab)/\1/e;
+
+ Unquoted string "abc" may clash with future reserved word at - line 3.
+ warn(warn_reserved
+ $a = abc;
+
+ Possible attempt to separate words with commas
+ @a = qw(a, b, c) ;
+
+ Possible attempt to put comments in qw() list
+ @a = qw(a b # c) ;
+
+ %s (...) interpreted as function
+ print ("")
+ printf ("")
+ sort ("")
+
+ Ambiguous use of %c{%s%s} resolved to %c%s%s
+ $a = ${time[2]}
+ $a = ${time{2}}
+
+
+ Ambiguous use of %c{%s} resolved to %c%s
+ $a = ${time}
+ sub fred {} $a = ${fred}
+
+ Misplaced _ in number
+ $a = 1_2;
+ $a = 1_2345_6;
+
+ Bareword \"%s\" refers to nonexistent package
+ $a = FRED:: ;
+
+ Ambiguous call resolved as CORE::%s(), qualify as such or use &
+ sub time {}
+ my $a = time()
+
+ Unrecognized escape \\%c passed through
+ $a = "\m" ;
+
+ %s number > %s non-portable
+ my $a = 0b011111111111111111111111111111110 ;
+ $a = 0b011111111111111111111111111111111 ;
+ $a = 0b111111111111111111111111111111111 ;
+ $a = 0x0fffffffe ;
+ $a = 0x0ffffffff ;
+ $a = 0x1ffffffff ;
+ $a = 0037777777776 ;
+ $a = 0037777777777 ;
+ $a = 0047777777777 ;
+
+ Integer overflow in binary number
+ my $a = 0b011111111111111111111111111111110 ;
+ $a = 0b011111111111111111111111111111111 ;
+ $a = 0b111111111111111111111111111111111 ;
+ $a = 0x0fffffffe ;
+ $a = 0x0ffffffff ;
+ $a = 0x1ffffffff ;
+ $a = 0037777777776 ;
+ $a = 0037777777777 ;
+ $a = 0047777777777 ;
+
+ Mandatory Warnings
+ ------------------
+ Use of "%s" without parentheses is ambiguous [check_uni]
+ rand + 4
+
+ Ambiguous use of -%s resolved as -&%s() [yylex]
+ sub fred {} ; - fred ;
+
+ Precedence problem: open %.*s should be open(%.*s) [yylex]
+ open FOO || die;
+
+ Operator or semicolon missing before %c%s [yylex]
+ Ambiguous use of %c resolved as operator %c
+ *foo *foo
+
+ __END__
+ # toke.c
+ use warnings 'deprecated' ;
+ format STDOUT =
+ @<<< @||| @>>> @>>>
+ $a $b "abc" 'def'
+ .
+ no warnings 'deprecated' ;
+ format STDOUT =
+ @<<< @||| @>>> @>>>
+ $a $b "abc" 'def'
+ .
+ EXPECT
+ Use of comma-less variable list is deprecated at - line 5.
+ Use of comma-less variable list is deprecated at - line 5.
+ Use of comma-less variable list is deprecated at - line 5.
+ ########
+ # toke.c
+ use warnings 'deprecated' ;
+ $a = <<;
+
+ no warnings 'deprecated' ;
+ $a = <<;
+
+ EXPECT
+ Use of bare << to mean <<"" is deprecated at - line 3.
+ ########
+ # toke.c
+ use warnings 'syntax' ;
+ s/(abc)/\1/;
+ no warnings 'syntax' ;
+ s/(abc)/\1/;
+ EXPECT
+ \1 better written as $1 at - line 3.
+ ########
+ # toke.c
+ use warnings 'semicolon' ;
+ $a = 1
+ &time ;
+ no warnings 'semicolon' ;
+ $a = 1
+ &time ;
+ EXPECT
+ Semicolon seems to be missing at - line 3.
+ ########
+ # toke.c
+ use warnings 'syntax' ;
+ my $a =+ 2 ;
+ $a =- 2 ;
+ $a =* 2 ;
+ $a =% 2 ;
+ $a =& 2 ;
+ $a =. 2 ;
+ $a =^ 2 ;
+ $a =| 2 ;
+ $a =< 2 ;
+ $a =/ 2 ;
+ EXPECT
+ Reversed += operator at - line 3.
+ Reversed -= operator at - line 4.
+ Reversed *= operator at - line 5.
+ Reversed %= operator at - line 6.
+ Reversed &= operator at - line 7.
+ Reversed .= operator at - line 8.
+ Reversed ^= operator at - line 9.
+ Reversed |= operator at - line 10.
+ Reversed <= operator at - line 11.
+ syntax error at - line 8, near "=."
+ syntax error at - line 9, near "=^"
+ syntax error at - line 10, near "=|"
+ Unterminated <> operator at - line 11.
+ ########
+ # toke.c
+ no warnings 'syntax' ;
+ my $a =+ 2 ;
+ $a =- 2 ;
+ $a =* 2 ;
+ $a =% 2 ;
+ $a =& 2 ;
+ $a =. 2 ;
+ $a =^ 2 ;
+ $a =| 2 ;
+ $a =< 2 ;
+ $a =/ 2 ;
+ EXPECT
+ syntax error at - line 8, near "=."
+ syntax error at - line 9, near "=^"
+ syntax error at - line 10, near "=|"
+ Unterminated <> operator at - line 11.
+ ########
+ # toke.c
+ use warnings 'syntax' ;
+ my $a = $a[1,2] ;
+ no warnings 'syntax' ;
+ my $a = $a[1,2] ;
+ EXPECT
+ Multidimensional syntax $a[1,2] not supported at - line 3.
+ ########
+ # toke.c
+ use warnings 'syntax' ;
+ sub fred {} ; $SIG{TERM} = fred;
+ no warnings 'syntax' ;
+ $SIG{TERM} = fred;
+ EXPECT
+ You need to quote "fred" at - line 3.
+ ########
+ # toke.c
+ use warnings 'syntax' ;
+ @a[3] = 2;
+ @a{3} = 2;
+ no warnings 'syntax' ;
+ @a[3] = 2;
+ @a{3} = 2;
+ EXPECT
+ Scalar value @a[3] better written as $a[3] at - line 3.
+ Scalar value @a{3} better written as $a{3} at - line 4.
+ ########
+ # toke.c
+ use warnings 'syntax' ;
+ $_ = "ab" ;
+ s/(ab)/\1/e;
+ no warnings 'syntax' ;
+ $_ = "ab" ;
+ s/(ab)/\1/e;
+ EXPECT
+ Can't use \1 to mean $1 in expression at - line 4.
+ ########
+ # toke.c
+ use warnings 'reserved' ;
+ $a = abc;
+ $a = { def
+
+ => 1 };
+ no warnings 'reserved' ;
+ $a = abc;
+ EXPECT
+ Unquoted string "abc" may clash with future reserved word at - line 3.
+ ########
+ # toke.c
+ use warnings 'qw' ;
+ @a = qw(a, b, c) ;
+ no warnings 'qw' ;
+ @a = qw(a, b, c) ;
+ EXPECT
+ Possible attempt to separate words with commas at - line 3.
+ ########
+ # toke.c
+ use warnings 'qw' ;
+ @a = qw(a b #) ;
+ no warnings 'qw' ;
+ @a = qw(a b #) ;
+ EXPECT
+ Possible attempt to put comments in qw() list at - line 3.
+ ########
+ # toke.c
+ use warnings 'syntax' ;
+ print ("")
+ EXPECT
+ print (...) interpreted as function at - line 3.
+ ########
+ # toke.c
+ no warnings 'syntax' ;
+ print ("")
+ EXPECT
+
+ ########
+ # toke.c
+ use warnings 'syntax' ;
+ printf ("")
+ EXPECT
+ printf (...) interpreted as function at - line 3.
+ ########
+ # toke.c
+ no warnings 'syntax' ;
+ printf ("")
+ EXPECT
+
+ ########
+ # toke.c
+ use warnings 'syntax' ;
+ sort ("")
+ EXPECT
+ sort (...) interpreted as function at - line 3.
+ ########
+ # toke.c
+ no warnings 'syntax' ;
+ sort ("")
+ EXPECT
+
+ ########
+ # toke.c
+ use warnings 'ambiguous' ;
+ $a = ${time[2]};
+ no warnings 'ambiguous' ;
+ $a = ${time[2]};
+ EXPECT
+ Ambiguous use of ${time[...]} resolved to $time[...] at - line 3.
+ ########
+ # toke.c
+ use warnings 'ambiguous' ;
+ $a = ${time{2}};
+ EXPECT
+ Ambiguous use of ${time{...}} resolved to $time{...} at - line 3.
+ ########
+ # toke.c
+ no warnings 'ambiguous' ;
+ $a = ${time{2}};
+ EXPECT
+
+ ########
+ # toke.c
+ use warnings 'ambiguous' ;
+ $a = ${time} ;
+ no warnings 'ambiguous' ;
+ $a = ${time} ;
+ EXPECT
+ Ambiguous use of ${time} resolved to $time at - line 3.
+ ########
+ # toke.c
+ use warnings 'ambiguous' ;
+ sub fred {}
+ $a = ${fred} ;
+ no warnings 'ambiguous' ;
+ $a = ${fred} ;
+ EXPECT
+ Ambiguous use of ${fred} resolved to $fred at - line 4.
+ ########
+ # toke.c
+ use warnings 'syntax' ;
+ $a = _123; print "$a\n"; #( 3 string)
+ $a = 1_23; print "$a\n";
+ $a = 12_3; print "$a\n";
+ $a = 123_; print "$a\n"; # 6
+ $a = _+123; print "$a\n"; # 7 string)
+ $a = +_123; print "$a\n"; #( 8 string)
+ $a = +1_23; print "$a\n";
+ $a = +12_3; print "$a\n";
+ $a = +123_; print "$a\n"; # 11
+ $a = _-123; print "$a\n"; #(12 string)
+ $a = -_123; print "$a\n"; #(13 string)
+ $a = -1_23; print "$a\n";
+ $a = -12_3; print "$a\n";
+ $a = -123_; print "$a\n"; # 16
+ $a = 123._456; print "$a\n"; # 17
+ $a = 123.4_56; print "$a\n";
+ $a = 123.45_6; print "$a\n";
+ $a = 123.456_; print "$a\n"; # 20
+ $a = +123._456; print "$a\n"; # 21
+ $a = +123.4_56; print "$a\n";
+ $a = +123.45_6; print "$a\n";
+ $a = +123.456_; print "$a\n"; # 24
+ $a = -123._456; print "$a\n"; # 25
+ $a = -123.4_56; print "$a\n";
+ $a = -123.45_6; print "$a\n";
+ $a = -123.456_; print "$a\n"; # 28
+ $a = 123.456E_12; print "$a\n"; # 29
+ $a = 123.456E1_2; print "$a\n";
+ $a = 123.456E12_; print "$a\n"; # 31
+ $a = 123.456E_+12; print "$a\n"; # 32
+ $a = 123.456E+_12; print "$a\n"; # 33
+ $a = 123.456E+1_2; print "$a\n";
+ $a = 123.456E+12_; print "$a\n"; # 35
+ $a = 123.456E_-12; print "$a\n"; # 36
+ $a = 123.456E-_12; print "$a\n"; # 37
+ $a = 123.456E-1_2; print "$a\n";
+ $a = 123.456E-12_; print "$a\n"; # 39
+ $a = 1__23; print "$a\n"; # 40
+ $a = 12.3__4; print "$a\n"; # 41
+ $a = 12.34e1__2; print "$a\n"; # 42
+ no warnings 'syntax' ;
+ $a = _123; print "$a\n";
+ $a = 1_23; print "$a\n";
+ $a = 12_3; print "$a\n";
+ $a = 123_; print "$a\n";
+ $a = _+123; print "$a\n";
+ $a = +_123; print "$a\n";
+ $a = +1_23; print "$a\n";
+ $a = +12_3; print "$a\n";
+ $a = +123_; print "$a\n";
+ $a = _-123; print "$a\n";
+ $a = -_123; print "$a\n";
+ $a = -1_23; print "$a\n";
+ $a = -12_3; print "$a\n";
+ $a = -123_; print "$a\n";
+ $a = 123._456; print "$a\n";
+ $a = 123.4_56; print "$a\n";
+ $a = 123.45_6; print "$a\n";
+ $a = 123.456_; print "$a\n";
+ $a = +123._456; print "$a\n";
+ $a = +123.4_56; print "$a\n";
+ $a = +123.45_6; print "$a\n";
+ $a = +123.456_; print "$a\n";
+ $a = -123._456; print "$a\n";
+ $a = -123.4_56; print "$a\n";
+ $a = -123.45_6; print "$a\n";
+ $a = -123.456_; print "$a\n";
+ $a = 123.456E_12; print "$a\n";
+ $a = 123.456E1_2; print "$a\n";
+ $a = 123.456E12_; print "$a\n";
+ $a = 123.456E_+12; print "$a\n";
+ $a = 123.456E+_12; print "$a\n";
+ $a = 123.456E+1_2; print "$a\n";
+ $a = 123.456E+12_; print "$a\n";
+ $a = 123.456E_-12; print "$a\n";
+ $a = 123.456E-_12; print "$a\n";
+ $a = 123.456E-1_2; print "$a\n";
+ $a = 123.456E-12_; print "$a\n";
+ $a = 1__23; print "$a\n";
+ $a = 12.3__4; print "$a\n";
+ $a = 12.34e1__2; print "$a\n";
+ EXPECT
+ OPTIONS regex
+ Misplaced _ in number at - line 6.
+ Misplaced _ in number at - line 11.
+ Misplaced _ in number at - line 16.
+ Misplaced _ in number at - line 17.
+ Misplaced _ in number at - line 20.
+ Misplaced _ in number at - line 21.
+ Misplaced _ in number at - line 24.
+ Misplaced _ in number at - line 25.
+ Misplaced _ in number at - line 28.
+ Misplaced _ in number at - line 29.
+ Misplaced _ in number at - line 31.
+ Misplaced _ in number at - line 32.
+ Misplaced _ in number at - line 33.
+ Misplaced _ in number at - line 35.
+ Misplaced _ in number at - line 36.
+ Misplaced _ in number at - line 37.
+ Misplaced _ in number at - line 39.
+ Misplaced _ in number at - line 40.
+ Misplaced _ in number at - line 41.
+ Misplaced _ in number at - line 42.
+ _123
+ 123
+ 123
+ 123
+ 123
+ _123
+ 123
+ 123
+ 123
+ -123
+ -_123
+ -123
+ -123
+ -123
+ 123.456
+ 123.456
+ 123.456
+ 123.456
+ 123.456
+ 123.456
+ 123.456
+ 123.456
+ -123.456
+ -123.456
+ -123.456
+ -123.456
+ 123456000000000
+ 123456000000000
+ 123456000000000
+ 123456000000000
+ 123456000000000
+ 123456000000000
+ 123456000000000
+ 1.23456e-0?10
+ 1.23456e-0?10
+ 1.23456e-0?10
+ 1.23456e-0?10
+ 123
+ 12.34
+ 12340000000000
+ _123
+ 123
+ 123
+ 123
+ 123
+ _123
+ 123
+ 123
+ 123
+ -123
+ -_123
+ -123
+ -123
+ -123
+ 123.456
+ 123.456
+ 123.456
+ 123.456
+ 123.456
+ 123.456
+ 123.456
+ 123.456
+ -123.456
+ -123.456
+ -123.456
+ -123.456
+ 123456000000000
+ 123456000000000
+ 123456000000000
+ 123456000000000
+ 123456000000000
+ 123456000000000
+ 123456000000000
+ 1.23456e-0?10
+ 1.23456e-0?10
+ 1.23456e-0?10
+ 1.23456e-0?10
+ 123
+ 12.34
+ 12340000000000
+ ########
+ # toke.c
+ use warnings 'bareword' ;
+ #line 25 "bar"
+ $a = FRED:: ;
+ no warnings 'bareword' ;
+ #line 25 "bar"
+ $a = FRED:: ;
+ EXPECT
+ Bareword "FRED::" refers to nonexistent package at bar line 25.
+ ########
+ # toke.c
+ use warnings 'ambiguous' ;
+ sub time {}
+ my $a = time() ;
+ no warnings 'ambiguous' ;
+ my $b = time() ;
+ EXPECT
+ Ambiguous call resolved as CORE::time(), qualify as such or use & at - line 4.
+ ########
+ # toke.c
+ use warnings ;
+ eval <<'EOE';
+ # line 30 "foo"
+ warn "yelp";
+ {
+ $_ = " \x{123} " ;
+ }
+ EOE
+ EXPECT
+ yelp at foo line 30.
+ ########
+ # toke.c
+ my $a = rand + 4 ;
+ EXPECT
+ Warning: Use of "rand" without parens is ambiguous at - line 2.
+ ########
+ # toke.c
+ $^W = 0 ;
+ my $a = rand + 4 ;
+ {
+ no warnings 'ambiguous' ;
+ $a = rand + 4 ;
+ use warnings 'ambiguous' ;
+ $a = rand + 4 ;
+ }
+ $a = rand + 4 ;
+ EXPECT
+ Warning: Use of "rand" without parens is ambiguous at - line 3.
+ Warning: Use of "rand" without parens is ambiguous at - line 8.
+ Warning: Use of "rand" without parens is ambiguous at - line 10.
+ ########
+ # toke.c
+ sub fred {};
+ -fred ;
+ EXPECT
+ Ambiguous use of -fred resolved as -&fred() at - line 3.
+ ########
+ # toke.c
+ $^W = 0 ;
+ sub fred {} ;
+ -fred ;
+ {
+ no warnings 'ambiguous' ;
+ -fred ;
+ use warnings 'ambiguous' ;
+ -fred ;
+ }
+ -fred ;
+ EXPECT
+ Ambiguous use of -fred resolved as -&fred() at - line 4.
+ Ambiguous use of -fred resolved as -&fred() at - line 9.
+ Ambiguous use of -fred resolved as -&fred() at - line 11.
+ ########
+ # toke.c
+ open FOO || time;
+ EXPECT
+ Precedence problem: open FOO should be open(FOO) at - line 2.
+ ########
+ # toke.c
+ $^W = 0 ;
+ open FOO || time;
+ {
+ no warnings 'precedence' ;
+ open FOO || time;
+ use warnings 'precedence' ;
+ open FOO || time;
+ }
+ open FOO || time;
+ EXPECT
+ Precedence problem: open FOO should be open(FOO) at - line 3.
+ Precedence problem: open FOO should be open(FOO) at - line 8.
+ Precedence problem: open FOO should be open(FOO) at - line 10.
+ ########
+ # toke.c
+ $^W = 0 ;
+ *foo *foo ;
+ {
+ no warnings 'ambiguous' ;
+ *foo *foo ;
+ use warnings 'ambiguous' ;
+ *foo *foo ;
+ }
+ *foo *foo ;
+ EXPECT
+ Operator or semicolon missing before *foo at - line 3.
+ Ambiguous use of * resolved as operator * at - line 3.
+ Operator or semicolon missing before *foo at - line 8.
+ Ambiguous use of * resolved as operator * at - line 8.
+ Operator or semicolon missing before *foo at - line 10.
+ Ambiguous use of * resolved as operator * at - line 10.
+ ########
+ # toke.c
+ use warnings 'misc' ;
+ my $a = "\m" ;
+ no warnings 'misc' ;
+ $a = "\m" ;
+ EXPECT
+ Unrecognized escape \m passed through at - line 3.
+ ########
+ # toke.c
+ use warnings 'portable' ;
+ my $a = 0b011111111111111111111111111111110 ;
+ $a = 0b011111111111111111111111111111111 ;
+ $a = 0b111111111111111111111111111111111 ;
+ $a = 0x0fffffffe ;
+ $a = 0x0ffffffff ;
+ $a = 0x1ffffffff ;
+ $a = 0037777777776 ;
+ $a = 0037777777777 ;
+ $a = 0047777777777 ;
+ no warnings 'portable' ;
+ $a = 0b011111111111111111111111111111110 ;
+ $a = 0b011111111111111111111111111111111 ;
+ $a = 0b111111111111111111111111111111111 ;
+ $a = 0x0fffffffe ;
+ $a = 0x0ffffffff ;
+ $a = 0x1ffffffff ;
+ $a = 0037777777776 ;
+ $a = 0037777777777 ;
+ $a = 0047777777777 ;
+ EXPECT
+ Binary number > 0b11111111111111111111111111111111 non-portable at - line 5.
+ Hexadecimal number > 0xffffffff non-portable at - line 8.
+ Octal number > 037777777777 non-portable at - line 11.
+ ########
+ # toke.c
+ use warnings 'overflow' ;
+ my $a = 0b011111111111111111111111111111110 ;
+ $a = 0b011111111111111111111111111111111 ;
+ $a = 0b10000000000000000000000000000000000000000000000000000000000000000 ;
+ $a = 0x0fffffffe ;
+ $a = 0x0ffffffff ;
+ $a = 0x10000000000000000 ;
+ $a = 0037777777776 ;
+ $a = 0037777777777 ;
+ $a = 002000000000000000000000;
+ no warnings 'overflow' ;
+ $a = 0b011111111111111111111111111111110 ;
+ $a = 0b011111111111111111111111111111111 ;
+ $a = 0b10000000000000000000000000000000000000000000000000000000000000000 ;
+ $a = 0x0fffffffe ;
+ $a = 0x0ffffffff ;
+ $a = 0x10000000000000000 ;
+ $a = 0037777777776 ;
+ $a = 0037777777777 ;
+ $a = 002000000000000000000000;
+ EXPECT
+ Integer overflow in binary number at - line 5.
+ Integer overflow in hexadecimal number at - line 8.
+ Integer overflow in octal number at - line 11.
+ ########
+ # toke.c
+ use warnings 'ambiguous';
+ "@mjd_previously_unused_array";
+ no warnings 'ambiguous';
+ "@mjd_previously_unused_array";
+ EXPECT
+ Possible unintended interpolation of @mjd_previously_unused_array in string at - line 3.
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/universal'
Index: ./t/lib/warnings/universal
*** ./t/lib/warnings/universal Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/universal Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,14 ----
+ universal.c AOK
+
+ Can't locate package %s for @%s::ISA [S_isa_lookup]
+
+
+
+ __END__
+ # universal.c [S_isa_lookup]
+ use warnings 'misc' ;
+ @ISA = qw(Joe) ;
+ my $a = bless [] ;
+ UNIVERSAL::isa $a, Jim ;
+ EXPECT
+ Can't locate package Joe for @main::ISA at - line 5.
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/utf8'
Index: ./t/lib/warnings/utf8
*** ./t/lib/warnings/utf8 Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/utf8 Mon Jul 9 17:11:25 2001
***************
*** 0 ****
--- 1,35 ----
+
+ utf8.c AOK
+
+ [utf8_to_uv]
+ Malformed UTF-8 character
+ my $a = ord "\x80" ;
+
+ Malformed UTF-8 character
+ my $a = ord "\xf080" ;
+ <<<<<< this warning can't be easily triggered from perl anymore
+
+ [utf16_to_utf8]
+ Malformed UTF-16 surrogate
+ <<<<<< Add a test when somethig actually calls utf16_to_utf8
+
+ __END__
+ # utf8.c [utf8_to_uv] -W
+ BEGIN {
+ if (ord('A') == 193) {
+ print "SKIPPED\n# ebcdic platforms do not generate Malformed UTF-8 warnings.";
+ exit 0;
+ }
+ }
+ use utf8 ;
+ my $a = "sn�storm" ;
+ {
+ no warnings 'utf8' ;
+ my $a = "sn�storm";
+ use warnings 'utf8' ;
+ my $a = "sn�storm";
+ }
+ EXPECT
+ Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 9.
+ Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 14.
+ ########
diff -c /dev/null 'perl-5.7.2/t/lib/warnings/util'
Index: ./t/lib/warnings/util
*** ./t/lib/warnings/util Thu Jan 1 02:00:00 1970
--- ./t/lib/warnings/util Thu Jul 12 16:54:38 2001
***************
*** 0 ****
--- 1,158 ----
+ util.c AOK
+
+ Illegal octal digit ignored
+ my $a = oct "029" ;
+
+ Illegal hex digit ignored
+ my $a = hex "0xv9" ;
+
+ Illegal binary digit ignored
+ my $a = oct "0b9" ;
+
+ Integer overflow in binary number
+ my $a = oct "0b111111111111111111111111111111111111111111" ;
+ Binary number > 0b11111111111111111111111111111111 non-portable
+ $a = oct "0b111111111111111111111111111111111" ;
+ Integer overflow in octal number
+ my $a = oct "077777777777777777777777777777" ;
+ Octal number > 037777777777 non-portable
+ $a = oct "0047777777777" ;
+ Integer overflow in hexadecimal number
+ my $a = hex "0xffffffffffffffffffff" ;
+ Hexadecimal number > 0xffffffff non-portable
+ $a = hex "0x1ffffffff" ;
+
+ __END__
+ # util.c
+ use warnings 'digit' ;
+ my $a = oct "029" ;
+ no warnings 'digit' ;
+ $a = oct "029" ;
+ EXPECT
+ Illegal octal digit '9' ignored at - line 3.
+ ########
+ # util.c
+ use warnings 'digit' ;
+ my $a = hex "0xv9" ;
+ no warnings 'digit' ;
+ $a = hex "0xv9" ;
+ EXPECT
+ Illegal hexadecimal digit 'v' ignored at - line 3.
+ ########
+ # util.c
+ use warnings 'digit' ;
+ my $a = oct "0b9" ;
+ no warnings 'digit' ;
+ $a = oct "0b9" ;
+ EXPECT
+ Illegal binary digit '9' ignored at - line 3.
+ ########
+ # util.c
+ use warnings 'overflow' ;
+ my $a = oct "0b11111111111111111111111111111111111111111111111111111111111111111";
+ no warnings 'overflow' ;
+ $a = oct "0b11111111111111111111111111111111111111111111111111111111111111111";
+ EXPECT
+ Integer overflow in binary number at - line 3.
+ ########
+ # util.c
+ use warnings 'overflow' ;
+ my $a = hex "0xffffffffffffffffffff" ;
+ no warnings 'overflow' ;
+ $a = hex "0xffffffffffffffffffff" ;
+ EXPECT
+ Integer overflow in hexadecimal number at - line 3.
+ ########
+ # util.c
+ use warnings 'overflow' ;
+ my $a = oct "077777777777777777777777777777" ;
+ no warnings 'overflow' ;
+ $a = oct "077777777777777777777777777777" ;
+ EXPECT
+ Integer overflow in octal number at - line 3.
+ ########
+ # util.c
+ use warnings 'portable' ;
+ my $a = oct "0b011111111111111111111111111111110" ;
+ $a = oct "0b011111111111111111111111111111111" ;
+ $a = oct "0b111111111111111111111111111111111" ;
+ no warnings 'portable' ;
+ $a = oct "0b011111111111111111111111111111110" ;
+ $a = oct "0b011111111111111111111111111111111" ;
+ $a = oct "0b111111111111111111111111111111111" ;
+ EXPECT
+ Binary number > 0b11111111111111111111111111111111 non-portable at - line 5.
+ ########
+ # util.c
+ use warnings 'portable' ;
+ my $a = hex "0x0fffffffe" ;
+ $a = hex "0x0ffffffff" ;
+ $a = hex "0x1ffffffff" ;
+ no warnings 'portable' ;
+ $a = hex "0x0fffffffe" ;
+ $a = hex "0x0ffffffff" ;
+ $a = hex "0x1ffffffff" ;
+ EXPECT
+ Hexadecimal number > 0xffffffff non-portable at - line 5.
+ ########
+ # util.c
+ use warnings 'portable' ;
+ my $a = oct "0037777777776" ;
+ $a = oct "0037777777777" ;
+ $a = oct "0047777777777" ;
+ no warnings 'portable' ;
+ $a = oct "0037777777776" ;
+ $a = oct "0037777777777" ;
+ $a = oct "0047777777777" ;
+ EXPECT
+ Octal number > 037777777777 non-portable at - line 5.
+ ########
+ # util.c
+ use warnings;
+ $x = 1;
+ if ($x) {
+ print $y;
+ }
+ EXPECT
+ Name "main::y" used only once: possible typo at - line 5.
+ Use of uninitialized value in print at - line 5.
+ ########
+ # util.c
+ use warnings;
+ $x = 1;
+ if ($x) {
+ $x++;
+ print $y;
+ }
+ EXPECT
+ Name "main::y" used only once: possible typo at - line 6.
+ Use of uninitialized value in print at - line 6.
+ ########
+ # util.c
+ use warnings;
+ $x = 0;
+ if ($x) {
+ print "1\n";
+ } elsif (!$x) {
+ print $y;
+ } else {
+ print "0\n";
+ }
+ EXPECT
+ Name "main::y" used only once: possible typo at - line 7.
+ Use of uninitialized value in print at - line 7.
+ ########
+ # util.c
+ use warnings;
+ $x = 0;
+ if ($x) {
+ print "1\n";
+ } elsif (!$x) {
+ $x++;
+ print $y;
+ } else {
+ print "0\n";
+ }
+ EXPECT
+ Name "main::y" used only once: possible typo at - line 8.
+ Use of uninitialized value in print at - line 8.
diff -c 'perl-5.7.1/t/op/anonsub.t' 'perl-5.7.2/t/op/anonsub.t'
Index: ./t/op/anonsub.t
*** ./t/op/anonsub.t Mon Mar 12 17:57:37 2001
--- ./t/op/anonsub.t Mon Jul 9 17:11:25 2001
***************
*** 4,9 ****
--- 4,11 ----
@INC = '../lib';
$Is_VMS = $^O eq 'VMS';
$Is_MSWin32 = $^O eq 'MSWin32';
+ $Is_MacOS = $^O eq 'MacOS';
+ $Is_NetWare = $^O eq 'NetWare';
$ENV{PERL5LIB} = "../lib" unless $Is_VMS;
$|=1;
***************
*** 26,35 ****
print TEST "$prog\n";
close TEST;
my $results = $Is_VMS ?
! `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` :
! $Is_MSWin32 ?
! `.\\perl -I../lib $switch $tmpfile 2>&1` :
! `./perl $switch $tmpfile 2>&1`;
my $status = $?;
$results =~ s/\n+$//;
# allow expected output to be written as if $prog is on STDIN
--- 28,41 ----
print TEST "$prog\n";
close TEST;
my $results = $Is_VMS ?
! `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` :
! $Is_MSWin32 ?
! `.\\perl -I../lib $switch $tmpfile 2>&1` :
! $Is_MacOS ?
! `$^X -I::lib $switch $tmpfile` :
! $Is_NetWare ?
! `perl -I../lib $switch $tmpfile 2>&1` :
! `./perl $switch $tmpfile 2>&1`;
my $status = $?;
$results =~ s/\n+$//;
# allow expected output to be written as if $prog is on STDIN
diff -c 'perl-5.7.1/t/op/append.t' 'perl-5.7.2/t/op/append.t'
Index: ./t/op/append.t
*** ./t/op/append.t Tue Mar 6 04:07:04 2001
--- ./t/op/append.t Mon Jul 9 17:11:25 2001
***************
*** 43,59 ****
my $t1 = $a; $t1 .= $ab;
print $t1 =~ /\142/ ? "ok 6\n" : "not ok 6\t# $t1\n";
my $t2 = $a; $t2 .= $ub;
! print $t2 =~ /\142/ ? "ok 7\n" : "not ok 7\t# $t2\n";
my $t3 = $u; $t3 .= $ab;
print $t3 =~ /\142/ ? "ok 8\n" : "not ok 8\t# $t3\n";
my $t4 = $u; $t4 .= $ub;
! print $t4 =~ /\142/ ? "ok 9\n" : "not ok 9\t# $t4\n";
my $t5 = $a; $t5 = $ab . $t5;
print $t5 =~ /\142/ ? "ok 10\n" : "not ok 10\t# $t5\n";
my $t6 = $a; $t6 = $ub . $t6;
! print $t6 =~ /\142/ ? "ok 11\n" : "not ok 11\t# $t6\n";
my $t7 = $u; $t7 = $ab . $t7;
print $t7 =~ /\142/ ? "ok 12\n" : "not ok 12\t# $t7\n";
my $t8 = $u; $t8 = $ub . $t8;
! print $t8 =~ /\142/ ? "ok 13\n" : "not ok 13\t# $t8\n";
}
--- 43,80 ----
my $t1 = $a; $t1 .= $ab;
print $t1 =~ /\142/ ? "ok 6\n" : "not ok 6\t# $t1\n";
my $t2 = $a; $t2 .= $ub;
! if (ord('A') == 193) {
! # print $t2 eq "\141\141\000" ? "ok 7\n" : "not ok 7\t# $t2\n";
! print $t2 =~ /\141/ ? "ok 7\n" : "not ok 7\t# $t2\n";
! }
! else {
! print $t2 =~ /\142/ ? "ok 7\n" : "not ok 7\t# $t2\n";
! }
my $t3 = $u; $t3 .= $ab;
print $t3 =~ /\142/ ? "ok 8\n" : "not ok 8\t# $t3\n";
my $t4 = $u; $t4 .= $ub;
! if (ord('A') == 193) {
! print $t4 =~ /\141/ ? "ok 9\n" : "not ok 9\t# $t4\n";
! }
! else {
! print $t4 =~ /\142/ ? "ok 9\n" : "not ok 9\t# $t4\n";
! }
my $t5 = $a; $t5 = $ab . $t5;
print $t5 =~ /\142/ ? "ok 10\n" : "not ok 10\t# $t5\n";
my $t6 = $a; $t6 = $ub . $t6;
! if (ord('A') == 193) {
! print $t6 =~ /\141/ ? "ok 11\n" : "not ok 11\t# $t6\n";
! }
! else {
! print $t6 =~ /\142/ ? "ok 11\n" : "not ok 11\t# $t6\n";
! }
my $t7 = $u; $t7 = $ab . $t7;
print $t7 =~ /\142/ ? "ok 12\n" : "not ok 12\t# $t7\n";
my $t8 = $u; $t8 = $ub . $t8;
! if (ord('A') == 193) {
! print $t8 =~ /\141/ ? "ok 13\n" : "not ok 13\t# $t8\n";
! }
! else {
! print $t8 =~ /\142/ ? "ok 13\n" : "not ok 13\t# $t8\n";
! }
}
diff -c 'perl-5.7.1/t/op/avhv.t' 'perl-5.7.2/t/op/avhv.t'
Index: ./t/op/avhv.t
*** ./t/op/avhv.t Tue Mar 6 04:07:04 2001
--- ./t/op/avhv.t Mon Jul 9 17:11:26 2001
***************
*** 17,23 ****
package main;
! print "1..28\n";
$sch = {
'abc' => 1,
--- 17,23 ----
package main;
! print "1..29\n";
$sch = {
'abc' => 1,
***************
*** 176,178 ****
--- 176,184 ----
(@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!");
print "not " unless ref $avhv->[0] eq 'HASH' and @extra == 6;
print "ok 28\n";
+
+ # Check hash slices (BUG ID 20010423.002)
+ $avhv = [{foo=>1, bar=>2}];
+ @$avhv{"foo", "bar"} = (42, 53);
+ print "not " unless $avhv->{foo} == 42 && $avhv->{bar} == 53;
+ print "ok 29\n";
diff -c 'perl-5.7.1/t/op/chop.t' 'perl-5.7.2/t/op/chop.t'
Index: ./t/op/chop.t
*** ./t/op/chop.t Wed Mar 7 16:49:46 2001
--- ./t/op/chop.t Mon Jul 9 17:11:26 2001
***************
*** 1,6 ****
#!./perl
! print "1..37\n";
# optimized
--- 1,6 ----
#!./perl
! print "1..41\n";
# optimized
***************
*** 116,118 ****
--- 116,128 ----
my %stuff = (1..4);
print chop(@stuff{1, 3}) eq '4' ? "ok 37\n" : "not ok 37\n";
+
+ # chomp should not stringify references unless it decides to modify them
+ $_ = [];
+ $/ = "\n";
+ print chomp() == 0 ? "ok 38\n" : "not ok 38\n";
+ print ref($_) eq "ARRAY" ? "ok 39\n" : "not ok 39\n";
+
+ $/ = ")"; # the last char of something like "ARRAY(0x80ff6e4)"
+ print chomp() == 1 ? "ok 40\n" : "not ok 40\n";
+ print !ref($_) ? "ok 41\n" : "not ok 41\n";
diff -c 'perl-5.7.1/t/op/closure.t' 'perl-5.7.2/t/op/closure.t'
Index: ./t/op/closure.t
*** ./t/op/closure.t Tue Mar 6 04:07:05 2001
--- ./t/op/closure.t Mon Jul 9 17:11:26 2001
***************
*** 429,435 ****
$test++;
}
! if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32') {
# Fork off a new perl to run the tests.
# (This is so we can catch spurious warnings.)
$| = 1; print ""; $| = 0; # flush output before forking
--- 429,435 ----
$test++;
}
! if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32' and $^O ne 'NetWare') {
# Fork off a new perl to run the tests.
# (This is so we can catch spurious warnings.)
$| = 1; print ""; $| = 0; # flush output before forking
***************
*** 465,473 ****
open CMD, ">$cmdfile"; print CMD $code; close CMD;
my $cmd = (($^O eq 'VMS') ? "MCR $^X"
: ($^O eq 'MSWin32') ? '.\perl'
: './perl');
$cmd .= " -w $cmdfile 2>$errfile";
! if ($^O eq 'VMS' or $^O eq 'MSWin32') {
# Use pipe instead of system so we don't inherit STD* from
# this process, and then foul our pipe back to parent by
# redirecting output in the child.
--- 465,475 ----
open CMD, ">$cmdfile"; print CMD $code; close CMD;
my $cmd = (($^O eq 'VMS') ? "MCR $^X"
: ($^O eq 'MSWin32') ? '.\perl'
+ : ($^O eq 'MacOS') ? $^X
+ : ($^O eq 'NetWare') ? 'perl'
: './perl');
$cmd .= " -w $cmdfile 2>$errfile";
! if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') {
# Use pipe instead of system so we don't inherit STD* from
# this process, and then foul our pipe back to parent by
# redirecting output in the child.
diff -c 'perl-5.7.1/t/op/cmp.t' 'perl-5.7.2/t/op/cmp.t'
Index: ./t/op/cmp.t
*** ./t/op/cmp.t Tue Mar 27 00:43:12 2001
--- ./t/op/cmp.t Mon Jul 9 17:11:26 2001
***************
*** 37,42 ****
--- 37,48 ----
$expect = 6 * ($#FOO+2) * ($#FOO+1);
print "1..$expect\n";
+ sub nok ($$$$$$$$) {
+ my ($test, $left, $threeway, $right, $result, $i, $j, $boolean) = @_;
+ $result = defined $result ? "'$result'" : 'undef';
+ print "not ok $test # ($left <=> $right) gives: $result \$i=$i \$j=$j, $boolean disagrees\n";
+ }
+
my $ok = 0;
for my $i (0..$#FOO) {
for my $j ($i..$#FOO) {
***************
*** 62,68 ****
print "ok $ok\n";
}
else {
! print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, < disagrees\n";
}
$ok++;
if (!defined($cmp) ? !($i4 == $j4)
--- 68,74 ----
print "ok $ok\n";
}
else {
! nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<');
}
$ok++;
if (!defined($cmp) ? !($i4 == $j4)
***************
*** 73,79 ****
print "ok $ok\n";
}
else {
! print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, == disagrees\n";
}
$ok++;
if (!defined($cmp) ? !($i5 > $j5)
--- 79,85 ----
print "ok $ok\n";
}
else {
! nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '==');
}
$ok++;
if (!defined($cmp) ? !($i5 > $j5)
***************
*** 84,90 ****
print "ok $ok\n";
}
else {
! print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, > disagrees\n";
}
$ok++;
if (!defined($cmp) ? !($i6 >= $j6)
--- 90,96 ----
print "ok $ok\n";
}
else {
! nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '>');
}
$ok++;
if (!defined($cmp) ? !($i6 >= $j6)
***************
*** 95,101 ****
print "ok $ok\n";
}
else {
! print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, >= disagrees\n";
}
$ok++;
# OK, so the docs are wrong it seems. NaN != NaN
--- 101,107 ----
print "ok $ok\n";
}
else {
! nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '>=');
}
$ok++;
# OK, so the docs are wrong it seems. NaN != NaN
***************
*** 107,113 ****
print "ok $ok\n";
}
else {
! print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, != disagrees\n";
}
$ok++;
if (!defined($cmp) ? !($i8 <= $j8)
--- 113,119 ----
print "ok $ok\n";
}
else {
! nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '!=');
}
$ok++;
if (!defined($cmp) ? !($i8 <= $j8)
***************
*** 118,124 ****
print "ok $ok\n";
}
else {
! print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, <= disagrees\n";
}
$ok++;
$cmp = $i9 cmp $j9;
--- 124,130 ----
print "ok $ok\n";
}
else {
! nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<=');
}
$ok++;
$cmp = $i9 cmp $j9;
***************
*** 129,135 ****
print "ok $ok\n";
}
else {
! print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, lt disagrees\n";
}
$ok++;
if ($cmp == -1 && !($i11 eq $j11) ||
--- 135,141 ----
print "ok $ok\n";
}
else {
! nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'lt');
}
$ok++;
if ($cmp == -1 && !($i11 eq $j11) ||
***************
*** 139,145 ****
print "ok $ok\n";
}
else {
! print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, eq disagrees\n";
}
$ok++;
if ($cmp == -1 && !($i12 gt $j12) ||
--- 145,151 ----
print "ok $ok\n";
}
else {
! nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'eq');
}
$ok++;
if ($cmp == -1 && !($i12 gt $j12) ||
***************
*** 149,155 ****
print "ok $ok\n";
}
else {
! print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, gt disagrees\n";
}
$ok++;
if ($cmp == -1 && $i13 le $j13 ||
--- 155,161 ----
print "ok $ok\n";
}
else {
! nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'gt');
}
$ok++;
if ($cmp == -1 && $i13 le $j13 ||
***************
*** 159,165 ****
print "ok $ok\n";
}
else {
! print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, le disagrees\n";
}
$ok++;
if ($cmp == -1 && ($i14 ne $j14) ||
--- 165,171 ----
print "ok $ok\n";
}
else {
! nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'le');
}
$ok++;
if ($cmp == -1 && ($i14 ne $j14) ||
***************
*** 169,175 ****
print "ok $ok\n";
}
else {
! print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, ne disagrees\n";
}
$ok++;
if ($cmp == -1 && !($i15 ge $j15) ||
--- 175,181 ----
print "ok $ok\n";
}
else {
! nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'ne');
}
$ok++;
if ($cmp == -1 && !($i15 ge $j15) ||
***************
*** 179,185 ****
print "ok $ok\n";
}
else {
! print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, ge disagrees\n";
}
}
}
--- 185,191 ----
print "ok $ok\n";
}
else {
! nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'ge');
}
}
}
diff -c 'perl-5.7.1/t/op/defins.t' 'perl-5.7.2/t/op/defins.t'
Index: ./t/op/defins.t
*** ./t/op/defins.t Tue Mar 6 04:07:05 2001
--- ./t/op/defins.t Mon Jul 9 17:11:26 2001
***************
*** 12,27 ****
}
$wanted_filename = $^O eq 'VMS' ? '0.' : '0';
print "not " if $warns;
print "ok 1\n";
! open(FILE,">./0");
print FILE "1\n";
print FILE "0";
close(FILE);
! open(FILE,"<./0");
my $seen = 0;
my $dummy;
while (my $name = <FILE>)
--- 12,28 ----
}
$wanted_filename = $^O eq 'VMS' ? '0.' : '0';
+ $saved_filename = $^O eq 'MacOS' ? ':0' : './0';
print "not " if $warns;
print "ok 1\n";
! open(FILE,">$saved_filename");
print FILE "1\n";
print FILE "0";
close(FILE);
! open(FILE,"<$saved_filename");
my $seen = 0;
my $dummy;
while (my $name = <FILE>)
***************
*** 63,69 ****
print "ok 5\n";
close FILE;
! opendir(DIR,'.');
$seen = 0;
while (my $name = readdir(DIR))
{
--- 64,70 ----
print "ok 5\n";
close FILE;
! opendir(DIR,($^O eq 'MacOS' ? ':' : '.'));
$seen = 0;
while (my $name = readdir(DIR))
{
***************
*** 116,122 ****
print "not " unless $seen;
print "ok 11\n";
! unlink("./0");
my %hash = (0 => 1, 1 => 2);
--- 117,123 ----
print "not " unless $seen;
print "ok 11\n";
! unlink($saved_filename);
my %hash = (0 => 1, 1 => 2);
diff -c 'perl-5.7.1/t/op/die_exit.t' 'perl-5.7.2/t/op/die_exit.t'
Index: ./t/op/die_exit.t
*** ./t/op/die_exit.t Tue Mar 6 04:07:05 2001
--- ./t/op/die_exit.t Mon Jul 9 17:11:26 2001
***************
*** 15,20 ****
--- 15,22 ----
exit 0;
}
+ $| = 1;
+
my $perl = -e '../perl' ? '../perl' : -e './perl' ? './perl' : 'perl';
use strict;
***************
*** 48,54 ****
my($bang, $query, $code) = @{$tests{$test}};
$code ||= 'die;';
my $exit =
! ($^O eq 'MSWin32'
? system qq($perl -e "\$! = $bang; \$? = $query; $code" 2> nul)
: system qq($perl -e '\$! = $bang; \$? = $query; $code' 2> /dev/null));
--- 50,56 ----
my($bang, $query, $code) = @{$tests{$test}};
$code ||= 'die;';
my $exit =
! (($^O eq 'MSWin32' || $^O eq 'NetWare')
? system qq($perl -e "\$! = $bang; \$? = $query; $code" 2> nul)
: system qq($perl -e '\$! = $bang; \$? = $query; $code' 2> /dev/null));
diff -c 'perl-5.7.1/t/op/eval.t' 'perl-5.7.2/t/op/eval.t'
Index: ./t/op/eval.t
*** ./t/op/eval.t Wed Mar 14 04:54:04 2001
--- ./t/op/eval.t Mon Jul 9 17:11:26 2001
***************
*** 99,105 ****
$x++;
do_eval1('eval q[print "ok $x\n"]');
$x++;
! do_eval1('sub { eval q[print "ok $x\n"] }->()');
$x++;
# calls from within eval'' should clone outer lexicals
--- 99,105 ----
$x++;
do_eval1('eval q[print "ok $x\n"]');
$x++;
! do_eval1('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
$x++;
# calls from within eval'' should clone outer lexicals
***************
*** 112,118 ****
$x++;
do_eval2('eval q[print "ok $x\n"]');
$x++;
! do_eval2('sub { eval q[print "ok $x\n"] }->()');
$x++;
EOT
--- 112,118 ----
$x++;
do_eval2('eval q[print "ok $x\n"]');
$x++;
! do_eval2('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
$x++;
EOT
diff -c 'perl-5.7.1/t/op/exec.t' 'perl-5.7.2/t/op/exec.t'
Index: ./t/op/exec.t
*** ./t/op/exec.t Tue Mar 6 04:07:06 2001
--- ./t/op/exec.t Mon Jul 9 17:11:26 2001
***************
*** 5,13 ****
$ENV{LC_ALL} = 'C'; # Forge English error messages.
$ENV{LANGUAGE} = 'C'; # Ditto in GNU.
! if ($^O eq 'MSWin32') {
# XXX the system tests could be written to use ./perl and so work on Win32
print "1..0 # Skip: shh, win32\n";
exit(0);
}
--- 5,19 ----
$ENV{LC_ALL} = 'C'; # Forge English error messages.
$ENV{LANGUAGE} = 'C'; # Ditto in GNU.
! if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
# XXX the system tests could be written to use ./perl and so work on Win32
print "1..0 # Skip: shh, win32\n";
+ exit(0);
+ }
+
+ if ($^O eq 'MacOS') {
+ # XXX the system tests could be written to use ./perl and so work on Win32
+ print "1..0 # Mostly useless tests for Mac OS\n";
exit(0);
}
diff -c 'perl-5.7.1/t/op/fork.t' 'perl-5.7.2/t/op/fork.t'
Index: ./t/op/fork.t
*** ./t/op/fork.t Tue Mar 6 04:07:06 2001
--- ./t/op/fork.t Mon Jul 9 17:11:26 2001
***************
*** 7,13 ****
@INC = '../lib';
require Config; import Config;
unless ($Config{'d_fork'}
! or ($^O eq 'MSWin32' and $Config{useithreads}
and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
# and !defined $Config{'useperlio'}
))
--- 7,13 ----
@INC = '../lib';
require Config; import Config;
unless ($Config{'d_fork'}
! or (($^O eq 'MSWin32' || $^O eq 'NetWare') and $Config{useithreads}
and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
# and !defined $Config{'useperlio'}
))
***************
*** 33,39 ****
1 while -f ++$tmpfile;
END { close TEST; unlink $tmpfile if $tmpfile; }
! $CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat');
for (@prgs){
my $switch;
--- 33,39 ----
1 while -f ++$tmpfile;
END { close TEST; unlink $tmpfile if $tmpfile; }
! $CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : (($^O eq 'NetWare') ? 'perl -e "print <>"' : 'cat'));
for (@prgs){
my $switch;
***************
*** 51,56 ****
--- 51,59 ----
if ($^O eq 'MSWin32') {
$results = `.\\perl -I../lib $switch $tmpfile 2>&1`;
}
+ elsif ($^O eq 'NetWare') {
+ $results = `perl -I../lib $switch $tmpfile 2>&1`;
+ }
else {
$results = `./perl $switch $tmpfile 2>&1`;
}
***************
*** 255,261 ****
$| = 1;
$\ = "\n";
my $getenv;
! if ($^O eq 'MSWin32') {
$getenv = qq[$^X -e "print \$ENV{TST}"];
}
else {
--- 258,264 ----
$| = 1;
$\ = "\n";
my $getenv;
! if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
$getenv = qq[$^X -e "print \$ENV{TST}"];
}
else {
diff -c 'perl-5.7.1/t/op/glob.t' 'perl-5.7.2/t/op/glob.t'
Index: ./t/op/glob.t
*** ./t/op/glob.t Tue Mar 6 04:07:06 2001
--- ./t/op/glob.t Mon Jul 9 17:11:26 2001
***************
*** 5,11 ****
@INC = '../lib';
}
! print "1..6\n";
@oops = @ops = <op/*>;
--- 5,11 ----
@INC = '../lib';
}
! print "1..10\n";
@oops = @ops = <op/*>;
***************
*** 38,40 ****
--- 38,58 ----
@glops = glob;
print "@glops" eq "@oops" ? "ok 6\n" : "not ok 6\n";
+
+ # glob should still work even after the File::Glob stash has gone away
+ # (this used to dump core)
+ my $i = 0;
+ for (1..2) {
+ eval "<.>";
+ undef %File::Glob::;
+ ++$i;
+ }
+ print $i == 2 ? "ok 7\n" : "not ok 7\n";
+
+ # [ID 20010526.001] localized glob loses value when assigned to
+
+ $j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{};
+
+ print $j == 1 ? "ok 8\n" : "not ok 8\n";
+ print $j{a} == 1 ? "ok 9\n" : "not ok 9\n";
+ print $j[0] == 1 ? "ok 10\n" : "not ok 10\n";
diff -c /dev/null 'perl-5.7.2/t/op/gmagic.t'
Index: ./t/op/gmagic.t
*** ./t/op/gmagic.t Thu Jan 1 02:00:00 1970
--- ./t/op/gmagic.t Mon Jul 9 17:11:27 2001
***************
*** 0 ****
--- 1,83 ----
+ #!./perl -w
+
+ BEGIN {
+ $| = 1;
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ print "1..18\n";
+
+ my $t = 1;
+ tie my $c => 'Tie::Monitor';
+
+ sub ok {
+ my($ok, $got, $exp, $rexp, $wexp) = @_;
+ my($rgot, $wgot) = (tied $c)->init(0);
+ print $ok ? "ok $t\n" : "# expected $exp, got $got\nnot ok $t\n";
+ ++$t;
+ if ($rexp == $rgot && $wexp == $wgot) {
+ print "ok $t\n";
+ } else {
+ print "# read $rgot expecting $rexp\n" if $rgot != $rexp;
+ print "# wrote $wgot expecting $wexp\n" if $wgot != $wexp;
+ print "not ok $t\n";
+ }
+ ++$t;
+ }
+
+ sub ok_undef { ok(!defined($_[0]), shift, "undef", @_) }
+ sub ok_numeric { ok($_[0] == $_[1], @_) }
+ sub ok_string { ok($_[0] eq $_[1], @_) }
+
+ my($r, $s);
+ # the thing itself
+ ok_numeric($r = $c + 0, 0, 1, 0);
+ ok_string($r = "$c", '0', 1, 0);
+
+ # concat
+ ok_string($c . 'x', '0x', 1, 0);
+ ok_string('x' . $c, 'x0', 1, 0);
+ $s = $c . $c;
+ ok_string($s, '00', 2, 0);
+ $r = 'x';
+ $s = $c = $r . 'y';
+ ok_string($s, 'xy', 1, 1);
+ $s = $c = $c . 'x';
+ ok_string($s, '0x', 2, 1);
+ $s = $c = 'x' . $c;
+ ok_string($s, 'x0', 2, 1);
+ $s = $c = $c . $c;
+ ok_string($s, '00', 3, 1);
+
+ # adapted from Tie::Counter by Abigail
+ package Tie::Monitor;
+
+ sub TIESCALAR {
+ my($class, $value) = @_;
+ bless {
+ read => 0,
+ write => 0,
+ values => [ 0 ],
+ };
+ }
+
+ sub FETCH {
+ my $self = shift;
+ ++$self->{read};
+ $self->{values}[$#{ $self->{values} }];
+ }
+
+ sub STORE {
+ my($self, $value) = @_;
+ ++$self->{write};
+ push @{ $self->{values} }, $value;
+ }
+
+ sub init {
+ my $self = shift;
+ my @results = ($self->{read}, $self->{write});
+ $self->{read} = $self->{write} = 0;
+ $self->{values} = [ 0 ];
+ @results;
+ }
diff -c 'perl-5.7.1/t/op/goto.t' 'perl-5.7.2/t/op/goto.t'
Index: ./t/op/goto.t
*** ./t/op/goto.t Wed Mar 14 06:46:31 2001
--- ./t/op/goto.t Mon Jul 9 17:11:27 2001
***************
*** 29,35 ****
print "#2\t:$foo: == 4\n";
if ($foo == 4) {print "ok 2\n";} else {print "not ok 2\n";}
! $PERL = ($^O eq 'MSWin32') ? '.\perl' : './perl';
$CMD = qq[$PERL -e "goto foo;" 2>&1 ];
$x = `$CMD`;
--- 29,35 ----
print "#2\t:$foo: == 4\n";
if ($foo == 4) {print "ok 2\n";} else {print "not ok 2\n";}
! $PERL = ($^O eq 'MSWin32') ? '.\perl' : ($^O eq 'MacOS') ? $^X : ($^O eq 'NetWare') ? 'perl' : './perl';
$CMD = qq[$PERL -e "goto foo;" 2>&1 ];
$x = `$CMD`;
diff -c 'perl-5.7.1/t/op/grent.t' 'perl-5.7.2/t/op/grent.t'
Index: ./t/op/grent.t
*** ./t/op/grent.t Tue Mar 6 04:07:06 2001
--- ./t/op/grent.t Mon Jul 9 17:11:27 2001
***************
*** 67,73 ****
--- 67,76 ----
my %perfect;
my %seen;
+ print "# where $where\n";
+
setgrent();
+
while (<GR>) {
chomp;
# LIMIT -1 so that groups with no users don't fall off
***************
*** 115,121 ****
endgrent();
! if (keys %perfect == 0) {
$max++;
print <<EOEX;
#
--- 118,126 ----
endgrent();
! print "# max = $max, n = $n, perfect = ", scalar keys %perfect, "\n";
!
! if (keys %perfect == 0 && $n) {
$max++;
print <<EOEX;
#
diff -c 'perl-5.7.1/t/op/groups.t' 'perl-5.7.2/t/op/groups.t'
Index: ./t/op/groups.t
*** ./t/op/groups.t Tue Mar 6 04:07:06 2001
--- ./t/op/groups.t Mon Jul 9 17:11:27 2001
***************
*** 10,16 ****
exit 0;
}
! quit() if $^O eq 'MSWin32' or $^O =~ /lynxos/i;
# We have to find a command that prints all (effective
# and real) group names (not ids). The known commands are:
--- 10,16 ----
exit 0;
}
! quit() if (($^O eq 'MSWin32' || $^O eq 'NetWare') or $^O =~ /lynxos/i);
# We have to find a command that prints all (effective
# and real) group names (not ids). The known commands are:
diff -c 'perl-5.7.1/t/op/lex_assign.t' 'perl-5.7.2/t/op/lex_assign.t'
Index: ./t/op/lex_assign.t
*** ./t/op/lex_assign.t Sun Mar 18 20:54:02 2001
--- ./t/op/lex_assign.t Mon Jul 9 17:11:27 2001
***************
*** 5,10 ****
--- 5,11 ----
@INC = '../lib';
}
+ $| = 1;
umask 0;
$xref = \ "";
$runme = ($^O eq 'VMS' ? 'MCR ' : '') . $^X;
diff -c 'perl-5.7.1/t/op/lfs.t' 'perl-5.7.2/t/op/lfs.t'
Index: ./t/op/lfs.t
*** ./t/op/lfs.t Tue Mar 6 04:07:12 2001
--- ./t/op/lfs.t Mon Jul 9 17:11:27 2001
***************
*** 54,63 ****
print "1..0 # Skip: @_\n" if @_;
}
print "# checking whether we have sparse files...\n";
# Known have-nots.
! if ($^O eq 'MSWin32' || $^O eq 'VMS') {
print "1..0 # Skip: no sparse files in $^O\n";
bye();
}
--- 54,65 ----
print "1..0 # Skip: @_\n" if @_;
}
+ $| = 1;
+
print "# checking whether we have sparse files...\n";
# Known have-nots.
! if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') {
print "1..0 # Skip: no sparse files in $^O\n";
bye();
}
diff -c 'perl-5.7.1/t/op/loopctl.t' 'perl-5.7.2/t/op/loopctl.t'
Index: ./t/op/loopctl.t
*** ./t/op/loopctl.t Wed Mar 14 04:26:43 2001
--- ./t/op/loopctl.t Mon Jul 9 17:11:27 2001
***************
*** 31,37 ****
#
# -- .robin. <robin@kitsite.com> 2001-03-13
! print "1..39\n";
my $ok;
--- 31,37 ----
#
# -- .robin. <robin@kitsite.com> 2001-03-13
! print "1..41\n";
my $ok;
***************
*** 923,925 ****
--- 923,946 ----
}
}
print ($ok ? "ok 39\n" : "not ok 39\n");
+
+
+ ### Test that loop control is dynamicly scoped.
+
+ sub test_last_label { last TEST40 }
+
+ TEST40: {
+ $ok = 1;
+ test_last_label();
+ $ok = 0;
+ }
+ print ($ok ? "ok 40\n" : "not ok 40\n");
+
+ sub test_last { last }
+
+ TEST41: {
+ $ok = 1;
+ test_last();
+ $ok = 0;
+ }
+ print ($ok ? "ok 41\n" : "not ok 41\n");
diff -c 'perl-5.7.1/t/op/magic.t' 'perl-5.7.2/t/op/magic.t'
Index: ./t/op/magic.t
*** ./t/op/magic.t Tue Mar 27 23:35:38 2001
--- ./t/op/magic.t Mon Jul 9 17:11:27 2001
***************
*** 21,33 ****
}
$Is_MSWin32 = $^O eq 'MSWin32';
$Is_VMS = $^O eq 'VMS';
$Is_Dos = $^O eq 'dos';
$Is_os2 = $^O eq 'os2';
$Is_Cygwin = $^O eq 'cygwin';
! $PERL = ($Is_MSWin32 ? '.\perl' : './perl');
! print "1..38\n";
eval '$ENV{"FOO"} = "hi there";'; # check that ENV is inited inside eval
if ($Is_MSWin32) { ok 1, `cmd /x /c set FOO` eq "FOO=hi there\n"; }
--- 21,35 ----
}
$Is_MSWin32 = $^O eq 'MSWin32';
+ $Is_NetWare = $^O eq 'NetWare';
$Is_VMS = $^O eq 'VMS';
$Is_Dos = $^O eq 'dos';
$Is_os2 = $^O eq 'os2';
$Is_Cygwin = $^O eq 'cygwin';
! $Is_MPE = $^O eq 'mpeix';
! $PERL = ($Is_MSWin32 ? '.\perl' : ($Is_NetWare ? 'perl' : './perl'));
! print "1..41\n";
eval '$ENV{"FOO"} = "hi there";'; # check that ENV is inited inside eval
if ($Is_MSWin32) { ok 1, `cmd /x /c set FOO` eq "FOO=hi there\n"; }
***************
*** 39,45 ****
ok 2, $!, $!;
close FOO; # just mention it, squelch used-only-once
! if ($Is_MSWin32 || $Is_Dos) {
ok "3 # skipped",1;
ok "4 # skipped",1;
}
--- 41,47 ----
ok 2, $!, $!;
close FOO; # just mention it, squelch used-only-once
! if ($Is_MSWin32 || $Is_NetWare || $Is_Dos || $Is_MPE) {
ok "3 # skipped",1;
ok "4 # skipped",1;
}
***************
*** 211,217 ****
# test case-insignificance of %ENV (these tests must be enabled only
# when perl is compiled with -DENV_IS_CASELESS)
! if ($Is_MSWin32) {
%ENV = ();
$ENV{'Foo'} = 'bar';
$ENV{'fOo'} = 'baz';
--- 213,219 ----
# test case-insignificance of %ENV (these tests must be enabled only
# when perl is compiled with -DENV_IS_CASELESS)
! if ($Is_MSWin32 || $Is_NetWare) {
%ENV = ();
$ENV{'Foo'} = 'bar';
$ENV{'fOo'} = 'baz';
***************
*** 247,249 ****
--- 249,255 ----
open(FOO, "nonesuch"); # Generate ENOENT
my %errs = %{"!"}; # Cause Errno.pm to be loaded at run-time
ok 38, ${"!"}{ENOENT};
+
+ ok 39, $^S == 0;
+ eval { ok 40, $^S == 1 };
+ ok 41, $^S == 0;
diff -c 'perl-5.7.1/t/op/method.t' 'perl-5.7.2/t/op/method.t'
Index: ./t/op/method.t
*** ./t/op/method.t Tue Mar 6 04:07:13 2001
--- ./t/op/method.t Mon Jul 9 17:11:27 2001
***************
*** 9,15 ****
@INC = '../lib';
}
! print "1..54\n";
@A::ISA = 'B';
@B::ISA = 'C';
--- 9,15 ----
@INC = '../lib';
}
! print "1..72\n";
@A::ISA = 'B';
@B::ISA = 'C';
***************
*** 46,51 ****
--- 46,54 ----
test((method $obj ("a","b","c")), "method,a,b,c");
test((method $obj "a","b","c"), "method,a,b,c");
+ test($obj->method(0), "method,0");
+ test($obj->method(1), "method,1");
+
test($obj->method(), "method");
test($obj->$mname(), "method");
test((method $obj ()), "method");
***************
*** 173,192 ****
test(A2->foo(), "foo");
}
! {
! test(do { use Config; eval 'Config->foo()';
! $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1);
! test(do { use Config; eval '$d = bless {}, "Config"; $d->foo()';
! $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1);
! }
- test(do { eval 'E->foo()';
- $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1);
- test(do { eval '$e = bless {}, "E"; $e->foo()';
- $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1);
# This is actually testing parsing of indirect objects and undefined subs
# print foo("bar") where foo does not exist is not an indirect object.
# print foo "bar" where foo does not exist is an indirect object.
eval { sub AUTOLOAD { "ok ", shift, "\n"; } };
print nonsuch(++$cnt);
--- 176,243 ----
test(A2->foo(), "foo");
}
! ## This test was totally misguided. It passed before only because the
! ## code to determine if a package was loaded used to look for the hash
! ## %Foo::Bar instead of the package Foo::Bar:: -- and Config.pm just
! ## happens to export %Config.
! # {
! # test(do { use Config; eval 'Config->foo()';
! # $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1);
! # test(do { use Config; eval '$d = bless {}, "Config"; $d->foo()';
! # $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1);
! # }
+ # test error messages if method loading fails
+ test(do { eval '$e = bless {}, "E::A"; E::A->foo()';
+ $@ =~ /^\QCan't locate object method "foo" via package "E::A" at/ ? 1 : $@}, 1);
+ test(do { eval '$e = bless {}, "E::B"; $e->foo()';
+ $@ =~ /^\QCan't locate object method "foo" via package "E::B" at/ ? 1 : $@}, 1);
+ test(do { eval 'E::C->foo()';
+ $@ =~ /^\QCan't locate object method "foo" via package "E::C" (perhaps / ? 1 : $@}, 1);
+
+ test(do { eval 'UNIVERSAL->E::D::foo()';
+ $@ =~ /^\QCan't locate object method "foo" via package "E::D" (perhaps / ? 1 : $@}, 1);
+ test(do { eval '$e = bless {}, "UNIVERSAL"; $e->E::E::foo()';
+ $@ =~ /^\QCan't locate object method "foo" via package "E::E" (perhaps / ? 1 : $@}, 1);
+
+ $e = bless {}, "E::F"; # force package to exist
+ test(do { eval 'UNIVERSAL->E::F::foo()';
+ $@ =~ /^\QCan't locate object method "foo" via package "E::F" at/ ? 1 : $@}, 1);
+ test(do { eval '$e = bless {}, "UNIVERSAL"; $e->E::F::foo()';
+ $@ =~ /^\QCan't locate object method "foo" via package "E::F" at/ ? 1 : $@}, 1);
+
+ # TODO: we need some tests for the SUPER:: pseudoclass
+
+ # failed method call or UNIVERSAL::can() should not autovivify packages
+ test( $::{"Foo::"} || "none", "none"); # sanity check 1
+ test( $::{"Foo::"} || "none", "none"); # sanity check 2
+
+ test( UNIVERSAL::can("Foo", "boogie") ? "yes":"no", "no" );
+ test( $::{"Foo::"} || "none", "none"); # still missing?
+
+ test( Foo->UNIVERSAL::can("boogie") ? "yes":"no", "no" );
+ test( $::{"Foo::"} || "none", "none"); # still missing?
+
+ test( Foo->can("boogie") ? "yes":"no", "no" );
+ test( $::{"Foo::"} || "none", "none"); # still missing?
+
+ test( eval 'Foo->boogie(); 1' ? "yes":"no", "no" );
+ test( $::{"Foo::"} || "none", "none"); # still missing?
+
+ test(do { eval 'Foo->boogie()';
+ $@ =~ /^\QCan't locate object method "boogie" via package "Foo" (perhaps / ? 1 : $@}, 1);
+
+ eval 'sub Foo::boogie { "yes, sir!" }';
+ test( $::{"Foo::"} ? "ok" : "none", "ok"); # should exist now
+ test( Foo->boogie(), "yes, sir!");
+
+ # TODO: universal.t should test NoSuchPackage->isa()/can()
+
# This is actually testing parsing of indirect objects and undefined subs
# print foo("bar") where foo does not exist is not an indirect object.
# print foo "bar" where foo does not exist is an indirect object.
eval { sub AUTOLOAD { "ok ", shift, "\n"; } };
print nonsuch(++$cnt);
+
+ print "# $cnt tests completed\n";
diff -c 'perl-5.7.1/t/op/misc.t' 'perl-5.7.2/t/op/misc.t'
Index: ./t/op/misc.t
*** ./t/op/misc.t Sun Mar 18 07:28:22 2001
--- ./t/op/misc.t Mon Jul 9 17:11:27 2001
***************
*** 17,23 ****
1 while -f ++$tmpfile;
END { while($tmpfile && unlink $tmpfile){} }
! $CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat');
for (@prgs){
my $switch;
--- 17,23 ----
1 while -f ++$tmpfile;
END { while($tmpfile && unlink $tmpfile){} }
! $CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : (($^O eq 'NetWare') ? 'perl -e "print <>"' : 'cat'));
for (@prgs){
my $switch;
***************
*** 35,40 ****
--- 35,43 ----
if ($^O eq 'MSWin32') {
$results = `.\\perl -I../lib $switch $tmpfile 2>&1`;
}
+ elsif ($^O eq 'NetWare') {
+ $results = `perl -I../lib $switch $tmpfile 2>&1`;
+ }
else {
$results = `./perl $switch $tmpfile 2>&1`;
}
***************
*** 258,263 ****
--- 261,275 ----
EXPECT
2 2 2
########
+ # used to attach defelem magic to all immortal values,
+ # which made restore of local $_ fail.
+ foo(2>1);
+ sub foo { bar() for @_; }
+ sub bar { local $_; }
+ print "ok\n";
+ EXPECT
+ ok
+ ########
@a = ($a, $b, $c, $d) = (5, 6);
print "ok\n"
if ($a[0] == 5 and $a[1] == 6 and !defined $a[2] and !defined $a[3]);
***************
*** 349,355 ****
/(?{"{"})/ # Check it outside of eval too
EXPECT
Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern
! Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/(?{ << HERE "{"})/ at - line 1.
########
/(?{"{"}})/ # Check it outside of eval too
EXPECT
--- 361,367 ----
/(?{"{"})/ # Check it outside of eval too
EXPECT
Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern
! Sequence (?{...}) not terminated or not {}-balanced in regex; marked by <-- HERE in m/(?{ <-- HERE "{"})/ at - line 1.
########
/(?{"{"}})/ # Check it outside of eval too
EXPECT
***************
*** 566,571 ****
--- 578,617 ----
EXPECT
aba\ba\b
########
+ # lexicals declared after the myeval() definition should not be visible
+ # within it
+ sub myeval { eval $_[0] }
+ my $foo = "ok 2\n";
+ myeval('sub foo { local $foo = "ok 1\n"; print $foo; }');
+ die $@ if $@;
+ foo();
+ print $foo;
+ EXPECT
+ ok 1
+ ok 2
+ ########
+ # lexicals outside an eval"" should be visible inside subroutine definitions
+ # within it
+ eval <<'EOT'; die $@ if $@;
+ {
+ my $X = "ok\n";
+ eval 'sub Y { print $X }'; die $@ if $@;
+ Y();
+ }
+ EOT
+ EXPECT
+ ok
+ ########
+ # test that closures generated by eval"" hold on to the CV of the eval""
+ # for their entire lifetime
+ $code = eval q[
+ sub { eval '$x = "ok 1\n"'; }
+ ];
+ &{$code}();
+ print $x;
+ EXPECT
+ ok 1
+ ########
# This test is here instead of pragma/locale.t because
# the bug depends on in the internal state of the locale
# settings and pragma/locale messes up that state pretty badly.
***************
*** 581,587 ****
$have_setlocale = 0 if $@;
# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1"
# and mingw32 uses said silly CRT
! $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i;
exit(0) unless $have_setlocale;
my @locales;
if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a|")) {
--- 627,633 ----
$have_setlocale = 0 if $@;
# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1"
# and mingw32 uses said silly CRT
! $have_setlocale = 0 if (($^O eq 'MSWin32' || $^O eq 'NetWare') && $Config{cc} =~ /^(cl|gcc)/i);
exit(0) unless $have_setlocale;
my @locales;
if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a|")) {
***************
*** 646,649 ****
new_pmop "abcdef"; reset;
new_pmop "abcdef"; reset;
new_pmop "abcdef"; reset;
!
--- 692,754 ----
new_pmop "abcdef"; reset;
new_pmop "abcdef"; reset;
new_pmop "abcdef"; reset;
! ########
! # David Dyck
! # coredump in 5.7.1
! close STDERR; die;
! EXPECT
! ########
! -w
! "x" =~ /(\G?x)?/; # core dump in 20000716.007
! EXPECT
! Quantifier unexpected on zero-length expression in regex; marked by <-- HERE in m/(\G?x)? <-- HERE / at - line 2.
! ########
! # Bug 20010515.004
! my @h = 1 .. 10;
! bad(@h);
! sub bad {
! undef @h;
! print "O";
! print for @_;
! print "K";
! }
! EXPECT
! OK
! ########
! # Bug 20010506.041
! "abcd\x{1234}" =~ /(a)(b[c])(d+)?/i and print "ok\n";
! EXPECT
! ok
! ########
! # Bug 20010422.005
! {s//${}/; //}
! EXPECT
! syntax error at - line 2, near "${}"
! Execution of - aborted due to compilation errors.
! ########
! # Bug 20010528.007
! "\x{"
! EXPECT
! Missing right brace on \x{} at - line 2, within string
! Execution of - aborted due to compilation errors.
! ########
! my $foo = Bar->new();
! my @dst;
! END {
! ($_ = "@dst") =~ s/\(0x.+?\)/(0x...)/;
! print $_, "\n";
! }
! package Bar;
! sub new {
! my Bar $self = bless [], Bar;
! eval '$self';
! return $self;
! }
! sub DESTROY {
! push @dst, "$_[0]";
! }
! EXPECT
! Bar=ARRAY(0x...)
! ########
! eval "a.b.c.d.e.f;sub"
! EXPECT
diff -c 'perl-5.7.1/t/op/mkdir.t' 'perl-5.7.2/t/op/mkdir.t'
Index: ./t/op/mkdir.t
*** ./t/op/mkdir.t Tue Mar 6 04:07:13 2001
--- ./t/op/mkdir.t Mon Jul 9 17:11:27 2001
***************
*** 20,25 ****
print (-d 'blurfl' ? "ok 4\n" : "not ok 4\n");
print (rmdir('blurfl') ? "ok 5\n" : "not ok 5\n");
print (rmdir('blurfl') ? "not ok 6\n" : "ok 6\n");
! print ($! =~ /cannot find|such|exist|not found/i ? "ok 7\n" : "# $!\nnot ok 7\n");
print (mkdir('blurfl') ? "ok 8\n" : "not ok 8\n");
print (rmdir('blurfl') ? "ok 9\n" : "not ok 9\n");
--- 20,25 ----
print (-d 'blurfl' ? "ok 4\n" : "not ok 4\n");
print (rmdir('blurfl') ? "ok 5\n" : "not ok 5\n");
print (rmdir('blurfl') ? "not ok 6\n" : "ok 6\n");
! print ($! =~ /cannot find|such|exist|not found|not a directory/i ? "ok 7\n" : "# $!\nnot ok 7\n");
print (mkdir('blurfl') ? "ok 8\n" : "not ok 8\n");
print (rmdir('blurfl') ? "ok 9\n" : "not ok 9\n");
diff -c 'perl-5.7.1/t/op/my_stash.t' 'perl-5.7.2/t/op/my_stash.t'
Index: ./t/op/my_stash.t
*** ./t/op/my_stash.t Tue Mar 6 04:07:13 2001
--- ./t/op/my_stash.t Mon Jul 9 17:11:27 2001
***************
*** 14,19 ****
--- 14,20 ----
{
package Foo::Bar::Biz::Baz;
+ 1;
}
for (qw(Foo Foo:: MyClass __PACKAGE__)) {
diff -c 'perl-5.7.1/t/op/numconvert.t' 'perl-5.7.2/t/op/numconvert.t'
Index: ./t/op/numconvert.t
*** ./t/op/numconvert.t Tue Mar 6 04:07:13 2001
--- ./t/op/numconvert.t Mon Jul 9 17:11:27 2001
***************
*** 204,215 ****
print "# ok, as string ++ of max_uv is \"$max_uv_pp\", numeric is $max_uv_p1\n"
} elsif ($opnames[$last] eq 'I' and $ans[1] eq "-1"
and $ans[0] eq $max_uv_p1_as_iv) {
print "# ok, \"$max_uv_p1\" correctly converts to IV \"$max_uv_p1_as_iv\"\n";
} elsif ($opnames[$last] eq 'U' and $ans[1] eq ~0
and $ans[0] eq $max_uv_p1_as_uv) {
print "# ok, \"$max_uv_p1\" correctly converts to UV \"$max_uv_p1_as_uv\"\n";
} elsif (grep {/^N$/} @opnames[@{$curops[0]}]
! and $ans[0] == $ans[1] and $ans[0] <= ~0) {
print "# ok, numerically equal - notation changed due to adding zero\n";
} else {
$nok++,
--- 204,238 ----
print "# ok, as string ++ of max_uv is \"$max_uv_pp\", numeric is $max_uv_p1\n"
} elsif ($opnames[$last] eq 'I' and $ans[1] eq "-1"
and $ans[0] eq $max_uv_p1_as_iv) {
+ # Max UV plus 1 is NV. This NV may stringify in E notation.
+ # And the number of decimal digits shown in E notation will depend
+ # on the binary digits in the mantissa. And it may be that
+ # (say) 18446744073709551616 in E notation is truncated to
+ # (say) 1.8446744073709551e+19 (say) which gets converted back
+ # as 1.8446744073709551000e+19
+ # ie 18446744073709551000
+ # which isn't the integer we first had.
+ # But each step of conversion is correct. So it's not an error.
+ # (Only shows up for 64 bit UVs and NVs with 64 bit mantissas,
+ # and on Crays (64 bit integers, 48 bit mantissas) IIRC)
print "# ok, \"$max_uv_p1\" correctly converts to IV \"$max_uv_p1_as_iv\"\n";
} elsif ($opnames[$last] eq 'U' and $ans[1] eq ~0
and $ans[0] eq $max_uv_p1_as_uv) {
+ # as aboce
print "# ok, \"$max_uv_p1\" correctly converts to UV \"$max_uv_p1_as_uv\"\n";
} elsif (grep {/^N$/} @opnames[@{$curops[0]}]
! and $ans[0] == $ans[1] and $ans[0] <= ~0
! # First must be in E notation (ie not just digits) and
! # second must still be an integer.
! # eg 1.84467440737095516e+19
! # 1.84467440737095516e+19 for 64 bit mantissa is in the
! # integer range, so 1.84467440737095516e+19 + 0 is treated
! # as integer addition. [should it be?]
! # and 18446744073709551600 + 0 is 18446744073709551600
! # Which isn't the string you first thought of.
! # I can't remember why there isn't symmetry in this
! # exception, ie why only the first ops are tested for 'N'
! and $ans[0] != /^-?\d+$/ and $ans[1] !~ /^-?\d+$/) {
print "# ok, numerically equal - notation changed due to adding zero\n";
} else {
$nok++,
***************
*** 216,223 ****
}
}
}
! print "not " if $nok;
! print "ok $test\n";
#print $txt if $nok;
$test++;
}
--- 239,249 ----
}
}
}
! if ($nok) {
! print "not ok $test\n";
! } else {
! print "ok $test\n";
! }
#print $txt if $nok;
$test++;
}
diff -c /dev/null 'perl-5.7.2/t/op/override.t'
Index: ./t/op/override.t
*** ./t/op/override.t Thu Jan 1 02:00:00 1970
--- ./t/op/override.t Mon Jul 9 17:11:27 2001
***************
*** 0 ****
--- 1,63 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ }
+
+ print "1..10\n";
+
+ #
+ # This file tries to test builtin override using CORE::GLOBAL
+ #
+ my $dirsep = "/";
+
+ BEGIN { package Foo; *main::getlogin = sub { "kilroy"; } }
+
+ print "not " unless getlogin eq "kilroy";
+ print "ok 1\n";
+
+ my $t = 42;
+ BEGIN { *CORE::GLOBAL::time = sub () { $t; } }
+
+ print "not " unless 45 == time + 3;
+ print "ok 2\n";
+
+ #
+ # require has special behaviour
+ #
+ my $r;
+ BEGIN { *CORE::GLOBAL::require = sub { $r = shift; 1; } }
+
+ require Foo;
+ print "not " unless $r eq "Foo.pm";
+ print "ok 3\n";
+
+ require Foo::Bar;
+ print "not " unless $r eq join($dirsep, "Foo", "Bar.pm");
+ print "ok 4\n";
+
+ require 'Foo';
+ print "not " unless $r eq "Foo";
+ print "ok 5\n";
+
+ require 5.6;
+ print "not " unless $r eq "5.6";
+ print "ok 6\n";
+
+ require v5.6;
+ print "not " unless $r == 5.006 && $r eq "\x05\x06";
+ print "ok 7\n";
+
+ eval "use Foo";
+ print "not " unless $r eq "Foo.pm";
+ print "ok 8\n";
+
+ eval "use Foo::Bar";
+ print "not " unless $r eq join($dirsep, "Foo", "Bar.pm");
+ print "ok 9\n";
+
+ eval "use 5.6";
+ print "not " unless $r eq "5.6";
+ print "ok 10\n";
diff -c 'perl-5.7.1/t/op/pack.t' 'perl-5.7.2/t/op/pack.t'
Index: ./t/op/pack.t
*** ./t/op/pack.t Mon Mar 19 23:32:22 2001
--- ./t/op/pack.t Mon Jul 9 17:11:28 2001
***************
*** 6,12 ****
require Config; import Config;
}
! print "1..160\n";
$format = "c2 x5 C C x s d i l a6";
# Need the expression in here to force ary[5] to be numeric. This avoids
--- 6,13 ----
require Config; import Config;
}
! print "1..161\n";
! # Note: All test numbers in comments are off by 1 after the comment below..
$format = "c2 x5 C C x s d i l a6";
# Need the expression in here to force ary[5] to be numeric. This avoids
***************
*** 43,49 ****
print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum
? "ok 7\n" : "not ok 7 $x\n";
! open(BIN, "./perl") || open(BIN, "./perl.exe")
|| die "Can't open ../perl or ../perl.exe: $!\n";
sysread BIN, $foo, 8192;
close BIN;
--- 44,50 ----
print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum
? "ok 7\n" : "not ok 7 $x\n";
! open(BIN, "./perl") || open(BIN, "./perl.exe") || open(BIN, $^X)
|| die "Can't open ../perl or ../perl.exe: $!\n";
sysread BIN, $foo, 8192;
close BIN;
***************
*** 57,68 ****
# check 'w'
my $test=10;
! my @x = (5,130,256,560,32000,3097152,268435455,1073741844,
'4503599627365785','23728385234614992549757750638446');
my $x = pack('w*', @x);
! my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f848080801487ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e';
! print $x eq $y ? "ok $test\n" : "not ok $test\n"; $test++;
@y = unpack('w*', $y);
my $a;
--- 58,74 ----
# check 'w'
my $test=10;
! my @x = (5,130,256,560,32000,3097152,268435455,1073741844, 2**33,
'4503599627365785','23728385234614992549757750638446');
my $x = pack('w*', @x);
! my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f8480808014A08080800087ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e';
! if ($x eq $y) {
! print "ok $test\n";
! } else {
! printf "not ok $test # %s\n", unpack 'H*', $x;
! }
! $test++;
@y = unpack('w*', $y);
my $a;
***************
*** 71,80 ****
print $a eq $b ? "ok $test\n" : "not ok $test\n$a\n$b\n"; $test++;
}
@y = unpack('w2', $x);
print scalar(@y) == 2 ? "ok $test\n" : "not ok $test\n"; $test++;
! print $y[1] == 130 ? "ok $test\n" : "not ok $test\n"; $test++;
# test exeptions
eval { $x = unpack 'w', pack 'C*', 0xff, 0xff};
--- 77,88 ----
print $a eq $b ? "ok $test\n" : "not ok $test\n$a\n$b\n"; $test++;
}
+ # XXX All test numbers in comments are off by 1 after this point.
+
@y = unpack('w2', $x);
print scalar(@y) == 2 ? "ok $test\n" : "not ok $test\n"; $test++;
! print $y[1] == 130 ? "ok $test\n" : "not ok $test # $y[1]\n"; $test++;
# test exeptions
eval { $x = unpack 'w', pack 'C*', 0xff, 0xff};
***************
*** 362,367 ****
--- 370,392 ----
# 144..152: /
+ # Using Test considered bad plan in op/*.t ?
+
+ sub report {
+ my ($pass, $test, $err, $wrong) = @_;
+ if ($pass) {
+ print "ok $test\n"
+ } else {
+ if ($err) {
+ chomp $err;
+ print "not ok $test # \$\@ = $err\n";
+ } else {
+ $wrong =~ s/([[:cntrl:]\177 ])/sprintf "\\%03o", ord $1/ge;
+ print "not ok $test # got $wrong\n";
+ }
+ }
+ }
+
my $z;
eval { ($x) = unpack '/a*','hello' };
print 'not ' unless $@; print "ok $test\n"; $test++;
***************
*** 373,380 ****
eval { ($x) = pack '/a*','hello' };
print 'not ' unless $@; print "ok $test\n"; $test++;
$z = pack 'n/a* N/Z* w/A*','string','hi there ','etc';
! print 'not ' unless $z eq "\000\006string\0\0\0\012hi there \000\003etc";
! print "ok $test\n"; $test++;
eval { ($x) = unpack 'a/a*/a*', '212ab345678901234567' };
print $@ eq '' && $x eq 'ab3456789012' ? "ok $test\n" : "#$x,$@\nnot ok $test\n";
--- 398,405 ----
eval { ($x) = pack '/a*','hello' };
print 'not ' unless $@; print "ok $test\n"; $test++;
$z = pack 'n/a* N/Z* w/A*','string','hi there ','etc';
! my $expect = "\000\006string\0\0\0\012hi there \000\003etc";
! report ($z eq $expect, $test++, '', $z);
eval { ($x) = unpack 'a/a*/a*', '212ab345678901234567' };
print $@ eq '' && $x eq 'ab3456789012' ? "ok $test\n" : "#$x,$@\nnot ok $test\n";
***************
*** 405,411 ****
n/a* # Count as network short
w/A* # Count a BER integer
EOP
! print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++;
print 'not ' unless "1.20.300.4000" eq sprintf "%vd", pack("U*",1,20,300,4000);
print "ok $test\n"; $test++;
--- 430,437 ----
n/a* # Count as network short
w/A* # Count a BER integer
EOP
! $expect = "\000\006string\003etc";
! report ($z eq $expect, $test++, '', $z);
print 'not ' unless "1.20.300.4000" eq sprintf "%vd", pack("U*",1,20,300,4000);
print "ok $test\n"; $test++;
diff -c 'perl-5.7.1/t/op/pat.t' 'perl-5.7.2/t/op/pat.t'
Index: ./t/op/pat.t
*** ./t/op/pat.t Wed Mar 28 18:36:00 2001
--- ./t/op/pat.t Mon Jul 9 17:11:28 2001
***************
*** 5,19 ****
# that does fit that format, add it to op/re_tests, not here.
$| = 1;
- print "1..581\n";
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
- use re 'asciirange'; # Compute ranges in ASCII space
-
eval 'use Config'; # Defaults assumed if this fails
$x = "abc\ndef\n";
--- 5,18 ----
# that does fit that format, add it to op/re_tests, not here.
$| = 1;
+ print "1..672\n";
+
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
eval 'use Config'; # Defaults assumed if this fails
$x = "abc\ndef\n";
***************
*** 1130,1135 ****
--- 1129,1136 ----
print "ok $test\n";
$test++;
+ my $ordA = ord('A');
+
$_ = "a\x{100}b";
if (/(.)(\C)(\C)(.)/) {
print "ok 232\n";
***************
*** 1138,1153 ****
} else {
print "not ok 233\n";
}
! if ($2 eq "\xC4") {
! print "ok 234\n";
} else {
! print "not ok 234\n";
}
- if ($3 eq "\x80") {
- print "ok 235\n";
- } else {
- print "not ok 235\n";
- }
if ($4 eq "b") {
print "ok 236\n";
} else {
--- 1139,1171 ----
} else {
print "not ok 233\n";
}
! if ($ordA == 65) { # ASCII (or equivalent), should be UTF-8
! if ($2 eq "\xC4") {
! print "ok 234\n";
! } else {
! print "not ok 234\n";
! }
! if ($3 eq "\x80") {
! print "ok 235\n";
! } else {
! print "not ok 235\n";
! }
! } elsif ($ordA == 193) { # EBCDIC (or equivalent), should be UTF-EBCDIC
! if ($2 eq "\x8C") {
! print "ok 234\n";
! } else {
! print "not ok 234\n";
! }
! if ($3 eq "\x41") {
! print "ok 235\n";
! } else {
! print "not ok 235\n";
! }
} else {
! for (234..235) {
! print "not ok $_ # ord('A') == $ordA\n";
! }
}
if ($4 eq "b") {
print "ok 236\n";
} else {
***************
*** 1162,1171 ****
if (/(\C)/g) {
print "ok 237\n";
# currently \C are still tagged as UTF-8
! if ($1 eq "\xC4") {
! print "ok 238\n";
} else {
! print "not ok 238\n";
}
} else {
for (237..238) {
--- 1180,1199 ----
if (/(\C)/g) {
print "ok 237\n";
# currently \C are still tagged as UTF-8
! if ($ordA == 65) {
! if ($1 eq "\xC4") {
! print "ok 238\n";
! } else {
! print "not ok 238\n";
! }
! } elsif ($ordA == 193) {
! if ($1 eq "\x8C") {
! print "ok 238\n";
! } else {
! print "not ok 238\n";
! }
} else {
! print "not ok 238 # ord('A') == $ordA\n";
}
} else {
for (237..238) {
***************
*** 1175,1184 ****
if (/(\C)/g) {
print "ok 239\n";
# currently \C are still tagged as UTF-8
! if ($1 eq "\x80") {
! print "ok 240\n";
} else {
! print "not ok 240\n";
}
} else {
for (239..240) {
--- 1203,1222 ----
if (/(\C)/g) {
print "ok 239\n";
# currently \C are still tagged as UTF-8
! if ($ordA == 65) {
! if ($1 eq "\x80") {
! print "ok 240\n";
! } else {
! print "not ok 240\n";
! }
! } elsif ($ordA == 193) {
! if ($1 eq "\x41") {
! print "ok 240\n";
! } else {
! print "not ok 240\n";
! }
} else {
! print "not ok 240 # ord('A') == $ordA\n";
}
} else {
for (239..240) {
***************
*** 1302,1307 ****
--- 1340,1346 ----
{
# the second half of 20001028.003
+ my $X = '';
$X =~ s/^/chr(1488)/e;
print "not " unless length $X == 1 && ord($X) == 1488;
print "ok 260\n";
***************
*** 1353,1362 ****
"\0" => 'Cc',
);
! for my $char (keys %s) {
my $class = $s{$char};
! my $code = sprintf("%04x", ord($char));
! printf "# 0x$code\n";
print "# IsAlpha\n";
if ($class =~ /^[LM]/) {
print "not " unless $char =~ /\p{IsAlpha}/;
--- 1392,1402 ----
"\0" => 'Cc',
);
! for my $char (map { s/^\S+ //; $_ }
! sort map { sprintf("%06x", ord($_))." $_" } keys %s) {
my $class = $s{$char};
! my $code = sprintf("%06x", ord($char));
! printf "#\n# 0x$code\n#\n";
print "# IsAlpha\n";
if ($class =~ /^[LM]/) {
print "not " unless $char =~ /\p{IsAlpha}/;
***************
*** 1382,1388 ****
print "ok $test\n"; $test++;
}
print "# IsASCII\n";
! if ($code <= 127) {
print "not " unless $char =~ /\p{IsASCII}/;
print "ok $test\n"; $test++;
print "not " if $char =~ /\P{IsASCII}/;
--- 1422,1428 ----
print "ok $test\n"; $test++;
}
print "# IsASCII\n";
! if ($code le '00007f') {
print "not " unless $char =~ /\p{IsASCII}/;
print "ok $test\n"; $test++;
print "not " if $char =~ /\P{IsASCII}/;
***************
*** 1547,1549 ****
--- 1587,1931 ----
print "ok 581\n";
}
+
+ {
+ $test = 582;
+
+ # bugid 20010410.006
+ for my $rx (
+ '/(.*?)\{(.*?)\}/csg',
+ '/(.*?)\{(.*?)\}/cg',
+ '/(.*?)\{(.*?)\}/sg',
+ '/(.*?)\{(.*?)\}/g',
+ '/(.+?)\{(.+?)\}/csg',
+ )
+ {
+ my($input, $i);
+
+ $i = 0;
+ $input = "a{b}c{d}";
+ eval <<EOT;
+ while (eval \$input =~ $rx) {
+ print "# \\\$1 = '\$1' \\\$2 = '\$2'\n";
+ ++\$i;
+ }
+ EOT
+ print "not " unless $i == 2;
+ print "ok " . $test++ . "\n";
+ }
+ }
+
+ {
+ # from Robin Houston
+
+ my $x = "\x{12345678}";
+ $x =~ s/(.)/$1/g;
+ print "not " unless ord($x) == 0x12345678 && length($x) == 1;
+ print "ok 587\n";
+ }
+
+ {
+ my $x = "\x7f";
+
+ print "not " if $x =~ /[\x80-\xff]/;
+ print "ok 588\n";
+
+ print "not " if $x =~ /[\x80-\x{100}]/;
+ print "ok 589\n";
+
+ print "not " if $x =~ /[\x{100}]/;
+ print "ok 590\n";
+
+ print "not " if $x =~ /\p{InLatin1Supplement}/;
+ print "ok 591\n";
+
+ print "not " unless $x =~ /\P{InLatin1Supplement}/;
+ print "ok 592\n";
+
+ print "not " if $x =~ /\p{InLatinExtendedA}/;
+ print "ok 593\n";
+
+ print "not " unless $x =~ /\P{InLatinExtendedA}/;
+ print "ok 594\n";
+ }
+
+ {
+ my $x = "\x80";
+
+ print "not " unless $x =~ /[\x80-\xff]/;
+ print "ok 595\n";
+
+ print "not " unless $x =~ /[\x80-\x{100}]/;
+ print "ok 596\n";
+
+ print "not " if $x =~ /[\x{100}]/;
+ print "ok 597\n";
+
+ print "not " unless $x =~ /\p{InLatin1Supplement}/;
+ print "ok 598\n";
+
+ print "not " if $x =~ /\P{InLatin1Supplement}/;
+ print "ok 599\n";
+
+ print "not " if $x =~ /\p{InLatinExtendedA}/;
+ print "ok 600\n";
+
+ print "not " unless $x =~ /\P{InLatinExtendedA}/;
+ print "ok 601\n";
+ }
+
+ {
+ my $x = "\xff";
+
+ print "not " unless $x =~ /[\x80-\xff]/;
+ print "ok 602\n";
+
+ print "not " unless $x =~ /[\x80-\x{100}]/;
+ print "ok 603\n";
+
+ print "not " if $x =~ /[\x{100}]/;
+ print "ok 604\n";
+
+ print "not " unless $x =~ /\p{InLatin1Supplement}/;
+ print "ok 605\n";
+
+ print "not " if $x =~ /\P{InLatin1Supplement}/;
+ print "ok 606\n";
+
+ print "not " if $x =~ /\p{InLatinExtendedA}/;
+ print "ok 607\n";
+
+ print "not " unless $x =~ /\P{InLatinExtendedA}/;
+ print "ok 608\n";
+ }
+
+ {
+ my $x = "\x{100}";
+
+ print "not " if $x =~ /[\x80-\xff]/;
+ print "ok 609\n";
+
+ print "not " unless $x =~ /[\x80-\x{100}]/;
+ print "ok 610\n";
+
+ print "not " unless $x =~ /[\x{100}]/;
+ print "ok 611\n";
+
+ print "not " if $x =~ /\p{InLatin1Supplement}/;
+ print "ok 612\n";
+
+ print "not " unless $x =~ /\P{InLatin1Supplement}/;
+ print "ok 613\n";
+
+ print "not " unless $x =~ /\p{InLatinExtendedA}/;
+ print "ok 614\n";
+
+ print "not " if $x =~ /\P{InLatinExtendedA}/;
+ print "ok 615\n";
+ }
+
+ {
+ # from japhy
+ my $w;
+ use warnings;
+ local $SIG{__WARN__} = sub { $w .= shift };
+
+ $w = "";
+ eval 'qr/(?c)/';
+ print "not " if $w !~ /^Useless \(\?c\)/;
+ print "ok 616\n";
+
+ $w = "";
+ eval 'qr/(?-c)/';
+ print "not " if $w !~ /^Useless \(\?-c\)/;
+ print "ok 617\n";
+
+ $w = "";
+ eval 'qr/(?g)/';
+ print "not " if $w !~ /^Useless \(\?g\)/;
+ print "ok 618\n";
+
+ $w = "";
+ eval 'qr/(?-g)/';
+ print "not " if $w !~ /^Useless \(\?-g\)/;
+ print "ok 619\n";
+
+ $w = "";
+ eval 'qr/(?o)/';
+ print "not " if $w !~ /^Useless \(\?o\)/;
+ print "ok 620\n";
+
+ $w = "";
+ eval 'qr/(?-o)/';
+ print "not " if $w !~ /^Useless \(\?-o\)/;
+ print "ok 621\n";
+
+ # now test multi-error regexes
+
+ $w = "";
+ eval 'qr/(?g-o)/';
+ print "not " if $w !~ /^Useless \(\?g\).*\nUseless \(\?-o\)/;
+ print "ok 622\n";
+
+ $w = "";
+ eval 'qr/(?g-c)/';
+ print "not " if $w !~ /^Useless \(\?g\).*\nUseless \(\?-c\)/;
+ print "ok 623\n";
+
+ $w = "";
+ eval 'qr/(?o-cg)/'; # (?c) means (?g) error won't be thrown
+ print "not " if $w !~ /^Useless \(\?o\).*\nUseless \(\?-c\)/;
+ print "ok 624\n";
+
+ $w = "";
+ eval 'qr/(?ogc)/';
+ print "not " if $w !~ /^Useless \(\?o\).*\nUseless \(\?g\).*\nUseless \(\?c\)/;
+ print "ok 625\n";
+ }
+
+ # More Unicode "class" tests
+
+ {
+ use charnames ':full';
+
+ print "not " unless "\N{LATIN CAPITAL LETTER A}" =~ /\p{InBasicLatin}/;
+ print "ok 626\n";
+
+ print "not " unless "\N{LATIN CAPITAL LETTER A WITH GRAVE}" =~ /\p{InLatin1Supplement}/;
+ print "ok 627\n";
+
+ print "not " unless "\N{LATIN CAPITAL LETTER A WITH MACRON}" =~ /\p{InLatinExtendedA}/;
+ print "ok 628\n";
+
+ print "not " unless "\N{LATIN SMALL LETTER B WITH STROKE}" =~ /\p{InLatinExtendedB}/;
+ print "ok 629\n";
+
+ print "not " unless "\N{KATAKANA LETTER SMALL A}" =~ /\p{InKatakana}/;
+ print "ok 630\n";
+ }
+
+ $_ = "foo";
+
+ eval <<"EOT"; die if $@;
+ /f
+ o\r
+ o
+ \$
+ /x && print "ok 631\n";
+ EOT
+
+ eval <<"EOT"; die if $@;
+ /f
+ o
+ o
+ \$\r
+ /x && print "ok 632\n";
+ EOT
+
+ #test /o feature
+ sub test_o { $_[0] =~/$_[1]/o; return $1}
+ if(test_o('abc','(.)..') eq 'a') {
+ print "ok 633\n";
+ } else {
+ print "not ok 633\n";
+ }
+ if(test_o('abc','..(.)') eq 'a') {
+ print "ok 634\n";
+ } else {
+ print "not ok 634\n";
+ }
+
+ # 635..639: ID 20010619.003 (only the space character is
+ # supposed to be [:print:], not the whole isprint()).
+
+ print "not " if "\n" =~ /[[:print:]]/;
+ print "ok 635\n";
+
+ print "not " if "\t" =~ /[[:print:]]/;
+ print "ok 636\n";
+
+ # Amazingly vertical tabulator is the same in ASCII and EBCDIC.
+ print "not " if "\014" =~ /[[:print:]]/;
+ print "ok 637\n";
+
+ print "not " if "\r" =~ /[[:print:]]/;
+ print "ok 638\n";
+
+ print "not " unless " " =~ /[[:print:]]/;
+ print "ok 639\n";
+
+ ##
+ ## Test basic $^N usage outside of a regex
+ ##
+ $x = "abcdef";
+ $T="ok 640\n";if ($x =~ /cde/ and not defined $^N) {print $T} else {print "not $T"};
+ $T="ok 641\n";if ($x =~ /(cde)/ and $^N eq "cde") {print $T} else {print "not $T"};
+ $T="ok 642\n";if ($x =~ /(c)(d)(e)/ and $^N eq "e") {print $T} else {print "not $T"};
+ $T="ok 643\n";if ($x =~ /(c(d)e)/ and $^N eq "cde") {print $T} else {print "not $T"};
+ $T="ok 644\n";if ($x =~ /(foo)|(c(d)e)/ and $^N eq "cde") {print $T} else {print "not $T"};
+ $T="ok 645\n";if ($x =~ /(c(d)e)|(foo)/ and $^N eq "cde") {print $T} else {print "not $T"};
+ $T="ok 646\n";if ($x =~ /(c(d)e)|(abc)/ and $^N eq "abc") {print $T} else {print "not $T"};
+ $T="ok 647\n";if ($x =~ /(c(d)e)|(abc)x/ and $^N eq "cde") {print $T} else {print "not $T"};
+ $T="ok 648\n";if ($x =~ /(c(d)e)(abc)?/ and $^N eq "cde") {print $T} else {print "not $T"};
+ $T="ok 649\n";if ($x =~ /(?:c(d)e)/ and $^N eq "d" ) {print $T} else {print "not $T"};
+ $T="ok 650\n";if ($x =~ /(?:c(d)e)(?:f)/ and $^N eq "d" ) {print $T} else {print "not $T"};
+ $T="ok 651\n";if ($x =~ /(?:([abc])|([def]))*/ and $^N eq "f" ){print $T} else {print "not $T"};
+ $T="ok 652\n";if ($x =~ /(?:([ace])|([bdf]))*/ and $^N eq "f" ){print $T} else {print "not $T"};
+ $T="ok 653\n";if ($x =~ /(([ace])|([bd]))*/ and $^N eq "e" ){print $T} else {print "not $T"};
+ {
+ $T="ok 654\n";if($x =~ /(([ace])|([bdf]))*/ and $^N eq "f" ){print $T} else {print "not $T"};
+ }
+ ## test to see if $^N is automatically localized -- it should now
+ ## have the value set in test 653
+ $T="ok 655\n";if ($^N eq "e" ){print $T} else {print "not $T"};
+
+ ##
+ ## Now test inside (?{...})
+ ##
+ $T="ok 656\n";if ($x =~ /a([abc])(?{$y=$^N})c/ and $y eq "b" ){print $T} else {print "not $T"};
+ $T="ok 657\n";if ($x =~ /a([abc]+)(?{$y=$^N})d/ and $y eq "bc"){print $T} else {print "not $T"};
+ $T="ok 658\n";if ($x =~ /a([abcdefg]+)(?{$y=$^N})d/ and $y eq "bc"){print $T} else {print "not $T"};
+ $T="ok 659\n";if ($x =~ /(a([abcdefg]+)(?{$y=$^N})d)(?{$z=$^N})e/ and $y eq "bc" and $z eq "abcd")
+ {print $T} else {print "not $T"};
+ $T="ok 660\n";if ($x =~ /(a([abcdefg]+)(?{$y=$^N})de)(?{$z=$^N})/ and $y eq "bc" and $z eq "abcde")
+ {print $T} else {print "not $T"};
+
+ # Test the Unicode script classes
+
+ print "not " unless chr(0x100) =~ /\p{InLatin}/; # outside Latin-1
+ print "ok 661\n";
+
+ print "not " unless chr(0x212b) =~ /\p{InLatin}/; # Angstrom sign, very outside
+ print "ok 662\n";
+
+ print "not " unless chr(0x5d0) =~ /\p{InHebrew}/; # inside HebrewBlock
+ print "ok 663\n";
+
+ print "not " unless chr(0xfb4f) =~ /\p{InHebrew}/; # outside HebrewBlock
+ print "ok 664\n";
+
+ print "not " unless chr(0xb5) =~ /\p{InGreek}/; # singleton (not in a range)
+ print "ok 665\n";
+
+ print "not " unless chr(0x37a) =~ /\p{InGreek}/; # singleton
+ print "ok 666\n";
+
+ print "not " unless chr(0x386) =~ /\p{InGreek}/; # singleton
+ print "ok 667\n";
+
+ print "not " unless chr(0x387) =~ /\P{InGreek}/; # not there
+ print "ok 668\n";
+
+ print "not " unless chr(0x388) =~ /\p{InGreek}/; # range
+ print "ok 669\n";
+
+ print "not " unless chr(0x38a) =~ /\p{InGreek}/; # range
+ print "ok 670\n";
+
+ print "not " unless chr(0x38b) =~ /\P{InGreek}/; # not there
+ print "ok 671\n";
+
+ print "not " unless chr(0x38c) =~ /\p{InGreek}/; # singleton
+ print "ok 672\n";
+
+
diff -c 'perl-5.7.1/t/op/pos.t' 'perl-5.7.2/t/op/pos.t'
Index: ./t/op/pos.t
*** ./t/op/pos.t Tue Mar 6 04:07:14 2001
--- ./t/op/pos.t Mon Jul 9 17:11:28 2001
***************
*** 1,6 ****
#!./perl
! print "1..4\n";
$x='banana';
$x=~/.a/g;
--- 1,6 ----
#!./perl
! print "1..7\n";
$x='banana';
$x=~/.a/g;
***************
*** 19,23 ****
--- 19,39 ----
print "not " unless $x eq "0123 5678910?";
print "ok 4\n";
+ # bug ID 20010704.003
+ use Tie::Scalar;
+ tie $y[0], Tie::StdScalar or die $!;
+ $y[0] = "aaa";
+ $y[0] =~ /./g;
+ if (pos($y[0]) == 1) {print "ok 5\n"} else {print "not ok 5\n"}
+ $x = 0;
+ $y[0] = "aaa";
+ $y[$x] =~ /./g;
+ if (pos($y[$x]) == 1) {print "ok 6\n"} else {print "not ok 6\n"}
+ untie $y[0];
+ tie $y{'abc'}, Tie::StdScalar or die $!;
+ $y{'abc'} = "aaa";
+ $y{'abc'} =~ /./g;
+ if (pos($y{'abc'}) == 1) {print "ok 7\n"} else {print "not ok 7\n"}
+ untie $y{'abc'};
diff -c 'perl-5.7.1/t/op/pwent.t' 'perl-5.7.2/t/op/pwent.t'
Index: ./t/op/pwent.t
*** ./t/op/pwent.t Thu Apr 5 21:18:27 2001
--- ./t/op/pwent.t Mon Jul 9 17:11:28 2001
***************
*** 3,9 ****
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
! eval {my @n = getpwuid 0};
if ($@ && $@ =~ /(The \w+ function is unimplemented)/) {
print "1..0 # Skip: $1\n";
exit 0;
--- 3,9 ----
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
! eval {my @n = getpwuid 0; setpwent()};
if ($@ && $@ =~ /(The \w+ function is unimplemented)/) {
print "1..0 # Skip: $1\n";
exit 0;
***************
*** 68,74 ****
--- 68,77 ----
my %perfect;
my %seen;
+ print "# where $where\n";
+
setpwent();
+
while (<PW>) {
chomp;
# LIMIT -1 so that users with empty shells don't fall off
***************
*** 115,123 ****
}
$n++;
}
endpwent();
! if (keys %perfect == 0) {
$max++;
print <<EOEX;
#
--- 118,129 ----
}
$n++;
}
+
endpwent();
! print "# max = $max, n = $n, perfect = ", scalar keys %perfect, "\n";
!
! if (keys %perfect == 0 && $n) {
$max++;
print <<EOEX;
#
diff -c 'perl-5.7.1/t/op/rand.t' 'perl-5.7.2/t/op/rand.t'
Index: ./t/op/rand.t
*** ./t/op/rand.t Tue Mar 6 04:07:14 2001
--- ./t/op/rand.t Mon Jul 9 17:11:28 2001
***************
*** 342,347 ****
--- 342,348 ----
for (1..5) {
my $PERL = (($^O eq 'VMS') ? "MCR $^X"
: ($^O eq 'MSWin32') ? '.\perl'
+ : ($^O eq 'NetWare') ? 'perl'
: './perl');
$pid = open PERL, qq[$PERL -e "print rand"|];
die "Couldn't pipe from perl: $!" unless defined $pid;
diff -c 'perl-5.7.1/t/op/re_tests' 'perl-5.7.2/t/op/re_tests'
Index: ./t/op/re_tests
*** ./t/op/re_tests Thu Mar 22 08:05:36 2001
--- ./t/op/re_tests Mon Jul 9 17:11:28 2001
***************
*** 45,53 ****
a[b-d] aac y $& ac
a[-b] a- y $& a-
a[b-] a- y $& a-
! a[b-a] - c - Invalid [] range "b-a" before HERE mark in regex m/a[b-a << HERE ]/
! a[]b - c - Unmatched [ before HERE mark in regex m/a[ << HERE ]b/
! a[ - c - Unmatched [ before HERE mark in regex m/a[ << HERE /
a] a] y $& a]
a[]]b a]b y $& a]b
a[^bc]d aed y $& aed
--- 45,53 ----
a[b-d] aac y $& ac
a[-b] a- y $& a-
a[b-] a- y $& a-
! a[b-a] - c - Invalid [] range "b-a"
! a[]b - c - Unmatched [
! a[ - c - Unmatched [
a] a] y $& a]
a[]]b a]b y $& a]b
a[^bc]d aed y $& aed
***************
*** 95,102 ****
ab|cd abc y $& ab
ab|cd abcd y $& ab
()ef def y $&-$1 ef-
! *a - c - Quantifier follows nothing before HERE mark in regex m/* << HERE a/
! (*)b - c - Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/
$b b n - -
a\ - c - Search pattern not terminated
a\(b a(b y $&-$1 a(b-
--- 95,102 ----
ab|cd abc y $& ab
ab|cd abcd y $& ab
()ef def y $&-$1 ef-
! *a - c - Quantifier follows nothing
! (*)b - c - Quantifier follows nothing
$b b n - -
a\ - c - Search pattern not terminated
a\(b a(b y $&-$1 a(b-
***************
*** 103,115 ****
a\(*b ab y $& ab
a\(*b a((b y $& a((b
a\\b a\b y $& a\b
! abc) - c - Unmatched ) before HERE mark in regex m/abc) << HERE /
! (abc - c - Unmatched ( before HERE mark in regex m/( << HERE abc/
((a)) abc y $&-$1-$2 a-a-a
(a)b(c) abc y $&-$1-$2 abc-a-c
a+b+c aabbabc y $& abc
a{1,}b{1,}c aabbabc y $& abc
! a** - c - Nested quantifiers before HERE mark in regex m/a** << HERE /
a.+?c abcabc y $& abc
(a+|b)* ab y $&-$1 ab-b
(a+|b){0,} ab y $&-$1 ab-b
--- 103,115 ----
a\(*b ab y $& ab
a\(*b a((b y $& a((b
a\\b a\b y $& a\b
! abc) - c - Unmatched )
! (abc - c - Unmatched (
((a)) abc y $&-$1-$2 a-a-a
(a)b(c) abc y $&-$1-$2 abc-a-c
a+b+c aabbabc y $& abc
a{1,}b{1,}c aabbabc y $& abc
! a** - c - Nested quantifiers
a.+?c abcabc y $& abc
(a+|b)* ab y $&-$1 ab-b
(a+|b){0,} ab y $&-$1 ab-b
***************
*** 117,123 ****
(a+|b){1,} ab y $&-$1 ab-b
(a+|b)? ab y $&-$1 a-a
(a+|b){0,1} ab y $&-$1 a-a
! )( - c - Unmatched ) before HERE mark in regex m/) << HERE (/
[^ab]* cde y $& cde
abc n - -
a* y $&
--- 117,123 ----
(a+|b){1,} ab y $&-$1 ab-b
(a+|b)? ab y $&-$1 a-a
(a+|b){0,1} ab y $&-$1 a-a
! )( - c - Unmatched )
[^ab]* cde y $& cde
abc n - -
a* y $&
***************
*** 218,226 ****
'a[b-d]'i AAC y $& AC
'a[-b]'i A- y $& A-
'a[b-]'i A- y $& A-
! 'a[b-a]'i - c - Invalid [] range "b-a" before HERE mark in regex m/a[b-a << HERE ]/
! 'a[]b'i - c - Unmatched [ before HERE mark in regex m/a[ << HERE ]b/
! 'a['i - c - Unmatched [ before HERE mark in regex m/a[ << HERE /
'a]'i A] y $& A]
'a[]]b'i A]B y $& A]B
'a[^bc]d'i AED y $& AED
--- 218,226 ----
'a[b-d]'i AAC y $& AC
'a[-b]'i A- y $& A-
'a[b-]'i A- y $& A-
! 'a[b-a]'i - c - Invalid [] range "b-a"
! 'a[]b'i - c - Unmatched [
! 'a['i - c - Unmatched [
'a]'i A] y $& A]
'a[]]b'i A]B y $& A]B
'a[^bc]d'i AED y $& AED
***************
*** 232,239 ****
'ab|cd'i ABC y $& AB
'ab|cd'i ABCD y $& AB
'()ef'i DEF y $&-$1 EF-
! '*a'i - c - Quantifier follows nothing before HERE mark in regex m/* << HERE a/
! '(*)b'i - c - Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/
'$b'i B n - -
'a\'i - c - Search pattern not terminated
'a\(b'i A(B y $&-$1 A(B-
--- 232,239 ----
'ab|cd'i ABC y $& AB
'ab|cd'i ABCD y $& AB
'()ef'i DEF y $&-$1 EF-
! '*a'i - c - Quantifier follows nothing
! '(*)b'i - c - Quantifier follows nothing
'$b'i B n - -
'a\'i - c - Search pattern not terminated
'a\(b'i A(B y $&-$1 A(B-
***************
*** 240,252 ****
'a\(*b'i AB y $& AB
'a\(*b'i A((B y $& A((B
'a\\b'i A\B y $& A\B
! 'abc)'i - c - Unmatched ) before HERE mark in regex m/abc) << HERE /
! '(abc'i - c - Unmatched ( before HERE mark in regex m/( << HERE abc/
'((a))'i ABC y $&-$1-$2 A-A-A
'(a)b(c)'i ABC y $&-$1-$2 ABC-A-C
'a+b+c'i AABBABC y $& ABC
'a{1,}b{1,}c'i AABBABC y $& ABC
! 'a**'i - c - Nested quantifiers before HERE mark in regex m/a** << HERE /
'a.+?c'i ABCABC y $& ABC
'a.*?c'i ABCABC y $& ABC
'a.{0,5}?c'i ABCABC y $& ABC
--- 240,252 ----
'a\(*b'i AB y $& AB
'a\(*b'i A((B y $& A((B
'a\\b'i A\B y $& A\B
! 'abc)'i - c - Unmatched )
! '(abc'i - c - Unmatched (
'((a))'i ABC y $&-$1-$2 A-A-A
'(a)b(c)'i ABC y $&-$1-$2 ABC-A-C
'a+b+c'i AABBABC y $& ABC
'a{1,}b{1,}c'i AABBABC y $& ABC
! 'a**'i - c - Nested quantifiers
'a.+?c'i ABCABC y $& ABC
'a.*?c'i ABCABC y $& ABC
'a.{0,5}?c'i ABCABC y $& ABC
***************
*** 257,263 ****
'(a+|b)?'i AB y $&-$1 A-A
'(a+|b){0,1}'i AB y $&-$1 A-A
'(a+|b){0,1}?'i AB y $&-$1 -
! ')('i - c - Unmatched ) before HERE mark in regex m/) << HERE (/
'[^ab]*'i CDE y $& CDE
'abc'i n - -
'a*'i y $&
--- 257,263 ----
'(a+|b)?'i AB y $&-$1 A-A
'(a+|b){0,1}'i AB y $&-$1 A-A
'(a+|b){0,1}?'i AB y $&-$1 -
! ')('i - c - Unmatched )
'[^ab]*'i CDE y $& CDE
'abc'i n - -
'a*'i y $&
***************
*** 346,352 ****
(?<!c)b cb n - -
(?<!c)b b y - -
(?<!c)b b y $& b
! (?<%)b - c - Sequence (?<%...) not recognized before HERE mark in regex m/(?<% << HERE )b/
(?:..)*a aba y $& aba
(?:..)*?a aba y $& a
^(?:b|a(?=(.)))*\1 abc y $& ab
--- 346,352 ----
(?<!c)b cb n - -
(?<!c)b b y - -
(?<!c)b b y $& b
! (?<%)b - c - Sequence (?<%...) not recognized
(?:..)*a aba y $& aba
(?:..)*?a aba y $& a
^(?:b|a(?=(.)))*\1 abc y $& ab
***************
*** 397,406 ****
'(ab)\d\1'i ab4Ab y $1 ab
foo\w*\d{4}baz foobar1234baz y $& foobar1234baz
a(?{})b cabd y $& ab
! a(?{)b - c - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE )b/
! a(?{{})b - c - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE {})b/
a(?{}})b - c -
! a(?{"{"})b - c - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE "{"})b/
a(?{"\{"})b cabd y $& ab
a(?{"{"}})b - c - Unmatched right curly bracket
a(?{$bl="\{"}).b caxbd y $bl {
--- 397,406 ----
'(ab)\d\1'i ab4Ab y $1 ab
foo\w*\d{4}baz foobar1234baz y $& foobar1234baz
a(?{})b cabd y $& ab
! a(?{)b - c - Sequence (?{...}) not terminated or not {}-balanced
! a(?{{})b - c - Sequence (?{...}) not terminated or not {}-balanced
a(?{}})b - c -
! a(?{"{"})b - c - Sequence (?{...}) not terminated or not {}-balanced
a(?{"\{"})b cabd y $& ab
a(?{"{"}})b - c - Unmatched right curly bracket
a(?{$bl="\{"}).b caxbd y $bl {
***************
*** 441,447 ****
^(\(+)?blah(?(1)(\)))$ blah y ($2) ()
^(\(+)?blah(?(1)(\)))$ blah) n - -
^(\(+)?blah(?(1)(\)))$ (blah n - -
! (?(1?)a|b) a c - Switch condition not recognized before HERE mark in regex m/(?(1? << HERE )a|b)/
(?(1)a|b|c) a c - Switch (?(condition)... contains too many branches
(?(?{0})a|b) a n - -
(?(?{0})b|a) a y $& a
--- 441,447 ----
^(\(+)?blah(?(1)(\)))$ blah y ($2) ()
^(\(+)?blah(?(1)(\)))$ blah) n - -
^(\(+)?blah(?(1)(\)))$ (blah n - -
! (?(1?)a|b) a c - Switch condition not recognized
(?(1)a|b|c) a c - Switch (?(condition)... contains too many branches
(?(?{0})a|b) a n - -
(?(?{0})b|a) a y $& a
***************
*** 473,482 ****
([[:]+) a:[b]: y $1 :[
([[=]+) a=[b]= y $1 =[
([[.]+) a.[b]. y $1 .[
! [a[:xyz: - c - Unmatched [ before HERE mark in regex m/[ << HERE a[:xyz:/
! [a[:xyz:] - c - POSIX class [:xyz:] unknown before HERE mark in regex m/[a[:xyz:] << HERE /
[a[:]b[:c] abc y $& abc
! ([a[:xyz:]b]+) pbaq c - POSIX class [:xyz:] unknown before HERE mark in regex m/([a[:xyz:] << HERE b]+)/
[a[:]b[:c] abc y $& abc
([[:alpha:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd
([[:alnum:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy
--- 473,482 ----
([[:]+) a:[b]: y $1 :[
([[=]+) a=[b]= y $1 =[
([[.]+) a.[b]. y $1 .[
! [a[:xyz: - c - Unmatched [
! [a[:xyz:] - c - POSIX class [:xyz:] unknown
[a[:]b[:c] abc y $& abc
! ([a[:xyz:]b]+) pbaq c - POSIX class [:xyz:] unknown
[a[:]b[:c] abc y $& abc
([[:alpha:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd
([[:alnum:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy
***************
*** 503,510 ****
([[:^word:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 -- ${nulnul}${ffff}
([[:^upper:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 cd01
([[:^xdigit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 Xy__-- ${nulnul}${ffff}
! [[:foo:]] - c - POSIX class [:foo:] unknown before HERE mark in regex m/[[:foo:] << HERE ]/
! [[:^foo:]] - c - POSIX class [:^foo:] unknown before HERE mark in regex m/[[:^foo:] << HERE ]/
((?>a+)b) aaab y $1 aaab
(?>(a+))b aaab y $1 aaa
((?>[^()]+)|\([^()]*\))+ ((abc(ade)ufh()()x y $& abc(ade)ufh()()x
--- 503,510 ----
([[:^word:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 -- ${nulnul}${ffff}
([[:^upper:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 cd01
([[:^xdigit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 Xy__-- ${nulnul}${ffff}
! [[:foo:]] - c - POSIX class [:foo:] unknown
! [[:^foo:]] - c - POSIX class [:^foo:] unknown
((?>a+)b) aaab y $1 aaab
(?>(a+))b aaab y $1 aaa
((?>[^()]+)|\([^()]*\))+ ((abc(ade)ufh()()x y $& abc(ade)ufh()()x
***************
*** 787,789 ****
--- 787,791 ----
(a)?(a)+ a y $1:$2 :a -
(ab)?(ab)+ ab y $1:$2 :ab -
(abc)?(abc)+ abc y $1:$2 :abc -
+ 'b\s^'m a\nb\n n - -
+ \ba a y - -
diff -c 'perl-5.7.1/t/op/regexp.t' 'perl-5.7.2/t/op/regexp.t'
Index: ./t/op/regexp.t
*** ./t/op/regexp.t Wed Mar 28 18:36:10 2001
--- ./t/op/regexp.t Mon Jul 9 17:11:28 2001
***************
*** 36,46 ****
@INC = '../lib';
}
- use re 'asciirange'; # ranges are computed in ASCII
-
$iters = shift || 1; # Poor man performance suite, 10000 is OK.
! open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests') ||
die "Can't open re_tests";
while (<TESTS>) { }
--- 36,44 ----
@INC = '../lib';
}
$iters = shift || 1; # Poor man performance suite, 10000 is OK.
! open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests') || open(TESTS,':op:re_tests') ||
die "Can't open re_tests";
while (<TESTS>) { }
***************
*** 72,79 ****
$expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;
$skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//));
# Certain tests don't work with utf8 (the re_test should be in UTF8)
! $skip = 1, $reason = 'utf8'
! if ($^H &= ~0x00000008) && $pat =~ /\[:\^(alnum|print|word|ascii|xdigit):\]/;
$result =~ s/B//i unless $skip;
for $study ('', 'study \$subject') {
$c = $iters;
--- 70,77 ----
$expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;
$skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//));
# Certain tests don't work with utf8 (the re_test should be in UTF8)
! # $skip = 1, $reason = 'utf8'
! # if ($^H &= ~0x00000008) && $pat =~ /\[:\^(alnum|print|word|ascii|xdigit):\]/;
$result =~ s/B//i unless $skip;
for $study ('', 'study \$subject') {
$c = $iters;
diff -c 'perl-5.7.1/t/op/regexp_noamp.t' 'perl-5.7.2/t/op/regexp_noamp.t'
Index: ./t/op/regexp_noamp.t
*** ./t/op/regexp_noamp.t Tue Mar 6 04:07:14 2001
--- ./t/op/regexp_noamp.t Mon Jul 9 17:11:28 2001
***************
*** 1,10 ****
#!./perl
$skip_amp = 1;
! for $file ('op/regexp.t', 't/op/regexp.t') {
if (-r $file) {
! do "./$file";
exit;
}
}
! die "Cannot find op/regexp.t or t/op/regexp.t\n";
--- 1,10 ----
#!./perl
$skip_amp = 1;
! for $file ('./op/regexp.t', './t/op/regexp.t', ':op:regexp.t') {
if (-r $file) {
! do $file;
exit;
}
}
! die "Cannot find ./op/regexp.t or ./t/op/regexp.t\n";
diff -c 'perl-5.7.1/t/op/regmesg.t' 'perl-5.7.2/t/op/regmesg.t'
Index: ./t/op/regmesg.t
*** ./t/op/regmesg.t Tue Mar 20 06:40:58 2001
--- ./t/op/regmesg.t Mon Jul 9 17:11:28 2001
***************
*** 13,20 ****
## arrays below. The {#} is a meta-marker -- it marks where the marker should
## go.
! my $marker1 = "HERE";
! my $marker2 = " << HERE ";
##
## Key-value pairs of code/error of code that should have fatal errors.
--- 13,20 ----
## arrays below. The {#} is a meta-marker -- it marks where the marker should
## go.
! my $marker1 = "<-- HERE";
! my $marker2 = " <-- HERE ";
##
## Key-value pairs of code/error of code that should have fatal errors.
***************
*** 26,83 ****
my $inf_p1 = $inf_m1 + 2;
my @death =
(
! '/[[=foo=]]/' => 'POSIX syntax [= =] is reserved for future extensions before {#} mark in regex m/[[=foo=]{#}]/',
! '/(?<= .*)/' => 'Variable length lookbehind not implemented before {#} mark in regex m/(?<= .*){#}/',
! '/(?<= x{1000})/' => 'Lookbehind longer than 255 not implemented before {#} mark in regex m/(?<= x{1000}){#}/',
! '/(?@)/' => 'Sequence (?@...) not implemented before {#} mark in regex m/(?@{#})/',
! '/(?{ 1/' => 'Sequence (?{...}) not terminated or not {}-balanced before {#} mark in regex m/(?{{#} 1/',
! '/(?(1x))/' => 'Switch condition not recognized before {#} mark in regex m/(?(1x{#}))/',
! '/(?(1)x|y|z)/' => 'Switch (?(condition)... contains too many branches before {#} mark in regex m/(?(1)x|y|{#}z)/',
! '/(?(x)y|x)/' => 'Unknown switch condition (?(x) before {#} mark in regex m/(?({#}x)y|x)/',
! '/(?/' => 'Sequence (? incomplete before {#} mark in regex m/(?{#}/',
! '/(?;x/' => 'Sequence (?;...) not recognized before {#} mark in regex m/(?;{#}x/',
! '/(?<;x/' => 'Sequence (?<;...) not recognized before {#} mark in regex m/(?<;{#}x/',
! '/((x)/' => 'Unmatched ( before {#} mark in regex m/({#}(x)/',
! "/x{$inf_p1}/" => "Quantifier in {,} bigger than $inf_m1 before {#} mark in regex m/x{{#}$inf_p1}/",
! '/x{3,1}/' => 'Can\'t do {n,m} with n > m before {#} mark in regex m/x{3,1}{#}/',
! '/x**/' => 'Nested quantifiers before {#} mark in regex m/x**{#}/',
! '/x[/' => 'Unmatched [ before {#} mark in regex m/x[{#}/',
! '/*/', => 'Quantifier follows nothing before {#} mark in regex m/*{#}/',
! '/\p{x/' => 'Missing right brace on \p{} before {#} mark in regex m/\p{{#}x/',
! 'use utf8; /[\p{x]/' => 'Missing right brace on \p{} before {#} mark in regex m/[\p{{#}x]/',
! '/(x)\2/' => 'Reference to nonexistent group before {#} mark in regex m/(x)\2{#}/',
'my $m = "\\\"; $m =~ $m', => 'Trailing \ in regex m/\/',
! '/\x{1/' => 'Missing right brace on \x{} before {#} mark in regex m/\x{{#}1/',
! 'use utf8; /[\x{X]/' => 'Missing right brace on \x{} before {#} mark in regex m/[\x{{#}X]/',
! '/[[:barf:]]/' => 'POSIX class [:barf:] unknown before {#} mark in regex m/[[:barf:]{#}]/',
! '/[[=barf=]]/' => 'POSIX syntax [= =] is reserved for future extensions before {#} mark in regex m/[[=barf=]{#}]/',
! '/[[.barf.]]/' => 'POSIX syntax [. .] is reserved for future extensions before {#} mark in regex m/[[.barf.]{#}]/',
! '/[z-a]/' => 'Invalid [] range "z-a" before {#} mark in regex m/[z-a{#}]/',
);
##
--- 26,83 ----
my $inf_p1 = $inf_m1 + 2;
my @death =
(
! '/[[=foo=]]/' => 'POSIX syntax [= =] is reserved for future extensions in regex; marked by {#} in m/[[=foo=]{#}]/',
! '/(?<= .*)/' => 'Variable length lookbehind not implemented in regex; marked by {#} in m/(?<= .*){#}/',
! '/(?<= x{1000})/' => 'Lookbehind longer than 255 not implemented in regex; marked by {#} in m/(?<= x{1000}){#}/',
! '/(?@)/' => 'Sequence (?@...) not implemented in regex; marked by {#} in m/(?@{#})/',
! '/(?{ 1/' => 'Sequence (?{...}) not terminated or not {}-balanced in regex; marked by {#} in m/(?{{#} 1/',
! '/(?(1x))/' => 'Switch condition not recognized in regex; marked by {#} in m/(?(1x{#}))/',
! '/(?(1)x|y|z)/' => 'Switch (?(condition)... contains too many branches in regex; marked by {#} in m/(?(1)x|y|{#}z)/',
! '/(?(x)y|x)/' => 'Unknown switch condition (?(x) in regex; marked by {#} in m/(?({#}x)y|x)/',
! '/(?/' => 'Sequence (? incomplete in regex; marked by {#} in m/(?{#}/',
! '/(?;x/' => 'Sequence (?;...) not recognized in regex; marked by {#} in m/(?;{#}x/',
! '/(?<;x/' => 'Sequence (?<;...) not recognized in regex; marked by {#} in m/(?<;{#}x/',
! '/((x)/' => 'Unmatched ( in regex; marked by {#} in m/({#}(x)/',
! "/x{$inf_p1}/" => "Quantifier in {,} bigger than $inf_m1 in regex; marked by {#} in m/x{{#}$inf_p1}/",
! '/x{3,1}/' => 'Can\'t do {n,m} with n > m in regex; marked by {#} in m/x{3,1}{#}/',
! '/x**/' => 'Nested quantifiers in regex; marked by {#} in m/x**{#}/',
! '/x[/' => 'Unmatched [ in regex; marked by {#} in m/x[{#}/',
! '/*/', => 'Quantifier follows nothing in regex; marked by {#} in m/*{#}/',
! '/\p{x/' => 'Missing right brace on \p{} in regex; marked by {#} in m/\p{{#}x/',
! 'use utf8; /[\p{x]/' => 'Missing right brace on \p{} in regex; marked by {#} in m/[\p{{#}x]/',
! '/(x)\2/' => 'Reference to nonexistent group in regex; marked by {#} in m/(x)\2{#}/',
'my $m = "\\\"; $m =~ $m', => 'Trailing \ in regex m/\/',
! '/\x{1/' => 'Missing right brace on \x{} in regex; marked by {#} in m/\x{{#}1/',
! 'use utf8; /[\x{X]/' => 'Missing right brace on \x{} in regex; marked by {#} in m/[\x{{#}X]/',
! '/[[:barf:]]/' => 'POSIX class [:barf:] unknown in regex; marked by {#} in m/[[:barf:]{#}]/',
! '/[[=barf=]]/' => 'POSIX syntax [= =] is reserved for future extensions in regex; marked by {#} in m/[[=barf=]{#}]/',
! '/[[.barf.]]/' => 'POSIX syntax [. .] is reserved for future extensions in regex; marked by {#} in m/[[.barf.]{#}]/',
! '/[z-a]/' => 'Invalid [] range "z-a" in regex; marked by {#} in m/[z-a{#}]/',
);
##
***************
*** 84,100 ****
## Key-value pairs of code/error of code that should have non-fatal warnings.
##
@warning = (
! "m/(?p{ 'a' })/" => "(?p{}) is deprecated - use (??{}) before {#} mark in regex m/(?p{#}{ 'a' })/",
! 'm/\b*/' => '\b* matches null string many times before {#} mark in regex m/\b*{#}/',
! 'm/[:blank:]/' => 'POSIX syntax [: :] belongs inside character classes before {#} mark in regex m/[:blank:]{#}/',
! "m'[\\y]'" => 'Unrecognized escape \y in character class passed through before {#} mark in regex m/[\y{#}]/',
! 'm/[a-\d]/' => 'False [] range "a-\d" before {#} mark in regex m/[a-\d{#}]/',
! 'm/[\w-x]/' => 'False [] range "\w-" before {#} mark in regex m/[\w-{#}x]/',
! "m'\\y'" => 'Unrecognized escape \y passed through before {#} mark in regex m/\y{#}/',
);
my $total = (@death + @warning)/2;
--- 84,100 ----
## Key-value pairs of code/error of code that should have non-fatal warnings.
##
@warning = (
! "m/(?p{ 'a' })/" => "(?p{}) is deprecated - use (??{}) in regex; marked by {#} in m/(?p{#}{ 'a' })/",
! 'm/\b*/' => '\b* matches null string many times in regex; marked by {#} in m/\b*{#}/',
! 'm/[:blank:]/' => 'POSIX syntax [: :] belongs inside character classes in regex; marked by {#} in m/[:blank:]{#}/',
! "m'[\\y]'" => 'Unrecognized escape \y in character class passed through in regex; marked by {#} in m/[\y{#}]/',
! 'm/[a-\d]/' => 'False [] range "a-\d" in regex; marked by {#} in m/[a-\d{#}]/',
! 'm/[\w-x]/' => 'False [] range "\w-" in regex; marked by {#} in m/[\w-{#}x]/',
! "m'\\y'" => 'Unrecognized escape \y passed through in regex; marked by {#} in m/\y{#}/',
);
my $total = (@death + @warning)/2;
diff -c 'perl-5.7.1/t/op/runlevel.t' 'perl-5.7.2/t/op/runlevel.t'
Index: ./t/op/runlevel.t
*** ./t/op/runlevel.t Tue Mar 6 04:07:15 2001
--- ./t/op/runlevel.t Mon Jul 9 17:11:28 2001
***************
*** 10,15 ****
--- 10,16 ----
@INC = '../lib';
$Is_VMS = $^O eq 'VMS';
$Is_MSWin32 = $^O eq 'MSWin32';
+ $Is_NetWare = $^O eq 'NetWare';
$ENV{PERL5LIB} = "../lib" unless $Is_VMS;
$|=1;
***************
*** 35,40 ****
--- 36,43 ----
`MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` :
$Is_MSWin32 ?
`.\\perl -I../lib $switch $tmpfile 2>&1` :
+ $Is_NetWare ?
+ `perl -I../lib $switch $tmpfile 2>&1` :
`./perl $switch $tmpfile 2>&1`;
my $status = $?;
$results =~ s/\n+$//;
diff -c 'perl-5.7.1/t/op/splice.t' 'perl-5.7.2/t/op/splice.t'
Index: ./t/op/splice.t
*** ./t/op/splice.t Tue Mar 6 04:07:15 2001
--- ./t/op/splice.t Thu Jul 12 17:21:09 2001
***************
*** 1,6 ****
#!./perl
! print "1..9\n";
@a = (1..10);
--- 1,6 ----
#!./perl
! print "1..12\n";
@a = (1..10);
***************
*** 32,34 ****
--- 32,54 ----
print "not " unless j(splice(@a,-3,-2,2)) eq j(7) && j(@a) eq j(1,2,7,3);
print "ok 9\n";
+
+ # Bug 20000223.001 - no test for splice(@array). Destructive test!
+ print "not " unless j(splice(@a)) eq j(1,2,7,3) && j(@a) eq '';
+ print "ok 10\n";
+
+ # Tests 11 and 12:
+ # [ID 20010711.005] in Tie::Array, SPLICE ignores context, breaking SHIFT
+
+ my $foo;
+
+ @a = ('red', 'green', 'blue');
+ $foo = splice @a, 1, 2;
+ print "not " unless $foo eq 'blue';
+ print "ok 11\n";
+
+ @a = ('red', 'green', 'blue');
+ $foo = shift @a;
+ print "not " unless $foo eq 'red';
+ print "ok 12\n";
+
diff -c 'perl-5.7.1/t/op/split.t' 'perl-5.7.2/t/op/split.t'
Index: ./t/op/split.t
*** ./t/op/split.t Thu Mar 8 00:03:55 2001
--- ./t/op/split.t Mon Jul 9 17:11:28 2001
***************
*** 5,11 ****
@INC = '../lib';
}
! print "1..44\n";
$FS = ':';
--- 5,11 ----
@INC = '../lib';
}
! print "1..45\n";
$FS = ':';
***************
*** 51,57 ****
--- 51,59 ----
# Does assignment to a list imply split to one more field than that?
if ($^O eq 'MSWin32') { $foo = `.\\perl -D1024 -e "(\$a,\$b) = split;" 2>&1` }
+ elsif ($^O eq 'NetWare') { $foo = `perl -D1024 -e "(\$a,\$b) = split;" 2>&1` }
elsif ($^O eq 'VMS') { $foo = `./perl "-D1024" -e "(\$a,\$b) = split;" 2>&1` }
+ elsif ($^O eq 'MacOS'){ $foo = `$^X "-D1024" -e "(\$a,\$b) = split;"` }
else { $foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1` }
print $foo =~ /DEBUGGING/ || $foo =~ /SV = (VOID|IV\(3\))/ ? "ok 11\n" : "not ok 11\n";
***************
*** 242,244 ****
--- 244,256 ----
print "ok 44\n";
}
+ {
+ # check that PMf_WHITE is cleared after \s+ is used
+ # reported in <20010627113312.RWGY6087.viemta06@localhost>
+ my $r;
+ foreach my $pat ( qr/\s+/, qr/ll/ ) {
+ $r = join ':' => split($pat, "hello cruel world");
+ }
+ print "not " unless $r eq "he:o cruel world";
+ print "ok 45\n";
+ }
diff -c 'perl-5.7.1/t/op/sprintf.t' 'perl-5.7.2/t/op/sprintf.t'
Index: ./t/op/sprintf.t
*** ./t/op/sprintf.t Tue Mar 6 04:07:15 2001
--- ./t/op/sprintf.t Mon Jul 9 17:11:28 2001
***************
*** 31,36 ****
--- 31,42 ----
for ($i = 1; @tests; $i++) {
($template, $data, $result, $comment) = @{shift @tests};
+ if ($^O eq 'os390' || $^O eq 's390') { # non-IEEE (s390 is UTS)
+ $data =~ s/([eE])96$/${1}63/; # smaller exponents
+ $result =~ s/([eE]\+)102$/${1}69/; # " "
+ $data =~ s/([eE])\-101$/${1}-56/; # larger exponents
+ $result =~ s/([eE])\-102$/${1}-57/; # " "
+ }
$evalData = eval $data;
$w = undef;
$x = sprintf(">$template<",
***************
*** 96,101 ****
--- 102,113 ----
>%.0f< >-0.1< >-0< >C library bug: no minus on VMS, HP-UX<
>%.0f< >1.5< >2< >Standard vague: no rounding rules<
>%.0f< >2.5< >2< >Standard vague: no rounding rules<
+ >%G< >1234567e96< >1.23457E+102< >exponent too big for OS/390<
+ >%G< >.1234567e-101< >1.23457E-102< >exponent too small for OS/390<
+ >%e< >1234567E96< >1.234567e+102< >exponent too big for OS/390<
+ >%e< >.1234567E-101< >1.234567e-102< >exponent too small for OS/390<
+ >%g< >.1234567E-101< >1.23457e-102< >exponent too small for OS/390<
+ >%g< >1234567E96< >1.23457e+102< >exponent too big for OS/390<
=end problematic
diff -c 'perl-5.7.1/t/op/stat.t' 'perl-5.7.2/t/op/stat.t'
Index: ./t/op/stat.t
*** ./t/op/stat.t Fri Mar 9 17:21:55 2001
--- ./t/op/stat.t Mon Jul 9 17:11:29 2001
***************
*** 12,21 ****
print "1..58\n";
$Is_MSWin32 = $^O eq 'MSWin32';
$Is_Dos = $^O eq 'dos';
- $Is_Dosish = $Is_Dos || $^O eq 'os2' || $Is_MSWin32;
$Is_Cygwin = $^O eq 'cygwin';
! chop($cwd = ($Is_MSWin32 ? `cd` : `pwd`));
$DEV = `ls -l /dev` unless $Is_Dosish or $Is_Cygwin;
--- 12,23 ----
print "1..58\n";
$Is_MSWin32 = $^O eq 'MSWin32';
+ $Is_NetWare = $^O eq 'NetWare';
$Is_Dos = $^O eq 'dos';
$Is_Cygwin = $^O eq 'cygwin';
! $Is_MPE = $^O eq 'mpeix';
! $Is_Dosish = $Is_Dos || $^O eq 'os2' || $Is_MSWin32 || $Is_NetWare || $Is_Cygwin;
! chop($cwd = (($Is_MSWin32 || $Is_NetWare) ? `cd` : `pwd`));
$DEV = `ls -l /dev` unless $Is_Dosish or $Is_Cygwin;
***************
*** 22,28 ****
unlink "Op.stat.tmp";
if (open(FOO, ">Op.stat.tmp")) {
# hack to make Apollo update link count:
! $junk = `ls Op.stat.tmp` unless ($Is_MSWin32 || $Is_Dos);
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat(FOO);
--- 24,30 ----
unlink "Op.stat.tmp";
if (open(FOO, ">Op.stat.tmp")) {
# hack to make Apollo update link count:
! $junk = `ls Op.stat.tmp` unless ($Is_MSWin32 || $Is_NetWare || $Is_Dos);
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat(FOO);
***************
*** 32,38 ****
else {
print "# res=$res, nlink=$nlink.\nnot ok 1\n";
}
! if ($Is_MSWin32 or $Is_Cygwin or $Is_Dos || ($mtime && $mtime == $ctime)) {
print "ok 2\n";
}
else {
--- 34,40 ----
else {
print "# res=$res, nlink=$nlink.\nnot ok 1\n";
}
! if ($Is_MSWin32 or $Is_NetWare or $Is_Cygwin or $Is_Dos || ($mtime && $mtime == $ctime)) {
print "ok 2\n";
}
else {
***************
*** 52,58 ****
print "# open failed: $!\nnot ok 1\nnot ok 2\n";
}
! if ($Is_Dosish) { unlink "Op.stat.tmp2"}
else {
`rm -f Op.stat.tmp2;ln Op.stat.tmp Op.stat.tmp2; chmod 644 Op.stat.tmp`;
}
--- 54,60 ----
print "# open failed: $!\nnot ok 1\nnot ok 2\n";
}
! if ($Is_Dosish || $Is_MPE) { unlink "Op.stat.tmp2"}
else {
`rm -f Op.stat.tmp2;ln Op.stat.tmp Op.stat.tmp2; chmod 644 Op.stat.tmp`;
}
***************
*** 60,75 ****
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat('Op.stat.tmp');
! if ($Is_Dosish || $Config{dont_use_nlink})
{print "ok 3 # skipped: no link count\n";}
elsif ($nlink == 2)
{print "ok 3\n";}
else {print "# \$nlink is |$nlink|\nnot ok 3\n";}
! if ( $Is_Dosish
# Solaris tmpfs bug
|| ($cwd =~ m#^/tmp# and $mtime && $mtime==$ctime && $^O eq 'solaris')
! || $cwd =~ m#/afs/#
|| $^O eq 'amigaos') {
print "ok 4 # skipped: different semantic of mtime/ctime\n";
}
--- 62,77 ----
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat('Op.stat.tmp');
! if ($Is_Dosish || $Is_MPE || $Config{dont_use_nlink})
{print "ok 3 # skipped: no link count\n";}
elsif ($nlink == 2)
{print "ok 3\n";}
else {print "# \$nlink is |$nlink|\nnot ok 3\n";}
! if ( $Is_Dosish || $Is_MPE
# Solaris tmpfs bug
|| ($cwd =~ m#^/tmp# and $mtime && $mtime==$ctime && $^O eq 'solaris')
! || $cwd =~ m#$Config{'afsroot'}/#
|| $^O eq 'amigaos') {
print "ok 4 # skipped: different semantic of mtime/ctime\n";
}
***************
*** 85,91 ****
print "#4 :$mtime: should != :$ctime:\n";
unlink "Op.stat.tmp" or print "# unlink failed: $!\n";
! if ($Is_MSWin32) { open F, '>Op.stat.tmp' and close F }
else { `touch Op.stat.tmp` }
if (-z 'Op.stat.tmp') {print "ok 5\n";} else {print "not ok 5\n";}
--- 87,93 ----
print "#4 :$mtime: should != :$ctime:\n";
unlink "Op.stat.tmp" or print "# unlink failed: $!\n";
! if ($Is_MSWin32 || $Is_NetWare) { open F, '>Op.stat.tmp' and close F }
else { `touch Op.stat.tmp` }
if (-z 'Op.stat.tmp') {print "ok 5\n";} else {print "not ok 5\n";}
***************
*** 100,106 ****
$Is_MSWin32 ? `cmd /c echo hi > Op.stat.tmp` : `echo hi >Op.stat.tmp`;
chmod 0,'Op.stat.tmp';
eval '$> = 1;'; # so switch uid (may not be implemented)
! if (!$> || $Is_Dos || ! -r 'Op.stat.tmp') {print "ok 9\n";} else {print "not ok 9\n";}
if (!$> || ! -w 'Op.stat.tmp') {print "ok 10\n";} else {print "not ok 10\n";}
eval '$> = $olduid;'; # switch uid back (may not be implemented)
print "# olduid=$olduid, newuid=$>\n" unless ($> == $olduid);
--- 102,108 ----
$Is_MSWin32 ? `cmd /c echo hi > Op.stat.tmp` : `echo hi >Op.stat.tmp`;
chmod 0,'Op.stat.tmp';
eval '$> = 1;'; # so switch uid (may not be implemented)
! if (!$> || $Is_Dos || $Is_Cygwin || ! -r 'Op.stat.tmp') {print "ok 9\n";} else {print "not ok 9\n";}
if (!$> || ! -w 'Op.stat.tmp') {print "ok 10\n";} else {print "not ok 10\n";}
eval '$> = $olduid;'; # switch uid back (may not be implemented)
print "# olduid=$olduid, newuid=$>\n" unless ($> == $olduid);
***************
*** 141,147 ****
unlink 'Op.stat.tmp2';
if (! -e 'Op.stat.tmp2') {print "ok 28\n";} else {print "not ok 28\n";}
! if ($Is_MSWin32 || $Is_Dos)
{print "ok 29\n";}
elsif ($DEV !~ /\nc.* (\S+)\n/)
{print "ok 29\n";}
--- 143,149 ----
unlink 'Op.stat.tmp2';
if (! -e 'Op.stat.tmp2') {print "ok 28\n";} else {print "not ok 28\n";}
! if ($Is_MSWin32 || $Is_NetWare || $Is_Dos)
{print "ok 29\n";}
elsif ($DEV !~ /\nc.* (\S+)\n/)
{print "ok 29\n";}
***************
*** 151,157 ****
{print "not ok 29\n";}
if (! -c '.') {print "ok 30\n";} else {print "not ok 30\n";}
! if ($Is_MSWin32 || $Is_Dos)
{print "ok 31\n";}
elsif ($DEV !~ /\ns.* (\S+)\n/)
{print "ok 31\n";}
--- 153,159 ----
{print "not ok 29\n";}
if (! -c '.') {print "ok 30\n";} else {print "not ok 30\n";}
! if ($Is_MSWin32 || $Is_NetWare || $Is_Dos)
{print "ok 31\n";}
elsif ($DEV !~ /\ns.* (\S+)\n/)
{print "ok 31\n";}
***************
*** 161,167 ****
{print "not ok 31\n";}
if (! -S '.') {print "ok 32\n";} else {print "not ok 32\n";}
! if ($Is_MSWin32 || $Is_Dos)
{print "ok 33\n";}
elsif ($DEV !~ /\nb.* (\S+)\n/)
{print "ok 33\n";}
--- 163,169 ----
{print "not ok 31\n";}
if (! -S '.') {print "ok 32\n";} else {print "not ok 32\n";}
! if ($Is_MSWin32 || $Is_NetWare || $Is_Dos)
{print "ok 33\n";}
elsif ($DEV !~ /\nb.* (\S+)\n/)
{print "ok 33\n";}
***************
*** 171,177 ****
{print "not ok 33\n";}
if (! -b '.') {print "ok 34\n";} else {print "not ok 34\n";}
! if ($^O eq 'mpeix' or $^O eq 'amigaos' or $Is_Dosish or $Is_Cygwin) {
print "ok 35 # skipped: no -u\n"; goto tty_test;
}
--- 173,179 ----
{print "not ok 33\n";}
if (! -b '.') {print "ok 34\n";} else {print "not ok 34\n";}
! if ($Is_MPE or $^O eq 'amigaos' or $Is_Dosish or $Is_Cygwin) {
print "ok 35 # skipped: no -u\n"; goto tty_test;
}
***************
*** 205,211 ****
# may not be available (at, cron rsh etc), the PERL_SKIP_TTY_TEST env var
# can be set to skip the tests that need a tty.
unless($ENV{PERL_SKIP_TTY_TEST}) {
! if ($Is_MSWin32) {
print "ok 36\n";
print "ok 37\n";
}
--- 207,213 ----
# may not be available (at, cron rsh etc), the PERL_SKIP_TTY_TEST env var
# can be set to skip the tests that need a tty.
unless($ENV{PERL_SKIP_TTY_TEST}) {
! if ($Is_MSWin32 || $Is_NetWare) {
print "ok 36\n";
print "ok 37\n";
}
***************
*** 236,242 ****
print "ok 39\n";
}
open(null,"/dev/null");
! if (! -t null || -e '/xenix' || $^O eq 'machten' || $Is_MSWin32)
{print "ok 40\n";} else {print "not ok 40\n";}
close(null);
--- 238,244 ----
print "ok 39\n";
}
open(null,"/dev/null");
! if (! -t null || -e '/xenix' || $^O eq 'machten' || $Is_MSWin32 || $Is_NetWare)
{print "ok 40\n";} else {print "not ok 40\n";}
close(null);
diff -c 'perl-5.7.1/t/op/study.t' 'perl-5.7.2/t/op/study.t'
Index: ./t/op/study.t
*** ./t/op/study.t Tue Mar 6 04:07:15 2001
--- ./t/op/study.t Mon Jul 9 17:11:29 2001
***************
*** 1,8 ****
#!./perl
! # $RCSfile: study.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:30 $
! print "1..24\n";
$x = "abc\ndef\n";
study($x);
--- 1,11 ----
#!./perl
! BEGIN {
! chdir 't' if -d 't';
! @INC = '../lib';
! }
! print "1..26\n";
$x = "abc\ndef\n";
study($x);
***************
*** 67,69 ****
--- 70,103 ----
$* = 1; # test 3 only tested the optimized version--this one is for real
if ("ab\ncd\n" =~ /^cd/) {print "ok 24\n";} else {print "not ok 24\n";}
+
+ if ($^O eq 'os390') {
+ # Even with the alarm() OS/390 can't manage these tests
+ # (Perl just goes into a busy loop, luckily an interruptable one)
+ for (25..26) { print "not ok $_ # compiler bug?\n" }
+ } else {
+ # [ID 20010618.006] tests 25..26 may loop
+ use Config;
+ my $have_alarm = $Config{d_alarm};
+ local $SIG{ALRM} = sub { die "timeout\n" };
+
+ $_ = 'FGF';
+ study;
+ my $ok = $have_alarm
+ ? eval { alarm(2); my $match = /G.F$/; alarm(0); !$match }
+ : eval { !/G.F$/ };
+ if ($ok && !$@) {
+ print "ok 25\n";
+ } else {
+ print "not ok 25\t# " . $@ || "should not match\n";
+ }
+ $ok = $have_alarm
+ ? eval { alarm(2); my $match = /[F]F$/; alarm(0); !$match }
+ : eval { !/[F]F$/ };
+ if ($ok && !$@) {
+ print "ok 26\n";
+ } else {
+ print "not ok 26\t# " . $@ || "should not match\n";
+ }
+ }
+
diff -c /dev/null 'perl-5.7.2/t/op/sub_lval.t'
Index: ./t/op/sub_lval.t
*** ./t/op/sub_lval.t Thu Jan 1 02:00:00 1970
--- ./t/op/sub_lval.t Mon Jul 9 17:11:29 2001
***************
*** 0 ****
--- 1,534 ----
+ print "1..64\n";
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary
+ sub b : lvalue { ${\shift} }
+
+ my $out = a(b()); # Check that temporaries are allowed.
+ print "# `$out'\nnot " unless ref $out eq 'main'; # Not reached if error.
+ print "ok 1\n";
+
+ my @out = grep /main/, a(b()); # Check that temporaries are allowed.
+ print "# `@out'\nnot " unless @out==1; # Not reached if error.
+ print "ok 2\n";
+
+ my $in;
+
+ # Check that we can return localized values from subroutines:
+
+ sub in : lvalue { $in = shift; }
+ sub neg : lvalue { #(num_str) return num_str
+ local $_ = shift;
+ s/^\+/-/;
+ $_;
+ }
+ in(neg("+2"));
+
+
+ print "# `$in'\nnot " unless $in eq '-2';
+ print "ok 3\n";
+
+ sub get_lex : lvalue { $in }
+ sub get_st : lvalue { $blah }
+ sub id : lvalue { ${\shift} }
+ sub id1 : lvalue { $_[0] }
+ sub inc : lvalue { ${\++$_[0]} }
+
+ $in = 5;
+ $blah = 3;
+
+ get_st = 7;
+
+ print "# `$blah' ne 7\nnot " unless $blah eq 7;
+ print "ok 4\n";
+
+ get_lex = 7;
+
+ print "# `$in' ne 7\nnot " unless $in eq 7;
+ print "ok 5\n";
+
+ ++get_st;
+
+ print "# `$blah' ne 8\nnot " unless $blah eq 8;
+ print "ok 6\n";
+
+ ++get_lex;
+
+ print "# `$in' ne 8\nnot " unless $in eq 8;
+ print "ok 7\n";
+
+ id(get_st) = 10;
+
+ print "# `$blah' ne 10\nnot " unless $blah eq 10;
+ print "ok 8\n";
+
+ id(get_lex) = 10;
+
+ print "# `$in' ne 10\nnot " unless $in eq 10;
+ print "ok 9\n";
+
+ ++id(get_st);
+
+ print "# `$blah' ne 11\nnot " unless $blah eq 11;
+ print "ok 10\n";
+
+ ++id(get_lex);
+
+ print "# `$in' ne 11\nnot " unless $in eq 11;
+ print "ok 11\n";
+
+ id1(get_st) = 20;
+
+ print "# `$blah' ne 20\nnot " unless $blah eq 20;
+ print "ok 12\n";
+
+ id1(get_lex) = 20;
+
+ print "# `$in' ne 20\nnot " unless $in eq 20;
+ print "ok 13\n";
+
+ ++id1(get_st);
+
+ print "# `$blah' ne 21\nnot " unless $blah eq 21;
+ print "ok 14\n";
+
+ ++id1(get_lex);
+
+ print "# `$in' ne 21\nnot " unless $in eq 21;
+ print "ok 15\n";
+
+ inc(get_st);
+
+ print "# `$blah' ne 22\nnot " unless $blah eq 22;
+ print "ok 16\n";
+
+ inc(get_lex);
+
+ print "# `$in' ne 22\nnot " unless $in eq 22;
+ print "ok 17\n";
+
+ inc(id(get_st));
+
+ print "# `$blah' ne 23\nnot " unless $blah eq 23;
+ print "ok 18\n";
+
+ inc(id(get_lex));
+
+ print "# `$in' ne 23\nnot " unless $in eq 23;
+ print "ok 19\n";
+
+ ++inc(id1(id(get_st)));
+
+ print "# `$blah' ne 25\nnot " unless $blah eq 25;
+ print "ok 20\n";
+
+ ++inc(id1(id(get_lex)));
+
+ print "# `$in' ne 25\nnot " unless $in eq 25;
+ print "ok 21\n";
+
+ @a = (1) x 3;
+ @b = (undef) x 2;
+ $#c = 3; # These slots are not fillable.
+
+ # Explanation: empty slots contain &sv_undef.
+
+ =for disabled constructs
+
+ sub a3 :lvalue {@a}
+ sub b2 : lvalue {@b}
+ sub c4: lvalue {@c}
+
+ $_ = '';
+
+ eval <<'EOE' or $_ = $@;
+ ($x, a3, $y, b2, $z, c4, $t) = (34 .. 78);
+ 1;
+ EOE
+
+ #@out = ($x, a3, $y, b2, $z, c4, $t);
+ #@in = (34 .. 41, (undef) x 4, 46);
+ #print "# `@out' ne `@in'\nnot " unless "@out" eq "@in";
+
+ print "# '$_'.\nnot "
+ unless /Can\'t return an uninitialized value from lvalue subroutine/;
+ =cut
+
+ print "ok 22\n";
+
+ my $var;
+
+ sub a::var : lvalue { $var }
+
+ "a"->var = 45;
+
+ print "# `$var' ne 45\nnot " unless $var eq 45;
+ print "ok 23\n";
+
+ my $oo;
+ $o = bless \$oo, "a";
+
+ $o->var = 47;
+
+ print "# `$var' ne 47\nnot " unless $var eq 47;
+ print "ok 24\n";
+
+ sub o : lvalue { $o }
+
+ o->var = 49;
+
+ print "# `$var' ne 49\nnot " unless $var eq 49;
+ print "ok 25\n";
+
+ sub nolv () { $x0, $x1 } # Not lvalue
+
+ $_ = '';
+
+ eval <<'EOE' or $_ = $@;
+ nolv = (2,3);
+ 1;
+ EOE
+
+ print "not "
+ unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
+ print "ok 26\n";
+
+ $_ = '';
+
+ eval <<'EOE' or $_ = $@;
+ nolv = (2,3) if $_;
+ 1;
+ EOE
+
+ print "not "
+ unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
+ print "ok 27\n";
+
+ $_ = '';
+
+ eval <<'EOE' or $_ = $@;
+ &nolv = (2,3) if $_;
+ 1;
+ EOE
+
+ print "not "
+ unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
+ print "ok 28\n";
+
+ $x0 = $x1 = $_ = undef;
+ $nolv = \&nolv;
+
+ eval <<'EOE' or $_ = $@;
+ $nolv->() = (2,3) if $_;
+ 1;
+ EOE
+
+ print "# '$_', '$x0', '$x1'.\nnot " if defined $_;
+ print "ok 29\n";
+
+ $x0 = $x1 = $_ = undef;
+ $nolv = \&nolv;
+
+ eval <<'EOE' or $_ = $@;
+ $nolv->() = (2,3);
+ 1;
+ EOE
+
+ print "# '$_', '$x0', '$x1'.\nnot "
+ unless /Can\'t modify non-lvalue subroutine call/;
+ print "ok 30\n";
+
+ sub lv0 : lvalue { } # Converted to lv10 in scalar context
+
+ $_ = undef;
+ eval <<'EOE' or $_ = $@;
+ lv0 = (2,3);
+ 1;
+ EOE
+
+ print "# '$_'.\nnot "
+ unless /Can\'t return a readonly value from lvalue subroutine/;
+ print "ok 31\n";
+
+ sub lv10 : lvalue {}
+
+ $_ = undef;
+ eval <<'EOE' or $_ = $@;
+ (lv0) = (2,3);
+ 1;
+ EOE
+
+ print "# '$_'.\nnot " if defined $_;
+ print "ok 32\n";
+
+ sub lv1u :lvalue { undef }
+
+ $_ = undef;
+ eval <<'EOE' or $_ = $@;
+ lv1u = (2,3);
+ 1;
+ EOE
+
+ print "# '$_'.\nnot "
+ unless /Can\'t return a readonly value from lvalue subroutine/;
+ print "ok 33\n";
+
+ $_ = undef;
+ eval <<'EOE' or $_ = $@;
+ (lv1u) = (2,3);
+ 1;
+ EOE
+
+ # Fixed by change @10777
+ #print "# '$_'.\nnot "
+ # unless /Can\'t return an uninitialized value from lvalue subroutine/;
+ print "ok 34 # Skip: removed test\n";
+
+ $x = '1234567';
+
+ $_ = undef;
+ eval <<'EOE' or $_ = $@;
+ sub lv1t : lvalue { index $x, 2 }
+ lv1t = (2,3);
+ 1;
+ EOE
+
+ print "# '$_'.\nnot "
+ unless /Can\'t modify index in lvalue subroutine return/;
+ print "ok 35\n";
+
+ $_ = undef;
+ eval <<'EOE' or $_ = $@;
+ sub lv2t : lvalue { shift }
+ (lv2t) = (2,3);
+ 1;
+ EOE
+
+ print "# '$_'.\nnot "
+ unless /Can\'t modify shift in lvalue subroutine return/;
+ print "ok 36\n";
+
+ $xxx = 'xxx';
+ sub xxx () { $xxx } # Not lvalue
+
+ $_ = undef;
+ eval <<'EOE' or $_ = $@;
+ sub lv1tmp : lvalue { xxx } # is it a TEMP?
+ lv1tmp = (2,3);
+ 1;
+ EOE
+
+ print "# '$_'.\nnot "
+ unless /Can\'t modify non-lvalue subroutine call in lvalue subroutine return/;
+ print "ok 37\n";
+
+ $_ = undef;
+ eval <<'EOE' or $_ = $@;
+ (lv1tmp) = (2,3);
+ 1;
+ EOE
+
+ print "# '$_'.\nnot "
+ unless /Can\'t return a temporary from lvalue subroutine/;
+ print "ok 38\n";
+
+ sub yyy () { 'yyy' } # Const, not lvalue
+
+ $_ = undef;
+ eval <<'EOE' or $_ = $@;
+ sub lv1tmpr : lvalue { yyy } # is it read-only?
+ lv1tmpr = (2,3);
+ 1;
+ EOE
+
+ print "# '$_'.\nnot "
+ unless /Can\'t modify constant item in lvalue subroutine return/;
+ print "ok 39\n";
+
+ $_ = undef;
+ eval <<'EOE' or $_ = $@;
+ (lv1tmpr) = (2,3);
+ 1;
+ EOE
+
+ print "# '$_'.\nnot "
+ unless /Can\'t return a readonly value from lvalue subroutine/;
+ print "ok 40\n";
+
+ sub lva : lvalue {@a}
+
+ $_ = undef;
+ @a = ();
+ $a[1] = 12;
+ eval <<'EOE' or $_ = $@;
+ (lva) = (2,3);
+ 1;
+ EOE
+
+ print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
+ print "ok 41\n";
+
+ $_ = undef;
+ @a = ();
+ $a[0] = undef;
+ $a[1] = 12;
+ eval <<'EOE' or $_ = $@;
+ (lva) = (2,3);
+ 1;
+ EOE
+
+ print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
+ print "ok 42\n";
+
+ $_ = undef;
+ @a = ();
+ $a[0] = undef;
+ $a[1] = 12;
+ eval <<'EOE' or $_ = $@;
+ (lva) = (2,3);
+ 1;
+ EOE
+
+ print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
+ print "ok 43\n";
+
+ sub lv1n : lvalue { $newvar }
+
+ $_ = undef;
+ eval <<'EOE' or $_ = $@;
+ lv1n = (3,4);
+ 1;
+ EOE
+
+ print "# '$_', '$newvar'.\nnot " unless "'$newvar' $_" eq "'4' ";
+ print "ok 44\n";
+
+ sub lv1nn : lvalue { $nnewvar }
+
+ $_ = undef;
+ eval <<'EOE' or $_ = $@;
+ (lv1nn) = (3,4);
+ 1;
+ EOE
+
+ print "# '$_'.\nnot " unless "'$nnewvar' $_" eq "'3' ";
+ print "ok 45\n";
+
+ $a = \&lv1nn;
+ $a->() = 8;
+ print "# '$nnewvar'.\nnot " unless $nnewvar eq '8';
+ print "ok 46\n";
+
+ # This must happen at run time
+ eval {
+ sub AUTOLOAD : lvalue { $newvar };
+ };
+ foobar() = 12;
+ print "# '$newvar'.\nnot " unless $newvar eq "12";
+ print "ok 47\n";
+
+ print "ok 48 # Skip: removed test\n";
+
+ print "ok 49 # Skip: removed test\n";
+
+ {
+ my %hash; my @array;
+ sub alv : lvalue { $array[1] }
+ sub alv2 : lvalue { $array[$_[0]] }
+ sub hlv : lvalue { $hash{"foo"} }
+ sub hlv2 : lvalue { $hash{$_[0]} }
+ $array[1] = "not ok 51\n";
+ alv() = "ok 50\n";
+ print alv();
+
+ alv2(20) = "ok 51\n";
+ print $array[20];
+
+ $hash{"foo"} = "not ok 52\n";
+ hlv() = "ok 52\n";
+ print $hash{foo};
+
+ $hash{bar} = "not ok 53\n";
+ hlv("bar") = "ok 53\n";
+ print hlv("bar");
+
+ sub array : lvalue { @array }
+ sub array2 : lvalue { @array2 } # This is a global.
+ sub hash : lvalue { %hash }
+ sub hash2 : lvalue { %hash2 } # So's this.
+ @array2 = qw(foo bar);
+ %hash2 = qw(foo bar);
+
+ (array()) = qw(ok 54);
+ print "not " unless "@array" eq "ok 54";
+ print "ok 54\n";
+
+ (array2()) = qw(ok 55);
+ print "not " unless "@array2" eq "ok 55";
+ print "ok 55\n";
+
+ (hash()) = qw(ok 56);
+ print "not " unless $hash{ok} == 56;
+ print "ok 56\n";
+
+ (hash2()) = qw(ok 57);
+ print "not " unless $hash2{ok} == 57;
+ print "ok 57\n";
+
+ @array = qw(a b c d);
+ sub aslice1 : lvalue { @array[0,2] };
+ (aslice1()) = ("ok", "already");
+ print "# @array\nnot " unless "@array" eq "ok b already d";
+ print "ok 58\n";
+
+ @array2 = qw(a B c d);
+ sub aslice2 : lvalue { @array2[0,2] };
+ (aslice2()) = ("ok", "already");
+ print "not " unless "@array2" eq "ok B already d";
+ print "ok 59\n";
+
+ %hash = qw(a Alpha b Beta c Gamma);
+ sub hslice : lvalue { @hash{"c", "b"} }
+ (hslice()) = ("CISC", "BogoMIPS");
+ print "not " unless join("/",@hash{"c","a","b"}) eq "CISC/Alpha/BogoMIPS";
+ print "ok 60\n";
+ }
+
+ $str = "Hello, world!";
+ sub sstr : lvalue { substr($str, 1, 4) }
+ sstr() = "i";
+ print "not " unless $str eq "Hi, world!";
+ print "ok 61\n";
+
+ $str = "Made w/ JavaScript";
+ sub veclv : lvalue { vec($str, 2, 32) }
+ if (ord('A') != 193) {
+ veclv() = 0x5065726C;
+ }
+ else { # EBCDIC?
+ veclv() = 0xD7859993;
+ }
+ print "# $str\nnot " unless $str eq "Made w/ PerlScript";
+ print "ok 62\n";
+
+ sub position : lvalue { pos }
+ @p = ();
+ $_ = "fee fi fo fum";
+ while (/f/g) {
+ push @p, position;
+ position() += 6;
+ }
+ print "# @p\nnot " unless "@p" eq "1 8";
+ print "ok 63\n";
+
+ # Bug 20001223.002: split thought that the list had only one element
+ @ary = qw(4 5 6);
+ sub lval1 : lvalue { $ary[0]; }
+ sub lval2 : lvalue { $ary[1]; }
+ (lval1(), lval2()) = split ' ', "1 2 3 4";
+ print "not " unless join(':', @ary) eq "1:2:6";
+ print "ok 64\n";
diff -c 'perl-5.7.1/t/op/subst.t' 'perl-5.7.2/t/op/subst.t'
Index: ./t/op/subst.t
*** ./t/op/subst.t Tue Mar 6 04:07:15 2001
--- ./t/op/subst.t Mon Jul 9 17:11:29 2001
***************
*** 6,12 ****
require Config; import Config;
}
! print "1..84\n";
$x = 'foo';
$_ = "x";
--- 6,12 ----
require Config; import Config;
}
! print "1..85\n";
$x = 'foo';
$_ = "x";
***************
*** 378,381 ****
--- 378,385 ----
$_ = "C:/";
s/^([a-z]:)/\u$1/ and print "not ";
print "ok 84\n";
+
+ $_ = "Charles Bronson";
+ s/\B\w//g;
+ print $_ eq "C B" ? "ok 85\n" : "not ok 85\n# \$_ eq '$_'\n";
diff -c 'perl-5.7.1/t/op/sysio.t' 'perl-5.7.2/t/op/sysio.t'
Index: ./t/op/sysio.t
*** ./t/op/sysio.t Tue Mar 6 04:07:16 2001
--- ./t/op/sysio.t Mon Jul 9 17:11:29 2001
***************
*** 6,12 ****
open(I, 'sysio.t') || die "sysio.t: cannot find myself: $!";
! $reopen = ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos' ||
$^O eq 'mpeix');
$x = 'abc';
--- 6,12 ----
open(I, 'sysio.t') || die "sysio.t: cannot find myself: $!";
! $reopen = ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' ||
$^O eq 'mpeix');
$x = 'abc';
diff -c 'perl-5.7.1/t/op/taint.t' 'perl-5.7.2/t/op/taint.t'
Index: ./t/op/taint.t
*** ./t/op/taint.t Tue Mar 6 04:07:16 2001
--- ./t/op/taint.t Mon Jul 9 17:11:29 2001
***************
*** 15,20 ****
--- 15,22 ----
use strict;
use Config;
+ $| = 1;
+
# We do not want the whole taint.t to fail
# just because Errno possibly failing.
eval { require Errno; import Errno };
***************
*** 38,46 ****
my $Is_VMS = $^O eq 'VMS';
my $Is_MSWin32 = $^O eq 'MSWin32';
my $Is_Dos = $^O eq 'dos';
my $Invoke_Perl = $Is_VMS ? 'MCR Sys$Disk:[]Perl.' :
! $Is_MSWin32 ? '.\perl' : './perl';
my @MoreEnv = qw/IFS CDPATH ENV BASH_ENV/;
if ($Is_VMS) {
--- 40,51 ----
my $Is_VMS = $^O eq 'VMS';
my $Is_MSWin32 = $^O eq 'MSWin32';
+ my $Is_NetWare = $^O eq 'NetWare';
my $Is_Dos = $^O eq 'dos';
+ my $Is_Cygwin = $^O eq 'cygwin';
my $Invoke_Perl = $Is_VMS ? 'MCR Sys$Disk:[]Perl.' :
! ($Is_MSWin32 ? '.\perl' :
! ($Is_NetWare ? 'perl' : './perl'));
my @MoreEnv = qw/IFS CDPATH ENV BASH_ENV/;
if ($Is_VMS) {
***************
*** 97,103 ****
}
# We need an external program to call.
! my $ECHO = ($Is_MSWin32 ? ".\\echo$$" : "./echo$$");
END { unlink $ECHO }
open PROG, "> $ECHO" or die "Can't create $ECHO: $!";
print PROG 'print "@ARGV\n"', "\n";
--- 102,108 ----
}
# We need an external program to call.
! my $ECHO = ($Is_MSWin32 ? ".\\echo$$" : ($Is_NetWare ? "echo$$" : "./echo$$"));
END { unlink $ECHO }
open PROG, "> $ECHO" or die "Can't create $ECHO: $!";
print PROG 'print "@ARGV\n"', "\n";
***************
*** 104,110 ****
close PROG;
my $echo = "$Invoke_Perl $ECHO";
! print "1..155\n";
# First, let's make sure that Perl is checking the dangerous
# environment variables. Maybe they aren't set yet, so we'll
--- 109,115 ----
close PROG;
my $echo = "$Invoke_Perl $ECHO";
! print "1..174\n";
# First, let's make sure that Perl is checking the dangerous
# environment variables. Maybe they aren't set yet, so we'll
***************
*** 116,124 ****
delete @ENV{@MoreEnv};
$ENV{TERM} = 'dumb';
test 1, eval { `$echo 1` } eq "1\n";
! if ($Is_MSWin32 || $Is_VMS || $Is_Dos) {
print "# Environment tainting tests skipped\n";
for (2..5) { print "ok $_\n" }
}
--- 121,135 ----
delete @ENV{@MoreEnv};
$ENV{TERM} = 'dumb';
+ if ($Is_Cygwin) {
+ system("/usr/bin/cp /usr/bin/cygwin1.dll .") &&
+ die "$0: failed to cp cygwin1.dll: $!\n";
+ END { unlink "cygwin1.dll" } # yes, done for all platforms...
+ }
+
test 1, eval { `$echo 1` } eq "1\n";
! if ($Is_MSWin32 || $Is_NetWare || $Is_VMS || $Is_Dos) {
print "# Environment tainting tests skipped\n";
for (2..5) { print "ok $_\n" }
}
***************
*** 142,148 ****
}
my $tmp;
! if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_Dos) {
print "# all directories are writeable\n";
}
else {
--- 153,159 ----
}
my $tmp;
! if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_NetWare || $Is_Dos) {
print "# all directories are writeable\n";
}
else {
***************
*** 731,735 ****
--- 742,841 ----
print "ok 155\n";
close IN;
+ }
+
+ {
+ # bug id 20010519.003
+
+ BEGIN {
+ use vars qw($has_fcntl);
+ eval { require Fcntl; import Fcntl; };
+ unless ($@) {
+ $has_fcntl = 1;
+ }
+ }
+
+ unless ($has_fcntl) {
+ for (156..173) {
+ print "ok $_ # Skip: no Fcntl (no dynaloading?)\n";
+ }
+ } else {
+ my $evil = "foo" . $TAINT;
+
+ eval { sysopen(my $ro, $evil, &O_RDONLY) };
+ test 156, $@ !~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $wo, $evil, &O_WRONLY) };
+ test 157, $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $rw, $evil, &O_RDWR) };
+ test 158, $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $ap, $evil, &O_APPEND) };
+ test 159, $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $cr, $evil, &O_CREAT) };
+ test 160, $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $tr, $evil, &O_TRUNC) };
+ test 161, $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $ro, "foo", &O_RDONLY | $evil) };
+ test 162, $@ !~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $wo, "foo", &O_WRONLY | $evil) };
+ test 163, $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $rw, "foo", &O_RDWR | $evil) };
+ test 164, $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $ap, "foo", &O_APPEND | $evil) };
+ test 165, $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $cr, "foo", &O_CREAT | $evil) };
+ test 166, $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $tr, "foo", &O_TRUNC | $evil) };
+ test 167, $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $ro, "foo", &O_RDONLY, $evil) };
+ test 168, $@ !~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $wo, "foo", &O_WRONLY, $evil) };
+ test 169, $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $rw, "foo", &O_RDWR, $evil) };
+ test 170, $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $ap, "foo", &O_APPEND, $evil) };
+ test 171, $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $cr, "foo", &O_CREAT, $evil) };
+ test 172, $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $tr, "foo", &O_TRUNC, $evil) };
+ test 173, $@ =~ /^Insecure dependency/, $@;
+
+ unlink("foo"); # not unlink($evil), because that would fail...
+ }
+ }
+
+ {
+ # bug 20010526.004
+
+ use warnings;
+
+ $SIG{__WARN__} = sub { print "not " };
+
+ sub fmi {
+ my $divnum = shift()/1;
+ sprintf("%1.1f\n", $divnum);
+ }
+
+ fmi(21 . $TAINT);
+ fmi(37);
+ fmi(248);
+
+ print "ok 174\n";
}
diff -c 'perl-5.7.1/t/op/tie.t' 'perl-5.7.2/t/op/tie.t'
Index: ./t/op/tie.t
*** ./t/op/tie.t Tue Mar 6 04:07:16 2001
--- ./t/op/tie.t Mon Jul 9 17:11:29 2001
***************
*** 196,198 ****
--- 196,204 ----
vec($b,1,1)=0;
die unless $a eq $b;
EXPECT
+ ########
+ # An attempt at lvalueable barewords broke this
+
+ tie FH, 'main';
+ EXPECT
+
diff -c 'perl-5.7.1/t/op/tr.t' 'perl-5.7.2/t/op/tr.t'
Index: ./t/op/tr.t
*** ./t/op/tr.t Sat Apr 7 18:45:42 2001
--- ./t/op/tr.t Mon Jul 9 17:11:29 2001
***************
*** 5,11 ****
@INC = '../lib';
}
! print "1..69\n";
$_ = "abcdefghijklmnopqrstuvwxyz";
--- 5,11 ----
@INC = '../lib';
}
! print "1..70\n";
$_ = "abcdefghijklmnopqrstuvwxyz";
***************
*** 384,387 ****
--- 384,393 ----
@a = (1,2); map { y/1/./ for $_.'' } @a;
print "not " if "@a" ne "1 2";
print "ok 69\n";
+
+ # Additional test for Inaba Hiroto patch (robin@kitsite.com)
+ ($a = "\x{100}\x{102}\x{101}") =~ tr/\x00-\377/XYZ/c;
+ print "not " unless $a eq "XZY";
+ print "ok 70\n";
+
diff -c 'perl-5.7.1/t/op/universal.t' 'perl-5.7.2/t/op/universal.t'
Index: ./t/op/universal.t
*** ./t/op/universal.t Tue Mar 6 04:07:16 2001
--- ./t/op/universal.t Mon Jul 9 17:11:29 2001
***************
*** 9,15 ****
$| = 1;
}
! print "1..80\n";
$a = {};
bless $a, "Bob";
--- 9,15 ----
$| = 1;
}
! print "1..84\n";
$a = {};
bless $a, "Bob";
***************
*** 118,123 ****
--- 118,131 ----
}
test $a->isa("UNIVERSAL");
+
+ test ! UNIVERSAL::isa([], "UNIVERSAL");
+
+ test ! UNIVERSAL::can({}, "can");
+
+ test UNIVERSAL::isa(Alice => "UNIVERSAL");
+
+ test UNIVERSAL::can(Alice => "can") == \&UNIVERSAL::can;
# now use UNIVERSAL.pm and see what changes
eval "use UNIVERSAL";
diff -c 'perl-5.7.1/t/op/ver.t' 'perl-5.7.2/t/op/ver.t'
Index: ./t/op/ver.t
*** ./t/op/ver.t Thu Mar 29 17:16:29 2001
--- ./t/op/ver.t Mon Jul 9 17:11:29 2001
***************
*** 5,14 ****
@INC = '../lib';
}
! print "1..28\n";
my $test = 1;
use v5.5.640;
require v5.5.640;
print "ok $test\n"; ++$test;
--- 5,24 ----
@INC = '../lib';
}
! print "1..37\n";
my $test = 1;
+ sub okeq {
+ my $ok = $_[0] eq $_[1];;
+ print "not " unless $ok;
+ print "ok ", $test++;
+ print " # $_[2]" if !$ok && @_ == 3;
+ print "\n";
+ }
+
+ sub skip { print "ok ", $test++, " # Skip: $_[0]\n" }
+
use v5.5.640;
require v5.5.640;
print "ok $test\n"; ++$test;
***************
*** 45,55 ****
else {
$x = v212.213.214;
}
! print "not " unless $x eq "MNO";
! print "ok $test\n"; ++$test;
! print "not " unless v1.20.300.4000 eq "\x{1}\x{14}\x{12c}\x{fa0}";
! print "ok $test\n"; ++$test;
#
# now do the same without the "v"
--- 55,63 ----
else {
$x = v212.213.214;
}
! okeq($x, "MNO");
! okeq(v1.20.300.4000, "\x{1}\x{14}\x{12c}\x{fa0}");
#
# now do the same without the "v"
***************
*** 72,179 ****
else {
$x = 212.213.214;
}
! print "not " unless $x eq "MNO";
! print "ok $test\n"; ++$test;
! print "not " unless 1.20.300.4000 eq "\x{1}\x{14}\x{12c}\x{fa0}";
! print "ok $test\n"; ++$test;
# test sprintf("%vd"...) etc
if (ord("\t") == 9) { # ASCII
! print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108';
}
else {
! print "not " unless sprintf("%vd", "Perl") eq '215.133.153.147';
}
- print "ok $test\n"; ++$test;
! print "not " unless sprintf("%vd", v1.22.333.4444) eq '1.22.333.4444';
! print "ok $test\n"; ++$test;
if (ord("\t") == 9) { # ASCII
! print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c';
}
else {
! print "not " unless sprintf("%vx", "Perl") eq 'd7.85.99.93';
}
- print "ok $test\n"; ++$test;
! print "not " unless sprintf("%vX", 1.22.333.4444) eq '1.16.14D.115C';
! print "ok $test\n"; ++$test;
if (ord("\t") == 9) { # ASCII
! print "not " unless sprintf("%#*vo", ":", "Perl") eq '0120:0145:0162:0154';
}
else {
! print "not " unless sprintf("%#*vo", ":", "Perl") eq '0327:0205:0231:0223';
}
- print "ok $test\n"; ++$test;
! print "not " unless sprintf("%*vb", "##", v1.22.333.4444)
! eq '1##10110##101001101##1000101011100';
! print "ok $test\n"; ++$test;
! print "not " unless sprintf("%vd", join("", map { chr }
! unpack 'U*', pack('U*',2001,2002,2003)))
! eq '2001.2002.2003';
! print "ok $test\n"; ++$test;
{
use bytes;
if (ord("\t") == 9) { # ASCII
! print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108';
}
else {
! print "not " unless sprintf("%vd", "Perl") eq '215.133.153.147';
}
- print "ok $test\n"; ++$test;
if (ord("\t") == 9) { # ASCII
! print "not " unless
! sprintf("%vd", 1.22.333.4444) eq '1.22.197.141.225.133.156';
}
else {
! print "not " unless
! sprintf("%vd", 1.22.333.4444) eq '1.22.142.84.187.81.112';
}
- print "ok $test\n"; ++$test;
if (ord("\t") == 9) { # ASCII
! print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c';
}
else {
! print "not " unless sprintf("%vx", "Perl") eq 'd7.85.99.93';
}
- print "ok $test\n"; ++$test;
if (ord("\t") == 9) { # ASCII
! print "not " unless sprintf("%vX", v1.22.333.4444) eq '1.16.C5.8D.E1.85.9C';
}
else {
! print "not " unless sprintf("%vX", v1.22.333.4444) eq '1.16.8E.54.BB.51.70';
}
- print "ok $test\n"; ++$test;
if (ord("\t") == 9) { # ASCII
! print "not " unless sprintf("%#*vo", ":", "Perl") eq '0120:0145:0162:0154';
}
else {
! print "not " unless sprintf("%#*vo", ":", "Perl") eq '0327:0205:0231:0223';
}
- print "ok $test\n"; ++$test;
if (ord("\t") == 9) { # ASCII
! print "not " unless sprintf("%*vb", "##", v1.22.333.4444)
! eq '1##10110##11000101##10001101##11100001##10000101##10011100';
}
else {
! print "not " unless sprintf("%*vb", "##", v1.22.333.4444)
! eq '1##10110##10001110##1010100##10111011##1010001##1110000';
}
- print "ok $test\n"; ++$test;
}
{
# bug id 20000323.056
print "not " unless "\x{41}" eq +v65;
--- 80,173 ----
else {
$x = 212.213.214;
}
! okeq($x, "MNO");
! okeq(1.20.300.4000, "\x{1}\x{14}\x{12c}\x{fa0}");
# test sprintf("%vd"...) etc
if (ord("\t") == 9) { # ASCII
! okeq(sprintf("%vd", "Perl"), '80.101.114.108');
}
else {
! okeq(sprintf("%vd", "Perl"), '215.133.153.147');
}
! okeq(sprintf("%vd", v1.22.333.4444), '1.22.333.4444');
if (ord("\t") == 9) { # ASCII
! okeq(sprintf("%vx", "Perl"), '50.65.72.6c');
}
else {
! okeq(sprintf("%vx", "Perl"), 'd7.85.99.93');
}
! okeq(sprintf("%vX", 1.22.333.4444), '1.16.14D.115C');
if (ord("\t") == 9) { # ASCII
! okeq(sprintf("%#*vo", ":", "Perl"), '0120:0145:0162:0154');
}
else {
! okeq(sprintf("%#*vo", ":", "Perl"), '0327:0205:0231:0223');
}
! okeq(sprintf("%*vb", "##", v1.22.333.4444),
! '1##10110##101001101##1000101011100');
! okeq(sprintf("%vd", join("", map { chr }
! unpack 'U*', pack('U*',2001,2002,2003))),
! '2001.2002.2003');
{
use bytes;
+
if (ord("\t") == 9) { # ASCII
! okeq(sprintf("%vd", "Perl"), '80.101.114.108');
}
else {
! okeq(sprintf("%vd", "Perl"), '215.133.153.147');
}
if (ord("\t") == 9) { # ASCII
! okeq(sprintf("%vd", 1.22.333.4444), '1.22.197.141.225.133.156');
}
else {
! okeq(sprintf("%vd", 1.22.333.4444), '1.22.142.84.187.81.112');
}
if (ord("\t") == 9) { # ASCII
! okeq(sprintf("%vx", "Perl"), '50.65.72.6c');
}
else {
! okeq(sprintf("%vx", "Perl"), 'd7.85.99.93');
}
if (ord("\t") == 9) { # ASCII
! okeq(sprintf("%vX", v1.22.333.4444), '1.16.C5.8D.E1.85.9C');
}
else {
! okeq(sprintf("%vX", v1.22.333.4444), '1.16.8E.54.BB.51.70');
}
if (ord("\t") == 9) { # ASCII
! okeq(sprintf("%#*vo", ":", "Perl"), '0120:0145:0162:0154');
}
else {
! okeq(sprintf("%#*vo", ":", "Perl"), '0327:0205:0231:0223');
}
if (ord("\t") == 9) { # ASCII
! okeq(sprintf("%*vb", "##", v1.22.333.4444),
! '1##10110##11000101##10001101##11100001##10000101##10011100');
}
else {
! okeq(sprintf("%*vb", "##", v1.22.333.4444),
! '1##10110##10001110##1010100##10111011##1010001##1110000');
}
}
{
+ # 24..28
+
# bug id 20000323.056
print "not " unless "\x{41}" eq +v65;
***************
*** 196,198 ****
--- 190,239 ----
print "ok $test\n";
$test++;
}
+
+ # See if the things Camel-III says are true: 29..33
+
+ # Chapter 2 pp67/68
+ my $vs = v1.20.300.4000;
+ okeq($vs,"\x{1}\x{14}\x{12c}\x{fa0}","v-string ne \\x{}");
+ okeq($vs,chr(1).chr(20).chr(300).chr(4000),"v-string ne chr()");
+ okeq('foo',((chr(193) eq 'A') ? v134.150.150 : v102.111.111),"v-string ne ''");
+
+ # Chapter 15, pp403
+
+ # See if sane addr and gethostbyaddr() work
+ eval { require Socket; gethostbyaddr(v127.0.0.1, Socket::AF_INET) };
+ if ($@)
+ {
+ # No - so don't test insane fails.
+ $@ =~ s/\n/\n# /g;
+ skip("No Socket::AF_INET # $@");
+ }
+ else
+ {
+ my $ip = v2004.148.0.1;
+ my $host;
+ eval { $host = gethostbyaddr($ip,Socket::AF_INET) };
+ okeq($@ =~ /Wide character/,1,"Non-bytes leak to gethostbyaddr");
+ }
+
+ # Chapter 28, pp671
+ okeq(v5.6.0 lt v5.7.0,1,"v5.6.0 lt v5.7.0 fails");
+
+ # floating point too messy
+ # my $v = ord($^V)+ord(substr($^V,1,1))/1000+ord(substr($^V,2,1))/1000000;
+ # okeq($v,$],"\$^V and \$] do not match");
+
+ # 34..37: part of 20000323.059
+ print "not " unless v200 eq chr(200);
+ print "ok 34\n";
+
+ print "not " unless v200 eq +v200;
+ print "ok 35\n";
+
+ print "not " unless v200 eq eval "v200";
+ print "ok 36\n";
+
+ print "not " unless v200 eq eval "+v200";
+ print "ok 37\n";
+
diff -c 'perl-5.7.1/t/op/write.t' 'perl-5.7.2/t/op/write.t'
Index: ./t/op/write.t
*** ./t/op/write.t Tue Mar 6 04:07:17 2001
--- ./t/op/write.t Mon Jul 9 17:11:29 2001
***************
*** 1,9 ****
#!./perl
! print "1..11\n";
! my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat';
format OUT =
the quick brown @<<
$fox
--- 1,16 ----
#!./perl
! BEGIN {
! chdir 't' if -d 't';
! @INC = '../lib';
! }
! print "1..44\n";
+ my $CAT = ($^O eq 'MSWin32' || $^O eq 'NetWare') ? 'type'
+ : ($^O eq 'MacOS') ? 'catenate'
+ : 'cat';
+
format OUT =
the quick brown @<<
$fox
***************
*** 263,265 ****
--- 270,413 ----
{ print "ok 11\n"; 1 while unlink 'Op_write.tmp'; }
else
{ print "not ok 11\n"; }
+
+ # 12..44: scary format testing from Merijn H. Brand
+
+ if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos') {
+ foreach (12..44) { print "ok $_ # skipped: '|-' and '-|' not supported\n"; }
+ exit(0);
+ }
+
+ use strict; # Amazed that this hackery can be made strict ...
+
+ # Just a complete test for format, including top-, left- and bottom marging
+ # and format detection through glob entries
+
+ $= = 7; # Page length
+ my $ps = $^L; $^L = ""; # Catch the page separator
+ my $tm = 1; # Top margin (empty lines before first output)
+ my $bm = 2; # Bottom marging (empty lines between last text and footer)
+ my $lm = 4; # Left margin (indent in spaces)
+
+ select ((select (STDOUT), $| = 1)[0]);
+ if ($lm > 0 and !open STDOUT, "|-") { # Left margin (in this test ALWAYS set)
+ select ((select (STDOUT), $| = 1)[0]);
+ my $i = 12;
+ my $s = " " x $lm;
+ while (<STDIN>) {
+ s/^/$s/;
+ print + ($_ eq <DATA> ? "" : "not "), "ok ", $i++, "\n";
+ }
+ close STDIN;
+ print + (<DATA>?"not ":""), "ok ", $i++, "\n";
+ close STDOUT;
+ exit;
+ }
+ $tm = "\n" x $tm;
+ $= -= $bm + 1; # count one for the trailing "----"
+ my $lastmin = 0;
+
+ my @E;
+
+ sub wryte
+ {
+ $lastmin = $-;
+ write;
+ } # wryte;
+
+ sub footer
+ {
+ $% == 1 and return "";
+
+ $lastmin < $= and print "\n" x $lastmin;
+ print "\n" x $bm, "----\n", $ps;
+ $lastmin = $-;
+ "";
+ } # footer
+
+ # Yes, this is sick ;-)
+ format TOP =
+ @* ~
+ @{[footer]}
+ @* ~
+ $tm
+ .
+
+ format EmptyTOP =
+ .
+
+ format ENTRY =
+ @ @<<<<~~
+ @{(shift @E)||["",""]}
+ .
+
+ format EOR =
+ - -----
+ .
+
+ sub has_format ($)
+ {
+ my $fmt = shift;
+ exists $::{$fmt} or return 0;
+ $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
+ open my $null, "> /dev/null" or die;
+ my $fh = select $null;
+ local $~ = $fmt;
+ eval "write";
+ select $fh;
+ $@?0:1;
+ } # has_format
+
+ $^ = has_format ("TOP") ? "TOP" : "EmptyTOP";
+ has_format ("ENTRY") or die "No format defined for ENTRY";
+ foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ],
+ [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
+ @E = @$e;
+ local $~ = "ENTRY";
+ wryte;
+ has_format ("EOR") or next;
+ local $~ = "EOR";
+ wryte;
+ }
+ if (has_format ("EOF")) {
+ local $~ = "EOF";
+ wryte;
+ }
+
+ close STDOUT;
+
+ # That was test 44.
+
+ __END__
+
+ 1 Test1
+ 2 Test2
+ 3 Test3
+
+
+ ----
+
+ 4 Test4
+ 5 Test5
+ 6 Test6
+
+
+ ----
+
+ 7 Test7
+ - -----
+
+
+
+ ----
+
+ 1 1tseT
+ 2 2tseT
+ 3 3tseT
+
+
+ ----
+
+ 4 4tseT
+ 5 5tseT
+ - -----
diff -c 'perl-5.7.1/t/pod/find.t' 'perl-5.7.2/t/pod/find.t'
Index: ./t/pod/find.t
*** ./t/pod/find.t Tue Mar 6 04:07:17 2001
--- ./t/pod/find.t Mon Jul 9 17:11:29 2001
***************
*** 1,6 ****
--- 1,11 ----
# Testing of Pod::Find
# Author: Marek Rouchal <marek@saftsack.fs.uni-bayreuth.de>
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
$| = 1;
use Test;
diff -c /dev/null 'perl-5.7.2/t/pod/plainer.t'
Index: ./t/pod/plainer.t
*** ./t/pod/plainer.t Thu Jan 1 02:00:00 1970
--- ./t/pod/plainer.t Mon Jul 9 17:11:30 2001
***************
*** 0 ****
--- 1,57 ----
+ #!./perl
+
+ BEGIN { chdir 't' if -d 't'; @INC = '../lib' }
+
+ use Pod::Plainer;
+ my $parser = Pod::Plainer->new();
+ my $header = "=pod\n\n";
+ my $input = 'plnr_in.pod';
+ my $output = 'plnr_out.pod';
+
+ my $test = 0;
+ print "1..7\n";
+ while( <DATA> ) {
+ my $expected = $header.<DATA>;
+
+ open(IN, '>', $input) or die $!;
+ print IN $header, $_;
+ close IN or die $!;
+
+ open IN, '<', $input or die $!;
+ open OUT, '>', $output or die $!;
+ $parser->parse_from_filehandle(\*IN,\*OUT);
+
+ open OUT, '<', $output or die $!;
+ my $returned; { local $/; $returned = <OUT>; }
+
+ unless( $returned eq $expected ) {
+ print map { s/^/\#/mg; $_; }
+ map {+$_} # to avoid readonly values
+ "EXPECTED:\n", $expected, "GOT:\n", $returned;
+ print "not ";
+ }
+ printf "ok %d\n", ++$test;
+ close OUT;
+ close IN;
+ }
+
+ END {
+ 1 while unlink $input;
+ 1 while unlink $output;
+ }
+
+ __END__
+ =head <> now reads in records
+ =head E<lt>E<gt> now reads in records
+ =item C<-T> and C<-B> not implemented on filehandles
+ =item C<-T> and C<-B> not implemented on filehandles
+ e.g. C<< Foo->bar() >> or C<< $obj->bar() >>
+ e.g. C<Foo-E<gt>bar()> or C<$obj-E<gt>bar()>
+ The C<< => >> operator is mostly just a more visually distinctive
+ The C<=E<gt>> operator is mostly just a more visually distinctive
+ C<uv < 0x80> in which case you can use C<*s = uv>.
+ C<uv E<lt> 0x80> in which case you can use C<*s = uv>.
+ C<time ^ ($$ + ($$ << 15))>), but that isn't necessary any more.
+ C<time ^ ($$ + ($$ E<lt>E<lt> 15))>), but that isn't necessary any more.
+ The bitwise operation C<<< >> >>>
+ The bitwise operation C<E<gt>E<gt>>
diff -c 'perl-5.7.1/t/pod/special_seqs.xr' 'perl-5.7.2/t/pod/special_seqs.xr'
Index: ./t/pod/special_seqs.xr
*** ./t/pod/special_seqs.xr Tue Mar 6 04:07:19 2001
--- ./t/pod/special_seqs.xr Wed Jul 11 07:54:40 2001
***************
*** 1,4 ****
! This is a test to see if I can do not only `$self' and `method()', but
also `$self->method()' and `$self->{FIELDNAME}' and `$Foo <=> $Bar'
without resorting to escape sequences. If I want to refer to the
right-shift operator I can do something like `$x >> 3' or even `$y >>
--- 1,4 ----
! This is a test to see if I can do not only $self and `method()', but
also `$self->method()' and `$self->{FIELDNAME}' and `$Foo <=> $Bar'
without resorting to escape sequences. If I want to refer to the
right-shift operator I can do something like `$x >> 3' or even `$y >>
***************
*** 13,19 ****
Dont forget `$self->method()->{FIELDNAME} = {FOO=>BAR}'.
! And make sure that `0' works too!
Now, if I use << or >> as my delimiters, then I have to use whitespace.
So things like `<$self-'method()>> and `<$self-'{FIELDNAME}>> wont end
--- 13,19 ----
Dont forget `$self->method()->{FIELDNAME} = {FOO=>BAR}'.
! And make sure that 0 works too!
Now, if I use << or >> as my delimiters, then I have to use whitespace.
So things like `<$self-'method()>> and `<$self-'{FIELDNAME}>> wont end
diff -c 'perl-5.7.1/t/pod/testp2pt.pl' 'perl-5.7.2/t/pod/testp2pt.pl'
Index: ./t/pod/testp2pt.pl
*** ./t/pod/testp2pt.pl Tue Mar 6 04:07:19 2001
--- ./t/pod/testp2pt.pl Mon Jul 9 17:11:31 2001
***************
*** 156,162 ****
for $podfile (@testpods) {
($testname, $_) = fileparse($podfile);
$testdir ||= $_;
! $testname =~ s/\.t$//;
$cmpfile = $testdir . $testname . '.xr';
$outfile = $testdir . $testname . '.OUT';
--- 156,162 ----
for $podfile (@testpods) {
($testname, $_) = fileparse($podfile);
$testdir ||= $_;
! $testname =~ s/\..*$//;
$cmpfile = $testdir . $testname . '.xr';
$outfile = $testdir . $testname . '.OUT';
diff -c /dev/null 'perl-5.7.2/t/run/exit.t'
Index: ./t/run/exit.t
*** ./t/run/exit.t Thu Jan 1 02:00:00 1970
--- ./t/run/exit.t Mon Jul 9 17:11:31 2001
***************
*** 0 ****
--- 1,32 ----
+ #!./perl
+ #
+ # Tests for perl exit codes, playing with $?, etc...
+
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+
+ # VMS and Windows need -e "...", most everything else works better with '
+ my $quote = $^O =~ /^(VMS|MSWin\d+)$/ ? q{"} : q{'};
+
+ # Run some code, return its wait status.
+ sub run {
+ my($code) = shift;
+ my $cmd = "$^X -e ";
+ return system($cmd.$quote.$code.$quote);
+ }
+
+ use Test::More tests => 3;
+
+ my $exit;
+
+ $exit = run('exit');
+ is( $exit >> 8, 0, 'Normal exit' );
+
+ $exit = run('exit 42');
+ is( $exit >> 8, 42, 'Non-zero exit' );
+
+ $exit = run('END { $? = 42 }');
+ is( $exit >> 8, 42, 'Changing $? in END block' );
diff -c 'perl-5.7.1/t/run/runenv.t' 'perl-5.7.2/t/run/runenv.t'
Index: ./t/run/runenv.t
*** ./t/run/runenv.t Tue Mar 6 04:07:23 2001
--- ./t/run/runenv.t Mon Jul 9 17:11:31 2001
***************
*** 14,26 ****
}
}
my $STDOUT = './results-0';
my $STDERR = './results-1';
my $PERL = './perl';
my $FAILURE_CODE = 119;
- print "1..9\n";
-
# Run perl with specified environment and arguments returns a list.
# First element is true iff Perl's stdout and stderr match the
# supplied $stdout and $stderr argument strings exactly.
--- 14,28 ----
}
}
+ use Test;
+
+ plan tests => 10;
+
my $STDOUT = './results-0';
my $STDERR = './results-1';
my $PERL = './perl';
my $FAILURE_CODE = 119;
# Run perl with specified environment and arguments returns a list.
# First element is true iff Perl's stdout and stderr match the
# supplied $stdout and $stderr argument strings exactly.
***************
*** 70,83 ****
}
sub try {
- my $testno = shift;
my ($success, $reason) = runperl(@_);
! if ($success) {
! print "ok $testno\n";
! } else {
! $reason =~ s/\n/\\n/g;
! print "not ok $testno # $reason\n";
! }
}
# PERL5OPT Command-line options (switches). Switches in
--- 72,80 ----
}
sub try {
my ($success, $reason) = runperl(@_);
! $reason =~ s/\n/\\n/g if defined $reason;
! ok( !!$success, 1, $reason );
}
# PERL5OPT Command-line options (switches). Switches in
***************
*** 90,114 ****
# -T, tainting will be enabled, and any
# subsequent options ignored.
! my $T = 1;
! try($T++, {PERL5OPT => '-w'}, ['-e', 'print $::x'],
"",
qq{Name "main::x" used only once: possible typo at -e line 1.\nUse of uninitialized value in print at -e line 1.\n});
! try($T++, {PERL5OPT => '-Mstrict'}, ['-e', 'print $::x'],
"", "");
! try($T++, {PERL5OPT => '-Mstrict'}, ['-e', 'print $x'],
"",
qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n});
# Fails in 5.6.0
! try($T++, {PERL5OPT => '-Mstrict -w'}, ['-e', 'print $x'],
"",
qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n});
# Fails in 5.6.0
! try($T++, {PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'],
"",
<<ERROR
Name "main::x" used only once: possible typo at -e line 1.
--- 87,110 ----
# -T, tainting will be enabled, and any
# subsequent options ignored.
! try({PERL5OPT => '-w'}, ['-e', 'print $::x'],
"",
qq{Name "main::x" used only once: possible typo at -e line 1.\nUse of uninitialized value in print at -e line 1.\n});
! try({PERL5OPT => '-Mstrict'}, ['-e', 'print $::x'],
"", "");
! try({PERL5OPT => '-Mstrict'}, ['-e', 'print $x'],
"",
qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n});
# Fails in 5.6.0
! try({PERL5OPT => '-Mstrict -w'}, ['-e', 'print $x'],
"",
qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n});
# Fails in 5.6.0
! try({PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'],
"",
<<ERROR
Name "main::x" used only once: possible typo at -e line 1.
***************
*** 117,123 ****
);
# Fails in 5.6.0
! try($T++, {PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'],
"",
<<ERROR
Name "main::x" used only once: possible typo at -e line 1.
--- 113,119 ----
);
# Fails in 5.6.0
! try({PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'],
"",
<<ERROR
Name "main::x" used only once: possible typo at -e line 1.
***************
*** 125,145 ****
ERROR
);
! try($T++, {PERL5OPT => '-MExporter'}, ['-e0'],
"",
"");
# Fails in 5.6.0
! try($T++, {PERL5OPT => '-MExporter -MExporter'}, ['-e0'],
"",
"");
! try($T++, {PERL5OPT => '-Mstrict -Mwarnings'},
['-e', 'print "ok" if $INC{"strict.pm"} and $INC{"warnings.pm"}'],
"ok",
"");
! print "# ", $T-1, " tests total.\n";
END {
1 while unlink $STDOUT;
--- 121,144 ----
ERROR
);
! try({PERL5OPT => '-MExporter'}, ['-e0'],
"",
"");
# Fails in 5.6.0
! try({PERL5OPT => '-MExporter -MExporter'}, ['-e0'],
"",
"");
! try({PERL5OPT => '-Mstrict -Mwarnings'},
['-e', 'print "ok" if $INC{"strict.pm"} and $INC{"warnings.pm"}'],
"ok",
"");
! try({PERL5OPT => '-w -w'},
! ['-e', 'print $ENV{PERL5OPT}'],
! '-w -w',
! '');
END {
1 while unlink $STDOUT;
diff -c 'perl-5.7.1/taint.c' 'perl-5.7.2/taint.c'
Index: ./taint.c
*** ./taint.c Tue Mar 6 04:07:23 2001
--- ./taint.c Mon Jul 9 17:11:31 2001
***************
*** 66,72 ****
TAINT;
taint_proper("Insecure %s%s", "$ENV{DCL$PATH}");
}
! if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}");
}
--- 66,72 ----
TAINT;
taint_proper("Insecure %s%s", "$ENV{DCL$PATH}");
}
! if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}");
}
***************
*** 81,87 ****
TAINT;
taint_proper("Insecure %s%s", "$ENV{PATH}");
}
! if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
}
--- 81,87 ----
TAINT;
taint_proper("Insecure %s%s", "$ENV{PATH}");
}
! if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
}
diff -c 'perl-5.7.1/thrdvar.h' 'perl-5.7.2/thrdvar.h'
Index: ./thrdvar.h
*** ./thrdvar.h Tue Mar 6 04:07:23 2001
--- ./thrdvar.h Mon Jul 9 17:11:31 2001
***************
*** 182,189 ****
PERLVAR(Tregstartp, I32 *) /* Pointer to startp array. */
PERLVAR(Tregendp, I32 *) /* Ditto for endp. */
PERLVAR(Treglastparen, U32 *) /* Similarly for lastparen. */
PERLVAR(Tregtill, char *) /* How far we are required to go. */
! PERLVAR(Tregprev, char) /* char before regbol, \n if none */
PERLVAR(Treg_start_tmp, char **) /* from regexec.c */
PERLVAR(Treg_start_tmpl,U32) /* from regexec.c */
PERLVAR(Tregdata, struct reg_data *)
--- 182,190 ----
PERLVAR(Tregstartp, I32 *) /* Pointer to startp array. */
PERLVAR(Tregendp, I32 *) /* Ditto for endp. */
PERLVAR(Treglastparen, U32 *) /* Similarly for lastparen. */
+ PERLVAR(Treglastcloseparen, U32 *) /* Similarly for lastcloseparen. */
PERLVAR(Tregtill, char *) /* How far we are required to go. */
! PERLVAR(Tregcompat1, char) /* used to be regprev1 */
PERLVAR(Treg_start_tmp, char **) /* from regexec.c */
PERLVAR(Treg_start_tmpl,U32) /* from regexec.c */
PERLVAR(Tregdata, struct reg_data *)
diff -c 'perl-5.7.1/thread.h' 'perl-5.7.2/thread.h'
Index: ./thread.h
*** ./thread.h Tue Mar 6 04:07:23 2001
--- ./thread.h Fri Jul 13 03:31:42 2001
***************
*** 1,8 ****
--- 1,15 ----
#if defined(USE_THREADS) || defined(USE_ITHREADS)
+ #if defined(VMS)
+ #include <builtins.h>
+ #endif
+
#ifdef WIN32
# include <win32thread.h>
#else
+ #ifdef NETWARE
+ # include <nw5thread.h>
+ #else
# ifdef OLD_PTHREADS_API /* Here be dragons. */
# define DETACH(t) \
STMT_START { \
***************
*** 50,55 ****
--- 57,63 ----
# define pthread_mutexattr_default NULL
# define pthread_condattr_default NULL
# endif
+ #endif /* NETWARE */
#endif
#ifndef PTHREAD_CREATE
***************
*** 69,74 ****
--- 77,86 ----
# endif
#endif
+ #ifdef DGUX
+ # define THREAD_CREATE_NEEDS_STACK (16*1024)
+ #endif
+
#ifdef I_MACH_CTHREADS
/* cthreads interface */
***************
*** 241,248 ****
} STMT_END
#endif /* JOIN */
#ifndef PERL_GET_CONTEXT
! # define PERL_GET_CONTEXT pthread_getspecific(PL_thr_key)
#endif
#ifndef PERL_SET_CONTEXT
--- 253,274 ----
} STMT_END
#endif /* JOIN */
+ /* Use an unchecked fetch of thread-specific data instead of a checked one.
+ * It would fail if the key were bogus, but if the key were bogus then
+ * Really Bad Things would be happening anyway. --dan */
+ #if (defined(__ALPHA) && (__VMS_VER >= 70000000)) || \
+ (defined(__alpha) && defined(__osf__)) /* Available only on >= 4.0 */
+ # define HAS_PTHREAD_UNCHECKED_GETSPECIFIC_NP /* Configure test needed */
+ #endif
+
+ #ifdef HAS_PTHREAD_UNCHECKED_GETSPECIFIC_NP
+ # define PTHREAD_GETSPECIFIC(key) pthread_unchecked_getspecific_np(key)
+ #else
+ # define PTHREAD_GETSPECIFIC(key) pthread_getspecific(key)
+ #endif
+
#ifndef PERL_GET_CONTEXT
! # define PERL_GET_CONTEXT PTHREAD_GETSPECIFIC(PL_thr_key)
#endif
#ifndef PERL_SET_CONTEXT
***************
*** 276,281 ****
--- 302,325 ----
} STMT_END
#endif
+ void Perl_atfork_lock(void);
+ void Perl_atfork_unlock(void);
+
+ #ifndef PTHREAD_ATFORK
+ # ifdef HAS_PTHREAD_ATFORK
+ # define PTHREAD_ATFORK(prepare,parent,child) \
+ pthread_atfork(prepare,parent,child)
+ # else
+ # ifdef HAS_FORK
+ # define PTHREAD_ATFORK(prepare,parent,child) \
+ Perl_croak(aTHX_ "No pthread_atfork() -- fork() too unsafe");
+ # else
+ # define PTHREAD_ATFORK(prepare,parent,child) \
+ NOOP
+ # endif
+ # endif
+ #endif
+
#ifndef THREAD_RET_TYPE
# define THREAD_RET_TYPE void *
# define THREAD_RET_CAST(p) ((void *)(p))
***************
*** 429,432 ****
--- 473,480 ----
#ifndef INIT_THREADS
# define INIT_THREADS NOOP
+ #endif
+
+ #ifndef PTHREAD_ATFORK
+ # define PTHREAD_ATFORK(prepare,parent,child) NOOP
#endif
diff -c 'perl-5.7.1/toke.c' 'perl-5.7.2/toke.c'
Index: ./toke.c
*** ./toke.c Sun Apr 1 08:43:59 2001
--- ./toke.c Thu Jul 12 08:23:08 2001
***************
*** 43,49 ****
#define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
#endif
! /* In variables name $^X, these are the legal values for X.
* 1999-02-27 mjd-perl-patch@plover.com */
#define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
--- 43,49 ----
#define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
#endif
! /* In variables named $^X, these are the legal values for X.
* 1999-02-27 mjd-perl-patch@plover.com */
#define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
***************
*** 181,192 ****
/* grandfather return to old style */
#define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
STATIC void
S_tokereport(pTHX_ char *thing, char* s, I32 rv)
{
- SV *report;
DEBUG_T({
! report = newSVpv(thing, 0);
Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop),
(IV)rv);
--- 181,193 ----
/* grandfather return to old style */
#define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
+ #ifdef DEBUGGING
+
STATIC void
S_tokereport(pTHX_ char *thing, char* s, I32 rv)
{
DEBUG_T({
! SV* report = newSVpv(thing, 0);
Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop),
(IV)rv);
***************
*** 197,205 ****
sv_catpv(report, PL_tokenbuf);
}
PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
! })
}
/*
* S_ao
*
--- 198,208 ----
sv_catpv(report, PL_tokenbuf);
}
PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
! });
}
+ #endif
+
/*
* S_ao
*
***************
*** 538,544 ****
for (;;) {
STRLEN prevlen;
SSize_t oldprevlen, oldoldprevlen;
! SSize_t oldloplen, oldunilen;
while (s < PL_bufend && isSPACE(*s)) {
if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
incline(s);
--- 541,547 ----
for (;;) {
STRLEN prevlen;
SSize_t oldprevlen, oldoldprevlen;
! SSize_t oldloplen = 0, oldunilen = 0;
while (s < PL_bufend && isSPACE(*s)) {
if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
incline(s);
***************
*** 1043,1048 ****
--- 1046,1052 ----
SAVEI32(PL_lex_inwhat);
SAVECOPLINE(PL_curcop);
SAVEPPTR(PL_bufptr);
+ SAVEPPTR(PL_bufend);
SAVEPPTR(PL_oldbufptr);
SAVEPPTR(PL_oldoldbufptr);
SAVEPPTR(PL_last_lop);
***************
*** 1253,1259 ****
char *e = d++;
while (e-- > c)
*(e + 1) = *e;
! *c = UTF_TO_NATIVE(0xff);
/* mark the range as done, and continue */
dorange = FALSE;
didrange = TRUE;
--- 1257,1263 ----
char *e = d++;
while (e-- > c)
*(e + 1) = *e;
! *c = (char)UTF_TO_NATIVE(0xff);
/* mark the range as done, and continue */
dorange = FALSE;
didrange = TRUE;
***************
*** 1304,1310 ****
Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
}
if (has_utf8) {
! *d++ = UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
s++;
continue;
}
--- 1308,1314 ----
Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
}
if (has_utf8) {
! *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
s++;
continue;
}
***************
*** 1370,1376 ****
else if (*s == '$') {
if (!PL_lex_inpat) /* not a regexp, so $ must be var */
break;
! if (s + 1 < send && !strchr("()| \n\t", s[1]))
break; /* in regexp, $ might be tail anchor */
}
--- 1374,1380 ----
else if (*s == '$') {
if (!PL_lex_inpat) /* not a regexp, so $ must be var */
break;
! if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
break; /* in regexp, $ might be tail anchor */
}
***************
*** 1438,1451 ****
++s;
if (*s == '{') {
char* e = strchr(s, '}');
if (!e) {
yyerror("Missing right brace on \\x{}");
! e = s;
}
! else {
! STRLEN len = 1; /* allow underscores */
! uv = (UV)scan_hex(s + 1, e - s - 1, &len);
! }
s = e + 1;
}
else {
--- 1442,1455 ----
++s;
if (*s == '{') {
char* e = strchr(s, '}');
+ STRLEN len = 1; /* allow underscores */
+
if (!e) {
yyerror("Missing right brace on \\x{}");
! ++s;
! continue;
}
! uv = (UV)scan_hex(s + 1, e - s - 1, &len);
s = e + 1;
}
else {
***************
*** 1634,1640 ****
*d = '\0';
SvCUR_set(sv, d - SvPVX(sv));
if (SvCUR(sv) >= SvLEN(sv))
! Perl_croak(aTHX_ "panic:constant overflowed allocated space");
SvPOK_on(sv);
if (has_utf8) {
--- 1638,1644 ----
*d = '\0';
SvCUR_set(sv, d - SvPVX(sv));
if (SvCUR(sv) >= SvLEN(sv))
! Perl_croak(aTHX_ "panic: constant overflowed allocated space");
SvPOK_on(sv);
if (has_utf8) {
***************
*** 2162,2294 ****
bool bof = FALSE;
/* check if there's an identifier for us to look at */
! if (PL_pending_ident) {
! /* pit holds the identifier we read and pending_ident is reset */
! char pit = PL_pending_ident;
! PL_pending_ident = 0;
- DEBUG_T({ PerlIO_printf(Perl_debug_log,
- "### Tokener saw identifier '%s'\n", PL_tokenbuf); })
-
- /* if we're in a my(), we can't allow dynamics here.
- $foo'bar has already been turned into $foo::bar, so
- just check for colons.
-
- if it's a legal name, the OP is a PADANY.
- */
- if (PL_in_my) {
- if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
- if (strchr(PL_tokenbuf,':'))
- yyerror(Perl_form(aTHX_ "No package name allowed for "
- "variable %s in \"our\"",
- PL_tokenbuf));
- tmp = pad_allocmy(PL_tokenbuf);
- }
- else {
- if (strchr(PL_tokenbuf,':'))
- yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
-
- yylval.opval = newOP(OP_PADANY, 0);
- yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
- return PRIVATEREF;
- }
- }
-
- /*
- build the ops for accesses to a my() variable.
-
- Deny my($a) or my($b) in a sort block, *if* $a or $b is
- then used in a comparison. This catches most, but not
- all cases. For instance, it catches
- sort { my($a); $a <=> $b }
- but not
- sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
- (although why you'd do that is anyone's guess).
- */
-
- if (!strchr(PL_tokenbuf,':')) {
- #ifdef USE_THREADS
- /* Check for single character per-thread SVs */
- if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
- && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
- && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
- {
- yylval.opval = newOP(OP_THREADSV, 0);
- yylval.opval->op_targ = tmp;
- return PRIVATEREF;
- }
- #endif /* USE_THREADS */
- if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
- SV *namesv = AvARRAY(PL_comppad_name)[tmp];
- /* might be an "our" variable" */
- if (SvFLAGS(namesv) & SVpad_OUR) {
- /* build ops for a bareword */
- SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
- sv_catpvn(sym, "::", 2);
- sv_catpv(sym, PL_tokenbuf+1);
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
- yylval.opval->op_private = OPpCONST_ENTERED;
- gv_fetchpv(SvPVX(sym),
- (PL_in_eval
- ? (GV_ADDMULTI | GV_ADDINEVAL)
- : TRUE
- ),
- ((PL_tokenbuf[0] == '$') ? SVt_PV
- : (PL_tokenbuf[0] == '@') ? SVt_PVAV
- : SVt_PVHV));
- return WORD;
- }
-
- /* if it's a sort block and they're naming $a or $b */
- if (PL_last_lop_op == OP_SORT &&
- PL_tokenbuf[0] == '$' &&
- (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
- && !PL_tokenbuf[2])
- {
- for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
- d < PL_bufend && *d != '\n';
- d++)
- {
- if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
- Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
- PL_tokenbuf);
- }
- }
- }
-
- yylval.opval = newOP(OP_PADANY, 0);
- yylval.opval->op_targ = tmp;
- return PRIVATEREF;
- }
- }
-
- /*
- Whine if they've said @foo in a doublequoted string,
- and @foo isn't a variable we can find in the symbol
- table.
- */
- if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
- GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
- if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
- && ckWARN(WARN_AMBIGUOUS))
- {
- /* Downgraded from fatal to warning 20000522 mjd */
- Perl_warner(aTHX_ WARN_AMBIGUOUS,
- "Possible unintended interpolation of %s in string",
- PL_tokenbuf);
- }
- }
-
- /* build ops for a bareword */
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
- yylval.opval->op_private = OPpCONST_ENTERED;
- gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
- ((PL_tokenbuf[0] == '$') ? SVt_PV
- : (PL_tokenbuf[0] == '@') ? SVt_PVAV
- : SVt_PVHV));
- return WORD;
- }
-
/* no identifier pending identification */
switch (PL_lex_state) {
--- 2166,2174 ----
bool bof = FALSE;
/* check if there's an identifier for us to look at */
! if (PL_pending_ident)
! return S_pending_ident(aTHX);
/* no identifier pending identification */
switch (PL_lex_state) {
***************
*** 2309,2315 ****
}
DEBUG_T({ PerlIO_printf(Perl_debug_log,
"### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
! (IV)PL_nexttype[PL_nexttoke]); })
return(PL_nexttype[PL_nexttoke]);
--- 2189,2195 ----
}
DEBUG_T({ PerlIO_printf(Perl_debug_log,
"### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
! (IV)PL_nexttype[PL_nexttoke]); });
return(PL_nexttype[PL_nexttoke]);
***************
*** 2343,2349 ****
}
else {
DEBUG_T({ PerlIO_printf(Perl_debug_log,
! "### Saw case modifier at '%s'\n", PL_bufptr); })
s = PL_bufptr + 1;
if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
--- 2223,2229 ----
}
else {
DEBUG_T({ PerlIO_printf(Perl_debug_log,
! "### Saw case modifier at '%s'\n", PL_bufptr); });
s = PL_bufptr + 1;
if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
***************
*** 2395,2401 ****
if (PL_bufptr == PL_bufend)
return sublex_done();
DEBUG_T({ PerlIO_printf(Perl_debug_log,
! "### Interpolated variable at '%s'\n", PL_bufptr); })
PL_expect = XTERM;
PL_lex_dojoin = (*PL_bufptr == '@');
PL_lex_state = LEX_INTERPNORMAL;
--- 2275,2281 ----
if (PL_bufptr == PL_bufend)
return sublex_done();
DEBUG_T({ PerlIO_printf(Perl_debug_log,
! "### Interpolated variable at '%s'\n", PL_bufptr); });
PL_expect = XTERM;
PL_lex_dojoin = (*PL_bufptr == '@');
PL_lex_state = LEX_INTERPNORMAL;
***************
*** 2495,2501 ****
DEBUG_T( {
PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
exp_name[PL_expect], s);
! } )
retry:
switch (*s) {
--- 2375,2381 ----
DEBUG_T( {
PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
exp_name[PL_expect], s);
! } );
retry:
switch (*s) {
***************
*** 2514,2520 ****
yyerror("Missing right curly or square bracket");
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Tokener got EOF\n");
! } )
TOKEN(0);
}
if (s++ < PL_bufend)
--- 2394,2400 ----
yyerror("Missing right curly or square bracket");
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Tokener got EOF\n");
! } );
TOKEN(0);
}
if (s++ < PL_bufend)
***************
*** 2541,2549 ****
if (PL_minus_l)
sv_catpv(PL_linestr,"chomp;");
if (PL_minus_a) {
- GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
- if (gv)
- GvIMPORTED_AV_on(gv);
if (PL_minus_F) {
if (strchr("/'\"", *PL_splitstr)
&& strchr(PL_splitstr + 1, *PL_splitstr))
--- 2421,2426 ----
***************
*** 2553,2559 ****
s = "'~#\200\1'"; /* surely one char is unused...*/
while (s[1] && strchr(PL_splitstr, *s)) s++;
delim = *s;
! Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
"q" + (delim == '\''), delim);
for (s = PL_splitstr; *s; s++) {
if (*s == '\\')
--- 2430,2436 ----
s = "'~#\200\1'"; /* surely one char is unused...*/
while (s[1] && strchr(PL_splitstr, *s)) s++;
delim = *s;
! Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
"q" + (delim == '\''), delim);
for (s = PL_splitstr; *s; s++) {
if (*s == '\\')
***************
*** 2564,2570 ****
}
}
else
! sv_catpv(PL_linestr,"@F=split(' ');");
}
}
sv_catpv(PL_linestr, "\n");
--- 2441,2447 ----
}
}
else
! sv_catpv(PL_linestr,"our @F=split(' ');");
}
}
sv_catpv(PL_linestr, "\n");
***************
*** 2847,2852 ****
--- 2724,2731 ----
s++;
if (s < d)
s++;
+ else if (s > d) /* Found by Ilya: feed random input to Perl. */
+ Perl_croak(aTHX_ "panic: input overflow");
incline(s);
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
PL_bufptr = s;
***************
*** 2874,2880 ****
s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw unary minus before =>, forcing word '%s'\n", s);
! } )
OPERATOR('-'); /* unary minus */
}
PL_last_uni = PL_oldbufptr;
--- 2753,2759 ----
s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw unary minus before =>, forcing word '%s'\n", s);
! } );
OPERATOR('-'); /* unary minus */
}
PL_last_uni = PL_oldbufptr;
***************
*** 2919,2925 ****
PL_last_lop_op = ftst;
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw file test %c\n", (int)ftst);
! } )
FTST(ftst);
}
else {
--- 2798,2804 ----
PL_last_lop_op = ftst;
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw file test %c\n", (int)ftst);
! } );
FTST(ftst);
}
else {
***************
*** 2928,2934 ****
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### %c looked like a file test but was not\n",
(int)ftst);
! } )
s -= 2;
}
}
--- 2807,2813 ----
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### %c looked like a file test but was not\n",
(int)ftst);
! } );
s -= 2;
}
}
***************
*** 3085,3092 ****
else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
CvMETHOD_on(PL_compcv);
#ifdef USE_ITHREADS
! else if (PL_in_my == KEY_our && len == 6 && strnEQ(s, "shared", len))
! GvSHARED_on(cGVOPx_gv(yylval.opval));
#endif
/* After we've set the flags, it could be argued that
we don't need to do the attributes.pm-based setting
--- 2964,2971 ----
else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
CvMETHOD_on(PL_compcv);
#ifdef USE_ITHREADS
! else if (PL_in_my == KEY_our && len == 6 && strnEQ(s, "unique", len))
! GvUNIQUE_on(cGVOPx_gv(yylval.opval));
#endif
/* After we've set the flags, it could be argued that
we don't need to do the attributes.pm-based setting
***************
*** 3225,3232 ****
else
PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
s = skipspace(s);
! if (*s == '}')
OPERATOR(HASHBRACK);
/* This hack serves to disambiguate a pair of curlies
* as being a block or an anon hash. Normally, expectation
* determines that, but in cases where we're not in a
--- 3104,3119 ----
else
PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
s = skipspace(s);
! if (*s == '}') {
! if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
! PL_expect = XTERM;
! /* This hack is to get the ${} in the message. */
! PL_bufptr = s+1;
! yyerror("syntax error");
! break;
! }
OPERATOR(HASHBRACK);
+ }
/* This hack serves to disambiguate a pair of curlies
* as being a block or an anon hash. Normally, expectation
* determines that, but in cases where we're not in a
***************
*** 3688,3694 ****
s = scan_num(s, &yylval);
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw number in '%s'\n", s);
! } )
if (PL_expect == XOPERATOR)
no_op("Number",s);
TERM(THING);
--- 3575,3581 ----
s = scan_num(s, &yylval);
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw number in '%s'\n", s);
! } );
if (PL_expect == XOPERATOR)
no_op("Number",s);
TERM(THING);
***************
*** 3697,3703 ****
s = scan_str(s,FALSE,FALSE);
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw string before '%s'\n", s);
! } )
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
--- 3584,3590 ----
s = scan_str(s,FALSE,FALSE);
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw string before '%s'\n", s);
! } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
***************
*** 3716,3722 ****
s = scan_str(s,FALSE,FALSE);
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw string before '%s'\n", s);
! } )
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
--- 3603,3609 ----
s = scan_str(s,FALSE,FALSE);
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw string before '%s'\n", s);
! } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
***************
*** 3741,3747 ****
s = scan_str(s,FALSE,FALSE);
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw backtick string before '%s'\n", s);
! } )
if (PL_expect == XOPERATOR)
no_op("Backticks",s);
if (!s)
--- 3628,3634 ----
s = scan_str(s,FALSE,FALSE);
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Saw backtick string before '%s'\n", s);
! } );
if (PL_expect == XOPERATOR)
no_op("Backticks",s);
if (!s)
***************
*** 3771,3777 ****
TERM(THING);
}
/* avoid v123abc() or $h{v1}, allow C<print v10;> */
! else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF)) {
char c = *start;
GV *gv;
*start = '\0';
--- 3658,3664 ----
TERM(THING);
}
/* avoid v123abc() or $h{v1}, allow C<print v10;> */
! else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE)) {
char c = *start;
GV *gv;
*start = '\0';
***************
*** 3857,3863 ****
CLINE;
yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
yylval.opval->op_private = OPpCONST_BARE;
! if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len))
SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
TERM(WORD);
}
--- 3744,3750 ----
CLINE;
yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
yylval.opval->op_private = OPpCONST_BARE;
! if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
TERM(WORD);
}
***************
*** 3911,3916 ****
--- 3798,3804 ----
default: /* not a keyword */
just_a_word: {
SV *sv;
+ int pkgname = 0;
char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
/* Get the rest if it looks like a package qualifier */
***************
*** 3923,3928 ****
--- 3811,3817 ----
Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
*s == '\'' ? "'" : "::");
len += morelen;
+ pkgname = 1;
}
if (PL_expect == XOPERATOR) {
***************
*** 4010,4024 ****
}
}
-
PL_expect = XOPERATOR;
s = skipspace(s);
/* Is this a word before a => operator? */
! if (*s == '=' && s[1] == '>') {
CLINE;
sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
! if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len))
SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
TERM(WORD);
}
--- 3899,3912 ----
}
}
PL_expect = XOPERATOR;
s = skipspace(s);
/* Is this a word before a => operator? */
! if (*s == '=' && s[1] == '>' && !pkgname) {
CLINE;
sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
! if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
TERM(WORD);
}
***************
*** 4181,4187 ****
--- 4069,4079 ----
loc = PerlIO_tell(PL_rsfp);
(void)PerlIO_seek(PL_rsfp, 0L, 0);
}
+ #ifdef NETWARE
+ if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
+ #else
if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
+ #endif /* NETWARE */
#ifdef PERLIO_IS_STDIO /* really? */
# if defined(__BORLANDC__)
/* XXX see note in do_binmode() */
***************
*** 4194,4200 ****
}
#endif
#ifdef PERLIO_LAYERS
! if (UTF && !IN_BYTE)
PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
#endif
PL_rsfp = Nullfp;
--- 4086,4092 ----
}
#endif
#ifdef PERLIO_LAYERS
! if (UTF && !IN_BYTES)
PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
#endif
PL_rsfp = Nullfp;
***************
*** 4283,4294 ****
LOP(OP_CRYPT,XTERM);
case KEY_chmod:
- if (ckWARN(WARN_CHMOD)) {
- for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
- if (*d != '0' && isDIGIT(*d))
- Perl_warner(aTHX_ WARN_CHMOD,
- "chmod() mode argument is missing initial 0");
- }
LOP(OP_CHMOD,XTERM);
case KEY_chown:
--- 4175,4180 ----
***************
*** 4983,4989 ****
really_sub:
{
char tmpbuf[sizeof PL_tokenbuf];
! SSize_t tboffset;
expectation attrful;
bool have_name, have_proto;
int key = tmp;
--- 4869,4875 ----
really_sub:
{
char tmpbuf[sizeof PL_tokenbuf];
! SSize_t tboffset = 0;
expectation attrful;
bool have_name, have_proto;
int key = tmp;
***************
*** 5146,5157 ****
LOP(OP_UTIME,XTERM);
case KEY_umask:
- if (ckWARN(WARN_UMASK)) {
- for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
- if (*d != '0' && isDIGIT(*d))
- Perl_warner(aTHX_ WARN_UMASK,
- "umask: argument is missing initial 0");
- }
UNI(OP_UMASK);
case KEY_unshift:
--- 5032,5037 ----
***************
*** 5232,5237 ****
--- 5112,5248 ----
#pragma segment Main
#endif
+ static int
+ S_pending_ident(pTHX)
+ {
+ register char *d;
+ register I32 tmp;
+ /* pit holds the identifier we read and pending_ident is reset */
+ char pit = PL_pending_ident;
+ PL_pending_ident = 0;
+
+ DEBUG_T({ PerlIO_printf(Perl_debug_log,
+ "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
+
+ /* if we're in a my(), we can't allow dynamics here.
+ $foo'bar has already been turned into $foo::bar, so
+ just check for colons.
+
+ if it's a legal name, the OP is a PADANY.
+ */
+ if (PL_in_my) {
+ if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
+ if (strchr(PL_tokenbuf,':'))
+ yyerror(Perl_form(aTHX_ "No package name allowed for "
+ "variable %s in \"our\"",
+ PL_tokenbuf));
+ tmp = pad_allocmy(PL_tokenbuf);
+ }
+ else {
+ if (strchr(PL_tokenbuf,':'))
+ yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
+
+ yylval.opval = newOP(OP_PADANY, 0);
+ yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
+ return PRIVATEREF;
+ }
+ }
+
+ /*
+ build the ops for accesses to a my() variable.
+
+ Deny my($a) or my($b) in a sort block, *if* $a or $b is
+ then used in a comparison. This catches most, but not
+ all cases. For instance, it catches
+ sort { my($a); $a <=> $b }
+ but not
+ sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
+ (although why you'd do that is anyone's guess).
+ */
+
+ if (!strchr(PL_tokenbuf,':')) {
+ #ifdef USE_THREADS
+ /* Check for single character per-thread SVs */
+ if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
+ && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
+ && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
+ {
+ yylval.opval = newOP(OP_THREADSV, 0);
+ yylval.opval->op_targ = tmp;
+ return PRIVATEREF;
+ }
+ #endif /* USE_THREADS */
+ if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
+ SV *namesv = AvARRAY(PL_comppad_name)[tmp];
+ /* might be an "our" variable" */
+ if (SvFLAGS(namesv) & SVpad_OUR) {
+ /* build ops for a bareword */
+ SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
+ sv_catpvn(sym, "::", 2);
+ sv_catpv(sym, PL_tokenbuf+1);
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
+ yylval.opval->op_private = OPpCONST_ENTERED;
+ gv_fetchpv(SvPVX(sym),
+ (PL_in_eval
+ ? (GV_ADDMULTI | GV_ADDINEVAL)
+ : TRUE
+ ),
+ ((PL_tokenbuf[0] == '$') ? SVt_PV
+ : (PL_tokenbuf[0] == '@') ? SVt_PVAV
+ : SVt_PVHV));
+ return WORD;
+ }
+
+ /* if it's a sort block and they're naming $a or $b */
+ if (PL_last_lop_op == OP_SORT &&
+ PL_tokenbuf[0] == '$' &&
+ (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
+ && !PL_tokenbuf[2])
+ {
+ for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
+ d < PL_bufend && *d != '\n';
+ d++)
+ {
+ if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
+ Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
+ PL_tokenbuf);
+ }
+ }
+ }
+
+ yylval.opval = newOP(OP_PADANY, 0);
+ yylval.opval->op_targ = tmp;
+ return PRIVATEREF;
+ }
+ }
+
+ /*
+ Whine if they've said @foo in a doublequoted string,
+ and @foo isn't a variable we can find in the symbol
+ table.
+ */
+ if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
+ GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
+ if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
+ && ckWARN(WARN_AMBIGUOUS))
+ {
+ /* Downgraded from fatal to warning 20000522 mjd */
+ Perl_warner(aTHX_ WARN_AMBIGUOUS,
+ "Possible unintended interpolation of %s in string",
+ PL_tokenbuf);
+ }
+ }
+
+ /* build ops for a bareword */
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
+ yylval.opval->op_private = OPpCONST_ENTERED;
+ gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
+ ((PL_tokenbuf[0] == '$') ? SVt_PV
+ : (PL_tokenbuf[0] == '@') ? SVt_PVAV
+ : SVt_PVHV));
+ return WORD;
+ }
+
I32
Perl_keyword(pTHX_ register char *d, I32 len)
{
***************
*** 5627,5633 ****
if (strEQ(d,"rindex")) return -KEY_rindex;
break;
case 7:
! if (strEQ(d,"require")) return -KEY_require;
if (strEQ(d,"reverse")) return -KEY_reverse;
if (strEQ(d,"readdir")) return -KEY_readdir;
break;
--- 5638,5644 ----
if (strEQ(d,"rindex")) return -KEY_rindex;
break;
case 7:
! if (strEQ(d,"require")) return KEY_require;
if (strEQ(d,"reverse")) return -KEY_reverse;
if (strEQ(d,"readdir")) return -KEY_readdir;
break;
***************
*** 6522,6528 ****
Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
}
SvREFCNT_dec(herewas);
! if (UTF && !IN_BYTE && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
SvUTF8_on(tmpstr);
PL_lex_stuff = tmpstr;
yylval.ival = op_type;
--- 6533,6539 ----
Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
}
SvREFCNT_dec(herewas);
! if (UTF && !IN_BYTES && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
SvUTF8_on(tmpstr);
PL_lex_stuff = tmpstr;
yylval.ival = op_type;
***************
*** 6876,6887 ****
Read a number in any of the formats that Perl accepts:
! 0(x[0-7A-F]+)|([0-7]+)|(b[01])
! [\d_]+(\.[\d_]*)?[Ee](\d+)
- Underbars (_) are allowed in decimal numbers. If -w is on,
- underbars before a decimal point must be at three digit intervals.
-
Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
thing it reads.
--- 6887,6898 ----
Read a number in any of the formats that Perl accepts:
! \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
! \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
! 0b[01](_?[01])*
! 0[0-7](_?[0-7])*
! 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
thing it reads.
***************
*** 6950,6958 ****
else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
goto decimal;
/* so it must be octal */
! else
shift = 3;
base = bases[shift];
Base = Bases[shift];
max = maxima[shift];
--- 6961,6978 ----
else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
goto decimal;
/* so it must be octal */
! else {
shift = 3;
+ s++;
+ }
+ if (*s == '_') {
+ if (ckWARN(WARN_SYNTAX))
+ Perl_warner(aTHX_ WARN_SYNTAX,
+ "Misplaced _ in number");
+ lastub = s++;
+ }
+
base = bases[shift];
Base = Bases[shift];
max = maxima[shift];
***************
*** 6969,6977 ****
default:
goto out;
! /* _ are ignored */
case '_':
! s++;
break;
/* 8 and 9 are not octal */
--- 6989,7000 ----
default:
goto out;
! /* _ are ignored -- but warned about if consecutive */
case '_':
! if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
! Perl_warner(aTHX_ WARN_SYNTAX,
! "Misplaced _ in number");
! lastub = s++;
break;
/* 8 and 9 are not octal */
***************
*** 7038,7043 ****
--- 7061,7073 ----
the number.
*/
out:
+
+ /* final misplaced underbar check */
+ if (s[-1] == '_') {
+ if (ckWARN(WARN_SYNTAX))
+ Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
+ }
+
sv = NEWSV(92,0);
if (overflowed) {
if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
***************
*** 7077,7085 ****
if -w is on
*/
if (*s == '_') {
! if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
! Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
! lastub = ++s;
}
else {
/* check for end of fixed-length buffer */
--- 7107,7116 ----
if -w is on
*/
if (*s == '_') {
! if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
! Perl_warner(aTHX_ WARN_SYNTAX,
! "Misplaced _ in number");
! lastub = s++;
}
else {
/* check for end of fixed-length buffer */
***************
*** 7091,7097 ****
}
/* final misplaced underbar check */
! if (lastub && s - lastub != 3) {
if (ckWARN(WARN_SYNTAX))
Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
}
--- 7122,7128 ----
}
/* final misplaced underbar check */
! if (lastub && s == lastub + 1) {
if (ckWARN(WARN_SYNTAX))
Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
}
***************
*** 7104,7119 ****
floatit = TRUE;
*d++ = *s++;
! /* copy, ignoring underbars, until we run out of
! digits. Note: no misplaced underbar checks!
*/
for (; isDIGIT(*s) || *s == '_'; s++) {
/* fixed length buffer check */
if (d >= e)
Perl_croak(aTHX_ number_too_long);
! if (*s != '_')
*d++ = *s;
}
if (*s == '.' && isDIGIT(s[1])) {
/* oops, it's really a v-string, but without the "v" */
s = start - 1;
--- 7135,7168 ----
floatit = TRUE;
*d++ = *s++;
! if (*s == '_') {
! if (ckWARN(WARN_SYNTAX))
! Perl_warner(aTHX_ WARN_SYNTAX,
! "Misplaced _ in number");
! lastub = s;
! }
!
! /* copy, ignoring underbars, until we run out of digits.
*/
for (; isDIGIT(*s) || *s == '_'; s++) {
/* fixed length buffer check */
if (d >= e)
Perl_croak(aTHX_ number_too_long);
! if (*s == '_') {
! if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
! Perl_warner(aTHX_ WARN_SYNTAX,
! "Misplaced _ in number");
! lastub = s;
! }
! else
*d++ = *s;
}
+ /* fractional part ending in underbar? */
+ if (s[-1] == '_') {
+ if (ckWARN(WARN_SYNTAX))
+ Perl_warner(aTHX_ WARN_SYNTAX,
+ "Misplaced _ in number");
+ }
if (*s == '.' && isDIGIT(s[1])) {
/* oops, it's really a v-string, but without the "v" */
s = start - 1;
***************
*** 7122,7128 ****
}
/* read exponent part, if present */
! if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
floatit = TRUE;
s++;
--- 7171,7177 ----
}
/* read exponent part, if present */
! if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) {
floatit = TRUE;
s++;
***************
*** 7129,7231 ****
/* regardless of whether user said 3E5 or 3e5, use lower 'e' */
*d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
/* allow positive or negative exponent */
if (*s == '+' || *s == '-')
*d++ = *s++;
! /* read digits of exponent (no underbars :-) */
! while (isDIGIT(*s)) {
! if (d >= e)
! Perl_croak(aTHX_ number_too_long);
! *d++ = *s++;
}
}
- /* terminate the string */
- *d = '\0';
/* make an sv from the string */
sv = NEWSV(92,0);
- #if defined(Strtol) && defined(Strtoul)
-
/*
! strtol/strtoll sets errno to ERANGE if the number is too big
! for an integer. We try to do an integer conversion first
! if no characters indicating "float" have been found.
*/
if (!floatit) {
- IV iv;
UV uv;
! errno = 0;
! if (*PL_tokenbuf == '-')
! iv = Strtol(PL_tokenbuf, (char**)NULL, 10);
! else
! uv = Strtoul(PL_tokenbuf, (char**)NULL, 10);
! if (errno)
! floatit = TRUE; /* Probably just too large. */
! else if (*PL_tokenbuf == '-')
! sv_setiv(sv, iv);
! else if (uv <= IV_MAX)
sv_setiv(sv, uv); /* Prefer IVs over UVs. */
! else
sv_setuv(sv, uv);
! }
if (floatit) {
nv = Atof(PL_tokenbuf);
sv_setnv(sv, nv);
}
- #else
- /*
- No working strtou?ll?.
- Unfortunately atol() doesn't do range checks (returning
- LONG_MIN/LONG_MAX, and setting errno to ERANGE on overflows)
- everywhere [1], so we cannot use use atol() (or atoll()).
- If we could, they would be used, as Atol(), very much like
- Strtol() and Strtoul() are used above.
-
- [1] XXX Configure test needed to check for atol()
- (and atoll()) overflow behaviour XXX
-
- --jhi
-
- We need to do this the hard way. */
-
- nv = Atof(PL_tokenbuf);
-
- /* See if we can make do with an integer value without loss of
- precision. We use U_V to cast to a UV, because some
- compilers have issues. Then we try casting it back and see
- if it was the same [1]. We only do this if we know we
- specifically read an integer. If floatit is true, then we
- don't need to do the conversion at all.
-
- [1] Note that this is lossy if our NVs cannot preserve our
- UVs. There are metaconfig defines NV_PRESERVES_UV (a boolean)
- and NV_PRESERVES_UV_BITS (a number), but in general we really
- do hope all such potentially lossy platforms have strtou?ll?
- to do a lossless IV/UV conversion.
-
- Maybe could do some tricks with DBL_DIG, LDBL_DIG and
- DBL_MANT_DIG and LDBL_MANT_DIG (these are already available
- as NV_DIG and NV_MANT_DIG)?
-
- --jhi
- */
- {
- UV uv = U_V(nv);
- if (!floatit && (NV)uv == nv) {
- if (uv <= IV_MAX)
- sv_setiv(sv, uv); /* Prefer IVs over UVs. */
- else
- sv_setuv(sv, uv);
- }
- else
- sv_setnv(sv, nv);
- }
- #endif
if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
(PL_hints & HINT_NEW_INTEGER) )
sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
--- 7178,7254 ----
/* regardless of whether user said 3E5 or 3e5, use lower 'e' */
*d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
+ /* stray preinitial _ */
+ if (*s == '_') {
+ if (ckWARN(WARN_SYNTAX))
+ Perl_warner(aTHX_ WARN_SYNTAX,
+ "Misplaced _ in number");
+ lastub = s++;
+ }
+
/* allow positive or negative exponent */
if (*s == '+' || *s == '-')
*d++ = *s++;
! /* stray initial _ */
! if (*s == '_') {
! if (ckWARN(WARN_SYNTAX))
! Perl_warner(aTHX_ WARN_SYNTAX,
! "Misplaced _ in number");
! lastub = s++;
}
+
+ /* read digits of exponent */
+ while (isDIGIT(*s) || *s == '_') {
+ if (isDIGIT(*s)) {
+ if (d >= e)
+ Perl_croak(aTHX_ number_too_long);
+ *d++ = *s++;
+ }
+ else {
+ if (ckWARN(WARN_SYNTAX) &&
+ ((lastub && s == lastub + 1) ||
+ (!isDIGIT(s[1]) && s[1] != '_')))
+ Perl_warner(aTHX_ WARN_SYNTAX,
+ "Misplaced _ in number");
+ lastub = s++;
+ }
+ }
}
/* make an sv from the string */
sv = NEWSV(92,0);
/*
! We try to do an integer conversion first if no characters
! indicating "float" have been found.
*/
if (!floatit) {
UV uv;
! int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
!
! if (flags == IS_NUMBER_IN_UV) {
! if (uv <= IV_MAX)
sv_setiv(sv, uv); /* Prefer IVs over UVs. */
! else
sv_setuv(sv, uv);
! } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
! if (uv <= (UV) IV_MIN)
! sv_setiv(sv, -(IV)uv);
! else
! floatit = TRUE;
! } else
! floatit = TRUE;
! }
if (floatit) {
+ /* terminate the string */
+ *d = '\0';
nv = Atof(PL_tokenbuf);
sv_setnv(sv, nv);
}
if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
(PL_hints & HINT_NEW_INTEGER) )
sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
diff -c 'perl-5.7.1/uconfig.h' 'perl-5.7.2/uconfig.h'
Index: ./uconfig.h
Prereq: 3.0.1.5
*** ./uconfig.h Thu Apr 5 20:45:59 2001
--- ./uconfig.h Fri Jul 13 03:15:19 2001
***************
*** 121,146 ****
*/
/*#define HAS_DLERROR / **/
- /* SETUID_SCRIPTS_ARE_SECURE_NOW:
- * This symbol, if defined, indicates that the bug that prevents
- * setuid scripts from being secure is not present in this kernel.
- */
- /* DOSUID:
- * This symbol, if defined, indicates that the C program should
- * check the script that it is executing for setuid/setgid bits, and
- * attempt to emulate setuid/setgid on systems that have disabled
- * setuid #! scripts because the kernel can't do it securely.
- * It is up to the package designer to make sure that this emulation
- * is done securely. Among other things, it should do an fstat on
- * the script it just opened to make sure it really is a setuid/setgid
- * script, it should make sure the arguments passed correspond exactly
- * to the argument on the #! line, and it should not trust any
- * subprocesses to which it must pass the filename rather than the
- * file descriptor of the script to be executed.
- */
- /*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/
- /*#define DOSUID / **/
-
/* HAS_DUP2:
* This symbol, if defined, indicates that the dup2 routine is
* available to duplicate file descriptors.
--- 121,126 ----
***************
*** 918,934 ****
*/
/*#define I_VALUES / **/
- /* I_STDARG:
- * This symbol, if defined, indicates that <stdarg.h> exists and should
- * be included.
- */
- /* I_VARARGS:
- * This symbol, if defined, indicates to the C program that it should
- * include <varargs.h>.
- */
- #define I_STDARG /**/
- /*#define I_VARARGS / **/
-
/* I_VFORK:
* This symbol, if defined, indicates to the C program that it should
* include vfork.h.
--- 898,903 ----
***************
*** 962,973 ****
*/
#define SH_PATH "" /**/
- /* CROSSCOMPILE:
- * This symbol, if defined, signifies that we our
- * build process is a cross-compilation.
- */
- /*#define CROSSCOMPILE / **/
-
/* INTSIZE:
* This symbol contains the value of sizeof(int) so that the C
* preprocessor can make decisions based on it.
--- 931,936 ----
***************
*** 980,988 ****
* This symbol contains the value of sizeof(short) so that the C
* preprocessor can make decisions based on it.
*/
! #define INTSIZE 1 /**/
! #define LONGSIZE 1 /**/
! #define SHORTSIZE 1 /**/
/* MULTIARCH:
* This symbol, if defined, signifies that the build
--- 943,951 ----
* This symbol contains the value of sizeof(short) so that the C
* preprocessor can make decisions based on it.
*/
! #define INTSIZE 4 /**/
! #define LONGSIZE 4 /**/
! #define SHORTSIZE 2 /**/
/* MULTIARCH:
* This symbol, if defined, signifies that the build
***************
*** 1038,1044 ****
--- 1001,1013 ----
* by Configure. You shouldn't rely on it too much; the specific
* feature tests from Configure are generally more reliable.
*/
+ /* OSVERS:
+ * This symbol contains the version of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
+ */
#define OSNAME "unknown" /**/
+ #define OSVERS "" /**/
/* MEM_ALIGNBYTES:
* This symbol contains the number of bytes required to align a
***************
*** 1045,1051 ****
* double, or a long double when applicable. Usual values are 2,
* 4 and 8. The default is eight, for safety.
*/
! #if defined(CROSSCOMPILE) || defined(MULTIARCH)
# define MEM_ALIGNBYTES 8
#else
#define MEM_ALIGNBYTES 4
--- 1014,1020 ----
* double, or a long double when applicable. Usual values are 2,
* 4 and 8. The default is eight, for safety.
*/
! #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
# define MEM_ALIGNBYTES 8
#else
#define MEM_ALIGNBYTES 4
***************
*** 1122,1128 ****
* so the default case (for NeXT) is big endian to catch them.
* This might matter for NeXT 3.0.
*/
! #if defined(CROSSCOMPILE) || defined(MULTIARCH)
# ifdef __LITTLE_ENDIAN__
# if LONGSIZE == 4
# define BYTEORDER 0x1234
--- 1091,1097 ----
* so the default case (for NeXT) is big endian to catch them.
* This might matter for NeXT 3.0.
*/
! #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
# ifdef __LITTLE_ENDIAN__
# if LONGSIZE == 4
# define BYTEORDER 0x1234
***************
*** 1146,1152 ****
# define BYTEORDER 0x4321
# endif
#else
! #define BYTEORDER 0x12 /* large digits for MSB */
#endif /* NeXT */
/* CAT2:
--- 1115,1121 ----
# define BYTEORDER 0x4321
# endif
#else
! #define BYTEORDER 0x1234 /* large digits for MSB */
#endif /* NeXT */
/* CAT2:
***************
*** 1312,1317 ****
--- 1281,1292 ----
*/
/*#define HAS_ENDSERVENT / **/
+ /* HAS_FCHDIR:
+ * This symbol, if defined, indicates that the fchdir routine is
+ * available to change directory using a file descriptor.
+ */
+ /*#define HAS_FCHDIR / **/
+
/* FCNTL_CAN_LOCK:
* This symbol, if defined, indicates that fcntl() can be used
* for file locking. Normally on Unix systems this is defined.
***************
*** 1697,1703 ****
*/
/*#define HAS_LONG_DOUBLE / **/
#ifdef HAS_LONG_DOUBLE
! #define LONG_DOUBLESIZE 1 /**/
#endif
/* HAS_LONG_LONG:
--- 1672,1678 ----
*/
/*#define HAS_LONG_DOUBLE / **/
#ifdef HAS_LONG_DOUBLE
! #define LONG_DOUBLESIZE 8 /**/
#endif
/* HAS_LONG_LONG:
***************
*** 1710,1716 ****
*/
/*#define HAS_LONG_LONG / **/
#ifdef HAS_LONG_LONG
! #define LONGLONGSIZE 1 /**/
#endif
/* HAS_LSEEK_PROTO:
--- 1685,1691 ----
*/
/*#define HAS_LONG_LONG / **/
#ifdef HAS_LONG_LONG
! #define LONGLONGSIZE 8 /**/
#endif
/* HAS_LSEEK_PROTO:
***************
*** 1770,1776 ****
--- 1745,1759 ----
* available to split a long double x into a fractional part f and
* an integer part i such that |f| < 1.0 and (f + i) = x.
*/
+ /* HAS_MODFL_POW32_BUG:
+ * This symbol, if defined, indicates that the modfl routine is
+ * broken for long doubles >= pow(2, 32).
+ * For example from 4294967303.150000 one would get 4294967302.000000
+ * and 1.150000. The bug has been seen in certain versions of glibc,
+ * release 2.2.2 is known to be okay.
+ */
/*#define HAS_MODFL / **/
+ /*#define HAS_MODFL_POW32_BUG / **/
/* HAS_MPROTECT:
* This symbol, if defined, indicates that the mprotect system call is
***************
*** 1845,1851 ****
/* HAS_SAFE_BCOPY:
* This symbol, if defined, indicates that the bcopy routine is available
! * to copy potentially overlapping memory blocks. Otherwise you should
* probably use memmove() or memcpy(). If neither is defined, roll your
* own version.
*/
--- 1828,1834 ----
/* HAS_SAFE_BCOPY:
* This symbol, if defined, indicates that the bcopy routine is available
! * to copy potentially overlapping memory blocks. Normally, you should
* probably use memmove() or memcpy(). If neither is defined, roll your
* own version.
*/
***************
*** 1853,1861 ****
/* HAS_SAFE_MEMCPY:
* This symbol, if defined, indicates that the memcpy routine is available
! * to copy potentially overlapping memory blocks. Otherwise you should
! * probably use memmove() or memcpy(). If neither is defined, roll your
! * own version.
*/
/*#define HAS_SAFE_MEMCPY / **/
--- 1836,1844 ----
/* HAS_SAFE_MEMCPY:
* This symbol, if defined, indicates that the memcpy routine is available
! * to copy potentially overlapping memory blocks. If you need to
! * copy overlapping memory blocks, you should check HAS_MEMMOVE and
! * use memmove() instead, if available.
*/
/*#define HAS_SAFE_MEMCPY / **/
***************
*** 2324,2330 ****
* This symbol contains the size of a double, so that the C preprocessor
* can make decisions based on it.
*/
! #define DOUBLESIZE 1 /**/
/* EBCDIC:
* This symbol, if defined, indicates that this system uses
--- 2307,2313 ----
* This symbol contains the size of a double, so that the C preprocessor
* can make decisions based on it.
*/
! #define DOUBLESIZE 8 /**/
/* EBCDIC:
* This symbol, if defined, indicates that this system uses
***************
*** 2401,2408 ****
--- 2384,2408 ----
* in the <db.h> header file. In older versions of DB, it was
* int, while in newer ones it is size_t.
*/
+ /* DB_VERSION_MAJOR_CFG:
+ * This symbol, if defined, defines the major version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ */
+ /* DB_VERSION_MINOR_CFG:
+ * This symbol, if defined, defines the minor version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
+ /* DB_VERSION_PATCH_CFG:
+ * This symbol, if defined, defines the patch version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
#define DB_Hash_t u_int32_t /**/
#define DB_Prefix_t size_t /**/
+ #define DB_VERSION_MAJOR_CFG /**/
+ #define DB_VERSION_MINOR_CFG /**/
+ #define DB_VERSION_PATCH_CFG /**/
/* I_GRP:
* This symbol, if defined, indicates to the C program that it should
***************
*** 2662,2669 ****
* This symbol holds the number of bytes used by the Off_t.
*/
#define Off_t int /* <offset> type */
! #define LSEEKSIZE 1 /* <offset> size */
! #define Off_t_size 1 /* <offset> size */
/* Free_t:
* This variable contains the return type of free(). It is usually
--- 2662,2669 ----
* This symbol holds the number of bytes used by the Off_t.
*/
#define Off_t int /* <offset> type */
! #define LSEEKSIZE 4 /* <offset> size */
! #define Off_t_size 4 /* <offset> size */
/* Free_t:
* This variable contains the return type of free(). It is usually
***************
*** 2927,2939 ****
* the compiler supports (void *); otherwise it will be
* sizeof(char *).
*/
! #define PTRSIZE 1 /**/
/* Drand01:
* This macro is to be used to generate uniformly distributed
* random numbers over the range [0., 1.[. You may have to supply
* an 'extern double drand48();' in your program since SunOS 4.1.3
! * doesn't provide you with anything relevant in it's headers.
* See HAS_DRAND48_PROTO.
*/
/* Rand_seed_t:
--- 2927,2939 ----
* the compiler supports (void *); otherwise it will be
* sizeof(char *).
*/
! #define PTRSIZE 4 /**/
/* Drand01:
* This macro is to be used to generate uniformly distributed
* random numbers over the range [0., 1.[. You may have to supply
* an 'extern double drand48();' in your program since SunOS 4.1.3
! * doesn't provide you with anything relevant in its headers.
* See HAS_DRAND48_PROTO.
*/
/* Rand_seed_t:
***************
*** 3052,3058 ****
/* Size_t_size:
* This symbol holds the size of a Size_t in bytes.
*/
! #define Size_t_size 1 /* */
/* Size_t:
* This symbol holds the type used to declare length parameters
--- 3052,3058 ----
/* Size_t_size:
* This symbol holds the size of a Size_t in bytes.
*/
! #define Size_t_size 4 /* */
/* Size_t:
* This symbol holds the type used to declare length parameters
***************
*** 3212,3217 ****
--- 3212,3222 ----
* This symbol, if defined, indicates that Perl should
* be built to use the old draft POSIX threads API.
*/
+ /* USE_REENTRANT_API:
+ * This symbol, if defined, indicates that Perl should
+ * try to use the various _r versions of library functions.
+ * This is extremely experimental.
+ */
/*#define USE_5005THREADS / **/
/*#define USE_ITHREADS / **/
#if defined(USE_5005THREADS) && !defined(USE_ITHREADS)
***************
*** 3218,3223 ****
--- 3223,3229 ----
#define USE_THREADS /* until src is revised*/
#endif
/*#define OLD_PTHREADS_API / **/
+ /*#define USE_REENTRANT_API / **/
/* PERL_VENDORARCH:
* If defined, this symbol contains the name of a private library.
***************
*** 3309,3314 ****
--- 3315,3386 ----
#define PERL_XS_APIVERSION "5.005"
#define PERL_PM_APIVERSION "5.005"
+ /* SETUID_SCRIPTS_ARE_SECURE_NOW:
+ * This symbol, if defined, indicates that the bug that prevents
+ * setuid scripts from being secure is not present in this kernel.
+ */
+ /* DOSUID:
+ * This symbol, if defined, indicates that the C program should
+ * check the script that it is executing for setuid/setgid bits, and
+ * attempt to emulate setuid/setgid on systems that have disabled
+ * setuid #! scripts because the kernel can't do it securely.
+ * It is up to the package designer to make sure that this emulation
+ * is done securely. Among other things, it should do an fstat on
+ * the script it just opened to make sure it really is a setuid/setgid
+ * script, it should make sure the arguments passed correspond exactly
+ * to the argument on the #! line, and it should not trust any
+ * subprocesses to which it must pass the filename rather than the
+ * file descriptor of the script to be executed.
+ */
+ /*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/
+ /*#define DOSUID / **/
+
+ /* I_STDARG:
+ * This symbol, if defined, indicates that <stdarg.h> exists and should
+ * be included.
+ */
+ /* I_VARARGS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <varargs.h>.
+ */
+ #define I_STDARG /**/
+ /*#define I_VARARGS / **/
+
+ /* USE_CROSS_COMPILE:
+ * This symbol, if defined, indicates that Perl is being cross-compiled.
+ */
+ /* PERL_TARGETARCH:
+ * This symbol, if defined, indicates the target architecture
+ * Perl has been cross-compiled to. Undefined if not a cross-compile.
+ */
+ #ifndef USE_CROSS_COMPILE
+ /*#define USE_CROSS_COMPILE / **/
+ #define PERL_TARGETARCH "" /**/
+ #endif
+
+ /* HAS_DBMINIT_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the dbminit() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int dbminit(char *);
+ */
+ /*#define HAS_DBMINIT_PROTO / **/
+
+ /* HAS_FLOCK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the flock() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int flock(int, int);
+ */
+ /*#define HAS_FLOCK_PROTO / **/
+
+ /* HAS_NL_LANGINFO:
+ * This symbol, if defined, indicates that the nl_langinfo routine is
+ * available to return local data. You will also need <langinfo.h>
+ * and therefore I_LANGINFO.
+ */
+ /*#define HAS_NL_LANGINFO / **/
+
/* HAS_SIGPROCMASK:
* This symbol, if defined, indicates that the sigprocmask
* system call is available to examine or change the signal mask
***************
*** 3322,3331 ****
--- 3394,3462 ----
*/
/*#define HAS_SOCKATMARK / **/
+ /* HAS_SOCKATMARK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the sockatmark() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int sockatmark _((int));
+ */
+ /*#define HAS_SOCKATMARK_PROTO / **/
+
+ /* HAS_SETRESGID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresgid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+ /*#define HAS_SETRESGID_PROTO / **/
+
+ /* HAS_SETRESUID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresuid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+ /*#define HAS_SETRESUID_PROTO / **/
+
+ /* HAS_STRFTIME:
+ * This symbol, if defined, indicates that the strftime routine is
+ * available to do time formatting.
+ */
+ /*#define HAS_STRFTIME / **/
+
+ /* HAS_SYSCALL_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the syscall() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int syscall(int, ...);
+ * extern int syscall(long, ...);
+ */
+ /*#define HAS_SYSCALL_PROTO / **/
+
/* U32_ALIGNMENT_REQUIRED:
* This symbol, if defined, indicates that you must access
* character data through U32-aligned pointers.
*/
#define U32_ALIGNMENT_REQUIRED /**/
+
+ /* HAS_USLEEP_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the usleep() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int usleep(useconds_t);
+ */
+ /*#define HAS_USLEEP_PROTO / **/
+
+ /* I_LANGINFO:
+ * This symbol, if defined, indicates that <langinfo.h> exists and
+ * should be included.
+ */
+ /*#define I_LANGINFO / **/
+
+ /* HAS_PTHREAD_ATFORK:
+ * This symbol, if defined, indicates that the pthread_atfork routine
+ * is available setup fork handlers.
+ */
+ /*#define HAS_PTHREAD_ATFORK / **/
#endif
diff -c 'perl-5.7.1/uconfig.sh' 'perl-5.7.2/uconfig.sh'
Index: ./uconfig.sh
*** ./uconfig.sh Thu Apr 5 19:20:48 2001
--- ./uconfig.sh Fri Jul 13 03:15:11 2001
***************
*** 2,7 ****
--- 2,8 ----
_a='.a'
_o='.o'
afs='false'
+ afsroot='/afs'
alignbytes='4'
apiversion='5.005'
archlib='/usr/local/lib/perl5/5.7/unknown'
***************
*** 9,20 ****
archname='unknown'
bin='/usr/local/bin'
bincompat5005='define'
! byteorder='12'
castflags='0'
charsize='1'
clocktype='clock_t'
cpp_stuff='42'
- crosscompile='undef'
d_Gconvert='sprintf((b),"%.*g",(n),(x))'
d_PRIEUldbl='undef'
d_PRIFUldbl='undef'
--- 10,20 ----
archname='unknown'
bin='/usr/local/bin'
bincompat5005='define'
! byteorder='1234'
castflags='0'
charsize='1'
clocktype='clock_t'
cpp_stuff='42'
d_Gconvert='sprintf((b),"%.*g",(n),(x))'
d_PRIEUldbl='undef'
d_PRIFUldbl='undef'
***************
*** 51,62 ****
d_chroot='undef'
d_chsize='undef'
d_closedir='undef'
- d_const='undef'
d_cmsghdr_s='undef'
d_crypt='undef'
d_csh='undef'
d_cuserid='undef'
d_dbl_dig='undef'
d_difftime='undef'
d_dirnamlen='undef'
d_dlerror='undef'
--- 51,63 ----
d_chroot='undef'
d_chsize='undef'
d_closedir='undef'
d_cmsghdr_s='undef'
+ d_const='undef'
d_crypt='undef'
d_csh='undef'
d_cuserid='undef'
d_dbl_dig='undef'
+ d_dbminitproto='undef'
d_difftime='undef'
d_dirnamlen='undef'
d_dlerror='undef'
***************
*** 74,79 ****
--- 75,81 ----
d_endsent='undef'
d_eofnblk='undef'
d_eunice='undef'
+ d_fchdir='undef'
d_fchmod='undef'
d_fchown='undef'
d_fcntl='undef'
***************
*** 84,89 ****
--- 86,92 ----
d_fgetpos='undef'
d_flexfnam='undef'
d_flock='undef'
+ d_flockproto='undef'
d_fork='define'
d_fpathconf='undef'
d_fpos64_t='undef'
***************
*** 171,176 ****
--- 174,180 ----
d_mktime='undef'
d_mmap='undef'
d_modfl='undef'
+ d_modfl_pow32_bug='undef'
d_mprotect='undef'
d_msg='undef'
d_msg_ctrunc='undef'
***************
*** 187,192 ****
--- 191,197 ----
d_munmap='undef'
d_mymalloc='undef'
d_nice='undef'
+ d_nl_langinfo='undef'
d_nv_preserves_uv='undef'
d_nv_preserves_uv_bits='0'
d_off64_t='undef'
***************
*** 201,206 ****
--- 206,212 ----
d_pipe='undef'
d_poll='undef'
d_portable='undef'
+ d_pthread_atfork='undef'
d_pthread_yield='undef'
d_pwage='undef'
d_pwchange='undef'
***************
*** 270,280 ****
--- 276,289 ----
d_sigprocmask='undef'
d_sigsetjmp='undef'
d_sockatmark='undef'
+ d_sockatmarkproto='undef'
d_socket='undef'
d_socklen_t='undef'
d_sockpair='undef'
d_socks5_init='undef'
d_sqrtl='undef'
+ d_sresgproto='undef'
+ d_sresuproto='undef'
d_statblks='undef'
d_statfs_f_flags='undef'
d_statfs_s='undef'
***************
*** 291,296 ****
--- 300,306 ----
d_strctcpy='undef'
d_strerrm='strerror(e)'
d_strerror='undef'
+ d_strftime='undef'
d_strtod='undef'
d_strtol='undef'
d_strtold='undef'
***************
*** 303,308 ****
--- 313,319 ----
d_suidsafe='undef'
d_symlink='undef'
d_syscall='undef'
+ d_syscallproto='undef'
d_sysconf='undef'
d_sysernlst=''
d_syserrlst='undef'
***************
*** 321,326 ****
--- 332,338 ----
d_uname='undef'
d_union_semun='undef'
d_usleep='undef'
+ d_usleepproto='undef'
d_ustat='undef'
d_vendorarch='undef'
d_vendorbin='undef'
***************
*** 341,347 ****
db_prefixtype='size_t'
defvoidused=1
direntrytype='struct dirent'
! doublesize=1
drand01="((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15))"
eagain='EAGAIN'
ebcdic='undef'
--- 353,359 ----
db_prefixtype='size_t'
defvoidused=1
direntrytype='struct dirent'
! doublesize='8'
drand01="((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15))"
eagain='EAGAIN'
ebcdic='undef'
***************
*** 380,385 ****
--- 392,398 ----
i_iconv='undef'
i_ieeefp='undef'
i_inttypes='undef'
+ i_langinfo='undef'
i_libutil='undef'
i_limits='undef'
i_locale='undef'
***************
*** 450,464 ****
installstyle='lib/perl5'
installusrbinperl='undef'
intsize='4'
- intsize=1
ivdformat='"ld"'
ivsize='4'
ivtype='long'
lib_ext='.a'
! longdblsize=1
! longlongsize=1
! longsize=1
! lseeksize=1
lseektype=int
malloctype='int*'
malloctype='void *'
--- 463,476 ----
installstyle='lib/perl5'
installusrbinperl='undef'
intsize='4'
ivdformat='"ld"'
ivsize='4'
ivtype='long'
lib_ext='.a'
! longdblsize=8
! longlongsize=8
! longsize='4'
! lseeksize=4
lseektype=int
malloctype='int*'
malloctype='void *'
***************
*** 489,495 ****
privlib='/usr/local/lib/perl5/5.7'
privlibexp='/usr/local/lib/perl5/5.7'
prototype='undef'
! ptrsize=1
quadkind='4'
quadtype='int64_t'
randbits='48'
--- 501,507 ----
privlib='/usr/local/lib/perl5/5.7'
privlibexp='/usr/local/lib/perl5/5.7'
prototype='undef'
! ptrsize='4'
quadkind='4'
quadtype='int64_t'
randbits='48'
***************
*** 516,527 ****
selectminbits='32'
selecttype=int
shmattype='void *'
! shortsize=1
sig_name_init='0'
sig_num_init='0'
sig_size='1'
signal_t=int
! sizesize=1
sizetype=int
socksizetype='int'
ssizetype=int
--- 528,539 ----
selectminbits='32'
selecttype=int
shmattype='void *'
! shortsize=2
sig_name_init='0'
sig_num_init='0'
sig_size='1'
signal_t=int
! sizesize=4
sizetype=int
socksizetype='int'
ssizetype=int
***************
*** 550,555 ****
--- 562,568 ----
use5005threads='undef'
use64bitall='undef'
use64bitint='undef'
+ usecrosscompile='undef'
usedl='undef'
useithreads='undef'
uselargefiles='undef'
***************
*** 561,566 ****
--- 574,580 ----
useopcode='true'
useperlio='undef'
useposix='true'
+ usereentrant='undef'
usesfio='false'
useshrplib='false'
usesocks='undef'
***************
*** 567,578 ****
usethreads='undef'
usevendorprefix='undef'
usevfork='false'
uvoformat='"lo"'
uvsize='4'
uvtype='unsigned long'
uvuformat='"lu"'
uvxformat='"lx"'
- uvXUformat='"lX"'
versiononly='undef'
voidflags=1
xs_apiversion='5.005'
--- 581,592 ----
usethreads='undef'
usevendorprefix='undef'
usevfork='false'
+ uvXUformat='"lX"'
uvoformat='"lo"'
uvsize='4'
uvtype='unsigned long'
uvuformat='"lu"'
uvxformat='"lx"'
versiononly='undef'
voidflags=1
xs_apiversion='5.005'
diff -c 'perl-5.7.1/universal.c' 'perl-5.7.2/universal.c'
Index: ./universal.c
*** ./universal.c Sun Mar 18 20:53:03 2001
--- ./universal.c Mon Jul 9 17:11:31 2001
***************
*** 305,311 ****
if (SvNV(req) > SvNV(sv))
Perl_croak(aTHX_ "%s version %s required--this is only version %s",
! HvNAME(pkg), SvPV(req,len), SvPV(sv,len));
}
finish:
--- 305,311 ----
if (SvNV(req) > SvNV(sv))
Perl_croak(aTHX_ "%s version %s required--this is only version %s",
! HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
}
finish:
***************
*** 405,410 ****
--- 405,414 ----
{
dXSARGS;
UV uv = SvUV(ST(0));
+
+ if (items > 1)
+ Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
+
ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
XSRETURN(1);
}
***************
*** 413,418 ****
--- 417,426 ----
{
dXSARGS;
UV uv = SvUV(ST(0));
+
+ if (items > 1)
+ Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
+
ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
XSRETURN(1);
}
diff -c 'perl-5.7.1/unixish.h' 'perl-5.7.2/unixish.h'
Index: ./unixish.h
*** ./unixish.h Tue Mar 6 04:07:24 2001
--- ./unixish.h Mon Jul 9 17:11:31 2001
***************
*** 118,137 ****
#define Fflush(fp) fflush(fp)
#define Mkdir(path,mode) mkdir((path),(mode))
- /* these should be set in a hint file, not here */
#ifndef PERL_SYS_INIT
! #if defined(PERL_SCO5) || defined(__FreeBSD__)
! # ifdef __FreeBSD__
! # include <floatingpoint.h>
! # endif
! # define PERL_SYS_INIT(c,v) fpsetmask(0); MALLOC_INIT
! #else
! # ifdef POSIX_BC
! # define PERL_SYS_INIT(c,v) sigignore(SIGFPE); MALLOC_INIT
! # else
! # define PERL_SYS_INIT(c,v) MALLOC_INIT
! # endif
! #endif
#endif
#ifndef PERL_SYS_TERM
--- 118,125 ----
#define Fflush(fp) fflush(fp)
#define Mkdir(path,mode) mkdir((path),(mode))
#ifndef PERL_SYS_INIT
! # define PERL_SYS_INIT(c,v) PERL_FPU_INIT MALLOC_INIT
#endif
#ifndef PERL_SYS_TERM
diff -c 'perl-5.7.1/utf8.c' 'perl-5.7.2/utf8.c'
Index: ./utf8.c
*** ./utf8.c Sat Mar 31 08:26:31 2001
--- ./utf8.c Mon Jul 9 17:11:31 2001
***************
*** 27,33 ****
/* Unicode support */
/*
! =for apidoc A|U8*|uvuni_to_utf8|U8 *d|UV uv
Adds the UTF8 representation of the Unicode codepoint C<uv> to the end
of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
--- 27,33 ----
/* Unicode support */
/*
! =for apidoc A|U8 *|uvuni_to_utf8|U8 *d|UV uv
Adds the UTF8 representation of the Unicode codepoint C<uv> to the end
of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
***************
*** 141,147 ****
The actual number of bytes in the UTF-8 character will be returned if
it is valid, otherwise 0.
! =cut */
STRLEN
Perl_is_utf8_char(pTHX_ U8 *s)
{
--- 141,148 ----
The actual number of bytes in the UTF-8 character will be returned if
it is valid, otherwise 0.
! =cut
! */
STRLEN
Perl_is_utf8_char(pTHX_ U8 *s)
{
***************
*** 162,168 ****
slen = len - 1;
s++;
! /* The initial value is dubious */
uv = u;
ouv = uv;
while (slen--) {
--- 163,169 ----
slen = len - 1;
s++;
! u &= UTF_START_MASK(len);
uv = u;
ouv = uv;
while (slen--) {
***************
*** 169,175 ****
if (!UTF8_IS_CONTINUATION(*s))
return 0;
uv = UTF8_ACCUMULATE(uv, *s);
! if (uv < ouv)
return 0;
ouv = uv;
s++;
--- 170,176 ----
if (!UTF8_IS_CONTINUATION(*s))
return 0;
uv = UTF8_ACCUMULATE(uv, *s);
! if (uv < ouv)
return 0;
ouv = uv;
s++;
***************
*** 236,247 ****
Most code should use utf8_to_uvchr() rather than call this directly.
! =cut */
UV
! Perl_utf8n_to_uvuni(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags)
{
! UV uv = *s, ouv;
STRLEN len = 1;
bool dowarn = ckWARN_d(WARN_UTF8);
STRLEN expectlen = 0;
--- 237,249 ----
Most code should use utf8_to_uvchr() rather than call this directly.
! =cut
! */
UV
! Perl_utf8n_to_uvuni(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
{
! UV uv = *s, ouv = 0;
STRLEN len = 1;
bool dowarn = ckWARN_d(WARN_UTF8);
STRLEN expectlen = 0;
***************
*** 439,445 ****
}
/*
! =for apidoc A|U8* s|utf8_to_uvchr|STRLEN *retlen
Returns the native character value of the first character in the string C<s>
which is assumed to be in UTF8 encoding; C<retlen> will be set to the
--- 441,447 ----
}
/*
! =for apidoc A|UV|utf8_to_uvchr|U8 *s|STRLEN *retlen
Returns the native character value of the first character in the string C<s>
which is assumed to be in UTF8 encoding; C<retlen> will be set to the
***************
*** 452,464 ****
*/
UV
! Perl_utf8_to_uvchr(pTHX_ U8* s, STRLEN* retlen)
{
return Perl_utf8n_to_uvchr(aTHX_ s, UTF8_MAXLEN, retlen, 0);
}
/*
! =for apidoc A|U8* s|utf8_to_uvuni|STRLEN *retlen
Returns the Unicode code point of the first character in the string C<s>
which is assumed to be in UTF8 encoding; C<retlen> will be set to the
--- 454,466 ----
*/
UV
! Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
{
return Perl_utf8n_to_uvchr(aTHX_ s, UTF8_MAXLEN, retlen, 0);
}
/*
! =for apidoc A|UV|utf8_to_uvuni|U8 *s|STRLEN *retlen
Returns the Unicode code point of the first character in the string C<s>
which is assumed to be in UTF8 encoding; C<retlen> will be set to the
***************
*** 474,480 ****
*/
UV
! Perl_utf8_to_uvuni(pTHX_ U8* s, STRLEN* retlen)
{
/* Call the low level routine asking for checks */
return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXLEN, retlen, 0);
--- 476,482 ----
*/
UV
! Perl_utf8_to_uvuni(pTHX_ U8 *s, STRLEN *retlen)
{
/* Call the low level routine asking for checks */
return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXLEN, retlen, 0);
***************
*** 481,487 ****
}
/*
! =for apidoc A|STRLEN|utf8_length|U8* s|U8 *e
Return the length of the UTF-8 char encoded string C<s> in characters.
Stops at C<e> (inclusive). If C<e E<lt> s> or if the scan would end
--- 483,489 ----
}
/*
! =for apidoc A|STRLEN|utf8_length|U8 *s|U8 *e
Return the length of the UTF-8 char encoded string C<s> in characters.
Stops at C<e> (inclusive). If C<e E<lt> s> or if the scan would end
***************
*** 491,497 ****
*/
STRLEN
! Perl_utf8_length(pTHX_ U8* s, U8* e)
{
STRLEN len = 0;
--- 493,499 ----
*/
STRLEN
! Perl_utf8_length(pTHX_ U8 *s, U8 *e)
{
STRLEN len = 0;
***************
*** 505,511 ****
U8 t = UTF8SKIP(s);
if (e - s < t)
! Perl_croak(aTHX_ "panic: utf8_length: s=%p (%02X) e=%p l=%d - unaligned end",s,*s,e,t);
s += t;
len++;
}
--- 507,513 ----
U8 t = UTF8SKIP(s);
if (e - s < t)
! Perl_croak(aTHX_ "panic: utf8_length: unaligned end");
s += t;
len++;
}
***************
*** 522,528 ****
WARNING: use only if you *know* that the pointers point inside the
same UTF-8 buffer.
! =cut */
IV
Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
--- 524,531 ----
WARNING: use only if you *know* that the pointers point inside the
same UTF-8 buffer.
! =cut
! */
IV
Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
***************
*** 558,564 ****
}
/*
! =for apidoc A|U8*|utf8_hop|U8 *s|I32 off
Return the UTF-8 pointer C<s> displaced by C<off> characters, either
forward or backward.
--- 561,567 ----
}
/*
! =for apidoc A|U8 *|utf8_hop|U8 *s|I32 off
Return the UTF-8 pointer C<s> displaced by C<off> characters, either
forward or backward.
***************
*** 567,573 ****
the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
on the first byte of character or just after the last byte of a character.
! =cut */
U8 *
Perl_utf8_hop(pTHX_ U8 *s, I32 off)
--- 570,577 ----
the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
on the first byte of character or just after the last byte of a character.
! =cut
! */
U8 *
Perl_utf8_hop(pTHX_ U8 *s, I32 off)
***************
*** 602,608 ****
*/
U8 *
! Perl_utf8_to_bytes(pTHX_ U8* s, STRLEN *len)
{
U8 *send;
U8 *d;
--- 606,612 ----
*/
U8 *
! Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
{
U8 *send;
U8 *d;
***************
*** 641,650 ****
is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
0 if C<s> is converted or contains all 7bit characters.
! =cut */
U8 *
! Perl_bytes_from_utf8(pTHX_ U8* s, STRLEN *len, bool *is_utf8)
{
U8 *d;
U8 *start = s;
--- 645,655 ----
is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
0 if C<s> is converted or contains all 7bit characters.
! =cut
! */
U8 *
! Perl_bytes_from_utf8(pTHX_ U8 *s, STRLEN *len, bool *is_utf8)
{
U8 *d;
U8 *start = s;
***************
*** 695,701 ****
*/
U8*
! Perl_bytes_to_utf8(pTHX_ U8* s, STRLEN *len)
{
U8 *send;
U8 *d;
--- 700,706 ----
*/
U8*
! Perl_bytes_to_utf8(pTHX_ U8 *s, STRLEN *len)
{
U8 *send;
U8 *d;
***************
*** 1040,1052 ****
* descendant of isalnum(3), in other words, it doesn't
* contain the '_'. --jhi */
PL_utf8_alnum = swash_init("utf8", "IsWord", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_alnum, p);
/* return *p == '_' || is_utf8_alpha(p) || is_utf8_digit(p); */
#ifdef SURPRISINGLY_SLOWER /* probably because alpha is usually true */
if (!PL_utf8_alnum)
PL_utf8_alnum = swash_init("utf8", "",
sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
! return swash_fetch(PL_utf8_alnum, p);
#endif
}
--- 1045,1057 ----
* descendant of isalnum(3), in other words, it doesn't
* contain the '_'. --jhi */
PL_utf8_alnum = swash_init("utf8", "IsWord", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_alnum, p, TRUE);
/* return *p == '_' || is_utf8_alpha(p) || is_utf8_digit(p); */
#ifdef SURPRISINGLY_SLOWER /* probably because alpha is usually true */
if (!PL_utf8_alnum)
PL_utf8_alnum = swash_init("utf8", "",
sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
! return swash_fetch(PL_utf8_alnum, p, TRUE);
#endif
}
***************
*** 1057,1069 ****
return FALSE;
if (!PL_utf8_alnum)
PL_utf8_alnum = swash_init("utf8", "IsAlnumC", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_alnum, p);
/* return is_utf8_alpha(p) || is_utf8_digit(p); */
#ifdef SURPRISINGLY_SLOWER /* probably because alpha is usually true */
if (!PL_utf8_alnum)
PL_utf8_alnum = swash_init("utf8", "",
sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
! return swash_fetch(PL_utf8_alnum, p);
#endif
}
--- 1062,1074 ----
return FALSE;
if (!PL_utf8_alnum)
PL_utf8_alnum = swash_init("utf8", "IsAlnumC", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_alnum, p, TRUE);
/* return is_utf8_alpha(p) || is_utf8_digit(p); */
#ifdef SURPRISINGLY_SLOWER /* probably because alpha is usually true */
if (!PL_utf8_alnum)
PL_utf8_alnum = swash_init("utf8", "",
sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
! return swash_fetch(PL_utf8_alnum, p, TRUE);
#endif
}
***************
*** 1080,1086 ****
return FALSE;
if (!PL_utf8_alpha)
PL_utf8_alpha = swash_init("utf8", "IsAlpha", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_alpha, p);
}
bool
--- 1085,1091 ----
return FALSE;
if (!PL_utf8_alpha)
PL_utf8_alpha = swash_init("utf8", "IsAlpha", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_alpha, p, TRUE);
}
bool
***************
*** 1090,1096 ****
return FALSE;
if (!PL_utf8_ascii)
PL_utf8_ascii = swash_init("utf8", "IsAscii", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_ascii, p);
}
bool
--- 1095,1101 ----
return FALSE;
if (!PL_utf8_ascii)
PL_utf8_ascii = swash_init("utf8", "IsAscii", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_ascii, p, TRUE);
}
bool
***************
*** 1100,1106 ****
return FALSE;
if (!PL_utf8_space)
PL_utf8_space = swash_init("utf8", "IsSpacePerl", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_space, p);
}
bool
--- 1105,1111 ----
return FALSE;
if (!PL_utf8_space)
PL_utf8_space = swash_init("utf8", "IsSpacePerl", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_space, p, TRUE);
}
bool
***************
*** 1110,1116 ****
return FALSE;
if (!PL_utf8_digit)
PL_utf8_digit = swash_init("utf8", "IsDigit", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_digit, p);
}
bool
--- 1115,1121 ----
return FALSE;
if (!PL_utf8_digit)
PL_utf8_digit = swash_init("utf8", "IsDigit", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_digit, p, TRUE);
}
bool
***************
*** 1120,1126 ****
return FALSE;
if (!PL_utf8_upper)
PL_utf8_upper = swash_init("utf8", "IsUpper", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_upper, p);
}
bool
--- 1125,1131 ----
return FALSE;
if (!PL_utf8_upper)
PL_utf8_upper = swash_init("utf8", "IsUpper", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_upper, p, TRUE);
}
bool
***************
*** 1130,1136 ****
return FALSE;
if (!PL_utf8_lower)
PL_utf8_lower = swash_init("utf8", "IsLower", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_lower, p);
}
bool
--- 1135,1141 ----
return FALSE;
if (!PL_utf8_lower)
PL_utf8_lower = swash_init("utf8", "IsLower", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_lower, p, TRUE);
}
bool
***************
*** 1140,1146 ****
return FALSE;
if (!PL_utf8_cntrl)
PL_utf8_cntrl = swash_init("utf8", "IsCntrl", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_cntrl, p);
}
bool
--- 1145,1151 ----
return FALSE;
if (!PL_utf8_cntrl)
PL_utf8_cntrl = swash_init("utf8", "IsCntrl", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_cntrl, p, TRUE);
}
bool
***************
*** 1150,1156 ****
return FALSE;
if (!PL_utf8_graph)
PL_utf8_graph = swash_init("utf8", "IsGraph", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_graph, p);
}
bool
--- 1155,1161 ----
return FALSE;
if (!PL_utf8_graph)
PL_utf8_graph = swash_init("utf8", "IsGraph", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_graph, p, TRUE);
}
bool
***************
*** 1160,1166 ****
return FALSE;
if (!PL_utf8_print)
PL_utf8_print = swash_init("utf8", "IsPrint", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_print, p);
}
bool
--- 1165,1171 ----
return FALSE;
if (!PL_utf8_print)
PL_utf8_print = swash_init("utf8", "IsPrint", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_print, p, TRUE);
}
bool
***************
*** 1170,1176 ****
return FALSE;
if (!PL_utf8_punct)
PL_utf8_punct = swash_init("utf8", "IsPunct", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_punct, p);
}
bool
--- 1175,1181 ----
return FALSE;
if (!PL_utf8_punct)
PL_utf8_punct = swash_init("utf8", "IsPunct", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_punct, p, TRUE);
}
bool
***************
*** 1180,1186 ****
return FALSE;
if (!PL_utf8_xdigit)
PL_utf8_xdigit = swash_init("utf8", "IsXDigit", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_xdigit, p);
}
bool
--- 1185,1191 ----
return FALSE;
if (!PL_utf8_xdigit)
PL_utf8_xdigit = swash_init("utf8", "IsXDigit", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_xdigit, p, TRUE);
}
bool
***************
*** 1190,1196 ****
return FALSE;
if (!PL_utf8_mark)
PL_utf8_mark = swash_init("utf8", "IsM", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_mark, p);
}
UV
--- 1195,1201 ----
return FALSE;
if (!PL_utf8_mark)
PL_utf8_mark = swash_init("utf8", "IsM", &PL_sv_undef, 0, 0);
! return swash_fetch(PL_utf8_mark, p, TRUE);
}
UV
***************
*** 1200,1206 ****
if (!PL_utf8_toupper)
PL_utf8_toupper = swash_init("utf8", "ToUpper", &PL_sv_undef, 4, 0);
! uv = swash_fetch(PL_utf8_toupper, p);
return uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p,0);
}
--- 1205,1211 ----
if (!PL_utf8_toupper)
PL_utf8_toupper = swash_init("utf8", "ToUpper", &PL_sv_undef, 4, 0);
! uv = swash_fetch(PL_utf8_toupper, p, TRUE);
return uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p,0);
}
***************
*** 1211,1217 ****
if (!PL_utf8_totitle)
PL_utf8_totitle = swash_init("utf8", "ToTitle", &PL_sv_undef, 4, 0);
! uv = swash_fetch(PL_utf8_totitle, p);
return uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p,0);
}
--- 1216,1222 ----
if (!PL_utf8_totitle)
PL_utf8_totitle = swash_init("utf8", "ToTitle", &PL_sv_undef, 4, 0);
! uv = swash_fetch(PL_utf8_totitle, p, TRUE);
return uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p,0);
}
***************
*** 1222,1228 ****
if (!PL_utf8_tolower)
PL_utf8_tolower = swash_init("utf8", "ToLower", &PL_sv_undef, 4, 0);
! uv = swash_fetch(PL_utf8_tolower, p);
return uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p,0);
}
--- 1227,1233 ----
if (!PL_utf8_tolower)
PL_utf8_tolower = swash_init("utf8", "ToLower", &PL_sv_undef, 4, 0);
! uv = swash_fetch(PL_utf8_tolower, p, TRUE);
return uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p,0);
}
***************
*** 1235,1244 ****
--- 1240,1254 ----
SV* tokenbufsv = sv_2mortal(NEWSV(0,0));
dSP;
HV *stash = gv_stashpvn(pkg, strlen(pkg), FALSE);
+ SV* errsv_save;
if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) { /* demand load utf8 */
ENTER;
+ errsv_save = newSVsv(ERRSV);
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpv(pkg,0), Nullsv);
+ if (!SvTRUE(ERRSV))
+ sv_setsv(ERRSV, errsv_save);
+ SvREFCNT_dec(errsv_save);
LEAVE;
}
SPAGAIN;
***************
*** 1258,1267 ****
--- 1268,1281 ----
if (PL_curcop == &PL_compiling)
/* XXX ought to be handled by lex_start */
sv_setpv(tokenbufsv, PL_tokenbuf);
+ errsv_save = newSVsv(ERRSV);
if (call_method("SWASHNEW", G_SCALAR))
retval = newSVsv(*PL_stack_sp--);
else
retval = &PL_sv_undef;
+ if (!SvTRUE(ERRSV))
+ sv_setsv(ERRSV, errsv_save);
+ SvREFCNT_dec(errsv_save);
LEAVE;
POPSTACK;
if (PL_curcop == &PL_compiling) {
***************
*** 1277,1298 ****
}
UV
! Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr)
{
HV* hv = (HV*)SvRV(sv);
! /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
! then the "swatch" is a vec() for al the chars which start
! with 0xAA..0xYY
! So the key in the hash is length of encoded char -1
! */
! U32 klen = UTF8SKIP(ptr) - 1;
! U32 off = ptr[klen];
STRLEN slen;
STRLEN needents;
U8 *tmps;
U32 bit;
SV *retval;
if (klen == 0)
{
/* If char in invariant then swatch is for all the invariant chars
--- 1291,1322 ----
}
UV
! Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr, bool do_utf8)
{
HV* hv = (HV*)SvRV(sv);
! U32 klen;
! U32 off;
STRLEN slen;
STRLEN needents;
U8 *tmps;
U32 bit;
SV *retval;
+ U8 tmputf8[2];
+ UV c = NATIVE_TO_ASCII(*ptr);
+ if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
+ tmputf8[0] = UTF8_EIGHT_BIT_HI(c);
+ tmputf8[1] = UTF8_EIGHT_BIT_LO(c);
+ ptr = tmputf8;
+ }
+ /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
+ * then the "swatch" is a vec() for al the chars which start
+ * with 0xAA..0xYY
+ * So the key in the hash (klen) is length of encoded char -1
+ */
+ klen = UTF8SKIP(ptr) - 1;
+ off = ptr[klen];
+
if (klen == 0)
{
/* If char in invariant then swatch is for all the invariant chars
***************
*** 1317,1325 ****
* NB: this code assumes that swatches are never modified, once generated!
*/
! if (hv == PL_last_swash_hv &&
klen == PL_last_swash_klen &&
! (!klen || memEQ((char *)ptr,(char *)PL_last_swash_key,klen)) )
{
tmps = PL_last_swash_tmps;
slen = PL_last_swash_slen;
--- 1341,1349 ----
* NB: this code assumes that swatches are never modified, once generated!
*/
! if (hv == PL_last_swash_hv &&
klen == PL_last_swash_klen &&
! (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
{
tmps = PL_last_swash_tmps;
slen = PL_last_swash_slen;
***************
*** 1335,1340 ****
--- 1359,1365 ----
Unicode tables, not a native character number.
*/
UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXLEN, NULL, 0);
+ SV *errsv_save;
ENTER;
SAVETMPS;
save_re_context();
***************
*** 1343,1355 ****
EXTEND(SP,3);
PUSHs((SV*)sv);
/* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
! PUSHs(sv_2mortal(newSViv((klen) ? (code_point & ~(needents - 1)) : 0)));
PUSHs(sv_2mortal(newSViv(needents)));
PUTBACK;
if (call_method("SWASHGET", G_SCALAR))
retval = newSVsv(*PL_stack_sp--);
else
retval = &PL_sv_undef;
POPSTACK;
FREETMPS;
LEAVE;
--- 1368,1385 ----
EXTEND(SP,3);
PUSHs((SV*)sv);
/* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
! PUSHs(sv_2mortal(newSViv((klen) ?
! (code_point & ~(needents - 1)) : 0)));
PUSHs(sv_2mortal(newSViv(needents)));
PUTBACK;
+ errsv_save = newSVsv(ERRSV);
if (call_method("SWASHGET", G_SCALAR))
retval = newSVsv(*PL_stack_sp--);
else
retval = &PL_sv_undef;
+ if (!SvTRUE(ERRSV))
+ sv_setsv(ERRSV, errsv_save);
+ SvREFCNT_dec(errsv_save);
POPSTACK;
FREETMPS;
LEAVE;
***************
*** 1390,1396 ****
/*
! =for apidoc A|U8*|uvchr_to_utf8|U8 *d|UV uv
Adds the UTF8 representation of the Native codepoint C<uv> to the end
of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
--- 1420,1426 ----
/*
! =for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
Adds the UTF8 representation of the Native codepoint C<uv> to the end
of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
***************
*** 1418,1424 ****
/*
! =for apidoc A|U8* s|utf8n_to_uvchr|STRLEN curlen, STRLEN *retlen, U32 flags
Returns the native character value of the first character in the string C<s>
which is assumed to be in UTF8 encoding; C<retlen> will be set to the
--- 1448,1454 ----
/*
! =for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
Returns the native character value of the first character in the string C<s>
which is assumed to be in UTF8 encoding; C<retlen> will be set to the
***************
*** 1433,1439 ****
*/
#undef Perl_utf8n_to_uvchr
UV
! Perl_utf8n_to_uvchr(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags)
{
UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
return UNI_TO_NATIVE(uv);
--- 1463,1469 ----
*/
#undef Perl_utf8n_to_uvchr
UV
! Perl_utf8n_to_uvchr(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
{
UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
return UNI_TO_NATIVE(uv);
diff -c 'perl-5.7.1/utf8.h' 'perl-5.7.2/utf8.h'
Index: ./utf8.h
*** ./utf8.h Sun Apr 1 03:08:09 2001
--- ./utf8.h Mon Jul 9 17:11:32 2001
***************
*** 111,120 ****
* (that is, the two high bits are set). Otherwise we risk loading in the
* heavy-duty SWASHINIT and SWASHGET routines unnecessarily.
*/
! #define isIDFIRST_lazy_if(p,c) ((IN_BYTE || (!c || (*((U8*)p) < 0xc0))) \
? isIDFIRST(*(p)) \
: isIDFIRST_utf8((U8*)p))
! #define isALNUM_lazy_if(p,c) ((IN_BYTE || (!c || (*((U8*)p) < 0xc0))) \
? isALNUM(*(p)) \
: isALNUM_utf8((U8*)p))
--- 111,120 ----
* (that is, the two high bits are set). Otherwise we risk loading in the
* heavy-duty SWASHINIT and SWASHGET routines unnecessarily.
*/
! #define isIDFIRST_lazy_if(p,c) ((IN_BYTES || (!c || (*((U8*)p) < 0xc0))) \
? isIDFIRST(*(p)) \
: isIDFIRST_utf8((U8*)p))
! #define isALNUM_lazy_if(p,c) ((IN_BYTES || (!c || (*((U8*)p) < 0xc0))) \
? isALNUM(*(p)) \
: isALNUM_utf8((U8*)p))
***************
*** 129,136 ****
#define UTF8_MAXLEN 13 /* how wide can a single UTF8 encoded character become */
/* #define IN_UTF8 (PL_curcop->op_private & HINT_UTF8) */
! #define IN_BYTE (PL_curcop->op_private & HINT_BYTE)
! #define DO_UTF8(sv) (SvUTF8(sv) && !IN_BYTE)
#define UTF8_ALLOW_EMPTY 0x0001
#define UTF8_ALLOW_CONTINUATION 0x0002
--- 129,136 ----
#define UTF8_MAXLEN 13 /* how wide can a single UTF8 encoded character become */
/* #define IN_UTF8 (PL_curcop->op_private & HINT_UTF8) */
! #define IN_BYTES (PL_curcop->op_private & HINT_BYTES)
! #define DO_UTF8(sv) (SvUTF8(sv) && !IN_BYTES)
#define UTF8_ALLOW_EMPTY 0x0001
#define UTF8_ALLOW_CONTINUATION 0x0002
***************
*** 155,164 ****
#define UNICODE_IS_SURROGATE(c) ((c) >= UNICODE_SURROGATE_FIRST && \
(c) <= UNICODE_SURROGATE_LAST)
! #define UNICODE_IS_REPLACEMENT(c) ((c) == UNICODE_REPLACMENT)
#define UNICODE_IS_BYTE_ORDER_MARK(c) ((c) == UNICODE_BYTER_ORDER_MARK)
#define UNICODE_IS_ILLEGAL(c) ((c) == UNICODE_ILLEGAL)
! #define UTF8_QUAD_MAX UINT64_C(0x1000000000)
#define UTF8_IS_ASCII(c) UTF8_IS_INVARIANT(c)
--- 155,166 ----
#define UNICODE_IS_SURROGATE(c) ((c) >= UNICODE_SURROGATE_FIRST && \
(c) <= UNICODE_SURROGATE_LAST)
! #define UNICODE_IS_REPLACEMENT(c) ((c) == UNICODE_REPLACEMENT)
#define UNICODE_IS_BYTE_ORDER_MARK(c) ((c) == UNICODE_BYTER_ORDER_MARK)
#define UNICODE_IS_ILLEGAL(c) ((c) == UNICODE_ILLEGAL)
! #ifdef HAS_QUAD
! # define UTF8_QUAD_MAX UINT64_C(0x1000000000)
! #endif
#define UTF8_IS_ASCII(c) UTF8_IS_INVARIANT(c)
diff -c 'perl-5.7.1/utfebcdic.h' 'perl-5.7.2/utfebcdic.h'
Index: ./utfebcdic.h
*** ./utfebcdic.h Wed Mar 21 02:35:30 2001
--- ./utfebcdic.h Mon Jul 9 17:11:32 2001
***************
*** 234,243 ****
* unnecessarily.
*/
! #define isIDFIRST_lazy_if(p,c) ((IN_BYTE || (!c || UTF8_IS_INVARIANT(*p))) \
? isIDFIRST(*(p)) \
: isIDFIRST_utf8((U8*)p))
! #define isALNUM_lazy_if(p,c) ((IN_BYTE || (!c || UTF8_IS_INVARIANT(*p))) \
? isALNUM(*(p)) \
: isALNUM_utf8((U8*)p))
--- 234,243 ----
* unnecessarily.
*/
! #define isIDFIRST_lazy_if(p,c) ((IN_BYTES || (!c || UTF8_IS_INVARIANT(*p))) \
? isIDFIRST(*(p)) \
: isIDFIRST_utf8((U8*)p))
! #define isALNUM_lazy_if(p,c) ((IN_BYTES || (!c || UTF8_IS_INVARIANT(*p))) \
? isALNUM(*(p)) \
: isALNUM_utf8((U8*)p))
diff -c 'perl-5.7.1/util.c' 'perl-5.7.2/util.c'
Index: ./util.c
*** ./util.c Thu Apr 5 06:51:00 2001
--- ./util.c Thu Jul 12 16:59:49 2001
***************
*** 41,50 ****
# include <sys/wait.h>
#endif
- #ifdef I_LOCALE
- # include <locale.h>
- #endif
-
#define FLUSH
#ifdef LEAKTEST
--- 41,46 ----
***************
*** 60,67 ****
# define FD_CLOEXEC 1 /* NeXT needs this */
#endif
- /* paranoid version of system's malloc() */
-
/* NOTE: Do not call the next three routines directly. Use the macros
* in handy.h, so that we can easily redefine everything to do tracking of
* allocated hunks back to the original New to track down any memory leaks.
--- 56,61 ----
***************
*** 68,73 ****
--- 62,69 ----
* XXX This advice seems to be widely ignored :-( --AD August 1996.
*/
+ /* paranoid version of system's malloc() */
+
Malloc_t
Perl_safesysmalloc(MEM_SIZE size)
{
***************
*** 340,345 ****
--- 336,372 ----
#endif /* LEAKTEST */
+ /* These must be defined when not using Perl's malloc for binary
+ * compatibility */
+
+ #ifndef MYMALLOC
+
+ Malloc_t Perl_malloc (MEM_SIZE nbytes)
+ {
+ dTHXs;
+ return PerlMem_malloc(nbytes);
+ }
+
+ Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
+ {
+ dTHXs;
+ return PerlMem_calloc(elements, size);
+ }
+
+ Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
+ {
+ dTHXs;
+ return PerlMem_realloc(where, nbytes);
+ }
+
+ Free_t Perl_mfree (Malloc_t where)
+ {
+ dTHXs;
+ PerlMem_free(where);
+ }
+
+ #endif
+
/* copy a string up to some (non-backslashed) delimiter, if any */
char *
***************
*** 457,984 ****
return Nullch;
}
- /*
- * Set up for a new ctype locale.
- */
- void
- Perl_new_ctype(pTHX_ char *newctype)
- {
- #ifdef USE_LOCALE_CTYPE
-
- int i;
-
- for (i = 0; i < 256; i++) {
- if (isUPPER_LC(i))
- PL_fold_locale[i] = toLOWER_LC(i);
- else if (isLOWER_LC(i))
- PL_fold_locale[i] = toUPPER_LC(i);
- else
- PL_fold_locale[i] = i;
- }
-
- #endif /* USE_LOCALE_CTYPE */
- }
-
- /*
- * Standardize the locale name from a string returned by 'setlocale'.
- *
- * The standard return value of setlocale() is either
- * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL
- * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL
- * (the space-separated values represent the various sublocales,
- * in some unspecificed order)
- *
- * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n",
- * which is harmful for further use of the string in setlocale().
- *
- */
- STATIC char *
- S_stdize_locale(pTHX_ char *locs)
- {
- char *s;
- bool okay = TRUE;
-
- if ((s = strchr(locs, '='))) {
- char *t;
-
- okay = FALSE;
- if ((t = strchr(s, '.'))) {
- char *u;
-
- if ((u = strchr(t, '\n'))) {
-
- if (u[1] == 0) {
- STRLEN len = u - s;
- Move(s + 1, locs, len, char);
- locs[len] = 0;
- okay = TRUE;
- }
- }
- }
- }
-
- if (!okay)
- Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
-
- return locs;
- }
-
- /*
- * Set up for a new collation locale.
- */
- void
- Perl_new_collate(pTHX_ char *newcoll)
- {
- #ifdef USE_LOCALE_COLLATE
-
- if (! newcoll) {
- if (PL_collation_name) {
- ++PL_collation_ix;
- Safefree(PL_collation_name);
- PL_collation_name = NULL;
- }
- PL_collation_standard = TRUE;
- PL_collxfrm_base = 0;
- PL_collxfrm_mult = 2;
- return;
- }
-
- if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
- ++PL_collation_ix;
- Safefree(PL_collation_name);
- PL_collation_name = stdize_locale(savepv(newcoll));
- PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX"));
-
- {
- /* 2: at most so many chars ('a', 'b'). */
- /* 50: surely no system expands a char more. */
- #define XFRMBUFSIZE (2 * 50)
- char xbuf[XFRMBUFSIZE];
- Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE);
- Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
- SSize_t mult = fb - fa;
- if (mult < 1)
- Perl_croak(aTHX_ "strxfrm() gets absurd");
- PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0;
- PL_collxfrm_mult = mult;
- }
- }
-
- #endif /* USE_LOCALE_COLLATE */
- }
-
- void
- Perl_set_numeric_radix(pTHX)
- {
- #ifdef USE_LOCALE_NUMERIC
- # ifdef HAS_LOCALECONV
- struct lconv* lc;
-
- lc = localeconv();
- if (lc && lc->decimal_point) {
- if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) {
- SvREFCNT_dec(PL_numeric_radix);
- PL_numeric_radix = 0;
- }
- else {
- if (PL_numeric_radix)
- sv_setpv(PL_numeric_radix, lc->decimal_point);
- else
- PL_numeric_radix = newSVpv(lc->decimal_point, 0);
- }
- }
- else
- PL_numeric_radix = 0;
- # endif /* HAS_LOCALECONV */
- #endif /* USE_LOCALE_NUMERIC */
- }
-
- /*
- * Set up for a new numeric locale.
- */
- void
- Perl_new_numeric(pTHX_ char *newnum)
- {
- #ifdef USE_LOCALE_NUMERIC
-
- if (! newnum) {
- if (PL_numeric_name) {
- Safefree(PL_numeric_name);
- PL_numeric_name = NULL;
- }
- PL_numeric_standard = TRUE;
- PL_numeric_local = TRUE;
- return;
- }
-
- if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) {
- Safefree(PL_numeric_name);
- PL_numeric_name = stdize_locale(savepv(newnum));
- PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX"));
- PL_numeric_local = TRUE;
- set_numeric_radix();
- }
-
- #endif /* USE_LOCALE_NUMERIC */
- }
-
- void
- Perl_set_numeric_standard(pTHX)
- {
- #ifdef USE_LOCALE_NUMERIC
-
- if (! PL_numeric_standard) {
- setlocale(LC_NUMERIC, "C");
- PL_numeric_standard = TRUE;
- PL_numeric_local = FALSE;
- set_numeric_radix();
- }
-
- #endif /* USE_LOCALE_NUMERIC */
- }
-
- void
- Perl_set_numeric_local(pTHX)
- {
- #ifdef USE_LOCALE_NUMERIC
-
- if (! PL_numeric_local) {
- setlocale(LC_NUMERIC, PL_numeric_name);
- PL_numeric_standard = FALSE;
- PL_numeric_local = TRUE;
- set_numeric_radix();
- }
-
- #endif /* USE_LOCALE_NUMERIC */
- }
-
- /*
- * Initialize locale awareness.
- */
- int
- Perl_init_i18nl10n(pTHX_ int printwarn)
- {
- int ok = 1;
- /* returns
- * 1 = set ok or not applicable,
- * 0 = fallback to C locale,
- * -1 = fallback to C locale failed
- */
-
- #if defined(USE_LOCALE)
-
- #ifdef USE_LOCALE_CTYPE
- char *curctype = NULL;
- #endif /* USE_LOCALE_CTYPE */
- #ifdef USE_LOCALE_COLLATE
- char *curcoll = NULL;
- #endif /* USE_LOCALE_COLLATE */
- #ifdef USE_LOCALE_NUMERIC
- char *curnum = NULL;
- #endif /* USE_LOCALE_NUMERIC */
- #ifdef __GLIBC__
- char *language = PerlEnv_getenv("LANGUAGE");
- #endif
- char *lc_all = PerlEnv_getenv("LC_ALL");
- char *lang = PerlEnv_getenv("LANG");
- bool setlocale_failure = FALSE;
-
- #ifdef LOCALE_ENVIRON_REQUIRED
-
- /*
- * Ultrix setlocale(..., "") fails if there are no environment
- * variables from which to get a locale name.
- */
-
- bool done = FALSE;
-
- #ifdef LC_ALL
- if (lang) {
- if (setlocale(LC_ALL, ""))
- done = TRUE;
- else
- setlocale_failure = TRUE;
- }
- if (!setlocale_failure) {
- #ifdef USE_LOCALE_CTYPE
- if (! (curctype =
- setlocale(LC_CTYPE,
- (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
- ? "" : Nullch)))
- setlocale_failure = TRUE;
- else
- curctype = savepv(curctype);
- #endif /* USE_LOCALE_CTYPE */
- #ifdef USE_LOCALE_COLLATE
- if (! (curcoll =
- setlocale(LC_COLLATE,
- (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
- ? "" : Nullch)))
- setlocale_failure = TRUE;
- else
- curcoll = savepv(curcoll);
- #endif /* USE_LOCALE_COLLATE */
- #ifdef USE_LOCALE_NUMERIC
- if (! (curnum =
- setlocale(LC_NUMERIC,
- (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
- ? "" : Nullch)))
- setlocale_failure = TRUE;
- else
- curnum = savepv(curnum);
- #endif /* USE_LOCALE_NUMERIC */
- }
-
- #endif /* LC_ALL */
-
- #endif /* !LOCALE_ENVIRON_REQUIRED */
-
- #ifdef LC_ALL
- if (! setlocale(LC_ALL, ""))
- setlocale_failure = TRUE;
- #endif /* LC_ALL */
-
- if (!setlocale_failure) {
- #ifdef USE_LOCALE_CTYPE
- if (! (curctype = setlocale(LC_CTYPE, "")))
- setlocale_failure = TRUE;
- else
- curctype = savepv(curctype);
- #endif /* USE_LOCALE_CTYPE */
- #ifdef USE_LOCALE_COLLATE
- if (! (curcoll = setlocale(LC_COLLATE, "")))
- setlocale_failure = TRUE;
- else
- curcoll = savepv(curcoll);
- #endif /* USE_LOCALE_COLLATE */
- #ifdef USE_LOCALE_NUMERIC
- if (! (curnum = setlocale(LC_NUMERIC, "")))
- setlocale_failure = TRUE;
- else
- curnum = savepv(curnum);
- #endif /* USE_LOCALE_NUMERIC */
- }
-
- if (setlocale_failure) {
- char *p;
- bool locwarn = (printwarn > 1 ||
- (printwarn &&
- (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
-
- if (locwarn) {
- #ifdef LC_ALL
-
- PerlIO_printf(Perl_error_log,
- "perl: warning: Setting locale failed.\n");
-
- #else /* !LC_ALL */
-
- PerlIO_printf(Perl_error_log,
- "perl: warning: Setting locale failed for the categories:\n\t");
- #ifdef USE_LOCALE_CTYPE
- if (! curctype)
- PerlIO_printf(Perl_error_log, "LC_CTYPE ");
- #endif /* USE_LOCALE_CTYPE */
- #ifdef USE_LOCALE_COLLATE
- if (! curcoll)
- PerlIO_printf(Perl_error_log, "LC_COLLATE ");
- #endif /* USE_LOCALE_COLLATE */
- #ifdef USE_LOCALE_NUMERIC
- if (! curnum)
- PerlIO_printf(Perl_error_log, "LC_NUMERIC ");
- #endif /* USE_LOCALE_NUMERIC */
- PerlIO_printf(Perl_error_log, "\n");
-
- #endif /* LC_ALL */
-
- PerlIO_printf(Perl_error_log,
- "perl: warning: Please check that your locale settings:\n");
-
- #ifdef __GLIBC__
- PerlIO_printf(Perl_error_log,
- "\tLANGUAGE = %c%s%c,\n",
- language ? '"' : '(',
- language ? language : "unset",
- language ? '"' : ')');
- #endif
-
- PerlIO_printf(Perl_error_log,
- "\tLC_ALL = %c%s%c,\n",
- lc_all ? '"' : '(',
- lc_all ? lc_all : "unset",
- lc_all ? '"' : ')');
-
- #if defined(USE_ENVIRON_ARRAY)
- {
- char **e;
- for (e = environ; *e; e++) {
- if (strnEQ(*e, "LC_", 3)
- && strnNE(*e, "LC_ALL=", 7)
- && (p = strchr(*e, '=')))
- PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
- (int)(p - *e), *e, p + 1);
- }
- }
- #else
- PerlIO_printf(Perl_error_log,
- "\t(possibly more locale environment variables)\n");
- #endif
-
- PerlIO_printf(Perl_error_log,
- "\tLANG = %c%s%c\n",
- lang ? '"' : '(',
- lang ? lang : "unset",
- lang ? '"' : ')');
-
- PerlIO_printf(Perl_error_log,
- " are supported and installed on your system.\n");
- }
-
- #ifdef LC_ALL
-
- if (setlocale(LC_ALL, "C")) {
- if (locwarn)
- PerlIO_printf(Perl_error_log,
- "perl: warning: Falling back to the standard locale (\"C\").\n");
- ok = 0;
- }
- else {
- if (locwarn)
- PerlIO_printf(Perl_error_log,
- "perl: warning: Failed to fall back to the standard locale (\"C\").\n");
- ok = -1;
- }
-
- #else /* ! LC_ALL */
-
- if (0
- #ifdef USE_LOCALE_CTYPE
- || !(curctype || setlocale(LC_CTYPE, "C"))
- #endif /* USE_LOCALE_CTYPE */
- #ifdef USE_LOCALE_COLLATE
- || !(curcoll || setlocale(LC_COLLATE, "C"))
- #endif /* USE_LOCALE_COLLATE */
- #ifdef USE_LOCALE_NUMERIC
- || !(curnum || setlocale(LC_NUMERIC, "C"))
- #endif /* USE_LOCALE_NUMERIC */
- )
- {
- if (locwarn)
- PerlIO_printf(Perl_error_log,
- "perl: warning: Cannot fall back to the standard locale (\"C\").\n");
- ok = -1;
- }
-
- #endif /* ! LC_ALL */
-
- #ifdef USE_LOCALE_CTYPE
- curctype = savepv(setlocale(LC_CTYPE, Nullch));
- #endif /* USE_LOCALE_CTYPE */
- #ifdef USE_LOCALE_COLLATE
- curcoll = savepv(setlocale(LC_COLLATE, Nullch));
- #endif /* USE_LOCALE_COLLATE */
- #ifdef USE_LOCALE_NUMERIC
- curnum = savepv(setlocale(LC_NUMERIC, Nullch));
- #endif /* USE_LOCALE_NUMERIC */
- }
- else {
-
- #ifdef USE_LOCALE_CTYPE
- new_ctype(curctype);
- #endif /* USE_LOCALE_CTYPE */
-
- #ifdef USE_LOCALE_COLLATE
- new_collate(curcoll);
- #endif /* USE_LOCALE_COLLATE */
-
- #ifdef USE_LOCALE_NUMERIC
- new_numeric(curnum);
- #endif /* USE_LOCALE_NUMERIC */
- }
-
- #endif /* USE_LOCALE */
-
- #ifdef USE_LOCALE_CTYPE
- if (curctype != NULL)
- Safefree(curctype);
- #endif /* USE_LOCALE_CTYPE */
- #ifdef USE_LOCALE_COLLATE
- if (curcoll != NULL)
- Safefree(curcoll);
- #endif /* USE_LOCALE_COLLATE */
- #ifdef USE_LOCALE_NUMERIC
- if (curnum != NULL)
- Safefree(curnum);
- #endif /* USE_LOCALE_NUMERIC */
- return ok;
- }
-
- /* Backwards compatibility. */
- int
- Perl_init_i18nl14n(pTHX_ int printwarn)
- {
- return init_i18nl10n(printwarn);
- }
-
- #ifdef USE_LOCALE_COLLATE
-
- /*
- * mem_collxfrm() is a bit like strxfrm() but with two important
- * differences. First, it handles embedded NULs. Second, it allocates
- * a bit more memory than needed for the transformed data itself.
- * The real transformed data begins at offset sizeof(collationix).
- * Please see sv_collxfrm() to see how this is used.
- */
- char *
- Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen)
- {
- char *xbuf;
- STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
-
- /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
- /* the +1 is for the terminating NUL. */
-
- xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
- New(171, xbuf, xAlloc, char);
- if (! xbuf)
- goto bad;
-
- *(U32*)xbuf = PL_collation_ix;
- xout = sizeof(PL_collation_ix);
- for (xin = 0; xin < len; ) {
- SSize_t xused;
-
- for (;;) {
- xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
- if (xused == -1)
- goto bad;
- if (xused < xAlloc - xout)
- break;
- xAlloc = (2 * xAlloc) + 1;
- Renew(xbuf, xAlloc, char);
- if (! xbuf)
- goto bad;
- }
-
- xin += strlen(s + xin) + 1;
- xout += xused;
-
- /* Embedded NULs are understood but silently skipped
- * because they make no sense in locale collation. */
- }
-
- xbuf[xout] = '\0';
- *xlen = xout - sizeof(PL_collation_ix);
- return xbuf;
-
- bad:
- Safefree(xbuf);
- *xlen = 0;
- return NULL;
- }
-
- #endif /* USE_LOCALE_COLLATE */
-
#define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/
/* As a space optimization, we do not compile tables for strings of length
--- 484,489 ----
***************
*** 1033,1039 ****
s--, i++;
}
}
! sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */
SvVALID_on(sv);
s = (unsigned char*)(SvPVX(sv)); /* deeper magic */
--- 538,544 ----
s--, i++;
}
}
! sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */
SvVALID_on(sv);
s = (unsigned char*)(SvPVX(sv)); /* deeper magic */
***************
*** 1218,1233 ****
top2:
/*SUPPRESS 560*/
if ((tmp = table[*s])) {
- #ifdef POINTERRIGOR
- if (bigend - s > tmp) {
- s += tmp;
- goto top2;
- }
- s += tmp;
- #else
if ((s += tmp) < bigend)
goto top2;
- #endif
goto check_end;
}
else { /* less expensive than calling strncmp() */
--- 723,730 ----
***************
*** 1268,1274 ****
*/
/* If SvTAIL is actually due to \Z or \z, this gives false positives
! if PL_multiline. In fact if !PL_multiline the autoritative answer
is not supported yet. */
char *
--- 765,771 ----
*/
/* If SvTAIL is actually due to \Z or \z, this gives false positives
! if PL_multiline. In fact if !PL_multiline the authoritative answer
is not supported yet. */
char *
***************
*** 1307,1314 ****
--- 804,817 ----
/* The value of pos we can stop at: */
stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
if (previous + start_shift > stop_pos) {
+ /*
+ stop_pos does not include SvTAIL in the count, so this check is incorrect
+ (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
+ */
+ #if 0
if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
goto check_tail;
+ #endif
return Nullch;
}
while (pos < previous + start_shift) {
***************
*** 1315,1339 ****
if (!(pos += PL_screamnext[pos]))
goto cant_find;
}
- #ifdef POINTERRIGOR
- do {
- if (pos >= stop_pos) break;
- if (big[pos-previous] != first)
- continue;
- for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
- if (*s++ != *x++) {
- s--;
- break;
- }
- }
- if (s == littleend) {
- *old_posp = pos;
- if (!last) return (char *)(big+pos-previous);
- found = 1;
- }
- } while ( pos += PL_screamnext[pos] );
- return (last && found) ? (char *)(big+(*old_posp)-previous) : Nullch;
- #else /* !POINTERRIGOR */
big -= previous;
do {
if (pos >= stop_pos) break;
--- 818,823 ----
***************
*** 1353,1359 ****
} while ( pos += PL_screamnext[pos] );
if (last && found)
return (char *)(big+(*old_posp));
- #endif /* POINTERRIGOR */
check_tail:
if (!SvTAIL(littlestr) || (end_shift > 0))
return Nullch;
--- 837,842 ----
***************
*** 1520,1536 ****
return retval;
}
SV *
Perl_vmess(pTHX_ const char *pat, va_list *args)
{
SV *sv = mess_alloc();
static char dgd[] = " during global destruction.\n";
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
! if (CopLINE(PL_curcop))
Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
! CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
bool line_mode = (RsSIMPLE(PL_rs) &&
SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
--- 1003,1062 ----
return retval;
}
+ STATIC COP*
+ S_closest_cop(pTHX_ COP *cop, OP *o)
+ {
+ /* Look for PL_op starting from o. cop is the last COP we've seen. */
+
+ if (!o || o == PL_op) return cop;
+
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid;
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
+ {
+ COP *new_cop;
+
+ /* If the OP_NEXTSTATE has been optimised away we can still use it
+ * the get the file and line number. */
+
+ if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
+ cop = (COP *)kid;
+
+ /* Keep searching, and return when we've found something. */
+
+ new_cop = closest_cop(cop, kid);
+ if (new_cop) return new_cop;
+ }
+ }
+
+ /* Nothing found. */
+
+ return 0;
+ }
+
SV *
Perl_vmess(pTHX_ const char *pat, va_list *args)
{
SV *sv = mess_alloc();
static char dgd[] = " during global destruction.\n";
+ COP *cop;
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
!
! /*
! * Try and find the file and line for PL_op. This will usually be
! * PL_curcop, but it might be a cop that has been optimised away. We
! * can try to find such a cop by searching through the optree starting
! * from the sibling of PL_curcop.
! */
!
! cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
! if (!cop) cop = PL_curcop;
!
! if (CopLINE(cop))
Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
! CopFILE(cop), (IV)CopLINE(cop));
if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
bool line_mode = (RsSIMPLE(PL_rs) &&
SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
***************
*** 1980,1986 ****
#ifdef USE_ENVIRON_ARRAY
/* VMS' and EPOC's my_setenv() is in vms.c and epoc.c */
! #if !defined(WIN32)
void
Perl_my_setenv(pTHX_ char *nam, char *val)
{
--- 1506,1512 ----
#ifdef USE_ENVIRON_ARRAY
/* VMS' and EPOC's my_setenv() is in vms.c and epoc.c */
! #if !defined(WIN32) && !defined(NETWARE)
void
Perl_my_setenv(pTHX_ char *nam, char *val)
{
***************
*** 2034,2040 ****
#endif /* PERL_USE_SAFE_PUTENV */
}
! #else /* WIN32 */
void
Perl_my_setenv(pTHX_ char *nam,char *val)
--- 1560,1566 ----
#endif /* PERL_USE_SAFE_PUTENV */
}
! #else /* WIN32 || NETWARE */
void
Perl_my_setenv(pTHX_ char *nam,char *val)
***************
*** 2051,2057 ****
Safefree(envstr);
}
! #endif /* WIN32 */
I32
Perl_setenv_getix(pTHX_ char *nam)
--- 1577,1583 ----
Safefree(envstr);
}
! #endif /* WIN32 || NETWARE */
I32
Perl_setenv_getix(pTHX_ char *nam)
***************
*** 2085,2091 ****
#endif
/* this is a drop-in replacement for bcopy() */
! #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
char *
Perl_my_bcopy(register const char *from,register char *to,register I32 len)
{
--- 1611,1617 ----
#endif
/* this is a drop-in replacement for bcopy() */
! #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
char *
Perl_my_bcopy(register const char *from,register char *to,register I32 len)
{
***************
*** 2312,2318 ****
PerlIO *
Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
{
! #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
int p[2];
register I32 This, that;
register Pid_t pid;
--- 1838,1844 ----
PerlIO *
Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
{
! #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
int p[2];
register I32 This, that;
register Pid_t pid;
***************
*** 2345,2352 ****
}
if (pid == 0) {
/* Child */
- GV* tmpgv;
- int fd;
#undef THIS
#undef THAT
#define THIS that
--- 1871,1876 ----
***************
*** 2368,2379 ****
}
#if !defined(HAS_FCNTL) || !defined(F_SETFD)
/* No automatic close - do it by hand */
! #ifndef NOFILE
! #define NOFILE 20
! #endif
! for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
! if (fd != pp[1])
! PerlLIO_close(fd);
}
#endif
do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
--- 1892,1907 ----
}
#if !defined(HAS_FCNTL) || !defined(F_SETFD)
/* No automatic close - do it by hand */
! # ifndef NOFILE
! # define NOFILE 20
! # endif
! {
! int fd;
!
! for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
! if (fd != pp[1])
! PerlLIO_close(fd);
! }
}
#endif
do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
***************
*** 2502,2512 ****
#ifndef NOFILE
#define NOFILE 20
#endif
! for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
! if (fd != pp[1])
! PerlLIO_close(fd);
#endif
! do_exec3(cmd,pp[1],did_pipes); /* may or may not use the shell */
PerlProc__exit(1);
}
#endif /* defined OS2 */
--- 2030,2045 ----
#ifndef NOFILE
#define NOFILE 20
#endif
! {
! int fd;
!
! for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
! if (fd != pp[1])
! PerlLIO_close(fd);
! }
#endif
! /* may or may not use the shell */
! do_exec3(cmd, pp[1], did_pipes);
PerlProc__exit(1);
}
#endif /* defined OS2 */
***************
*** 2564,2570 ****
return PerlIO_fdopen(p[This], mode);
}
#else
! #if defined(atarist) || defined(DJGPP)
FILE *popen();
PerlIO *
Perl_my_popen(pTHX_ char *cmd, char *mode)
--- 2097,2103 ----
return PerlIO_fdopen(p[This], mode);
}
#else
! #if defined(atarist)
FILE *popen();
PerlIO *
Perl_my_popen(pTHX_ char *cmd, char *mode)
***************
*** 2576,2582 ****
--- 2109,2129 ----
*/
return PerlIO_importFILE(popen(cmd, mode), 0);
}
+ #else
+ #if defined(DJGPP)
+ FILE *djgpp_popen();
+ PerlIO *
+ Perl_my_popen(pTHX_ char *cmd, char *mode)
+ {
+ PERL_FLUSHALL_FOR_CHILD;
+ /* Call system's popen() to get a FILE *, then import it.
+ used 0 for 2nd parameter to PerlIO_importFILE;
+ apparently not used
+ */
+ return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
+ }
#endif
+ #endif
#endif /* !DOSISH */
***************
*** 2750,2756 ****
Pid_t pid;
Pid_t pid2;
bool close_failed;
! int saved_errno;
#ifdef VMS
int saved_vaxc_errno;
#endif
--- 2297,2303 ----
Pid_t pid;
Pid_t pid2;
bool close_failed;
! int saved_errno = 0;
#ifdef VMS
int saved_vaxc_errno;
#endif
***************
*** 2802,2818 ****
}
#endif /* !DOSISH */
! #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
I32
Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
{
SV *sv;
SV** svp;
char spid[TYPE_CHARS(int)];
- if (!pid)
- return -1;
- #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
if (pid > 0) {
sprintf(spid, "%"IVdf, (IV)pid);
svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
--- 2349,2366 ----
}
#endif /* !DOSISH */
! #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
I32
Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
{
+ if (!pid)
+ return -1;
+ #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
+ {
SV *sv;
SV** svp;
char spid[TYPE_CHARS(int)];
if (pid > 0) {
sprintf(spid, "%"IVdf, (IV)pid);
svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
***************
*** 2834,2839 ****
--- 2382,2388 ----
(void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
return pid;
}
+ }
}
#endif
#ifdef HAS_WAITPID
***************
*** 2862,2868 ****
}
#endif
}
! #endif /* !DOSISH || OS2 || WIN32 */
void
/*SUPPRESS 590*/
--- 2411,2417 ----
}
#endif
}
! #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
void
/*SUPPRESS 590*/
***************
*** 2878,2884 ****
return;
}
! #if defined(atarist) || defined(OS2) || defined(DJGPP)
int pclose();
#ifdef HAS_FORK
int /* Cannot prototype with I32
--- 2427,2433 ----
return;
}
! #if defined(atarist) || defined(OS2)
int pclose();
#ifdef HAS_FORK
int /* Cannot prototype with I32
***************
*** 2892,2900 ****
/* Needs work for PerlIO ! */
FILE *f = PerlIO_findFILE(ptr);
I32 result = pclose(f);
#if defined(DJGPP)
result = (result << 8) & 0xff00;
- #endif
PerlIO_releaseFILE(ptr,f);
return result;
}
--- 2441,2460 ----
/* Needs work for PerlIO ! */
FILE *f = PerlIO_findFILE(ptr);
I32 result = pclose(f);
+ PerlIO_releaseFILE(ptr,f);
+ return result;
+ }
+ #endif
+
#if defined(DJGPP)
+ int djgpp_pclose();
+ I32
+ Perl_my_pclose(pTHX_ PerlIO *ptr)
+ {
+ /* Needs work for PerlIO ! */
+ FILE *f = PerlIO_findFILE(ptr);
+ I32 result = djgpp_pclose(f);
result = (result << 8) & 0xff00;
PerlIO_releaseFILE(ptr,f);
return result;
}
***************
*** 2920,3004 ****
}
}
- U32
- Perl_cast_ulong(pTHX_ NV f)
- {
- long along;
-
- #if CASTFLAGS & 2
- # define BIGDOUBLE 2147483648.0
- if (f >= BIGDOUBLE)
- return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000;
- #endif
- if (f >= 0.0)
- return (unsigned long)f;
- along = (long)f;
- return (unsigned long)along;
- }
- # undef BIGDOUBLE
-
- /* Unfortunately, on some systems the cast_uv() function doesn't
- work with the system-supplied definition of ULONG_MAX. The
- comparison (f >= ULONG_MAX) always comes out true. It must be a
- problem with the compiler constant folding.
-
- In any case, this workaround should be fine on any two's complement
- system. If it's not, supply a '-DMY_ULONG_MAX=whatever' in your
- ccflags.
- --Andy Dougherty <doughera@lafcol.lafayette.edu>
- */
-
- /* Code modified to prefer proper named type ranges, I32, IV, or UV, instead
- of LONG_(MIN/MAX).
- -- Kenneth Albanowski <kjahds@kjahds.com>
- */
-
- #ifndef MY_UV_MAX
- # define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1)
- #endif
-
- I32
- Perl_cast_i32(pTHX_ NV f)
- {
- if (f >= I32_MAX)
- return (I32) I32_MAX;
- if (f <= I32_MIN)
- return (I32) I32_MIN;
- return (I32) f;
- }
-
- IV
- Perl_cast_iv(pTHX_ NV f)
- {
- if (f >= IV_MAX) {
- UV uv;
-
- if (f >= (NV)UV_MAX)
- return (IV) UV_MAX;
- uv = (UV) f;
- return (IV)uv;
- }
- if (f <= IV_MIN)
- return (IV) IV_MIN;
- return (IV) f;
- }
-
- UV
- Perl_cast_uv(pTHX_ NV f)
- {
- if (f >= MY_UV_MAX)
- return (UV) MY_UV_MAX;
- if (f < 0) {
- IV iv;
-
- if (f < IV_MIN)
- return (UV)IV_MIN;
- iv = (IV) f;
- return (UV) iv;
- }
- return (UV) f;
- }
-
#ifndef HAS_RENAME
I32
Perl_same_dirent(pTHX_ char *a, char *b)
--- 2480,2485 ----
***************
*** 3036,3251 ****
}
#endif /* !HAS_RENAME */
- NV
- Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen)
- {
- register char *s = start;
- register NV rnv = 0.0;
- register UV ruv = 0;
- register bool seenb = FALSE;
- register bool overflowed = FALSE;
-
- for (; len-- && *s; s++) {
- if (!(*s == '0' || *s == '1')) {
- if (*s == '_' && len && *retlen
- && (s[1] == '0' || s[1] == '1'))
- {
- --len;
- ++s;
- }
- else if (seenb == FALSE && *s == 'b' && ruv == 0) {
- /* Disallow 0bbb0b0bbb... */
- seenb = TRUE;
- continue;
- }
- else {
- if (ckWARN(WARN_DIGIT))
- Perl_warner(aTHX_ WARN_DIGIT,
- "Illegal binary digit '%c' ignored", *s);
- break;
- }
- }
- if (!overflowed) {
- register UV xuv = ruv << 1;
-
- if ((xuv >> 1) != ruv) {
- overflowed = TRUE;
- rnv = (NV) ruv;
- if (ckWARN_d(WARN_OVERFLOW))
- Perl_warner(aTHX_ WARN_OVERFLOW,
- "Integer overflow in binary number");
- }
- else
- ruv = xuv | (*s - '0');
- }
- if (overflowed) {
- rnv *= 2;
- /* If an NV has not enough bits in its mantissa to
- * represent an UV this summing of small low-order numbers
- * is a waste of time (because the NV cannot preserve
- * the low-order bits anyway): we could just remember when
- * did we overflow and in the end just multiply rnv by the
- * right amount. */
- rnv += (*s - '0');
- }
- }
- if (!overflowed)
- rnv = (NV) ruv;
- if ( ( overflowed && rnv > 4294967295.0)
- #if UVSIZE > 4
- || (!overflowed && ruv > 0xffffffff )
- #endif
- ) {
- if (ckWARN(WARN_PORTABLE))
- Perl_warner(aTHX_ WARN_PORTABLE,
- "Binary number > 0b11111111111111111111111111111111 non-portable");
- }
- *retlen = s - start;
- return rnv;
- }
-
- NV
- Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen)
- {
- register char *s = start;
- register NV rnv = 0.0;
- register UV ruv = 0;
- register bool overflowed = FALSE;
-
- for (; len-- && *s; s++) {
- if (!(*s >= '0' && *s <= '7')) {
- if (*s == '_' && len && *retlen
- && (s[1] >= '0' && s[1] <= '7'))
- {
- --len;
- ++s;
- }
- else {
- /* Allow \octal to work the DWIM way (that is, stop scanning
- * as soon as non-octal characters are seen, complain only iff
- * someone seems to want to use the digits eight and nine). */
- if (*s == '8' || *s == '9') {
- if (ckWARN(WARN_DIGIT))
- Perl_warner(aTHX_ WARN_DIGIT,
- "Illegal octal digit '%c' ignored", *s);
- }
- break;
- }
- }
- if (!overflowed) {
- register UV xuv = ruv << 3;
-
- if ((xuv >> 3) != ruv) {
- overflowed = TRUE;
- rnv = (NV) ruv;
- if (ckWARN_d(WARN_OVERFLOW))
- Perl_warner(aTHX_ WARN_OVERFLOW,
- "Integer overflow in octal number");
- }
- else
- ruv = xuv | (*s - '0');
- }
- if (overflowed) {
- rnv *= 8.0;
- /* If an NV has not enough bits in its mantissa to
- * represent an UV this summing of small low-order numbers
- * is a waste of time (because the NV cannot preserve
- * the low-order bits anyway): we could just remember when
- * did we overflow and in the end just multiply rnv by the
- * right amount of 8-tuples. */
- rnv += (NV)(*s - '0');
- }
- }
- if (!overflowed)
- rnv = (NV) ruv;
- if ( ( overflowed && rnv > 4294967295.0)
- #if UVSIZE > 4
- || (!overflowed && ruv > 0xffffffff )
- #endif
- ) {
- if (ckWARN(WARN_PORTABLE))
- Perl_warner(aTHX_ WARN_PORTABLE,
- "Octal number > 037777777777 non-portable");
- }
- *retlen = s - start;
- return rnv;
- }
-
- NV
- Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen)
- {
- register char *s = start;
- register NV rnv = 0.0;
- register UV ruv = 0;
- register bool overflowed = FALSE;
- char *hexdigit;
-
- if (len > 2) {
- if (s[0] == 'x') {
- s++;
- len--;
- }
- else if (len > 3 && s[0] == '0' && s[1] == 'x') {
- s+=2;
- len-=2;
- }
- }
-
- for (; len-- && *s; s++) {
- hexdigit = strchr((char *) PL_hexdigit, *s);
- if (!hexdigit) {
- if (*s == '_' && len && *retlen && s[1]
- && (hexdigit = strchr((char *) PL_hexdigit, s[1])))
- {
- --len;
- ++s;
- }
- else {
- if (ckWARN(WARN_DIGIT))
- Perl_warner(aTHX_ WARN_DIGIT,
- "Illegal hexadecimal digit '%c' ignored", *s);
- break;
- }
- }
- if (!overflowed) {
- register UV xuv = ruv << 4;
-
- if ((xuv >> 4) != ruv) {
- overflowed = TRUE;
- rnv = (NV) ruv;
- if (ckWARN_d(WARN_OVERFLOW))
- Perl_warner(aTHX_ WARN_OVERFLOW,
- "Integer overflow in hexadecimal number");
- }
- else
- ruv = xuv | ((hexdigit - PL_hexdigit) & 15);
- }
- if (overflowed) {
- rnv *= 16.0;
- /* If an NV has not enough bits in its mantissa to
- * represent an UV this summing of small low-order numbers
- * is a waste of time (because the NV cannot preserve
- * the low-order bits anyway): we could just remember when
- * did we overflow and in the end just multiply rnv by the
- * right amount of 16-tuples. */
- rnv += (NV)((hexdigit - PL_hexdigit) & 15);
- }
- }
- if (!overflowed)
- rnv = (NV) ruv;
- if ( ( overflowed && rnv > 4294967295.0)
- #if UVSIZE > 4
- || (!overflowed && ruv > 0xffffffff )
- #endif
- ) {
- if (ckWARN(WARN_PORTABLE))
- Perl_warner(aTHX_ WARN_PORTABLE,
- "Hexadecimal number > 0xffffffff non-portable");
- }
- *retlen = s - start;
- return rnv;
- }
-
char*
Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
{
--- 2517,2522 ----
***************
*** 3489,3500 ****
Perl_croak_nocontext("panic: pthread_getspecific");
return (void*)t;
# else
! # ifdef I_MACH_CTHREADS
return (void*)cthread_data(cthread_self());
! # else
! return (void*)pthread_getspecific(PL_thr_key);
# endif
- # endif
#else
return (void*)NULL;
#endif
--- 2760,2771 ----
Perl_croak_nocontext("panic: pthread_getspecific");
return (void*)t;
# else
! # ifdef I_MACH_CTHREADS
return (void*)cthread_data(cthread_self());
! # else
! return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
! # endif
# endif
#else
return (void*)NULL;
#endif
***************
*** 3596,3603 ****
{
MAGIC *mg;
! SvUPGRADE(sv, SVt_PVMG);
! mg = mg_find(sv, 'm');
if (!mg) {
condpair_t *cp;
--- 2867,2874 ----
{
MAGIC *mg;
! (void)SvUPGRADE(sv, SVt_PVMG);
! mg = mg_find(sv, PERL_MAGIC_mutex);
if (!mg) {
condpair_t *cp;
***************
*** 3607,3613 ****
COND_INIT(&cp->cond);
cp->owner = 0;
LOCK_CRED_MUTEX; /* XXX need separate mutex? */
! mg = mg_find(sv, 'm');
if (mg) {
/* someone else beat us to initialising it */
UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
--- 2878,2884 ----
COND_INIT(&cp->cond);
cp->owner = 0;
LOCK_CRED_MUTEX; /* XXX need separate mutex? */
! mg = mg_find(sv, PERL_MAGIC_mutex);
if (mg) {
/* someone else beat us to initialising it */
UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
***************
*** 3617,3629 ****
Safefree(cp);
}
else {
! sv_magic(sv, Nullsv, 'm', 0, 0);
mg = SvMAGIC(sv);
mg->mg_ptr = (char *)cp;
mg->mg_len = sizeof(cp);
UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
! "%p: condpair_magic %p\n", thr, sv));)
}
}
return mg;
--- 2888,2900 ----
Safefree(cp);
}
else {
! sv_magic(sv, Nullsv, PERL_MAGIC_mutex, 0, 0);
mg = SvMAGIC(sv);
mg->mg_ptr = (char *)cp;
mg->mg_len = sizeof(cp);
UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
! "%p: condpair_magic %p\n", thr, sv)));
}
}
return mg;
***************
*** 3650,3656 ****
MgOWNER(mg) = thr;
DEBUG_S(PerlIO_printf(Perl_debug_log,
"0x%"UVxf": Perl_lock lock 0x%"UVxf"\n",
! PTR2UV(thr), PTR2UV(sv));)
MUTEX_UNLOCK(MgMUTEXP(mg));
SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
}
--- 2921,2927 ----
MgOWNER(mg) = thr;
DEBUG_S(PerlIO_printf(Perl_debug_log,
"0x%"UVxf": Perl_lock lock 0x%"UVxf"\n",
! PTR2UV(thr), PTR2UV(sv)));
MUTEX_UNLOCK(MgMUTEXP(mg));
SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
}
***************
*** 3761,3767 ****
if (*svp && *svp != &PL_sv_undef) {
SV *sv = newSVsv(*svp);
av_store(thr->threadsv, i, sv);
! sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1);
DEBUG_S(PerlIO_printf(Perl_debug_log,
"new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
(IV)i, t, thr));
--- 3032,3038 ----
if (*svp && *svp != &PL_sv_undef) {
SV *sv = newSVsv(*svp);
av_store(thr->threadsv, i, sv);
! sv_magic(sv, 0, PERL_MAGIC_sv, &PL_threadsv_names[i], 1);
DEBUG_S(PerlIO_printf(Perl_debug_log,
"new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
(IV)i, t, thr));
***************
*** 3788,3809 ****
}
#endif /* USE_THREADS */
- #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
- /*
- * This hack is to force load of "huge" support from libm.a
- * So it is in perl for (say) POSIX to use.
- * Needed for SunOS with Sun's 'acc' for example.
- */
- NV
- Perl_huge(void)
- {
- # if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
- return HUGE_VALL;
- # endif
- return HUGE_VAL;
- }
- #endif
-
#ifdef PERL_GLOBAL_STRUCT
struct perl_vars *
Perl_GetVars(pTHX)
--- 3059,3064 ----
***************
*** 3969,3996 ****
extern void _fwalk(int (*)(FILE *));
_fwalk(&fflush);
return 0;
! # else
! long open_max = -1;
# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
# else
! # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
open_max = sysconf(_SC_OPEN_MAX);
! # else
! # ifdef FOPEN_MAX
open_max = FOPEN_MAX;
! # else
! # ifdef OPEN_MAX
open_max = OPEN_MAX;
! # else
! # ifdef _NFILE
open_max = _NFILE;
# endif
# endif
# endif
- # endif
- # endif
if (open_max > 0) {
long i;
for (i = 0; i < open_max; i++)
--- 3224,3251 ----
extern void _fwalk(int (*)(FILE *));
_fwalk(&fflush);
return 0;
! # else
# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
+ long open_max = -1;
# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
# else
! # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
open_max = sysconf(_SC_OPEN_MAX);
! # else
! # ifdef FOPEN_MAX
open_max = FOPEN_MAX;
! # else
! # ifdef OPEN_MAX
open_max = OPEN_MAX;
! # else
! # ifdef _NFILE
open_max = _NFILE;
+ # endif
+ # endif
# endif
# endif
# endif
if (open_max > 0) {
long i;
for (i = 0; i < open_max; i++)
***************
*** 4007,4035 ****
#endif
}
- NV
- Perl_my_atof(pTHX_ const char* s)
- {
- NV x = 0.0;
- #ifdef USE_LOCALE_NUMERIC
- if ((PL_hints & HINT_LOCALE) && PL_numeric_local) {
- NV y;
-
- Perl_atof2(s, x);
- SET_NUMERIC_STANDARD();
- Perl_atof2(s, y);
- SET_NUMERIC_LOCAL();
- if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
- return y;
- }
- else
- Perl_atof2(s, x);
- #else
- Perl_atof2(s, x);
- #endif
- return x;
- }
-
void
Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
{
--- 3262,3267 ----
***************
*** 4040,4050 ****
op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
PL_op_desc[op];
char *pars = OP_IS_FILETEST(op) ? "" : "()";
! char *type = OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) ?
"socket" : "filehandle";
char *name = NULL;
! if (io && IoTYPE(io) == IoTYPE_CLOSED) {
vile = "closed";
warn_type = WARN_CLOSED;
}
--- 3272,3283 ----
op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
PL_op_desc[op];
char *pars = OP_IS_FILETEST(op) ? "" : "()";
! char *type = OP_IS_SOCKET(op) ||
! (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
"socket" : "filehandle";
char *name = NULL;
! if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
vile = "closed";
warn_type = WARN_CLOSED;
}
***************
*** 4078,4084 ****
else {
Perl_warner(aTHX_ warn_type,
"%s%s on %s %s", func, pars, vile, type);
! if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
Perl_warner(aTHX_ warn_type,
"\t(Are you trying to call %s%s on dirhandle?)\n",
func, pars);
--- 3311,3317 ----
else {
Perl_warner(aTHX_ warn_type,
"%s%s on %s %s", func, pars, vile, type);
! if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
Perl_warner(aTHX_ warn_type,
"\t(Are you trying to call %s%s on dirhandle?)\n",
func, pars);
***************
*** 4124,4126 ****
--- 3357,3819 ----
}
}
#endif
+
+ /* XXX struct tm on some systems (SunOS4/BSD) contains extra (non POSIX)
+ * fields for which we don't have Configure support yet:
+ * char *tm_zone; -- abbreviation of timezone name
+ * long tm_gmtoff; -- offset from GMT in seconds
+ * To workaround core dumps from the uninitialised tm_zone we get the
+ * system to give us a reasonable struct to copy. This fix means that
+ * strftime uses the tm_zone and tm_gmtoff values returned by
+ * localtime(time()). That should give the desired result most of the
+ * time. But probably not always!
+ *
+ * This is a temporary workaround to be removed once Configure
+ * support is added and NETaa14816 is considered in full.
+ * It does not address tzname aspects of NETaa14816.
+ */
+ #ifdef HAS_GNULIBC
+ # ifndef STRUCT_TM_HASZONE
+ # define STRUCT_TM_HASZONE
+ # endif
+ #endif
+
+ void
+ Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
+ {
+ #ifdef STRUCT_TM_HASZONE
+ Time_t now;
+ (void)time(&now);
+ Copy(localtime(&now), ptm, 1, struct tm);
+ #endif
+ }
+
+ /*
+ * mini_mktime - normalise struct tm values without the localtime()
+ * semantics (and overhead) of mktime().
+ */
+ void
+ Perl_mini_mktime(pTHX_ struct tm *ptm)
+ {
+ int yearday;
+ int secs;
+ int month, mday, year, jday;
+ int odd_cent, odd_year;
+
+ #define DAYS_PER_YEAR 365
+ #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
+ #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
+ #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
+ #define SECS_PER_HOUR (60*60)
+ #define SECS_PER_DAY (24*SECS_PER_HOUR)
+ /* parentheses deliberately absent on these two, otherwise they don't work */
+ #define MONTH_TO_DAYS 153/5
+ #define DAYS_TO_MONTH 5/153
+ /* offset to bias by March (month 4) 1st between month/mday & year finding */
+ #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
+ /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
+ #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
+
+ /*
+ * Year/day algorithm notes:
+ *
+ * With a suitable offset for numeric value of the month, one can find
+ * an offset into the year by considering months to have 30.6 (153/5) days,
+ * using integer arithmetic (i.e., with truncation). To avoid too much
+ * messing about with leap days, we consider January and February to be
+ * the 13th and 14th month of the previous year. After that transformation,
+ * we need the month index we use to be high by 1 from 'normal human' usage,
+ * so the month index values we use run from 4 through 15.
+ *
+ * Given that, and the rules for the Gregorian calendar (leap years are those
+ * divisible by 4 unless also divisible by 100, when they must be divisible
+ * by 400 instead), we can simply calculate the number of days since some
+ * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
+ * the days we derive from our month index, and adding in the day of the
+ * month. The value used here is not adjusted for the actual origin which
+ * it normally would use (1 January A.D. 1), since we're not exposing it.
+ * We're only building the value so we can turn around and get the
+ * normalised values for the year, month, day-of-month, and day-of-year.
+ *
+ * For going backward, we need to bias the value we're using so that we find
+ * the right year value. (Basically, we don't want the contribution of
+ * March 1st to the number to apply while deriving the year). Having done
+ * that, we 'count up' the contribution to the year number by accounting for
+ * full quadracenturies (400-year periods) with their extra leap days, plus
+ * the contribution from full centuries (to avoid counting in the lost leap
+ * days), plus the contribution from full quad-years (to count in the normal
+ * leap days), plus the leftover contribution from any non-leap years.
+ * At this point, if we were working with an actual leap day, we'll have 0
+ * days left over. This is also true for March 1st, however. So, we have
+ * to special-case that result, and (earlier) keep track of the 'odd'
+ * century and year contributions. If we got 4 extra centuries in a qcent,
+ * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
+ * Otherwise, we add back in the earlier bias we removed (the 123 from
+ * figuring in March 1st), find the month index (integer division by 30.6),
+ * and the remainder is the day-of-month. We then have to convert back to
+ * 'real' months (including fixing January and February from being 14/15 in
+ * the previous year to being in the proper year). After that, to get
+ * tm_yday, we work with the normalised year and get a new yearday value for
+ * January 1st, which we subtract from the yearday value we had earlier,
+ * representing the date we've re-built. This is done from January 1
+ * because tm_yday is 0-origin.
+ *
+ * Since POSIX time routines are only guaranteed to work for times since the
+ * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
+ * applies Gregorian calendar rules even to dates before the 16th century
+ * doesn't bother me. Besides, you'd need cultural context for a given
+ * date to know whether it was Julian or Gregorian calendar, and that's
+ * outside the scope for this routine. Since we convert back based on the
+ * same rules we used to build the yearday, you'll only get strange results
+ * for input which needed normalising, or for the 'odd' century years which
+ * were leap years in the Julian calander but not in the Gregorian one.
+ * I can live with that.
+ *
+ * This algorithm also fails to handle years before A.D. 1 gracefully, but
+ * that's still outside the scope for POSIX time manipulation, so I don't
+ * care.
+ */
+
+ year = 1900 + ptm->tm_year;
+ month = ptm->tm_mon;
+ mday = ptm->tm_mday;
+ /* allow given yday with no month & mday to dominate the result */
+ if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
+ month = 0;
+ mday = 0;
+ jday = 1 + ptm->tm_yday;
+ }
+ else {
+ jday = 0;
+ }
+ if (month >= 2)
+ month+=2;
+ else
+ month+=14, year--;
+ yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
+ yearday += month*MONTH_TO_DAYS + mday + jday;
+ /*
+ * Note that we don't know when leap-seconds were or will be,
+ * so we have to trust the user if we get something which looks
+ * like a sensible leap-second. Wild values for seconds will
+ * be rationalised, however.
+ */
+ if ((unsigned) ptm->tm_sec <= 60) {
+ secs = 0;
+ }
+ else {
+ secs = ptm->tm_sec;
+ ptm->tm_sec = 0;
+ }
+ secs += 60 * ptm->tm_min;
+ secs += SECS_PER_HOUR * ptm->tm_hour;
+ if (secs < 0) {
+ if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
+ /* got negative remainder, but need positive time */
+ /* back off an extra day to compensate */
+ yearday += (secs/SECS_PER_DAY)-1;
+ secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
+ }
+ else {
+ yearday += (secs/SECS_PER_DAY);
+ secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
+ }
+ }
+ else if (secs >= SECS_PER_DAY) {
+ yearday += (secs/SECS_PER_DAY);
+ secs %= SECS_PER_DAY;
+ }
+ ptm->tm_hour = secs/SECS_PER_HOUR;
+ secs %= SECS_PER_HOUR;
+ ptm->tm_min = secs/60;
+ secs %= 60;
+ ptm->tm_sec += secs;
+ /* done with time of day effects */
+ /*
+ * The algorithm for yearday has (so far) left it high by 428.
+ * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
+ * bias it by 123 while trying to figure out what year it
+ * really represents. Even with this tweak, the reverse
+ * translation fails for years before A.D. 0001.
+ * It would still fail for Feb 29, but we catch that one below.
+ */
+ jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
+ yearday -= YEAR_ADJUST;
+ year = (yearday / DAYS_PER_QCENT) * 400;
+ yearday %= DAYS_PER_QCENT;
+ odd_cent = yearday / DAYS_PER_CENT;
+ year += odd_cent * 100;
+ yearday %= DAYS_PER_CENT;
+ year += (yearday / DAYS_PER_QYEAR) * 4;
+ yearday %= DAYS_PER_QYEAR;
+ odd_year = yearday / DAYS_PER_YEAR;
+ year += odd_year;
+ yearday %= DAYS_PER_YEAR;
+ if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
+ month = 1;
+ yearday = 29;
+ }
+ else {
+ yearday += YEAR_ADJUST; /* recover March 1st crock */
+ month = yearday*DAYS_TO_MONTH;
+ yearday -= month*MONTH_TO_DAYS;
+ /* recover other leap-year adjustment */
+ if (month > 13) {
+ month-=14;
+ year++;
+ }
+ else {
+ month-=2;
+ }
+ }
+ ptm->tm_year = year - 1900;
+ if (yearday) {
+ ptm->tm_mday = yearday;
+ ptm->tm_mon = month;
+ }
+ else {
+ ptm->tm_mday = 31;
+ ptm->tm_mon = month - 1;
+ }
+ /* re-build yearday based on Jan 1 to get tm_yday */
+ year--;
+ yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
+ yearday += 14*MONTH_TO_DAYS + 1;
+ ptm->tm_yday = jday - yearday;
+ /* fix tm_wday if not overridden by caller */
+ if ((unsigned)ptm->tm_wday > 6)
+ ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
+ }
+
+ char *
+ Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
+ {
+ #ifdef HAS_STRFTIME
+ char *buf;
+ int buflen;
+ struct tm mytm;
+ int len;
+
+ 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;
+ mini_mktime(&mytm);
+ buflen = 64;
+ New(0, buf, buflen, char);
+ len = strftime(buf, buflen, fmt, &mytm);
+ /*
+ ** The following is needed to handle to the situation where
+ ** tmpbuf overflows. Basically we want to allocate a buffer
+ ** and try repeatedly. The reason why it is so complicated
+ ** is that getting a return value of 0 from strftime can indicate
+ ** one of the following:
+ ** 1. buffer overflowed,
+ ** 2. illegal conversion specifier, or
+ ** 3. the format string specifies nothing to be returned(not
+ ** an error). This could be because format is an empty string
+ ** or it specifies %p that yields an empty string in some locale.
+ ** If there is a better way to make it portable, go ahead by
+ ** all means.
+ */
+ if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
+ return buf;
+ else {
+ /* Possibly buf overflowed - try again with a bigger buf */
+ int fmtlen = strlen(fmt);
+ int bufsize = fmtlen + buflen;
+
+ New(0, buf, bufsize, char);
+ while (buf) {
+ buflen = strftime(buf, bufsize, fmt, &mytm);
+ if (buflen > 0 && buflen < bufsize)
+ break;
+ /* heuristic to prevent out-of-memory errors */
+ if (bufsize > 100*fmtlen) {
+ Safefree(buf);
+ buf = NULL;
+ break;
+ }
+ bufsize *= 2;
+ Renew(buf, bufsize, char);
+ }
+ return buf;
+ }
+ #else
+ Perl_croak(aTHX_ "panic: no strftime");
+ #endif
+ }
+
+
+ #define SV_CWD_RETURN_UNDEF \
+ sv_setsv(sv, &PL_sv_undef); \
+ return FALSE
+
+ #define SV_CWD_ISDOT(dp) \
+ (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
+ (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
+
+ /*
+ =for apidoc getcwd_sv
+
+ Fill the sv with current working directory
+
+ =cut
+ */
+
+ /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
+ * rewritten again by dougm, optimized for use with xs TARG, and to prefer
+ * getcwd(3) if available
+ * Comments from the orignal:
+ * This is a faster version of getcwd. It's also more dangerous
+ * because you might chdir out of a directory that you can't chdir
+ * back into. */
+
+ int
+ Perl_getcwd_sv(pTHX_ register SV *sv)
+ {
+ #ifndef PERL_MICRO
+
+ #ifdef HAS_GETCWD
+ {
+ char buf[MAXPATHLEN];
+
+ /* Some getcwd()s automatically allocate a buffer of the given
+ * size from the heap if they are given a NULL buffer pointer.
+ * The problem is that this behaviour is not portable. */
+ if (getcwd(buf, sizeof(buf) - 1)) {
+ STRLEN len = strlen(buf);
+ sv_setpvn(sv, buf, len);
+ return TRUE;
+ }
+ else {
+ sv_setsv(sv, &PL_sv_undef);
+ return FALSE;
+ }
+ }
+
+ #else
+
+ struct stat statbuf;
+ int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
+ int namelen, pathlen=0;
+ DIR *dir;
+ Direntry_t *dp;
+
+ (void)SvUPGRADE(sv, SVt_PV);
+
+ if (PerlLIO_lstat(".", &statbuf) < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
+
+ orig_cdev = statbuf.st_dev;
+ orig_cino = statbuf.st_ino;
+ cdev = orig_cdev;
+ cino = orig_cino;
+
+ for (;;) {
+ odev = cdev;
+ oino = cino;
+
+ if (PerlDir_chdir("..") < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
+ if (PerlLIO_stat(".", &statbuf) < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
+
+ cdev = statbuf.st_dev;
+ cino = statbuf.st_ino;
+
+ if (odev == cdev && oino == cino) {
+ break;
+ }
+ if (!(dir = PerlDir_open("."))) {
+ SV_CWD_RETURN_UNDEF;
+ }
+
+ while ((dp = PerlDir_read(dir)) != NULL) {
+ #ifdef DIRNAMLEN
+ namelen = dp->d_namlen;
+ #else
+ namelen = strlen(dp->d_name);
+ #endif
+ /* skip . and .. */
+ if (SV_CWD_ISDOT(dp)) {
+ continue;
+ }
+
+ if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
+
+ tdev = statbuf.st_dev;
+ tino = statbuf.st_ino;
+ if (tino == oino && tdev == odev) {
+ break;
+ }
+ }
+
+ if (!dp) {
+ SV_CWD_RETURN_UNDEF;
+ }
+
+ if (pathlen + namelen + 1 >= MAXPATHLEN) {
+ SV_CWD_RETURN_UNDEF;
+ }
+
+ SvGROW(sv, pathlen + namelen + 1);
+
+ if (pathlen) {
+ /* shift down */
+ Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
+ }
+
+ /* prepend current directory to the front */
+ *SvPVX(sv) = '/';
+ Move(dp->d_name, SvPVX(sv)+1, namelen, char);
+ pathlen += (namelen + 1);
+
+ #ifdef VOID_CLOSEDIR
+ PerlDir_close(dir);
+ #else
+ if (PerlDir_close(dir) < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
+ #endif
+ }
+
+ if (pathlen) {
+ SvCUR_set(sv, pathlen);
+ *SvEND(sv) = '\0';
+ SvPOK_only(sv);
+
+ if (PerlDir_chdir(SvPVX(sv)) < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
+ }
+ if (PerlLIO_stat(".", &statbuf) < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
+
+ cdev = statbuf.st_dev;
+ cino = statbuf.st_ino;
+
+ if (cdev != orig_cdev || cino != orig_cino) {
+ Perl_croak(aTHX_ "Unstable directory path, "
+ "current directory changed unexpectedly");
+ }
+ #endif
+
+ return TRUE;
+ #else
+ return FALSE;
+ #endif
+ }
+
diff -c 'perl-5.7.1/util.h' 'perl-5.7.2/util.h'
Index: ./util.h
*** ./util.h Tue Mar 6 04:07:24 2001
--- ./util.h Mon Jul 9 17:11:32 2001
***************
*** 21,26 ****
--- 21,32 ----
|| ((f)[0] && (f)[1] == ':') /* drive name */ \
|| ((f)[0] == '\\' && (f)[1] == '\\')) /* UNC path */
# else /* !WIN32 */
+ # ifdef NETWARE
+ # define PERL_FILE_IS_ABSOLUTE(f) \
+ (((f)[0] && (f)[1] == ':') /* drive name */ \
+ || ((f)[0] == '\\' && (f)[1] == '\\') /* UNC path */ \
+ || ((f)[3] == ':')) /* volume name, currently only sys */
+ # else /* !NETWARE */
# if defined( DOSISH) || defined(EPOC)
# define PERL_FILE_IS_ABSOLUTE(f) \
(*(f) == '/' \
***************
*** 32,36 ****
--- 38,43 ----
# define PERL_FILE_IS_ABSOLUTE(f) (*(f) == '/')
# endif /* MACOS_TRADITIONAL */
# endif /* DOSISH */
+ # endif /* NETWARE */
# endif /* WIN32 */
#endif /* VMS */
diff -c /dev/null 'perl-5.7.2/utils.lst'
Index: ./utils.lst
*** ./utils.lst Thu Jan 1 02:00:00 1970
--- ./utils.lst Mon Jul 9 17:11:32 2001
***************
*** 0 ****
--- 1,21 ----
+ lib/ExtUtils/xsubpp
+ pod/pod2html
+ pod/pod2latex
+ pod/pod2man
+ pod/pod2text
+ pod/pod2usage
+ pod/podchecker
+ pod/podselect
+ utils/c2ph # link = utils/pstruct
+ utils/dprofpp
+ utils/h2ph
+ utils/h2xs
+ utils/libnetcfg
+ utils/perlbug
+ utils/perlcc
+ utils/perldoc
+ utils/pl2pm
+ utils/splain
+ x2p/a2p # pod = x2p/a2p.pod
+ x2p/find2perl
+ x2p/s2p # link = x2p/psed
diff -c 'perl-5.7.1/utils/Makefile' 'perl-5.7.2/utils/Makefile'
Index: ./utils/Makefile
*** ./utils/Makefile Tue Mar 6 04:07:24 2001
--- ./utils/Makefile Mon Jul 9 17:11:32 2001
***************
*** 5,26 ****
# Files to be built with variable substitution after miniperl is
# available. Dependencies handled manually below (for now).
! pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL splain.PL perlcc.PL dprofpp.PL
! plextract = c2ph h2ph h2xs perlbug perldoc pl2pm splain perlcc dprofpp
! plextractexe = ./c2ph ./h2ph ./h2xs ./perlbug ./perldoc ./pl2pm ./splain ./perlcc ./dprofpp
all: $(plextract)
compile: all $(plextract)
! $(REALPERL) -I../lib perlcc c2ph -o c2ph.exe -v 10 -log ../compilelog;
! $(REALPERL) -I../lib perlcc h2ph -o h2ph.exe -v 10 -log ../compilelog;
! $(REALPERL) -I../lib perlcc h2xs -o h2xs.exe -v 10 -log ../compilelog;
! $(REALPERL) -I../lib perlcc perlbug -o perlbug.exe -v 10 -log ../compilelog;
! $(REALPERL) -I../lib perlcc perldoc -o perldoc.exe -v 10 -log ../compilelog;
! $(REALPERL) -I../lib perlcc pl2pm -o pl2pm.exe -v 10 -log ../compilelog;
! $(REALPERL) -I../lib perlcc splain -o splain.exe -v 10 -log ../compilelog;
! $(REALPERL) -I../lib perlcc perlcc -o perlcc.exe -v 10 -log ../compilelog;
! $(REALPERL) -I../lib perlcc dprofpp -o dprofpp.exe -v 10 -log ../compilelog;
$(plextract):
$(PERL) -I../lib $@.PL
--- 5,27 ----
# Files to be built with variable substitution after miniperl is
# available. Dependencies handled manually below (for now).
! pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL splain.PL perlcc.PL dprofpp.PL libnetcfg.PL
! plextract = c2ph h2ph h2xs perlbug perldoc pl2pm splain perlcc dprofpp libnetcfg
! plextractexe = ./c2ph ./h2ph ./h2xs ./perlbug ./perldoc ./pl2pm ./splain ./perlcc ./dprofpp ./libnetcfg
all: $(plextract)
compile: all $(plextract)
! $(REALPERL) -I../lib perlcc -I .. -L .. c2ph -o c2ph.exe -v 10 -log ../compilelog;
! $(REALPERL) -I../lib perlcc -I .. -L .. h2ph -o h2ph.exe -v 10 -log ../compilelog;
! $(REALPERL) -I../lib perlcc -I .. -L .. h2xs -o h2xs.exe -v 10 -log ../compilelog;
! $(REALPERL) -I../lib perlcc -I .. -L .. perlbug -o perlbug.exe -v 10 -log ../compilelog;
! $(REALPERL) -I../lib perlcc -I .. -L .. perldoc -o perldoc.exe -v 10 -log ../compilelog;
! $(REALPERL) -I../lib perlcc -I .. -L .. pl2pm -o pl2pm.exe -v 10 -log ../compilelog;
! $(REALPERL) -I../lib perlcc -I .. -L .. splain -o splain.exe -v 10 -log ../compilelog;
! $(REALPERL) -I../lib perlcc -I .. -L .. perlcc -I .. -L .. -o perlcc.exe -v 10 -log ../compilelog;
! $(REALPERL) -I../lib perlcc -I .. -L .. dprofpp -o dprofpp.exe -v 10 -log ../compilelog;
! $(REALPERL) -I../lib perlcc -I .. -L .. libnetcfg -o libnetcfg.exe -v 10 -log ../compilelog;
$(plextract):
$(PERL) -I../lib $@.PL
***************
*** 42,47 ****
--- 43,50 ----
perlcc: perlcc.PL ../config.sh
dprofpp: dprofpp.PL ../config.sh
+
+ libnetcfg: libnetcfg.PL ../config.sh
clean:
diff -c 'perl-5.7.1/utils/dprofpp.PL' 'perl-5.7.2/utils/dprofpp.PL'
Index: ./utils/dprofpp.PL
*** ./utils/dprofpp.PL Tue Mar 6 04:07:25 2001
--- ./utils/dprofpp.PL Mon Jul 9 17:11:32 2001
***************
*** 57,68 ****
=head1 SYNOPSIS
! dprofpp [B<-a>|B<-z>|B<-l>|B<-v>|B<-U>] [B<-s>|B<-r>|B<-u>] [B<-q>] [B<-F>] [B<-I|-E>] [B<-O cnt>] [B<-A>] [B<-R>] [B<-S>] [B<-g subroutine>] [profile]
!
dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
dprofpp B<-p script> [B<-Q>] [other opts]
dprofpp B<-V> [profile]
--- 57,70 ----
=head1 SYNOPSIS
! dprofpp [B<-a>|B<-z>|B<-l>|B<-v>|B<-U>] [B<-d>] [B<-s>|B<-r>|B<-u>] [B<-q>] [B<-F>] [B<-I|-E>] [B<-O cnt>] [B<-A>] [B<-R>] [B<-S>] [B<-g subroutine>] [B<-G> <regexp> [B<-P>]] [B<-f> <regexp>] [profile]
!
dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
+ dprofpp B<-G> <regexp> [B<-P>] [profile]
+
dprofpp B<-p script> [B<-Q>] [other opts]
dprofpp B<-V> [profile]
***************
*** 147,152 ****
--- 149,158 ----
Sort alphabetically by subroutine names.
+ =item B<-d>
+
+ Reverse whatever sort is used
+
=item B<-A>
Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>.
***************
*** 258,263 ****
--- 264,288 ----
Ignore subroutines except C<subroutine> and whatever is called from it.
+ =item B<-G> <regexp>
+
+ Aggregate "Group" all calls matching the pattern together.
+ For example this can be used to group all calls of a set of packages
+
+ -G "(package1::)|(package2::)|(package3::)"
+
+ or to group subroutines by name:
+
+ -G "getNum"
+
+ =item B<-P>
+
+ Used with -G to aggregate "Pull" together all calls that did not match -G.
+
+ =item B<-f> <regexp>
+
+ Filter all calls matching the pattern.
+
=back
=head1 ENVIRONMENT
***************
*** 297,303 ****
use Config '%Config';
Setup: {
! my $options = 'O:g:lzaAvuTtqrRsUFEIp:QVS';
$Monfile = 'tmon.out';
if( exists $ENV{DPROFPP_OPTS} ){
--- 322,328 ----
use Config '%Config';
Setup: {
! my $options = 'O:g:G:Pf:dlzaAvuTtqrRsUFEIp:QVS';
$Monfile = 'tmon.out';
if( exists $ENV{DPROFPP_OPTS} ){
***************
*** 340,345 ****
--- 365,375 ----
# -g subr count only those who are SUBR or called from SUBR
# -S Create statistics for all the depths
+ # -G Group all calls matching the pattern together.
+ # -P Used with -G to pull all other calls together.
+ # -f Filter all calls mathcing the pattern.
+ # -d Reverse sort
+
if( defined $opt_V ){
my $fh = 'main::fh';
print "$0 version: $VERSION\n";
***************
*** 357,362 ****
--- 387,396 ----
$sort = 'by_calls' if defined $opt_l;
$sort = 'by_alpha' if defined $opt_a;
$sort = 'by_avgcpu' if defined $opt_v;
+
+ if(defined $opt_d){
+ $sort = "r".$sort;
+ }
$incl_excl = 'Exclusive';
$incl_excl = 'Inclusive' if defined $opt_I;
$whichtime = 'User+System';
***************
*** 412,417 ****
--- 446,468 ----
parsestack( $fh, $names, $calls, $times, $ctimes, $idkeys );
+ #filter calls
+ if( $opt_f ){
+ for(my $i = 0;$i < @$idkeys - 2;){
+ $key = $$idkeys[$i];
+ if($key =~ /$opt_f/){
+ splice(@$idkeys, $i, 1);
+ $runtime -= $$times{$key};
+ next;
+ }
+ $i++;
+ }
+ }
+
+ if( $opt_G ){
+ group($names, $calls, $times, $ctimes, $idkeys );
+ }
+
settime( \$runtime, $hz ) unless $opt_g;
exit(0) if $opt_T || $opt_t;
***************
*** 430,436 ****
--- 481,530 ----
$deep_times);
}
+ sub group{
+ my ($names, $calls, $times, $ctimes, $idkeys ) = @_;
+ print "Option G Grouping: [$opt_G]\n";
+ # create entries to store grouping
+ $$names{$opt_G} = $opt_G;
+ $$calls{$opt_G} = 0;
+ $$times{$opt_G} = 0;
+ $$ctimes{$opt_G} = 0;
+ $$idkeys[@$idkeys] = $opt_G;
+ # Sum calls for the grouping
+ my $other = "other";
+ if($opt_P){
+ $$names{$other} = $other;
+ $$calls{$other} = 0;
+ $$times{$other} = 0;
+ $$ctimes{$other} = 0;
+ $$idkeys[@$idkeys] = $other;
+ }
+
+ for(my $i = 0;$i < @$idkeys - 2;){
+ $key = $$idkeys[$i];
+ if($key =~ /$opt_G/){
+ $$calls{$opt_G} += $$calls{$key};
+ $$times{$opt_G} += $$times{$key};
+ $$ctimes{$opt_G} += $$ctimes{$key};
+ splice(@$idkeys, $i, 1);
+ next;
+ }else{
+ if($opt_P){
+ $$calls{$other} += $$calls{$key};
+ $$times{$other} += $$times{$key};
+ $$ctimes{$other} += $$ctimes{$key};
+ splice(@$idkeys, $i, 1);
+ next;
+ }
+ }
+ $i++;
+ }
+ print "Grouping [$opt_G] Calls: [$$calls{$opt_G}]\n".
+ "Grouping [$opt_G] Times: [$$times{$opt_G}]\n".
+ "Grouping [$opt_G] IncTimes: [$$ctimes{$opt_G}]\n";
+ }
+
# Sets $runtime to user, system, real, or user+system time. The
# result is given in seconds.
#
***************
*** 563,568 ****
--- 657,663 ----
pop @$curdeep_times;
}
+
sub parsestack {
my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_;
my( $dir, $name );
***************
*** 598,604 ****
chop;
if (/^&/) {
($dir, $id, $pack, $name) = split;
! if ($opt_R and ($name =~ /::(__ANON_|END)$/)) {
$name .= "($id)";
}
$cv_hash{$id} = "$pack\::$name";
--- 693,699 ----
chop;
if (/^&/) {
($dir, $id, $pack, $name) = split;
! if ($opt_R and ($name =~ /(?:::)?(__ANON__|END)$/)) {
$name .= "($id)";
}
$cv_hash{$id} = "$pack\::$name";
***************
*** 734,741 ****
if( ! defined $x ){
die "Garbled profile, missing an enter time stamp";
}
! if( $x->[0] ne $name ){
! if ($x->[0] =~ /::AUTOLOAD$/) {
if ($opt_A) {
$name = $x->[0];
}
--- 829,836 ----
if( ! defined $x ){
die "Garbled profile, missing an enter time stamp";
}
! if( $x->[0] ne $name and $opt_G and ($name =~ /$opt_G/)){
! if ($x->[0] =~ /(?:::)?AUTOLOAD$/) {
if ($opt_A) {
$name = $x->[0];
}
***************
*** 814,819 ****
--- 909,920 ----
sub by_calls { $calls->{$b} <=> $calls->{$a} }
sub by_alpha { $names->{$a} cmp $names->{$b} }
sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} }
+ # Reversed
+ sub rby_time { $times->{$a} <=> $times->{$b} }
+ sub rby_ctime { $ctimes->{$a} <=> $ctimes->{$b} }
+ sub rby_calls { $calls->{$a} <=> $calls->{$b} }
+ sub rby_alpha { $names->{$b} cmp $names->{$a} }
+ sub rby_avgcpu { $persecs->{$a} <=> $persecs->{$b} }
format CSTAT_top =
***************
*** 836,838 ****
--- 937,940 ----
close OUT or die "Can't close $file: $!";
chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+
diff -c 'perl-5.7.1/utils/h2ph.PL' 'perl-5.7.2/utils/h2ph.PL'
Index: ./utils/h2ph.PL
*** ./utils/h2ph.PL Thu Mar 15 02:58:31 2001
--- ./utils/h2ph.PL Mon Jul 9 17:11:32 2001
***************
*** 108,131 ****
}
print OUT "require '_h2ph_pre.ph';\n\n";
! while (<IN>) {
! chop;
! while (/\\$/) {
! chop;
! $_ .= <IN>;
! chop;
! }
! print OUT "# $_\n" if $opt_D;
!
! if (s:/\*:\200:g) {
! s:\*/:\201:g;
! s/\200[^\201]*\201//g; # delete single line comments
! if (s/\200.*//) { # begin multi-line comment?
! $_ .= '/*';
! $_ .= <IN>;
! redo;
! }
! }
if (s/^\s*\#\s*//) {
if (s/^define\s+(\w+)//) {
$name = $1;
--- 108,114 ----
}
print OUT "require '_h2ph_pre.ph';\n\n";
! while (defined (local $_ = next_line())) {
if (s/^\s*\#\s*//) {
if (s/^define\s+(\w+)//) {
$name = $1;
***************
*** 387,394 ****
$new .= '->' if /^[\[\{]/;
} elsif ($id eq 'defined') {
$new .= 'defined';
! } elsif (/^\(/) {
! s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
$new .= " &$id";
} elsif ($isatype{$id}) {
if ($new =~ /{\s*$/) {
--- 370,377 ----
$new .= '->' if /^[\[\{]/;
} elsif ($id eq 'defined') {
$new .= 'defined';
! } elsif (/^\s*\(/) {
! s/^\s*\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
$new .= " &$id";
} elsif ($isatype{$id}) {
if ($new =~ /{\s*$/) {
***************
*** 412,417 ****
--- 395,460 ----
};
s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
}
+ }
+
+
+ sub next_line
+ {
+ my ($in, $out);
+ my $pre_sub_tri_graphs = 1;
+
+ READ: while (not eof IN) {
+ $in .= <IN>;
+ chomp $in;
+ next unless length $in;
+
+ while (length $in) {
+ if ($pre_sub_tri_graphs) {
+ # Preprocess all tri-graphs
+ # including things stuck in quoted string constants.
+ $in =~ s/\?\?=/#/g; # | ??=| #|
+ $in =~ s/\?\?\!/|/g; # | ??!| ||
+ $in =~ s/\?\?'/^/g; # | ??'| ^|
+ $in =~ s/\?\?\(/[/g; # | ??(| [|
+ $in =~ s/\?\?\)/]/g; # | ??)| ]|
+ $in =~ s/\?\?\-/~/g; # | ??-| ~|
+ $in =~ s/\?\?\//\\/g; # | ??/| \|
+ $in =~ s/\?\?</{/g; # | ??<| {|
+ $in =~ s/\?\?>/}/g; # | ??>| }|
+ }
+ if ($in =~ s/\\$//) { # \-newline
+ $out .= ' ';
+ next READ;
+ } elsif ($in =~ s/^([^"'\\\/]+)//) { # Passthrough
+ $out .= $1;
+ } elsif ($in =~ s/^(\\.)//) { # \...
+ $out .= $1;
+ } elsif ($in =~ s/^('(\\.|[^'\\])*')//) { # '...
+ $out .= $1;
+ } elsif ($in =~ s/^("(\\.|[^"\\])*")//) { # "...
+ $out .= $1;
+ } elsif ($in =~ s/^\/\/.*//) { # //...
+ last READ;
+ } elsif ($in =~ m/^\/\*/) { # /*...
+ # C comment removal adapted from perlfaq6:
+ if ($in =~ s/^\/\*[^*]*\*+([^\/*][^*]*\*+)*\///) {
+ $out .= ' ';
+ } else { # Incomplete /* */
+ next READ;
+ }
+ } elsif ($in =~ s/^(\/)//) { # /...
+ $out .= $1;
+ } elsif ($in =~ s/^([^\'\"\\\/]+)//) {
+ $out .= $1;
+ } else {
+ die "Cannot parse:\n$in\n";
+ }
+ }
+
+ last READ;
+ }
+
+ return $out;
}
diff -c 'perl-5.7.1/utils/h2xs.PL' 'perl-5.7.2/utils/h2xs.PL'
Index: ./utils/h2xs.PL
*** ./utils/h2xs.PL Thu Mar 29 17:42:12 2001
--- ./utils/h2xs.PL Mon Jul 9 17:11:32 2001
***************
*** 59,70 ****
If the extension might need extra libraries, they should be included
here. The extension Makefile.PL will take care of checking whether
! the libraries actually exist and how they should be loaded.
! The extra libraries should be specified in the form -lm -lposix, etc,
! just as on the cc command line. By default, the Makefile.PL will
! search through the library path determined by Configure. That path
! can be augmented by including arguments of the form B<-L/another/library/path>
! in the extra-libraries argument.
=head1 OPTIONS
--- 59,70 ----
If the extension might need extra libraries, they should be included
here. The extension Makefile.PL will take care of checking whether
! the libraries actually exist and how they should be loaded. The extra
! libraries should be specified in the form -lm -lposix, etc, just as on
! the cc command line. By default, the Makefile.PL will search through
! the library path determined by Configure. That path can be augmented
! by including arguments of the form B<-L/another/library/path> in the
! extra-libraries argument.
=head1 OPTIONS
***************
*** 72,79 ****
=item B<-A>
! Omit all autoload facilities. This is the same as B<-c> but also removes the
! S<C<use AutoLoader>> statement from the .pm file.
=item B<-C>
--- 72,79 ----
=item B<-A>
! Omit all autoload facilities. This is the same as B<-c> but also
! removes the S<C<use AutoLoader>> statement from the .pm file.
=item B<-C>
***************
*** 116,121 ****
--- 116,133 ----
which returns a Ptr type pointing to the same structure, and a C<new>
method to construct and return a new structure, initialised to zeroes.
+ =item B<-b> I<version>
+
+ Generates a .pm file which is backwards compatible with the specified
+ perl version.
+
+ For versions < 5.6.0, the changes are.
+ - no use of 'our' (uses 'use vars' instead)
+ - no 'use warnings'
+
+ Specifying a compatibility version higher than the version of perl you
+ are using to run h2xs will have no effect.
+
=item B<-c>
Omit C<constant()> from the .xs file and corresponding specialised
***************
*** 157,163 ****
This may be useful since, say, types which are C<typedef>-equivalent
to integers may represent OS-related handles, and one may want to work
with these handles in OO-way, as in C<$handle-E<gt>do_something()>.
! Use C<-o .> if you want to handle all the C<typedef>ed types as opaque types.
The type-to-match is whitewashed (except for commas, which have no
whitespace before them, and multiple C<*> which have no whitespace
--- 169,176 ----
This may be useful since, say, types which are C<typedef>-equivalent
to integers may represent OS-related handles, and one may want to work
with these handles in OO-way, as in C<$handle-E<gt>do_something()>.
! Use C<-o .> if you want to handle all the C<typedef>ed types as opaque
! types.
The type-to-match is whitewashed (except for commas, which have no
whitespace before them, and multiple C<*> which have no whitespace
***************
*** 165,179 ****
=item B<-p> I<prefix>
! Specify a prefix which should be removed from the Perl function names, e.g., S<-p sec_rgy_>
! This sets up the XS B<PREFIX> keyword and removes the prefix from functions that are
! autoloaded via the C<constant()> mechanism.
=item B<-s> I<sub1,sub2>
! Create a perl subroutine for the specified macros rather than autoload with the constant() subroutine.
! These macros are assumed to have a return type of B<char *>, e.g., S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>.
=item B<-v> I<version>
Specify a version number for this extension. This version number is added
--- 178,202 ----
=item B<-p> I<prefix>
! Specify a prefix which should be removed from the Perl function names,
! e.g., S<-p sec_rgy_> This sets up the XS B<PREFIX> keyword and removes
! the prefix from functions that are autoloaded via the C<constant()>
! mechanism.
=item B<-s> I<sub1,sub2>
! Create a perl subroutine for the specified macros rather than autoload
! with the constant() subroutine. These macros are assumed to have a
! return type of B<char *>, e.g.,
! S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>.
+ =item B<-t> I<type>
+
+ Specify the internal type that the constant() mechanism uses for macros.
+ The default is IV (signed integer). Currently all macros found during the
+ header scanning process will be assumed to have this type. Future versions
+ of C<h2xs> may gain the ability to make educated guesses.
+
=item B<-v> I<version>
Specify a version number for this extension. This version number is added
***************
*** 184,191 ****
Automatically generate XSUBs basing on function declarations in the
header file. The package C<C::Scan> should be installed. If this
option is specified, the name of the header file may look like
! C<NAME1,NAME2>. In this case NAME1 is used instead of the specified string,
! but XSUBs are emitted only for the declarations included from file NAME2.
Note that some types of arguments/return-values for functions may
result in XSUB-declarations/typemap-entries which need
--- 207,215 ----
Automatically generate XSUBs basing on function declarations in the
header file. The package C<C::Scan> should be installed. If this
option is specified, the name of the header file may look like
! C<NAME1,NAME2>. In this case NAME1 is used instead of the specified
! string, but XSUBs are emitted only for the declarations included from
! file NAME2.
Note that some types of arguments/return-values for functions may
result in XSUB-declarations/typemap-entries which need
***************
*** 193,210 ****
pointer (like C<long long>), pointers to functions, or arrays. See
also the section on L<LIMITATIONS of B<-x>>.
- =item B<-b> I<version>
-
- Generates a .pm file which is backwards compatible with the specified
- perl version.
-
- For versions < 5.6.0, the changes are.
- - no use of 'our' (uses 'use vars' instead)
- - no 'use warnings'
-
- Specifying a compatibility version higher than the version of perl you
- are using to run h2xs will have no effect.
-
=back
=head1 EXAMPLES
--- 217,222 ----
***************
*** 412,417 ****
--- 424,433 ----
use Getopt::Std;
use Config;
+ use Text::Wrap;
+ $Text::Wrap::huge = 'overflow';
+ $Text::Wrap::columns = 80;
+ use ExtUtils::Constant qw (constant_types C_constant XS_constant autoload);
sub usage {
warn "@_\n" if @_;
***************
*** 426,431 ****
--- 442,448 ----
-P Omit the stub POD section.
-X Omit the XS portion (implies both -c and -f).
-a Generate get/set accessors for struct and union members (used with -x).
+ -b Specify a perl version to be backwards compatibile with
-c Omit the constant() function and specialised AUTOLOAD from the XS file.
-d Turn on debugging messages.
-f Force creation of the extension even if the C header does not exist.
***************
*** 436,444 ****
-o Regular expression for \"opaque\" types.
-p Specify a prefix which should be removed from the Perl function names.
-s Create subroutines for specified macros.
-v Specify a version number for this extension.
-x Autogenerate XSUBs using C::Scan.
- -b Specify a perl version to be backwards compatibile with
extra_libraries
are any libraries that might be needed for loading the
extension, e.g. -lm would try to link in the math library.
--- 453,461 ----
-o Regular expression for \"opaque\" types.
-p Specify a prefix which should be removed from the Perl function names.
-s Create subroutines for specified macros.
+ -t Default type for autoloaded constants
-v Specify a version number for this extension.
-x Autogenerate XSUBs using C::Scan.
extra_libraries
are any libraries that might be needed for loading the
extension, e.g. -lm would try to link in the math library.
***************
*** 446,455 ****
}
! getopts("ACF:M:OPXacdfhkmn:o:p:s:v:xb:") || usage;
! use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_a $opt_c $opt_d
! $opt_f $opt_h $opt_k $opt_m $opt_n $opt_o $opt_p $opt_s $opt_v $opt_x
! $opt_b);
usage if $opt_h;
--- 463,472 ----
}
! getopts("ACF:M:OPXacdfhkmn:o:p:s:v:xb:t:") || usage;
! use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_a $opt_c
! $opt_d $opt_f $opt_h $opt_k $opt_m $opt_n $opt_o $opt_p $opt_s
! $opt_v $opt_x $opt_b $opt_t);
usage if $opt_h;
***************
*** 536,541 ****
--- 553,559 ----
use Config;
use File::Spec;
my @paths;
+ my $pre_sub_tri_graphs = 1;
if ($^O eq 'VMS') { # Consider overrides of default location
# XXXX This is not equivalent to what the older version did:
# it was looking at $hadsys header-file per header-file...
***************
*** 599,604 ****
--- 617,635 ----
open(CH, "<$rel_path_h") || die "Can't open $rel_path_h: $!\n";
defines:
while (<CH>) {
+ if ($pre_sub_tri_graphs) {
+ # Preprocess all tri-graphs
+ # including things stuck in quoted string constants.
+ s/\?\?=/#/g; # | ??=| #|
+ s/\?\?\!/|/g; # | ??!| ||
+ s/\?\?'/^/g; # | ??'| ^|
+ s/\?\?\(/[/g; # | ??(| [|
+ s/\?\?\)/]/g; # | ??)| ]|
+ s/\?\?\-/~/g; # | ??-| ~|
+ s/\?\?\//\\/g; # | ??/| \|
+ s/\?\?</{/g; # | ??<| {|
+ s/\?\?>/}/g; # | ??>| }|
+ }
if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^" \t])(.*)/) {
my $def = $1;
my $rest = $2;
***************
*** 664,674 ****
if( $nested ){
my $modpath = "";
foreach (@modparts){
! mkdir("$modpath$_", 0777);
$modpath .= "$_/";
}
}
! mkdir($modpname, 0777);
chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
my %types_seen;
--- 695,705 ----
if( $nested ){
my $modpath = "";
foreach (@modparts){
! -d "$modpath$_" || mkdir("$modpath$_", 0777);
$modpath .= "$_/";
}
}
! -d "$modpname" || mkdir($modpname, 0777);
chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
my %types_seen;
***************
*** 891,932 ****
}
! $tmp = ( $compat_version < 5.006 ? "" : "our \$AUTOLOAD;" );
! print PM <<"END" unless $opt_c or $opt_X;
! sub AUTOLOAD {
! # This AUTOLOAD is used to 'autoload' constants from the constant()
! # XS function. If a constant is not found then control is passed
! # to the AUTOLOAD in AutoLoader.
- my \$constname;
- $tmp
- (\$constname = \$AUTOLOAD) =~ s/.*:://;
- croak "&${module}::constant not defined" if \$constname eq 'constant';
- my \$val = constant(\$constname, \@_ ? \$_[0] : 0);
- if (\$! != 0) {
- if (\$! =~ /Invalid/ || \$!{EINVAL}) {
- \$AutoLoader::AUTOLOAD = \$AUTOLOAD;
- goto &AutoLoader::AUTOLOAD;
- }
- else {
- croak "Your vendor has not defined $module macro \$constname";
- }
- }
- {
- no strict 'refs';
- # Fixed between 5.005_53 and 5.005_61
- if (\$] >= 5.00561) {
- *\$AUTOLOAD = sub () { \$val };
- }
- else {
- *\$AUTOLOAD = sub { \$val };
- }
- }
- goto &\$AUTOLOAD;
- }
-
- END
-
if( ! $opt_X ){ # print bootstrap, unless XS is disabled
print PM <<"END";
bootstrap $module \$VERSION;
--- 922,929 ----
}
! print PM autoload ($module, $compat_version) unless $opt_c or $opt_X;
if( ! $opt_X ){ # print bootstrap, unless XS is disabled
print PM <<"END";
bootstrap $module \$VERSION;
***************
*** 1059,1072 ****
#
#Blah blah blah.
$exp_doc$meth_doc$revhist
#=head1 AUTHOR
#
#$author, E<lt>${email}E<gt>
#
! #=head1 SEE ALSO
#
! #L<perl>.
#
#=cut
END
--- 1056,1084 ----
#
#Blah blah blah.
$exp_doc$meth_doc$revhist
+ #
+ #=head1 SEE ALSO
+ #
+ #Mention other useful documentation such as the documentation of
+ #related modules or operating system documentation (such as man pages
+ #in UNIX), or any relevant external documentation such as RFCs or
+ #standards.
+ #
+ #If you have a mailing list set up for your module, mention it here.
+ #
+ #If you have a web site set up for your module, mention it here.
+ #
#=head1 AUTHOR
#
#$author, E<lt>${email}E<gt>
#
! #=head1 COPYRIGHT AND LICENSE
#
! #Copyright ${\(1900 + (localtime) [5])} by $author
#
+ #This library is free software; you can redistribute it and/or modify
+ #it under the same terms as Perl itself.
+ #
#=cut
END
***************
*** 1132,1306 ****
return ($struct_typedefs{$otype} = $out);
}
! # Some macros will bomb if you try to return them from a double-returning func.
! # Say, ((char *)0), or strlen (if somebody #define STRLEN strlen).
! # Fortunately, we can detect both these cases...
! sub protect_convert_to_double {
! my $in = shift;
! my $val;
! return '' unless defined ($val = $seen_define{$in});
! return '(IV)' if $known_fnames{$val};
! # OUT_t of ((OUT_t)-1):
! return '' unless $val =~ /^\s*(\(\s*)?\(\s*([^()]*?)\s*\)/;
! td_is_pointer($2) ? '(IV)' : '';
! }
! # For each of the generated functions, length($pref) leading
! # letters are already checked. Moreover, it is recommended that
! # the generated functions uses switch on letter at offset at least
! # $off + length($pref).
! #
! # The given list has length($pref) chars removed at front, it is
! # guarantied that $off leading chars in the rest are the same for all
! # elts of the list.
! #
! # Returns: how at which offset it was decided to make a switch, or -1 if none.
!
! sub write_const;
!
! sub write_const {
! my ($fh, $pref, $off, $list) = (shift,shift,shift,shift);
! my %leading;
! my $offarg = length $pref;
!
! if (@$list == 0) { # Can happen on the initial iteration only
! print $fh <<"END";
! static double
! constant(char *name, int len, int arg)
! {
! errno = EINVAL;
! return 0;
! }
! END
! return -1;
}
-
- if (@$list == 1) { # Can happen on the initial iteration only
- my $protect = protect_convert_to_double("$pref$list->[0]");
-
- print $fh <<"END";
- static double
- constant(char *name, int len, int arg)
- {
- errno = 0;
- if (strEQ(name + $offarg, "$list->[0]")) { /* $pref removed */
- #ifdef $pref$list->[0]
- return $protect$pref$list->[0];
- #else
- errno = ENOENT;
- return 0;
- #endif
- }
- errno = EINVAL;
- return 0;
}
- END
- return -1;
- }
- for my $n (@$list) {
- my $c = substr $n, $off, 1;
- $leading{$c} = [] unless exists $leading{$c};
- push @{$leading{$c}}, $off < length $n ? substr $n, $off + 1 : $n
- }
-
- if (keys(%leading) == 1) {
- return 1 + write_const $fh, $pref, $off + 1, $list;
- }
-
- my $leader = substr $list->[0], 0, $off;
- foreach my $letter (keys %leading) {
- write_const $fh, "$pref$leader$letter", 0, $leading{$letter}
- if @{$leading{$letter}} > 1;
- }
-
- my $npref = "_$pref";
- $npref = '' if $pref eq '';
-
- print $fh <<"END";
- static double
- constant$npref(char *name, int len, int arg)
- {
- END
-
- print $fh <<"END" if $npref eq '';
- errno = 0;
- END
-
- print $fh <<"END" if $off;
- if ($offarg + $off >= len ) {
- errno = EINVAL;
- return 0;
- }
- END
-
- print $fh <<"END";
- switch (name[$offarg + $off]) {
- END
-
- foreach my $letter (sort keys %leading) {
- my $let = $letter;
- $let = '\0' if $letter eq '';
-
- print $fh <<EOP;
- case '$let':
- EOP
- if (@{$leading{$letter}} > 1) {
- # It makes sense to call a function
- if ($off) {
- print $fh <<EOP;
- if (!strnEQ(name + $offarg,"$leader", $off))
- break;
- EOP
- }
- print $fh <<EOP;
- return constant_$pref$leader$letter(name, len, arg);
- EOP
- }
- else {
- # Do it ourselves
- my $protect
- = protect_convert_to_double("$pref$leader$letter$leading{$letter}[0]");
-
- print $fh <<EOP;
- if (strEQ(name + $offarg, "$leader$letter$leading{$letter}[0]")) { /* $pref removed */
- #ifdef $pref$leader$letter$leading{$letter}[0]
- return $protect$pref$leader$letter$leading{$letter}[0];
- #else
- goto not_there;
- #endif
- }
- EOP
- }
- }
- print $fh <<"END";
- }
- errno = EINVAL;
- return 0;
-
- not_there:
- errno = ENOENT;
- return 0;
- }
-
- END
-
- }
-
- if( ! $opt_c ) {
- print XS <<"END";
- static int
- not_here(char *s)
- {
- croak("${module}::%s not implemented on this architecture", s);
- return -1;
- }
-
- END
-
- write_const(\*XS, '', 0, \@const_names);
- }
-
print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
my $prefix = defined $opt_p ? "PREFIX = $opt_p" : '';
--- 1144,1161 ----
return ($struct_typedefs{$otype} = $out);
}
! my $types = {};
! # Important. Passing an undef scalar doesn't cause the
! # autovivified hashref to appear back out in this scope.
! if( ! $opt_c ) {
! print XS constant_types(), "\n";
! foreach (C_constant ($module, undef, $opt_t, $types, undef, undef,
! @const_names)) {
! print XS $_, "\n";
}
}
print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
my $prefix = defined $opt_p ? "PREFIX = $opt_p" : '';
***************
*** 1332,1354 ****
# If a constant() function was written then output a corresponding
# XS declaration:
! print XS <<"END" unless $opt_c;
- double
- constant(sv,arg)
- PREINIT:
- STRLEN len;
- INPUT:
- SV * sv
- char * s = SvPV(sv, len);
- int arg
- CODE:
- RETVAL = constant(s,len,arg);
- OUTPUT:
- RETVAL
-
- END
-
my %seen_decl;
my %typemap;
--- 1187,1195 ----
# If a constant() function was written then output a corresponding
# XS declaration:
! # XXX IVs
! print XS XS_constant ($module, $types) unless $opt_c;
my %seen_decl;
my %typemap;
***************
*** 1591,1597 ****
my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
# Start with useful default values
! $typemap{float} = 'T_DOUBLE';
foreach my $typemap (@tm) {
next unless -e $typemap ;
--- 1432,1438 ----
my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
# Start with useful default values
! $typemap{float} = 'T_NV';
foreach my $typemap (@tm) {
next unless -e $typemap ;
***************
*** 1806,1835 ****
Put the correct copyright and licence information here.
! Copyright (C) $thisyear $author blah blah blah
_RMEND_
close(RM) || die "Can't close $ext$modpname/README: $!\n";
! warn "Writing $ext$modpname/test.pl\n";
! open(EX, ">test.pl") || die "Can't create $ext$modpname/test.pl: $!\n";
! print EX <<'_END_';
# Before `make install' is performed this script should be runnable with
! # `make test'. After `make install' it should work as `perl test.pl'
#########################
! # change 'tests => 1' to 'tests => last_test_to_print';
use Test;
! BEGIN { plan tests => 1 };
! _END_
! print EX <<_END_;
use $module;
- _END_
- print EX <<'_END_';
ok(1); # If we made it this far, we're ok.
#########################
# Insert your test code below, the Test module is use()ed here so read
--- 1647,1710 ----
Put the correct copyright and licence information here.
! Copyright (C) $thisyear $author
+ This library is free software; you can redistribute it and/or modify
+ it under the same terms as Perl itself.
+
_RMEND_
close(RM) || die "Can't close $ext$modpname/README: $!\n";
! my $testdir = "t";
! my $testfile = "$testdir/1.t";
! unless (-d "$testdir") {
! mkdir "$testdir" or die "Cannot mkdir $testdir: $!\n";
! }
! warn "Writing $ext$modpname/$testfile\n";
! my $tests = @const_names ? 2 : 1;
!
! open EX, ">$testfile" or die "Can't create $ext$modpname/$testfile: $!\n";
! print EX <<_END_;
# Before `make install' is performed this script should be runnable with
! # `make test'. After `make install' it should work as `perl 1.t'
#########################
! # change 'tests => $tests' to 'tests => last_test_to_print';
use Test;
! BEGIN { plan tests => $tests };
use $module;
ok(1); # If we made it this far, we're ok.
+ _END_
+ if (@const_names) {
+ my $const_names = join " ", @const_names;
+ print EX <<'_END_';
+
+ my $fail;
+ foreach my $constname (qw(
+ _END_
+ print EX wrap ("\t", "\t", $const_names);
+ print EX (")) {\n");
+ print EX <<_END_;
+ next if (eval "my \\\$a = \$constname; 1");
+ if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
+ print "# pass: \$\@";
+ } else {
+ print "# fail: \$\@";
+ \$fail = 1;
+ }
+ }
+ if (\$fail) {
+ print "not ok 2\\n";
+ } else {
+ print "ok 2\\n";
+ }
+
+ _END_
+ }
+ print EX <<'_END_';
#########################
# Insert your test code below, the Test module is use()ed here so read
***************
*** 1836,1842 ****
# its man page ( perldoc Test ) for help writing this test script.
_END_
! close(EX) || die "Can't close $ext$modpname/test.pl: $!\n";
unless ($opt_C) {
warn "Writing $ext$modpname/Changes\n";
--- 1711,1717 ----
# its man page ( perldoc Test ) for help writing this test script.
_END_
! close(EX) || die "Can't close $ext$modpname/$testfile: $!\n";
unless ($opt_C) {
warn "Writing $ext$modpname/Changes\n";
***************
*** 1856,1862 ****
warn "Writing $ext$modpname/MANIFEST\n";
open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
! my @files = <*>;
if (!@files) {
eval {opendir(D,'.');};
unless ($@) { @files = readdir(D); closedir(D); }
--- 1731,1737 ----
warn "Writing $ext$modpname/MANIFEST\n";
open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
! my @files = grep { -f } (<*>, <t/*>);
if (!@files) {
eval {opendir(D,'.');};
unless ($@) { @files = readdir(D); closedir(D); }
diff -c /dev/null 'perl-5.7.2/utils/libnetcfg.PL'
Index: ./utils/libnetcfg.PL
*** ./utils/libnetcfg.PL Thu Jan 1 02:00:00 1970
--- ./utils/libnetcfg.PL Fri Jul 13 17:09:58 2001
***************
*** 0 ****
--- 1,760 ----
+ #!/usr/local/bin/perl
+
+ use Config;
+ use File::Basename qw(&basename &dirname);
+ use Cwd;
+
+ # List explicitly here the variables you want Configure to
+ # generate. Metaconfig only looks for shell variables, so you
+ # have to mention them as if they were shell variables, not
+ # %Config entries. Thus you write
+ # $startperl
+ # to ensure Configure will look for $Config{startperl}.
+
+ # This forces PL files to create target in same directory as PL file.
+ # This is so that make depend always knows where to find PL derivatives.
+ my $origdir = cwd;
+ chdir dirname($0);
+ my $file = basename($0, '.PL');
+ $file .= '.com' if $^O eq 'VMS';
+
+ open OUT,">$file" or die "Can't create $file: $!";
+
+ print "Extracting $file (with variable substitutions)\n";
+
+ # In this section, perl variables will be expanded during extraction.
+ # You can use $Config{...} to use Configure variables.
+
+ print OUT <<"!GROK!THIS!";
+ $Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+ !GROK!THIS!
+
+ # In the following, perl variables are not expanded during extraction.
+
+ print OUT <<'!NO!SUBS!';
+
+ =head1 NAME
+
+ libnetcfg - configure libnet
+
+ =head1 DESCRIPTION
+
+ The libnetcfg utility can be be used to configure the libnet.
+ Starting from perl 5.8 libnet is part of the standard Perl
+ distribution, but the libnetcfg can be be used for any libnet
+ installation.
+
+ =head1 USAGE
+
+ Without arguments libnetcfg displays the current configuration.
+
+ $ libnetcfg
+ # old config ./libnet.cfg
+ daytime_hosts ntp1.none.such
+ ftp_int_passive 0
+ ftp_testhost ftp.funet.fi
+ inet_domain none.such
+ nntp_hosts nntp.none.such
+ ph_hosts
+ pop3_hosts pop.none.such
+ smtp_hosts smtp.none.such
+ snpp_hosts
+ test_exist 1
+ test_hosts 1
+ time_hosts ntp.none.such
+ # libnetcfg -h for help
+ $
+
+ It tells where the old configuration file was found (if found).
+
+ The C<-h> option will show a usage message.
+
+ To change the configuration you will need to use either the C<-c> or
+ the C<-d> options.
+
+ The default name of the old configuration file is by default
+ "libnet.cfg", unless otherwise specified using the -i option,
+ C<-i oldfile>, and it is searched first from the current directory,
+ and the from your module path.
+
+ The default name of new configuration file is "libnet.cfg", and by
+ default it is written to the current directory, unless otherwise
+ specified using the -o option, C<-o newfile>.
+
+ =head1 SEE ALSO
+
+ L<Net::Config>, L<Net::libnetFAQ>
+
+ =head1 AUTHORS
+
+ Graham Barr, the original Configure script of libnet.
+
+ Jarkko Hietaniemi, conversion into libnet cfg for inclusion into Perl 5.8.
+
+ =cut
+
+ # $Id: Configure,v 1.8 1997/03/04 09:22:32 gbarr Exp $
+
+ use strict;
+ use IO::File;
+ use Getopt::Std;
+ use ExtUtils::MakeMaker qw(prompt);
+ use File::Spec;
+
+ use vars qw($opt_d $opt_c $opt_h $opt_o $opt_i);
+
+ ##
+ ##
+ ##
+
+ my %cfg = ();
+ my @cfg = ();
+
+ my($libnet_cfg_in,$libnet_cfg_out,$msg,$ans,$def,$have_old);
+
+ ##
+ ##
+ ##
+
+ sub valid_host
+ {
+ my $h = shift;
+
+ defined($h) && (($cfg{'test_exist'} == 0) || gethostbyname($h));
+ }
+
+ ##
+ ##
+ ##
+
+ sub test_hostnames (\@)
+ {
+ my $hlist = shift;
+ my @h = ();
+ my $host;
+ my $err = 0;
+
+ foreach $host (@$hlist)
+ {
+ if(valid_host($host))
+ {
+ push(@h, $host);
+ next;
+ }
+ warn "Bad hostname: '$host'\n";
+ $err++;
+ }
+ @$hlist = @h;
+ $err ? join(" ",@h) : undef;
+ }
+
+ ##
+ ##
+ ##
+
+ sub Prompt
+ {
+ my($prompt,$def) = @_;
+
+ $def = "" unless defined $def;
+
+ chomp($prompt);
+
+ if($opt_d)
+ {
+ print $prompt,," [",$def,"]\n";
+ return $def;
+ }
+ prompt($prompt,$def);
+ }
+
+ ##
+ ##
+ ##
+
+ sub get_host_list
+ {
+ my($prompt,$def) = @_;
+
+ $def = join(" ",@$def) if ref($def);
+
+ my @hosts;
+
+ do
+ {
+ my $ans = Prompt($prompt,$def);
+
+ $ans =~ s/(\A\s+|\s+\Z)//g;
+
+ @hosts = split(/\s+/, $ans);
+ }
+ while(@hosts && defined($def = test_hostnames(@hosts)));
+
+ \@hosts;
+ }
+
+ ##
+ ##
+ ##
+
+ sub get_hostname
+ {
+ my($prompt,$def) = @_;
+
+ my $host;
+
+ while(1)
+ {
+ my $ans = Prompt($prompt,$def);
+ $host = ($ans =~ /(\S*)/)[0];
+ last
+ if(!length($host) || valid_host($host));
+
+ $def =""
+ if $def eq $host;
+
+ print <<"EDQ";
+
+ *** ERROR:
+ Hostname `$host' does not seem to exist, please enter again
+ or a single space to clear any default
+
+ EDQ
+ }
+
+ length $host
+ ? $host
+ : undef;
+ }
+
+ ##
+ ##
+ ##
+
+ sub get_bool ($$)
+ {
+ my($prompt,$def) = @_;
+
+ chomp($prompt);
+
+ my $val = Prompt($prompt,$def ? "yes" : "no");
+
+ $val =~ /^y/i ? 1 : 0;
+ }
+
+ ##
+ ##
+ ##
+
+ sub get_netmask ($$)
+ {
+ my($prompt,$def) = @_;
+
+ chomp($prompt);
+
+ my %list;
+ @list{@$def} = ();
+
+ MASK:
+ while(1) {
+ my $bad = 0;
+ my $ans = Prompt($prompt) or last;
+
+ if($ans eq '*') {
+ %list = ();
+ next;
+ }
+
+ if($ans eq '=') {
+ print "\n",( %list ? join("\n", sort keys %list) : 'none'),"\n\n";
+ next;
+ }
+
+ unless ($ans =~ m{^\s*(?:(-?\s*)(\d+(?:\.\d+){0,3})/(\d+))}) {
+ warn "Bad netmask '$ans'\n";
+ next;
+ }
+
+ my($remove,$bits,@ip) = ($1,$3,split(/\./, $2),0,0,0);
+ if ( $ip[0] < 1 || $bits < 1 || $bits > 32) {
+ warn "Bad netmask '$ans'\n";
+ next MASK;
+ }
+ foreach my $byte (@ip) {
+ if ( $byte > 255 ) {
+ warn "Bad netmask '$ans'\n";
+ next MASK;
+ }
+ }
+
+ my $mask = sprintf("%d.%d.%d.%d/%d",@ip[0..3],$bits);
+
+ if ($remove) {
+ delete $list{$mask};
+ }
+ else {
+ $list{$mask} = 1;
+ }
+
+ }
+
+ [ keys %list ];
+ }
+
+ ##
+ ##
+ ##
+
+ sub default_hostname
+ {
+ my $host;
+ my @host;
+
+ foreach $host (@_)
+ {
+ if(defined($host) && valid_host($host))
+ {
+ return $host
+ unless wantarray;
+ push(@host,$host);
+ }
+ }
+
+ return wantarray ? @host : undef;
+ }
+
+ ##
+ ##
+ ##
+
+ getopts('dcho:i:');
+
+ $libnet_cfg_in = "libnet.cfg"
+ unless(defined($libnet_cfg_in = $opt_i));
+
+ $libnet_cfg_out = "libnet.cfg"
+ unless(defined($libnet_cfg_out = $opt_o));
+
+ my %oldcfg = ();
+
+ $Net::Config::CONFIGURE = 1; # Suppress load of user overrides
+ if( -f $libnet_cfg_in )
+ {
+ %oldcfg = ( %{ do $libnet_cfg_in } );
+ }
+ elsif (eval { require Net::Config })
+ {
+ $have_old = 1;
+ %oldcfg = %Net::Config::NetConfig;
+ }
+
+ map { $cfg{lc $_} = $cfg{$_}; delete $cfg{$_} if /[A-Z]/ } keys %cfg;
+
+ #---------------------------------------------------------------------------
+
+ if ($opt_h) {
+ print <<EOU;
+ $0: Usage: $0 [-c] [-d] [-i oldconfigile] [-o newconfigfile] [-h]
+ Without options, the old configuration is shown.
+
+ -c change the configuration
+ -d use defaults from the old config (implies -c, non-interactive)
+ -i use a specific file as the old config file
+ -o use a specific file as the new config file
+ -h show this help
+
+ The default name of the old configuration file is by default
+ "libnet.cfg", unless otherwise specified using the -i option,
+ C<-i oldfile>, and it is searched first from the current directory,
+ and the from your module path.
+
+ The default name of new configuration file is "libnet.cfg", and by
+ default it is written to the current directory, unless otherwise
+ specified using the -o option.
+
+ EOU
+ exit(0);
+ }
+
+ #---------------------------------------------------------------------------
+
+ {
+ my $oldcfgfile;
+ my @inc;
+ push @inc, $ENV{PERL5LIB} if exists $ENV{PERL5LIB};
+ push @inc, $ENV{PERLLIB} if exists $ENV{PERLLIB};
+ push @inc, @INC;
+ for (@inc) {
+ my $trycfgfile = File::Spec->catfile($_, $libnet_cfg_in);
+ if (-f $trycfgfile && -r $trycfgfile) {
+ $oldcfgfile = $trycfgfile;
+ last;
+ }
+ }
+ print "# old config $oldcfgfile\n" if defined $oldcfgfile;
+ for (sort keys %oldcfg) {
+ printf "%-20s %s\n", $_,
+ ref $oldcfg{$_} ? @{$oldcfg{$_}} : $oldcfg{$_};
+ }
+ unless ($opt_c || $opt_d) {
+ print "# $0 -h for help\n";
+ exit(0);
+ }
+ }
+
+ #---------------------------------------------------------------------------
+
+ $oldcfg{'test_exist'} = 1 unless exists $oldcfg{'test_exist'};
+ $oldcfg{'test_hosts'} = 1 unless exists $oldcfg{'test_hosts'};
+
+ #---------------------------------------------------------------------------
+
+ if($have_old && !$opt_d)
+ {
+ $msg = <<EDQ;
+
+ Ah, I see you already have installed libnet before.
+
+ Do you want to modify/update your configuration (y|n) ?
+ EDQ
+
+ $opt_d = 1
+ unless get_bool($msg,0);
+ }
+
+ #---------------------------------------------------------------------------
+
+ $msg = <<EDQ;
+
+ This script will prompt you to enter hostnames that can be used as
+ defaults for some of the modules in the libnet distribution.
+
+ To ensure that you do not enter an invalid hostname, I can perform a
+ lookup on each hostname you enter. If your internet connection is via
+ a dialup line then you may not want me to perform these lookups, as
+ it will require you to be on-line.
+
+ Do you want me to perform hostname lookups (y|n) ?
+ EDQ
+
+ $cfg{'test_exist'} = get_bool($msg, $oldcfg{'test_exist'});
+
+ print <<EDQ unless $cfg{'test_exist'};
+
+ *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
+
+ OK I will not check if the hostnames you give are valid
+ so be very cafeful
+
+ *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
+ EDQ
+
+
+ #---------------------------------------------------------------------------
+
+ print <<EDQ;
+
+ The following questions all require a list of host names, separated
+ with spaces. If you do not have a host available for any of the
+ services, then enter a single space, followed by <CR>. To accept the
+ default, hit <CR>
+
+ EDQ
+
+ $msg = 'Enter a list of available NNTP hosts :';
+
+ $def = $oldcfg{'nntp_hosts'} ||
+ [ default_hostname($ENV{NNTPSERVER},$ENV{NEWSHOST},'news') ];
+
+ $cfg{'nntp_hosts'} = get_host_list($msg,$def);
+
+ #---------------------------------------------------------------------------
+
+ $msg = 'Enter a list of available SMTP hosts :';
+
+ $def = $oldcfg{'smtp_hosts'} ||
+ [ default_hostname(split(/:/,$ENV{SMTPHOSTS} || ""), 'mailhost') ];
+
+ $cfg{'smtp_hosts'} = get_host_list($msg,$def);
+
+ #---------------------------------------------------------------------------
+
+ $msg = 'Enter a list of available POP3 hosts :';
+
+ $def = $oldcfg{'pop3_hosts'} || [];
+
+ $cfg{'pop3_hosts'} = get_host_list($msg,$def);
+
+ #---------------------------------------------------------------------------
+
+ $msg = 'Enter a list of available SNPP hosts :';
+
+ $def = $oldcfg{'snpp_hosts'} || [];
+
+ $cfg{'snpp_hosts'} = get_host_list($msg,$def);
+
+ #---------------------------------------------------------------------------
+
+ $msg = 'Enter a list of available PH Hosts :' ;
+
+ $def = $oldcfg{'ph_hosts'} ||
+ [ default_hostname('dirserv') ];
+
+ $cfg{'ph_hosts'} = get_host_list($msg,$def);
+
+ #---------------------------------------------------------------------------
+
+ $msg = 'Enter a list of available TIME Hosts :' ;
+
+ $def = $oldcfg{'time_hosts'} || [];
+
+ $cfg{'time_hosts'} = get_host_list($msg,$def);
+
+ #---------------------------------------------------------------------------
+
+ $msg = 'Enter a list of available DAYTIME Hosts :' ;
+
+ $def = $oldcfg{'daytime_hosts'} || $oldcfg{'time_hosts'};
+
+ $cfg{'daytime_hosts'} = get_host_list($msg,$def);
+
+ #---------------------------------------------------------------------------
+
+ $msg = <<EDQ;
+
+ Do you have a firewall/ftp proxy between your machine and the internet
+
+ If you use a SOCKS firewall answer no
+
+ (y|n) ?
+ EDQ
+
+ if(get_bool($msg,0)) {
+
+ $msg = <<'EDQ';
+ What series of FTP commands do you need to send to your
+ firewall to connect to an external host.
+
+ user/pass => external user & password
+ fwuser/fwpass => firewall user & password
+
+ 0) None
+ 1) -----------------------
+ USER user@remote.host
+ PASS pass
+ 2) -----------------------
+ USER fwuser
+ PASS fwpass
+ USER user@remote.host
+ PASS pass
+ 3) -----------------------
+ USER fwuser
+ PASS fwpass
+ SITE remote.site
+ USER user
+ PASS pass
+ 4) -----------------------
+ USER fwuser
+ PASS fwpass
+ OPEN remote.site
+ USER user
+ PASS pass
+ 5) -----------------------
+ USER user@fwuser@remote.site
+ PASS pass@fwpass
+ 6) -----------------------
+ USER fwuser@remote.site
+ PASS fwpass
+ USER user
+ PASS pass
+ 7) -----------------------
+ USER user@remote.host
+ PASS pass
+ AUTH fwuser
+ RESP fwpass
+
+ Choice:
+ EDQ
+ $def = exists $oldcfg{'ftp_firewall_type'} ? $oldcfg{'ftp_firewall_type'} : 1;
+ $ans = Prompt($msg,$def);
+ $cfg{'ftp_firewall_type'} = 0+$ans;
+ $def = $oldcfg{'ftp_firewall'} || $ENV{FTP_FIREWALL};
+
+ $cfg{'ftp_firewall'} = get_hostname("FTP proxy hostname :", $def);
+ }
+ else {
+ delete $cfg{'ftp_firewall'};
+ }
+
+
+ #---------------------------------------------------------------------------
+
+ if (defined $cfg{'ftp_firewall'})
+ {
+ print <<EDQ;
+
+ By default Net::FTP assumes that it only needs to use a firewall if it
+ cannot resolve the name of the host given. This only works if your DNS
+ system is setup to only resolve internal hostnames. If this is not the
+ case and your DNS will resolve external hostnames, then another method
+ is needed. Net::Config can do this if you provide the netmasks that
+ describe your internal network. Each netmask should be entered in the
+ form x.x.x.x/y, for example 127.0.0.0/8 or 214.8.16.32/24
+
+ EDQ
+ $def = [];
+ if(ref($oldcfg{'local_netmask'}))
+ {
+ $def = $oldcfg{'local_netmask'};
+ print "Your current netmasks are :\n\n\t",
+ join("\n\t",@{$def}),"\n\n";
+ }
+
+ print "
+ Enter one netmask at each prompt, prefix with a - to remove a netmask
+ from the list, enter a '*' to clear the whole list, an '=' to show the
+ current list and an empty line to continue with Configure.
+
+ ";
+
+ my $mask = get_netmask("netmask :",$def);
+ $cfg{'local_netmask'} = $mask if ref($mask) && @$mask;
+ }
+
+ #---------------------------------------------------------------------------
+
+ ###$msg =<<EDQ;
+ ###
+ ###SOCKS is a commonly used firewall protocol. If you use SOCKS firewalls
+ ###then enter a list of hostames
+ ###
+ ###Enter a list of available SOCKS hosts :
+ ###EDQ
+ ###
+ ###$def = $cfg{'socks_hosts'} ||
+ ### [ default_hostname($ENV{SOCKS5_SERVER},
+ ### $ENV{SOCKS_SERVER},
+ ### $ENV{SOCKS4_SERVER}) ];
+ ###
+ ###$cfg{'socks_hosts'} = get_host_list($msg,$def);
+
+ #---------------------------------------------------------------------------
+
+ print <<EDQ;
+
+ Normally when FTP needs a data connection the client tells the server
+ a port to connect to, and the server initiates a connection to the client.
+
+ Some setups, in particular firewall setups, can/do not work using this
+ protocol. In these situations the client must make the connection to the
+ server, this is called a passive transfer.
+ EDQ
+
+ if (defined $cfg{'ftp_firewall'}) {
+ $msg = "\nShould all FTP connections via a firewall/proxy be passive (y|n) ?";
+
+ $def = $oldcfg{'ftp_ext_passive'} || 0;
+
+ $cfg{'ftp_ext_passive'} = get_bool($msg,$def);
+
+ $msg = "\nShould all other FTP connections be passive (y|n) ?";
+
+ }
+ else {
+ $msg = "\nShould all FTP connections be passive (y|n) ?";
+ }
+
+ $def = $oldcfg{'ftp_int_passive'} || 0;
+
+ $cfg{'ftp_int_passive'} = get_bool($msg,$def);
+
+
+ #---------------------------------------------------------------------------
+
+ $def = $oldcfg{'inet_domain'} || $ENV{LOCALDOMAIN};
+
+ $ans = Prompt("\nWhat is your local internet domain name :",$def);
+
+ $cfg{'inet_domain'} = ($ans =~ /(\S+)/)[0];
+
+ #---------------------------------------------------------------------------
+
+ $msg = <<EDQ;
+
+ If you specified some default hosts above, it is possible for me to
+ do some basic tests when you run `make test'
+
+ This will cause `make test' to be quite a bit slower and, if your
+ internet connection is via dialup, will require you to be on-line
+ unless the hosts are local.
+
+ Do you want me to run these tests (y|n) ?
+ EDQ
+
+ $cfg{'test_hosts'} = get_bool($msg,$oldcfg{'test_hosts'});
+
+ #---------------------------------------------------------------------------
+
+ $msg = <<EDQ;
+
+ To allow Net::FTP to be tested I will need a hostname. This host
+ should allow anonymous access and have a /pub directory
+
+ What host can I use :
+ EDQ
+
+ $cfg{'ftp_testhost'} = get_hostname($msg,$oldcfg{'ftp_testhost'})
+ if $cfg{'test_hosts'};
+
+
+ print "\n";
+
+ #---------------------------------------------------------------------------
+
+ my $fh = IO::File->new($libnet_cfg_out, "w") or
+ die "Cannot create `$libnet_cfg_out': $!";
+
+ print "Writing $libnet_cfg_out\n";
+
+ print $fh "{\n";
+
+ my $key;
+ foreach $key (keys %cfg) {
+ my $val = $cfg{$key};
+ if(!defined($val)) {
+ $val = "undef";
+ }
+ elsif(ref($val)) {
+ $val = '[' . join(",",
+ map {
+ my $v = "undef";
+ if(defined $_) {
+ ($v = $_) =~ s/'/\'/sog;
+ $v = "'" . $v . "'";
+ }
+ $v;
+ } @$val ) . ']';
+ }
+ else {
+ $val =~ s/'/\'/sog;
+ $val = "'" . $val . "'" if $val =~ /\D/;
+ }
+ print $fh "\t'",$key,"' => ",$val,",\n";
+ }
+
+ print $fh "}\n";
+
+ $fh->close;
+
+ ############################################################################
+ ############################################################################
+
+ exit 0;
+ !NO!SUBS!
+
+ close OUT or die "Can't close $file: $!";
+ chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+ exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+ chdir $origdir;
diff -c 'perl-5.7.1/utils/perlbug.PL' 'perl-5.7.2/utils/perlbug.PL'
Index: ./utils/perlbug.PL
*** ./utils/perlbug.PL Tue Mar 6 04:07:25 2001
--- ./utils/perlbug.PL Mon Jul 9 17:11:32 2001
***************
*** 342,347 ****
--- 342,352 ----
}
# Prompt for subject of message, if needed
+
+ if (TrivialSubject($subject)) {
+ $subject = '';
+ }
+
unless ($subject) {
paraprint <<EOF;
First of all, please provide a subject for the
***************
*** 349,366 ****
the bug or problem. "perl bug" or "perl problem"
is not a concise description.
EOF
- print "Subject: ";
- $subject = <>;
my $err = 0;
! while ($subject !~ /\S/) {
! print "\nPlease enter a subject: ";
$subject = <>;
! if ($err++ > 5) {
die "Aborting.\n";
}
! }
! chop $subject;
}
# Prompt for return address, if needed
--- 354,369 ----
the bug or problem. "perl bug" or "perl problem"
is not a concise description.
EOF
my $err = 0;
! do {
! print "Subject: ";
$subject = <>;
! chomp $subject;
! if ($err++ == 5) {
die "Aborting.\n";
}
! } while (TrivialSubject($subject));
}
# Prompt for return address, if needed
***************
*** 416,422 ****
# verify it
print "Your address [$guess]: ";
$from = <>;
! chop $from;
$from = $guess if $from eq '';
}
}
--- 419,425 ----
# verify it
print "Your address [$guess]: ";
$from = <>;
! chomp $from;
$from = $guess if $from eq '';
}
}
***************
*** 436,442 ****
EOF
print "Local perl administrator [$cc]: ";
my $entry = scalar <>;
! chop $entry;
if ($entry ne "") {
$cc = $entry;
--- 439,445 ----
EOF
print "Local perl administrator [$cc]: ";
my $entry = scalar <>;
! chomp $entry;
if ($entry ne "") {
$cc = $entry;
***************
*** 474,480 ****
EOF
print "Editor [$ed]: ";
my $entry =scalar <>;
! chop $entry;
$usefile = 0;
if ($entry eq "file") {
--- 477,483 ----
EOF
print "Editor [$ed]: ";
my $entry =scalar <>;
! chomp $entry;
$usefile = 0;
if ($entry eq "file") {
***************
*** 501,507 ****
EOF
print "Filename: ";
my $entry = scalar <>;
! chop $entry;
if ($entry eq "") {
paraprint <<EOF;
--- 504,510 ----
EOF
print "Filename: ";
my $entry = scalar <>;
! chomp $entry;
if ($entry eq "") {
paraprint <<EOF;
***************
*** 618,624 ****
my @env =
qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR LANGUAGE);
push @env, $Config{ldlibpthname} if $Config{ldlibpthname} ne '';
! push @env, grep /^(?:PERL|LC_|LANG)/, keys %ENV;
my %env;
@env{@env} = @env;
for my $env (sort keys %env) {
--- 621,627 ----
my @env =
qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR LANGUAGE);
push @env, $Config{ldlibpthname} if $Config{ldlibpthname} ne '';
! push @env, grep /^(?:PERL|LC_|LANG|CYGWIN)/, keys %ENV;
my %env;
@env{@env} = @env;
for my $env (sort keys %env) {
***************
*** 645,651 ****
EOF
print "Editor [$ed]: ";
my $entry =scalar <>;
! chop $entry;
$ed = $entry unless $entry eq '';
}
--- 648,654 ----
EOF
print "Editor [$ed]: ";
my $entry =scalar <>;
! chomp $entry;
$ed = $entry unless $entry eq '';
}
***************
*** 668,674 ****
EOF
print "Editor [$ed]: ";
my $entry =scalar <>;
! chop $entry;
if ($entry ne "") {
$ed = $entry;
--- 671,677 ----
EOF
print "Editor [$ed]: ";
my $entry =scalar <>;
! chomp $entry;
if ($entry ne "") {
$ed = $entry;
***************
*** 722,740 ****
paraprint <<EOF;
Now that you have completed your report, would you like to send
the message to $address$andcc, display the message on
! the screen, re-edit it, or cancel without sending anything?
You may also save the message as a file to mail at another time.
EOF
retry:
! print "Action (Send/Display/Edit/Cancel/Save to File): ";
my $action = scalar <>;
! chop $action;
if ($action =~ /^(f|sa)/i) { # <F>ile/<Sa>ve
my $file_save = $outfile || "perlbug.rep";
print "\n\nName of file to save message in [$file_save]: ";
my $file = scalar <>;
! chop $file;
$file = $file_save if $file eq "";
unless (open(FILE, ">$file")) {
--- 725,744 ----
paraprint <<EOF;
Now that you have completed your report, would you like to send
the message to $address$andcc, display the message on
! the screen, re-edit it, display/change the subject,
! or cancel without sending anything?
You may also save the message as a file to mail at another time.
EOF
retry:
! print "Action (Send/Display/Edit/Subject/Save to File): ";
my $action = scalar <>;
! chomp $action;
if ($action =~ /^(f|sa)/i) { # <F>ile/<Sa>ve
my $file_save = $outfile || "perlbug.rep";
print "\n\nName of file to save message in [$file_save]: ";
my $file = scalar <>;
! chomp $file;
$file = $file_save if $file eq "";
unless (open(FILE, ">$file")) {
***************
*** 757,768 ****
open(REP, "<$filename") or die "Couldn't open file `$filename': $!\n";
while (<REP>) { print $_ }
close(REP) or die "Error closing report file `$filename': $!";
} elsif ($action =~ /^se/i) { # <S>end
# Send the message
print "Are you certain you want to send this message?\n"
. 'Please type "yes" if you are: ';
my $reply = scalar <STDIN>;
! chop $reply;
if ($reply eq "yes") {
last;
} else {
--- 761,785 ----
open(REP, "<$filename") or die "Couldn't open file `$filename': $!\n";
while (<REP>) { print $_ }
close(REP) or die "Error closing report file `$filename': $!";
+ } elsif ($action =~ /^su/i) { # <Su>bject
+ print "Subject: $subject\n";
+ print "If the above subject is fine, just press Enter.\n";
+ print "If not, type in the new subject.\n";
+ print "Subject: ";
+ my $reply = scalar <STDIN>;
+ chomp $reply;
+ if ($reply ne '') {
+ unless (TrivialSubject($reply)) {
+ $subject = $reply;
+ print "Subject: $subject\n";
+ }
+ }
} elsif ($action =~ /^se/i) { # <S>end
# Send the message
print "Are you certain you want to send this message?\n"
. 'Please type "yes" if you are: ';
my $reply = scalar <STDIN>;
! chomp $reply;
if ($reply eq "yes") {
last;
} else {
***************
*** 785,790 ****
--- 802,820 ----
}
}
} # sub NowWhat
+
+ sub TrivialSubject {
+ my $subject = shift;
+ if ($subject =~
+ /^(y(es)?|no?|help|perl( (bug|problem))?|bug|problem)$/i ||
+ length($subject) < 4 ||
+ $subject !~ /\s/) {
+ print "\nThat doesn't look like a good subject. Please be more verbose.\n\n";
+ return 1;
+ } else {
+ return 0;
+ }
+ }
sub Send {
# Message has been accepted for transmission -- Send the message
diff -c 'perl-5.7.1/utils/perlcc.PL' 'perl-5.7.2/utils/perlcc.PL'
Index: ./utils/perlcc.PL
*** ./utils/perlcc.PL Tue Mar 6 04:07:25 2001
--- ./utils/perlcc.PL Mon Jul 9 17:11:32 2001
***************
*** 146,153 ****
sub parse_argv {
use Getopt::Long;
! # Getopt::Long::Configure("bundling"); turned off. this is silly because
! # it doesn't allow for long switches.
Getopt::Long::Configure("no_ignore_case");
# no difference in exists and defined for %ENV; also, a "0"
--- 146,155 ----
sub parse_argv {
use Getopt::Long;
!
! # disallows using long arguments
! # Getopt::Long::Configure("bundling");
!
Getopt::Long::Configure("no_ignore_case");
# no difference in exists and defined for %ENV; also, a "0"
***************
*** 173,189 ****
'log:s' # where to log compilation process information
);
- # This is an attempt to make perlcc's arg. handling look like cc.
- # if ( opt('s') ) { # must quote: looks like s)foo)bar)!
- # if (opt('s') eq 'hared') {
- # $Options->{shared}++;
- # } elsif (opt('s') eq 'tatic') {
- # $Options->{static}++;
- # } else {
- # warn "$0: Unknown option -s", opt('s');
- # }
- # }
-
$Options->{v} += 0;
helpme() if opt(h); # And exit
--- 175,180 ----
***************
*** 334,339 ****
--- 325,331 ----
$command .= " -L".$_ for split /\s+/, opt(L);
my @mods = split /-?u /, $stash;
$command .= " ".ExtUtils::Embed::ldopts("-std", \@mods);
+ $command .= " -lperl";
vprint 3, "running $Config{cc} $command";
system("$Config{cc} $command");
}
***************
*** 582,589 ****
$ perlcc -e 'print q//' # Compiles a one-liner into 'a.out'
$ perlcc -c -e 'print q//' # Creates a C file 'a.out.c'
! $ perlcc -r hello # compiles 'hello' into 'a.out', runs 'a.out'.
$ perlcc -r hello a b c # compiles 'hello' into 'a.out', runs 'a.out'.
# with arguments 'a b c'
--- 574,583 ----
$ perlcc -e 'print q//' # Compiles a one-liner into 'a.out'
$ perlcc -c -e 'print q//' # Creates a C file 'a.out.c'
! $ perlcc -I /foo hello # extra headers (notice the space after -I)
! $ perlcc -L /foo hello # extra libraries (notice the space after -L)
+ $ perlcc -r hello # compiles 'hello' into 'a.out', runs 'a.out'.
$ perlcc -r hello a b c # compiles 'hello' into 'a.out', runs 'a.out'.
# with arguments 'a b c'
diff -c 'perl-5.7.1/utils/pl2pm.PL' 'perl-5.7.2/utils/pl2pm.PL'
Index: ./utils/pl2pm.PL
*** ./utils/pl2pm.PL Tue Mar 6 04:07:25 2001
--- ./utils/pl2pm.PL Mon Jul 9 17:11:32 2001
***************
*** 61,75 ****
=cut
while (<DATA>) {
! chop;
$keyword{$_} = 1;
}
! undef $/;
! $* = 1;
while (<>) {
! $newname = $ARGV;
$newname =~ s/\.pl$/.pm/ || next;
$newname =~ s#(.*/)?(\w+)#$1\u$2#;
if (-f $newname) {
--- 61,80 ----
=cut
+ use strict;
+ use warnings;
+
+ my %keyword = ();
+
while (<DATA>) {
! chomp;
$keyword{$_} = 1;
}
! local $/;
!
while (<>) {
! my $newname = $ARGV;
$newname =~ s/\.pl$/.pm/ || next;
$newname =~ s#(.*/)?(\w+)#$1\u$2#;
if (-f $newname) {
***************
*** 76,103 ****
warn "Won't overwrite existing $newname\n";
next;
}
! $oldpack = $2;
! $newpack = "\u$2";
! @export = ();
! print "$oldpack => $newpack\n" if $verbose;
s/\bstd(in|out|err)\b/\U$&/g;
s/(sub\s+)(\w+)(\s*\{[ \t]*\n)\s*package\s+$oldpack\s*;[ \t]*\n+/${1}main'$2$3/ig;
! if (/sub\s+main'/) {
! @export = m/sub\s+main'(\w+)/g;
s/(sub\s+)main'(\w+)/$1$2/g;
}
else {
@export = m/sub\s+([A-Za-z]\w*)/g;
}
! @export_ok = grep($keyword{$_}, @export);
@export = grep(!$keyword{$_}, @export);
@export{@export} = (1) x @export;
s/(^\s*);#/$1#/g;
s/(#.*)require ['"]$oldpack\.pl['"]/$1use $newpack/;
s/(package\s*)($oldpack)\s*;[ \t]*\n+//ig;
! s/([\$\@%&*])'(\w+)/&xlate($1,"",$2)/eg;
! s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3)/eg;
if (!/\$\[\s*\)?\s*=\s*[^0\s]/) {
s/^\s*(local\s*\()?\s*\$\[\s*\)?\s*=\s*0\s*;[ \t]*\n//g;
s/\$\[\s*\+\s*//g;
--- 81,110 ----
warn "Won't overwrite existing $newname\n";
next;
}
! my $oldpack = $2;
! my $newpack = "\u$2";
! my @export = ();
s/\bstd(in|out|err)\b/\U$&/g;
s/(sub\s+)(\w+)(\s*\{[ \t]*\n)\s*package\s+$oldpack\s*;[ \t]*\n+/${1}main'$2$3/ig;
! if (/sub\s+\w+'/) {
! @export = m/sub\s+\w+'(\w+)/g;
s/(sub\s+)main'(\w+)/$1$2/g;
}
else {
@export = m/sub\s+([A-Za-z]\w*)/g;
}
! my @export_ok = grep($keyword{$_}, @export);
@export = grep(!$keyword{$_}, @export);
+
+ my %export = ();
@export{@export} = (1) x @export;
+
s/(^\s*);#/$1#/g;
s/(#.*)require ['"]$oldpack\.pl['"]/$1use $newpack/;
s/(package\s*)($oldpack)\s*;[ \t]*\n+//ig;
! s/([\$\@%&*])'(\w+)/&xlate($1,"",$2,$newpack,$oldpack,\%export)/eg;
! s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3,$newpack,$oldpack,\%export)/eg;
if (!/\$\[\s*\)?\s*=\s*[^0\s]/) {
s/^\s*(local\s*\()?\s*\$\[\s*\)?\s*=\s*0\s*;[ \t]*\n//g;
s/\$\[\s*\+\s*//g;
***************
*** 106,129 ****
}
s/open\s+(\w+)/open($1)/g;
if (s/\bdie\b/croak/g) {
$carp = "use Carp;\n";
s/croak "([^"]*)\\n"/croak "$1"/g;
}
! else {
! $carp = "";
! }
if (@export_ok) {
$export_ok = "\@EXPORT_OK = qw(@export_ok);\n";
}
- else {
- $export_ok = "";
- }
! open(PM, ">$newname") || warn "Can't create $newname: $!\n";
! print PM <<"END";
package $newpack;
! require 5.000;
require Exporter;
$carp
\@ISA = qw(Exporter);
--- 113,135 ----
}
s/open\s+(\w+)/open($1)/g;
+ my $export_ok = '';
+ my $carp ='';
+
+
if (s/\bdie\b/croak/g) {
$carp = "use Carp;\n";
s/croak "([^"]*)\\n"/croak "$1"/g;
}
!
if (@export_ok) {
$export_ok = "\@EXPORT_OK = qw(@export_ok);\n";
}
! if ( open(PM, ">$newname") ) {
! print PM <<"END";
package $newpack;
! require 5.6.0;
require Exporter;
$carp
\@ISA = qw(Exporter);
***************
*** 131,157 ****
$export_ok
$_
END
}
sub xlate {
! local($prefix, $pack, $ident) = @_;
if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) {
! "${pack}'$ident";
}
! elsif ($pack eq "" || $pack eq "main") {
! if ($export{$ident}) {
! "$prefix$ident";
}
else {
! "$prefix${pack}::$ident";
}
}
elsif ($pack eq $oldpack) {
! "$prefix${newpack}::$ident";
}
else {
! "$prefix${pack}::$ident";
}
}
__END__
AUTOLOAD
--- 137,171 ----
$export_ok
$_
END
+ }
+ else {
+ warn "Can't create $newname: $!\n";
+ }
}
sub xlate {
! my ($prefix, $pack, $ident,$newpack,$oldpack,$export) = @_;
!
! my $xlated ;
if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) {
! $xlated = "${pack}'$ident";
}
! elsif ($pack eq '' || $pack eq 'main') {
! if ($export->{$ident}) {
! $xlated = "$prefix$ident";
}
else {
! $xlated = "$prefix${pack}::$ident";
}
}
elsif ($pack eq $oldpack) {
! $xlated = "$prefix${newpack}::$ident";
}
else {
! $xlated = "$prefix${pack}::$ident";
}
+
+ return $xlated;
}
__END__
AUTOLOAD
***************
*** 159,164 ****
--- 173,180 ----
CORE
DESTROY
END
+ INIT
+ CHECK
abs
accept
alarm
***************
*** 170,175 ****
--- 186,192 ----
caller
chdir
chmod
+ chomp
chop
chown
chr
***************
*** 201,206 ****
--- 218,224 ----
eq
eval
exec
+ exists
exit
exp
fcntl
***************
*** 260,269 ****
--- 278,289 ----
listen
local
localtime
+ lock
log
lstat
lt
m
+ map
mkdir
msgctl
msgget
***************
*** 279,294 ****
--- 299,319 ----
opendir
or
ord
+ our
pack
package
pipe
pop
+ pos
print
printf
+ prototype
push
q
qq
+ qr
quotemeta
+ qu
qw
qx
rand
***************
*** 348,359 ****
--- 373,387 ----
substr
symlink
syscall
+ sysopen
sysread
+ sysseek
system
syswrite
tell
telldir
tie
+ tied
time
times
tr
diff -c /dev/null 'perl-5.7.2/uts/sprintf_wrap.c'
Index: ./uts/sprintf_wrap.c
*** ./uts/sprintf_wrap.c Thu Jan 1 02:00:00 1970
--- ./uts/sprintf_wrap.c Thu Jul 12 06:36:23 2001
***************
*** 0 ****
--- 1,196 ----
+ #include <stdlib.h>
+ #include <stdio.h>
+ #include <assert.h>
+ #include <string.h>
+
+ char *UTS_sprintf_wrap();
+ char *do_efmt();
+ char *do_gfmt();
+ char *Fill();
+
+ /* main(argc, argv)
+ * char **argv;
+ * {
+ * double d;
+ * char *Fmt, *Ret;
+ * char obuf[200];
+ *
+ * assert(argc > 2);
+ * Fmt = argv[1];
+ * d = strtod(argv[2], (char **)0);
+ *
+ * putchar('{');
+ * printf(Fmt, d);
+ * printf("}\n");
+ *
+ * Ret = UTS_sprintf_wrap(obuf, Fmt, d);
+ * assert(Ret == obuf);
+ *
+ * printf("{%s}\n", obuf);
+ * }
+ */
+
+ char *
+ UTS_sprintf_wrap(obuf, fmt, d,
+ a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15)
+ char *obuf, *fmt;
+ double d;
+ {
+ int fmtlen, Width=0, Precision=6, Alt=0, Plus=0, Minus=0,
+ Zero = 0;
+ int FmtChar, BaseFmt = 0;
+ char *f = fmt, *AfterWidth = 0, *AfterPrecision = 0;
+ char *Dot;
+
+ if(*f++ != '%') {
+ return
+ sprintf(obuf, fmt, d, a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15);
+ }
+ fmtlen = strlen(fmt);
+ FmtChar = fmt[fmtlen - 1];
+ switch(FmtChar) {
+ case 'f':
+ case 'F':
+ return
+ sprintf(obuf, fmt, d, a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15);
+ case 'e':
+ case 'E':
+ BaseFmt = 'e';
+ goto BaseFmt_IsSet;
+ case 'g':
+ case 'G':
+ BaseFmt = 'g';
+ BaseFmt_IsSet:
+ if(*f == '#') { Alt = 1; ++f; } /* Always has '.' */
+ if(*f == '+') { Plus = 1; ++f; } /* Force explicit sign */
+ if(*f == '-') { Minus = 1; ++f; } /* Left justify */
+ if(*f == '0') { Zero = 1; ++f;} /* Fill using 0s*/
+ if(Dot = strchr(f, '.')) {
+ Precision = strtol(Dot+1, &AfterPrecision, 0);
+ }
+ if(!Dot || (Dot && Dot > f)) { /* Next char=='.' => no width*/
+ Width = strtol(f, &AfterWidth, 0);
+ }
+ if(Dot) { f = AfterPrecision; }
+ else if(AfterWidth) { f = AfterWidth; }
+ if(*f != FmtChar) goto regular_sprintf;
+ /* It doesn't look like a f.p. sprintf call */
+ /* from Perl_sv_vcatpvfn */
+
+ if(BaseFmt == 'e') {
+ return do_efmt(d, obuf, Width, Precision, Alt,
+ Plus, Minus, Zero, FmtChar == 'E');
+ } else {
+ return do_gfmt(d, obuf, Width, Precision, Alt,
+ Plus, Minus, Zero, FmtChar == 'G');
+ }
+ default:
+ regular_sprintf:
+ return
+ sprintf(obuf, fmt, d, a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15);
+ }
+ }
+
+ char *
+ do_efmt(d, obuf, Width, Precision, Alt, Plus, Minus, Zero, UpperCase)
+ char *obuf;
+ double d;
+ {
+ char *Ecvt;
+ char *ob;
+ int decpt, sign, E;
+ int len;
+ int AllZeroes = 0;
+
+ Ecvt = ecvt( d , Precision+1, &decpt, &sign);
+
+ /* fprintf(stderr, "decpt=%d, sign=%d\n", decpt, sign); */
+
+ len = strlen(Ecvt);
+ if(strspn(Ecvt, "0") == len) AllZeroes = 1;
+
+ ob = obuf;
+ if(sign) *ob++ = '-';
+ else if(Plus) *ob++ = '+';
+
+ *ob++ = Ecvt[0];
+
+ if(Precision > 0 || Alt) *ob++ = '.';
+ strcpy(ob, &Ecvt[1]);
+
+ ob += strlen(ob); /* ADVANCE TO END OF WHAT WE JUST ADDED */
+ *ob++ = UpperCase ? 'E' : 'e';
+
+ if(AllZeroes) E = 0;
+ else E = decpt - 1;
+
+ if(E < 0) { *ob++ = '-'; E = -E; }
+ else { *ob++ = '+'; }
+
+ sprintf(ob, "%.2d", E); /* Too much horsepower used here */
+
+ if(Width > strlen(obuf)) return Fill(obuf, Width, Minus, Zero);
+ else return obuf;
+ }
+
+ char *
+ do_gfmt(d, obuf, Width, Precision, Alt, Plus, Minus, Zero, UpperCase)
+ char *obuf;
+ double d;
+ {
+ char *Ecvt = gcvt(d, Precision ? Precision : 1, obuf);
+ int len = strlen(obuf);
+
+ /* gcvt fails (maybe give a warning? For now return empty string): */
+ if(!Ecvt) { *obuf = '\0'; return obuf; }
+
+ /* printf("Ecvt='%s'\n", Ecvt); */
+ if(Plus && (Ecvt[0] != '-')) {
+ memmove(obuf+1, obuf, len+1); /* "+1" to get '\0' at end */
+ obuf[0] = '+';
+ ++len;
+ }
+ if(Alt && !strchr(Ecvt, '.')) {
+ int LenUpTo_E = strcspn(obuf, "eE");
+ int E_etc_len = strlen(&obuf[LenUpTo_E]);
+ /* ABOVE: Will be 0 if there's no E/e because */
+ /* strcspn will return length of whole string */
+
+ if(E_etc_len)
+ memmove(obuf+LenUpTo_E+1, obuf+LenUpTo_E, E_etc_len);
+ obuf[LenUpTo_E] = '.';
+ obuf[LenUpTo_E + 1 + E_etc_len ] = '\0';
+ }
+ { char *E_loc;
+ if(UpperCase && (E_loc = strchr(obuf, 'e'))) { *E_loc = 'E'; }
+ }
+ if(Width > len)
+ return Fill(obuf, Width, Minus, Zero);
+ else
+ return obuf;
+ }
+
+ char *
+ Fill(obuf, Width, LeftJustify, Zero)
+ char *obuf;
+ {
+ int W = strlen(obuf);
+ int diff = Width - W;
+ /* LeftJustify means there was a '-' flag, and in that case, */
+ /* printf man page (UTS4.4) says ignore '0' */
+ char FillChar = (Zero && !LeftJustify) ? '0' : ' ';
+ int i;
+ int LeftFill = ! LeftJustify;
+
+ if(Width <= W) return obuf;
+
+ if(LeftFill) {
+ memmove(obuf+diff, obuf, W+1); /* "+1" to get '\0' at end */
+ for(i=0 ; i < diff ; ++i) { obuf[i] = FillChar; }
+ } else {
+ for(i=W ; i < Width ; ++i)
+ obuf[i] = FillChar;
+ obuf[Width] = '\0';
+ }
+ return obuf;
+ }
diff -c /dev/null 'perl-5.7.2/uts/strtol_wrap.c'
Index: ./uts/strtol_wrap.c
*** ./uts/strtol_wrap.c Thu Jan 1 02:00:00 1970
--- ./uts/strtol_wrap.c Mon Jul 9 17:11:32 2001
***************
*** 0 ****
--- 1,174 ----
+ /* A wrapper around strtol() and strtoul() to correct some
+ * "out of bounds" cases that don't work well on at least UTS.
+ * If a value is Larger than the max, strto[u]l should return
+ * the max value, and set errno to ERANGE
+ * The same if a value is smaller than the min value (only
+ * relevant for strtol(); not strtoul()), except the minimum
+ * value is returned (and errno == ERANGE).
+ */
+
+ #include <ctype.h>
+ #include <string.h>
+ #include <sys/errno.h>
+ #include <stdlib.h>
+
+ extern int errno;
+
+ #undef I32
+ #undef U32
+
+ #define I32 int
+ #define U32 unsigned int
+
+ struct base_info {
+ char *ValidChars;
+
+ char *Ulong_max_str;
+ char *Long_max_str;
+ char *Long_min_str; /* Absolute value */
+
+ int Ulong_max_str_len;
+ int Long_max_str_len;
+ int Long_min_str_len; /* Absolute value */
+
+ U32 Ulong_max;
+ I32 Long_max;
+ I32 Long_min; /* NOT Absolute value */
+ };
+ static struct base_info Base_info[37];
+
+ static struct base_info Base_info_16 = {
+ "0123456789abcdefABCDEF",
+ "4294967295", "2147483648" /* <== ABS VAL */ , "2147483647",
+ 10, 10, 10,
+ 4294967295, 2147483647, - 2147483648,
+ };
+
+ static struct base_info Base_info_10 = {
+ "0123456789",
+ "4294967295", "2147483648" /* <== ABS VAL */ , "2147483647",
+ 10, 10, 10,
+ 4294967295, 2147483647, - 2147483648,
+ };
+
+ /* Used eventually (if this is fully developed) to hold info
+ * for processing bases 2-36. So that we can just plug the
+ * base in as a selector for its info, we sacrifice
+ * Base_info[0] and Base_info[1] (unless they are used
+ * at some point for special information).
+ */
+
+ /* This may be replaced later by something more universal */
+ static void
+ init_Base_info()
+ {
+ if(Base_info[10].ValidChars) return;
+ Base_info[10] = Base_info_10;
+ Base_info[16] = Base_info_16;
+ }
+
+ unsigned int
+ strtoul_wrap32(char *s, char **pEnd, int base)
+ {
+ int Len;
+ int isNegated = 0;
+ char *sOrig = s;
+
+ init_Base_info();
+
+ while(*s && isspace(*s)) ++s;
+
+ if(*s == '-') {
+ ++isNegated;
+ ++s;
+ while(*s && isspace(*s)) ++s;
+ }
+ if(base == 0) {
+ if(*s == '0') {
+ if(s[1] == 'x' || s[1] == 'X') {
+ s += 2;
+ base = 16;
+ } else {
+ ++s;
+ base = 8;
+ }
+ } else if(isdigit(*s)) {
+ base = 10;
+ }
+ }
+ if(base != 10) {
+ return strtoul(sOrig, pEnd, base);
+ }
+
+ Len = strspn(s, Base_info[base].ValidChars);
+
+ if(Len > Base_info[base].Ulong_max_str_len
+ ||
+ (Len == Base_info[base].Ulong_max_str_len
+ &&
+ strncmp(Base_info[base].Ulong_max_str, s, Len) < 0)
+ ) {
+ /* In case isNegated is set - what to do?? */
+ /* Mightn't we say a negative number is ERANGE for strtoul? */
+ errno = ERANGE;
+ return Base_info[base].Ulong_max;
+ }
+
+ return strtoul(sOrig, pEnd, base);
+ }
+
+ int
+ strtol_wrap32(char *s, char **pEnd, int base)
+ {
+ int Len;
+ int isNegated = 0;
+ char *sOrig = s;
+
+ init_Base_info();
+
+ while(*s && isspace(*s)) ++s;
+
+ if(*s == '-') {
+ ++isNegated;
+ ++s;
+ while(*s && isspace(*s)) ++s;
+ }
+ if(base == 0) {
+ if(*s == '0') {
+ if(s[1] == 'x' || s[1] == 'X') {
+ s += 2;
+ base = 16;
+ } else {
+ ++s;
+ base = 8;
+ }
+ } else if(isdigit(*s)) {
+ base = 10;
+ }
+ }
+ if(base != 10) {
+ return strtol(sOrig, pEnd, base);
+ }
+
+ Len = strspn(s, Base_info[base].ValidChars);
+
+ if(Len > Base_info[base].Long_max_str_len
+ ||
+ (!isNegated && Len == Base_info[base].Long_max_str_len
+ &&
+ strncmp(Base_info[base].Long_max_str, s, Len) < 0)
+ ||
+ (isNegated && Len == Base_info[base].Long_min_str_len
+ &&
+ strncmp(Base_info[base].Long_min_str, s, Len) < 0)
+ ) {
+ /* In case isNegated is set - what to do?? */
+ /* Mightn't we say a negative number is ERANGE for strtol? */
+ errno = ERANGE;
+ return(isNegated ? Base_info[base].Long_min
+ :
+ Base_info[base].Long_min);
+ }
+
+ return strtol(sOrig, pEnd, base);
+ }
diff -c 'perl-5.7.1/vms/descrip_mms.template' 'perl-5.7.2/vms/descrip_mms.template'
Index: ./vms/descrip_mms.template
*** ./vms/descrip_mms.template Tue Mar 6 04:07:26 2001
--- ./vms/descrip_mms.template Mon Jul 9 17:11:32 2001
***************
*** 231,240 ****
# life easier for those who modify Perl and rebuild it.
INSTPERL = perl
- # Space-separated list of "dynamic" extensions which should be built for
- # run-time dynamic loading.
- dynamic_ext = $extensions
-
# Space-separated list of "static" extensions to build into perlshr (case counts).
MYEXT = DynaLoader
# object files for these extensions; the trailing comma is required if
--- 231,236 ----
***************
*** 241,256 ****
# there are any object files specified
# These must be built separately, or you must add rules below to build them
myextobj = [.ext.dynaloader]dl_vms$(O),
- #: We include the Socket extension by default if we're building with socket
- #: support, since it's small and not really worth bothering to keep track
- #: of separately.
- .ifdef SOCKET
- EXT = $(MYEXT) Socket
- extobj = $(myextobj) [.ext.socket]socket$(O),
- .else
EXT = $(MYEXT)
extobj = $(myextobj)
- .endif
.ifdef LIBS2
.else
--- 237,244 ----
***************
*** 271,287 ****
#### End of system configuration section. ####
! c0 = $(MALLOC_C) $(SOCKC) av.c deb.c doio.c doop.c dump.c globals.c gv.c
! c1 = hv.c mg.c miniperlmain.c op.c perl.c perlapi.c perlio.c perly.c pp.c pp_ctl.c
! c2 = pp_hot.c pp_sys.c regcomp.c regexec.c run.c scope.c sv.c taint.c
! c3 = toke.c universal.c utf8.c util.c vms.c xsutils.c
c = $(c0) $(c1) $(c2) $(c3)
obj0 = $(MALLOC_O) $(SOCKO) av$(O) deb$(O) doio$(O) doop$(O) dump$(O)
! obj1 = globals$(O) gv$(O) hv$(O) mg$(O) miniperlmain$(O) op$(O) perl$(O) perlapi$(O)
! obj2 = perlio$(O) perly$(O) pp$(O) pp_ctl$(O) pp_hot$(O) pp_sys$(O) regcomp$(O)
! obj3 = regexec$(O) run$(O) scope$(O) sv$(O) taint$(O) toke$(O) universal$(O)
! obj4 = utf8$(O) util$(O) vms$(O) xsutils$(O)
obj = $(obj0) $(obj1) $(obj2) $(obj3) $(obj4)
h0 = av.h cc_runtime.h config.h cop.h cv.h embed.h embedvar.h
--- 259,275 ----
#### End of system configuration section. ####
! c0 = $(MALLOC_C) $(SOCKC) av.c deb.c doio.c doop.c dump.c globals.c gv.c hv.c
! c1 = mg.c locale.c miniperlmain.c numeric.c op.c perl.c perlapi.c perlio.c
! c2 = perly.c pp.c pp_ctl.c pp_hot.c pp_pack.c pp_sys.c regcomp.c regexec.c
! c3 = run.c scope.c sv.c taint.c toke.c universal.c utf8.c util.c vms.c xsutils.c
c = $(c0) $(c1) $(c2) $(c3)
obj0 = $(MALLOC_O) $(SOCKO) av$(O) deb$(O) doio$(O) doop$(O) dump$(O)
! obj1 = globals$(O) gv$(O) hv$(O) locale$(O) mg$(O) miniperlmain$(O) numeric$(O)
! obj2 = op$(O) perl$(O) perlapi$(O) perlio$(O) perly$(O) pp$(O) pp_ctl$(O) pp_hot$(O)
! obj3 = pp_pack$(O) pp_sys$(O) regcomp$(O) regexec$(O) run$(O) scope$(O) sv$(O) taint$(O) toke$(O)
! obj4 = universal$(O) utf8$(O) util$(O) vms$(O) xsutils$(O)
obj = $(obj0) $(obj1) $(obj2) $(obj3) $(obj4)
h0 = av.h cc_runtime.h config.h cop.h cv.h embed.h embedvar.h
***************
*** 388,394 ****
pod19 = [.lib.pod]perltodo.pod [.lib.pod]perltoot.pod [.lib.pod]perltootc.pod
pod20 = [.lib.pod]perltrap.pod [.lib.pod]perlunicode.pod [.lib.pod]perlvar.pod
pod21 = [.lib.pod]perlxs.pod [.lib.pod]perlxstut.pod [.lib.pod]win32.pod [.lib.pod]perlvms.pod
! pod = $(pod0) $(pod1) $(pod2) $(pod3) $(pod4) $(pod5) $(pod6) $(pod7) $(pod8) $(pod9) $(pod10) $(pod11) $(pod12) $(pod13) $(pod14) $(pod15) $(pod16) $(pod17) $(pod18) $(pod19) $(pod20) $(pod21)
perlpods : $(pod)
@ $(NOOP)
--- 376,384 ----
pod19 = [.lib.pod]perltodo.pod [.lib.pod]perltoot.pod [.lib.pod]perltootc.pod
pod20 = [.lib.pod]perltrap.pod [.lib.pod]perlunicode.pod [.lib.pod]perlvar.pod
pod21 = [.lib.pod]perlxs.pod [.lib.pod]perlxstut.pod [.lib.pod]win32.pod [.lib.pod]perlvms.pod
! pod22 = [.lib.pod]perldebguts.pod [.lib.pod]perldebtut.pod [.lib.pod]perlebcdic.pod [.lib.pod]perliol.pod
! pod23 = [.lib.pod]perlnewmod.pod [.lib.pod]perlnumber.pod [.lib.pod]perlrequick.pod [.lib.pod]perlretut.pod [.lib.pod]perlutil.pod
! pod = $(pod0) $(pod1) $(pod2) $(pod3) $(pod4) $(pod5) $(pod6) $(pod7) $(pod8) $(pod9) $(pod10) $(pod11) $(pod12) $(pod13) $(pod14) $(pod15) $(pod16) $(pod17) $(pod18) $(pod19) $(pod20) $(pod21) $(pod22) $(pod23)
perlpods : $(pod)
@ $(NOOP)
***************
*** 496,503 ****
$(MINIPERL) $(MMS$SOURCE)
@ Rename/Log xsloader.pm [.ext.dynaloader]
! dynext : $(LIBPREREQ) $(DBG)perlshr$(E)
! @make_ext "$(dynamic_ext)" "$(MINIPERL_EXE)" "$(MMS)"
[.lib]vmsish.pm : [.vms.ext]vmsish.pm
Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
--- 486,493 ----
$(MINIPERL) $(MMS$SOURCE)
@ Rename/Log xsloader.pm [.ext.dynaloader]
! dynext : $(LIBPREREQ) $(DBG)perlshr$(E) preplibrary
! @make_ext "$(MINIPERL_EXE)" "$(MMS)"
[.lib]vmsish.pm : [.vms.ext]vmsish.pm
Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
***************
*** 618,624 ****
$(MINIPERL) $(MMS$SOURCE)
Copy/Log [.pod]podselect.com $(MMS$TARGET)
! preplibrary : $(MINIPERL_EXE) $(LIBPREREQ) $(SOCKPM)
@ Write Sys$Output "Autosplitting Perl library . . ."
@ Create/Directory [.lib.auto]
@ $(MINIPERL) -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm
--- 608,614 ----
$(MINIPERL) $(MMS$SOURCE)
Copy/Log [.pod]podselect.com $(MMS$TARGET)
! preplibrary : $(MINIPERL_EXE) $(LIBPREREQ)
@ Write Sys$Output "Autosplitting Perl library . . ."
@ Create/Directory [.lib.auto]
@ $(MINIPERL) -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm
***************
*** 659,664 ****
--- 649,660 ----
[.lib.pod]perldebug.pod : [.pod]perldebug.pod
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+ [.lib.pod]perldebguts.pod : [.pod]perldebguts.pod
+ @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+ [.lib.pod]perldebtut.pod : [.pod]perldebtut.pod
+ @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
[.lib.pod]perldelta.pod : [.pod]perldelta.pod
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
***************
*** 668,673 ****
--- 664,672 ----
[.lib.pod]perldsc.pod : [.pod]perldsc.pod
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+ [.lib.pod]perlebcdic.pod : [.pod]perlebcdic.pod
+ @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
[.lib.pod]perlembed.pod : [.pod]perlembed.pod
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
***************
*** 725,730 ****
--- 724,732 ----
[.lib.pod]perlintern.pod : [.pod]perlintern.pod
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+ [.lib.pod]perliol.pod : [.pod]perliol.pod
+ @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
[.lib.pod]perlipc.pod : [.pod]perlipc.pod
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
***************
*** 746,751 ****
--- 748,759 ----
[.lib.pod]perlmodlib.pod : [.pod]perlmodlib.pod
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+ [.lib.pod]perlnewmod.pod : [.pod]perlnewmod.pod
+ @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+ [.lib.pod]perlnumber.pod : [.pod]perlnumber.pod
+ @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
[.lib.pod]perlobj.pod : [.pod]perlobj.pod
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
***************
*** 770,775 ****
--- 778,789 ----
[.lib.pod]perlreftut.pod : [.pod]perlreftut.pod
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+ [.lib.pod]perlrequick.pod : [.pod]perlrequick.pod
+ @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+ [.lib.pod]perlretut.pod : [.pod]perlretut.pod
+ @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
[.lib.pod]perlrun.pod : [.pod]perlrun.pod
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
***************
*** 809,814 ****
--- 823,831 ----
[.lib.pod]perlunicode.pod : [.pod]perlunicode.pod
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+ [.lib.pod]perlutil.pod : [.pod]perlutil.pod
+ @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
[.lib.pod]perlvar.pod : [.pod]perlvar.pod
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
***************
*** 836,850 ****
.ifdef SOCKET
- .ifdef LINK_ONLY
- .else
- [.ext.Socket]Socket$(O) : [.ext.Socket]Socket.c
- $(CC) $(CFLAGS) /Object=$(MMS$TARGET) $(MMS$SOURCE)
-
- [.ext.Socket]Socket.c : [.ext.Socket]Socket.xs [.lib.ExtUtils]XSSymSet.pm $(MINIPERL_EXE)
- $(XSUBPP) $(MMS$SOURCE) >$(MMS$TARGET)
- .endif # !LINK_ONLY
-
vmsish.h : $(SOCKH)
$(SOCKO) : $(SOCKC) EXTERN.h perl.h config.h embed.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h opnames.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h perlio.h
--- 853,858 ----
***************
*** 855,862 ****
$(SOCKH) : [.vms]$(SOCKH)
Copy/Log/NoConfirm [.vms]$(SOCKH) []$(SOCKH)
- [.lib]Socket.pm : [.ext.Socket]Socket.pm
- Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
.endif
# The following files are generated automatically
--- 863,868 ----
***************
*** 902,911 ****
[.t.lib]vmsish.t : [.vms.ext]vmsish.t
Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
check : test
@ Continue
! test : all [.t.lib]vmsfspec.t [.t.lib]vmsish.t
- @[.VMS]Test.Com "$(E)" "$(__DEBUG__)"
@ $(MINIPERL) -e "print ""Ran tests"";" > [.t]rantests.
--- 908,923 ----
[.t.lib]vmsish.t : [.vms.ext]vmsish.t
Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
+ [.t.lib]vms_dclsym.t : [.vms.ext.DCLsym]test.pl
+ Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
+
+ [.t.lib]vms_stdio.t : [.vms.ext.Stdio]test.pl
+ Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
+
check : test
@ Continue
! test : all [.t.lib]vmsfspec.t [.t.lib]vmsish.t [.t.lib]vms_dclsym.t [.t.lib]vms_stdio.t
- @[.VMS]Test.Com "$(E)" "$(__DEBUG__)"
@ $(MINIPERL) -e "print ""Ran tests"";" > [.t]rantests.
***************
*** 933,940 ****
# Should move to VMS installperl when we get one
.ifdef SOCKET
$(SOCKARCH) : $(SOCKH)
! @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
! Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
.endif
$(ARCHCORE)av.h : av.h
@ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
--- 945,952 ----
# Should move to VMS installperl when we get one
.ifdef SOCKET
$(SOCKARCH) : $(SOCKH)
! @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
! Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
.endif
$(ARCHCORE)av.h : av.h
@ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
***************
*** 1113,1118 ****
--- 1125,1132 ----
$(CC) $(CORECFLAGS) $(MMS$SOURCE)
hv$(O) : hv.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h
$(CC) $(CORECFLAGS) $(MMS$SOURCE)
+ locale$(O) : locale.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h
+ $(CC) $(CORECFLAGS) $(MMS$SOURCE)
malloc$(O) : malloc.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h
$(CC) $(CORECFLAGS) $(MMS$SOURCE)
mg$(O) : mg.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h
***************
*** 1119,1124 ****
--- 1133,1140 ----
$(CC) $(CORECFLAGS) $(MMS$SOURCE)
miniperlmain$(O) : miniperlmain.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h
$(CC) $(CORECFLAGS) $(MMS$SOURCE)
+ numeric$(O) : numeric.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h keywords.h
+ $(CC) $(CORECFLAGS) $(MMS$SOURCE)
op$(O) : op.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h keywords.h
$(CC) $(CORECFLAGS) $(MMS$SOURCE)
perl$(O) : perl.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h patchlevel.h intrpvar.h thrdvar.h
***************
*** 1137,1142 ****
--- 1153,1159 ----
$(CC) $(CORECFLAGS) $(MMS$SOURCE)
pp_hot$(O) : pp_hot.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h
$(CC) $(CORECFLAGS) $(MMS$SOURCE)
+ pp_pack$(O) : pp_pack.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h
pp_sys$(O) : pp_sys.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h
$(CC) $(CORECFLAGS) $(MMS$SOURCE)
regcomp$(O) : regcomp.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h intern.h regcomp.h regnodes.h
***************
*** 1232,1238 ****
- If F$Search("Perlshr_Gbl*.Mar;-1") .nes."" Then Purge/NoConfirm/Log Perlshr_Gbl*.Mar
- If F$Search("[.Ext.DynaLoader]DL_VMS$(O);-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O)
- If F$Search("[.Ext.DynaLoader]DL_VMS.C;-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C
- - If F$Search("[.Ext.Socket]Socket.C;-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C
- If F$Search("[.Ext.Opcode...];-1").nes."" Then Purge/NoConfirm/Log [.Ext.Opcode]
- If F$Search("[.VMS.Ext...]*.C;-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*.C
- If F$Search("[.VMS.Ext...]*$(O);-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*$(O)
--- 1249,1254 ----
***************
*** 1240,1246 ****
- If F$Search("[.Lib.Auto...]autosplit.ix;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Auto...]autosplit.ix
- If F$Search("[.Lib]DynaLoader.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib]DynaLoader.pm
- If F$Search("[.Lib]XSLoader.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib]XSLoader.pm
- - If F$Search("[.Lib]Socket.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib]Socket.pm
- If F$Search("[.Lib]Config.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib]Config.pm
- If F$Search("$(ARCHDIR)Config.pm;-1").nes."" Then Purge/NoConfirm/Log $(ARCHDIR)Config.pm
- If F$Search("[.lib.ExtUtils]Miniperl.pm").nes."" Then Purge/NoConfirm/Log [.lib.ExtUtils]Miniperl.pm
--- 1256,1261 ----
***************
*** 1255,1261 ****
- If F$Search("[.lib.pod]*.com;-1").nes."" Then Purge/NoConfirm/Log [.lib.pod]*.com
clean : tidy cleantest
! - @make_ext "$(dynamic_ext)" "$(MINIPERL_EXE)" "$(MMS)" clean
- If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt
- If F$Search("[...]*$(O);*") .nes."" Then Delete/NoConfirm/Log [...]*$(O);*
- If F$Search(F$Parse("Sys$Disk:[]","$(SOCKH)")).nes."" Then Delete/NoConfirm/Log $(SOCKH);*
--- 1270,1276 ----
- If F$Search("[.lib.pod]*.com;-1").nes."" Then Purge/NoConfirm/Log [.lib.pod]*.com
clean : tidy cleantest
! - @make_ext "$(MINIPERL_EXE)" "$(MMS)" clean
- If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt
- If F$Search("[...]*$(O);*") .nes."" Then Delete/NoConfirm/Log [...]*$(O);*
- If F$Search(F$Parse("Sys$Disk:[]","$(SOCKH)")).nes."" Then Delete/NoConfirm/Log $(SOCKH);*
***************
*** 1273,1280 ****
- If F$Search("[.Ext.DynaLoader]DL_VMS.C").nes."" Then Delete/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C;*
- If F$Search("[.Ext.DynaLoader]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log [.Ext.DynaLoader]DynaLoader.pm;*
- If F$Search("[.Ext.DynaLoader]XSLoader.pm").nes."" Then Delete/NoConfirm/Log [.Ext.DynaLoader]XSLoader.pm;*
- - If F$Search("[.Ext.Socket]Socket$(O)").nes."" Then Delete/NoConfirm/Log [.Ext.Socket]Socket$(O);*
- - If F$Search("[.Ext.Socket]Socket.C").nes."" Then Delete/NoConfirm/Log [.Ext.Socket]Socket.C;*
- If F$Search("[.VMS.Ext...]*.C").nes."" Then Delete/NoConfirm/Log [.VMS.Ext...]*.C;*
- If F$Search("[.VMS.Ext...]*$(O)").nes."" Then Delete/NoConfirm/Log [.VMS.Ext...]*$(O);*
- If F$Search("[.pod]*.com").nes."" Then Delete/NoConfirm/Log [.pod]*.com;*
--- 1288,1293 ----
***************
*** 1281,1287 ****
- @extra_pods CLEAN
realclean : clean
! - @make_ext "$(dynamic_ext)" "$(MINIPERL_EXE)" "$(MMS)" realclean
- If F$Search("*$(OLB)").nes."" Then Delete/NoConfirm/Log *$(OLB);*
- If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*
- If F$Search("Config.H").nes."" Then Delete/NoConfirm/Log Config.H;*
--- 1294,1300 ----
- @extra_pods CLEAN
realclean : clean
! - @make_ext "$(MINIPERL_EXE)" "$(MMS)" realclean
- If F$Search("*$(OLB)").nes."" Then Delete/NoConfirm/Log *$(OLB);*
- If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*
- If F$Search("Config.H").nes."" Then Delete/NoConfirm/Log Config.H;*
***************
*** 1294,1300 ****
- If F$Search("*.TS").nes."" Then Delete/NoConfirm/Log *.TS;*
- If F$Search("[.Lib]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log [.Lib]DynaLoader.pm;*
- If F$Search("[.Lib]XSLoader.pm").nes."" Then Delete/NoConfirm/Log [.Lib]XSLoader.pm;*
- - If F$Search("[.Lib]Socket.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Socket.pm;*
- If F$Search("[.Lib]Config.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;*
- If F$Search("[.Lib]*.com").nes."" Then Delete/NoConfirm/Log [.Lib]*.com;*
- If F$Search("[.pod]*.com").nes."" Then Delete/NoConfirm/Log [.pod]*.com;*
--- 1307,1312 ----
***************
*** 1310,1315 ****
--- 1322,1331 ----
- If F$Search("[...]*$(E)").nes."" Then Delete/NoConfirm/Log [...]*$(E);*
- If F$Search("[.vms]Perl_Setup.Com").nes."" Then Delete/NoConfirm/Log [.vms]Perl_Setup.Com;*
- If F$Search("[.t]rantests.").nes."" Then Delete/NoConfirm/Log [.t]rantests.;*
+ - If F$Search("[.t.lib]vmsfspec.t").nes."" Then Delete/NoConfirm/Log [.t.lib]vmsfspec.t;*
+ - If F$Search("[.t.lib]vmsish.t").nes."" Then Delete/NoConfirm/Log [.t.lib]vmsish.t;*
+ - If F$Search("[.t.lib]vms_dclsym.t").nes."" Then Delete/NoConfirm/Log [.t.lib]vms_dclsym.t;*
+ - If F$Search("[.t.lib]vms_stdio.t").nes."" Then Delete/NoConfirm/Log [.t.lib]vms_stdio.t;*
cleansrc : clean
!GROK!THIS!
diff -c 'perl-5.7.1/vms/ext/Stdio/Stdio.xs' 'perl-5.7.2/vms/ext/Stdio/Stdio.xs'
Index: ./vms/ext/Stdio/Stdio.xs
*** ./vms/ext/Stdio/Stdio.xs Tue Mar 6 04:07:26 2001
--- ./vms/ext/Stdio/Stdio.xs Mon Jul 9 17:11:33 2001
***************
*** 81,87 ****
static SV *
! newFH(FILE *fp, char type) {
SV *rv;
GV **stashp, *gv = (GV *)NEWSV(0,0);
HV *stash;
--- 81,87 ----
static SV *
! newFH(PerlIO *fp, char type) {
SV *rv;
GV **stashp, *gv = (GV *)NEWSV(0,0);
HV *stash;
***************
*** 128,143 ****
SV * fh
PROTOTYPE: $
CODE:
! IO *io = sv_2io(fh);
! FILE *fp = io ? IoOFP(io) : NULL;
! char iotype = io ? IoTYPE(io) : '\0';
! char filespec[NAM$C_MAXRSS], *acmode, *s, *colon, *dirend = Nullch;
! int ret = 0, saverrno = errno, savevmserrno = vaxc$errno;
! fpos_t pos;
if (fp == NULL || strchr(">was+-|",iotype) == Nullch) {
set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
}
! if (!fgetname(fp,filespec)) XSRETURN_UNDEF;
for (s = filespec; *s; s++) {
if (*s == ':') colon = s;
else if (*s == ']' || *s == '>') dirend = s;
--- 128,147 ----
SV * fh
PROTOTYPE: $
CODE:
! SV *name;
! IO *io;
! char iotype;
! char filespec[NAM$C_MAXRSS], *acmode, *s, *colon, *dirend = Nullch;
! int ret = 0, saverrno = errno, savevmserrno = vaxc$errno;
! SV pos;
! PerlIO *fp;
! io = sv_2io(fh);
! fp = io ? IoOFP(io) : NULL;
! iotype = io ? IoTYPE(io) : '\0';
if (fp == NULL || strchr(">was+-|",iotype) == Nullch) {
set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
}
! if (!PerlIO_getname(fp,filespec)) XSRETURN_UNDEF;
for (s = filespec; *s; s++) {
if (*s == ':') colon = s;
else if (*s == ']' || *s == '>') dirend = s;
***************
*** 149,155 ****
/* If we've got a non-file-structured device, clip off the trailing
* junk, and don't lose sleep if we can't get a stream position. */
if (dirend == Nullch) *(colon+1) = '\0';
! if (iotype != '-' && (ret = fgetpos(fp, &pos)) == -1 && dirend)
XSRETURN_UNDEF;
switch (iotype) {
case '<': case 'r': acmode = "rb"; break;
--- 153,159 ----
/* If we've got a non-file-structured device, clip off the trailing
* junk, and don't lose sleep if we can't get a stream position. */
if (dirend == Nullch) *(colon+1) = '\0';
! if (iotype != '-' && (ret = PerlIO_getpos(fp, &pos)) == -1 && dirend)
XSRETURN_UNDEF;
switch (iotype) {
case '<': case 'r': acmode = "rb"; break;
***************
*** 158,164 ****
fsetpos below will take care of restoring file position */
case 'a': acmode = "ab"; break;
case '+': case 's': acmode = "rb+"; break;
! case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
/* iotype'll be null for the SYS$INPUT:/SYS$OUTPUT:/SYS$ERROR: files */
/* since we didn't really open them and can't really */
/* reopen them */
--- 162,168 ----
fsetpos below will take care of restoring file position */
case 'a': acmode = "ab"; break;
case '+': case 's': acmode = "rb+"; break;
! case '-': acmode = PerlIO_fileno(fp) ? "ab" : "rb"; break;
/* iotype'll be null for the SYS$INPUT:/SYS$OUTPUT:/SYS$ERROR: files */
/* since we didn't really open them and can't really */
/* reopen them */
***************
*** 168,175 ****
iotype, filespec);
acmode = "rb+";
}
! if (freopen(filespec,acmode,fp) == NULL) XSRETURN_UNDEF;
! if (iotype != '-' && ret != -1 && fsetpos(fp,&pos) == -1) XSRETURN_UNDEF;
if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); }
XSRETURN_YES;
--- 172,181 ----
iotype, filespec);
acmode = "rb+";
}
! /* appearances to the contrary, this is an freopen substitute */
! name = sv_2mortal(newSVpvn(filespec,strlen(filespec)));
! if (PerlIO_openn(Nullch,acmode,-1,0,0,fp,1,&name) == Nullfp) XSRETURN_UNDEF;
! if (iotype != '-' && ret != -1 && PerlIO_setpos(fp,&pos) == -1) XSRETURN_UNDEF;
if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); }
XSRETURN_YES;
***************
*** 176,202 ****
void
flush(fp)
! FILE * fp
PROTOTYPE: $
CODE:
! if (fflush(fp)) { ST(0) = &PL_sv_undef; }
! else { clearerr(fp); ST(0) = &PL_sv_yes; }
char *
getname(fp)
! FILE * fp
PROTOTYPE: $
CODE:
char fname[NAM$C_MAXRSS+1];
ST(0) = sv_newmortal();
! if (fgetname(fp,fname) != NULL) sv_setpv(ST(0),fname);
void
rewind(fp)
! FILE * fp
PROTOTYPE: $
CODE:
! ST(0) = rewind(fp) ? &PL_sv_undef : &PL_sv_yes;
void
remove(name)
--- 182,212 ----
void
flush(fp)
! PerlIO * fp
PROTOTYPE: $
CODE:
! FILE *stdio = PerlIO_exportFILE(fp,0);
! if (fflush(stdio)) { ST(0) = &PL_sv_undef; }
! else { clearerr(stdio); ST(0) = &PL_sv_yes; }
! PerlIO_releaseFILE(fp,stdio);
char *
getname(fp)
! PerlIO * fp
PROTOTYPE: $
CODE:
char fname[NAM$C_MAXRSS+1];
ST(0) = sv_newmortal();
! if (PerlIO_getname(fp,fname) != NULL) sv_setpv(ST(0),fname);
void
rewind(fp)
! PerlIO * fp
PROTOTYPE: $
CODE:
! FILE *stdio = PerlIO_exportFILE(fp,0);
! ST(0) = rewind(stdio) ? &PL_sv_undef : &PL_sv_yes;
! PerlIO_releaseFILE(fp,stdio);
void
remove(name)
***************
*** 261,271 ****
void
sync(fp)
! FILE * fp
PROTOTYPE: $
CODE:
! if (fsync(fileno(fp))) { ST(0) = &PL_sv_undef; }
! else { clearerr(fp); ST(0) = &PL_sv_yes; }
char *
tmpnam()
--- 271,283 ----
void
sync(fp)
! PerlIO * fp
PROTOTYPE: $
CODE:
! FILE *stdio = PerlIO_exportFILE(fp,0);
! if (fsync(fileno(stdio))) { ST(0) = &PL_sv_undef; }
! else { clearerr(stdio); ST(0) = &PL_sv_yes; }
! PerlIO_releaseFILE(fp,stdio);
char *
tmpnam()
***************
*** 283,288 ****
--- 295,302 ----
char *args[8],mode[3] = {'r','\0','\0'}, type = '<';
register int i, myargc;
FILE *fp;
+ SV *fh;
+ PerlIO *pio_fp;
STRLEN n_a;
if (!spec || !*spec) {
***************
*** 333,341 ****
fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
break;
}
! if (fp != Nullfp) {
! SV *fh = newFH(fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] == 'a' ? 'a' : '>'))));
! ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
}
else { ST(0) = &PL_sv_undef; }
--- 347,356 ----
fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
break;
}
! if (fp != Null(FILE*)) {
! pio_fp = PerlIO_importFILE(fp,0);
! fh = newFH(pio_fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] == 'a' ? 'a' : '>'))));
! ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
}
else { ST(0) = &PL_sv_undef; }
***************
*** 349,354 ****
--- 364,370 ----
char *args[8];
int i, myargc, fd;
FILE *fp;
+ PerlIO *pio_fp;
SV *fh;
STRLEN n_a;
if (!spec || !*spec) {
***************
*** 391,408 ****
}
i = mode & 3;
if (fd >= 0 &&
! ((fp = fdopen(fd, &("r\000w\000r+"[2*i]))) != Nullfp)) {
! SV *fh = newFH(fp,"<>++"[i]);
! ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
}
else { ST(0) = &PL_sv_undef; }
void
waitfh(fp)
! FILE * fp
PROTOTYPE: $
CODE:
! ST(0) = fwait(fp) ? &PL_sv_undef : &PL_sv_yes;
void
writeof(mysv)
--- 407,427 ----
}
i = mode & 3;
if (fd >= 0 &&
! ((fp = fdopen(fd, &("r\000w\000r+"[2*i]))) != Null(FILE*))) {
! pio_fp = PerlIO_importFILE(fp,0);
! fh = newFH(pio_fp,"<>++"[i]);
! ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
}
else { ST(0) = &PL_sv_undef; }
void
waitfh(fp)
! PerlIO * fp
PROTOTYPE: $
CODE:
! FILE *stdio = PerlIO_exportFILE(fp,0);
! ST(0) = fwait(stdio) ? &PL_sv_undef : &PL_sv_yes;
! PerlIO_releaseFILE(fp,stdio);
void
writeof(mysv)
***************
*** 413,423 ****
unsigned long int chan, iosb[2], retsts, retsts2;
struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
IO *io = sv_2io(mysv);
! FILE *fp = io ? IoOFP(io) : NULL;
if (fp == NULL || strchr(">was+-|",IoTYPE(io)) == Nullch) {
set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
}
! if (fgetname(fp,devnam) == Nullch) { ST(0) = &PL_sv_undef; XSRETURN(1); }
if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
devdsc.dsc$w_length = strlen(devnam);
retsts = sys$assign(&devdsc,&chan,0,0);
--- 432,442 ----
unsigned long int chan, iosb[2], retsts, retsts2;
struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
IO *io = sv_2io(mysv);
! PerlIO *fp = io ? IoOFP(io) : NULL;
if (fp == NULL || strchr(">was+-|",IoTYPE(io)) == Nullch) {
set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
}
! if (PerlIO_getname(fp,devnam) == Nullch) { ST(0) = &PL_sv_undef; XSRETURN(1); }
if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
devdsc.dsc$w_length = strlen(devnam);
retsts = sys$assign(&devdsc,&chan,0,0);
diff -c 'perl-5.7.1/vms/ext/filespec.t' 'perl-5.7.2/vms/ext/filespec.t'
Index: ./vms/ext/filespec.t
*** ./vms/ext/filespec.t Tue Mar 6 04:07:27 2001
--- ./vms/ext/filespec.t Mon Jul 9 17:11:33 2001
***************
*** 68,82 ****
__DATA__
# Basic VMS to Unix filespecs
! some:[where.over]the.rainbow unixify /some/where/over/the.rainbow
! [.some.where.over]the.rainbow unixify some/where/over/the.rainbow
! [-.some.where.over]the.rainbow unixify ../some/where/over/the.rainbow
! [.some.--.where.over]the.rainbow unixify some/../../where/over/the.rainbow
! [.some...where.over]the.rainbow unixify some/.../where/over/the.rainbow
! [...some.where.over]the.rainbow unixify .../some/where/over/the.rainbow
! [.some.where.over...]the.rainbow unixify some/where/over/.../the.rainbow
! [.some.where.over...] unixify some/where/over/.../
! [.some.where.over.-] unixify some/where/over/../
[] unixify ./
[-] unixify ../
[--] unixify ../../
--- 68,82 ----
__DATA__
# Basic VMS to Unix filespecs
! some_logical_name_not_likely:[where.over]the.rainbow unixify /some_logical_name_not_likely/where/over/the.rainbow
! [.some_logical_name_not_likely.where.over]the.rainbow unixify some_logical_name_not_likely/where/over/the.rainbow
! [-.some_logical_name_not_likely.where.over]the.rainbow unixify ../some_logical_name_not_likely/where/over/the.rainbow
! [.some_logical_name_not_likely.--.where.over]the.rainbow unixify some_logical_name_not_likely/../../where/over/the.rainbow
! [.some_logical_name_not_likely...where.over]the.rainbow unixify some_logical_name_not_likely/.../where/over/the.rainbow
! [...some_logical_name_not_likely.where.over]the.rainbow unixify .../some_logical_name_not_likely/where/over/the.rainbow
! [.some_logical_name_not_likely.where.over...]the.rainbow unixify some_logical_name_not_likely/where/over/.../the.rainbow
! [.some_logical_name_not_likely.where.over...] unixify some_logical_name_not_likely/where/over/.../
! [.some_logical_name_not_likely.where.over.-] unixify some_logical_name_not_likely/where/over/../
[] unixify ./
[-] unixify ../
[--] unixify ../../
***************
*** 83,96 ****
[...] unixify .../
# and back again
! /some/where/over/the.rainbow vmsify some:[where.over]the.rainbow
! some/where/over/the.rainbow vmsify [.some.where.over]the.rainbow
! ../some/where/over/the.rainbow vmsify [-.some.where.over]the.rainbow
! some/../../where/over/the.rainbow vmsify [-.where.over]the.rainbow
! .../some/where/over/the.rainbow vmsify [...some.where.over]the.rainbow
! some/.../where/over/the.rainbow vmsify [.some...where.over]the.rainbow
! /some/.../where/over/the.rainbow vmsify some:[...where.over]the.rainbow
! some/where/... vmsify [.some.where...]
/where/... vmsify where:[...]
. vmsify []
.. vmsify [-]
--- 83,96 ----
[...] unixify .../
# and back again
! /some_logical_name_not_likely/where/over/the.rainbow vmsify some_logical_name_not_likely:[where.over]the.rainbow
! some_logical_name_not_likely/where/over/the.rainbow vmsify [.some_logical_name_not_likely.where.over]the.rainbow
! ../some_logical_name_not_likely/where/over/the.rainbow vmsify [-.some_logical_name_not_likely.where.over]the.rainbow
! some_logical_name_not_likely/../../where/over/the.rainbow vmsify [-.where.over]the.rainbow
! .../some_logical_name_not_likely/where/over/the.rainbow vmsify [...some_logical_name_not_likely.where.over]the.rainbow
! some_logical_name_not_likely/.../where/over/the.rainbow vmsify [.some_logical_name_not_likely...where.over]the.rainbow
! /some_logical_name_not_likely/.../where/over/the.rainbow vmsify some_logical_name_not_likely:[...where.over]the.rainbow
! some_logical_name_not_likely/where/... vmsify [.some_logical_name_not_likely.where...]
/where/... vmsify where:[...]
. vmsify []
.. vmsify [-]
***************
*** 99,146 ****
/ vmsify sys$disk:[000000]
# Fileifying directory specs
! down:[the.garden.path] fileify down:[the.garden]path.dir;1
! [.down.the.garden.path] fileify [.down.the.garden]path.dir;1
! /down/the/garden/path fileify /down/the/garden/path.dir;1
! /down/the/garden/path/ fileify /down/the/garden/path.dir;1
! down/the/garden/path fileify down/the/garden/path.dir;1
! down:[the.garden]path fileify down:[the.garden]path.dir;1
! down:[the.garden]path. fileify # N.B. trailing . ==> null type
! down:[the]garden.path fileify
! /down/the/garden/path. fileify # N.B. trailing . ==> null type
! /down/the/garden.path fileify
# and pathifying them
! down:[the.garden]path.dir;1 pathify down:[the.garden.path]
! [.down.the.garden]path.dir pathify [.down.the.garden.path]
! /down/the/garden/path.dir pathify /down/the/garden/path/
! down/the/garden/path.dir pathify down/the/garden/path/
! down:[the.garden]path pathify down:[the.garden.path]
! down:[the.garden]path. pathify # N.B. trailing . ==> null type
! down:[the]garden.path pathify
! /down/the/garden/path. pathify # N.B. trailing . ==> null type
! /down/the/garden.path pathify
! down:[the.garden]path.dir;2 pathify #N.B. ;2
path pathify path/
! /down/the/garden/. pathify /down/the/garden/./
! /down/the/garden/.. pathify /down/the/garden/../
! /down/the/garden/... pathify /down/the/garden/.../
path.notdir pathify
# Both VMS/Unix and file/path conversions
! down:[the.garden]path.dir;1 unixpath /down/the/garden/path/
! /down/the/garden/path vmspath down:[the.garden.path]
! down:[the.garden.path] unixpath /down/the/garden/path/
! down:[the.garden.path...] unixpath /down/the/garden/path/.../
! /down/the/garden/path.dir vmspath down:[the.garden.path]
! [.down.the.garden]path.dir unixpath down/the/garden/path/
! down/the/garden/path vmspath [.down.the.garden.path]
path vmspath [.path]
/ vmspath sys$disk:[000000]
# Redundant characters in Unix paths
! //some/where//over/../the.rainbow vmsify some:[where]the.rainbow
! /some/where//over/./the.rainbow vmsify some:[where.over]the.rainbow
..//../ vmspath [--]
./././ vmspath []
./../. vmsify [-]
--- 99,146 ----
/ vmsify sys$disk:[000000]
# Fileifying directory specs
! down_logical_name_not_likely:[the.garden.path] fileify down_logical_name_not_likely:[the.garden]path.dir;1
! [.down_logical_name_not_likely.the.garden.path] fileify [.down_logical_name_not_likely.the.garden]path.dir;1
! /down_logical_name_not_likely/the/garden/path fileify /down_logical_name_not_likely/the/garden/path.dir;1
! /down_logical_name_not_likely/the/garden/path/ fileify /down_logical_name_not_likely/the/garden/path.dir;1
! down_logical_name_not_likely/the/garden/path fileify down_logical_name_not_likely/the/garden/path.dir;1
! down_logical_name_not_likely:[the.garden]path fileify down_logical_name_not_likely:[the.garden]path.dir;1
! down_logical_name_not_likely:[the.garden]path. fileify # N.B. trailing . ==> null type
! down_logical_name_not_likely:[the]garden.path fileify
! /down_logical_name_not_likely/the/garden/path. fileify # N.B. trailing . ==> null type
! /down_logical_name_not_likely/the/garden.path fileify
# and pathifying them
! down_logical_name_not_likely:[the.garden]path.dir;1 pathify down_logical_name_not_likely:[the.garden.path]
! [.down_logical_name_not_likely.the.garden]path.dir pathify [.down_logical_name_not_likely.the.garden.path]
! /down_logical_name_not_likely/the/garden/path.dir pathify /down_logical_name_not_likely/the/garden/path/
! down_logical_name_not_likely/the/garden/path.dir pathify down_logical_name_not_likely/the/garden/path/
! down_logical_name_not_likely:[the.garden]path pathify down_logical_name_not_likely:[the.garden.path]
! down_logical_name_not_likely:[the.garden]path. pathify # N.B. trailing . ==> null type
! down_logical_name_not_likely:[the]garden.path pathify
! /down_logical_name_not_likely/the/garden/path. pathify # N.B. trailing . ==> null type
! /down_logical_name_not_likely/the/garden.path pathify
! down_logical_name_not_likely:[the.garden]path.dir;2 pathify #N.B. ;2
path pathify path/
! /down_logical_name_not_likely/the/garden/. pathify /down_logical_name_not_likely/the/garden/./
! /down_logical_name_not_likely/the/garden/.. pathify /down_logical_name_not_likely/the/garden/../
! /down_logical_name_not_likely/the/garden/... pathify /down_logical_name_not_likely/the/garden/.../
path.notdir pathify
# Both VMS/Unix and file/path conversions
! down_logical_name_not_likely:[the.garden]path.dir;1 unixpath /down_logical_name_not_likely/the/garden/path/
! /down_logical_name_not_likely/the/garden/path vmspath down_logical_name_not_likely:[the.garden.path]
! down_logical_name_not_likely:[the.garden.path] unixpath /down_logical_name_not_likely/the/garden/path/
! down_logical_name_not_likely:[the.garden.path...] unixpath /down_logical_name_not_likely/the/garden/path/.../
! /down_logical_name_not_likely/the/garden/path.dir vmspath down_logical_name_not_likely:[the.garden.path]
! [.down_logical_name_not_likely.the.garden]path.dir unixpath down_logical_name_not_likely/the/garden/path/
! down_logical_name_not_likely/the/garden/path vmspath [.down_logical_name_not_likely.the.garden.path]
path vmspath [.path]
/ vmspath sys$disk:[000000]
# Redundant characters in Unix paths
! //some_logical_name_not_likely/where//over/../the.rainbow vmsify some_logical_name_not_likely:[where]the.rainbow
! /some_logical_name_not_likely/where//over/./the.rainbow vmsify some_logical_name_not_likely:[where.over]the.rainbow
..//../ vmspath [--]
./././ vmspath []
./../. vmsify [-]
diff -c 'perl-5.7.1/vms/gen_shrfls.pl' 'perl-5.7.2/vms/gen_shrfls.pl'
Index: ./vms/gen_shrfls.pl
*** ./vms/gen_shrfls.pl Tue Mar 6 04:07:27 2001
--- ./vms/gen_shrfls.pl Mon Jul 9 17:11:33 2001
***************
*** 39,45 ****
$debug = $ENV{'GEN_SHRFLS_DEBUG'};
! print "gen_shrfls.pl Rev. 14-Dec-1997\n" if $debug;
if ($ARGV[0] eq '-f') {
open(INP,$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n";
--- 39,45 ----
$debug = $ENV{'GEN_SHRFLS_DEBUG'};
! print "gen_shrfls.pl Rev. 18-May-2001\n" if $debug;
if ($ARGV[0] eq '-f') {
open(INP,$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n";
***************
*** 69,75 ****
else { die "$0: Can't find perl.h\n"; }
$use_threads = $use_mymalloc = $case_about_case = $debugging_enabled = 0;
! $hide_mymalloc = $isgcc = 0;
# Go see what is enabled in config.sh
$config = $dir . "config.sh";
--- 69,75 ----
else { die "$0: Can't find perl.h\n"; }
$use_threads = $use_mymalloc = $case_about_case = $debugging_enabled = 0;
! $hide_mymalloc = $isgcc = $use_perlio = 0;
# Go see what is enabled in config.sh
$config = $dir . "config.sh";
***************
*** 81,86 ****
--- 81,87 ----
$debugging_enabled++ if /usedebugging_perl='Y'/;
$hide_mymalloc++ if /embedmymalloc='Y'/;
$isgcc++ if /gccversion='[^']/;
+ $use_perlio++ if /useperlio='define'/;
}
close CONFIG;
***************
*** 147,152 ****
--- 148,154 ----
my($line) = @_;
print "\tchecking for global routine\n" if $debug > 1;
+ $line =~ s/\b(IV|Off_t|Size_t|SSize_t|void)\b//i;
if ( $line =~ /(\w+)\s*\(/ ) {
print "\troutine name is \\$1\\\n" if $debug > 1;
if ($1 eq 'main' || $1 eq 'perl_init_ext') {
***************
*** 164,173 ****
$fcns{'Perl_mfree'}++;
}
$used_expectation_enum = $used_opcode_enum = 0; # avoid warnings
if ($docc) {
! open(CPP,"${cc_cmd}/NoObj/PreProc=Sys\$Output ${dir}perl.h|")
! or die "$0: Can't preprocess ${dir}perl.h: $!\n";
}
else {
open(CPP,"$cpp_file") or die "$0: Can't read preprocessed file $cpp_file: $!\n";
--- 166,181 ----
$fcns{'Perl_mfree'}++;
}
+ if ($use_perlio) {
+ $preprocess_list = "${dir}perl.h,${dir}perliol.h";
+ } else {
+ $preprocess_list = "${dir}perl.h";
+ }
+
$used_expectation_enum = $used_opcode_enum = 0; # avoid warnings
if ($docc) {
! open(CPP,"${cc_cmd}/NoObj/PreProc=Sys\$Output $preprocess_list|")
! or die "$0: Can't preprocess $preprocess_list: $!\n";
}
else {
open(CPP,"$cpp_file") or die "$0: Can't read preprocessed file $cpp_file: $!\n";
***************
*** 198,203 ****
--- 206,212 ----
# Pull name from library module or header filespec
$spec =~ /^(\w+)$/ or $spec =~ /(\w+)\.h/i;
my $name = lc $1;
+ $name = 'perlio' if $name eq 'perliol';
$ckfunc = exists $checkh{$name} ? 1 : 0;
$scanname = $name if $ckfunc;
print "Header file transition: ckfunc = $ckfunc for $name.h\n" if $debug > 1;
diff -c 'perl-5.7.1/vms/perlvms.pod' 'perl-5.7.2/vms/perlvms.pod'
Index: ./vms/perlvms.pod
*** ./vms/perlvms.pod Tue Mar 6 04:07:27 2001
--- ./vms/perlvms.pod Mon Jul 9 17:11:33 2001
***************
*** 575,584 ****
Perl waits for the subprocess to complete before continuing
execution in the current process. As described in L<perlfunc>,
the return value of C<system> is a fake "status" which follows
! POSIX semantics; see the description of C<$?> in this document
! for more detail. The actual VMS exit status of the subprocess
! is available in C<$^S> (as long as you haven't used another Perl
! function that resets C<$?> and C<$^S> in the meantime).
=item time
--- 575,583 ----
Perl waits for the subprocess to complete before continuing
execution in the current process. As described in L<perlfunc>,
the return value of C<system> is a fake "status" which follows
! POSIX semantics unless the pragma C<use vmsish 'status'> is in
! effect; see the description of C<$?> in this document for more
! detail.
=item time
***************
*** 845,859 ****
otherwise, they contain the severity value shifted left one bit.
As a result, C<$?> will always be zero if the subprocess' exit
status indicated successful completion, and non-zero if a
! warning or error occurred. The actual VMS exit status may
! be found in C<$^S> (q.v.).
! =item $^S
!
! Under VMS, this is the 32-bit VMS status value returned by the
! last subprocess to complete. Unlike C<$?>, no manipulation
! is done to make this look like a POSIX wait(5) value, so it
! may be treated as a normal VMS status value.
=item $|
--- 844,854 ----
otherwise, they contain the severity value shifted left one bit.
As a result, C<$?> will always be zero if the subprocess' exit
status indicated successful completion, and non-zero if a
! warning or error occurred.
! The pragma C<use vmsish 'status'> makes C<$?> reflect the actual
! VMS exit status, instead of the default emulation of POSIX status
! described above.
=item $|
diff -c 'perl-5.7.1/vms/perly_c.vms' 'perl-5.7.2/vms/perly_c.vms'
Index: ./vms/perly_c.vms
Prereq: 1.8
*** ./vms/perly_c.vms Mon Mar 19 23:32:56 2001
--- ./vms/perly_c.vms Mon Jul 9 17:11:33 2001
***************
*** 1,6 ****
/* Postprocessed by vms_yfix.pl 1.11 to add VMS declarations of globals */
#ifndef lint
! static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91";
#endif
#define YYBYACC 1
#line 16 "perly.y"
--- 1,6 ----
/* Postprocessed by vms_yfix.pl 1.11 to add VMS declarations of globals */
#ifndef lint
! /* static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91"; */
#endif
#define YYBYACC 1
#line 16 "perly.y"
***************
*** 54,82 ****
#line 54 "perly.c"
#define YYERRCODE 256
static short yylhs[] = { -1,
! 50, 0, 8, 6, 9, 7, 10, 10, 10, 11,
! 11, 11, 11, 24, 24, 24, 24, 24, 24, 24,
! 14, 14, 14, 13, 13, 42, 42, 12, 12, 12,
! 12, 12, 12, 12, 26, 26, 27, 27, 28, 29,
! 30, 31, 32, 49, 49, 1, 1, 1, 1, 1,
! 2, 38, 38, 46, 51, 3, 4, 5, 39, 40,
! 40, 44, 44, 44, 45, 45, 41, 41, 52, 52,
! 54, 53, 15, 15, 15, 25, 25, 25, 36, 36,
! 36, 36, 36, 36, 36, 36, 55, 36, 37, 37,
17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
! 17, 16, 16, 16, 16, 16, 16, 16, 16, 16,
! 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
! 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
! 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
! 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
! 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
! 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
! 47, 47, 48, 48, 48, 48, 48, 33, 33, 34,
! 34, 34, 43, 23, 18, 19, 20, 21, 22, 35,
! 35, 35, 35,
};
static short yylen[] = { 2,
! 0, 2, 4, 0, 4, 0, 0, 2, 2, 2,
1, 2, 3, 1, 1, 3, 3, 3, 3, 3,
0, 2, 6, 7, 7, 0, 2, 8, 8, 10,
9, 8, 11, 3, 0, 1, 0, 1, 1, 1,
--- 54,82 ----
#line 54 "perly.c"
#define YYERRCODE 256
static short yylhs[] = { -1,
! 0, 9, 7, 6, 10, 8, 11, 11, 11, 12,
! 12, 12, 12, 25, 25, 25, 25, 25, 25, 25,
! 15, 15, 15, 14, 14, 43, 43, 13, 13, 13,
! 13, 13, 13, 13, 27, 27, 28, 28, 29, 30,
! 31, 32, 33, 54, 54, 1, 1, 1, 1, 1,
! 2, 39, 39, 47, 55, 3, 4, 5, 40, 41,
! 41, 45, 45, 45, 46, 46, 42, 42, 56, 56,
! 58, 57, 16, 16, 16, 26, 26, 26, 37, 37,
! 37, 37, 37, 37, 37, 37, 59, 37, 38, 38,
! 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
! 18, 50, 50, 50, 50, 50, 50, 50, 50, 50,
! 50, 50, 50, 50, 51, 51, 51, 51, 51, 51,
! 51, 51, 52, 52, 52, 52, 52, 53, 53, 53,
! 53, 53, 53, 17, 17, 17, 17, 17, 17, 17,
17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
! 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
! 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
! 17, 17, 17, 17, 48, 48, 49, 49, 49, 49,
! 49, 34, 34, 35, 35, 35, 44, 24, 19, 20,
! 21, 22, 23, 36, 36, 36, 36,
};
static short yylen[] = { 2,
! 2, 4, 0, 0, 4, 0, 0, 2, 2, 2,
1, 2, 3, 1, 1, 3, 3, 3, 3, 3,
0, 2, 6, 7, 7, 0, 2, 8, 8, 10,
9, 8, 11, 3, 0, 1, 0, 1, 1, 1,
***************
*** 87,865 ****
6, 3, 3, 5, 2, 4, 0, 5, 1, 1,
5, 4, 5, 4, 5, 6, 5, 4, 5, 4,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
! 3, 3, 3, 5, 3, 2, 2, 2, 2, 2,
! 2, 2, 2, 2, 1, 2, 3, 2, 3, 2,
! 4, 3, 5, 1, 1, 1, 1, 1, 1, 6,
! 5, 4, 5, 1, 1, 3, 4, 3, 2, 2,
! 4, 5, 4, 5, 1, 2, 2, 1, 2, 2,
! 2, 1, 3, 1, 3, 4, 4, 6, 1, 1,
! 3, 2, 3, 2, 1, 1, 1, 0, 1, 0,
! 1, 2, 1, 2, 2, 2, 2, 2, 2, 1,
! 1, 1, 1,
};
! static short yydefred[] = { 1,
0, 7, 0, 45, 58, 56, 0, 56, 56, 8,
46, 9, 11, 48, 0, 47, 49, 50, 0, 0,
! 0, 70, 71, 0, 14, 4, 169, 0, 0, 144,
! 0, 164, 0, 57, 57, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 12, 0, 0, 0, 0, 0, 0, 0, 10,
! 0, 0, 0, 0, 0, 136, 138, 0, 0, 0,
! 0, 170, 125, 52, 0, 59, 0, 69, 0, 0,
! 7, 190, 193, 192, 191, 0, 0, 0, 0, 0,
! 0, 4, 4, 4, 4, 4, 4, 0, 0, 0,
! 0, 0, 159, 0, 0, 0, 0, 85, 0, 188,
! 0, 150, 0, 0, 0, 0, 0, 0, 0, 175,
! 177, 176, 0, 184, 0, 0, 0, 0, 0, 0,
! 0, 0, 130, 0, 0, 0, 185, 186, 187, 189,
! 0, 34, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 121, 122, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 13, 0, 51, 61, 0,
! 0, 0, 0, 83, 0, 0, 87, 0, 0, 0,
! 0, 0, 0, 0, 4, 163, 165, 0, 0, 0,
! 0, 0, 0, 0, 132, 0, 148, 174, 0, 0,
! 171, 0, 0, 129, 27, 0, 0, 19, 0, 0,
! 0, 0, 73, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 89, 0,
! 0, 90, 0, 0, 101, 0, 0, 0, 0, 0,
! 0, 0, 146, 0, 0, 0, 0, 0, 0, 3,
! 0, 0, 167, 0, 0, 0, 42, 0, 43, 0,
! 0, 0, 0, 183, 0, 0, 36, 41, 0, 0,
! 0, 166, 182, 86, 0, 151, 0, 153, 0, 131,
! 173, 65, 0, 0, 0, 0, 98, 0, 0, 0,
! 0, 100, 94, 0, 92, 0, 142, 0, 147, 63,
! 68, 67, 55, 0, 54, 84, 0, 88, 133, 0,
! 0, 0, 0, 0, 0, 0, 0, 80, 152, 154,
! 141, 0, 0, 0, 99, 93, 0, 97, 95, 143,
! 91, 72, 168, 6, 0, 0, 0, 0, 0, 0,
! 0, 0, 140, 96, 81, 7, 28, 29, 0, 0,
! 24, 25, 0, 32, 0, 0, 0, 22, 0, 0,
! 0, 31, 5, 0, 30, 0, 0, 33, 0, 23,
};
static short yydgoto[] = { 1,
! 10, 11, 20, 100, 19, 91, 366, 94, 355, 3,
! 12, 13, 70, 371, 281, 72, 73, 74, 75, 76,
! 77, 78, 79, 287, 81, 288, 277, 279, 282, 290,
! 278, 280, 118, 210, 96, 82, 253, 85, 87, 190,
! 323, 152, 285, 267, 221, 14, 83, 133, 15, 2,
! 16, 17, 18, 89, 274,
};
static short yysindex[] = { 0,
! 0, 0, -199, 0, 0, 0, -53, 0, 0, 0,
! 0, 0, 0, 0, 646, 0, 0, 0, -217, -207,
! 44, 0, 0, -207, 0, 0, 0, -32, -32, 0,
! 66, 0, 2177, 0, 0, 69, 83, 93, 110, -35,
! 2177, 119, 121, 136, 1013, 973, -32, 1077, 1344, -146,
! 2177, 68, -32, 2177, 2177, 2177, 2177, 2177, 2177, 1384,
! 1424, 0, 2177, 2177, -32, -32, -32, -32, -152, 0,
! 470, 845, -13, -65, -63, 0, 0, 55, 137, 122,
! 138, 0, 0, 0, 60, 0, -70, 0, -66, -70,
! 0, 0, 0, 0, 0, 2177, 146, 2177, 1085, 60,
! -70, 0, 0, 0, 0, 0, 0, 152, 845, 153,
! 1464, 973, 0, 1085, 0, -65, 138, 0, 2177, 0,
! 160, 0, 1085, 2, 76, -52, 2177, 1085, 1524, 0,
! 0, 0, -96, 0, 138, -181, -181, -181, -112, -112,
! 123, -38, 0, -74, -181, -181, 0, 0, 0, 0,
! 60, 0, 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177,
! 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177,
! 2177, 2177, 2177, 0, 0, -16, 2177, 1731, 2177, 2177,
! 2177, 2177, 2177, 2177, 1791, 0, 2177, 0, 0, -88,
! -34, -88, 339, 0, 2177, 287, 0, -88, 2177, 2177,
! 2177, 2177, 173, 1850, 0, 0, 0, -33, 46, 180,
! 2177, 138, 1910, 2025, 0, 97, 0, 0, -31, -29,
! 0, 2177, 133, 0, 0, -237, -237, 0, -237, -237,
! -237, -69, 0, 1614, 1085, 684, 167, 107, 845, 3800,
! 1125, 405, 1164, 778, -228, -181, -181, 2177, 0, 2117,
! 2177, 0, 197, -48, 0, -9, -72, -45, -7, -42,
! 56, -36, 0, -4, 845, -10, -47, 2177, -47, 0,
! 216, 2177, 0, 2177, 60, -237, 0, 219, 0, 230,
! -237, 233, 237, 0, 242, 470, 0, 0, 246, 225,
! 2177, 0, 0, 0, 13, 0, 18, 0, 29, 0,
! 0, 0, 61, 2177, 2177, 54, 0, 32, 63, 2177,
! 165, 0, 0, 174, 0, 178, 0, 191, 0, 0,
! 0, 0, 0, 261, 0, 0, 350, 0, 0, 182,
! 182, 182, 182, 2177, 182, 2177, 281, 0, 0, 0,
! 0, 102, 1237, 202, 0, 0, 294, 0, 0, 0,
! 0, 0, 0, 0, -152, -152, -130, -130, 297, -152,
! 290, 182, 0, 0, 0, 0, 0, 0, 182, 318,
! 0, 0, 182, 0, 1850, -152, 407, 0, 2177, -152,
! 324, 0, 0, 326, 0, 182, 182, 0, -130, 0,
};
static short yyrindex[] = { 0,
! 0, 0, 243, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 236, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 36, 451, 0, 0, 2208, 2271, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 115, 0,
! -12, 939, 2325, 2385, 2463, 0, 0, 2510, 2561, 0,
! 1220, 0, 0, 0, 0, 0, -44, 0, 0, -44,
! 0, 0, 0, 0, 0, 2271, 0, 0, 3846, 0,
! -105, 0, 0, 0, 0, 0, 0, 0, 2612, 0,
! 0, 327, 0, 3883, 522, 583, 3032, 0, 0, 0,
! 2621, 0, 3893, 2385, 0, 0, 2271, 3930, 0, 0,
! 0, 0, 2667, 0, 3092, 3374, 3418, 3458, 3219, 3331,
! 2746, 0, 0, 0, 3496, 3567, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 2797, 0, 0, -23,
- 0, -23, 913, 0, 327, 0, 0, 247, 336, 0,
- 0, 0, 0, 333, 0, 0, 0, 0, 352, 0,
- 0, 3138, 0, 0, 0, 0, 0, 0, 0, 2857,
- 0, 0, 2903, 0, 0, -8, -2, 0, 7, 33,
- 42, 2255, 0, -28, 3968, 1822, 3732, 3769, 3023, 0,
- 4119, 4082, 4021, 4005, 1044, 3610, 3694, 0, 0, 0,
- 0, 0, 2949, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 3657, -21, 0, 345, 0, 0,
- 0, 0, 0, 2271, 0, 71, 0, 0, 0, 0,
- 364, 0, 0, 0, 0, 86, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 327,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 355, 0, 0, 0, 0,
! 0, 0, 2972, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 115, 115, 175, 175, 0, 115,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 374, 115, 913, 0, 0, 115,
! 0, 0, 0, 0, 0, 0, 0, 0, 175, 0,
};
static short yygindex[] = { 0,
! 0, 0, 164, 383, 0, 14, 0, 37, 655, -89,
! 0, 0, 0, -336, -15, 3415, 0, 2211, 368, 369,
! 0, 0, 0, 410, 916, 0, 0, 273, -163, 62,
! 94, 249, -71, -186, 634, 0, 0, 0, 428, -46,
! 184, 118, 0, -149, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0,
};
! #define YYTABLESIZE 4423
static short yytable[] = { 71,
! 65, 193, 223, 65, 107, 22, 216, 292, 271, 301,
! 311, 321, 111, 314, 60, 111, 316, 60, 224, 65,
! 313, 372, 318, 250, 194, 181, 178, 183, 15, 111,
! 111, 312, 18, 126, 111, 62, 319, 64, 39, 84,
! 289, 214, 269, 192, 142, 144, 15, 16, 275, 86,
! 18, 69, 390, 338, 198, 217, 39, 180, 339, 182,
! 163, 164, 158, 159, 111, 16, 4, 5, 6, 340,
! 7, 8, 345, 17, 251, 26, 155, 179, 60, 155,
! 172, 113, 20, 173, 122, 315, 174, 175, 176, 293,
! 26, 17, 181, 155, 155, 208, 209, 9, 155, 62,
! 20, 64, 88, 65, 67, 98, 248, 129, 102, 177,
! 127, 38, 344, 219, 26, 199, 200, 201, 202, 203,
! 204, 188, 103, 347, 180, 151, 40, 337, 155, 38,
! 173, 66, 104, 174, 175, 176, 197, 226, 227, 229,
! 230, 231, 232, 233, 15, 369, 370, 26, 317, 105,
! 26, 26, 26, 341, 26, 346, 26, 26, 110, 26,
! 111, 254, 256, 257, 258, 259, 260, 261, 262, 264,
! 359, 23, 24, 26, 21, 112, 185, 184, 26, 209,
! 186, 187, 26, 276, 227, 195, 227, 225, 286, 189,
! 191, 205, 60, 206, 363, 295, 324, 297, 299, 213,
! 215, 220, 328, 21, 176, 26, 303, 21, 65, 266,
! 21, 21, 21, 222, 21, 384, 21, 21, 291, 21,
! 294, 300, 268, 304, 92, 158, 159, 158, 159, 93,
! 302, 159, 306, 21, 308, 309, 310, 26, 21, 26,
! 26, 249, 2, 111, 111, 111, 111, 158, 159, 320,
! 111, 158, 159, 60, 158, 159, 326, 158, 159, 330,
! 106, 158, 159, 158, 159, 21, 158, 159, 158, 159,
! 331, 111, 111, 332, 111, 44, 377, 333, 44, 44,
! 44, 334, 44, 336, 44, 44, 335, 44, 342, 348,
! 158, 159, 158, 159, 209, 158, 159, 21, 349, 21,
! 21, 44, 350, 322, 354, 322, 44, 155, 155, 155,
! 155, 329, 158, 159, 155, 351, 155, 158, 159, 352,
! 276, 362, 155, 155, 155, 155, 364, 273, 158, 159,
! 272, 158, 159, 44, 365, 155, 155, 373, 155, 155,
! 155, 155, 155, 155, 155, 158, 159, 155, 375, 166,
! 155, 155, 155, 158, 159, 158, 159, 379, 53, 71,
! 158, 159, 158, 159, 386, 44, 387, 180, 44, 62,
! 26, 26, 26, 26, 26, 26, 37, 26, 26, 26,
! 26, 26, 26, 26, 26, 26, 26, 26, 26, 26,
! 353, 35, 181, 26, 26, 163, 26, 26, 26, 26,
! 26, 158, 159, 178, 40, 26, 26, 26, 26, 26,
! 26, 26, 166, 37, 35, 172, 26, 101, 173, 131,
! 132, 174, 175, 176, 80, 26, 228, 26, 26, 361,
! 21, 21, 21, 21, 21, 21, 381, 21, 21, 21,
! 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
! 283, 90, 325, 21, 21, 0, 21, 21, 21, 21,
! 21, 0, 0, 270, 0, 21, 21, 21, 21, 21,
! 21, 21, 367, 368, 0, 172, 21, 374, 173, 0,
! 0, 174, 175, 176, 0, 21, 0, 21, 21, 0,
! 0, 162, 0, 382, 162, 0, 0, 385, 44, 44,
! 44, 44, 44, 44, 0, 44, 44, 44, 162, 162,
! 0, 44, 0, 162, 44, 44, 44, 44, 0, 0,
! 0, 44, 44, 0, 44, 44, 44, 44, 44, 0,
! 0, 383, 0, 44, 44, 44, 44, 44, 44, 0,
! 0, 0, 0, 162, 44, 0, 0, 0, 0, 0,
! 0, 0, 0, 44, 190, 44, 44, 190, 190, 190,
! 0, 190, 169, 190, 190, 169, 190, 160, 0, 0,
! 0, 0, 0, 161, 162, 163, 164, 0, 0, 169,
! 169, 0, 0, 0, 169, 190, 0, 0, 0, 165,
! 167, 168, 169, 170, 171, 172, 0, 0, 173, 0,
! 0, 174, 175, 176, 4, 5, 6, 0, 7, 8,
! 0, 0, 190, 0, 169, 191, 0, 0, 191, 191,
! 191, 0, 191, 134, 191, 191, 134, 191, 0, 0,
! 160, 0, 0, 0, 0, 9, 161, 162, 163, 164,
! 134, 134, 0, 0, 0, 134, 191, 190, 0, 0,
! 0, 0, 165, 167, 168, 169, 170, 171, 172, 0,
! 0, 173, 97, 0, 174, 175, 176, 0, 0, 0,
! 0, 0, 4, 5, 6, 134, 7, 8, 55, 119,
! 120, 65, 67, 53, 0, 60, 134, 68, 64, 0,
! 63, 161, 162, 163, 164, 0, 0, 0, 147, 148,
! 149, 150, 0, 9, 62, 0, 0, 0, 191, 66,
! 169, 170, 171, 172, 0, 0, 173, 0, 0, 174,
! 175, 176, 162, 162, 162, 162, 0, 0, 0, 162,
! 0, 162, 0, 0, 0, 0, 61, 162, 162, 162,
! 162, 153, 154, 155, 156, 211, 0, 0, 157, 0,
! 162, 162, 0, 162, 162, 162, 162, 162, 162, 162,
! 0, 0, 162, 0, 0, 162, 162, 162, 26, 158,
! 159, 56, 0, 0, 0, 0, 0, 0, 190, 190,
! 190, 190, 190, 0, 190, 190, 190, 0, 0, 0,
! 190, 0, 0, 169, 169, 169, 169, 0, 0, 0,
! 169, 190, 169, 190, 190, 190, 190, 190, 169, 169,
! 169, 169, 190, 190, 190, 190, 190, 190, 0, 0,
! 0, 169, 169, 190, 169, 169, 169, 169, 169, 169,
! 169, 0, 190, 169, 190, 190, 169, 169, 169, 191,
! 191, 191, 191, 191, 0, 191, 191, 191, 0, 0,
! 0, 191, 0, 0, 134, 134, 134, 134, 0, 0,
! 0, 134, 191, 134, 191, 191, 191, 191, 191, 134,
! 134, 134, 134, 191, 191, 191, 191, 191, 191, 0,
! 0, 0, 134, 134, 191, 134, 134, 134, 134, 134,
! 134, 134, 0, 191, 134, 191, 191, 134, 134, 134,
! 0, 25, 27, 28, 29, 30, 31, 166, 32, 33,
! 34, 0, 0, 0, 35, 0, 0, 36, 37, 38,
! 39, 0, 0, 0, 40, 41, 0, 42, 43, 44,
! 45, 46, 0, 0, 0, 0, 47, 48, 49, 50,
! 51, 52, 0, 0, 0, 44, 0, 54, 44, 44,
! 44, 0, 44, 0, 44, 44, 57, 44, 58, 59,
! 0, 117, 0, 0, 0, 0, 0, 0, 0, 135,
! 161, 44, 163, 164, 0, 0, 44, 0, 0, 78,
! 0, 0, 78, 0, 0, 356, 357, 358, 0, 360,
! 0, 171, 172, 0, 0, 173, 78, 78, 174, 175,
! 176, 0, 0, 44, 0, 55, 0, 0, 65, 67,
! 53, 117, 60, 0, 68, 64, 376, 63, 0, 0,
! 0, 0, 0, 378, 0, 0, 0, 380, 0, 0,
! 0, 78, 0, 0, 212, 44, 66, 0, 44, 0,
! 388, 389, 117, 0, 0, 55, 0, 0, 65, 67,
! 53, 0, 60, 0, 68, 64, 0, 63, 0, 0,
! 0, 0, 0, 61, 161, 162, 163, 164, 0, 0,
! 0, 0, 0, 0, 0, 0, 66, 0, 0, 0,
! 0, 0, 0, 0, 106, 171, 172, 106, 0, 173,
! 0, 0, 174, 175, 176, 26, 0, 0, 56, 0,
! 0, 106, 106, 61, 0, 0, 106, 0, 0, 55,
! 0, 0, 65, 67, 53, 0, 60, 0, 68, 64,
! 0, 63, 0, 0, 0, 160, 0, 0, 0, 0,
! 0, 161, 162, 163, 164, 26, 106, 0, 56, 0,
! 66, 0, 0, 0, 0, 0, 0, 165, 167, 168,
! 169, 170, 171, 172, 0, 0, 173, 0, 0, 174,
! 175, 176, 0, 0, 0, 0, 0, 61, 44, 44,
! 44, 44, 44, 44, 0, 44, 44, 44, 0, 0,
! 0, 44, 0, 117, 44, 44, 44, 44, 0, 117,
! 0, 44, 44, 0, 44, 44, 44, 44, 44, 26,
! 0, 0, 56, 44, 44, 44, 44, 44, 44, 0,
! 78, 78, 78, 78, 44, 0, 0, 78, 0, 0,
! 0, 0, 0, 44, 0, 44, 44, 0, 0, 115,
! 28, 29, 30, 31, 93, 32, 33, 34, 78, 78,
! 0, 35, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 41, 0, 42, 43, 44, 45, 46, 0,
! 75, 0, 0, 47, 48, 49, 50, 51, 52, 27,
! 28, 29, 30, 31, 54, 32, 33, 34, 75, 0,
! 0, 35, 0, 57, 0, 58, 59, 0, 0, 0,
! 0, 0, 41, 0, 42, 43, 44, 45, 46, 166,
! 0, 0, 0, 47, 48, 49, 50, 51, 52, 0,
! 0, 0, 75, 0, 54, 106, 106, 106, 106, 0,
! 0, 0, 106, 57, 106, 58, 59, 0, 0, 0,
! 106, 106, 0, 121, 28, 29, 30, 31, 0, 32,
! 33, 34, 0, 106, 106, 35, 106, 106, 106, 106,
! 106, 106, 0, 0, 0, 0, 41, 0, 42, 43,
44, 45, 46, 0, 0, 0, 0, 47, 48, 49,
! 50, 51, 52, 163, 164, 0, 55, 0, 54, 65,
! 67, 53, 0, 60, 0, 68, 64, 57, 63, 58,
! 59, 0, 171, 172, 0, 0, 173, 0, 0, 174,
! 175, 176, 125, 0, 0, 0, 0, 66, 0, 0,
! 0, 161, 162, 163, 164, 0, 55, 0, 0, 65,
! 67, 53, 0, 60, 141, 68, 64, 0, 63, 168,
! 169, 170, 171, 172, 61, 0, 173, 0, 0, 174,
! 175, 176, 0, 0, 0, 0, 0, 66, 0, 0,
! 161, 162, 163, 164, 0, 0, 55, 0, 0, 65,
! 67, 53, 0, 60, 0, 68, 64, 0, 63, 56,
! 170, 171, 172, 0, 61, 173, 0, 0, 174, 175,
! 176, 0, 0, 0, 0, 0, 0, 66, 0, 0,
! 0, 75, 75, 75, 75, 0, 55, 0, 75, 65,
! 67, 53, 0, 60, 207, 68, 64, 0, 63, 56,
! 0, 0, 0, 0, 61, 0, 143, 160, 0, 75,
! 75, 0, 0, 161, 162, 163, 164, 66, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 167, 168, 169, 170, 171, 172, 0, 0, 173, 56,
! 0, 174, 175, 176, 61, 0, 55, 0, 0, 65,
! 67, 53, 0, 60, 218, 68, 64, 0, 63, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 66, 0, 56,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 27, 28, 29, 30, 31, 0, 32, 33, 34, 0,
! 0, 0, 35, 0, 61, 0, 0, 0, 0, 0,
! 0, 0, 0, 41, 0, 42, 43, 44, 45, 46,
0, 0, 0, 0, 47, 48, 49, 50, 51, 52,
! 27, 28, 29, 30, 31, 54, 32, 33, 34, 56,
! 0, 0, 35, 0, 57, 0, 58, 59, 0, 0,
! 0, 0, 0, 41, 0, 42, 43, 44, 45, 46,
! 0, 0, 0, 0, 47, 48, 49, 50, 51, 52,
! 27, 28, 29, 30, 31, 54, 32, 33, 34, 0,
! 0, 0, 35, 0, 57, 0, 58, 59, 0, 0,
! 0, 0, 0, 41, 0, 42, 43, 44, 45, 46,
! 0, 0, 0, 0, 47, 48, 49, 50, 51, 52,
! 27, 28, 29, 30, 31, 54, 32, 33, 34, 0,
! 0, 0, 35, 0, 57, 0, 58, 59, 0, 0,
! 0, 0, 0, 41, 0, 42, 43, 44, 45, 46,
! 0, 0, 0, 0, 47, 48, 49, 50, 51, 52,
! 0, 0, 0, 55, 0, 54, 65, 67, 53, 0,
! 60, 255, 68, 64, 57, 63, 58, 59, 0, 0,
27, 28, 29, 30, 31, 0, 32, 33, 34, 0,
0, 0, 35, 0, 66, 0, 0, 0, 0, 0,
0, 0, 0, 41, 0, 42, 43, 44, 45, 46,
0, 0, 0, 0, 47, 48, 49, 50, 51, 52,
0, 61, 0, 55, 0, 54, 65, 67, 53, 0,
! 60, 263, 68, 64, 57, 63, 58, 59, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 66, 0, 56, 0, 0, 0,
- 0, 0, 108, 0, 0, 108, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 108,
- 108, 61, 55, 0, 108, 65, 67, 53, 0, 60,
- 0, 68, 64, 0, 63, 0, 0, 0, 0, 0,
- 161, 162, 163, 164, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 66, 108, 0, 56, 167, 168, 169,
- 170, 171, 172, 0, 0, 173, 0, 0, 174, 175,
- 176, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 61, 0, 55, 0, 0, 65, 67, 53, 0, 60,
- 296, 68, 64, 0, 63, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 66, 0, 56, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 27, 28, 29,
30, 31, 0, 32, 33, 34, 0, 0, 0, 35,
! 61, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 41, 0, 42, 43, 44, 45, 46, 0, 0, 0,
! 0, 47, 48, 49, 50, 51, 52, 0, 0, 0,
! 0, 0, 54, 0, 0, 56, 0, 0, 0, 0,
0, 57, 0, 58, 59, 0, 0, 27, 28, 29,
! 30, 31, 0, 32, 33, 34, 0, 55, 0, 35,
! 65, 67, 53, 0, 60, 298, 68, 64, 0, 63,
41, 0, 42, 43, 44, 45, 46, 0, 0, 0,
! 0, 47, 48, 49, 50, 51, 52, 0, 66, 0,
! 0, 0, 54, 108, 108, 108, 108, 0, 0, 0,
! 108, 57, 108, 58, 59, 25, 27, 28, 29, 30,
! 31, 0, 32, 33, 34, 61, 0, 0, 35, 0,
! 0, 108, 108, 0, 108, 108, 108, 108, 108, 41,
! 0, 42, 43, 44, 45, 46, 0, 0, 0, 0,
! 47, 48, 49, 50, 51, 52, 0, 0, 0, 55,
! 56, 54, 65, 67, 53, 0, 60, 307, 68, 64,
! 57, 63, 58, 59, 0, 0, 27, 28, 29, 30,
! 31, 0, 32, 33, 34, 0, 0, 0, 35, 0,
! 66, 0, 0, 0, 0, 0, 0, 0, 0, 41,
! 0, 42, 43, 44, 45, 46, 0, 0, 0, 0,
! 47, 48, 49, 50, 51, 52, 0, 61, 0, 55,
! 0, 54, 65, 67, 53, 0, 60, 0, 68, 64,
! 57, 63, 58, 59, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 95, 95,
! 66, 0, 56, 0, 0, 0, 0, 0, 158, 0,
! 108, 158, 0, 0, 0, 0, 116, 95, 124, 0,
! 0, 0, 130, 95, 0, 158, 158, 61, 0, 0,
! 158, 0, 0, 0, 0, 95, 95, 95, 95, 0,
! 0, 27, 28, 29, 30, 31, 0, 32, 33, 34,
! 0, 0, 0, 35, 0, 74, 0, 0, 74, 0,
! 158, 0, 56, 0, 41, 0, 42, 43, 44, 45,
! 46, 178, 0, 74, 178, 47, 48, 49, 50, 51,
! 52, 0, 116, 0, 0, 0, 54, 0, 178, 178,
! 0, 0, 0, 178, 0, 57, 0, 58, 59, 0,
! 0, 0, 0, 0, 0, 0, 0, 74, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 178, 0, 139, 0, 0, 139, 0,
- 0, 0, 0, 27, 28, 29, 30, 31, 0, 32,
- 33, 34, 139, 139, 0, 35, 252, 139, 0, 0,
- 0, 0, 0, 0, 0, 0, 41, 0, 42, 43,
- 44, 45, 46, 0, 0, 0, 0, 47, 48, 49,
- 50, 51, 52, 284, 0, 0, 0, 139, 54, 0,
- 0, 0, 0, 0, 0, 134, 0, 57, 134, 58,
- 59, 0, 0, 27, 28, 29, 30, 31, 0, 32,
- 33, 34, 134, 134, 0, 35, 0, 134, 0, 0,
- 0, 0, 0, 0, 0, 0, 41, 0, 42, 43,
- 44, 45, 46, 0, 0, 0, 0, 47, 48, 49,
- 50, 51, 52, 0, 0, 0, 0, 134, 54, 158,
- 158, 158, 158, 0, 0, 0, 158, 57, 158, 58,
- 59, 0, 0, 0, 158, 158, 158, 158, 0, 0,
- 0, 0, 0, 137, 0, 0, 137, 158, 158, 0,
- 158, 158, 158, 158, 158, 158, 158, 0, 0, 158,
- 137, 137, 158, 158, 158, 137, 74, 74, 74, 74,
- 0, 0, 0, 74, 0, 0, 0, 0, 0, 0,
- 0, 0, 178, 178, 178, 178, 0, 0, 0, 178,
- 135, 178, 0, 135, 74, 137, 0, 178, 178, 178,
- 178, 0, 0, 0, 0, 0, 0, 135, 135, 0,
- 178, 178, 135, 178, 178, 178, 178, 178, 178, 178,
- 0, 0, 178, 0, 0, 178, 178, 178, 0, 0,
- 0, 0, 0, 0, 0, 0, 139, 139, 139, 139,
- 0, 145, 135, 139, 145, 139, 0, 0, 0, 0,
- 0, 139, 139, 139, 139, 0, 0, 0, 145, 145,
- 0, 0, 0, 145, 139, 139, 0, 139, 139, 139,
- 139, 139, 139, 139, 0, 0, 139, 0, 0, 139,
- 139, 139, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 156, 145, 0, 156, 134, 134, 134, 134,
- 0, 169, 0, 134, 169, 134, 0, 0, 0, 156,
- 156, 134, 134, 134, 134, 0, 0, 0, 169, 169,
- 0, 0, 0, 169, 134, 134, 0, 134, 134, 134,
- 134, 134, 134, 134, 0, 0, 134, 0, 0, 134,
- 134, 134, 0, 0, 156, 0, 0, 172, 0, 0,
- 172, 0, 0, 169, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 172, 172, 0, 0, 0, 172,
- 0, 0, 0, 0, 137, 137, 137, 137, 0, 0,
- 0, 137, 0, 137, 0, 0, 0, 0, 0, 137,
- 137, 137, 137, 0, 0, 0, 0, 0, 0, 172,
- 0, 0, 137, 137, 0, 137, 137, 137, 137, 137,
- 137, 137, 0, 0, 137, 0, 0, 137, 137, 137,
- 0, 135, 135, 135, 135, 0, 128, 0, 135, 128,
- 135, 0, 0, 0, 0, 0, 135, 135, 135, 135,
- 0, 0, 0, 128, 128, 0, 0, 0, 128, 135,
- 135, 0, 135, 135, 135, 135, 135, 135, 135, 0,
- 0, 135, 0, 0, 135, 135, 135, 0, 0, 0,
- 0, 0, 145, 145, 145, 145, 0, 76, 128, 145,
- 76, 145, 0, 0, 0, 0, 0, 145, 145, 145,
- 145, 0, 0, 0, 76, 76, 0, 0, 0, 76,
- 145, 145, 0, 145, 145, 145, 145, 145, 145, 145,
- 0, 0, 145, 0, 0, 145, 145, 145, 0, 0,
- 0, 0, 0, 156, 156, 156, 156, 0, 0, 76,
- 156, 0, 169, 169, 169, 169, 0, 66, 0, 169,
- 66, 169, 0, 0, 0, 0, 0, 169, 169, 169,
- 169, 156, 156, 0, 66, 66, 0, 0, 0, 66,
- 169, 169, 0, 169, 169, 169, 169, 169, 169, 169,
- 0, 0, 169, 0, 0, 169, 169, 169, 172, 172,
- 172, 172, 0, 127, 0, 172, 127, 172, 0, 66,
- 0, 0, 0, 172, 172, 172, 172, 0, 0, 0,
- 127, 127, 0, 0, 0, 127, 172, 172, 0, 172,
- 172, 172, 172, 172, 172, 172, 0, 0, 172, 0,
- 0, 172, 172, 172, 0, 0, 0, 0, 0, 82,
- 0, 0, 82, 0, 0, 127, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 82, 82, 0, 0,
- 0, 82, 114, 0, 0, 114, 0, 128, 128, 128,
- 128, 0, 0, 0, 128, 0, 128, 0, 0, 114,
- 114, 0, 128, 128, 128, 128, 0, 0, 0, 0,
- 0, 82, 0, 0, 0, 128, 128, 0, 128, 128,
- 128, 128, 128, 128, 128, 0, 0, 128, 0, 0,
- 128, 128, 128, 102, 114, 0, 102, 0, 76, 76,
- 76, 76, 179, 0, 0, 76, 0, 76, 0, 0,
- 102, 102, 0, 76, 76, 76, 76, 0, 0, 179,
- 179, 0, 0, 0, 179, 0, 76, 76, 0, 76,
- 76, 76, 76, 76, 76, 76, 0, 0, 76, 0,
- 0, 76, 76, 76, 0, 102, 0, 0, 0, 0,
- 0, 0, 0, 0, 179, 0, 0, 0, 66, 66,
- 66, 66, 157, 0, 0, 66, 0, 66, 0, 0,
- 0, 0, 0, 66, 66, 66, 66, 0, 0, 157,
- 157, 0, 0, 0, 157, 0, 66, 66, 0, 66,
- 66, 66, 66, 66, 66, 66, 0, 0, 66, 0,
- 0, 66, 66, 66, 127, 127, 127, 127, 79, 0,
- 0, 127, 0, 127, 157, 0, 0, 0, 0, 127,
- 127, 127, 127, 0, 0, 79, 79, 0, 0, 0,
- 79, 0, 127, 127, 0, 127, 127, 127, 127, 127,
- 127, 127, 0, 0, 127, 0, 0, 127, 127, 127,
- 82, 82, 82, 82, 0, 0, 0, 82, 0, 82,
- 79, 0, 0, 0, 0, 82, 82, 82, 82, 0,
- 0, 0, 0, 114, 114, 114, 114, 0, 82, 82,
- 114, 82, 82, 82, 82, 82, 82, 82, 0, 123,
- 82, 0, 123, 82, 82, 82, 0, 0, 0, 0,
- 0, 114, 114, 0, 114, 0, 123, 123, 0, 0,
- 0, 123, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 102, 102, 102, 102, 0, 0,
- 0, 102, 0, 179, 179, 179, 179, 0, 0, 0,
- 179, 123, 179, 0, 0, 0, 0, 0, 179, 179,
- 179, 179, 102, 102, 0, 0, 0, 0, 0, 0,
- 0, 179, 179, 0, 179, 179, 179, 179, 179, 179,
- 179, 0, 0, 179, 0, 0, 179, 179, 179, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 157, 157, 157, 157, 0, 0, 0,
! 157, 124, 157, 0, 124, 0, 0, 0, 157, 157,
! 157, 157, 0, 0, 0, 0, 0, 0, 124, 124,
! 0, 157, 157, 124, 157, 157, 157, 157, 157, 157,
! 157, 0, 0, 157, 0, 0, 157, 157, 157, 79,
! 79, 79, 79, 0, 118, 0, 79, 118, 79, 0,
! 0, 0, 0, 124, 79, 79, 79, 79, 0, 0,
! 0, 118, 118, 0, 0, 0, 118, 79, 79, 0,
! 79, 79, 79, 79, 79, 79, 79, 99, 0, 79,
! 0, 0, 79, 79, 79, 109, 0, 0, 119, 114,
! 0, 119, 123, 0, 0, 128, 118, 0, 0, 136,
! 137, 138, 139, 140, 0, 119, 119, 145, 146, 0,
! 119, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 123, 123, 123, 123, 0, 0, 0, 123, 120, 123,
! 0, 120, 0, 0, 0, 123, 123, 123, 123, 0,
! 119, 0, 196, 0, 0, 120, 120, 0, 123, 123,
! 120, 123, 123, 123, 123, 123, 123, 123, 0, 0,
! 123, 0, 0, 0, 0, 0, 116, 0, 0, 116,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 120, 0, 0, 116, 116, 0, 0, 0, 116, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 234, 235, 236, 237, 238, 239,
! 240, 241, 242, 243, 244, 245, 246, 247, 116, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 265, 124, 124, 124, 124, 0, 117, 0, 124,
! 117, 124, 0, 0, 0, 0, 0, 124, 124, 124,
! 124, 0, 0, 0, 117, 117, 0, 0, 0, 117,
! 124, 124, 0, 124, 124, 124, 124, 124, 124, 124,
! 0, 0, 124, 0, 0, 118, 118, 118, 118, 0,
! 115, 0, 118, 115, 118, 0, 0, 0, 0, 117,
! 118, 118, 118, 118, 0, 0, 0, 115, 115, 0,
! 0, 0, 115, 118, 118, 0, 118, 118, 118, 118,
! 118, 118, 118, 0, 0, 0, 327, 0, 0, 119,
! 119, 119, 119, 0, 0, 0, 119, 77, 119, 0,
! 77, 0, 115, 0, 119, 119, 119, 119, 0, 0,
! 0, 0, 0, 0, 77, 77, 0, 119, 119, 343,
! 119, 119, 119, 119, 119, 119, 119, 0, 0, 120,
! 120, 120, 120, 0, 103, 0, 120, 103, 120, 0,
! 0, 0, 0, 0, 120, 120, 120, 120, 0, 77,
! 0, 103, 103, 0, 0, 0, 103, 120, 120, 0,
! 120, 120, 120, 120, 120, 120, 120, 116, 116, 116,
! 116, 0, 104, 0, 116, 104, 116, 0, 0, 0,
! 0, 0, 116, 116, 116, 116, 103, 0, 0, 104,
! 104, 0, 0, 0, 104, 116, 116, 0, 116, 116,
! 116, 116, 116, 116, 116, 0, 0, 0, 0, 105,
! 0, 0, 105, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 104, 0, 105, 105, 0, 0,
! 0, 105, 0, 0, 0, 0, 0, 0, 117, 117,
! 117, 117, 0, 0, 0, 117, 0, 117, 0, 0,
! 0, 0, 0, 117, 117, 117, 117, 305, 0, 0,
! 0, 105, 166, 0, 0, 0, 117, 117, 0, 117,
! 117, 117, 117, 117, 117, 117, 0, 0, 0, 0,
! 0, 115, 115, 115, 115, 0, 161, 0, 115, 161,
! 115, 0, 0, 0, 0, 0, 115, 115, 115, 115,
! 0, 0, 0, 161, 161, 0, 0, 0, 161, 115,
! 115, 0, 115, 115, 115, 115, 115, 115, 115, 0,
! 0, 0, 0, 160, 0, 0, 160, 0, 77, 77,
! 77, 77, 0, 149, 0, 77, 149, 0, 161, 0,
! 160, 160, 0, 0, 0, 160, 0, 0, 0, 0,
! 149, 149, 0, 0, 0, 149, 77, 77, 0, 0,
! 0, 0, 0, 0, 0, 103, 103, 103, 103, 0,
! 126, 0, 103, 126, 103, 160, 0, 0, 0, 0,
! 103, 103, 103, 103, 0, 149, 0, 126, 126, 0,
! 0, 0, 126, 103, 103, 0, 103, 103, 103, 103,
! 103, 103, 103, 104, 104, 104, 104, 0, 107, 0,
! 104, 107, 104, 0, 0, 0, 0, 0, 104, 104,
! 104, 104, 126, 0, 0, 107, 107, 0, 0, 0,
! 107, 104, 104, 0, 104, 104, 104, 104, 104, 104,
! 105, 105, 105, 105, 0, 109, 0, 105, 109, 105,
! 0, 0, 0, 0, 0, 105, 105, 0, 105, 0,
! 107, 110, 109, 109, 110, 0, 0, 109, 105, 105,
! 0, 105, 105, 105, 105, 105, 105, 0, 110, 110,
! 160, 0, 0, 110, 0, 0, 161, 162, 163, 164,
! 0, 0, 0, 0, 0, 0, 0, 109, 0, 0,
! 0, 0, 165, 167, 168, 169, 170, 171, 172, 0,
! 0, 173, 0, 110, 174, 175, 176, 161, 161, 161,
! 161, 0, 112, 0, 161, 112, 161, 0, 0, 0,
! 0, 0, 161, 161, 0, 0, 0, 0, 0, 112,
! 112, 0, 0, 0, 112, 161, 161, 0, 161, 161,
! 161, 161, 161, 0, 160, 160, 160, 160, 0, 113,
! 0, 160, 113, 160, 149, 149, 149, 149, 0, 160,
! 160, 149, 0, 149, 112, 0, 113, 113, 0, 149,
! 149, 113, 160, 160, 0, 160, 160, 160, 160, 160,
! 0, 0, 149, 149, 0, 149, 149, 149, 149, 149,
! 0, 126, 126, 126, 126, 0, 0, 0, 126, 0,
! 126, 113, 0, 0, 0, 0, 126, 126, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 126,
! 126, 0, 126, 126, 126, 126, 126, 0, 0, 107,
! 107, 107, 107, 0, 0, 0, 107, 0, 107, 0,
! 0, 0, 0, 0, 0, 107, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 107, 107, 0,
! 107, 107, 107, 107, 107, 0, 109, 109, 109, 109,
! 0, 0, 0, 109, 0, 109, 0, 0, 0, 0,
! 0, 0, 110, 110, 110, 110, 0, 0, 0, 110,
! 0, 110, 0, 0, 109, 109, 0, 109, 109, 109,
! 109, 109, 0, 0, 0, 0, 0, 0, 0, 0,
! 110, 110, 0, 110, 110, 110, 110, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 112, 112, 112, 112, 0, 0, 0,
! 112, 0, 112, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 112, 112, 0, 112, 112, 112, 0, 0, 0,
! 113, 113, 113, 113, 0, 0, 0, 113, 0, 113,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 113, 113,
! 0, 113, 113,
};
static short yycheck[] = { 15,
! 36, 91, 41, 36, 40, 59, 59, 41, 195, 41,
! 59, 59, 41, 59, 59, 44, 59, 123, 93, 36,
! 93, 358, 59, 40, 96, 91, 40, 91, 41, 58,
! 59, 41, 41, 49, 63, 59, 41, 59, 41, 257,
! 204, 40, 192, 90, 60, 61, 59, 41, 198, 257,
! 59, 15, 389, 41, 101, 127, 59, 123, 41, 123,
! 289, 290, 300, 301, 93, 59, 266, 267, 268, 41,
! 270, 271, 41, 41, 91, 123, 41, 91, 123, 44,
! 309, 45, 41, 312, 48, 93, 315, 316, 317, 44,
! 123, 59, 91, 58, 59, 111, 112, 297, 63, 123,
! 59, 123, 59, 36, 37, 40, 123, 40, 40, 123,
! 257, 41, 59, 129, 0, 102, 103, 104, 105, 106,
! 107, 85, 40, 310, 123, 278, 41, 291, 93, 59,
! 312, 64, 40, 315, 316, 317, 100, 153, 154, 155,
! 156, 157, 158, 159, 59, 276, 277, 33, 93, 40,
! 36, 37, 38, 93, 40, 93, 42, 43, 40, 45,
! 40, 177, 178, 179, 180, 181, 182, 183, 184, 185,
! 334, 8, 9, 59, 0, 40, 40, 123, 64, 195,
! 59, 44, 123, 199, 200, 40, 202, 151, 204, 260,
! 257, 40, 298, 41, 93, 211, 268, 213, 214, 40,
! 125, 298, 274, 257, 317, 91, 222, 33, 36, 298,
! 36, 37, 38, 91, 40, 379, 42, 43, 205, 45,
! 41, 125, 257, 91, 257, 300, 301, 300, 301, 262,
! 260, 301, 248, 59, 250, 251, 40, 123, 64, 125,
! 126, 258, 0, 272, 273, 274, 275, 300, 301, 260,
! 279, 300, 301, 298, 300, 301, 41, 300, 301, 41,
! 296, 300, 301, 300, 301, 91, 300, 301, 300, 301,
! 41, 300, 301, 41, 303, 33, 366, 41, 36, 37,
! 38, 40, 40, 59, 42, 43, 41, 45, 304, 125,
! 300, 301, 300, 301, 310, 300, 301, 123, 125, 125,
! 126, 59, 125, 267, 123, 269, 64, 272, 273, 274,
! 275, 275, 300, 301, 279, 125, 281, 300, 301, 59,
! 336, 41, 287, 288, 289, 290, 125, 41, 300, 301,
! 44, 300, 301, 91, 41, 300, 301, 41, 303, 304,
! 305, 306, 307, 308, 309, 300, 301, 312, 59, 63,
! 315, 316, 317, 300, 301, 300, 301, 40, 123, 375,
! 300, 301, 300, 301, 41, 123, 41, 41, 126, 123,
! 256, 257, 258, 259, 260, 261, 41, 263, 264, 265,
! 266, 267, 268, 269, 270, 271, 272, 273, 274, 275,
! 41, 59, 41, 279, 280, 289, 282, 283, 284, 285,
! 286, 300, 301, 59, 41, 291, 292, 293, 294, 295,
! 296, 297, 63, 59, 41, 309, 302, 35, 312, 52,
! 52, 315, 316, 317, 15, 311, 154, 313, 314, 336,
! 256, 257, 258, 259, 260, 261, 375, 263, 264, 265,
! 266, 267, 268, 269, 270, 271, 272, 273, 274, 275,
! 202, 24, 269, 279, 280, -1, 282, 283, 284, 285,
! 286, -1, -1, 125, -1, 291, 292, 293, 294, 295,
! 296, 297, 355, 356, -1, 309, 302, 360, 312, -1,
! -1, 315, 316, 317, -1, 311, -1, 313, 314, -1,
! -1, 41, -1, 376, 44, -1, -1, 380, 256, 257,
! 258, 259, 260, 261, -1, 263, 264, 265, 58, 59,
! -1, 269, -1, 63, 272, 273, 274, 275, -1, -1,
! -1, 279, 280, -1, 282, 283, 284, 285, 286, -1,
! -1, 125, -1, 291, 292, 293, 294, 295, 296, -1,
! -1, -1, -1, 93, 302, -1, -1, -1, -1, -1,
! -1, -1, -1, 311, 33, 313, 314, 36, 37, 38,
! -1, 40, 41, 42, 43, 44, 45, 281, -1, -1,
! -1, -1, -1, 287, 288, 289, 290, -1, -1, 58,
! 59, -1, -1, -1, 63, 64, -1, -1, -1, 303,
! 304, 305, 306, 307, 308, 309, -1, -1, 312, -1,
! -1, 315, 316, 317, 266, 267, 268, -1, 270, 271,
! -1, -1, 91, -1, 93, 33, -1, -1, 36, 37,
! 38, -1, 40, 41, 42, 43, 44, 45, -1, -1,
! 281, -1, -1, -1, -1, 297, 287, 288, 289, 290,
! 58, 59, -1, -1, -1, 63, 64, 126, -1, -1,
! -1, -1, 303, 304, 305, 306, 307, 308, 309, -1,
! -1, 312, 29, -1, 315, 316, 317, -1, -1, -1,
! -1, -1, 266, 267, 268, 93, 270, 271, 33, 46,
! 47, 36, 37, 38, -1, 40, 53, 42, 43, -1,
! 45, 287, 288, 289, 290, -1, -1, -1, 65, 66,
! 67, 68, -1, 297, 59, -1, -1, -1, 126, 64,
306, 307, 308, 309, -1, -1, 312, -1, -1, 315,
! 316, 317, 272, 273, 274, 275, -1, -1, -1, 279,
! -1, 281, -1, -1, -1, -1, 91, 287, 288, 289,
! 290, 272, 273, 274, 275, 112, -1, -1, 279, -1,
! 300, 301, -1, 303, 304, 305, 306, 307, 308, 309,
! -1, -1, 312, -1, -1, 315, 316, 317, 123, 300,
! 301, 126, -1, -1, -1, -1, -1, -1, 257, 258,
! 259, 260, 261, -1, 263, 264, 265, -1, -1, -1,
! 269, -1, -1, 272, 273, 274, 275, -1, -1, -1,
! 279, 280, 281, 282, 283, 284, 285, 286, 287, 288,
! 289, 290, 291, 292, 293, 294, 295, 296, -1, -1,
! -1, 300, 301, 302, 303, 304, 305, 306, 307, 308,
! 309, -1, 311, 312, 313, 314, 315, 316, 317, 257,
! 258, 259, 260, 261, -1, 263, 264, 265, -1, -1,
! -1, 269, -1, -1, 272, 273, 274, 275, -1, -1,
! -1, 279, 280, 281, 282, 283, 284, 285, 286, 287,
! 288, 289, 290, 291, 292, 293, 294, 295, 296, -1,
! -1, -1, 300, 301, 302, 303, 304, 305, 306, 307,
! 308, 309, -1, 311, 312, 313, 314, 315, 316, 317,
! -1, 256, 257, 258, 259, 260, 261, 63, 263, 264,
265, -1, -1, -1, 269, -1, -1, 272, 273, 274,
! 275, -1, -1, -1, 279, 280, -1, 282, 283, 284,
! 285, 286, -1, -1, -1, -1, 291, 292, 293, 294,
! 295, 296, -1, -1, -1, 33, -1, 302, 36, 37,
! 38, -1, 40, -1, 42, 43, 311, 45, 313, 314,
! -1, 46, -1, -1, -1, -1, -1, -1, -1, 54,
! 287, 59, 289, 290, -1, -1, 64, -1, -1, 41,
! -1, -1, 44, -1, -1, 331, 332, 333, -1, 335,
! -1, 308, 309, -1, -1, 312, 58, 59, 315, 316,
! 317, -1, -1, 91, -1, 33, -1, -1, 36, 37,
! 38, 96, 40, -1, 42, 43, 362, 45, -1, -1,
! -1, -1, -1, 369, -1, -1, -1, 373, -1, -1,
! -1, 93, -1, -1, 119, 123, 64, -1, 126, -1,
! 386, 387, 127, -1, -1, 33, -1, -1, 36, 37,
! 38, -1, 40, -1, 42, 43, -1, 45, -1, -1,
! -1, -1, -1, 91, 287, 288, 289, 290, -1, -1,
! -1, -1, -1, -1, -1, -1, 64, -1, -1, -1,
! -1, -1, -1, -1, 41, 308, 309, 44, -1, 312,
! -1, -1, 315, 316, 317, 123, -1, -1, 126, -1,
! -1, 58, 59, 91, -1, -1, 63, -1, -1, 33,
! -1, -1, 36, 37, 38, -1, 40, -1, 42, 43,
! -1, 45, -1, -1, -1, 281, -1, -1, -1, -1,
! -1, 287, 288, 289, 290, 123, 93, -1, 126, -1,
! 64, -1, -1, -1, -1, -1, -1, 303, 304, 305,
! 306, 307, 308, 309, -1, -1, 312, -1, -1, 315,
! 316, 317, -1, -1, -1, -1, -1, 91, 256, 257,
! 258, 259, 260, 261, -1, 263, 264, 265, -1, -1,
! -1, 269, -1, 268, 272, 273, 274, 275, -1, 274,
! -1, 279, 280, -1, 282, 283, 284, 285, 286, 123,
! -1, -1, 126, 291, 292, 293, 294, 295, 296, -1,
! 272, 273, 274, 275, 302, -1, -1, 279, -1, -1,
! -1, -1, -1, 311, -1, 313, 314, -1, -1, 257,
! 258, 259, 260, 261, 262, 263, 264, 265, 300, 301,
! -1, 269, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, 280, -1, 282, 283, 284, 285, 286, -1,
! 41, -1, -1, 291, 292, 293, 294, 295, 296, 257,
! 258, 259, 260, 261, 302, 263, 264, 265, 59, -1,
! -1, 269, -1, 311, -1, 313, 314, -1, -1, -1,
! -1, -1, 280, -1, 282, 283, 284, 285, 286, 63,
! -1, -1, -1, 291, 292, 293, 294, 295, 296, -1,
! -1, -1, 93, -1, 302, 272, 273, 274, 275, -1,
! -1, -1, 279, 311, 281, 313, 314, -1, -1, -1,
! 287, 288, -1, 257, 258, 259, 260, 261, -1, 263,
! 264, 265, -1, 300, 301, 269, 303, 304, 305, 306,
! 307, 308, -1, -1, -1, -1, 280, -1, 282, 283,
284, 285, 286, -1, -1, -1, -1, 291, 292, 293,
! 294, 295, 296, 289, 290, -1, 33, -1, 302, 36,
! 37, 38, -1, 40, -1, 42, 43, 311, 45, 313,
! 314, -1, 308, 309, -1, -1, 312, -1, -1, 315,
! 316, 317, 59, -1, -1, -1, -1, 64, -1, -1,
! -1, 287, 288, 289, 290, -1, 33, -1, -1, 36,
! 37, 38, -1, 40, 41, 42, 43, -1, 45, 305,
! 306, 307, 308, 309, 91, -1, 312, -1, -1, 315,
! 316, 317, -1, -1, -1, -1, -1, 64, -1, -1,
! 287, 288, 289, 290, -1, -1, 33, -1, -1, 36,
! 37, 38, -1, 40, -1, 42, 43, -1, 45, 126,
! 307, 308, 309, -1, 91, 312, -1, -1, 315, 316,
! 317, -1, -1, -1, -1, -1, -1, 64, -1, -1,
! -1, 272, 273, 274, 275, -1, 33, -1, 279, 36,
! 37, 38, -1, 40, 41, 42, 43, -1, 45, 126,
! -1, -1, -1, -1, 91, -1, 93, 281, -1, 300,
! 301, -1, -1, 287, 288, 289, 290, 64, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 304, 305, 306, 307, 308, 309, -1, -1, 312, 126,
! -1, 315, 316, 317, 91, -1, 33, -1, -1, 36,
37, 38, -1, 40, 41, 42, 43, -1, 45, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, 64, -1, 126,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 257, 258, 259, 260, 261, -1, 263, 264, 265, -1,
! -1, -1, 269, -1, 91, -1, -1, -1, -1, -1,
! -1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
-1, -1, -1, -1, 291, 292, 293, 294, 295, 296,
! 257, 258, 259, 260, 261, 302, 263, 264, 265, 126,
! -1, -1, 269, -1, 311, -1, 313, 314, -1, -1,
! -1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
! -1, -1, -1, -1, 291, 292, 293, 294, 295, 296,
! 257, 258, 259, 260, 261, 302, 263, 264, 265, -1,
! -1, -1, 269, -1, 311, -1, 313, 314, -1, -1,
! -1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
! -1, -1, -1, -1, 291, 292, 293, 294, 295, 296,
! 257, 258, 259, 260, 261, 302, 263, 264, 265, -1,
! -1, -1, 269, -1, 311, -1, 313, 314, -1, -1,
! -1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
! -1, -1, -1, -1, 291, 292, 293, 294, 295, 296,
! -1, -1, -1, 33, -1, 302, 36, 37, 38, -1,
40, 41, 42, 43, 311, 45, 313, 314, -1, -1,
257, 258, 259, 260, 261, -1, 263, 264, 265, -1,
-1, -1, 269, -1, 64, -1, -1, -1, -1, -1,
--- 87,921 ----
6, 3, 3, 5, 2, 4, 0, 5, 1, 1,
5, 4, 5, 4, 5, 6, 5, 4, 5, 4,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
! 3, 3, 3, 3, 2, 2, 2, 2, 2, 2,
! 2, 2, 3, 2, 4, 3, 5, 2, 2, 4,
! 5, 4, 5, 1, 1, 1, 1, 5, 2, 1,
! 2, 3, 2, 1, 1, 1, 1, 1, 1, 6,
! 5, 4, 5, 1, 1, 3, 4, 3, 1, 2,
! 2, 1, 2, 2, 2, 1, 3, 1, 3, 4,
! 4, 6, 1, 1, 3, 2, 3, 2, 1, 1,
! 1, 0, 1, 0, 1, 2, 1, 2, 2, 2,
! 2, 2, 2, 1, 1, 1, 1,
};
! static short yydefred[] = { 4,
0, 7, 0, 45, 58, 56, 0, 56, 56, 8,
46, 9, 11, 48, 0, 47, 49, 50, 0, 0,
! 0, 70, 71, 0, 14, 3, 173, 0, 0, 154,
! 0, 168, 0, 57, 57, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 12, 0, 0, 0, 0, 0, 0, 0, 10,
! 0, 0, 0, 0, 0, 146, 148, 0, 0, 0,
! 0, 174, 140, 134, 135, 136, 137, 52, 0, 59,
! 0, 69, 0, 0, 7, 194, 197, 196, 195, 0,
! 0, 0, 0, 0, 0, 3, 3, 3, 3, 3,
! 3, 0, 0, 0, 0, 0, 163, 0, 0, 0,
! 0, 85, 0, 192, 0, 129, 0, 0, 0, 0,
! 0, 0, 0, 179, 181, 180, 0, 188, 0, 0,
! 0, 0, 0, 0, 0, 0, 124, 0, 0, 0,
! 189, 190, 191, 193, 0, 34, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 119, 120, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 13,
! 0, 51, 61, 0, 0, 0, 0, 83, 0, 0,
! 87, 0, 0, 0, 0, 0, 0, 0, 3, 167,
! 169, 0, 0, 0, 0, 0, 0, 0, 126, 0,
! 158, 178, 0, 0, 175, 0, 0, 123, 27, 0,
! 0, 19, 0, 0, 0, 0, 73, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 89, 0, 0, 90, 0, 0, 101, 0,
! 0, 0, 0, 0, 0, 0, 156, 0, 0, 0,
! 0, 0, 0, 2, 0, 0, 171, 0, 0, 0,
! 42, 0, 43, 0, 0, 0, 0, 187, 0, 0,
! 36, 41, 0, 0, 0, 170, 186, 86, 0, 130,
! 0, 132, 0, 125, 177, 65, 0, 0, 0, 0,
! 98, 0, 0, 0, 0, 100, 94, 0, 92, 0,
! 152, 0, 157, 63, 68, 67, 55, 0, 54, 84,
! 0, 88, 127, 0, 0, 0, 0, 0, 0, 0,
! 0, 80, 131, 133, 151, 0, 0, 0, 99, 93,
! 0, 97, 95, 153, 91, 72, 172, 6, 0, 0,
! 0, 0, 0, 0, 0, 0, 150, 96, 81, 7,
! 28, 29, 0, 0, 24, 25, 0, 32, 0, 0,
! 0, 22, 0, 0, 0, 31, 5, 0, 30, 0,
! 0, 33, 0, 23,
};
static short yydgoto[] = { 1,
! 10, 11, 20, 104, 19, 2, 95, 370, 98, 359,
! 3, 12, 13, 70, 375, 285, 72, 73, 74, 75,
! 76, 77, 78, 79, 291, 81, 292, 281, 283, 286,
! 294, 282, 284, 122, 214, 100, 82, 257, 89, 91,
! 194, 327, 156, 289, 271, 225, 14, 83, 137, 84,
! 85, 86, 87, 15, 16, 17, 18, 93, 278,
};
static short yysindex[] = { 0,
! 0, 0, -132, 0, 0, 0, -51, 0, 0, 0,
! 0, 0, 0, 0, 650, 0, 0, 0, -239, -215,
! 5, 0, 0, -215, 0, 0, 0, -31, -31, 0,
! -24, 0, 2181, 0, 0, 11, 16, 32, 46, -34,
! 2181, 49, 72, 76, 1017, 977, -31, 1081, 1348, -134,
! 2181, 85, -31, 2181, 2181, 2181, 2181, 2181, 2181, 1388,
! 1428, 0, 2181, 2181, -31, -31, -31, -31, -150, 0,
! 337, 849, -13, -58, -48, 0, 0, 8, 97, 92,
! 116, 0, 0, 0, 0, 0, 0, 0, 52, 0,
! -97, 0, -75, -97, 0, 0, 0, 0, 0, 2181,
! 146, 2181, 395, 52, -97, 0, 0, 0, 0, 0,
! 0, 150, 849, 153, 1468, 977, 0, 395, 0, -58,
! 116, 0, 2181, 0, 157, 0, 395, -8, 83, -52,
! 2181, 395, 1528, 0, 0, 0, -89, 0, 116, 107,
! 107, 107, -104, -104, 123, -37, 0, -73, 107, 107,
! 0, 0, 0, 0, 52, 0, 2181, 2181, 2181, 2181,
! 2181, 2181, 2181, 2181, 2181, 2181, 2181, 2181, 2181, 2181,
! 2181, 2181, 2181, 2181, 2181, 2181, 2181, 0, 0, -12,
! 2181, 1735, 2181, 2181, 2181, 2181, 2181, 2181, 1795, 0,
! 2181, 0, 0, -64, -32, -64, 411, 0, 2181, 291,
! 0, -64, 2181, 2181, 2181, 2181, 187, 1854, 0, 0,
! 0, -29, 58, 189, 2181, 116, 1914, 2029, 0, 111,
! 0, 0, -26, -19, 0, 2181, 165, 0, 0, -241,
! -241, 0, -241, -241, -241, -40, 0, 1618, 395, 1306,
! 185, 168, 849, 1235, 1129, 1169, 1268, 782, 235, 107,
! 107, 2181, 0, 2121, 2181, 0, 218, -46, 0, -3,
! -68, 61, 106, 65, 108, 68, 0, 17, 849, 26,
! -30, 2181, -30, 0, 236, 2181, 0, 2181, 52, -241,
! 0, 250, 0, 255, -241, 259, 260, 0, 248, 337,
! 0, 0, 262, 261, 2181, 0, 0, 0, 22, 0,
! 33, 0, 36, 0, 0, 0, 125, 2181, 2181, 71,
! 0, 50, 127, 2181, 182, 0, 0, 184, 0, 199,
! 0, 201, 0, 0, 0, 0, 0, 272, 0, 0,
! 354, 0, 0, 216, 216, 216, 216, 2181, 216, 2181,
! 301, 0, 0, 0, 0, 167, 2418, 228, 0, 0,
! 319, 0, 0, 0, 0, 0, 0, 0, -150, -150,
! -123, -123, 322, -150, 308, 216, 0, 0, 0, 0,
! 0, 0, 216, 334, 0, 0, 216, 0, 1854, -150,
! 449, 0, 2181, -150, 340, 0, 0, 355, 0, 216,
! 216, 0, -123, 0,
};
static short yyrindex[] = { 0,
! 0, 0, 247, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 274, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 40, 455, 0, 0, 2367, 2469, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 119, 0,
! 3, 943, 2515, 2603, 2653, 0, 0, 2708, 2754, 0,
! -6, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! -33, 0, 0, -33, 0, 0, 0, 0, 0, 2469,
! 0, 0, 3919, 0, -102, 0, 0, 0, 0, 0,
! 0, 0, 3216, 0, 0, 359, 0, 3955, 526, 587,
! 2276, 0, 0, 0, 2801, 0, 3999, 2603, 0, 0,
! 2469, 4043, 0, 0, 0, 0, 2858, 0, 3225, 3461,
! 3527, 3588, 3352, 3399, 2908, 0, 0, 0, 3635, 3680,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 2990, 0, 0, -28, 0, -28, 917, 0, 359, 0,
! 0, 295, 379, 0, 0, 0, 0, 370, 0, 0,
! 0, 0, 390, 0, 0, 3291, 0, 0, 0, 0,
! 0, 0, 0, 3056, 0, 0, 3113, 0, 0, 14,
! 35, 0, 55, 91, 117, 1991, 0, 4235, 4090, 1826,
! 3807, 3871, 3283, 0, -22, 4191, 4155, 4145, 1048, 3719,
! 3763, 0, 0, 0, 0, 0, 3163, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 4267, -10,
! 0, 375, 0, 0, 0, 0, 0, 2469, 0, 136,
! 0, 0, 0, 0, 400, 0, 0, 0, 0, 139,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 359, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 396,
! 0, 0, 0, 0, 0, 0, 4080, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 119, 119,
! 179, 179, 0, 119, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 415, 119,
! 917, 0, 0, 119, 0, 0, 0, 0, 0, 0,
! 0, 0, 179, 0,
};
static short yygindex[] = { 0,
! 0, 0, 196, 425, 0, 0, -2, 0, 37, 634,
! -94, 0, 0, 0, -323, -15, 2445, 0, 999, 414,
! 417, 0, 0, 0, 463, -43, 0, 0, 321, -198,
! 103, 147, 280, -91, -185, 1, 0, 0, 0, 464,
! -44, 222, 338, 0, -179, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0,
};
! #define YYTABLESIZE 4568
static short yytable[] = { 71,
! 197, 65, 121, 227, 65, 111, 220, 22, 198, 293,
! 139, 296, 315, 275, 305, 102, 273, 88, 113, 228,
! 60, 113, 279, 65, 317, 60, 182, 254, 325, 101,
! 62, 218, 185, 130, 75, 113, 113, 316, 376, 221,
! 113, 90, 187, 15, 146, 148, 123, 124, 64, 196,
! 106, 69, 75, 138, 18, 107, 121, 323, 162, 163,
! 202, 15, 342, 92, 184, 151, 152, 153, 154, 394,
! 113, 108, 18, 343, 186, 39, 344, 183, 255, 216,
! 159, 117, 185, 159, 126, 109, 75, 121, 114, 60,
! 349, 26, 26, 39, 62, 16, 341, 159, 159, 212,
! 213, 297, 159, 203, 204, 205, 206, 207, 208, 181,
! 252, 115, 64, 16, 184, 116, 215, 223, 26, 318,
! 65, 67, 131, 320, 133, 192, 322, 155, 351, 348,
! 188, 17, 159, 4, 5, 6, 189, 7, 8, 363,
! 201, 230, 231, 233, 234, 235, 236, 237, 66, 17,
! 190, 26, 373, 374, 26, 26, 26, 20, 26, 191,
! 26, 26, 193, 26, 9, 258, 260, 261, 262, 263,
! 264, 265, 266, 268, 26, 20, 38, 26, 21, 40,
! 328, 195, 26, 213, 388, 199, 332, 280, 231, 209,
! 231, 229, 290, 210, 38, 60, 217, 15, 319, 299,
! 321, 301, 303, 23, 24, 21, 295, 219, 224, 26,
! 307, 21, 180, 226, 21, 21, 21, 345, 21, 350,
! 21, 21, 65, 21, 272, 96, 162, 163, 121, 298,
! 97, 162, 163, 270, 121, 304, 310, 21, 312, 313,
! 306, 26, 21, 26, 26, 253, 1, 162, 163, 113,
! 113, 113, 113, 162, 163, 308, 113, 314, 113, 367,
! 163, 110, 162, 163, 60, 75, 75, 75, 75, 21,
! 162, 163, 75, 162, 163, 381, 330, 113, 113, 44,
! 113, 113, 44, 44, 44, 324, 44, 338, 44, 44,
! 334, 44, 346, 75, 75, 335, 162, 163, 213, 336,
! 337, 21, 339, 21, 21, 44, 352, 326, 353, 326,
! 44, 159, 159, 159, 159, 333, 162, 163, 159, 340,
! 159, 162, 163, 354, 280, 355, 159, 159, 159, 159,
! 356, 277, 162, 163, 276, 162, 163, 44, 358, 159,
! 159, 366, 159, 159, 159, 159, 159, 159, 159, 162,
! 163, 159, 368, 170, 159, 159, 159, 162, 163, 369,
! 162, 163, 377, 71, 162, 163, 379, 162, 163, 44,
! 162, 163, 44, 383, 26, 26, 26, 26, 26, 26,
! 390, 26, 26, 26, 26, 26, 26, 26, 26, 26,
! 26, 26, 26, 26, 357, 391, 53, 26, 26, 184,
! 26, 26, 26, 26, 26, 162, 163, 162, 163, 26,
! 26, 26, 26, 26, 26, 26, 170, 62, 177, 37,
! 26, 178, 179, 180, 162, 163, 162, 163, 35, 26,
! 185, 26, 26, 182, 21, 21, 21, 21, 21, 21,
! 40, 21, 21, 21, 21, 21, 21, 21, 21, 21,
! 21, 21, 21, 21, 37, 35, 167, 21, 21, 105,
! 21, 21, 21, 21, 21, 135, 162, 163, 136, 21,
! 21, 21, 21, 21, 21, 21, 176, 80, 232, 177,
! 21, 385, 178, 179, 180, 287, 365, 94, 0, 21,
! 0, 21, 21, 176, 329, 166, 177, 0, 166, 178,
! 179, 180, 44, 44, 44, 44, 44, 44, 0, 44,
! 44, 44, 166, 166, 0, 44, 0, 166, 44, 44,
! 44, 44, 0, 167, 168, 44, 44, 0, 44, 44,
! 44, 44, 44, 0, 0, 274, 0, 44, 44, 44,
! 44, 44, 44, 176, 0, 0, 177, 166, 44, 178,
! 179, 180, 0, 0, 0, 0, 0, 44, 194, 44,
! 44, 194, 194, 194, 0, 194, 173, 194, 194, 173,
! 194, 164, 0, 387, 0, 0, 0, 165, 166, 167,
! 168, 0, 0, 173, 173, 0, 0, 0, 173, 194,
! 0, 0, 0, 169, 171, 172, 173, 174, 175, 176,
! 0, 0, 177, 0, 0, 178, 179, 180, 157, 158,
! 159, 160, 0, 0, 0, 161, 194, 0, 173, 195,
! 0, 0, 195, 195, 195, 0, 195, 144, 195, 195,
! 144, 195, 0, 0, 164, 0, 162, 163, 0, 0,
! 165, 166, 167, 168, 144, 144, 0, 0, 0, 144,
! 195, 194, 0, 0, 0, 0, 169, 171, 172, 173,
! 174, 175, 176, 0, 0, 177, 0, 0, 178, 179,
! 180, 0, 0, 0, 0, 0, 4, 5, 6, 144,
! 7, 8, 55, 167, 168, 65, 67, 53, 0, 60,
! 0, 68, 64, 0, 63, 0, 371, 372, 0, 0,
! 0, 378, 175, 176, 0, 0, 177, 9, 62, 178,
! 179, 180, 195, 66, 4, 5, 6, 386, 7, 8,
! 0, 389, 0, 0, 0, 0, 166, 166, 166, 166,
! 0, 0, 0, 166, 0, 166, 0, 0, 0, 0,
! 61, 166, 166, 166, 166, 9, 0, 0, 0, 0,
! 0, 0, 0, 0, 166, 166, 0, 166, 166, 166,
! 166, 166, 166, 166, 0, 0, 166, 0, 0, 166,
! 166, 166, 26, 0, 0, 56, 0, 0, 0, 0,
! 0, 0, 194, 194, 194, 194, 194, 0, 194, 194,
! 194, 0, 0, 0, 194, 0, 0, 173, 173, 173,
! 173, 0, 0, 0, 173, 194, 173, 194, 194, 194,
! 194, 194, 173, 173, 173, 173, 194, 194, 194, 194,
! 194, 194, 0, 0, 0, 173, 173, 194, 173, 173,
! 173, 173, 173, 173, 173, 0, 194, 173, 194, 194,
! 173, 173, 173, 195, 195, 195, 195, 195, 0, 195,
! 195, 195, 0, 0, 0, 195, 0, 0, 144, 144,
! 144, 144, 0, 0, 0, 144, 195, 144, 195, 195,
! 195, 195, 195, 144, 144, 144, 144, 195, 195, 195,
! 195, 195, 195, 0, 0, 0, 144, 144, 195, 144,
! 144, 144, 144, 144, 144, 144, 0, 195, 144, 195,
! 195, 144, 144, 144, 0, 25, 27, 28, 29, 30,
! 31, 170, 32, 33, 34, 0, 0, 0, 35, 0,
! 0, 36, 37, 38, 39, 0, 0, 0, 40, 41,
! 0, 42, 43, 44, 45, 46, 0, 0, 0, 0,
! 47, 48, 49, 50, 51, 52, 0, 0, 0, 44,
! 0, 54, 44, 44, 44, 0, 44, 0, 44, 44,
! 57, 44, 58, 59, 0, 0, 0, 0, 360, 361,
! 362, 0, 364, 0, 0, 44, 0, 0, 0, 0,
! 44, 0, 0, 78, 0, 0, 78, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 380,
! 78, 78, 0, 0, 0, 0, 382, 44, 0, 55,
! 384, 0, 65, 67, 53, 0, 60, 0, 68, 64,
! 0, 63, 0, 392, 393, 0, 99, 99, 0, 0,
! 0, 0, 0, 0, 0, 78, 0, 0, 112, 44,
! 66, 0, 44, 0, 120, 99, 128, 0, 0, 55,
! 134, 99, 65, 67, 53, 0, 60, 0, 68, 64,
! 0, 63, 0, 99, 99, 99, 99, 61, 165, 166,
! 167, 168, 0, 0, 0, 0, 0, 0, 0, 0,
! 66, 0, 0, 0, 0, 0, 0, 0, 106, 175,
! 176, 106, 0, 177, 0, 0, 178, 179, 180, 26,
! 0, 0, 56, 0, 0, 106, 106, 61, 0, 0,
! 106, 0, 0, 55, 120, 0, 65, 67, 53, 0,
! 60, 0, 68, 64, 0, 63, 0, 0, 0, 164,
! 0, 0, 0, 0, 0, 165, 166, 167, 168, 26,
! 106, 0, 56, 0, 66, 0, 0, 0, 0, 0,
! 0, 169, 171, 172, 173, 174, 175, 176, 0, 0,
! 177, 0, 0, 178, 179, 180, 0, 0, 0, 0,
! 0, 61, 44, 44, 44, 44, 44, 44, 256, 44,
! 44, 44, 0, 0, 0, 44, 0, 0, 44, 44,
! 44, 44, 0, 0, 0, 44, 44, 0, 44, 44,
! 44, 44, 44, 26, 0, 288, 56, 44, 44, 44,
! 44, 44, 44, 0, 78, 78, 78, 78, 44, 0,
! 0, 78, 0, 0, 0, 0, 0, 44, 0, 44,
! 44, 0, 0, 119, 28, 29, 30, 31, 97, 32,
! 33, 34, 78, 78, 0, 35, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 41, 0, 42, 43,
44, 45, 46, 0, 0, 0, 0, 47, 48, 49,
! 50, 51, 52, 27, 28, 29, 30, 31, 54, 32,
! 33, 34, 0, 0, 0, 35, 0, 57, 0, 58,
! 59, 0, 309, 0, 0, 0, 41, 170, 42, 43,
! 44, 45, 46, 0, 0, 0, 0, 47, 48, 49,
! 50, 51, 52, 0, 0, 0, 0, 0, 54, 106,
! 106, 106, 106, 0, 0, 0, 106, 57, 106, 58,
! 59, 0, 0, 0, 106, 106, 0, 125, 28, 29,
! 30, 31, 0, 32, 33, 34, 0, 106, 106, 35,
! 106, 106, 106, 106, 106, 106, 0, 0, 0, 0,
! 41, 0, 42, 43, 44, 45, 46, 0, 0, 0,
! 0, 47, 48, 49, 50, 51, 52, 0, 0, 0,
! 55, 0, 54, 65, 67, 53, 0, 60, 0, 68,
! 64, 57, 63, 58, 59, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 129, 0, 0, 0,
! 0, 66, 0, 0, 0, 165, 166, 167, 168, 0,
! 55, 0, 0, 65, 67, 53, 0, 60, 145, 68,
! 64, 0, 63, 172, 173, 174, 175, 176, 61, 0,
! 177, 0, 0, 178, 179, 180, 0, 0, 0, 0,
! 0, 66, 0, 0, 0, 165, 166, 167, 168, 0,
! 55, 0, 0, 65, 67, 53, 0, 60, 0, 68,
! 64, 0, 63, 56, 173, 174, 175, 176, 61, 0,
! 177, 0, 0, 178, 179, 180, 0, 0, 0, 0,
! 0, 66, 0, 0, 0, 0, 0, 0, 0, 0,
! 55, 0, 0, 65, 67, 53, 0, 60, 211, 68,
! 64, 0, 63, 56, 0, 164, 0, 0, 61, 0,
! 147, 165, 166, 167, 168, 0, 0, 0, 0, 0,
! 0, 66, 0, 0, 0, 0, 0, 169, 171, 172,
! 173, 174, 175, 176, 0, 0, 177, 0, 0, 178,
! 179, 180, 0, 56, 165, 166, 167, 168, 61, 0,
! 55, 0, 0, 65, 67, 53, 0, 60, 222, 68,
! 64, 0, 63, 0, 174, 175, 176, 0, 0, 177,
! 0, 0, 178, 179, 180, 0, 0, 0, 0, 0,
! 0, 66, 165, 56, 167, 168, 0, 0, 0, 0,
! 0, 0, 0, 0, 27, 28, 29, 30, 31, 0,
! 32, 33, 34, 175, 176, 0, 35, 177, 61, 0,
! 178, 179, 180, 0, 0, 0, 0, 41, 0, 42,
! 43, 44, 45, 46, 0, 0, 0, 0, 47, 48,
! 49, 50, 51, 52, 27, 28, 29, 30, 31, 54,
! 32, 33, 34, 56, 0, 0, 35, 0, 57, 0,
! 58, 59, 0, 0, 0, 0, 0, 41, 0, 42,
! 43, 44, 45, 46, 0, 0, 0, 0, 47, 48,
! 49, 50, 51, 52, 27, 28, 29, 30, 31, 54,
! 32, 33, 34, 0, 0, 0, 35, 0, 57, 0,
! 58, 59, 0, 0, 0, 0, 0, 41, 0, 42,
! 43, 44, 45, 46, 0, 0, 0, 0, 47, 48,
! 49, 50, 51, 52, 27, 28, 29, 30, 31, 54,
! 32, 33, 34, 0, 0, 0, 35, 0, 57, 0,
! 58, 59, 0, 0, 0, 0, 0, 41, 0, 42,
! 43, 44, 45, 46, 0, 0, 0, 0, 47, 48,
! 49, 50, 51, 52, 0, 0, 0, 55, 0, 54,
! 65, 67, 53, 0, 60, 259, 68, 64, 57, 63,
! 58, 59, 0, 0, 27, 28, 29, 30, 31, 0,
! 32, 33, 34, 0, 0, 0, 35, 0, 66, 0,
! 0, 0, 0, 0, 0, 0, 0, 41, 0, 42,
! 43, 44, 45, 46, 0, 0, 0, 0, 47, 48,
! 49, 50, 51, 52, 0, 61, 0, 55, 0, 54,
! 65, 67, 53, 0, 60, 267, 68, 64, 57, 63,
! 58, 59, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 66, 0,
! 56, 0, 0, 0, 0, 0, 108, 0, 0, 108,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 108, 108, 61, 55, 0, 108, 65,
! 67, 53, 0, 60, 0, 68, 64, 0, 63, 0,
! 0, 0, 0, 0, 165, 166, 167, 168, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 66, 108, 0,
! 56, 171, 172, 173, 174, 175, 176, 0, 0, 177,
! 0, 0, 178, 179, 180, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 61, 0, 55, 0, 0, 65,
! 67, 53, 0, 60, 300, 68, 64, 0, 63, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 66, 0, 56,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 27, 28, 29, 30, 31, 0, 32, 33, 34,
! 0, 0, 0, 35, 61, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 41, 0, 42, 43, 44, 45,
! 46, 0, 0, 0, 0, 47, 48, 49, 50, 51,
! 52, 74, 0, 0, 74, 0, 54, 0, 0, 56,
! 0, 0, 0, 0, 0, 57, 0, 58, 59, 74,
! 0, 27, 28, 29, 30, 31, 0, 32, 33, 34,
! 0, 55, 0, 35, 65, 67, 53, 0, 60, 302,
! 68, 64, 0, 63, 41, 0, 42, 43, 44, 45,
! 46, 0, 0, 74, 0, 47, 48, 49, 50, 51,
! 52, 0, 66, 0, 0, 0, 54, 108, 108, 108,
! 108, 0, 0, 0, 108, 57, 108, 58, 59, 25,
! 27, 28, 29, 30, 31, 0, 32, 33, 34, 61,
! 0, 0, 35, 0, 0, 108, 108, 0, 108, 108,
! 108, 108, 108, 41, 0, 42, 43, 44, 45, 46,
0, 0, 0, 0, 47, 48, 49, 50, 51, 52,
! 0, 0, 0, 55, 56, 54, 65, 67, 53, 0,
! 60, 311, 68, 64, 57, 63, 58, 59, 0, 0,
27, 28, 29, 30, 31, 0, 32, 33, 34, 0,
0, 0, 35, 0, 66, 0, 0, 0, 0, 0,
0, 0, 0, 41, 0, 42, 43, 44, 45, 46,
0, 0, 0, 0, 47, 48, 49, 50, 51, 52,
0, 61, 0, 55, 0, 54, 65, 67, 53, 0,
! 60, 0, 68, 64, 57, 63, 58, 59, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 66, 0, 56, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 74, 74, 74, 74, 0, 0, 0, 74,
! 0, 61, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 27, 28, 29, 30, 31,
! 74, 32, 33, 34, 0, 0, 0, 35, 0, 0,
! 0, 0, 0, 0, 0, 0, 56, 0, 41, 0,
! 42, 43, 44, 45, 46, 0, 183, 0, 0, 47,
! 48, 49, 50, 51, 52, 0, 0, 0, 0, 0,
! 54, 0, 0, 183, 183, 0, 0, 0, 183, 57,
! 0, 58, 59, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 183, 0,
0, 0, 0, 0, 0, 0, 0, 27, 28, 29,
30, 31, 0, 32, 33, 34, 0, 0, 0, 35,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 41, 0, 42, 43, 44, 45, 46, 162, 0, 0,
! 162, 47, 48, 49, 50, 51, 52, 0, 0, 0,
! 0, 0, 54, 0, 162, 162, 0, 0, 0, 162,
0, 57, 0, 58, 59, 0, 0, 27, 28, 29,
! 30, 31, 0, 32, 33, 34, 0, 0, 0, 35,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 162,
41, 0, 42, 43, 44, 45, 46, 0, 0, 0,
! 0, 47, 48, 49, 50, 51, 52, 103, 0, 0,
! 170, 0, 54, 0, 0, 113, 0, 0, 0, 118,
! 0, 57, 127, 58, 59, 132, 0, 0, 0, 140,
! 141, 142, 143, 144, 0, 0, 0, 149, 150, 182,
! 0, 0, 182, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 182, 182, 0, 0,
! 0, 182, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 200, 183, 183, 183,
! 183, 0, 0, 0, 183, 149, 183, 0, 149, 0,
! 0, 182, 183, 183, 183, 183, 0, 0, 0, 0,
! 0, 0, 149, 149, 0, 183, 183, 149, 183, 183,
! 183, 183, 183, 183, 183, 0, 0, 183, 0, 0,
! 183, 183, 183, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 149, 238, 239,
! 240, 241, 242, 243, 244, 245, 246, 247, 248, 249,
! 250, 251, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 269, 0, 0, 162, 162,
! 162, 162, 0, 144, 0, 162, 144, 162, 0, 0,
! 0, 0, 0, 162, 162, 162, 162, 0, 0, 0,
! 144, 144, 0, 0, 0, 144, 162, 162, 0, 162,
! 162, 162, 162, 162, 162, 162, 0, 0, 162, 0,
! 0, 162, 162, 162, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 147, 0, 144, 147, 0, 164, 0,
! 0, 0, 0, 0, 165, 166, 167, 168, 0, 0,
! 147, 147, 0, 0, 0, 147, 0, 0, 0, 0,
! 331, 171, 172, 173, 174, 175, 176, 0, 0, 177,
! 0, 0, 178, 179, 180, 0, 0, 0, 0, 0,
! 182, 182, 182, 182, 0, 147, 0, 182, 145, 182,
! 0, 145, 0, 347, 0, 182, 182, 182, 182, 0,
! 0, 0, 0, 0, 0, 145, 145, 0, 182, 182,
! 145, 182, 182, 182, 182, 182, 182, 182, 0, 0,
! 182, 0, 0, 182, 182, 182, 149, 149, 149, 149,
! 0, 0, 0, 149, 155, 149, 0, 155, 0, 0,
! 145, 149, 149, 149, 149, 0, 0, 0, 0, 0,
! 0, 155, 155, 0, 149, 149, 155, 149, 149, 149,
! 149, 149, 149, 149, 0, 0, 149, 0, 0, 149,
! 149, 149, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 173, 0, 0, 173, 0, 155, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 173, 173,
! 0, 0, 0, 173, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 144, 144, 144, 144, 0, 0,
! 0, 144, 0, 144, 0, 0, 0, 0, 0, 144,
! 144, 144, 144, 173, 0, 0, 0, 0, 176, 0,
! 0, 176, 144, 144, 0, 144, 144, 144, 144, 144,
! 144, 144, 0, 0, 144, 176, 176, 144, 144, 144,
! 176, 0, 0, 0, 147, 147, 147, 147, 0, 0,
! 0, 147, 0, 147, 0, 0, 0, 0, 0, 147,
! 147, 147, 147, 0, 0, 0, 0, 0, 143, 0,
! 176, 143, 147, 147, 0, 147, 147, 147, 147, 147,
! 147, 147, 0, 0, 147, 143, 143, 147, 147, 147,
! 143, 0, 0, 0, 0, 0, 0, 0, 0, 145,
! 145, 145, 145, 0, 0, 0, 145, 0, 145, 0,
! 0, 0, 0, 0, 145, 145, 145, 145, 0, 0,
! 143, 0, 0, 0, 0, 0, 0, 145, 145, 0,
! 145, 145, 145, 145, 145, 145, 145, 0, 0, 145,
! 0, 0, 145, 145, 145, 155, 155, 155, 155, 0,
! 76, 0, 155, 76, 155, 0, 0, 0, 0, 0,
! 155, 155, 155, 155, 0, 0, 0, 76, 76, 0,
! 0, 0, 76, 155, 155, 0, 155, 155, 155, 155,
! 155, 155, 155, 0, 0, 155, 0, 0, 155, 155,
! 155, 0, 173, 173, 173, 173, 0, 0, 0, 173,
! 0, 173, 76, 0, 0, 0, 0, 173, 173, 173,
! 173, 0, 0, 0, 0, 0, 66, 0, 0, 66,
! 173, 173, 0, 173, 173, 173, 173, 173, 173, 173,
! 0, 0, 173, 66, 66, 173, 173, 173, 66, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 176,
! 176, 176, 176, 0, 0, 0, 176, 0, 176, 0,
! 0, 0, 0, 0, 176, 176, 176, 176, 66, 0,
! 0, 0, 0, 142, 0, 0, 142, 176, 176, 0,
! 176, 176, 176, 176, 176, 176, 176, 0, 0, 176,
! 142, 142, 176, 176, 176, 142, 0, 0, 0, 143,
! 143, 143, 143, 0, 0, 0, 143, 0, 143, 0,
! 0, 0, 0, 0, 143, 143, 143, 143, 0, 0,
! 0, 0, 0, 82, 0, 142, 82, 143, 143, 0,
! 143, 143, 143, 143, 143, 143, 143, 0, 0, 143,
! 82, 82, 143, 143, 143, 82, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 82, 160, 0, 0, 160,
! 0, 76, 76, 76, 76, 161, 0, 0, 76, 0,
! 76, 0, 0, 160, 160, 0, 76, 76, 76, 76,
! 0, 0, 161, 161, 0, 0, 0, 161, 0, 76,
! 76, 0, 76, 76, 76, 76, 76, 76, 76, 0,
! 0, 76, 0, 0, 76, 76, 76, 0, 160, 0,
! 0, 0, 0, 0, 0, 0, 0, 161, 0, 0,
! 0, 0, 0, 102, 0, 0, 102, 66, 66, 66,
! 66, 79, 0, 0, 66, 0, 66, 0, 0, 0,
! 102, 102, 66, 66, 66, 66, 0, 0, 79, 79,
! 0, 0, 0, 79, 0, 66, 66, 0, 66, 66,
! 66, 66, 66, 66, 66, 0, 0, 66, 0, 0,
! 66, 66, 66, 0, 0, 102, 0, 0, 0, 0,
! 0, 0, 0, 79, 142, 142, 142, 142, 0, 0,
! 0, 142, 121, 142, 0, 121, 0, 0, 0, 142,
! 142, 142, 142, 0, 0, 0, 0, 0, 0, 121,
! 121, 0, 142, 142, 121, 142, 142, 142, 142, 142,
! 142, 142, 0, 0, 142, 0, 0, 142, 142, 142,
! 0, 0, 0, 0, 82, 82, 82, 82, 0, 122,
! 0, 82, 122, 82, 121, 0, 0, 0, 0, 82,
! 82, 82, 82, 0, 0, 0, 122, 122, 0, 0,
! 0, 122, 82, 82, 0, 82, 82, 82, 82, 82,
! 82, 82, 0, 0, 82, 0, 0, 82, 82, 82,
! 0, 0, 0, 0, 0, 0, 0, 160, 160, 160,
! 160, 122, 0, 0, 160, 0, 161, 161, 161, 161,
! 0, 117, 0, 161, 117, 161, 0, 0, 0, 0,
! 0, 161, 161, 161, 161, 160, 160, 0, 117, 117,
! 0, 0, 0, 117, 161, 161, 0, 161, 161, 161,
! 161, 161, 161, 161, 0, 0, 161, 0, 0, 161,
! 161, 161, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 117, 102, 102, 102, 102, 0, 0,
! 0, 102, 79, 79, 79, 79, 0, 118, 0, 79,
! 118, 79, 0, 0, 0, 0, 0, 79, 79, 79,
! 79, 0, 102, 102, 118, 118, 0, 0, 0, 118,
! 79, 79, 0, 79, 79, 79, 79, 79, 79, 79,
! 0, 0, 79, 0, 0, 79, 79, 79, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 118,
! 0, 0, 0, 121, 121, 121, 121, 0, 139, 0,
! 121, 139, 121, 0, 0, 0, 0, 0, 121, 121,
! 121, 121, 0, 0, 0, 139, 139, 0, 0, 0,
! 139, 121, 121, 0, 121, 121, 121, 121, 121, 121,
! 121, 0, 0, 121, 0, 0, 0, 0, 0, 0,
! 122, 122, 122, 122, 0, 115, 0, 122, 115, 122,
! 139, 0, 0, 0, 0, 122, 122, 122, 122, 0,
! 0, 0, 115, 115, 0, 0, 0, 115, 122, 122,
! 0, 122, 122, 122, 122, 122, 122, 122, 0, 0,
! 122, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 116, 0, 0, 116, 0, 0, 0, 115, 0, 0,
! 0, 0, 117, 117, 117, 117, 0, 116, 116, 117,
! 0, 117, 116, 0, 0, 0, 0, 117, 117, 117,
! 117, 0, 0, 0, 0, 0, 0, 0, 0, 114,
! 117, 117, 114, 117, 117, 117, 117, 117, 117, 117,
! 0, 0, 116, 0, 0, 0, 114, 114, 0, 0,
! 0, 114, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 118, 118,
! 118, 118, 0, 103, 0, 118, 103, 118, 0, 0,
! 0, 114, 0, 118, 118, 118, 118, 0, 0, 0,
! 103, 103, 0, 0, 0, 103, 118, 118, 0, 118,
! 118, 118, 118, 118, 118, 118, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 104, 0, 0,
! 104, 0, 0, 0, 0, 103, 0, 0, 0, 139,
! 139, 139, 139, 0, 104, 104, 139, 0, 139, 104,
! 0, 0, 0, 0, 139, 139, 139, 139, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 139, 139, 0,
! 139, 139, 139, 139, 139, 139, 139, 0, 0, 104,
! 0, 0, 0, 0, 0, 0, 115, 115, 115, 115,
! 0, 105, 0, 115, 105, 115, 0, 0, 0, 0,
! 0, 115, 115, 115, 115, 0, 0, 0, 105, 105,
! 0, 0, 0, 105, 115, 115, 0, 115, 115, 115,
! 115, 115, 115, 115, 0, 0, 0, 0, 0, 0,
! 0, 116, 116, 116, 116, 0, 0, 0, 116, 165,
! 116, 0, 165, 105, 0, 0, 116, 116, 116, 116,
! 0, 0, 0, 0, 0, 0, 165, 165, 0, 116,
! 116, 165, 116, 116, 116, 116, 116, 116, 116, 0,
! 114, 114, 114, 114, 0, 164, 0, 114, 164, 114,
! 0, 0, 0, 0, 0, 114, 114, 114, 114, 0,
! 0, 165, 164, 164, 0, 0, 0, 164, 114, 114,
! 0, 114, 114, 114, 114, 114, 114, 114, 0, 0,
! 0, 0, 0, 0, 103, 103, 103, 103, 0, 128,
! 0, 103, 128, 103, 0, 0, 0, 164, 0, 103,
! 103, 103, 103, 0, 0, 0, 128, 128, 0, 0,
! 0, 128, 103, 103, 0, 103, 103, 103, 103, 103,
! 103, 103, 0, 0, 0, 0, 0, 0, 104, 104,
! 104, 104, 0, 141, 0, 104, 141, 104, 0, 0,
! 0, 128, 0, 104, 104, 104, 104, 0, 0, 0,
! 141, 141, 0, 0, 0, 141, 104, 104, 0, 104,
! 104, 104, 104, 104, 104, 0, 0, 0, 0, 0,
! 138, 0, 0, 138, 0, 0, 0, 0, 0, 0,
! 107, 0, 0, 107, 0, 141, 0, 138, 138, 0,
! 0, 0, 105, 105, 105, 105, 0, 107, 107, 105,
! 0, 105, 107, 0, 0, 0, 0, 105, 105, 0,
! 105, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 105, 105, 138, 105, 105, 105, 105, 105, 105, 0,
! 0, 0, 107, 0, 0, 109, 0, 0, 109, 0,
! 165, 165, 165, 165, 0, 110, 0, 165, 110, 165,
! 0, 0, 109, 109, 0, 165, 165, 109, 0, 0,
! 0, 0, 110, 110, 0, 0, 0, 110, 165, 165,
! 0, 165, 165, 165, 165, 165, 164, 164, 164, 164,
! 0, 112, 0, 164, 112, 164, 0, 109, 0, 0,
! 0, 164, 164, 0, 0, 0, 0, 110, 112, 112,
! 0, 0, 0, 112, 164, 164, 0, 164, 164, 164,
! 164, 164, 0, 0, 0, 0, 0, 0, 0, 0,
! 128, 128, 128, 128, 0, 111, 0, 128, 111, 128,
! 0, 0, 0, 112, 0, 128, 128, 0, 0, 0,
! 0, 0, 111, 111, 0, 0, 0, 111, 128, 128,
! 0, 128, 128, 128, 128, 128, 0, 77, 0, 0,
! 77, 0, 0, 0, 141, 141, 141, 141, 0, 0,
! 0, 141, 0, 141, 77, 77, 0, 111, 0, 141,
! 141, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 141, 141, 0, 141, 141, 141, 141, 141,
! 0, 138, 138, 138, 138, 0, 0, 0, 138, 77,
! 0, 107, 107, 107, 107, 0, 0, 0, 107, 0,
! 107, 0, 0, 0, 0, 0, 0, 107, 0, 138,
! 138, 0, 138, 0, 0, 0, 0, 0, 0, 107,
! 107, 0, 107, 107, 107, 107, 107, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 109, 109, 109, 109,
! 0, 0, 0, 109, 0, 109, 110, 110, 110, 110,
! 0, 0, 0, 110, 0, 110, 0, 0, 0, 0,
! 0, 0, 0, 0, 109, 109, 0, 109, 109, 109,
! 109, 109, 0, 0, 110, 110, 0, 110, 110, 110,
! 110, 0, 112, 112, 112, 112, 0, 0, 0, 112,
! 0, 112, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 112, 112, 0, 112, 112, 112, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 111, 111, 111, 111,
! 0, 0, 0, 111, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 111, 111, 0, 111, 77, 77,
! 77, 77, 0, 0, 0, 77, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 77, 77,
};
static short yycheck[] = { 15,
! 95, 36, 46, 41, 36, 40, 59, 59, 100, 208,
! 54, 41, 59, 199, 41, 40, 196, 257, 41, 93,
! 123, 44, 202, 36, 93, 59, 40, 40, 59, 29,
! 59, 40, 91, 49, 41, 58, 59, 41, 362, 131,
! 63, 257, 91, 41, 60, 61, 46, 47, 59, 94,
! 40, 15, 59, 53, 41, 40, 100, 41, 300, 301,
! 105, 59, 41, 59, 123, 65, 66, 67, 68, 393,
! 93, 40, 59, 41, 123, 41, 41, 91, 91, 123,
! 41, 45, 91, 44, 48, 40, 93, 131, 40, 123,
! 41, 123, 123, 59, 123, 41, 295, 58, 59, 115,
! 116, 44, 63, 106, 107, 108, 109, 110, 111, 123,
! 123, 40, 123, 59, 123, 40, 116, 133, 0, 59,
! 36, 37, 257, 59, 40, 89, 59, 278, 314, 59,
! 123, 41, 93, 266, 267, 268, 40, 270, 271, 338,
! 104, 157, 158, 159, 160, 161, 162, 163, 64, 59,
! 59, 33, 276, 277, 36, 37, 38, 41, 40, 44,
! 42, 43, 260, 45, 297, 181, 182, 183, 184, 185,
! 186, 187, 188, 189, 123, 59, 41, 59, 0, 41,
! 272, 257, 64, 199, 383, 40, 278, 203, 204, 40,
! 206, 155, 208, 41, 59, 298, 40, 59, 93, 215,
! 93, 217, 218, 8, 9, 257, 209, 125, 298, 91,
! 226, 33, 317, 91, 36, 37, 38, 93, 40, 93,
! 42, 43, 36, 45, 257, 257, 300, 301, 272, 41,
! 262, 300, 301, 298, 278, 125, 252, 59, 254, 255,
! 260, 123, 64, 125, 126, 258, 0, 300, 301, 272,
! 273, 274, 275, 300, 301, 91, 279, 40, 281, 93,
! 301, 296, 300, 301, 298, 272, 273, 274, 275, 91,
! 300, 301, 279, 300, 301, 370, 41, 300, 301, 33,
! 303, 304, 36, 37, 38, 260, 40, 40, 42, 43,
! 41, 45, 308, 300, 301, 41, 300, 301, 314, 41,
! 41, 123, 41, 125, 126, 59, 125, 271, 125, 273,
! 64, 272, 273, 274, 275, 279, 300, 301, 279, 59,
! 281, 300, 301, 125, 340, 125, 287, 288, 289, 290,
! 59, 41, 300, 301, 44, 300, 301, 91, 123, 300,
! 301, 41, 303, 304, 305, 306, 307, 308, 309, 300,
! 301, 312, 125, 63, 315, 316, 317, 300, 301, 41,
! 300, 301, 41, 379, 300, 301, 59, 300, 301, 123,
! 300, 301, 126, 40, 256, 257, 258, 259, 260, 261,
! 41, 263, 264, 265, 266, 267, 268, 269, 270, 271,
! 272, 273, 274, 275, 41, 41, 123, 279, 280, 41,
! 282, 283, 284, 285, 286, 300, 301, 300, 301, 291,
! 292, 293, 294, 295, 296, 297, 63, 123, 312, 41,
! 302, 315, 316, 317, 300, 301, 300, 301, 59, 311,
! 41, 313, 314, 59, 256, 257, 258, 259, 260, 261,
! 41, 263, 264, 265, 266, 267, 268, 269, 270, 271,
! 272, 273, 274, 275, 59, 41, 289, 279, 280, 35,
! 282, 283, 284, 285, 286, 52, 300, 301, 52, 291,
! 292, 293, 294, 295, 296, 297, 309, 15, 158, 312,
! 302, 379, 315, 316, 317, 206, 340, 24, -1, 311,
! -1, 313, 314, 309, 273, 41, 312, -1, 44, 315,
! 316, 317, 256, 257, 258, 259, 260, 261, -1, 263,
! 264, 265, 58, 59, -1, 269, -1, 63, 272, 273,
! 274, 275, -1, 289, 290, 279, 280, -1, 282, 283,
! 284, 285, 286, -1, -1, 125, -1, 291, 292, 293,
! 294, 295, 296, 309, -1, -1, 312, 93, 302, 315,
! 316, 317, -1, -1, -1, -1, -1, 311, 33, 313,
! 314, 36, 37, 38, -1, 40, 41, 42, 43, 44,
! 45, 281, -1, 125, -1, -1, -1, 287, 288, 289,
! 290, -1, -1, 58, 59, -1, -1, -1, 63, 64,
! -1, -1, -1, 303, 304, 305, 306, 307, 308, 309,
! -1, -1, 312, -1, -1, 315, 316, 317, 272, 273,
! 274, 275, -1, -1, -1, 279, 91, -1, 93, 33,
! -1, -1, 36, 37, 38, -1, 40, 41, 42, 43,
! 44, 45, -1, -1, 281, -1, 300, 301, -1, -1,
! 287, 288, 289, 290, 58, 59, -1, -1, -1, 63,
! 64, 126, -1, -1, -1, -1, 303, 304, 305, 306,
! 307, 308, 309, -1, -1, 312, -1, -1, 315, 316,
! 317, -1, -1, -1, -1, -1, 266, 267, 268, 93,
! 270, 271, 33, 289, 290, 36, 37, 38, -1, 40,
! -1, 42, 43, -1, 45, -1, 359, 360, -1, -1,
! -1, 364, 308, 309, -1, -1, 312, 297, 59, 315,
! 316, 317, 126, 64, 266, 267, 268, 380, 270, 271,
! -1, 384, -1, -1, -1, -1, 272, 273, 274, 275,
! -1, -1, -1, 279, -1, 281, -1, -1, -1, -1,
! 91, 287, 288, 289, 290, 297, -1, -1, -1, -1,
! -1, -1, -1, -1, 300, 301, -1, 303, 304, 305,
306, 307, 308, 309, -1, -1, 312, -1, -1, 315,
! 316, 317, 123, -1, -1, 126, -1, -1, -1, -1,
! -1, -1, 257, 258, 259, 260, 261, -1, 263, 264,
265, -1, -1, -1, 269, -1, -1, 272, 273, 274,
! 275, -1, -1, -1, 279, 280, 281, 282, 283, 284,
! 285, 286, 287, 288, 289, 290, 291, 292, 293, 294,
! 295, 296, -1, -1, -1, 300, 301, 302, 303, 304,
! 305, 306, 307, 308, 309, -1, 311, 312, 313, 314,
! 315, 316, 317, 257, 258, 259, 260, 261, -1, 263,
! 264, 265, -1, -1, -1, 269, -1, -1, 272, 273,
! 274, 275, -1, -1, -1, 279, 280, 281, 282, 283,
! 284, 285, 286, 287, 288, 289, 290, 291, 292, 293,
! 294, 295, 296, -1, -1, -1, 300, 301, 302, 303,
! 304, 305, 306, 307, 308, 309, -1, 311, 312, 313,
! 314, 315, 316, 317, -1, 256, 257, 258, 259, 260,
! 261, 63, 263, 264, 265, -1, -1, -1, 269, -1,
! -1, 272, 273, 274, 275, -1, -1, -1, 279, 280,
! -1, 282, 283, 284, 285, 286, -1, -1, -1, -1,
! 291, 292, 293, 294, 295, 296, -1, -1, -1, 33,
! -1, 302, 36, 37, 38, -1, 40, -1, 42, 43,
! 311, 45, 313, 314, -1, -1, -1, -1, 335, 336,
! 337, -1, 339, -1, -1, 59, -1, -1, -1, -1,
! 64, -1, -1, 41, -1, -1, 44, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, 366,
! 58, 59, -1, -1, -1, -1, 373, 91, -1, 33,
! 377, -1, 36, 37, 38, -1, 40, -1, 42, 43,
! -1, 45, -1, 390, 391, -1, 28, 29, -1, -1,
! -1, -1, -1, -1, -1, 93, -1, -1, 40, 123,
! 64, -1, 126, -1, 46, 47, 48, -1, -1, 33,
! 52, 53, 36, 37, 38, -1, 40, -1, 42, 43,
! -1, 45, -1, 65, 66, 67, 68, 91, 287, 288,
! 289, 290, -1, -1, -1, -1, -1, -1, -1, -1,
! 64, -1, -1, -1, -1, -1, -1, -1, 41, 308,
! 309, 44, -1, 312, -1, -1, 315, 316, 317, 123,
! -1, -1, 126, -1, -1, 58, 59, 91, -1, -1,
! 63, -1, -1, 33, 116, -1, 36, 37, 38, -1,
! 40, -1, 42, 43, -1, 45, -1, -1, -1, 281,
! -1, -1, -1, -1, -1, 287, 288, 289, 290, 123,
! 93, -1, 126, -1, 64, -1, -1, -1, -1, -1,
! -1, 303, 304, 305, 306, 307, 308, 309, -1, -1,
! 312, -1, -1, 315, 316, 317, -1, -1, -1, -1,
! -1, 91, 256, 257, 258, 259, 260, 261, 180, 263,
! 264, 265, -1, -1, -1, 269, -1, -1, 272, 273,
! 274, 275, -1, -1, -1, 279, 280, -1, 282, 283,
! 284, 285, 286, 123, -1, 207, 126, 291, 292, 293,
! 294, 295, 296, -1, 272, 273, 274, 275, 302, -1,
! -1, 279, -1, -1, -1, -1, -1, 311, -1, 313,
! 314, -1, -1, 257, 258, 259, 260, 261, 262, 263,
! 264, 265, 300, 301, -1, 269, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 280, -1, 282, 283,
284, 285, 286, -1, -1, -1, -1, 291, 292, 293,
! 294, 295, 296, 257, 258, 259, 260, 261, 302, 263,
! 264, 265, -1, -1, -1, 269, -1, 311, -1, 313,
! 314, -1, 58, -1, -1, -1, 280, 63, 282, 283,
! 284, 285, 286, -1, -1, -1, -1, 291, 292, 293,
! 294, 295, 296, -1, -1, -1, -1, -1, 302, 272,
! 273, 274, 275, -1, -1, -1, 279, 311, 281, 313,
! 314, -1, -1, -1, 287, 288, -1, 257, 258, 259,
! 260, 261, -1, 263, 264, 265, -1, 300, 301, 269,
! 303, 304, 305, 306, 307, 308, -1, -1, -1, -1,
! 280, -1, 282, 283, 284, 285, 286, -1, -1, -1,
! -1, 291, 292, 293, 294, 295, 296, -1, -1, -1,
! 33, -1, 302, 36, 37, 38, -1, 40, -1, 42,
! 43, 311, 45, 313, 314, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 59, -1, -1, -1,
! -1, 64, -1, -1, -1, 287, 288, 289, 290, -1,
! 33, -1, -1, 36, 37, 38, -1, 40, 41, 42,
! 43, -1, 45, 305, 306, 307, 308, 309, 91, -1,
! 312, -1, -1, 315, 316, 317, -1, -1, -1, -1,
! -1, 64, -1, -1, -1, 287, 288, 289, 290, -1,
! 33, -1, -1, 36, 37, 38, -1, 40, -1, 42,
! 43, -1, 45, 126, 306, 307, 308, 309, 91, -1,
! 312, -1, -1, 315, 316, 317, -1, -1, -1, -1,
! -1, 64, -1, -1, -1, -1, -1, -1, -1, -1,
! 33, -1, -1, 36, 37, 38, -1, 40, 41, 42,
! 43, -1, 45, 126, -1, 281, -1, -1, 91, -1,
! 93, 287, 288, 289, 290, -1, -1, -1, -1, -1,
! -1, 64, -1, -1, -1, -1, -1, 303, 304, 305,
! 306, 307, 308, 309, -1, -1, 312, -1, -1, 315,
! 316, 317, -1, 126, 287, 288, 289, 290, 91, -1,
! 33, -1, -1, 36, 37, 38, -1, 40, 41, 42,
! 43, -1, 45, -1, 307, 308, 309, -1, -1, 312,
! -1, -1, 315, 316, 317, -1, -1, -1, -1, -1,
! -1, 64, 287, 126, 289, 290, -1, -1, -1, -1,
! -1, -1, -1, -1, 257, 258, 259, 260, 261, -1,
! 263, 264, 265, 308, 309, -1, 269, 312, 91, -1,
! 315, 316, 317, -1, -1, -1, -1, 280, -1, 282,
! 283, 284, 285, 286, -1, -1, -1, -1, 291, 292,
! 293, 294, 295, 296, 257, 258, 259, 260, 261, 302,
! 263, 264, 265, 126, -1, -1, 269, -1, 311, -1,
! 313, 314, -1, -1, -1, -1, -1, 280, -1, 282,
! 283, 284, 285, 286, -1, -1, -1, -1, 291, 292,
! 293, 294, 295, 296, 257, 258, 259, 260, 261, 302,
! 263, 264, 265, -1, -1, -1, 269, -1, 311, -1,
! 313, 314, -1, -1, -1, -1, -1, 280, -1, 282,
! 283, 284, 285, 286, -1, -1, -1, -1, 291, 292,
! 293, 294, 295, 296, 257, 258, 259, 260, 261, 302,
! 263, 264, 265, -1, -1, -1, 269, -1, 311, -1,
! 313, 314, -1, -1, -1, -1, -1, 280, -1, 282,
! 283, 284, 285, 286, -1, -1, -1, -1, 291, 292,
! 293, 294, 295, 296, -1, -1, -1, 33, -1, 302,
! 36, 37, 38, -1, 40, 41, 42, 43, 311, 45,
! 313, 314, -1, -1, 257, 258, 259, 260, 261, -1,
! 263, 264, 265, -1, -1, -1, 269, -1, 64, -1,
! -1, -1, -1, -1, -1, -1, -1, 280, -1, 282,
! 283, 284, 285, 286, -1, -1, -1, -1, 291, 292,
! 293, 294, 295, 296, -1, 91, -1, 33, -1, 302,
! 36, 37, 38, -1, 40, 41, 42, 43, 311, 45,
! 313, 314, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 64, -1,
! 126, -1, -1, -1, -1, -1, 41, -1, -1, 44,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, 58, 59, 91, 33, -1, 63, 36,
! 37, 38, -1, 40, -1, 42, 43, -1, 45, -1,
! -1, -1, -1, -1, 287, 288, 289, 290, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 64, 93, -1,
! 126, 304, 305, 306, 307, 308, 309, -1, -1, 312,
! -1, -1, 315, 316, 317, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 91, -1, 33, -1, -1, 36,
37, 38, -1, 40, 41, 42, 43, -1, 45, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, 64, -1, 126,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 257, 258, 259, 260, 261, -1, 263, 264, 265,
! -1, -1, -1, 269, 91, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 280, -1, 282, 283, 284, 285,
! 286, -1, -1, -1, -1, 291, 292, 293, 294, 295,
! 296, 41, -1, -1, 44, -1, 302, -1, -1, 126,
! -1, -1, -1, -1, -1, 311, -1, 313, 314, 59,
! -1, 257, 258, 259, 260, 261, -1, 263, 264, 265,
! -1, 33, -1, 269, 36, 37, 38, -1, 40, 41,
! 42, 43, -1, 45, 280, -1, 282, 283, 284, 285,
! 286, -1, -1, 93, -1, 291, 292, 293, 294, 295,
! 296, -1, 64, -1, -1, -1, 302, 272, 273, 274,
! 275, -1, -1, -1, 279, 311, 281, 313, 314, 256,
! 257, 258, 259, 260, 261, -1, 263, 264, 265, 91,
! -1, -1, 269, -1, -1, 300, 301, -1, 303, 304,
! 305, 306, 307, 280, -1, 282, 283, 284, 285, 286,
-1, -1, -1, -1, 291, 292, 293, 294, 295, 296,
! -1, -1, -1, 33, 126, 302, 36, 37, 38, -1,
40, 41, 42, 43, 311, 45, 313, 314, -1, -1,
257, 258, 259, 260, 261, -1, 263, 264, 265, -1,
-1, -1, 269, -1, 64, -1, -1, -1, -1, -1,
***************
*** 866,1131 ****
-1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
-1, -1, -1, -1, 291, 292, 293, 294, 295, 296,
-1, 91, -1, 33, -1, 302, 36, 37, 38, -1,
! 40, 41, 42, 43, 311, 45, 313, 314, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, 64, -1, 126, -1, -1, -1,
- -1, -1, 41, -1, -1, 44, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 58,
- 59, 91, 33, -1, 63, 36, 37, 38, -1, 40,
- -1, 42, 43, -1, 45, -1, -1, -1, -1, -1,
- 287, 288, 289, 290, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, 64, 93, -1, 126, 304, 305, 306,
- 307, 308, 309, -1, -1, 312, -1, -1, 315, 316,
- 317, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 91, -1, 33, -1, -1, 36, 37, 38, -1, 40,
- 41, 42, 43, -1, 45, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, 64, -1, 126, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, 257, 258, 259,
260, 261, -1, 263, 264, 265, -1, -1, -1, 269,
! 91, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 280, -1, 282, 283, 284, 285, 286, -1, -1, -1,
! -1, 291, 292, 293, 294, 295, 296, -1, -1, -1,
! -1, -1, 302, -1, -1, 126, -1, -1, -1, -1,
-1, 311, -1, 313, 314, -1, -1, 257, 258, 259,
! 260, 261, -1, 263, 264, 265, -1, 33, -1, 269,
! 36, 37, 38, -1, 40, 41, 42, 43, -1, 45,
280, -1, 282, 283, 284, 285, 286, -1, -1, -1,
! -1, 291, 292, 293, 294, 295, 296, -1, 64, -1,
! -1, -1, 302, 272, 273, 274, 275, -1, -1, -1,
! 279, 311, 281, 313, 314, 256, 257, 258, 259, 260,
! 261, -1, 263, 264, 265, 91, -1, -1, 269, -1,
! -1, 300, 301, -1, 303, 304, 305, 306, 307, 280,
! -1, 282, 283, 284, 285, 286, -1, -1, -1, -1,
! 291, 292, 293, 294, 295, 296, -1, -1, -1, 33,
! 126, 302, 36, 37, 38, -1, 40, 41, 42, 43,
! 311, 45, 313, 314, -1, -1, 257, 258, 259, 260,
! 261, -1, 263, 264, 265, -1, -1, -1, 269, -1,
! 64, -1, -1, -1, -1, -1, -1, -1, -1, 280,
! -1, 282, 283, 284, 285, 286, -1, -1, -1, -1,
! 291, 292, 293, 294, 295, 296, -1, 91, -1, 33,
! -1, 302, 36, 37, 38, -1, 40, -1, 42, 43,
! 311, 45, 313, 314, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 28, 29,
! 64, -1, 126, -1, -1, -1, -1, -1, 41, -1,
! 40, 44, -1, -1, -1, -1, 46, 47, 48, -1,
! -1, -1, 52, 53, -1, 58, 59, 91, -1, -1,
! 63, -1, -1, -1, -1, 65, 66, 67, 68, -1,
! -1, 257, 258, 259, 260, 261, -1, 263, 264, 265,
! -1, -1, -1, 269, -1, 41, -1, -1, 44, -1,
! 93, -1, 126, -1, 280, -1, 282, 283, 284, 285,
! 286, 41, -1, 59, 44, 291, 292, 293, 294, 295,
! 296, -1, 112, -1, -1, -1, 302, -1, 58, 59,
! -1, -1, -1, 63, -1, 311, -1, 313, 314, -1,
! -1, -1, -1, -1, -1, -1, -1, 93, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, 93, -1, 41, -1, -1, 44, -1,
! -1, -1, -1, 257, 258, 259, 260, 261, -1, 263,
! 264, 265, 58, 59, -1, 269, 176, 63, -1, -1,
! -1, -1, -1, -1, -1, -1, 280, -1, 282, 283,
! 284, 285, 286, -1, -1, -1, -1, 291, 292, 293,
! 294, 295, 296, 203, -1, -1, -1, 93, 302, -1,
! -1, -1, -1, -1, -1, 41, -1, 311, 44, 313,
! 314, -1, -1, 257, 258, 259, 260, 261, -1, 263,
! 264, 265, 58, 59, -1, 269, -1, 63, -1, -1,
! -1, -1, -1, -1, -1, -1, 280, -1, 282, 283,
! 284, 285, 286, -1, -1, -1, -1, 291, 292, 293,
! 294, 295, 296, -1, -1, -1, -1, 93, 302, 272,
! 273, 274, 275, -1, -1, -1, 279, 311, 281, 313,
! 314, -1, -1, -1, 287, 288, 289, 290, -1, -1,
! -1, -1, -1, 41, -1, -1, 44, 300, 301, -1,
! 303, 304, 305, 306, 307, 308, 309, -1, -1, 312,
! 58, 59, 315, 316, 317, 63, 272, 273, 274, 275,
! -1, -1, -1, 279, -1, -1, -1, -1, -1, -1,
! -1, -1, 272, 273, 274, 275, -1, -1, -1, 279,
! 41, 281, -1, 44, 300, 93, -1, 287, 288, 289,
! 290, -1, -1, -1, -1, -1, -1, 58, 59, -1,
! 300, 301, 63, 303, 304, 305, 306, 307, 308, 309,
! -1, -1, 312, -1, -1, 315, 316, 317, -1, -1,
! -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
! -1, 41, 93, 279, 44, 281, -1, -1, -1, -1,
! -1, 287, 288, 289, 290, -1, -1, -1, 58, 59,
! -1, -1, -1, 63, 300, 301, -1, 303, 304, 305,
306, 307, 308, 309, -1, -1, 312, -1, -1, 315,
316, 317, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, 41, 93, -1, 44, 272, 273, 274, 275,
! -1, 41, -1, 279, 44, 281, -1, -1, -1, 58,
! 59, 287, 288, 289, 290, -1, -1, -1, 58, 59,
! -1, -1, -1, 63, 300, 301, -1, 303, 304, 305,
! 306, 307, 308, 309, -1, -1, 312, -1, -1, 315,
! 316, 317, -1, -1, 93, -1, -1, 41, -1, -1,
! 44, -1, -1, 93, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 58, 59, -1, -1, -1, 63,
-1, -1, -1, -1, 272, 273, 274, 275, -1, -1,
-1, 279, -1, 281, -1, -1, -1, -1, -1, 287,
! 288, 289, 290, -1, -1, -1, -1, -1, -1, 93,
! -1, -1, 300, 301, -1, 303, 304, 305, 306, 307,
! 308, 309, -1, -1, 312, -1, -1, 315, 316, 317,
! -1, 272, 273, 274, 275, -1, 41, -1, 279, 44,
! 281, -1, -1, -1, -1, -1, 287, 288, 289, 290,
! -1, -1, -1, 58, 59, -1, -1, -1, 63, 300,
! 301, -1, 303, 304, 305, 306, 307, 308, 309, -1,
! -1, 312, -1, -1, 315, 316, 317, -1, -1, -1,
! -1, -1, 272, 273, 274, 275, -1, 41, 93, 279,
! 44, 281, -1, -1, -1, -1, -1, 287, 288, 289,
! 290, -1, -1, -1, 58, 59, -1, -1, -1, 63,
300, 301, -1, 303, 304, 305, 306, 307, 308, 309,
! -1, -1, 312, -1, -1, 315, 316, 317, -1, -1,
! -1, -1, -1, 272, 273, 274, 275, -1, -1, 93,
! 279, -1, 272, 273, 274, 275, -1, 41, -1, 279,
! 44, 281, -1, -1, -1, -1, -1, 287, 288, 289,
! 290, 300, 301, -1, 58, 59, -1, -1, -1, 63,
! 300, 301, -1, 303, 304, 305, 306, 307, 308, 309,
! -1, -1, 312, -1, -1, 315, 316, 317, 272, 273,
! 274, 275, -1, 41, -1, 279, 44, 281, -1, 93,
! -1, -1, -1, 287, 288, 289, 290, -1, -1, -1,
! 58, 59, -1, -1, -1, 63, 300, 301, -1, 303,
! 304, 305, 306, 307, 308, 309, -1, -1, 312, -1,
! -1, 315, 316, 317, -1, -1, -1, -1, -1, 41,
! -1, -1, 44, -1, -1, 93, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 58, 59, -1, -1,
! -1, 63, 41, -1, -1, 44, -1, 272, 273, 274,
! 275, -1, -1, -1, 279, -1, 281, -1, -1, 58,
! 59, -1, 287, 288, 289, 290, -1, -1, -1, -1,
! -1, 93, -1, -1, -1, 300, 301, -1, 303, 304,
! 305, 306, 307, 308, 309, -1, -1, 312, -1, -1,
! 315, 316, 317, 41, 93, -1, 44, -1, 272, 273,
! 274, 275, 41, -1, -1, 279, -1, 281, -1, -1,
! 58, 59, -1, 287, 288, 289, 290, -1, -1, 58,
! 59, -1, -1, -1, 63, -1, 300, 301, -1, 303,
! 304, 305, 306, 307, 308, 309, -1, -1, 312, -1,
! -1, 315, 316, 317, -1, 93, -1, -1, -1, -1,
! -1, -1, -1, -1, 93, -1, -1, -1, 272, 273,
! 274, 275, 41, -1, -1, 279, -1, 281, -1, -1,
! -1, -1, -1, 287, 288, 289, 290, -1, -1, 58,
! 59, -1, -1, -1, 63, -1, 300, 301, -1, 303,
! 304, 305, 306, 307, 308, 309, -1, -1, 312, -1,
! -1, 315, 316, 317, 272, 273, 274, 275, 41, -1,
! -1, 279, -1, 281, 93, -1, -1, -1, -1, 287,
! 288, 289, 290, -1, -1, 58, 59, -1, -1, -1,
! 63, -1, 300, 301, -1, 303, 304, 305, 306, 307,
! 308, 309, -1, -1, 312, -1, -1, 315, 316, 317,
! 272, 273, 274, 275, -1, -1, -1, 279, -1, 281,
! 93, -1, -1, -1, -1, 287, 288, 289, 290, -1,
! -1, -1, -1, 272, 273, 274, 275, -1, 300, 301,
! 279, 303, 304, 305, 306, 307, 308, 309, -1, 41,
! 312, -1, 44, 315, 316, 317, -1, -1, -1, -1,
! -1, 300, 301, -1, 303, -1, 58, 59, -1, -1,
! -1, 63, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 272, 273, 274, 275, -1, -1,
! -1, 279, -1, 272, 273, 274, 275, -1, -1, -1,
! 279, 93, 281, -1, -1, -1, -1, -1, 287, 288,
! 289, 290, 300, 301, -1, -1, -1, -1, -1, -1,
! -1, 300, 301, -1, 303, 304, 305, 306, 307, 308,
! 309, -1, -1, 312, -1, -1, 315, 316, 317, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, 272, 273, 274, 275, -1, -1, -1,
- 279, 41, 281, -1, 44, -1, -1, -1, 287, 288,
- 289, 290, -1, -1, -1, -1, -1, -1, 58, 59,
- -1, 300, 301, 63, 303, 304, 305, 306, 307, 308,
- 309, -1, -1, 312, -1, -1, 315, 316, 317, 272,
- 273, 274, 275, -1, 41, -1, 279, 44, 281, -1,
- -1, -1, -1, 93, 287, 288, 289, 290, -1, -1,
- -1, 58, 59, -1, -1, -1, 63, 300, 301, -1,
- 303, 304, 305, 306, 307, 308, 309, 33, -1, 312,
- -1, -1, 315, 316, 317, 41, -1, -1, 41, 45,
- -1, 44, 48, -1, -1, 51, 93, -1, -1, 55,
- 56, 57, 58, 59, -1, 58, 59, 63, 64, -1,
- 63, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 272, 273, 274, 275, -1, -1, -1, 279, 41, 281,
- -1, 44, -1, -1, -1, 287, 288, 289, 290, -1,
- 93, -1, 98, -1, -1, 58, 59, -1, 300, 301,
- 63, 303, 304, 305, 306, 307, 308, 309, -1, -1,
- 312, -1, -1, -1, -1, -1, 41, -1, -1, 44,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 93, -1, -1, 58, 59, -1, -1, -1, 63, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 160, 161, 162, 163, 164, 165,
! 166, 167, 168, 169, 170, 171, 172, 173, 93, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 187, 272, 273, 274, 275, -1, 41, -1, 279,
44, 281, -1, -1, -1, -1, -1, 287, 288, 289,
! 290, -1, -1, -1, 58, 59, -1, -1, -1, 63,
300, 301, -1, 303, 304, 305, 306, 307, 308, 309,
! -1, -1, 312, -1, -1, 272, 273, 274, 275, -1,
! 41, -1, 279, 44, 281, -1, -1, -1, -1, 93,
! 287, 288, 289, 290, -1, -1, -1, 58, 59, -1,
! -1, -1, 63, 300, 301, -1, 303, 304, 305, 306,
! 307, 308, 309, -1, -1, -1, 272, -1, -1, 272,
! 273, 274, 275, -1, -1, -1, 279, 41, 281, -1,
! 44, -1, 93, -1, 287, 288, 289, 290, -1, -1,
! -1, -1, -1, -1, 58, 59, -1, 300, 301, 305,
! 303, 304, 305, 306, 307, 308, 309, -1, -1, 272,
! 273, 274, 275, -1, 41, -1, 279, 44, 281, -1,
! -1, -1, -1, -1, 287, 288, 289, 290, -1, 93,
! -1, 58, 59, -1, -1, -1, 63, 300, 301, -1,
! 303, 304, 305, 306, 307, 308, 309, 272, 273, 274,
! 275, -1, 41, -1, 279, 44, 281, -1, -1, -1,
! -1, -1, 287, 288, 289, 290, 93, -1, -1, 58,
! 59, -1, -1, -1, 63, 300, 301, -1, 303, 304,
! 305, 306, 307, 308, 309, -1, -1, -1, -1, 41,
! -1, -1, 44, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 93, -1, 58, 59, -1, -1,
! -1, 63, -1, -1, -1, -1, -1, -1, 272, 273,
! 274, 275, -1, -1, -1, 279, -1, 281, -1, -1,
! -1, -1, -1, 287, 288, 289, 290, 58, -1, -1,
! -1, 93, 63, -1, -1, -1, 300, 301, -1, 303,
! 304, 305, 306, 307, 308, 309, -1, -1, -1, -1,
! -1, 272, 273, 274, 275, -1, 41, -1, 279, 44,
! 281, -1, -1, -1, -1, -1, 287, 288, 289, 290,
! -1, -1, -1, 58, 59, -1, -1, -1, 63, 300,
! 301, -1, 303, 304, 305, 306, 307, 308, 309, -1,
! -1, -1, -1, 41, -1, -1, 44, -1, 272, 273,
! 274, 275, -1, 41, -1, 279, 44, -1, 93, -1,
! 58, 59, -1, -1, -1, 63, -1, -1, -1, -1,
! 58, 59, -1, -1, -1, 63, 300, 301, -1, -1,
! -1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
! 41, -1, 279, 44, 281, 93, -1, -1, -1, -1,
! 287, 288, 289, 290, -1, 93, -1, 58, 59, -1,
! -1, -1, 63, 300, 301, -1, 303, 304, 305, 306,
! 307, 308, 309, 272, 273, 274, 275, -1, 41, -1,
279, 44, 281, -1, -1, -1, -1, -1, 287, 288,
! 289, 290, 93, -1, -1, 58, 59, -1, -1, -1,
63, 300, 301, -1, 303, 304, 305, 306, 307, 308,
272, 273, 274, 275, -1, 41, -1, 279, 44, 281,
! -1, -1, -1, -1, -1, 287, 288, -1, 290, -1,
! 93, 41, 58, 59, 44, -1, -1, 63, 300, 301,
! -1, 303, 304, 305, 306, 307, 308, -1, 58, 59,
! 281, -1, -1, 63, -1, -1, 287, 288, 289, 290,
! -1, -1, -1, -1, -1, -1, -1, 93, -1, -1,
! -1, -1, 303, 304, 305, 306, 307, 308, 309, -1,
! -1, 312, -1, 93, 315, 316, 317, 272, 273, 274,
! 275, -1, 41, -1, 279, 44, 281, -1, -1, -1,
! -1, -1, 287, 288, -1, -1, -1, -1, -1, 58,
! 59, -1, -1, -1, 63, 300, 301, -1, 303, 304,
! 305, 306, 307, -1, 272, 273, 274, 275, -1, 41,
! -1, 279, 44, 281, 272, 273, 274, 275, -1, 287,
! 288, 279, -1, 281, 93, -1, 58, 59, -1, 287,
! 288, 63, 300, 301, -1, 303, 304, 305, 306, 307,
-1, -1, 300, 301, -1, 303, 304, 305, 306, 307,
-1, 272, 273, 274, 275, -1, -1, -1, 279, -1,
! 281, 93, -1, -1, -1, -1, 287, 288, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, 300,
! 301, -1, 303, 304, 305, 306, 307, -1, -1, 272,
! 273, 274, 275, -1, -1, -1, 279, -1, 281, -1,
! -1, -1, -1, -1, -1, 288, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 300, 301, -1,
! 303, 304, 305, 306, 307, -1, 272, 273, 274, 275,
-1, -1, -1, 279, -1, 281, -1, -1, -1, -1,
! -1, -1, 272, 273, 274, 275, -1, -1, -1, 279,
! -1, 281, -1, -1, 300, 301, -1, 303, 304, 305,
! 306, 307, -1, -1, -1, -1, -1, -1, -1, -1,
! 300, 301, -1, 303, 304, 305, 306, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, 272, 273, 274, 275, -1, -1, -1,
! 279, -1, 281, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 300, 301, -1, 303, 304, 305, -1, -1, -1,
! 272, 273, 274, 275, -1, -1, -1, 279, -1, 281,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 300, 301,
! -1, 303, 304,
};
#define YYFINAL 1
#ifndef YYDEBUG
--- 922,1162 ----
-1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
-1, -1, -1, -1, 291, 292, 293, 294, 295, 296,
-1, 91, -1, 33, -1, 302, 36, 37, 38, -1,
! 40, -1, 42, 43, 311, 45, 313, 314, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, 64, -1, 126, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, 272, 273, 274, 275, -1, -1, -1, 279,
! -1, 91, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, 257, 258, 259, 260, 261,
! 300, 263, 264, 265, -1, -1, -1, 269, -1, -1,
! -1, -1, -1, -1, -1, -1, 126, -1, 280, -1,
! 282, 283, 284, 285, 286, -1, 41, -1, -1, 291,
! 292, 293, 294, 295, 296, -1, -1, -1, -1, -1,
! 302, -1, -1, 58, 59, -1, -1, -1, 63, 311,
! -1, 313, 314, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 93, -1,
-1, -1, -1, -1, -1, -1, -1, 257, 258, 259,
260, 261, -1, 263, 264, 265, -1, -1, -1, 269,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 280, -1, 282, 283, 284, 285, 286, 41, -1, -1,
! 44, 291, 292, 293, 294, 295, 296, -1, -1, -1,
! -1, -1, 302, -1, 58, 59, -1, -1, -1, 63,
-1, 311, -1, 313, 314, -1, -1, 257, 258, 259,
! 260, 261, -1, 263, 264, 265, -1, -1, -1, 269,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, 93,
280, -1, 282, 283, 284, 285, 286, -1, -1, -1,
! -1, 291, 292, 293, 294, 295, 296, 33, -1, -1,
! 63, -1, 302, -1, -1, 41, -1, -1, -1, 45,
! -1, 311, 48, 313, 314, 51, -1, -1, -1, 55,
! 56, 57, 58, 59, -1, -1, -1, 63, 64, 41,
! -1, -1, 44, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 58, 59, -1, -1,
! -1, 63, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 102, 272, 273, 274,
! 275, -1, -1, -1, 279, 41, 281, -1, 44, -1,
! -1, 93, 287, 288, 289, 290, -1, -1, -1, -1,
! -1, -1, 58, 59, -1, 300, 301, 63, 303, 304,
! 305, 306, 307, 308, 309, -1, -1, 312, -1, -1,
! 315, 316, 317, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 93, 164, 165,
! 166, 167, 168, 169, 170, 171, 172, 173, 174, 175,
! 176, 177, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, 191, -1, -1, 272, 273,
! 274, 275, -1, 41, -1, 279, 44, 281, -1, -1,
! -1, -1, -1, 287, 288, 289, 290, -1, -1, -1,
! 58, 59, -1, -1, -1, 63, 300, 301, -1, 303,
! 304, 305, 306, 307, 308, 309, -1, -1, 312, -1,
! -1, 315, 316, 317, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, 41, -1, 93, 44, -1, 281, -1,
! -1, -1, -1, -1, 287, 288, 289, 290, -1, -1,
! 58, 59, -1, -1, -1, 63, -1, -1, -1, -1,
! 276, 304, 305, 306, 307, 308, 309, -1, -1, 312,
! -1, -1, 315, 316, 317, -1, -1, -1, -1, -1,
! 272, 273, 274, 275, -1, 93, -1, 279, 41, 281,
! -1, 44, -1, 309, -1, 287, 288, 289, 290, -1,
! -1, -1, -1, -1, -1, 58, 59, -1, 300, 301,
! 63, 303, 304, 305, 306, 307, 308, 309, -1, -1,
! 312, -1, -1, 315, 316, 317, 272, 273, 274, 275,
! -1, -1, -1, 279, 41, 281, -1, 44, -1, -1,
! 93, 287, 288, 289, 290, -1, -1, -1, -1, -1,
! -1, 58, 59, -1, 300, 301, 63, 303, 304, 305,
306, 307, 308, 309, -1, -1, 312, -1, -1, 315,
316, 317, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 41, -1, -1, 44, -1, 93, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 58, 59,
! -1, -1, -1, 63, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, 272, 273, 274, 275, -1, -1,
-1, 279, -1, 281, -1, -1, -1, -1, -1, 287,
! 288, 289, 290, 93, -1, -1, -1, -1, 41, -1,
! -1, 44, 300, 301, -1, 303, 304, 305, 306, 307,
! 308, 309, -1, -1, 312, 58, 59, 315, 316, 317,
! 63, -1, -1, -1, 272, 273, 274, 275, -1, -1,
! -1, 279, -1, 281, -1, -1, -1, -1, -1, 287,
! 288, 289, 290, -1, -1, -1, -1, -1, 41, -1,
! 93, 44, 300, 301, -1, 303, 304, 305, 306, 307,
! 308, 309, -1, -1, 312, 58, 59, 315, 316, 317,
! 63, -1, -1, -1, -1, -1, -1, -1, -1, 272,
! 273, 274, 275, -1, -1, -1, 279, -1, 281, -1,
! -1, -1, -1, -1, 287, 288, 289, 290, -1, -1,
! 93, -1, -1, -1, -1, -1, -1, 300, 301, -1,
! 303, 304, 305, 306, 307, 308, 309, -1, -1, 312,
! -1, -1, 315, 316, 317, 272, 273, 274, 275, -1,
! 41, -1, 279, 44, 281, -1, -1, -1, -1, -1,
! 287, 288, 289, 290, -1, -1, -1, 58, 59, -1,
! -1, -1, 63, 300, 301, -1, 303, 304, 305, 306,
! 307, 308, 309, -1, -1, 312, -1, -1, 315, 316,
! 317, -1, 272, 273, 274, 275, -1, -1, -1, 279,
! -1, 281, 93, -1, -1, -1, -1, 287, 288, 289,
! 290, -1, -1, -1, -1, -1, 41, -1, -1, 44,
300, 301, -1, 303, 304, 305, 306, 307, 308, 309,
! -1, -1, 312, 58, 59, 315, 316, 317, 63, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, 272,
! 273, 274, 275, -1, -1, -1, 279, -1, 281, -1,
! -1, -1, -1, -1, 287, 288, 289, 290, 93, -1,
! -1, -1, -1, 41, -1, -1, 44, 300, 301, -1,
! 303, 304, 305, 306, 307, 308, 309, -1, -1, 312,
! 58, 59, 315, 316, 317, 63, -1, -1, -1, 272,
! 273, 274, 275, -1, -1, -1, 279, -1, 281, -1,
! -1, -1, -1, -1, 287, 288, 289, 290, -1, -1,
! -1, -1, -1, 41, -1, 93, 44, 300, 301, -1,
! 303, 304, 305, 306, 307, 308, 309, -1, -1, 312,
! 58, 59, 315, 316, 317, 63, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, 93, 41, -1, -1, 44,
! -1, 272, 273, 274, 275, 41, -1, -1, 279, -1,
! 281, -1, -1, 58, 59, -1, 287, 288, 289, 290,
! -1, -1, 58, 59, -1, -1, -1, 63, -1, 300,
! 301, -1, 303, 304, 305, 306, 307, 308, 309, -1,
! -1, 312, -1, -1, 315, 316, 317, -1, 93, -1,
! -1, -1, -1, -1, -1, -1, -1, 93, -1, -1,
! -1, -1, -1, 41, -1, -1, 44, 272, 273, 274,
! 275, 41, -1, -1, 279, -1, 281, -1, -1, -1,
! 58, 59, 287, 288, 289, 290, -1, -1, 58, 59,
! -1, -1, -1, 63, -1, 300, 301, -1, 303, 304,
! 305, 306, 307, 308, 309, -1, -1, 312, -1, -1,
! 315, 316, 317, -1, -1, 93, -1, -1, -1, -1,
! -1, -1, -1, 93, 272, 273, 274, 275, -1, -1,
! -1, 279, 41, 281, -1, 44, -1, -1, -1, 287,
! 288, 289, 290, -1, -1, -1, -1, -1, -1, 58,
! 59, -1, 300, 301, 63, 303, 304, 305, 306, 307,
! 308, 309, -1, -1, 312, -1, -1, 315, 316, 317,
! -1, -1, -1, -1, 272, 273, 274, 275, -1, 41,
! -1, 279, 44, 281, 93, -1, -1, -1, -1, 287,
! 288, 289, 290, -1, -1, -1, 58, 59, -1, -1,
! -1, 63, 300, 301, -1, 303, 304, 305, 306, 307,
! 308, 309, -1, -1, 312, -1, -1, 315, 316, 317,
! -1, -1, -1, -1, -1, -1, -1, 272, 273, 274,
! 275, 93, -1, -1, 279, -1, 272, 273, 274, 275,
! -1, 41, -1, 279, 44, 281, -1, -1, -1, -1,
! -1, 287, 288, 289, 290, 300, 301, -1, 58, 59,
! -1, -1, -1, 63, 300, 301, -1, 303, 304, 305,
! 306, 307, 308, 309, -1, -1, 312, -1, -1, 315,
! 316, 317, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, 93, 272, 273, 274, 275, -1, -1,
! -1, 279, 272, 273, 274, 275, -1, 41, -1, 279,
44, 281, -1, -1, -1, -1, -1, 287, 288, 289,
! 290, -1, 300, 301, 58, 59, -1, -1, -1, 63,
300, 301, -1, 303, 304, 305, 306, 307, 308, 309,
! -1, -1, 312, -1, -1, 315, 316, 317, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, 93,
! -1, -1, -1, 272, 273, 274, 275, -1, 41, -1,
279, 44, 281, -1, -1, -1, -1, -1, 287, 288,
! 289, 290, -1, -1, -1, 58, 59, -1, -1, -1,
63, 300, 301, -1, 303, 304, 305, 306, 307, 308,
+ 309, -1, -1, 312, -1, -1, -1, -1, -1, -1,
272, 273, 274, 275, -1, 41, -1, 279, 44, 281,
! 93, -1, -1, -1, -1, 287, 288, 289, 290, -1,
! -1, -1, 58, 59, -1, -1, -1, 63, 300, 301,
! -1, 303, 304, 305, 306, 307, 308, 309, -1, -1,
! 312, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 41, -1, -1, 44, -1, -1, -1, 93, -1, -1,
! -1, -1, 272, 273, 274, 275, -1, 58, 59, 279,
! -1, 281, 63, -1, -1, -1, -1, 287, 288, 289,
! 290, -1, -1, -1, -1, -1, -1, -1, -1, 41,
! 300, 301, 44, 303, 304, 305, 306, 307, 308, 309,
! -1, -1, 93, -1, -1, -1, 58, 59, -1, -1,
! -1, 63, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 272, 273,
! 274, 275, -1, 41, -1, 279, 44, 281, -1, -1,
! -1, 93, -1, 287, 288, 289, 290, -1, -1, -1,
! 58, 59, -1, -1, -1, 63, 300, 301, -1, 303,
! 304, 305, 306, 307, 308, 309, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 41, -1, -1,
! 44, -1, -1, -1, -1, 93, -1, -1, -1, 272,
! 273, 274, 275, -1, 58, 59, 279, -1, 281, 63,
! -1, -1, -1, -1, 287, 288, 289, 290, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 300, 301, -1,
! 303, 304, 305, 306, 307, 308, 309, -1, -1, 93,
! -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
! -1, 41, -1, 279, 44, 281, -1, -1, -1, -1,
! -1, 287, 288, 289, 290, -1, -1, -1, 58, 59,
! -1, -1, -1, 63, 300, 301, -1, 303, 304, 305,
! 306, 307, 308, 309, -1, -1, -1, -1, -1, -1,
! -1, 272, 273, 274, 275, -1, -1, -1, 279, 41,
! 281, -1, 44, 93, -1, -1, 287, 288, 289, 290,
! -1, -1, -1, -1, -1, -1, 58, 59, -1, 300,
! 301, 63, 303, 304, 305, 306, 307, 308, 309, -1,
! 272, 273, 274, 275, -1, 41, -1, 279, 44, 281,
! -1, -1, -1, -1, -1, 287, 288, 289, 290, -1,
! -1, 93, 58, 59, -1, -1, -1, 63, 300, 301,
! -1, 303, 304, 305, 306, 307, 308, 309, -1, -1,
! -1, -1, -1, -1, 272, 273, 274, 275, -1, 41,
! -1, 279, 44, 281, -1, -1, -1, 93, -1, 287,
! 288, 289, 290, -1, -1, -1, 58, 59, -1, -1,
! -1, 63, 300, 301, -1, 303, 304, 305, 306, 307,
! 308, 309, -1, -1, -1, -1, -1, -1, 272, 273,
! 274, 275, -1, 41, -1, 279, 44, 281, -1, -1,
! -1, 93, -1, 287, 288, 289, 290, -1, -1, -1,
! 58, 59, -1, -1, -1, 63, 300, 301, -1, 303,
! 304, 305, 306, 307, 308, -1, -1, -1, -1, -1,
! 41, -1, -1, 44, -1, -1, -1, -1, -1, -1,
! 41, -1, -1, 44, -1, 93, -1, 58, 59, -1,
! -1, -1, 272, 273, 274, 275, -1, 58, 59, 279,
! -1, 281, 63, -1, -1, -1, -1, 287, 288, -1,
! 290, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 300, 301, 93, 303, 304, 305, 306, 307, 308, -1,
! -1, -1, 93, -1, -1, 41, -1, -1, 44, -1,
! 272, 273, 274, 275, -1, 41, -1, 279, 44, 281,
! -1, -1, 58, 59, -1, 287, 288, 63, -1, -1,
! -1, -1, 58, 59, -1, -1, -1, 63, 300, 301,
! -1, 303, 304, 305, 306, 307, 272, 273, 274, 275,
! -1, 41, -1, 279, 44, 281, -1, 93, -1, -1,
! -1, 287, 288, -1, -1, -1, -1, 93, 58, 59,
! -1, -1, -1, 63, 300, 301, -1, 303, 304, 305,
! 306, 307, -1, -1, -1, -1, -1, -1, -1, -1,
! 272, 273, 274, 275, -1, 41, -1, 279, 44, 281,
! -1, -1, -1, 93, -1, 287, 288, -1, -1, -1,
! -1, -1, 58, 59, -1, -1, -1, 63, 300, 301,
! -1, 303, 304, 305, 306, 307, -1, 41, -1, -1,
! 44, -1, -1, -1, 272, 273, 274, 275, -1, -1,
! -1, 279, -1, 281, 58, 59, -1, 93, -1, 287,
! 288, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, 300, 301, -1, 303, 304, 305, 306, 307,
+ -1, 272, 273, 274, 275, -1, -1, -1, 279, 93,
-1, 272, 273, 274, 275, -1, -1, -1, 279, -1,
! 281, -1, -1, -1, -1, -1, -1, 288, -1, 300,
! 301, -1, 303, -1, -1, -1, -1, -1, -1, 300,
! 301, -1, 303, 304, 305, 306, 307, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
! -1, -1, -1, 279, -1, 281, 272, 273, 274, 275,
-1, -1, -1, 279, -1, 281, -1, -1, -1, -1,
! -1, -1, -1, -1, 300, 301, -1, 303, 304, 305,
! 306, 307, -1, -1, 300, 301, -1, 303, 304, 305,
! 306, -1, 272, 273, 274, 275, -1, -1, -1, 279,
! -1, 281, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 300, 301, -1, 303, 304, 305, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
+ -1, -1, -1, 279, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 300, 301, -1, 303, 272, 273,
! 274, 275, -1, -1, -1, 279, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 300, 301,
};
#define YYFINAL 1
#ifndef YYDEBUG
***************
*** 1152,1161 ****
};
static char *yyrule[] = {
"$accept : prog",
! "$$1 :",
! "prog : $$1 lineseq",
"block : '{' remember lineseq '}'",
"remember :",
"mblock : '{' mremember lineseq '}'",
"mremember :",
"lineseq :",
--- 1183,1192 ----
};
static char *yyrule[] = {
"$accept : prog",
! "prog : progstart lineseq",
"block : '{' remember lineseq '}'",
"remember :",
+ "progstart :",
"mblock : '{' mremember lineseq '}'",
"mremember :",
"lineseq :",
***************
*** 1222,1229 ****
"subbody : ';'",
"package : PACKAGE WORD ';'",
"package : PACKAGE ';'",
! "$$2 :",
! "use : USE startsub $$2 WORD WORD listexpr ';'",
"expr : expr ANDOP expr",
"expr : expr OROP expr",
"expr : argexpr",
--- 1253,1260 ----
"subbody : ';'",
"package : PACKAGE WORD ';'",
"package : PACKAGE ';'",
! "$$1 :",
! "use : USE startsub $$1 WORD WORD listexpr ';'",
"expr : expr ANDOP expr",
"expr : expr OROP expr",
"expr : argexpr",
***************
*** 1238,1245 ****
"listop : FUNCMETH indirob '(' listexprcom ')'",
"listop : LSTOP listexpr",
"listop : FUNC '(' listexprcom ')'",
! "$$3 :",
! "listop : LSTOPSUB startanonsub block $$3 listexpr",
"method : METHOD",
"method : scalar",
"subscripted : star '{' expr ';' '}'",
--- 1269,1276 ----
"listop : FUNCMETH indirob '(' listexprcom ')'",
"listop : LSTOP listexpr",
"listop : FUNC '(' listexprcom ')'",
! "$$2 :",
! "listop : LSTOPSUB startanonsub block $$2 listexpr",
"method : METHOD",
"method : scalar",
"subscripted : star '{' expr ';' '}'",
***************
*** 1253,1290 ****
"subscripted : term ARROW '(' expr ')'",
"subscripted : subscripted '(' expr ')'",
"subscripted : subscripted '(' ')'",
! "term : term ASSIGNOP term",
! "term : term POWOP term",
! "term : term MULOP term",
! "term : term ADDOP term",
! "term : term SHIFTOP term",
! "term : term RELOP term",
! "term : term EQOP term",
! "term : term BITANDOP term",
! "term : term BITOROP term",
! "term : term DOTDOT term",
! "term : term ANDAND term",
! "term : term OROR term",
"term : term '?' term ':' term",
- "term : term MATCHOP term",
- "term : '-' term",
- "term : '+' term",
- "term : '!' term",
- "term : '~' term",
"term : REFGEN term",
- "term : term POSTINC",
- "term : term POSTDEC",
- "term : PREINC term",
- "term : PREDEC term",
"term : myattrterm",
"term : LOCAL term",
"term : '(' expr ')'",
"term : '(' ')'",
- "term : '[' expr ']'",
- "term : '[' ']'",
- "term : HASHBRACK expr ';' '}'",
- "term : HASHBRACK ';' '}'",
- "term : ANONSUB startanonsub proto subattrlist block",
"term : scalar",
"term : star",
"term : hsh",
--- 1284,1331 ----
"subscripted : term ARROW '(' expr ')'",
"subscripted : subscripted '(' expr ')'",
"subscripted : subscripted '(' ')'",
! "termbinop : term ASSIGNOP term",
! "termbinop : term POWOP term",
! "termbinop : term MULOP term",
! "termbinop : term ADDOP term",
! "termbinop : term SHIFTOP term",
! "termbinop : term RELOP term",
! "termbinop : term EQOP term",
! "termbinop : term BITANDOP term",
! "termbinop : term BITOROP term",
! "termbinop : term DOTDOT term",
! "termbinop : term ANDAND term",
! "termbinop : term OROR term",
! "termbinop : term MATCHOP term",
! "termunop : '-' term",
! "termunop : '+' term",
! "termunop : '!' term",
! "termunop : '~' term",
! "termunop : term POSTINC",
! "termunop : term POSTDEC",
! "termunop : PREINC term",
! "termunop : PREDEC term",
! "anonymous : '[' expr ']'",
! "anonymous : '[' ']'",
! "anonymous : HASHBRACK expr ';' '}'",
! "anonymous : HASHBRACK ';' '}'",
! "anonymous : ANONSUB startanonsub proto subattrlist block",
! "termdo : DO term",
! "termdo : DO block",
! "termdo : DO WORD '(' ')'",
! "termdo : DO WORD '(' expr ')'",
! "termdo : DO scalar '(' ')'",
! "termdo : DO scalar '(' expr ')'",
! "term : termbinop",
! "term : termunop",
! "term : anonymous",
! "term : termdo",
"term : term '?' term ':' term",
"term : REFGEN term",
"term : myattrterm",
"term : LOCAL term",
"term : '(' expr ')'",
"term : '(' ')'",
"term : scalar",
"term : star",
"term : hsh",
***************
*** 1300,1311 ****
"term : amper '(' ')'",
"term : amper '(' expr ')'",
"term : NOAMP WORD listexpr",
- "term : DO term",
- "term : DO block",
- "term : DO WORD '(' ')'",
- "term : DO WORD '(' expr ')'",
- "term : DO scalar '(' ')'",
- "term : DO scalar '(' expr ')'",
"term : LOOPEX",
"term : LOOPEX term",
"term : NOTOP argexpr",
--- 1341,1346 ----
***************
*** 1361,1367 ****
#define YYMAXDEPTH 500
#endif
#endif
! #line 736 "perly.y"
/* PROGRAM */
/* more stuff added to make perly_c.diff easier to apply */
--- 1396,1402 ----
#define YYMAXDEPTH 500
#endif
#endif
! #line 793 "perly.y"
/* PROGRAM */
/* more stuff added to make perly_c.diff easier to apply */
***************
*** 1371,1377 ****
#endif
#define yyparse() Perl_yyparse(pTHX)
! #line 1446 "perly.c"
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
--- 1406,1412 ----
#endif
#define yyparse() Perl_yyparse(pTHX)
! #line 1409 "perly.c"
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
***************
*** 1401,1409 ****
ysave->oldyychar = yychar;
ysave->oldyyval = yyval;
ysave->oldyylval = yylval;
!
#if YYDEBUG
! if (yys = getenv("YYDEBUG"))
{
yyn = *yys;
if (yyn >= '0' && yyn <= '9')
--- 1436,1444 ----
ysave->oldyychar = yychar;
ysave->oldyyval = yyval;
ysave->oldyylval = yylval;
!
#if YYDEBUG
! if ((yys = getenv("YYDEBUG")))
{
yyn = *yys;
if (yyn >= '0' && yyn <= '9')
***************
*** 1431,1437 ****
*yyssp = yystate = 0;
yyloop:
! if (yyn = yydefred[yystate]) goto yyreduce;
if (yychar < 0)
{
if ((yychar = yylex()) < 0) yychar = 0;
--- 1466,1472 ----
*yyssp = yystate = 0;
yyloop:
! if ((yyn = yydefred[yystate])) goto yyreduce;
if (yychar < 0)
{
if ((yychar = yylex()) < 0) yychar = 0;
***************
*** 1466,1472 ****
ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE);
ysave->yyss = Renew(yyss, yystacksize, short);
if (!yyvs || !yyss)
! goto yyoverflow;
yyssp = yyss + yyps_index;
yyvsp = yyvs + yypv_index;
}
--- 1501,1507 ----
ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE);
ysave->yyss = Renew(yyss, yystacksize, short);
if (!yyvs || !yyss)
! goto yyoverflow;
yyssp = yyss + yyps_index;
yyvsp = yyvs + yypv_index;
}
***************
*** 1484,1497 ****
}
if (yyerrflag) goto yyinrecovery;
#ifdef lint
! goto yynewerror;
#endif
! yynewerror:
yyerror("syntax error");
#ifdef lint
! goto yyerrlab;
#endif
! yyerrlab:
++yynerrs;
yyinrecovery:
if (yyerrflag < 3)
--- 1519,1532 ----
}
if (yyerrflag) goto yyinrecovery;
#ifdef lint
!
#endif
!
yyerror("syntax error");
#ifdef lint
!
#endif
!
++yynerrs;
yyinrecovery:
if (yyerrflag < 3)
***************
*** 1519,1525 ****
ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE);
ysave->yyss = Renew(yyss, yystacksize, short);
if (!yyvs || !yyss)
! goto yyoverflow;
yyssp = yyss + yyps_index;
yyvsp = yyvs + yypv_index;
}
--- 1554,1560 ----
ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE);
ysave->yyss = Renew(yyss, yystacksize, short);
if (!yyvs || !yyss)
! goto yyoverflow;
yyssp = yyss + yyps_index;
yyvsp = yyvs + yypv_index;
}
***************
*** 1567,1614 ****
switch (yyn)
{
case 1:
! #line 128 "perly.y"
! {
! #if defined(YYDEBUG) && defined(DEBUGGING)
! yydebug = (DEBUG_p_TEST);
! #endif
! PL_expect = XSTATE;
! }
break;
case 2:
! #line 135 "perly.y"
! { newPROG(yyvsp[0].opval); }
! break;
! case 3:
! #line 139 "perly.y"
{ if (PL_copline > (line_t)yyvsp[-3].ival)
PL_copline = yyvsp[-3].ival;
yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); }
break;
! case 4:
! #line 145 "perly.y"
{ yyval.ival = block_start(TRUE); }
break;
case 5:
! #line 149 "perly.y"
{ if (PL_copline > (line_t)yyvsp[-3].ival)
PL_copline = yyvsp[-3].ival;
yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); }
break;
case 6:
! #line 155 "perly.y"
{ yyval.ival = block_start(FALSE); }
break;
case 7:
! #line 159 "perly.y"
{ yyval.opval = Nullop; }
break;
case 8:
! #line 161 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
case 9:
! #line 163 "perly.y"
{ yyval.opval = append_list(OP_LINESEQ,
(LISTOP*)yyvsp[-1].opval, (LISTOP*)yyvsp[0].opval);
PL_pad_reset_pending = TRUE;
--- 1602,1649 ----
switch (yyn)
{
case 1:
! #line 131 "perly.y"
! { yyval.ival = yyvsp[-1].ival; newPROG(block_end(yyvsp[-1].ival,yyvsp[0].opval)); }
break;
case 2:
! #line 136 "perly.y"
{ if (PL_copline > (line_t)yyvsp[-3].ival)
PL_copline = yyvsp[-3].ival;
yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); }
break;
! case 3:
! #line 142 "perly.y"
{ yyval.ival = block_start(TRUE); }
break;
+ case 4:
+ #line 146 "perly.y"
+ {
+ #if defined(YYDEBUG) && defined(DEBUGGING)
+ yydebug = (DEBUG_p_TEST);
+ #endif
+ PL_expect = XSTATE; yyval.ival = block_start(TRUE);
+ }
+ break;
case 5:
! #line 156 "perly.y"
{ if (PL_copline > (line_t)yyvsp[-3].ival)
PL_copline = yyvsp[-3].ival;
yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); }
break;
case 6:
! #line 162 "perly.y"
{ yyval.ival = block_start(FALSE); }
break;
case 7:
! #line 167 "perly.y"
{ yyval.opval = Nullop; }
break;
case 8:
! #line 169 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
case 9:
! #line 171 "perly.y"
{ yyval.opval = append_list(OP_LINESEQ,
(LISTOP*)yyvsp[-1].opval, (LISTOP*)yyvsp[0].opval);
PL_pad_reset_pending = TRUE;
***************
*** 1615,1625 ****
if (yyvsp[-1].opval && yyvsp[0].opval) PL_hints |= HINT_BLOCK_SCOPE; }
break;
case 10:
! #line 170 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); }
break;
case 12:
! #line 173 "perly.y"
{ if (yyvsp[-1].pval != Nullch) {
yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0));
}
--- 1650,1660 ----
if (yyvsp[-1].opval && yyvsp[0].opval) PL_hints |= HINT_BLOCK_SCOPE; }
break;
case 10:
! #line 179 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); }
break;
case 12:
! #line 182 "perly.y"
{ if (yyvsp[-1].pval != Nullch) {
yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0));
}
***************
*** 1630,1704 ****
PL_expect = XSTATE; }
break;
case 13:
! #line 182 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval, yyvsp[-1].opval);
PL_expect = XSTATE; }
break;
case 14:
! #line 187 "perly.y"
{ yyval.opval = Nullop; }
break;
case 15:
! #line 189 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 16:
! #line 191 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); }
break;
case 17:
! #line 193 "perly.y"
{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); }
break;
case 18:
! #line 195 "perly.y"
{ yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); }
break;
case 19:
! #line 197 "perly.y"
{ yyval.opval = newLOOPOP(OPf_PARENS, 1, yyvsp[0].opval, yyvsp[-2].opval);}
break;
case 20:
! #line 199 "perly.y"
{ yyval.opval = newFOROP(0, Nullch, yyvsp[-1].ival,
Nullop, yyvsp[0].opval, yyvsp[-2].opval, Nullop); }
break;
case 21:
! #line 204 "perly.y"
{ yyval.opval = Nullop; }
break;
case 22:
! #line 206 "perly.y"
{ (yyvsp[0].opval)->op_flags |= OPf_PARENS; yyval.opval = scope(yyvsp[0].opval); }
break;
case 23:
! #line 208 "perly.y"
{ PL_copline = yyvsp[-5].ival;
yyval.opval = newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval);
PL_hints |= HINT_BLOCK_SCOPE; }
break;
case 24:
! #line 214 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); }
break;
case 25:
! #line 218 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); }
break;
case 26:
! #line 224 "perly.y"
{ yyval.opval = Nullop; }
break;
case 27:
! #line 226 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
case 28:
! #line 230 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newSTATEOP(0, yyvsp[-7].pval,
--- 1665,1739 ----
PL_expect = XSTATE; }
break;
case 13:
! #line 191 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval, yyvsp[-1].opval);
PL_expect = XSTATE; }
break;
case 14:
! #line 197 "perly.y"
{ yyval.opval = Nullop; }
break;
case 15:
! #line 199 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 16:
! #line 201 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); }
break;
case 17:
! #line 203 "perly.y"
{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); }
break;
case 18:
! #line 205 "perly.y"
{ yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); }
break;
case 19:
! #line 207 "perly.y"
{ yyval.opval = newLOOPOP(OPf_PARENS, 1, yyvsp[0].opval, yyvsp[-2].opval);}
break;
case 20:
! #line 209 "perly.y"
{ yyval.opval = newFOROP(0, Nullch, yyvsp[-1].ival,
Nullop, yyvsp[0].opval, yyvsp[-2].opval, Nullop); }
break;
case 21:
! #line 215 "perly.y"
{ yyval.opval = Nullop; }
break;
case 22:
! #line 217 "perly.y"
{ (yyvsp[0].opval)->op_flags |= OPf_PARENS; yyval.opval = scope(yyvsp[0].opval); }
break;
case 23:
! #line 219 "perly.y"
{ PL_copline = yyvsp[-5].ival;
yyval.opval = newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval);
PL_hints |= HINT_BLOCK_SCOPE; }
break;
case 24:
! #line 226 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); }
break;
case 25:
! #line 230 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); }
break;
case 26:
! #line 237 "perly.y"
{ yyval.opval = Nullop; }
break;
case 27:
! #line 239 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
case 28:
! #line 244 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newSTATEOP(0, yyvsp[-7].pval,
***************
*** 1706,1712 ****
yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); }
break;
case 29:
! #line 236 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newSTATEOP(0, yyvsp[-7].pval,
--- 1741,1747 ----
yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); }
break;
case 29:
! #line 250 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newSTATEOP(0, yyvsp[-7].pval,
***************
*** 1714,1736 ****
yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); }
break;
case 30:
! #line 242 "perly.y"
{ yyval.opval = block_end(yyvsp[-6].ival,
newFOROP(0, yyvsp[-9].pval, yyvsp[-8].ival, yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 31:
! #line 245 "perly.y"
{ yyval.opval = block_end(yyvsp[-4].ival,
newFOROP(0, yyvsp[-8].pval, yyvsp[-7].ival, mod(yyvsp[-6].opval, OP_ENTERLOOP),
yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 32:
! #line 249 "perly.y"
{ yyval.opval = block_end(yyvsp[-4].ival,
newFOROP(0, yyvsp[-7].pval, yyvsp[-6].ival, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 33:
! #line 253 "perly.y"
{ OP *forop;
PL_copline = yyvsp[-9].ival;
forop = newSTATEOP(0, yyvsp[-10].pval,
--- 1749,1771 ----
yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); }
break;
case 30:
! #line 256 "perly.y"
{ yyval.opval = block_end(yyvsp[-6].ival,
newFOROP(0, yyvsp[-9].pval, yyvsp[-8].ival, yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 31:
! #line 259 "perly.y"
{ yyval.opval = block_end(yyvsp[-4].ival,
newFOROP(0, yyvsp[-8].pval, yyvsp[-7].ival, mod(yyvsp[-6].opval, OP_ENTERLOOP),
yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 32:
! #line 263 "perly.y"
{ yyval.opval = block_end(yyvsp[-4].ival,
newFOROP(0, yyvsp[-7].pval, yyvsp[-6].ival, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 33:
! #line 267 "perly.y"
{ OP *forop;
PL_copline = yyvsp[-9].ival;
forop = newSTATEOP(0, yyvsp[-10].pval,
***************
*** 1747,1843 ****
yyval.opval = block_end(yyvsp[-7].ival, forop); }
break;
case 34:
! #line 268 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval,
newWHILEOP(0, 1, (LOOP*)Nullop,
NOLINE, Nullop, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 35:
! #line 274 "perly.y"
{ yyval.opval = Nullop; }
break;
case 37:
! #line 279 "perly.y"
{ (void)scan_num("1", &yylval); yyval.opval = yylval.opval; }
break;
case 39:
! #line 284 "perly.y"
{ yyval.opval = invert(scalar(yyvsp[0].opval)); }
break;
case 40:
! #line 288 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 41:
! #line 292 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 42:
! #line 296 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 43:
! #line 300 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 44:
! #line 304 "perly.y"
{ yyval.pval = Nullch; }
break;
case 46:
! #line 309 "perly.y"
{ yyval.ival = 0; }
break;
case 47:
! #line 311 "perly.y"
{ yyval.ival = 0; }
break;
case 48:
! #line 313 "perly.y"
{ yyval.ival = 0; }
break;
case 49:
! #line 315 "perly.y"
{ yyval.ival = 0; }
break;
case 50:
! #line 317 "perly.y"
{ yyval.ival = 0; }
break;
case 51:
! #line 321 "perly.y"
{ newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 52:
! #line 324 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 53:
! #line 325 "perly.y"
{ yyval.opval = Nullop; }
break;
case 54:
! #line 329 "perly.y"
{ newMYSUB(yyvsp[-4].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 55:
! #line 333 "perly.y"
{ newATTRSUB(yyvsp[-4].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 56:
! #line 337 "perly.y"
{ yyval.ival = start_subparse(FALSE, 0); }
break;
case 57:
! #line 341 "perly.y"
{ yyval.ival = start_subparse(FALSE, CVf_ANON); }
break;
case 58:
! #line 345 "perly.y"
{ yyval.ival = start_subparse(TRUE, 0); }
break;
case 59:
! #line 348 "perly.y"
{ STRLEN n_a; char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv,n_a);
if (strEQ(name, "BEGIN") || strEQ(name, "END")
|| strEQ(name, "INIT") || strEQ(name, "CHECK"))
--- 1782,1878 ----
yyval.opval = block_end(yyvsp[-7].ival, forop); }
break;
case 34:
! #line 282 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval,
newWHILEOP(0, 1, (LOOP*)Nullop,
NOLINE, Nullop, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 35:
! #line 289 "perly.y"
{ yyval.opval = Nullop; }
break;
case 37:
! #line 295 "perly.y"
{ (void)scan_num("1", &yylval); yyval.opval = yylval.opval; }
break;
case 39:
! #line 301 "perly.y"
{ yyval.opval = invert(scalar(yyvsp[0].opval)); }
break;
case 40:
! #line 306 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 41:
! #line 310 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 42:
! #line 314 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 43:
! #line 318 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 44:
! #line 323 "perly.y"
{ yyval.pval = Nullch; }
break;
case 46:
! #line 329 "perly.y"
{ yyval.ival = 0; }
break;
case 47:
! #line 331 "perly.y"
{ yyval.ival = 0; }
break;
case 48:
! #line 333 "perly.y"
{ yyval.ival = 0; }
break;
case 49:
! #line 335 "perly.y"
{ yyval.ival = 0; }
break;
case 50:
! #line 337 "perly.y"
{ yyval.ival = 0; }
break;
case 51:
! #line 341 "perly.y"
{ newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 52:
! #line 344 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 53:
! #line 345 "perly.y"
{ yyval.opval = Nullop; }
break;
case 54:
! #line 350 "perly.y"
{ newMYSUB(yyvsp[-4].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 55:
! #line 355 "perly.y"
{ newATTRSUB(yyvsp[-4].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 56:
! #line 359 "perly.y"
{ yyval.ival = start_subparse(FALSE, 0); }
break;
case 57:
! #line 363 "perly.y"
{ yyval.ival = start_subparse(FALSE, CVf_ANON); }
break;
case 58:
! #line 367 "perly.y"
{ yyval.ival = start_subparse(TRUE, 0); }
break;
case 59:
! #line 371 "perly.y"
{ STRLEN n_a; char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv,n_a);
if (strEQ(name, "BEGIN") || strEQ(name, "END")
|| strEQ(name, "INIT") || strEQ(name, "CHECK"))
***************
*** 1845,1925 ****
yyval.opval = yyvsp[0].opval; }
break;
case 60:
! #line 356 "perly.y"
{ yyval.opval = Nullop; }
break;
case 62:
! #line 361 "perly.y"
{ yyval.opval = Nullop; }
break;
case 63:
! #line 363 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 64:
! #line 365 "perly.y"
{ yyval.opval = Nullop; }
break;
case 65:
! #line 369 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 66:
! #line 371 "perly.y"
{ yyval.opval = Nullop; }
break;
case 67:
! #line 374 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 68:
! #line 375 "perly.y"
{ yyval.opval = Nullop; PL_expect = XSTATE; }
break;
case 69:
! #line 379 "perly.y"
{ package(yyvsp[-1].opval); }
break;
case 70:
! #line 381 "perly.y"
{ package(Nullop); }
break;
case 71:
! #line 385 "perly.y"
{ CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ }
break;
case 72:
! #line 387 "perly.y"
{ utilize(yyvsp[-6].ival, yyvsp[-5].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); }
break;
case 73:
! #line 391 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 74:
! #line 393 "perly.y"
{ yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 76:
! #line 398 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
case 77:
! #line 400 "perly.y"
{ yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 79:
! #line 405 "perly.y"
{ yyval.opval = convert(yyvsp[-2].ival, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF(yyvsp[-2].ival,yyvsp[-1].opval), yyvsp[0].opval) ); }
break;
case 80:
! #line 408 "perly.y"
{ yyval.opval = convert(yyvsp[-4].ival, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF(yyvsp[-4].ival,yyvsp[-2].opval), yyvsp[-1].opval) ); }
break;
case 81:
! #line 411 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, scalar(yyvsp[-5].opval), yyvsp[-1].opval),
--- 1880,1960 ----
yyval.opval = yyvsp[0].opval; }
break;
case 60:
! #line 380 "perly.y"
{ yyval.opval = Nullop; }
break;
case 62:
! #line 386 "perly.y"
{ yyval.opval = Nullop; }
break;
case 63:
! #line 388 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 64:
! #line 390 "perly.y"
{ yyval.opval = Nullop; }
break;
case 65:
! #line 395 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 66:
! #line 397 "perly.y"
{ yyval.opval = Nullop; }
break;
case 67:
! #line 401 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 68:
! #line 402 "perly.y"
{ yyval.opval = Nullop; PL_expect = XSTATE; }
break;
case 69:
! #line 406 "perly.y"
{ package(yyvsp[-1].opval); }
break;
case 70:
! #line 408 "perly.y"
{ package(Nullop); }
break;
case 71:
! #line 412 "perly.y"
{ CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ }
break;
case 72:
! #line 414 "perly.y"
{ utilize(yyvsp[-6].ival, yyvsp[-5].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); }
break;
case 73:
! #line 419 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 74:
! #line 421 "perly.y"
{ yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 76:
! #line 427 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
case 77:
! #line 429 "perly.y"
{ yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 79:
! #line 435 "perly.y"
{ yyval.opval = convert(yyvsp[-2].ival, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF(yyvsp[-2].ival,yyvsp[-1].opval), yyvsp[0].opval) ); }
break;
case 80:
! #line 438 "perly.y"
{ yyval.opval = convert(yyvsp[-4].ival, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF(yyvsp[-4].ival,yyvsp[-2].opval), yyvsp[-1].opval) ); }
break;
case 81:
! #line 441 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, scalar(yyvsp[-5].opval), yyvsp[-1].opval),
***************
*** 1926,1938 ****
newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); }
break;
case 82:
! #line 416 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, scalar(yyvsp[-2].opval),
newUNOP(OP_METHOD, 0, yyvsp[0].opval))); }
break;
case 83:
! #line 420 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-1].opval, yyvsp[0].opval),
--- 1961,1973 ----
newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); }
break;
case 82:
! #line 446 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, scalar(yyvsp[-2].opval),
newUNOP(OP_METHOD, 0, yyvsp[0].opval))); }
break;
case 83:
! #line 450 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-1].opval, yyvsp[0].opval),
***************
*** 1939,1945 ****
newUNOP(OP_METHOD, 0, yyvsp[-2].opval))); }
break;
case 84:
! #line 425 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-3].opval, yyvsp[-1].opval),
--- 1974,1980 ----
newUNOP(OP_METHOD, 0, yyvsp[-2].opval))); }
break;
case 84:
! #line 455 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-3].opval, yyvsp[-1].opval),
***************
*** 1946,1995 ****
newUNOP(OP_METHOD, 0, yyvsp[-4].opval))); }
break;
case 85:
! #line 430 "perly.y"
{ yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
case 86:
! #line 432 "perly.y"
{ yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
case 87:
! #line 434 "perly.y"
{ yyvsp[0].opval = newANONATTRSUB(yyvsp[-1].ival, 0, Nullop, yyvsp[0].opval); }
break;
case 88:
! #line 436 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval), yyvsp[-4].opval)); }
break;
case 91:
! #line 446 "perly.y"
{ yyval.opval = newBINOP(OP_GELEM, 0, yyvsp[-4].opval, scalar(yyvsp[-2].opval)); }
break;
case 92:
! #line 448 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); }
break;
case 93:
! #line 450 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0,
ref(newAVREF(yyvsp[-4].opval),OP_RV2AV),
scalar(yyvsp[-1].opval));}
break;
case 94:
! #line 454 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0,
ref(newAVREF(yyvsp[-3].opval),OP_RV2AV),
scalar(yyvsp[-1].opval));}
break;
case 95:
! #line 458 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval));
PL_expect = XOPERATOR; }
break;
case 96:
! #line 461 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-5].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
--- 1981,2030 ----
newUNOP(OP_METHOD, 0, yyvsp[-4].opval))); }
break;
case 85:
! #line 460 "perly.y"
{ yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
case 86:
! #line 462 "perly.y"
{ yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
case 87:
! #line 464 "perly.y"
{ yyvsp[0].opval = newANONATTRSUB(yyvsp[-1].ival, 0, Nullop, yyvsp[0].opval); }
break;
case 88:
! #line 466 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval), yyvsp[-4].opval)); }
break;
case 91:
! #line 480 "perly.y"
{ yyval.opval = newBINOP(OP_GELEM, 0, yyvsp[-4].opval, scalar(yyvsp[-2].opval)); }
break;
case 92:
! #line 482 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); }
break;
case 93:
! #line 484 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0,
ref(newAVREF(yyvsp[-4].opval),OP_RV2AV),
scalar(yyvsp[-1].opval));}
break;
case 94:
! #line 488 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0,
ref(newAVREF(yyvsp[-3].opval),OP_RV2AV),
scalar(yyvsp[-1].opval));}
break;
case 95:
! #line 492 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval));
PL_expect = XOPERATOR; }
break;
case 96:
! #line 495 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-5].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
***************
*** 1996,2002 ****
PL_expect = XOPERATOR; }
break;
case 97:
! #line 466 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-4].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
--- 2031,2037 ----
PL_expect = XOPERATOR; }
break;
case 97:
! #line 500 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-4].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
***************
*** 2003,2197 ****
PL_expect = XOPERATOR; }
break;
case 98:
! #line 471 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar(yyvsp[-3].opval))); }
break;
case 99:
! #line 474 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval,
newCVREF(0, scalar(yyvsp[-4].opval)))); }
break;
case 100:
! #line 479 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval,
newCVREF(0, scalar(yyvsp[-3].opval)))); }
break;
case 101:
! #line 483 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar(yyvsp[-2].opval))); }
break;
case 102:
! #line 489 "perly.y"
{ yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); }
break;
case 103:
! #line 491 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 104:
! #line 493 "perly.y"
{ if (yyvsp[-1].ival != OP_REPEAT)
scalar(yyvsp[-2].opval);
yyval.opval = newBINOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, scalar(yyvsp[0].opval)); }
break;
case 105:
! #line 497 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 106:
! #line 499 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 107:
! #line 501 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 108:
! #line 503 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 109:
! #line 505 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 110:
! #line 507 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 111:
! #line 509 "perly.y"
{ yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));}
break;
case 112:
! #line 511 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 113:
! #line 513 "perly.y"
{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 114:
! #line 515 "perly.y"
! { yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); }
! break;
! case 115:
! #line 517 "perly.y"
{ yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); }
break;
! case 116:
! #line 520 "perly.y"
{ yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); }
break;
! case 117:
! #line 522 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 118:
! #line 524 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
! case 119:
! #line 526 "perly.y"
{ yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));}
break;
! case 120:
! #line 528 "perly.y"
! { yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); }
! break;
! case 121:
! #line 530 "perly.y"
{ yyval.opval = newUNOP(OP_POSTINC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTINC)); }
break;
! case 122:
! #line 533 "perly.y"
{ yyval.opval = newUNOP(OP_POSTDEC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); }
break;
! case 123:
! #line 536 "perly.y"
{ yyval.opval = newUNOP(OP_PREINC, 0,
mod(scalar(yyvsp[0].opval), OP_PREINC)); }
break;
! case 124:
! #line 539 "perly.y"
{ yyval.opval = newUNOP(OP_PREDEC, 0,
mod(scalar(yyvsp[0].opval), OP_PREDEC)); }
break;
case 125:
! #line 542 "perly.y"
! { yyval.opval = yyvsp[0].opval; }
break;
case 126:
! #line 544 "perly.y"
! { yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); }
break;
case 127:
! #line 546 "perly.y"
! { yyval.opval = sawparens(yyvsp[-1].opval); }
break;
case 128:
! #line 548 "perly.y"
! { yyval.opval = sawparens(newNULLLIST()); }
break;
case 129:
! #line 550 "perly.y"
! { yyval.opval = newANONLIST(yyvsp[-1].opval); }
break;
case 130:
! #line 552 "perly.y"
! { yyval.opval = newANONLIST(Nullop); }
break;
case 131:
! #line 554 "perly.y"
! { yyval.opval = newANONHASH(yyvsp[-2].opval); }
break;
case 132:
! #line 556 "perly.y"
! { yyval.opval = newANONHASH(Nullop); }
break;
case 133:
! #line 558 "perly.y"
! { yyval.opval = newANONATTRSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
break;
! case 134:
! #line 560 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 135:
! #line 562 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 136:
! #line 564 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 137:
! #line 566 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 138:
! #line 568 "perly.y"
{ yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));}
break;
! case 139:
! #line 570 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 140:
! #line 572 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); }
break;
! case 141:
! #line 574 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); }
break;
! case 142:
! #line 576 "perly.y"
{ yyval.opval = prepend_elem(OP_ASLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_ASLICE, 0,
--- 2038,2274 ----
PL_expect = XOPERATOR; }
break;
case 98:
! #line 505 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar(yyvsp[-3].opval))); }
break;
case 99:
! #line 508 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval,
newCVREF(0, scalar(yyvsp[-4].opval)))); }
break;
case 100:
! #line 513 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval,
newCVREF(0, scalar(yyvsp[-3].opval)))); }
break;
case 101:
! #line 517 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar(yyvsp[-2].opval))); }
break;
case 102:
! #line 523 "perly.y"
{ yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); }
break;
case 103:
! #line 525 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 104:
! #line 527 "perly.y"
{ if (yyvsp[-1].ival != OP_REPEAT)
scalar(yyvsp[-2].opval);
yyval.opval = newBINOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, scalar(yyvsp[0].opval)); }
break;
case 105:
! #line 531 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 106:
! #line 533 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 107:
! #line 535 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 108:
! #line 537 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 109:
! #line 539 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 110:
! #line 541 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 111:
! #line 543 "perly.y"
{ yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));}
break;
case 112:
! #line 545 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 113:
! #line 547 "perly.y"
{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 114:
! #line 549 "perly.y"
{ yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); }
break;
! case 115:
! #line 554 "perly.y"
{ yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); }
break;
! case 116:
! #line 556 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 117:
! #line 558 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
! case 118:
! #line 560 "perly.y"
{ yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));}
break;
! case 119:
! #line 562 "perly.y"
{ yyval.opval = newUNOP(OP_POSTINC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTINC)); }
break;
! case 120:
! #line 565 "perly.y"
{ yyval.opval = newUNOP(OP_POSTDEC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); }
break;
! case 121:
! #line 568 "perly.y"
{ yyval.opval = newUNOP(OP_PREINC, 0,
mod(scalar(yyvsp[0].opval), OP_PREINC)); }
break;
! case 122:
! #line 571 "perly.y"
{ yyval.opval = newUNOP(OP_PREDEC, 0,
mod(scalar(yyvsp[0].opval), OP_PREDEC)); }
break;
+ case 123:
+ #line 578 "perly.y"
+ { yyval.opval = newANONLIST(yyvsp[-1].opval); }
+ break;
+ case 124:
+ #line 580 "perly.y"
+ { yyval.opval = newANONLIST(Nullop); }
+ break;
case 125:
! #line 582 "perly.y"
! { yyval.opval = newANONHASH(yyvsp[-2].opval); }
break;
case 126:
! #line 584 "perly.y"
! { yyval.opval = newANONHASH(Nullop); }
break;
case 127:
! #line 586 "perly.y"
! { yyval.opval = newANONATTRSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 128:
! #line 592 "perly.y"
! { yyval.opval = dofile(yyvsp[0].opval); }
break;
case 129:
! #line 594 "perly.y"
! { yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); }
break;
case 130:
! #line 596 "perly.y"
! { yyval.opval = newUNOP(OP_ENTERSUB,
! OPf_SPECIAL|OPf_STACKED,
! prepend_elem(OP_LIST,
! scalar(newCVREF(
! (OPpENTERSUB_AMPER<<8),
! scalar(yyvsp[-2].opval)
! )),Nullop)); dep();}
break;
case 131:
! #line 604 "perly.y"
! { yyval.opval = newUNOP(OP_ENTERSUB,
! OPf_SPECIAL|OPf_STACKED,
! append_elem(OP_LIST,
! yyvsp[-1].opval,
! scalar(newCVREF(
! (OPpENTERSUB_AMPER<<8),
! scalar(yyvsp[-3].opval)
! )))); dep();}
break;
case 132:
! #line 613 "perly.y"
! { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
! prepend_elem(OP_LIST,
! scalar(newCVREF(0,scalar(yyvsp[-2].opval))), Nullop)); dep();}
break;
case 133:
! #line 617 "perly.y"
! { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
! prepend_elem(OP_LIST,
! yyvsp[-1].opval,
! scalar(newCVREF(0,scalar(yyvsp[-3].opval))))); dep();}
break;
! case 138:
! #line 629 "perly.y"
! { yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); }
! break;
! case 139:
! #line 631 "perly.y"
! { yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); }
! break;
! case 140:
! #line 633 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 141:
! #line 635 "perly.y"
! { yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); }
! break;
! case 142:
! #line 637 "perly.y"
! { yyval.opval = sawparens(yyvsp[-1].opval); }
! break;
! case 143:
! #line 639 "perly.y"
! { yyval.opval = sawparens(newNULLLIST()); }
! break;
! case 144:
! #line 641 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 145:
! #line 643 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 146:
! #line 645 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 147:
! #line 647 "perly.y"
! { yyval.opval = yyvsp[0].opval; }
! break;
! case 148:
! #line 649 "perly.y"
{ yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));}
break;
! case 149:
! #line 651 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 150:
! #line 653 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); }
break;
! case 151:
! #line 655 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); }
break;
! case 152:
! #line 657 "perly.y"
{ yyval.opval = prepend_elem(OP_ASLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_ASLICE, 0,
***************
*** 2198,2205 ****
list(yyvsp[-1].opval),
ref(yyvsp[-3].opval, OP_ASLICE))); }
break;
! case 143:
! #line 582 "perly.y"
{ yyval.opval = prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_HSLICE, 0,
--- 2275,2282 ----
list(yyvsp[-1].opval),
ref(yyvsp[-3].opval, OP_ASLICE))); }
break;
! case 153:
! #line 663 "perly.y"
{ yyval.opval = prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_HSLICE, 0,
***************
*** 2207,2428 ****
ref(oopsHV(yyvsp[-4].opval), OP_HSLICE)));
PL_expect = XOPERATOR; }
break;
! case 144:
! #line 589 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 145:
! #line 591 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); }
break;
! case 146:
! #line 593 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); }
break;
! case 147:
! #line 595 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); }
break;
! case 148:
! #line 598 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
break;
! case 149:
! #line 601 "perly.y"
! { yyval.opval = dofile(yyvsp[0].opval); }
! break;
! case 150:
! #line 603 "perly.y"
! { yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); }
! break;
! case 151:
! #line 605 "perly.y"
! { yyval.opval = newUNOP(OP_ENTERSUB,
! OPf_SPECIAL|OPf_STACKED,
! prepend_elem(OP_LIST,
! scalar(newCVREF(
! (OPpENTERSUB_AMPER<<8),
! scalar(yyvsp[-2].opval)
! )),Nullop)); dep();}
! break;
! case 152:
! #line 613 "perly.y"
! { yyval.opval = newUNOP(OP_ENTERSUB,
! OPf_SPECIAL|OPf_STACKED,
! append_elem(OP_LIST,
! yyvsp[-1].opval,
! scalar(newCVREF(
! (OPpENTERSUB_AMPER<<8),
! scalar(yyvsp[-3].opval)
! )))); dep();}
! break;
! case 153:
! #line 622 "perly.y"
! { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
! prepend_elem(OP_LIST,
! scalar(newCVREF(0,scalar(yyvsp[-2].opval))), Nullop)); dep();}
! break;
! case 154:
! #line 626 "perly.y"
! { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
! prepend_elem(OP_LIST,
! yyvsp[-1].opval,
! scalar(newCVREF(0,scalar(yyvsp[-3].opval))))); dep();}
! break;
! case 155:
! #line 631 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL);
PL_hints |= HINT_BLOCK_SCOPE; }
break;
! case 156:
! #line 634 "perly.y"
{ yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); }
break;
! case 157:
! #line 636 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
! case 158:
! #line 638 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
! case 159:
! #line 640 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
! case 160:
! #line 642 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
! case 161:
! #line 644 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
break;
! case 162:
! #line 647 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
! case 163:
! #line 649 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, 0); }
break;
! case 164:
! #line 651 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
scalar(yyvsp[0].opval)); }
break;
! case 165:
! #line 654 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); }
break;
! case 166:
! #line 656 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
! case 167:
! #line 658 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); }
break;
! case 168:
! #line 660 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); }
break;
! case 171:
! #line 666 "perly.y"
{ yyval.opval = my_attrs(yyvsp[-1].opval,yyvsp[0].opval); }
break;
! case 172:
! #line 668 "perly.y"
{ yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); }
break;
! case 173:
! #line 672 "perly.y"
{ yyval.opval = sawparens(yyvsp[-1].opval); }
break;
! case 174:
! #line 674 "perly.y"
{ yyval.opval = sawparens(newNULLLIST()); }
break;
! case 175:
! #line 676 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 176:
! #line 678 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 177:
! #line 680 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 178:
! #line 684 "perly.y"
{ yyval.opval = Nullop; }
break;
! case 179:
! #line 686 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 180:
! #line 690 "perly.y"
{ yyval.opval = Nullop; }
break;
! case 181:
! #line 692 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 182:
! #line 694 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
! case 183:
! #line 698 "perly.y"
{ PL_in_my = 0; yyval.opval = my(yyvsp[0].opval); }
break;
! case 184:
! #line 702 "perly.y"
{ yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); }
break;
! case 185:
! #line 706 "perly.y"
{ yyval.opval = newSVREF(yyvsp[0].opval); }
break;
! case 186:
! #line 710 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
! case 187:
! #line 714 "perly.y"
{ yyval.opval = newHVREF(yyvsp[0].opval); }
break;
! case 188:
! #line 718 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
! case 189:
! #line 722 "perly.y"
{ yyval.opval = newGVREF(0,yyvsp[0].opval); }
break;
! case 190:
! #line 726 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
! case 191:
! #line 728 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
! case 192:
! #line 730 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
! case 193:
! #line 733 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! #line 2442 "perly.c"
}
yyssp -= yym;
yystate = *yyssp;
--- 2284,2463 ----
ref(oopsHV(yyvsp[-4].opval), OP_HSLICE)));
PL_expect = XOPERATOR; }
break;
! case 154:
! #line 670 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 155:
! #line 672 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); }
break;
! case 156:
! #line 674 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); }
break;
! case 157:
! #line 676 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); }
break;
! case 158:
! #line 679 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
break;
! case 159:
! #line 682 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL);
PL_hints |= HINT_BLOCK_SCOPE; }
break;
! case 160:
! #line 685 "perly.y"
{ yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); }
break;
! case 161:
! #line 687 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
! case 162:
! #line 689 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
! case 163:
! #line 691 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
! case 164:
! #line 693 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
! case 165:
! #line 695 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
break;
! case 166:
! #line 698 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
! case 167:
! #line 700 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, 0); }
break;
! case 168:
! #line 702 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
scalar(yyvsp[0].opval)); }
break;
! case 169:
! #line 705 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); }
break;
! case 170:
! #line 707 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
! case 171:
! #line 709 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); }
break;
! case 172:
! #line 711 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); }
break;
! case 175:
! #line 718 "perly.y"
{ yyval.opval = my_attrs(yyvsp[-1].opval,yyvsp[0].opval); }
break;
! case 176:
! #line 720 "perly.y"
{ yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); }
break;
! case 177:
! #line 725 "perly.y"
{ yyval.opval = sawparens(yyvsp[-1].opval); }
break;
! case 178:
! #line 727 "perly.y"
{ yyval.opval = sawparens(newNULLLIST()); }
break;
! case 179:
! #line 729 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 180:
! #line 731 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 181:
! #line 733 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 182:
! #line 738 "perly.y"
{ yyval.opval = Nullop; }
break;
! case 183:
! #line 740 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 184:
! #line 744 "perly.y"
{ yyval.opval = Nullop; }
break;
! case 185:
! #line 746 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! case 186:
! #line 748 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
! case 187:
! #line 754 "perly.y"
{ PL_in_my = 0; yyval.opval = my(yyvsp[0].opval); }
break;
! case 188:
! #line 758 "perly.y"
{ yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); }
break;
! case 189:
! #line 762 "perly.y"
{ yyval.opval = newSVREF(yyvsp[0].opval); }
break;
! case 190:
! #line 766 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
! case 191:
! #line 770 "perly.y"
{ yyval.opval = newHVREF(yyvsp[0].opval); }
break;
! case 192:
! #line 774 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
! case 193:
! #line 778 "perly.y"
{ yyval.opval = newGVREF(0,yyvsp[0].opval); }
break;
! case 194:
! #line 783 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
! case 195:
! #line 785 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
! case 196:
! #line 787 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
! case 197:
! #line 790 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! #line 2459 "perly.c"
}
yyssp -= yym;
yystate = *yyssp;
***************
*** 2477,2483 ****
ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE);
ysave->yyss = Renew(yyss, yystacksize, short);
if (!yyvs || !yyss)
! goto yyoverflow;
yyssp = yyss + yyps_index;
yyvsp = yyvs + yypv_index;
}
--- 2512,2518 ----
ysave->yyvs = Renew(yyvs, yystacksize, YYSTYPE);
ysave->yyss = Renew(yyss, yystacksize, short);
if (!yyvs || !yyss)
! goto yyoverflow;
yyssp = yyss + yyps_index;
yyvsp = yyvs + yypv_index;
}
diff -c 'perl-5.7.1/vms/test.com' 'perl-5.7.2/vms/test.com'
Index: ./vms/test.com
*** ./vms/test.com Tue Mar 6 04:07:28 2001
--- ./vms/test.com Mon Jul 9 17:11:34 2001
***************
*** 112,117 ****
--- 112,118 ----
# of Unixisms in the tests. (The Perl operators being tested may work fine,
# but the tests may use other operators which don't.)
use Config;
+ use File::Spec;
@compexcl=('cpp.t');
@ioexcl=('argv.t','dup.t','fs.t','pipe.t');
***************
*** 143,150 ****
chdir 't' if -f 't/TEST';
if ($ARGV[0] eq '') {
! foreach (<[.*]*.t>) {
! s/.*[\[.]t./[./;
($fname = $_) =~ s/.*\]//;
if ($skip{"\L$fname"}) { push(@skipped,$_); }
else { push(@ARGV,$_); }
--- 144,152 ----
chdir 't' if -f 't/TEST';
if ($ARGV[0] eq '') {
! foreach (<[-.ext...]*.t>, <[-.lib...]*.t>, <[.*]*.t>) {
! $_ = File::Spec->abs2rel($_);
! s/\[([a-z]+)/[.$1/; # hmm, abs2rel doesn't do subdirs of the cwd
($fname = $_) =~ s/.*\]//;
if ($skip{"\L$fname"}) { push(@skipped,$_); }
else { push(@ARGV,$_); }
***************
*** 166,172 ****
}
$te = $test;
chop($te);
! $te .= '.' x (24 - length($te));
open(script,"$test") || die "Can't run $test.\n";
$_ = <script>;
close(script);
--- 168,174 ----
}
$te = $test;
chop($te);
! $te .= '.' x (40 - length($te));
open(script,"$test") || die "Can't run $test.\n";
$_ = <script>;
close(script);
***************
*** 187,209 ****
$te = '';
}
unless (/^#/) {
! if (/^1\.\.([0-9]+)/) {
$max = $1;
$totmax += $max;
$files += 1;
$next = 1;
$ok = 1;
} else {
! $next = $1, $ok = 0, last if /^not ok ([0-9]*)/;
! next if /^\s*$/; # our 'echo' substitute produces one more \n than Unix'
! if (/^ok (.*)/ && $1 == $next) {
! $next = $1, $ok=0, last if $pending_not;
! $next = $next + 1;
! } elsif (/^not/) {
! $pending_not = 1;
! } else {
! $ok = 0;
}
}
}
}
--- 189,239 ----
$te = '';
}
unless (/^#/) {
! if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) {
$max = $1;
+ %todo = map { $_ => 1 } split / /, $3 if $3;
$totmax += $max;
$files += 1;
$next = 1;
$ok = 1;
} else {
! # our 'echo' substitute produces one more \n than Unix'
! next if /^\s*$/;
!
!
! if (/^(not )?ok (\d+)(\s*#.*)?/ &&
! $2 == $next)
! {
! my($not, $num, $extra) = ($1, $2, $3);
! my($istodo) = $extra =~ /^\s*#\s*TODO/ if $extra;
! $istodo = 1 if $todo{$num};
!
! if( $not && !$istodo ) {
! $ok = 0;
! $next = $num;
! last;
! }
! elsif( $pending_not ) {
! $next = $num;
! $ok = 0;
! }
! else {
! $next = $next + 1;
! }
! }
! elsif(/^not $/) {
! # VMS has this problem. It sometimes adds newlines
! # between prints. This sometimes means you get
! # "not \nok 42"
! $pending_not = 1;
! }
! elsif (/^Bail out!\s*(.*)/i) { # magic words
! die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
}
+ else {
+ $ok = 0;
+ }
+
}
}
}
diff -c 'perl-5.7.1/vms/vms.c' 'perl-5.7.2/vms/vms.c'
Index: ./vms/vms.c
Prereq: 2.2
*** ./vms/vms.c Wed Mar 28 20:08:39 2001
--- ./vms/vms.c Mon Jul 9 17:11:34 2001
***************
*** 49,54 ****
--- 49,57 ----
# define SS$_NOSUCHOBJECT 2696
#endif
+ /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
+ #define PERLIO_NOT_STDIO 0
+
/* Don't replace system definitions of vfork, getenv, and stat,
* code below needs to get to the underlying CRTL routines. */
#define DONT_MASK_RTL_CALLS
***************
*** 129,135 ****
/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
int
! Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx,
struct dsc$descriptor_s **tabvec, unsigned long int flags)
{
char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
--- 132,138 ----
/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
int
! Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
struct dsc$descriptor_s **tabvec, unsigned long int flags)
{
char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
***************
*** 142,158 ****
{LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
{0, 0, 0, 0}};
$DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
! #if defined(USE_THREADS)
/* We jump through these hoops because we can be called at */
/* platform-specific initialization time, which is before anything is */
/* set up--we can't even do a plain dTHX since that relies on the */
/* interpreter structure to be initialized */
- struct perl_thread *thr;
if (PL_curinterp) {
! thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
} else {
! thr = NULL;
}
#endif
if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
--- 145,170 ----
{LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
{0, 0, 0, 0}};
$DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
! #if defined(PERL_IMPLICIT_CONTEXT)
! pTHX = NULL;
! # if defined(USE_5005THREADS)
/* We jump through these hoops because we can be called at */
/* platform-specific initialization time, which is before anything is */
/* set up--we can't even do a plain dTHX since that relies on the */
/* interpreter structure to be initialized */
if (PL_curinterp) {
! aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
} else {
! aTHX = NULL;
}
+ # else
+ if (PL_curinterp) {
+ aTHX = PERL_GET_INTERP;
+ } else {
+ aTHX = NULL;
+ }
+
+ # endif
#endif
if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
***************
*** 344,352 ****
/*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
char *
! my_getenv_len(const char *lnm, unsigned long *len, bool sys)
{
- dTHX;
char *buf, *cp1, *cp2;
unsigned long idx = 0;
static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
--- 356,363 ----
/*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
char *
! Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
{
char *buf, *cp1, *cp2;
unsigned long idx = 0;
static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
***************
*** 398,404 ****
} /* end of my_getenv_len() */
/*}}}*/
! static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
--- 409,415 ----
} /* end of my_getenv_len() */
/*}}}*/
! static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
***************
*** 409,415 ****
* find, in preparation for iterating over it.
*/
{
- dTHX;
static int primed = 0;
HV *seenhv = NULL, *envhv;
char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
--- 420,425 ----
***************
*** 426,436 ****
--- 436,469 ----
$DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
$DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
$DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
+ #if defined(PERL_IMPLICIT_CONTEXT)
+ pTHX;
+ #endif
#if defined(USE_THREADS) || defined(USE_ITHREADS)
static perl_mutex primenv_mutex;
MUTEX_INIT(&primenv_mutex);
#endif
+ #if defined(PERL_IMPLICIT_CONTEXT)
+ /* We jump through these hoops because we can be called at */
+ /* platform-specific initialization time, which is before anything is */
+ /* set up--we can't even do a plain dTHX since that relies on the */
+ /* interpreter structure to be initialized */
+ #if defined(USE_5005THREADS)
+ if (PL_curinterp) {
+ aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
+ } else {
+ aTHX = NULL;
+ }
+ #else
+ if (PL_curinterp) {
+ aTHX = PERL_GET_INTERP;
+ } else {
+ aTHX = NULL;
+ }
+ #endif
+ #endif
+
if (primed || !PL_envgv) return;
MUTEX_LOCK(&primenv_mutex);
if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
***************
*** 585,591 ****
* Like setenv() returns 0 for success, non-zero on error.
*/
int
! vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
{
char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
--- 618,624 ----
* Like setenv() returns 0 for success, non-zero on error.
*/
int
! Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
{
char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
***************
*** 595,601 ****
tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
$DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
$DESCRIPTOR(local,"_LOCAL");
- dTHX;
for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
*cp2 = _toupper(*cp1);
--- 628,633 ----
***************
*** 755,761 ****
* used for redirection of sys$error
*/
void
! Perl_vmssetuserlnm(char *name, char *eqv)
{
$DESCRIPTOR(d_tab, "LNM$PROCESS");
struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
--- 787,793 ----
* used for redirection of sys$error
*/
void
! Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
{
$DESCRIPTOR(d_tab, "LNM$PROCESS");
struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
***************
*** 786,792 ****
* be upcased by the caller.
*/
char *
! my_crypt(const char *textpasswd, const char *usrname)
{
# ifndef UAI$C_PREFERRED_ALGORITHM
# define UAI$C_PREFERRED_ALGORITHM 127
--- 818,824 ----
* be upcased by the caller.
*/
char *
! Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
{
# ifndef UAI$C_PREFERRED_ALGORITHM
# define UAI$C_PREFERRED_ALGORITHM 127
***************
*** 866,877 ****
*/
/*{{{int kill_file(char *name)*/
int
! kill_file(char *name)
{
char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
- dTHX;
struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
struct myacedef {
unsigned char myace$b_length;
--- 898,908 ----
*/
/*{{{int kill_file(char *name)*/
int
! Perl_kill_file(pTHX_ char *name)
{
char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
struct myacedef {
unsigned char myace$b_length;
***************
*** 968,977 ****
/*{{{int my_mkdir(char *,Mode_t)*/
int
! my_mkdir(char *dir, Mode_t mode)
{
STRLEN dirlen = strlen(dir);
- dTHX;
/* zero length string sometimes gives ACCVIO */
if (dirlen == 0) return -1;
--- 999,1007 ----
/*{{{int my_mkdir(char *,Mode_t)*/
int
! Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
{
STRLEN dirlen = strlen(dir);
/* zero length string sometimes gives ACCVIO */
if (dirlen == 0) return -1;
***************
*** 992,1001 ****
/*{{{int my_chdir(char *)*/
int
! my_chdir(char *dir)
{
STRLEN dirlen = strlen(dir);
- dTHX;
/* zero length string sometimes gives ACCVIO */
if (dirlen == 0) return -1;
--- 1022,1030 ----
/*{{{int my_chdir(char *)*/
int
! Perl_my_chdir(pTHX_ char *dir)
{
STRLEN dirlen = strlen(dir);
/* zero length string sometimes gives ACCVIO */
if (dirlen == 0) return -1;
***************
*** 1022,1028 ****
{
FILE *fp;
char *cp;
- dTHX;
if ((fp = tmpfile())) return fp;
--- 1051,1056 ----
***************
*** 1036,1052 ****
}
/*}}}*/
/* default piping mailbox size */
#define PERL_BUFSIZ 512
static void
! create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
{
unsigned long int mbxbufsiz;
static unsigned long int syssize = 0;
unsigned long int dviitm = DVI$_DEVNAM;
- dTHX;
char csize[LNM$C_NAMLENGTH+1];
if (!syssize) {
--- 1064,1100 ----
}
/*}}}*/
+
+ #ifndef HOMEGROWN_POSIX_SIGNALS
+ /*
+ * The C RTL's sigaction fails to check for invalid signal numbers so we
+ * help it out a bit. The docs are correct, but the actual routine doesn't
+ * do what the docs say it will.
+ */
+ /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
+ int
+ Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
+ struct sigaction* oact)
+ {
+ if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
+ SETERRNO(EINVAL, SS$_INVARG);
+ return -1;
+ }
+ return sigaction(sig, act, oact);
+ }
+ /*}}}*/
+ #endif
+
/* default piping mailbox size */
#define PERL_BUFSIZ 512
static void
! create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
{
unsigned long int mbxbufsiz;
static unsigned long int syssize = 0;
unsigned long int dviitm = DVI$_DEVNAM;
char csize[LNM$C_NAMLENGTH+1];
if (!syssize) {
***************
*** 1131,1136 ****
--- 1179,1188 ----
pInfo info;
pCBuf curr;
pCBuf curr2;
+ #if defined(PERL_IMPLICIT_CONTEXT)
+ void *thx; /* Either a thread or an interpreter */
+ /* pointer, depending on how we're built */
+ #endif
};
***************
*** 1172,1183 ****
static unsigned long int
! pipe_exit_routine()
{
pInfo info;
unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
int sts, did_stuff, need_eof;
- dTHX;
/*
first we try sending an EOF...ignore if doesn't work, make sure we
--- 1224,1234 ----
static unsigned long int
! pipe_exit_routine(pTHX)
{
pInfo info;
unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
int sts, did_stuff, need_eof;
/*
first we try sending an EOF...ignore if doesn't work, make sure we
***************
*** 1242,1248 ****
static void
popen_completion_ast(pInfo info)
{
- dTHX;
pInfo i = open_pipes;
int iss;
--- 1293,1298 ----
***************
*** 1274,1282 ****
if (info->in && !info->in_done) { /* only for mode=w */
if (info->in->shut_on_empty && info->in->need_wake) {
info->in->need_wake = FALSE;
! _ckvmssts(sys$dclast(pipe_tochild2_ast,info->in,0));
} else {
! _ckvmssts(sys$cancel(info->in->chan_out));
}
}
--- 1324,1332 ----
if (info->in && !info->in_done) { /* only for mode=w */
if (info->in->shut_on_empty && info->in->need_wake) {
info->in->need_wake = FALSE;
! _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
} else {
! _ckvmssts_noperl(sys$cancel(info->in->chan_out));
}
}
***************
*** 1284,1290 ****
info->out->shut_on_empty = TRUE;
iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
if (iss == SS$_MBFULL) iss = SS$_NORMAL;
! _ckvmssts(iss);
}
if (info->err && !info->err_done) { /* we were piping stderr */
--- 1334,1340 ----
info->out->shut_on_empty = TRUE;
iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
if (iss == SS$_MBFULL) iss = SS$_NORMAL;
! _ckvmssts_noperl(iss);
}
if (info->err && !info->err_done) { /* we were piping stderr */
***************
*** 1291,1303 ****
info->err->shut_on_empty = TRUE;
iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
if (iss == SS$_MBFULL) iss = SS$_NORMAL;
! _ckvmssts(iss);
}
! _ckvmssts(sys$setef(pipe_ef));
}
! static unsigned long int setup_cmddsc(char *cmd, int check_img);
static void vms_execfree(pTHX);
/*
--- 1341,1353 ----
info->err->shut_on_empty = TRUE;
iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
if (iss == SS$_MBFULL) iss = SS$_NORMAL;
! _ckvmssts_noperl(iss);
}
! _ckvmssts_noperl(sys$setef(pipe_ef));
}
! static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img);
static void vms_execfree(pTHX);
/*
***************
*** 1307,1313 ****
*/
static unsigned short
! popen_translate(char *logical, char *result)
{
int iss;
$DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
--- 1357,1363 ----
*/
static unsigned short
! popen_translate(pTHX_ char *logical, char *result)
{
int iss;
$DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
***************
*** 1367,1375 ****
#define INITIAL_TOCHILDQUEUE 2
static pPipe
! pipe_tochild_setup(char *rmbx, char *wmbx)
{
- dTHX;
pPipe p;
pCBuf b;
char mbx1[64], mbx2[64];
--- 1417,1424 ----
#define INITIAL_TOCHILDQUEUE 2
static pPipe
! pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
{
pPipe p;
pCBuf b;
char mbx1[64], mbx2[64];
***************
*** 1382,1389 ****
New(1368, p, 1, Pipe);
! create_mbx(&p->chan_in , &d_mbx1);
! create_mbx(&p->chan_out, &d_mbx2);
_ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
p->buf = 0;
--- 1431,1438 ----
New(1368, p, 1, Pipe);
! create_mbx(aTHX_ &p->chan_in , &d_mbx1);
! create_mbx(aTHX_ &p->chan_out, &d_mbx2);
_ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
p->buf = 0;
***************
*** 1398,1403 ****
--- 1447,1455 ----
p->curr = 0;
p->curr2 = 0;
p->info = 0;
+ #ifdef PERL_IMPLICIT_CONTEXT
+ p->thx = aTHX;
+ #endif
n = sizeof(CBuf) + p->bufsize;
***************
*** 1419,1428 ****
static void
pipe_tochild1_ast(pPipe p)
{
- dTHX;
pCBuf b = p->curr;
int iss = p->iosb.status;
int eof = (iss == SS$_ENDOFFILE);
if (p->retry) {
if (eof) {
--- 1471,1482 ----
static void
pipe_tochild1_ast(pPipe p)
{
pCBuf b = p->curr;
int iss = p->iosb.status;
int eof = (iss == SS$_ENDOFFILE);
+ #ifdef PERL_IMPLICIT_CONTEXT
+ pTHX = p->thx;
+ #endif
if (p->retry) {
if (eof) {
***************
*** 1479,1490 ****
static void
pipe_tochild2_ast(pPipe p)
{
- dTHX;
pCBuf b = p->curr2;
int iss = p->iosb2.status;
int n = sizeof(CBuf) + p->bufsize;
int done = (p->info && p->info->done) ||
iss == SS$_CANCEL || iss == SS$_ABORT;
do {
if (p->type) { /* type=1 has old buffer, dispose */
--- 1533,1546 ----
static void
pipe_tochild2_ast(pPipe p)
{
pCBuf b = p->curr2;
int iss = p->iosb2.status;
int n = sizeof(CBuf) + p->bufsize;
int done = (p->info && p->info->done) ||
iss == SS$_CANCEL || iss == SS$_ABORT;
+ #if defined(PERL_IMPLICIT_CONTEXT)
+ pTHX = p->thx;
+ #endif
do {
if (p->type) { /* type=1 has old buffer, dispose */
***************
*** 1532,1540 ****
static pPipe
! pipe_infromchild_setup(char *rmbx, char *wmbx)
{
- dTHX;
pPipe p;
char mbx1[64], mbx2[64];
struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
--- 1588,1595 ----
static pPipe
! pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
{
pPipe p;
char mbx1[64], mbx2[64];
struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
***************
*** 1544,1551 ****
unsigned int dviitm = DVI$_DEVBUFSIZ;
New(1367, p, 1, Pipe);
! create_mbx(&p->chan_in , &d_mbx1);
! create_mbx(&p->chan_out, &d_mbx2);
_ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
New(1367, p->buf, p->bufsize, char);
--- 1599,1606 ----
unsigned int dviitm = DVI$_DEVBUFSIZ;
New(1367, p, 1, Pipe);
! create_mbx(aTHX_ &p->chan_in , &d_mbx1);
! create_mbx(aTHX_ &p->chan_out, &d_mbx2);
_ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
New(1367, p->buf, p->bufsize, char);
***************
*** 1553,1558 ****
--- 1608,1616 ----
p->info = 0;
p->type = 0;
p->iosb.status = SS$_NORMAL;
+ #if defined(PERL_IMPLICIT_CONTEXT)
+ p->thx = aTHX;
+ #endif
pipe_infromchild_ast(p);
strcpy(wmbx, mbx1);
***************
*** 1563,1573 ****
static void
pipe_infromchild_ast(pPipe p)
{
- dTHX;
int iss = p->iosb.status;
int eof = (iss == SS$_ENDOFFILE);
int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
int kideof = (eof && (p->iosb.dvispec == p->info->pid));
if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
_ckvmssts(sys$dassgn(p->chan_out));
--- 1621,1633 ----
static void
pipe_infromchild_ast(pPipe p)
{
int iss = p->iosb.status;
int eof = (iss == SS$_ENDOFFILE);
int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
int kideof = (eof && (p->iosb.dvispec == p->info->pid));
+ #if defined(PERL_IMPLICIT_CONTEXT)
+ pTHX = p->thx;
+ #endif
if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
_ckvmssts(sys$dassgn(p->chan_out));
***************
*** 1639,1647 ****
}
static pPipe
! pipe_mbxtofd_setup(int fd, char *out)
{
- dTHX;
pPipe p;
char mbx[64];
unsigned long dviitm = DVI$_DEVBUFSIZ;
--- 1699,1706 ----
}
static pPipe
! pipe_mbxtofd_setup(pTHX_ int fd, char *out)
{
pPipe p;
char mbx[64];
unsigned long dviitm = DVI$_DEVBUFSIZ;
***************
*** 1664,1670 ****
New(1366, p, 1, Pipe);
p->fd_out = dup(fd);
! create_mbx(&p->chan_in, &d_mbx);
_ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
New(1366, p->buf, p->bufsize+1, char);
p->shut_on_empty = FALSE;
--- 1723,1729 ----
New(1366, p, 1, Pipe);
p->fd_out = dup(fd);
! create_mbx(aTHX_ &p->chan_in, &d_mbx);
_ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
New(1366, p->buf, p->bufsize+1, char);
p->shut_on_empty = FALSE;
***************
*** 1682,1688 ****
static void
pipe_mbxtofd_ast(pPipe p)
{
- dTHX;
int iss = p->iosb.status;
int done = p->info->done;
int iss2;
--- 1741,1746 ----
***************
*** 1689,1696 ****
int eof = (iss == SS$_ENDOFFILE);
int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
int err = !(iss&1) && !eof;
-
if (done && myeof) { /* end piping */
close(p->fd_out);
sys$dassgn(p->chan_in);
--- 1747,1756 ----
int eof = (iss == SS$_ENDOFFILE);
int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
int err = !(iss&1) && !eof;
+ #if defined(PERL_IMPLICIT_CONTEXT)
+ pTHX = p->thx;
+ #endif
if (done && myeof) { /* end piping */
close(p->fd_out);
sys$dassgn(p->chan_in);
***************
*** 1733,1739 ****
static pPLOC head_PLOC = 0;
void
! free_pipelocs(void *head)
{
pPLOC p, pnext;
--- 1793,1799 ----
static pPLOC head_PLOC = 0;
void
! free_pipelocs(pTHX_ void *head)
{
pPLOC p, pnext;
***************
*** 1746,1752 ****
}
static void
! store_pipelocs()
{
int i;
pPLOC p;
--- 1806,1812 ----
}
static void
! store_pipelocs(pTHX)
{
int i;
pPLOC p;
***************
*** 1810,1821 ****
p->dir[NAM$C_MAXRSS] = '\0';
}
#endif
! Perl_call_atexit(&free_pipelocs, head_PLOC);
}
static char *
! find_vmspipe(void)
{
static int vmspipe_file_status = 0;
static char vmspipe_file[NAM$C_MAXRSS+1];
--- 1870,1881 ----
p->dir[NAM$C_MAXRSS] = '\0';
}
#endif
! Perl_call_atexit(aTHX_ &free_pipelocs, head_PLOC);
}
static char *
! find_vmspipe(pTHX)
{
static int vmspipe_file_status = 0;
static char vmspipe_file[NAM$C_MAXRSS+1];
***************
*** 1857,1863 ****
}
static FILE *
! vmspipe_tempfile(void)
{
char file[NAM$C_MAXRSS+1];
FILE *fp;
--- 1917,1923 ----
}
static FILE *
! vmspipe_tempfile(pTHX)
{
char file[NAM$C_MAXRSS+1];
FILE *fp;
***************
*** 1936,1944 ****
static PerlIO *
! safe_popen(char *cmd, char *mode)
{
- dTHX;
static int handler_set_up = FALSE;
unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
unsigned int table = LIB$K_CLI_GLOBAL_SYM;
--- 1996,2003 ----
static PerlIO *
! safe_popen(pTHX_ char *cmd, char *mode)
{
static int handler_set_up = FALSE;
unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
unsigned int table = LIB$K_CLI_GLOBAL_SYM;
***************
*** 1986,1996 ****
/* see if we can find a VMSPIPE.COM */
tfilebuf[0] = '@';
! vmspipe = find_vmspipe();
if (vmspipe) {
strcpy(tfilebuf+1,vmspipe);
} else { /* uh, oh...we're in tempfile hell */
! tpipe = vmspipe_tempfile();
if (!tpipe) { /* a fish popular in Boston */
if (ckWARN(WARN_PIPE)) {
Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
--- 2045,2055 ----
/* see if we can find a VMSPIPE.COM */
tfilebuf[0] = '@';
! vmspipe = find_vmspipe(aTHX);
if (vmspipe) {
strcpy(tfilebuf+1,vmspipe);
} else { /* uh, oh...we're in tempfile hell */
! tpipe = vmspipe_tempfile(aTHX);
if (!tpipe) { /* a fish popular in Boston */
if (ckWARN(WARN_PIPE)) {
Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
***************
*** 2002,2008 ****
vmspipedsc.dsc$a_pointer = tfilebuf;
vmspipedsc.dsc$w_length = strlen(tfilebuf);
! if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
New(1301,info,1,Info);
info->mode = *mode;
--- 2061,2067 ----
vmspipedsc.dsc$a_pointer = tfilebuf;
vmspipedsc.dsc$w_length = strlen(tfilebuf);
! if (!(setup_cmddsc(aTHX_ cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
New(1301,info,1,Info);
info->mode = *mode;
***************
*** 2019,2025 ****
if (*mode == 'r') { /* piping from subroutine */
! info->out = pipe_infromchild_setup(mbx,out);
if (info->out) {
info->out->pipe_done = &info->out_done;
info->out_done = FALSE;
--- 2078,2084 ----
if (*mode == 'r') { /* piping from subroutine */
! info->out = pipe_infromchild_setup(aTHX_ mbx,out);
if (info->out) {
info->out->pipe_done = &info->out_done;
info->out_done = FALSE;
***************
*** 2044,2050 ****
return Nullfp;
}
! info->err = pipe_mbxtofd_setup(fileno(stderr), err);
if (info->err) {
info->err->pipe_done = &info->err_done;
info->err_done = FALSE;
--- 2103,2109 ----
return Nullfp;
}
! info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
if (info->err) {
info->err->pipe_done = &info->err_done;
info->err_done = FALSE;
***************
*** 2053,2059 ****
} else { /* piping to subroutine , mode=w*/
! info->in = pipe_tochild_setup(in,mbx);
info->fp = PerlIO_open(mbx, mode);
if (info->in) {
info->in->pipe_done = &info->in_done;
--- 2112,2118 ----
} else { /* piping to subroutine , mode=w*/
! info->in = pipe_tochild_setup(aTHX_ in,mbx);
info->fp = PerlIO_open(mbx, mode);
if (info->in) {
info->in->pipe_done = &info->in_done;
***************
*** 2083,2089 ****
}
! info->out = pipe_mbxtofd_setup(fileno(stdout), out);
if (info->out) {
info->out->pipe_done = &info->out_done;
info->out_done = FALSE;
--- 2142,2148 ----
}
! info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
if (info->out) {
info->out->pipe_done = &info->out_done;
info->out_done = FALSE;
***************
*** 2090,2096 ****
info->out->info = info;
}
! info->err = pipe_mbxtofd_setup(fileno(stderr), err);
if (info->err) {
info->err->pipe_done = &info->err_done;
info->err_done = FALSE;
--- 2149,2155 ----
info->out->info = info;
}
! info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
if (info->err) {
info->err->pipe_done = &info->err_done;
info->err_done = FALSE;
***************
*** 2149,2170 ****
} /* end of safe_popen */
! /*{{{ FILE *my_popen(char *cmd, char *mode)*/
! FILE *
Perl_my_popen(pTHX_ char *cmd, char *mode)
{
TAINT_ENV();
TAINT_PROPER("popen");
PERL_FLUSHALL_FOR_CHILD;
! return safe_popen(cmd,mode);
}
/*}}}*/
! /*{{{ I32 my_pclose(FILE *fp)*/
! I32 Perl_my_pclose(pTHX_ FILE *fp)
{
- dTHX;
pInfo info, last = NULL;
unsigned long int retsts;
int done, iss;
--- 2208,2228 ----
} /* end of safe_popen */
! /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
! PerlIO *
Perl_my_popen(pTHX_ char *cmd, char *mode)
{
TAINT_ENV();
TAINT_PROPER("popen");
PERL_FLUSHALL_FOR_CHILD;
! return safe_popen(aTHX_ cmd,mode);
}
/*}}}*/
! /*{{{ I32 my_pclose(PerlIO *fp)*/
! I32 Perl_my_pclose(pTHX_ PerlIO *fp)
{
pInfo info, last = NULL;
unsigned long int retsts;
int done, iss;
***************
*** 2186,2192 ****
* the first EOF closing the pipe (and DASSGN'ing the channel)...
*/
! fsync(fileno(info->fp)); /* first, flush data */
_ckvmssts(sys$setast(0));
info->closing = TRUE;
--- 2244,2250 ----
* the first EOF closing the pipe (and DASSGN'ing the channel)...
*/
! PerlIO_flush(info->fp); /* first, flush data */
_ckvmssts(sys$setast(0));
info->closing = TRUE;
***************
*** 2250,2260 ****
/* sort-of waitpid; use only with popen() */
/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
Pid_t
! my_waitpid(Pid_t pid, int *statusp, int flags)
{
pInfo info;
int done;
- dTHX;
for (info = open_pipes; info != NULL; info = info->next)
if (info->pid == pid) break;
--- 2308,2317 ----
/* sort-of waitpid; use only with popen() */
/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
Pid_t
! Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
{
pInfo info;
int done;
for (info = open_pipes; info != NULL; info = info->next)
if (info->pid == pid) break;
***************
*** 3407,3413 ****
static int background_process(int argc, char **argv);
! static void pipe_and_fork(char **cmargv);
/*{{{ void getredirection(int *ac, char ***av)*/
static void
--- 3464,3470 ----
static int background_process(int argc, char **argv);
! static void pipe_and_fork(pTHX_ char **cmargv);
/*{{{ void getredirection(int *ac, char ***av)*/
static void
***************
*** 3471,3477 ****
{
if (j+1 >= argc)
{
! PerlIO_printf(Perl_debug_log,"No input file after < on command line");
exit(LIB$_WRONUMARG);
}
in = argv[++j];
--- 3528,3534 ----
{
if (j+1 >= argc)
{
! fprintf(stderr,"No input file after < on command line");
exit(LIB$_WRONUMARG);
}
in = argv[++j];
***************
*** 3486,3492 ****
{
if (j+1 >= argc)
{
! PerlIO_printf(Perl_debug_log,"No output file after > on command line");
exit(LIB$_WRONUMARG);
}
out = argv[++j];
--- 3543,3549 ----
{
if (j+1 >= argc)
{
! fprintf(stderr,"No output file after > on command line");
exit(LIB$_WRONUMARG);
}
out = argv[++j];
***************
*** 3506,3512 ****
out = 1 + ap;
if (j >= argc)
{
! PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
exit(LIB$_WRONUMARG);
}
continue;
--- 3563,3569 ----
out = 1 + ap;
if (j >= argc)
{
! fprintf(stderr,"No output file after > or >> on command line");
exit(LIB$_WRONUMARG);
}
continue;
***************
*** 3528,3534 ****
err = 2 + ap;
if (j >= argc)
{
! PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
exit(LIB$_WRONUMARG);
}
continue;
--- 3585,3591 ----
err = 2 + ap;
if (j >= argc)
{
! fprintf(stderr,"No output file after 2> or 2>> on command line");
exit(LIB$_WRONUMARG);
}
continue;
***************
*** 3537,3543 ****
{
if (j+1 >= argc)
{
! PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
exit(LIB$_WRONUMARG);
}
cmargc = argc-(j+1);
--- 3594,3600 ----
{
if (j+1 >= argc)
{
! fprintf(stderr,"No command into which to pipe on command line");
exit(LIB$_WRONUMARG);
}
cmargc = argc-(j+1);
***************
*** 3568,3577 ****
{
if (out != NULL)
{
! PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
exit(LIB$_INVARGORD);
}
! pipe_and_fork(cmargv);
}
/* Check for input from a pipe (mailbox) */
--- 3625,3634 ----
{
if (out != NULL)
{
! fprintf(stderr,"'|' and '>' may not both be specified on command line");
exit(LIB$_INVARGORD);
}
! pipe_and_fork(aTHX_ cmargv);
}
/* Check for input from a pipe (mailbox) */
***************
*** 3587,3593 ****
/* Input from a pipe, reopen it in binary mode to disable */
/* carriage control processing. */
! PerlIO_getname(stdin, mbxname);
mbxnam.dsc$a_pointer = mbxname;
mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
--- 3644,3650 ----
/* Input from a pipe, reopen it in binary mode to disable */
/* carriage control processing. */
! fgetname(stdin, mbxname);
mbxnam.dsc$a_pointer = mbxname;
mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
***************
*** 3601,3639 ****
freopen(mbxname, "rb", stdin);
if (errno != 0)
{
! PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
exit(vaxc$errno);
}
}
if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
{
! PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
exit(vaxc$errno);
}
if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
{
! PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
exit(vaxc$errno);
}
! if (out != NULL) Perl_vmssetuserlnm("SYS$OUTPUT",out);
if (err != NULL) {
if (strcmp(err,"&1") == 0) {
! dup2(fileno(stdout), fileno(Perl_debug_log));
! Perl_vmssetuserlnm("SYS$ERROR","SYS$OUTPUT");
} else {
FILE *tmperr;
if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
{
! PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
exit(vaxc$errno);
}
fclose(tmperr);
! if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
{
exit(vaxc$errno);
}
! Perl_vmssetuserlnm("SYS$ERROR",err);
}
}
#ifdef ARGPROC_DEBUG
--- 3658,3696 ----
freopen(mbxname, "rb", stdin);
if (errno != 0)
{
! fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
exit(vaxc$errno);
}
}
if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
{
! fprintf(stderr,"Can't open input file %s as stdin",in);
exit(vaxc$errno);
}
if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
{
! fprintf(stderr,"Can't open output file %s as stdout",out);
exit(vaxc$errno);
}
! if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
if (err != NULL) {
if (strcmp(err,"&1") == 0) {
! dup2(fileno(stdout), fileno(stderr));
! Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
} else {
FILE *tmperr;
if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
{
! fprintf(stderr,"Can't open error file %s as stderr",err);
exit(vaxc$errno);
}
fclose(tmperr);
! if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
{
exit(vaxc$errno);
}
! Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
}
}
#ifdef ARGPROC_DEBUG
***************
*** 3804,3810 ****
0
};
! static void pipe_and_fork(char **cmargv)
{
char subcmd[2048];
$DESCRIPTOR(cmddsc, "");
--- 3861,3867 ----
0
};
! static void pipe_and_fork(pTHX_ char **cmargv)
{
char subcmd[2048];
$DESCRIPTOR(cmddsc, "");
***************
*** 3823,3829 ****
cmddsc.dsc$a_pointer = subcmd;
cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
! create_mbx(&child_chan,&mbxdsc);
#ifdef ARGPROC_DEBUG
PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
--- 3880,3886 ----
cmddsc.dsc$a_pointer = subcmd;
cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
! create_mbx(aTHX_ &child_chan,&mbxdsc);
#ifdef ARGPROC_DEBUG
PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
***************
*** 3903,3919 ****
unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
unsigned short int dummy, rlen;
struct dsc$descriptor_s **tabvec;
! dTHX;
struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
{sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
{ sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
{ 0, 0, 0, 0} };
! _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
! _ckvmssts(iosb[0]);
for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
if (iprv[i]) { /* Running image installed with privs? */
! _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
will_taint = TRUE;
break;
}
--- 3960,3978 ----
unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
unsigned short int dummy, rlen;
struct dsc$descriptor_s **tabvec;
! #if defined(PERL_IMPLICIT_CONTEXT)
! pTHX = NULL;
! #endif
struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
{sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
{ sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
{ 0, 0, 0, 0} };
! _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
! _ckvmssts_noperl(iosb[0]);
for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
if (iprv[i]) { /* Running image installed with privs? */
! _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
will_taint = TRUE;
break;
}
***************
*** 3938,3945 ****
if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
jpilist[1].buflen = rsz * sizeof(unsigned long int);
! _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
! _ckvmssts(iosb[0]);
}
mask = jpilist[1].bufadr;
/* Check attribute flags for each identifier (2nd longword); protected
--- 3997,4004 ----
if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
jpilist[1].buflen = rsz * sizeof(unsigned long int);
! _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
! _ckvmssts_noperl(iosb[0]);
}
mask = jpilist[1].bufadr;
/* Check attribute flags for each identifier (2nd longword); protected
***************
*** 3995,4001 ****
tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
tabvec[tabidx]->dsc$a_pointer = NULL;
! _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
}
if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
--- 4054,4060 ----
tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
tabvec[tabidx]->dsc$a_pointer = NULL;
! _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
}
if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
***************
*** 4251,4258 ****
* Collect all the version numbers for the current file.
*/
static void
! collectversions(dd)
! DIR *dd;
{
struct dsc$descriptor_s pat;
struct dsc$descriptor_s res;
--- 4310,4316 ----
* Collect all the version numbers for the current file.
*/
static void
! collectversions(pTHX_ DIR *dd)
{
struct dsc$descriptor_s pat;
struct dsc$descriptor_s res;
***************
*** 4260,4266 ****
char *p, *text, buff[sizeof dd->entry.d_name];
int i;
unsigned long context, tmpsts;
- dTHX;
/* Convenient shorthand. */
e = &dd->entry;
--- 4318,4323 ----
***************
*** 4307,4313 ****
*/
/*{{{ struct dirent *readdir(DIR *dd)*/
struct dirent *
! readdir(DIR *dd)
{
struct dsc$descriptor_s res;
char *p, buff[sizeof dd->entry.d_name];
--- 4364,4370 ----
*/
/*{{{ struct dirent *readdir(DIR *dd)*/
struct dirent *
! Perl_readdir(pTHX_ DIR *dd)
{
struct dsc$descriptor_s res;
char *p, buff[sizeof dd->entry.d_name];
***************
*** 4352,4358 ****
dd->entry.d_namlen = strlen(dd->entry.d_name);
dd->entry.vms_verscount = 0;
! if (dd->vms_wantversions) collectversions(dd);
return &dd->entry;
} /* end of readdir() */
--- 4409,4415 ----
dd->entry.d_namlen = strlen(dd->entry.d_name);
dd->entry.vms_verscount = 0;
! if (dd->vms_wantversions) collectversions(aTHX_ dd);
return &dd->entry;
} /* end of readdir() */
***************
*** 4374,4383 ****
*/
/*{{{ void seekdir(DIR *dd,long count)*/
void
! seekdir(DIR *dd, long count)
{
int vms_wantversions;
- dTHX;
/* If we haven't done anything yet... */
if (dd->count == 0)
--- 4431,4439 ----
*/
/*{{{ void seekdir(DIR *dd,long count)*/
void
! Perl_seekdir(pTHX_ DIR *dd, long count)
{
int vms_wantversions;
/* If we haven't done anything yet... */
if (dd->count == 0)
***************
*** 4454,4462 ****
}
static char *
! setup_argstr(SV *really, SV **mark, SV **sp)
{
- dTHX;
char *junk, *tmps = Nullch;
register size_t cmdlen = 0;
size_t rlen;
--- 4510,4517 ----
}
static char *
! setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
{
char *junk, *tmps = Nullch;
register size_t cmdlen = 0;
size_t rlen;
***************
*** 4499,4505 ****
static unsigned long int
! setup_cmddsc(char *cmd, int check_img)
{
char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
$DESCRIPTOR(defdsc,".EXE");
--- 4554,4560 ----
static unsigned long int
! setup_cmddsc(pTHX_ char *cmd, int check_img)
{
char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
$DESCRIPTOR(defdsc,".EXE");
***************
*** 4509,4515 ****
unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
register char *s, *rest, *cp, *wordbreak;
register int isdcl;
- dTHX;
if (strlen(cmd) >
(sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
--- 4564,4569 ----
***************
*** 4624,4632 ****
/* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
bool
! vms_do_aexec(SV *really,SV **mark,SV **sp)
{
- dTHX;
if (sp > mark) {
if (vfork_called) { /* this follows a vfork - act Unixish */
vfork_called--;
--- 4678,4685 ----
/* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
bool
! Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
{
if (sp > mark) {
if (vfork_called) { /* this follows a vfork - act Unixish */
vfork_called--;
***************
*** 4637,4643 ****
else return do_aexec(really,mark,sp);
}
/* no vfork - act VMSish */
! return vms_do_exec(setup_argstr(really,mark,sp));
}
--- 4690,4696 ----
else return do_aexec(really,mark,sp);
}
/* no vfork - act VMSish */
! return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
}
***************
*** 4647,4656 ****
/* {{{bool vms_do_exec(char *cmd) */
bool
! vms_do_exec(char *cmd)
{
- dTHX;
if (vfork_called) { /* this follows a vfork - act Unixish */
vfork_called--;
if (vfork_called < 0) {
--- 4700,4708 ----
/* {{{bool vms_do_exec(char *cmd) */
bool
! Perl_vms_do_exec(pTHX_ char *cmd)
{
if (vfork_called) { /* this follows a vfork - act Unixish */
vfork_called--;
if (vfork_called < 0) {
***************
*** 4665,4671 ****
TAINT_ENV();
TAINT_PROPER("exec");
! if ((retsts = setup_cmddsc(cmd,1)) & 1)
retsts = lib$do_command(&VMScmd);
switch (retsts) {
--- 4717,4723 ----
TAINT_ENV();
TAINT_PROPER("exec");
! if ((retsts = setup_cmddsc(aTHX_ cmd,1)) & 1)
retsts = lib$do_command(&VMScmd);
switch (retsts) {
***************
*** 4699,4712 ****
} /* end of vms_do_exec() */
/*}}}*/
! unsigned long int do_spawn(char *);
/* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
unsigned long int
! do_aspawn(void *really,void **mark,void **sp)
{
! dTHX;
! if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
return SS$_ABORT;
} /* end of do_aspawn() */
--- 4751,4763 ----
} /* end of vms_do_exec() */
/*}}}*/
! unsigned long int Perl_do_spawn(pTHX_ char *);
/* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
unsigned long int
! Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
{
! if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
return SS$_ABORT;
} /* end of do_aspawn() */
***************
*** 4714,4723 ****
/* {{{unsigned long int do_spawn(char *cmd) */
unsigned long int
! do_spawn(char *cmd)
{
unsigned long int sts, substs, hadcmd = 1;
- dTHX;
TAINT_ENV();
TAINT_PROPER("spawn");
--- 4765,4773 ----
/* {{{unsigned long int do_spawn(char *cmd) */
unsigned long int
! Perl_do_spawn(pTHX_ char *cmd)
{
unsigned long int sts, substs, hadcmd = 1;
TAINT_ENV();
TAINT_PROPER("spawn");
***************
*** 4725,4731 ****
hadcmd = 0;
sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
}
! else if ((sts = setup_cmddsc(cmd,0)) & 1) {
sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
}
--- 4775,4781 ----
hadcmd = 0;
sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
}
! else if ((sts = setup_cmddsc(aTHX_ cmd,0)) & 1) {
sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
}
***************
*** 4821,4829 ****
* data with nulls sprinkled in the middle but also data with no null
* byte at the end.
*/
! /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
int
! my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
{
register char *cp, *end, *cpd, *data;
register unsigned int fd = fileno(dest);
--- 4871,4879 ----
* data with nulls sprinkled in the middle but also data with no null
* byte at the end.
*/
! /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
int
! my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
{
register char *cp, *end, *cpd, *data;
register unsigned int fd = fileno(dest);
***************
*** 4861,4867 ****
/*{{{ int my_flush(FILE *fp)*/
int
! my_flush(FILE *fp)
{
int res;
if ((res = fflush(fp)) == 0 && fp) {
--- 4911,4917 ----
/*{{{ int my_flush(FILE *fp)*/
int
! Perl_my_flush(pTHX_ FILE *fp)
{
int res;
if ((res = fflush(fp)) == 0 && fp) {
***************
*** 4942,4950 ****
/*
* This routine does most of the work extracting the user information.
*/
! static int fillpasswd (const char *name, struct passwd *pwd)
{
- dTHX;
static struct {
unsigned char length;
char pw_gecos[UAI$S_OWNER+1];
--- 4992,4999 ----
/*
* This routine does most of the work extracting the user information.
*/
! static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
{
static struct {
unsigned char length;
char pw_gecos[UAI$S_OWNER+1];
***************
*** 5024,5038 ****
* Get information for a named user.
*/
/*{{{struct passwd *getpwnam(char *name)*/
! struct passwd *my_getpwnam(char *name)
{
struct dsc$descriptor_s name_desc;
union uicdef uic;
unsigned long int status, sts;
- dTHX;
__pwdcache = __passwd_empty;
! if (!fillpasswd(name, &__pwdcache)) {
/* We still may be able to determine pw_uid and pw_gid */
name_desc.dsc$w_length= strlen(name);
name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
--- 5073,5086 ----
* Get information for a named user.
*/
/*{{{struct passwd *getpwnam(char *name)*/
! struct passwd *Perl_my_getpwnam(pTHX_ char *name)
{
struct dsc$descriptor_s name_desc;
union uicdef uic;
unsigned long int status, sts;
__pwdcache = __passwd_empty;
! if (!fillpasswd(aTHX_ name, &__pwdcache)) {
/* We still may be able to determine pw_uid and pw_gid */
name_desc.dsc$w_length= strlen(name);
name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
***************
*** 5063,5075 ****
* Called by my_getpwent with uid=-1 to list all users.
*/
/*{{{struct passwd *my_getpwuid(Uid_t uid)*/
! struct passwd *my_getpwuid(Uid_t uid)
{
const $DESCRIPTOR(name_desc,__pw_namecache);
unsigned short lname;
union uicdef uic;
unsigned long int status;
- dTHX;
if (uid == (unsigned int) -1) {
do {
--- 5111,5122 ----
* Called by my_getpwent with uid=-1 to list all users.
*/
/*{{{struct passwd *my_getpwuid(Uid_t uid)*/
! struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
{
const $DESCRIPTOR(name_desc,__pw_namecache);
unsigned short lname;
union uicdef uic;
unsigned long int status;
if (uid == (unsigned int) -1) {
do {
***************
*** 5109,5115 ****
__pwdcache.pw_uid = uic.uic$l_uic;
__pwdcache.pw_gid = uic.uic$v_group;
! fillpasswd(__pw_namecache, &__pwdcache);
return &__pwdcache;
} /* end of my_getpwuid() */
--- 5156,5162 ----
__pwdcache.pw_uid = uic.uic$l_uic;
__pwdcache.pw_gid = uic.uic$v_group;
! fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
return &__pwdcache;
} /* end of my_getpwuid() */
***************
*** 5119,5125 ****
* Get information for next user.
*/
/*{{{struct passwd *my_getpwent()*/
! struct passwd *my_getpwent()
{
return (my_getpwuid((unsigned int) -1));
}
--- 5166,5172 ----
* Get information for next user.
*/
/*{{{struct passwd *my_getpwent()*/
! struct passwd *Perl_my_getpwent(pTHX)
{
return (my_getpwuid((unsigned int) -1));
}
***************
*** 5129,5137 ****
* Finish searching rights database for users.
*/
/*{{{void my_endpwent()*/
! void my_endpwent()
{
- dTHX;
if (contxt) {
_ckvmssts(sys$finish_rdb(&contxt));
contxt= 0;
--- 5176,5183 ----
* Finish searching rights database for users.
*/
/*{{{void my_endpwent()*/
! void Perl_my_endpwent(pTHX)
{
if (contxt) {
_ckvmssts(sys$finish_rdb(&contxt));
contxt= 0;
***************
*** 5474,5480 ****
*/
static int
! tz_parse(time_t *w, int *dst, char *zone, int *gmtoff)
{
time_t when;
struct tm *w2;
--- 5520,5526 ----
*/
static int
! tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
{
time_t when;
struct tm *w2;
***************
*** 5600,5608 ****
*/
/*{{{time_t my_time(time_t *timep)*/
! time_t my_time(time_t *timep)
{
- dTHX;
time_t when;
struct tm *tm_p;
--- 5646,5653 ----
*/
/*{{{time_t my_time(time_t *timep)*/
! time_t Perl_my_time(pTHX_ time_t *timep)
{
time_t when;
struct tm *tm_p;
***************
*** 5654,5662 ****
/*{{{struct tm *my_gmtime(const time_t *timep)*/
struct tm *
! my_gmtime(const time_t *timep)
{
- dTHX;
char *p;
time_t when;
struct tm *rsltmp;
--- 5699,5706 ----
/*{{{struct tm *my_gmtime(const time_t *timep)*/
struct tm *
! Perl_my_gmtime(pTHX_ const time_t *timep)
{
char *p;
time_t when;
struct tm *rsltmp;
***************
*** 5685,5693 ****
/*{{{struct tm *my_localtime(const time_t *timep)*/
struct tm *
! my_localtime(const time_t *timep)
{
- dTHX;
time_t when, whenutc;
struct tm *rsltmp;
int dst, offset;
--- 5729,5736 ----
/*{{{struct tm *my_localtime(const time_t *timep)*/
struct tm *
! Perl_my_localtime(pTHX_ const time_t *timep)
{
time_t when, whenutc;
struct tm *rsltmp;
int dst, offset;
***************
*** 5752,5760 ****
static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
/*{{{int my_utime(char *path, struct utimbuf *utimes)*/
! int my_utime(char *file, struct utimbuf *utimes)
{
- dTHX;
register int i;
long int bintime[2], len = 2, lowbit, unixtime,
secscale = 10000000; /* seconds --> 100 ns intervals */
--- 5795,5802 ----
static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
/*{{{int my_utime(char *path, struct utimbuf *utimes)*/
! int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
{
register int i;
long int bintime[2], len = 2, lowbit, unixtime,
secscale = 10000000; /* seconds --> 100 ns intervals */
***************
*** 5937,5943 ****
* on the first call.
*/
#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
! static mydev_t encode_dev (const char *dev)
{
int i;
unsigned long int f;
--- 5979,5985 ----
* on the first call.
*/
#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
! static mydev_t encode_dev (pTHX_ const char *dev)
{
int i;
unsigned long int f;
***************
*** 5944,5950 ****
mydev_t enc;
char c;
const char *q;
- dTHX;
if (!dev || !dev[0]) return 0;
--- 5986,5991 ----
***************
*** 5990,5996 ****
is_null_device(name)
const char *name;
{
- dTHX;
/* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
The underscore prefix, controller letter, and unit number are
independently optional; for our purposes, the colon punctuation
--- 6031,6036 ----
***************
*** 6054,6060 ****
/*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
I32
! cando_by_name(I32 bit, Uid_t effective, char *fname)
{
static char usrname[L_cuserid];
static struct dsc$descriptor_s usrdsc =
--- 6094,6100 ----
/*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
I32
! Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
{
static char usrname[L_cuserid];
static struct dsc$descriptor_s usrdsc =
***************
*** 6062,6068 ****
char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
unsigned short int retlen;
- dTHX;
struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
union prvdef curprv;
struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
--- 6102,6107 ----
***************
*** 6141,6152 ****
/*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
int
! flex_fstat(int fd, Stat_t *statbufp)
{
- dTHX;
if (!fstat(fd,(stat_t *) statbufp)) {
if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
! statbufp->st_dev = encode_dev(statbufp->st_devnam);
# ifdef RTL_USES_UTC
# ifdef VMSISH_TIME
if (VMSISH_TIME) {
--- 6180,6190 ----
/*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
int
! Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
{
if (!fstat(fd,(stat_t *) statbufp)) {
if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
! statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
# ifdef RTL_USES_UTC
# ifdef VMSISH_TIME
if (VMSISH_TIME) {
***************
*** 6175,6183 ****
/*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
int
! flex_stat(const char *fspec, Stat_t *statbufp)
{
- dTHX;
char fileified[NAM$C_MAXRSS+1];
char temp_fspec[NAM$C_MAXRSS+300];
int retval = -1;
--- 6213,6220 ----
/*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
int
! Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
{
char fileified[NAM$C_MAXRSS+1];
char temp_fspec[NAM$C_MAXRSS+300];
int retval = -1;
***************
*** 6187,6193 ****
do_tovmsspec(temp_fspec,namecache,0);
if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
memset(statbufp,0,sizeof *statbufp);
! statbufp->st_dev = encode_dev("_NLA0:");
statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
statbufp->st_uid = 0x00010001;
statbufp->st_gid = 0x0001;
--- 6224,6230 ----
do_tovmsspec(temp_fspec,namecache,0);
if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
memset(statbufp,0,sizeof *statbufp);
! statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
statbufp->st_uid = 0x00010001;
statbufp->st_gid = 0x0001;
***************
*** 6211,6217 ****
}
if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
if (!retval) {
! statbufp->st_dev = encode_dev(statbufp->st_devnam);
# ifdef RTL_USES_UTC
# ifdef VMSISH_TIME
if (VMSISH_TIME) {
--- 6248,6254 ----
}
if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
if (!retval) {
! statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
# ifdef RTL_USES_UTC
# ifdef VMSISH_TIME
if (VMSISH_TIME) {
***************
*** 6564,6570 ****
mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
if (SvTYPE(mysv) == SVt_PVGV) {
! if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
ST(0) = &PL_sv_no;
XSRETURN(1);
--- 6601,6607 ----
mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
if (SvTYPE(mysv) == SVt_PVGV) {
! if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
ST(0) = &PL_sv_no;
XSRETURN(1);
***************
*** 6601,6607 ****
mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
if (SvTYPE(mysv) == SVt_PVGV) {
! if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
ST(0) = &PL_sv_no;
XSRETURN(1);
--- 6638,6644 ----
mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
if (SvTYPE(mysv) == SVt_PVGV) {
! if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
ST(0) = &PL_sv_no;
XSRETURN(1);
***************
*** 6617,6623 ****
}
mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
if (SvTYPE(mysv) == SVt_PVGV) {
! if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
ST(0) = &PL_sv_no;
XSRETURN(1);
--- 6654,6660 ----
}
mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
if (SvTYPE(mysv) == SVt_PVGV) {
! if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
ST(0) = &PL_sv_no;
XSRETURN(1);
***************
*** 6639,6645 ****
void
! mod2fname(CV *cv)
{
dXSARGS;
char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
--- 6676,6682 ----
void
! mod2fname(pTHX_ CV *cv)
{
dXSARGS;
char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
***************
*** 6716,6723 ****
void
init_os_extras()
{
- char* file = __FILE__;
dTHX;
char temp_buff[512];
if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
no_translate_barewords = TRUE;
--- 6753,6760 ----
void
init_os_extras()
{
dTHX;
+ char* file = __FILE__;
char temp_buff[512];
if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
no_translate_barewords = TRUE;
***************
*** 6736,6742 ****
newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
! store_pipelocs();
return;
}
--- 6773,6779 ----
newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
! store_pipelocs(aTHX);
return;
}
diff -c 'perl-5.7.1/vms/vmsish.h' 'perl-5.7.2/vms/vmsish.h'
Index: ./vms/vmsish.h
*** ./vms/vmsish.h Wed Mar 28 20:09:24 2001
--- ./vms/vmsish.h Mon Jul 9 17:11:34 2001
***************
*** 63,79 ****
#define HAS_GETENV_SV
#define HAS_GETENV_LEN
#ifndef DONT_MASK_RTL_CALLS
# ifdef getenv
# undef getenv
# endif
/* getenv used for regular logical names */
! # define getenv(v) my_getenv(v,TRUE)
#endif
#ifdef getenv_len
# undef getenv_len
#endif
! #define getenv_len(v,l) my_getenv_len(v,l,TRUE)
/* DECC introduces this routine in the RTL as of VMS 7.0; for now,
* we'll use ours, since it gives us the full VMS exit status. */
--- 63,92 ----
#define HAS_GETENV_SV
#define HAS_GETENV_LEN
+ /* All this stiff is for the x2P programs. Hopefully they'll still work */
+ #if defined(PERL_FOR_X2P)
+ #ifndef aTHX_
+ #define aTHX_
+ #endif
+ #ifndef pTHX_
+ #define pTHX_
+ #endif
+ #ifndef pTHX
+ #define pTHX
+ #endif
+ #endif
+
#ifndef DONT_MASK_RTL_CALLS
# ifdef getenv
# undef getenv
# endif
/* getenv used for regular logical names */
! # define getenv(v) Perl_my_getenv(aTHX_ v,TRUE)
#endif
#ifdef getenv_len
# undef getenv_len
#endif
! #define getenv_len(v,l) Perl_my_getenv_len(aTHX_ v,l,TRUE)
/* DECC introduces this routine in the RTL as of VMS 7.0; for now,
* we'll use ours, since it gives us the full VMS exit status. */
***************
*** 86,97 ****
#define DONT_DECLARE_STD 1
/* Our own contribution to PerlShr's global symbols . . . */
- #define my_getenv_len Perl_my_getenv_len
#define prime_env_iter Perl_prime_env_iter
! #define vmssetenv Perl_vmssetenv
#if !defined(PERL_IMPLICIT_CONTEXT)
#define my_trnlnm Perl_my_trnlnm
- #define vmstrnenv Perl_vmstrnenv
#define my_setenv Perl_my_setenv
#define my_getenv Perl_my_getenv
#define tounixspec Perl_tounixspec
--- 99,112 ----
#define DONT_DECLARE_STD 1
/* Our own contribution to PerlShr's global symbols . . . */
#define prime_env_iter Perl_prime_env_iter
! #define vms_image_init Perl_vms_image_init
! #define my_tmpfile Perl_my_tmpfile
! #define vmstrnenv Perl_vmstrnenv
#if !defined(PERL_IMPLICIT_CONTEXT)
+ #define my_getenv_len Perl_my_getenv_len
+ #define vmssetenv Perl_vmssetenv
#define my_trnlnm Perl_my_trnlnm
#define my_setenv Perl_my_setenv
#define my_getenv Perl_my_getenv
#define tounixspec Perl_tounixspec
***************
*** 110,118 ****
#define trim_unixpath Perl_trim_unixpath
#define opendir Perl_opendir
#define rmscopy Perl_rmscopy
#else
#define my_trnlnm(a,b,c) Perl_my_trnlnm(aTHX_ a,b,c)
- #define vmstrnenv(a,b,c,d,e) Perl_vmstrnenv(aTHX_ a,b,c,d,e)
#define my_setenv(a,b) Perl_my_setenv(aTHX_ a,b)
#define my_getenv(a,b) Perl_my_getenv(aTHX_ a,b)
#define tounixspec(a,b) Perl_tounixspec(aTHX_ a,b)
--- 125,155 ----
#define trim_unixpath Perl_trim_unixpath
#define opendir Perl_opendir
#define rmscopy Perl_rmscopy
+ #define my_mkdir Perl_my_mkdir
+ #define vms_do_aexec Perl_vms_do_aexec
+ #define vms_do_exec Perl_vms_do_exec
+ #define my_waitpid Perl_my_waitpid
+ #define my_crypt Perl_my_crypt
+ #define kill_file Perl_kill_file
+ #define my_utime Perl_my_utime
+ #define my_chdir Perl_my_chdir
+ #define do_aspawn Perl_do_aspawn
+ #define seekdir Perl_seekdir
+ #define my_gmtime Perl_my_gmtime
+ #define my_localtime Perl_my_localtime
+ #define my_time Perl_my_time
+ #define do_spawn Perl_do_spawn
+ #define flex_fstat Perl_flex_fstat
+ #define flex_stat Perl_flex_stat
+ #define cando_by_name Perl_cando_by_name
+ #define my_getpwnam Perl_my_getpwnam
+ #define my_getpwuid Perl_my_getpwuid
+ #define my_flush Perl_my_flush
+ #define readdir Perl_readdir
#else
+ #define my_getenv_len(a,b,c) Perl_my_getenv_len(aTHX_ a,b,c)
+ #define vmssetenv(a,b,c) Perl_vmssetenv(aTHX_ a,b,c)
#define my_trnlnm(a,b,c) Perl_my_trnlnm(aTHX_ a,b,c)
#define my_setenv(a,b) Perl_my_setenv(aTHX_ a,b)
#define my_getenv(a,b) Perl_my_getenv(aTHX_ a,b)
#define tounixspec(a,b) Perl_tounixspec(aTHX_ a,b)
***************
*** 133,156 ****
#define trim_unixpath(a,b,c) Perl_trim_unixpath(aTHX_ a,b,c)
#define opendir(a) Perl_opendir(aTHX_ a)
#define rmscopy(a,b,c) Perl_rmscopy(aTHX_ a,b,c)
#endif
- #define my_crypt Perl_my_crypt
- #define my_waitpid Perl_my_waitpid
#define my_gconvert Perl_my_gconvert
- #define kill_file Perl_kill_file
- #define my_mkdir Perl_my_mkdir
- #define my_chdir Perl_my_chdir
- #define my_tmpfile Perl_my_tmpfile
- #define my_utime Perl_my_utime
- #define vms_image_init Perl_vms_image_init
- #define readdir Perl_readdir
#define telldir Perl_telldir
- #define seekdir Perl_seekdir
#define closedir Perl_closedir
#define vmsreaddirversions Perl_vmsreaddirversions
- #define my_gmtime Perl_my_gmtime
- #define my_localtime Perl_my_localtime
- #define my_time Perl_my_time
#define my_sigemptyset Perl_my_sigemptyset
#define my_sigfillset Perl_my_sigfillset
#define my_sigaddset Perl_my_sigaddset
--- 170,201 ----
#define trim_unixpath(a,b,c) Perl_trim_unixpath(aTHX_ a,b,c)
#define opendir(a) Perl_opendir(aTHX_ a)
#define rmscopy(a,b,c) Perl_rmscopy(aTHX_ a,b,c)
+ #define my_mkdir(a,b) Perl_my_mkdir(aTHX_ a,b)
+ #define vms_do_aexec(a,b,c) Perl_vms_do_aexec(aTHX_ a,b,c)
+ #define vms_do_exec(a) Perl_vms_do_exec(aTHX_ a)
+ #define my_waitpid(a,b,c) Perl_my_waitpid(aTHX_ a,b,c)
+ #define my_crypt(a,b) Perl_my_crypt(aTHX_ a,b)
+ #define kill_file(a) Perl_kill_file(aTHX_ a)
+ #define my_utime(a,b) Perl_my_utime(aTHX_ a,b)
+ #define my_chdir(a) Perl_my_chdir(aTHX_ a)
+ #define do_aspawn(a,b,c) Perl_do_aspawn(aTHX_ a,b,c)
+ #define seekdir(a,b) Perl_seekdir(aTHX_ a,b)
+ #define my_gmtime(a) Perl_my_gmtime(aTHX_ a)
+ #define my_localtime(a) Perl_my_localtime(aTHX_ a)
+ #define my_time(a) Perl_my_time(aTHX_ a)
+ #define do_spawn(a) Perl_do_spawn(aTHX_ a)
+ #define flex_fstat(a,b) Perl_flex_fstat(aTHX_ a,b)
+ #define cando_by_name(a,b,c) Perl_cando_by_name(aTHX_ a,b,c)
+ #define flex_stat(a,b) Perl_flex_stat(aTHX_ a,b)
+ #define my_getpwnam(a) Perl_my_getpwnam(aTHX_ a)
+ #define my_getpwuid(a) Perl_my_getpwuid(aTHX_ a)
+ #define my_flush(a) Perl_my_flush(aTHX_ a)
+ #define readdir(a) Perl_readdir(aTHX_ a)
#endif
#define my_gconvert Perl_my_gconvert
#define telldir Perl_telldir
#define closedir Perl_closedir
#define vmsreaddirversions Perl_vmsreaddirversions
#define my_sigemptyset Perl_my_sigemptyset
#define my_sigfillset Perl_my_sigfillset
#define my_sigaddset Perl_my_sigaddset
***************
*** 157,176 ****
#define my_sigdelset Perl_my_sigdelset
#define my_sigismember Perl_my_sigismember
#define my_sigprocmask Perl_my_sigprocmask
- #define cando_by_name Perl_cando_by_name
- #define flex_fstat Perl_flex_fstat
- #define flex_stat Perl_flex_stat
#define my_vfork Perl_my_vfork
- #define vms_do_aexec Perl_vms_do_aexec
- #define vms_do_exec Perl_vms_do_exec
- #define do_aspawn Perl_do_aspawn
- #define do_spawn Perl_do_spawn
#define my_fdopen Perl_my_fdopen
#define my_fclose Perl_my_fclose
#define my_fwrite Perl_my_fwrite
- #define my_flush Perl_my_flush
- #define my_getpwnam Perl_my_getpwnam
- #define my_getpwuid Perl_my_getpwuid
#define my_getpwent Perl_my_getpwent
#define my_endpwent Perl_my_endpwent
#define my_getlogin Perl_my_getlogin
--- 202,211 ----
***************
*** 197,203 ****
* from a specific directory to permit creation of files).
*/
#ifndef DONT_MASK_RTL_CALLS
! # define tmpfile my_tmpfile
#endif
--- 232,238 ----
* from a specific directory to permit creation of files).
*/
#ifndef DONT_MASK_RTL_CALLS
! # define tmpfile Perl_my_tmpfile
#endif
***************
*** 275,281 ****
#define _ckvmssts_noperl(call) STMT_START { register unsigned long int __ckvms_sts; \
if (!((__ckvms_sts=(call))&1)) { \
set_errno(EVMSERR); set_vaxc_errno(__ckvms_sts); \
! fprintf(Perl_debug_log,"Fatal VMS error (status=%d) at %s, line %d", \
__ckvms_sts,__FILE__,__LINE__); lib$signal(__ckvms_sts); } } STMT_END
#ifdef VMS_DO_SOCKETS
--- 310,316 ----
#define _ckvmssts_noperl(call) STMT_START { register unsigned long int __ckvms_sts; \
if (!((__ckvms_sts=(call))&1)) { \
set_errno(EVMSERR); set_vaxc_errno(__ckvms_sts); \
! fprintf(stderr,"Fatal VMS error (status=%d) at %s, line %d", \
__ckvms_sts,__FILE__,__LINE__); lib$signal(__ckvms_sts); } } STMT_END
#ifdef VMS_DO_SOCKETS
***************
*** 376,381 ****
--- 411,417 ----
#ifndef DONT_MASK_RTL_CALLS
+ # define fwrite my_fwrite /* for PerlSIO_fwrite */
# define fdopen my_fdopen
# define fclose my_fclose
#endif
***************
*** 456,461 ****
--- 492,505 ----
# define sa_mask sv_mask
# define sigsuspend(set) sigpause(*set)
# define sigpending(a) (not_here("sigpending"),0)
+ #else
+ /*
+ * The C RTL's sigaction fails to check for invalid signal numbers so we
+ * help it out a bit.
+ */
+ # ifndef DONT_MASK_RTL_CALLS
+ # define sigaction(a,b,c) Perl_my_sigaction(a,b,c)
+ # endif
#endif
/* VMS doesn't use a real sys_nerr, but we need this when scanning for error
***************
*** 466,472 ****
/* Look up new %ENV values on the fly */
#define DYNAMIC_ENV_FETCH 1
- #define ENV_HV_NAME "%EnV%VmS%"
/* Special getenv function for retrieving %ENV elements. */
#define ENVgetenv(v) my_getenv(v,FALSE)
#define ENVgetenv_len(v,l) my_getenv_len(v,l,FALSE)
--- 510,515 ----
***************
*** 476,490 ****
#define getlogin my_getlogin
/* Ditto for sys$hash_password() . . . */
! #define crypt my_crypt
/* Tweak arg to mkdir & chdir first, so we can tolerate trailing /. */
! #define Mkdir(dir,mode) my_mkdir((dir),(mode))
#define Chdir(dir) my_chdir((dir))
/* Use our own stat() clones, which handle Unix-style directory names */
#define Stat(name,bufptr) flex_stat(name,bufptr)
! #define Fstat(fd,bufptr) flex_fstat(fd,bufptr)
/* Setup for the dirent routines:
* opendir(), closedir(), readdir(), seekdir(), telldir(), and
--- 519,533 ----
#define getlogin my_getlogin
/* Ditto for sys$hash_password() . . . */
! #define crypt(a,b) Perl_my_crypt(aTHX_ a,b)
/* Tweak arg to mkdir & chdir first, so we can tolerate trailing /. */
! #define Mkdir(dir,mode) Perl_my_mkdir(aTHX_ (dir),(mode))
#define Chdir(dir) my_chdir((dir))
/* Use our own stat() clones, which handle Unix-style directory names */
#define Stat(name,bufptr) flex_stat(name,bufptr)
! #define Fstat(fd,bufptr) Perl_flex_fstat(aTHX_ fd,bufptr)
/* Setup for the dirent routines:
* opendir(), closedir(), readdir(), seekdir(), telldir(), and
***************
*** 655,663 ****
void init_os_extras ();
/* prototype section start marker; `typedef' passes through cpp */
typedef char __VMS_PROTOTYPES__;
#if !defined(PERL_IMPLICIT_CONTEXT)
char * Perl_my_getenv (const char *, bool);
- int Perl_vmstrnenv (const char *, char *, unsigned long int, struct dsc$descriptor_s **, unsigned long int);
int Perl_my_trnlnm (const char *, char *, unsigned long int);
char * Perl_tounixspec (char *, char *);
char * Perl_tounixspec_ts (char *, char *);
--- 698,706 ----
void init_os_extras ();
/* prototype section start marker; `typedef' passes through cpp */
typedef char __VMS_PROTOTYPES__;
+ int Perl_vmstrnenv (const char *, char *, unsigned long int, struct dsc$descriptor_s **, unsigned long int);
#if !defined(PERL_IMPLICIT_CONTEXT)
char * Perl_my_getenv (const char *, bool);
int Perl_my_trnlnm (const char *, char *, unsigned long int);
char * Perl_tounixspec (char *, char *);
char * Perl_tounixspec_ts (char *, char *);
***************
*** 677,684 ****
int Perl_trim_unixpath (char *, char*, int);
DIR * Perl_opendir (char *);
int Perl_rmscopy (char *, char *, int);
#else
- int Perl_vmstrnenv (pTHX_ const char *, char *, unsigned long int, struct dsc$descriptor_s **, unsigned long int);
char * Perl_my_getenv (pTHX_ const char *, bool);
int Perl_my_trnlnm (pTHX_ const char *, char *, unsigned long int);
char * Perl_tounixspec (pTHX_ char *, char *);
--- 720,728 ----
int Perl_trim_unixpath (char *, char*, int);
DIR * Perl_opendir (char *);
int Perl_rmscopy (char *, char *, int);
+ int Perl_my_mkdir (char *, Mode_t);
+ bool Perl_vms_do_aexec (SV *, SV **, SV **);
#else
char * Perl_my_getenv (pTHX_ const char *, bool);
int Perl_my_trnlnm (pTHX_ const char *, char *, unsigned long int);
char * Perl_tounixspec (pTHX_ char *, char *);
***************
*** 699,725 ****
int Perl_trim_unixpath (pTHX_ char *, char*, int);
DIR * Perl_opendir (pTHX_ char *);
int Perl_rmscopy (pTHX_ char *, char *, int);
#endif
! char * my_getenv_len (const char *, unsigned long *, bool);
! int vmssetenv (char *, char *, struct dsc$descriptor_s **);
! void Perl_vmssetuserlnm(char *name, char *eqv);
! char * my_crypt (const char *, const char *);
! Pid_t my_waitpid (Pid_t, int *, int);
char * my_gconvert (double, int, int, char *);
! int kill_file (char *);
! int my_mkdir (char *, Mode_t);
! int my_chdir (char *);
! FILE * my_tmpfile (void);
! int my_utime (char *, struct utimbuf *);
! void vms_image_init (int *, char ***);
! struct dirent * readdir (DIR *);
long telldir (DIR *);
! void seekdir (DIR *, long);
void closedir (DIR *);
void vmsreaddirversions (DIR *, int);
! struct tm * my_gmtime (const time_t *);
! struct tm * my_localtime (const time_t *);
! time_t my_time (time_t *);
#ifdef HOMEGROWN_POSIX_SIGNALS
int my_sigemptyset (sigset_t *);
int my_sigfillset (sigset_t *);
--- 743,773 ----
int Perl_trim_unixpath (pTHX_ char *, char*, int);
DIR * Perl_opendir (pTHX_ char *);
int Perl_rmscopy (pTHX_ char *, char *, int);
+ int Perl_my_mkdir (pTHX_ char *, Mode_t);
+ bool Perl_vms_do_aexec (pTHX_ SV *, SV **, SV **);
#endif
! char * Perl_my_getenv_len (pTHX_ const char *, unsigned long *, bool);
! int Perl_vmssetenv (pTHX_ char *, char *, struct dsc$descriptor_s **);
! void Perl_vmssetuserlnm(pTHX_ char *name, char *eqv);
! char * Perl_my_crypt (pTHX_ const char *, const char *);
! Pid_t Perl_my_waitpid (pTHX_ Pid_t, int *, int);
char * my_gconvert (double, int, int, char *);
! int Perl_kill_file (pTHX_ char *);
! int Perl_my_chdir (pTHX_ char *);
! FILE * Perl_my_tmpfile ();
! #ifndef HOMEGROWN_POSIX_SIGNALS
! int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);
! #endif
! int Perl_my_utime (pTHX_ char *, struct utimbuf *);
! void Perl_vms_image_init (int *, char ***);
! struct dirent * Perl_readdir (pTHX_ DIR *);
long telldir (DIR *);
! void Perl_seekdir (pTHX_ DIR *, long);
void closedir (DIR *);
void vmsreaddirversions (DIR *, int);
! struct tm * Perl_my_gmtime (pTHX_ const time_t *);
! struct tm * Perl_my_localtime (pTHX_ const time_t *);
! time_t Perl_my_time (pTHX_ time_t *);
#ifdef HOMEGROWN_POSIX_SIGNALS
int my_sigemptyset (sigset_t *);
int my_sigfillset (sigset_t *);
***************
*** 728,748 ****
int my_sigismember (sigset_t *, int);
int my_sigprocmask (int, sigset_t *, sigset_t *);
#endif
! I32 cando_by_name (I32, Uid_t, char *);
! int flex_fstat (int, Stat_t *);
! int flex_stat (const char *, Stat_t *);
int my_vfork ();
! bool vms_do_aexec (SV *, SV **, SV **);
! bool vms_do_exec (char *);
! unsigned long int do_aspawn (void *, void **, void **);
! unsigned long int do_spawn (char *);
FILE * my_fdopen (int, const char *);
int my_fclose (FILE *);
! int my_fwrite (void *, size_t, size_t, FILE *);
! int my_flush (FILE *);
! struct passwd * my_getpwnam (char *name);
! struct passwd * my_getpwuid (Uid_t uid);
! struct passwd * my_getpwent ();
void my_endpwent ();
char * my_getlogin ();
typedef char __VMS_SEPYTOTORP__;
--- 776,794 ----
int my_sigismember (sigset_t *, int);
int my_sigprocmask (int, sigset_t *, sigset_t *);
#endif
! I32 Perl_cando_by_name (pTHX_ I32, Uid_t, char *);
! int Perl_flex_fstat (pTHX_ int, Stat_t *);
! int Perl_flex_stat (pTHX_ const char *, Stat_t *);
int my_vfork ();
! bool Perl_vms_do_exec (pTHX_ char *);
! unsigned long int Perl_do_aspawn (pTHX_ void *, void **, void **);
! unsigned long int Perl_do_spawn (pTHX_ char *);
FILE * my_fdopen (int, const char *);
int my_fclose (FILE *);
! int my_fwrite (const void *, size_t, size_t, FILE *);
! int Perl_my_flush (pTHX_ FILE *);
! struct passwd * Perl_my_getpwnam (pTHX_ char *name);
! struct passwd * Perl_my_getpwuid (pTHX_ Uid_t uid);
void my_endpwent ();
char * my_getlogin ();
typedef char __VMS_SEPYTOTORP__;
diff -c 'perl-5.7.1/vos/Changes' 'perl-5.7.2/vos/Changes'
Index: ./vos/Changes
*** ./vos/Changes Tue Mar 6 04:07:29 2001
--- ./vos/Changes Mon Jul 9 17:11:34 2001
***************
*** 1,6 ****
--- 1,17 ----
This file documents the changes made to port Perl to the Stratus
VOS operating system.
+ For 5.7.1:
+ Updated "build.cm" and "compile_perl.cm" to build perl using
+ either cc or gcc.
+ Brought "config.alpha.def" and "config.ga.def" up-to-date.
+ Updated "configure_perl.cm" to rebuild the header file even if
+ the date of the definitions file is equal to the date of
+ the header, because the perl distribution resets all dates
+ to the same value.
+ Update "Changes".
+ Update "perl.bind".
+
For 5.7:
Updated "build.cm" to build perl using either the alpha or GA
version of POSIX.
diff -c /dev/null 'perl-5.7.2/vos/Makefile'
Index: ./vos/Makefile
*** ./vos/Makefile Thu Jan 1 02:00:00 1970
--- ./vos/Makefile Mon Jul 9 17:11:34 2001
***************
*** 0 ****
--- 1,21 ----
+ #
+ # This Makefile can be used to update the config.alpha.h and
+ # config.ga.h files *in UNIX* (in VOS the configure_perl.cm
+ # is used). Update the config.*.def files appropriately when
+ # you add new symbols to Configure. If you don't know VOS,
+ # most of the time a safe guess for a symbol is 'undef'.
+ #
+
+ all: config.alpha.h config.ga.h
+
+ config.alpha.h: config.alpha.def ../config_h.SH ../mv-if-diff
+ cp config.alpha.def config.def
+ perl config.pl
+ sh ../mv-if-diff config.h.new config.alpha.h
+ rm -f config.def config.h.new
+
+ config.ga.h: config.ga.def ../config_h.SH ../mv-if-diff
+ cp config.ga.def config.def
+ perl config.pl
+ sh ../mv-if-diff config.h.new config.ga.h
+ rm -f config.def config.h.new
diff -c 'perl-5.7.1/vos/build.cm' 'perl-5.7.2/vos/build.cm'
Index: ./vos/build.cm
*** ./vos/build.cm Tue Mar 6 04:07:29 2001
--- ./vos/build.cm Mon Jul 9 17:11:34 2001
***************
*** 4,9 ****
--- 4,10 ----
rebind switch(-rebind),=1
tgt_mod option(-target_module)module_name,='(current_module)'
version option(-version)name,allow(alpha,ga),=ga
+ compiler option(-compiler)name,allow(cc,gcc)=cc
&end_parameters
&echo command_lines
&
***************
*** 46,52 ****
--- 47,61 ----
&then &set_string obj2 .68k
&else &set_string obj2 &obj&
&
+ &if &compiler& = cc
+ &then &do
&set_string cpu -processor &cpu&
+ &set_string s .obj
+ &end
+ &else &do
+ &set_string cpu ''
+ &set_string s .o
+ &end
&
& If requested, compile the source code.
&
***************
*** 66,72 ****
& Suppress several harmless compiler warning and advice messages.
& Use -list -show_include all -show_macros both_ways when debugging.
&
! &set_string cflags '-u -O4 -D_POSIX_C_SOURCE=199506L -DPERL_CORE'
&
& The following is a work-around for stcp-1437,8,9
&
--- 75,83 ----
& Suppress several harmless compiler warning and advice messages.
& Use -list -show_include all -show_macros both_ways when debugging.
&
! &if &compiler& = cc
! &then &set_string cflags '-O4 -D_POSIX_C_SOURCE=199506L -DPERL_CORE -u'
! &else &set_string cflags '-O4 -D_POSIX_C_SOURCE=199506L -DPERL_CORE -c'
&
& The following is a work-around for stcp-1437,8,9
&
***************
*** 73,103 ****
&if &version& = ga
&then &set_string cflags &cflags& -D_BSD_SOURCE
&
! !cc <<av.c -suppress_diag 2006 2064 2065 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<deb.c -suppress_diag 2006 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<doio.c -suppress_diag 2006 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<doop.c -suppress_diag 2006 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<dump.c -suppress_diag 2006 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<ebcdic.c -suppress_diag 2006 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<globals.c -suppress_diag 2006 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<gv.c -suppress_diag 2006 2065 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<hv.c -suppress_diag 2006 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! & !cc <<malloc.c -suppress_diag 2006 &cpu& &cflags&
& &if (command_status) ^= 0 &then &return
! !cc <<mg.c -suppress_diag 2006 2064 2065 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<miniperlmain.c -suppress_diag 2006 2065 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<op.c -suppress_diag 2006 2064 2065 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
&
& We are essentially building miniperl for now. Until we
--- 84,123 ----
&if &version& = ga
&then &set_string cflags &cflags& -D_BSD_SOURCE
&
! &if &compiler& = cc
! &then &set_string diag -suppress_diag 2006 2064 2065
! &else &set_string diag ''
! &
! & The following is a work-around for stcp-1570 and GCC.
! &
! &if &compiler& = gcc
! &then &set_string diag &diag& -w
! &
! !&compiler& <<av.c &diag& &cpu& &cflags& -o av&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<deb.c &diag& &cpu& &cflags& -o deb&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<doio.c &diag& &cpu& &cflags& -o doio&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<doop.c &diag& &cpu& &cflags& -o doop&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<dump.c &diag& &cpu& &cflags& -o dump&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<globals.c &diag& &cpu& &cflags& -o globals&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<gv.c &diag& &cpu& &cflags& -o gv&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<hv.c &diag& &cpu& &cflags& -o hv&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<locale.c &diag& &cpu& &cflags& -o locale&s&
&if (command_status) ^= 0 &then &return
! & !&compiler& <<malloc.c &diag& &cpu& &cflags& -o malloc&s&
& &if (command_status) ^= 0 &then &return
! !&compiler& <<mg.c &diag& &cpu& &cflags& -o mg&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<numeric.c &diag& &cpu& &cflags& -o numeric&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<op.c &diag& &cpu& &cflags& -o op&s&
&if (command_status) ^= 0 &then &return
&
& We are essentially building miniperl for now. Until we
***************
*** 105,167 ****
&
& !link <<op.c opmini.c -delete
& &if (command_status) ^= 0 &then &return
! & !cc opmini.c -suppress_diag 2006 2064 2065 &cpu& &cflags& -DPERL_EXTERNAL_GLOB
& &if (command_status) ^= 0 &then &return
& !unlink opmini.c
& &if (command_status) ^= 0 &then &return
&
! !cc <<perl.c -suppress_diag 2006 2053 2065 &cpu& &cflags& &+
-DARCHLIB="/system/ported/perl/lib/5.7&obj2&" &+
-DARCHLIB_EXP="/system/ported/perl/lib/5.7&obj2&" &+
-DSITEARCH="/system/ported/perl/lib/site/5.7&obj2&" &+
-DSITEARCH_EXP="/system/ported/perl/lib/site/5.7&obj2&"
&if (command_status) ^= 0 &then &return
! !cc <<perlapi.c &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<perlio.c -suppress_diag 2006 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<perly.c -suppress_diag 2006 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
& compiling pp.c for the PA-RISC hits compiler bug pcg-98; avoid it.
& The bug is fixed in VOS 14.1.0 and all later releases.
&if (index (string &cpu&) pa) > 0 & (module_info os_release) < 'VOS Release 14.1.0'
! &then !cc <<pp.c -suppress_diag 2006 2064 2065 &cpu& &cflags& -no_schedule
! &else !cc <<pp.c -suppress_diag 2006 2064 2065 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<pp_ctl.c -suppress_diag 2006 2064 2065 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<pp_hot.c -suppress_diag 2006 2064 2065 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<pp_sys.c -suppress_diag 2006 2064 2065 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<regcomp.c -suppress_diag 2006 2064 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<regexec.c -suppress_diag 2006 2064 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<run.c -suppress_diag 2006 2065 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<scope.c -suppress_diag 2006 2064 2065 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<sv.c -suppress_diag 2006 2065 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<taint.c -suppress_diag 2006 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<toke.c -suppress_diag 2006 2064 2065 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<universal.c -suppress_diag 2006 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<utf8.c -suppress_diag 2065 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<util.c -suppress_diag 2006 2065 &cpu& &cflags&
&if (command_status) ^= 0 &then &return
! !cc <<xsutils.c &cpu& &cflags&
&if (command_status) ^= 0 &then &return
&if &version& = alpha
&then &do
! !cc <vos_dummies.c &cpu& -O4
&if (command_status) ^= 0 &then &return
&end
&
& If requested, bind the executable program module.
&
&label CHECK_REBIND
--- 125,202 ----
&
& !link <<op.c opmini.c -delete
& &if (command_status) ^= 0 &then &return
! & !&compiler& opmini.c &diag& &cpu& &cflags& -DPERL_EXTERNAL_GLOB -o opmini&s&
& &if (command_status) ^= 0 &then &return
& !unlink opmini.c
& &if (command_status) ^= 0 &then &return
&
! !&compiler& <<perl.c &diag& &cpu& &cflags& -o perl&s& &+
-DARCHLIB="/system/ported/perl/lib/5.7&obj2&" &+
-DARCHLIB_EXP="/system/ported/perl/lib/5.7&obj2&" &+
-DSITEARCH="/system/ported/perl/lib/site/5.7&obj2&" &+
-DSITEARCH_EXP="/system/ported/perl/lib/site/5.7&obj2&"
&if (command_status) ^= 0 &then &return
! !&compiler& <<perlapi.c &diag& &cpu& &cflags& -o perlapi&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<perlio.c &diag& &cpu& &cflags& -o perlio&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<perly.c &diag& &cpu& &cflags& -o perly&s&
&if (command_status) ^= 0 &then &return
& compiling pp.c for the PA-RISC hits compiler bug pcg-98; avoid it.
& The bug is fixed in VOS 14.1.0 and all later releases.
&if (index (string &cpu&) pa) > 0 & (module_info os_release) < 'VOS Release 14.1.0'
! &then !&compiler& <<pp.c &diag& &cpu& &cflags& -no_schedule -o pp&s&
! &else !&compiler& <<pp.c &diag& &cpu& &cflags& -o pp&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<pp_ctl.c &diag& &cpu& &cflags& -o pp_ctl&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<pp_hot.c &diag& &cpu& &cflags& -o pp_hot&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<pp_pack.c &diag& &cpu& &cflags& -o pp_pack&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<pp_sys.c &diag& &cpu& &cflags& -o pp_sys&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<regcomp.c &diag& &cpu& &cflags& -o regcomp&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<regexec.c &diag& &cpu& &cflags& -o regexec&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<run.c &diag& &cpu& &cflags& -o run&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<scope.c &diag& &cpu& &cflags& -o scope&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<sv.c &diag& &cpu& &cflags& -o sv&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<taint.c &diag& &cpu& &cflags& -o taint&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<toke.c &diag& &cpu& &cflags& -o toke&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<universal.c &diag& &cpu& &cflags& -o universal&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<utf8.c &diag& &cpu& &cflags& -o utf8&s&
&if (command_status) ^= 0 &then &return
! !&compiler& <<util.c &diag& &cpu& &cflags& -o util&s&
&if (command_status) ^= 0 &then &return
+ !&compiler& <<xsutils.c &diag& &cpu& &cflags& -o xsutils&s&
+ &if (command_status) ^= 0 &then &return
&if &version& = alpha
&then &do
! !&compiler& <vos_dummies.c &cpu& -O4 -o vos_dummies&s&
&if (command_status) ^= 0 &then &return
&end
&
+ &if &compiler& = gcc
+ &then &do
+ !delete_file perl.a
+ !ar rc perl.a av.o deb.o doio.o doop.o dump.o globals.o gv.o hv.o mg.o &+
+ op.o perl.o perlapi.o perlio.o perly.o pp.o pp_ctl.o pp_hot.o pp_sys.o &+
+ regcomp.o regexec.o run.o scope.o sv.o taint.o toke.o universal.o utf8.o &+
+ util.o xsutils.o
+ &end
+ &else &do
+ !&compiler& <<miniperlmain.c &diag& &cpu& &cflags& -o miniperlmain&s&
+ &if (command_status) ^= 0 &then &return
+ &end
+ &
& If requested, bind the executable program module.
&
&label CHECK_REBIND
***************
*** 201,211 ****
&posix_objlib&>bsd &+
&posix_objlib& &+
&c_objlib& &objlib&
! &if &version& = alpha
! &then !bind -control <perl.bind vos_dummies &+
&tcp_objlib&>tcp_runtime &tcp_objlib&>tcp_gethost &+
&cpu& -target_module &tgt_mod& -map
! &else !bind -control <perl.bind &cpu& -target_module &tgt_mod& -map
! &if (command_status) ^= 0 &then &return
! !delete_file *.obj -no_ask -brief
! !unlink *.obj -no_ask -brief
--- 236,255 ----
&posix_objlib&>bsd &+
&posix_objlib& &+
&c_objlib& &objlib&
! &if &compiler& = gcc
! &then &do
! &set_string cflags (before &$cflags& -c)
! !&compiler& <<miniperlmain.c perl.a &diag& &cpu& &cflags& -o perl.pm
! &if (command_status) ^= 0 &then &return
! !delete_file perl.a
! &end
! &else &do
! &if &version& = alpha
! &then !bind -control <perl.bind vos_dummies &+
&tcp_objlib&>tcp_runtime &tcp_objlib&>tcp_gethost &+
&cpu& -target_module &tgt_mod& -map
! &else !bind -control <perl.bind &cpu& -target_module &tgt_mod& -map
! &if (command_status) ^= 0 &then &return
! &end
! !delete_file *&s& -no_ask -brief
! !unlink *&s& -no_ask -brief
diff -c 'perl-5.7.1/vos/compile_perl.cm' 'perl-5.7.2/vos/compile_perl.cm'
Index: ./vos/compile_perl.cm
*** ./vos/compile_perl.cm Tue Mar 6 04:07:30 2001
--- ./vos/compile_perl.cm Mon Jul 9 17:11:34 2001
***************
*** 12,17 ****
--- 12,18 ----
module option(-module)module_name,='(current_module)'
tgt_mod option(-target_module)module_name,='(current_module)'
version option(-version)name,allow(alpha,ga),=ga
+ compiler option(-compiler)name,allow(cc,gcc)=cc
&end_parameters
&echo command_lines
&
***************
*** 32,37 ****
--- 33,43 ----
&if &cpu& = pa8000
&then &set_string obj .8000
&
+ &if &compiler& = gcc & &version& = alpha
+ &then &do
+ &display_line GCC is not supported by the alpha version of POSIX support.
+ &return e$translation_failed
+ &end
&if ^ (exists obj&obj& -directory)
&then !create_dir obj&obj&
&
***************
*** 42,46 ****
&
!change_current_dir obj&obj&
!start_process (string <build -processor &cpu& &recompile& &rebind& &+
! -target_module &tgt_mod& -version &version&) -module &module&
!change_current_dir <
--- 48,53 ----
&
!change_current_dir obj&obj&
!start_process (string <build -processor &cpu& &recompile& &rebind& &+
! -target_module &tgt_mod& -version &version& -compiler &compiler&) &+
! -module &module&
!change_current_dir <
diff -c 'perl-5.7.1/vos/config.alpha.def' 'perl-5.7.2/vos/config.alpha.def'
Index: ./vos/config.alpha.def
*** ./vos/config.alpha.def Thu Apr 5 20:37:02 2001
--- ./vos/config.alpha.def Fri Jul 13 03:17:02 2001
***************
*** 8,14 ****
$byteorder='4321'
$castflags='0'
$cf_by='Paul_Green@stratus.com'
! $cf_time='2000-10-23 18:48 UCT'
$CONFIG_SH='config.sh'
$cpp_stuff='42'
$cpplast='-'
--- 8,14 ----
$byteorder='4321'
$castflags='0'
$cf_by='Paul_Green@stratus.com'
! $cf_time='2001-06-11 02:41 UCT'
$CONFIG_SH='config.sh'
$cpp_stuff='42'
$cpplast='-'
***************
*** 15,21 ****
$cppminus='-'
$cpprun='cc -E -'
$cppstdin='cc -E'
! $crosscompile='undef'
$d__fwalk='undef'
$d_access='undef'
$d_accessx='undef'
--- 15,25 ----
$cppminus='-'
$cpprun='cc -E -'
$cppstdin='cc -E'
! $d_Gconvert='sprintf((b),"%.*g",(n),(x))'
! $d_PRIeldbl='define'
! $d_PRIfldbl='define'
! $d_PRIgldbl='define'
! $d_SCNfldbl='define'
$d__fwalk='undef'
$d_access='undef'
$d_accessx='undef'
***************
*** 42,47 ****
--- 46,52 ----
$d_csh='undef'
$d_cuserid='undef'
$d_dbl_dig='define'
+ $d_dbminitproto='undef'
$d_difftime='define'
$d_dirnamlen='undef'
$d_dlerror='undef'
***************
*** 57,62 ****
--- 62,68 ----
$d_endpwent='undef'
$d_endsent='define'
$d_eofnblk='define'
+ $d_fchdir='undef'
$d_fchmod='define'
$d_fchown='undef'
$d_fcntl='define'
***************
*** 65,70 ****
--- 71,77 ----
$d_fgetpos='define'
$d_flexfnam='define'
$d_flock='undef'
+ $d_flockproto='undef'
$d_fork='undef'
$d_fpathconf='define'
$d_fpos64_t='undef'
***************
*** 76,82 ****
$d_fstatvfs='undef'
$d_fsync='undef'
$d_ftello='undef'
- $d_Gconvert='sprintf((b),"%.*g",(n),(x))'
$d_getcwd='define'
$d_getespwnam='undef'
$d_getfsstat='undef'
--- 83,88 ----
***************
*** 145,156 ****
$d_memset='define'
$d_mkdir='define'
$d_mkdtemp='undef'
$d_mkstemp='undef'
$d_mkstemps='undef'
- $d_mkfifo='define'
$d_mktime='define'
$d_mmap='undef'
$d_modfl='undef'
$d_mprotect='undef'
$d_msg='undef'
$d_msg_ctrunc='undef'
--- 151,163 ----
$d_memset='define'
$d_mkdir='define'
$d_mkdtemp='undef'
+ $d_mkfifo='define'
$d_mkstemp='undef'
$d_mkstemps='undef'
$d_mktime='define'
$d_mmap='undef'
$d_modfl='undef'
+ $d_modfl_pow32_bug='undef'
$d_mprotect='undef'
$d_msg='undef'
$d_msg_ctrunc='undef'
***************
*** 163,168 ****
--- 170,176 ----
$d_munmap='undef'
$d_mymalloc='undef'
$d_nice='undef'
+ $d_nl_langinfo='undef'
$d_nv_preserves_uv='define'
$d_nv_preserves_uv_bits='32'
$d_off64_t='undef'
***************
*** 170,183 ****
$d_oldpthreads='undef'
$d_open3='define'
$d_pathconf='define'
- $d_perl_otherlibdirs='undef'
$d_pause='define'
$d_phostname='undef'
$d_pipe='define'
$d_poll='define'
! $d_PRIeldbl='define'
! $d_PRIfldbl='define'
! $d_PRIgldbl='define'
$d_pthread_yield='undef'
$d_pwage='undef'
$d_pwchange='undef'
--- 178,189 ----
$d_oldpthreads='undef'
$d_open3='define'
$d_pathconf='define'
$d_pause='define'
+ $d_perl_otherlibdirs='undef'
$d_phostname='undef'
$d_pipe='define'
$d_poll='define'
! $d_pthread_atfork='undef'
$d_pthread_yield='undef'
$d_pwage='undef'
$d_pwchange='undef'
***************
*** 201,207 ****
$d_sbrkproto='undef'
$d_sched_yield='undef'
$d_scm_rights='undef'
- $d_SCNfldbl='define'
$d_seekdir='undef'
$d_select='define'
$d_sem='undef'
--- 207,212 ----
***************
*** 213,218 ****
--- 218,224 ----
$d_setgrent='undef'
$d_setgrps='undef'
$d_sethent='define'
+ $d_setitimer='undef'
$d_setlinebuf='undef'
$d_setlocale='define'
$d_setnent='define'
***************
*** 239,255 ****
$d_sigprocmask='undef'
$d_sigsetjmp='undef'
$d_sockatmark='undef'
$d_socket='define'
$d_sockpair='undef'
$d_socks5_init='undef'
$d_sqrtl='undef'
$d_statblks='undef'
$d_statfs_f_flags='undef'
$d_statfs_s='undef'
$d_stdio_cnt_lval='define'
$d_stdio_ptr_lval='define'
- $d_stdio_ptr_lval_sets_cnt='undef'
$d_stdio_ptr_lval_nochange_cnt='undef'
$d_stdio_stream_array='define'
$d_stdiobase='define'
$d_stdstdio='define'
--- 245,264 ----
$d_sigprocmask='undef'
$d_sigsetjmp='undef'
$d_sockatmark='undef'
+ $d_sockatmarkproto='undef'
$d_socket='define'
$d_sockpair='undef'
$d_socks5_init='undef'
$d_sqrtl='undef'
+ $d_sresgproto='undef'
+ $d_sresuproto='undef'
$d_statblks='undef'
$d_statfs_f_flags='undef'
$d_statfs_s='undef'
$d_stdio_cnt_lval='define'
$d_stdio_ptr_lval='define'
$d_stdio_ptr_lval_nochange_cnt='undef'
+ $d_stdio_ptr_lval_sets_cnt='undef'
$d_stdio_stream_array='define'
$d_stdiobase='define'
$d_stdstdio='define'
***************
*** 258,263 ****
--- 267,273 ----
$d_strctcpy='define'
$d_strerrm='strerror(e)'
$d_strerror='define'
+ $d_strftime='define'
$d_strtod='define'
$d_strtol='define'
$d_strtold='undef'
***************
*** 270,275 ****
--- 280,286 ----
$d_suidsafe='define'
$d_symlink='define'
$d_syscall='undef'
+ $d_syscallproto='undef'
$d_sysconf='define'
$d_syserrlst='define'
$d_system='define'
***************
*** 286,291 ****
--- 297,303 ----
$d_uname='define'
$d_union_semun='undef'
$d_usleep='undef'
+ $d_usleepproto='undef'
$d_ustat='undef'
$d_vendorarch='define'
$d_vendorlib='define'
***************
*** 300,305 ****
--- 312,320 ----
$d_writev='undef'
$db_hashtype='int'
$db_prefixtype='int'
+ $db_version_major='undef'
+ $db_version_minor='undef'
+ $db_version_patch='undef'
$defvoidused='15'
$direntrytype='struct dirent'
$doublesize='8'
***************
*** 335,340 ****
--- 350,356 ----
$i_iconv='undef'
$i_ieeefp='undef'
$i_inttypes='undef'
+ $i_langinfo='undef'
$i_libutil='undef'
$i_limits='define'
$i_locale='define'
***************
*** 425,430 ****
--- 441,447 ----
$o_nonblock='O_NONBLOCK'
$old_pthread_create_joinable=''
$osname='VOS'
+ $osvers='VOS'
$otherlibdirs=''
$package='perl5'
$pidtype='pid_t'
***************
*** 470,475 ****
--- 487,493 ----
$stdio_cnt='((fp)->_cnt)'
$stdio_ptr='((fp)->_ptr)'
$stdio_stream_array='_iob'
+ $targetarch='undef'
$timetype='time_t'
$u16size='2'
$u16type='unsigned short'
***************
*** 488,493 ****
--- 506,512 ----
$use5005threads='undef'
$use64bitall='undef'
$use64bitint='undef'
+ $usecrosscompile='undef'
$usedl='undef'
$useithreads='undef'
$uselargefiles='undef'
***************
*** 495,500 ****
--- 514,520 ----
$usemorebits='undef'
$usemultiplicity='undef'
$useperlio='undef'
+ $usereentrant='undef'
$usesocks='undef'
$uvoformat='"o"'
$uvsize='4'
diff -c 'perl-5.7.1/vos/config.alpha.h' 'perl-5.7.2/vos/config.alpha.h'
Index: ./vos/config.alpha.h
Prereq: 3.0.1.5
*** ./vos/config.alpha.h Thu Apr 5 19:20:01 2001
--- ./vos/config.alpha.h Fri Jul 13 03:17:16 2001
***************
*** 13,19 ****
/*
* Package name : perl5
* Source directory : /vos_ftp_site/pub/vos/posix/(alpha|ga)/perl
! * Configuration time: 2000-10-23 18:48 UCT
* Configured by : Paul_Green@stratus.com
* Target system : VOS
*/
--- 13,19 ----
/*
* Package name : perl5
* Source directory : /vos_ftp_site/pub/vos/posix/(alpha|ga)/perl
! * Configuration time: 2001-06-11 02:41 UCT
* Configured by : Paul_Green@stratus.com
* Target system : VOS
*/
***************
*** 121,146 ****
*/
/*#define HAS_DLERROR /**/
- /* SETUID_SCRIPTS_ARE_SECURE_NOW:
- * This symbol, if defined, indicates that the bug that prevents
- * setuid scripts from being secure is not present in this kernel.
- */
- /* DOSUID:
- * This symbol, if defined, indicates that the C program should
- * check the script that it is executing for setuid/setgid bits, and
- * attempt to emulate setuid/setgid on systems that have disabled
- * setuid #! scripts because the kernel can't do it securely.
- * It is up to the package designer to make sure that this emulation
- * is done securely. Among other things, it should do an fstat on
- * the script it just opened to make sure it really is a setuid/setgid
- * script, it should make sure the arguments passed correspond exactly
- * to the argument on the #! line, and it should not trust any
- * subprocesses to which it must pass the filename rather than the
- * file descriptor of the script to be executed.
- */
- #define SETUID_SCRIPTS_ARE_SECURE_NOW /**/
- /*#define DOSUID /**/
-
/* HAS_DUP2:
* This symbol, if defined, indicates that the dup2 routine is
* available to duplicate file descriptors.
--- 121,126 ----
***************
*** 165,183 ****
*/
#define HAS_FCNTL /**/
- /* HAS__FWALK:
- * This symbol, if defined, indicates that the _fwalk system call is
- * available to apply a function to all the file handles.
- */
- /*#define HAS__FWALK / **/
-
- /* FCNTL_CAN_LOCK:
- * This symbol, if defined, indicates that fcntl() can be used
- * for file locking. Normally on Unix systems this is defined.
- * It may be undefined on VMS.
- */
- #define FCNTL_CAN_LOCK /**/
-
/* HAS_FGETPOS:
* This symbol, if defined, indicates that the fgetpos routine is
* available to get the file position indicator, similar to ftell().
--- 145,150 ----
***************
*** 226,238 ****
*/
#define HAS_GETLOGIN /**/
- /* HAS_GETPAGESIZE:
- * This symbol, if defined, indicates that the getpagesize system call
- * is available to get system page size, which is the granularity of
- * many memory management calls.
- */
- /*#define HAS_GETPAGESIZE /**/
-
/* HAS_GETPGID:
* This symbol, if defined, indicates to the C program that
* the getpgid(pid) function is available to get the
--- 193,198 ----
***************
*** 442,460 ****
*/
#define HAS_READLINK /**/
- /* HAS_READV:
- * This symbol, if defined, indicates that the readv routine is
- * available to do gather reads. You will also need <sys/uio.h>
- * and there I_SYSUIO.
- */
- /*#define HAS_READV /**/
-
- /* HAS_RECVMSG:
- * This symbol, if defined, indicates that the recvmsg routine is
- * available to send structured socket messages.
- */
- /*#define HAS_RECVMSG /**/
-
/* HAS_RENAME:
* This symbol, if defined, indicates that the rename routine is available
* to rename files. Otherwise you should do the unlink(), link(), unlink()
--- 402,407 ----
***************
*** 614,625 ****
*/
#define HAS_STRTOL /**/
- /* HAS_STRTOUL:
- * This symbol, if defined, indicates that the strtoul routine is
- * available to provide conversion of strings to unsigned long.
- */
- #define HAS_STRTOUL /**/
-
/* HAS_STRXFRM:
* This symbol, if defined, indicates that the strxfrm() routine is
* available to transform strings.
--- 561,566 ----
***************
*** 856,862 ****
--- 797,808 ----
* This symbol, if defined, indicates that <sys/ioctl.h> exists and should
* be included. Otherwise, include <sgtty.h> or <termio.h>.
*/
+ /* I_SYS_SOCKIO:
+ * This symbol, if defined, indicates the <sys/sockio.h> should be included
+ * to get socket ioctl options, like SIOCATMARK.
+ */
#define I_SYS_IOCTL /**/
+ /*#define I_SYS_SOCKIO /**/
/* I_SYS_NDIR:
* This symbol, if defined, indicates to the C program that it should
***************
*** 952,968 ****
*/
#define I_VALUES /**/
- /* I_STDARG:
- * This symbol, if defined, indicates that <stdarg.h> exists and should
- * be included.
- */
- /* I_VARARGS:
- * This symbol, if defined, indicates to the C program that it should
- * include <varargs.h>.
- */
- #define I_STDARG /**/
- /*#define I_VARARGS /**/
-
/* I_VFORK:
* This symbol, if defined, indicates to the C program that it should
* include vfork.h.
--- 898,903 ----
***************
*** 996,1013 ****
*/
#define SH_PATH "/bin/sh" /**/
- /* STDCHAR:
- * This symbol is defined to be the type of char used in stdio.h.
- * It has the values "unsigned char" or "char".
- */
- #define STDCHAR unsigned char /**/
-
- /* CROSSCOMPILE:
- * This symbol, if defined, signifies that we our
- * build process is a cross-compilation.
- */
- /*#define CROSSCOMPILE /**/
-
/* INTSIZE:
* This symbol contains the value of sizeof(int) so that the C
* preprocessor can make decisions based on it.
--- 931,936 ----
***************
*** 1078,1084 ****
--- 1001,1013 ----
* by Configure. You shouldn't rely on it too much; the specific
* feature tests from Configure are generally more reliable.
*/
+ /* OSVERS:
+ * This symbol contains the version of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
+ */
#define OSNAME "VOS" /**/
+ #define OSVERS "VOS" /**/
/* MEM_ALIGNBYTES:
* This symbol contains the number of bytes required to align a
***************
*** 1085,1091 ****
* double, or a long double when applicable. Usual values are 2,
* 4 and 8. The default is eight, for safety.
*/
! #if defined(CROSSCOMPILE) || defined(MULTIARCH)
# define MEM_ALIGNBYTES 8
#else
#define MEM_ALIGNBYTES 8
--- 1014,1020 ----
* double, or a long double when applicable. Usual values are 2,
* 4 and 8. The default is eight, for safety.
*/
! #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
# define MEM_ALIGNBYTES 8
#else
#define MEM_ALIGNBYTES 8
***************
*** 1162,1168 ****
* so the default case (for NeXT) is big endian to catch them.
* This might matter for NeXT 3.0.
*/
! #if defined(CROSSCOMPILE) || defined(MULTIARCH)
# ifdef __LITTLE_ENDIAN__
# if LONGSIZE == 4
# define BYTEORDER 0x1234
--- 1091,1097 ----
* so the default case (for NeXT) is big endian to catch them.
* This might matter for NeXT 3.0.
*/
! #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
# ifdef __LITTLE_ENDIAN__
# if LONGSIZE == 4
# define BYTEORDER 0x1234
***************
*** 1243,1248 ****
--- 1172,1183 ----
#define CPPRUN "cc -E -"
#define CPPLAST "-"
+ /* HAS__FWALK:
+ * This symbol, if defined, indicates that the _fwalk system call is
+ * available to apply a function to all the file handles.
+ */
+ /*#define HAS__FWALK /**/
+
/* HAS_ACCESS:
* This manifest constant lets the C program know that the access()
* system call is available to check for accessibility using real UID/GID.
***************
*** 1281,1287 ****
* This symbol, if defined, indicates that the struct cmsghdr
* is supported.
*/
! /*#define HAS_STRUCT_CMSGHDR / **/
/* HAS_CSH:
* This symbol, if defined, indicates that the C-shell exists.
--- 1216,1222 ----
* This symbol, if defined, indicates that the struct cmsghdr
* is supported.
*/
! /*#define HAS_STRUCT_CMSGHDR /**/
/* HAS_CSH:
* This symbol, if defined, indicates that the C-shell exists.
***************
*** 1346,1351 ****
--- 1281,1299 ----
*/
#define HAS_ENDSERVENT /**/
+ /* HAS_FCHDIR:
+ * This symbol, if defined, indicates that the fchdir routine is
+ * available to change directory using a file descriptor.
+ */
+ /*#define HAS_FCHDIR /**/
+
+ /* FCNTL_CAN_LOCK:
+ * This symbol, if defined, indicates that fcntl() can be used
+ * for file locking. Normally on Unix systems this is defined.
+ * It may be undefined on VMS.
+ */
+ #define FCNTL_CAN_LOCK /**/
+
/* HAS_FD_SET:
* This symbol, when defined, indicates presence of the fd_set typedef
* in <sys/types.h>
***************
*** 1541,1546 ****
--- 1489,1501 ----
*/
#define HAS_GETNET_PROTOS /**/
+ /* HAS_GETPAGESIZE:
+ * This symbol, if defined, indicates that the getpagesize system call
+ * is available to get system page size, which is the granularity of
+ * many memory management calls.
+ */
+ /*#define HAS_GETPAGESIZE /**/
+
/* HAS_GETPROTOENT:
* This symbol, if defined, indicates that the getprotoent() routine is
* available to look up protocols in some data base or another.
***************
*** 1547,1552 ****
--- 1502,1518 ----
*/
#define HAS_GETPROTOENT /**/
+ /* HAS_GETPGRP:
+ * This symbol, if defined, indicates that the getpgrp routine is
+ * available to get the current process group.
+ */
+ /* USE_BSD_GETPGRP:
+ * This symbol, if defined, indicates that getpgrp needs one
+ * arguments whereas USG one needs none.
+ */
+ #define HAS_GETPGRP /**/
+ /*#define USE_BSD_GETPGRP /**/
+
/* HAS_GETPROTOBYNAME:
* This symbol, if defined, indicates that the getprotobyname()
* routine is available to look up protocols by their name.
***************
*** 1779,1785 ****
--- 1745,1759 ----
* available to split a long double x into a fractional part f and
* an integer part i such that |f| < 1.0 and (f + i) = x.
*/
+ /* HAS_MODFL_POW32_BUG:
+ * This symbol, if defined, indicates that the modfl routine is
+ * broken for long doubles >= pow(2, 32).
+ * For example from 4294967303.150000 one would get 4294967302.000000
+ * and 1.150000. The bug has been seen in certain versions of glibc,
+ * release 2.2.2 is known to be okay.
+ */
/*#define HAS_MODFL /**/
+ /*#define HAS_MODFL_POW32_BUG /**/
/* HAS_MPROTECT:
* This symbol, if defined, indicates that the mprotect system call is
***************
*** 1797,1803 ****
* This symbol, if defined, indicates that the struct msghdr
* is supported.
*/
! /*#define HAS_STRUCT_MSGHDR / **/
/* HAS_OFF64_T:
* This symbol will be defined if the C compiler supports off64_t.
--- 1771,1777 ----
* This symbol, if defined, indicates that the struct msghdr
* is supported.
*/
! /*#define HAS_STRUCT_MSGHDR /**/
/* HAS_OFF64_T:
* This symbol will be defined if the C compiler supports off64_t.
***************
*** 1839,1847 ****
#define SCHED_YIELD /**/
/*#define HAS_SCHED_YIELD /**/
/* HAS_SAFE_BCOPY:
* This symbol, if defined, indicates that the bcopy routine is available
! * to copy potentially overlapping memory blocks. Otherwise you should
* probably use memmove() or memcpy(). If neither is defined, roll your
* own version.
*/
--- 1813,1834 ----
#define SCHED_YIELD /**/
/*#define HAS_SCHED_YIELD /**/
+ /* HAS_READV:
+ * This symbol, if defined, indicates that the readv routine is
+ * available to do gather reads. You will also need <sys/uio.h>
+ * and there I_SYSUIO.
+ */
+ /*#define HAS_READV /**/
+
+ /* HAS_RECVMSG:
+ * This symbol, if defined, indicates that the recvmsg routine is
+ * available to send structured socket messages.
+ */
+ /*#define HAS_RECVMSG /**/
+
/* HAS_SAFE_BCOPY:
* This symbol, if defined, indicates that the bcopy routine is available
! * to copy potentially overlapping memory blocks. Normally, you should
* probably use memmove() or memcpy(). If neither is defined, roll your
* own version.
*/
***************
*** 1849,1857 ****
/* HAS_SAFE_MEMCPY:
* This symbol, if defined, indicates that the memcpy routine is available
! * to copy potentially overlapping memory blocks. Otherwise you should
! * probably use memmove() or memcpy(). If neither is defined, roll your
! * own version.
*/
/*#define HAS_SAFE_MEMCPY /**/
--- 1836,1844 ----
/* HAS_SAFE_MEMCPY:
* This symbol, if defined, indicates that the memcpy routine is available
! * to copy potentially overlapping memory blocks. If you need to
! * copy overlapping memory blocks, you should check HAS_MEMMOVE and
! * use memmove() instead, if available.
*/
/*#define HAS_SAFE_MEMCPY /**/
***************
*** 1869,1875 ****
* extern void* sbrk _((int));
* extern void* sbrk _((size_t));
*/
! /*#define HAS_SBRK_PROTO / **/
/* HAS_SEM:
* This symbol, if defined, indicates that the entire sem*(2) library is
--- 1856,1862 ----
* extern void* sbrk _((int));
* extern void* sbrk _((size_t));
*/
! /*#define HAS_SBRK_PROTO /**/
/* HAS_SEM:
* This symbol, if defined, indicates that the entire sem*(2) library is
***************
*** 1920,1925 ****
--- 1907,1924 ----
*/
#define HAS_SETPROTOENT /**/
+ /* HAS_SETPGRP:
+ * This symbol, if defined, indicates that the setpgrp routine is
+ * available to set the current process group.
+ */
+ /* USE_BSD_SETPGRP:
+ * This symbol, if defined, indicates that setpgrp needs two
+ * arguments whereas USG one needs none. See also HAS_SETPGID
+ * for a POSIX interface.
+ */
+ /*#define HAS_SETPGRP /**/
+ /*#define USE_BSD_SETPGRP /**/
+
/* HAS_SETPROCTITLE:
* This symbol, if defined, indicates that the setproctitle routine is
* available to set process title.
***************
*** 1963,1975 ****
*/
/*#define HAS_SIGACTION /**/
- /* HAS_SIGPROCMASK:
- * This symbol, if defined, indicates that sigprocmask
- * system call is available to examine or change the signal mask
- * of the calling process.
- */
- /*#define HAS_SIGPROCMASK /**/
-
/* HAS_SIGSETJMP:
* This variable indicates to the C program that the sigsetjmp()
* routine is available to save the calling process's registers
--- 1962,1967 ----
***************
*** 2193,2208 ****
/*#define HAS_STRTOLL /**/
/* HAS_STRTOQ:
! * This symbol, if defined, indicates that the strtouq routine is
* available to convert strings to long longs (quads).
*/
/*#define HAS_STRTOQ /**/
! /* HAS_STRTOQ:
! * This symbol, if defined, indicates that the strtouq routine is
! * available to convert strings to long longs (quads).
*/
! /*#define HAS_STRTOQ /**/
/* HAS_STRTOULL:
* This symbol, if defined, indicates that the strtoull routine is
--- 2185,2200 ----
/*#define HAS_STRTOLL /**/
/* HAS_STRTOQ:
! * This symbol, if defined, indicates that the strtoq routine is
* available to convert strings to long longs (quads).
*/
/*#define HAS_STRTOQ /**/
! /* HAS_STRTOUL:
! * This symbol, if defined, indicates that the strtoul routine is
! * available to provide conversion of strings to unsigned long.
*/
! #define HAS_STRTOUL /**/
/* HAS_STRTOULL:
* This symbol, if defined, indicates that the strtoull routine is
***************
*** 2392,2399 ****
--- 2384,2408 ----
* in the <db.h> header file. In older versions of DB, it was
* int, while in newer ones it is size_t.
*/
+ /* DB_VERSION_MAJOR_CFG:
+ * This symbol, if defined, defines the major version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ */
+ /* DB_VERSION_MINOR_CFG:
+ * This symbol, if defined, defines the minor version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
+ /* DB_VERSION_PATCH_CFG:
+ * This symbol, if defined, defines the patch version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
#define DB_Hash_t int /**/
#define DB_Prefix_t int /**/
+ #define DB_VERSION_MAJOR_CFG undef /**/
+ #define DB_VERSION_MINOR_CFG undef /**/
+ #define DB_VERSION_PATCH_CFG undef /**/
/* I_GRP:
* This symbol, if defined, indicates to the C program that it should
***************
*** 2706,2711 ****
--- 2715,2731 ----
#define RD_NODATA -1
#define EOF_NONBLOCK
+ /* NEED_VA_COPY:
+ * This symbol, if defined, indicates that the system stores
+ * the variable argument list datatype, va_list, in a format
+ * that cannot be copied by simple assignment, so that some
+ * other means must be used when copying is required.
+ * As such systems vary in their provision (or non-provision)
+ * of copying mechanisms, handy.h defines a platform-
+ * independent macro, Perl_va_copy(src, dst), to do the job.
+ */
+ /*#define NEED_VA_COPY /**/
+
/* Netdb_host_t:
* This symbol holds the type used for the 1st argument
* to gethostbyaddr().
***************
*** 2857,2864 ****
* as an unsigned hexadecimal integer in lowercase abcdef.
*/
/* UVXf:
! * This symbol defines the format string used for printing a Perl UV
! * as an unsigned hexadecimal integer in uppercase ABCDEF.
*/
/* NVef:
* This symbol defines the format string used for printing a Perl NV
--- 2877,2884 ----
* as an unsigned hexadecimal integer in lowercase abcdef.
*/
/* UVXf:
! * This symbol defines the format string used for printing a Perl UV
! * as an unsigned hexadecimal integer in uppercase ABCDEF.
*/
/* NVef:
* This symbol defines the format string used for printing a Perl NV
***************
*** 2913,2919 ****
* This macro is to be used to generate uniformly distributed
* random numbers over the range [0., 1.[. You may have to supply
* an 'extern double drand48();' in your program since SunOS 4.1.3
! * doesn't provide you with anything relevant in it's headers.
* See HAS_DRAND48_PROTO.
*/
/* Rand_seed_t:
--- 2933,2939 ----
* This macro is to be used to generate uniformly distributed
* random numbers over the range [0., 1.[. You may have to supply
* an 'extern double drand48();' in your program since SunOS 4.1.3
! * doesn't provide you with anything relevant in its headers.
* See HAS_DRAND48_PROTO.
*/
/* Rand_seed_t:
***************
*** 3065,3070 ****
--- 3085,3096 ----
*/
#define STARTPERL "!perl.pm" /**/
+ /* STDCHAR:
+ * This symbol is defined to be the type of char used in stdio.h.
+ * It has the values "unsigned char" or "char".
+ */
+ #define STDCHAR unsigned char /**/
+
/* HAS_STDIO_STREAM_ARRAY:
* This symbol, if defined, tells that there is an array
* holding the stdio streams.
***************
*** 3186,3191 ****
--- 3212,3222 ----
* This symbol, if defined, indicates that Perl should
* be built to use the old draft POSIX threads API.
*/
+ /* USE_REENTRANT_API:
+ * This symbol, if defined, indicates that Perl should
+ * try to use the various _r versions of library functions.
+ * This is extremely experimental.
+ */
/*#define USE_5005THREADS /**/
/*#define USE_ITHREADS /**/
#if defined(USE_5005THREADS) && !defined(USE_ITHREADS)
***************
*** 3192,3197 ****
--- 3223,3229 ----
#define USE_THREADS /* until src is revised*/
#endif
/*#define OLD_PTHREADS_API /**/
+ /*#define USE_REENTRANT_API /**/
/* PERL_VENDORARCH:
* If defined, this symbol contains the name of a private library.
***************
*** 3283,3332 ****
#define PERL_XS_APIVERSION "5.00563"
#define PERL_PM_APIVERSION "5.005"
! /* HAS_GETPGRP:
! * This symbol, if defined, indicates that the getpgrp routine is
! * available to get the current process group.
*/
! /* USE_BSD_GETPGRP:
! * This symbol, if defined, indicates that getpgrp needs one
! * arguments whereas USG one needs none.
*/
! #define HAS_GETPGRP /**/
! /*#define USE_BSD_GETPGRP /**/
! /* HAS_SETPGRP:
! * This symbol, if defined, indicates that the setpgrp routine is
! * available to set the current process group.
*/
! /* USE_BSD_SETPGRP:
! * This symbol, if defined, indicates that setpgrp needs two
! * arguments whereas USG one needs none. See also HAS_SETPGID
! * for a POSIX interface.
*/
! /*#define HAS_SETPGRP /**/
! /*#define USE_BSD_SETPGRP /**/
! /* NEED_VA_COPY:
! * This symbol, if defined, indicates that the system stores
! * the variable argument list datatype, va_list, in a format
! * that cannot be copied by simple assignment, so that some
! * other means must be used when copying is required.
! * As such systems vary in their provision (or non-provision)
! * of copying mechanisms, handy.h defines a platform-
! * independent macro, Perl_va_copy(src, dst), to do the job.
*/
! /*#define NEED_VA_COPY / **/
/* HAS_SOCKATMARK:
* This symbol, if defined, indicates that the sockatmark routine is
* available to test whether a socket is at the out-of-band mark.
*/
! /*#define HAS_SOCKATMARK / **/
/* U32_ALIGNMENT_REQUIRED:
* This symbol, if defined, indicates that you must access
* character data through U32-aligned pointers.
*/
#define U32_ALIGNMENT_REQUIRED /**/
#endif
--- 3315,3462 ----
#define PERL_XS_APIVERSION "5.00563"
#define PERL_PM_APIVERSION "5.005"
! /* SETUID_SCRIPTS_ARE_SECURE_NOW:
! * This symbol, if defined, indicates that the bug that prevents
! * setuid scripts from being secure is not present in this kernel.
*/
! /* DOSUID:
! * This symbol, if defined, indicates that the C program should
! * check the script that it is executing for setuid/setgid bits, and
! * attempt to emulate setuid/setgid on systems that have disabled
! * setuid #! scripts because the kernel can't do it securely.
! * It is up to the package designer to make sure that this emulation
! * is done securely. Among other things, it should do an fstat on
! * the script it just opened to make sure it really is a setuid/setgid
! * script, it should make sure the arguments passed correspond exactly
! * to the argument on the #! line, and it should not trust any
! * subprocesses to which it must pass the filename rather than the
! * file descriptor of the script to be executed.
*/
! #define SETUID_SCRIPTS_ARE_SECURE_NOW /**/
! /*#define DOSUID /**/
! /* I_STDARG:
! * This symbol, if defined, indicates that <stdarg.h> exists and should
! * be included.
*/
! /* I_VARARGS:
! * This symbol, if defined, indicates to the C program that it should
! * include <varargs.h>.
*/
! #define I_STDARG /**/
! /*#define I_VARARGS /**/
! /* USE_CROSS_COMPILE:
! * This symbol, if defined, indicates that Perl is being cross-compiled.
*/
! /* PERL_TARGETARCH:
! * This symbol, if defined, indicates the target architecture
! * Perl has been cross-compiled to. Undefined if not a cross-compile.
! */
! #ifndef USE_CROSS_COMPILE
! /*#define USE_CROSS_COMPILE /**/
! #define PERL_TARGETARCH "undef" /**/
! #endif
+ /* HAS_DBMINIT_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the dbminit() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int dbminit(char *);
+ */
+ /*#define HAS_DBMINIT_PROTO /**/
+
+ /* HAS_FLOCK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the flock() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int flock(int, int);
+ */
+ /*#define HAS_FLOCK_PROTO /**/
+
+ /* HAS_NL_LANGINFO:
+ * This symbol, if defined, indicates that the nl_langinfo routine is
+ * available to return local data. You will also need <langinfo.h>
+ * and therefore I_LANGINFO.
+ */
+ /*#define HAS_NL_LANGINFO /**/
+
+ /* HAS_SIGPROCMASK:
+ * This symbol, if defined, indicates that the sigprocmask
+ * system call is available to examine or change the signal mask
+ * of the calling process.
+ */
+ /*#define HAS_SIGPROCMASK /**/
+
/* HAS_SOCKATMARK:
* This symbol, if defined, indicates that the sockatmark routine is
* available to test whether a socket is at the out-of-band mark.
*/
! /*#define HAS_SOCKATMARK /**/
+ /* HAS_SOCKATMARK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the sockatmark() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int sockatmark _((int));
+ */
+ /*#define HAS_SOCKATMARK_PROTO /**/
+
+ /* HAS_SETRESGID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresgid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+ /*#define HAS_SETRESGID_PROTO /**/
+
+ /* HAS_SETRESUID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresuid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+ /*#define HAS_SETRESUID_PROTO /**/
+
+ /* HAS_STRFTIME:
+ * This symbol, if defined, indicates that the strftime routine is
+ * available to do time formatting.
+ */
+ #define HAS_STRFTIME /**/
+
+ /* HAS_SYSCALL_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the syscall() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int syscall(int, ...);
+ * extern int syscall(long, ...);
+ */
+ /*#define HAS_SYSCALL_PROTO /**/
+
/* U32_ALIGNMENT_REQUIRED:
* This symbol, if defined, indicates that you must access
* character data through U32-aligned pointers.
*/
#define U32_ALIGNMENT_REQUIRED /**/
+
+ /* HAS_USLEEP_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the usleep() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int usleep(useconds_t);
+ */
+ /*#define HAS_USLEEP_PROTO /**/
+
+ /* I_LANGINFO:
+ * This symbol, if defined, indicates that <langinfo.h> exists and
+ * should be included.
+ */
+ /*#define I_LANGINFO /**/
+
+ /* HAS_PTHREAD_ATFORK:
+ * This symbol, if defined, indicates that the pthread_atfork routine
+ * is available setup fork handlers.
+ */
+ /*#define HAS_PTHREAD_ATFORK /**/
#endif
diff -c 'perl-5.7.1/vos/config.ga.def' 'perl-5.7.2/vos/config.ga.def'
Index: ./vos/config.ga.def
*** ./vos/config.ga.def Thu Apr 5 20:36:50 2001
--- ./vos/config.ga.def Fri Jul 13 03:17:12 2001
***************
*** 3,14 ****
$archlib=''
$archlibexp=''
$archname='vos'
! $bin='/system/ported/command_library'
! $binexp='/system/ported/command_library'
$byteorder='4321'
$castflags='0'
$cf_by='Paul_Green@stratus.com'
! $cf_time='2000-10-24 15:35 UCT'
$CONFIG_SH='config.sh'
$cpp_stuff='42'
$cpplast='-'
--- 3,14 ----
$archlib=''
$archlibexp=''
$archname='vos'
! $bin='/system/gnu_library/bin'
! $binexp='/system/gnu_library/bin'
$byteorder='4321'
$castflags='0'
$cf_by='Paul_Green@stratus.com'
! $cf_time='2001-06-11 02:46 UCT'
$CONFIG_SH='config.sh'
$cpp_stuff='42'
$cpplast='-'
***************
*** 15,21 ****
$cppminus='-'
$cpprun='cc -E -'
$cppstdin='cc -E'
! $crosscompile='undef'
$d__fwalk='undef'
$d_access='define'
$d_accessx='undef'
--- 15,25 ----
$cppminus='-'
$cpprun='cc -E -'
$cppstdin='cc -E'
! $d_Gconvert='sprintf((b),"%.*g",(n),(x))'
! $d_PRIeldbl='define'
! $d_PRIfldbl='define'
! $d_PRIgldbl='define'
! $d_SCNfldbl='define'
$d__fwalk='undef'
$d_access='define'
$d_accessx='undef'
***************
*** 42,47 ****
--- 46,52 ----
$d_csh='define'
$d_cuserid='undef'
$d_dbl_dig='define'
+ $d_dbminitproto='undef'
$d_difftime='define'
$d_dirnamlen='undef'
$d_dlerror='undef'
***************
*** 57,62 ****
--- 62,68 ----
$d_endpwent='undef'
$d_endsent='define'
$d_eofnblk='define'
+ $d_fchdir='undef'
$d_fchmod='define'
$d_fchown='undef'
$d_fcntl='define'
***************
*** 65,70 ****
--- 71,77 ----
$d_fgetpos='define'
$d_flexfnam='define'
$d_flock='undef'
+ $d_flockproto='undef'
$d_fork='define'
$d_fpathconf='define'
$d_fpos64_t='undef'
***************
*** 76,82 ****
$d_fstatvfs='undef'
$d_fsync='undef'
$d_ftello='undef'
- $d_Gconvert='sprintf((b),"%.*g",(n),(x))'
$d_getcwd='define'
$d_getespwnam='undef'
$d_getfsstat='undef'
--- 83,88 ----
***************
*** 145,156 ****
$d_memset='define'
$d_mkdir='define'
$d_mkdtemp='undef'
$d_mkstemp='undef'
$d_mkstemps='undef'
- $d_mkfifo='define'
$d_mktime='define'
$d_mmap='define'
$d_modfl='undef'
$d_mprotect='undef'
$d_msg='undef'
$d_msg_ctrunc='undef'
--- 151,163 ----
$d_memset='define'
$d_mkdir='define'
$d_mkdtemp='undef'
+ $d_mkfifo='define'
$d_mkstemp='undef'
$d_mkstemps='undef'
$d_mktime='define'
$d_mmap='define'
$d_modfl='undef'
+ $d_modfl_pow32_bug='undef'
$d_mprotect='undef'
$d_msg='undef'
$d_msg_ctrunc='undef'
***************
*** 163,168 ****
--- 170,176 ----
$d_munmap='define'
$d_mymalloc='undef'
$d_nice='undef'
+ $d_nl_langinfo='undef'
$d_nv_preserves_uv='define'
$d_nv_preserves_uv_bits='32'
$d_off64_t='undef'
***************
*** 170,183 ****
$d_oldpthreads='undef'
$d_open3='define'
$d_pathconf='define'
- $d_perl_otherlibdirs='undef'
$d_pause='define'
$d_phostname='undef'
$d_pipe='define'
$d_poll='define'
! $d_PRIeldbl='define'
! $d_PRIfldbl='define'
! $d_PRIgldbl='define'
$d_pthread_yield='undef'
$d_pwage='undef'
$d_pwchange='undef'
--- 178,189 ----
$d_oldpthreads='undef'
$d_open3='define'
$d_pathconf='define'
$d_pause='define'
+ $d_perl_otherlibdirs='undef'
$d_phostname='undef'
$d_pipe='define'
$d_poll='define'
! $d_pthread_atfork='undef'
$d_pthread_yield='undef'
$d_pwage='undef'
$d_pwchange='undef'
***************
*** 201,207 ****
$d_sbrkproto='undef'
$d_sched_yield='undef'
$d_scm_rights='undef'
- $d_SCNfldbl='define'
$d_seekdir='undef'
$d_select='define'
$d_sem='undef'
--- 207,212 ----
***************
*** 213,218 ****
--- 218,224 ----
$d_setgrent='undef'
$d_setgrps='undef'
$d_sethent='define'
+ $d_setitimer='undef'
$d_setlinebuf='define'
$d_setlocale='define'
$d_setnent='define'
***************
*** 239,255 ****
$d_sigprocmask='define'
$d_sigsetjmp='define'
$d_sockatmark='undef'
$d_socket='define'
$d_sockpair='undef'
$d_socks5_init='undef'
$d_sqrtl='undef'
$d_statblks='undef'
$d_statfs_f_flags='undef'
$d_statfs_s='undef'
$d_stdio_cnt_lval='define'
$d_stdio_ptr_lval='define'
- $d_stdio_ptr_lval_sets_cnt='undef'
$d_stdio_ptr_lval_nochange_cnt='undef'
$d_stdio_stream_array='define'
$d_stdiobase='define'
$d_stdstdio='define'
--- 245,264 ----
$d_sigprocmask='define'
$d_sigsetjmp='define'
$d_sockatmark='undef'
+ $d_sockatmarkproto='undef'
$d_socket='define'
$d_sockpair='undef'
$d_socks5_init='undef'
$d_sqrtl='undef'
+ $d_sresgproto='undef'
+ $d_sresuproto='undef'
$d_statblks='undef'
$d_statfs_f_flags='undef'
$d_statfs_s='undef'
$d_stdio_cnt_lval='define'
$d_stdio_ptr_lval='define'
$d_stdio_ptr_lval_nochange_cnt='undef'
+ $d_stdio_ptr_lval_sets_cnt='undef'
$d_stdio_stream_array='define'
$d_stdiobase='define'
$d_stdstdio='define'
***************
*** 258,263 ****
--- 267,273 ----
$d_strctcpy='define'
$d_strerrm='strerror(e)'
$d_strerror='define'
+ $d_strftime='define'
$d_strtod='define'
$d_strtol='define'
$d_strtold='undef'
***************
*** 270,275 ****
--- 280,286 ----
$d_suidsafe='define'
$d_symlink='define'
$d_syscall='undef'
+ $d_syscallproto='undef'
$d_sysconf='define'
$d_syserrlst='define'
$d_system='define'
***************
*** 286,291 ****
--- 297,303 ----
$d_uname='define'
$d_union_semun='undef'
$d_usleep='undef'
+ $d_usleepproto='undef'
$d_ustat='undef'
$d_vendorarch='define'
$d_vendorlib='define'
***************
*** 300,305 ****
--- 312,320 ----
$d_writev='undef'
$db_hashtype='int'
$db_prefixtype='int'
+ $db_version_major='undef'
+ $db_version_minor='undef'
+ $db_version_patch='undef'
$defvoidused='15'
$direntrytype='struct dirent'
$doublesize='8'
***************
*** 310,317 ****
$fflushNULL='define'
$fpostype='fpos_t'
$freetype='void'
! $full_csh='/system/ported/command_library/bash.pm'
! $full_sed='/system/ported/command_library/sed.pm'
$gidformat='"d"'
$gidsize='4'
$gidsign='-1'
--- 325,332 ----
$fflushNULL='define'
$fpostype='fpos_t'
$freetype='void'
! $full_csh='/system/gnu_library/bin/bash.pm'
! $full_sed='/system/gnu_library/bin/sed.pm'
$gidformat='"d"'
$gidsize='4'
$gidsign='-1'
***************
*** 335,340 ****
--- 350,356 ----
$i_iconv='undef'
$i_ieeefp='undef'
$i_inttypes='undef'
+ $i_langinfo='undef'
$i_libutil='undef'
$i_limits='define'
$i_locale='define'
***************
*** 425,430 ****
--- 441,447 ----
$o_nonblock='O_NONBLOCK'
$old_pthread_create_joinable=''
$osname='VOS'
+ $osvers='VOS'
$otherlibdirs=''
$package='perl5'
$pidtype='pid_t'
***************
*** 442,448 ****
$seedfunc='srand'
$selectminbits='1'
$selecttype='fd_set *'
! $sh='/system/ported/command_library/bash.pm'
$shmattype='void *'
$shortsize='2'
$sig_name_init='"ZERO","ABRT","FPE","ILL","INT","SEGV","TERM","USR1","USR2","IO","HUP","URG","ALRM","CHLD","CONT","KILL","STOP","PIPE","QUIT","BUS","TRAP","TSTP","TTIN","TTOU","RT1","RT2","RT3","RT4","RT5","RT6","RT7","RT8",0'
--- 459,465 ----
$seedfunc='srand'
$selectminbits='1'
$selecttype='fd_set *'
! $sh='/system/gnu_library/bin/bash.pm'
$shmattype='void *'
$shortsize='2'
$sig_name_init='"ZERO","ABRT","FPE","ILL","INT","SEGV","TERM","USR1","USR2","IO","HUP","URG","ALRM","CHLD","CONT","KILL","STOP","PIPE","QUIT","BUS","TRAP","TSTP","TTIN","TTOU","RT1","RT2","RT3","RT4","RT5","RT6","RT7","RT8",0'
***************
*** 470,475 ****
--- 487,493 ----
$stdio_cnt='((fp)->_cnt)'
$stdio_ptr='((fp)->_ptr)'
$stdio_stream_array='_iob'
+ $targetarch='undef'
$timetype='time_t'
$u16size='2'
$u16type='unsigned short'
***************
*** 488,493 ****
--- 506,512 ----
$use5005threads='undef'
$use64bitall='undef'
$use64bitint='undef'
+ $usecrosscompile='undef'
$usedl='undef'
$useithreads='undef'
$uselargefiles='undef'
***************
*** 495,500 ****
--- 514,520 ----
$usemorebits='undef'
$usemultiplicity='undef'
$useperlio='undef'
+ $usereentrant='undef'
$usesocks='undef'
$uvoformat='"o"'
$uvsize='4'
diff -c 'perl-5.7.1/vos/config.ga.h' 'perl-5.7.2/vos/config.ga.h'
Index: ./vos/config.ga.h
Prereq: 3.0.1.5
*** ./vos/config.ga.h Thu Apr 5 19:24:42 2001
--- ./vos/config.ga.h Fri Jul 13 03:17:17 2001
***************
*** 13,19 ****
/*
* Package name : perl5
* Source directory : /vos_ftp_site/pub/vos/posix/(alpha|ga)/perl
! * Configuration time: 2000-10-24 15:35 UCT
* Configured by : Paul_Green@stratus.com
* Target system : VOS
*/
--- 13,19 ----
/*
* Package name : perl5
* Source directory : /vos_ftp_site/pub/vos/posix/(alpha|ga)/perl
! * Configuration time: 2001-06-11 02:46 UCT
* Configured by : Paul_Green@stratus.com
* Target system : VOS
*/
***************
*** 24,30 ****
/* LOC_SED:
* This symbol holds the complete pathname to the sed program.
*/
! #define LOC_SED "/system/ported/command_library/sed.pm" /**/
/* HAS_ALARM:
* This symbol, if defined, indicates that the alarm routine is
--- 24,30 ----
/* LOC_SED:
* This symbol holds the complete pathname to the sed program.
*/
! #define LOC_SED "/system/gnu_library/bin/sed.pm" /**/
/* HAS_ALARM:
* This symbol, if defined, indicates that the alarm routine is
***************
*** 121,146 ****
*/
/*#define HAS_DLERROR /**/
- /* SETUID_SCRIPTS_ARE_SECURE_NOW:
- * This symbol, if defined, indicates that the bug that prevents
- * setuid scripts from being secure is not present in this kernel.
- */
- /* DOSUID:
- * This symbol, if defined, indicates that the C program should
- * check the script that it is executing for setuid/setgid bits, and
- * attempt to emulate setuid/setgid on systems that have disabled
- * setuid #! scripts because the kernel can't do it securely.
- * It is up to the package designer to make sure that this emulation
- * is done securely. Among other things, it should do an fstat on
- * the script it just opened to make sure it really is a setuid/setgid
- * script, it should make sure the arguments passed correspond exactly
- * to the argument on the #! line, and it should not trust any
- * subprocesses to which it must pass the filename rather than the
- * file descriptor of the script to be executed.
- */
- #define SETUID_SCRIPTS_ARE_SECURE_NOW /**/
- /*#define DOSUID /**/
-
/* HAS_DUP2:
* This symbol, if defined, indicates that the dup2 routine is
* available to duplicate file descriptors.
--- 121,126 ----
***************
*** 165,183 ****
*/
#define HAS_FCNTL /**/
- /* HAS__FWALK:
- * This symbol, if defined, indicates that the _fwalk system call is
- * available to apply a function to all the file handles.
- */
- /*#define HAS__FWALK / **/
-
- /* FCNTL_CAN_LOCK:
- * This symbol, if defined, indicates that fcntl() can be used
- * for file locking. Normally on Unix systems this is defined.
- * It may be undefined on VMS.
- */
- #define FCNTL_CAN_LOCK /**/
-
/* HAS_FGETPOS:
* This symbol, if defined, indicates that the fgetpos routine is
* available to get the file position indicator, similar to ftell().
--- 145,150 ----
***************
*** 226,238 ****
*/
#define HAS_GETLOGIN /**/
- /* HAS_GETPAGESIZE:
- * This symbol, if defined, indicates that the getpagesize system call
- * is available to get system page size, which is the granularity of
- * many memory management calls.
- */
- /*#define HAS_GETPAGESIZE /**/
-
/* HAS_GETPGID:
* This symbol, if defined, indicates to the C program that
* the getpgid(pid) function is available to get the
--- 193,198 ----
***************
*** 442,460 ****
*/
#define HAS_READLINK /**/
- /* HAS_READV:
- * This symbol, if defined, indicates that the readv routine is
- * available to do gather reads. You will also need <sys/uio.h>
- * and there I_SYSUIO.
- */
- /*#define HAS_READV /**/
-
- /* HAS_RECVMSG:
- * This symbol, if defined, indicates that the recvmsg routine is
- * available to send structured socket messages.
- */
- /*#define HAS_RECVMSG /**/
-
/* HAS_RENAME:
* This symbol, if defined, indicates that the rename routine is available
* to rename files. Otherwise you should do the unlink(), link(), unlink()
--- 402,407 ----
***************
*** 614,637 ****
*/
#define HAS_STRTOL /**/
- /* HAS_STRTOQ:
- * This symbol, if defined, indicates that the strtouq routine is
- * available to convert strings to long longs (quads).
- */
- /*#define HAS_STRTOQ /**/
-
- /* HAS_STRTOQ:
- * This symbol, if defined, indicates that the strtouq routine is
- * available to convert strings to long longs (quads).
- */
- /*#define HAS_STRTOQ /**/
-
- /* HAS_STRTOUL:
- * This symbol, if defined, indicates that the strtoul routine is
- * available to provide conversion of strings to unsigned long.
- */
- #define HAS_STRTOUL /**/
-
/* HAS_STRXFRM:
* This symbol, if defined, indicates that the strxfrm() routine is
* available to transform strings.
--- 561,566 ----
***************
*** 868,874 ****
--- 797,808 ----
* This symbol, if defined, indicates that <sys/ioctl.h> exists and should
* be included. Otherwise, include <sgtty.h> or <termio.h>.
*/
+ /* I_SYS_SOCKIO:
+ * This symbol, if defined, indicates the <sys/sockio.h> should be included
+ * to get socket ioctl options, like SIOCATMARK.
+ */
#define I_SYS_IOCTL /**/
+ /*#define I_SYS_SOCKIO /**/
/* I_SYS_NDIR:
* This symbol, if defined, indicates to the C program that it should
***************
*** 964,980 ****
*/
#define I_VALUES /**/
- /* I_STDARG:
- * This symbol, if defined, indicates that <stdarg.h> exists and should
- * be included.
- */
- /* I_VARARGS:
- * This symbol, if defined, indicates to the C program that it should
- * include <varargs.h>.
- */
- #define I_STDARG /**/
- /*#define I_VARARGS /**/
-
/* I_VFORK:
* This symbol, if defined, indicates to the C program that it should
* include vfork.h.
--- 898,903 ----
***************
*** 1006,1025 ****
* /bin/pdksh, /bin/ash, /bin/bash, or even something such as
* D:/bin/sh.exe.
*/
! #define SH_PATH "/system/ported/command_library/bash.pm" /**/
- /* STDCHAR:
- * This symbol is defined to be the type of char used in stdio.h.
- * It has the values "unsigned char" or "char".
- */
- #define STDCHAR unsigned char /**/
-
- /* CROSSCOMPILE:
- * This symbol, if defined, signifies that we our
- * build process is a cross-compilation.
- */
- /*#define CROSSCOMPILE /**/
-
/* INTSIZE:
* This symbol contains the value of sizeof(int) so that the C
* preprocessor can make decisions based on it.
--- 929,936 ----
* /bin/pdksh, /bin/ash, /bin/bash, or even something such as
* D:/bin/sh.exe.
*/
! #define SH_PATH "/system/gnu_library/bin/bash.pm" /**/
/* INTSIZE:
* This symbol contains the value of sizeof(int) so that the C
* preprocessor can make decisions based on it.
***************
*** 1090,1096 ****
--- 1001,1013 ----
* by Configure. You shouldn't rely on it too much; the specific
* feature tests from Configure are generally more reliable.
*/
+ /* OSVERS:
+ * This symbol contains the version of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
+ */
#define OSNAME "VOS" /**/
+ #define OSVERS "VOS" /**/
/* MEM_ALIGNBYTES:
* This symbol contains the number of bytes required to align a
***************
*** 1097,1103 ****
* double, or a long double when applicable. Usual values are 2,
* 4 and 8. The default is eight, for safety.
*/
! #if defined(CROSSCOMPILE) || defined(MULTIARCH)
# define MEM_ALIGNBYTES 8
#else
#define MEM_ALIGNBYTES 8
--- 1014,1020 ----
* double, or a long double when applicable. Usual values are 2,
* 4 and 8. The default is eight, for safety.
*/
! #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
# define MEM_ALIGNBYTES 8
#else
#define MEM_ALIGNBYTES 8
***************
*** 1147,1154 ****
* This symbol is the filename expanded version of the BIN symbol, for
* programs that do not want to deal with that at run-time.
*/
! #define BIN "/system/ported/command_library" /**/
! #define BIN_EXP "/system/ported/command_library" /**/
/* PERL_BINCOMPAT_5005:
* This symbol, if defined, indicates that this version of Perl should be
--- 1064,1071 ----
* This symbol is the filename expanded version of the BIN symbol, for
* programs that do not want to deal with that at run-time.
*/
! #define BIN "/system/gnu_library/bin" /**/
! #define BIN_EXP "/system/gnu_library/bin" /**/
/* PERL_BINCOMPAT_5005:
* This symbol, if defined, indicates that this version of Perl should be
***************
*** 1174,1180 ****
* so the default case (for NeXT) is big endian to catch them.
* This might matter for NeXT 3.0.
*/
! #if defined(CROSSCOMPILE) || defined(MULTIARCH)
# ifdef __LITTLE_ENDIAN__
# if LONGSIZE == 4
# define BYTEORDER 0x1234
--- 1091,1097 ----
* so the default case (for NeXT) is big endian to catch them.
* This might matter for NeXT 3.0.
*/
! #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
# ifdef __LITTLE_ENDIAN__
# if LONGSIZE == 4
# define BYTEORDER 0x1234
***************
*** 1255,1260 ****
--- 1172,1183 ----
#define CPPRUN "cc -E -"
#define CPPLAST "-"
+ /* HAS__FWALK:
+ * This symbol, if defined, indicates that the _fwalk system call is
+ * available to apply a function to all the file handles.
+ */
+ /*#define HAS__FWALK /**/
+
/* HAS_ACCESS:
* This manifest constant lets the C program know that the access()
* system call is available to check for accessibility using real UID/GID.
***************
*** 1293,1299 ****
* This symbol, if defined, indicates that the struct cmsghdr
* is supported.
*/
! /*#define HAS_STRUCT_CMSGHDR / **/
/* HAS_CSH:
* This symbol, if defined, indicates that the C-shell exists.
--- 1216,1222 ----
* This symbol, if defined, indicates that the struct cmsghdr
* is supported.
*/
! /*#define HAS_STRUCT_CMSGHDR /**/
/* HAS_CSH:
* This symbol, if defined, indicates that the C-shell exists.
***************
*** 1303,1309 ****
*/
#define HAS_CSH /**/
#ifdef HAS_CSH
! #define CSH "/system/ported/command_library/bash.pm" /**/
#endif
/* DLSYM_NEEDS_UNDERSCORE:
--- 1226,1232 ----
*/
#define HAS_CSH /**/
#ifdef HAS_CSH
! #define CSH "/system/gnu_library/bin/bash.pm" /**/
#endif
/* DLSYM_NEEDS_UNDERSCORE:
***************
*** 1358,1363 ****
--- 1281,1299 ----
*/
#define HAS_ENDSERVENT /**/
+ /* HAS_FCHDIR:
+ * This symbol, if defined, indicates that the fchdir routine is
+ * available to change directory using a file descriptor.
+ */
+ /*#define HAS_FCHDIR /**/
+
+ /* FCNTL_CAN_LOCK:
+ * This symbol, if defined, indicates that fcntl() can be used
+ * for file locking. Normally on Unix systems this is defined.
+ * It may be undefined on VMS.
+ */
+ #define FCNTL_CAN_LOCK /**/
+
/* HAS_FD_SET:
* This symbol, when defined, indicates presence of the fd_set typedef
* in <sys/types.h>
***************
*** 1553,1558 ****
--- 1489,1501 ----
*/
#define HAS_GETNET_PROTOS /**/
+ /* HAS_GETPAGESIZE:
+ * This symbol, if defined, indicates that the getpagesize system call
+ * is available to get system page size, which is the granularity of
+ * many memory management calls.
+ */
+ /*#define HAS_GETPAGESIZE /**/
+
/* HAS_GETPROTOENT:
* This symbol, if defined, indicates that the getprotoent() routine is
* available to look up protocols in some data base or another.
***************
*** 1559,1564 ****
--- 1502,1518 ----
*/
#define HAS_GETPROTOENT /**/
+ /* HAS_GETPGRP:
+ * This symbol, if defined, indicates that the getpgrp routine is
+ * available to get the current process group.
+ */
+ /* USE_BSD_GETPGRP:
+ * This symbol, if defined, indicates that getpgrp needs one
+ * arguments whereas USG one needs none.
+ */
+ #define HAS_GETPGRP /**/
+ /*#define USE_BSD_GETPGRP /**/
+
/* HAS_GETPROTOBYNAME:
* This symbol, if defined, indicates that the getprotobyname()
* routine is available to look up protocols by their name.
***************
*** 1791,1797 ****
--- 1745,1759 ----
* available to split a long double x into a fractional part f and
* an integer part i such that |f| < 1.0 and (f + i) = x.
*/
+ /* HAS_MODFL_POW32_BUG:
+ * This symbol, if defined, indicates that the modfl routine is
+ * broken for long doubles >= pow(2, 32).
+ * For example from 4294967303.150000 one would get 4294967302.000000
+ * and 1.150000. The bug has been seen in certain versions of glibc,
+ * release 2.2.2 is known to be okay.
+ */
/*#define HAS_MODFL /**/
+ /*#define HAS_MODFL_POW32_BUG /**/
/* HAS_MPROTECT:
* This symbol, if defined, indicates that the mprotect system call is
***************
*** 1809,1815 ****
* This symbol, if defined, indicates that the struct msghdr
* is supported.
*/
! /*#define HAS_STRUCT_MSGHDR / **/
/* HAS_OFF64_T:
* This symbol will be defined if the C compiler supports off64_t.
--- 1771,1777 ----
* This symbol, if defined, indicates that the struct msghdr
* is supported.
*/
! /*#define HAS_STRUCT_MSGHDR /**/
/* HAS_OFF64_T:
* This symbol will be defined if the C compiler supports off64_t.
***************
*** 1851,1859 ****
#define SCHED_YIELD /**/
/*#define HAS_SCHED_YIELD /**/
/* HAS_SAFE_BCOPY:
* This symbol, if defined, indicates that the bcopy routine is available
! * to copy potentially overlapping memory blocks. Otherwise you should
* probably use memmove() or memcpy(). If neither is defined, roll your
* own version.
*/
--- 1813,1834 ----
#define SCHED_YIELD /**/
/*#define HAS_SCHED_YIELD /**/
+ /* HAS_READV:
+ * This symbol, if defined, indicates that the readv routine is
+ * available to do gather reads. You will also need <sys/uio.h>
+ * and there I_SYSUIO.
+ */
+ /*#define HAS_READV /**/
+
+ /* HAS_RECVMSG:
+ * This symbol, if defined, indicates that the recvmsg routine is
+ * available to send structured socket messages.
+ */
+ /*#define HAS_RECVMSG /**/
+
/* HAS_SAFE_BCOPY:
* This symbol, if defined, indicates that the bcopy routine is available
! * to copy potentially overlapping memory blocks. Normally, you should
* probably use memmove() or memcpy(). If neither is defined, roll your
* own version.
*/
***************
*** 1861,1869 ****
/* HAS_SAFE_MEMCPY:
* This symbol, if defined, indicates that the memcpy routine is available
! * to copy potentially overlapping memory blocks. Otherwise you should
! * probably use memmove() or memcpy(). If neither is defined, roll your
! * own version.
*/
/*#define HAS_SAFE_MEMCPY /**/
--- 1836,1844 ----
/* HAS_SAFE_MEMCPY:
* This symbol, if defined, indicates that the memcpy routine is available
! * to copy potentially overlapping memory blocks. If you need to
! * copy overlapping memory blocks, you should check HAS_MEMMOVE and
! * use memmove() instead, if available.
*/
/*#define HAS_SAFE_MEMCPY /**/
***************
*** 1881,1887 ****
* extern void* sbrk _((int));
* extern void* sbrk _((size_t));
*/
! /*#define HAS_SBRK_PROTO / **/
/* HAS_SEM:
* This symbol, if defined, indicates that the entire sem*(2) library is
--- 1856,1862 ----
* extern void* sbrk _((int));
* extern void* sbrk _((size_t));
*/
! /*#define HAS_SBRK_PROTO /**/
/* HAS_SEM:
* This symbol, if defined, indicates that the entire sem*(2) library is
***************
*** 1932,1937 ****
--- 1907,1924 ----
*/
#define HAS_SETPROTOENT /**/
+ /* HAS_SETPGRP:
+ * This symbol, if defined, indicates that the setpgrp routine is
+ * available to set the current process group.
+ */
+ /* USE_BSD_SETPGRP:
+ * This symbol, if defined, indicates that setpgrp needs two
+ * arguments whereas USG one needs none. See also HAS_SETPGID
+ * for a POSIX interface.
+ */
+ /*#define HAS_SETPGRP /**/
+ /*#define USE_BSD_SETPGRP /**/
+
/* HAS_SETPROCTITLE:
* This symbol, if defined, indicates that the setproctitle routine is
* available to set process title.
***************
*** 1975,1987 ****
*/
#define HAS_SIGACTION /**/
- /* HAS_SIGPROCMASK:
- * This symbol, if defined, indicates that sigprocmask
- * system call is available to examine or change the signal mask
- * of the calling process.
- */
- #define HAS_SIGPROCMASK /**/
-
/* HAS_SIGSETJMP:
* This variable indicates to the C program that the sigsetjmp()
* routine is available to save the calling process's registers
--- 1962,1967 ----
***************
*** 2204,2209 ****
--- 2184,2201 ----
*/
/*#define HAS_STRTOLL /**/
+ /* HAS_STRTOQ:
+ * This symbol, if defined, indicates that the strtoq routine is
+ * available to convert strings to long longs (quads).
+ */
+ /*#define HAS_STRTOQ /**/
+
+ /* HAS_STRTOUL:
+ * This symbol, if defined, indicates that the strtoul routine is
+ * available to provide conversion of strings to unsigned long.
+ */
+ #define HAS_STRTOUL /**/
+
/* HAS_STRTOULL:
* This symbol, if defined, indicates that the strtoull routine is
* available to convert strings to unsigned long longs.
***************
*** 2392,2399 ****
--- 2384,2408 ----
* in the <db.h> header file. In older versions of DB, it was
* int, while in newer ones it is size_t.
*/
+ /* DB_VERSION_MAJOR_CFG:
+ * This symbol, if defined, defines the major version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ */
+ /* DB_VERSION_MINOR_CFG:
+ * This symbol, if defined, defines the minor version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
+ /* DB_VERSION_PATCH_CFG:
+ * This symbol, if defined, defines the patch version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
#define DB_Hash_t int /**/
#define DB_Prefix_t int /**/
+ #define DB_VERSION_MAJOR_CFG undef /**/
+ #define DB_VERSION_MINOR_CFG undef /**/
+ #define DB_VERSION_PATCH_CFG undef /**/
/* I_GRP:
* This symbol, if defined, indicates to the C program that it should
***************
*** 2706,2711 ****
--- 2715,2731 ----
#define RD_NODATA -1
#define EOF_NONBLOCK
+ /* NEED_VA_COPY:
+ * This symbol, if defined, indicates that the system stores
+ * the variable argument list datatype, va_list, in a format
+ * that cannot be copied by simple assignment, so that some
+ * other means must be used when copying is required.
+ * As such systems vary in their provision (or non-provision)
+ * of copying mechanisms, handy.h defines a platform-
+ * independent macro, Perl_va_copy(src, dst), to do the job.
+ */
+ /*#define NEED_VA_COPY /**/
+
/* Netdb_host_t:
* This symbol holds the type used for the 1st argument
* to gethostbyaddr().
***************
*** 2857,2864 ****
* as an unsigned hexadecimal integer in lowercase abcdef.
*/
/* UVXf:
! * This symbol defines the format string used for printing a Perl UV
! * as an unsigned hexadecimal integer in uppercase ABCDEF.
*/
/* NVef:
* This symbol defines the format string used for printing a Perl NV
--- 2877,2884 ----
* as an unsigned hexadecimal integer in lowercase abcdef.
*/
/* UVXf:
! * This symbol defines the format string used for printing a Perl UV
! * as an unsigned hexadecimal integer in uppercase ABCDEF.
*/
/* NVef:
* This symbol defines the format string used for printing a Perl NV
***************
*** 2913,2919 ****
* This macro is to be used to generate uniformly distributed
* random numbers over the range [0., 1.[. You may have to supply
* an 'extern double drand48();' in your program since SunOS 4.1.3
! * doesn't provide you with anything relevant in it's headers.
* See HAS_DRAND48_PROTO.
*/
/* Rand_seed_t:
--- 2933,2939 ----
* This macro is to be used to generate uniformly distributed
* random numbers over the range [0., 1.[. You may have to supply
* an 'extern double drand48();' in your program since SunOS 4.1.3
! * doesn't provide you with anything relevant in its headers.
* See HAS_DRAND48_PROTO.
*/
/* Rand_seed_t:
***************
*** 3065,3070 ****
--- 3085,3096 ----
*/
#define STARTPERL "!perl.pm" /**/
+ /* STDCHAR:
+ * This symbol is defined to be the type of char used in stdio.h.
+ * It has the values "unsigned char" or "char".
+ */
+ #define STDCHAR unsigned char /**/
+
/* HAS_STDIO_STREAM_ARRAY:
* This symbol, if defined, tells that there is an array
* holding the stdio streams.
***************
*** 3186,3191 ****
--- 3212,3222 ----
* This symbol, if defined, indicates that Perl should
* be built to use the old draft POSIX threads API.
*/
+ /* USE_REENTRANT_API:
+ * This symbol, if defined, indicates that Perl should
+ * try to use the various _r versions of library functions.
+ * This is extremely experimental.
+ */
/*#define USE_5005THREADS /**/
/*#define USE_ITHREADS /**/
#if defined(USE_5005THREADS) && !defined(USE_ITHREADS)
***************
*** 3192,3197 ****
--- 3223,3229 ----
#define USE_THREADS /* until src is revised*/
#endif
/*#define OLD_PTHREADS_API /**/
+ /*#define USE_REENTRANT_API /**/
/* PERL_VENDORARCH:
* If defined, this symbol contains the name of a private library.
***************
*** 3283,3332 ****
#define PERL_XS_APIVERSION "5.00563"
#define PERL_PM_APIVERSION "5.005"
! /* HAS_GETPGRP:
! * This symbol, if defined, indicates that the getpgrp routine is
! * available to get the current process group.
*/
! /* USE_BSD_GETPGRP:
! * This symbol, if defined, indicates that getpgrp needs one
! * arguments whereas USG one needs none.
*/
! #define HAS_GETPGRP /**/
! /*#define USE_BSD_GETPGRP /**/
! /* HAS_SETPGRP:
! * This symbol, if defined, indicates that the setpgrp routine is
! * available to set the current process group.
*/
! /* USE_BSD_SETPGRP:
! * This symbol, if defined, indicates that setpgrp needs two
! * arguments whereas USG one needs none. See also HAS_SETPGID
! * for a POSIX interface.
*/
! /*#define HAS_SETPGRP /**/
! /*#define USE_BSD_SETPGRP /**/
! /* NEED_VA_COPY:
! * This symbol, if defined, indicates that the system stores
! * the variable argument list datatype, va_list, in a format
! * that cannot be copied by simple assignment, so that some
! * other means must be used when copying is required.
! * As such systems vary in their provision (or non-provision)
! * of copying mechanisms, handy.h defines a platform-
! * independent macro, Perl_va_copy(src, dst), to do the job.
*/
! /*#define NEED_VA_COPY / **/
/* HAS_SOCKATMARK:
* This symbol, if defined, indicates that the sockatmark routine is
* available to test whether a socket is at the out-of-band mark.
*/
! /*#define HAS_SOCKATMARK / **/
/* U32_ALIGNMENT_REQUIRED:
* This symbol, if defined, indicates that you must access
* character data through U32-aligned pointers.
*/
#define U32_ALIGNMENT_REQUIRED /**/
#endif
--- 3315,3462 ----
#define PERL_XS_APIVERSION "5.00563"
#define PERL_PM_APIVERSION "5.005"
! /* SETUID_SCRIPTS_ARE_SECURE_NOW:
! * This symbol, if defined, indicates that the bug that prevents
! * setuid scripts from being secure is not present in this kernel.
*/
! /* DOSUID:
! * This symbol, if defined, indicates that the C program should
! * check the script that it is executing for setuid/setgid bits, and
! * attempt to emulate setuid/setgid on systems that have disabled
! * setuid #! scripts because the kernel can't do it securely.
! * It is up to the package designer to make sure that this emulation
! * is done securely. Among other things, it should do an fstat on
! * the script it just opened to make sure it really is a setuid/setgid
! * script, it should make sure the arguments passed correspond exactly
! * to the argument on the #! line, and it should not trust any
! * subprocesses to which it must pass the filename rather than the
! * file descriptor of the script to be executed.
*/
! #define SETUID_SCRIPTS_ARE_SECURE_NOW /**/
! /*#define DOSUID /**/
! /* I_STDARG:
! * This symbol, if defined, indicates that <stdarg.h> exists and should
! * be included.
*/
! /* I_VARARGS:
! * This symbol, if defined, indicates to the C program that it should
! * include <varargs.h>.
*/
! #define I_STDARG /**/
! /*#define I_VARARGS /**/
! /* USE_CROSS_COMPILE:
! * This symbol, if defined, indicates that Perl is being cross-compiled.
*/
! /* PERL_TARGETARCH:
! * This symbol, if defined, indicates the target architecture
! * Perl has been cross-compiled to. Undefined if not a cross-compile.
! */
! #ifndef USE_CROSS_COMPILE
! /*#define USE_CROSS_COMPILE /**/
! #define PERL_TARGETARCH "undef" /**/
! #endif
+ /* HAS_DBMINIT_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the dbminit() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int dbminit(char *);
+ */
+ /*#define HAS_DBMINIT_PROTO /**/
+
+ /* HAS_FLOCK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the flock() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int flock(int, int);
+ */
+ /*#define HAS_FLOCK_PROTO /**/
+
+ /* HAS_NL_LANGINFO:
+ * This symbol, if defined, indicates that the nl_langinfo routine is
+ * available to return local data. You will also need <langinfo.h>
+ * and therefore I_LANGINFO.
+ */
+ /*#define HAS_NL_LANGINFO /**/
+
+ /* HAS_SIGPROCMASK:
+ * This symbol, if defined, indicates that the sigprocmask
+ * system call is available to examine or change the signal mask
+ * of the calling process.
+ */
+ #define HAS_SIGPROCMASK /**/
+
/* HAS_SOCKATMARK:
* This symbol, if defined, indicates that the sockatmark routine is
* available to test whether a socket is at the out-of-band mark.
*/
! /*#define HAS_SOCKATMARK /**/
+ /* HAS_SOCKATMARK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the sockatmark() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int sockatmark _((int));
+ */
+ /*#define HAS_SOCKATMARK_PROTO /**/
+
+ /* HAS_SETRESGID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresgid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+ /*#define HAS_SETRESGID_PROTO /**/
+
+ /* HAS_SETRESUID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresuid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+ /*#define HAS_SETRESUID_PROTO /**/
+
+ /* HAS_STRFTIME:
+ * This symbol, if defined, indicates that the strftime routine is
+ * available to do time formatting.
+ */
+ #define HAS_STRFTIME /**/
+
+ /* HAS_SYSCALL_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the syscall() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int syscall(int, ...);
+ * extern int syscall(long, ...);
+ */
+ /*#define HAS_SYSCALL_PROTO /**/
+
/* U32_ALIGNMENT_REQUIRED:
* This symbol, if defined, indicates that you must access
* character data through U32-aligned pointers.
*/
#define U32_ALIGNMENT_REQUIRED /**/
+
+ /* HAS_USLEEP_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the usleep() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int usleep(useconds_t);
+ */
+ /*#define HAS_USLEEP_PROTO /**/
+
+ /* I_LANGINFO:
+ * This symbol, if defined, indicates that <langinfo.h> exists and
+ * should be included.
+ */
+ /*#define I_LANGINFO /**/
+
+ /* HAS_PTHREAD_ATFORK:
+ * This symbol, if defined, indicates that the pthread_atfork routine
+ * is available setup fork handlers.
+ */
+ /*#define HAS_PTHREAD_ATFORK /**/
#endif
diff -c 'perl-5.7.1/vos/configure_perl.cm' 'perl-5.7.2/vos/configure_perl.cm'
Index: ./vos/configure_perl.cm
*** ./vos/configure_perl.cm Tue Mar 6 04:07:30 2001
--- ./vos/configure_perl.cm Mon Jul 9 17:11:34 2001
***************
*** 8,14 ****
&end_parameters
&echo command_lines
&
! &if (file_info config.&version&.def date_modified) > (file_info config.&version&.h date_modified)
&then &do
!copy_file config.&version&.def config.def -delete
&
--- 8,15 ----
&end_parameters
&echo command_lines
&
! &if (file_info config.&version&.def date_modified) >= &+
! (file_info config.&version&.h date_modified)
&then &do
!copy_file config.&version&.def config.def -delete
&
diff -c 'perl-5.7.1/vos/perl.bind' 'perl-5.7.2/vos/perl.bind'
Index: ./vos/perl.bind
*** ./vos/perl.bind Tue Mar 6 04:07:30 2001
--- ./vos/perl.bind Mon Jul 9 17:11:34 2001
***************
*** 11,17 ****
--- 11,19 ----
globals,
gv,
hv,
+ locale,
mg,
+ numeric,
op,
perl,
perlapi,
***************
*** 20,25 ****
--- 22,28 ----
pp,
pp_ctl,
pp_hot,
+ pp_pack,
pp_sys,
regcomp,
regexec,
diff -c 'perl-5.7.1/warnings.h' 'perl-5.7.2/warnings.h'
Index: ./warnings.h
*** ./warnings.h Thu Apr 5 20:48:17 2001
--- ./warnings.h Thu Jul 12 08:23:16 2001
***************
*** 23,74 ****
#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
(x) == pWARN_NONE)
#define WARN_ALL 0
! #define WARN_CHMOD 1
! #define WARN_CLOSURE 2
! #define WARN_EXITING 3
! #define WARN_GLOB 4
! #define WARN_IO 5
! #define WARN_CLOSED 6
! #define WARN_EXEC 7
! #define WARN_NEWLINE 8
! #define WARN_PIPE 9
! #define WARN_UNOPENED 10
! #define WARN_MISC 11
! #define WARN_NUMERIC 12
! #define WARN_ONCE 13
! #define WARN_OVERFLOW 14
! #define WARN_PACK 15
! #define WARN_PORTABLE 16
! #define WARN_RECURSION 17
! #define WARN_REDEFINE 18
! #define WARN_REGEXP 19
! #define WARN_SEVERE 20
! #define WARN_DEBUGGING 21
! #define WARN_INPLACE 22
! #define WARN_INTERNAL 23
! #define WARN_MALLOC 24
! #define WARN_SIGNAL 25
! #define WARN_SUBSTR 26
! #define WARN_SYNTAX 27
! #define WARN_AMBIGUOUS 28
! #define WARN_BAREWORD 29
! #define WARN_DEPRECATED 30
! #define WARN_DIGIT 31
! #define WARN_PARENTHESIS 32
! #define WARN_PRECEDENCE 33
! #define WARN_PRINTF 34
! #define WARN_PROTOTYPE 35
! #define WARN_QW 36
! #define WARN_RESERVED 37
! #define WARN_SEMICOLON 38
! #define WARN_TAINT 39
! #define WARN_UMASK 40
! #define WARN_UNINITIALIZED 41
! #define WARN_UNPACK 42
! #define WARN_UNTIE 43
! #define WARN_UTF8 44
! #define WARN_VOID 45
! #define WARN_Y2K 46
#define WARNsize 12
#define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125"
--- 23,72 ----
#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
(x) == pWARN_NONE)
#define WARN_ALL 0
! #define WARN_CLOSURE 1
! #define WARN_EXITING 2
! #define WARN_GLOB 3
! #define WARN_IO 4
! #define WARN_CLOSED 5
! #define WARN_EXEC 6
! #define WARN_NEWLINE 7
! #define WARN_PIPE 8
! #define WARN_UNOPENED 9
! #define WARN_MISC 10
! #define WARN_NUMERIC 11
! #define WARN_ONCE 12
! #define WARN_OVERFLOW 13
! #define WARN_PACK 14
! #define WARN_PORTABLE 15
! #define WARN_RECURSION 16
! #define WARN_REDEFINE 17
! #define WARN_REGEXP 18
! #define WARN_SEVERE 19
! #define WARN_DEBUGGING 20
! #define WARN_INPLACE 21
! #define WARN_INTERNAL 22
! #define WARN_MALLOC 23
! #define WARN_SIGNAL 24
! #define WARN_SUBSTR 25
! #define WARN_SYNTAX 26
! #define WARN_AMBIGUOUS 27
! #define WARN_BAREWORD 28
! #define WARN_DEPRECATED 29
! #define WARN_DIGIT 30
! #define WARN_PARENTHESIS 31
! #define WARN_PRECEDENCE 32
! #define WARN_PRINTF 33
! #define WARN_PROTOTYPE 34
! #define WARN_QW 35
! #define WARN_RESERVED 36
! #define WARN_SEMICOLON 37
! #define WARN_TAINT 38
! #define WARN_UNINITIALIZED 39
! #define WARN_UNPACK 40
! #define WARN_UNTIE 41
! #define WARN_UTF8 42
! #define WARN_VOID 43
! #define WARN_Y2K 44
#define WARNsize 12
#define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125"
diff -c 'perl-5.7.1/warnings.pl' 'perl-5.7.2/warnings.pl'
Index: ./warnings.pl
*** ./warnings.pl Tue Mar 6 04:07:31 2001
--- ./warnings.pl Thu Jul 12 08:23:07 2001
***************
*** 47,54 ****
'regexp' => DEFAULT_OFF,
'glob' => DEFAULT_OFF,
'y2k' => DEFAULT_OFF,
- 'chmod' => DEFAULT_OFF,
- 'umask' => DEFAULT_OFF,
'untie' => DEFAULT_OFF,
'substr' => DEFAULT_OFF,
'taint' => DEFAULT_OFF,
--- 47,52 ----
diff -c 'perl-5.7.1/win32/FindExt.pm' 'perl-5.7.2/win32/FindExt.pm'
Index: ./win32/FindExt.pm
*** ./win32/FindExt.pm Sat Apr 7 18:41:12 2001
--- ./win32/FindExt.pm Mon Jul 9 17:11:35 2001
***************
*** 4,10 ****
use File::Basename;
use Cwd;
! my $no = join('|',qw(DynaLoader GDBM_File ODBM_File NDBM_File DB_File Syslog Sysv));
$no = qr/^(?:$no)$/i;
my %ext;
--- 4,11 ----
use File::Basename;
use Cwd;
! my $no = join('|',qw(DynaLoader GDBM_File ODBM_File NDBM_File DB_File
! Syslog SysV Langinfo));
$no = qr/^(?:$no)$/i;
my %ext;
***************
*** 27,33 ****
sub noxs_extensions
{
! return grep $ext{$_} eq 'noxs',keys %ext;
}
sub extensions
--- 28,34 ----
sub noxs_extensions
{
! return grep $ext{$_} eq 'nonxs',keys %ext;
}
sub extensions
***************
*** 37,43 ****
sub find_ext
{
! if (/^(.*)\.pm$/i || /^(.*)_pm.PL$/i)
{
my $name = $1;
return if $name =~ $no;
--- 38,44 ----
sub find_ext
{
! if (/^(.*)\.pm$/i || /^(.*)_pm\.PL$/i || /^(.*)\.xs$/i)
{
my $name = $1;
return if $name =~ $no;
diff -c 'perl-5.7.1/win32/Makefile' 'perl-5.7.2/win32/Makefile'
Index: ./win32/Makefile
*** ./win32/Makefile Tue Apr 10 05:29:17 2001
--- ./win32/Makefile Fri Jul 13 17:18:33 2001
***************
*** 1,1220 ****
! #
! # Makefile to build perl on Windows NT using Microsoft NMAKE.
! # Supported compilers:
! # Visual C++ 5.x (possibly other versions)
! #
! # This is set up to build a perl.exe that runs off a shared library
! # (perl57.dll). Also makes individual DLLs for the XS extensions.
! #
!
! ##
! ## Make sure you read README.win32 *before* you mess with anything here!
! ##
!
! ##
! ## Build configuration. Edit the values below to suit your needs.
! ##
!
! #
! # Set these to wherever you want "nmake install" to put your
! # newly built perl.
! #
! INST_DRV = c:
! INST_TOP = $(INST_DRV)\perl
!
! #
! # Comment this out if you DON'T want your perl installation to be versioned.
! # This means that the new installation will overwrite any files from the
! # old installation at the same INST_TOP location. Leaving it enabled is
! # the safest route, as perl adds the extra version directory to all the
! # locations it installs files to. If you disable it, an alternative
! # versioned installation can be obtained by setting INST_TOP above to a
! # path that includes an arbitrary version string.
! #
! #INST_VER = \5.7.1
!
! #
! # Comment this out if you DON'T want your perl installation to have
! # architecture specific components. This means that architecture-
! # specific files will be installed along with the architecture-neutral
! # files. Leaving it enabled is safer and more flexible, in case you
! # want to build multiple flavors of perl and install them together in
! # the same location. Commenting it out gives you a simpler
! # installation that is easier to understand for beginners.
! #
! #INST_ARCH = \$(ARCHNAME)
!
! #
! # uncomment to enable multiple interpreters. This is need for fork()
! # emulation.
! #
! USE_MULTI = define
!
! #
! # Beginnings of interpreter cloning/threads; still very incomplete.
! # This should be enabled to get the fork() emulation. This needs
! # USE_MULTI as well.
! #
! USE_ITHREADS = define
!
! #
! # uncomment to enable the implicit "host" layer for all system calls
! # made by perl. This needs USE_MULTI above. This is also needed to
! # get fork().
! #
! USE_IMP_SYS = define
!
! #
! # uncomment to enable the experimental PerlIO I/O subsystem.
! USE_PERLIO = define
!
! #
! # WARNING! This option is deprecated and will eventually go away (enable
! # USE_ITHREADS instead).
! #
! # uncomment to enable threads-capabilities. This is incompatible with
! # USE_ITHREADS, and is only here for people who may have come to rely
! # on the experimental Thread support that was in 5.005.
! #
! #USE_5005THREADS = define
!
! #
! # WARNING! This option is deprecated and will eventually go away (enable
! # USE_MULTI instead).
! #
! # uncomment next line if you want to use the PERL_OBJECT build option.
! # DO NOT ENABLE unless you have legacy code that relies on the C++
! # CPerlObj class that was available in 5.005. This cannot be enabled
! # if you ask for USE_5005THREADS above.
! #
! #USE_OBJECT = define
!
! #
! # uncomment one of the following lines if you are using either
! # Visual C++ 2.x or Visual C++ 6.x (aka Visual Studio 98)
! #
! #CCTYPE = MSVC20
! #CCTYPE = MSVC60
!
! #
! # uncomment next line if you want debug version of perl (big,slow)
! #
! #CFG = Debug
!
! #
! # uncomment to enable use of PerlCRT.DLL when using the Visual C compiler.
! # It has patches that fix known bugs in older versions of MSVCRT.DLL.
! # This currently requires VC 5.0 with Service Pack 3 or later.
! # Get it from CPAN at http://www.perl.com/CPAN/authors/id/D/DO/DOUGL/
! # and follow the directions in the package to install.
! #
! # Not recommended if you have VC 6.x and you're not running Windows 9x.
! #
! #USE_PERLCRT = define
!
! #
! # uncomment to enable linking with setargv.obj under the Visual C
! # compiler. Setting this options enables perl to expand wildcards in
! # arguments, but it may be harder to use alternate methods like
! # File::DosGlob that are more powerful. This option is supported only with
! # Visual C.
! #
! #USE_SETARGV = define
!
! #
! # if you have the source for des_fcrypt(), uncomment this and make sure the
! # file exists (see README.win32). File should be located in the same
! # directory as this file.
! #
! #CRYPT_SRC = fcrypt.c
!
! #
! # if you didn't set CRYPT_SRC and if you have des_fcrypt() available in a
! # library, uncomment this, and make sure the library exists (see README.win32)
! # Specify the full pathname of the library.
! #
! #CRYPT_LIB = fcrypt.lib
!
! #
! # set this if you wish to use perl's malloc
! # WARNING: Turning this on/off WILL break binary compatibility with extensions
! # you may have compiled with/without it. Be prepared to recompile all
! # extensions if you change the default. Currently, this cannot be enabled
! # if you ask for USE_IMP_SYS above.
! #
! #PERL_MALLOC = define
!
! #
! # set the install locations of the compiler include/libraries
! # Running VCVARS32.BAT is *required* when using Visual C.
! # Some versions of Visual C don't define MSVCDIR in the environment,
! # so you may have to set CCHOME explicitly (spaces in the path name should
! # not be quoted)
! #
! #CCHOME = f:\msvc20
! CCHOME = $(MSVCDIR)
! CCINCDIR = $(CCHOME)\include
! CCLIBDIR = $(CCHOME)\lib
!
! #
! # Additional compiler flags can be specified here.
! #
!
! #
! # This should normally be disabled. Adding -DPERL_POLLUTE enables support
! # for old symbols by default, at the expense of extreme pollution. You most
! # probably just want to build modules that won't compile with
! # perl Makefile.PL POLLUTE=1
! # instead of enabling this. Please report such modules to the respective
! # authors.
! #
! #BUILDOPT = $(BUILDOPT) -DPERL_POLLUTE
!
! #
! # This should normally be disabled. Enabling it will disable the File::Glob
! # implementation of CORE::glob.
! #
! #BUILDOPT = $(BUILDOPT) -DPERL_EXTERNAL_GLOB
!
! #
! # This should normally be disabled. Enabling it causes perl to read scripts
! # in text mode (which is the 5.005 behavior) and will break ByteLoader.
! #BUILDOPT = $(BUILDOPT) -DPERL_TEXTMODE_SCRIPTS
!
! #
! # specify semicolon-separated list of extra directories that modules will
! # look for libraries (spaces in path names need not be quoted)
! #
! EXTRALIBDIRS =
!
! #
! # set this to your email address (perl will guess a value from
! # from your loginname and your hostname, which may not be right)
! #
! #EMAIL =
!
! ##
! ## Build configuration ends.
! ##
!
! ##################### CHANGE THESE ONLY IF YOU MUST #####################
!
! !IF "$(CRYPT_SRC)$(CRYPT_LIB)" == ""
! D_CRYPT = undef
! !ELSE
! D_CRYPT = define
! CRYPT_FLAG = -DHAVE_DES_FCRYPT
! !ENDIF
!
! !IF "$(USE_OBJECT)" == "define"
! PERL_MALLOC = undef
! USE_5005THREADS = undef
! USE_MULTI = undef
! USE_IMP_SYS = define
! !ENDIF
!
! !IF "$(PERL_MALLOC)" == ""
! PERL_MALLOC = undef
! !ENDIF
!
! !IF "$(USE_5005THREADS)" == ""
! USE_5005THREADS = undef
! !ENDIF
!
! !IF "$(USE_5005THREADS)" == "define"
! USE_ITHREADS = undef
! !ENDIF
!
! !IF "$(USE_IMP_SYS)" == "define"
! PERL_MALLOC = undef
! !ENDIF
!
! !IF "$(USE_MULTI)" == ""
! USE_MULTI = undef
! !ENDIF
!
! !IF "$(USE_OBJECT)" == ""
! USE_OBJECT = undef
! !ENDIF
!
! !IF "$(USE_ITHREADS)" == ""
! USE_ITHREADS = undef
! !ENDIF
!
! !IF "$(USE_IMP_SYS)" == ""
! USE_IMP_SYS = undef
! !ENDIF
!
! !IF "$(USE_PERLIO)" == ""
! USE_PERLIO = undef
! !ENDIF
!
! !IF "$(USE_PERLCRT)" == ""
! USE_PERLCRT = undef
! !ENDIF
!
! !IF "$(USE_IMP_SYS)$(USE_MULTI)$(USE_5005THREADS)$(USE_OBJECT)" == "defineundefundefundef"
! USE_MULTI = define
! !ENDIF
!
! !IF "$(USE_ITHREADS)$(USE_MULTI)$(USE_OBJECT)" == "defineundefundef"
! USE_MULTI = define
! USE_5005THREADS = undef
! !ENDIF
!
! !IF "$(USE_MULTI)$(USE_5005THREADS)$(USE_OBJECT)" != "undefundefundef"
! BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_CONTEXT
! !ENDIF
!
! !IF "$(USE_IMP_SYS)" != "undef"
! BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_SYS
! !ENDIF
!
! !IF "$(PROCESSOR_ARCHITECTURE)" == ""
! PROCESSOR_ARCHITECTURE = x86
! !ENDIF
!
! !IF "$(USE_OBJECT)" == "define"
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-object
! !ELSE
! !IF "$(USE_5005THREADS)" == "define"
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-thread
! !ELSE
! !IF "$(USE_MULTI)" == "define"
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-multi
! !ELSE
! !IF "$(USE_PERLIO)" == "define"
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-perlio
! !ELSE
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)
! !ENDIF
! !ENDIF
! !ENDIF
! !ENDIF
!
! !IF "$(USE_PERLIO)" == "define"
! BUILDOPT = $(BUILDOPT) -DUSE_PERLIO
! !ENDIF
!
! !IF "$(USE_ITHREADS)" == "define"
! ARCHNAME = $(ARCHNAME)-thread
! !ENDIF
!
! # Visual Studio 98 specific
! !IF "$(CCTYPE)" == "MSVC60"
!
! # VC 6.0 can load the socket dll on demand. Makes the test suite
! # run in about 10% less time.
! DELAYLOAD = -DELAYLOAD:wsock32.dll -DELAYLOAD:shell32.dll delayimp.lib
! !ENDIF
!
! ARCHDIR = ..\lib\$(ARCHNAME)
! COREDIR = ..\lib\CORE
! AUTODIR = ..\lib\auto
! LIBDIR = ..\lib
! EXTDIR = ..\ext
! PODDIR = ..\pod
! EXTUTILSDIR = $(LIBDIR)\ExtUtils
!
! #
! INST_SCRIPT = $(INST_TOP)$(INST_VER)\bin
! INST_BIN = $(INST_SCRIPT)$(INST_ARCH)
! INST_LIB = $(INST_TOP)$(INST_VER)\lib
! INST_ARCHLIB = $(INST_LIB)$(INST_ARCH)
! INST_COREDIR = $(INST_ARCHLIB)\CORE
! INST_POD = $(INST_LIB)\pod
! INST_HTML = $(INST_TOP)$(INST_VER)\html
!
! #
! # Programs to compile, build .lib files and link
! #
!
! CC = cl
! LINK32 = link
! LIB32 = $(LINK32) -lib
! RSC = rc
!
! #
! # Options
! #
!
! INCLUDES = -I$(COREDIR) -I.\include -I. -I..
! #PCHFLAGS = -Fpc:\temp\vcmoduls.pch -YX
! DEFINES = -DWIN32 -D_CONSOLE -DNO_STRICT $(CRYPT_FLAG)
! LOCDEFS = -DPERLDLL -DPERL_CORE
! SUBSYS = console
! CXX_FLAG = -TP -GX
!
! !IF "$(USE_PERLCRT)" != "define"
! LIBC = msvcrt.lib
! !ELSE
! LIBC = PerlCRT.lib
! !ENDIF
!
! PERLEXE_RES =
! PERLDLL_RES =
!
! !IF "$(CFG)" == "Debug"
! ! IF "$(CCTYPE)" == "MSVC20"
! OPTIMIZE = -Od -MD -Z7 -DDEBUGGING
! ! ELSE
! OPTIMIZE = -Od -MD -Zi -DDEBUGGING
! ! ENDIF
! LINK_DBG = -debug -pdb:none
! !ELSE
! # -O1 yields smaller code, which turns out to be faster than -O2
! #OPTIMIZE = -O2 -MD -DNDEBUG
! OPTIMIZE = -O1 -MD -DNDEBUG
! LINK_DBG = -release
! !ENDIF
!
! !IF "$(USE_OBJECT)" == "define"
! OPTIMIZE = $(OPTIMIZE) $(CXX_FLAG)
! BUILDOPT = $(BUILDOPT) -DPERL_OBJECT
! !ENDIF
!
! !IF "$(USE_PERLCRT)" != "define"
! BUILDOPT = $(BUILDOPT) -DPERL_MSVCRT_READFIX
! !ENDIF
!
! LIBBASEFILES = $(CRYPT_LIB) \
! oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib \
! comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib \
! netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib \
! version.lib odbc32.lib odbccp32.lib
!
! # we add LIBC here, since we may be using PerlCRT.dll
! LIBFILES = $(LIBBASEFILES) $(LIBC)
!
! CFLAGS = -nologo -Gf -W3 $(INCLUDES) $(DEFINES) $(LOCDEFS) \
! $(PCHFLAGS) $(OPTIMIZE)
! LINK_FLAGS = -nologo -nodefaultlib $(LINK_DBG) \
! -libpath:"$(INST_COREDIR)" \
! -machine:$(PROCESSOR_ARCHITECTURE)
! OBJOUT_FLAG = -Fo
! EXEOUT_FLAG = -Fe
!
! CFLAGS_O = $(CFLAGS) $(BUILDOPT)
!
! #################### do not edit below this line #######################
! ############# NO USER-SERVICEABLE PARTS BEYOND THIS POINT ##############
!
! o = .obj
!
! #
! # Rules
! #
!
! .SUFFIXES : .c $(o) .dll .lib .exe .rc .res
!
! .c$(o):
! $(CC) -c -I$(<D) $(CFLAGS_O) $(OBJOUT_FLAG)$@ $<
!
! .y.c:
! $(NOOP)
!
! $(o).dll:
! $(LINK32) -dll -subsystem:windows -implib:$(*B).lib -def:$(*B).def \
! -out:$@ $(LINK_FLAGS) $(LIBFILES) $< $(LIBPERL)
!
! .rc.res:
! $(RSC) -i.. $<
!
! #
! # various targets
!
! # makedef.pl must be updated if this changes, and this should normally
! # only change when there is an incompatible revision of the public API.
! # XXX so why did we change it from perl56 to perl57?
! PERLIMPLIB = ..\perl57.lib
! PERLDLL = ..\perl57.dll
!
! MINIPERL = ..\miniperl.exe
! MINIDIR = .\mini
! PERLEXE = ..\perl.exe
! WPERLEXE = ..\wperl.exe
! GLOBEXE = ..\perlglob.exe
! CONFIGPM = ..\lib\Config.pm
! MINIMOD = ..\lib\ExtUtils\Miniperl.pm
! X2P = ..\x2p\a2p.exe
!
! PL2BAT = bin\pl2bat.pl
! GLOBBAT = bin\perlglob.bat
!
! UTILS = \
! ..\utils\h2ph \
! ..\utils\splain \
! ..\utils\dprofpp \
! ..\utils\perlbug \
! ..\utils\pl2pm \
! ..\utils\c2ph \
! ..\utils\h2xs \
! ..\utils\perldoc \
! ..\utils\perlcc \
! ..\pod\checkpods \
! ..\pod\pod2html \
! ..\pod\pod2latex \
! ..\pod\pod2man \
! ..\pod\pod2text \
! ..\pod\pod2usage \
! ..\pod\podchecker \
! ..\pod\podselect \
! ..\x2p\find2perl \
! ..\x2p\s2p \
! bin\exetype.pl \
! bin\runperl.pl \
! bin\pl2bat.pl \
! bin\perlglob.pl \
! bin\search.pl
!
! MAKE = nmake -nologo
!
! CFGSH_TMPL = config.vc
! CFGH_TMPL = config_H.vc
!
! XCOPY = xcopy /f /r /i /d
! RCOPY = xcopy /f /r /i /e /d
! NOOP = @echo
! NULL =
!
! DEL = bin\mdelete.bat
!
! #
! # filenames given to xsubpp must have forward slashes (since it puts
! # full pathnames in #line strings)
! XSUBPP = ..\$(MINIPERL) -I..\..\lib ..\$(EXTUTILSDIR)\xsubpp \
! -C++ -prototypes
!
! MICROCORE_SRC = \
! ..\av.c \
! ..\deb.c \
! ..\doio.c \
! ..\doop.c \
! ..\dump.c \
! ..\globals.c \
! ..\gv.c \
! ..\hv.c \
! ..\mg.c \
! ..\op.c \
! ..\perl.c \
! ..\perlapi.c \
! ..\perly.c \
! ..\pp.c \
! ..\pp_ctl.c \
! ..\pp_hot.c \
! ..\pp_sys.c \
! ..\regcomp.c \
! ..\regexec.c \
! ..\run.c \
! ..\scope.c \
! ..\sv.c \
! ..\taint.c \
! ..\toke.c \
! ..\universal.c \
! ..\utf8.c \
! ..\util.c \
! ..\xsutils.c
!
! EXTRACORE_SRC = $(EXTRACORE_SRC) perllib.c
!
! !IF "$(PERL_MALLOC)" == "define"
! EXTRACORE_SRC = $(EXTRACORE_SRC) ..\malloc.c
! !ENDIF
!
! !IF "$(USE_OBJECT)" != "define"
! EXTRACORE_SRC = $(EXTRACORE_SRC) ..\perlio.c
! !ENDIF
!
! WIN32_SRC = \
! .\win32.c \
! .\win32sck.c \
! .\win32thread.c
!
! !IF "$(CRYPT_SRC)" != ""
! WIN32_SRC = $(WIN32_SRC) .\$(CRYPT_SRC)
! !ENDIF
!
! DLL_SRC = $(DYNALOADER).c
!
! X2P_SRC = \
! ..\x2p\a2p.c \
! ..\x2p\hash.c \
! ..\x2p\str.c \
! ..\x2p\util.c \
! ..\x2p\walk.c
!
! CORE_NOCFG_H = \
! ..\av.h \
! ..\cop.h \
! ..\cv.h \
! ..\dosish.h \
! ..\embed.h \
! ..\form.h \
! ..\gv.h \
! ..\handy.h \
! ..\hv.h \
! ..\iperlsys.h \
! ..\mg.h \
! ..\nostdio.h \
! ..\op.h \
! ..\opcode.h \
! ..\perl.h \
! ..\perlapi.h \
! ..\perlsdio.h \
! ..\perlsfio.h \
! ..\perly.h \
! ..\pp.h \
! ..\proto.h \
! ..\regexp.h \
! ..\scope.h \
! ..\sv.h \
! ..\thread.h \
! ..\unixish.h \
! ..\utf8.h \
! ..\util.h \
! ..\warnings.h \
! ..\XSUB.h \
! ..\EXTERN.h \
! ..\perlvars.h \
! ..\intrpvar.h \
! ..\thrdvar.h \
! .\include\dirent.h \
! .\include\netdb.h \
! .\include\sys\socket.h \
! .\win32.h
!
! CORE_H = $(CORE_NOCFG_H) .\config.h
!
! MICROCORE_OBJ = $(MICROCORE_SRC:.c=.obj)
! CORE_OBJ = $(MICROCORE_OBJ) $(EXTRACORE_SRC:.c=.obj)
! WIN32_OBJ = $(WIN32_SRC:.c=.obj)
! MINICORE_OBJ = $(MICROCORE_OBJ:..\=.\mini\) \
! $(MINIDIR)\miniperlmain$(o) \
! $(MINIDIR)\perlio$(o)
! MINIWIN32_OBJ = $(WIN32_OBJ:.\=.\mini\)
! MINI_OBJ = $(MINICORE_OBJ) $(MINIWIN32_OBJ)
! DLL_OBJ = $(DLL_SRC:.c=.obj)
! X2P_OBJ = $(X2P_SRC:.c=.obj)
!
! PERLDLL_OBJ = $(CORE_OBJ)
! PERLEXE_OBJ = perlmain$(o)
!
! PERLDLL_OBJ = $(PERLDLL_OBJ) $(WIN32_OBJ) $(DLL_OBJ)
! #PERLEXE_OBJ = $(PERLEXE_OBJ) $(WIN32_OBJ) $(DLL_OBJ)
!
! !IF "$(USE_SETARGV)" != ""
! SETARGV_OBJ = setargv$(o)
! !ENDIF
!
! DYNAMIC_EXT = Socket IO Fcntl Opcode SDBM_File POSIX attrs Thread B re \
! Data/Dumper Devel/Peek ByteLoader Devel/DProf File/Glob \
! Sys/Hostname Storable Filter/Util/Call Encode Digest/MD5 \
! PerlIO/Scalar MIME/Base64
! STATIC_EXT = DynaLoader
! NONXS_EXT = Errno
!
! DYNALOADER = $(EXTDIR)\DynaLoader\DynaLoader
! SOCKET = $(EXTDIR)\Socket\Socket
! FCNTL = $(EXTDIR)\Fcntl\Fcntl
! OPCODE = $(EXTDIR)\Opcode\Opcode
! SDBM_FILE = $(EXTDIR)\SDBM_File\SDBM_File
! IO = $(EXTDIR)\IO\IO
! POSIX = $(EXTDIR)\POSIX\POSIX
! ATTRS = $(EXTDIR)\attrs\attrs
! THREAD = $(EXTDIR)\Thread\Thread
! B = $(EXTDIR)\B\B
! RE = $(EXTDIR)\re\re
! DUMPER = $(EXTDIR)\Data\Dumper\Dumper
! ERRNO = $(EXTDIR)\Errno\Errno
! PEEK = $(EXTDIR)\Devel\Peek\Peek
! BYTELOADER = $(EXTDIR)\ByteLoader\ByteLoader
! DPROF = $(EXTDIR)\Devel\DProf\DProf
! GLOB = $(EXTDIR)\File\Glob\Glob
! HOSTNAME = $(EXTDIR)\Sys\Hostname\Hostname
! STORABLE = $(EXTDIR)\Storable\Storable
! FILTER = $(EXTDIR)\Filter\Util\Call\Call
! ENCODE = $(EXTDIR)\Encode\Encode
! MD5 = $(EXTDIR)\Digest\MD5\MD5
! PERLIOSCALAR = $(EXTDIR)\PerlIO\Scalar\Scalar
! MIMEBASE64 = $(EXTDIR)\MIME\Base64\Base64
!
! SOCKET_DLL = $(AUTODIR)\Socket\Socket.dll
! FCNTL_DLL = $(AUTODIR)\Fcntl\Fcntl.dll
! OPCODE_DLL = $(AUTODIR)\Opcode\Opcode.dll
! SDBM_FILE_DLL = $(AUTODIR)\SDBM_File\SDBM_File.dll
! IO_DLL = $(AUTODIR)\IO\IO.dll
! POSIX_DLL = $(AUTODIR)\POSIX\POSIX.dll
! ATTRS_DLL = $(AUTODIR)\attrs\attrs.dll
! THREAD_DLL = $(AUTODIR)\Thread\Thread.dll
! B_DLL = $(AUTODIR)\B\B.dll
! DUMPER_DLL = $(AUTODIR)\Data\Dumper\Dumper.dll
! PEEK_DLL = $(AUTODIR)\Devel\Peek\Peek.dll
! RE_DLL = $(AUTODIR)\re\re.dll
! BYTELOADER_DLL = $(AUTODIR)\ByteLoader\ByteLoader.dll
! DPROF_DLL = $(AUTODIR)\Devel\DProf\DProf.dll
! GLOB_DLL = $(AUTODIR)\File\Glob\Glob.dll
! HOSTNAME_DLL = $(AUTODIR)\Sys\Hostname\Hostname.dll
! STORABLE_DLL = $(AUTODIR)\Storable\Storable.dll
! FILTER_DLL = $(AUTODIR)\Filter\Util\Call\Call.dll
! ENCODE_DLL = $(AUTODIR)\Encode\Encode.dll
! MD5_DLL = $(AUTODIR)\Digest\MD5\MD5.dll
! PERLIOSCALAR_DLL= $(AUTODIR)\PerlIO\Scalar\Scalar.dll
! MIMEBASE64_DLL = $(AUTODIR)\MIME\Base64\Base64.dll
!
! ERRNO_PM = $(LIBDIR)\Errno.pm
!
! EXTENSION_C = \
! $(SOCKET).c \
! $(FCNTL).c \
! $(OPCODE).c \
! $(SDBM_FILE).c \
! $(IO).c \
! $(POSIX).c \
! $(ATTRS).c \
! $(THREAD).c \
! $(RE).c \
! $(DUMPER).c \
! $(PEEK).c \
! $(B).c \
! $(BYTELOADER).c \
! $(DPROF).c \
! $(GLOB).c \
! $(HOSTNAME).c \
! $(STORABLE).c \
! $(FILTER).c \
! $(ENCODE).c \
! $(MD5).c \
! $(PERLIOSCALAR).c
!
! EXTENSION_DLL = \
! $(SOCKET_DLL) \
! $(FCNTL_DLL) \
! $(OPCODE_DLL) \
! $(SDBM_FILE_DLL)\
! $(IO_DLL) \
! $(POSIX_DLL) \
! $(ATTRS_DLL) \
! $(DUMPER_DLL) \
! $(PEEK_DLL) \
! $(B_DLL) \
! $(RE_DLL) \
! $(THREAD_DLL) \
! $(BYTELOADER_DLL) \
! $(DPROF_DLL) \
! $(GLOB_DLL) \
! $(HOSTNAME_DLL) \
! $(STORABLE_DLL) \
! $(FILTER_DLL) \
! $(ENCODE_DLL) \
! $(MD5_DLL) \
! $(PERLIOSCALAR_DLL)
!
! EXTENSION_PM = \
! $(ERRNO_PM)
!
! POD2HTML = $(PODDIR)\pod2html
! POD2MAN = $(PODDIR)\pod2man
! POD2LATEX = $(PODDIR)\pod2latex
! POD2TEXT = $(PODDIR)\pod2text
!
! CFG_VARS = \
! "INST_DRV=$(INST_DRV)" \
! "INST_TOP=$(INST_TOP)" \
! "INST_VER=$(INST_VER)" \
! "INST_ARCH=$(INST_ARCH)" \
! "archname=$(ARCHNAME)" \
! "cc=$(CC)" \
! "ld=$(LINK32)" \
! "ccflags=-nologo -Gf -W3 $(OPTIMIZE:"=\") $(DEFINES) $(BUILDOPT)" \
! "cf_email=$(EMAIL)" \
! "d_crypt=$(D_CRYPT)" \
! "d_mymalloc=$(PERL_MALLOC)" \
! "libs=$(LIBFILES)" \
! "incpath=$(CCINCDIR:"=\")" \
! "libperl=$(PERLIMPLIB:..\=)" \
! "libpth=$(CCLIBDIR:"=\");$(EXTRALIBDIRS:"=\")" \
! "libc=$(LIBC)" \
! "make=nmake" \
! "static_ext=$(STATIC_EXT)" \
! "dynamic_ext=$(DYNAMIC_EXT)" \
! "nonxs_ext=$(NONXS_EXT)" \
! "use5005threads=$(USE_5005THREADS)" \
! "useithreads=$(USE_ITHREADS)" \
! "usethreads=$(USE_5005THREADS)" \
! "usemultiplicity=$(USE_MULTI)" \
! "useperlio=$(USE_PERLIO)" \
! "LINK_FLAGS=$(LINK_FLAGS:"=\")" \
! "optimize=$(OPTIMIZE:"=\")"
!
! #
! # Top targets
! #
!
! all : .\config.h $(GLOBEXE) $(MINIMOD) $(CONFIGPM) $(PERLEXE) \
! $(X2P) $(EXTENSION_DLL) $(EXTENSION_PM)
!
! $(DYNALOADER)$(o) : $(DYNALOADER).c $(CORE_H) $(EXTDIR)\DynaLoader\dlutils.c
!
! #------------------------------------------------------------
!
! $(GLOBEXE) : perlglob$(o)
! $(LINK32) $(LINK_FLAGS) $(LIBFILES) -out:$@ -subsystem:$(SUBSYS) \
! perlglob$(o) setargv$(o)
!
! perlglob$(o) : perlglob.c
!
! config.w32 : $(CFGSH_TMPL)
! copy $(CFGSH_TMPL) config.w32
!
! .\config.h : $(CFGH_TMPL)
! -del /f config.h
! copy $(CFGH_TMPL) config.h
!
! ..\config.sh : config.w32 $(MINIPERL) config_sh.PL
! $(MINIPERL) -I..\lib config_sh.PL $(CFG_VARS) config.w32 > ..\config.sh
!
! # this target is for when changes to the main config.sh happen
! # edit config.{b,v,g}c and make this target once for each supported
! # compiler (e.g. `nmake CCTYPE=BORLAND regen_config_h`)
! regen_config_h:
! perl config_sh.PL $(CFG_VARS) $(CFGSH_TMPL) > ..\config.sh
! cd ..
! -del /f perl.exe
! perl configpm
! cd win32
! -del /f $(CFGH_TMPL)
! -mkdir $(COREDIR)
! -perl -I..\lib config_h.PL "INST_VER=$(INST_VER)"
! rename config.h $(CFGH_TMPL)
!
! $(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl
! cd ..
! miniperl configpm
! cd win32
! if exist lib\* $(RCOPY) lib\*.* ..\lib\$(NULL)
! $(XCOPY) ..\*.h $(COREDIR)\*.*
! $(XCOPY) *.h $(COREDIR)\*.*
! $(XCOPY) ..\ext\re\re.pm $(LIBDIR)\*.*
! $(RCOPY) include $(COREDIR)\*.*
! -$(MINIPERL) -I..\lib config_h.PL "INST_VER=$(INST_VER)"
! if errorlevel 1 $(MAKE) /$(MAKEFLAGS) $(CONFIGPM)
!
! $(MINIPERL) : $(MINIDIR) $(MINI_OBJ)
! $(LINK32) -subsystem:console -out:$@ @<<
! $(LINK_FLAGS) $(LIBFILES) $(MINI_OBJ)
! <<
!
! $(MINIDIR) :
! if not exist "$(MINIDIR)" mkdir "$(MINIDIR)"
!
! $(MINICORE_OBJ) : $(CORE_NOCFG_H)
! $(CC) -c $(CFLAGS) -DPERL_EXTERNAL_GLOB $(OBJOUT_FLAG)$@ ..\$(*F).c
!
! $(MINIWIN32_OBJ) : $(CORE_NOCFG_H)
! $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $(*F).c
!
! # -DPERL_IMPLICIT_SYS needs C++ for perllib.c
! # This is the only file that depends on perlhost.h, vmem.h, and vdir.h
! !IF "$(USE_IMP_SYS)$(USE_OBJECT)" == "defineundef"
! perllib$(o) : perllib.c .\perlhost.h .\vdir.h .\vmem.h
! $(CC) -c -I. $(CFLAGS_O) $(CXX_FLAG) $(OBJOUT_FLAG)$@ perllib.c
! !ENDIF
!
! # 1. we don't want to rebuild miniperl.exe when config.h changes
! # 2. we don't want to rebuild miniperl.exe with non-default config.h
! $(MINI_OBJ) : $(CORE_NOCFG_H)
!
! $(WIN32_OBJ) : $(CORE_H)
! $(CORE_OBJ) : $(CORE_H)
! $(DLL_OBJ) : $(CORE_H)
! $(X2P_OBJ) : $(CORE_H)
!
! perldll.def : $(MINIPERL) $(CONFIGPM) ..\global.sym ..\pp.sym ..\makedef.pl
! $(MINIPERL) -w ..\makedef.pl PLATFORM=win32 $(OPTIMIZE) $(DEFINES) $(BUILDOPT) \
! CCTYPE=$(CCTYPE) > perldll.def
!
! $(PERLDLL): perldll.def $(PERLDLL_OBJ) $(PERLDLL_RES)
! $(LINK32) -dll -def:perldll.def -base:0x28000000 -out:$@ @<<
! $(LINK_FLAGS) $(DELAYLOAD) $(LIBFILES) $(PERLDLL_OBJ) $(PERLDLL_RES)
! <<
! $(XCOPY) $(PERLIMPLIB) $(COREDIR)
!
! $(MINIMOD) : $(MINIPERL) ..\minimod.pl
! cd ..
! miniperl minimod.pl > lib\ExtUtils\Miniperl.pm
! cd win32
!
! ..\x2p\a2p$(o) : ..\x2p\a2p.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\a2p.c
!
! ..\x2p\hash$(o) : ..\x2p\hash.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\hash.c
!
! ..\x2p\str$(o) : ..\x2p\str.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\str.c
!
! ..\x2p\util$(o) : ..\x2p\util.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\util.c
!
! ..\x2p\walk$(o) : ..\x2p\walk.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\walk.c
!
! $(X2P) : $(MINIPERL) $(X2P_OBJ)
! $(MINIPERL) ..\x2p\find2perl.PL
! $(MINIPERL) ..\x2p\s2p.PL
! $(LINK32) -subsystem:console -out:$@ @<<
! $(LINK_FLAGS) $(LIBFILES) $(X2P_OBJ)
! <<
!
! perlmain.c : runperl.c
! copy runperl.c perlmain.c
!
! perlmain$(o) : perlmain.c
! $(CC) $(CFLAGS_O) -UPERLDLL $(OBJOUT_FLAG)$@ -c perlmain.c
!
! $(PERLEXE): $(PERLDLL) $(CONFIGPM) $(PERLEXE_OBJ) $(PERLEXE_RES)
! $(LINK32) -subsystem:console -out:$@ -stack:0x1000000 $(LINK_FLAGS) \
! $(LIBFILES) $(PERLEXE_OBJ) $(SETARGV_OBJ) $(PERLIMPLIB) $(PERLEXE_RES)
! copy $(PERLEXE) $(WPERLEXE)
! $(MINIPERL) -I..\lib bin\exetype.pl $(WPERLEXE) WINDOWS
! copy splittree.pl ..
! $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR)
!
! $(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM)
! if not exist $(AUTODIR) mkdir $(AUTODIR)
! cd $(EXTDIR)\$(*B)
! ..\$(MINIPERL) -I..\..\lib $(*B)_pm.PL
! ..\$(MINIPERL) -I..\..\lib XSLoader_pm.PL
! cd ..\..\win32
! $(XCOPY) $(EXTDIR)\$(*B)\$(*B).pm $(LIBDIR)\$(NULL)
! $(XCOPY) $(EXTDIR)\$(*B)\XSLoader.pm $(LIBDIR)\$(NULL)
! cd $(EXTDIR)\$(*B)
! $(XSUBPP) dl_win32.xs > $(*B).c
! cd ..\..\win32
!
! $(EXTDIR)\DynaLoader\dl_win32.xs: dl_win32.xs
! copy dl_win32.xs $(EXTDIR)\DynaLoader\dl_win32.xs
!
! $(DUMPER_DLL): $(PERLEXE) $(DUMPER).xs
! cd $(EXTDIR)\Data\$(*B)
! ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\..\win32
!
! $(DPROF_DLL): $(PERLEXE) $(DPROF).xs
! cd $(EXTDIR)\Devel\$(*B)
! ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\..\win32
!
! $(GLOB_DLL): $(PERLEXE) $(GLOB).xs
! cd $(EXTDIR)\File\$(*B)
! ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\..\win32
!
! $(PEEK_DLL): $(PERLEXE) $(PEEK).xs
! cd $(EXTDIR)\Devel\$(*B)
! ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\..\win32
!
! $(RE_DLL): $(PERLEXE) $(RE).xs
! cd $(EXTDIR)\$(*B)
! ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\win32
!
! $(B_DLL): $(PERLEXE) $(B).xs
! cd $(EXTDIR)\$(*B)
! ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\win32
!
! $(THREAD_DLL): $(PERLEXE) $(THREAD).xs
! cd $(EXTDIR)\$(*B)
! ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\win32
!
! $(ATTRS_DLL): $(PERLEXE) $(ATTRS).xs
! cd $(EXTDIR)\$(*B)
! ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\win32
!
! $(POSIX_DLL): $(PERLEXE) $(POSIX).xs
! cd $(EXTDIR)\$(*B)
! ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\win32
!
! $(IO_DLL): $(PERLEXE) $(IO).xs
! cd $(EXTDIR)\$(*B)
! ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\win32
!
! $(SDBM_FILE_DLL) : $(PERLEXE) $(SDBM_FILE).xs
! cd $(EXTDIR)\$(*B)
! ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\win32
!
! $(FCNTL_DLL): $(PERLEXE) $(FCNTL).xs
! cd $(EXTDIR)\$(*B)
! ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\win32
!
! $(OPCODE_DLL): $(PERLEXE) $(OPCODE).xs
! cd $(EXTDIR)\$(*B)
! ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\win32
!
! $(SOCKET_DLL): $(PERLEXE) $(SOCKET).xs
! cd $(EXTDIR)\$(*B)
! ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\win32
!
! $(HOSTNAME_DLL): $(PERLEXE) $(HOSTNAME).xs
! cd $(EXTDIR)\Sys\$(*B)
! ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\..\win32
!
! $(BYTELOADER_DLL): $(PERLEXE) $(BYTELOADER).xs
! cd $(EXTDIR)\$(*B)
! ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\win32
!
! $(STORABLE_DLL): $(PERLEXE) $(STORABLE).xs
! cd $(EXTDIR)\$(*B)
! ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\win32
!
! $(FILTER_DLL): $(PERLEXE) $(FILTER).xs
! cd $(EXTDIR)\Filter\Util\Call
! ..\..\..\..\miniperl -I..\..\..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\..\..\win32
!
! $(ENCODE_DLL): $(PERLEXE) $(ENCODE).xs
! cd $(EXTDIR)\$(*B)
! ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\win32
!
! $(MD5_DLL): $(PERLEXE) $(MD5).xs
! cd $(EXTDIR)\$(*B)
! ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\win32
!
! $(PERLIOSCALAR_DLL): $(PERLEXE) $(PERLIOSCALAR).xs
! cd $(EXTDIR)\$(*B)
! ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\win32
!
! $(ERRNO_PM): $(PERLEXE) $(ERRNO)_pm.PL
! cd $(EXTDIR)\$(*B)
! ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
! $(MAKE)
! cd ..\..\win32
!
! doc: $(PERLEXE)
! $(PERLEXE) -I..\lib ..\installhtml --podroot=.. --htmldir=./html \
! --podpath=pod:lib:ext:utils --htmlroot="file://$(INST_HTML::=|)" \
! --libpod=perlfunc:perlguts:perlvar:perlrun:perlop --recurse
!
! utils: $(PERLEXE) $(X2P)
! cd ..\utils
! $(MAKE) PERL=$(MINIPERL)
! cd ..\pod
! copy ..\README.aix .\perlaix.pod
! copy ..\README.amiga .\perlamiga.pod
! copy ..\README.bs2000 .\perlbs2000.pod
! copy ..\README.cygwin .\perlcygwin.pod
! copy ..\README.dos .\perldos.pod
! copy ..\README.epoc .\perlepoc.pod
! copy ..\README.hpux .\perlhpux.pod
! copy ..\README.machten .\perlmachten.pod
! copy ..\README.macos .\perlmacos.pod
! copy ..\README.mpeix .\perlmpeix.pod
! copy ..\README.os2 .\perlos2.pod
! copy ..\README.os390 .\perlos390.pod
! copy ..\README.solaris .\perlsolaris.pod
! copy ..\README.vmesa .\perlvmesa.pod
! copy ..\vms\perlvms.pod .\perlvms.pod
! copy ..\README.vos .\perlvos.pod
! copy ..\README.win32 .\perlwin32.pod
! $(MAKE) -f ..\win32\pod.mak converters
! cd ..\lib
! $(PERLEXE) lib_pm.PL
! cd ..\win32
! $(PERLEXE) $(PL2BAT) $(UTILS)
!
! distclean: clean
! -del /f $(MINIPERL) $(PERLEXE) $(PERLDLL) $(GLOBEXE) \
! $(PERLIMPLIB) ..\miniperl.lib $(MINIMOD)
! -del /f *.def *.map
! -del /f $(EXTENSION_DLL) $(EXTENSION_PM)
! -del /f $(EXTENSION_C) $(DYNALOADER).c $(ERRNO).pm
! -del /f $(EXTDIR)\DynaLoader\dl_win32.xs
! -del /f $(LIBDIR)\.exists $(LIBDIR)\attrs.pm $(LIBDIR)\DynaLoader.pm
! -del /f $(LIBDIR)\XSLoader.pm
! -del /f $(LIBDIR)\Fcntl.pm $(LIBDIR)\IO.pm $(LIBDIR)\Opcode.pm
! -del /f $(LIBDIR)\ops.pm $(LIBDIR)\Safe.pm $(LIBDIR)\Thread.pm
! -del /f $(LIBDIR)\SDBM_File.pm $(LIBDIR)\Socket.pm $(LIBDIR)\POSIX.pm
! -del /f $(LIBDIR)\B.pm $(LIBDIR)\O.pm $(LIBDIR)\re.pm
! -del /f $(LIBDIR)\Data\Dumper.pm $(LIBDIR)\ByteLoader.pm
! -del /f $(LIBDIR)\Devel\Peek.pm $(LIBDIR)\Devel\DProf.pm
! -del /f $(LIBDIR)\File\Glob.pm
! -del /f $(LIBDIR)\Storable.pm
! -del /f $(LIBDIR)\Filter\Util\Call\Call.pm
! -del /f $(LIBDIR)\Digest\MD5.pm
! -del /f $(LIBDIR)\PerlIO\Scalar\Scalar.pm
! -del /f $(LIBDIR)\MIME\Base64\Base64.pm
! -del /f $(LIBDIR)\MIME\Base64\QuotedPrint.pm
! -if exist $(LIBDIR)\IO rmdir /s /q $(LIBDIR)\IO
! -rmdir /s $(LIBDIR)\IO
! -if exist $(LIBDIR)\Thread rmdir /s /q $(LIBDIR)\Thread
! -rmdir /s $(LIBDIR)\Thread
! -if exist $(LIBDIR)\B rmdir /s /q $(LIBDIR)\B
! -rmdir /s $(LIBDIR)\B
! -if exist $(LIBDIR)\Data rmdir /s /q $(LIBDIR)\Data
! -rmdir /s $(LIBDIR)\Data
! -if exist $(LIBDIR)\Filter\Util\Call rmdir /s /q $(LIBDIR)\Filter\Util\Call
! -if exist $(LIBDIR)\Filter\Util rmdir /s /q $(LIBDIR)\Filter\Util
! -if exist $(LIBDIR)\Digest\MD5 rmdir /s /q $(LIBDIR)\Digest\MD5
! -rmdir /s $(LIBDIR)\Digest\MD5
! -if exist $(LIBDIR)\Digest rmdir /s /q $(LIBDIR)\Digest
! -rmdir /s $(LIBDIR)\Digest
! -if exist $(LIBDIR)\MIME\Base64 rmdir /s /q $(LIBDIR)\MIME\Base64
! -rmdir /s $(LIBDIR)\MIME\Base64
! -if exist $(LIBDIR)\MIME rmdir /s /q $(LIBDIR)\MIME
! -rmdir /s $(LIBDIR)\MIME
! cd $(PODDIR)
! -del /f *.html *.bat checkpods \
! perlaix.pod perlamiga.pod perlbs2000.pod perlcygwin.pod \
! perldos.pod perlepoc.pod perlhpux.pod perlmachten.pod \
! perlmacos.pod perlmpeix.pod perlos2.pod perlos390.pod \
! perlsolaris.pod perlvmesa.pod perlvms.pod perlvos.pod \
! perlwin32.pod pod2html pod2latex pod2man pod2text pod2usage \
! podchecker podselect
! cd ..\utils
! -del /f h2ph splain perlbug pl2pm c2ph h2xs perldoc dprofpp
! -del /f *.bat
! cd ..\win32
! cd ..\x2p
! -del /f find2perl s2p
! -del /f *.bat
! cd ..\win32
! -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c config.h.new
! -del /f $(CONFIGPM)
! -del /f bin\*.bat
! cd $(EXTDIR)
! -del /s *.lib *.def *.map *.pdb *.bs Makefile *$(o) pm_to_blib
! cd ..\win32
! -if exist $(AUTODIR) rmdir /s /q $(AUTODIR)
! -rmdir /s $(AUTODIR)
! -if exist $(COREDIR) rmdir /s /q $(COREDIR)
! -rmdir /s $(COREDIR)
!
! install : all installbare installhtml
!
! installbare : utils
! $(PERLEXE) ..\installperl
! if exist $(WPERLEXE) $(XCOPY) $(WPERLEXE) $(INST_BIN)\*.*
! $(XCOPY) $(GLOBEXE) $(INST_BIN)\*.*
! $(XCOPY) bin\*.bat $(INST_SCRIPT)\*.*
!
! installhtml : doc
! $(RCOPY) html\*.* $(INST_HTML)\*.*
!
! inst_lib : $(CONFIGPM)
! copy splittree.pl ..
! $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR)
! $(RCOPY) ..\lib $(INST_LIB)\*.*
!
! minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) utils
! $(XCOPY) $(MINIPERL) ..\t\perl.exe
! $(XCOPY) $(GLOBEXE) ..\t\$(NULL)
! attrib -r ..\t\*.*
! copy test ..\t
! cd ..\t
! $(MINIPERL) -I..\lib test base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t
! cd ..\win32
!
! test-prep : all utils
! $(XCOPY) $(PERLEXE) ..\t\$(NULL)
! $(XCOPY) $(PERLDLL) ..\t\$(NULL)
! $(XCOPY) $(GLOBEXE) ..\t\$(NULL)
!
! test : test-prep
! cd ..\t
! $(PERLEXE) -I..\lib harness
! cd ..\win32
!
! test-notty : test-prep
! set PERL_SKIP_TTY_TEST=1
! cd ..\t
! $(PERLEXE) -I..\lib harness
! cd ..\win32
!
! test-wide : test-prep
! set HARNESS_PERL_SWITCHES=-C
! cd ..\t
! $(PERLEXE) -I..\lib harness
! cd ..\win32
!
! test-wide-notty : test-prep
! set PERL_SKIP_TTY_TEST=1
! set HARNESS_PERL_SWITCHES=-C
! cd ..\t
! $(PERLEXE) -I..\lib harness
! cd ..\win32
!
! clean :
! -@$(DEL) miniperlmain$(o)
! -@$(DEL) $(MINIPERL)
! -@$(DEL) perlglob$(o)
! -@$(DEL) perlmain$(o)
! -@$(DEL) config.w32
! -@$(DEL) /f config.h
! -@$(DEL) $(GLOBEXE)
! -@$(DEL) $(PERLEXE)
! -@$(DEL) $(WPERLEXE)
! -@$(DEL) $(PERLDLL)
! -@$(DEL) $(CORE_OBJ)
! -if exist $(MINIDIR) rmdir /s /q $(MINIDIR)
! -rmdir /s $(MINIDIR)
! -@$(DEL) $(WIN32_OBJ)
! -@$(DEL) $(DLL_OBJ)
! -@$(DEL) $(X2P_OBJ)
! -@$(DEL) ..\*$(o) ..\*.lib ..\*.exp *$(o) *.lib *.exp *.res
! -@$(DEL) ..\t\*.exe ..\t\*.dll ..\t\*.bat
! -@$(DEL) ..\x2p\*.exe ..\x2p\*.bat
! -@$(DEL) *.ilk
! -@$(DEL) *.pdb
!
! # Handy way to run perlbug -ok without having to install and run the
! # installed perlbug. We don't re-run the tests here - we trust the user.
! # Please *don't* use this unless all tests pass.
! # If you want to report test failures, use "nmake nok" instead.
! ok: utils
! $(PERLEXE) -I..\lib ..\utils\perlbug -ok -s "(UNINSTALLED)"
!
! okfile: utils
! $(PERLEXE) -I..\lib ..\utils\perlbug -ok -s "(UNINSTALLED)" -F perl.ok
!
! nok: utils
! $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)"
!
! nokfile: utils
! $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)" -F perl.nok
--- 1,1141 ----
! #
! # Makefile to build perl on Windows NT using Microsoft NMAKE.
! # Supported compilers:
! # Visual C++ 5.x (possibly other versions)
! #
! # This is set up to build a perl.exe that runs off a shared library
! # (perl57.dll). Also makes individual DLLs for the XS extensions.
! #
!
! ##
! ## Make sure you read README.win32 *before* you mess with anything here!
! ##
!
! ##
! ## Build configuration. Edit the values below to suit your needs.
! ##
!
! #
! # Set these to wherever you want "nmake install" to put your
! # newly built perl.
! #
! INST_DRV = c:
! INST_TOP = $(INST_DRV)\perl
!
! #
! # Comment this out if you DON'T want your perl installation to be versioned.
! # This means that the new installation will overwrite any files from the
! # old installation at the same INST_TOP location. Leaving it enabled is
! # the safest route, as perl adds the extra version directory to all the
! # locations it installs files to. If you disable it, an alternative
! # versioned installation can be obtained by setting INST_TOP above to a
! # path that includes an arbitrary version string.
! #
! #INST_VER = \5.7.2
!
! #
! # Comment this out if you DON'T want your perl installation to have
! # architecture specific components. This means that architecture-
! # specific files will be installed along with the architecture-neutral
! # files. Leaving it enabled is safer and more flexible, in case you
! # want to build multiple flavors of perl and install them together in
! # the same location. Commenting it out gives you a simpler
! # installation that is easier to understand for beginners.
! #
! #INST_ARCH = \$(ARCHNAME)
!
! #
! # uncomment to enable multiple interpreters. This is need for fork()
! # emulation.
! #
! USE_MULTI = define
!
! #
! # Beginnings of interpreter cloning/threads; still very incomplete.
! # This should be enabled to get the fork() emulation. This needs
! # USE_MULTI as well.
! #
! USE_ITHREADS = define
!
! #
! # uncomment to enable the implicit "host" layer for all system calls
! # made by perl. This needs USE_MULTI above. This is also needed to
! # get fork().
! #
! USE_IMP_SYS = define
!
! #
! # uncomment to enable the experimental PerlIO I/O subsystem.
! USE_PERLIO = define
!
! #
! # WARNING! This option is deprecated and will eventually go away (enable
! # USE_ITHREADS instead).
! #
! # uncomment to enable threads-capabilities. This is incompatible with
! # USE_ITHREADS, and is only here for people who may have come to rely
! # on the experimental Thread support that was in 5.005.
! #
! #USE_5005THREADS = define
!
! #
! # WARNING! This option is deprecated and will eventually go away (enable
! # USE_MULTI instead).
! #
! # uncomment next line if you want to use the PERL_OBJECT build option.
! # DO NOT ENABLE unless you have legacy code that relies on the C++
! # CPerlObj class that was available in 5.005. This cannot be enabled
! # if you ask for USE_5005THREADS above.
! #
! #USE_OBJECT = define
!
! #
! # uncomment one of the following lines if you are using either
! # Visual C++ 2.x or Visual C++ 6.x (aka Visual Studio 98)
! #
! #CCTYPE = MSVC20
! #CCTYPE = MSVC60
!
! #
! # uncomment next line if you want debug version of perl (big,slow)
! #
! #CFG = Debug
!
! #
! # uncomment to enable use of PerlCRT.DLL when using the Visual C compiler.
! # It has patches that fix known bugs in older versions of MSVCRT.DLL.
! # This currently requires VC 5.0 with Service Pack 3 or later.
! # Get it from CPAN at http://www.perl.com/CPAN/authors/id/D/DO/DOUGL/
! # and follow the directions in the package to install.
! #
! # Not recommended if you have VC 6.x and you're not running Windows 9x.
! #
! #USE_PERLCRT = define
!
! #
! # uncomment to enable linking with setargv.obj under the Visual C
! # compiler. Setting this options enables perl to expand wildcards in
! # arguments, but it may be harder to use alternate methods like
! # File::DosGlob that are more powerful. This option is supported only with
! # Visual C.
! #
! #USE_SETARGV = define
!
! #
! # if you have the source for des_fcrypt(), uncomment this and make sure the
! # file exists (see README.win32). File should be located in the same
! # directory as this file.
! #
! #CRYPT_SRC = fcrypt.c
!
! #
! # if you didn't set CRYPT_SRC and if you have des_fcrypt() available in a
! # library, uncomment this, and make sure the library exists (see README.win32)
! # Specify the full pathname of the library.
! #
! #CRYPT_LIB = fcrypt.lib
!
! #
! # set this if you wish to use perl's malloc
! # WARNING: Turning this on/off WILL break binary compatibility with extensions
! # you may have compiled with/without it. Be prepared to recompile all
! # extensions if you change the default. Currently, this cannot be enabled
! # if you ask for USE_IMP_SYS above.
! #
! #PERL_MALLOC = define
!
! #
! # set the install locations of the compiler include/libraries
! # Running VCVARS32.BAT is *required* when using Visual C.
! # Some versions of Visual C don't define MSVCDIR in the environment,
! # so you may have to set CCHOME explicitly (spaces in the path name should
! # not be quoted)
! #
! #CCHOME = f:\msvc20
! CCHOME = $(MSVCDIR)
! CCINCDIR = $(CCHOME)\include
! CCLIBDIR = $(CCHOME)\lib
!
! #
! # Additional compiler flags can be specified here.
! #
!
! #
! # This should normally be disabled. Adding -DPERL_POLLUTE enables support
! # for old symbols by default, at the expense of extreme pollution. You most
! # probably just want to build modules that won't compile with
! # perl Makefile.PL POLLUTE=1
! # instead of enabling this. Please report such modules to the respective
! # authors.
! #
! #BUILDOPT = $(BUILDOPT) -DPERL_POLLUTE
!
! #
! # This should normally be disabled. Enabling it will disable the File::Glob
! # implementation of CORE::glob.
! #
! #BUILDOPT = $(BUILDOPT) -DPERL_EXTERNAL_GLOB
!
! #
! # This should normally be disabled. Enabling it causes perl to read scripts
! # in text mode (which is the 5.005 behavior) and will break ByteLoader.
! #BUILDOPT = $(BUILDOPT) -DPERL_TEXTMODE_SCRIPTS
!
! #
! # specify semicolon-separated list of extra directories that modules will
! # look for libraries (spaces in path names need not be quoted)
! #
! EXTRALIBDIRS =
!
! #
! # set this to your email address (perl will guess a value from
! # from your loginname and your hostname, which may not be right)
! #
! #EMAIL =
!
! ##
! ## Build configuration ends.
! ##
!
! ##################### CHANGE THESE ONLY IF YOU MUST #####################
!
! !IF "$(CRYPT_SRC)$(CRYPT_LIB)" == ""
! D_CRYPT = undef
! !ELSE
! D_CRYPT = define
! CRYPT_FLAG = -DHAVE_DES_FCRYPT
! !ENDIF
!
! !IF "$(USE_OBJECT)" == "define"
! PERL_MALLOC = undef
! USE_5005THREADS = undef
! USE_MULTI = undef
! USE_IMP_SYS = define
! !ENDIF
!
! !IF "$(PERL_MALLOC)" == ""
! PERL_MALLOC = undef
! !ENDIF
!
! !IF "$(USE_5005THREADS)" == ""
! USE_5005THREADS = undef
! !ENDIF
!
! !IF "$(USE_5005THREADS)" == "define"
! USE_ITHREADS = undef
! !ENDIF
!
! !IF "$(USE_IMP_SYS)" == "define"
! PERL_MALLOC = undef
! !ENDIF
!
! !IF "$(USE_MULTI)" == ""
! USE_MULTI = undef
! !ENDIF
!
! !IF "$(USE_OBJECT)" == ""
! USE_OBJECT = undef
! !ENDIF
!
! !IF "$(USE_ITHREADS)" == ""
! USE_ITHREADS = undef
! !ENDIF
!
! !IF "$(USE_IMP_SYS)" == ""
! USE_IMP_SYS = undef
! !ENDIF
!
! !IF "$(USE_PERLIO)" == ""
! USE_PERLIO = undef
! !ENDIF
!
! !IF "$(USE_PERLCRT)" == ""
! USE_PERLCRT = undef
! !ENDIF
!
! !IF "$(USE_IMP_SYS)$(USE_MULTI)$(USE_5005THREADS)$(USE_OBJECT)" == "defineundefundefundef"
! USE_MULTI = define
! !ENDIF
!
! !IF "$(USE_ITHREADS)$(USE_MULTI)$(USE_OBJECT)" == "defineundefundef"
! USE_MULTI = define
! USE_5005THREADS = undef
! !ENDIF
!
! !IF "$(USE_MULTI)$(USE_5005THREADS)$(USE_OBJECT)" != "undefundefundef"
! BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_CONTEXT
! !ENDIF
!
! !IF "$(USE_IMP_SYS)" != "undef"
! BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_SYS
! !ENDIF
!
! !IF "$(PROCESSOR_ARCHITECTURE)" == ""
! PROCESSOR_ARCHITECTURE = x86
! !ENDIF
!
! !IF "$(USE_OBJECT)" == "define"
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-object
! !ELSE
! !IF "$(USE_5005THREADS)" == "define"
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-thread
! !ELSE
! !IF "$(USE_MULTI)" == "define"
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-multi
! !ELSE
! !IF "$(USE_PERLIO)" == "define"
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-perlio
! !ELSE
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)
! !ENDIF
! !ENDIF
! !ENDIF
! !ENDIF
!
! !IF "$(USE_PERLIO)" == "define"
! BUILDOPT = $(BUILDOPT) -DUSE_PERLIO
! !ENDIF
!
! !IF "$(USE_ITHREADS)" == "define"
! ARCHNAME = $(ARCHNAME)-thread
! !ENDIF
!
! # Visual Studio 98 specific
! !IF "$(CCTYPE)" == "MSVC60"
!
! # VC 6.0 can load the socket dll on demand. Makes the test suite
! # run in about 10% less time.
! DELAYLOAD = -DELAYLOAD:wsock32.dll -DELAYLOAD:shell32.dll delayimp.lib
! !ENDIF
!
! ARCHDIR = ..\lib\$(ARCHNAME)
! COREDIR = ..\lib\CORE
! AUTODIR = ..\lib\auto
! LIBDIR = ..\lib
! EXTDIR = ..\ext
! PODDIR = ..\pod
! EXTUTILSDIR = $(LIBDIR)\ExtUtils
!
! #
! INST_SCRIPT = $(INST_TOP)$(INST_VER)\bin
! INST_BIN = $(INST_SCRIPT)$(INST_ARCH)
! INST_LIB = $(INST_TOP)$(INST_VER)\lib
! INST_ARCHLIB = $(INST_LIB)$(INST_ARCH)
! INST_COREDIR = $(INST_ARCHLIB)\CORE
! INST_POD = $(INST_LIB)\pod
! INST_HTML = $(INST_TOP)$(INST_VER)\html
!
! #
! # Programs to compile, build .lib files and link
! #
!
! CC = cl
! LINK32 = link
! LIB32 = $(LINK32) -lib
! RSC = rc
!
! #
! # Options
! #
!
! INCLUDES = -I$(COREDIR) -I.\include -I. -I..
! #PCHFLAGS = -Fpc:\temp\vcmoduls.pch -YX
! DEFINES = -DWIN32 -D_CONSOLE -DNO_STRICT $(CRYPT_FLAG)
! LOCDEFS = -DPERLDLL -DPERL_CORE
! SUBSYS = console
! CXX_FLAG = -TP -GX
!
! !IF "$(USE_PERLCRT)" != "define"
! LIBC = msvcrt.lib
! !ELSE
! LIBC = PerlCRT.lib
! !ENDIF
!
! PERLEXE_RES =
! PERLDLL_RES =
!
! !IF "$(CFG)" == "Debug"
! ! IF "$(CCTYPE)" == "MSVC20"
! OPTIMIZE = -Od -MD -Z7 -DDEBUGGING
! ! ELSE
! OPTIMIZE = -Od -MD -Zi -DDEBUGGING
! ! ENDIF
! LINK_DBG = -debug -pdb:none
! !ELSE
! # -O1 yields smaller code, which turns out to be faster than -O2
! #OPTIMIZE = -O2 -MD -DNDEBUG
! OPTIMIZE = -O1 -MD -DNDEBUG
! LINK_DBG = -release
! !ENDIF
!
! !IF "$(USE_OBJECT)" == "define"
! OPTIMIZE = $(OPTIMIZE) $(CXX_FLAG)
! BUILDOPT = $(BUILDOPT) -DPERL_OBJECT
! !ENDIF
!
! !IF "$(USE_PERLCRT)" != "define"
! BUILDOPT = $(BUILDOPT) -DPERL_MSVCRT_READFIX
! !ENDIF
!
! LIBBASEFILES = $(CRYPT_LIB) \
! oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib \
! comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib \
! netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib \
! version.lib odbc32.lib odbccp32.lib
!
! # we add LIBC here, since we may be using PerlCRT.dll
! LIBFILES = $(LIBBASEFILES) $(LIBC)
!
! CFLAGS = -nologo -Gf -W3 $(INCLUDES) $(DEFINES) $(LOCDEFS) \
! $(PCHFLAGS) $(OPTIMIZE)
! LINK_FLAGS = -nologo -nodefaultlib $(LINK_DBG) \
! -libpath:"$(INST_COREDIR)" \
! -machine:$(PROCESSOR_ARCHITECTURE)
! OBJOUT_FLAG = -Fo
! EXEOUT_FLAG = -Fe
!
! CFLAGS_O = $(CFLAGS) $(BUILDOPT)
!
! #################### do not edit below this line #######################
! ############# NO USER-SERVICEABLE PARTS BEYOND THIS POINT ##############
!
! o = .obj
!
! #
! # Rules
! #
!
! .SUFFIXES : .c $(o) .dll .lib .exe .rc .res
!
! .c$(o):
! $(CC) -c -I$(<D) $(CFLAGS_O) $(OBJOUT_FLAG)$@ $<
!
! .y.c:
! $(NOOP)
!
! $(o).dll:
! $(LINK32) -dll -subsystem:windows -implib:$(*B).lib -def:$(*B).def \
! -out:$@ $(LINK_FLAGS) $(LIBFILES) $< $(LIBPERL)
!
! .rc.res:
! $(RSC) -i.. $<
!
! #
! # various targets
!
! # makedef.pl must be updated if this changes, and this should normally
! # only change when there is an incompatible revision of the public API.
! # XXX so why did we change it from perl56 to perl57?
! PERLIMPLIB = ..\perl57.lib
! PERLDLL = ..\perl57.dll
!
! MINIPERL = ..\miniperl.exe
! MINIDIR = .\mini
! PERLEXE = ..\perl.exe
! WPERLEXE = ..\wperl.exe
! GLOBEXE = ..\perlglob.exe
! CONFIGPM = ..\lib\Config.pm
! MINIMOD = ..\lib\ExtUtils\Miniperl.pm
! X2P = ..\x2p\a2p.exe
!
! # Nominate a target which causes extensions to be re-built
! # This used to be $(PERLEXE), but at worst it is the .dll that they depend
! # on and really only the interface - i.e. the .def file used to export symbols
! # from the .dll
! PERLDEP = perldll.def
!
! PL2BAT = bin\pl2bat.pl
! GLOBBAT = bin\perlglob.bat
!
! UTILS = \
! ..\utils\h2ph \
! ..\utils\splain \
! ..\utils\dprofpp \
! ..\utils\perlbug \
! ..\utils\pl2pm \
! ..\utils\c2ph \
! ..\utils\h2xs \
! ..\utils\perldoc \
! ..\utils\perlcc \
! ..\pod\checkpods \
! ..\pod\pod2html \
! ..\pod\pod2latex \
! ..\pod\pod2man \
! ..\pod\pod2text \
! ..\pod\pod2usage \
! ..\pod\podchecker \
! ..\pod\podselect \
! ..\x2p\find2perl \
! ..\x2p\s2p \
! bin\exetype.pl \
! bin\runperl.pl \
! bin\pl2bat.pl \
! bin\perlglob.pl \
! bin\search.pl
!
! MAKE = nmake -nologo
! MAKE_BARE = nmake
!
! CFGSH_TMPL = config.vc
! CFGH_TMPL = config_H.vc
!
! XCOPY = xcopy /f /r /i /d
! RCOPY = xcopy /f /r /i /e /d
! NOOP = @echo
! NULL =
!
! DEL = del
!
! #
! # filenames given to xsubpp must have forward slashes (since it puts
! # full pathnames in #line strings)
! XSUBPP = ..\$(MINIPERL) -I..\..\lib ..\$(EXTUTILSDIR)\xsubpp \
! -C++ -prototypes
!
! MICROCORE_SRC = \
! ..\av.c \
! ..\deb.c \
! ..\doio.c \
! ..\doop.c \
! ..\dump.c \
! ..\globals.c \
! ..\gv.c \
! ..\hv.c \
! ..\locale.c \
! ..\mg.c \
! ..\numeric.c \
! ..\op.c \
! ..\perl.c \
! ..\perlapi.c \
! ..\perly.c \
! ..\pp.c \
! ..\pp_ctl.c \
! ..\pp_hot.c \
! ..\pp_pack.c \
! ..\pp_sys.c \
! ..\regcomp.c \
! ..\regexec.c \
! ..\run.c \
! ..\scope.c \
! ..\sv.c \
! ..\taint.c \
! ..\toke.c \
! ..\universal.c \
! ..\utf8.c \
! ..\util.c \
! ..\xsutils.c
!
! EXTRACORE_SRC = $(EXTRACORE_SRC) perllib.c
!
! !IF "$(PERL_MALLOC)" == "define"
! EXTRACORE_SRC = $(EXTRACORE_SRC) ..\malloc.c
! !ENDIF
!
! !IF "$(USE_OBJECT)" != "define"
! EXTRACORE_SRC = $(EXTRACORE_SRC) ..\perlio.c
! !ENDIF
!
! WIN32_SRC = \
! .\win32.c \
! .\win32io.c \
! .\win32sck.c \
! .\win32thread.c
!
! !IF "$(CRYPT_SRC)" != ""
! WIN32_SRC = $(WIN32_SRC) .\$(CRYPT_SRC)
! !ENDIF
!
! DLL_SRC = $(DYNALOADER).c
!
! X2P_SRC = \
! ..\x2p\a2p.c \
! ..\x2p\hash.c \
! ..\x2p\str.c \
! ..\x2p\util.c \
! ..\x2p\walk.c
!
! CORE_NOCFG_H = \
! ..\av.h \
! ..\cop.h \
! ..\cv.h \
! ..\dosish.h \
! ..\embed.h \
! ..\form.h \
! ..\gv.h \
! ..\handy.h \
! ..\hv.h \
! ..\iperlsys.h \
! ..\mg.h \
! ..\nostdio.h \
! ..\op.h \
! ..\opcode.h \
! ..\perl.h \
! ..\perlapi.h \
! ..\perlsdio.h \
! ..\perlsfio.h \
! ..\perly.h \
! ..\pp.h \
! ..\proto.h \
! ..\regexp.h \
! ..\scope.h \
! ..\sv.h \
! ..\thread.h \
! ..\unixish.h \
! ..\utf8.h \
! ..\util.h \
! ..\warnings.h \
! ..\XSUB.h \
! ..\EXTERN.h \
! ..\perlvars.h \
! ..\intrpvar.h \
! ..\thrdvar.h \
! .\include\dirent.h \
! .\include\netdb.h \
! .\include\sys\socket.h \
! .\win32.h
!
! CORE_H = $(CORE_NOCFG_H) .\config.h
!
! MICROCORE_OBJ = $(MICROCORE_SRC:.c=.obj)
! CORE_OBJ = $(MICROCORE_OBJ) $(EXTRACORE_SRC:.c=.obj)
! WIN32_OBJ = $(WIN32_SRC:.c=.obj)
! MINICORE_OBJ = $(MICROCORE_OBJ:..\=.\mini\) \
! $(MINIDIR)\miniperlmain$(o) \
! $(MINIDIR)\perlio$(o)
! MINIWIN32_OBJ = $(WIN32_OBJ:.\=.\mini\)
! MINI_OBJ = $(MINICORE_OBJ) $(MINIWIN32_OBJ)
! DLL_OBJ = $(DLL_SRC:.c=.obj)
! X2P_OBJ = $(X2P_SRC:.c=.obj)
!
! PERLDLL_OBJ = $(CORE_OBJ)
! PERLEXE_OBJ = perlmain$(o)
!
! PERLDLL_OBJ = $(PERLDLL_OBJ) $(WIN32_OBJ) $(DLL_OBJ)
! #PERLEXE_OBJ = $(PERLEXE_OBJ) $(WIN32_OBJ) $(DLL_OBJ)
!
! !IF "$(USE_SETARGV)" != ""
! SETARGV_OBJ = setargv$(o)
! !ENDIF
!
! DYNALOADER = $(EXTDIR)\DynaLoader\DynaLoader
! SOCKET = $(EXTDIR)\Socket\Socket
! FCNTL = $(EXTDIR)\Fcntl\Fcntl
! OPCODE = $(EXTDIR)\Opcode\Opcode
! SDBM_FILE = $(EXTDIR)\SDBM_File\SDBM_File
! IO = $(EXTDIR)\IO\IO
! POSIX = $(EXTDIR)\POSIX\POSIX
! ATTRS = $(EXTDIR)\attrs\attrs
! THREAD = $(EXTDIR)\Thread\Thread
! B = $(EXTDIR)\B\B
! RE = $(EXTDIR)\re\re
! DUMPER = $(EXTDIR)\Data\Dumper\Dumper
! ERRNO = $(EXTDIR)\Errno\Errno
! PEEK = $(EXTDIR)\Devel\Peek\Peek
! BYTELOADER = $(EXTDIR)\ByteLoader\ByteLoader
! DPROF = $(EXTDIR)\Devel\DProf\DProf
! GLOB = $(EXTDIR)\File\Glob\Glob
! HOSTNAME = $(EXTDIR)\Sys\Hostname\Hostname
! STORABLE = $(EXTDIR)\Storable\Storable
! FILTER = $(EXTDIR)\Filter\Util\Call\Call
! ENCODE = $(EXTDIR)\Encode\Encode
! MD5 = $(EXTDIR)\Digest\MD5\MD5
! PERLIOSCALAR = $(EXTDIR)\PerlIO\Scalar\Scalar
! MIMEBASE64 = $(EXTDIR)\MIME\Base64\Base64
! TIMEHIRES = $(EXTDIR)\Time\HiRes\HiRes
! TIMEPIECE = $(EXTDIR)\Time\Piece\Piece
! CWD = $(EXTDIR)\Cwd\Cwd
! LISTUTIL = $(EXTDIR)\List\Util\Util
! PERLIOVIA = $(EXTDIR)\PerlIO\Via\Via
! XSTYPEMAP = $(EXTDIR)\XS\Typemap\Typemap
!
! SOCKET_DLL = $(AUTODIR)\Socket\Socket.dll
! FCNTL_DLL = $(AUTODIR)\Fcntl\Fcntl.dll
! OPCODE_DLL = $(AUTODIR)\Opcode\Opcode.dll
! SDBM_FILE_DLL = $(AUTODIR)\SDBM_File\SDBM_File.dll
! IO_DLL = $(AUTODIR)\IO\IO.dll
! POSIX_DLL = $(AUTODIR)\POSIX\POSIX.dll
! ATTRS_DLL = $(AUTODIR)\attrs\attrs.dll
! THREAD_DLL = $(AUTODIR)\Thread\Thread.dll
! B_DLL = $(AUTODIR)\B\B.dll
! DUMPER_DLL = $(AUTODIR)\Data\Dumper\Dumper.dll
! PEEK_DLL = $(AUTODIR)\Devel\Peek\Peek.dll
! RE_DLL = $(AUTODIR)\re\re.dll
! BYTELOADER_DLL = $(AUTODIR)\ByteLoader\ByteLoader.dll
! DPROF_DLL = $(AUTODIR)\Devel\DProf\DProf.dll
! GLOB_DLL = $(AUTODIR)\File\Glob\Glob.dll
! HOSTNAME_DLL = $(AUTODIR)\Sys\Hostname\Hostname.dll
! STORABLE_DLL = $(AUTODIR)\Storable\Storable.dll
! FILTER_DLL = $(AUTODIR)\Filter\Util\Call\Call.dll
! ENCODE_DLL = $(AUTODIR)\Encode\Encode.dll
! MD5_DLL = $(AUTODIR)\Digest\MD5\MD5.dll
! PERLIOSCALAR_DLL= $(AUTODIR)\PerlIO\Scalar\Scalar.dll
! MIMEBASE64_DLL = $(AUTODIR)\MIME\Base64\Base64.dll
! TIMEHIRES_DLL = $(AUTODIR)\Time\HiRes\HiRes.dll
! TIMEPIECE_DLL = $(AUTODIR)\Time\Piece\Piece.dll
! CWD_DLL = $(AUTODIR)\Cwd\Cwd.dll
! LISTUTIL_DLL = $(AUTODIR)\List\Util\Util.dll
! PERLIOVIA_DLL = $(AUTODIR)\PerlIO\Via\Via.dll
! XSTYPEMAP_DLL = $(AUTODIR)\XS\Typemap\Typemap.dll
!
! EXTENSION_C = \
! $(SOCKET).c \
! $(FCNTL).c \
! $(OPCODE).c \
! $(SDBM_FILE).c \
! $(IO).c \
! $(POSIX).c \
! $(ATTRS).c \
! $(THREAD).c \
! $(RE).c \
! $(DUMPER).c \
! $(PEEK).c \
! $(B).c \
! $(BYTELOADER).c \
! $(DPROF).c \
! $(GLOB).c \
! $(HOSTNAME).c \
! $(STORABLE).c \
! $(FILTER).c \
! $(ENCODE).c \
! $(MD5).c \
! $(PERLIOSCALAR).c \
! $(MIMEBASE64).c \
! $(TIMEHIRES).c \
! $(TIMEPIECE).c \
! $(CWD).c \
! $(LISTUTIL).c \
! $(PERLIOVIA).c \
! $(XSTYPEMAP).c
!
! EXTENSION_DLL = \
! $(SOCKET_DLL) \
! $(FCNTL_DLL) \
! $(OPCODE_DLL) \
! $(SDBM_FILE_DLL)\
! $(IO_DLL) \
! $(POSIX_DLL) \
! $(ATTRS_DLL) \
! $(DUMPER_DLL) \
! $(PEEK_DLL) \
! $(B_DLL) \
! $(RE_DLL) \
! $(THREAD_DLL) \
! $(BYTELOADER_DLL) \
! $(DPROF_DLL) \
! $(GLOB_DLL) \
! $(HOSTNAME_DLL) \
! $(STORABLE_DLL) \
! $(FILTER_DLL) \
! $(ENCODE_DLL) \
! $(MD5_DLL) \
! $(PERLIOSCALAR_DLL) \
! $(MIMEBASE64_DLL) \
! $(TIMEHIRES_DLL) \
! $(TIMEPIECE_DLL) \
! $(CWD_DLL) \
! $(LISTUTIL_DLL) \
! $(PERLIOVIA_DLL) \
! $(XSTYPEMAP_DLL)
!
! POD2HTML = $(PODDIR)\pod2html
! POD2MAN = $(PODDIR)\pod2man
! POD2LATEX = $(PODDIR)\pod2latex
! POD2TEXT = $(PODDIR)\pod2text
!
! CFG_VARS = \
! "INST_DRV=$(INST_DRV)" \
! "INST_TOP=$(INST_TOP)" \
! "INST_VER=$(INST_VER)" \
! "INST_ARCH=$(INST_ARCH)" \
! "archname=$(ARCHNAME)" \
! "cc=$(CC)" \
! "ld=$(LINK32)" \
! "ccflags=-nologo -Gf -W3 $(OPTIMIZE:"=\") $(DEFINES) $(BUILDOPT)" \
! "cf_email=$(EMAIL)" \
! "d_crypt=$(D_CRYPT)" \
! "d_mymalloc=$(PERL_MALLOC)" \
! "libs=$(LIBFILES)" \
! "incpath=$(CCINCDIR:"=\")" \
! "libperl=$(PERLIMPLIB:..\=)" \
! "libpth=$(CCLIBDIR:"=\");$(EXTRALIBDIRS:"=\")" \
! "libc=$(LIBC)" \
! "make=$(MAKE_BARE)" \
! "use5005threads=$(USE_5005THREADS)" \
! "useithreads=$(USE_ITHREADS)" \
! "usethreads=$(USE_5005THREADS)" \
! "usemultiplicity=$(USE_MULTI)" \
! "useperlio=$(USE_PERLIO)" \
! "LINK_FLAGS=$(LINK_FLAGS:"=\")" \
! "optimize=$(OPTIMIZE:"=\")"
!
! #
! # Top targets
! #
!
! all : .\config.h $(GLOBEXE) $(MINIMOD) $(CONFIGPM) $(PERLEXE) \
! $(X2P) Extensions
! @echo Everything is up to date. '$(MAKE_BARE) test' to run test suite.
!
! $(DYNALOADER)$(o) : $(DYNALOADER).c $(CORE_H) $(EXTDIR)\DynaLoader\dlutils.c
!
! #------------------------------------------------------------
!
! $(GLOBEXE) : perlglob$(o)
! $(LINK32) $(LINK_FLAGS) $(LIBFILES) -out:$@ -subsystem:$(SUBSYS) \
! perlglob$(o) setargv$(o)
!
! perlglob$(o) : perlglob.c
!
! config.w32 : $(CFGSH_TMPL)
! copy $(CFGSH_TMPL) config.w32
!
! .\config.h : $(CFGH_TMPL)
! -del /f config.h
! copy $(CFGH_TMPL) config.h
!
! ..\config.sh : config.w32 $(MINIPERL) config_sh.PL
! $(MINIPERL) -I..\lib config_sh.PL $(CFG_VARS) config.w32 > ..\config.sh
!
! # this target is for when changes to the main config.sh happen
! # edit config.{b,v,g}c and make this target once for each supported
! # compiler (e.g. `nmake CCTYPE=BORLAND regen_config_h`)
! regen_config_h:
! perl config_sh.PL $(CFG_VARS) $(CFGSH_TMPL) > ..\config.sh
! cd ..
! -del /f perl.exe
! perl configpm
! cd win32
! -del /f $(CFGH_TMPL)
! -mkdir $(COREDIR)
! -perl -I..\lib config_h.PL "INST_VER=$(INST_VER)"
! rename config.h $(CFGH_TMPL)
!
! $(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl
! cd ..
! miniperl configpm
! cd win32
! if exist lib\* $(RCOPY) lib\*.* ..\lib\$(NULL)
! $(XCOPY) ..\*.h $(COREDIR)\*.*
! $(XCOPY) *.h $(COREDIR)\*.*
! $(XCOPY) ..\ext\re\re.pm $(LIBDIR)\*.*
! $(RCOPY) include $(COREDIR)\*.*
! -$(MINIPERL) -I..\lib config_h.PL "INST_VER=$(INST_VER)"
! if errorlevel 1 $(MAKE) /$(MAKEFLAGS) $(CONFIGPM)
!
! $(MINIPERL) : $(MINIDIR) $(MINI_OBJ)
! $(LINK32) -subsystem:console -out:$@ @<<
! $(LINK_FLAGS) $(LIBFILES) $(MINI_OBJ)
! <<
!
! $(MINIDIR) :
! if not exist "$(MINIDIR)" mkdir "$(MINIDIR)"
!
! $(MINICORE_OBJ) : $(CORE_NOCFG_H)
! $(CC) -c $(CFLAGS) -DPERL_EXTERNAL_GLOB $(OBJOUT_FLAG)$@ ..\$(*F).c
!
! $(MINIWIN32_OBJ) : $(CORE_NOCFG_H)
! $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $(*F).c
!
! # -DPERL_IMPLICIT_SYS needs C++ for perllib.c
! # This is the only file that depends on perlhost.h, vmem.h, and vdir.h
! !IF "$(USE_IMP_SYS)$(USE_OBJECT)" == "defineundef"
! perllib$(o) : perllib.c .\perlhost.h .\vdir.h .\vmem.h
! $(CC) -c -I. $(CFLAGS_O) $(CXX_FLAG) $(OBJOUT_FLAG)$@ perllib.c
! !ENDIF
!
! # 1. we don't want to rebuild miniperl.exe when config.h changes
! # 2. we don't want to rebuild miniperl.exe with non-default config.h
! $(MINI_OBJ) : $(CORE_NOCFG_H)
!
! $(WIN32_OBJ) : $(CORE_H)
! $(CORE_OBJ) : $(CORE_H)
! $(DLL_OBJ) : $(CORE_H)
! $(X2P_OBJ) : $(CORE_H)
!
! perldll.def : $(MINIPERL) $(CONFIGPM) ..\global.sym ..\pp.sym ..\makedef.pl
! $(MINIPERL) -w ..\makedef.pl PLATFORM=win32 $(OPTIMIZE) $(DEFINES) $(BUILDOPT) \
! CCTYPE=$(CCTYPE) > perldll.def
!
! $(PERLDLL): perldll.def $(PERLDLL_OBJ) $(PERLDLL_RES)
! $(LINK32) -dll -def:perldll.def -base:0x28000000 -out:$@ @<<
! $(LINK_FLAGS) $(DELAYLOAD) $(LIBFILES) $(PERLDLL_OBJ) $(PERLDLL_RES)
! <<
! $(XCOPY) $(PERLIMPLIB) $(COREDIR)
!
! $(MINIMOD) : $(MINIPERL) ..\minimod.pl
! cd ..
! miniperl minimod.pl > lib\ExtUtils\Miniperl.pm
! cd win32
!
! ..\x2p\a2p$(o) : ..\x2p\a2p.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\a2p.c
!
! ..\x2p\hash$(o) : ..\x2p\hash.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\hash.c
!
! ..\x2p\str$(o) : ..\x2p\str.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\str.c
!
! ..\x2p\util$(o) : ..\x2p\util.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\util.c
!
! ..\x2p\walk$(o) : ..\x2p\walk.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\walk.c
!
! $(X2P) : $(MINIPERL) $(X2P_OBJ)
! $(MINIPERL) ..\x2p\find2perl.PL
! $(MINIPERL) ..\x2p\s2p.PL
! $(LINK32) -subsystem:console -out:$@ @<<
! $(LINK_FLAGS) $(LIBFILES) $(X2P_OBJ)
! <<
!
! perlmain.c : runperl.c
! copy runperl.c perlmain.c
!
! perlmain$(o) : perlmain.c
! $(CC) $(CFLAGS_O) -UPERLDLL $(OBJOUT_FLAG)$@ -c perlmain.c
!
! $(PERLEXE): $(PERLDLL) $(CONFIGPM) $(PERLEXE_OBJ) $(PERLEXE_RES)
! $(LINK32) -subsystem:console -out:$@ -stack:0x1000000 $(LINK_FLAGS) \
! $(LIBFILES) $(PERLEXE_OBJ) $(SETARGV_OBJ) $(PERLIMPLIB) $(PERLEXE_RES)
! copy $(PERLEXE) $(WPERLEXE)
! $(MINIPERL) -I..\lib bin\exetype.pl $(WPERLEXE) WINDOWS
! copy splittree.pl ..
! $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR)
!
! $(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM)
! if not exist $(AUTODIR) mkdir $(AUTODIR)
! cd $(EXTDIR)\$(*B)
! ..\$(MINIPERL) -I..\..\lib $(*B)_pm.PL
! ..\$(MINIPERL) -I..\..\lib XSLoader_pm.PL
! cd ..\..\win32
! $(XCOPY) $(EXTDIR)\$(*B)\$(*B).pm $(LIBDIR)\$(NULL)
! $(XCOPY) $(EXTDIR)\$(*B)\XSLoader.pm $(LIBDIR)\$(NULL)
! cd $(EXTDIR)\$(*B)
! $(XSUBPP) dl_win32.xs > $(*B).c
! cd ..\..\win32
!
! $(EXTDIR)\DynaLoader\dl_win32.xs: dl_win32.xs
! copy dl_win32.xs $(EXTDIR)\DynaLoader\dl_win32.xs
!
! #----------------------------------------------------------------------------------
! Extensions: buildext.pl $(PERLDEP) $(CONFIGPM)
! $(MINIPERL) -I..\lib buildext.pl $(MAKE) $(PERLDEP) $(EXTDIR)
!
! Extensions_clean:
! -if exist $(MINIPERL) $(MINIPERL) -I..\lib buildext.pl $(MAKE) $(PERLDEP) $(EXTDIR) clean
!
! #----------------------------------------------------------------------------------
!
! doc: $(PERLEXE)
! $(PERLEXE) -I..\lib ..\installhtml --podroot=.. --htmldir=./html \
! --podpath=pod:lib:ext:utils --htmlroot="file://$(INST_HTML::=|)" \
! --libpod=perlfunc:perlguts:perlvar:perlrun:perlop --recurse
!
! utils: $(PERLEXE) $(X2P)
! cd ..\utils
! $(MAKE) PERL=$(MINIPERL)
! cd ..\pod
! copy ..\README.aix .\perlaix.pod
! copy ..\README.amiga .\perlamiga.pod
! copy ..\README.apollo .\perlapollo.pod
! copy ..\README.beos .\perlbeos.pod
! copy ..\README.bs2000 .\perlbs2000.pod
! copy ..\README.cygwin .\perlcygwin.pod
! copy ..\README.dgux .\perldgux.pod
! copy ..\README.dos .\perldos.pod
! copy ..\README.epoc .\perlepoc.pod
! copy ..\README.hurd .\perlhurd.pod
! copy ..\README.hpux .\perlhpux.pod
! copy ..\README.machten .\perlmachten.pod
! copy ..\README.macos .\perlmacos.pod
! copy ..\README.mint .\perlmint.pod
! copy ..\README.mpeix .\perlmpeix.pod
! copy ..\README.netware .\perlnetware.pod
! copy ..\README.os2 .\perlos2.pod
! copy ..\README.os390 .\perlos390.pod
! copy ..\README.plan9 .\perlplan9.pod
! copy ..\README.qnx .\perlqnx.pod
! copy ..\README.solaris .\perlsolaris.pod
! copy ..\README.tru64 .\perltru64.pod
! copy ..\README.uts .\perluts.pod
! copy ..\README.vmesa .\perlvmesa.pod
! copy ..\vms\perlvms.pod .\perlvms.pod
! copy ..\README.vos .\perlvos.pod
! copy ..\README.win32 .\perlwin32.pod
! $(MAKE) -f ..\win32\pod.mak converters
! cd ..\lib
! $(PERLEXE) lib_pm.PL
! cd ..\win32
! $(PERLEXE) $(PL2BAT) $(UTILS)
!
! distclean: clean
! -del /f $(MINIPERL) $(PERLEXE) $(PERLDLL) $(GLOBEXE) \
! $(PERLIMPLIB) ..\miniperl.lib $(MINIMOD)
! -del /f *.def *.map
! -del /f $(EXTENSION_DLL)
! -del /f $(EXTENSION_C) $(DYNALOADER).c $(ERRNO).pm
! -del /f $(EXTDIR)\DynaLoader\dl_win32.xs
! -del /f $(LIBDIR)\.exists $(LIBDIR)\attrs.pm $(LIBDIR)\DynaLoader.pm
! -del /f $(LIBDIR)\XSLoader.pm
! -del /f $(LIBDIR)\Fcntl.pm $(LIBDIR)\IO.pm $(LIBDIR)\Opcode.pm
! -del /f $(LIBDIR)\ops.pm $(LIBDIR)\Safe.pm $(LIBDIR)\Thread.pm
! -del /f $(LIBDIR)\SDBM_File.pm $(LIBDIR)\Socket.pm $(LIBDIR)\POSIX.pm
! -del /f $(LIBDIR)\B.pm $(LIBDIR)\O.pm $(LIBDIR)\re.pm
! -del /f $(LIBDIR)\Data\Dumper.pm $(LIBDIR)\ByteLoader.pm
! -del /f $(LIBDIR)\Devel\Peek.pm $(LIBDIR)\Devel\DProf.pm
! -del /f $(LIBDIR)\File\Glob.pm
! -del /f $(LIBDIR)\Storable.pm
! -del /f $(LIBDIR)\Filter\Util\Call.pm
! -del /f $(LIBDIR)\Digest\MD5.pm
! -del /f $(LIBDIR)\PerlIO\Scalar.pm
! -del /f $(LIBDIR)\PerlIO\Via.pm
! -del /f $(LIBDIR)\MIME\Base64.pm
! -del /f $(LIBDIR)\MIME\QuotedPrint.pm
! -del /f $(LIBDIR)\List\Util.pm
! -del /f $(LIBDIR)\Scalar\Util.pm
! -del /f $(LIBDIR)\Time\HiRes.pm
! -del /f $(LIBDIR)\Time\Piece.pm
! -del /f $(LIBDIR)\XS\Typemap.pm
! -if exist $(LIBDIR)\IO rmdir /s /q $(LIBDIR)\IO
! -rmdir /s $(LIBDIR)\IO
! -if exist $(LIBDIR)\Thread rmdir /s /q $(LIBDIR)\Thread
! -rmdir /s $(LIBDIR)\Thread
! -if exist $(LIBDIR)\B rmdir /s /q $(LIBDIR)\B
! -rmdir /s $(LIBDIR)\B
! -if exist $(LIBDIR)\Data rmdir /s /q $(LIBDIR)\Data
! -rmdir /s $(LIBDIR)\Data
! -if exist $(LIBDIR)\Filter\Util rmdir /s /q $(LIBDIR)\Filter\Util
! -if exist $(LIBDIR)\Digest rmdir /s /q $(LIBDIR)\Digest
! -rmdir /s $(LIBDIR)\Digest
! -if exist $(LIBDIR)\MIME rmdir /s /q $(LIBDIR)\MIME
! -rmdir /s $(LIBDIR)\MIME
! -if exist $(LIBDIR)\List rmdir /s /q $(LIBDIR)\List
! -rmdir /s $(LIBDIR)\List
! -if exist $(LIBDIR)\Scalar rmdir /s /q $(LIBDIR)\Scalar
! -rmdir /s $(LIBDIR)\Scalar
! -if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS
! -rmdir /s $(LIBDIR)\XS
! cd $(PODDIR)
! -del /f *.html *.bat checkpods \
! perlaix.pod perlamiga.pod perlapollo.pod perlbeos.pod \
! perlbs2000.pod perlcygwin.pod perldgux.pod \
! perldos.pod perlepoc.pod perlhurd.pod \
! perlhpux.pod perlmachten.pod \
! perlmacos.pod perlmint.pod perlmpeix.pod perlnetware.pod \
! perlos2.pod perlos390.pod perlplan9.pod perlqnx.pod \
! perlsolaris.pod perltru64.pod perluts.pod \
! perlvmesa.pod perlvms.pod perlvos.pod \
! perlwin32.pod pod2html pod2latex pod2man pod2text pod2usage \
! podchecker podselect
! cd ..\utils
! -del /f h2ph splain perlbug pl2pm c2ph h2xs perldoc dprofpp
! -del /f *.bat
! cd ..\win32
! cd ..\x2p
! -del /f find2perl s2p
! -del /f *.bat
! cd ..\win32
! -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c config.h.new
! -del /f $(CONFIGPM)
! -del /f bin\*.bat
! cd $(EXTDIR)
! -del /s *.lib *.def *.map *.pdb *.bs Makefile *$(o) pm_to_blib
! cd ..\win32
! -if exist $(AUTODIR) rmdir /s /q $(AUTODIR)
! -rmdir /s $(AUTODIR)
! -if exist $(COREDIR) rmdir /s /q $(COREDIR)
! -rmdir /s $(COREDIR)
!
! install : all installbare installhtml
!
! installbare : utils
! $(PERLEXE) ..\installperl
! if exist $(WPERLEXE) $(XCOPY) $(WPERLEXE) $(INST_BIN)\*.*
! $(XCOPY) $(GLOBEXE) $(INST_BIN)\*.*
! $(XCOPY) bin\*.bat $(INST_SCRIPT)\*.*
!
! installhtml : doc
! $(RCOPY) html\*.* $(INST_HTML)\*.*
!
! inst_lib : $(CONFIGPM)
! copy splittree.pl ..
! $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR)
! $(RCOPY) ..\lib $(INST_LIB)\*.*
!
! minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) utils
! $(XCOPY) $(MINIPERL) ..\t\perl.exe
! $(XCOPY) $(GLOBEXE) ..\t\$(NULL)
! attrib -r ..\t\*.*
! copy test ..\t
! cd ..\t
! $(MINIPERL) -I..\lib test base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t
! cd ..\win32
!
! test-prep : all utils
! $(XCOPY) $(PERLEXE) ..\t\$(NULL)
! $(XCOPY) $(PERLDLL) ..\t\$(NULL)
! $(XCOPY) $(GLOBEXE) ..\t\$(NULL)
!
! test : test-prep
! cd ..\t
! $(PERLEXE) -I..\lib harness
! cd ..\win32
!
! test-notty : test-prep
! set PERL_SKIP_TTY_TEST=1
! cd ..\t
! $(PERLEXE) -I..\lib harness
! cd ..\win32
!
! test-wide : test-prep
! set HARNESS_PERL_SWITCHES=-C
! cd ..\t
! $(PERLEXE) -I..\lib harness
! cd ..\win32
!
! test-wide-notty : test-prep
! set PERL_SKIP_TTY_TEST=1
! set HARNESS_PERL_SWITCHES=-C
! cd ..\t
! $(PERLEXE) -I..\lib harness
! cd ..\win32
!
! clean : Extensions_clean
! -@$(DEL) miniperlmain$(o)
! -@$(DEL) $(MINIPERL)
! -@$(DEL) perlglob$(o)
! -@$(DEL) perlmain$(o)
! -@$(DEL) config.w32
! -@$(DEL) config.h
! -@$(DEL) $(GLOBEXE)
! -@$(DEL) $(PERLEXE)
! -@$(DEL) $(WPERLEXE)
! -@$(DEL) $(PERLDLL)
! -@$(DEL) $(CORE_OBJ)
! -if exist $(MINIDIR) rmdir /s /q $(MINIDIR)
! -rmdir /s $(MINIDIR)
! -@$(DEL) $(WIN32_OBJ)
! -@$(DEL) $(DLL_OBJ)
! -@$(DEL) $(X2P_OBJ)
! -@$(DEL) ..\*$(o) ..\*.lib ..\*.exp *$(o) *.lib *.exp *.res
! -@$(DEL) ..\t\*.exe ..\t\*.dll ..\t\*.bat
! -@$(DEL) ..\x2p\*.exe ..\x2p\*.bat
! -@$(DEL) *.ilk
! -@$(DEL) *.pdb
!
! # Handy way to run perlbug -ok without having to install and run the
! # installed perlbug. We don't re-run the tests here - we trust the user.
! # Please *don't* use this unless all tests pass.
! # If you want to report test failures, use "nmake nok" instead.
! ok: utils
! $(PERLEXE) -I..\lib ..\utils\perlbug -ok -s "(UNINSTALLED)"
!
! okfile: utils
! $(PERLEXE) -I..\lib ..\utils\perlbug -ok -s "(UNINSTALLED)" -F perl.ok
!
! nok: utils
! $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)"
!
! nokfile: utils
! $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)" -F perl.nok
diff -c 'perl-5.7.1/win32/buildext.pl' 'perl-5.7.2/win32/buildext.pl'
Index: ./win32/buildext.pl
*** ./win32/buildext.pl Sat Apr 7 18:41:48 2001
--- ./win32/buildext.pl Mon Jul 9 17:11:35 2001
***************
*** 1,3 ****
--- 1,23 ----
+ =head1 NAME
+
+ buildext.pl - build extensions
+
+ =head1 SYNOPSIS
+
+ buildext.pl make [-make_opts] dep directory [target]
+
+ E.g.
+
+ buildext.pl nmake -nologo perldll.def ..\ext
+
+ buildext.pl nmake -nologo perldll.def ..\ext clean
+
+ buildext.pl dmake perldll.def ..\ext
+
+ buildext.pl dmake perldll.def ..\ext clean
+
+ =cut
+
use File::Basename;
use Cwd;
use FindExt;
***************
*** 14,19 ****
--- 34,40 ----
my $dmod = -M $dep;
my $dir = shift;
chdir($dir) || die "Cannot cd to $dir\n";
+ my $targ = shift;
(my $ext = getcwd()) =~ s,/,\\,g;
FindExt::scan_ext($ext);
***************
*** 27,33 ****
if (!(-f 'Makefile') || $mmod > $dmod)
{
print "\nRunning Makefile.PL in $dir\n";
! my $code = system($perl,"-I$here\\..\lib",'Makefile.PL','INSTALLDIRS=perl');
warn "$code from $dir's Makefile.PL" if $code;
$mmod = -M 'Makefile';
if ($mmod > $dmod)
--- 48,55 ----
if (!(-f 'Makefile') || $mmod > $dmod)
{
print "\nRunning Makefile.PL in $dir\n";
! print "$perl \"-I$here\\..\\lib\" Makefile.PL INSTALLDIRS=perl\n";
! my $code = system($perl,"-I$here\\..\\lib",'Makefile.PL','INSTALLDIRS=perl');
warn "$code from $dir's Makefile.PL" if $code;
$mmod = -M 'Makefile';
if ($mmod > $dmod)
***************
*** 35,42 ****
warn "Makefile $mmod > $dmod ($dep)\n";
}
}
! print "\nMaking $dir\n";
! system($make);
chdir($here) || die "Cannot cd to $here:$!";
}
else
--- 57,72 ----
warn "Makefile $mmod > $dmod ($dep)\n";
}
}
! if ($targ)
! {
! print "Making $targ in $dir\n$make $targ\n";
! system($make,$targ);
! }
! else
! {
! print "Making $dir\n$make\n";
! system($make);
! }
chdir($here) || die "Cannot cd to $here:$!";
}
else
diff -c 'perl-5.7.1/win32/config.bc' 'perl-5.7.2/win32/config.bc'
Index: ./win32/config.bc
*** ./win32/config.bc Thu Apr 5 19:23:07 2001
--- ./win32/config.bc Fri Jul 13 03:17:50 2001
***************
*** 1,7 ****
## Configured by: ~cf_email~
## Target system: WIN32
Author=''
! CONFIGDOTSH='true'
Date='$Date'
Header=''
Id='$Id'
--- 1,7 ----
## Configured by: ~cf_email~
## Target system: WIN32
Author=''
! PERL_CONFIG_SH='true'
Date='$Date'
Header=''
Id='$Id'
***************
*** 15,20 ****
--- 15,21 ----
_exe='.exe'
_o='.obj'
afs='false'
+ afsroot='/afs'
alignbytes='8'
ansi2knr=''
aphostname=''
***************
*** 67,76 ****
cpprun='cpp32 -oCON'
cppstdin='cpp32 -oCON'
cppsymbols=''
- crosscompile='undef'
cryptlib=''
csh='undef'
- d__fwalk='undef'
d_Gconvert='gcvt((x),(n),(b))'
d_PRIEUldbl='undef'
d_PRIFUldbl='undef'
--- 68,75 ----
***************
*** 84,89 ****
--- 83,89 ----
d_PRIo64='undef'
d_PRIu64='undef'
d_PRIx64='undef'
+ d__fwalk='undef'
d_access='define'
d_accessx='undef'
d_alarm='undef'
***************
*** 105,116 ****
d_chroot='undef'
d_chsize='define'
d_closedir='define'
- d_const='define'
d_cmsghdr_s='undef'
d_crypt='undef'
d_csh='undef'
d_cuserid='undef'
d_dbl_dig='define'
d_difftime='define'
d_dirnamlen='define'
d_dlerror='define'
--- 105,117 ----
d_chroot='undef'
d_chsize='define'
d_closedir='define'
d_cmsghdr_s='undef'
+ d_const='define'
d_crypt='undef'
d_csh='undef'
d_cuserid='undef'
d_dbl_dig='define'
+ d_dbminitproto='undef'
d_difftime='define'
d_dirnamlen='define'
d_dlerror='define'
***************
*** 128,133 ****
--- 129,135 ----
d_endsent='undef'
d_eofnblk='define'
d_eunice='undef'
+ d_fchdir='undef'
d_fchmod='undef'
d_fchown='undef'
d_fcntl='undef'
***************
*** 138,143 ****
--- 140,146 ----
d_fgetpos='define'
d_flexfnam='define'
d_flock='define'
+ d_flockproto='undef'
d_fork='undef'
d_fpathconf='undef'
d_fpos64_t='undef'
***************
*** 150,156 ****
d_fsync='undef'
d_ftello='undef'
d_ftime='define'
! d_getcwd='undef'
d_getespwnam='undef'
d_getfsstat='undef'
d_getgrent='undef'
--- 153,159 ----
d_fsync='undef'
d_ftello='undef'
d_ftime='define'
! d_getcwd='define'
d_getespwnam='undef'
d_getfsstat='undef'
d_getgrent='undef'
***************
*** 224,229 ****
--- 227,233 ----
d_mktime='define'
d_mmap='undef'
d_modfl='undef'
+ d_modfl_pow32_bug='undef'
d_mprotect='undef'
d_msg='undef'
d_msg_ctrunc='undef'
***************
*** 240,245 ****
--- 244,250 ----
d_munmap='undef'
d_mymalloc='undef'
d_nice='undef'
+ d_nl_langinfo='undef'
d_nv_preserves_uv='define'
d_nv_preserves_uv_bits='32'
d_off64_t='undef'
***************
*** 254,259 ****
--- 259,265 ----
d_pipe='define'
d_poll='undef'
d_portable='define'
+ d_pthread_atfork='undef'
d_pthread_yield='undef'
d_pwage='undef'
d_pwchange='undef'
***************
*** 322,332 ****
--- 328,341 ----
d_sigprocmask='undef'
d_sigsetjmp='undef'
d_sockatmark='undef'
+ d_sockatmarkproto='undef'
d_socket='define'
d_socklen_t='undef'
d_sockpair='undef'
d_socks5_init='undef'
d_sqrtl='undef'
+ d_sresgproto='undef'
+ d_sresuproto='undef'
d_statblks='undef'
d_statfs_f_flags='undef'
d_statfs_s='undef'
***************
*** 333,340 ****
d_statvfs='undef'
d_stdio_cnt_lval='define'
d_stdio_ptr_lval='define'
d_stdio_ptr_lval_sets_cnt='undef'
- d_stdio_ptr_lval_nochange_cnt='undef'
d_stdio_stream_array='undef'
d_stdiobase='define'
d_stdstdio='define'
--- 342,349 ----
d_statvfs='undef'
d_stdio_cnt_lval='define'
d_stdio_ptr_lval='define'
+ d_stdio_ptr_lval_nochange_cnt='define'
d_stdio_ptr_lval_sets_cnt='undef'
d_stdio_stream_array='undef'
d_stdiobase='define'
d_stdstdio='define'
***************
*** 343,348 ****
--- 352,358 ----
d_strctcpy='define'
d_strerrm='strerror(e)'
d_strerror='define'
+ d_strftime='define'
d_strtod='define'
d_strtol='define'
d_strtold='undef'
***************
*** 355,360 ****
--- 365,371 ----
d_suidsafe='undef'
d_symlink='undef'
d_syscall='undef'
+ d_syscallproto='undef'
d_sysconf='undef'
d_sysernlst=''
d_syserrlst='define'
***************
*** 373,378 ****
--- 384,390 ----
d_uname='define'
d_union_semun='define'
d_usleep='undef'
+ d_usleepproto='undef'
d_ustat='undef'
d_vendorarch='undef'
d_vendorbin='undef'
***************
*** 455,460 ****
--- 467,473 ----
i_iconv='undef'
i_ieeefp='undef'
i_inttypes='undef'
+ i_langinfo='undef'
i_limits='define'
i_locale='define'
i_machcthr='undef'
***************
*** 732,738 ****
ssizetype='int'
startperl='#!perl'
startsh='#!/bin/sh'
! static_ext='DynaLoader'
stdchar='unsigned char'
stdio_base='((fp)->buffer)'
stdio_bufsiz='((fp)->level + (fp)->curp - (fp)->buffer)'
--- 745,751 ----
ssizetype='int'
startperl='#!perl'
startsh='#!/bin/sh'
! static_ext=' '
stdchar='unsigned char'
stdio_base='((fp)->buffer)'
stdio_bufsiz='((fp)->level + (fp)->curp - (fp)->buffer)'
***************
*** 773,778 ****
--- 786,792 ----
use5005threads='undef'
use64bitall='undef'
use64bitint='undef'
+ usecrosscompile='undef'
usedl='define'
useithreads='undef'
uselargefiles='undef'
***************
*** 784,789 ****
--- 798,804 ----
useopcode='true'
useperlio='~USE_PERLIO~'
useposix='true'
+ usereentrant='undef'
usesfio='false'
useshrplib='yes'
usesocks='undef'
diff -c 'perl-5.7.1/win32/config.gc' 'perl-5.7.2/win32/config.gc'
Index: ./win32/config.gc
*** ./win32/config.gc Thu Apr 5 19:23:29 2001
--- ./win32/config.gc Fri Jul 13 03:18:00 2001
***************
*** 1,7 ****
## Configured by: ~cf_email~
## Target system: WIN32
Author=''
! CONFIGDOTSH='true'
Date='$Date'
Header=''
Id='$Id'
--- 1,7 ----
## Configured by: ~cf_email~
## Target system: WIN32
Author=''
! PERL_CONFIG_SH='true'
Date='$Date'
Header=''
Id='$Id'
***************
*** 15,20 ****
--- 15,21 ----
_exe='.exe'
_o='.o'
afs='false'
+ afsroot='/afs'
alignbytes='8'
ansi2knr=''
aphostname=''
***************
*** 67,76 ****
cpprun='gcc -E'
cppstdin='gcc -E'
cppsymbols=''
- crosscompile='undef'
cryptlib=''
csh='undef'
- d__fwalk='undef'
d_Gconvert='sprintf((b),"%.*g",(n),(x))'
d_PRIEUldbl='undef'
d_PRIFUldbl='undef'
--- 68,75 ----
***************
*** 84,89 ****
--- 83,89 ----
d_PRIo64='undef'
d_PRIu64='undef'
d_PRIx64='undef'
+ d__fwalk='undef'
d_access='define'
d_accessx='undef'
d_alarm='undef'
***************
*** 105,116 ****
d_chroot='undef'
d_chsize='define'
d_closedir='define'
- d_const='define'
d_cmsghdr_s='undef'
d_crypt='undef'
d_csh='undef'
d_cuserid='undef'
d_dbl_dig='define'
d_difftime='define'
d_dirnamlen='define'
d_dlerror='define'
--- 105,117 ----
d_chroot='undef'
d_chsize='define'
d_closedir='define'
d_cmsghdr_s='undef'
+ d_const='define'
d_crypt='undef'
d_csh='undef'
d_cuserid='undef'
d_dbl_dig='define'
+ d_dbminitproto='undef'
d_difftime='define'
d_dirnamlen='define'
d_dlerror='define'
***************
*** 128,133 ****
--- 129,135 ----
d_endsent='undef'
d_eofnblk='define'
d_eunice='undef'
+ d_fchdir='undef'
d_fchmod='undef'
d_fchown='undef'
d_fcntl='undef'
***************
*** 138,143 ****
--- 140,146 ----
d_fgetpos='define'
d_flexfnam='define'
d_flock='define'
+ d_flockproto='undef'
d_fork='undef'
d_fpathconf='undef'
d_fpos64_t='undef'
***************
*** 150,156 ****
d_fsync='undef'
d_ftello='undef'
d_ftime='define'
! d_getcwd='undef'
d_getespwnam='undef'
d_getfsstat='undef'
d_getgrent='undef'
--- 153,159 ----
d_fsync='undef'
d_ftello='undef'
d_ftime='define'
! d_getcwd='define'
d_getespwnam='undef'
d_getfsstat='undef'
d_getgrent='undef'
***************
*** 224,229 ****
--- 227,233 ----
d_mktime='define'
d_mmap='undef'
d_modfl='undef'
+ d_modfl_pow32_bug='undef'
d_mprotect='undef'
d_msg='undef'
d_msg_ctrunc='undef'
***************
*** 240,245 ****
--- 244,250 ----
d_munmap='undef'
d_mymalloc='undef'
d_nice='undef'
+ d_nl_langinfo='undef'
d_nv_preserves_uv='define'
d_nv_preserves_uv_bits='32'
d_off64_t='undef'
***************
*** 254,259 ****
--- 259,265 ----
d_pipe='define'
d_poll='undef'
d_portable='define'
+ d_pthread_atfork='undef'
d_pthread_yield='undef'
d_pwage='undef'
d_pwchange='undef'
***************
*** 322,332 ****
--- 328,341 ----
d_sigprocmask='undef'
d_sigsetjmp='undef'
d_sockatmark='undef'
+ d_sockatmarkproto='undef'
d_socket='define'
d_socklen_t='undef'
d_sockpair='undef'
d_socks5_init='undef'
d_sqrtl='undef'
+ d_sresgproto='undef'
+ d_sresuproto='undef'
d_statblks='undef'
d_statfs_f_flags='undef'
d_statfs_s='undef'
***************
*** 333,340 ****
d_statvfs='undef'
d_stdio_cnt_lval='define'
d_stdio_ptr_lval='define'
- d_stdio_ptr_lval_sets_cnt='undef'
d_stdio_ptr_lval_nochange_cnt='define'
d_stdio_stream_array='undef'
d_stdiobase='define'
d_stdstdio='define'
--- 342,349 ----
d_statvfs='undef'
d_stdio_cnt_lval='define'
d_stdio_ptr_lval='define'
d_stdio_ptr_lval_nochange_cnt='define'
+ d_stdio_ptr_lval_sets_cnt='undef'
d_stdio_stream_array='undef'
d_stdiobase='define'
d_stdstdio='define'
***************
*** 343,348 ****
--- 352,358 ----
d_strctcpy='define'
d_strerrm='strerror(e)'
d_strerror='define'
+ d_strftime='define'
d_strtod='define'
d_strtol='define'
d_strtold='undef'
***************
*** 355,360 ****
--- 365,371 ----
d_suidsafe='undef'
d_symlink='undef'
d_syscall='undef'
+ d_syscallproto='undef'
d_sysconf='undef'
d_sysernlst=''
d_syserrlst='define'
***************
*** 373,378 ****
--- 384,390 ----
d_uname='define'
d_union_semun='define'
d_usleep='undef'
+ d_usleepproto='undef'
d_ustat='undef'
d_vendorarch='undef'
d_vendorbin='undef'
***************
*** 455,460 ****
--- 467,473 ----
i_iconv='undef'
i_ieeefp='undef'
i_inttypes='undef'
+ i_langinfo='undef'
i_limits='define'
i_locale='define'
i_machcthr='undef'
***************
*** 732,738 ****
ssizetype='int'
startperl='#!perl'
startsh='#!/bin/sh'
! static_ext='DynaLoader'
stdchar='char'
stdio_base='((fp)->_base)'
stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)'
--- 745,751 ----
ssizetype='int'
startperl='#!perl'
startsh='#!/bin/sh'
! static_ext=' '
stdchar='char'
stdio_base='((fp)->_base)'
stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)'
***************
*** 773,778 ****
--- 786,792 ----
use5005threads='undef'
use64bitall='undef'
use64bitint='undef'
+ usecrosscompile='undef'
usedl='define'
useithreads='undef'
uselargefiles='undef'
***************
*** 784,789 ****
--- 798,804 ----
useopcode='true'
useperlio='~USE_PERLIO~'
useposix='true'
+ usereentrant='undef'
usesfio='false'
useshrplib='yes'
usesocks='undef'
diff -c 'perl-5.7.1/win32/config.vc' 'perl-5.7.2/win32/config.vc'
Index: ./win32/config.vc
*** ./win32/config.vc Thu Apr 5 19:23:18 2001
--- ./win32/config.vc Fri Jul 13 03:18:04 2001
***************
*** 1,7 ****
# Configured by: ~cf_email~
## Target system: WIN32
Author=''
! CONFIGDOTSH='true'
Date='$Date'
Header=''
Id='$Id'
--- 1,7 ----
# Configured by: ~cf_email~
## Target system: WIN32
Author=''
! PERL_CONFIG_SH='true'
Date='$Date'
Header=''
Id='$Id'
***************
*** 15,20 ****
--- 15,21 ----
_exe='.exe'
_o='.obj'
afs='false'
+ afsroot='/afs'
alignbytes='8'
ansi2knr=''
aphostname=''
***************
*** 67,76 ****
cpprun='cl -nologo -E'
cppstdin='cl -nologo -E'
cppsymbols=''
- crosscompile='undef'
cryptlib=''
csh='undef'
- d__fwalk='undef'
d_Gconvert='sprintf((b),"%.*g",(n),(x))'
d_PRIEUldbl='undef'
d_PRIFUldbl='undef'
--- 68,75 ----
***************
*** 84,89 ****
--- 83,89 ----
d_PRIo64='undef'
d_PRIu64='undef'
d_PRIx64='undef'
+ d__fwalk='undef'
d_access='define'
d_accessx='undef'
d_alarm='undef'
***************
*** 105,116 ****
d_chroot='undef'
d_chsize='define'
d_closedir='define'
- d_const='define'
d_cmsghdr_s='undef'
d_crypt='undef'
d_csh='undef'
d_cuserid='undef'
d_dbl_dig='define'
d_difftime='define'
d_dirnamlen='define'
d_dlerror='define'
--- 105,117 ----
d_chroot='undef'
d_chsize='define'
d_closedir='define'
d_cmsghdr_s='undef'
+ d_const='define'
d_crypt='undef'
d_csh='undef'
d_cuserid='undef'
d_dbl_dig='define'
+ d_dbminitproto='undef'
d_difftime='define'
d_dirnamlen='define'
d_dlerror='define'
***************
*** 128,133 ****
--- 129,135 ----
d_endsent='undef'
d_eofnblk='define'
d_eunice='undef'
+ d_fchdir='undef'
d_fchmod='undef'
d_fchown='undef'
d_fcntl='undef'
***************
*** 138,143 ****
--- 140,146 ----
d_fgetpos='define'
d_flexfnam='define'
d_flock='define'
+ d_flockproto='undef'
d_fork='undef'
d_fpathconf='undef'
d_fpos64_t='undef'
***************
*** 150,156 ****
d_fsync='undef'
d_ftello='undef'
d_ftime='define'
! d_getcwd='undef'
d_getespwnam='undef'
d_getfsstat='undef'
d_getgrent='undef'
--- 153,159 ----
d_fsync='undef'
d_ftello='undef'
d_ftime='define'
! d_getcwd='define'
d_getespwnam='undef'
d_getfsstat='undef'
d_getgrent='undef'
***************
*** 224,229 ****
--- 227,233 ----
d_mktime='define'
d_mmap='undef'
d_modfl='undef'
+ d_modfl_pow32_bug='undef'
d_mprotect='undef'
d_msg='undef'
d_msg_ctrunc='undef'
***************
*** 240,245 ****
--- 244,250 ----
d_munmap='undef'
d_mymalloc='undef'
d_nice='undef'
+ d_nl_langinfo='undef'
d_nv_preserves_uv='define'
d_nv_preserves_uv_bits='32'
d_off64_t='undef'
***************
*** 254,259 ****
--- 259,265 ----
d_pipe='define'
d_poll='undef'
d_portable='define'
+ d_pthread_atfork='undef'
d_pthread_yield='undef'
d_pwage='undef'
d_pwchange='undef'
***************
*** 322,332 ****
--- 328,341 ----
d_sigprocmask='undef'
d_sigsetjmp='undef'
d_sockatmark='undef'
+ d_sockatmarkproto='undef'
d_socket='define'
d_socklen_t='undef'
d_sockpair='undef'
d_socks5_init='undef'
d_sqrtl='undef'
+ d_sresgproto='undef'
+ d_sresuproto='undef'
d_statblks='undef'
d_statfs_f_flags='undef'
d_statfs_s='undef'
***************
*** 333,340 ****
d_statvfs='undef'
d_stdio_cnt_lval='define'
d_stdio_ptr_lval='define'
- d_stdio_ptr_lval_sets_cnt='undef'
d_stdio_ptr_lval_nochange_cnt='define'
d_stdio_stream_array='undef'
d_stdiobase='define'
d_stdstdio='define'
--- 342,349 ----
d_statvfs='undef'
d_stdio_cnt_lval='define'
d_stdio_ptr_lval='define'
d_stdio_ptr_lval_nochange_cnt='define'
+ d_stdio_ptr_lval_sets_cnt='undef'
d_stdio_stream_array='undef'
d_stdiobase='define'
d_stdstdio='define'
***************
*** 343,348 ****
--- 352,358 ----
d_strctcpy='define'
d_strerrm='strerror(e)'
d_strerror='define'
+ d_strftime='define'
d_strtod='define'
d_strtol='define'
d_strtold='undef'
***************
*** 355,360 ****
--- 365,371 ----
d_suidsafe='undef'
d_symlink='undef'
d_syscall='undef'
+ d_syscallproto='undef'
d_sysconf='undef'
d_sysernlst=''
d_syserrlst='define'
***************
*** 373,378 ****
--- 384,390 ----
d_uname='define'
d_union_semun='define'
d_usleep='undef'
+ d_usleepproto='undef'
d_ustat='undef'
d_vendorarch='undef'
d_vendorbin='undef'
***************
*** 455,460 ****
--- 467,473 ----
i_iconv='undef'
i_ieeefp='undef'
i_inttypes='undef'
+ i_langinfo='undef'
i_limits='define'
i_locale='define'
i_machcthr='undef'
***************
*** 732,738 ****
ssizetype='int'
startperl='#!perl'
startsh='#!/bin/sh'
! static_ext='DynaLoader'
stdchar='char'
stdio_base='((fp)->_base)'
stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)'
--- 745,751 ----
ssizetype='int'
startperl='#!perl'
startsh='#!/bin/sh'
! static_ext=' '
stdchar='char'
stdio_base='((fp)->_base)'
stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)'
***************
*** 773,778 ****
--- 786,792 ----
use5005threads='undef'
use64bitall='undef'
use64bitint='undef'
+ usecrosscompile='undef'
usedl='define'
useithreads='undef'
uselargefiles='undef'
***************
*** 784,789 ****
--- 798,804 ----
useopcode='true'
useperlio='~USE_PERLIO~'
useposix='true'
+ usereentrant='undef'
usesfio='false'
useshrplib='yes'
usesocks='undef'
diff -c 'perl-5.7.1/win32/config_H.bc' 'perl-5.7.2/win32/config_H.bc'
Index: ./win32/config_H.bc
Prereq: 3.0.1.5
*** ./win32/config_H.bc Sun Apr 8 01:57:29 2001
--- ./win32/config_H.bc Fri Jul 13 17:07:18 2001
***************
*** 13,20 ****
/*
* Package name : perl5
* Source directory :
! * Configuration time: Fri Apr 6 21:55:47 2001
! * Configured by : nick
* Target system :
*/
--- 13,20 ----
/*
* Package name : perl5
* Source directory :
! * Configuration time: Mon Jul 2 02:03:57 2001
! * Configured by : gsar
* Target system :
*/
***************
*** 121,146 ****
*/
#define HAS_DLERROR /**/
- /* SETUID_SCRIPTS_ARE_SECURE_NOW:
- * This symbol, if defined, indicates that the bug that prevents
- * setuid scripts from being secure is not present in this kernel.
- */
- /* DOSUID:
- * This symbol, if defined, indicates that the C program should
- * check the script that it is executing for setuid/setgid bits, and
- * attempt to emulate setuid/setgid on systems that have disabled
- * setuid #! scripts because the kernel can't do it securely.
- * It is up to the package designer to make sure that this emulation
- * is done securely. Among other things, it should do an fstat on
- * the script it just opened to make sure it really is a setuid/setgid
- * script, it should make sure the arguments passed correspond exactly
- * to the argument on the #! line, and it should not trust any
- * subprocesses to which it must pass the filename rather than the
- * file descriptor of the script to be executed.
- */
- /*#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/
- /*#define DOSUID /**/
-
/* HAS_DUP2:
* This symbol, if defined, indicates that the dup2 routine is
* available to duplicate file descriptors.
--- 121,126 ----
***************
*** 918,934 ****
*/
/*#define I_VALUES /**/
- /* I_STDARG:
- * This symbol, if defined, indicates that <stdarg.h> exists and should
- * be included.
- */
- /* I_VARARGS:
- * This symbol, if defined, indicates to the C program that it should
- * include <varargs.h>.
- */
- #define I_STDARG /**/
- /*#define I_VARARGS /**/
-
/* I_VFORK:
* This symbol, if defined, indicates to the C program that it should
* include vfork.h.
--- 898,903 ----
***************
*** 962,973 ****
*/
#define SH_PATH "cmd /x /c" /**/
- /* CROSSCOMPILE:
- * This symbol, if defined, signifies that we our
- * build process is a cross-compilation.
- */
- /*#define CROSSCOMPILE /**/
-
/* INTSIZE:
* This symbol contains the value of sizeof(int) so that the C
* preprocessor can make decisions based on it.
--- 931,936 ----
***************
*** 1038,1044 ****
--- 1001,1013 ----
* by Configure. You shouldn't rely on it too much; the specific
* feature tests from Configure are generally more reliable.
*/
+ /* OSVERS:
+ * This symbol contains the version of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
+ */
#define OSNAME "MSWin32" /**/
+ #define OSVERS "4.0" /**/
/* MEM_ALIGNBYTES:
* This symbol contains the number of bytes required to align a
***************
*** 1045,1051 ****
* double, or a long double when applicable. Usual values are 2,
* 4 and 8. The default is eight, for safety.
*/
! #if defined(CROSSCOMPILE) || defined(MULTIARCH)
# define MEM_ALIGNBYTES 8
#else
#define MEM_ALIGNBYTES 8
--- 1014,1020 ----
* double, or a long double when applicable. Usual values are 2,
* 4 and 8. The default is eight, for safety.
*/
! #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
# define MEM_ALIGNBYTES 8
#else
#define MEM_ALIGNBYTES 8
***************
*** 1064,1070 ****
* This symbol contains the ~name expanded version of ARCHLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define ARCHLIB "c:\\perl\\5.7.1\\lib\\MSWin32-x86-multi-thread" /**/
/*#define ARCHLIB_EXP "" /**/
/* ARCHNAME:
--- 1033,1039 ----
* This symbol contains the ~name expanded version of ARCHLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define ARCHLIB "c:\\perl\\5.7.2\\lib\\MSWin32-x86-multi-thread" /**/
/*#define ARCHLIB_EXP "" /**/
/* ARCHNAME:
***************
*** 1095,1102 ****
* This symbol is the filename expanded version of the BIN symbol, for
* programs that do not want to deal with that at run-time.
*/
! #define BIN "c:\\perl\\5.7.1\\bin\\MSWin32-x86-multi-thread" /**/
! #define BIN_EXP "c:\\perl\\5.7.1\\bin\\MSWin32-x86-multi-thread" /**/
/* PERL_BINCOMPAT_5005:
* This symbol, if defined, indicates that this version of Perl should be
--- 1064,1071 ----
* This symbol is the filename expanded version of the BIN symbol, for
* programs that do not want to deal with that at run-time.
*/
! #define BIN "c:\\perl\\5.7.2\\bin\\MSWin32-x86-multi-thread" /**/
! #define BIN_EXP "c:\\perl\\5.7.2\\bin\\MSWin32-x86-multi-thread" /**/
/* PERL_BINCOMPAT_5005:
* This symbol, if defined, indicates that this version of Perl should be
***************
*** 1122,1128 ****
* so the default case (for NeXT) is big endian to catch them.
* This might matter for NeXT 3.0.
*/
! #if defined(CROSSCOMPILE) || defined(MULTIARCH)
# ifdef __LITTLE_ENDIAN__
# if LONGSIZE == 4
# define BYTEORDER 0x1234
--- 1091,1097 ----
* so the default case (for NeXT) is big endian to catch them.
* This might matter for NeXT 3.0.
*/
! #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
# ifdef __LITTLE_ENDIAN__
# if LONGSIZE == 4
# define BYTEORDER 0x1234
***************
*** 1312,1317 ****
--- 1281,1292 ----
*/
/*#define HAS_ENDSERVENT /**/
+ /* HAS_FCHDIR:
+ * This symbol, if defined, indicates that the fchdir routine is
+ * available to change directory using a file descriptor.
+ */
+ /*#define HAS_FCHDIR /**/
+
/* FCNTL_CAN_LOCK:
* This symbol, if defined, indicates that fcntl() can be used
* for file locking. Normally on Unix systems this is defined.
***************
*** 1395,1401 ****
* This symbol, if defined, indicates that the getcwd routine is
* available to get the current working directory.
*/
! /*#define HAS_GETCWD /**/
/* HAS_GETESPWNAM:
* This symbol, if defined, indicates that the getespwnam system call is
--- 1370,1376 ----
* This symbol, if defined, indicates that the getcwd routine is
* available to get the current working directory.
*/
! #define HAS_GETCWD /**/
/* HAS_GETESPWNAM:
* This symbol, if defined, indicates that the getespwnam system call is
***************
*** 1770,1776 ****
--- 1745,1759 ----
* available to split a long double x into a fractional part f and
* an integer part i such that |f| < 1.0 and (f + i) = x.
*/
+ /* HAS_MODFL_POW32_BUG:
+ * This symbol, if defined, indicates that the modfl routine is
+ * broken for long doubles >= pow(2, 32).
+ * For example from 4294967303.150000 one would get 4294967302.000000
+ * and 1.150000. The bug has been seen in certain versions of glibc,
+ * release 2.2.2 is known to be okay.
+ */
/*#define HAS_MODFL /**/
+ /*#define HAS_MODFL_POW32_BUG /**/
/* HAS_MPROTECT:
* This symbol, if defined, indicates that the mprotect system call is
***************
*** 1845,1851 ****
/* HAS_SAFE_BCOPY:
* This symbol, if defined, indicates that the bcopy routine is available
! * to copy potentially overlapping memory blocks. Otherwise you should
* probably use memmove() or memcpy(). If neither is defined, roll your
* own version.
*/
--- 1828,1834 ----
/* HAS_SAFE_BCOPY:
* This symbol, if defined, indicates that the bcopy routine is available
! * to copy potentially overlapping memory blocks. Normally, you should
* probably use memmove() or memcpy(). If neither is defined, roll your
* own version.
*/
***************
*** 1853,1861 ****
/* HAS_SAFE_MEMCPY:
* This symbol, if defined, indicates that the memcpy routine is available
! * to copy potentially overlapping memory blocks. Otherwise you should
! * probably use memmove() or memcpy(). If neither is defined, roll your
! * own version.
*/
/*#define HAS_SAFE_MEMCPY /**/
--- 1836,1844 ----
/* HAS_SAFE_MEMCPY:
* This symbol, if defined, indicates that the memcpy routine is available
! * to copy potentially overlapping memory blocks. If you need to
! * copy overlapping memory blocks, you should check HAS_MEMMOVE and
! * use memmove() instead, if available.
*/
/*#define HAS_SAFE_MEMCPY /**/
***************
*** 2141,2147 ****
#define FILE_cnt(fp) ((fp)->level)
#define STDIO_CNT_LVALUE /**/
/*#define STDIO_PTR_LVAL_SETS_CNT /**/
! /*#define STDIO_PTR_LVAL_NOCHANGE_CNT /**/
#endif
/* USE_STDIO_BASE:
--- 2124,2130 ----
#define FILE_cnt(fp) ((fp)->level)
#define STDIO_CNT_LVALUE /**/
/*#define STDIO_PTR_LVAL_SETS_CNT /**/
! #define STDIO_PTR_LVAL_NOCHANGE_CNT /**/
#endif
/* USE_STDIO_BASE:
***************
*** 2401,2408 ****
--- 2384,2408 ----
* in the <db.h> header file. In older versions of DB, it was
* int, while in newer ones it is size_t.
*/
+ /* DB_VERSION_MAJOR_CFG:
+ * This symbol, if defined, defines the major version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ */
+ /* DB_VERSION_MINOR_CFG:
+ * This symbol, if defined, defines the minor version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
+ /* DB_VERSION_PATCH_CFG:
+ * This symbol, if defined, defines the patch version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
#define DB_Hash_t int /**/
#define DB_Prefix_t int /**/
+ #define DB_VERSION_MAJOR_CFG undef /**/
+ #define DB_VERSION_MINOR_CFG undef /**/
+ #define DB_VERSION_PATCH_CFG undef /**/
/* I_GRP:
* This symbol, if defined, indicates to the C program that it should
***************
*** 2918,2925 ****
* This symbol contains the ~name expanded version of PRIVLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define PRIVLIB "c:\\perl\\5.7.1\\lib" /**/
! #define PRIVLIB_EXP (win32_get_privlib("5.7.1")) /**/
/* PTRSIZE:
* This symbol contains the size of a pointer, so that the C preprocessor
--- 2918,2925 ----
* This symbol contains the ~name expanded version of PRIVLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define PRIVLIB "c:\\perl\\5.7.2\\lib" /**/
! #define PRIVLIB_EXP (win32_get_privlib("5.7.2")) /**/
/* PTRSIZE:
* This symbol contains the size of a pointer, so that the C preprocessor
***************
*** 2933,2939 ****
* This macro is to be used to generate uniformly distributed
* random numbers over the range [0., 1.[. You may have to supply
* an 'extern double drand48();' in your program since SunOS 4.1.3
! * doesn't provide you with anything relevant in it's headers.
* See HAS_DRAND48_PROTO.
*/
/* Rand_seed_t:
--- 2933,2939 ----
* This macro is to be used to generate uniformly distributed
* random numbers over the range [0., 1.[. You may have to supply
* an 'extern double drand48();' in your program since SunOS 4.1.3
! * doesn't provide you with anything relevant in its headers.
* See HAS_DRAND48_PROTO.
*/
/* Rand_seed_t:
***************
*** 3022,3028 ****
* This symbol contains the ~name expanded version of SITEARCH, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define SITEARCH "c:\\perl\\site\\5.7.1\\lib\\MSWin32-x86-multi-thread" /**/
/*#define SITEARCH_EXP "" /**/
/* SITELIB:
--- 3022,3028 ----
* This symbol contains the ~name expanded version of SITEARCH, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define SITEARCH "c:\\perl\\site\\5.7.2\\lib\\MSWin32-x86-multi-thread" /**/
/*#define SITEARCH_EXP "" /**/
/* SITELIB:
***************
*** 3045,3052 ****
* removed. The elements in inc_version_list (inc_version_list.U) can
* be tacked onto this variable to generate a list of directories to search.
*/
! #define SITELIB "c:\\perl\\site\\5.7.1\\lib" /**/
! #define SITELIB_EXP (win32_get_sitelib("5.7.1")) /**/
#define SITELIB_STEM "" /**/
/* Size_t_size:
--- 3045,3052 ----
* removed. The elements in inc_version_list (inc_version_list.U) can
* be tacked onto this variable to generate a list of directories to search.
*/
! #define SITELIB "c:\\perl\\site\\5.7.2\\lib" /**/
! #define SITELIB_EXP (win32_get_sitelib("5.7.2")) /**/
#define SITELIB_STEM "" /**/
/* Size_t_size:
***************
*** 3212,3217 ****
--- 3212,3222 ----
* This symbol, if defined, indicates that Perl should
* be built to use the old draft POSIX threads API.
*/
+ /* USE_REENTRANT_API:
+ * This symbol, if defined, indicates that Perl should
+ * try to use the various _r versions of library functions.
+ * This is extremely experimental.
+ */
/*#define USE_5005THREADS /**/
#define USE_ITHREADS /**/
#if defined(USE_5005THREADS) && !defined(USE_ITHREADS)
***************
*** 3218,3223 ****
--- 3223,3229 ----
#define USE_THREADS /* until src is revised*/
#endif
/*#define OLD_PTHREADS_API /**/
+ /*#define USE_REENTRANT_API /**/
/* PERL_VENDORARCH:
* If defined, this symbol contains the name of a private library.
***************
*** 3277,3283 ****
/* PERL_XS_APIVERSION:
* This variable contains the version of the oldest perl binary
* compatible with the present perl. perl.c:incpush() and
! * lib/lib.pm will automatically search in c:\\perl\\site\\5.7.1\\lib\\MSWin32-x86-multi-thread for older
* directories across major versions back to xs_apiversion.
* This is only useful if you have a perl library directory tree
* structured like the default one.
--- 3283,3289 ----
/* PERL_XS_APIVERSION:
* This variable contains the version of the oldest perl binary
* compatible with the present perl. perl.c:incpush() and
! * lib/lib.pm will automatically search in c:\\perl\\site\\5.7.2\\lib\\MSWin32-x86-multi-thread for older
* directories across major versions back to xs_apiversion.
* This is only useful if you have a perl library directory tree
* structured like the default one.
***************
*** 3296,3302 ****
* compatible with the present perl. (That is, pure perl modules
* written for pm_apiversion will still work for the current
* version). perl.c:incpush() and lib/lib.pm will automatically
! * search in c:\\perl\\site\\5.7.1\\lib for older directories across major versions
* back to pm_apiversion. This is only useful if you have a perl
* library directory tree structured like the default one. The
* versioned site_perl library was introduced in 5.005, so that's
--- 3302,3308 ----
* compatible with the present perl. (That is, pure perl modules
* written for pm_apiversion will still work for the current
* version). perl.c:incpush() and lib/lib.pm will automatically
! * search in c:\\perl\\site\\5.7.2\\lib for older directories across major versions
* back to pm_apiversion. This is only useful if you have a perl
* library directory tree structured like the default one. The
* versioned site_perl library was introduced in 5.005, so that's
***************
*** 3309,3314 ****
--- 3315,3386 ----
#define PERL_XS_APIVERSION "5.6.0"
#define PERL_PM_APIVERSION "5.005"
+ /* SETUID_SCRIPTS_ARE_SECURE_NOW:
+ * This symbol, if defined, indicates that the bug that prevents
+ * setuid scripts from being secure is not present in this kernel.
+ */
+ /* DOSUID:
+ * This symbol, if defined, indicates that the C program should
+ * check the script that it is executing for setuid/setgid bits, and
+ * attempt to emulate setuid/setgid on systems that have disabled
+ * setuid #! scripts because the kernel can't do it securely.
+ * It is up to the package designer to make sure that this emulation
+ * is done securely. Among other things, it should do an fstat on
+ * the script it just opened to make sure it really is a setuid/setgid
+ * script, it should make sure the arguments passed correspond exactly
+ * to the argument on the #! line, and it should not trust any
+ * subprocesses to which it must pass the filename rather than the
+ * file descriptor of the script to be executed.
+ */
+ /*#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/
+ /*#define DOSUID /**/
+
+ /* I_STDARG:
+ * This symbol, if defined, indicates that <stdarg.h> exists and should
+ * be included.
+ */
+ /* I_VARARGS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <varargs.h>.
+ */
+ #define I_STDARG /**/
+ /*#define I_VARARGS /**/
+
+ /* USE_CROSS_COMPILE:
+ * This symbol, if defined, indicates that Perl is being cross-compiled.
+ */
+ /* PERL_TARGETARCH:
+ * This symbol, if defined, indicates the target architecture
+ * Perl has been cross-compiled to. Undefined if not a cross-compile.
+ */
+ #ifndef USE_CROSS_COMPILE
+ /*#define USE_CROSS_COMPILE /**/
+ #define PERL_TARGETARCH "undef" /**/
+ #endif
+
+ /* HAS_DBMINIT_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the dbminit() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int dbminit(char *);
+ */
+ /*#define HAS_DBMINIT_PROTO /**/
+
+ /* HAS_FLOCK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the flock() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int flock(int, int);
+ */
+ /*#define HAS_FLOCK_PROTO /**/
+
+ /* HAS_NL_LANGINFO:
+ * This symbol, if defined, indicates that the nl_langinfo routine is
+ * available to return local data. You will also need <langinfo.h>
+ * and therefore I_LANGINFO.
+ */
+ /*#define HAS_NL_LANGINFO /**/
+
/* HAS_SIGPROCMASK:
* This symbol, if defined, indicates that the sigprocmask
* system call is available to examine or change the signal mask
***************
*** 3322,3331 ****
--- 3394,3462 ----
*/
/*#define HAS_SOCKATMARK /**/
+ /* HAS_SOCKATMARK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the sockatmark() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int sockatmark _((int));
+ */
+ /*#define HAS_SOCKATMARK_PROTO /**/
+
+ /* HAS_SETRESGID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresgid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+ /*#define HAS_SETRESGID_PROTO /**/
+
+ /* HAS_SETRESUID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresuid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+ /*#define HAS_SETRESUID_PROTO /**/
+
+ /* HAS_STRFTIME:
+ * This symbol, if defined, indicates that the strftime routine is
+ * available to do time formatting.
+ */
+ #define HAS_STRFTIME /**/
+
+ /* HAS_SYSCALL_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the syscall() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int syscall(int, ...);
+ * extern int syscall(long, ...);
+ */
+ /*#define HAS_SYSCALL_PROTO /**/
+
/* U32_ALIGNMENT_REQUIRED:
* This symbol, if defined, indicates that you must access
* character data through U32-aligned pointers.
*/
#define U32_ALIGNMENT_REQUIRED /**/
+
+ /* HAS_USLEEP_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the usleep() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int usleep(useconds_t);
+ */
+ /*#define HAS_USLEEP_PROTO /**/
+
+ /* I_LANGINFO:
+ * This symbol, if defined, indicates that <langinfo.h> exists and
+ * should be included.
+ */
+ /*#define I_LANGINFO /**/
+
+ /* HAS_PTHREAD_ATFORK:
+ * This symbol, if defined, indicates that the pthread_atfork routine
+ * is available setup fork handlers.
+ */
+ /*#define HAS_PTHREAD_ATFORK /**/
#endif
diff -c 'perl-5.7.1/win32/config_H.gc' 'perl-5.7.2/win32/config_H.gc'
Index: ./win32/config_H.gc
Prereq: 3.0.1.5
*** ./win32/config_H.gc Sun Apr 8 01:57:47 2001
--- ./win32/config_H.gc Fri Jul 13 17:07:18 2001
***************
*** 13,20 ****
/*
* Package name : perl5
* Source directory :
! * Configuration time: Fri Apr 6 21:55:32 2001
! * Configured by : nick
* Target system :
*/
--- 13,20 ----
/*
* Package name : perl5
* Source directory :
! * Configuration time: Mon Jul 2 02:03:50 2001
! * Configured by : gsar
* Target system :
*/
***************
*** 121,146 ****
*/
#define HAS_DLERROR /**/
- /* SETUID_SCRIPTS_ARE_SECURE_NOW:
- * This symbol, if defined, indicates that the bug that prevents
- * setuid scripts from being secure is not present in this kernel.
- */
- /* DOSUID:
- * This symbol, if defined, indicates that the C program should
- * check the script that it is executing for setuid/setgid bits, and
- * attempt to emulate setuid/setgid on systems that have disabled
- * setuid #! scripts because the kernel can't do it securely.
- * It is up to the package designer to make sure that this emulation
- * is done securely. Among other things, it should do an fstat on
- * the script it just opened to make sure it really is a setuid/setgid
- * script, it should make sure the arguments passed correspond exactly
- * to the argument on the #! line, and it should not trust any
- * subprocesses to which it must pass the filename rather than the
- * file descriptor of the script to be executed.
- */
- /*#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/
- /*#define DOSUID /**/
-
/* HAS_DUP2:
* This symbol, if defined, indicates that the dup2 routine is
* available to duplicate file descriptors.
--- 121,126 ----
***************
*** 918,934 ****
*/
/*#define I_VALUES /**/
- /* I_STDARG:
- * This symbol, if defined, indicates that <stdarg.h> exists and should
- * be included.
- */
- /* I_VARARGS:
- * This symbol, if defined, indicates to the C program that it should
- * include <varargs.h>.
- */
- #define I_STDARG /**/
- /*#define I_VARARGS /**/
-
/* I_VFORK:
* This symbol, if defined, indicates to the C program that it should
* include vfork.h.
--- 898,903 ----
***************
*** 962,973 ****
*/
#define SH_PATH "cmd /x /c" /**/
- /* CROSSCOMPILE:
- * This symbol, if defined, signifies that we our
- * build process is a cross-compilation.
- */
- /*#define CROSSCOMPILE /**/
-
/* INTSIZE:
* This symbol contains the value of sizeof(int) so that the C
* preprocessor can make decisions based on it.
--- 931,936 ----
***************
*** 1038,1044 ****
--- 1001,1013 ----
* by Configure. You shouldn't rely on it too much; the specific
* feature tests from Configure are generally more reliable.
*/
+ /* OSVERS:
+ * This symbol contains the version of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
+ */
#define OSNAME "MSWin32" /**/
+ #define OSVERS "4.0" /**/
/* MEM_ALIGNBYTES:
* This symbol contains the number of bytes required to align a
***************
*** 1045,1051 ****
* double, or a long double when applicable. Usual values are 2,
* 4 and 8. The default is eight, for safety.
*/
! #if defined(CROSSCOMPILE) || defined(MULTIARCH)
# define MEM_ALIGNBYTES 8
#else
#define MEM_ALIGNBYTES 8
--- 1014,1020 ----
* double, or a long double when applicable. Usual values are 2,
* 4 and 8. The default is eight, for safety.
*/
! #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
# define MEM_ALIGNBYTES 8
#else
#define MEM_ALIGNBYTES 8
***************
*** 1064,1070 ****
* This symbol contains the ~name expanded version of ARCHLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define ARCHLIB "c:\\perl\\5.7.1\\lib\\MSWin32-x86-multi-thread" /**/
/*#define ARCHLIB_EXP "" /**/
/* ARCHNAME:
--- 1033,1039 ----
* This symbol contains the ~name expanded version of ARCHLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define ARCHLIB "c:\\perl\\5.7.2\\lib\\MSWin32-x86-multi-thread" /**/
/*#define ARCHLIB_EXP "" /**/
/* ARCHNAME:
***************
*** 1095,1102 ****
* This symbol is the filename expanded version of the BIN symbol, for
* programs that do not want to deal with that at run-time.
*/
! #define BIN "c:\\perl\\5.7.1\\bin\\MSWin32-x86-multi-thread" /**/
! #define BIN_EXP "c:\\perl\\5.7.1\\bin\\MSWin32-x86-multi-thread" /**/
/* PERL_BINCOMPAT_5005:
* This symbol, if defined, indicates that this version of Perl should be
--- 1064,1071 ----
* This symbol is the filename expanded version of the BIN symbol, for
* programs that do not want to deal with that at run-time.
*/
! #define BIN "c:\\perl\\5.7.2\\bin\\MSWin32-x86-multi-thread" /**/
! #define BIN_EXP "c:\\perl\\5.7.2\\bin\\MSWin32-x86-multi-thread" /**/
/* PERL_BINCOMPAT_5005:
* This symbol, if defined, indicates that this version of Perl should be
***************
*** 1122,1128 ****
* so the default case (for NeXT) is big endian to catch them.
* This might matter for NeXT 3.0.
*/
! #if defined(CROSSCOMPILE) || defined(MULTIARCH)
# ifdef __LITTLE_ENDIAN__
# if LONGSIZE == 4
# define BYTEORDER 0x1234
--- 1091,1097 ----
* so the default case (for NeXT) is big endian to catch them.
* This might matter for NeXT 3.0.
*/
! #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
# ifdef __LITTLE_ENDIAN__
# if LONGSIZE == 4
# define BYTEORDER 0x1234
***************
*** 1312,1317 ****
--- 1281,1292 ----
*/
/*#define HAS_ENDSERVENT /**/
+ /* HAS_FCHDIR:
+ * This symbol, if defined, indicates that the fchdir routine is
+ * available to change directory using a file descriptor.
+ */
+ /*#define HAS_FCHDIR /**/
+
/* FCNTL_CAN_LOCK:
* This symbol, if defined, indicates that fcntl() can be used
* for file locking. Normally on Unix systems this is defined.
***************
*** 1395,1401 ****
* This symbol, if defined, indicates that the getcwd routine is
* available to get the current working directory.
*/
! /*#define HAS_GETCWD /**/
/* HAS_GETESPWNAM:
* This symbol, if defined, indicates that the getespwnam system call is
--- 1370,1376 ----
* This symbol, if defined, indicates that the getcwd routine is
* available to get the current working directory.
*/
! #define HAS_GETCWD /**/
/* HAS_GETESPWNAM:
* This symbol, if defined, indicates that the getespwnam system call is
***************
*** 1770,1776 ****
--- 1745,1759 ----
* available to split a long double x into a fractional part f and
* an integer part i such that |f| < 1.0 and (f + i) = x.
*/
+ /* HAS_MODFL_POW32_BUG:
+ * This symbol, if defined, indicates that the modfl routine is
+ * broken for long doubles >= pow(2, 32).
+ * For example from 4294967303.150000 one would get 4294967302.000000
+ * and 1.150000. The bug has been seen in certain versions of glibc,
+ * release 2.2.2 is known to be okay.
+ */
/*#define HAS_MODFL /**/
+ /*#define HAS_MODFL_POW32_BUG /**/
/* HAS_MPROTECT:
* This symbol, if defined, indicates that the mprotect system call is
***************
*** 1845,1851 ****
/* HAS_SAFE_BCOPY:
* This symbol, if defined, indicates that the bcopy routine is available
! * to copy potentially overlapping memory blocks. Otherwise you should
* probably use memmove() or memcpy(). If neither is defined, roll your
* own version.
*/
--- 1828,1834 ----
/* HAS_SAFE_BCOPY:
* This symbol, if defined, indicates that the bcopy routine is available
! * to copy potentially overlapping memory blocks. Normally, you should
* probably use memmove() or memcpy(). If neither is defined, roll your
* own version.
*/
***************
*** 1853,1861 ****
/* HAS_SAFE_MEMCPY:
* This symbol, if defined, indicates that the memcpy routine is available
! * to copy potentially overlapping memory blocks. Otherwise you should
! * probably use memmove() or memcpy(). If neither is defined, roll your
! * own version.
*/
/*#define HAS_SAFE_MEMCPY /**/
--- 1836,1844 ----
/* HAS_SAFE_MEMCPY:
* This symbol, if defined, indicates that the memcpy routine is available
! * to copy potentially overlapping memory blocks. If you need to
! * copy overlapping memory blocks, you should check HAS_MEMMOVE and
! * use memmove() instead, if available.
*/
/*#define HAS_SAFE_MEMCPY /**/
***************
*** 2401,2408 ****
--- 2384,2408 ----
* in the <db.h> header file. In older versions of DB, it was
* int, while in newer ones it is size_t.
*/
+ /* DB_VERSION_MAJOR_CFG:
+ * This symbol, if defined, defines the major version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ */
+ /* DB_VERSION_MINOR_CFG:
+ * This symbol, if defined, defines the minor version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
+ /* DB_VERSION_PATCH_CFG:
+ * This symbol, if defined, defines the patch version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
#define DB_Hash_t int /**/
#define DB_Prefix_t int /**/
+ #define DB_VERSION_MAJOR_CFG undef /**/
+ #define DB_VERSION_MINOR_CFG undef /**/
+ #define DB_VERSION_PATCH_CFG undef /**/
/* I_GRP:
* This symbol, if defined, indicates to the C program that it should
***************
*** 2918,2925 ****
* This symbol contains the ~name expanded version of PRIVLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define PRIVLIB "c:\\perl\\5.7.1\\lib" /**/
! #define PRIVLIB_EXP (win32_get_privlib("5.7.1")) /**/
/* PTRSIZE:
* This symbol contains the size of a pointer, so that the C preprocessor
--- 2918,2925 ----
* This symbol contains the ~name expanded version of PRIVLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define PRIVLIB "c:\\perl\\5.7.2\\lib" /**/
! #define PRIVLIB_EXP (win32_get_privlib("5.7.2")) /**/
/* PTRSIZE:
* This symbol contains the size of a pointer, so that the C preprocessor
***************
*** 2933,2939 ****
* This macro is to be used to generate uniformly distributed
* random numbers over the range [0., 1.[. You may have to supply
* an 'extern double drand48();' in your program since SunOS 4.1.3
! * doesn't provide you with anything relevant in it's headers.
* See HAS_DRAND48_PROTO.
*/
/* Rand_seed_t:
--- 2933,2939 ----
* This macro is to be used to generate uniformly distributed
* random numbers over the range [0., 1.[. You may have to supply
* an 'extern double drand48();' in your program since SunOS 4.1.3
! * doesn't provide you with anything relevant in its headers.
* See HAS_DRAND48_PROTO.
*/
/* Rand_seed_t:
***************
*** 3022,3028 ****
* This symbol contains the ~name expanded version of SITEARCH, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define SITEARCH "c:\\perl\\site\\5.7.1\\lib\\MSWin32-x86-multi-thread" /**/
/*#define SITEARCH_EXP "" /**/
/* SITELIB:
--- 3022,3028 ----
* This symbol contains the ~name expanded version of SITEARCH, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define SITEARCH "c:\\perl\\site\\5.7.2\\lib\\MSWin32-x86-multi-thread" /**/
/*#define SITEARCH_EXP "" /**/
/* SITELIB:
***************
*** 3045,3052 ****
* removed. The elements in inc_version_list (inc_version_list.U) can
* be tacked onto this variable to generate a list of directories to search.
*/
! #define SITELIB "c:\\perl\\site\\5.7.1\\lib" /**/
! #define SITELIB_EXP (win32_get_sitelib("5.7.1")) /**/
#define SITELIB_STEM "" /**/
/* Size_t_size:
--- 3045,3052 ----
* removed. The elements in inc_version_list (inc_version_list.U) can
* be tacked onto this variable to generate a list of directories to search.
*/
! #define SITELIB "c:\\perl\\site\\5.7.2\\lib" /**/
! #define SITELIB_EXP (win32_get_sitelib("5.7.2")) /**/
#define SITELIB_STEM "" /**/
/* Size_t_size:
***************
*** 3212,3217 ****
--- 3212,3222 ----
* This symbol, if defined, indicates that Perl should
* be built to use the old draft POSIX threads API.
*/
+ /* USE_REENTRANT_API:
+ * This symbol, if defined, indicates that Perl should
+ * try to use the various _r versions of library functions.
+ * This is extremely experimental.
+ */
/*#define USE_5005THREADS /**/
#define USE_ITHREADS /**/
#if defined(USE_5005THREADS) && !defined(USE_ITHREADS)
***************
*** 3218,3223 ****
--- 3223,3229 ----
#define USE_THREADS /* until src is revised*/
#endif
/*#define OLD_PTHREADS_API /**/
+ /*#define USE_REENTRANT_API /**/
/* PERL_VENDORARCH:
* If defined, this symbol contains the name of a private library.
***************
*** 3277,3283 ****
/* PERL_XS_APIVERSION:
* This variable contains the version of the oldest perl binary
* compatible with the present perl. perl.c:incpush() and
! * lib/lib.pm will automatically search in c:\\perl\\site\\5.7.1\\lib\\MSWin32-x86-multi-thread for older
* directories across major versions back to xs_apiversion.
* This is only useful if you have a perl library directory tree
* structured like the default one.
--- 3283,3289 ----
/* PERL_XS_APIVERSION:
* This variable contains the version of the oldest perl binary
* compatible with the present perl. perl.c:incpush() and
! * lib/lib.pm will automatically search in c:\\perl\\site\\5.7.2\\lib\\MSWin32-x86-multi-thread for older
* directories across major versions back to xs_apiversion.
* This is only useful if you have a perl library directory tree
* structured like the default one.
***************
*** 3296,3302 ****
* compatible with the present perl. (That is, pure perl modules
* written for pm_apiversion will still work for the current
* version). perl.c:incpush() and lib/lib.pm will automatically
! * search in c:\\perl\\site\\5.7.1\\lib for older directories across major versions
* back to pm_apiversion. This is only useful if you have a perl
* library directory tree structured like the default one. The
* versioned site_perl library was introduced in 5.005, so that's
--- 3302,3308 ----
* compatible with the present perl. (That is, pure perl modules
* written for pm_apiversion will still work for the current
* version). perl.c:incpush() and lib/lib.pm will automatically
! * search in c:\\perl\\site\\5.7.2\\lib for older directories across major versions
* back to pm_apiversion. This is only useful if you have a perl
* library directory tree structured like the default one. The
* versioned site_perl library was introduced in 5.005, so that's
***************
*** 3309,3314 ****
--- 3315,3386 ----
#define PERL_XS_APIVERSION "5.6.0"
#define PERL_PM_APIVERSION "5.005"
+ /* SETUID_SCRIPTS_ARE_SECURE_NOW:
+ * This symbol, if defined, indicates that the bug that prevents
+ * setuid scripts from being secure is not present in this kernel.
+ */
+ /* DOSUID:
+ * This symbol, if defined, indicates that the C program should
+ * check the script that it is executing for setuid/setgid bits, and
+ * attempt to emulate setuid/setgid on systems that have disabled
+ * setuid #! scripts because the kernel can't do it securely.
+ * It is up to the package designer to make sure that this emulation
+ * is done securely. Among other things, it should do an fstat on
+ * the script it just opened to make sure it really is a setuid/setgid
+ * script, it should make sure the arguments passed correspond exactly
+ * to the argument on the #! line, and it should not trust any
+ * subprocesses to which it must pass the filename rather than the
+ * file descriptor of the script to be executed.
+ */
+ /*#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/
+ /*#define DOSUID /**/
+
+ /* I_STDARG:
+ * This symbol, if defined, indicates that <stdarg.h> exists and should
+ * be included.
+ */
+ /* I_VARARGS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <varargs.h>.
+ */
+ #define I_STDARG /**/
+ /*#define I_VARARGS /**/
+
+ /* USE_CROSS_COMPILE:
+ * This symbol, if defined, indicates that Perl is being cross-compiled.
+ */
+ /* PERL_TARGETARCH:
+ * This symbol, if defined, indicates the target architecture
+ * Perl has been cross-compiled to. Undefined if not a cross-compile.
+ */
+ #ifndef USE_CROSS_COMPILE
+ /*#define USE_CROSS_COMPILE /**/
+ #define PERL_TARGETARCH "undef" /**/
+ #endif
+
+ /* HAS_DBMINIT_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the dbminit() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int dbminit(char *);
+ */
+ /*#define HAS_DBMINIT_PROTO /**/
+
+ /* HAS_FLOCK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the flock() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int flock(int, int);
+ */
+ /*#define HAS_FLOCK_PROTO /**/
+
+ /* HAS_NL_LANGINFO:
+ * This symbol, if defined, indicates that the nl_langinfo routine is
+ * available to return local data. You will also need <langinfo.h>
+ * and therefore I_LANGINFO.
+ */
+ /*#define HAS_NL_LANGINFO /**/
+
/* HAS_SIGPROCMASK:
* This symbol, if defined, indicates that the sigprocmask
* system call is available to examine or change the signal mask
***************
*** 3322,3331 ****
--- 3394,3462 ----
*/
/*#define HAS_SOCKATMARK /**/
+ /* HAS_SOCKATMARK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the sockatmark() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int sockatmark _((int));
+ */
+ /*#define HAS_SOCKATMARK_PROTO /**/
+
+ /* HAS_SETRESGID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresgid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+ /*#define HAS_SETRESGID_PROTO /**/
+
+ /* HAS_SETRESUID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresuid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+ /*#define HAS_SETRESUID_PROTO /**/
+
+ /* HAS_STRFTIME:
+ * This symbol, if defined, indicates that the strftime routine is
+ * available to do time formatting.
+ */
+ #define HAS_STRFTIME /**/
+
+ /* HAS_SYSCALL_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the syscall() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int syscall(int, ...);
+ * extern int syscall(long, ...);
+ */
+ /*#define HAS_SYSCALL_PROTO /**/
+
/* U32_ALIGNMENT_REQUIRED:
* This symbol, if defined, indicates that you must access
* character data through U32-aligned pointers.
*/
#define U32_ALIGNMENT_REQUIRED /**/
+
+ /* HAS_USLEEP_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the usleep() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int usleep(useconds_t);
+ */
+ /*#define HAS_USLEEP_PROTO /**/
+
+ /* I_LANGINFO:
+ * This symbol, if defined, indicates that <langinfo.h> exists and
+ * should be included.
+ */
+ /*#define I_LANGINFO /**/
+
+ /* HAS_PTHREAD_ATFORK:
+ * This symbol, if defined, indicates that the pthread_atfork routine
+ * is available setup fork handlers.
+ */
+ /*#define HAS_PTHREAD_ATFORK /**/
#endif
diff -c 'perl-5.7.1/win32/config_H.vc' 'perl-5.7.2/win32/config_H.vc'
Index: ./win32/config_H.vc
Prereq: 3.0.1.5
*** ./win32/config_H.vc Sun Apr 8 01:57:58 2001
--- ./win32/config_H.vc Fri Jul 13 17:07:18 2001
***************
*** 13,20 ****
/*
* Package name : perl5
* Source directory :
! * Configuration time: Fri Apr 6 22:05:41 2001
! * Configured by : nick
* Target system :
*/
--- 13,20 ----
/*
* Package name : perl5
* Source directory :
! * Configuration time: Mon Jul 2 02:04:03 2001
! * Configured by : gsar
* Target system :
*/
***************
*** 121,146 ****
*/
#define HAS_DLERROR /**/
- /* SETUID_SCRIPTS_ARE_SECURE_NOW:
- * This symbol, if defined, indicates that the bug that prevents
- * setuid scripts from being secure is not present in this kernel.
- */
- /* DOSUID:
- * This symbol, if defined, indicates that the C program should
- * check the script that it is executing for setuid/setgid bits, and
- * attempt to emulate setuid/setgid on systems that have disabled
- * setuid #! scripts because the kernel can't do it securely.
- * It is up to the package designer to make sure that this emulation
- * is done securely. Among other things, it should do an fstat on
- * the script it just opened to make sure it really is a setuid/setgid
- * script, it should make sure the arguments passed correspond exactly
- * to the argument on the #! line, and it should not trust any
- * subprocesses to which it must pass the filename rather than the
- * file descriptor of the script to be executed.
- */
- /*#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/
- /*#define DOSUID /**/
-
/* HAS_DUP2:
* This symbol, if defined, indicates that the dup2 routine is
* available to duplicate file descriptors.
--- 121,126 ----
***************
*** 918,934 ****
*/
/*#define I_VALUES /**/
- /* I_STDARG:
- * This symbol, if defined, indicates that <stdarg.h> exists and should
- * be included.
- */
- /* I_VARARGS:
- * This symbol, if defined, indicates to the C program that it should
- * include <varargs.h>.
- */
- #define I_STDARG /**/
- /*#define I_VARARGS /**/
-
/* I_VFORK:
* This symbol, if defined, indicates to the C program that it should
* include vfork.h.
--- 898,903 ----
***************
*** 962,973 ****
*/
#define SH_PATH "cmd /x /c" /**/
- /* CROSSCOMPILE:
- * This symbol, if defined, signifies that we our
- * build process is a cross-compilation.
- */
- /*#define CROSSCOMPILE /**/
-
/* INTSIZE:
* This symbol contains the value of sizeof(int) so that the C
* preprocessor can make decisions based on it.
--- 931,936 ----
***************
*** 1038,1044 ****
--- 1001,1013 ----
* by Configure. You shouldn't rely on it too much; the specific
* feature tests from Configure are generally more reliable.
*/
+ /* OSVERS:
+ * This symbol contains the version of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
+ */
#define OSNAME "MSWin32" /**/
+ #define OSVERS "4.0" /**/
/* MEM_ALIGNBYTES:
* This symbol contains the number of bytes required to align a
***************
*** 1045,1051 ****
* double, or a long double when applicable. Usual values are 2,
* 4 and 8. The default is eight, for safety.
*/
! #if defined(CROSSCOMPILE) || defined(MULTIARCH)
# define MEM_ALIGNBYTES 8
#else
#define MEM_ALIGNBYTES 8
--- 1014,1020 ----
* double, or a long double when applicable. Usual values are 2,
* 4 and 8. The default is eight, for safety.
*/
! #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
# define MEM_ALIGNBYTES 8
#else
#define MEM_ALIGNBYTES 8
***************
*** 1064,1070 ****
* This symbol contains the ~name expanded version of ARCHLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define ARCHLIB "c:\\perl\\5.7.1\\lib\\MSWin32-x86-multi-thread" /**/
/*#define ARCHLIB_EXP "" /**/
/* ARCHNAME:
--- 1033,1039 ----
* This symbol contains the ~name expanded version of ARCHLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define ARCHLIB "c:\\perl\\5.7.2\\lib\\MSWin32-x86-multi-thread" /**/
/*#define ARCHLIB_EXP "" /**/
/* ARCHNAME:
***************
*** 1095,1102 ****
* This symbol is the filename expanded version of the BIN symbol, for
* programs that do not want to deal with that at run-time.
*/
! #define BIN "c:\\perl\\5.7.1\\bin\\MSWin32-x86-multi-thread" /**/
! #define BIN_EXP "c:\\perl\\5.7.1\\bin\\MSWin32-x86-multi-thread" /**/
/* PERL_BINCOMPAT_5005:
* This symbol, if defined, indicates that this version of Perl should be
--- 1064,1071 ----
* This symbol is the filename expanded version of the BIN symbol, for
* programs that do not want to deal with that at run-time.
*/
! #define BIN "c:\\perl\\5.7.2\\bin\\MSWin32-x86-multi-thread" /**/
! #define BIN_EXP "c:\\perl\\5.7.2\\bin\\MSWin32-x86-multi-thread" /**/
/* PERL_BINCOMPAT_5005:
* This symbol, if defined, indicates that this version of Perl should be
***************
*** 1122,1128 ****
* so the default case (for NeXT) is big endian to catch them.
* This might matter for NeXT 3.0.
*/
! #if defined(CROSSCOMPILE) || defined(MULTIARCH)
# ifdef __LITTLE_ENDIAN__
# if LONGSIZE == 4
# define BYTEORDER 0x1234
--- 1091,1097 ----
* so the default case (for NeXT) is big endian to catch them.
* This might matter for NeXT 3.0.
*/
! #if defined(USE_CROSS_COMPILE) || defined(MULTIARCH)
# ifdef __LITTLE_ENDIAN__
# if LONGSIZE == 4
# define BYTEORDER 0x1234
***************
*** 1312,1317 ****
--- 1281,1292 ----
*/
/*#define HAS_ENDSERVENT /**/
+ /* HAS_FCHDIR:
+ * This symbol, if defined, indicates that the fchdir routine is
+ * available to change directory using a file descriptor.
+ */
+ /*#define HAS_FCHDIR /**/
+
/* FCNTL_CAN_LOCK:
* This symbol, if defined, indicates that fcntl() can be used
* for file locking. Normally on Unix systems this is defined.
***************
*** 1395,1401 ****
* This symbol, if defined, indicates that the getcwd routine is
* available to get the current working directory.
*/
! /*#define HAS_GETCWD /**/
/* HAS_GETESPWNAM:
* This symbol, if defined, indicates that the getespwnam system call is
--- 1370,1376 ----
* This symbol, if defined, indicates that the getcwd routine is
* available to get the current working directory.
*/
! #define HAS_GETCWD /**/
/* HAS_GETESPWNAM:
* This symbol, if defined, indicates that the getespwnam system call is
***************
*** 1770,1776 ****
--- 1745,1759 ----
* available to split a long double x into a fractional part f and
* an integer part i such that |f| < 1.0 and (f + i) = x.
*/
+ /* HAS_MODFL_POW32_BUG:
+ * This symbol, if defined, indicates that the modfl routine is
+ * broken for long doubles >= pow(2, 32).
+ * For example from 4294967303.150000 one would get 4294967302.000000
+ * and 1.150000. The bug has been seen in certain versions of glibc,
+ * release 2.2.2 is known to be okay.
+ */
/*#define HAS_MODFL /**/
+ /*#define HAS_MODFL_POW32_BUG /**/
/* HAS_MPROTECT:
* This symbol, if defined, indicates that the mprotect system call is
***************
*** 1845,1851 ****
/* HAS_SAFE_BCOPY:
* This symbol, if defined, indicates that the bcopy routine is available
! * to copy potentially overlapping memory blocks. Otherwise you should
* probably use memmove() or memcpy(). If neither is defined, roll your
* own version.
*/
--- 1828,1834 ----
/* HAS_SAFE_BCOPY:
* This symbol, if defined, indicates that the bcopy routine is available
! * to copy potentially overlapping memory blocks. Normally, you should
* probably use memmove() or memcpy(). If neither is defined, roll your
* own version.
*/
***************
*** 1853,1861 ****
/* HAS_SAFE_MEMCPY:
* This symbol, if defined, indicates that the memcpy routine is available
! * to copy potentially overlapping memory blocks. Otherwise you should
! * probably use memmove() or memcpy(). If neither is defined, roll your
! * own version.
*/
/*#define HAS_SAFE_MEMCPY /**/
--- 1836,1844 ----
/* HAS_SAFE_MEMCPY:
* This symbol, if defined, indicates that the memcpy routine is available
! * to copy potentially overlapping memory blocks. If you need to
! * copy overlapping memory blocks, you should check HAS_MEMMOVE and
! * use memmove() instead, if available.
*/
/*#define HAS_SAFE_MEMCPY /**/
***************
*** 2401,2408 ****
--- 2384,2408 ----
* in the <db.h> header file. In older versions of DB, it was
* int, while in newer ones it is size_t.
*/
+ /* DB_VERSION_MAJOR_CFG:
+ * This symbol, if defined, defines the major version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ */
+ /* DB_VERSION_MINOR_CFG:
+ * This symbol, if defined, defines the minor version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
+ /* DB_VERSION_PATCH_CFG:
+ * This symbol, if defined, defines the patch version number of
+ * Berkeley DB found in the <db.h> header when Perl was configured.
+ * For DB version 1 this is always 0.
+ */
#define DB_Hash_t int /**/
#define DB_Prefix_t int /**/
+ #define DB_VERSION_MAJOR_CFG undef /**/
+ #define DB_VERSION_MINOR_CFG undef /**/
+ #define DB_VERSION_PATCH_CFG undef /**/
/* I_GRP:
* This symbol, if defined, indicates to the C program that it should
***************
*** 2918,2925 ****
* This symbol contains the ~name expanded version of PRIVLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define PRIVLIB "c:\\perl\\5.7.1\\lib" /**/
! #define PRIVLIB_EXP (win32_get_privlib("5.7.1")) /**/
/* PTRSIZE:
* This symbol contains the size of a pointer, so that the C preprocessor
--- 2918,2925 ----
* This symbol contains the ~name expanded version of PRIVLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define PRIVLIB "c:\\perl\\5.7.2\\lib" /**/
! #define PRIVLIB_EXP (win32_get_privlib("5.7.2")) /**/
/* PTRSIZE:
* This symbol contains the size of a pointer, so that the C preprocessor
***************
*** 2933,2939 ****
* This macro is to be used to generate uniformly distributed
* random numbers over the range [0., 1.[. You may have to supply
* an 'extern double drand48();' in your program since SunOS 4.1.3
! * doesn't provide you with anything relevant in it's headers.
* See HAS_DRAND48_PROTO.
*/
/* Rand_seed_t:
--- 2933,2939 ----
* This macro is to be used to generate uniformly distributed
* random numbers over the range [0., 1.[. You may have to supply
* an 'extern double drand48();' in your program since SunOS 4.1.3
! * doesn't provide you with anything relevant in its headers.
* See HAS_DRAND48_PROTO.
*/
/* Rand_seed_t:
***************
*** 3022,3028 ****
* This symbol contains the ~name expanded version of SITEARCH, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define SITEARCH "c:\\perl\\site\\5.7.1\\lib\\MSWin32-x86-multi-thread" /**/
/*#define SITEARCH_EXP "" /**/
/* SITELIB:
--- 3022,3028 ----
* This symbol contains the ~name expanded version of SITEARCH, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
! #define SITEARCH "c:\\perl\\site\\5.7.2\\lib\\MSWin32-x86-multi-thread" /**/
/*#define SITEARCH_EXP "" /**/
/* SITELIB:
***************
*** 3045,3052 ****
* removed. The elements in inc_version_list (inc_version_list.U) can
* be tacked onto this variable to generate a list of directories to search.
*/
! #define SITELIB "c:\\perl\\site\\5.7.1\\lib" /**/
! #define SITELIB_EXP (win32_get_sitelib("5.7.1")) /**/
#define SITELIB_STEM "" /**/
/* Size_t_size:
--- 3045,3052 ----
* removed. The elements in inc_version_list (inc_version_list.U) can
* be tacked onto this variable to generate a list of directories to search.
*/
! #define SITELIB "c:\\perl\\site\\5.7.2\\lib" /**/
! #define SITELIB_EXP (win32_get_sitelib("5.7.2")) /**/
#define SITELIB_STEM "" /**/
/* Size_t_size:
***************
*** 3212,3217 ****
--- 3212,3222 ----
* This symbol, if defined, indicates that Perl should
* be built to use the old draft POSIX threads API.
*/
+ /* USE_REENTRANT_API:
+ * This symbol, if defined, indicates that Perl should
+ * try to use the various _r versions of library functions.
+ * This is extremely experimental.
+ */
/*#define USE_5005THREADS /**/
#define USE_ITHREADS /**/
#if defined(USE_5005THREADS) && !defined(USE_ITHREADS)
***************
*** 3218,3223 ****
--- 3223,3229 ----
#define USE_THREADS /* until src is revised*/
#endif
/*#define OLD_PTHREADS_API /**/
+ /*#define USE_REENTRANT_API /**/
/* PERL_VENDORARCH:
* If defined, this symbol contains the name of a private library.
***************
*** 3277,3283 ****
/* PERL_XS_APIVERSION:
* This variable contains the version of the oldest perl binary
* compatible with the present perl. perl.c:incpush() and
! * lib/lib.pm will automatically search in c:\\perl\\site\\5.7.1\\lib\\MSWin32-x86-multi-thread for older
* directories across major versions back to xs_apiversion.
* This is only useful if you have a perl library directory tree
* structured like the default one.
--- 3283,3289 ----
/* PERL_XS_APIVERSION:
* This variable contains the version of the oldest perl binary
* compatible with the present perl. perl.c:incpush() and
! * lib/lib.pm will automatically search in c:\\perl\\site\\5.7.2\\lib\\MSWin32-x86-multi-thread for older
* directories across major versions back to xs_apiversion.
* This is only useful if you have a perl library directory tree
* structured like the default one.
***************
*** 3296,3302 ****
* compatible with the present perl. (That is, pure perl modules
* written for pm_apiversion will still work for the current
* version). perl.c:incpush() and lib/lib.pm will automatically
! * search in c:\\perl\\site\\5.7.1\\lib for older directories across major versions
* back to pm_apiversion. This is only useful if you have a perl
* library directory tree structured like the default one. The
* versioned site_perl library was introduced in 5.005, so that's
--- 3302,3308 ----
* compatible with the present perl. (That is, pure perl modules
* written for pm_apiversion will still work for the current
* version). perl.c:incpush() and lib/lib.pm will automatically
! * search in c:\\perl\\site\\5.7.2\\lib for older directories across major versions
* back to pm_apiversion. This is only useful if you have a perl
* library directory tree structured like the default one. The
* versioned site_perl library was introduced in 5.005, so that's
***************
*** 3309,3314 ****
--- 3315,3386 ----
#define PERL_XS_APIVERSION "5.6.0"
#define PERL_PM_APIVERSION "5.005"
+ /* SETUID_SCRIPTS_ARE_SECURE_NOW:
+ * This symbol, if defined, indicates that the bug that prevents
+ * setuid scripts from being secure is not present in this kernel.
+ */
+ /* DOSUID:
+ * This symbol, if defined, indicates that the C program should
+ * check the script that it is executing for setuid/setgid bits, and
+ * attempt to emulate setuid/setgid on systems that have disabled
+ * setuid #! scripts because the kernel can't do it securely.
+ * It is up to the package designer to make sure that this emulation
+ * is done securely. Among other things, it should do an fstat on
+ * the script it just opened to make sure it really is a setuid/setgid
+ * script, it should make sure the arguments passed correspond exactly
+ * to the argument on the #! line, and it should not trust any
+ * subprocesses to which it must pass the filename rather than the
+ * file descriptor of the script to be executed.
+ */
+ /*#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/
+ /*#define DOSUID /**/
+
+ /* I_STDARG:
+ * This symbol, if defined, indicates that <stdarg.h> exists and should
+ * be included.
+ */
+ /* I_VARARGS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <varargs.h>.
+ */
+ #define I_STDARG /**/
+ /*#define I_VARARGS /**/
+
+ /* USE_CROSS_COMPILE:
+ * This symbol, if defined, indicates that Perl is being cross-compiled.
+ */
+ /* PERL_TARGETARCH:
+ * This symbol, if defined, indicates the target architecture
+ * Perl has been cross-compiled to. Undefined if not a cross-compile.
+ */
+ #ifndef USE_CROSS_COMPILE
+ /*#define USE_CROSS_COMPILE /**/
+ #define PERL_TARGETARCH "undef" /**/
+ #endif
+
+ /* HAS_DBMINIT_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the dbminit() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int dbminit(char *);
+ */
+ /*#define HAS_DBMINIT_PROTO /**/
+
+ /* HAS_FLOCK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the flock() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int flock(int, int);
+ */
+ /*#define HAS_FLOCK_PROTO /**/
+
+ /* HAS_NL_LANGINFO:
+ * This symbol, if defined, indicates that the nl_langinfo routine is
+ * available to return local data. You will also need <langinfo.h>
+ * and therefore I_LANGINFO.
+ */
+ /*#define HAS_NL_LANGINFO /**/
+
/* HAS_SIGPROCMASK:
* This symbol, if defined, indicates that the sigprocmask
* system call is available to examine or change the signal mask
***************
*** 3322,3331 ****
--- 3394,3462 ----
*/
/*#define HAS_SOCKATMARK /**/
+ /* HAS_SOCKATMARK_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the sockatmark() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int sockatmark _((int));
+ */
+ /*#define HAS_SOCKATMARK_PROTO /**/
+
+ /* HAS_SETRESGID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresgid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresgid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+ /*#define HAS_SETRESGID_PROTO /**/
+
+ /* HAS_SETRESUID_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the setresuid() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int setresuid(uid_t ruid, uid_t euid, uid_t suid);
+ */
+ /*#define HAS_SETRESUID_PROTO /**/
+
+ /* HAS_STRFTIME:
+ * This symbol, if defined, indicates that the strftime routine is
+ * available to do time formatting.
+ */
+ #define HAS_STRFTIME /**/
+
+ /* HAS_SYSCALL_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the syscall() function. Otherwise, it is up
+ * to the program to supply one. Good guesses are
+ * extern int syscall(int, ...);
+ * extern int syscall(long, ...);
+ */
+ /*#define HAS_SYSCALL_PROTO /**/
+
/* U32_ALIGNMENT_REQUIRED:
* This symbol, if defined, indicates that you must access
* character data through U32-aligned pointers.
*/
#define U32_ALIGNMENT_REQUIRED /**/
+
+ /* HAS_USLEEP_PROTO:
+ * This symbol, if defined, indicates that the system provides
+ * a prototype for the usleep() function. Otherwise, it is up
+ * to the program to supply one. A good guess is
+ * extern int usleep(useconds_t);
+ */
+ /*#define HAS_USLEEP_PROTO /**/
+
+ /* I_LANGINFO:
+ * This symbol, if defined, indicates that <langinfo.h> exists and
+ * should be included.
+ */
+ /*#define I_LANGINFO /**/
+
+ /* HAS_PTHREAD_ATFORK:
+ * This symbol, if defined, indicates that the pthread_atfork routine
+ * is available setup fork handlers.
+ */
+ /*#define HAS_PTHREAD_ATFORK /**/
#endif
diff -c 'perl-5.7.1/win32/config_sh.PL' 'perl-5.7.2/win32/config_sh.PL'
Index: ./win32/config_sh.PL
*** ./win32/config_sh.PL Sat Apr 7 18:41:49 2001
--- ./win32/config_sh.PL Mon Jul 9 17:11:35 2001
***************
*** 44,51 ****
shift(@{$optref});
}
! $opt{'dynamic_ext'} = join(' ',FindExt::dynamic_extensions());
! $opt{'nonxs_ext'} = join(' ',FindExt::noxs_extensions());
my $pl_h = '../patchlevel.h';
--- 44,64 ----
shift(@{$optref});
}
! my @dynamic = FindExt::dynamic_extensions();
! my @noxs = FindExt::noxs_extensions();
! my @known = sort(@dynamic,split(/\s+/,$opt{'staticext'}),@noxs);
! $opt{'known_extensions'} = join(' ',@known);
!
! if (!$opt{'use5005threads'} || $opt{'use5005threads'} eq 'undef')
! {
! @dynamic = grep(!/Thread/,@dynamic);
! @known = grep(!/Thread/,@dynamic);
! }
!
! $opt{'dynamic_ext'} = join(' ',@dynamic);
! $opt{'nonxs_ext'} = join(' ',@noxs);
!
! $opt{'extensions'} = join(' ',@known);
my $pl_h = '../patchlevel.h';
diff -c 'perl-5.7.1/win32/distclean.bat' 'perl-5.7.2/win32/distclean.bat'
Index: ./win32/distclean.bat
*** ./win32/distclean.bat Tue Mar 6 04:07:33 2001
--- ./win32/distclean.bat Fri Jul 13 15:55:41 2001
***************
*** 6,19 ****
use File::Find;
use ExtUtils::Manifest qw(maniread);
my $files = maniread();
my @dead;
find(sub {
! return if -d $_;
! my $name = $File::Find::name;
! $name =~ s#^\./##;
! unless (exists $files->{$name})
{
! print "new $name\n";
push(@dead,$name);
}
},'.');
--- 6,25 ----
use File::Find;
use ExtUtils::Manifest qw(maniread);
my $files = maniread();
+ my %files;
+ foreach (keys %$files)
+ {
+ $files{lc($_)} = $files->{$_};
+ }
+
my @dead;
find(sub {
! return if -d $_;
! my $name = $File::Find::name;
! $name =~ s#^\./##;
! unless (exists $files{lc($name)})
{
! # print "new $name\n";
push(@dead,$name);
}
},'.');
diff -c 'perl-5.7.1/win32/makefile.mk' 'perl-5.7.2/win32/makefile.mk'
Index: ./win32/makefile.mk
*** ./win32/makefile.mk Tue Apr 10 05:29:17 2001
--- ./win32/makefile.mk Fri Jul 13 17:18:33 2001
***************
*** 1,1242 ****
! #
! # Makefile to build perl on Windows NT using DMAKE.
! # Supported compilers:
! # Visual C++ 2.0 thro 6.0
! # Borland C++ 5.02
! # Mingw32 with gcc-2.95.2 or better **experimental**
! #
! # This is set up to build a perl.exe that runs off a shared library
! # (perl57.dll). Also makes individual DLLs for the XS extensions.
! #
!
! ##
! ## Make sure you read README.win32 *before* you mess with anything here!
! ##
!
! ##
! ## Build configuration. Edit the values below to suit your needs.
! ##
!
! #
! # Set these to wherever you want "dmake install" to put your
! # newly built perl.
! #
! INST_DRV *= c:
! INST_TOP *= $(INST_DRV)\perl
!
! #
! # Comment this out if you DON'T want your perl installation to be versioned.
! # This means that the new installation will overwrite any files from the
! # old installation at the same INST_TOP location. Leaving it enabled is
! # the safest route, as perl adds the extra version directory to all the
! # locations it installs files to. If you disable it, an alternative
! # versioned installation can be obtained by setting INST_TOP above to a
! # path that includes an arbitrary version string.
! #
! INST_VER *= \5.7.1
!
! #
! # Comment this out if you DON'T want your perl installation to have
! # architecture specific components. This means that architecture-
! # specific files will be installed along with the architecture-neutral
! # files. Leaving it enabled is safer and more flexible, in case you
! # want to build multiple flavors of perl and install them together in
! # the same location. Commenting it out gives you a simpler
! # installation that is easier to understand for beginners.
! #
! INST_ARCH *= \$(ARCHNAME)
!
! #
! # uncomment to enable multiple interpreters. This is need for fork()
! # emulation.
! #
! USE_MULTI *= define
!
! #
! # Beginnings of interpreter cloning/threads; still very incomplete.
! # This should be enabled to get the fork() emulation. This needs
! # USE_MULTI as well.
! #
! USE_ITHREADS *= define
!
! #
! # uncomment to enable the implicit "host" layer for all system calls
! # made by perl. This needs USE_MULTI above. This is also needed to
! # get fork().
! #
! USE_IMP_SYS *= define
!
! #
! # uncomment to enable the experimental PerlIO I/O subsystem.
! USE_PERLIO = define
!
! #
! # WARNING! This option is deprecated and will eventually go away (enable
! # USE_ITHREADS instead).
! #
! # uncomment to enable threads-capabilities. This is incompatible with
! # USE_ITHREADS, and is only here for people who may have come to rely
! # on the experimental Thread support that was in 5.005.
! #
! #USE_5005THREADS *= define
!
! #
! # WARNING! This option is deprecated and will eventually go away (enable
! # USE_MULTI instead).
! #
! # uncomment next line if you want to use the PERL_OBJECT build option.
! # DO NOT ENABLE unless you have legacy code that relies on the C++
! # CPerlObj class that was available in 5.005. This cannot be enabled
! # if you ask for USE_5005THREADS above.
! #
! #USE_OBJECT *= define
!
! #
! # uncomment exactly one of the following
! #
! # Visual C++ 2.x
! #CCTYPE *= MSVC20
! # Visual C++ > 2.x and < 6.x
! #CCTYPE *= MSVC
! # Visual C++ >= 6.x
! CCTYPE *= MSVC60
! # Borland 5.02 or later
! #CCTYPE *= BORLAND
! # mingw32+gcc-2.95.2 or better
! #CCTYPE *= GCC
!
! #
! # uncomment this if your Borland compiler is older than v5.4.
! BCCOLD = define
! #
! # uncomment this if you want to use Borland's VCL as your CRT
! #BCCVCL = define
!
! #
! # uncomment this if you are compiling under Windows 95/98 and command.com
! # (not needed if you're running under 4DOS/NT 6.01 or later)
! #IS_WIN95 *= define
!
! #
! # uncomment next line if you want debug version of perl (big,slow)
! # If not enabled, we automatically try to use maximum optimization
! # with all compilers that are known to have a working optimizer.
! #
! CFG *= Debug
!
! #
! # uncomment to enable use of PerlCRT.DLL when using the Visual C compiler.
! # It has patches that fix known bugs in older versions of MSVCRT.DLL.
! # This currently requires VC 5.0 with Service Pack 3 or later.
! # Get it from CPAN at http://www.perl.com/CPAN/authors/id/D/DO/DOUGL/
! # and follow the directions in the package to install.
! #
! # Not recommended if you have VC 6.x and you're not running Windows 9x.
! #
! #USE_PERLCRT *= define
!
! #
! # uncomment to enable linking with setargv.obj under the Visual C
! # compiler. Setting this options enables perl to expand wildcards in
! # arguments, but it may be harder to use alternate methods like
! # File::DosGlob that are more powerful. This option is supported only with
! # Visual C.
! #
! #USE_SETARGV *= define
!
! #
! # if you have the source for des_fcrypt(), uncomment this and make sure the
! # file exists (see README.win32). File should be located in the same
! # directory as this file.
! #
! #CRYPT_SRC *= fcrypt.c
!
! #
! # if you didn't set CRYPT_SRC and if you have des_fcrypt() available in a
! # library, uncomment this, and make sure the library exists (see README.win32)
! # Specify the full pathname of the library.
! #
! #CRYPT_LIB *= fcrypt.lib
!
! #
! # set this if you wish to use perl's malloc
! # WARNING: Turning this on/off WILL break binary compatibility with extensions
! # you may have compiled with/without it. Be prepared to recompile all
! # extensions if you change the default. Currently, this cannot be enabled
! # if you ask for USE_IMP_SYS above.
! #
! #PERL_MALLOC *= define
!
! #
! # set the install locations of the compiler include/libraries
! # Running VCVARS32.BAT is *required* when using Visual C.
! # Some versions of Visual C don't define MSVCDIR in the environment,
! # so you may have to set CCHOME explicitly (spaces in the path name should
! # not be quoted)
! #
! #CCHOME *= F:\borland\bc5
! CCHOME *= $(MSVCDIR)
! #CCHOME *= c:\gcc-2.95.2
! CCINCDIR *= $(CCHOME)\include
! CCLIBDIR *= $(CCHOME)\lib
!
! #
! # Additional compiler flags can be specified here.
! #
!
! #
! # This should normally be disabled. Adding -DPERL_POLLUTE enables support
! # for old symbols by default, at the expense of extreme pollution. You most
! # probably just want to build modules that won't compile with
! # perl Makefile.PL POLLUTE=1
! # instead of enabling this. Please report such modules to the respective
! # authors.
! #
! #BUILDOPT += -DPERL_POLLUTE
!
! #
! # This should normally be disabled. Enabling it will disable the File::Glob
! # implementation of CORE::glob.
! #
! #BUILDOPT += -DPERL_EXTERNAL_GLOB
!
! #
! # This should normally be disabled. Enabling it causes perl to read scripts
! # in text mode (which is the 5.005 behavior) and will break ByteLoader.
! #BUILDOPT += -DPERL_TEXTMODE_SCRIPTS
!
! #
! # specify semicolon-separated list of extra directories that modules will
! # look for libraries (spaces in path names need not be quoted)
! #
! EXTRALIBDIRS *=
!
! #
! # set this to point to cmd.exe (only needed if you use some
! # alternate shell that doesn't grok cmd.exe style commands)
! #
! #SHELL *= g:\winnt\system32\cmd.exe
!
! #
! # set this to your email address (perl will guess a value from
! # from your loginname and your hostname, which may not be right)
! #
! #EMAIL *=
!
! ##
! ## Build configuration ends.
! ##
!
! ##################### CHANGE THESE ONLY IF YOU MUST #####################
!
! .IF "$(CRYPT_SRC)$(CRYPT_LIB)" == ""
! D_CRYPT = undef
! .ELSE
! D_CRYPT = define
! CRYPT_FLAG = -DHAVE_DES_FCRYPT
! .ENDIF
!
! .IF "$(USE_OBJECT)" == "define"
! PERL_MALLOC != undef
! USE_5005THREADS != undef
! USE_MULTI != undef
! USE_IMP_SYS != define
! .ENDIF
!
! PERL_MALLOC *= undef
!
! USE_5005THREADS *= undef
!
! .IF "$(USE_5005THREADS)" == "define"
! USE_ITHREADS != undef
! .ENDIF
!
! .IF "$(USE_IMP_SYS)" == "define"
! PERL_MALLOC != undef
! .ENDIF
!
! USE_MULTI *= undef
! USE_OBJECT *= undef
! USE_ITHREADS *= undef
! USE_IMP_SYS *= undef
! USE_PERLIO *= undef
! USE_PERLCRT *= undef
!
! .IF "$(USE_IMP_SYS)$(USE_MULTI)$(USE_5005THREADS)$(USE_OBJECT)" == "defineundefundefundef"
! USE_MULTI != define
! .ENDIF
!
! .IF "$(USE_ITHREADS)$(USE_MULTI)$(USE_OBJECT)" == "defineundefundef"
! USE_MULTI != define
! USE_5005THREADS != undef
! .ENDIF
!
! .IF "$(USE_MULTI)$(USE_5005THREADS)$(USE_OBJECT)" != "undefundefundef"
! BUILDOPT += -DPERL_IMPLICIT_CONTEXT
! .ENDIF
!
! .IF "$(USE_IMP_SYS)" != "undef"
! BUILDOPT += -DPERL_IMPLICIT_SYS
! .ENDIF
!
! .IMPORT .IGNORE : PROCESSOR_ARCHITECTURE
!
! PROCESSOR_ARCHITECTURE *= x86
!
! .IF "$(USE_OBJECT)" == "define"
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-object
! .ELIF "$(USE_5005THREADS)" == "define"
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-thread
! .ELIF "$(USE_MULTI)" == "define"
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-multi
! .ELSE
! .IF "$(USE_PERLIO)" == "define"
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-perlio
! .ELSE
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)
! .ENDIF
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)
! .ENDIF
!
! .IF "$(USE_ITHREADS)" == "define"
! ARCHNAME !:= $(ARCHNAME)-thread
! .ENDIF
!
! # Visual Studio 98 specific
! .IF "$(CCTYPE)" == "MSVC60"
!
! # VC 6.0 can load the socket dll on demand. Makes the test suite
! # run in about 10% less time.
! DELAYLOAD *= -DELAYLOAD:wsock32.dll -DELAYLOAD:shell32.dll delayimp.lib
!
! .IF "$(CFG)" == "Debug"
! .ELSE
! # VC 6.0 seems capable of compiling perl correctly with optimizations
! # enabled. Anything earlier fails tests.
! CFG *= Optimize
! .ENDIF
! .ENDIF
!
! ARCHDIR = ..\lib\$(ARCHNAME)
! COREDIR = ..\lib\CORE
! AUTODIR = ..\lib\auto
! LIBDIR = ..\lib
! EXTDIR = ..\ext
! PODDIR = ..\pod
! EXTUTILSDIR = $(LIBDIR)\ExtUtils
!
! #
! INST_SCRIPT = $(INST_TOP)$(INST_VER)\bin
! INST_BIN = $(INST_SCRIPT)$(INST_ARCH)
! INST_LIB = $(INST_TOP)$(INST_VER)\lib
! INST_ARCHLIB = $(INST_LIB)$(INST_ARCH)
! INST_COREDIR = $(INST_ARCHLIB)\CORE
! INST_POD = $(INST_LIB)\pod
! INST_HTML = $(INST_TOP)$(INST_VER)\html
!
! #
! # Programs to compile, build .lib files and link
! #
!
! .USESHELL :
!
! .IF "$(CCTYPE)" == "BORLAND"
!
! CC = bcc32
! .IF "$(BCCOLD)" != "define"
! LINK32 = ilink32
! .ELSE
! LINK32 = tlink32
! .ENDIF
! LIB32 = tlib /P128
! IMPLIB = implib -c
! RSC = rc
!
! #
! # Options
! #
! INCLUDES = -I$(COREDIR) -I.\include -I. -I.. -I"$(CCINCDIR)"
! #PCHFLAGS = -H -Hc -H=c:\temp\bcmoduls.pch
! DEFINES = -DWIN32 $(CRYPT_FLAG)
! LOCDEFS = -DPERLDLL -DPERL_CORE
! SUBSYS = console
! CXX_FLAG = -P
!
! LIBC = cw32mti.lib
! LIBFILES = $(CRYPT_LIB) import32.lib $(LIBC)
!
! .IF "$(CFG)" == "Debug"
! OPTIMIZE = -v -D_RTLDLL -DDEBUGGING
! LINK_DBG = -v
! .ELSE
! OPTIMIZE = -O2 -D_RTLDLL
! LINK_DBG =
! .ENDIF
!
! CFLAGS = -w -g0 -tWM -tWD $(INCLUDES) $(DEFINES) $(LOCDEFS) \
! $(PCHFLAGS) $(OPTIMIZE)
! LINK_FLAGS = $(LINK_DBG) -L"$(INST_COREDIR)" -L"$(CCLIBDIR)"
! OBJOUT_FLAG = -o
! EXEOUT_FLAG = -e
! LIBOUT_FLAG =
! .IF "$(BCCOLD)" != "define"
! LINK_FLAGS += -Gn
! DEFINES += -D_MT
! .END
! .IF "$(BCCVCL)" == "define"
! LIBC = cp32mti.lib vcl.lib vcl50.lib vclx50.lib vcle50.lib
! LINK_FLAGS += -L"$(CCLIBDIR)\Release"
! .END
!
!
! .ELIF "$(CCTYPE)" == "GCC"
!
! CC = gcc
! LINK32 = gcc
! LIB32 = ar rc
! IMPLIB = dlltool
! RSC = rc
!
! i = .i
! o = .o
! a = .a
!
! #
! # Options
! #
!
! INCLUDES = -I.\include -I. -I.. -I$(COREDIR)
! DEFINES = -DWIN32 $(CRYPT_FLAG)
! LOCDEFS = -DPERLDLL -DPERL_CORE
! SUBSYS = console
! CXX_FLAG = -xc++
!
! LIBC = -lmsvcrt
!
! # same libs as MSVC
! LIBFILES = $(CRYPT_LIB) $(LIBC) \
! -lmoldname -lkernel32 -luser32 -lgdi32 \
! -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 \
! -loleaut32 -lnetapi32 -luuid -lwsock32 -lmpr \
! -lwinmm -lversion -lodbc32
!
! .IF "$(CFG)" == "Debug"
! OPTIMIZE = -g -O2 -DDEBUGGING
! LINK_DBG = -g
! .ELSE
! OPTIMIZE = -g -O2
! LINK_DBG = -g
! .ENDIF
!
! CFLAGS = $(INCLUDES) $(DEFINES) $(LOCDEFS) $(OPTIMIZE)
! LINK_FLAGS = $(LINK_DBG) -L"$(INST_COREDIR)" -L"$(CCLIBDIR)"
! OBJOUT_FLAG = -o
! EXEOUT_FLAG = -o
! LIBOUT_FLAG =
!
! # NOTE: we assume that GCC uses MSVCRT.DLL
! BUILDOPT += -fno-strict-aliasing -DPERL_MSVCRT_READFIX
!
! .ELSE
!
! CC = cl
! LINK32 = link
! LIB32 = $(LINK32) -lib
! RSC = rc
!
! #
! # Options
! #
!
! INCLUDES = -I$(COREDIR) -I.\include -I. -I..
! #PCHFLAGS = -Fpc:\temp\vcmoduls.pch -YX
! DEFINES = -DWIN32 -D_CONSOLE -DNO_STRICT $(CRYPT_FLAG)
! LOCDEFS = -DPERLDLL -DPERL_CORE
! SUBSYS = console
! CXX_FLAG = -TP -GX
!
! .IF "$(USE_PERLCRT)" != "define"
! LIBC = msvcrt.lib
! .ELSE
! LIBC = PerlCRT.lib
! .ENDIF
!
! PERLEXE_RES =
! PERLDLL_RES =
!
! .IF "$(CFG)" == "Debug"
! .IF "$(CCTYPE)" == "MSVC20"
! OPTIMIZE = -Od -MD -Z7 -DDEBUGGING
! LINK_DBG = -debug -pdb:none
! .ELSE
! # -Zi requires .pdb file(s)
! #OPTIMIZE = -Od -MD -Zi -DDEBUGGING
! #LINK_DBG = -debug
! OPTIMIZE = -O1 -MD -Z7 -DDEBUGGING
! LINK_DBG = -debug -debugtype:both -pdb:none
! .ENDIF
! .ELSE
! .IF "$(CFG)" == "Optimize"
! # -O1 yields smaller code, which turns out to be faster than -O2
! #OPTIMIZE = -O2 -MD -DNDEBUG
! OPTIMIZE = -O1 -MD -DNDEBUG
! .ELSE
! OPTIMIZE = -Od -MD -DNDEBUG
! .ENDIF
! LINK_DBG = -release
! .ENDIF
!
! LIBBASEFILES = $(CRYPT_LIB) \
! oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib \
! comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib \
! netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib \
! version.lib odbc32.lib odbccp32.lib
!
! # we add LIBC here, since we may be using PerlCRT.dll
! LIBFILES = $(LIBBASEFILES) $(LIBC)
!
! CFLAGS = -nologo -Gf -W3 $(INCLUDES) $(DEFINES) $(LOCDEFS) \
! $(PCHFLAGS) $(OPTIMIZE)
! LINK_FLAGS = -nologo -nodefaultlib $(LINK_DBG) \
! -libpath:"$(INST_COREDIR)" \
! -machine:$(PROCESSOR_ARCHITECTURE)
! OBJOUT_FLAG = -Fo
! EXEOUT_FLAG = -Fe
! LIBOUT_FLAG = /out:
!
! .IF "$(USE_PERLCRT)" != "define"
! BUILDOPT += -DPERL_MSVCRT_READFIX
! .ENDIF
!
! .ENDIF
!
! .IF "$(USE_OBJECT)" == "define"
! OPTIMIZE += $(CXX_FLAG)
! BUILDOPT += -DPERL_OBJECT
! .ENDIF
!
! CFLAGS_O = $(CFLAGS) $(BUILDOPT)
!
! # used to allow local linking flags that are not propogated into Config.pm,
! # currently unused
! # -- BKS, 12-12-1999
! PRIV_LINK_FLAGS *=
! BLINK_FLAGS = $(PRIV_LINK_FLAGS) $(LINK_FLAGS)
!
! #################### do not edit below this line #######################
! ############# NO USER-SERVICEABLE PARTS BEYOND THIS POINT ##############
!
! o *= .obj
! a *= .lib
!
! LKPRE = INPUT (
! LKPOST = )
!
! #
! # Rules
! #
!
! .SUFFIXES : .c .i $(o) .dll $(a) .exe .rc .res
!
! .c$(o):
! $(CC) -c $(null,$(<:d) $(NULL) -I$(<:d)) $(CFLAGS_O) $(OBJOUT_FLAG)$@ $<
!
! .c.i:
! $(CC) -c $(null,$(<:d) $(NULL) -I$(<:d)) $(CFLAGS_O) -E $< >$@
!
! .y.c:
! $(NOOP)
!
! $(o).dll:
! .IF "$(CCTYPE)" == "BORLAND"
! $(LINK32) -Tpd -ap $(BLINK_FLAGS) c0d32$(o) $<,$@,,$(LIBFILES),$(*B).def
! $(IMPLIB) $(*B).lib $@
! .ELIF "$(CCTYPE)" == "GCC"
! $(LINK32) -o $@ $(BLINK_FLAGS) $< $(LIBFILES)
! $(IMPLIB) --input-def $(*B).def --output-lib $(*B).a $@
! .ELSE
! $(LINK32) -dll -subsystem:windows -implib:$(*B).lib -def:$(*B).def \
! -out:$@ $(BLINK_FLAGS) $(LIBFILES) $< $(LIBPERL)
! .ENDIF
!
! .rc.res:
! $(RSC) -i.. $<
!
! #
! # various targets
! MINIPERL = ..\miniperl.exe
! MINIDIR = .\mini
! PERLEXE = ..\perl.exe
! WPERLEXE = ..\wperl.exe
! GLOBEXE = ..\perlglob.exe
! CONFIGPM = ..\lib\Config.pm
! MINIMOD = ..\lib\ExtUtils\Miniperl.pm
! X2P = ..\x2p\a2p.exe
!
! # Nominate a target which causes extensions to be re-built
! # This used to be $(PERLEXE), but at worst it is the .dll that they depend
! # on and really only the interface - i.e. the .def file used to export symbols
! # from the .dll
! PERLDEP = perldll.def
!
!
! PL2BAT = bin\pl2bat.pl
! GLOBBAT = bin\perlglob.bat
!
! UTILS = \
! ..\utils\h2ph \
! ..\utils\splain \
! ..\utils\dprofpp \
! ..\utils\perlbug \
! ..\utils\pl2pm \
! ..\utils\c2ph \
! ..\utils\h2xs \
! ..\utils\perldoc \
! ..\utils\perlcc \
! ..\pod\checkpods \
! ..\pod\pod2html \
! ..\pod\pod2latex \
! ..\pod\pod2man \
! ..\pod\pod2text \
! ..\pod\pod2usage \
! ..\pod\podchecker \
! ..\pod\podselect \
! ..\x2p\find2perl \
! ..\x2p\s2p \
! bin\exetype.pl \
! bin\runperl.pl \
! bin\pl2bat.pl \
! bin\perlglob.pl \
! bin\search.pl
!
! .IF "$(CCTYPE)" == "BORLAND"
!
! CFGSH_TMPL = config.bc
! CFGH_TMPL = config_H.bc
!
! .ELIF "$(CCTYPE)" == "GCC"
!
! CFGSH_TMPL = config.gc
! CFGH_TMPL = config_H.gc
! PERLIMPLIB = ..\libperl57$(a)
!
! .ELSE
!
! CFGSH_TMPL = config.vc
! CFGH_TMPL = config_H.vc
!
! .ENDIF
!
! # makedef.pl must be updated if this changes, and this should normally
! # only change when there is an incompatible revision of the public API.
! # XXX so why did we change it from perl56 to perl57?
! PERLIMPLIB *= ..\perl57$(a)
! PERLDLL = ..\perl57.dll
!
! XCOPY = xcopy /f /r /i /d
! RCOPY = xcopy /f /r /i /e /d
! NOOP = @echo
!
! #
! # filenames given to xsubpp must have forward slashes (since it puts
! # full pathnames in #line strings)
! XSUBPP = ..\$(MINIPERL) -I..\..\lib ..\$(EXTUTILSDIR)\xsubpp \
! -C++ -prototypes
!
! MICROCORE_SRC = \
! ..\av.c \
! ..\deb.c \
! ..\doio.c \
! ..\doop.c \
! ..\dump.c \
! ..\globals.c \
! ..\gv.c \
! ..\hv.c \
! ..\mg.c \
! ..\op.c \
! ..\perl.c \
! ..\perlapi.c \
! ..\perly.c \
! ..\pp.c \
! ..\pp_ctl.c \
! ..\pp_hot.c \
! ..\pp_sys.c \
! ..\regcomp.c \
! ..\regexec.c \
! ..\run.c \
! ..\scope.c \
! ..\sv.c \
! ..\taint.c \
! ..\toke.c \
! ..\universal.c \
! ..\utf8.c \
! ..\util.c \
! ..\xsutils.c
!
! EXTRACORE_SRC += perllib.c
!
! .IF "$(PERL_MALLOC)" == "define"
! EXTRACORE_SRC += ..\malloc.c
! .ENDIF
!
! .IF "$(USE_OBJECT)" != "define"
! EXTRACORE_SRC += ..\perlio.c
! .ENDIF
!
! WIN32_SRC = \
! .\win32.c \
! .\win32sck.c \
! .\win32thread.c
!
! .IF "$(CRYPT_SRC)" != ""
! WIN32_SRC += .\$(CRYPT_SRC)
! .ENDIF
!
! DLL_SRC = $(DYNALOADER).c
!
! X2P_SRC = \
! ..\x2p\a2p.c \
! ..\x2p\hash.c \
! ..\x2p\str.c \
! ..\x2p\util.c \
! ..\x2p\walk.c
!
! CORE_NOCFG_H = \
! ..\av.h \
! ..\cop.h \
! ..\cv.h \
! ..\dosish.h \
! ..\embed.h \
! ..\form.h \
! ..\gv.h \
! ..\handy.h \
! ..\hv.h \
! ..\iperlsys.h \
! ..\mg.h \
! ..\nostdio.h \
! ..\op.h \
! ..\opcode.h \
! ..\perl.h \
! ..\perlapi.h \
! ..\perlsdio.h \
! ..\perlsfio.h \
! ..\perly.h \
! ..\pp.h \
! ..\proto.h \
! ..\regexp.h \
! ..\scope.h \
! ..\sv.h \
! ..\thread.h \
! ..\unixish.h \
! ..\utf8.h \
! ..\util.h \
! ..\warnings.h \
! ..\XSUB.h \
! ..\EXTERN.h \
! ..\perlvars.h \
! ..\intrpvar.h \
! ..\thrdvar.h \
! .\include\dirent.h \
! .\include\netdb.h \
! .\include\sys\socket.h \
! .\win32.h
!
! CORE_H = $(CORE_NOCFG_H) .\config.h
!
! MICROCORE_OBJ = $(MICROCORE_SRC:db:+$(o))
! CORE_OBJ = $(MICROCORE_OBJ) $(EXTRACORE_SRC:db:+$(o))
! WIN32_OBJ = $(WIN32_SRC:db:+$(o))
! MINICORE_OBJ = $(MINIDIR)\{$(MICROCORE_OBJ:f) miniperlmain$(o) perlio$(o)}
! MINIWIN32_OBJ = $(MINIDIR)\{$(WIN32_OBJ:f)}
! MINI_OBJ = $(MINICORE_OBJ) $(MINIWIN32_OBJ)
! DLL_OBJ = $(DLL_SRC:db:+$(o))
! X2P_OBJ = $(X2P_SRC:db:+$(o))
!
! PERLDLL_OBJ = $(CORE_OBJ)
! PERLEXE_OBJ = perlmain$(o)
!
! PERLDLL_OBJ += $(WIN32_OBJ) $(DLL_OBJ)
!
! .IF "$(USE_SETARGV)" != ""
! SETARGV_OBJ = setargv$(o)
! .ENDIF
!
! DYNAMIC_EXT = Socket IO Fcntl Opcode SDBM_File POSIX attrs Thread B re \
! Data/Dumper Devel/Peek ByteLoader Devel/DProf File/Glob \
! Sys/Hostname Storable Filter/Util/Call Encode \
! Digest/MD5 PerlIO/Scalar MIME/Base64
! STATIC_EXT = DynaLoader
! NONXS_EXT = Errno
!
! DYNALOADER = $(EXTDIR)\DynaLoader\DynaLoader
!
! POD2HTML = $(PODDIR)\pod2html
! POD2MAN = $(PODDIR)\pod2man
! POD2LATEX = $(PODDIR)\pod2latex
! POD2TEXT = $(PODDIR)\pod2text
!
! # vars must be separated by "\t+~\t+", since we're using the tempfile
! # version of config_sh.pl (we were overflowing someone's buffer by
! # trying to fit them all on the command line)
! # -- BKS 10-17-1999
! CFG_VARS = \
! INST_DRV=$(INST_DRV) ~ \
! INST_TOP=$(INST_TOP:s/\/\\/) ~ \
! INST_VER=$(INST_VER:s/\/\\/) ~ \
! INST_ARCH=$(INST_ARCH) ~ \
! archname=$(ARCHNAME) ~ \
! cc=$(CC) ~ \
! ld=$(LINK32) ~ \
! ccflags=$(OPTIMIZE) $(DEFINES) $(BUILDOPT) ~ \
! cf_email=$(EMAIL) ~ \
! d_crypt=$(D_CRYPT) ~ \
! d_mymalloc=$(PERL_MALLOC) ~ \
! libs=$(LIBFILES:f) ~ \
! incpath=$(CCINCDIR:s/\/\\/) ~ \
! libperl=$(PERLIMPLIB:f) ~ \
! libpth=$(CCLIBDIR:s/\/\\/);$(EXTRALIBDIRS:s/\/\\/) ~ \
! libc=$(LIBC) ~ \
! make=dmake ~ \
! _o=$(o) obj_ext=$(o) ~ \
! _a=$(a) lib_ext=$(a) ~ \
! static_ext=$(STATIC_EXT) ~ \
! use5005threads=$(USE_5005THREADS) ~ \
! useithreads=$(USE_ITHREADS) ~ \
! usethreads=$(USE_5005THREADS) ~ \
! usemultiplicity=$(USE_MULTI) ~ \
! useperlio=$(USE_PERLIO) ~ \
! LINK_FLAGS=$(LINK_FLAGS:s/\/\\/) ~ \
! optimize=$(OPTIMIZE)
!
! #
! # set up targets varying between Win95 and WinNT builds
! #
!
! .IF "$(IS_WIN95)" == "define"
! MK2 = .\makefile.95
! RIGHTMAKE = __switch_makefiles
! NOOP = @rem
! .ELSE
! MK2 = __not_needed
! RIGHTMAKE =
! .ENDIF
!
! #
! # Top targets
! #
!
! all : .\config.h $(GLOBEXE) $(MINIPERL) $(MK2) \
! $(RIGHTMAKE) $(MINIMOD) $(CONFIGPM) $(PERLEXE) \
! $(X2P) Extensions
!
! $(DYNALOADER)$(o) : $(DYNALOADER).c $(CORE_H) $(EXTDIR)\DynaLoader\dlutils.c
!
! #----------------------------------------------------------------
!
! #-------------------- BEGIN Win95 SPECIFIC ----------------------
!
! # this target is a jump-off point for Win95
! # 1. it switches to the Win95-specific makefile if it exists
! # (__do_switch_makefiles)
! # 2. it prints a message when the Win95-specific one finishes (__done)
! # 3. it then kills this makefile by trying to make __no_such_target
!
! __switch_makefiles: __do_switch_makefiles __done __no_such_target
!
! __do_switch_makefiles:
! .IF "$(NOTFIRST)" != "true"
! if exist $(MK2) $(MAKE:s/-S//) -f $(MK2) $(MAKETARGETS) NOTFIRST=true
! .ELSE
! $(NOOP)
! .ENDIF
!
! .IF "$(NOTFIRST)" != "true"
! __done:
! @echo Build process complete. Ignore any errors after this message.
! @echo Run "dmake test" to test and "dmake install" to install
!
! .ELSE
! # dummy targets for Win95-specific makefile
!
! __done:
! $(NOOP)
!
! __no_such_target:
! $(NOOP)
!
! .ENDIF
!
! # This target is used to generate the new makefile (.\makefile.95) for Win95
!
! .\makefile.95: .\makefile.mk
! $(MINIPERL) genmk95.pl makefile.mk $(MK2)
!
! #--------------------- END Win95 SPECIFIC ---------------------
!
! # a blank target for when builds don't need to do certain things
! # this target added for Win95 port but used to keep the WinNT port able to
! # use this file
! __not_needed:
! $(NOOP)
!
! $(GLOBEXE) : perlglob$(o)
! .IF "$(CCTYPE)" == "BORLAND"
! $(CC) -c -w -v -tWM -I"$(CCINCDIR)" perlglob.c
! $(LINK32) -Tpe -ap $(BLINK_FLAGS) c0x32$(o) perlglob$(o) \
! "$(CCLIBDIR)\32BIT\wildargs$(o)",$@,,import32.lib cw32mt.lib,
! .ELIF "$(CCTYPE)" == "GCC"
! $(LINK32) $(BLINK_FLAGS) -mconsole -o $@ perlglob$(o) $(LIBFILES)
! .ELSE
! $(LINK32) $(BLINK_FLAGS) $(LIBFILES) -out:$@ -subsystem:$(SUBSYS) \
! perlglob$(o) setargv$(o)
! .ENDIF
!
! perlglob$(o) : perlglob.c
!
! config.w32 : $(CFGSH_TMPL)
! copy $(CFGSH_TMPL) config.w32
!
! .\config.h : $(CFGH_TMPL) $(CORE_NOCFG_H)
! -del /f config.h
! copy $(CFGH_TMPL) config.h
!
! ..\config.sh : config.w32 $(MINIPERL) config_sh.PL FindExt.pm
! $(MINIPERL) -I..\lib config_sh.PL --cfgsh-option-file \
! $(mktmp $(CFG_VARS)) config.w32 > ..\config.sh
!
! # this target is for when changes to the main config.sh happen
! # edit config.{b,v,g}c and make this target once for each supported
! # compiler (e.g. `dmake CCTYPE=BORLAND regen_config_h`)
! regen_config_h:
! perl config_sh.PL --cfgsh-option-file $(mktmp $(CFG_VARS)) \
! $(CFGSH_TMPL) > ..\config.sh
! -cd .. && del /f perl.exe
! cd .. && perl configpm
! -del /f $(CFGH_TMPL)
! -mkdir $(COREDIR)
! -perl -I..\lib config_h.PL "INST_VER=$(INST_VER)"
! rename config.h $(CFGH_TMPL)
!
! $(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl
! cd .. && miniperl configpm
! if exist lib\* $(RCOPY) lib\*.* ..\lib\$(NULL)
! $(XCOPY) ..\*.h $(COREDIR)\*.*
! $(XCOPY) *.h $(COREDIR)\*.*
! $(XCOPY) ..\ext\re\re.pm $(LIBDIR)\*.*
! $(RCOPY) include $(COREDIR)\*.*
! $(MINIPERL) -I..\lib config_h.PL "INST_VER=$(INST_VER)" \
! || $(MAKE) $(MAKEMACROS) $(CONFIGPM) $(MAKEFILE)
!
! $(MINIPERL) : $(MINIDIR) $(MINI_OBJ) $(CRTIPMLIBS)
! .IF "$(CCTYPE)" == "BORLAND"
! $(LINK32) -Tpe -ap $(BLINK_FLAGS) \
! @$(mktmp c0x32$(o) $(MINI_OBJ:s,\,\\),$(@:s,\,\\),,$(LIBFILES),)
! .ELIF "$(CCTYPE)" == "GCC"
! $(LINK32) -v -mconsole -o $@ $(BLINK_FLAGS) \
! $(mktmp $(LKPRE) $(MINI_OBJ:s,\,\\) $(LIBFILES) $(LKPOST))
! .ELSE
! $(LINK32) -subsystem:console -out:$@ \
! @$(mktmp $(BLINK_FLAGS) $(LIBFILES) $(MINI_OBJ:s,\,\\))
! .ENDIF
!
! $(MINIDIR) :
! if not exist "$(MINIDIR)" mkdir "$(MINIDIR)"
!
! $(MINICORE_OBJ) : $(CORE_NOCFG_H)
! $(CC) -c $(CFLAGS) -DPERL_EXTERNAL_GLOB $(OBJOUT_FLAG)$@ ..\$(*B).c
!
! $(MINIWIN32_OBJ) : $(CORE_NOCFG_H)
! $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $(*B).c
!
! # -DPERL_IMPLICIT_SYS needs C++ for perllib.c
! # rules wrapped in .IFs break Win9X build (we end up with unbalanced []s unless
! # unless the .IF is true), so instead we use a .ELSE with the default.
! # This is the only file that depends on perlhost.h, vmem.h, and vdir.h
!
! perllib$(o) : perllib.c .\perlhost.h .\vdir.h .\vmem.h
! .IF "$(USE_IMP_SYS)$(USE_OBJECT)" == "defineundef"
! $(CC) -c -I. $(CFLAGS_O) $(CXX_FLAG) $(OBJOUT_FLAG)$@ perllib.c
! .ELSE
! $(CC) -c -I. $(CFLAGS_O) $(OBJOUT_FLAG)$@ perllib.c
! .ENDIF
!
! # 1. we don't want to rebuild miniperl.exe when config.h changes
! # 2. we don't want to rebuild miniperl.exe with non-default config.h
! $(MINI_OBJ) : $(CORE_NOCFG_H)
!
! $(WIN32_OBJ) : $(CORE_H)
! $(CORE_OBJ) : $(CORE_H)
! $(DLL_OBJ) : $(CORE_H)
! $(X2P_OBJ) : $(CORE_H)
!
! perldll.def : $(MINIPERL) $(CONFIGPM) ..\global.sym ..\pp.sym ..\makedef.pl
! $(MINIPERL) -w ..\makedef.pl PLATFORM=win32 $(OPTIMIZE) $(DEFINES) \
! $(BUILDOPT) CCTYPE=$(CCTYPE) > perldll.def
!
! $(PERLDLL): perldll.def $(PERLDLL_OBJ) $(PERLDLL_RES)
! .IF "$(CCTYPE)" == "BORLAND"
! $(LINK32) -Tpd -ap $(BLINK_FLAGS) \
! @$(mktmp c0d32$(o) $(PERLDLL_OBJ:s,\,\\)\n \
! $@,\n \
! $(LIBFILES)\n \
! perldll.def\n)
! $(IMPLIB) $*.lib $@
! .ELIF "$(CCTYPE)" == "GCC"
! $(LINK32) -mdll -o $@ -Wl,--base-file -Wl,perl.base $(BLINK_FLAGS) \
! $(mktmp $(LKPRE) $(PERLDLL_OBJ:s,\,\\) $(LIBFILES) $(LKPOST))
! dlltool --output-lib $(PERLIMPLIB) \
! --dllname $(PERLDLL:b).dll \
! --def perldll.def \
! --base-file perl.base \
! --output-exp perl.exp
! $(LINK32) -mdll -o $@ $(BLINK_FLAGS) \
! $(mktmp $(LKPRE) $(PERLDLL_OBJ:s,\,\\) $(LIBFILES) \
! perl.exp $(LKPOST))
! .ELSE
! $(LINK32) -dll -def:perldll.def -out:$@ \
! @$(mktmp -base:0x28000000 $(BLINK_FLAGS) $(DELAYLOAD) $(LIBFILES) \
! $(PERLDLL_RES) $(PERLDLL_OBJ:s,\,\\))
! .ENDIF
! $(XCOPY) $(PERLIMPLIB) $(COREDIR)
!
! $(MINIMOD) : $(MINIPERL) ..\minimod.pl
! cd .. && miniperl minimod.pl > lib\ExtUtils\Miniperl.pm
!
! ..\x2p\a2p$(o) : ..\x2p\a2p.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\a2p.c
!
! ..\x2p\hash$(o) : ..\x2p\hash.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\hash.c
!
! ..\x2p\str$(o) : ..\x2p\str.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\str.c
!
! ..\x2p\util$(o) : ..\x2p\util.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\util.c
!
! ..\x2p\walk$(o) : ..\x2p\walk.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\walk.c
!
! $(X2P) : $(MINIPERL) $(X2P_OBJ)
! $(MINIPERL) ..\x2p\find2perl.PL
! $(MINIPERL) ..\x2p\s2p.PL
! .IF "$(CCTYPE)" == "BORLAND"
! $(LINK32) -Tpe -ap $(BLINK_FLAGS) \
! @$(mktmp c0x32$(o) $(X2P_OBJ:s,\,\\),$(@:s,\,\\),,$(LIBFILES),)
! .ELIF "$(CCTYPE)" == "GCC"
! $(LINK32) -v -o $@ $(BLINK_FLAGS) \
! $(mktmp $(LKPRE) $(X2P_OBJ:s,\,\\) $(LIBFILES) $(LKPOST))
! .ELSE
! $(LINK32) -subsystem:console -out:$@ \
! @$(mktmp $(BLINK_FLAGS) $(LIBFILES) $(X2P_OBJ:s,\,\\))
! .ENDIF
!
! perlmain.c : runperl.c
! copy runperl.c perlmain.c
!
! perlmain$(o) : perlmain.c
! $(CC) $(CFLAGS_O) -UPERLDLL $(OBJOUT_FLAG)$@ -c perlmain.c
!
! $(PERLEXE): $(PERLDLL) $(CONFIGPM) $(PERLEXE_OBJ) $(PERLEXE_RES)
! .IF "$(CCTYPE)" == "BORLAND"
! $(LINK32) -Tpe -ap $(BLINK_FLAGS) \
! @$(mktmp c0x32$(o) $(PERLEXE_OBJ:s,\,\\)\n \
! $(@:s,\,\\),\n \
! $(PERLIMPLIB) $(LIBFILES)\n)
! .ELIF "$(CCTYPE)" == "GCC"
! $(LINK32) -mconsole -o $@ $(BLINK_FLAGS) \
! $(PERLEXE_OBJ) $(PERLIMPLIB) $(LIBFILES)
! .ELSE
! $(LINK32) -subsystem:console -out:$@ -stack:0x1000000 $(BLINK_FLAGS) \
! $(LIBFILES) $(PERLEXE_OBJ) $(SETARGV_OBJ) $(PERLIMPLIB) $(PERLEXE_RES)
! .ENDIF
! copy $(PERLEXE) $(WPERLEXE)
! $(MINIPERL) -I..\lib bin\exetype.pl $(WPERLEXE) WINDOWS
! copy splittree.pl ..
! $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR)
!
! $(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM)
! if not exist $(AUTODIR) mkdir $(AUTODIR)
! cd $(EXTDIR)\$(*B) && ..\$(MINIPERL) -I..\..\lib $(*B)_pm.PL
! cd $(EXTDIR)\$(*B) && ..\$(MINIPERL) -I..\..\lib XSLoader_pm.PL
! $(XCOPY) $(EXTDIR)\$(*B)\$(*B).pm $(LIBDIR)\$(NULL)
! $(XCOPY) $(EXTDIR)\$(*B)\XSLoader.pm $(LIBDIR)\$(NULL)
! cd $(EXTDIR)\$(*B) && $(XSUBPP) dl_win32.xs > $(*B).c
! $(XCOPY) $(EXTDIR)\$(*B)\dlutils.c .
!
! $(EXTDIR)\DynaLoader\dl_win32.xs: dl_win32.xs
! copy dl_win32.xs $(EXTDIR)\DynaLoader\dl_win32.xs
!
! #----------------------------------------------------------------------------------
! Extensions : buildext.pl $(PERLDEP) $(CONFIGPM)
! $(MINIPERL) -I..\lib buildext.pl $(MAKE) $(PERLDEP) $(EXTDIR)
!
! #----------------------------------------------------------------------------------
!
!
! doc: $(PERLEXE)
! $(PERLEXE) -I..\lib ..\installhtml --podroot=.. --htmldir=./html \
! --podpath=pod:lib:ext:utils --htmlroot="file://$(INST_HTML:s,:,|,)"\
! --libpod=perlfunc:perlguts:perlvar:perlrun:perlop --recurse
!
! utils: $(PERLEXE) $(X2P)
! cd ..\utils && $(MAKE) PERL=$(MINIPERL)
! copy ..\README.aix ..\pod\perlaix.pod
! copy ..\README.amiga ..\pod\perlamiga.pod
! copy ..\README.bs2000 ..\pod\perlbs2000.pod
! copy ..\README.cygwin ..\pod\perlcygwin.pod
! copy ..\README.dos ..\pod\perldos.pod
! copy ..\README.epoc ..\pod\perlepoc.pod
! copy ..\README.hpux ..\pod\perlhpux.pod
! copy ..\README.machten ..\pod\perlmachten.pod
! copy ..\README.macos ..\pod\perlmacos.pod
! copy ..\README.mpeix ..\pod\perlmpeix.pod
! copy ..\README.os2 ..\pod\perlos2.pod
! copy ..\README.os390 ..\pod\perlos390.pod
! copy ..\README.solaris ..\pod\perlsolaris.pod
! copy ..\README.vmesa ..\pod\perlvmesa.pod
! copy ..\vms\perlvms.pod ..\pod\perlvms.pod
! copy ..\README.vos ..\pod\perlvos.pod
! copy ..\README.win32 ..\pod\perlwin32.pod
! cd ..\pod && $(MAKE) -f ..\win32\pod.mak converters
! cd ..\lib && $(PERLEXE) lib_pm.PL
! $(PERLEXE) $(PL2BAT) $(UTILS)
!
! distclean: clean
! -del /f $(MINIPERL) $(PERLEXE) $(PERLDLL) $(GLOBEXE) \
! $(PERLIMPLIB) ..\miniperl$(a) $(MINIMOD)
! -del /f *.def *.map
! -del /f $(EXTDIR)\DynaLoader\dl_win32.xs
! -del /f $(LIBDIR)\.exists $(LIBDIR)\attrs.pm $(LIBDIR)\DynaLoader.pm
! -del /f $(LIBDIR)\XSLoader.pm
! -del /f $(LIBDIR)\Fcntl.pm $(LIBDIR)\IO.pm $(LIBDIR)\Opcode.pm
! -del /f $(LIBDIR)\ops.pm $(LIBDIR)\Safe.pm $(LIBDIR)\Thread.pm
! -del /f $(LIBDIR)\SDBM_File.pm $(LIBDIR)\Socket.pm $(LIBDIR)\POSIX.pm
! -del /f $(LIBDIR)\B.pm $(LIBDIR)\O.pm $(LIBDIR)\re.pm
! -del /f $(LIBDIR)\Data\Dumper.pm $(LIBDIR)\ByteLoader.pm
! -del /f $(LIBDIR)\PerlIO\Scalar.pm
! -del /f $(LIBDIR)\Devel\Peek.pm $(LIBDIR)\Devel\DProf.pm
! -del /f $(LIBDIR)\File\Glob.pm
! -del /f $(LIBDIR)\Storable.pm
! -del /f $(LIBDIR)\Filter\Util\Call\Call.pm
! -del /f $(LIBDIR)\Digest\MD5.pm
! -del /f $(LIBDIR)\MIME\Base64\Base64.pm
! -del /f $(LIBDIR)\MIME\Base64\QuotedPrint.pm
! -if exist $(LIBDIR)\IO rmdir /s /q $(LIBDIR)\IO || rmdir /s $(LIBDIR)\IO
! -if exist $(LIBDIR)\Thread rmdir /s /q $(LIBDIR)\Thread || rmdir /s $(LIBDIR)\Thread
! -if exist $(LIBDIR)\B rmdir /s /q $(LIBDIR)\B || rmdir /s $(LIBDIR)\B
! -if exist $(LIBDIR)\Data rmdir /s /q $(LIBDIR)\Data || rmdir /s $(LIBDIR)\Data
! -if exist $(LIBDIR)\Filter\Util\Call rmdir /s /q $(LIBDIR)\Filter\Util\Call || rmdir /s $(LIBDIR)\Filter
! -if exist $(LIBDIR)\Filter\Util rmdir /s /q $(LIBDIR)\Filter\Util || rmdir /s $(LIBDIR)\Filter
! -if exist $(LIBDIR)\Digest\MD5 rmdir /s /q $(LIBDIR)\Digest\MD5 || rmdir /s $(LIBDIR)\Digest\MD5
! -if exist $(LIBDIR)\Digest rmdir /s /q $(LIBDIR)\Digest || rmdir /s $(LIBDIR)\Digest
! -if exist $(LIBDIR)\MIME\Base64 rmdir /s /q $(LIBDIR)\MIME\Base64 || rmdir /s $(LIBDIR)\MIME\Base64
! -if exist $(LIBDIR)\MIME rmdir /s /q $(LIBDIR)\MIME || rmdir /s $(LIBDIR)\MIME
! -cd $(PODDIR) && del /f *.html *.bat checkpods \
! perlaix.pod perlamiga.pod perlbs2000.pod perlcygwin.pod \
! perldos.pod perlepoc.pod perlhpux.pod perlmachten.pod \
! perlmacos.pod perlmpeix.pod perlos2.pod perlos390.pod \
! perlsolaris.pod perlvmesa.pod perlvms.pod perlvos.pod \
! perlwin32.pod pod2html pod2latex pod2man pod2text pod2usage \
! podchecker podselect
! -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph h2xs perldoc \
! dprofpp *.bat
! -cd ..\x2p && del /f find2perl s2p *.bat
! -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c config.h.new
! -del /f $(CONFIGPM)
! -del /f bin\*.bat
! -cd $(EXTDIR) && del /s *$(a) *.def *.map *.pdb *.bs Makefile *$(o) \
! pm_to_blib
! -if exist $(AUTODIR) rmdir /s /q $(AUTODIR) || rmdir /s $(AUTODIR)
! -if exist $(COREDIR) rmdir /s /q $(COREDIR) || rmdir /s $(COREDIR)
!
! install : all installbare installhtml
!
! installbare : $(RIGHTMAKE) utils
! $(PERLEXE) ..\installperl
! if exist $(WPERLEXE) $(XCOPY) $(WPERLEXE) $(INST_BIN)\*.*
! $(XCOPY) $(GLOBEXE) $(INST_BIN)\*.*
! $(XCOPY) bin\*.bat $(INST_SCRIPT)\*.*
!
! installhtml : doc
! $(RCOPY) html\*.* $(INST_HTML)\*.*
!
! inst_lib : $(CONFIGPM)
! copy splittree.pl ..
! $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR)
! $(RCOPY) ..\lib $(INST_LIB)\*.*
!
! minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) utils
! $(XCOPY) $(MINIPERL) ..\t\perl.exe
! .IF "$(CCTYPE)" == "BORLAND"
! $(XCOPY) $(GLOBBAT) ..\t\$(NULL)
! .ELSE
! $(XCOPY) $(GLOBEXE) ..\t\$(NULL)
! .ENDIF
! attrib -r ..\t\*.*
! copy test ..\t
! cd ..\t && \
! $(MINIPERL) -I..\lib test base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t
!
! test-prep : all utils
! $(XCOPY) $(PERLEXE) ..\t\$(NULL)
! $(XCOPY) $(PERLDLL) ..\t\$(NULL)
! .IF "$(CCTYPE)" == "BORLAND"
! $(XCOPY) $(GLOBBAT) ..\t\$(NULL)
! .ELSE
! $(XCOPY) $(GLOBEXE) ..\t\$(NULL)
! .ENDIF
!
! test : $(RIGHTMAKE) test-prep
! cd ..\t && $(PERLEXE) -I..\lib harness
!
! test-notty : test-prep
! set PERL_SKIP_TTY_TEST=1 && \
! cd ..\t && $(PERLEXE) -I.\lib harness
!
! test-wide : test-prep
! set HARNESS_PERL_SWITCHES=-C && \
! cd ..\t && $(PERLEXE) -I..\lib harness
!
! test-wide-notty : test-prep
! set PERL_SKIP_TTY_TEST=1 && \
! set HARNESS_PERL_SWITCHES=-C && \
! cd ..\t && $(PERLEXE) -I..\lib harness
!
! clean :
! -@erase miniperlmain$(o)
! -@erase $(MINIPERL)
! -@erase perlglob$(o)
! -@erase perlmain$(o)
! -@erase config.w32
! -@erase /f config.h
! -@erase $(GLOBEXE)
! -@erase $(PERLEXE)
! -@erase $(WPERLEXE)
! -@erase $(PERLDLL)
! -@erase $(CORE_OBJ)
! -if exist $(MINIDIR) rmdir /s /q $(MINIDIR) || rmdir /s $(MINIDIR)
! -@erase $(WIN32_OBJ)
! -@erase $(DLL_OBJ)
! -@erase $(X2P_OBJ)
! -@erase ..\*$(o) ..\*$(a) ..\*.exp *$(o) *$(a) *.exp *.res
! -@erase ..\t\*.exe ..\t\*.dll ..\t\*.bat
! -@erase ..\x2p\*.exe ..\x2p\*.bat
! -@erase *.ilk
! -@erase *.pdb
!
! # Handy way to run perlbug -ok without having to install and run the
! # installed perlbug. We don't re-run the tests here - we trust the user.
! # Please *don't* use this unless all tests pass.
! # If you want to report test failures, use "dmake nok" instead.
! ok: utils
! $(PERLEXE) -I..\lib ..\utils\perlbug -ok -s "(UNINSTALLED)"
!
! okfile: utils
! $(PERLEXE) -I..\lib ..\utils\perlbug -ok -s "(UNINSTALLED)" -F perl.ok
!
! nok: utils
! $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)"
!
! nokfile: utils
! $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)" -F perl.nok
--- 1,1268 ----
! #
! # Makefile to build perl on Windows NT using DMAKE.
! # Supported compilers:
! # Visual C++ 2.0 thro 6.0
! # Borland C++ 5.02
! # Mingw32 with gcc-2.95.2 or better **experimental**
! #
! # This is set up to build a perl.exe that runs off a shared library
! # (perl57.dll). Also makes individual DLLs for the XS extensions.
! #
!
! ##
! ## Make sure you read README.win32 *before* you mess with anything here!
! ##
!
! ##
! ## Build configuration. Edit the values below to suit your needs.
! ##
!
! #
! # Set these to wherever you want "dmake install" to put your
! # newly built perl.
! #
! INST_DRV *= c:
! INST_TOP *= $(INST_DRV)\perl
!
! #
! # Comment this out if you DON'T want your perl installation to be versioned.
! # This means that the new installation will overwrite any files from the
! # old installation at the same INST_TOP location. Leaving it enabled is
! # the safest route, as perl adds the extra version directory to all the
! # locations it installs files to. If you disable it, an alternative
! # versioned installation can be obtained by setting INST_TOP above to a
! # path that includes an arbitrary version string.
! #
! INST_VER *= \5.7.2
!
! #
! # Comment this out if you DON'T want your perl installation to have
! # architecture specific components. This means that architecture-
! # specific files will be installed along with the architecture-neutral
! # files. Leaving it enabled is safer and more flexible, in case you
! # want to build multiple flavors of perl and install them together in
! # the same location. Commenting it out gives you a simpler
! # installation that is easier to understand for beginners.
! #
! INST_ARCH *= \$(ARCHNAME)
!
! #
! # uncomment to enable multiple interpreters. This is need for fork()
! # emulation.
! #
! USE_MULTI *= define
!
! #
! # Beginnings of interpreter cloning/threads; still very incomplete.
! # This should be enabled to get the fork() emulation. This needs
! # USE_MULTI as well.
! #
! USE_ITHREADS *= define
!
! #
! # uncomment to enable the implicit "host" layer for all system calls
! # made by perl. This needs USE_MULTI above. This is also needed to
! # get fork().
! #
! USE_IMP_SYS *= define
!
! #
! # uncomment to enable the experimental PerlIO I/O subsystem.
! USE_PERLIO = define
!
! #
! # WARNING! This option is deprecated and will eventually go away (enable
! # USE_ITHREADS instead).
! #
! # uncomment to enable threads-capabilities. This is incompatible with
! # USE_ITHREADS, and is only here for people who may have come to rely
! # on the experimental Thread support that was in 5.005.
! #
! #USE_5005THREADS *= define
!
! #
! # WARNING! This option is deprecated and will eventually go away (enable
! # USE_MULTI instead).
! #
! # uncomment next line if you want to use the PERL_OBJECT build option.
! # DO NOT ENABLE unless you have legacy code that relies on the C++
! # CPerlObj class that was available in 5.005. This cannot be enabled
! # if you ask for USE_5005THREADS above.
! #
! #USE_OBJECT *= define
!
! #
! # uncomment exactly one of the following
! #
! # Visual C++ 2.x
! #CCTYPE *= MSVC20
! # Visual C++ > 2.x and < 6.x
! #CCTYPE *= MSVC
! # Visual C++ >= 6.x
! CCTYPE *= MSVC60
! # Borland 5.02 or later
! #CCTYPE *= BORLAND
! # mingw32+gcc-2.95.2 or better
! #CCTYPE *= GCC
!
! #
! # uncomment this if your Borland compiler is older than v5.4.
! BCCOLD = define
! #
! # uncomment this if you want to use Borland's VCL as your CRT
! #BCCVCL = define
!
! #
! # uncomment this if you are compiling under Windows 95/98 and command.com
! # (not needed if you're running under 4DOS/NT 6.01 or later)
! #IS_WIN95 *= define
!
! #
! # uncomment next line if you want debug version of perl (big,slow)
! # If not enabled, we automatically try to use maximum optimization
! # with all compilers that are known to have a working optimizer.
! #
! CFG *= Debug
!
! #
! # uncomment to enable use of PerlCRT.DLL when using the Visual C compiler.
! # It has patches that fix known bugs in older versions of MSVCRT.DLL.
! # This currently requires VC 5.0 with Service Pack 3 or later.
! # Get it from CPAN at http://www.perl.com/CPAN/authors/id/D/DO/DOUGL/
! # and follow the directions in the package to install.
! #
! # Not recommended if you have VC 6.x and you're not running Windows 9x.
! #
! #USE_PERLCRT *= define
!
! #
! # uncomment to enable linking with setargv.obj under the Visual C
! # compiler. Setting this options enables perl to expand wildcards in
! # arguments, but it may be harder to use alternate methods like
! # File::DosGlob that are more powerful. This option is supported only with
! # Visual C.
! #
! #USE_SETARGV *= define
!
! #
! # if you have the source for des_fcrypt(), uncomment this and make sure the
! # file exists (see README.win32). File should be located in the same
! # directory as this file.
! #
! #CRYPT_SRC *= fcrypt.c
!
! #
! # if you didn't set CRYPT_SRC and if you have des_fcrypt() available in a
! # library, uncomment this, and make sure the library exists (see README.win32)
! # Specify the full pathname of the library.
! #
! #CRYPT_LIB *= fcrypt.lib
!
! #
! # set this if you wish to use perl's malloc
! # WARNING: Turning this on/off WILL break binary compatibility with extensions
! # you may have compiled with/without it. Be prepared to recompile all
! # extensions if you change the default. Currently, this cannot be enabled
! # if you ask for USE_IMP_SYS above.
! #
! #PERL_MALLOC *= define
!
! #
! # set the install locations of the compiler include/libraries
! # Running VCVARS32.BAT is *required* when using Visual C.
! # Some versions of Visual C don't define MSVCDIR in the environment,
! # so you may have to set CCHOME explicitly (spaces in the path name should
! # not be quoted)
! #
! #CCHOME *= F:\borland\bc5
! CCHOME *= $(MSVCDIR)
! #CCHOME *= c:\gcc-2.95.2
! CCINCDIR *= $(CCHOME)\include
! CCLIBDIR *= $(CCHOME)\lib
!
! #
! # Additional compiler flags can be specified here.
! #
!
! #
! # This should normally be disabled. Adding -DPERL_POLLUTE enables support
! # for old symbols by default, at the expense of extreme pollution. You most
! # probably just want to build modules that won't compile with
! # perl Makefile.PL POLLUTE=1
! # instead of enabling this. Please report such modules to the respective
! # authors.
! #
! #BUILDOPT += -DPERL_POLLUTE
!
! #
! # This should normally be disabled. Enabling it will disable the File::Glob
! # implementation of CORE::glob.
! #
! #BUILDOPT += -DPERL_EXTERNAL_GLOB
!
! #
! # This should normally be disabled. Enabling it causes perl to read scripts
! # in text mode (which is the 5.005 behavior) and will break ByteLoader.
! #BUILDOPT += -DPERL_TEXTMODE_SCRIPTS
!
! #
! # specify semicolon-separated list of extra directories that modules will
! # look for libraries (spaces in path names need not be quoted)
! #
! EXTRALIBDIRS *=
!
! #
! # set this to point to cmd.exe (only needed if you use some
! # alternate shell that doesn't grok cmd.exe style commands)
! #
! #SHELL *= g:\winnt\system32\cmd.exe
!
! #
! # set this to your email address (perl will guess a value from
! # from your loginname and your hostname, which may not be right)
! #
! #EMAIL *=
!
! ##
! ## Build configuration ends.
! ##
!
! ##################### CHANGE THESE ONLY IF YOU MUST #####################
!
! .IF "$(CRYPT_SRC)$(CRYPT_LIB)" == ""
! D_CRYPT = undef
! .ELSE
! D_CRYPT = define
! CRYPT_FLAG = -DHAVE_DES_FCRYPT
! .ENDIF
!
! .IF "$(USE_OBJECT)" == "define"
! PERL_MALLOC != undef
! USE_5005THREADS != undef
! USE_MULTI != undef
! USE_IMP_SYS != define
! .ENDIF
!
! PERL_MALLOC *= undef
!
! USE_5005THREADS *= undef
!
! .IF "$(USE_5005THREADS)" == "define"
! USE_ITHREADS != undef
! .ENDIF
!
! .IF "$(USE_IMP_SYS)" == "define"
! PERL_MALLOC != undef
! .ENDIF
!
! USE_MULTI *= undef
! USE_OBJECT *= undef
! USE_ITHREADS *= undef
! USE_IMP_SYS *= undef
! USE_PERLIO *= undef
! USE_PERLCRT *= undef
!
! .IF "$(USE_IMP_SYS)$(USE_MULTI)$(USE_5005THREADS)$(USE_OBJECT)" == "defineundefundefundef"
! USE_MULTI != define
! .ENDIF
!
! .IF "$(USE_ITHREADS)$(USE_MULTI)$(USE_OBJECT)" == "defineundefundef"
! USE_MULTI != define
! USE_5005THREADS != undef
! .ENDIF
!
! .IF "$(USE_MULTI)$(USE_5005THREADS)$(USE_OBJECT)" != "undefundefundef"
! BUILDOPT += -DPERL_IMPLICIT_CONTEXT
! .ENDIF
!
! .IF "$(USE_IMP_SYS)" != "undef"
! BUILDOPT += -DPERL_IMPLICIT_SYS
! .ENDIF
!
! .IMPORT .IGNORE : PROCESSOR_ARCHITECTURE
!
! PROCESSOR_ARCHITECTURE *= x86
!
! .IF "$(USE_OBJECT)" == "define"
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-object
! .ELIF "$(USE_5005THREADS)" == "define"
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-thread
! .ELIF "$(USE_MULTI)" == "define"
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-multi
! .ELSE
! .IF "$(USE_PERLIO)" == "define"
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-perlio
! .ELSE
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)
! .ENDIF
! ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)
! .ENDIF
!
! .IF "$(USE_ITHREADS)" == "define"
! ARCHNAME !:= $(ARCHNAME)-thread
! .ENDIF
!
! # Visual Studio 98 specific
! .IF "$(CCTYPE)" == "MSVC60"
!
! # VC 6.0 can load the socket dll on demand. Makes the test suite
! # run in about 10% less time.
! DELAYLOAD *= -DELAYLOAD:wsock32.dll -DELAYLOAD:shell32.dll delayimp.lib
!
! .IF "$(CFG)" == "Debug"
! .ELSE
! # VC 6.0 seems capable of compiling perl correctly with optimizations
! # enabled. Anything earlier fails tests.
! CFG *= Optimize
! .ENDIF
! .ENDIF
!
! ARCHDIR = ..\lib\$(ARCHNAME)
! COREDIR = ..\lib\CORE
! AUTODIR = ..\lib\auto
! LIBDIR = ..\lib
! EXTDIR = ..\ext
! PODDIR = ..\pod
! EXTUTILSDIR = $(LIBDIR)\ExtUtils
!
! #
! INST_SCRIPT = $(INST_TOP)$(INST_VER)\bin
! INST_BIN = $(INST_SCRIPT)$(INST_ARCH)
! INST_LIB = $(INST_TOP)$(INST_VER)\lib
! INST_ARCHLIB = $(INST_LIB)$(INST_ARCH)
! INST_COREDIR = $(INST_ARCHLIB)\CORE
! INST_POD = $(INST_LIB)\pod
! INST_HTML = $(INST_TOP)$(INST_VER)\html
!
! #
! # Programs to compile, build .lib files and link
! #
!
! .USESHELL :
!
! .IF "$(CCTYPE)" == "BORLAND"
!
! CC = bcc32
! .IF "$(BCCOLD)" != "define"
! LINK32 = ilink32
! .ELSE
! LINK32 = tlink32
! .ENDIF
! LIB32 = tlib /P128
! IMPLIB = implib -c
! RSC = rc
!
! #
! # Options
! #
! INCLUDES = -I$(COREDIR) -I.\include -I. -I.. -I"$(CCINCDIR)"
! #PCHFLAGS = -H -Hc -H=c:\temp\bcmoduls.pch
! DEFINES = -DWIN32 $(CRYPT_FLAG)
! LOCDEFS = -DPERLDLL -DPERL_CORE
! SUBSYS = console
! CXX_FLAG = -P
!
! LIBC = cw32mti.lib
! LIBFILES = $(CRYPT_LIB) import32.lib $(LIBC)
!
! .IF "$(CFG)" == "Debug"
! OPTIMIZE = -v -D_RTLDLL -DDEBUGGING
! LINK_DBG = -v
! .ELSE
! OPTIMIZE = -O2 -D_RTLDLL
! LINK_DBG =
! .ENDIF
!
! CFLAGS = -w -g0 -tWM -tWD $(INCLUDES) $(DEFINES) $(LOCDEFS) \
! $(PCHFLAGS) $(OPTIMIZE)
! LINK_FLAGS = $(LINK_DBG) -L"$(INST_COREDIR)" -L"$(CCLIBDIR)"
! OBJOUT_FLAG = -o
! EXEOUT_FLAG = -e
! LIBOUT_FLAG =
! .IF "$(BCCOLD)" != "define"
! LINK_FLAGS += -Gn
! DEFINES += -D_MT -D__USELOCALES__ -D_WIN32_WINNT=0x0410
! .END
! .IF "$(BCCVCL)" == "define"
! LIBC = cp32mti.lib vcl.lib vcl50.lib vclx50.lib vcle50.lib
! LINK_FLAGS += -L"$(CCLIBDIR)\Release"
! .END
!
!
! .ELIF "$(CCTYPE)" == "GCC"
!
! CC = gcc
! LINK32 = gcc
! LIB32 = ar rc
! IMPLIB = dlltool
! RSC = rc
!
! i = .i
! o = .o
! a = .a
!
! #
! # Options
! #
!
! INCLUDES = -I.\include -I. -I.. -I$(COREDIR)
! DEFINES = -DWIN32 $(CRYPT_FLAG)
! LOCDEFS = -DPERLDLL -DPERL_CORE
! SUBSYS = console
! CXX_FLAG = -xc++
!
! LIBC = -lmsvcrt
!
! # same libs as MSVC
! LIBFILES = $(CRYPT_LIB) $(LIBC) \
! -lmoldname -lkernel32 -luser32 -lgdi32 \
! -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 \
! -loleaut32 -lnetapi32 -luuid -lwsock32 -lmpr \
! -lwinmm -lversion -lodbc32
!
! .IF "$(CFG)" == "Debug"
! OPTIMIZE = -g -O2 -DDEBUGGING
! LINK_DBG = -g
! .ELSE
! OPTIMIZE = -g -O2
! LINK_DBG = -g
! .ENDIF
!
! CFLAGS = $(INCLUDES) $(DEFINES) $(LOCDEFS) $(OPTIMIZE)
! LINK_FLAGS = $(LINK_DBG) -L"$(INST_COREDIR)" -L"$(CCLIBDIR)"
! OBJOUT_FLAG = -o
! EXEOUT_FLAG = -o
! LIBOUT_FLAG =
!
! # NOTE: we assume that GCC uses MSVCRT.DLL
! BUILDOPT += -fno-strict-aliasing -DPERL_MSVCRT_READFIX
!
! .ELSE
!
! CC = cl
! LINK32 = link
! LIB32 = $(LINK32) -lib
! RSC = rc
!
! #
! # Options
! #
!
! INCLUDES = -I$(COREDIR) -I.\include -I. -I..
! #PCHFLAGS = -Fpc:\temp\vcmoduls.pch -YX
! DEFINES = -DWIN32 -D_CONSOLE -DNO_STRICT $(CRYPT_FLAG)
! LOCDEFS = -DPERLDLL -DPERL_CORE
! SUBSYS = console
! CXX_FLAG = -TP -GX
!
! .IF "$(USE_PERLCRT)" != "define"
! LIBC = msvcrt.lib
! .ELSE
! LIBC = PerlCRT.lib
! .ENDIF
!
! PERLEXE_RES =
! PERLDLL_RES =
!
! .IF "$(CFG)" == "Debug"
! .IF "$(CCTYPE)" == "MSVC20"
! OPTIMIZE = -Od -MD -Z7 -DDEBUGGING
! LINK_DBG = -debug -pdb:none
! .ELSE
! # -Zi requires .pdb file(s)
! #OPTIMIZE = -Od -MD -Zi -DDEBUGGING
! #LINK_DBG = -debug
! OPTIMIZE = -O1 -MD -Z7 -DDEBUGGING
! LINK_DBG = -debug -debugtype:both -pdb:none
! .ENDIF
! .ELSE
! .IF "$(CFG)" == "Optimize"
! # -O1 yields smaller code, which turns out to be faster than -O2
! #OPTIMIZE = -O2 -MD -DNDEBUG
! OPTIMIZE = -O1 -MD -DNDEBUG
! .ELSE
! OPTIMIZE = -Od -MD -DNDEBUG
! .ENDIF
! LINK_DBG = -release
! .ENDIF
!
! LIBBASEFILES = $(CRYPT_LIB) \
! oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib \
! comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib \
! netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib \
! version.lib odbc32.lib odbccp32.lib
!
! # we add LIBC here, since we may be using PerlCRT.dll
! LIBFILES = $(LIBBASEFILES) $(LIBC)
!
! CFLAGS = -nologo -Gf -W3 $(INCLUDES) $(DEFINES) $(LOCDEFS) \
! $(PCHFLAGS) $(OPTIMIZE)
! LINK_FLAGS = -nologo -nodefaultlib $(LINK_DBG) \
! -libpath:"$(INST_COREDIR)" \
! -machine:$(PROCESSOR_ARCHITECTURE)
! OBJOUT_FLAG = -Fo
! EXEOUT_FLAG = -Fe
! LIBOUT_FLAG = /out:
!
! .IF "$(USE_PERLCRT)" != "define"
! BUILDOPT += -DPERL_MSVCRT_READFIX
! .ENDIF
!
! .ENDIF
!
! .IF "$(USE_OBJECT)" == "define"
! OPTIMIZE += $(CXX_FLAG)
! BUILDOPT += -DPERL_OBJECT
! .ENDIF
!
! CFLAGS_O = $(CFLAGS) $(BUILDOPT)
!
! # used to allow local linking flags that are not propogated into Config.pm,
! # currently unused
! # -- BKS, 12-12-1999
! PRIV_LINK_FLAGS *=
! BLINK_FLAGS = $(PRIV_LINK_FLAGS) $(LINK_FLAGS)
!
! #################### do not edit below this line #######################
! ############# NO USER-SERVICEABLE PARTS BEYOND THIS POINT ##############
!
! o *= .obj
! a *= .lib
!
! LKPRE = INPUT (
! LKPOST = )
!
! #
! # Rules
! #
!
! .SUFFIXES : .c .i $(o) .dll $(a) .exe .rc .res
!
! .c$(o):
! $(CC) -c $(null,$(<:d) $(NULL) -I$(<:d)) $(CFLAGS_O) $(OBJOUT_FLAG)$@ $<
!
! .c.i:
! $(CC) -c $(null,$(<:d) $(NULL) -I$(<:d)) $(CFLAGS_O) -E $< >$@
!
! .y.c:
! $(NOOP)
!
! $(o).dll:
! .IF "$(CCTYPE)" == "BORLAND"
! $(LINK32) -Tpd -ap $(BLINK_FLAGS) c0d32$(o) $<,$@,,$(LIBFILES),$(*B).def
! $(IMPLIB) $(*B).lib $@
! .ELIF "$(CCTYPE)" == "GCC"
! $(LINK32) -o $@ $(BLINK_FLAGS) $< $(LIBFILES)
! $(IMPLIB) --input-def $(*B).def --output-lib $(*B).a $@
! .ELSE
! $(LINK32) -dll -subsystem:windows -implib:$(*B).lib -def:$(*B).def \
! -out:$@ $(BLINK_FLAGS) $(LIBFILES) $< $(LIBPERL)
! .ENDIF
!
! .rc.res:
! $(RSC) -i.. $<
!
! #
! # various targets
! MINIPERL = ..\miniperl.exe
! MINIDIR = .\mini
! PERLEXE = ..\perl.exe
! WPERLEXE = ..\wperl.exe
! GLOBEXE = ..\perlglob.exe
! CONFIGPM = ..\lib\Config.pm
! MINIMOD = ..\lib\ExtUtils\Miniperl.pm
! X2P = ..\x2p\a2p.exe
!
! # Nominate a target which causes extensions to be re-built
! # This used to be $(PERLEXE), but at worst it is the .dll that they depend
! # on and really only the interface - i.e. the .def file used to export symbols
! # from the .dll
! PERLDEP = perldll.def
!
!
! PL2BAT = bin\pl2bat.pl
! GLOBBAT = bin\perlglob.bat
!
! UTILS = \
! ..\utils\h2ph \
! ..\utils\splain \
! ..\utils\dprofpp \
! ..\utils\perlbug \
! ..\utils\pl2pm \
! ..\utils\c2ph \
! ..\utils\h2xs \
! ..\utils\perldoc \
! ..\utils\perlcc \
! ..\pod\checkpods \
! ..\pod\pod2html \
! ..\pod\pod2latex \
! ..\pod\pod2man \
! ..\pod\pod2text \
! ..\pod\pod2usage \
! ..\pod\podchecker \
! ..\pod\podselect \
! ..\x2p\find2perl \
! ..\x2p\s2p \
! bin\exetype.pl \
! bin\runperl.pl \
! bin\pl2bat.pl \
! bin\perlglob.pl \
! bin\search.pl
!
! .IF "$(CCTYPE)" == "BORLAND"
!
! CFGSH_TMPL = config.bc
! CFGH_TMPL = config_H.bc
!
! .ELIF "$(CCTYPE)" == "GCC"
!
! CFGSH_TMPL = config.gc
! CFGH_TMPL = config_H.gc
! PERLIMPLIB = ..\libperl57$(a)
!
! .ELSE
!
! CFGSH_TMPL = config.vc
! CFGH_TMPL = config_H.vc
!
! .ENDIF
!
! # makedef.pl must be updated if this changes, and this should normally
! # only change when there is an incompatible revision of the public API.
! # XXX so why did we change it from perl56 to perl57?
! PERLIMPLIB *= ..\perl57$(a)
! PERLDLL = ..\perl57.dll
!
! XCOPY = xcopy /f /r /i /d
! RCOPY = xcopy /f /r /i /e /d
! NOOP = @echo
!
! #
! # filenames given to xsubpp must have forward slashes (since it puts
! # full pathnames in #line strings)
! XSUBPP = ..\$(MINIPERL) -I..\..\lib ..\$(EXTUTILSDIR)\xsubpp \
! -C++ -prototypes
!
! MICROCORE_SRC = \
! ..\av.c \
! ..\deb.c \
! ..\doio.c \
! ..\doop.c \
! ..\dump.c \
! ..\globals.c \
! ..\gv.c \
! ..\hv.c \
! ..\locale.c \
! ..\mg.c \
! ..\numeric.c \
! ..\op.c \
! ..\perl.c \
! ..\perlapi.c \
! ..\perly.c \
! ..\pp.c \
! ..\pp_ctl.c \
! ..\pp_hot.c \
! ..\pp_pack.c \
! ..\pp_sys.c \
! ..\regcomp.c \
! ..\regexec.c \
! ..\run.c \
! ..\scope.c \
! ..\sv.c \
! ..\taint.c \
! ..\toke.c \
! ..\universal.c \
! ..\utf8.c \
! ..\util.c \
! ..\xsutils.c
!
! EXTRACORE_SRC += perllib.c
!
! .IF "$(PERL_MALLOC)" == "define"
! EXTRACORE_SRC += ..\malloc.c
! .ENDIF
!
! .IF "$(USE_OBJECT)" != "define"
! EXTRACORE_SRC += ..\perlio.c
! .ENDIF
!
! WIN32_SRC = \
! .\win32.c \
! .\win32io.c \
! .\win32sck.c \
! .\win32thread.c
!
! .IF "$(CRYPT_SRC)" != ""
! WIN32_SRC += .\$(CRYPT_SRC)
! .ENDIF
!
! DLL_SRC = $(DYNALOADER).c
!
! X2P_SRC = \
! ..\x2p\a2p.c \
! ..\x2p\hash.c \
! ..\x2p\str.c \
! ..\x2p\util.c \
! ..\x2p\walk.c
!
! CORE_NOCFG_H = \
! ..\av.h \
! ..\cop.h \
! ..\cv.h \
! ..\dosish.h \
! ..\embed.h \
! ..\form.h \
! ..\gv.h \
! ..\handy.h \
! ..\hv.h \
! ..\iperlsys.h \
! ..\mg.h \
! ..\nostdio.h \
! ..\op.h \
! ..\opcode.h \
! ..\perl.h \
! ..\perlapi.h \
! ..\perlsdio.h \
! ..\perlsfio.h \
! ..\perly.h \
! ..\pp.h \
! ..\proto.h \
! ..\regexp.h \
! ..\scope.h \
! ..\sv.h \
! ..\thread.h \
! ..\unixish.h \
! ..\utf8.h \
! ..\util.h \
! ..\warnings.h \
! ..\XSUB.h \
! ..\EXTERN.h \
! ..\perlvars.h \
! ..\intrpvar.h \
! ..\thrdvar.h \
! .\include\dirent.h \
! .\include\netdb.h \
! .\include\sys\socket.h \
! .\win32.h
!
! CORE_H = $(CORE_NOCFG_H) .\config.h
!
! MICROCORE_OBJ = $(MICROCORE_SRC:db:+$(o))
! CORE_OBJ = $(MICROCORE_OBJ) $(EXTRACORE_SRC:db:+$(o))
! WIN32_OBJ = $(WIN32_SRC:db:+$(o))
! MINICORE_OBJ = $(MINIDIR)\{$(MICROCORE_OBJ:f) miniperlmain$(o) perlio$(o)}
! MINIWIN32_OBJ = $(MINIDIR)\{$(WIN32_OBJ:f)}
! MINI_OBJ = $(MINICORE_OBJ) $(MINIWIN32_OBJ)
! DLL_OBJ = $(DLL_SRC:db:+$(o))
! X2P_OBJ = $(X2P_SRC:db:+$(o))
!
! PERLDLL_OBJ = $(CORE_OBJ)
! PERLEXE_OBJ = perlmain$(o)
!
! PERLDLL_OBJ += $(WIN32_OBJ) $(DLL_OBJ)
!
! .IF "$(USE_SETARGV)" != ""
! SETARGV_OBJ = setargv$(o)
! .ENDIF
!
! DYNAMIC_EXT = Socket IO Fcntl Opcode SDBM_File POSIX attrs Thread B re \
! Data/Dumper Devel/Peek ByteLoader Devel/DProf File/Glob \
! Sys/Hostname Storable Filter/Util/Call Encode \
! Digest/MD5 PerlIO/Scalar MIME/Base64 Time/HiRes Time/Piece
! STATIC_EXT = DynaLoader
! NONXS_EXT = Errno
!
! DYNALOADER = $(EXTDIR)\DynaLoader\DynaLoader
!
! POD2HTML = $(PODDIR)\pod2html
! POD2MAN = $(PODDIR)\pod2man
! POD2LATEX = $(PODDIR)\pod2latex
! POD2TEXT = $(PODDIR)\pod2text
!
! # vars must be separated by "\t+~\t+", since we're using the tempfile
! # version of config_sh.pl (we were overflowing someone's buffer by
! # trying to fit them all on the command line)
! # -- BKS 10-17-1999
! CFG_VARS = \
! INST_DRV=$(INST_DRV) ~ \
! INST_TOP=$(INST_TOP:s/\/\\/) ~ \
! INST_VER=$(INST_VER:s/\/\\/) ~ \
! INST_ARCH=$(INST_ARCH) ~ \
! archname=$(ARCHNAME) ~ \
! cc=$(CC) ~ \
! ld=$(LINK32) ~ \
! ccflags=$(OPTIMIZE) $(DEFINES) $(BUILDOPT) ~ \
! cf_email=$(EMAIL) ~ \
! d_crypt=$(D_CRYPT) ~ \
! d_mymalloc=$(PERL_MALLOC) ~ \
! libs=$(LIBFILES:f) ~ \
! incpath=$(CCINCDIR:s/\/\\/) ~ \
! libperl=$(PERLIMPLIB:f) ~ \
! libpth=$(CCLIBDIR:s/\/\\/);$(EXTRALIBDIRS:s/\/\\/) ~ \
! libc=$(LIBC) ~ \
! make=dmake ~ \
! _o=$(o) obj_ext=$(o) ~ \
! _a=$(a) lib_ext=$(a) ~ \
! static_ext=$(STATIC_EXT) ~ \
! use5005threads=$(USE_5005THREADS) ~ \
! useithreads=$(USE_ITHREADS) ~ \
! usethreads=$(USE_5005THREADS) ~ \
! usemultiplicity=$(USE_MULTI) ~ \
! useperlio=$(USE_PERLIO) ~ \
! LINK_FLAGS=$(LINK_FLAGS:s/\/\\/) ~ \
! optimize=$(OPTIMIZE)
!
! #
! # set up targets varying between Win95 and WinNT builds
! #
!
! .IF "$(IS_WIN95)" == "define"
! MK2 = .\makefile.95
! RIGHTMAKE = __switch_makefiles
! NOOP = @rem
! .ELSE
! MK2 = __not_needed
! RIGHTMAKE =
! .ENDIF
!
! #
! # Top targets
! #
!
! all : .\config.h $(GLOBEXE) $(MINIPERL) $(MK2) \
! $(RIGHTMAKE) $(MINIMOD) $(CONFIGPM) $(PERLEXE) \
! $(X2P) Extensions
!
! $(DYNALOADER)$(o) : $(DYNALOADER).c $(CORE_H) $(EXTDIR)\DynaLoader\dlutils.c
!
! #----------------------------------------------------------------
!
! #-------------------- BEGIN Win95 SPECIFIC ----------------------
!
! # this target is a jump-off point for Win95
! # 1. it switches to the Win95-specific makefile if it exists
! # (__do_switch_makefiles)
! # 2. it prints a message when the Win95-specific one finishes (__done)
! # 3. it then kills this makefile by trying to make __no_such_target
!
! __switch_makefiles: __do_switch_makefiles __done __no_such_target
!
! __do_switch_makefiles:
! .IF "$(NOTFIRST)" != "true"
! if exist $(MK2) $(MAKE:s/-S//) -f $(MK2) $(MAKETARGETS) NOTFIRST=true
! .ELSE
! $(NOOP)
! .ENDIF
!
! .IF "$(NOTFIRST)" != "true"
! __done:
! @echo Build process complete. Ignore any errors after this message.
! @echo Run "dmake test" to test and "dmake install" to install
!
! .ELSE
! # dummy targets for Win95-specific makefile
!
! __done:
! $(NOOP)
!
! __no_such_target:
! $(NOOP)
!
! .ENDIF
!
! # This target is used to generate the new makefile (.\makefile.95) for Win95
!
! .\makefile.95: .\makefile.mk
! $(MINIPERL) genmk95.pl makefile.mk $(MK2)
!
! #--------------------- END Win95 SPECIFIC ---------------------
!
! # a blank target for when builds don't need to do certain things
! # this target added for Win95 port but used to keep the WinNT port able to
! # use this file
! __not_needed:
! $(NOOP)
!
! $(GLOBEXE) : perlglob$(o)
! .IF "$(CCTYPE)" == "BORLAND"
! $(CC) -c -w -v -tWM -I"$(CCINCDIR)" perlglob.c
! $(LINK32) -Tpe -ap $(BLINK_FLAGS) c0x32$(o) perlglob$(o) \
! "$(CCLIBDIR)\32BIT\wildargs$(o)",$@,,import32.lib cw32mt.lib,
! .ELIF "$(CCTYPE)" == "GCC"
! $(LINK32) $(BLINK_FLAGS) -mconsole -o $@ perlglob$(o) $(LIBFILES)
! .ELSE
! $(LINK32) $(BLINK_FLAGS) $(LIBFILES) -out:$@ -subsystem:$(SUBSYS) \
! perlglob$(o) setargv$(o)
! .ENDIF
!
! perlglob$(o) : perlglob.c
!
! config.w32 : $(CFGSH_TMPL)
! copy $(CFGSH_TMPL) config.w32
!
! .\config.h : $(CFGH_TMPL) $(CORE_NOCFG_H)
! -del /f config.h
! copy $(CFGH_TMPL) config.h
!
! ..\config.sh : config.w32 $(MINIPERL) config_sh.PL FindExt.pm
! $(MINIPERL) -I..\lib config_sh.PL --cfgsh-option-file \
! $(mktmp $(CFG_VARS)) config.w32 > ..\config.sh
!
! # this target is for when changes to the main config.sh happen
! # edit config.{b,v,g}c and make this target once for each supported
! # compiler (e.g. `dmake CCTYPE=BORLAND regen_config_h`)
! regen_config_h:
! perl config_sh.PL --cfgsh-option-file $(mktmp $(CFG_VARS)) \
! $(CFGSH_TMPL) > ..\config.sh
! -cd .. && del /f perl.exe
! cd .. && perl configpm
! -del /f $(CFGH_TMPL)
! -mkdir $(COREDIR)
! -perl -I..\lib config_h.PL "INST_VER=$(INST_VER)"
! rename config.h $(CFGH_TMPL)
!
! $(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl
! cd .. && miniperl configpm
! if exist lib\* $(RCOPY) lib\*.* ..\lib\$(NULL)
! $(XCOPY) ..\*.h $(COREDIR)\*.*
! $(XCOPY) *.h $(COREDIR)\*.*
! $(XCOPY) ..\ext\re\re.pm $(LIBDIR)\*.*
! $(RCOPY) include $(COREDIR)\*.*
! $(MINIPERL) -I..\lib config_h.PL "INST_VER=$(INST_VER)" \
! || $(MAKE) $(MAKEMACROS) $(CONFIGPM) $(MAKEFILE)
!
! $(MINIPERL) : $(MINIDIR) $(MINI_OBJ) $(CRTIPMLIBS)
! .IF "$(CCTYPE)" == "BORLAND"
! $(LINK32) -Tpe -ap $(BLINK_FLAGS) \
! @$(mktmp c0x32$(o) $(MINI_OBJ:s,\,\\),$(@:s,\,\\),,$(LIBFILES),)
! .ELIF "$(CCTYPE)" == "GCC"
! $(LINK32) -v -mconsole -o $@ $(BLINK_FLAGS) \
! $(mktmp $(LKPRE) $(MINI_OBJ:s,\,\\) $(LIBFILES) $(LKPOST))
! .ELSE
! $(LINK32) -subsystem:console -out:$@ \
! @$(mktmp $(BLINK_FLAGS) $(LIBFILES) $(MINI_OBJ:s,\,\\))
! .ENDIF
!
! $(MINIDIR) :
! if not exist "$(MINIDIR)" mkdir "$(MINIDIR)"
!
! $(MINICORE_OBJ) : $(CORE_NOCFG_H)
! $(CC) -c $(CFLAGS) -DPERL_EXTERNAL_GLOB $(OBJOUT_FLAG)$@ ..\$(*B).c
!
! $(MINIWIN32_OBJ) : $(CORE_NOCFG_H)
! $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $(*B).c
!
! # -DPERL_IMPLICIT_SYS needs C++ for perllib.c
! # rules wrapped in .IFs break Win9X build (we end up with unbalanced []s unless
! # unless the .IF is true), so instead we use a .ELSE with the default.
! # This is the only file that depends on perlhost.h, vmem.h, and vdir.h
!
! perllib$(o) : perllib.c .\perlhost.h .\vdir.h .\vmem.h
! .IF "$(USE_IMP_SYS)$(USE_OBJECT)" == "defineundef"
! $(CC) -c -I. $(CFLAGS_O) $(CXX_FLAG) $(OBJOUT_FLAG)$@ perllib.c
! .ELSE
! $(CC) -c -I. $(CFLAGS_O) $(OBJOUT_FLAG)$@ perllib.c
! .ENDIF
!
! # 1. we don't want to rebuild miniperl.exe when config.h changes
! # 2. we don't want to rebuild miniperl.exe with non-default config.h
! $(MINI_OBJ) : $(CORE_NOCFG_H)
!
! $(WIN32_OBJ) : $(CORE_H)
! $(CORE_OBJ) : $(CORE_H)
! $(DLL_OBJ) : $(CORE_H)
! $(X2P_OBJ) : $(CORE_H)
!
! perldll.def : $(MINIPERL) $(CONFIGPM) ..\global.sym ..\pp.sym ..\makedef.pl
! $(MINIPERL) -w ..\makedef.pl PLATFORM=win32 $(OPTIMIZE) $(DEFINES) \
! $(BUILDOPT) CCTYPE=$(CCTYPE) > perldll.def
!
! $(PERLDLL): perldll.def $(PERLDLL_OBJ) $(PERLDLL_RES)
! .IF "$(CCTYPE)" == "BORLAND"
! $(LINK32) -Tpd -ap $(BLINK_FLAGS) \
! @$(mktmp c0d32$(o) $(PERLDLL_OBJ:s,\,\\)\n \
! $@,\n \
! $(LIBFILES)\n \
! perldll.def\n)
! $(IMPLIB) $*.lib $@
! .ELIF "$(CCTYPE)" == "GCC"
! $(LINK32) -mdll -o $@ -Wl,--base-file -Wl,perl.base $(BLINK_FLAGS) \
! $(mktmp $(LKPRE) $(PERLDLL_OBJ:s,\,\\) $(LIBFILES) $(LKPOST))
! dlltool --output-lib $(PERLIMPLIB) \
! --dllname $(PERLDLL:b).dll \
! --def perldll.def \
! --base-file perl.base \
! --output-exp perl.exp
! $(LINK32) -mdll -o $@ $(BLINK_FLAGS) \
! $(mktmp $(LKPRE) $(PERLDLL_OBJ:s,\,\\) $(LIBFILES) \
! perl.exp $(LKPOST))
! .ELSE
! $(LINK32) -dll -def:perldll.def -out:$@ \
! @$(mktmp -base:0x28000000 $(BLINK_FLAGS) $(DELAYLOAD) $(LIBFILES) \
! $(PERLDLL_RES) $(PERLDLL_OBJ:s,\,\\))
! .ENDIF
! $(XCOPY) $(PERLIMPLIB) $(COREDIR)
!
! $(MINIMOD) : $(MINIPERL) ..\minimod.pl
! cd .. && miniperl minimod.pl > lib\ExtUtils\Miniperl.pm
!
! ..\x2p\a2p$(o) : ..\x2p\a2p.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\a2p.c
!
! ..\x2p\hash$(o) : ..\x2p\hash.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\hash.c
!
! ..\x2p\str$(o) : ..\x2p\str.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\str.c
!
! ..\x2p\util$(o) : ..\x2p\util.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\util.c
!
! ..\x2p\walk$(o) : ..\x2p\walk.c
! $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\walk.c
!
! $(X2P) : $(MINIPERL) $(X2P_OBJ)
! $(MINIPERL) ..\x2p\find2perl.PL
! $(MINIPERL) ..\x2p\s2p.PL
! .IF "$(CCTYPE)" == "BORLAND"
! $(LINK32) -Tpe -ap $(BLINK_FLAGS) \
! @$(mktmp c0x32$(o) $(X2P_OBJ:s,\,\\),$(@:s,\,\\),,$(LIBFILES),)
! .ELIF "$(CCTYPE)" == "GCC"
! $(LINK32) -v -o $@ $(BLINK_FLAGS) \
! $(mktmp $(LKPRE) $(X2P_OBJ:s,\,\\) $(LIBFILES) $(LKPOST))
! .ELSE
! $(LINK32) -subsystem:console -out:$@ \
! @$(mktmp $(BLINK_FLAGS) $(LIBFILES) $(X2P_OBJ:s,\,\\))
! .ENDIF
!
! perlmain.c : runperl.c
! copy runperl.c perlmain.c
!
! perlmain$(o) : perlmain.c
! $(CC) $(CFLAGS_O) -UPERLDLL $(OBJOUT_FLAG)$@ -c perlmain.c
!
! $(PERLEXE): $(PERLDLL) $(CONFIGPM) $(PERLEXE_OBJ) $(PERLEXE_RES)
! .IF "$(CCTYPE)" == "BORLAND"
! $(LINK32) -Tpe -ap $(BLINK_FLAGS) \
! @$(mktmp c0x32$(o) $(PERLEXE_OBJ:s,\,\\)\n \
! $(@:s,\,\\),\n \
! $(PERLIMPLIB) $(LIBFILES)\n)
! .ELIF "$(CCTYPE)" == "GCC"
! $(LINK32) -mconsole -o $@ $(BLINK_FLAGS) \
! $(PERLEXE_OBJ) $(PERLIMPLIB) $(LIBFILES)
! .ELSE
! $(LINK32) -subsystem:console -out:$@ -stack:0x1000000 $(BLINK_FLAGS) \
! $(LIBFILES) $(PERLEXE_OBJ) $(SETARGV_OBJ) $(PERLIMPLIB) $(PERLEXE_RES)
! .ENDIF
! copy $(PERLEXE) $(WPERLEXE)
! $(MINIPERL) -I..\lib bin\exetype.pl $(WPERLEXE) WINDOWS
! copy splittree.pl ..
! $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR)
!
! $(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM)
! if not exist $(AUTODIR) mkdir $(AUTODIR)
! cd $(EXTDIR)\$(*B) && ..\$(MINIPERL) -I..\..\lib $(*B)_pm.PL
! cd $(EXTDIR)\$(*B) && ..\$(MINIPERL) -I..\..\lib XSLoader_pm.PL
! $(XCOPY) $(EXTDIR)\$(*B)\$(*B).pm $(LIBDIR)\$(NULL)
! $(XCOPY) $(EXTDIR)\$(*B)\XSLoader.pm $(LIBDIR)\$(NULL)
! cd $(EXTDIR)\$(*B) && $(XSUBPP) dl_win32.xs > $(*B).c
! $(XCOPY) $(EXTDIR)\$(*B)\dlutils.c .
!
! $(EXTDIR)\DynaLoader\dl_win32.xs: dl_win32.xs
! copy dl_win32.xs $(EXTDIR)\DynaLoader\dl_win32.xs
!
! #----------------------------------------------------------------------------------
! Extensions : buildext.pl $(PERLDEP) $(CONFIGPM)
! $(MINIPERL) -I..\lib buildext.pl $(MAKE) $(PERLDEP) $(EXTDIR)
!
! Extensions_clean :
! -if exist $(MINIPERL) $(MINIPERL) -I..\lib buildext.pl $(MAKE) $(PERLDEP) $(EXTDIR) clean
!
! #----------------------------------------------------------------------------------
!
!
! doc: $(PERLEXE)
! $(PERLEXE) -I..\lib ..\installhtml --podroot=.. --htmldir=./html \
! --podpath=pod:lib:ext:utils --htmlroot="file://$(INST_HTML:s,:,|,)"\
! --libpod=perlfunc:perlguts:perlvar:perlrun:perlop --recurse
!
! utils: $(PERLEXE) $(X2P)
! cd ..\utils && $(MAKE) PERL=$(MINIPERL)
! copy ..\README.aix ..\pod\perlaix.pod
! copy ..\README.amiga ..\pod\perlamiga.pod
! copy ..\README.apollo ..\pod\perlapollo.pod
! copy ..\README.beos ..\pod\perlbeos.pod
! copy ..\README.bs2000 ..\pod\perlbs2000.pod
! copy ..\README.cygwin ..\pod\perlcygwin.pod
! copy ..\README.dgux ..\pod\perldgux.pod
! copy ..\README.dos ..\pod\perldos.pod
! copy ..\README.epoc ..\pod\perlepoc.pod
! copy ..\README.hpux ..\pod\perlhpux.pod
! copy ..\README.hurd ..\pod\perlhurd.pod
! copy ..\README.machten ..\pod\perlmachten.pod
! copy ..\README.macos ..\pod\perlmacos.pod
! copy ..\README.mint ..\pod\perlmint.pod
! copy ..\README.mpeix ..\pod\perlmpeix.pod
! copy ..\README.netware ..\pod\perlnetware.pod
! copy ..\README.os2 ..\pod\perlos2.pod
! copy ..\README.os390 ..\pod\perlos390.pod
! copy ..\README.plan9 ..\pod\perlplan9.pod
! copy ..\README.qnx ..\pod\perlqnx.pod
! copy ..\README.solaris ..\pod\perlsolaris.pod
! copy ..\README.tru64 ..\pod\perltru64.pod
! copy ..\README.uts ..\pod\perluts.pod
! copy ..\README.vmesa ..\pod\perlvmesa.pod
! copy ..\vms\perlvms.pod ..\pod\perlvms.pod
! copy ..\README.vos ..\pod\perlvos.pod
! copy ..\README.win32 ..\pod\perlwin32.pod
! cd ..\pod && $(MAKE) -f ..\win32\pod.mak converters
! cd ..\lib && $(PERLEXE) lib_pm.PL
! $(PERLEXE) $(PL2BAT) $(UTILS)
!
! distclean: clean
! -del /f $(MINIPERL) $(PERLEXE) $(PERLDLL) $(GLOBEXE) \
! $(PERLIMPLIB) ..\miniperl$(a) $(MINIMOD)
! -del /f *.def *.map
! -del /f $(EXTDIR)\DynaLoader\dl_win32.xs
! -del /f $(LIBDIR)\.exists $(LIBDIR)\attrs.pm $(LIBDIR)\DynaLoader.pm
! -del /f $(LIBDIR)\XSLoader.pm
! -del /f $(LIBDIR)\Fcntl.pm $(LIBDIR)\IO.pm $(LIBDIR)\Opcode.pm
! -del /f $(LIBDIR)\ops.pm $(LIBDIR)\Safe.pm $(LIBDIR)\Thread.pm
! -del /f $(LIBDIR)\SDBM_File.pm $(LIBDIR)\Socket.pm $(LIBDIR)\POSIX.pm
! -del /f $(LIBDIR)\B.pm $(LIBDIR)\O.pm $(LIBDIR)\re.pm
! -del /f $(LIBDIR)\Data\Dumper.pm $(LIBDIR)\ByteLoader.pm
! -del /f $(LIBDIR)\PerlIO\Scalar.pm
! -del /f $(LIBDIR)\Devel\Peek.pm $(LIBDIR)\Devel\DProf.pm
! -del /f $(LIBDIR)\File\Glob.pm
! -del /f $(LIBDIR)\Storable.pm
! -del /f $(LIBDIR)\Filter\Util\Call.pm
! -del /f $(LIBDIR)\Digest\MD5.pm
! -del /f $(LIBDIR)\MIME\Base64.pm
! -del /f $(LIBDIR)\MIME\QuotedPrint.pm
! -del /f $(LIBDIR)\Time\HiRes.pm
! -del /f $(LIBDIR)\List\Util.pm
! -del /f $(LIBDIR)\Scalar\Util.pm
! -del /f $(LIBDIR)\Time\Piece.pm
! -if exist $(LIBDIR)\IO rmdir /s /q $(LIBDIR)\IO || rmdir /s $(LIBDIR)\IO
! -if exist $(LIBDIR)\Thread rmdir /s /q $(LIBDIR)\Thread || rmdir /s $(LIBDIR)\Thread
! -if exist $(LIBDIR)\B rmdir /s /q $(LIBDIR)\B || rmdir /s $(LIBDIR)\B
! -if exist $(LIBDIR)\Data rmdir /s /q $(LIBDIR)\Data || rmdir /s $(LIBDIR)\Data
! -if exist $(LIBDIR)\Filter\Util\Call rmdir /s /q $(LIBDIR)\Filter\Util\Call || rmdir /s $(LIBDIR)\Filter
! -if exist $(LIBDIR)\Filter\Util rmdir /s /q $(LIBDIR)\Filter\Util || rmdir /s $(LIBDIR)\Filter
! -if exist $(LIBDIR)\Digest rmdir /s /q $(LIBDIR)\Digest || rmdir /s $(LIBDIR)\Digest
! -if exist $(LIBDIR)\MIME rmdir /s /q $(LIBDIR)\MIME || rmdir /s $(LIBDIR)\MIME
! -if exist $(LIBDIR)\List rmdir /s /q $(LIBDIR)\List || rmdir /s $(LIBDIR)\List
! -if exist $(LIBDIR)\Scalar rmdir /s /q $(LIBDIR)\Scalar || rmdir /s $(LIBDIR)\Scalar
! -cd $(PODDIR) && del /f *.html *.bat checkpods \
! perlaix.pod perlamiga.pod perlapollo.pod \
! perlbeos.pod perlbs2000.pod perlcygwin.pod perldgux.pod \
! perldos.pod perlepoc.pod perlhpux.pod perlhurd.pod \
! perlmachten.pod perlmint.pod \
! perlmacos.pod perlmpeix.pod perlnetware.pod \
! perlos2.pod perlos390.pod \
! perlplan9.pod perlqnx.pod \
! perlsolaris.pod perltru64.pod perluts.pod \
! perlvmesa.pod perlvms.pod perlvos.pod \
! perlwin32.pod pod2html pod2latex pod2man pod2text pod2usage \
! podchecker podselect
! -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph h2xs perldoc \
! dprofpp *.bat
! -cd ..\x2p && del /f find2perl s2p *.bat
! -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c config.h.new
! -del /f $(CONFIGPM)
! -del /f bin\*.bat
! -cd $(EXTDIR) && del /s *$(a) *.def *.map *.pdb *.bs Makefile *$(o) \
! pm_to_blib
! -if exist $(AUTODIR) rmdir /s /q $(AUTODIR) || rmdir /s $(AUTODIR)
! -if exist $(COREDIR) rmdir /s /q $(COREDIR) || rmdir /s $(COREDIR)
!
! install : all installbare installhtml
!
! installbare : $(RIGHTMAKE) utils
! $(PERLEXE) ..\installperl
! if exist $(WPERLEXE) $(XCOPY) $(WPERLEXE) $(INST_BIN)\*.*
! $(XCOPY) $(GLOBEXE) $(INST_BIN)\*.*
! $(XCOPY) bin\*.bat $(INST_SCRIPT)\*.*
!
! installhtml : doc
! $(RCOPY) html\*.* $(INST_HTML)\*.*
!
! inst_lib : $(CONFIGPM)
! copy splittree.pl ..
! $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR)
! $(RCOPY) ..\lib $(INST_LIB)\*.*
!
! minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) utils
! $(XCOPY) $(MINIPERL) ..\t\perl.exe
! .IF "$(CCTYPE)" == "BORLAND"
! $(XCOPY) $(GLOBBAT) ..\t\$(NULL)
! .ELSE
! $(XCOPY) $(GLOBEXE) ..\t\$(NULL)
! .ENDIF
! attrib -r ..\t\*.*
! copy test ..\t
! cd ..\t && \
! $(MINIPERL) -I..\lib test base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t
!
! test-prep : all utils
! $(XCOPY) $(PERLEXE) ..\t\$(NULL)
! $(XCOPY) $(PERLDLL) ..\t\$(NULL)
! .IF "$(CCTYPE)" == "BORLAND"
! $(XCOPY) $(GLOBBAT) ..\t\$(NULL)
! .ELSE
! $(XCOPY) $(GLOBEXE) ..\t\$(NULL)
! .ENDIF
!
! test : $(RIGHTMAKE) test-prep
! cd ..\t && $(PERLEXE) -I..\lib harness
!
! test-notty : test-prep
! set PERL_SKIP_TTY_TEST=1 && \
! cd ..\t && $(PERLEXE) -I.\lib harness
!
! test-wide : test-prep
! set HARNESS_PERL_SWITCHES=-C && \
! cd ..\t && $(PERLEXE) -I..\lib harness
!
! test-wide-notty : test-prep
! set PERL_SKIP_TTY_TEST=1 && \
! set HARNESS_PERL_SWITCHES=-C && \
! cd ..\t && $(PERLEXE) -I..\lib harness
!
! clean : Extensions_clean
! -@erase miniperlmain$(o)
! -@erase $(MINIPERL)
! -@erase perlglob$(o)
! -@erase perlmain$(o)
! -@erase config.w32
! -@erase /f config.h
! -@erase $(GLOBEXE)
! -@erase $(PERLEXE)
! -@erase $(WPERLEXE)
! -@erase $(PERLDLL)
! -@erase $(CORE_OBJ)
! -if exist $(MINIDIR) rmdir /s /q $(MINIDIR) || rmdir /s $(MINIDIR)
! -@erase $(WIN32_OBJ)
! -@erase $(DLL_OBJ)
! -@erase $(X2P_OBJ)
! -@erase ..\*$(o) ..\*$(a) ..\*.exp *$(o) *$(a) *.exp *.res
! -@erase ..\t\*.exe ..\t\*.dll ..\t\*.bat
! -@erase ..\x2p\*.exe ..\x2p\*.bat
! -@erase *.ilk
! -@erase *.pdb
!
! # Handy way to run perlbug -ok without having to install and run the
! # installed perlbug. We don't re-run the tests here - we trust the user.
! # Please *don't* use this unless all tests pass.
! # If you want to report test failures, use "dmake nok" instead.
! ok: utils
! $(PERLEXE) -I..\lib ..\utils\perlbug -ok -s "(UNINSTALLED)"
!
! okfile: utils
! $(PERLEXE) -I..\lib ..\utils\perlbug -ok -s "(UNINSTALLED)" -F perl.ok
!
! nok: utils
! $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)"
!
! nokfile: utils
! $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)" -F perl.nok
diff -c /dev/null 'perl-5.7.2/win32/mdelete.bat'
Index: ./win32/mdelete.bat
*** ./win32/mdelete.bat Thu Jan 1 02:00:00 1970
--- ./win32/mdelete.bat Mon Jul 9 17:11:36 2001
***************
*** 0 ****
--- 1,29 ----
+ @echo off
+ rem ! This is a batch file to delete all the files on its
+ rem ! command line, to work around command.com's del command's
+ rem ! braindeadness
+ rem !
+ rem ! -- BKS, 11-11-2000
+
+ :nextfile
+ set file=%1
+ shift
+ if "%file%"=="" goto end
+ del %file%
+ goto nextfile
+ :end
+
+ @echo off
+ rem ! This is a batch file to delete all the files on its
+ rem ! command line, to work around command.com's del command's
+ rem ! braindeadness
+ rem !
+ rem ! -- BKS, 11-11-2000
+
+ :nextfile
+ set file=%1
+ shift
+ if "%file%"=="" goto end
+ del %file%
+ goto nextfile
+ :end
diff -c 'perl-5.7.1/win32/perllib.c' 'perl-5.7.2/win32/perllib.c'
Index: ./win32/perllib.c
*** ./win32/perllib.c Tue Mar 6 04:07:34 2001
--- ./win32/perllib.c Mon Jul 9 17:11:36 2001
***************
*** 396,398 ****
--- 396,421 ----
}
return TRUE;
}
+
+ #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
+ EXTERN_C PerlInterpreter *
+ perl_clone_host(PerlInterpreter* proto_perl, UV flags) {
+ dTHXo;
+ CPerlHost *h;
+ h = new CPerlHost(*(CPerlHost*)PL_sys_intern.internal_host);
+ proto_perl = perl_clone_using(proto_perl, flags,
+ h->m_pHostperlMem,
+ h->m_pHostperlMemShared,
+ h->m_pHostperlMemParse,
+ h->m_pHostperlEnv,
+ h->m_pHostperlStdIO,
+ h->m_pHostperlLIO,
+ h->m_pHostperlDir,
+ h->m_pHostperlSock,
+ h->m_pHostperlProc
+ );
+ proto_perl->Isys_intern.internal_host = h;
+ return proto_perl;
+
+ }
+ #endif
diff -c 'perl-5.7.1/win32/win32.c' 'perl-5.7.2/win32/win32.c'
Index: ./win32/win32.c
*** ./win32/win32.c Sat Mar 24 17:56:12 2001
--- ./win32/win32.c Thu Jul 12 20:03:59 2001
***************
*** 850,856 ****
long endpos = dirp->end - dirp->start;
long newsize = endpos + strlen(ptr) + 1;
/* bump the string table size by enough for the
! * new name and it's null terminator */
while (newsize > dirp->size) {
long curpos = dirp->curr - dirp->start;
dirp->size *= 2;
--- 850,856 ----
long endpos = dirp->end - dirp->start;
long newsize = endpos + strlen(ptr) + 1;
/* bump the string table size by enough for the
! * new name and its null terminator */
while (newsize > dirp->size) {
long curpos = dirp->curr - dirp->start;
dirp->size *= 2;
***************
*** 3362,3369 ****
dTHXo;
/* if this is a pseudo-forked child, we just want to spawn
* the new program, and return */
! if (w32_pseudo_id)
! return win32_spawnvp(P_WAIT, cmdname, (char *const *)argv);
#endif
return execvp(cmdname, (char *const *)argv);
}
--- 3362,3376 ----
dTHXo;
/* if this is a pseudo-forked child, we just want to spawn
* the new program, and return */
! if (w32_pseudo_id) {
! int status = win32_spawnvp(P_WAIT, cmdname, (char *const *)argv);
! if (status != -1) {
! my_exit(status);
! return 0;
! }
! else
! return status;
! }
#endif
return execvp(cmdname, (char *const *)argv);
}
diff -c 'perl-5.7.1/win32/win32.h' 'perl-5.7.2/win32/win32.h'
Index: ./win32/win32.h
*** ./win32/win32.h Sun Apr 1 03:06:00 2001
--- ./win32/win32.h Mon Jul 9 17:11:36 2001
***************
*** 15,21 ****
#if defined(PERL_OBJECT) || defined(PERL_IMPLICIT_SYS) || defined(PERL_CAPI)
# define DYNAMIC_ENV_FETCH
- # define ENV_HV_NAME "___ENV_HV_NAME___"
# define HAS_GETENV_LEN
# define prime_env_iter()
# define WIN32IO_IS_STDIO /* don't pull in custom stdio layer */
--- 15,20 ----
***************
*** 466,477 ****
/* Use CP_UTF8 when mode is UTF8 */
#define A2WHELPER_LEN(lpa, alen, lpw, nBytes)\
! (lpw[0] = 0, MultiByteToWideChar((IN_BYTE) ? CP_ACP : CP_UTF8, 0, \
lpa, alen, lpw, (nBytes/sizeof(WCHAR))))
#define A2WHELPER(lpa, lpw, nBytes) A2WHELPER_LEN(lpa, -1, lpw, nBytes)
#define W2AHELPER_LEN(lpw, wlen, lpa, nChars)\
! (lpa[0] = '\0', WideCharToMultiByte((IN_BYTE) ? CP_ACP : CP_UTF8, 0, \
lpw, wlen, (LPSTR)lpa, nChars,NULL,NULL))
#define W2AHELPER(lpw, lpa, nChars) W2AHELPER_LEN(lpw, -1, lpa, nChars)
--- 465,476 ----
/* Use CP_UTF8 when mode is UTF8 */
#define A2WHELPER_LEN(lpa, alen, lpw, nBytes)\
! (lpw[0] = 0, MultiByteToWideChar((IN_BYTES) ? CP_ACP : CP_UTF8, 0, \
lpa, alen, lpw, (nBytes/sizeof(WCHAR))))
#define A2WHELPER(lpa, lpw, nBytes) A2WHELPER_LEN(lpa, -1, lpw, nBytes)
#define W2AHELPER_LEN(lpw, wlen, lpa, nChars)\
! (lpa[0] = '\0', WideCharToMultiByte((IN_BYTES) ? CP_ACP : CP_UTF8, 0, \
lpw, wlen, (LPSTR)lpa, nChars,NULL,NULL))
#define W2AHELPER(lpw, lpa, nChars) W2AHELPER_LEN(lpw, -1, lpa, nChars)
diff -c /dev/null 'perl-5.7.2/win32/win32io.c'
Index: ./win32/win32io.c
*** ./win32/win32io.c Thu Jan 1 02:00:00 1970
--- ./win32/win32io.c Mon Jul 9 17:11:36 2001
***************
*** 0 ****
--- 1,325 ----
+ #define PERL_NO_GET_CONTEXT
+ #define WIN32_LEAN_AND_MEAN
+ #define WIN32IO_IS_STDIO
+ #include <tchar.h>
+ #ifdef __GNUC__
+ #define Win32_Winsock
+ #endif
+ #include <windows.h>
+
+ #include <sys/stat.h>
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "perliol.h"
+
+ #define NO_XSLOCKS
+ #include "XSUB.h"
+
+ /* Bottom-most level for Win32 case */
+
+ typedef struct
+ {
+ struct _PerlIO base; /* The generic part */
+ HANDLE h; /* OS level handle */
+ IV refcnt; /* REFCNT for the "fd" this represents */
+ int fd; /* UNIX like file descriptor - index into fdtable */
+ } PerlIOWin32;
+
+ PerlIOWin32 *fdtable[256];
+ IV max_open_fd = -1;
+
+ IV
+ PerlIOWin32_popped(PerlIO *f)
+ {
+ PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
+ if (--s->refcnt > 0)
+ {
+ *f = PerlIOBase(f)->next;
+ return 1;
+ }
+ fdtable[s->fd] = NULL;
+ return 0;
+ }
+
+ IV
+ PerlIOWin32_fileno(PerlIO *f)
+ {
+ return PerlIOSelf(f,PerlIOWin32)->fd;
+ }
+
+ IV
+ PerlIOWin32_pushed(PerlIO *f, const char *mode, SV *arg)
+ {
+ IV code = PerlIOBase_pushed(f,mode,arg);
+ if (*PerlIONext(f))
+ {
+ PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
+ s->fd = PerlIO_fileno(PerlIONext(f));
+ }
+ PerlIOBase(f)->flags |= PERLIO_F_OPEN;
+ return code;
+ }
+
+ PerlIO *
+ PerlIOWin32_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
+ {
+ const char *tmode = mode;
+ HANDLE h = INVALID_HANDLE_VALUE;
+ if (f)
+ {
+ /* Close if already open */
+ if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
+ (*PerlIOBase(f)->tab->Close)(f);
+ }
+ if (narg > 0)
+ {
+ char *path = SvPV_nolen(*args);
+ DWORD access = 0;
+ DWORD share = 0;
+ DWORD create = -1;
+ DWORD attr = FILE_ATTRIBUTE_NORMAL;
+ if (*mode == '#')
+ {
+ /* sysopen - imode is UNIX-like O_RDONLY etc.
+ - do_open has converted that back to string form in mode as well
+ - perm is UNIX like permissions
+ */
+ mode++;
+ }
+ else
+ {
+ /* Normal open - decode mode string */
+ }
+ switch(*mode)
+ {
+ case 'r':
+ access = GENERIC_READ;
+ create = OPEN_EXISTING;
+ if (*++mode == '+')
+ {
+ access |= GENERIC_WRITE;
+ create = OPEN_ALWAYS;
+ mode++;
+ }
+ break;
+
+ case 'w':
+ access = GENERIC_WRITE;
+ create = TRUNCATE_EXISTING;
+ if (*++mode == '+')
+ {
+ access |= GENERIC_READ;
+ mode++;
+ }
+ break;
+
+ case 'a':
+ access = GENERIC_WRITE;
+ create = OPEN_ALWAYS;
+ if (*++mode == '+')
+ {
+ access |= GENERIC_READ;
+ mode++;
+ }
+ break;
+ }
+ if (*mode == 'b')
+ {
+ mode++;
+ }
+ else if (*mode == 't')
+ {
+ mode++;
+ }
+ if (*mode || create == -1)
+ {
+ SETERRNO(EINVAL,LIB$_INVARG);
+ return NULL;
+ }
+ if (!(access & GENERIC_WRITE))
+ share = FILE_SHARE_READ;
+ h = CreateFile(path,access,share,NULL,create,attr,NULL);
+ if (h == INVALID_HANDLE_VALUE)
+ {
+ if (create == TRUNCATE_EXISTING)
+ h = CreateFile(path,access,share,NULL,(create = OPEN_ALWAYS),attr,NULL);
+ }
+ }
+ else
+ {
+ /* fd open */
+ h = INVALID_HANDLE_VALUE;
+ if (fd >= 0 && fd <= max_open_fd)
+ {
+ PerlIOWin32 *s = fdtable[fd];
+ if (s)
+ {
+ s->refcnt++;
+ if (!f)
+ f = PerlIO_allocate(aTHX);
+ *f = &s->base;
+ return f;
+ }
+ }
+ if (*mode == 'I')
+ {
+ mode++;
+ switch(fd)
+ {
+ case 0:
+ h = GetStdHandle(STD_INPUT_HANDLE);
+ break;
+ case 1:
+ h = GetStdHandle(STD_OUTPUT_HANDLE);
+ break;
+ case 2:
+ h = GetStdHandle(STD_ERROR_HANDLE);
+ break;
+ }
+ }
+ }
+ if (h != INVALID_HANDLE_VALUE)
+ fd = win32_open_osfhandle((long) h, PerlIOUnix_oflags(tmode));
+ if (fd >= 0)
+ {
+ PerlIOWin32 *s;
+ if (!f)
+ f = PerlIO_allocate(aTHX);
+ s = PerlIOSelf(PerlIO_push(aTHX_ f,self,tmode,PerlIOArg),PerlIOWin32);
+ s->h = h;
+ s->fd = fd;
+ s->refcnt = 1;
+ if (fd >= 0)
+ {
+ fdtable[fd] = s;
+ if (fd > max_open_fd)
+ max_open_fd = fd;
+ }
+ return f;
+ }
+ if (f)
+ {
+ /* FIXME: pop layers ??? */
+ }
+ return NULL;
+ }
+
+ SSize_t
+ PerlIOWin32_read(PerlIO *f, void *vbuf, Size_t count)
+ {
+ PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
+ DWORD len;
+ if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
+ return 0;
+ if (ReadFile(s->h,vbuf,count,&len,NULL))
+ {
+ return len;
+ }
+ else
+ {
+ if (GetLastError() != NO_ERROR)
+ {
+ PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ return -1;
+ }
+ else
+ {
+ if (count != 0)
+ PerlIOBase(f)->flags |= PERLIO_F_EOF;
+ return 0;
+ }
+ }
+ }
+
+ SSize_t
+ PerlIOWin32_write(PerlIO *f, const void *vbuf, Size_t count)
+ {
+ PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
+ DWORD len;
+ if (WriteFile(s->h,vbuf,count,&len,NULL))
+ {
+ return len;
+ }
+ else
+ {
+ PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ return -1;
+ }
+ }
+
+ IV
+ PerlIOWin32_seek(PerlIO *f, Off_t offset, int whence)
+ {
+ static const DWORD where[3] = { FILE_BEGIN, FILE_CURRENT, FILE_END };
+ PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
+ DWORD high = (sizeof(offset) > sizeof(DWORD)) ? (DWORD)(offset >> 32) : 0;
+ DWORD low = (DWORD) offset;
+ DWORD res = SetFilePointer(s->h,low,&high,where[whence]);
+ if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
+ {
+ return 0;
+ }
+ else
+ {
+ return -1;
+ }
+ }
+
+ Off_t
+ PerlIOWin32_tell(PerlIO *f)
+ {
+ PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
+ DWORD high = 0;
+ DWORD res = SetFilePointer(s->h,0,&high,FILE_CURRENT);
+ if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
+ {
+ return ((Off_t) high << 32) | res;
+ }
+ return (Off_t) -1;
+ }
+
+ IV
+ PerlIOWin32_close(PerlIO *f)
+ {
+ PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
+ if (s->refcnt == 1)
+ {
+ if (CloseHandle(s->h))
+ {
+ s->h = INVALID_HANDLE_VALUE;
+ return -1;
+ }
+ }
+ PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
+ return 0;
+ }
+
+ PerlIO_funcs PerlIO_win32 = {
+ "win32",
+ sizeof(PerlIOWin32),
+ PERLIO_K_RAW,
+ PerlIOWin32_pushed,
+ PerlIOWin32_popped,
+ PerlIOWin32_open,
+ NULL, /* getarg */
+ PerlIOWin32_fileno,
+ PerlIOWin32_read,
+ PerlIOBase_unread,
+ PerlIOWin32_write,
+ PerlIOWin32_seek,
+ PerlIOWin32_tell,
+ PerlIOWin32_close,
+ PerlIOBase_noop_ok, /* flush */
+ PerlIOBase_noop_fail, /* fill */
+ PerlIOBase_eof,
+ PerlIOBase_error,
+ PerlIOBase_clearerr,
+ PerlIOBase_setlinebuf,
+ NULL, /* get_base */
+ NULL, /* get_bufsiz */
+ NULL, /* get_ptr */
+ NULL, /* get_cnt */
+ NULL, /* set_ptrcnt */
+ };
+
+
diff -c 'perl-5.7.1/win32/win32thread.h' 'perl-5.7.2/win32/win32thread.h'
Index: ./win32/win32thread.h
*** ./win32/win32thread.h Tue Mar 6 04:07:39 2001
--- ./win32/win32thread.h Mon Jul 9 17:11:37 2001
***************
*** 180,185 ****
--- 180,187 ----
TlsFree(PL_thr_key); \
} STMT_END
+ #define PTHREAD_ATFORK(prepare,parent,child) NOOP
+
#if defined(USE_RTL_THREAD_API) && !defined(_MSC_VER)
#define JOIN(t, avp) \
STMT_START { \
diff -c 'perl-5.7.1/writemain.SH' 'perl-5.7.2/writemain.SH'
Index: ./writemain.SH
*** ./writemain.SH Tue Mar 6 04:07:39 2001
--- ./writemain.SH Mon Jul 9 17:11:37 2001
***************
*** 1,4 ****
! case $CONFIGDOTSH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
--- 1,4 ----
! case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
diff -c 'perl-5.7.1/x2p/Makefile.SH' 'perl-5.7.2/x2p/Makefile.SH'
Index: ./x2p/Makefile.SH
*** ./x2p/Makefile.SH Sun Mar 11 18:30:13 2001
--- ./x2p/Makefile.SH Mon Jul 9 17:11:37 2001
***************
*** 1,4 ****
! case $CONFIGDOTSH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
--- 1,4 ----
! case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
***************
*** 102,108 ****
@echo " "
compile: all
! $(REALPERL) -I../lib ../utils/perlcc -regex 's/$$/.exe/' $(plextract) -prog -verbose dcf -log ../compilelog;
a2p: $(obj) a2p$(OBJ_EXT)
$(CC) -o a2p $(LDFLAGS) $(obj) a2p$(OBJ_EXT) $(libs)
--- 102,108 ----
@echo " "
compile: all
! $(REALPERL) -I../lib ../utils/perlcc -I .. -L .. $(plextract) -v -log ../compilelog;
a2p: $(obj) a2p$(OBJ_EXT)
$(CC) -o a2p $(LDFLAGS) $(obj) a2p$(OBJ_EXT) $(libs)
***************
*** 111,121 ****
# used only if you force byacc to run by saying
# make run_byacc
! run_byacc: FORCE
@ echo Expect many shift/reduce and reduce/reduce conflicts
$(BYACC) a2p.y
rm -f a2p.c
! mv y.tab.c a2p.c
FORCE:
--- 111,131 ----
# used only if you force byacc to run by saying
# make run_byacc
! check_byacc:
! @$(BYACC) -V 2>&1 | grep 'version 1\.8\.2'
!
! run_byacc: FORCE check_byacc
@ echo Expect many shift/reduce and reduce/reduce conflicts
$(BYACC) a2p.y
rm -f a2p.c
! sed -e 's/(yyn = yydefred\[yystate\])/((yyn = yydefred[yystate]))/' \
! -e 's/(yys = getenv("YYDEBUG"))/((yys = getenv("YYDEBUG")))/' \
! -e 's/^yyerrlab://' \
! -e 's/^ goto yyerrlab;//' \
! -e 's/^yynewerror://' \
! -e 's/^ goto yynewerror;//' \
! -e 's|^static char yysccsid\(.*\)|/* static char yysccsid\1 */|' \
! < y.tab.c > a2p.c
FORCE:
***************
*** 129,135 ****
$(CCCMD) a2p.c
clean:
! rm -f a2p *$(OBJ_EXT) $(plexe) $(plc) $(plm)
realclean: clean
rm -f core $(addedbyconf) all malloc.c
--- 139,145 ----
$(CCCMD) a2p.c
clean:
! rm -f a2p psed *$(OBJ_EXT) $(plexe) $(plc) $(plm)
realclean: clean
rm -f core $(addedbyconf) all malloc.c
diff -c 'perl-5.7.1/x2p/a2p.c' 'perl-5.7.2/x2p/a2p.c'
Index: ./x2p/a2p.c
Prereq: 1.8
*** ./x2p/a2p.c Tue Mar 6 04:07:40 2001
--- ./x2p/a2p.c Mon Jul 9 17:11:38 2001
***************
*** 1,5 ****
#ifndef lint
! static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91";
#endif
#define YYBYACC 1
#line 2 "a2p.y"
--- 1,5 ----
#ifndef lint
! /* static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91"; */
#endif
#define YYBYACC 1
#line 2 "a2p.y"
***************
*** 2087,2096 ****
register int yym, yyn, yystate;
#if YYDEBUG
register char *yys;
- #ifndef __cplusplus
extern char *getenv();
! #endif
! if (yys = getenv("YYDEBUG"))
{
yyn = *yys;
if (yyn >= '0' && yyn <= '9')
--- 2087,2095 ----
register int yym, yyn, yystate;
#if YYDEBUG
register char *yys;
extern char *getenv();
!
! if ((yys = getenv("YYDEBUG")))
{
yyn = *yys;
if (yyn >= '0' && yyn <= '9')
***************
*** 2107,2113 ****
*yyssp = yystate = 0;
yyloop:
! if (yyn = yydefred[yystate]) goto yyreduce;
if (yychar < 0)
{
if ((yychar = yylex()) < 0) yychar = 0;
--- 2106,2112 ----
*yyssp = yystate = 0;
yyloop:
! if ((yyn = yydefred[yystate])) goto yyreduce;
if (yychar < 0)
{
if ((yychar = yylex()) < 0) yychar = 0;
***************
*** 2148,2161 ****
}
if (yyerrflag) goto yyinrecovery;
#ifdef lint
! goto yynewerror;
#endif
! yynewerror:
yyerror("syntax error");
#ifdef lint
! goto yyerrlab;
#endif
! yyerrlab:
++yynerrs;
yyinrecovery:
if (yyerrflag < 3)
--- 2147,2160 ----
}
if (yyerrflag) goto yyinrecovery;
#ifdef lint
!
#endif
!
yyerror("syntax error");
#ifdef lint
!
#endif
!
++yynerrs;
yyinrecovery:
if (yyerrflag < 3)
diff -c 'perl-5.7.1/x2p/a2p.h' 'perl-5.7.2/x2p/a2p.h'
Index: ./x2p/a2p.h
*** ./x2p/a2p.h Tue Mar 6 04:07:40 2001
--- ./x2p/a2p.h Mon Jul 9 17:11:38 2001
***************
*** 86,103 ****
# include <strings.h>
#endif
- #if !defined(HAS_BCOPY) || defined(__cplusplus)
- # define bcopy(s1,s2,l) memcpy(s2,s1,l)
- #endif
- #if !defined(HAS_BZERO) || defined(__cplusplus)
- # define bzero(s,l) memset(s,0,l)
- #endif
-
#if !defined(HAS_STRCHR) && defined(HAS_INDEX) && !defined(strchr)
#define strchr index
#define strrchr rindex
#endif
-
#ifdef I_TIME
# include <time.h>
--- 86,95 ----
diff -c 'perl-5.7.1/x2p/a2py.c' 'perl-5.7.2/x2p/a2py.c'
Index: ./x2p/a2py.c
*** ./x2p/a2py.c Tue Mar 6 04:07:40 2001
--- ./x2p/a2py.c Mon Jul 9 17:11:38 2001
***************
*** 8,17 ****
* $Log: a2py.c,v $
*/
! #if defined(OS2) || defined(WIN32)
#if defined(WIN32)
#include <io.h>
#endif
#include "../patchlevel.h"
#endif
#include "util.h"
--- 8,20 ----
* $Log: a2py.c,v $
*/
! #if defined(OS2) || defined(WIN32) || defined(NETWARE)
#if defined(WIN32)
#include <io.h>
#endif
+ #if defined(NETWARE)
+ #include "../netware/clibstuf.h"
+ #endif
#include "../patchlevel.h"
#endif
#include "util.h"
***************
*** 29,35 ****
int oper5(int type, int arg1, int arg2, int arg3, int arg4, int arg5);
STR *walk(int useval, int level, register int node, int *numericptr, int minprec);
! #if defined(OS2) || defined(WIN32)
static void usage(void);
static void
--- 32,38 ----
int oper5(int type, int arg1, int arg2, int arg3, int arg4, int arg5);
STR *walk(int useval, int level, register int node, int *numericptr, int minprec);
! #if defined(OS2) || defined(WIN32) || defined(NETWARE)
static void usage(void);
static void
***************
*** 55,60 ****
--- 58,67 ----
int i;
STR *tmpstr;
+ #ifdef NETWARE
+ fnInitGpfGlobals(); // For importing the CLIB calls in place of Watcom calls
+ #endif /* NETWARE */
+
myname = argv[0];
linestr = str_new(80);
str = str_new(0); /* first used for -I flags */
***************
*** 61,67 ****
for (argc--,argv++; argc; argc--,argv++) {
if (argv[0][0] != '-' || !argv[0][1])
break;
- reswitch:
switch (argv[0][1]) {
#ifdef DEBUGGING
case 'D':
--- 68,73 ----
***************
*** 91,97 ****
case 0:
break;
default:
! #if defined(OS2) || defined(WIN32)
fprintf(stderr, "Unrecognized switch: %s\n",argv[0]);
usage();
#else
--- 97,103 ----
case 0:
break;
default:
! #if defined(OS2) || defined(WIN32) || defined(NETWARE)
fprintf(stderr, "Unrecognized switch: %s\n",argv[0]);
usage();
#else
***************
*** 104,110 ****
/* open script */
if (argv[0] == Nullch) {
! #if defined(OS2) || defined(WIN32)
if ( isatty(fileno(stdin)) )
usage();
#endif
--- 110,116 ----
/* open script */
if (argv[0] == Nullch) {
! #if defined(OS2) || defined(WIN32) || defined(NETWARE)
if ( isatty(fileno(stdin)) )
usage();
#endif
***************
*** 212,222 ****
retry:
#if YYDEBUG
! if (yydebug)
if (strchr(s,'\n'))
fprintf(stderr,"Tokener at %s",s);
else
fprintf(stderr,"Tokener at %s\n",s);
#endif
switch (*s) {
default:
--- 218,229 ----
retry:
#if YYDEBUG
! if (yydebug) {
if (strchr(s,'\n'))
fprintf(stderr,"Tokener at %s",s);
else
fprintf(stderr,"Tokener at %s\n",s);
+ }
#endif
switch (*s) {
default:
***************
*** 281,287 ****
s++;
XTERM('}');
case '}':
! for (d = s + 1; isspace(*d); d++) ;
if (!*d)
s = d - 1;
*s = 127;
--- 288,294 ----
s++;
XTERM('}');
case '}':
! for (d = s + 1; isSPACE(*d); d++) ;
if (!*d)
s = d - 1;
*s = 127;
***************
*** 383,389 ****
#define SNARFWORD \
d = tokenbuf; \
! while (isalpha(*s) || isdigit(*s) || *s == '_') \
*d++ = *s++; \
*d = '\0'; \
d = tokenbuf; \
--- 390,396 ----
#define SNARFWORD \
d = tokenbuf; \
! while (isALPHA(*s) || isDIGIT(*s) || *s == '_') \
*d++ = *s++; \
*d = '\0'; \
d = tokenbuf; \
***************
*** 402,409 ****
ID("0");
}
do_split = TRUE;
! if (isdigit(*s)) {
! for (d = s; isdigit(*s); s++) ;
yylval = string(d,s-d);
tmp = atoi(d);
if (tmp > maxfld)
--- 409,416 ----
ID("0");
}
do_split = TRUE;
! if (isDIGIT(*s)) {
! for (d = s; isDIGIT(*s); s++) ;
yylval = string(d,s-d);
tmp = atoi(d);
if (tmp > maxfld)
***************
*** 473,487 ****
XTERM(FUN1);
}
if (strEQ(d,"chdir"))
! *d = toupper(*d);
else if (strEQ(d,"crypt"))
! *d = toupper(*d);
else if (strEQ(d,"chop"))
! *d = toupper(*d);
else if (strEQ(d,"chmod"))
! *d = toupper(*d);
else if (strEQ(d,"chown"))
! *d = toupper(*d);
ID(d);
case 'd': case 'D':
SNARFWORD;
--- 480,494 ----
XTERM(FUN1);
}
if (strEQ(d,"chdir"))
! *d = toUPPER(*d);
else if (strEQ(d,"crypt"))
! *d = toUPPER(*d);
else if (strEQ(d,"chop"))
! *d = toUPPER(*d);
else if (strEQ(d,"chmod"))
! *d = toUPPER(*d);
else if (strEQ(d,"chown"))
! *d = toUPPER(*d);
ID(d);
case 'd': case 'D':
SNARFWORD;
***************
*** 490,496 ****
if (strEQ(d,"delete"))
XTERM(DELETE);
if (strEQ(d,"die"))
! *d = toupper(*d);
ID(d);
case 'e': case 'E':
SNARFWORD;
--- 497,503 ----
if (strEQ(d,"delete"))
XTERM(DELETE);
if (strEQ(d,"die"))
! *d = toUPPER(*d);
ID(d);
case 'e': case 'E':
SNARFWORD;
***************
*** 507,523 ****
XTERM(FUN1);
}
if (strEQ(d,"elsif"))
! *d = toupper(*d);
else if (strEQ(d,"eq"))
! *d = toupper(*d);
else if (strEQ(d,"eval"))
! *d = toupper(*d);
else if (strEQ(d,"eof"))
! *d = toupper(*d);
else if (strEQ(d,"each"))
! *d = toupper(*d);
else if (strEQ(d,"exec"))
! *d = toupper(*d);
ID(d);
case 'f': case 'F':
SNARFWORD;
--- 514,530 ----
XTERM(FUN1);
}
if (strEQ(d,"elsif"))
! *d = toUPPER(*d);
else if (strEQ(d,"eq"))
! *d = toUPPER(*d);
else if (strEQ(d,"eval"))
! *d = toUPPER(*d);
else if (strEQ(d,"eof"))
! *d = toUPPER(*d);
else if (strEQ(d,"each"))
! *d = toUPPER(*d);
else if (strEQ(d,"exec"))
! *d = toUPPER(*d);
ID(d);
case 'f': case 'F':
SNARFWORD;
***************
*** 524,532 ****
if (strEQ(d,"FS")) {
saw_FS++;
if (saw_FS == 1 && in_begin) {
! for (d = s; *d && isspace(*d); d++) ;
if (*d == '=') {
! for (d++; *d && isspace(*d); d++) ;
if (*d == '"' && d[2] == '"')
const_FS = d[1];
}
--- 531,539 ----
if (strEQ(d,"FS")) {
saw_FS++;
if (saw_FS == 1 && in_begin) {
! for (d = s; *d && isSPACE(*d); d++) ;
if (*d == '=') {
! for (d++; *d && isSPACE(*d); d++) ;
if (*d == '"' && d[2] == '"')
const_FS = d[1];
}
***************
*** 540,552 ****
if (strEQ(d,"FILENAME"))
d = "ARGV";
if (strEQ(d,"foreach"))
! *d = toupper(*d);
else if (strEQ(d,"format"))
! *d = toupper(*d);
else if (strEQ(d,"fork"))
! *d = toupper(*d);
else if (strEQ(d,"fh"))
! *d = toupper(*d);
ID(d);
case 'g': case 'G':
SNARFWORD;
--- 547,559 ----
if (strEQ(d,"FILENAME"))
d = "ARGV";
if (strEQ(d,"foreach"))
! *d = toUPPER(*d);
else if (strEQ(d,"format"))
! *d = toUPPER(*d);
else if (strEQ(d,"fork"))
! *d = toUPPER(*d);
else if (strEQ(d,"fh"))
! *d = toUPPER(*d);
ID(d);
case 'g': case 'G':
SNARFWORD;
***************
*** 555,572 ****
if (strEQ(d,"gsub"))
XTERM(GSUB);
if (strEQ(d,"ge"))
! *d = toupper(*d);
else if (strEQ(d,"gt"))
! *d = toupper(*d);
else if (strEQ(d,"goto"))
! *d = toupper(*d);
else if (strEQ(d,"gmtime"))
! *d = toupper(*d);
ID(d);
case 'h': case 'H':
SNARFWORD;
if (strEQ(d,"hex"))
! *d = toupper(*d);
ID(d);
case 'i': case 'I':
SNARFWORD;
--- 562,579 ----
if (strEQ(d,"gsub"))
XTERM(GSUB);
if (strEQ(d,"ge"))
! *d = toUPPER(*d);
else if (strEQ(d,"gt"))
! *d = toUPPER(*d);
else if (strEQ(d,"goto"))
! *d = toUPPER(*d);
else if (strEQ(d,"gmtime"))
! *d = toUPPER(*d);
ID(d);
case 'h': case 'H':
SNARFWORD;
if (strEQ(d,"hex"))
! *d = toUPPER(*d);
ID(d);
case 'i': case 'I':
SNARFWORD;
***************
*** 586,599 ****
case 'j': case 'J':
SNARFWORD;
if (strEQ(d,"join"))
! *d = toupper(*d);
ID(d);
case 'k': case 'K':
SNARFWORD;
if (strEQ(d,"keys"))
! *d = toupper(*d);
else if (strEQ(d,"kill"))
! *d = toupper(*d);
ID(d);
case 'l': case 'L':
SNARFWORD;
--- 593,606 ----
case 'j': case 'J':
SNARFWORD;
if (strEQ(d,"join"))
! *d = toUPPER(*d);
ID(d);
case 'k': case 'K':
SNARFWORD;
if (strEQ(d,"keys"))
! *d = toUPPER(*d);
else if (strEQ(d,"kill"))
! *d = toUPPER(*d);
ID(d);
case 'l': case 'L':
SNARFWORD;
***************
*** 606,622 ****
XTERM(FUN1);
}
if (strEQ(d,"last"))
! *d = toupper(*d);
else if (strEQ(d,"local"))
! *d = toupper(*d);
else if (strEQ(d,"lt"))
! *d = toupper(*d);
else if (strEQ(d,"le"))
! *d = toupper(*d);
else if (strEQ(d,"locatime"))
! *d = toupper(*d);
else if (strEQ(d,"link"))
! *d = toupper(*d);
ID(d);
case 'm': case 'M':
SNARFWORD;
--- 613,629 ----
XTERM(FUN1);
}
if (strEQ(d,"last"))
! *d = toUPPER(*d);
else if (strEQ(d,"local"))
! *d = toUPPER(*d);
else if (strEQ(d,"lt"))
! *d = toUPPER(*d);
else if (strEQ(d,"le"))
! *d = toUPPER(*d);
else if (strEQ(d,"locatime"))
! *d = toUPPER(*d);
else if (strEQ(d,"link"))
! *d = toUPPER(*d);
ID(d);
case 'm': case 'M':
SNARFWORD;
***************
*** 625,631 ****
XTERM(MATCH);
}
if (strEQ(d,"m"))
! *d = toupper(*d);
ID(d);
case 'n': case 'N':
SNARFWORD;
--- 632,638 ----
XTERM(MATCH);
}
if (strEQ(d,"m"))
! *d = toUPPER(*d);
ID(d);
case 'n': case 'N':
SNARFWORD;
***************
*** 636,642 ****
XTERM(NEXT);
}
if (strEQ(d,"ne"))
! *d = toupper(*d);
ID(d);
case 'o': case 'O':
SNARFWORD;
--- 643,649 ----
XTERM(NEXT);
}
if (strEQ(d,"ne"))
! *d = toUPPER(*d);
ID(d);
case 'o': case 'O':
SNARFWORD;
***************
*** 652,662 ****
d = "#";
}
if (strEQ(d,"open"))
! *d = toupper(*d);
else if (strEQ(d,"ord"))
! *d = toupper(*d);
else if (strEQ(d,"oct"))
! *d = toupper(*d);
ID(d);
case 'p': case 'P':
SNARFWORD;
--- 659,669 ----
d = "#";
}
if (strEQ(d,"open"))
! *d = toUPPER(*d);
else if (strEQ(d,"ord"))
! *d = toUPPER(*d);
else if (strEQ(d,"oct"))
! *d = toUPPER(*d);
ID(d);
case 'p': case 'P':
SNARFWORD;
***************
*** 667,675 ****
XTERM(PRINTF);
}
if (strEQ(d,"push"))
! *d = toupper(*d);
else if (strEQ(d,"pop"))
! *d = toupper(*d);
ID(d);
case 'q': case 'Q':
SNARFWORD;
--- 674,682 ----
XTERM(PRINTF);
}
if (strEQ(d,"push"))
! *d = toUPPER(*d);
else if (strEQ(d,"pop"))
! *d = toUPPER(*d);
ID(d);
case 'q': case 'Q':
SNARFWORD;
***************
*** 687,697 ****
if (strEQ(d,"return"))
XTERM(RET);
if (strEQ(d,"reset"))
! *d = toupper(*d);
else if (strEQ(d,"redo"))
! *d = toupper(*d);
else if (strEQ(d,"rename"))
! *d = toupper(*d);
ID(d);
case 's': case 'S':
SNARFWORD;
--- 694,704 ----
if (strEQ(d,"return"))
XTERM(RET);
if (strEQ(d,"reset"))
! *d = toUPPER(*d);
else if (strEQ(d,"redo"))
! *d = toUPPER(*d);
else if (strEQ(d,"rename"))
! *d = toUPPER(*d);
ID(d);
case 's': case 'S':
SNARFWORD;
***************
*** 734,787 ****
XTERM(FUN1);
}
if (strEQ(d,"s"))
! *d = toupper(*d);
else if (strEQ(d,"shift"))
! *d = toupper(*d);
else if (strEQ(d,"select"))
! *d = toupper(*d);
else if (strEQ(d,"seek"))
! *d = toupper(*d);
else if (strEQ(d,"stat"))
! *d = toupper(*d);
else if (strEQ(d,"study"))
! *d = toupper(*d);
else if (strEQ(d,"sleep"))
! *d = toupper(*d);
else if (strEQ(d,"symlink"))
! *d = toupper(*d);
else if (strEQ(d,"sort"))
! *d = toupper(*d);
ID(d);
case 't': case 'T':
SNARFWORD;
if (strEQ(d,"tr"))
! *d = toupper(*d);
else if (strEQ(d,"tell"))
! *d = toupper(*d);
else if (strEQ(d,"time"))
! *d = toupper(*d);
else if (strEQ(d,"times"))
! *d = toupper(*d);
ID(d);
case 'u': case 'U':
SNARFWORD;
if (strEQ(d,"until"))
! *d = toupper(*d);
else if (strEQ(d,"unless"))
! *d = toupper(*d);
else if (strEQ(d,"umask"))
! *d = toupper(*d);
else if (strEQ(d,"unshift"))
! *d = toupper(*d);
else if (strEQ(d,"unlink"))
! *d = toupper(*d);
else if (strEQ(d,"utime"))
! *d = toupper(*d);
ID(d);
case 'v': case 'V':
SNARFWORD;
if (strEQ(d,"values"))
! *d = toupper(*d);
ID(d);
case 'w': case 'W':
SNARFWORD;
--- 741,794 ----
XTERM(FUN1);
}
if (strEQ(d,"s"))
! *d = toUPPER(*d);
else if (strEQ(d,"shift"))
! *d = toUPPER(*d);
else if (strEQ(d,"select"))
! *d = toUPPER(*d);
else if (strEQ(d,"seek"))
! *d = toUPPER(*d);
else if (strEQ(d,"stat"))
! *d = toUPPER(*d);
else if (strEQ(d,"study"))
! *d = toUPPER(*d);
else if (strEQ(d,"sleep"))
! *d = toUPPER(*d);
else if (strEQ(d,"symlink"))
! *d = toUPPER(*d);
else if (strEQ(d,"sort"))
! *d = toUPPER(*d);
ID(d);
case 't': case 'T':
SNARFWORD;
if (strEQ(d,"tr"))
! *d = toUPPER(*d);
else if (strEQ(d,"tell"))
! *d = toUPPER(*d);
else if (strEQ(d,"time"))
! *d = toUPPER(*d);
else if (strEQ(d,"times"))
! *d = toUPPER(*d);
ID(d);
case 'u': case 'U':
SNARFWORD;
if (strEQ(d,"until"))
! *d = toUPPER(*d);
else if (strEQ(d,"unless"))
! *d = toUPPER(*d);
else if (strEQ(d,"umask"))
! *d = toUPPER(*d);
else if (strEQ(d,"unshift"))
! *d = toUPPER(*d);
else if (strEQ(d,"unlink"))
! *d = toUPPER(*d);
else if (strEQ(d,"utime"))
! *d = toUPPER(*d);
ID(d);
case 'v': case 'V':
SNARFWORD;
if (strEQ(d,"values"))
! *d = toUPPER(*d);
ID(d);
case 'w': case 'W':
SNARFWORD;
***************
*** 788,806 ****
if (strEQ(d,"while"))
XTERM(WHILE);
if (strEQ(d,"write"))
! *d = toupper(*d);
else if (strEQ(d,"wait"))
! *d = toupper(*d);
ID(d);
case 'x': case 'X':
SNARFWORD;
if (strEQ(d,"x"))
! *d = toupper(*d);
ID(d);
case 'y': case 'Y':
SNARFWORD;
if (strEQ(d,"y"))
! *d = toupper(*d);
ID(d);
case 'z': case 'Z':
SNARFWORD;
--- 795,813 ----
if (strEQ(d,"while"))
XTERM(WHILE);
if (strEQ(d,"write"))
! *d = toUPPER(*d);
else if (strEQ(d,"wait"))
! *d = toUPPER(*d);
ID(d);
case 'x': case 'X':
SNARFWORD;
if (strEQ(d,"x"))
! *d = toUPPER(*d);
ID(d);
case 'y': case 'Y':
SNARFWORD;
if (strEQ(d,"y"))
! *d = toUPPER(*d);
ID(d);
case 'z': case 'Z':
SNARFWORD;
***************
*** 869,881 ****
case '1': case '2': case '3': case '4': case '5':
case '6': case '7': case '8': case '9': case '0' : case '.':
d = tokenbuf;
! while (isdigit(*s)) {
*d++ = *s++;
}
if (*s == '.') {
! if (isdigit(s[1])) {
*d++ = *s++;
! while (isdigit(*s)) {
*d++ = *s++;
}
}
--- 876,888 ----
case '1': case '2': case '3': case '4': case '5':
case '6': case '7': case '8': case '9': case '0' : case '.':
d = tokenbuf;
! while (isDIGIT(*s)) {
*d++ = *s++;
}
if (*s == '.') {
! if (isDIGIT(s[1])) {
*d++ = *s++;
! while (isDIGIT(*s)) {
*d++ = *s++;
}
}
***************
*** 886,892 ****
*d++ = *s++;
if (*s == '+' || *s == '-')
*d++ = *s++;
! while (isdigit(*s))
*d++ = *s++;
}
*d = '\0';
--- 893,899 ----
*d++ = *s++;
if (*s == '+' || *s == '-')
*d++ = *s++;
! while (isDIGIT(*s))
*d++ = *s++;
}
*d = '\0';
***************
*** 1059,1067 ****
s++;
}
else if (*s == '\n') {
! for (t = s+1; isspace(*t & 127); t++) ;
t--;
! while (isspace(*t & 127) && *t != '\n') t--;
if (*t == '\n' && t-s > 1) {
if (s[-1] == '{')
s--;
--- 1066,1074 ----
s++;
}
else if (*s == '\n') {
! for (t = s+1; isSPACE(*t & 127); t++) ;
t--;
! while (isSPACE(*t & 127) && *t != '\n') t--;
if (*t == '\n' && t-s > 1) {
if (s[-1] == '{')
s--;
***************
*** 1094,1100 ****
if (pos > 78) { /* split a long line? */
*d-- = '\0';
newpos = 0;
! for (t = tokenbuf; isspace(*t & 127); t++) {
if (*t == '\t')
newpos += 8;
else
--- 1101,1107 ----
if (pos > 78) { /* split a long line? */
*d-- = '\0';
newpos = 0;
! for (t = tokenbuf; isSPACE(*t & 127); t++) {
if (*t == '\t')
newpos += 8;
else
***************
*** 1226,1232 ****
{
int type;
STR *str;
! int numargs;
if (!arg)
return prevargs;
--- 1233,1239 ----
{
int type;
STR *str;
! int numargs = 0;
if (!arg)
return prevargs;
diff -c 'perl-5.7.1/x2p/cflags.SH' 'perl-5.7.2/x2p/cflags.SH'
Index: ./x2p/cflags.SH
*** ./x2p/cflags.SH Tue Mar 6 04:07:40 2001
--- ./x2p/cflags.SH Mon Jul 9 17:11:38 2001
***************
*** 1,4 ****
! case $CONFIGDOTSH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
--- 1,4 ----
! case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
***************
*** 34,40 ****
: In the following dollars and backticks do not need the extra backslash.
$spitshell >>cflags <<'!NO!SUBS!'
! case $CONFIG in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
--- 34,40 ----
: In the following dollars and backticks do not need the extra backslash.
$spitshell >>cflags <<'!NO!SUBS!'
! case $PERL_CONFIG_SH in
'')
if test -f config.sh; then TOP=.;
elif test -f ../config.sh; then TOP=..;
diff -c 'perl-5.7.1/x2p/find2perl.PL' 'perl-5.7.2/x2p/find2perl.PL'
Index: ./x2p/find2perl.PL
*** ./x2p/find2perl.PL Tue Apr 3 20:59:17 2001
--- ./x2p/find2perl.PL Mon Jul 9 17:11:38 2001
***************
*** 56,67 ****
#
# Modified 2000-01-28 to use the 'follow' option of File::Find
my @roots = ();
while ($ARGV[0] =~ /^[^-!(]/) {
push(@roots, shift);
}
@roots = (curdir()) unless @roots;
! for (@roots) { $_ = "e($_) }
my $roots = join(', ', @roots);
my $find = "find";
--- 56,72 ----
#
# Modified 2000-01-28 to use the 'follow' option of File::Find
+ sub tab ();
+ sub n ($$);
+ sub fileglob_to_re ($);
+ sub quote ($);
+
my @roots = ();
while ($ARGV[0] =~ /^[^-!(]/) {
push(@roots, shift);
}
@roots = (curdir()) unless @roots;
! for (@roots) { $_ = quote($_) }
my $roots = join(', ', @roots);
my $find = "find";
***************
*** 72,77 ****
--- 77,83 ----
my $initfile = '';
my $initnewer = '';
my $out = '';
+ my $declaresubs = "sub wanted;\n";
my %init = ();
my ($follow_in_effect,$Skip_And) = (0,0);
***************
*** 79,104 ****
$_ = shift;
s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
if ($_ eq '(') {
! $out .= &tab . "(\n";
$indent_depth++;
next;
} elsif ($_ eq ')') {
--$indent_depth;
! $out .= &tab . ")";
} elsif ($_ eq 'follow') {
$follow_in_effect= 1;
$stat = 'stat';
$Skip_And= 1;
} elsif ($_ eq '!') {
! $out .= &tab . "!";
next;
} elsif ($_ eq 'name') {
! $out .= &tab . '/' . &fileglob_to_re(shift) . "/s";
} elsif ($_ eq 'perm') {
my $onum = shift;
$onum =~ /^-?[0-7]+$/
|| die "Malformed -perm argument: $onum\n";
! $out .= &tab;
if ($onum =~ s/^-//) {
$onum = sprintf("0%o", oct($onum) & 07777);
$out .= "((\$mode & $onum) == $onum)";
--- 85,110 ----
$_ = shift;
s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
if ($_ eq '(') {
! $out .= tab . "(\n";
$indent_depth++;
next;
} elsif ($_ eq ')') {
--$indent_depth;
! $out .= tab . ")";
} elsif ($_ eq 'follow') {
$follow_in_effect= 1;
$stat = 'stat';
$Skip_And= 1;
} elsif ($_ eq '!') {
! $out .= tab . "!";
next;
} elsif ($_ eq 'name') {
! $out .= tab . '/' . fileglob_to_re(shift) . "/s";
} elsif ($_ eq 'perm') {
my $onum = shift;
$onum =~ /^-?[0-7]+$/
|| die "Malformed -perm argument: $onum\n";
! $out .= tab;
if ($onum =~ s/^-//) {
$onum = sprintf("0%o", oct($onum) & 07777);
$out .= "((\$mode & $onum) == $onum)";
***************
*** 108,121 ****
}
} elsif ($_ eq 'type') {
(my $filetest = shift) =~ tr/s/S/;
! $out .= &tab . "-$filetest _";
} elsif ($_ eq 'print') {
! $out .= &tab . 'print("$name\n")';
} elsif ($_ eq 'print0') {
! $out .= &tab . 'print("$name\0")';
} elsif ($_ eq 'fstype') {
my $type = shift;
! $out .= &tab;
if ($type eq 'nfs') {
$out .= '($dev < 0)';
} else {
--- 114,127 ----
}
} elsif ($_ eq 'type') {
(my $filetest = shift) =~ tr/s/S/;
! $out .= tab . "-$filetest _";
} elsif ($_ eq 'print') {
! $out .= tab . 'print("$name\n")';
} elsif ($_ eq 'print0') {
! $out .= tab . 'print("$name\0")';
} elsif ($_ eq 'fstype') {
my $type = shift;
! $out .= tab;
if ($type eq 'nfs') {
$out .= '($dev < 0)';
} else {
***************
*** 123,144 ****
}
} elsif ($_ eq 'user') {
my $uname = shift;
! $out .= &tab . "(\$uid == \$uid{'$uname'})";
$init{user} = 1;
} elsif ($_ eq 'group') {
my $gname = shift;
! $out .= &tab . "(\$gid == \$gid{'$gname'})";
$init{group} = 1;
} elsif ($_ eq 'nouser') {
! $out .= &tab . '!exists $uid{$uid}';
$init{user} = 1;
} elsif ($_ eq 'nogroup') {
! $out .= &tab . '!exists $gid{$gid}';
$init{group} = 1;
} elsif ($_ eq 'links') {
! $out .= &tab . &n('$nlink', shift);
} elsif ($_ eq 'inum') {
! $out .= &tab . &n('$ino', shift);
} elsif ($_ eq 'size') {
$_ = shift;
my $n = 'int(((-s _) + 511) / 512)';
--- 129,150 ----
}
} elsif ($_ eq 'user') {
my $uname = shift;
! $out .= tab . "(\$uid == \$uid{'$uname'})";
$init{user} = 1;
} elsif ($_ eq 'group') {
my $gname = shift;
! $out .= tab . "(\$gid == \$gid{'$gname'})";
$init{group} = 1;
} elsif ($_ eq 'nouser') {
! $out .= tab . '!exists $uid{$uid}';
$init{user} = 1;
} elsif ($_ eq 'nogroup') {
! $out .= tab . '!exists $gid{$gid}';
$init{group} = 1;
} elsif ($_ eq 'links') {
! $out .= tab . n('$nlink', shift);
} elsif ($_ eq 'inum') {
! $out .= tab . n('$ino', shift);
} elsif ($_ eq 'size') {
$_ = shift;
my $n = 'int(((-s _) + 511) / 512)';
***************
*** 147,165 ****
} elsif (s/k\z//) {
$n = 'int(((-s _) + 1023) / 1024)';
}
! $out .= &tab . &n($n, $_);
} elsif ($_ eq 'atime') {
! $out .= &tab . &n('int(-A _)', shift);
} elsif ($_ eq 'mtime') {
! $out .= &tab . &n('int(-M _)', shift);
} elsif ($_ eq 'ctime') {
! $out .= &tab . &n('int(-C _)', shift);
} elsif ($_ eq 'exec') {
my @cmd = ();
while (@ARGV && $ARGV[0] ne ';')
{ push(@cmd, shift) }
shift;
! $out .= &tab;
if ($cmd[0] =~m#^(?:(?:/usr)?/bin/)?rm$#
&& $cmd[$#cmd] eq '{}'
&& (@cmd == 2 || (@cmd == 3 && $cmd[1] eq '-f'))) {
--- 153,171 ----
} elsif (s/k\z//) {
$n = 'int(((-s _) + 1023) / 1024)';
}
! $out .= tab . n($n, $_);
} elsif ($_ eq 'atime') {
! $out .= tab . n('int(-A _)', shift);
} elsif ($_ eq 'mtime') {
! $out .= tab . n('int(-M _)', shift);
} elsif ($_ eq 'ctime') {
! $out .= tab . n('int(-C _)', shift);
} elsif ($_ eq 'exec') {
my @cmd = ();
while (@ARGV && $ARGV[0] ne ';')
{ push(@cmd, shift) }
shift;
! $out .= tab;
if ($cmd[0] =~m#^(?:(?:/usr)?/bin/)?rm$#
&& $cmd[$#cmd] eq '{}'
&& (@cmd == 2 || (@cmd == 3 && $cmd[1] eq '-f'))) {
***************
*** 173,179 ****
} else {
for (@cmd)
{ s/'/\\'/g }
! { local $" = "','"; $out .= "&doexec(0, '@cmd')"; }
$init{doexec} = 1;
}
} elsif ($_ eq 'ok') {
--- 179,186 ----
} else {
for (@cmd)
{ s/'/\\'/g }
! { local $" = "','"; $out .= "doexec(0, '@cmd')"; }
! $declaresubs .= "sub doexec (\$\@);\n";
$init{doexec} = 1;
}
} elsif ($_ eq 'ok') {
***************
*** 181,195 ****
while (@ARGV && $ARGV[0] ne ';')
{ push(@cmd, shift) }
shift;
! $out .= &tab;
for (@cmd)
{ s/'/\\'/g }
! { local $" = "','"; $out .= "&doexec(0, '@cmd')"; }
$init{doexec} = 1;
} elsif ($_ eq 'prune') {
! $out .= &tab . '($File::Find::prune = 1)';
} elsif ($_ eq 'xdev') {
! $out .= &tab . '!($File::Find::prune |= ($dev != $File::Find::topdev))'
;
} elsif ($_ eq 'newer') {
my $file = shift;
--- 188,203 ----
while (@ARGV && $ARGV[0] ne ';')
{ push(@cmd, shift) }
shift;
! $out .= tab;
for (@cmd)
{ s/'/\\'/g }
! { local $" = "','"; $out .= "doexec(0, '@cmd')"; }
! $declaresubs .= "sub doexec (\$\@);\n";
$init{doexec} = 1;
} elsif ($_ eq 'prune') {
! $out .= tab . '($File::Find::prune = 1)';
} elsif ($_ eq 'xdev') {
! $out .= tab . '!($File::Find::prune |= ($dev != $File::Find::topdev))'
;
} elsif ($_ eq 'newer') {
my $file = shift;
***************
*** 196,212 ****
my $newername = 'AGE_OF' . $file;
$newername =~ s/\W/_/g;
$newername = '$' . $newername;
! $out .= &tab . "(-M _ < $newername)";
! $initnewer .= "my $newername = -M " . "e($file) . ";\n";
} elsif ($_ eq 'eval') {
my $prog = shift;
$prog =~ s/'/\\'/g;
! $out .= &tab . "eval {$prog}";
} elsif ($_ eq 'depth') {
$find = 'finddepth';
next;
} elsif ($_ eq 'ls') {
! $out .= &tab . "&ls";
$init{ls} = 1;
} elsif ($_ eq 'tar') {
die "-tar must have a filename argument\n" unless @ARGV;
--- 204,221 ----
my $newername = 'AGE_OF' . $file;
$newername =~ s/\W/_/g;
$newername = '$' . $newername;
! $out .= tab . "(-M _ < $newername)";
! $initnewer .= "my $newername = -M " . quote($file) . ";\n";
} elsif ($_ eq 'eval') {
my $prog = shift;
$prog =~ s/'/\\'/g;
! $out .= tab . "eval {$prog}";
} elsif ($_ eq 'depth') {
$find = 'finddepth';
next;
} elsif ($_ eq 'ls') {
! $out .= tab . "ls";
! $declaresubs .= "sub ls ();\n";
$init{ls} = 1;
} elsif ($_ eq 'tar') {
die "-tar must have a filename argument\n" unless @ARGV;
***************
*** 213,221 ****
my $file = shift;
my $fh = 'FH' . $file;
$fh =~ s/\W/_/g;
! $out .= &tab . "&tar(*$fh, \$name)";
! $flushall .= "&tflushall;\n";
! $initfile .= "open($fh, " . "e('> ' . $file) .
qq{) || die "Can't open $fh: \$!\\n";\n};
$init{tar} = 1;
} elsif (/^(n?)cpio\z/) {
--- 222,231 ----
my $file = shift;
my $fh = 'FH' . $file;
$fh =~ s/\W/_/g;
! $out .= tab . "tar(*$fh, \$name)";
! $flushall .= "tflushall;\n";
! $declaresubs .= "sub tar;\nsub tflushall ();\n";
! $initfile .= "open($fh, " . quote('> ' . $file) .
qq{) || die "Can't open $fh: \$!\\n";\n};
$init{tar} = 1;
} elsif (/^(n?)cpio\z/) {
***************
*** 223,232 ****
my $file = shift;
my $fh = 'FH' . $file;
$fh =~ s/\W/_/g;
! $out .= &tab . "&cpio(*$fh, \$name, '$1')";
$find = 'finddepth';
! $flushall .= "&cflushall;\n";
! $initfile .= "open($fh, " . "e('> ' . $file) .
qq{) || die "Can't open $fh: \$!\\n";\n};
$init{cpio} = 1;
} else {
--- 233,243 ----
my $file = shift;
my $fh = 'FH' . $file;
$fh =~ s/\W/_/g;
! $out .= tab . "cpio(*$fh, \$name, '$1')";
$find = 'finddepth';
! $flushall .= "cflushall;\n";
! $declaresubs .= "sub cpio;\nsub cflushall ();\n";
! $initfile .= "open($fh, " . quote('> ' . $file) .
qq{) || die "Can't open $fh: \$!\\n";\n};
$init{cpio} = 1;
} else {
***************
*** 235,241 ****
if (@ARGV) {
if ($ARGV[0] eq '-o') {
! { local($statdone) = 1; $out .= "\n" . &tab . "||\n"; }
$statdone = 0 if $indent_depth == 1 && exists $init{delayedstat};
$init{saw_or} = 1;
shift;
--- 246,252 ----
if (@ARGV) {
if ($ARGV[0] eq '-o') {
! { local($statdone) = 1; $out .= "\n" . tab . "||\n"; }
$statdone = 0 if $indent_depth == 1 && exists $init{delayedstat};
$init{saw_or} = 1;
shift;
***************
*** 265,273 ****
*dir = *File::Find::dir;
*prune = *File::Find::prune;
END
-
if (exists $init{ls}) {
print <<'END';
my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx);
--- 276,285 ----
*dir = *File::Find::dir;
*prune = *File::Find::prune;
+ $declaresubs
+
END
if (exists $init{ls}) {
print <<'END';
my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx);
***************
*** 339,357 ****
use Cwd ();
my $cwd = Cwd::cwd();
! sub doexec {
my $ok = shift;
! for my $word (@_)
{ $word =~ s#{}#$name#g }
if ($ok) {
my $old = select(STDOUT);
$| = 1;
! print "@_";
select($old);
return 0 unless <STDIN> =~ /^y/;
}
chdir $cwd; #sigh
! system @_;
chdir $File::Find::dir;
return !$?;
}
--- 351,370 ----
use Cwd ();
my $cwd = Cwd::cwd();
! sub doexec ($@) {
my $ok = shift;
! my @command = @_; # copy so we don't try to s/// aliases to constants
! for my $word (@command)
{ $word =~ s#{}#$name#g }
if ($ok) {
my $old = select(STDOUT);
$| = 1;
! print "@command";
select($old);
return 0 unless <STDIN> =~ /^y/;
}
chdir $cwd; #sigh
! system @command;
chdir $File::Find::dir;
return !$?;
}
***************
*** 367,373 ****
sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff);
}
! sub ls {
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
INTRO
\$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
--- 380,386 ----
sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff);
}
! sub ls () {
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
INTRO
\$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
***************
*** 515,523 ****
}
}
! sub cflushall {
for my $fh (keys %cpout) {
! &cpio($fh, undef, $nc{$fh});
$cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
flush($fh, \$cpout{$fh}, 5120);
print $blocks{$fh} * 10, " blocks\n";
--- 528,536 ----
}
}
! sub cflushall () {
for my $fh (keys %cpout) {
! cpio($fh, undef, $nc{$fh});
$cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
flush($fh, \$cpout{$fh}, 5120);
print $blocks{$fh} * 10, " blocks\n";
***************
*** 619,625 ****
}
}
! sub tflushall {
my $len;
for my $fh (keys %tarout) {
$len = 10240 - length($tarout{$fh});
--- 632,638 ----
}
}
! sub tflushall () {
my $len;
for my $fh (keys %tarout) {
$len = 10240 - length($tarout{$fh});
***************
*** 636,642 ****
############################################################################
! sub tab {
my $tabstring;
$tabstring = "\t" x ($indent_depth/2) . ' ' x ($indent_depth%2 * 4);
--- 649,655 ----
############################################################################
! sub tab () {
my $tabstring;
$tabstring = "\t" x ($indent_depth/2) . ' ' x ($indent_depth%2 * 4);
***************
*** 659,672 ****
$tabstring;
}
! sub fileglob_to_re {
my $x = shift;
! $x =~ s#([./^\$()])#\\$1#g;
$x =~ s#([?*])#.$1#g;
"^$x\\z";
}
! sub n {
my ($pre, $n) = @_;
$n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
$n =~ s/ 0*(\d)/ $1/;
--- 672,685 ----
$tabstring;
}
! sub fileglob_to_re ($) {
my $x = shift;
! $x =~ s#([./^\$()+])#\\$1#g;
$x =~ s#([?*])#.$1#g;
"^$x\\z";
}
! sub n ($$) {
my ($pre, $n) = @_;
$n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
$n =~ s/ 0*(\d)/ $1/;
***************
*** 673,679 ****
"($pre $n)";
}
! sub quote {
my $string = shift;
$string =~ s/\\/\\\\/g;
$string =~ s/'/\\'/g;
--- 686,692 ----
"($pre $n)";
}
! sub quote ($) {
my $string = shift;
$string =~ s/\\/\\\\/g;
$string =~ s/'/\\'/g;
diff -c 'perl-5.7.1/x2p/hash.c' 'perl-5.7.2/x2p/hash.c'
Index: ./x2p/hash.c
*** ./x2p/hash.c Tue Mar 6 04:07:40 2001
--- ./x2p/hash.c Mon Jul 9 17:11:38 2001
***************
*** 137,143 ****
register HENT **oentry;
a = (HENT**) saferealloc((char*)tb->tbl_array, newsize * sizeof(HENT*));
! bzero((char*)&a[oldsize], oldsize * sizeof(HENT*)); /* zero second half */
tb->tbl_max = --newsize;
tb->tbl_array = a;
--- 137,143 ----
register HENT **oentry;
a = (HENT**) saferealloc((char*)tb->tbl_array, newsize * sizeof(HENT*));
! memset(&a[oldsize], 0, oldsize * sizeof(HENT*)); /* zero second half */
tb->tbl_max = --newsize;
tb->tbl_array = a;
***************
*** 171,177 ****
tb->tbl_fill = 0;
tb->tbl_max = 7;
hiterinit(tb); /* so each() will start off right */
! bzero((char*)tb->tbl_array, 8 * sizeof(HENT*));
return tb;
}
--- 171,177 ----
tb->tbl_fill = 0;
tb->tbl_max = 7;
hiterinit(tb); /* so each() will start off right */
! memset(tb->tbl_array, 0, 8 * sizeof(HENT*));
return tb;
}
diff -c 'perl-5.7.1/x2p/s2p.PL' 'perl-5.7.2/x2p/s2p.PL'
Index: ./x2p/s2p.PL
*** ./x2p/s2p.PL Tue Apr 3 21:01:26 2001
--- ./x2p/s2p.PL Mon Jul 9 17:11:38 2001
***************
*** 29,36 ****
$Config{startperl}
eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
if \$running_under_some_shell;
! my $startperl;
! my $perlpath;
(\$startperl = <<'/../') =~ s/\\s*\\z//;
$Config{startperl}
/../
--- 29,36 ----
$Config{startperl}
eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
if \$running_under_some_shell;
! my \$startperl;
! my \$perlpath;
(\$startperl = <<'/../') =~ s/\\s*\\z//;
$Config{startperl}
/../
***************
*** 54,66 ****
=head1 NAME
! sed - a stream editor
=head1 SYNOPSIS
! sed [-an] script [file ...]
! sed [-an] [-e script] [-f script-file] [file ...]
=head1 DESCRIPTION
A stream editor reads the input stream consisting of the specified files
--- 54,68 ----
=head1 NAME
! psed - a stream editor
=head1 SYNOPSIS
! psed [-an] script [file ...]
! psed [-an] [-e script] [-f script-file] [file ...]
+ s2p [-an] [-e script] [-f script-file]
+
=head1 DESCRIPTION
A stream editor reads the input stream consisting of the specified files
***************
*** 1960,1964 ****
--- 1962,1975 ----
close OUT or die "Can't close $file: $!";
chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+ unlink 'psed';
+ print "Linking s2p to psed.\n";
+ if (defined $Config{d_link}) {
+ link 's2p', 'psed';
+ } else {
+ unshift @INC, '../lib';
+ require File::Copy;
+ File::Copy::syscopy('s2p', 'psed');
+ }
exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
chdir $origdir;
diff -c 'perl-5.7.1/x2p/str.c' 'perl-5.7.2/x2p/str.c'
Index: ./x2p/str.c
*** ./x2p/str.c Tue Mar 6 04:07:41 2001
--- ./x2p/str.c Mon Jul 9 17:11:38 2001
***************
*** 77,83 ****
str_nset(register STR *str, register char *ptr, register int len)
{
GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
! bcopy(ptr,str->str_ptr,len);
str->str_cur = len;
*(str->str_ptr+str->str_cur) = '\0';
str->str_nok = 0; /* invalidate number */
--- 77,83 ----
str_nset(register STR *str, register char *ptr, register int len)
{
GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
! memcpy(str->str_ptr,ptr,len);
str->str_cur = len;
*(str->str_ptr+str->str_cur) = '\0';
str->str_nok = 0; /* invalidate number */
***************
*** 93,99 ****
ptr = "";
len = strlen(ptr);
GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
! bcopy(ptr,str->str_ptr,len+1);
str->str_cur = len;
str->str_nok = 0; /* invalidate number */
str->str_pok = 1; /* validate pointer */
--- 93,99 ----
ptr = "";
len = strlen(ptr);
GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
! memcpy(str->str_ptr,ptr,len+1);
str->str_cur = len;
str->str_nok = 0; /* invalidate number */
str->str_pok = 1; /* validate pointer */
***************
*** 107,113 ****
if (!(str->str_pok))
str_2ptr(str);
str->str_cur -= (ptr - str->str_ptr);
! bcopy(ptr,str->str_ptr, str->str_cur + 1);
str->str_nok = 0; /* invalidate number */
str->str_pok = 1; /* validate pointer */
}
--- 107,113 ----
if (!(str->str_pok))
str_2ptr(str);
str->str_cur -= (ptr - str->str_ptr);
! memcpy(str->str_ptr, ptr, str->str_cur + 1);
str->str_nok = 0; /* invalidate number */
str->str_pok = 1; /* validate pointer */
}
***************
*** 118,124 ****
if (!(str->str_pok))
str_2ptr(str);
GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1);
! bcopy(ptr,str->str_ptr+str->str_cur,len);
str->str_cur += len;
*(str->str_ptr+str->str_cur) = '\0';
str->str_nok = 0; /* invalidate number */
--- 118,124 ----
if (!(str->str_pok))
str_2ptr(str);
GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1);
! memcpy(str->str_ptr+str->str_cur, ptr, len);
str->str_cur += len;
*(str->str_ptr+str->str_cur) = '\0';
str->str_nok = 0; /* invalidate number */
***************
*** 145,151 ****
str_2ptr(str);
len = strlen(ptr);
GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1);
! bcopy(ptr,str->str_ptr+str->str_cur,len+1);
str->str_cur += len;
str->str_nok = 0; /* invalidate number */
str->str_pok = 1; /* validate pointer */
--- 145,151 ----
str_2ptr(str);
len = strlen(ptr);
GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1);
! memcpy(str->str_ptr+str->str_cur, ptr, len+1);
str->str_cur += len;
str->str_nok = 0; /* invalidate number */
str->str_pok = 1; /* validate pointer */
***************
*** 197,203 ****
}
else {
str = (STR *) safemalloc(sizeof(STR));
! bzero((char*)str,sizeof(STR));
}
if (len)
GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
--- 197,203 ----
}
else {
str = (STR *) safemalloc(sizeof(STR));
! memset((char*)str,0,sizeof(STR));
}
if (len)
GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
***************
*** 221,227 ****
str->str_len = nstr->str_len;
str->str_cur = nstr->str_cur;
str->str_pok = nstr->str_pok;
! if (str->str_nok = nstr->str_nok)
str->str_nval = nstr->str_nval;
safefree((char*)nstr);
}
--- 221,227 ----
str->str_len = nstr->str_len;
str->str_cur = nstr->str_cur;
str->str_pok = nstr->str_pok;
! if ((str->str_nok = nstr->str_nok))
str->str_nval = nstr->str_nval;
safefree((char*)nstr);
}
***************
*** 285,291 ****
ptr = FILE_ptr(fp);
for (;;) {
while (--cnt >= 0) {
! if ((*bp++ = *ptr++) == newline)
if (bp <= str->str_ptr || bp[-2] != '\\')
goto thats_all_folks;
else {
--- 285,291 ----
ptr = FILE_ptr(fp);
for (;;) {
while (--cnt >= 0) {
! if ((*bp++ = *ptr++) == newline) {
if (bp <= str->str_ptr || bp[-2] != '\\')
goto thats_all_folks;
else {
***************
*** 292,297 ****
--- 292,298 ----
line++;
bp -= 2;
}
+ }
}
FILE_cnt(fp) = cnt; /* deregisterize cnt and ptr */
***************
*** 353,359 ****
}
for (d = str->str_ptr; *d && *d != '.'; d++) ;
d--;
! if (!isdigit(*str->str_ptr) || !isdigit(*d) ) {
str_numset(str,atof(str->str_ptr) + 1.0); /* punt */
return;
}
--- 354,360 ----
}
for (d = str->str_ptr; *d && *d != '.'; d++) ;
d--;
! if (!isDIGIT(*str->str_ptr) || !isDIGIT(*d) ) {
str_numset(str,atof(str->str_ptr) + 1.0); /* punt */
return;
}
***************
*** 389,395 ****
}
for (d = str->str_ptr; *d && *d != '.'; d++) ;
d--;
! if (!isdigit(*str->str_ptr) || !isdigit(*d) || (*d == '0' && d == str->str_ptr)) {
str_numset(str,atof(str->str_ptr) - 1.0); /* punt */
return;
}
--- 390,396 ----
}
for (d = str->str_ptr; *d && *d != '.'; d++) ;
d--;
! if (!isDIGIT(*str->str_ptr) || !isDIGIT(*d) || (*d == '0' && d == str->str_ptr)) {
str_numset(str,atof(str->str_ptr) - 1.0); /* punt */
return;
}
diff -c 'perl-5.7.1/x2p/walk.c' 'perl-5.7.2/x2p/walk.c'
Index: ./x2p/walk.c
*** ./x2p/walk.c Tue Mar 6 04:07:41 2001
--- ./x2p/walk.c Mon Jul 9 17:11:39 2001
***************
*** 52,58 ****
STR *tmp2str;
STR *tmp3str;
char *t;
! char *d, *s;
int numarg;
int numeric = FALSE;
STR *fstr;
--- 52,58 ----
STR *tmp2str;
STR *tmp3str;
char *t;
! char *d, *s = 0;
int numarg;
int numeric = FALSE;
STR *fstr;
***************
*** 69,80 ****
case OPROG:
arymax = 0;
if (namelist) {
! while (isalpha(*namelist)) {
for (d = tokenbuf,s=namelist;
! isalpha(*s) || isdigit(*s) || *s == '_';
*d++ = *s++) ;
*d = '\0';
! while (*s && !isalpha(*s)) s++;
namelist = s;
nameary[++arymax] = savestr(tokenbuf);
}
--- 69,80 ----
case OPROG:
arymax = 0;
if (namelist) {
! while (isALPHA(*namelist)) {
for (d = tokenbuf,s=namelist;
! isALPHA(*s) || isDIGIT(*s) || *s == '_';
*d++ = *s++) ;
*d = '\0';
! while (*s && !isALPHA(*s)) s++;
namelist = s;
nameary[++arymax] = savestr(tokenbuf);
}
***************
*** 241,247 ****
tmpstr=walk(0,level,ops[node+1].ival,&numarg,P_MIN);
/* translate \nnn to [\nnn] */
for (s = tmpstr->str_ptr, d = tokenbuf; *s; s++, d++) {
! if (*s == '\\' && isdigit(s[1]) && isdigit(s[2]) && isdigit(s[3])){
*d++ = '[';
*d++ = *s++;
*d++ = *s++;
--- 241,247 ----
tmpstr=walk(0,level,ops[node+1].ival,&numarg,P_MIN);
/* translate \nnn to [\nnn] */
for (s = tmpstr->str_ptr, d = tokenbuf; *s; s++, d++) {
! if (*s == '\\' && isDIGIT(s[1]) && isDIGIT(s[2]) && isDIGIT(s[3])){
*d++ = '[';
*d++ = *s++;
*d++ = *s++;
***************
*** 589,597 ****
s = savestr(tokenbuf);
for (t = tokenbuf; *t; t++) {
*t &= 127;
! if (islower(*t))
! *t = toupper(*t);
! if (!isalpha(*t) && !isdigit(*t))
*t = '_';
}
if (!strchr(tokenbuf,'_'))
--- 589,597 ----
s = savestr(tokenbuf);
for (t = tokenbuf; *t; t++) {
*t &= 127;
! if (isLOWER(*t))
! *t = toUPPER(*t);
! if (!isALPHA(*t) && !isDIGIT(*t))
*t = '_';
}
if (!strchr(tokenbuf,'_'))
***************
*** 750,756 ****
subretnum |= numarg;
s = Nullch;
t = tmp2str->str_ptr;
! while (t = instr(t,"return "))
s = t++;
if (s) {
i = 0;
--- 750,756 ----
subretnum |= numarg;
s = Nullch;
t = tmp2str->str_ptr;
! while ((t = instr(t,"return ")))
s = t++;
if (s) {
i = 0;
***************
*** 1120,1128 ****
s = savestr(tokenbuf);
for (t = tokenbuf; *t; t++) {
*t &= 127;
! if (islower(*t))
! *t = toupper(*t);
! if (!isalpha(*t) && !isdigit(*t))
*t = '_';
}
if (!strchr(tokenbuf,'_'))
--- 1120,1128 ----
s = savestr(tokenbuf);
for (t = tokenbuf; *t; t++) {
*t &= 127;
! if (isLOWER(*t))
! *t = toUPPER(*t);
! if (!isALPHA(*t) && !isDIGIT(*t))
*t = '_';
}
if (!strchr(tokenbuf,'_'))
***************
*** 1157,1165 ****
s = savestr(tokenbuf);
for (t = tokenbuf; *t; t++) {
*t &= 127;
! if (islower(*t))
! *t = toupper(*t);
! if (!isalpha(*t) && !isdigit(*t))
*t = '_';
}
if (!strchr(tokenbuf,'_'))
--- 1157,1165 ----
s = savestr(tokenbuf);
for (t = tokenbuf; *t; t++) {
*t &= 127;
! if (isLOWER(*t))
! *t = toUPPER(*t);
! if (!isALPHA(*t) && !isDIGIT(*t))
*t = '_';
}
if (!strchr(tokenbuf,'_'))
***************
*** 1430,1436 ****
i = numarg;
if (i) {
t = s = tmpstr->str_ptr;
! while (isalpha(*t) || isdigit(*t) || *t == '$' || *t == '_')
t++;
i = t - s;
if (i < 2)
--- 1430,1436 ----
i = numarg;
if (i) {
t = s = tmpstr->str_ptr;
! while (isALPHA(*t) || isDIGIT(*t) || *t == '$' || *t == '_')
t++;
i = t - s;
if (i < 2)
***************
*** 1463,1469 ****
if (!s)
fatal("Illegal for loop: %s",d);
*s++ = '\0';
! for (t = s; i = *t; t++) {
i &= 127;
if (i == '}' || i == ']')
break;
--- 1463,1469 ----
if (!s)
fatal("Illegal for loop: %s",d);
*s++ = '\0';
! for (t = s; (i = *t); t++) {
i &= 127;
if (i == '}' || i == ']')
break;
diff -c 'perl-5.7.1/xsutils.c' 'perl-5.7.2/xsutils.c'
Index: ./xsutils.c
*** ./xsutils.c Tue Mar 6 04:07:41 2001
--- ./xsutils.c Mon Jul 9 17:11:39 2001
***************
*** 85,95 ****
}
break;
case 's':
! if (strEQ(name, "shared")) {
if (negated)
! GvSHARED_off(CvGV((CV*)sv));
else
! GvSHARED_on(CvGV((CV*)sv));
continue;
}
break;
--- 85,95 ----
}
break;
case 's':
! if (strEQ(name, "unique")) {
if (negated)
! GvUNIQUE_off(CvGV((CV*)sv));
else
! GvUNIQUE_on(CvGV((CV*)sv));
continue;
}
break;
***************
*** 102,109 ****
case 6:
switch (*name) {
case 's':
! if (strEQ(name, "shared")) {
! /* toke.c has already marked as GvSHARED */
continue;
}
}
--- 102,109 ----
case 6:
switch (*name) {
case 's':
! if (strEQ(name, "unique")) {
! /* toke.c has already marked as GVf_UNIQUE */
continue;
}
}
***************
*** 127,132 ****
--- 127,135 ----
dXSARGS;
char *file = __FILE__;
+ if( items > 1 )
+ Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
+
newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file);
newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
***************
*** 186,193 ****
#endif
if (cvflags & CVf_METHOD)
XPUSHs(sv_2mortal(newSVpvn("method", 6)));
! if (GvSHARED(CvGV((CV*)sv)))
! XPUSHs(sv_2mortal(newSVpvn("shared", 6)));
break;
default:
break;
--- 189,196 ----
#endif
if (cvflags & CVf_METHOD)
XPUSHs(sv_2mortal(newSVpvn("method", 6)));
! if (GvUNIQUE(CvGV((CV*)sv)))
! XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
break;
default:
break;
***************
*** 228,245 ****
HV *stash = Nullhv;
switch (SvTYPE(sv)) {
case SVt_PVCV:
! if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)) &&
! HvNAME(GvSTASH(CvGV(sv))))
stash = GvSTASH(CvGV(sv));
! else if (/* !CvANON(sv) && */ CvSTASH(sv) && HvNAME(CvSTASH(sv)))
stash = CvSTASH(sv);
break;
case SVt_PVMG:
! if (!(SvFAKE(sv) && SvTIED_mg(sv, '*')))
break;
/*FALLTHROUGH*/
case SVt_PVGV:
! if (GvGP(sv) && GvESTASH((GV*)sv) && HvNAME(GvESTASH((GV*)sv)))
stash = GvESTASH((GV*)sv);
break;
default:
--- 231,247 ----
HV *stash = Nullhv;
switch (SvTYPE(sv)) {
case SVt_PVCV:
! if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
stash = GvSTASH(CvGV(sv));
! else if (/* !CvANON(sv) && */ CvSTASH(sv))
stash = CvSTASH(sv);
break;
case SVt_PVMG:
! if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
break;
/*FALLTHROUGH*/
case SVt_PVGV:
! if (GvGP(sv) && GvESTASH((GV*)sv))
stash = GvESTASH((GV*)sv);
break;
default:
#### End of Patch data ####
#### ApplyPatch data follows ####
# Data version : 1.0
# Date generated : Fri Jul 13 17:23:13 2001
# Generated by : makepatch 2.00_05
# Recurse directories : Yes
# r 'win32/bin/mdelete.bat' 555 0
# r 't/pragma/warnings.t' 3455 0
# r 't/pragma/warn/util' 3019 0
# r 't/pragma/warn/utf8' 867 0
# r 't/pragma/warn/universal' 344 0
# r 't/pragma/warn/toke' 12042 0
# r 't/pragma/warn/taint' 660 0
# r 't/pragma/warn/sv' 6954 0
# r 't/pragma/warn/run' 94 0
# r 't/pragma/warn/regexec' 3218 0
# r 't/pragma/warn/regcomp' 5001 0
# r 't/pragma/warn/pp_sys' 9855 0
# r 't/pragma/warn/pp_hot' 5736 0
# r 't/pragma/warn/pp_ctl' 3709 0
# r 't/pragma/warn/pp' 2232 0
# r 't/pragma/warn/perly' 687 0
# r 't/pragma/warn/perlio' 164 0
# r 't/pragma/warn/perl' 1524 0
# r 't/pragma/warn/op' 20525 0
# r 't/pragma/warn/mg' 826 0
# r 't/pragma/warn/malloc' 152 0
# r 't/pragma/warn/hv' 130 0
# r 't/pragma/warn/gv' 1181 0
# r 't/pragma/warn/doop' 63 0
# r 't/pragma/warn/doio' 4879 0
# r 't/pragma/warn/av' 160 0
# r 't/pragma/warn/9enabled' 19606 0
# r 't/pragma/warn/8signal' 434 0
# r 't/pragma/warn/7fatal' 5740 0
# r 't/pragma/warn/6default' 3034 0
# r 't/pragma/warn/5nolint' 2820 0
# r 't/pragma/warn/4lint' 4083 0
# r 't/pragma/warn/3both' 4069 0
# r 't/pragma/warn/2use' 6046 0
# r 't/pragma/warn/1global' 2886 0
# r 't/pragma/utf8.t' 2416 0
# r 't/pragma/subs.t' 3692 0
# r 't/pragma/sub_lval.t' 9870 0
# r 't/pragma/strict.t' 2222 0
# r 't/pragma/strict-vars' 8116 0
# r 't/pragma/strict-subs' 5886 0
# r 't/pragma/strict-refs' 5251 0
# r 't/pragma/overload.t' 24450 0
# r 't/pragma/locale/utf8' 322 0
# r 't/pragma/locale/latin1' 314 0
# r 't/pragma/locale.t' 18474 0
# r 't/pragma/diagnostics.t' 837 0
# r 't/pragma/constant.t' 7114 0
# r 't/lib/xs-typemap.t' 5641 0
# r 't/lib/trig.t' 4535 0
# r 't/lib/timelocal.t' 2028 0
# r 't/lib/tie-substrhash.t' 2326 0
# r 't/lib/tie-stdpush.t' 146 0
# r 't/lib/tie-stdhandle.t' 972 0
# r 't/lib/tie-stdarray.t' 197 0
# r 't/lib/tie-splice.t' 251 0
# r 't/lib/tie-refhash.t' 8061 0
# r 't/lib/tie-push.t' 432 0
# r 't/lib/thr5005.t' 4936 0
# r 't/lib/textwrap.t' 5166 0
# r 't/lib/texttabs.t' 1822 0
# r 't/lib/textfill.t' 2852 0
# r 't/lib/test-harness.t' 8043 0
# r 't/lib/tb-xvari.t' 2170 0
# r 't/lib/tb-xtagg.t' 3517 0
# r 't/lib/tb-xquot.t' 3020 0
# r 't/lib/tb-xmult.t' 6837 0
# r 't/lib/tb-xdeli.t' 1982 0
# r 't/lib/tb-xcode.t' 2348 0
# r 't/lib/tb-xbrak.t' 2249 0
# r 't/lib/tb-genxt.t' 2787 0
# r 't/lib/syslog.t' 2031 0
# r 't/lib/syslfs.t' 6977 0
# r 't/lib/symbol.t' 872 0
# r 't/lib/switch.t' 7128 0
# r 't/lib/st-utf8.t' 706 0
# r 't/lib/st-tieditems.t' 1274 0
# r 't/lib/st-tiedhook.t' 4921 0
# r 't/lib/st-tied.t' 3992 0
# r 't/lib/st-store.t' 2471 0
# r 't/lib/st-retrieve.t' 1861 0
# r 't/lib/st-recurse.t' 5846 0
# r 't/lib/st-overload.t' 1722 0
# r 't/lib/st-lock.t' 1286 0
# r 't/lib/st-freeze.t' 2418 0
# r 't/lib/st-forgive.t' 1810 0
# r 't/lib/st-dclone.t' 1720 0
# r 't/lib/st-canonical.t' 3732 0
# r 't/lib/st-blessed.t' 2188 0
# r 't/lib/st-06compat.t' 3630 0
# r 't/lib/soundex.t' 2446 0
# r 't/lib/socket.t' 2087 0
# r 't/lib/sigaction.t' 2892 0
# r 't/lib/selfloader.t' 3652 0
# r 't/lib/selectsaver.t' 365 0
# r 't/lib/searchdict.t' 1408 0
# r 't/lib/sdbm.t' 10659 0
# r 't/lib/safe2.t' 4105 0
# r 't/lib/safe1.t' 1825 0
# r 't/lib/posix.t' 4233 0
# r 't/lib/ph.t' 3046 0
# r 't/lib/peek.t' 5780 0
# r 't/lib/parsewords.t' 3132 0
# r 't/lib/ops.t' 543 0
# r 't/lib/open3.t' 3480 0
# r 't/lib/open2.t' 1083 0
# r 't/lib/opcode.t' 3371 0
# r 't/lib/odbm.t' 10965 0
# r 't/lib/net-hostent.t' 1922 0
# r 't/lib/ndbm.t' 10516 0
# r 't/lib/mimeqp.t' 3774 0
# r 't/lib/mimeb64u.t' 189 0
# r 't/lib/mimeb64.t' 8504 0
# r 't/lib/md5-file.t' 3383 0
# r 't/lib/md5-badf.t' 517 0
# r 't/lib/md5-align.t' 398 0
# r 't/lib/md5-aaa.t' 88305 0
# r 't/lib/lc-uk.t' 2367 0
# r 't/lib/lc-language.t' 4016 0
# r 't/lib/lc-currency.t' 3320 0
# r 't/lib/lc-country.t' 4793 0
# r 't/lib/lc-constants.t' 711 0
# r 't/lib/lc-all.t' 8296 0
# r 't/lib/ipc_sysv.t' 4827 0
# r 't/lib/io_xs.t' 630 0
# r 't/lib/io_unix.t' 1708 0
# r 't/lib/io_udp.t' 2204 0
# r 't/lib/io_tell.t' 1540 0
# r 't/lib/io_taint.t' 1057 0
# r 't/lib/io_sock.t' 7284 0
# r 't/lib/io_sel.t' 2753 0
# r 't/lib/io_scalar.t' 632 0
# r 't/lib/io_poll.t' 1297 0
# r 't/lib/io_pipe.t' 1931 0
# r 't/lib/io_multihomed.t' 2136 0
# r 't/lib/io_linenum.t' 1427 0
# r 't/lib/io_dup.t' 1130 0
# r 't/lib/io_dir.t' 1485 0
# r 't/lib/io_const.t' 641 0
# r 't/lib/hostname.t' 436 0
# r 't/lib/h2ph.t' 861 0
# r 't/lib/gol-oo.t' 853 0
# r 't/lib/gol-linkage.t' 1310 0
# r 't/lib/gol-compat.t' 710 0
# r 't/lib/gol-basic.t' 812 0
# r 't/lib/glob-taint.t' 593 0
# r 't/lib/glob-global.t' 2753 0
# r 't/lib/glob-case.t' 1441 0
# r 't/lib/glob-basic.t' 4072 0
# r 't/lib/getopt.t' 1280 0
# r 't/lib/gdbm.t' 10620 0
# r 't/lib/ftmp-tempfile.t' 3341 0
# r 't/lib/ftmp-security.t' 3618 0
# r 't/lib/ftmp-posix.t' 1549 0
# r 't/lib/ftmp-mktemp.t' 2520 0
# r 't/lib/findbin.t' 168 0
# r 't/lib/filter-util.t' 11489 0
# r 't/lib/filespec.t' 21624 0
# r 't/lib/filepath.t' 485 0
# r 't/lib/filehand.t' 1604 0
# r 't/lib/filefunc.t' 220 0
# r 't/lib/filefind.t' 6605 0
# r 't/lib/filecopy.t' 3096 0
# r 't/lib/filecache.t' 358 0
# r 't/lib/fields.t' 3984 0
# r 't/lib/fatal.t' 823 0
# r 't/lib/errno.t' 996 0
# r 't/lib/env.t' 295 0
# r 't/lib/env-array.t' 1500 0
# r 't/lib/english.t' 1457 0
# r 't/lib/encode.t' 3995 0
# r 't/lib/dumper.t' 14021 0
# r 't/lib/dumper-ovl.t' 534 0
# r 't/lib/dprof.t' 1737 0
# r 't/lib/dosglob.t' 1966 0
# r 't/lib/dirhand.t' 742 0
# r 't/lib/digest.t' 635 0
# r 't/lib/db-recno.t' 20573 0
# r 't/lib/db-hash.t' 16715 0
# r 't/lib/db-btree.t' 28480 0
# r 't/lib/cwd.t' 3496 0
# r 't/lib/complex.t' 25574 0
# r 't/lib/class-struct.t' 1007 0
# r 't/lib/class-isa.t' 1221 0
# r 't/lib/checktree.t' 254 0
# r 't/lib/charnames.t' 3013 0
# r 't/lib/cgi-request.t' 4047 0
# r 't/lib/cgi-pretty.t' 985 0
# r 't/lib/cgi-html.t' 3777 0
# r 't/lib/cgi-function.t' 4686 0
# r 't/lib/cgi-form.t' 4078 0
# r 't/lib/cgi-esc.t' 1665 0
# r 't/lib/bigintpm.t' 7371 0
# r 't/lib/bigint.t' 4394 0
# r 't/lib/bigfltpm.t' 13997 0
# r 't/lib/bigfloat.t' 8220 0
# r 't/lib/basename.t' 5024 0
# r 't/lib/b.t' 4926 0
# r 't/lib/autoloader.t' 2334 0
# r 't/lib/attrs.t' 3262 0
# r 't/lib/anydbm.t' 3718 0
# r 't/lib/ansicolor.t' 2111 0
# r 't/lib/abbrev.t' 1138 0
# r 't/camel-III/vstring.t' 970 0
# r 'plan9/perlplan9.pod' 3026 0
# r 'plan9/perlplan9.doc' 4588 0
# r 'lib/unicode/distinct.pm' 476 0
# r 'lib/unicode/In/YiSyllables.pl' 172 0
# r 'lib/unicode/In/YiRadicals.pl' 172 0
# r 'lib/unicode/In/UnifiedCanadianAboriginalSyllabics.pl' 172 0
# r 'lib/unicode/In/Tibetan.pl' 172 0
# r 'lib/unicode/In/Thai.pl' 172 0
# r 'lib/unicode/In/Thaana.pl' 172 0
# r 'lib/unicode/In/Telugu.pl' 172 0
# r 'lib/unicode/In/Tamil.pl' 172 0
# r 'lib/unicode/In/Syriac.pl' 172 0
# r 'lib/unicode/In/SuperscriptsandSubscripts.pl' 172 0
# r 'lib/unicode/In/Specials.pl' 172 0
# r 'lib/unicode/In/SpacingModifierLetters.pl' 172 0
# r 'lib/unicode/In/SmallFormVariants.pl' 172 0
# r 'lib/unicode/In/Sinhala.pl' 172 0
# r 'lib/unicode/In/Runic.pl' 172 0
# r 'lib/unicode/In/PrivateUse.pl' 172 0
# r 'lib/unicode/In/Oriya.pl' 172 0
# r 'lib/unicode/In/OpticalCharacterRecognition.pl' 172 0
# r 'lib/unicode/In/Ogham.pl' 172 0
# r 'lib/unicode/In/NumberForms.pl' 172 0
# r 'lib/unicode/In/Myanmar.pl' 172 0
# r 'lib/unicode/In/Mongolian.pl' 172 0
# r 'lib/unicode/In/MiscellaneousTechnical.pl' 172 0
# r 'lib/unicode/In/MiscellaneousSymbols.pl' 172 0
# r 'lib/unicode/In/MathematicalOperators.pl' 172 0
# r 'lib/unicode/In/Malayalam.pl' 172 0
# r 'lib/unicode/In/LowSurrogates.pl' 172 0
# r 'lib/unicode/In/LetterlikeSymbols.pl' 172 0
# r 'lib/unicode/In/LatinExtendedAdditional.pl' 172 0
# r 'lib/unicode/In/LatinExtended-B.pl' 172 0
# r 'lib/unicode/In/LatinExtended-A.pl' 172 0
# r 'lib/unicode/In/Latin-1Supplement.pl' 172 0
# r 'lib/unicode/In/Lao.pl' 172 0
# r 'lib/unicode/In/Khmer.pl' 172 0
# r 'lib/unicode/In/Katakana.pl' 172 0
# r 'lib/unicode/In/Kannada.pl' 172 0
# r 'lib/unicode/In/KangxiRadicals.pl' 172 0
# r 'lib/unicode/In/Kanbun.pl' 172 0
# r 'lib/unicode/In/IdeographicDescriptionCharacters.pl' 172 0
# r 'lib/unicode/In/IPAExtensions.pl' 172 0
# r 'lib/unicode/In/Hiragana.pl' 172 0
# r 'lib/unicode/In/HighSurrogates.pl' 172 0
# r 'lib/unicode/In/HighPrivateUseSurrogates.pl' 172 0
# r 'lib/unicode/In/Hebrew.pl' 172 0
# r 'lib/unicode/In/HangulSyllables.pl' 172 0
# r 'lib/unicode/In/HangulJamo.pl' 172 0
# r 'lib/unicode/In/HangulCompatibilityJamo.pl' 172 0
# r 'lib/unicode/In/HalfwidthandFullwidthForms.pl' 172 0
# r 'lib/unicode/In/Gurmukhi.pl' 172 0
# r 'lib/unicode/In/Gujarati.pl' 172 0
# r 'lib/unicode/In/GreekExtended.pl' 172 0
# r 'lib/unicode/In/Greek.pl' 172 0
# r 'lib/unicode/In/Georgian.pl' 172 0
# r 'lib/unicode/In/GeometricShapes.pl' 172 0
# r 'lib/unicode/In/GeneralPunctuation.pl' 172 0
# r 'lib/unicode/In/Ethiopic.pl' 172 0
# r 'lib/unicode/In/EnclosedCJKLettersandMonths.pl' 172 0
# r 'lib/unicode/In/EnclosedAlphanumerics.pl' 172 0
# r 'lib/unicode/In/Dingbats.pl' 172 0
# r 'lib/unicode/In/Devanagari.pl' 172 0
# r 'lib/unicode/In/Cyrillic.pl' 172 0
# r 'lib/unicode/In/CurrencySymbols.pl' 172 0
# r 'lib/unicode/In/ControlPictures.pl' 172 0
# r 'lib/unicode/In/CombiningMarksforSymbols.pl' 172 0
# r 'lib/unicode/In/CombiningHalfMarks.pl' 172 0
# r 'lib/unicode/In/CombiningDiacriticalMarks.pl' 172 0
# r 'lib/unicode/In/Cherokee.pl' 172 0
# r 'lib/unicode/In/CJKUnifiedIdeographsExtensionA.pl' 172 0
# r 'lib/unicode/In/CJKUnifiedIdeographs.pl' 172 0
# r 'lib/unicode/In/CJKSymbolsandPunctuation.pl' 172 0
# r 'lib/unicode/In/CJKRadicalsSupplement.pl' 172 0
# r 'lib/unicode/In/CJKCompatibilityIdeographs.pl' 172 0
# r 'lib/unicode/In/CJKCompatibilityForms.pl' 172 0
# r 'lib/unicode/In/CJKCompatibility.pl' 172 0
# r 'lib/unicode/In/BraillePatterns.pl' 172 0
# r 'lib/unicode/In/BoxDrawing.pl' 172 0
# r 'lib/unicode/In/BopomofoExtended.pl' 172 0
# r 'lib/unicode/In/Bopomofo.pl' 172 0
# r 'lib/unicode/In/BlockElements.pl' 172 0
# r 'lib/unicode/In/Bengali.pl' 172 0
# r 'lib/unicode/In/BasicLatin.pl' 172 0
# r 'lib/unicode/In/Arrows.pl' 172 0
# r 'lib/unicode/In/Armenian.pl' 172 0
# r 'lib/unicode/In/ArabicPresentationForms-B.pl' 172 0
# r 'lib/unicode/In/ArabicPresentationForms-A.pl' 172 0
# r 'lib/unicode/In/Arabic.pl' 172 0
# r 'lib/unicode/In/AlphabeticPresentationForms.pl' 172 0
# r 'lib/unicode/Block.pl' 162 0
# r 'ext/util/mkbootstrap' 95 0
# r 'ext/Thread/unsync4.t' 751 0
# r 'ext/Thread/unsync3.t' 686 0
# r 'ext/Thread/unsync2.t' 676 0
# r 'ext/Thread/unsync.t' 729 0
# r 'ext/Thread/sync2.t' 1307 0
# r 'ext/Thread/sync.t' 1012 0
# r 'ext/Thread/specific.t' 348 0
# r 'ext/Thread/queue.t' 757 0
# r 'ext/Thread/lock.t' 535 0
# r 'ext/Thread/list.t' 677 0
# r 'ext/Thread/join2.t' 246 0
# r 'ext/Thread/join.t' 268 0
# r 'ext/Thread/io.t' 672 0
# r 'ext/Thread/die2.t' 315 0
# r 'ext/Thread/die.t' 279 0
# r 'ext/Thread/create.t' 496 0
# r 'ext/SDBM_File/sdbm/dbm.h' 1667 0
# r 'ext/SDBM_File/sdbm/dbm.c' 2857 0
# r 'Todo-5.6' 7960 0
# r 'Todo' 3450 0
# p 'patchlevel.h' 3032 995033652 0100444
# p 'AUTHORS' 29555 995032573 0100444
# p 'Changes' 1593386 995032778 0100444
# p 'Configure' 371403 994983280 0100555
# c 'Cross/README' 0 994687778 0100444
# p 'INSTALL' 84947 994687778 0100444
# p 'MANIFEST' 94335 994986808 0100444
# p 'Makefile.SH' 33573 994687778 0100555
# p 'Makefile.micro' 2888 994687778 0100444
# c 'NetWare/CLIBsdio.h' 0 994687778 0100444
# c 'NetWare/CLIBstr.h' 0 994687779 0100444
# c 'NetWare/CLIBstuf.c' 0 994687779 0100444
# c 'NetWare/CLIBstuf.h' 0 994687779 0100444
# c 'NetWare/Main.c' 0 994687779 0100444
# c 'NetWare/Makefile' 0 994687779 0100444
# c 'NetWare/NWTInfo.c' 0 994687779 0100444
# c 'NetWare/NWUtil.c' 0 994687779 0100444
# c 'NetWare/Nwmain.c' 0 994687779 0100444
# c 'NetWare/Nwpipe.c' 0 994687779 0100444
# c 'NetWare/bat/BldNWExt.bat' 0 994687779 0100444
# c 'NetWare/bat/Buildtype.bat' 0 994687779 0100444
# c 'NetWare/bat/MPKBuild.bat' 0 994687779 0100444
# c 'NetWare/bat/SetNWBld.bat' 0 994687779 0100444
# c 'NetWare/bat/Setmpksdk.bat' 0 994687779 0100444
# c 'NetWare/bat/Setnlmsdk.bat' 0 994687779 0100444
# c 'NetWare/bat/Setwatcom.bat' 0 994687779 0100444
# c 'NetWare/bat/ToggleD2.bat' 0 994687780 0100444
# c 'NetWare/bat/ToggleXDC.bat' 0 994687780 0100444
# c 'NetWare/config.wc' 0 994983503 0100444
# c 'NetWare/config_H.wc' 0 994983648 0100444
# c 'NetWare/config_h.PL' 0 994687780 0100444
# c 'NetWare/config_sh.PL' 0 994687780 0100444
# c 'NetWare/deb.h' 0 994687780 0100444
# c 'NetWare/dl_netware.xs' 0 994687780 0100444
# c 'NetWare/intdef.h' 0 994687780 0100444
# c 'NetWare/interface.c' 0 994687780 0100444
# c 'NetWare/interface.h' 0 994687780 0100444
# c 'NetWare/iperlhost.h' 0 994687781 0100444
# c 'NetWare/netware.h' 0 994688383 0100444
# c 'NetWare/nw5.c' 0 994687781 0100444
# c 'NetWare/nw5iop.h' 0 994687781 0100444
# c 'NetWare/nw5sck.c' 0 994687781 0100444
# c 'NetWare/nw5sck.h' 0 994687781 0100444
# c 'NetWare/nw5thread.c' 0 994687781 0100444
# c 'NetWare/nw5thread.h' 0 994687781 0100444
# c 'NetWare/nwperlsys.c' 0 994687781 0100444
# c 'NetWare/nwperlsys.h' 0 994687781 0100444
# c 'NetWare/nwpipe.h' 0 994687781 0100444
# c 'NetWare/nwplglob.c' 0 994687781 0100444
# c 'NetWare/nwplglob.h' 0 994687781 0100444
# c 'NetWare/nwstdio.h' 0 994687781 0100444
# c 'NetWare/nwtinfo.h' 0 994687782 0100444
# c 'NetWare/nwutil.h' 0 994687782 0100444
# c 'NetWare/t/NWModify.pl' 0 994687782 0100444
# c 'NetWare/t/NWScripts.pl' 0 994687782 0100444
# c 'NetWare/t/Readme.txt' 0 994687782 0100444
# c 'NetWare/testnlm/echo/echo.c' 0 994687782 0100444
# c 'NetWare/testnlm/type/type.c' 0 994687782 0100444
# c 'NetWare/win32ish.h' 0 994687782 0100444
# p 'Policy_sh.SH' 7649 994687782 0100555
# p 'Porting/Glossary' 148091 994983538 0100444
# p 'Porting/config.sh' 19902 995033337 0100444
# p 'Porting/config_H' 103715 995033238 0100444
# p 'Porting/makerel' 4452 994687784 0100555
# p 'Porting/patching.pod' 14176 994687784 0100444
# p 'Porting/repository.pod' 12588 994984748 0100444
# c 'Porting/testall.atom' 0 994687784 0100444
# p 'README.aix' 5734 994960777 0100444
# p 'README.amiga' 6747 994687785 0100444
# p 'README.apollo' 552 994687785 0100444
# p 'README.beos' 1283 994687785 0100444
# p 'README.bs2000' 6218 994687785 0100444
# p 'README.cygwin' 20405 994687785 0100444
# c 'README.dgux' 0 994687785 0100444
# p 'README.dos' 11092 995033912 0100444
# p 'README.epoc' 6318 994687785 0100444
# p 'README.hpux' 11360 994687785 0100444
# p 'README.hurd' 1734 994687785 0100444
# p 'README.machten' 3262 994687785 0100444
# p 'README.macos' 1868 994687785 0100444
# p 'README.micro' 341 994687785 0100444
# p 'README.mint' 9218 994687785 0100444
# p 'README.mpeix' 14269 994687785 0100444
# c 'README.netware' 0 995028040 0100444
# p 'README.os2' 61959 994687786 0100444
# p 'README.os390' 15231 994687786 0100444
# p 'README.plan9' 1859 994687786 0100444
# p 'README.qnx' 807 994959377 0100444
# p 'README.solaris' 19960 994687786 0100444
# c 'README.tru64' 0 994687786 0100444
# c 'README.uts' 0 994964151 0100444
# p 'README.vmesa' 3959 994687786 0100444
# p 'README.vms' 23538 994687786 0100444
# p 'README.vos' 7236 994687786 0100444
# p 'README.win32' 29711 995033913 0100444
# p 'XSUB.h' 13777 994687786 0100444
# p 'av.c' 18157 994982159 0100444
# p 'cc_runtime.h' 1965 994687786 0100444
# p 'cflags.SH' 3180 994687787 0100555
# p 'config_h.SH' 105283 994983280 0100555
# p 'configpm' 13517 994687787 0100555
# p 'configure.com' 172850 994983373 0100444
# p 'cop.h' 16325 994687787 0100444
# p 'cv.h' 4506 994687787 0100444
# p 'cygwin/Makefile.SHs' 6728 994687787 0100444
# p 'djgpp/config.over' 1447 994687788 0100444
# p 'djgpp/configure.bat' 991 995033912 0100444
# p 'djgpp/djgpp.c' 10124 994687788 0100444
# p 'djgpp/djgppsed.sh' 2501 994687788 0100444
# p 'djgpp/fixpmain' 1025 994687788 0100444
# p 'doio.c' 53782 994687788 0100444
# p 'doop.c' 29441 994687788 0100444
# p 'dosish.h' 3626 994687788 0100444
# p 'dump.c' 37096 994946078 0100444
# p 'emacs/cperl-mode.el' 306618 994687789 0100444
# p 'emacs/e2ctags.pl' 1887 994687789 0100444
# p 'embed.h' 242533 994962879 0100644
# p 'embed.pl' 76185 994962873 0100555
# p 'embedvar.h' 74720 994962880 0100644
# p 'epoc/config.sh' 18023 994983339 0100444
# p 'epoc/epocish.h' 4383 994687790 0100444
# p 'ext/B/B.pm' 16483 994687790 0100444
# c 'ext/B/B.t' 0 994687790 0100444
# p 'ext/B/B.xs' 21244 994687790 0100444
# p 'ext/B/B/Assembler.pm' 7179 994687790 0100444
# p 'ext/B/B/C.pm' 49651 994687790 0100444
# p 'ext/B/B/Concise.pm' 25562 994687790 0100444
# p 'ext/B/B/Debug.pm' 5775 994687790 0100444
# p 'ext/B/B/Deparse.pm' 93082 994687791 0100444
# c 'ext/B/Debug.t' 0 994687791 0100444
# c 'ext/B/Deparse.t' 0 994687791 0100444
# p 'ext/B/O.pm' 2651 994687791 0100444
# c 'ext/B/Showlex.t' 0 994687791 0100444
# c 'ext/B/Stash.t' 0 994687791 0100444
# p 'ext/B/defsubs_h.PL' 1109 994687792 0100444
# p 'ext/ByteLoader/ByteLoader.xs' 3246 994687792 0100444
# p 'ext/ByteLoader/bytecode.h' 8468 994945607 0100444
# c 'ext/Cwd/Cwd.t' 0 994687792 0100444
# p 'ext/Cwd/Cwd.xs' 2941 994687792 0100444
# p 'ext/Cwd/Makefile.PL' 88 994687792 0100444
# p 'ext/DB_File/Changes' 8738 994687792 0100444
# p 'ext/DB_File/DB_File.pm' 57710 994687792 0100444
# p 'ext/DB_File/DB_File.xs' 47354 994687793 0100444
# c 'ext/DB_File/t/db-btree.t' 0 994687793 0100444
# c 'ext/DB_File/t/db-hash.t' 0 994687793 0100444
# c 'ext/DB_File/t/db-recno.t' 0 994687793 0100444
# p 'ext/DB_File/version.c' 2259 994687793 0100444
# p 'ext/Data/Dumper/Dumper.xs' 24518 994687793 0100444
# c 'ext/Data/Dumper/t/dumper.t' 0 994687794 0100444
# c 'ext/Data/Dumper/t/overload.t' 0 994687794 0100444
# p 'ext/Devel/DProf/DProf.xs' 17841 994687794 0100444
# p 'ext/Devel/Peek/Peek.pm' 14281 994687794 0100444
# c 'ext/Devel/Peek/Peek.t' 0 994687794 0100444
# p 'ext/Devel/Peek/Peek.xs' 10112 994687794 0100444
# p 'ext/Digest/MD5/MD5.xs' 16711 994687794 0100444
# p 'ext/Digest/MD5/Makefile.PL' 422 994687794 0100444
# c 'ext/Digest/MD5/t/aaa.t' 0 994687794 0100444
# c 'ext/Digest/MD5/t/align.t' 0 994687794 0100444
# c 'ext/Digest/MD5/t/badfile.t' 0 994687794 0100444
# c 'ext/Digest/MD5/t/files.t' 0 994687794 0100444
# p 'ext/DynaLoader/DynaLoader_pm.PL' 29358 994687795 0100444
# p 'ext/DynaLoader/dl_aix.xs' 17697 994687795 0100444
# p 'ext/DynaLoader/dl_dlopen.xs' 7242 994687795 0100444
# p 'ext/DynaLoader/dl_mpeix.xs' 3596 994687795 0100444
# p 'ext/DynaLoader/dlutils.c' 2880 994687795 0100444
# c 'ext/Encode.t' 0 994687795 0100444
# p 'ext/Encode/Encode.pm' 25922 994738526 0100444
# p 'ext/Encode/Encode.xs' 15116 994687796 0100444
# c 'ext/Encode/Encode/7bit-jis.enc' 0 994687796 0100444
# c 'ext/Encode/Encode/7bit-kana.enc' 0 994730449 0100444
# c 'ext/Encode/Encode/7bit-kr.enc' 0 994687796 0100444
# c 'ext/Encode/Encode/HZ.enc' 0 994730963 0100444
# p 'ext/Encode/Encode/Tcl.pm' 4235 994730450 0100444
# c 'ext/Encode/Encode/Tcl.t' 0 994730450 0100444
# p 'ext/Encode/Encode/iso2022-jp.enc' 195 994730450 0100444
# p 'ext/Encode/Encode/iso2022-kr.enc' 115 994730450 0100444
# c 'ext/Errno/Errno.t' 0 994687801 0100444
# p 'ext/Errno/Errno_pm.PL' 8745 994687801 0100444
# p 'ext/Fcntl/Fcntl.pm' 5213 994687801 0100444
# c 'ext/Fcntl/Fcntl.t' 0 994687801 0100444
# p 'ext/Fcntl/Fcntl.xs' 13913 994687801 0100444
# p 'ext/Fcntl/Makefile.PL' 213 994687801 0100444
# c 'ext/Fcntl/syslfs.t' 0 994687801 0100444
# p 'ext/File/Glob/Glob.pm' 12825 994687802 0100444
# p 'ext/File/Glob/Glob.xs' 3398 994687802 0100444
# p 'ext/File/Glob/Makefile.PL' 568 994687802 0100444
# p 'ext/File/Glob/bsd_glob.c' 23243 994687802 0100444
# p 'ext/File/Glob/bsd_glob.h' 3654 994687802 0100444
# c 'ext/File/Glob/t/basic.t' 0 994731561 0100444
# c 'ext/File/Glob/t/case.t' 0 994687802 0100444
# c 'ext/File/Glob/t/global.t' 0 994687802 0100444
# c 'ext/File/Glob/t/taint.t' 0 994687802 0100444
# p 'ext/Filter/Util/Call/Call.xs' 5343 994687802 0100444
# c 'ext/Filter/t/call.t' 0 994687802 0100444
# p 'ext/GDBM_File/GDBM_File.pm' 1930 994687802 0100444
# p 'ext/GDBM_File/GDBM_File.xs' 7063 994687802 0100444
# p 'ext/GDBM_File/Makefile.PL' 269 994687802 0100444
# c 'ext/GDBM_File/gdbm.t' 0 994687802 0100444
# c 'ext/I18N/Langinfo/Langinfo.pm' 0 994687802 0100444
# c 'ext/I18N/Langinfo/Langinfo.t' 0 994982299 0100444
# c 'ext/I18N/Langinfo/Langinfo.xs' 0 994687803 0100444
# c 'ext/I18N/Langinfo/Makefile.PL' 0 994687803 0100444
# p 'ext/IO/IO.xs' 9868 994687803 0100444
# p 'ext/IO/lib/IO/Dir.pm' 5005 994687803 0100444
# p 'ext/IO/lib/IO/Handle.pm' 15635 994687803 0100444
# p 'ext/IO/lib/IO/Seekable.pm' 2914 994687803 0100444
# p 'ext/IO/lib/IO/Select.pm' 8022 994687803 0100444
# p 'ext/IO/lib/IO/Socket.pm' 11407 994687803 0100444
# p 'ext/IO/lib/IO/Socket/INET.pm' 10548 994687803 0100444
# p 'ext/IO/lib/IO/Socket/UNIX.pm' 3097 994687804 0100444
# c 'ext/IO/lib/IO/t/io_const.t' 0 994687804 0100444
# c 'ext/IO/lib/IO/t/io_dir.t' 0 994687804 0100444
# c 'ext/IO/lib/IO/t/io_dup.t' 0 994687804 0100444
# c 'ext/IO/lib/IO/t/io_linenum.t' 0 994687804 0100444
# c 'ext/IO/lib/IO/t/io_multihomed.t' 0 994687804 0100444
# c 'ext/IO/lib/IO/t/io_pipe.t' 0 994687804 0100444
# c 'ext/IO/lib/IO/t/io_poll.t' 0 994687804 0100444
# c 'ext/IO/lib/IO/t/io_sel.t' 0 994687804 0100444
# c 'ext/IO/lib/IO/t/io_sock.t' 0 994687804 0100444
# c 'ext/IO/lib/IO/t/io_taint.t' 0 994687804 0100444
# c 'ext/IO/lib/IO/t/io_tell.t' 0 994687804 0100444
# c 'ext/IO/lib/IO/t/io_udp.t' 0 994687804 0100444
# c 'ext/IO/lib/IO/t/io_unix.t' 0 994959489 0100444
# c 'ext/IO/lib/IO/t/io_xs.t' 0 994687804 0100444
# p 'ext/IPC/SysV/Msg.pm' 3919 994687807 0100444
# p 'ext/IPC/SysV/Semaphore.pm' 5782 994687807 0100444
# p 'ext/IPC/SysV/SysV.pm' 2177 994687807 0100444
# p 'ext/IPC/SysV/SysV.xs' 10283 994687807 0100444
# c 'ext/IPC/SysV/ipcsysv.t' 0 994687807 0100444
# p 'ext/IPC/SysV/t/msg.t' 934 994687808 0100444
# p 'ext/IPC/SysV/t/sem.t' 905 994687808 0100444
# c 'ext/List/Util/ChangeLog' 0 994687808 0100444
# c 'ext/List/Util/Makefile.PL' 0 994687808 0100444
# c 'ext/List/Util/README' 0 994687808 0100444
# c 'ext/List/Util/Util.xs' 0 994687808 0100444
# c 'ext/List/Util/lib/List/Util.pm' 0 994687808 0100444
# c 'ext/List/Util/lib/Scalar/Util.pm' 0 994687808 0100444
# c 'ext/List/Util/t/blessed.t' 0 994687808 0100444
# c 'ext/List/Util/t/dualvar.t' 0 994687808 0100444
# c 'ext/List/Util/t/first.t' 0 994687808 0100444
# c 'ext/List/Util/t/max.t' 0 994687808 0100444
# c 'ext/List/Util/t/maxstr.t' 0 994687808 0100444
# c 'ext/List/Util/t/min.t' 0 994687808 0100444
# c 'ext/List/Util/t/minstr.t' 0 994687808 0100444
# c 'ext/List/Util/t/readonly.t' 0 994687808 0100444
# c 'ext/List/Util/t/reduce.t' 0 994687808 0100444
# c 'ext/List/Util/t/reftype.t' 0 994687808 0100444
# c 'ext/List/Util/t/sum.t' 0 994687808 0100444
# c 'ext/List/Util/t/tainted.t' 0 994687808 0100444
# c 'ext/List/Util/t/weak.t' 0 994687808 0100444
# p 'ext/MIME/Base64/Base64.xs' 5538 994687808 0100444
# p 'ext/MIME/Base64/Makefile.PL' 186 994687808 0100444
# p 'ext/MIME/Base64/QuotedPrint.pm' 3494 994687809 0100444
# c 'ext/MIME/Base64/t/base64.t' 0 994687809 0100444
# c 'ext/MIME/Base64/t/qp.t' 0 994687809 0100444
# c 'ext/MIME/Base64/t/unicode.t' 0 994687809 0100444
# p 'ext/NDBM_File/NDBM_File.xs' 3704 994687809 0100444
# c 'ext/NDBM_File/hints/linux.pl' 0 994687809 0100444
# c 'ext/NDBM_File/ndbm.t' 0 994687809 0100444
# p 'ext/ODBM_File/ODBM_File.xs' 4860 994687809 0100444
# c 'ext/ODBM_File/odbm.t' 0 994687810 0100444
# p 'ext/Opcode/Opcode.pm' 15200 994687810 0100444
# c 'ext/Opcode/Opcode.t' 0 994687810 0100444
# p 'ext/Opcode/Safe.pm' 16710 994687810 0100444
# c 'ext/Opcode/ops.t' 0 994687810 0100444
# p 'ext/POSIX/Makefile.PL' 321 994687810 0100444
# p 'ext/POSIX/POSIX.pm' 18449 994687810 0100444
# p 'ext/POSIX/POSIX.pod' 50402 994687810 0100444
# c 'ext/POSIX/POSIX.t' 0 994861105 0100444
# p 'ext/POSIX/POSIX.xs' 81727 994687810 0100444
# c 'ext/POSIX/hints/uts.pl' 0 994687811 0100444
# c 'ext/POSIX/sigaction.t' 0 994687811 0100444
# c 'ext/PerlIO/PerlIO.t' 0 994687811 0100444
# p 'ext/PerlIO/Scalar/Makefile.PL' 102 994687811 0100444
# p 'ext/PerlIO/Scalar/Scalar.pm' 522 994687811 0100444
# p 'ext/PerlIO/Scalar/Scalar.xs' 4085 994687811 0100444
# p 'ext/PerlIO/Via/Makefile.PL' 96 994687811 0100444
# p 'ext/PerlIO/Via/Via.pm' 2640 994687811 0100444
# p 'ext/PerlIO/Via/Via.xs' 10560 994687811 0100444
# c 'ext/PerlIO/t/encoding.t' 0 995028528 0100444
# c 'ext/PerlIO/t/scalar.t' 0 994687811 0100444
# c 'ext/SDBM_File/sdbm.t' 0 994687812 0100444
# c 'ext/Safe/safe1.t' 0 994687812 0100444
# c 'ext/Safe/safe2.t' 0 994687813 0100444
# p 'ext/Socket/Makefile.PL' 295 994687813 0100444
# p 'ext/Socket/Socket.pm' 8531 994687813 0100444
# c 'ext/Socket/Socket.t' 0 994687813 0100444
# p 'ext/Socket/Socket.xs' 20802 994687813 0100444
# p 'ext/Storable/ChangeLog' 16946 994687813 0100444
# p 'ext/Storable/Storable.pm' 25311 994687813 0100444
# p 'ext/Storable/Storable.xs' 126846 994687813 0100444
# c 'ext/Storable/t/blessed.t' 0 994687813 0100444
# c 'ext/Storable/t/canonical.t' 0 994687813 0100444
# c 'ext/Storable/t/compat06.t' 0 994687813 0100444
# c 'ext/Storable/t/dclone.t' 0 994687813 0100444
# c 'ext/Storable/t/forgive.t' 0 994687813 0100444
# c 'ext/Storable/t/freeze.t' 0 994687813 0100444
# c 'ext/Storable/t/lock.t' 0 994687813 0100444
# c 'ext/Storable/t/overload.t' 0 994687813 0100444
# c 'ext/Storable/t/recurse.t' 0 994687813 0100444
# c 'ext/Storable/t/retrieve.t' 0 994687813 0100444
# c 'ext/Storable/t/store.t' 0 994687813 0100444
# c 'ext/Storable/t/tied.t' 0 994687813 0100444
# c 'ext/Storable/t/tied_hook.t' 0 994687813 0100444
# c 'ext/Storable/t/tied_items.t' 0 994687814 0100444
# c 'ext/Storable/t/utf8.t' 0 994687814 0100444
# c 'ext/Sys/Hostname/Hostname.t' 0 994687814 0100444
# p 'ext/Sys/Hostname/Hostname.xs' 1463 994687814 0100444
# p 'ext/Sys/Syslog/Makefile.PL' 208 994687814 0100444
# p 'ext/Sys/Syslog/Syslog.pm' 8472 994687814 0100444
# p 'ext/Sys/Syslog/Syslog.xs' 10388 994687814 0100444
# c 'ext/Sys/Syslog/syslog.t' 0 994687814 0100444
# p 'ext/Thread/Thread.pm' 7594 994687814 0100444
# p 'ext/Thread/Thread.xs' 16624 994687814 0100444
# c 'ext/Thread/create.tx' 0 994687815 0100444
# c 'ext/Thread/die.tx' 0 994687815 0100444
# c 'ext/Thread/die2.tx' 0 994687815 0100444
# c 'ext/Thread/io.tx' 0 994687815 0100444
# c 'ext/Thread/join.tx' 0 994687815 0100444
# c 'ext/Thread/join2.tx' 0 994687815 0100444
# c 'ext/Thread/list.tx' 0 994687815 0100444
# c 'ext/Thread/lock.tx' 0 994687815 0100444
# c 'ext/Thread/queue.tx' 0 994687815 0100444
# c 'ext/Thread/specific.tx' 0 994687815 0100444
# c 'ext/Thread/sync.tx' 0 994687815 0100444
# c 'ext/Thread/sync2.tx' 0 994687815 0100444
# c 'ext/Thread/thr5005.t' 0 994687815 0100444
# p 'ext/Thread/typemap' 596 994687815 0100444
# c 'ext/Thread/unsync.tx' 0 994687815 0100444
# c 'ext/Thread/unsync2.tx' 0 994687815 0100444
# c 'ext/Thread/unsync3.tx' 0 994687816 0100444
# c 'ext/Thread/unsync4.tx' 0 994687816 0100444
# c 'ext/Time/HiRes/Changes' 0 994687816 0100444
# c 'ext/Time/HiRes/HiRes.pm' 0 994687816 0100444
# c 'ext/Time/HiRes/HiRes.t' 0 994687816 0100444
# c 'ext/Time/HiRes/HiRes.xs' 0 994687816 0100444
# c 'ext/Time/HiRes/Makefile.PL' 0 994687816 0100444
# c 'ext/Time/HiRes/hints/dynixptx.pl' 0 994815274 0100444
# c 'ext/Time/HiRes/hints/sco.pl' 0 994687816 0100444
# c 'ext/Time/Piece/Makefile.PL' 0 994687816 0100444
# c 'ext/Time/Piece/Piece.pm' 0 994687816 0100444
# c 'ext/Time/Piece/Piece.t' 0 994687816 0100444
# c 'ext/Time/Piece/Piece.xs' 0 994687816 0100444
# c 'ext/Time/Piece/README' 0 994687816 0100444
# c 'ext/Time/Piece/Seconds.pm' 0 994687816 0100444
# p 'ext/XS/Typemap/Makefile.PL' 454 994687816 0100444
# p 'ext/XS/Typemap/Typemap.pm' 2044 994687817 0100444
# c 'ext/XS/Typemap/Typemap.t' 0 994687817 0100444
# p 'ext/XS/Typemap/Typemap.xs' 14842 994687817 0100444
# p 'ext/XS/Typemap/typemap' 516 994687817 0100444
# c 'ext/attrs.t' 0 994687817 0100444
# p 'ext/attrs/attrs.pm' 1434 994687817 0100444
# p 'ext/attrs/attrs.xs' 1379 994687817 0100444
# p 'ext/re/Makefile.PL' 1313 994687817 0100444
# p 'ext/re/re.pm' 3802 994687817 0100444
# p 'ext/re/re.xs' 1384 994687817 0100444
# p 'ext/util/make_ext' 4005 994687817 0100444
# p 'global.sym' 9323 994962878 0100644
# p 'globals.c' 1826 994687818 0100444
# p 'gv.c' 44032 994687818 0100444
# p 'gv.h' 5303 994687818 0100444
# p 'handy.h' 21820 994687819 0100444
# p 'hints/aix.sh' 13858 994963780 0100444
# c 'hints/atheos.sh' 0 994687819 0100444
# p 'hints/darwin.sh' 1278 994687819 0100444
# p 'hints/dec_osf.sh' 11976 994687819 0100444
# p 'hints/dgux.sh' 5390 994687819 0100444
# p 'hints/dos_djgpp.sh' 1355 994687819 0100444
# p 'hints/dynixptx.sh' 2133 994815274 0100444
# p 'hints/freebsd.sh' 6320 994687820 0100444
# p 'hints/hpux.sh' 14456 994687820 0100444
# p 'hints/linux.sh' 9855 994687820 0100444
# p 'hints/mpeix.sh' 4205 994687821 0100444
# p 'hints/next_3.sh' 4950 994687821 0100444
# p 'hints/os2.sh' 9788 994687821 0100444
# p 'hints/os390.sh' 5917 994687821 0100444
# p 'hints/posix-bc.sh' 2323 994687821 0100444
# p 'hints/qnx.sh' 6557 994959393 0100444
# p 'hints/rhapsody.sh' 1228 994687821 0100444
# p 'hints/sco.sh' 8348 994687821 0100444
# p 'hints/svr5.sh' 7553 994687822 0100444
# p 'hints/unicos.sh' 964 994687822 0100444
# p 'hints/uts.sh' 538 994909006 0100444
# p 'hints/vmesa.sh' 7402 994687822 0100444
# p 'hv.c' 39603 994998810 0100444
# p 'hv.h' 7243 994687822 0100444
# p 'installman' 8662 994687822 0100555
# p 'installperl' 21735 994687822 0100555
# p 'intrpvar.h' 17044 995030454 0100444
# p 'iperlsys.h' 46663 994687822 0100444
# p 'jpl/JNI/JNI.pm' 8728 994687823 0100444
# p 'jpl/JNI/JNI.xs' 66009 994687823 0100444
# p 'jpl/JNI/Makefile.PL' 8452 994687823 0100444
# p 'keywords.h' 5925 994687824 0100644
# p 'keywords.pl' 2237 994687824 0100555
# c 'lib/AnyDBM_File.t' 0 994687824 0100444
# c 'lib/Attribute/Handlers.pm' 0 994687824 0100444
# c 'lib/Attribute/Handlers/Changes' 0 994687824 0100444
# c 'lib/Attribute/Handlers/README' 0 994687825 0100444
# c 'lib/Attribute/Handlers/demo/Demo.pm' 0 994687825 0100444
# c 'lib/Attribute/Handlers/demo/Descriptions.pm' 0 994687825 0100444
# c 'lib/Attribute/Handlers/demo/MyClass.pm' 0 994687825 0100444
# c 'lib/Attribute/Handlers/demo/demo.pl' 0 994687825 0100444
# c 'lib/Attribute/Handlers/demo/demo2.pl' 0 994687825 0100444
# c 'lib/Attribute/Handlers/demo/demo3.pl' 0 994687825 0100444
# c 'lib/Attribute/Handlers/demo/demo4.pl' 0 994687825 0100444
# c 'lib/Attribute/Handlers/demo/demo_call.pl' 0 994687825 0100444
# c 'lib/Attribute/Handlers/demo/demo_chain.pl' 0 994687825 0100444
# c 'lib/Attribute/Handlers/demo/demo_cycle.pl' 0 994687825 0100444
# c 'lib/Attribute/Handlers/demo/demo_hashdir.pl' 0 994687825 0100444
# c 'lib/Attribute/Handlers/demo/demo_phases.pl' 0 994687825 0100444
# c 'lib/Attribute/Handlers/demo/demo_range.pl' 0 994687825 0100444
# c 'lib/Attribute/Handlers/demo/demo_rawdata.pl' 0 994687825 0100444
# c 'lib/Attribute/Handlers/test.pl' 0 994687825 0100444
# p 'lib/AutoLoader.pm' 10672 994687825 0100444
# c 'lib/AutoLoader.t' 0 994687825 0100444
# p 'lib/AutoSplit.pm' 15212 994687825 0100444
# p 'lib/Benchmark.pm' 22257 994687825 0100444
# c 'lib/Benchmark.t' 0 994687825 0100444
# p 'lib/CGI/Pretty.pm' 6692 994687826 0100444
# c 'lib/CGI/t/form.t' 0 994687827 0100444
# c 'lib/CGI/t/function.t' 0 994687827 0100444
# c 'lib/CGI/t/html.t' 0 994687827 0100444
# c 'lib/CGI/t/pretty.t' 0 994687827 0100444
# c 'lib/CGI/t/request.t' 0 994687827 0100444
# c 'lib/CGI/t/util.t' 0 994687827 0100444
# p 'lib/CPAN.pm' 217862 994687827 0100444
# p 'lib/CPAN/Nox.pm' 792 994687827 0100444
# c 'lib/CPAN/t/loadme.t' 0 994687828 0100444
# c 'lib/CPAN/t/vcmp.t' 0 994687828 0100444
# p 'lib/Carp.pm' 4214 994687828 0100444
# c 'lib/Carp.t' 0 994687828 0100444
# p 'lib/Carp/Heavy.pm' 5772 994687828 0100444
# c 'lib/Class/ISA/test.pl' 0 994687828 0100444
# p 'lib/Class/Struct.pm' 18673 994687828 0100444
# c 'lib/Class/Struct.t' 0 994687828 0100444
# p 'lib/Cwd.pm' 10982 994687828 0100444
# p 'lib/Devel/SelfStubber.pm' 4519 994687828 0100444
# c 'lib/Devel/SelfStubber.t' 0 994687828 0100444
# c 'lib/Digest.t' 0 994687828 0100444
# p 'lib/DirHandle.pm' 1377 994687828 0100444
# c 'lib/DirHandle.t' 0 994687828 0100444
# c 'lib/English.t' 0 994687828 0100444
# c 'lib/Env/array.t' 0 994687829 0100444
# c 'lib/Env/env.t' 0 994687829 0100444
# p 'lib/Exporter.pm' 10002 994687829 0100444
# c 'lib/Exporter.t' 0 994687829 0100444
# p 'lib/Exporter/Heavy.pm' 6035 994687829 0100444
# c 'lib/ExtUtils.t' 0 994815958 0100444
# p 'lib/ExtUtils/Command.pm' 3537 994687829 0100444
# c 'lib/ExtUtils/Constant.pm' 0 994815198 0100444
# p 'lib/ExtUtils/Embed.pm' 12573 994687829 0100444
# p 'lib/ExtUtils/Install.pm' 13348 994687829 0100444
# p 'lib/ExtUtils/Installed.pm' 7127 994687829 0100444
# p 'lib/ExtUtils/Liblist.pm' 27209 994687829 0100444
# c 'lib/ExtUtils/MM_NW5.pm' 0 994687829 0100444
# p 'lib/ExtUtils/MM_Unix.pm' 109868 994687829 0100444
# p 'lib/ExtUtils/MM_VMS.pm' 71987 994731653 0100444
# p 'lib/ExtUtils/MM_Win32.pm' 26079 994687829 0100444
# p 'lib/ExtUtils/MakeMaker.pm' 64290 994687830 0100444
# p 'lib/ExtUtils/Manifest.pm' 13116 994687830 0100444
# p 'lib/ExtUtils/Mksymlists.pm' 10408 994687830 0100444
# p 'lib/ExtUtils/Packlist.pm' 6888 994687831 0100444
# p 'lib/ExtUtils/typemap' 6756 994687833 0100444
# p 'lib/ExtUtils/xsubpp' 46808 994687833 0100444
# c 'lib/Fatal.t' 0 994687834 0100444
# p 'lib/File/Basename.pm' 9144 994687834 0100444
# c 'lib/File/Basename.t' 0 994687834 0100444
# c 'lib/File/CheckTree.t' 0 994687834 0100444
# p 'lib/File/Compare.pm' 4342 994687834 0100444
# c 'lib/File/Compare.t' 0 994687834 0100444
# p 'lib/File/Copy.pm' 11695 994982388 0100444
# c 'lib/File/Copy.t' 0 994982597 0100444
# c 'lib/File/DosGlob.t' 0 994687834 0100444
# p 'lib/File/Find.pm' 21060 994687834 0100444
# c 'lib/File/Find/find.t' 0 994687834 0100444
# c 'lib/File/Find/taint.t' 0 994687834 0100444
# c 'lib/File/Path.t' 0 994687834 0100444
# c 'lib/File/Spec.t' 0 994687834 0100444
# c 'lib/File/Spec/Functions.t' 0 994687834 0100444
# p 'lib/File/Spec/Unix.pm' 10945 994687834 0100444
# p 'lib/File/Spec/VMS.pm' 13402 994687834 0100444
# c 'lib/File/Temp/t/mktemp.t' 0 994687835 0100444
# c 'lib/File/Temp/t/posix.t' 0 994687835 0100444
# c 'lib/File/Temp/t/security.t' 0 994687835 0100444
# c 'lib/File/Temp/t/tempfile.t' 0 994687835 0100444
# c 'lib/File/stat.t' 0 994687835 0100444
# c 'lib/FileCache.t' 0 994687835 0100444
# p 'lib/FileHandle.pm' 6774 994687835 0100444
# c 'lib/FileHandle.t' 0 994687835 0100444
# p 'lib/Filter/Simple.pm' 6110 994687835 0100444
# c 'lib/Filter/Simple/test.pl' 0 994687835 0100444
# p 'lib/FindBin.pm' 4333 994687835 0100444
# c 'lib/FindBin.t' 0 994687835 0100444
# c 'lib/Getopt/Long/t/basic.t' 0 994687835 0100444
# c 'lib/Getopt/Long/t/compat.t' 0 994687835 0100444
# c 'lib/Getopt/Long/t/linkage.t' 0 994687835 0100444
# c 'lib/Getopt/Long/t/oo.t' 0 994687835 0100444
# c 'lib/Getopt/Std.t' 0 994687835 0100444
# c 'lib/I18N/Collate.t' 0 994687835 0100444
# c 'lib/I18N/LangTags.pm' 0 994687836 0100444
# c 'lib/I18N/LangTags/ChangeLog' 0 994687836 0100444
# c 'lib/I18N/LangTags/List.pm' 0 994687836 0100444
# c 'lib/I18N/LangTags/README' 0 994687836 0100444
# c 'lib/I18N/LangTags/test.pl' 0 994687836 0100444
# c 'lib/IPC/Open2.t' 0 994687836 0100444
# p 'lib/IPC/Open3.pm' 10279 994687836 0100444
# c 'lib/IPC/Open3.t' 0 994687836 0100444
# c 'lib/IPC/SysV.t' 0 994687836 0100444
# c 'lib/Locale/Codes/t/all.t' 0 994687836 0100444
# c 'lib/Locale/Codes/t/constants.t' 0 994687836 0100444
# c 'lib/Locale/Codes/t/country.t' 0 994687836 0100444
# c 'lib/Locale/Codes/t/currency.t' 0 994687836 0100444
# c 'lib/Locale/Codes/t/languages.t' 0 994687836 0100444
# c 'lib/Locale/Codes/t/uk.t' 0 994687836 0100444
# c 'lib/Locale/Maketext.pm' 0 994687836 0100444
# c 'lib/Locale/Maketext.pod' 0 994687836 0100444
# c 'lib/Locale/Maketext/ChangeLog' 0 994687836 0100444
# c 'lib/Locale/Maketext/README' 0 994687836 0100444
# c 'lib/Locale/Maketext/TPJ13.pod' 0 994687836 0100444
# c 'lib/Locale/Maketext/test.pl' 0 994687837 0100444
# p 'lib/Math/BigFloat.pm' 11133 994776605 0100444
# p 'lib/Math/BigInt.pm' 13978 994776656 0100444
# c 'lib/Math/BigInt/Calc.pm' 0 994776605 0100444
# c 'lib/Math/BigInt/t/bigfltpm.t' 0 994732107 0100444
# c 'lib/Math/BigInt/t/bigintc.t' 0 994732118 0100444
# c 'lib/Math/BigInt/t/bigintpm.t' 0 994776605 0100444
# c 'lib/Math/BigInt/t/mbimbf.t' 0 994732136 0100444
# p 'lib/Math/Complex.pm' 42926 994687837 0100444
# c 'lib/Math/Complex.t' 0 994687837 0100444
# p 'lib/Math/Trig.pm' 14267 994687837 0100444
# c 'lib/Math/Trig.t' 0 994687837 0100444
# c 'lib/Memoize.pm' 0 994687837 0100444
# c 'lib/Memoize/AnyDBM_File.pm' 0 994687837 0100444
# c 'lib/Memoize/Expire.pm' 0 994687837 0100444
# c 'lib/Memoize/ExpireFile.pm' 0 994687837 0100444
# c 'lib/Memoize/ExpireTest.pm' 0 994687837 0100444
# c 'lib/Memoize/NDBM_File.pm' 0 994687837 0100444
# c 'lib/Memoize/README' 0 994687837 0100444
# c 'lib/Memoize/SDBM_File.pm' 0 994687837 0100444
# c 'lib/Memoize/Saves.pm' 0 994687837 0100444
# c 'lib/Memoize/Storable.pm' 0 994687837 0100444
# c 'lib/Memoize/TODO' 0 994687837 0100444
# c 'lib/Memoize/t/array.t' 0 994687837 0100444
# c 'lib/Memoize/t/array_confusion.t' 0 994687838 0100444
# c 'lib/Memoize/t/correctness.t' 0 994687838 0100444
# c 'lib/Memoize/t/errors.t' 0 994687838 0100444
# c 'lib/Memoize/t/expire.t' 0 994687838 0100444
# c 'lib/Memoize/t/expire_file.t' 0 994687838 0100444
# c 'lib/Memoize/t/expire_module_n.t' 0 994687838 0100444
# c 'lib/Memoize/t/expire_module_t.t' 0 994687838 0100444
# c 'lib/Memoize/t/flush.t' 0 994687838 0100444
# c 'lib/Memoize/t/normalize.t' 0 994687838 0100444
# c 'lib/Memoize/t/prototype.t' 0 994687838 0100444
# c 'lib/Memoize/t/speed.t' 0 994687838 0100444
# c 'lib/Memoize/t/tie.t' 0 994687838 0100444
# c 'lib/Memoize/t/tie_gdbm.t' 0 994687838 0100444
# c 'lib/Memoize/t/tie_ndbm.t' 0 994687838 0100444
# c 'lib/Memoize/t/tie_sdbm.t' 0 994687838 0100444
# c 'lib/Memoize/t/tie_storable.t' 0 994687838 0100444
# c 'lib/Memoize/t/tiefeatures.t' 0 994687838 0100444
# c 'lib/Memoize/t/unmemoize.t' 0 994687838 0100444
# c 'lib/NEXT.pm' 0 994687838 0100444
# c 'lib/NEXT/test.pl' 0 994687838 0100444
# c 'lib/Net/ChangeLog.libnet' 0 994687838 0100444
# c 'lib/Net/Cmd.pm' 0 994687838 0100444
# c 'lib/Net/Config.eg' 0 994687838 0100444
# c 'lib/Net/Config.pm' 0 994687838 0100444
# c 'lib/Net/Domain.pm' 0 994687838 0100444
# c 'lib/Net/FTP.pm' 0 994687838 0100444
# c 'lib/Net/FTP/A.pm' 0 994687838 0100444
# c 'lib/Net/FTP/E.pm' 0 994687838 0100444
# c 'lib/Net/FTP/I.pm' 0 994687838 0100444
# c 'lib/Net/FTP/L.pm' 0 994687838 0100444
# c 'lib/Net/FTP/dataconn.pm' 0 994687839 0100444
# c 'lib/Net/Hostname.eg' 0 994687839 0100444
# c 'lib/Net/NNTP.pm' 0 994687839 0100444
# c 'lib/Net/Netrc.pm' 0 994687839 0100444
# c 'lib/Net/POP3.pm' 0 994687839 0100444
# p 'lib/Net/Ping.pm' 24150 994687839 0100444
# c 'lib/Net/README.config' 0 994687839 0100444
# c 'lib/Net/README.libnet' 0 994687839 0100444
# c 'lib/Net/SMTP.pm' 0 994687839 0100444
# c 'lib/Net/Time.pm' 0 994687839 0100444
# c 'lib/Net/demos/ftp' 0 994687839 0100444
# c 'lib/Net/demos/inetd' 0 994687839 0100444
# c 'lib/Net/demos/nntp' 0 994687839 0100444
# c 'lib/Net/demos/nntp.mirror' 0 994687839 0100444
# c 'lib/Net/demos/pop3' 0 994687839 0100444
# c 'lib/Net/demos/smtp.self' 0 994687839 0100444
# c 'lib/Net/demos/snpp' 0 994687839 0100444
# c 'lib/Net/demos/time' 0 994687839 0100444
# c 'lib/Net/hostent.t' 0 994687839 0100444
# c 'lib/Net/libnet.ppd' 0 994687839 0100444
# c 'lib/Net/libnetFAQ.pod' 0 994687839 0100444
# c 'lib/Net/netent.t' 0 994687840 0100444
# c 'lib/Net/protoent.t' 0 994687840 0100444
# c 'lib/Net/servent.t' 0 994687840 0100444
# c 'lib/Net/t/ftp.t' 0 994687840 0100444
# c 'lib/Net/t/hostname.t' 0 994687841 0100444
# c 'lib/Net/t/nntp.t' 0 994687841 0100444
# c 'lib/Net/t/require.t' 0 994687841 0100444
# c 'lib/Net/t/smtp.t' 0 994687841 0100444
# p 'lib/PerlIO.pm' 3600 994688742 0100444
# p 'lib/Pod/Html.pm' 57823 994687841 0100444
# p 'lib/Pod/Man.pm' 49827 994774574 0100444
# p 'lib/Pod/Text.pm' 29227 994774579 0100444
# p 'lib/Pod/Text/Color.pm' 3625 994774593 0100444
# p 'lib/Pod/Text/Overstrike.pm' 4769 994774593 0100444
# p 'lib/Pod/Text/Termcap.pm' 4198 994774595 0100444
# c 'lib/Search/Dict.t' 0 994687842 0100444
# c 'lib/SelectSaver.t' 0 994687842 0100444
# p 'lib/SelfLoader.pm' 12135 994687842 0100444
# c 'lib/SelfLoader.t' 0 994687842 0100444
# p 'lib/Shell.pm' 4043 994687842 0100444
# p 'lib/Switch.pm' 24268 994687842 0100444
# c 'lib/Switch/test.pl' 0 994687842 0100444
# p 'lib/Symbol.pm' 3876 994687842 0100444
# c 'lib/Symbol.t' 0 994687842 0100444
# p 'lib/Term/ANSIColor.pm' 13487 994774243 0100444
# c 'lib/Term/ANSIColor/ChangeLog' 0 994774223 0100444
# c 'lib/Term/ANSIColor/README' 0 994774223 0100444
# c 'lib/Term/ANSIColor/test.pl' 0 994774253 0100444
# p 'lib/Term/Cap.pm' 11770 994687842 0100444
# p 'lib/Test.pm' 7862 994687843 0100444
# p 'lib/Test/Harness.pm' 25228 994687843 0100444
# c 'lib/Test/Harness.t' 0 994687843 0100444
# c 'lib/Test/More.pm' 0 994687843 0100444
# c 'lib/Test/More/Changes' 0 994687843 0100444
# c 'lib/Test/More/t/More.t' 0 994687843 0100444
# c 'lib/Test/More/t/fail-like.t' 0 994687843 0100444
# c 'lib/Test/More/t/fail.t' 0 994687843 0100444
# c 'lib/Test/More/t/plan_is_noplan.t' 0 994687843 0100444
# c 'lib/Test/More/t/skipall.t' 0 994687843 0100444
# c 'lib/Test/Simple.pm' 0 994687843 0100444
# c 'lib/Test/Simple/Changes' 0 994687843 0100444
# c 'lib/Test/Simple/t/exit.t' 0 994687843 0100444
# c 'lib/Test/Simple/t/extra.t' 0 994687843 0100444
# c 'lib/Test/Simple/t/fail.t' 0 994687843 0100444
# c 'lib/Test/Simple/t/missing.t' 0 994687843 0100444
# c 'lib/Test/Simple/t/no_plan.t' 0 994687843 0100444
# c 'lib/Test/Simple/t/plan_is_noplan.t' 0 994687843 0100444
# c 'lib/Test/Simple/t/simple.t' 0 994687843 0100444
# c 'lib/Test/t/fail.t' 0 994687843 0100444
# c 'lib/Test/t/mix.t' 0 994687843 0100444
# c 'lib/Test/t/onfail.t' 0 994687843 0100444
# c 'lib/Test/t/qr.t' 0 994687843 0100444
# c 'lib/Test/t/skip.t' 0 994687844 0100444
# c 'lib/Test/t/success.t' 0 994687844 0100444
# c 'lib/Test/t/todo.t' 0 994687844 0100444
# c 'lib/Text/Abbrev.t' 0 994687844 0100444
# p 'lib/Text/Balanced.pm' 24719 994687844 0100444
# c 'lib/Text/Balanced/t/genxt.t' 0 994687844 0100444
# c 'lib/Text/Balanced/t/xbrak.t' 0 994687844 0100444
# c 'lib/Text/Balanced/t/xcode.t' 0 994687844 0100444
# c 'lib/Text/Balanced/t/xdeli.t' 0 994687844 0100444
# c 'lib/Text/Balanced/t/xmult.t' 0 994687844 0100444
# c 'lib/Text/Balanced/t/xquot.t' 0 994687844 0100444
# c 'lib/Text/Balanced/t/xtagg.t' 0 994687844 0100444
# c 'lib/Text/Balanced/t/xvari.t' 0 994687844 0100444
# p 'lib/Text/ParseWords.pm' 6544 994687844 0100444
# c 'lib/Text/ParseWords.t' 0 994687844 0100444
# p 'lib/Text/Soundex.pm' 4247 994687844 0100444
# c 'lib/Text/Soundex.t' 0 994687845 0100444
# c 'lib/Text/TabsWrap/t/fill.t' 0 994687845 0100444
# c 'lib/Text/TabsWrap/t/tabs.t' 0 994687845 0100444
# c 'lib/Text/TabsWrap/t/wrap.t' 0 994687845 0100444
# p 'lib/Tie/Array.pm' 7433 994947092 0100444
# c 'lib/Tie/Array/push.t' 0 994687845 0100444
# c 'lib/Tie/Array/splice.t' 0 994687845 0100444
# c 'lib/Tie/Array/std.t' 0 994687845 0100444
# c 'lib/Tie/Array/stdpush.t' 0 994687845 0100444
# c 'lib/Tie/Handle/stdhandle.t' 0 994687845 0100444
# p 'lib/Tie/Hash.pm' 4046 994687845 0100444
# c 'lib/Tie/RefHash.t' 0 994687845 0100444
# c 'lib/Tie/SubstrHash.t' 0 994687845 0100444
# p 'lib/Time/Local.pm' 7964 994687846 0100444
# c 'lib/Time/Local.t' 0 994687846 0100444
# c 'lib/Time/gmtime.t' 0 994687846 0100444
# c 'lib/Time/localtime.t' 0 994687846 0100444
# c 'lib/UnicodeCD.pm' 0 994951357 0100444
# c 'lib/UnicodeCD.t' 0 994951346 0100444
# c 'lib/User/grent.t' 0 994687846 0100444
# c 'lib/User/pwent.t' 0 994687847 0100444
# p 'lib/attributes.pm' 12075 994687847 0100444
# p 'lib/autouse.pm' 4019 994687847 0100444
# c 'lib/autouse.t' 0 994687847 0100444
# p 'lib/base.pm' 2381 994687847 0100444
# c 'lib/bigfloat.t' 0 994687847 0100444
# c 'lib/bigint.t' 0 994687847 0100444
# c 'lib/charnames.t' 0 994687848 0100444
# p 'lib/constant.pm' 10667 994687848 0100444
# c 'lib/constant.t' 0 994687848 0100444
# p 'lib/diagnostics.pm' 14438 994687848 0100444
# c 'lib/diagnostics.t' 0 994687848 0100444
# p 'lib/dumpvar.pl' 11982 994687848 0100444
# p 'lib/fields.pm' 7980 994687848 0100444
# c 'lib/fields.t' 0 994687848 0100444
# c 'lib/h2ph.t' 0 994687849 0100444
# c 'lib/h2xs.t' 0 994687849 0100444
# p 'lib/locale.pm' 822 994687849 0100444
# c 'lib/locale.t' 0 994687849 0100444
# p 'lib/open.pm' 3878 994961341 0100444
# c 'lib/overload.t' 0 994687849 0100444
# p 'lib/perl5db.pl' 85208 994687849 0100444
# c 'lib/ph.t' 0 994687849 0100444
# p 'lib/strict.pm' 2624 994687850 0100444
# c 'lib/strict.t' 0 994687850 0100444
# c 'lib/subs.t' 0 994687850 0100444
# c 'lib/unicode/Blocks.pl' 0 994687850 0100444
# c 'lib/unicode/In.pl' 0 994687851 0100444
# c 'lib/unicode/In/0.pl' 0 994687851 0100444
# c 'lib/unicode/In/1.pl' 0 994687851 0100444
# c 'lib/unicode/In/10.pl' 0 994687851 0100444
# c 'lib/unicode/In/100.pl' 0 994687851 0100444
# c 'lib/unicode/In/101.pl' 0 994687851 0100444
# c 'lib/unicode/In/102.pl' 0 994687851 0100444
# c 'lib/unicode/In/103.pl' 0 994687851 0100444
# c 'lib/unicode/In/104.pl' 0 994687851 0100444
# c 'lib/unicode/In/105.pl' 0 994687851 0100444
# c 'lib/unicode/In/106.pl' 0 994687851 0100444
# c 'lib/unicode/In/107.pl' 0 994687851 0100444
# c 'lib/unicode/In/108.pl' 0 994687851 0100444
# c 'lib/unicode/In/109.pl' 0 994687851 0100444
# c 'lib/unicode/In/11.pl' 0 994687851 0100444
# c 'lib/unicode/In/110.pl' 0 994687851 0100444
# c 'lib/unicode/In/111.pl' 0 994687851 0100444
# c 'lib/unicode/In/112.pl' 0 994687851 0100444
# c 'lib/unicode/In/113.pl' 0 994687851 0100444
# c 'lib/unicode/In/114.pl' 0 994687852 0100444
# c 'lib/unicode/In/115.pl' 0 994687852 0100444
# c 'lib/unicode/In/116.pl' 0 994687852 0100444
# c 'lib/unicode/In/117.pl' 0 994687852 0100444
# c 'lib/unicode/In/118.pl' 0 994687852 0100444
# c 'lib/unicode/In/119.pl' 0 994687852 0100444
# c 'lib/unicode/In/12.pl' 0 994687852 0100444
# c 'lib/unicode/In/120.pl' 0 994687852 0100444
# c 'lib/unicode/In/121.pl' 0 994687852 0100444
# c 'lib/unicode/In/122.pl' 0 994687852 0100444
# c 'lib/unicode/In/123.pl' 0 994687852 0100444
# c 'lib/unicode/In/124.pl' 0 994687852 0100444
# c 'lib/unicode/In/125.pl' 0 994687852 0100444
# c 'lib/unicode/In/126.pl' 0 994687852 0100444
# c 'lib/unicode/In/127.pl' 0 994687852 0100444
# c 'lib/unicode/In/128.pl' 0 994687852 0100444
# c 'lib/unicode/In/129.pl' 0 994687852 0100444
# c 'lib/unicode/In/13.pl' 0 994687852 0100444
# c 'lib/unicode/In/130.pl' 0 994687852 0100444
# c 'lib/unicode/In/131.pl' 0 994687852 0100444
# c 'lib/unicode/In/132.pl' 0 994687852 0100444
# c 'lib/unicode/In/133.pl' 0 994687852 0100444
# c 'lib/unicode/In/134.pl' 0 994687852 0100444
# c 'lib/unicode/In/135.pl' 0 994687852 0100444
# c 'lib/unicode/In/14.pl' 0 994687852 0100444
# c 'lib/unicode/In/15.pl' 0 994687852 0100444
# c 'lib/unicode/In/16.pl' 0 994687852 0100444
# c 'lib/unicode/In/17.pl' 0 994687852 0100444
# c 'lib/unicode/In/18.pl' 0 994687853 0100444
# c 'lib/unicode/In/19.pl' 0 994687853 0100444
# c 'lib/unicode/In/2.pl' 0 994687853 0100444
# c 'lib/unicode/In/20.pl' 0 994687853 0100444
# c 'lib/unicode/In/21.pl' 0 994687853 0100444
# c 'lib/unicode/In/22.pl' 0 994687853 0100444
# c 'lib/unicode/In/23.pl' 0 994687853 0100444
# c 'lib/unicode/In/24.pl' 0 994687853 0100444
# c 'lib/unicode/In/25.pl' 0 994687853 0100444
# c 'lib/unicode/In/26.pl' 0 994687853 0100444
# c 'lib/unicode/In/27.pl' 0 994687853 0100444
# c 'lib/unicode/In/28.pl' 0 994687853 0100444
# c 'lib/unicode/In/29.pl' 0 994687853 0100444
# c 'lib/unicode/In/3.pl' 0 994687853 0100444
# c 'lib/unicode/In/30.pl' 0 994687853 0100444
# c 'lib/unicode/In/31.pl' 0 994687853 0100444
# c 'lib/unicode/In/32.pl' 0 994687853 0100444
# c 'lib/unicode/In/33.pl' 0 994687853 0100444
# c 'lib/unicode/In/34.pl' 0 994687853 0100444
# c 'lib/unicode/In/35.pl' 0 994687853 0100444
# c 'lib/unicode/In/36.pl' 0 994687853 0100444
# c 'lib/unicode/In/37.pl' 0 994687853 0100444
# c 'lib/unicode/In/38.pl' 0 994687853 0100444
# c 'lib/unicode/In/39.pl' 0 994687853 0100444
# c 'lib/unicode/In/4.pl' 0 994687853 0100444
# c 'lib/unicode/In/40.pl' 0 994687853 0100444
# c 'lib/unicode/In/41.pl' 0 994687853 0100444
# c 'lib/unicode/In/42.pl' 0 994687853 0100444
# c 'lib/unicode/In/43.pl' 0 994687853 0100444
# c 'lib/unicode/In/44.pl' 0 994687853 0100444
# c 'lib/unicode/In/45.pl' 0 994687853 0100444
# c 'lib/unicode/In/46.pl' 0 994687854 0100444
# c 'lib/unicode/In/47.pl' 0 994687854 0100444
# c 'lib/unicode/In/48.pl' 0 994687854 0100444
# c 'lib/unicode/In/49.pl' 0 994687854 0100444
# c 'lib/unicode/In/5.pl' 0 994687854 0100444
# c 'lib/unicode/In/50.pl' 0 994687854 0100444
# c 'lib/unicode/In/51.pl' 0 994687854 0100444
# c 'lib/unicode/In/52.pl' 0 994687854 0100444
# c 'lib/unicode/In/53.pl' 0 994687854 0100444
# c 'lib/unicode/In/54.pl' 0 994687854 0100444
# c 'lib/unicode/In/55.pl' 0 994687854 0100444
# c 'lib/unicode/In/56.pl' 0 994687854 0100444
# c 'lib/unicode/In/57.pl' 0 994687854 0100444
# c 'lib/unicode/In/58.pl' 0 994687854 0100444
# c 'lib/unicode/In/59.pl' 0 994687854 0100444
# c 'lib/unicode/In/6.pl' 0 994687854 0100444
# c 'lib/unicode/In/60.pl' 0 994687854 0100444
# c 'lib/unicode/In/61.pl' 0 994687854 0100444
# c 'lib/unicode/In/62.pl' 0 994687854 0100444
# c 'lib/unicode/In/63.pl' 0 994687854 0100444
# c 'lib/unicode/In/64.pl' 0 994687854 0100444
# c 'lib/unicode/In/65.pl' 0 994687854 0100444
# c 'lib/unicode/In/66.pl' 0 994687854 0100444
# c 'lib/unicode/In/67.pl' 0 994687854 0100444
# c 'lib/unicode/In/68.pl' 0 994687854 0100444
# c 'lib/unicode/In/69.pl' 0 994687854 0100444
# c 'lib/unicode/In/7.pl' 0 994687854 0100444
# c 'lib/unicode/In/70.pl' 0 994687854 0100444
# c 'lib/unicode/In/71.pl' 0 994687854 0100444
# c 'lib/unicode/In/72.pl' 0 994687854 0100444
# c 'lib/unicode/In/73.pl' 0 994687855 0100444
# c 'lib/unicode/In/74.pl' 0 994687855 0100444
# c 'lib/unicode/In/75.pl' 0 994687855 0100444
# c 'lib/unicode/In/76.pl' 0 994687855 0100444
# c 'lib/unicode/In/77.pl' 0 994687855 0100444
# c 'lib/unicode/In/78.pl' 0 994687855 0100444
# c 'lib/unicode/In/79.pl' 0 994687855 0100444
# c 'lib/unicode/In/8.pl' 0 994687855 0100444
# c 'lib/unicode/In/80.pl' 0 994687855 0100444
# c 'lib/unicode/In/81.pl' 0 994687855 0100444
# c 'lib/unicode/In/82.pl' 0 994687855 0100444
# c 'lib/unicode/In/83.pl' 0 994687855 0100444
# c 'lib/unicode/In/84.pl' 0 994687855 0100444
# c 'lib/unicode/In/85.pl' 0 994687855 0100444
# c 'lib/unicode/In/86.pl' 0 994687855 0100444
# c 'lib/unicode/In/87.pl' 0 994687855 0100444
# c 'lib/unicode/In/88.pl' 0 994687855 0100444
# c 'lib/unicode/In/89.pl' 0 994687855 0100444
# c 'lib/unicode/In/9.pl' 0 994687855 0100444
# c 'lib/unicode/In/90.pl' 0 994687855 0100444
# c 'lib/unicode/In/91.pl' 0 994687855 0100444
# c 'lib/unicode/In/92.pl' 0 994687855 0100444
# c 'lib/unicode/In/93.pl' 0 994687855 0100444
# c 'lib/unicode/In/94.pl' 0 994687855 0100444
# c 'lib/unicode/In/95.pl' 0 994687855 0100444
# c 'lib/unicode/In/96.pl' 0 994687855 0100444
# c 'lib/unicode/In/97.pl' 0 994687855 0100444
# c 'lib/unicode/In/98.pl' 0 994687855 0100444
# c 'lib/unicode/In/99.pl' 0 994687855 0100444
# c 'lib/unicode/Scripts.pl' 0 994687862 0100444
# p 'lib/unicode/mktables.PL' 13425 994687864 0100444
# p 'lib/utf8.pm' 3072 994687864 0100444
# c 'lib/utf8.t' 0 994687864 0100444
# p 'lib/utf8_heavy.pl' 5483 994687864 0100444
# p 'lib/vars.pm' 2770 994687865 0100444
# c 'lib/vars.t' 0 994687865 0100444
# p 'lib/warnings.pm' 14347 994915396 0100644
# c 'lib/warnings.t' 0 994687865 0100444
# c 'locale.c' 0 994687865 0100444
# p 'makeaperl.SH' 3906 994687865 0100555
# p 'makedef.pl' 21355 995030745 0100444
# p 'makedepend.SH' 6816 994687865 0100555
# p 'makedir.SH' 1188 994687865 0100555
# p 'malloc.c' 63050 994687865 0100444
# p 'mg.c' 50594 994687865 0100444
# p 'miniperlmain.c' 1606 994901616 0100444
# p 'mpeix/mpeixish.h' 4217 994687866 0100444
# p 'mpeix/relink' 528 994687866 0100444
# p 'myconfig.SH' 2536 995003499 0100555
# c 'numeric.c' 0 994687866 0100444
# p 'objXSUB.h' 74681 994962880 0100644
# p 'op.c' 173485 994958005 0100444
# p 'op.h' 14009 994958065 0100444
# p 'opcode.h' 46070 994911403 0100644
# p 'opcode.pl' 22238 994910480 0100555
# p 'os2/Changes' 14851 994687867 0100444
# p 'os2/Makefile.SHs' 8909 994687867 0100444
# p 'os2/OS2/PrfDB/PrfDB.xs' 2995 994687867 0100444
# p 'os2/OS2/Process/Process.pm' 6491 994687867 0100444
# p 'os2/OS2/Process/Process.xs' 7807 994687867 0100444
# p 'os2/OS2/REXX/DLL/DLL.pm' 3286 994687868 0100444
# p 'os2/OS2/REXX/REXX.xs' 10357 994687868 0100444
# p 'os2/diff.configure' 690 994687868 0100444
# p 'os2/dl_os2.c' 1934 994687868 0100444
# p 'os2/dlfcn.h' 125 994687868 0100444
# p 'os2/os2.c' 57673 994687868 0100444
# c 'os2/os2_base.t' 0 994687868 0100444
# p 'os2/os2ish.h' 16764 994687868 0100444
# p 'perl.c' 99840 994917520 0100444
# p 'perl.h' 97474 994998529 0100444
# p 'perlapi.c' 82056 994962881 0100644
# p 'perlapi.h' 32380 994962880 0100644
# p 'perlio.c' 76198 994986790 0100444
# p 'perlio.h' 8978 994687869 0100444
# p 'perliol.h' 5904 994687869 0100444
# p 'perlsdio.h' 4266 994687869 0100444
# p 'perlsfio.h' 2455 994687869 0100444
# p 'perly.c' 101708 994687869 0100444
# p 'perly.fixer' 7186 994687869 0100555
# p 'perly.y' 17484 994687869 0100444
# p 'perly_c.diff' 4929 994687869 0100444
# c 'perlyline.pl' 0 994687869 0100444
# p 'plan9/mkfile' 4530 994687870 0100444
# p 'pod/Makefile.SH' 4170 994687870 0100444
# p 'pod/buildtoc.PL' 9587 994964700 0100444
# p 'pod/checkpods.PL' 2908 994687870 0100444
# p 'pod/perl.pod' 12353 994964631 0100444
# p 'pod/perl5005delta.pod' 34268 994687870 0100444
# p 'pod/perl570delta.pod' 21639 994687870 0100444
# p 'pod/perl571delta.pod' 30194 994687870 0100444
# c 'pod/perl572delta.pod' 0 994982243 0100444
# p 'pod/perlapi.pod' 77713 994962885 0100644
# p 'pod/perlbook.pod' 618 994687871 0100444
# p 'pod/perldata.pod' 33959 994687871 0100444
# p 'pod/perldebguts.pod' 33597 994687871 0100444
# p 'pod/perldebtut.pod' 21091 994687871 0100444
# p 'pod/perldebug.pod' 31973 994687871 0100444
# p 'pod/perldiag.pod' 141003 994915391 0100444
# p 'pod/perlebcdic.pod' 54119 994687871 0100444
# p 'pod/perlfaq.pod' 24051 994687872 0100444
# p 'pod/perlfaq1.pod' 16454 994687872 0100444
# p 'pod/perlfaq2.pod' 21645 994687872 0100444
# p 'pod/perlfaq3.pod' 31321 994687872 0100444
# p 'pod/perlfaq4.pod' 61479 994986427 0100444
# p 'pod/perlfaq5.pod' 42761 994687872 0100444
# p 'pod/perlfaq6.pod' 25065 994687872 0100444
# p 'pod/perlfaq7.pod' 33595 994687872 0100444
# p 'pod/perlfaq8.pod' 38268 994687872 0100444
# p 'pod/perlfilter.pod' 20581 994687872 0100444
# p 'pod/perlfunc.pod' 232179 994814965 0100444
# p 'pod/perlguts.pod' 89582 994815127 0100444
# p 'pod/perlhack.pod' 70167 994687873 0100444
# p 'pod/perlhist.pod' 23402 995033455 0100444
# p 'pod/perlintern.pod' 3222 994962885 0100644
# p 'pod/perllexwarn.pod' 14019 994915390 0100444
# p 'pod/perllocale.pod' 39540 994687874 0100444
# p 'pod/perlmod.pod' 18300 994687874 0100444
# p 'pod/perlmodlib.PL' 33469 994687874 0100444
# p 'pod/perlmodlib.pod' 43767 994999011 0100444
# p 'pod/perlnewmod.pod' 11296 994687874 0100444
# p 'pod/perlobj.pod' 20223 994687874 0100444
# p 'pod/perlop.pod' 74336 994687874 0100444
# p 'pod/perlport.pod' 70167 994815485 0100444
# p 'pod/perlre.pod' 49389 994687874 0100444
# p 'pod/perlref.pod' 26920 994687875 0100444
# p 'pod/perlretut.pod' 99886 994687875 0100444
# p 'pod/perlsec.pod' 16999 994687875 0100444
# p 'pod/perlsub.pod' 47103 994687875 0100444
# p 'pod/perlsyn.pod' 22486 994687875 0100444
# p 'pod/perltie.pod' 33227 994687875 0100444
# p 'pod/perltoc.pod' 232417 994999002 0100444
# p 'pod/perltodo.pod' 24097 994687876 0100444
# p 'pod/perlunicode.pod' 10613 994687876 0100444
# p 'pod/perlutil.pod' 6141 994687876 0100444
# p 'pod/perlvar.pod' 41979 994687876 0100444
# p 'pod/perlxs.pod' 63359 994687876 0100444
# p 'pod/perlxstut.pod' 46829 994687876 0100444
# p 'pod/pod2man.PL' 18798 994774617 0100444
# p 'pod/pod2text.PL' 8071 994774618 0100444
# p 'pp.c' 127049 994687877 0100444
# p 'pp.h' 12758 994687877 0100444
# p 'pp.sym' 5921 994911403 0100644
# p 'pp_ctl.c' 104364 994815022 0100444
# p 'pp_hot.c' 72532 994687877 0100444
# c 'pp_pack.c' 0 994687877 0100444
# p 'pp_proto.h' 10565 994911403 0100644
# p 'pp_sys.c' 117991 994901795 0100444
# p 'proto.h' 65462 994962878 0100644
# p 'regcomp.c' 129639 994963538 0100444
# p 'regcomp.h' 11504 994963538 0100444
# p 'regexec.c' 107348 994944911 0100444
# p 'regexp.h' 3810 994687880 0100444
# p 'run.c' 3004 994687880 0100444
# p 'scope.c' 24948 994687881 0100444
# p 'sv.c' 225634 994999145 0100444
# p 'sv.h' 36306 994687881 0100444
# p 't/TEST' 5648 994687881 0100555
# p 't/TestInit.pm' 478 994687881 0100444
# p 't/base/lex.t' 5351 994687881 0100555
# p 't/base/term.t' 1136 994687881 0100555
# p 't/cmd/for.t' 1080 994687881 0100555
# p 't/comp/cpp.t' 413 994687882 0100555
# p 't/comp/multiline.t' 930 994687882 0100555
# p 't/comp/proto.t' 10727 994687882 0100555
# p 't/comp/script.t' 589 994687882 0100555
# p 't/harness' 1807 994687882 0100444
# p 't/io/argv.t' 2878 994687882 0100555
# p 't/io/dup.t' 698 994687882 0100555
# c 't/io/fflush.t' 0 994687882 0100555
# p 't/io/fs.t' 7128 994687882 0100555
# p 't/io/inplace.t' 861 994687882 0100555
# p 't/io/iprefix.t' 832 994687882 0100555
# p 't/io/tell.t' 2394 994687882 0100555
# p 't/io/utf8.t' 3902 994687882 0100555
# p 't/lib/1_compile.t' 2061 994998960 0100555
# c 't/lib/MyFilter.pm' 0 994687882 0100444
# c 't/lib/Test/More/Catch.pm' 0 994687883 0100444
# c 't/lib/Test/Simple/Catch.pm' 0 994687883 0100444
# c 't/lib/Test/Simple/sample_tests/death.plx' 0 994687883 0100444
# c 't/lib/Test/Simple/sample_tests/death_in_eval.plx' 0 994687883 0100444
# c 't/lib/Test/Simple/sample_tests/extras.plx' 0 994687883 0100444
# c 't/lib/Test/Simple/sample_tests/five_fail.plx' 0 994687883 0100444
# c 't/lib/Test/Simple/sample_tests/last_minute_death.plx' 0 994687883 0100444
# c 't/lib/Test/Simple/sample_tests/one_fail.plx' 0 994687883 0100444
# c 't/lib/Test/Simple/sample_tests/require.plx' 0 994687883 0100444
# c 't/lib/Test/Simple/sample_tests/success.plx' 0 994687883 0100444
# c 't/lib/Test/Simple/sample_tests/too_few.plx' 0 994687883 0100444
# c 't/lib/Test/Simple/sample_tests/two_fail.plx' 0 994687883 0100444
# p 't/lib/h2ph.h' 2462 994687883 0100444
# p 't/lib/h2ph.pht' 2835 994687883 0100444
# c 't/lib/locale/latin1' 0 994687883 0100444
# c 't/lib/locale/utf8' 0 994687883 0100444
# c 't/lib/strict/refs' 0 994687884 0100444
# c 't/lib/strict/subs' 0 994687884 0100444
# c 't/lib/strict/vars' 0 994687884 0100444
# c 't/lib/warnings/1global' 0 994687884 0100444
# c 't/lib/warnings/2use' 0 994687884 0100444
# c 't/lib/warnings/3both' 0 994687884 0100444
# c 't/lib/warnings/4lint' 0 994687884 0100444
# c 't/lib/warnings/5nolint' 0 994687884 0100444
# c 't/lib/warnings/6default' 0 994687884 0100444
# c 't/lib/warnings/7fatal' 0 994687884 0100444
# c 't/lib/warnings/8signal' 0 994687884 0100444
# c 't/lib/warnings/9enabled' 0 994687884 0100444
# c 't/lib/warnings/av' 0 994687884 0100444
# c 't/lib/warnings/doio' 0 994901795 0100444
# c 't/lib/warnings/doop' 0 994687885 0100444
# c 't/lib/warnings/gv' 0 994687885 0100444
# c 't/lib/warnings/hv' 0 994687885 0100444
# c 't/lib/warnings/malloc' 0 994687885 0100444
# c 't/lib/warnings/mg' 0 994687885 0100444
# c 't/lib/warnings/op' 0 994910480 0100444
# c 't/lib/warnings/perl' 0 994687885 0100444
# c 't/lib/warnings/perlio' 0 994687885 0100444
# c 't/lib/warnings/perly' 0 994687885 0100444
# c 't/lib/warnings/pp' 0 994687885 0100444
# c 't/lib/warnings/pp_ctl' 0 994687885 0100444
# c 't/lib/warnings/pp_hot' 0 994687885 0100444
# c 't/lib/warnings/pp_pack' 0 994687885 0100444
# c 't/lib/warnings/pp_sys' 0 994687885 0100444
# c 't/lib/warnings/regcomp' 0 994687885 0100444
# c 't/lib/warnings/regexec' 0 994687885 0100444
# c 't/lib/warnings/run' 0 994687885 0100444
# c 't/lib/warnings/sv' 0 994687885 0100444
# c 't/lib/warnings/taint' 0 994687885 0100444
# c 't/lib/warnings/toke' 0 994915390 0100444
# c 't/lib/warnings/universal' 0 994687885 0100444
# c 't/lib/warnings/utf8' 0 994687885 0100444
# c 't/lib/warnings/util' 0 994946078 0100444
# p 't/op/anonsub.t' 1821 994687885 0100555
# p 't/op/append.t' 1808 994687885 0100555
# p 't/op/avhv.t' 3910 994687886 0100555
# p 't/op/chop.t' 2667 994687886 0100555
# p 't/op/closure.t' 12636 994687886 0100555
# p 't/op/cmp.t' 4949 994687886 0100555
# p 't/op/defins.t' 2405 994687886 0100555
# p 't/op/die_exit.t' 1265 994687886 0100555
# p 't/op/eval.t' 4694 994687886 0100555
# p 't/op/exec.t' 1257 994687886 0100555
# p 't/op/fork.t' 7582 994687886 0100555
# p 't/op/glob.t' 889 994687886 0100555
# c 't/op/gmagic.t' 0 994687887 0100555
# p 't/op/goto.t' 3152 994687887 0100555
# p 't/op/grent.t' 3772 994687887 0100555
# p 't/op/groups.t' 3755 994687887 0100555
# p 't/op/lex_assign.t' 7140 994687887 0100555
# p 't/op/lfs.t' 6750 994687887 0100555
# p 't/op/loopctl.t' 13867 994687887 0100555
# p 't/op/magic.t' 5609 994687887 0100555
# p 't/op/method.t' 5186 994687887 0100555
# p 't/op/misc.t' 13178 994687887 0100555
# p 't/op/mkdir.t' 770 994687887 0100555
# p 't/op/my_stash.t' 449 994687887 0100555
# p 't/op/numconvert.t' 6451 994687887 0100555
# c 't/op/override.t' 0 994687887 0100555
# p 't/op/pack.t' 12842 994687888 0100555
# p 't/op/pat.t' 35412 994687888 0100555
# p 't/op/pos.t' 449 994687888 0100555
# p 't/op/pwent.t' 4032 994687888 0100555
# p 't/op/rand.t' 11368 994687888 0100555
# p 't/op/re_tests' 23338 994687888 0100444
# p 't/op/regexp.t' 3553 994687888 0100555
# p 't/op/regexp_noamp.t' 172 994687888 0100555
# p 't/op/regmesg.t' 5278 994687888 0100555
# p 't/op/runlevel.t' 5827 994687888 0100555
# p 't/op/splice.t' 878 994947669 0100555
# p 't/op/split.t' 7215 994687888 0100555
# p 't/op/sprintf.t' 12617 994687888 0100555
# p 't/op/stat.t' 8819 994687889 0100555
# p 't/op/study.t' 1933 994687889 0100555
# c 't/op/sub_lval.t' 0 994687889 0100555
# p 't/op/subst.t' 9569 994687889 0100555
# p 't/op/sysio.t' 4978 994687889 0100555
# p 't/op/taint.t' 19323 994687889 0100555
# p 't/op/tie.t' 3809 994687889 0100555
# p 't/op/tr.t' 10081 994687889 0100555
# p 't/op/universal.t' 2536 994687889 0100555
# p 't/op/ver.t' 4672 994687889 0100555
# p 't/op/write.t' 4351 994687889 0100555
# p 't/pod/find.t' 2403 994687889 0100555
# c 't/pod/plainer.t' 0 994687890 0100555
# p 't/pod/special_seqs.xr' 1082 994827280 0100444
# p 't/pod/testp2pt.pl' 5747 994687891 0100444
# c 't/run/exit.t' 0 994687891 0100555
# p 't/run/runenv.t' 4230 994687891 0100555
# p 'taint.c' 2737 994687891 0100444
# p 'thrdvar.h' 9637 994687891 0100444
# p 'thread.h' 11471 994984302 0100444
# p 'toke.c' 194758 994915388 0100444
# p 'uconfig.h' 103282 994983319 0100444
# p 'uconfig.sh' 10694 994983311 0100444
# p 'universal.c' 8819 994687891 0100444
# p 'unixish.h' 4383 994687891 0100444
# p 'utf8.c' 33970 994687891 0100444
# p 'utf8.h' 5991 994687892 0100444
# p 'utfebcdic.h' 18862 994687892 0100444
# p 'util.c' 95074 994946389 0100444
# p 'util.h' 1127 994687892 0100444
# c 'utils.lst' 0 994687892 0100444
# p 'utils/Makefile' 1678 994687892 0100444
# p 'utils/dprofpp.PL' 22201 994687892 0100444
# p 'utils/h2ph.PL' 20812 994687892 0100444
# p 'utils/h2xs.PL' 48550 994687892 0100444
# c 'utils/libnetcfg.PL' 0 995033398 0100444
# p 'utils/perlbug.PL' 37686 994687892 0100444
# p 'utils/perlcc.PL' 18175 994687892 0100444
# p 'utils/pl2pm.PL' 5435 994687892 0100444
# c 'uts/sprintf_wrap.c' 0 994908983 0100444
# c 'uts/strtol_wrap.c' 0 994687892 0100444
# p 'vms/descrip_mms.template' 66622 994687892 0100444
# p 'vms/ext/Stdio/Stdio.xs' 12949 994687893 0100444
# p 'vms/ext/filespec.t' 5424 994687893 0100555
# p 'vms/gen_shrfls.pl' 13155 994687893 0100444
# p 'vms/perlvms.pod' 38036 994687893 0100444
# p 'vms/perly_c.vms' 101813 994687893 0100644
# p 'vms/test.com' 6758 994687894 0100444
# p 'vms/vms.c' 218036 994687894 0100444
# p 'vms/vmsish.h' 28222 994687894 0100444
# p 'vos/Changes' 2923 994687894 0100444
# c 'vos/Makefile' 0 994687894 0100444
# p 'vos/build.cm' 8163 994687894 0100444
# p 'vos/compile_perl.cm' 1465 994687894 0100444
# p 'vos/config.alpha.def' 10558 994983422 0100444
# p 'vos/config.alpha.h' 103150 994983436 0100444
# p 'vos/config.ga.def' 10656 994983432 0100444
# p 'vos/config.ga.h' 103191 994983437 0100444
# p 'vos/configure_perl.cm' 812 994687894 0100444
# p 'vos/perl.bind' 549 994687894 0100444
# p 'warnings.h' 3524 994915396 0100644
# p 'warnings.pl' 14140 994915387 0100444
# p 'win32/FindExt.pm' 1027 994687895 0100444
# p 'win32/Makefile' 34648 995033913 0100644
# p 'win32/buildext.pl' 1021 994687895 0100444
# p 'win32/config.bc' 16457 994983470 0100444
# p 'win32/config.gc' 16442 994983480 0100444
# p 'win32/config.vc' 16459 994983484 0100444
# p 'win32/config_H.bc' 103303 995033238 0100644
# p 'win32/config_H.gc' 103300 995033238 0100644
# p 'win32/config_H.vc' 103309 995033238 0100644
# p 'win32/config_sh.PL' 2255 994687895 0100444
# p 'win32/distclean.bat' 514 995028941 0100444
# p 'win32/makefile.mk' 36680 995033913 0100644
# c 'win32/mdelete.bat' 0 994687896 0100444
# p 'win32/perllib.c' 9542 994687896 0100444
# p 'win32/win32.c' 99011 994957439 0100444
# p 'win32/win32.h' 15321 994687896 0100444
# c 'win32/win32io.c' 0 994687896 0100444
# p 'win32/win32thread.h' 6522 994687897 0100444
# p 'writemain.SH' 2831 994687897 0100555
# p 'x2p/Makefile.SH' 4139 994687897 0100555
# p 'x2p/a2p.c' 132919 994687898 0100444
# p 'x2p/a2p.h' 9574 994687898 0100444
# p 'x2p/a2py.c' 25810 994687898 0100444
# p 'x2p/cflags.SH' 2301 994687898 0100555
# p 'x2p/find2perl.PL' 24116 994687898 0100444
# p 'x2p/hash.c' 4748 994687898 0100444
# p 'x2p/s2p.PL' 52253 994687898 0100444
# p 'x2p/str.c' 10017 994687898 0100444
# p 'x2p/walk.c' 48919 994687899 0100444
# p 'xsutils.c' 6398 994687899 0100444
# R 't/pragma/warn'
# R 't/pragma/locale'
# R 't/pragma'
# R 't/camel-III'
# C 'Cross' 0 995033755 040755
# C 'NetWare' 0 995033849 040755
# C 'NetWare/bat' 0 995033847 040755
# C 'NetWare/t' 0 995033849 040755
# C 'NetWare/testnlm' 0 995033849 040755
# C 'NetWare/testnlm/echo' 0 995033849 040755
# C 'NetWare/testnlm/type' 0 995033849 040755
# C 'ext/DB_File/t' 0 995033760 040755
# C 'ext/Data/Dumper/t' 0 995033759 040755
# C 'ext/Digest/MD5/t' 0 995033761 040755
# C 'ext/File/Glob/t' 0 995033772 040755
# C 'ext/Filter/t' 0 995033772 040755
# C 'ext/I18N' 0 995033773 040755
# C 'ext/I18N/Langinfo' 0 995033773 040755
# C 'ext/IO/lib/IO/t' 0 995033774 040755
# C 'ext/List' 0 995033775 040755
# C 'ext/List/Util' 0 995033776 040755
# C 'ext/List/Util/lib' 0 995033775 040755
# C 'ext/List/Util/lib/List' 0 995033775 040755
# C 'ext/List/Util/lib/Scalar' 0 995033775 040755
# C 'ext/List/Util/t' 0 995033776 040755
# C 'ext/MIME/Base64/t' 0 995033776 040755
# C 'ext/PerlIO/t' 0 995033778 040755
# C 'ext/Safe' 0 995033779 040755
# C 'ext/Storable/t' 0 995033782 040755
# C 'ext/Time' 0 995033784 040755
# C 'ext/Time/HiRes' 0 995033784 040755
# C 'ext/Time/HiRes/hints' 0 995033784 040755
# C 'ext/Time/Piece' 0 995033784 040755
# C 'lib/Attribute' 0 995033796 040755
# C 'lib/Attribute/Handlers' 0 995033797 040755
# C 'lib/Attribute/Handlers/demo' 0 995033797 040755
# C 'lib/CGI/t' 0 995033799 040755
# C 'lib/CPAN/t' 0 995033800 040755
# C 'lib/Class/ISA' 0 995033800 040755
# C 'lib/Env' 0 995033801 040755
# C 'lib/File/Find' 0 995033804 040755
# C 'lib/File/Temp' 0 995033805 040755
# C 'lib/File/Temp/t' 0 995033805 040755
# C 'lib/Filter/Simple' 0 995033809 040755
# C 'lib/Getopt/Long' 0 995033809 040755
# C 'lib/Getopt/Long/t' 0 995033809 040755
# C 'lib/I18N/LangTags' 0 995033810 040755
# C 'lib/Locale/Codes' 0 995033811 040755
# C 'lib/Locale/Codes/t' 0 995033811 040755
# C 'lib/Locale/Maketext' 0 995033812 040755
# C 'lib/Math/BigInt' 0 995033812 040755
# C 'lib/Math/BigInt/t' 0 995033812 040755
# C 'lib/Memoize' 0 995033814 040755
# C 'lib/Memoize/t' 0 995033814 040755
# C 'lib/NEXT' 0 995033816 040755
# C 'lib/Net/FTP' 0 995033815 040755
# C 'lib/Net/demos' 0 995033814 040755
# C 'lib/Net/t' 0 995033816 040755
# C 'lib/Switch' 0 995033819 040755
# C 'lib/Term/ANSIColor' 0 995033819 040755
# C 'lib/Test/More' 0 995033820 040755
# C 'lib/Test/More/t' 0 995033820 040755
# C 'lib/Test/Simple' 0 995033820 040755
# C 'lib/Test/Simple/t' 0 995033820 040755
# C 'lib/Test/t' 0 995033821 040755
# C 'lib/Text/Balanced' 0 995033821 040755
# C 'lib/Text/Balanced/t' 0 995033821 040755
# C 'lib/Text/TabsWrap' 0 995033822 040755
# C 'lib/Text/TabsWrap/t' 0 995033822 040755
# C 'lib/Tie/Array' 0 995033822 040755
# C 'lib/Tie/Handle' 0 995033822 040755
# C 't/lib/Test' 0 995033872 040755
# C 't/lib/Test/More' 0 995033872 040755
# C 't/lib/Test/Simple' 0 995033872 040755
# C 't/lib/Test/Simple/sample_tests' 0 995033872 040755
# C 't/lib/locale' 0 995033871 040755
# C 't/lib/strict' 0 995033872 040755
# C 't/lib/warnings' 0 995033874 040755
# C 'uts' 0 995033886 040755
#### End of ApplyPatch data ####
#### End of Patch kit [created: Fri Jul 13 17:23:13 2001] ####
#### Patch checksum: 275677 8405588 23923 ####
#### Checksum: 277465 8462118 30151 ####