diff options
| author | Nick Ing-Simmons <nik@tiuk.ti.com> | 2000-12-15 22:14:31 +0000 |
|---|---|---|
| committer | Nick Ing-Simmons <nik@tiuk.ti.com> | 2000-12-15 22:14:31 +0000 |
| commit | 9ad0568745f6fe01e5fc04f7d23be449d0c377a4 (patch) | |
| tree | 3a1dbd9cb1a8f0456fa0cbaadc88bf7f3f7ddaf3 | |
| parent | 18b7339f76ca9f2454845b454e0d2168c487e8ee (diff) | |
| parent | f9172815abf2357cc8661dd092b8830b9ecd8186 (diff) | |
| download | perl-9ad0568745f6fe01e5fc04f7d23be449d0c377a4.tar.gz | |
Integrate mainline
p4raw-id: //depot/perlio@8140
51 files changed, 2726 insertions, 480 deletions
@@ -32,6 +32,255 @@ Version v5.7.1 Development release working toward v5.8 -------------- ____________________________________________________________________________ +[ 8132] By: jhi on 2000/12/15 15:44:16 + Log: Some compilers get huffy if you do not cast a const pointer + to a non-const when assigning. + Branch: perl + ! gv.c +____________________________________________________________________________ +[ 8131] By: jhi on 2000/12/15 15:38:30 + Log: Subject: [PATCH 5.7.0] speeding up object creation/destruction 4x times + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Fri, 15 Dec 2000 05:26:57 -0500 + Message-ID: <20001215052657.A8319@math.mps.ohio-state.edu> + Branch: perl + ! embed.h embed.pl gv.c objXSUB.h perl.h proto.h sv.c + ! t/pragma/overload.t +____________________________________________________________________________ +[ 8130] By: jhi on 2000/12/15 15:36:08 + Log: Subject: [PATCH 5.7.0] cosmetic change to overloading + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Thu, 14 Dec 2000 22:02:43 -0500 + Message-ID: <20001214220243.A18437@monk.mps.ohio-state.edu> + Branch: perl + ! gv.c perl.h +____________________________________________________________________________ +[ 8129] By: jhi on 2000/12/15 15:34:16 + Log: Subject: PATCH: h2xs nit + From: Tim Jenness <t.jenness@jach.hawaii.edu> + Date: Thu, 14 Dec 2000 18:25:46 -1000 (HST) + Message-ID: <Pine.LNX.4.30.0012141820340.2533-100000@lapaki.jach.hawaii.edu> + + Add a template README. + Branch: perl + ! utils/h2xs.PL +____________________________________________________________________________ +[ 8128] By: jhi on 2000/12/15 15:32:22 + Log: Still buggy findgteprime, fix from Eric Joanis <joanis@cs.toronto.edu>. + Branch: perl + ! lib/Tie/SubstrHash.pm t/lib/tie-substrhash.t +____________________________________________________________________________ +[ 8127] By: jhi on 2000/12/15 15:19:34 + Log: Subject: [PATCH Opcode.XS, Perl 5.6+] stuff for caller and _ in Safe:: + From: lane@DUPHY4.Physics.Drexel.Edu (Charles Lane) + Date: Thu, 14 Dec 2000 20:04:42 EST + Message-Id: <001214200310.49929@DUPHY4.Physics.Drexel.Edu> + Branch: perl + ! ext/Opcode/Opcode.xs +____________________________________________________________________________ +[ 8126] By: jhi on 2000/12/15 15:17:49 + Log: Subject: [PATCH: perl@8102] s/use vars qw\(/our(/ for OS/390 extension builds + From: Peter Prymmer <pvhp@forte.com> + Date: Thu, 14 Dec 2000 15:50:20 -0800 (PST) + Message-ID: <Pine.OSF.4.10.10012141548200.57557-100000@aspara.forte.com> + Branch: perl + ! ext/Errno/Errno_pm.PL lib/ExtUtils/MM_Unix.pm + ! lib/ExtUtils/Manifest.pm lib/File/Spec.pm + ! lib/File/Spec/Functions.pm lib/File/Spec/Unix.pm +____________________________________________________________________________ +[ 8125] By: jhi on 2000/12/15 15:11:05 + Log: This seems to be a stage sane and stable enough to checkin. + (it basically is 8102..8118+8122 but no 8120, 8121, 8123, 8124) + Branch: perl + ! MANIFEST embed.h embed.pl objXSUB.h op.c perl.h perlapi.c + ! pod/perlapi.pod pp.c pp_hot.c proto.h sv.c sv.h t/lib/peek.t + ! t/op/cmp.t t/op/numconvert.t +____________________________________________________________________________ +[ 8124] By: jhi on 2000/12/15 04:20:26 + Log: Something is really wonky. + Branch: perl + ! sv.c +____________________________________________________________________________ +[ 8123] By: jhi on 2000/12/15 04:00:50 + Log: Fixes for the IV UV patches to compile in Digital UNIX. + Branch: perl + ! sv.c +____________________________________________________________________________ +[ 8122] By: jhi on 2000/12/15 02:53:40 + Log: Subject: Re: [ID 20001214.011] Unreachable value in a search list logical name + From: "Craig A. Berry" <craigberry@mac.com> + Date: Thu, 14 Dec 2000 19:10:49 -0600 + Message-Id: <p04330100b65efbe32f30@[172.16.52.1]> + Branch: perl + ! vms/vms.c +____________________________________________________________________________ +[ 8121] By: jhi on 2000/12/15 02:50:00 + Log: Metaconfig changes for #8120. + Branch: metaconfig + + U/modified/d_strtoul.U + Branch: metaconfig/U/perl + ! d_strtoull.U d_strtouq.U +____________________________________________________________________________ +[ 8120] By: jhi on 2000/12/15 02:49:42 + Log: From: Nicholas Clark <nick@ccl4.org> + Subject: [PATCH] strtoq, strtou(q|ll|l) testing (was [PATCH] faster and 64 bit preserving arithmetic) + Date: Thu, 14 Dec 2000 18:38:57 +0000 + Message-ID: <20001214183857.B97909@plum.flirble.org> + Branch: perl + ! Configure Porting/Glossary Porting/config.sh Porting/config_H + ! config_h.SH configure.com epoc/config.sh perl.h sv.c 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 +____________________________________________________________________________ +[ 8119] By: jhi on 2000/12/14 23:40:58 + Log: Subject: [PATCH] faster and 64 bit preserving arithmetic + From: Nicholas Clark <nick@ccl4.org> + Date: Wed, 13 Dec 2000 20:08:50 +0000 + Message-ID: <20001213200849.B71166@plum.flirble.org> + Branch: perl + ! embed.h embed.pl objXSUB.h op.c perl.h pp.c pp_hot.c proto.h + ! sv.c sv.h t/lib/peek.t t/op/cmp.t t/op/numconvert.t +____________________________________________________________________________ +[ 8118] By: jhi on 2000/12/14 22:46:26 + Log: Integrate perlio. + Branch: perl + !> MANIFEST ext/Encode/compile makedef.pl +____________________________________________________________________________ +[ 8117] By: nick on 2000/12/14 22:38:53 + Log: Win32 tweaks to get Encode to build + - temp hack to makedef.pl till PerlIO is properly "exported". + - MSVC dislikes + static encpage_t foo[]; + so make 'em extern for now. + Branch: perlio + ! ext/Encode/compile makedef.pl +____________________________________________________________________________ +[ 8116] By: nick on 2000/12/14 22:00:53 + Log: Document the new files + Branch: perlio + ! MANIFEST +____________________________________________________________________________ +[ 8115] By: jhi on 2000/12/14 21:58:01 + Log: MANIFEST new files of #8114. + Branch: perl + ! MANIFEST +____________________________________________________________________________ +[ 8114] By: jhi on 2000/12/14 21:50:49 + Log: Integrate perlio. + Branch: perl + +> ext/Encode/compile ext/Encode/encengine.c ext/Encode/encode.h + !> ext/Encode/Encode.pm ext/Encode/Encode.xs + !> ext/Encode/Encode/ascii.enc ext/Encode/Encode/cp1047.enc + !> ext/Encode/Encode/cp37.enc ext/Encode/Encode/posix-bc.enc + !> ext/Encode/Makefile.PL +____________________________________________________________________________ +[ 8113] By: jhi on 2000/12/14 21:48:49 + Log: The documentation part of the + + Subject: [ID 20001214.002] Net::Ping patch + From: Jonathan Stowe <gellyfish@gellyfish.com> + Date: Thu, 14 Dec 2000 08:28:14 +0000 (GMT) + Message-Id: <Pine.LNX.4.10.10012140805480.19767-200000@orpheus.gellyfish.com> + since the #7529 had already addressed the same problem. + Branch: perl + ! lib/Net/Ping.pm +____________________________________________________________________________ +[ 8112] By: jhi on 2000/12/14 21:42:57 + Log: Subject: [PATCH] Re: [ID 20001013.006] XS subs are not define()ed + From: Dominic Dunlop <domo@computer.org> + Date: Tue, 12 Dec 2000 10:47:10 +0100 + Message-Id: <p04320402b65ba33a92b2@[192.168.1.4]> + + Document how elusive subroutines can be. + Branch: perl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 8111] By: jhi on 2000/12/14 21:38:05 + Log: Subject: [ID 20001214.003] [PATCH bleadperl] POSIX::tmpnam() is dangerous + From: Dominic Dunlop <domo@computer.org> + Date: Thu, 14 Dec 2000 10:13:51 +0100 + Message-Id: <p04320407b65e3f4853aa@[192.168.1.4]> + Branch: perl + ! ext/POSIX/POSIX.pod +____________________________________________________________________________ +[ 8110] By: jhi on 2000/12/14 21:36:32 + Log: Subject: [patch] perlfaq7 + From: "Gerrit P. Haase" <gerrit.haase@t-online.de> + Date: Thu, 14 Dec 2000 15:31:07 +0100 + Message-ID: <3A38E7BB.13178.11C40A8@localhost> + Branch: perl + ! pod/perlfaq7.pod +____________________________________________________________________________ +[ 8109] By: jhi on 2000/12/14 21:29:20 + Log: Subject: [8104] Encode + From: "H.Merijn Brand" <h.m.brand@hccnet.nl> + Date: Thu, 14 Dec 2000 14:49:34 +0100 + Message-Id: <20001214142101.B338.H.M.BRAND@hccnet.nl> + + Type casting for nervous compilers. + Branch: perl + ! ext/Encode/Encode.xs +____________________________________________________________________________ +[ 8108] By: jhi on 2000/12/14 21:26:17 + Log: Subject: [8104] DB_File + From: "H.Merijn Brand" <h.m.brand@hccnet.nl> + Date: Thu, 14 Dec 2000 14:49:35 +0100 + Message-Id: <20001214144439.B33A.H.M.BRAND@hccnet.nl> + + Type definition incorrect for DB 2.7.7. Not known when it + changed, so only changed it for a known revision. + Branch: perl + ! ext/DB_File/DB_File.xs +____________________________________________________________________________ +[ 8107] By: jhi on 2000/12/14 21:23:41 + Log: Subject: [PATCH: perl@8102] Re: Encode/cp1047.enc etc. + From: Peter Prymmer <pvhp@forte.com> + Date: Thu, 14 Dec 2000 11:11:50 -0800 (PST) + Message-ID: <Pine.OSF.4.10.10012141057330.57557-100000@aspara.forte.com> + + Use '?' (0x6F in EBCDIC) for the illegal codepoint. + Branch: perl + ! ext/Encode/Encode/cp1047.enc ext/Encode/Encode/cp37.enc + ! ext/Encode/Encode/posix-bc.enc +____________________________________________________________________________ +[ 8106] By: nick on 2000/12/14 20:36:13 + Log: "Cold" build correction to Encode's Makefile.PL + Branch: perlio + ! ext/Encode/Makefile.PL +____________________________________________________________________________ +[ 8105] By: nick on 2000/12/14 20:09:37 + Log: "Compiled" encodings. + Correct replacement character in EBCDIC .enc files + Add 0x7F to ASCII repertoire. + Branch: perlio + ! ext/Encode/Encode.pm ext/Encode/Encode.xs + ! ext/Encode/Encode/ascii.enc ext/Encode/Encode/cp1047.enc + ! ext/Encode/Encode/cp37.enc ext/Encode/Encode/posix-bc.enc + ! ext/Encode/Makefile.PL ext/Encode/compile + ! ext/Encode/encengine.c ext/Encode/encode.h +____________________________________________________________________________ +[ 8104] By: nick on 2000/12/14 00:38:20 + Log: Integrate mainline + Branch: perlio + !> Changes Configure doio.c embed.h embed.pl ext/DB_File/Changes + !> ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs + !> ext/DB_File/dbinfo ext/DB_File/typemap ext/DB_File/version.c + !> hints/hpux.sh lib/Cwd.pm objXSUB.h patchlevel.h perlapi.c + !> pod/perlapi.pod pp_hot.c proto.h t/lib/db-btree.t + !> t/lib/db-hash.t t/lib/db-recno.t +____________________________________________________________________________ +[ 8103] By: nick on 2000/12/13 23:16:13 + Log: Beginings of compiled encodings - checked in as a snapshot of thoughts + so far and so it does not get lost. + Branch: perlio + + ext/Encode/compile ext/Encode/encengine.c ext/Encode/encode.h +____________________________________________________________________________ +[ 8102] By: jhi on 2000/12/13 17:14:22 + Log: Update Changes. + Branch: perl + ! Changes patchlevel.h +____________________________________________________________________________ [ 8101] By: jhi on 2000/12/13 16:53:41 Log: Move the proto of start_glob() to a better place; regen api files. Branch: perl @@ -20,7 +20,7 @@ # $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $ # -# Generated on Wed Dec 13 17:45:13 EET 2000 [metaconfig 3.0 PL70] +# Generated on Fri Dec 15 20:31:25 EET 2000 [metaconfig 3.0 PL70] # (with additional metaconfig patches by perlbug@perl.org) cat >c1$$ <<EOF @@ -562,6 +562,7 @@ d_strtod='' d_strtol='' d_strtold='' d_strtoll='' +d_strtoq='' d_strtoul='' d_strtoull='' d_strtouq='' @@ -11927,10 +11928,87 @@ EOM ;; esac +: see if strtoq exists +set strtoq d_strtoq +eval $inlibc + : see if strtoul exists set strtoul d_strtoul eval $inlibc +case "$d_strtoul" in +"$define") + $cat <<EOM +Checking whether your strtoul() works okay... +EOM + $cat >try.c <<'EOCP' +#include <errno.h> +#include <stdio.h> +extern unsigned long int strtoul(char *s, char **, int); +static int bad = 0; +void check(char *s, unsigned long eul, int een) { + unsigned long gul; + errno = 0; + gul = strtoul(s, 0, 10); + if (!((gul == eul) && (errno == een))) + bad++; +} +int main() { + check(" 1", 1L, 0); + check(" 0", 0L, 0); +EOCP + case "$longsize" in + 8) + $cat >>try.c <<'EOCP' + check("18446744073709551615", 18446744073709551615UL, 0); + check("18446744073709551616", 18446744073709551615UL, ERANGE); +#if 0 /* strtoul() for /^-/ strings is undefined. */ + check("-1", 18446744073709551615UL, 0); + check("-18446744073709551614", 2, 0); + check("-18446744073709551615", 1, 0); + check("-18446744073709551616", 18446744073709551615UL, ERANGE); + check("-18446744073709551617", 18446744073709551615UL, ERANGE); +#endif +EOCP + ;; + 4) + $cat >>try.c <<'EOCP' + check("4294967295", 4294967295UL, 0); + check("4294967296", 4294967295UL, ERANGE); +#if 0 /* strtoul() for /^-/ strings is undefined. */ + check("-1", 4294967295UL, 0); + check("-4294967294", 2, 0); + check("-4294967295", 1, 0); + check("-4294967296", 4294967295UL, ERANGE); + check("-4294967297", 4294967295UL, ERANGE); +#endif +EOCP + ;; + *) +: Should we write these tests to be more portable by sprintf-ing +: ~0 and then manipulating that char string as input for strtol? + ;; + esac + $cat >>try.c <<'EOCP' + if (!bad) + printf("ok\n"); + return 0; +} +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. +EOM + d_strtoul="$undef" + ;; + esac + fi + ;; +esac + : see if strtoull exists set strtoull d_strtoull eval $inlibc @@ -11956,10 +12034,17 @@ int check(char *s, long long eull, int een) { bad++; } int main() { - check(" 1", 1LL, 0); - check(" 0", 0LL, 0); - check("18446744073709551615", 18446744073709551615ULL, 0); - check("18446744073709551616", 18446744073709551615ULL, ERANGE); + check(" 1", 1LL, 0); + check(" 0", 0LL, 0); + check("18446744073709551615", 18446744073709551615ULL, 0); + check("18446744073709551616", 18446744073709551615ULL, ERANGE); +#if 0 /* strtoull() for /^-/ strings is undefined. */ + check("-1", 18446744073709551615ULL, 0); + check("-18446744073709551614", 2LL, 0); + check("-18446744073709551615", 1LL, 0); + check("-18446744073709551616", 18446744073709551615ULL, ERANGE); + check("-18446744073709551617", 18446744073709551615ULL, ERANGE); +#endif if (!bad) printf("ok\n"); } @@ -11982,6 +12067,54 @@ esac set strtouq d_strtouq eval $inlibc +case "$d_strtouq" in +"$define") + $cat <<EOM +Checking whether your strtouq() works okay... +EOM + $cat >try.c <<'EOCP' +#include <errno.h> +#include <stdio.h> +extern unsigned long long int strtouq(char *s, char **, int); +static int bad = 0; +void check(char *s, unsigned long long eull, int een) { + unsigned long long gull; + errno = 0; + gull = strtouq(s, 0, 10); + if (!((gull == eull) && (errno == een))) + bad++; +} +int main() { + check(" 1", 1LL, 0); + check(" 0", 0LL, 0); + check("18446744073709551615", 18446744073709551615ULL, 0); + check("18446744073709551616", 18446744073709551615ULL, ERANGE); +#if 0 /* strtouq() for /^-/ strings is undefined. */ + check("-1", 18446744073709551615ULL, 0); + check("-18446744073709551614", 2LL, 0); + check("-18446744073709551615", 1LL, 0); + check("-18446744073709551616", 18446744073709551615ULL, ERANGE); + check("-18446744073709551617", 18446744073709551615ULL, ERANGE); +#endif + if (!bad) + printf("ok\n"); + return 0; +} +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. +EOM + d_strtouq="$undef" + ;; + esac + fi + ;; +esac + : see if strxfrm exists set strxfrm d_strxfrm eval $inlibc @@ -15883,6 +16016,7 @@ d_strtod='$d_strtod' d_strtol='$d_strtol' d_strtold='$d_strtold' d_strtoll='$d_strtoll' +d_strtoq='$d_strtoq' d_strtoul='$d_strtoul' d_strtoull='$d_strtoull' d_strtouq='$d_strtouq' @@ -192,11 +192,6 @@ 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.h Encode extension -ext/Encode/encengine.c Encode extension -ext/Encode/compile Encode extension -ext/Encode/Makefile.PL Encode extension -ext/Encode/Todo Encode extension ext/Encode/Encode/EncodeFormat.pod Encoding table format ext/Encode/Encode/ascii.enc Encoding tables ext/Encode/Encode/big5.enc Encoding tables @@ -279,6 +274,11 @@ ext/Encode/Encode/macUkraine.enc Encoding tables ext/Encode/Encode/posix-bc.enc Encoding tables ext/Encode/Encode/shiftjis.enc Encoding tables ext/Encode/Encode/symbol.enc 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 @@ -403,8 +403,8 @@ 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/Makefile.PL 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 @@ -450,8 +450,8 @@ 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 -fakethr.h Fake threads header 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) @@ -679,13 +679,13 @@ 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/Spec/Epoc.pm portable operations on EPOC 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 @@ -1163,8 +1163,8 @@ perlapi.c Perl API functions perlapi.h Perl API function declarations perlio.c C code for PerlIO abstraction perlio.h PerlIO abstraction -perliol.h PerlIO Layer definition 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 @@ -1386,9 +1386,9 @@ 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/encode.t See if Encode works t/lib/env.t See if Env works t/lib/errno.t See if Errno works t/lib/fatal.t See if Fatal works @@ -1400,8 +1400,8 @@ 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.t See if Filter::Util::Call 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 @@ -1734,8 +1734,8 @@ 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.ga.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 diff --git a/Porting/Glossary b/Porting/Glossary index c4ce3de565..5c7b393aa3 100644 --- a/Porting/Glossary +++ b/Porting/Glossary @@ -1564,6 +1564,10 @@ d_strtoll (d_strtoll.U): This variable conditionally defines the HAS_STRTOLL symbol, which indicates to the C program that the strtoll() routine is available. +d_strtoq (d_strtoq.U): + This variable conditionally defines the HAS_STRTOQ symbol, which + indicates to the C program that the strtoq() routine is available. + d_strtoul (d_strtoul.U): This variable conditionally defines the HAS_STRTOUL symbol, which indicates to the C program that the strtoul() routine is available diff --git a/Porting/config.sh b/Porting/config.sh index 2f760ae8a0..2954f11bc2 100644 --- a/Porting/config.sh +++ b/Porting/config.sh @@ -8,7 +8,7 @@ # Package name : perl5 # Source directory : /m/fs/work/work/permanent/perl/pp4/perl -# Configuration time: Tue Nov 21 20:44:07 EET 2000 +# Configuration time: Fri Dec 15 20:33:12 EET 2000 # Configured by : jhi # Target system : osf1 alpha.hut.fi v4.0 878 alpha @@ -62,7 +62,7 @@ ccsymbols='__alpha=1 __LANGUAGE_C__=1 __osf__=1 __unix__=1 _LONGLONG=1 _SYSTYPE_ ccversion='V5.6-082' cf_by='jhi' cf_email='yourname@yourhost.yourplace.com' -cf_time='Tue Nov 21 20:44:07 EET 2000' +cf_time='Fri Dec 15 20:33:12 EET 2000' charsize='1' chgrp='' chmod='' @@ -355,6 +355,7 @@ d_strtod='define' d_strtol='define' d_strtold='undef' d_strtoll='undef' +d_strtoq='undef' d_strtoul='define' d_strtoull='undef' d_strtouq='undef' @@ -401,7 +402,7 @@ dlext='so' dlsrc='dl_dlopen.xs' doublesize='8' drand01='drand48()' -dynamic_ext='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re' +dynamic_ext='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob Filter/Util/Call IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re' eagain='EAGAIN' ebcdic='undef' echo='echo' @@ -410,7 +411,7 @@ emacs='' eunicefix=':' exe_ext='' expr='expr' -extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re Errno' +extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob Filter/Util/Call IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re Errno' fflushNULL='define' fflushall='undef' find='' @@ -549,7 +550,7 @@ intsize='4' ivdformat='"ld"' ivsize='8' ivtype='long' -known_extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob GDBM_File IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re' +known_extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob Filter/Util/Call GDBM_File IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re' ksh='' ld='ld' lddlflags='-shared -expect_unresolved "*" -msym -std -s' diff --git a/Porting/config_H b/Porting/config_H index 10130c2a6d..991e62e65d 100644 --- a/Porting/config_H +++ b/Porting/config_H @@ -17,7 +17,7 @@ /* * Package name : perl5 * Source directory : /m/fs/work/work/permanent/perl/pp4/perl - * Configuration time: Tue Nov 21 20:44:07 EET 2000 + * Configuration time: Fri Dec 15 20:33:12 EET 2000 * Configured by : jhi * Target system : osf1 alpha.hut.fi v4.0 878 alpha */ @@ -585,12 +585,6 @@ */ #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. @@ -961,12 +955,6 @@ */ #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. @@ -2111,6 +2099,12 @@ */ /*#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_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. @@ -3191,6 +3185,18 @@ #define HAS_SETPGRP /**/ #define USE_BSD_SETPGRP /**/ +/* HAS_STRTOUL: + * This symbol, if defined, indicates that the strtoul routine is + * available to provide conversion of strings to unsigned long. + */ +#define HAS_STRTOUL /**/ + +/* 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__FWALK: * This symbol, if defined, indicates that the _fwalk system call is * available to apply a function to all the file handles. diff --git a/config_h.SH b/config_h.SH index bc1fc3f7d6..8ab759d85c 100644 --- a/config_h.SH +++ b/config_h.SH @@ -605,12 +605,6 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_strtol HAS_STRTOL /**/ -/* HAS_STRTOUL: - * This symbol, if defined, indicates that the strtoul routine is - * available to provide conversion of strings to unsigned long. - */ -#$d_strtoul HAS_STRTOUL /**/ - /* HAS_STRXFRM: * This symbol, if defined, indicates that the strxfrm() routine is * available to transform strings. @@ -2125,6 +2119,12 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_strtoll HAS_STRTOLL /**/ +/* HAS_STRTOQ: + * This symbol, if defined, indicates that the strtoq routine is + * available to convert strings to long longs (quads). + */ +#$d_strtoq HAS_STRTOQ /**/ + /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. @@ -3205,6 +3205,12 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #$d_setpgrp HAS_SETPGRP /**/ #$d_bsdsetpgrp USE_BSD_SETPGRP /**/ +/* HAS_STRTOUL: + * This symbol, if defined, indicates that the strtoul routine is + * available to provide conversion of strings to unsigned long. + */ +#$d_strtoul HAS_STRTOUL /**/ + /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". diff --git a/configure.com b/configure.com index 5b8ccbc302..36bf11e053 100644 --- a/configure.com +++ b/configure.com @@ -3596,6 +3596,42 @@ $ tmp = "strtoll" $ GOSUB inlibc $ d_strtoll = tmp $! +$! Check for strtoq +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <string.h>" +$ WS "int main()" +$ WS "{" +$ WS "__int64 result;" +$ WS "result = strtoq(""123123"", NULL, 10);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "strtoq" +$ GOSUB inlibc +$ d_strtoq = tmp +$! +$! Check for strtoq +$! +$ OS +$ WS "#if defined(__DECC) || defined(__DECCXX)" +$ WS "#include <stdlib.h>" +$ WS "#endif" +$ WS "#include <string.h>" +$ WS "int main()" +$ WS "{" +$ WS "__int64 result;" +$ WS "result = strtoq(""123123"", NULL, 10);" +$ WS "exit(0);" +$ WS "}" +$ CS +$ tmp = "strtoq" +$ GOSUB inlibc +$ d_strtoq = tmp +$! $! Check for strtold $! $ OS @@ -5004,6 +5040,7 @@ $ WC "d_strtod='define'" $ WC "d_strtol='define'" $ WC "d_strtold='" + d_strtold + "'" $ WC "d_strtoll='" + d_strtoll + "'" +$ WC "d_strtoq='define'" $ WC "d_strtoul='define'" $ WC "d_strtoull='" + d_strtoull + "'" $ WC "d_strtouq='" + d_strtouq + "'" @@ -68,6 +68,7 @@ #endif #define amagic_call Perl_amagic_call #define Gv_AMupdate Perl_Gv_AMupdate +#define gv_handler Perl_gv_handler #define append_elem Perl_append_elem #define append_list Perl_append_list #define apply Perl_apply @@ -1087,6 +1088,10 @@ # 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 #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #define check_uni S_check_uni @@ -1556,6 +1561,7 @@ #endif #define amagic_call(a,b,c,d) Perl_amagic_call(aTHX_ a,b,c,d) #define Gv_AMupdate(a) Perl_Gv_AMupdate(aTHX_ a) +#define gv_handler(a,b) Perl_gv_handler(aTHX_ a,b) #define append_elem(a,b,c) Perl_append_elem(aTHX_ a,b,c) #define append_list(a,b,c) Perl_append_list(aTHX_ a,b,c) #define apply(a,b,c) Perl_apply(aTHX_ a,b,c) @@ -2545,6 +2551,10 @@ # 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 #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #define check_uni() S_check_uni(aTHX) @@ -3021,6 +3031,8 @@ #define amagic_call Perl_amagic_call #define Perl_Gv_AMupdate CPerlObj::Perl_Gv_AMupdate #define Gv_AMupdate Perl_Gv_AMupdate +#define Perl_gv_handler CPerlObj::Perl_gv_handler +#define gv_handler Perl_gv_handler #define Perl_append_elem CPerlObj::Perl_append_elem #define append_elem Perl_append_elem #define Perl_append_list CPerlObj::Perl_append_list @@ -4951,6 +4963,12 @@ #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 #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #define S_check_uni CPerlObj::S_check_uni @@ -1376,6 +1376,7 @@ START_EXTERN_C # include "pp_proto.h" Ap |SV* |amagic_call |SV* left|SV* right|int method|int dir Ap |bool |Gv_AMupdate |HV* stash +Ap |CV* |gv_handler |HV* stash|I32 id p |OP* |append_elem |I32 optype|OP* head|OP* tail p |OP* |append_list |I32 optype|LISTOP* first|LISTOP* last p |I32 |apply |I32 type|SV** mark|SV** sp @@ -2467,6 +2468,10 @@ 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 #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) diff --git a/epoc/config.sh b/epoc/config.sh index 2ea89c17a2..c2921b72a5 100644 --- a/epoc/config.sh +++ b/epoc/config.sh @@ -341,7 +341,9 @@ 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' diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index 751ceaae6b..5ba18f395d 100644 --- a/ext/DB_File/DB_File.xs +++ b/ext/DB_File/DB_File.xs @@ -592,7 +592,7 @@ const DBT * key2 ; } -#ifdef BERKELEY_DB_1_OR_2 +#if defined(BERKELEY_DB_1_OR_2) && !(DB_VERSION_MINOR == 7 && DB_VERSION_PATCH >= 7) # define HASH_CB_SIZE_TYPE size_t #else # define HASH_CB_SIZE_TYPE u_int32_t diff --git a/ext/Encode/Encode.xs b/ext/Encode/Encode.xs index 3bd8e95c66..cca1ddcd7b 100644 --- a/ext/Encode/Encode.xs +++ b/ext/Encode/Encode.xs @@ -107,7 +107,7 @@ PerlIOEncode_get_base(PerlIO *f) e->bufsv = newSV(e->base.bufsiz); sv_setpvn(e->bufsv,"",0); } - e->base.buf = SvPVX(e->bufsv); + e->base.buf = (STDCHAR *)SvPVX(e->bufsv); if (!e->base.ptr) e->base.ptr = e->base.buf; if (!e->base.end) @@ -122,7 +122,7 @@ PerlIOEncode_get_base(PerlIO *f) { SSize_t poff = e->base.ptr - e->base.buf; SSize_t eoff = e->base.end - e->base.buf; - e->base.buf = SvGROW(e->bufsv,e->base.bufsiz); + e->base.buf = (STDCHAR *)SvGROW(e->bufsv,e->base.bufsiz); e->base.ptr = e->base.buf + poff; e->base.end = e->base.buf + eoff; } @@ -171,7 +171,7 @@ PerlIOEncode_fill(PerlIO *f) s = SvPVutf8(uni,len); if (s != SvPVX(e->bufsv)) { - e->base.buf = SvGROW(e->bufsv,len); + e->base.buf = (STDCHAR *)SvGROW(e->bufsv,len); Move(s,e->base.buf,len,char); SvCUR_set(e->bufsv,len); } @@ -222,7 +222,7 @@ PerlIOEncode_flush(PerlIO *f) s = SvPV(str,len); if (s != SvPVX(e->bufsv)) { - e->base.buf = SvGROW(e->bufsv,len); + e->base.buf = (STDCHAR *)SvGROW(e->bufsv,len); Move(s,e->base.buf,len,char); SvCUR_set(e->bufsv,len); } diff --git a/ext/Errno/Errno_pm.PL b/ext/Errno/Errno_pm.PL index 9ea60416f6..3e34b90bee 100644 --- a/ext/Errno/Errno_pm.PL +++ b/ext/Errno/Errno_pm.PL @@ -2,9 +2,7 @@ use ExtUtils::MakeMaker; use Config; use strict; -use vars qw($VERSION); - -$VERSION = "1.111"; +our $VERSION = "1.111"; my %err = (); @@ -185,7 +183,7 @@ sub write_errno_pm { # package Errno; -use vars qw(\@EXPORT_OK \%EXPORT_TAGS \@ISA \$VERSION \%errno \$AUTOLOAD); +our (\@EXPORT_OK,\%EXPORT_TAGS,\@ISA,\$VERSION,\%errno,\$AUTOLOAD); use Exporter (); use Config; use strict; diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs index e191ec7c9c..04f7c3fa33 100644 --- a/ext/Opcode/Opcode.xs +++ b/ext/Opcode/Opcode.xs @@ -253,6 +253,12 @@ PPCODE: save_hptr(&PL_defstash); /* save current default stash */ /* the assignment to global defstash changes our sense of 'main' */ PL_defstash = gv_stashpv(Package, GV_ADDWARN); /* should exist already */ + if (strNE(HvNAME(PL_defstash),"main")) { + Safefree(HvNAME(PL_defstash)); + HvNAME(PL_defstash) = savepv("main"); /* make it think it's in main:: */ + hv_store(PL_defstash,"_",1,(SV *)PL_defgv,0); /* connect _ to global */ + SvREFCNT_inc((SV *)PL_defgv); /* want to keep _ around! */ + } save_hptr(&PL_curstash); PL_curstash = PL_defstash; diff --git a/ext/POSIX/POSIX.pod b/ext/POSIX/POSIX.pod index e93fb742da..10199e9a2b 100644 --- a/ext/POSIX/POSIX.pod +++ b/ext/POSIX/POSIX.pod @@ -1438,7 +1438,9 @@ Returns a name for a temporary file. $tmpfile = POSIX::tmpnam(); -See also L<File::Temp>. +For security reasons, which are probably detailed in your system's +documentation for the C library tmpnam() function, this interface +should not be used; instead see L<File::Temp>. =item tolower @@ -1152,14 +1152,10 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL; AMT amt; STRLEN n_a; -#ifdef OVERLOAD_VIA_HASH - GV** gvp; - HV* hv; -#endif if (mg && amtp->was_ok_am == PL_amagic_generation && amtp->was_ok_sub == PL_sub_generation) - return AMT_AMAGIC(amtp); + return AMT_OVERLOADED(amtp); if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */ int i; for (i=1; i<NofAMmeth; i++) { @@ -1177,90 +1173,40 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) amt.fallback = AMGfallNO; amt.flags = 0; -#ifdef OVERLOAD_VIA_HASH - gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */ - if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) { - int filled=0; - int i; - char *cp; - SV* sv; - SV** svp; - - /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ - - if (( cp = (char *)PL_AMG_names[0] ) && - (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) { - if (SvTRUE(sv)) amt.fallback=AMGfallYES; - else if (SvOK(sv)) amt.fallback=AMGfallNEVER; - } - for (i = 1; i < NofAMmeth; i++) { - cv = 0; - cp = (char *)PL_AMG_names[i]; - - svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE); - if (svp && ((sv = *svp) != &PL_sv_undef)) { - switch (SvTYPE(sv)) { - default: - if (!SvROK(sv)) { - if (!SvOK(sv)) break; - gv = gv_fetchmethod(stash, SvPV(sv, n_a)); - if (gv) cv = GvCV(gv); - break; - } - cv = (CV*)SvRV(sv); - if (SvTYPE(cv) == SVt_PVCV) - break; - /* FALL THROUGH */ - case SVt_PVHV: - case SVt_PVAV: - Perl_croak(aTHX_ "Not a subroutine reference in overload table"); - return FALSE; - case SVt_PVCV: - cv = (CV*)sv; - break; - case SVt_PVGV: - if (!(cv = GvCVu((GV*)sv))) - cv = sv_2cv(sv, &stash, &gv, FALSE); - break; - } - if (cv) filled=1; - else { - Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n", - cp,HvNAME(stash)); - return FALSE; - } - } -#else { - int filled = 0; - int i; + int filled = 0, have_ovl = 0; + int i, lim = 1; const char *cp; SV* sv = NULL; /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ - if ((cp = PL_AMG_names[0])) { - /* Try to find via inheritance. */ - gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */ - if (gv) - sv = GvSV(gv); - - if (!gv) - goto no_table; - else if (SvTRUE(sv)) - amt.fallback=AMGfallYES; - else if (SvOK(sv)) - amt.fallback=AMGfallNEVER; - } + /* Try to find via inheritance. */ + gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1); + if (gv) + sv = GvSV(gv); + + if (!gv) + lim = DESTROY_amg; /* Skip overloading entries. */ + else if (SvTRUE(sv)) + amt.fallback=AMGfallYES; + else if (SvOK(sv)) + amt.fallback=AMGfallNEVER; + + for (i = 1; i < lim; i++) + amt.table[i] = Nullcv; + for (; i < NofAMmeth; i++) { + char *cooky = (char*)PL_AMG_names[i]; + /* Human-readable form, for debugging: */ + char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i)); + STRLEN l = strlen(cooky); - for (i = 1; i < NofAMmeth; i++) { - SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i])); DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n", cp, HvNAME(stash)) ); /* don't fill the cache while looking up! */ - gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1); + gv = gv_fetchmeth(stash, cooky, l, -1); cv = 0; - if(gv && (cv = GvCV(gv))) { + if (gv && (cv = GvCV(gv))) { if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) { /* GvSV contains the name of the method. */ @@ -1288,14 +1234,17 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))) ); filled = 1; + if (i < DESTROY_amg) + have_ovl = 1; } -#endif amt.table[i]=(CV*)SvREFCNT_inc(cv); } if (filled) { AMT_AMAGIC_on(&amt); + if (have_ovl) + AMT_OVERLOADED_on(&amt); sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT)); - return TRUE; + return have_ovl; } } /* Here we have no table: */ @@ -1305,6 +1254,29 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) return FALSE; } + +CV* +Perl_gv_handler(pTHX_ HV *stash, I32 id) +{ + dTHR; + MAGIC *mg = mg_find((SV*)stash,'c'); + AMT *amtp; + + 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 + || amtp->was_ok_sub != PL_sub_generation ) + goto do_update; + if (AMT_AMAGIC(amtp)) + return amtp->table[id]; + return Nullcv; +} + + SV* Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) { @@ -1488,7 +1460,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (off==-1) off=method; msg = sv_2mortal(Perl_newSVpvf(aTHX_ "Operation `%s': no method found,%sargument %s%s%s%s", - PL_AMG_names[method + assignshift], + AMG_id2name(method + assignshift), (flags & AMGf_unary ? " " : "\n\tleft "), SvAMAGIC(left)? "in overloaded package ": @@ -1517,11 +1489,11 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (!notfound) { DEBUG_o( Perl_deb(aTHX_ "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n", - PL_AMG_names[off], + AMG_id2name(off), method+assignshift==off? "" : " (initially `", method+assignshift==off? "" : - PL_AMG_names[method+assignshift], + AMG_id2name(method+assignshift), method+assignshift==off? "" : "')", flags & AMGf_unary? "" : lr==1 ? " for right argument": " for left argument", @@ -1581,7 +1553,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PUSHs(lr>0? left: right); PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); if (notfound) { - PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0))); + PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0))); } PUSHs((SV*)cv); PUTBACK; diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index c88f8f7a79..50f10d8a8a 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -7,8 +7,8 @@ use Config; use File::Basename qw(basename dirname fileparse); use DirHandle; use strict; -use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS $Is_Win32 $Is_Dos $Is_PERL_OBJECT - $Verbose %pm %static $Xsubpp_Version); +our ($Is_Mac,$Is_OS2,$Is_VMS,$Is_Win32,$Is_Dos,$Is_PERL_OBJECT, + $Verbose,%pm,%static,$Xsubpp_Version); our $VERSION = '1.12603'; diff --git a/lib/ExtUtils/Manifest.pm b/lib/ExtUtils/Manifest.pm index 46ace64e61..030eedffeb 100644 --- a/lib/ExtUtils/Manifest.pm +++ b/lib/ExtUtils/Manifest.pm @@ -8,8 +8,8 @@ use File::Spec::Functions qw(splitpath); use Carp; use strict; -use vars qw($VERSION @ISA @EXPORT_OK - $Is_VMS $Debug $Verbose $Quiet $MANIFEST $found $DEFAULT_MSKIP); +our ($VERSION,@ISA,@EXPORT_OK, + $Is_VMS,$Debug,$Verbose,$Quiet,$MANIFEST,$found,$DEFAULT_MSKIP); $VERSION = substr(q$Revision: 1.33 $, 10); @ISA=('Exporter'); diff --git a/lib/File/Spec.pm b/lib/File/Spec.pm index 3f79d74b66..35707cc780 100644 --- a/lib/File/Spec.pm +++ b/lib/File/Spec.pm @@ -1,7 +1,7 @@ package File::Spec; use strict; -use vars qw(@ISA $VERSION); +our(@ISA, $VERSION); $VERSION = 0.82 ; diff --git a/lib/File/Spec/Functions.pm b/lib/File/Spec/Functions.pm index 0036ac1ded..be653338fa 100644 --- a/lib/File/Spec/Functions.pm +++ b/lib/File/Spec/Functions.pm @@ -3,7 +3,7 @@ package File::Spec::Functions; use File::Spec; use strict; -use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); +our (@ISA,@EXPORT,@EXPORT_OK,%EXPORT_TAGS,$VERSION); $VERSION = '1.1'; diff --git a/lib/File/Spec/Unix.pm b/lib/File/Spec/Unix.pm index a81c533235..4e4cc753aa 100644 --- a/lib/File/Spec/Unix.pm +++ b/lib/File/Spec/Unix.pm @@ -1,7 +1,7 @@ package File::Spec::Unix; use strict; -use vars qw($VERSION); +our($VERSION); $VERSION = '1.2'; diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm index e3006f959f..20a642e0c3 100644 --- a/lib/Net/Ping.pm +++ b/lib/Net/Ping.pm @@ -460,6 +460,11 @@ 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 tcp and udp ping, a host +will be reported as unreachable if if not 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 diff --git a/lib/Tie/SubstrHash.pm b/lib/Tie/SubstrHash.pm index 3b92bd1cee..afe5d8dc25 100644 --- a/lib/Tie/SubstrHash.pm +++ b/lib/Tie/SubstrHash.pm @@ -186,19 +186,21 @@ sub ceil { sub findgteprime { # find the smallest prime integer greater than or equal to use integer; +# It may be sufficient (and more efficient, IF IT IS CORRECT) to use +# $max = 1 + int sqrt $num and calculate it once only, but is it correct? + my $num = ceil(shift); return 2 if $num <= 2; $num++ unless $num % 2; - my $max = int sqrt $num; - NUM: for (;; $num += 2) { - for ($i = 3; $i <= $max; $i += 2) { - next NUM unless $num % $i; - } - return $num; + my $max = int sqrt $num; + for ($i = 3; $i <= $max; $i += 2) { + next NUM unless $num % $i; + } + return $num; } } @@ -35,6 +35,10 @@ #define Perl_Gv_AMupdate pPerl->Perl_Gv_AMupdate #undef Gv_AMupdate #define Gv_AMupdate Perl_Gv_AMupdate +#undef Perl_gv_handler +#define Perl_gv_handler pPerl->Perl_gv_handler +#undef gv_handler +#define gv_handler Perl_gv_handler #undef Perl_apply_attrs_string #define Perl_apply_attrs_string pPerl->Perl_apply_attrs_string #undef apply_attrs_string @@ -2292,6 +2296,8 @@ #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) # if defined(DEBUGGING) # endif +# if !defined(NV_PRESERVES_UV) +# endif #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) #if 0 @@ -2249,13 +2249,11 @@ Perl_fold_constants(pTHX_ register OP *o) if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK && type != OP_NEGATE) { - IV iv = SvIV(sv); - if ((NV)iv == SvNV(sv)) { - SvREFCNT_dec(sv); - sv = newSViv(iv); - } - else - SvIOK_off(sv); /* undo SvIV() damage */ +#ifdef PERL_PRESERVE_IVUV + /* Only bother to attempt to fold to IV if + most operators will benefit */ + SvIV_please(sv); +#endif } return newSVOP(OP_CONST, 0, sv); } diff --git a/patchlevel.h b/patchlevel.h index 72652f5e64..46918d1e4d 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -70,7 +70,7 @@ #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT) static char *local_patches[] = { NULL - ,"DEVEL8101" + ,"DEVEL8132" ,NULL }; @@ -1084,6 +1084,11 @@ typedef UVTYPE UV; #define IV_DIG (BIT_DIGITS(IVSIZE * 8)) #define UV_DIG (BIT_DIGITS(UVSIZE * 8)) +/* We like our integers to stay integers. */ +#ifndef NO_PERL_PRESERVE_IVUV +#define PERL_PRESERVE_IVUV +#endif + /* * The macros INT2PTR and NUM2PTR are (despite their names) * bi-directional: they will convert int/float to or from pointers. @@ -3055,46 +3060,53 @@ enum { to_sv_amg, to_av_amg, to_hv_amg, to_gv_amg, to_cv_amg, iter_amg, - max_amg_code + DESTROY_amg, max_amg_code /* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */ }; #define NofAMmeth max_amg_code +#define AMG_id2name(id) ((char*)PL_AMG_names[id]+1) #ifdef DOINIT EXTCONST char * PL_AMG_names[NofAMmeth] = { - "fallback", "abs", /* "fallback" should be the first. */ - "bool", "nomethod", - "\"\"", "0+", - "+", "+=", - "-", "-=", - "*", "*=", - "/", "/=", - "%", "%=", - "**", "**=", - "<<", "<<=", - ">>", ">>=", - "&", "&=", - "|", "|=", - "^", "^=", - "<", "<=", - ">", ">=", - "==", "!=", - "<=>", "cmp", - "lt", "le", - "gt", "ge", - "eq", "ne", - "!", "~", - "++", "--", - "atan2", "cos", - "sin", "exp", - "log", "sqrt", - "x", "x=", - ".", ".=", - "=", "neg", - "${}", "@{}", - "%{}", "*{}", - "&{}", "<>", + /* Names kept in the symbol table. fallback => "()", the rest has + "(" prepended. The only other place in perl which knows about + this convention is AMG_id2name (used for debugging output and + 'nomethod' only), the only other place which has it hardwired is + overload.pm. */ + "()", "(abs", /* "fallback" should be the first. */ + "(bool", "(nomethod", + "(\"\"", "(0+", + "(+", "(+=", + "(-", "(-=", + "(*", "(*=", + "(/", "(/=", + "(%", "(%=", + "(**", "(**=", + "(<<", "(<<=", + "(>>", "(>>=", + "(&", "(&=", + "(|", "(|=", + "(^", "(^=", + "(<", "(<=", + "(>", "(>=", + "(==", "(!=", + "(<=>", "(cmp", + "(lt", "(le", + "(gt", "(ge", + "(eq", "(ne", + "(!", "(~", + "(++", "(--", + "(atan2", "(cos", + "(sin", "(exp", + "(log", "(sqrt", + "(x", "(x=", + "(.", "(.=", + "(=", "(neg", + "(${}", "(@{}", + "(%{}", "(*{}", + "(&{}", "(<>", + "DESTROY", }; #else EXTCONST char * PL_AMG_names[NofAMmeth]; @@ -3122,10 +3134,15 @@ typedef struct am_table_short AMTS; #define AMGfallYES 3 #define AMTf_AMAGIC 1 +#define AMTf_OVERLOADED 2 #define AMT_AMAGIC(amt) ((amt)->flags & AMTf_AMAGIC) #define AMT_AMAGIC_on(amt) ((amt)->flags |= AMTf_AMAGIC) #define AMT_AMAGIC_off(amt) ((amt)->flags &= ~AMTf_AMAGIC) +#define AMT_OVERLOADED(amt) ((amt)->flags & AMTf_OVERLOADED) +#define AMT_OVERLOADED_on(amt) ((amt)->flags |= AMTf_OVERLOADED) +#define AMT_OVERLOADED_off(amt) ((amt)->flags &= ~AMTf_OVERLOADED) +#define StashHANDLER(stash,meth) gv_handler((stash),CAT2(meth,_amg)) /* * some compilers like to redefine cos et alia as faster @@ -3235,6 +3252,9 @@ typedef struct am_table_short AMTS; # if !defined(Strtol) && defined(HAS_STRTOLL) # define Strtol strtoll # endif +# if !defined(Strtol) && defined(HAS_STRTOQ) +# define Strtol strtoq +# endif /* is there atoq() anywhere? */ #endif #if !defined(Strtol) && defined(HAS_STRTOL) diff --git a/pod/perlapi.pod b/pod/perlapi.pod index 3085084148..8041f68498 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -298,7 +298,7 @@ L<perlsub/"Constant Functions">. SV* cv_const_sv(CV* cv) =for hackers -Found in file op.c +Found in file opmini.c =item dMARK @@ -1178,7 +1178,7 @@ eligible for inlining at compile-time. CV* newCONSTSUB(HV* stash, char* name, SV* sv) =for hackers -Found in file op.c +Found in file opmini.c =item newHV @@ -1324,7 +1324,7 @@ Found in file sv.c Used by C<xsubpp> to hook up XSUBs as Perl subs. =for hackers -Found in file op.c +Found in file opmini.c =item newXSproto diff --git a/pod/perlfaq7.pod b/pod/perlfaq7.pod index 9e559f7d0e..0299c2d893 100644 --- a/pod/perlfaq7.pod +++ b/pod/perlfaq7.pod @@ -397,7 +397,7 @@ they'll still work properly under C<use strict 'refs'>. For example: If you're planning on generating new filehandles, you could do this: sub openit { - my $name = shift; + my $path = shift; local *FH; return open (FH, $path) ? *FH : undef; } diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 06d3b1da2d..ed3f2dc6a3 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -923,7 +923,10 @@ element to return happens to be C<undef>. You may also use C<defined(&func)> to check whether subroutine C<&func> has ever been defined. The return value is unaffected by any forward -declarations of C<&foo>. +declarations of C<&foo>. Note that a subroutine which is not defined +may still be callable: its package may have an C<AUTOLOAD> method that +makes it spring into existence the first time that it is called -- see +L<perlsub>. Use of C<defined> on aggregates (hashes and arrays) is deprecated. It used to report whether memory for that aggregate has ever been @@ -1479,7 +1482,10 @@ it exists, but the reverse doesn't necessarily hold true. Given an expression that specifies the name of a subroutine, returns true if the specified subroutine has ever been declared, even if it is undefined. Mentioning a subroutine name for exists or defined -does not count as declaring it. +does not count as declaring it. Note that a subroutine which does not +exist may still be callable: its package may have an C<AUTOLOAD> +method that makes it spring into existence the first time that it is +called -- see L<perlsub>. print "Exists\n" if exists &subroutine; print "Defined\n" if defined &subroutine; @@ -925,6 +925,114 @@ PP(pp_pow) PP(pp_multiply) { djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + /* 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. */ + /* Left operand is defined, so is it IV? */ + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + const UV topmask = (~ (UV)0) << (4 * sizeof (UV)); + const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV))); + UV alow; + UV ahigh; + UV blow; + UV bhigh; + + if (auvok) { + alow = SvUVX(TOPm1s); + } else { + IV aiv = SvIVX(TOPm1s); + if (aiv >= 0) { + alow = aiv; + auvok = TRUE; /* effectively it's a UV now */ + } else { + alow = -aiv; /* abs, auvok == false records sign */ + } + } + if (buvok) { + blow = SvUVX(TOPs); + } else { + IV biv = SvIVX(TOPs); + if (biv >= 0) { + blow = biv; + buvok = TRUE; /* effectively it's a UV now */ + } else { + blow = -biv; /* abs, buvok == false records sign */ + } + } + + /* If this does sign extension on unsigned it's time for plan B */ + ahigh = alow >> (4 * sizeof (UV)); + alow &= botmask; + bhigh = blow >> (4 * sizeof (UV)); + blow &= botmask; + if (ahigh && bhigh) { + /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000 + which is overflow. Drop to NVs below. */ + } else if (!ahigh && !bhigh) { + /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001 + so the unsigned multiply cannot overflow. */ + UV product = alow * blow; + if (auvok == buvok) { + /* -ve * -ve or +ve * +ve gives a +ve result. */ + SP--; + SETu( product ); + RETURN; + } else if (product <= (UV)IV_MIN) { + /* 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 { + /* One operand is large, 1 small */ + UV product_middle; + if (bhigh) { + /* swap the operands */ + ahigh = bhigh; + bhigh = blow; /* bhigh now the temp var for the swap */ + blow = alow; + alow = bhigh; + } + /* now, ((ahigh * blow) << half_UV_len) + (alow * blow) + multiplies can't overflow. shift can, add can, -ve can. */ + product_middle = ahigh * blow; + if (!(product_middle & topmask)) { + /* OK, (ahigh * blow) won't lose bits when we shift it. */ + UV product_low; + product_middle <<= (4 * sizeof (UV)); + product_low = alow * blow; + + /* as for pp_add, UV + something mustn't get smaller. + IIRC ANSI mandates this wrapping *behaviour* for + unsigned whatever the actual representation*/ + product_low += product_middle; + if (product_low >= product_middle) { + /* didn't overflow */ + if (auvok == buvok) { + /* -ve * -ve or +ve * +ve gives a +ve result. */ + SP--; + SETu( product_low ); + RETURN; + } else if (product_low <= (UV)IV_MIN) { + /* 2s complement assumption again */ + /* -ve result, which could overflow an IV */ + SP--; + SETi( -product_low ); + RETURN; + } /* else drop to NVs below. */ + } + } /* product_middle too large */ + } /* ahigh && bhigh */ + } /* SvIOK(TOPm1s) */ + } /* SvIOK(TOPs) */ +#endif { dPOPTOPnnrl; SETn( left * right ); @@ -1116,11 +1224,146 @@ PP(pp_repeat) PP(pp_subtract) { - djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); + djSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN); + useleft = USE_LEFT(TOPm1s); +#ifdef PERL_PRESERVE_IVUV + /* We must see if we can perform the addition with integers if possible, + as the integer code detects overflow while the NV code doesn't. + If either argument hasn't had a numeric conversion yet attempt to get + the IV. It's important to do this now, rather than just assuming that + it's not IOK as a PV of "9223372036854775806" may not take well to NV + addition, and an SV which is NOK, NV=6.0 ought to be coerced to + integer in case the second argument is IV=9223372036854775806 + We can (now) rely on sv_2iv to do the right thing, only setting the + public IOK flag if the value in the NV (or PV) slot is truly integer. + + A side effect is that this also aggressively prefers integer maths over + fp maths for integer values. */ + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + /* 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. */ + if (!useleft) { + /* left operand is undef, treat as zero. + 0 is identity. */ + if (SvUOK(TOPs)) { + dPOPuv; /* Scary macros. Lets put a sequence point (;) here */ + if (value <= (UV)IV_MIN) { + /* 2s complement assumption. */ + SETi(-(IV)value); + RETURN; + } /* else drop through into NVs below */ + } else { + dPOPiv; + SETu((UV)-value); + RETURN; + } + } else { + /* Left operand is defined, so is it IV? */ + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + + if (!auvok && !buvok) { /* ## IV - IV ## */ + IV aiv = SvIVX(TOPm1s); + IV biv = SvIVX(TOPs); + IV result = aiv - biv; + + if (biv >= 0 ? (result < aiv) : (result >= aiv)) { + SP--; + SETi( result ); + RETURN; + } + /* +ve - +ve can't overflow. (worst case 0 - IV_MAX) */ + /* -ve - -ve can't overflow. (worst case -1 - IV_MIN) */ + /* -ve - +ve can only overflow too negative. */ + /* leaving +ve - -ve, which will go UV */ + if (aiv >= 0 && biv < 0) { /* assert don't need biv <0 */ + /* 2s complement assumption for IV_MIN */ + UV result = (UV)aiv + (UV)-biv; + /* UV + UV must get bigger. +ve IV + +ve IV +1 can't + overflow UV (2s complement assumption */ + assert (result >= (UV) aiv); + SP--; + SETu( result ); + RETURN; + } + /* Overflow, drop through to NVs */ + } else if (auvok && buvok) { /* ## UV - UV ## */ + UV auv = SvUVX(TOPm1s); + UV buv = SvUVX(TOPs); + IV result; + + if (auv >= buv) { + SP--; + SETu( auv - buv ); + RETURN; + } + /* Blatant 2s complement assumption. */ + result = (IV)(auv - buv); + if (result < 0) { + SP--; + SETi( result ); + RETURN; + } + /* Overflow on IV - IV, drop through to NVs */ + } else if (auvok) { /* ## Mixed UV - IV ## */ + UV auv = SvUVX(TOPm1s); + IV biv = SvIVX(TOPs); + + if (biv < 0) { + /* 2s complement assumptions for IV_MIN */ + UV result = auv + ((UV)-biv); + /* UV + UV can only get bigger... */ + if (result >= auv) { + SP--; + SETu( result ); + RETURN; + } + /* and if it gets too big for UV then it's NV time. */ + } else if (auv > (UV)IV_MAX) { + /* I think I'm making an implicit 2s complement + assumption that IV_MIN == -IV_MAX - 1 */ + /* biv is >= 0 */ + UV result = auv - (UV)biv; + assert (result <= auv); + SP--; + SETu( result ); + RETURN; + } else { + /* biv is >= 0 */ + IV result = (IV)auv - biv; + assert (result <= (IV)auv); + SP--; + SETi( result ); + RETURN; + } + } else { /* ## Mixed IV - UV ## */ + IV aiv = SvIVX(TOPm1s); + UV buv = SvUVX(TOPs); + IV result = aiv - (IV)buv; /* 2s complement assumption. */ + + /* result must not get larger. */ + if (result <= aiv) { + SP--; + SETi( result ); + RETURN; + } /* end of IV-IV / UV-UV / UV-IV / IV-UV */ + } + } + } + } +#endif { - dPOPTOPnnrl_ul; - SETn( left - right ); - RETURN; + dPOPnv; + if (!useleft) { + /* left operand is undef, treat as zero - value */ + SETn(-value); + RETURN; + } + SETn( TOPn - value ); + RETURN; } } @@ -1161,6 +1404,74 @@ PP(pp_right_shift) PP(pp_lt) { djSP; tryAMAGICbinSET(lt,0); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + + if (!auvok && !buvok) { /* ## IV < IV ## */ + IV aiv = SvIVX(TOPm1s); + IV biv = SvIVX(TOPs); + + SP--; + SETs(boolSV(aiv < biv)); + RETURN; + } + if (auvok && buvok) { /* ## UV < UV ## */ + UV auv = SvUVX(TOPm1s); + UV buv = SvUVX(TOPs); + + SP--; + SETs(boolSV(auv < buv)); + RETURN; + } + if (auvok) { /* ## UV < IV ## */ + UV auv; + IV biv; + + biv = SvIVX(TOPs); + SP--; + if (biv < 0) { + /* As (a) is a UV, it's >=0, so it cannot be < */ + SETs(&PL_sv_no); + RETURN; + } + auv = SvUVX(TOPs); + if (auv >= (UV) IV_MAX) { + /* As (b) is an IV, it cannot be > IV_MAX */ + SETs(&PL_sv_no); + RETURN; + } + SETs(boolSV(auv < (UV)biv)); + RETURN; + } + { /* ## IV < UV ## */ + IV aiv; + UV buv; + + aiv = SvIVX(TOPm1s); + if (aiv < 0) { + /* As (b) is a UV, it's >=0, so it must be < */ + SP--; + SETs(&PL_sv_yes); + RETURN; + } + buv = SvUVX(TOPs); + SP--; + if (buv > (UV) IV_MAX) { + /* As (a) is an IV, it cannot be > IV_MAX */ + SETs(&PL_sv_yes); + RETURN; + } + SETs(boolSV((UV)aiv < buv)); + RETURN; + } + } + } +#endif { dPOPnv; SETs(boolSV(TOPn < value)); @@ -1171,6 +1482,74 @@ PP(pp_lt) PP(pp_gt) { djSP; tryAMAGICbinSET(gt,0); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + + if (!auvok && !buvok) { /* ## IV > IV ## */ + IV aiv = SvIVX(TOPm1s); + IV biv = SvIVX(TOPs); + + SP--; + SETs(boolSV(aiv > biv)); + RETURN; + } + if (auvok && buvok) { /* ## UV > UV ## */ + UV auv = SvUVX(TOPm1s); + UV buv = SvUVX(TOPs); + + SP--; + SETs(boolSV(auv > buv)); + RETURN; + } + if (auvok) { /* ## UV > IV ## */ + UV auv; + IV biv; + + biv = SvIVX(TOPs); + SP--; + if (biv < 0) { + /* As (a) is a UV, it's >=0, so it must be > */ + SETs(&PL_sv_yes); + RETURN; + } + auv = SvUVX(TOPs); + if (auv > (UV) IV_MAX) { + /* As (b) is an IV, it cannot be > IV_MAX */ + SETs(&PL_sv_yes); + RETURN; + } + SETs(boolSV(auv > (UV)biv)); + RETURN; + } + { /* ## IV > UV ## */ + IV aiv; + UV buv; + + aiv = SvIVX(TOPm1s); + if (aiv < 0) { + /* As (b) is a UV, it's >=0, so it cannot be > */ + SP--; + SETs(&PL_sv_no); + RETURN; + } + buv = SvUVX(TOPs); + SP--; + if (buv >= (UV) IV_MAX) { + /* As (a) is an IV, it cannot be > IV_MAX */ + SETs(&PL_sv_no); + RETURN; + } + SETs(boolSV((UV)aiv > buv)); + RETURN; + } + } + } +#endif { dPOPnv; SETs(boolSV(TOPn > value)); @@ -1181,6 +1560,74 @@ PP(pp_gt) PP(pp_le) { djSP; tryAMAGICbinSET(le,0); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + + if (!auvok && !buvok) { /* ## IV <= IV ## */ + IV aiv = SvIVX(TOPm1s); + IV biv = SvIVX(TOPs); + + SP--; + SETs(boolSV(aiv <= biv)); + RETURN; + } + if (auvok && buvok) { /* ## UV <= UV ## */ + UV auv = SvUVX(TOPm1s); + UV buv = SvUVX(TOPs); + + SP--; + SETs(boolSV(auv <= buv)); + RETURN; + } + if (auvok) { /* ## UV <= IV ## */ + UV auv; + IV biv; + + biv = SvIVX(TOPs); + SP--; + if (biv < 0) { + /* As (a) is a UV, it's >=0, so a cannot be <= */ + SETs(&PL_sv_no); + RETURN; + } + auv = SvUVX(TOPs); + if (auv > (UV) IV_MAX) { + /* As (b) is an IV, it cannot be > IV_MAX */ + SETs(&PL_sv_no); + RETURN; + } + SETs(boolSV(auv <= (UV)biv)); + RETURN; + } + { /* ## IV <= UV ## */ + IV aiv; + UV buv; + + aiv = SvIVX(TOPm1s); + if (aiv < 0) { + /* As (b) is a UV, it's >=0, so a must be <= */ + SP--; + SETs(&PL_sv_yes); + RETURN; + } + buv = SvUVX(TOPs); + SP--; + if (buv >= (UV) IV_MAX) { + /* As (a) is an IV, it cannot be > IV_MAX */ + SETs(&PL_sv_yes); + RETURN; + } + SETs(boolSV((UV)aiv <= buv)); + RETURN; + } + } + } +#endif { dPOPnv; SETs(boolSV(TOPn <= value)); @@ -1191,6 +1638,74 @@ PP(pp_le) PP(pp_ge) { djSP; tryAMAGICbinSET(ge,0); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + + if (!auvok && !buvok) { /* ## IV >= IV ## */ + IV aiv = SvIVX(TOPm1s); + IV biv = SvIVX(TOPs); + + SP--; + SETs(boolSV(aiv >= biv)); + RETURN; + } + if (auvok && buvok) { /* ## UV >= UV ## */ + UV auv = SvUVX(TOPm1s); + UV buv = SvUVX(TOPs); + + SP--; + SETs(boolSV(auv >= buv)); + RETURN; + } + if (auvok) { /* ## UV >= IV ## */ + UV auv; + IV biv; + + biv = SvIVX(TOPs); + SP--; + if (biv < 0) { + /* As (a) is a UV, it's >=0, so it must be >= */ + SETs(&PL_sv_yes); + RETURN; + } + auv = SvUVX(TOPs); + if (auv >= (UV) IV_MAX) { + /* As (b) is an IV, it cannot be > IV_MAX */ + SETs(&PL_sv_yes); + RETURN; + } + SETs(boolSV(auv >= (UV)biv)); + RETURN; + } + { /* ## IV >= UV ## */ + IV aiv; + UV buv; + + aiv = SvIVX(TOPm1s); + if (aiv < 0) { + /* As (b) is a UV, it's >=0, so a cannot be >= */ + SP--; + SETs(&PL_sv_no); + RETURN; + } + buv = SvUVX(TOPs); + SP--; + if (buv > (UV) IV_MAX) { + /* As (a) is an IV, it cannot be > IV_MAX */ + SETs(&PL_sv_no); + RETURN; + } + SETs(boolSV((UV)aiv >= buv)); + RETURN; + } + } + } +#endif { dPOPnv; SETs(boolSV(TOPn >= value)); @@ -1201,6 +1716,66 @@ PP(pp_ge) PP(pp_ne) { djSP; tryAMAGICbinSET(ne,0); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + + if (!auvok && !buvok) { /* ## IV <=> IV ## */ + IV aiv = SvIVX(TOPm1s); + IV biv = SvIVX(TOPs); + + SP--; + SETs(boolSV(aiv != biv)); + RETURN; + } + if (auvok && buvok) { /* ## UV != UV ## */ + UV auv = SvUVX(TOPm1s); + UV buv = SvUVX(TOPs); + + SP--; + SETs(boolSV(auv != buv)); + RETURN; + } + { /* ## Mixed IV,UV ## */ + IV iv; + UV uv; + + /* != is commutative so swap if needed (save code) */ + if (auvok) { + /* swap. top of stack (b) is the iv */ + iv = SvIVX(TOPs); + SP--; + if (iv < 0) { + /* As (a) is a UV, it's >0, so it cannot be == */ + SETs(&PL_sv_yes); + RETURN; + } + uv = SvUVX(TOPs); + } else { + iv = SvIVX(TOPm1s); + SP--; + if (iv < 0) { + /* As (b) is a UV, it's >0, so it cannot be == */ + SETs(&PL_sv_yes); + RETURN; + } + uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */ + } + /* we know iv is >= 0 */ + if (uv > (UV) IV_MAX) { + SETs(&PL_sv_yes); + RETURN; + } + SETs(boolSV((UV)iv != uv)); + RETURN; + } + } + } +#endif { dPOPnv; SETs(boolSV(TOPn != value)); @@ -1211,6 +1786,84 @@ PP(pp_ne) PP(pp_ncmp) { djSP; dTARGET; tryAMAGICbin(ncmp,0); +#ifdef PERL_PRESERVE_IVUV + /* Fortunately it seems NaN isn't IOK */ + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool leftuvok = SvUOK(TOPm1s); + bool rightuvok = SvUOK(TOPs); + I32 value; + if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */ + IV leftiv = SvIVX(TOPm1s); + IV rightiv = SvIVX(TOPs); + + if (leftiv > rightiv) + value = 1; + else if (leftiv < rightiv) + value = -1; + else + value = 0; + } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */ + UV leftuv = SvUVX(TOPm1s); + UV rightuv = SvUVX(TOPs); + + if (leftuv > rightuv) + value = 1; + else if (leftuv < rightuv) + value = -1; + else + value = 0; + } else if (leftuvok) { /* ## UV <=> IV ## */ + UV leftuv; + IV rightiv; + + rightiv = SvIVX(TOPs); + if (rightiv < 0) { + /* As (a) is a UV, it's >=0, so it cannot be < */ + value = 1; + } else { + leftuv = SvUVX(TOPm1s); + if (leftuv > (UV) IV_MAX) { + /* As (b) is an IV, it cannot be > IV_MAX */ + value = 1; + } else if (leftuv > (UV)rightiv) { + value = 1; + } else if (leftuv < (UV)rightiv) { + value = -1; + } else { + value = 0; + } + } + } else { /* ## IV <=> UV ## */ + IV leftiv; + UV rightuv; + + leftiv = SvIVX(TOPm1s); + if (leftiv < 0) { + /* As (b) is a UV, it's >=0, so it must be < */ + value = -1; + } else { + rightuv = SvUVX(TOPs); + if (rightuv > (UV) IV_MAX) { + /* As (a) is an IV, it cannot be > IV_MAX */ + value = -1; + } else if (leftiv > (UV)rightuv) { + value = 1; + } else if (leftiv < (UV)rightuv) { + value = -1; + } else { + value = 0; + } + } + } + SP--; + SETi(value); + RETURN; + } + } +#endif { dPOPTOPnnrl; I32 value; @@ -1397,11 +2050,15 @@ PP(pp_negate) djSP; dTARGET; tryAMAGICun(neg); { dTOPss; + int flags = SvFLAGS(sv); if (SvGMAGICAL(sv)) mg_get(sv); - if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) { + if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { + /* It's publicly an integer, or privately an integer-not-float */ + oops_its_an_int: if (SvIsUV(sv)) { if (SvIVX(sv) == IV_MIN) { + /* 2s complement assumption. */ SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */ RETURN; } @@ -1414,6 +2071,12 @@ PP(pp_negate) SETi(-SvIVX(sv)); RETURN; } +#ifdef PERL_PRESERVE_IVUV + else { + SETu((UV)IV_MIN); + RETURN; + } +#endif } if (SvNIOKp(sv)) SETn(-SvNV(sv)); @@ -1432,8 +2095,12 @@ PP(pp_negate) sv_setpvn(TARG, "-", 1); sv_catsv(TARG, sv); } - else - sv_setnv(TARG, -SvNV(sv)); + else { + SvIV_please(sv); + if (SvIOK(sv)) + goto oops_its_an_int; + sv_setnv(TARG, -SvNV(sv)); + } SETTARG; } else @@ -1896,38 +2563,49 @@ PP(pp_int) { djSP; dTARGET; { - NV value = TOPn; - IV iv; - - if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) { - iv = SvIVX(TOPs); - SETi(iv); - } - else { + NV value; + IV iv = TOPi; /* attempt to convert to IV if possible. */ + /* XXX it's arguable that compiler casting to IV might be subtly + different from modf (for numbers inside (IV_MIN,UV_MAX)) in which + else preferring IV has introduced a subtle behaviour change bug. OTOH + relying on floating point to be accurate is a bug. */ + + if (SvIOK(TOPs)) { + if (SvIsUV(TOPs)) { + UV uv = TOPu; + SETu(uv); + } else + SETi(iv); + } else { + value = TOPn; if (value >= 0.0) { + if (value < (NV)UV_MAX + 0.5) { + SETu(U_V(value)); + } else { #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE) - (void)Perl_modf(value, &value); + (void)Perl_modf(value, &value); #else - double tmp = (double)value; - (void)Perl_modf(tmp, &tmp); - value = (NV)tmp; + double tmp = (double)value; + (void)Perl_modf(tmp, &tmp); + value = (NV)tmp; #endif + } } - else { + else { + if (value > (NV)IV_MIN - 0.5) { + SETi(I_V(value)); + } else { #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE) - (void)Perl_modf(-value, &value); - value = -value; + (void)Perl_modf(-value, &value); + value = -value; #else - double tmp = (double)value; - (void)Perl_modf(-tmp, &tmp); - value = -(NV)tmp; + double tmp = (double)value; + (void)Perl_modf(-tmp, &tmp); + value = -(NV)tmp; #endif - } - iv = I_V(value); - if (iv == value) - SETi(iv); - else - SETn(value); + SETn(value); + } + } } } RETURN; @@ -1937,18 +2615,30 @@ PP(pp_abs) { djSP; dTARGET; tryAMAGICun(abs); { - NV value = TOPn; - IV iv; - - if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) && - (iv = SvIVX(TOPs)) != IV_MIN) { - if (iv < 0) - iv = -iv; - SETi(iv); - } - else { + /* This will cache the NV value if string isn't actually integer */ + IV iv = TOPi; + + if (SvIOK(TOPs)) { + /* IVX is precise */ + if (SvIsUV(TOPs)) { + SETu(TOPu); /* force it to be numeric only */ + } else { + if (iv >= 0) { + SETi(iv); + } else { + if (iv != IV_MIN) { + SETi(-iv); + } else { + /* 2s complement assumption. Also, not really needed as + IV_MIN and -IV_MIN should both be %100...00 and NV-able */ + SETu(IV_MIN); + } + } + } + } else{ + NV value = TOPn; if (value < 0.0) - value = -value; + value = -value; SETn(value); } } @@ -279,6 +279,69 @@ PP(pp_readline) PP(pp_eq) { djSP; tryAMAGICbinSET(eq,0); +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + /* 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. */ + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + + if (!auvok && !buvok) { /* ## IV == IV ## */ + IV aiv = SvIVX(TOPm1s); + IV biv = SvIVX(TOPs); + + SP--; + SETs(boolSV(aiv == biv)); + RETURN; + } + if (auvok && buvok) { /* ## UV == UV ## */ + UV auv = SvUVX(TOPm1s); + UV buv = SvUVX(TOPs); + + SP--; + SETs(boolSV(auv == buv)); + RETURN; + } + { /* ## Mixed IV,UV ## */ + IV iv; + UV uv; + + /* == is commutative so swap if needed (save code) */ + if (auvok) { + /* swap. top of stack (b) is the iv */ + iv = SvIVX(TOPs); + SP--; + if (iv < 0) { + /* As (a) is a UV, it's >0, so it cannot be == */ + SETs(&PL_sv_no); + RETURN; + } + uv = SvUVX(TOPs); + } else { + iv = SvIVX(TOPm1s); + SP--; + if (iv < 0) { + /* As (b) is a UV, it's >0, so it cannot be == */ + SETs(&PL_sv_no); + RETURN; + } + uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */ + } + /* we know iv is >= 0 */ + if (uv > (UV) IV_MAX) { + SETs(&PL_sv_no); + RETURN; + } + SETs(boolSV((UV)iv == uv)); + RETURN; + } + } + } +#endif { dPOPnv; SETs(boolSV(TOPn == value)); @@ -297,7 +360,7 @@ PP(pp_preinc) ++SvIVX(TOPs); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } - else + else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */ sv_inc(TOPs); SvSETMAGIC(TOPs); return NORMAL; @@ -316,11 +379,125 @@ PP(pp_or) PP(pp_add) { - djSP; dATARGET; tryAMAGICbin(add,opASSIGN); + djSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN); + useleft = USE_LEFT(TOPm1s); +#ifdef PERL_PRESERVE_IVUV + /* We must see if we can perform the addition with integers if possible, + as the integer code detects overflow while the NV code doesn't. + If either argument hasn't had a numeric conversion yet attempt to get + the IV. It's important to do this now, rather than just assuming that + it's not IOK as a PV of "9223372036854775806" may not take well to NV + addition, and an SV which is NOK, NV=6.0 ought to be coerced to + integer in case the second argument is IV=9223372036854775806 + We can (now) rely on sv_2iv to do the right thing, only setting the + public IOK flag if the value in the NV (or PV) slot is truly integer. + + A side effect is that this also aggressively prefers integer maths over + fp maths for integer values. */ + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + /* 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. */ + if (!useleft) { + /* left operand is undef, treat as zero. + 0 is identity. */ + if (SvUOK(TOPs)) { + dPOPuv; /* Scary macros. Lets put a sequence point (;) here */ + SETu(value); + RETURN; + } else { + dPOPiv; + SETi(value); + RETURN; + } + } + /* Left operand is defined, so is it IV? */ + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + + if (!auvok && !buvok) { /* ## IV + IV ## */ + IV aiv = SvIVX(TOPm1s); + IV biv = SvIVX(TOPs); + IV result = aiv + biv; + + if (biv >= 0 ? (result >= aiv) : (result < aiv)) { + SP--; + SETi( result ); + RETURN; + } + if (biv >=0 && aiv >= 0) { + UV result = (UV)aiv + (UV)biv; + /* UV + UV can only get bigger... */ + if (result >= (UV) aiv) { + SP--; + SETu( result ); + RETURN; + } + } + /* Overflow, drop through to NVs (beyond next if () else ) */ + } else if (auvok && buvok) { /* ## UV + UV ## */ + UV auv = SvUVX(TOPm1s); + UV buv = SvUVX(TOPs); + UV result = auv + buv; + if (result >= auv) { + SP--; + SETu( result ); + RETURN; + } + /* Overflow, drop through to NVs (beyond next if () else ) */ + } else { /* ## Mixed IV,UV ## */ + IV aiv; + UV buv; + + /* addition is commutative so swap if needed (save code) */ + if (buvok) { + aiv = SvIVX(TOPm1s); + buv = SvUVX(TOPs); + } else { + aiv = SvIVX(TOPs); + buv = SvUVX(TOPm1s); + } + + if (aiv >= 0) { + UV result = (UV)aiv + buv; + if (result >= buv) { + SP--; + SETu( result ); + RETURN; + } + } else if (buv > (UV) IV_MAX) { + /* assuming 2s complement means that IV_MIN == -IV_MIN, + and (UV)-IV_MIN *is* the value -IV_MIN (or IV_MAX + 1) + as buv > IV_MAX, it is >= (IV_MAX + 1), and therefore + as the value we can be subtracting from it only lies in + the range (-IV_MIN to -1) it can't overflow a UV */ + SP--; + SETu( buv - (UV)-aiv ); + RETURN; + } else { + IV result = (IV) buv + aiv; + /* aiv < 0 so it must get smaller. */ + if (result < (IV) buv) { + SP--; + SETi( result ); + RETURN; + } + } + } /* end of IV+IV / UV+UV / mixed */ + } + } +#endif { - dPOPTOPnnrl_ul; - SETn( left + right ); - RETURN; + dPOPnv; + if (!useleft) { + /* left operand is undef, treat as zero. + 0.0 is identity. */ + SETn(value); + RETURN; + } + SETn( value + TOPn ); + RETURN; } } @@ -58,6 +58,7 @@ START_EXTERN_C # include "pp_proto.h" PERL_CALLCONV SV* Perl_amagic_call(pTHX_ SV* left, SV* right, int method, int dir); PERL_CALLCONV bool Perl_Gv_AMupdate(pTHX_ HV* stash); +PERL_CALLCONV CV* Perl_gv_handler(pTHX_ HV* stash, I32 id); PERL_CALLCONV OP* Perl_append_elem(pTHX_ I32 optype, OP* head, OP* tail); PERL_CALLCONV OP* Perl_append_list(pTHX_ I32 optype, LISTOP* first, LISTOP* last); PERL_CALLCONV I32 Perl_apply(pTHX_ I32 type, SV** mark, SV** sp); @@ -1207,6 +1208,10 @@ 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 #endif #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT) @@ -1320,6 +1320,10 @@ See C<sv_setuv_mg>. void Perl_sv_setuv(pTHX_ register SV *sv, UV u) { + if (u <= (UV)IV_MAX) { + sv_setiv(sv, (IV)u); + return; + } sv_setiv(sv, 0); SvIsUV_on(sv); SvUVX(sv) = u; @@ -1336,7 +1340,13 @@ Like C<sv_setuv>, but also handles 'set' magic. void Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) { - sv_setuv(sv,u); + if (u <= (UV)IV_MAX) { + sv_setiv(sv, (IV)u); + } else { + sv_setiv(sv, 0); + SvIsUV_on(sv); + sv_setuv(sv,u); + } SvSETMAGIC(sv); } @@ -1449,16 +1459,220 @@ S_not_a_number(pTHX_ SV *sv) "Argument \"%s\" isn't numeric", tmpbuf); } -/* the number can be converted to integer with atol() or atoll() */ -#define IS_NUMBER_TO_INT_BY_ATOL 0x01 -#define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */ -#define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */ -#define IS_NUMBER_NEG 0x08 /* not good to cache UV */ -#define IS_NUMBER_INFINITY 0x10 /* this is big */ +/* 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 + lossy conversion chains. (lossless conversion chains are perfectly + acceptable (still)) + + + flags are used: + SvIOKp is true if the IV slot contains a valid value + SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true) + SvNOKp is true if the NV slot contains a valid value + 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" + 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=%X\n", SvPVX(sv), SvIVX(sv), nv, 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=%X\n", SvPVX(sv), SvIVX(sv), nv, nv_as_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=%X\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), numtype)); + if (SvNVX(sv) < (NV)IV_MIN) { + (void)SvIOKp_on(sv); + (void)SvNOK_on(sv); + SvIVX(sv) = IV_MIN; + return IS_NUMBER_UNDERFLOW_IV; + } + if (SvNVX(sv) > (NV)UV_MAX) { + (void)SvIOKp_on(sv); + (void)SvNOK_on(sv); + SvIsUV_on(sv); + 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)) { + 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 (sv, numtype); +} +#endif /* NV_PRESERVES_UV*/ + + IV Perl_sv_2iv(pTHX_ register SV *sv) { @@ -1507,19 +1721,71 @@ Perl_sv_2iv(pTHX_ register SV *sv) } } if (SvNOKp(sv)) { - /* We can cache the IV/UV value even if it not good enough - * to reconstruct NV, since the conversion to PV will prefer - * NV over IV/UV. - */ + /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv + * without also getting a cached IV/UV from it at the same time + * (ie PV->NV conversion should detect loss of accuracy and cache + * IV or UV at same time to avoid this. NWC */ if (SvTYPE(sv) == SVt_NV) sv_upgrade(sv, SVt_PVNV); - (void)SvIOK_on(sv); - if (SvNVX(sv) < (NV)IV_MAX + 0.5) + (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ + /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost + certainly cast into the IV range at IV_MAX, whereas the correct + answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary + cases go to UV */ + if (SvNVX(sv) < (NV)IV_MAX + 0.5) { SvIVX(sv) = I_V(SvNVX(sv)); + if (SvNVX(sv) == (NV) SvIVX(sv) +#ifndef NV_PRESERVES_UV + && (((UV)1 << NV_PRESERVES_UV_BITS) > + (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) + /* Don't flag it as "accurately an integer" if the number + came from a (by definition imprecise) NV operation, and + we're outside the range of NV integer precision */ +#endif + ) { + SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%"UVxf" iv(%g => %"IVdf") (precise)\n", + PTR2UV(sv), + SvNVX(sv), + SvIVX(sv))); + + } else { + /* IV not precise. No need to convert from PV, as NV + conversion would already have cached IV if it detected + that PV->IV would be better than PV->NV->IV + flags already correct - don't set public IOK. */ + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n", + PTR2UV(sv), + SvNVX(sv), + SvIVX(sv))); + } + /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN, + but the cast (NV)IV_MIN rounds to a the value less (more + negative) than IV_MIN which happens to be equal to SvNVX ?? + Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and + NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and + (NV)UVX == NVX are both true, but the values differ. :-( + Hopefully for 2s complement IV_MIN is something like + 0x8000000000000000 which will be exact. NWC */ + } else { SvUVX(sv) = U_V(SvNVX(sv)); + if ( + (SvNVX(sv) == (NV) SvUVX(sv)) +#ifndef NV_PRESERVES_UV + /* Make sure it's not 0xFFFFFFFFFFFFFFFF */ + /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */ + && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv)) + /* Don't flag it as "accurately an integer" if the number + came from a (by definition imprecise) NV operation, and + we're outside the range of NV integer precision */ +#endif + ) + SvIOK_on(sv); SvIsUV_on(sv); ret_iv_max: DEBUG_c(PerlIO_printf(Perl_debug_log, @@ -1539,46 +1805,117 @@ Perl_sv_2iv(pTHX_ register SV *sv) 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 - cache the NV if not needed. + cache the NV if we are sure it's not needed. */ - if (numtype & IS_NUMBER_NOT_IV) { - /* May be not an integer. Need to cache NV if we cache IV - * - otherwise future conversion to NV will be wrong. */ - NV d; - - d = Atof(SvPVX(sv)); - if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); - SvNVX(sv) = d; - (void)SvNOK_on(sv); + 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" 2nv(%" PERL_PRIgldbl ")\n", - PTR2UV(sv), SvNVX(sv))); + 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" 2nv(%g)\n", - PTR2UV(sv), SvNVX(sv))); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n", + PTR2UV(sv), SvNVX(sv))); #endif - if (SvNVX(sv) < (NV)IV_MAX + 0.5) - SvIVX(sv) = I_V(SvNVX(sv)); - else { - SvUVX(sv) = U_V(SvNVX(sv)); - SvIsUV_on(sv); - goto ret_iv_max; + + +#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 { /* 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)); - if (! numtype && ckWARN(WARN_NUMERIC)) - not_a_number(sv); - } - } - else { + } else { if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) report_uninit(); if (SvTYPE(sv) < SVt_IV) @@ -1638,26 +1975,74 @@ Perl_sv_2uv(pTHX_ register SV *sv) } } if (SvNOKp(sv)) { - /* We can cache the IV/UV value even if it not good enough - * to reconstruct NV, since the conversion to PV will prefer - * NV over IV/UV. - */ + /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv + * without also getting a cached IV/UV from it at the same time + * (ie PV->NV conversion should detect loss of accuracy and cache + * IV or UV at same time to avoid this. */ + /* IV-over-UV optimisation - choose to cache IV if possible */ + if (SvTYPE(sv) == SVt_NV) sv_upgrade(sv, SVt_PVNV); - (void)SvIOK_on(sv); - if (SvNVX(sv) >= -0.5) { - SvIsUV_on(sv); - SvUVX(sv) = U_V(SvNVX(sv)); - } - else { + + (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ + if (SvNVX(sv) < (NV)IV_MAX + 0.5) { SvIVX(sv) = I_V(SvNVX(sv)); - ret_zero: + if (SvNVX(sv) == (NV) SvIVX(sv) +#ifndef NV_PRESERVES_UV + && (((UV)1 << NV_PRESERVES_UV_BITS) > + (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) + /* Don't flag it as "accurately an integer" if the number + came from a (by definition imprecise) NV operation, and + we're outside the range of NV integer precision */ +#endif + ) { + SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%"UVxf" uv(%g => %"IVdf") (precise)\n", + PTR2UV(sv), + SvNVX(sv), + SvIVX(sv))); + + } else { + /* IV not precise. No need to convert from PV, as NV + conversion would already have cached IV if it detected + that PV->IV would be better than PV->NV->IV + flags already correct - don't set public IOK. */ + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n", + PTR2UV(sv), + SvNVX(sv), + SvIVX(sv))); + } + /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN, + but the cast (NV)IV_MIN rounds to a the value less (more + negative) than IV_MIN which happens to be equal to SvNVX ?? + Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and + NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and + (NV)UVX == NVX are both true, but the values differ. :-( + Hopefully for 2s complement IV_MIN is something like + 0x8000000000000000 which will be exact. NWC */ + } + else { + SvUVX(sv) = U_V(SvNVX(sv)); + if ( + (SvNVX(sv) == (NV) SvUVX(sv)) +#ifndef NV_PRESERVES_UV + /* Make sure it's not 0xFFFFFFFFFFFFFFFF */ + /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */ + && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv)) + /* Don't flag it as "accurately an integer" if the number + came from a (by definition imprecise) NV operation, and + we're outside the range of NV integer precision */ +#endif + ) + SvIOK_on(sv); + SvIsUV_on(sv); DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n", + "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n", PTR2UV(sv), - SvIVX(sv), - (IV)(UV)SvIVX(sv))); - return (UV)SvIVX(sv); + SvUVX(sv), + SvUVX(sv))); } } else if (SvPOKp(sv) && SvLEN(sv)) { @@ -1671,66 +2056,137 @@ Perl_sv_2uv(pTHX_ register SV *sv) NV as well. Moreover, we trade speed for space, and do not cache the NV if not needed. */ - if (numtype & IS_NUMBER_NOT_IV) { - /* May be not an integer. Need to cache NV if we cache IV - * - otherwise future conversion to NV will be wrong. */ - NV d; - d = Atof(SvPVX(sv)); - - if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); - SvNVX(sv) = d; - (void)SvNOK_on(sv); - (void)SvIOK_on(sv); -#if defined(USE_LONG_DOUBLE) - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", - PTR2UV(sv), SvNVX(sv))); -#else - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" 2nv(%g)\n", - PTR2UV(sv), SvNVX(sv))); -#endif - if (SvNVX(sv) < -0.5) { - SvIVX(sv) = I_V(SvNVX(sv)); - goto ret_zero; - } else { - SvUVX(sv) = U_V(SvNVX(sv)); - SvIsUV_on(sv); - } - } - else if (numtype & IS_NUMBER_NEG) { + 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_PV) - sv_upgrade(sv, SVt_PVIV); - (void)SvIOK_on(sv); - SvIVX(sv) = (IV)Atol(SvPVX(sv)); - } - else if (numtype) { /* Non-negative */ - /* The NV may be reconstructed from UV - safe to cache UV, - which may be calculated by strtoul()/atol. */ - if (SvTYPE(sv) == SVt_PV) + which may be calculated by atol(). */ + if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); (void)SvIOK_on(sv); - (void)SvIsUV_on(sv); + SvIVX(sv) = Atol(SvPVX(sv)); + } else { #ifdef HAS_STRTOUL - SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10); -#else /* no atou(), but we know the number fits into IV... */ - /* The only problem may be if it is negative... */ - SvUVX(sv) = (UV)Atol(SvPVX(sv)); + 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 - } - else { /* Not a number. Cache 0. */ - if (SvTYPE(sv) < SVt_PVIV) - sv_upgrade(sv, SVt_PVIV); - (void)SvIOK_on(sv); - (void)SvIsUV_on(sv); - SvUVX(sv) = 0; /* We assume that 0s have the - same bitmap in IV and UV. */ - if (ckWARN(WARN_NUMERIC)) - not_a_number(sv); + { + 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 { @@ -1822,21 +2278,63 @@ Perl_sv_2nv(pTHX_ register SV *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); +#else + /* Only set the public NV OK flag if this NV preserves the IV */ + /* Check it's not 0xFFFFFFFFFFFFFFFF */ + if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) + : (SvIVX(sv) == I_V(SvNVX(sv)))) + SvNOK_on(sv); + else + SvNOKp_on(sv); +#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. */ + /* if that shift count is out of range then Configure's test is + 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 { if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) report_uninit(); if (SvTYPE(sv) < SVt_NV) /* Typically the caller expects that sv_any is not NULL now. */ + /* XXX Ilya implies that this is a bug in callers that assume this + and ideally should be fixed. */ sv_upgrade(sv, SVt_NV); return 0.0; } - SvNOK_on(sv); #if defined(USE_LONG_DOUBLE) DEBUG_c({ STORE_NUMERIC_LOCAL_SET_STANDARD(); @@ -1889,23 +2387,32 @@ S_asUV(pTHX_ SV *sv) /* * Returns a combination of (advisory only - can get false negatives) - * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV, - * IS_NUMBER_NEG + * 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. * - * In fact possible values are 0 and - * IS_NUMBER_TO_INT_BY_ATOL 123 - * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1 - * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0 + * (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 - * with a possible addition of IS_NUMBER_NEG. */ /* =for apidoc looks_like_number Test if an the content of an SV looks like a number (or is a -number). +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 */ @@ -1943,9 +2450,10 @@ Perl_looks_like_number(pTHX_ SV *sv) nbegin = s; /* - * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted - * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need - * (int)atof(). + * 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 */ @@ -1954,10 +2462,34 @@ Perl_looks_like_number(pTHX_ SV *sv) s++; } while (isDIGIT(*s)); - if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */ - numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV; - else + /* 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 @@ -1965,7 +2497,7 @@ Perl_looks_like_number(pTHX_ SV *sv) #endif ) { s++; - numtype |= IS_NUMBER_NOT_IV; + numtype |= IS_NUMBER_NOT_INT; while (isDIGIT(*s)) /* optional digits after the radix */ s++; } @@ -1976,7 +2508,7 @@ Perl_looks_like_number(pTHX_ SV *sv) #endif ) { s++; - numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV; + 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 { @@ -2002,12 +2534,13 @@ Perl_looks_like_number(pTHX_ SV *sv) return 0; if (sawinf) - numtype = IS_NUMBER_INFINITY; + 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_IV; + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT; s++; if (*s == '+' || *s == '-') s++; @@ -2198,15 +2731,33 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) return ""; } } - if (SvPOK(sv)) { - *lp = SvCUR(sv); - return SvPVX(sv); + if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) { + /* I'm assuming that if both IV and NV are equally valid then + converting the IV is going to be more efficient */ + U32 isIOK = SvIOK(sv); + U32 isUIOK = SvIsUV(sv); + char buf[TYPE_CHARS(UV)]; + char *ebuf, *ptr; + + if (SvTYPE(sv) < SVt_PVIV) + sv_upgrade(sv, SVt_PVIV); + if (isUIOK) + ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf); + else + ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf); + SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */ + Move(ptr,SvPVX(sv),ebuf - ptr,char); + SvCUR_set(sv, ebuf - ptr); + s = SvEND(sv); + *s = '\0'; + if (isIOK) + SvIOK_on(sv); + else + SvIOKp_on(sv); + if (isUIOK) + SvIsUV_on(sv); } - else if (SvNOKp(sv)) { /* See note in sv_2uv() */ - /* XXXX 64-bit? IV may have better precision... */ - /* I tried changing this to be 64-bit-aware and - * the t/op/numconvert.t became very, very, angry. - * --jhi Sep 1999 */ + else if (SvNOKp(sv)) { if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); /* The +20 is pure guesswork. Configure test needed. --jhi */ @@ -2232,31 +2783,6 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) *--s = '\0'; #endif } - else if (SvIOKp(sv)) { - U32 isIOK = SvIOK(sv); - U32 isUIOK = SvIsUV(sv); - char buf[TYPE_CHARS(UV)]; - char *ebuf, *ptr; - - if (SvTYPE(sv) < SVt_PVIV) - sv_upgrade(sv, SVt_PVIV); - if (isUIOK) - ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf); - else - ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf); - SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */ - Move(ptr,SvPVX(sv),ebuf - ptr,char); - SvCUR_set(sv, ebuf - ptr); - s = SvEND(sv); - *s = '\0'; - if (isIOK) - SvIOK_on(sv); - else - SvIOKp_on(sv); - if (isUIOK) - SvIsUV_on(sv); - SvPOK_on(sv); - } else { if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) @@ -3721,7 +4247,7 @@ Perl_sv_clear(pTHX_ register SV *sv) if (SvOBJECT(sv)) { if (PL_defstash) { /* Still have a symbol table? */ djSP; - GV* destructor; + CV* destructor; SV tmpref; Zero(&tmpref, 1, SV); @@ -3730,9 +4256,9 @@ Perl_sv_clear(pTHX_ register SV *sv) SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */ SvREFCNT(&tmpref) = 1; - do { + do { stash = SvSTASH(sv); - destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); + destructor = StashHANDLER(stash,DESTROY); if (destructor) { ENTER; PUSHSTACKi(PERLSI_DESTROY); @@ -3741,8 +4267,7 @@ Perl_sv_clear(pTHX_ register SV *sv) PUSHMARK(SP); PUSHs(&tmpref); PUTBACK; - call_sv((SV*)GvCV(destructor), - G_DISCARD|G_EVAL|G_KEEPERR); + call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR); SvREFCNT(sv)--; POPSTACK; SPAGAIN; @@ -4637,12 +5162,15 @@ Perl_sv_inc(pTHX_ register SV *sv) } } flags = SvFLAGS(sv); - if (flags & SVp_NOK) { - (void)SvNOK_only(sv); - SvNVX(sv) += 1.0; - return; - } - if (flags & SVp_IOK) { + if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) { + /* It's (privately or publicly) a float, but not tested as an + integer, so test it to see. */ + (void) SvIV(sv); + flags = SvFLAGS(sv); + } + if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { + /* It's publicly an integer, or privately an integer-not-float */ + oops_its_int: if (SvIsUV(sv)) { if (SvUVX(sv) == UV_MAX) sv_setnv(sv, (NV)UV_MAX + 1.0); @@ -4651,7 +5179,7 @@ Perl_sv_inc(pTHX_ register SV *sv) ++SvUVX(sv); } else { if (SvIVX(sv) == IV_MAX) - sv_setnv(sv, (NV)IV_MAX + 1.0); + sv_setuv(sv, (UV)IV_MAX + 1); else { (void)SvIOK_only(sv); ++SvIVX(sv); @@ -4659,18 +5187,59 @@ Perl_sv_inc(pTHX_ register SV *sv) } return; } + if (flags & SVp_NOK) { + (void)SvNOK_only(sv); + SvNVX(sv) += 1.0; + return; + } + if (!(flags & SVp_POK) || !*SvPVX(sv)) { - if ((flags & SVTYPEMASK) < SVt_PVNV) - sv_upgrade(sv, SVt_IV); - (void)SvIOK_only(sv); - SvIVX(sv) = 1; + if ((flags & SVTYPEMASK) < SVt_PVIV) + sv_upgrade(sv, SVt_IV); + (void)SvIOK_only(sv); + SvIVX(sv) = 1; return; } d = SvPVX(sv); while (isALPHA(*d)) d++; while (isDIGIT(*d)) d++; if (*d) { - sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */ +#ifdef PERL_PRESERVE_IVUV + /* 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. + but "9.22337203685478e+18" + 0 is UV=9223372036854779904 + so $a="9.22337203685478e+18"; $a+0; $a++ + needs to be the same as $a="9.22337203685478e+18"; $a++ + or we go insane. */ + + (void) sv_2iv(sv); + if (SvIOK(sv)) + goto oops_its_int; + + /* sv_2iv *should* have made this an NV */ + if (flags & SVp_NOK) { + (void)SvNOK_only(sv); + SvNVX(sv) += 1.0; + return; + } + /* I don't think we can get here. Maybe I should assert this + And if we do get here I suspect that sv_setnv will croak. NWC + Fall through. */ +#if defined(USE_LONG_DOUBLE) + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", + SvPVX(sv), SvIVX(sv), SvNVX(sv))); +#else + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n", + SvPVX(sv), SvIVX(sv), SvNVX(sv))); +#endif + } +#endif /* PERL_PRESERVE_IVUV */ + sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); return; } d--; @@ -4743,13 +5312,12 @@ Perl_sv_dec(pTHX_ register SV *sv) sv_setiv(sv, i); } } + /* Unlike sv_inc we don't have to worry about string-never-numbers + and keeping them magic. But we mustn't warn on punting */ flags = SvFLAGS(sv); - if (flags & SVp_NOK) { - SvNVX(sv) -= 1.0; - (void)SvNOK_only(sv); - return; - } - if (flags & SVp_IOK) { + if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { + /* It's publicly an integer, or privately an integer-not-float */ + oops_its_int: if (SvIsUV(sv)) { if (SvUVX(sv) == 0) { (void)SvIOK_only(sv); @@ -4769,6 +5337,11 @@ Perl_sv_dec(pTHX_ register SV *sv) } return; } + if (flags & SVp_NOK) { + SvNVX(sv) -= 1.0; + (void)SvNOK_only(sv); + return; + } if (!(flags & SVp_POK)) { if ((flags & SVTYPEMASK) < SVt_PVNV) sv_upgrade(sv, SVt_NV); @@ -4776,6 +5349,40 @@ Perl_sv_dec(pTHX_ register SV *sv) (void)SvNOK_only(sv); return; } +#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. + but "9.22337203685478e+18" + 0 is UV=9223372036854779904 + so $a="9.22337203685478e+18"; $a+0; $a-- + needs to be the same as $a="9.22337203685478e+18"; $a-- + or we go insane. */ + + (void) sv_2iv(sv); + if (SvIOK(sv)) + goto oops_its_int; + + /* sv_2iv *should* have made this an NV */ + if (flags & SVp_NOK) { + (void)SvNOK_only(sv); + SvNVX(sv) -= 1.0; + return; + } + /* I don't think we can get here. Maybe I should assert this + And if we do get here I suspect that sv_setnv will croak. NWC + Fall through. */ +#if defined(USE_LONG_DOUBLE) + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", + SvPVX(sv), SvIVX(sv), SvNVX(sv))); +#else + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n", + SvPVX(sv), SvIVX(sv), SvNVX(sv))); +#endif + } + } +#endif /* PERL_PRESERVE_IVUV */ sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */ } @@ -448,6 +448,9 @@ Tells and SV that it is an unsigned integer and disables all other OK bits. =for apidoc Am|void|SvIOK_UV|SV* sv Returns a boolean indicating whether the SV contains an unsigned integer. +=for apidoc Am|void|SvUOK|SV* sv +Returns a boolean indicating whether the SV contains an unsigned integer. + =for apidoc Am|void|SvIOK_notUV|SV* sv Returns a boolean indicating whether the SV contains an signed integer. @@ -562,6 +565,7 @@ Set the length of the string which is in the SV. See C<SvCUR>. #define SvIOK_UV(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) \ == (SVf_IOK|SVf_IVisUV)) +#define SvUOK(sv) SvIOK_UV(sv) #define SvIOK_notUV(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) \ == SVf_IOK) @@ -714,6 +718,12 @@ and disables all other OK bits. #define SvMAGIC(sv) ((XPVMG*) SvANY(sv))->xmg_magic #define SvSTASH(sv) ((XPVMG*) SvANY(sv))->xmg_stash +/* Ask a scalar nicely to try to become an IV, if possible. + Not guaranteed to stay returning void */ +/* Macro won't actually call sv_2iv if already IOK */ +#define SvIV_please(sv) \ + STMT_START {if (!SvIOKp(sv) && (SvNOK(sv) || SvPOK(sv))) \ + (void) SvIV(sv); } STMT_END #define SvIV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVIV*) SvANY(sv))->xiv_iv = val); } STMT_END diff --git a/t/lib/peek.t b/t/lib/peek.t index a90574f744..288d3bdf6d 100644 --- a/t/lib/peek.t +++ b/t/lib/peek.t @@ -88,10 +88,10 @@ do_test( 5, do_test( 6, $c + $d, -'SV = NV\\($ADDR\\) at $ADDR +'SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(PADTMP,NOK,pNOK\\) - NV = 456'); + FLAGS = \\(PADTMP,IOK,pIOK\\) + IV = 456'); ($d = "789") += 0.1; @@ -110,8 +110,8 @@ do_test( 8, 0xabcd, 'SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(.*IOK,READONLY,pIOK,IsUV\\) - UV = 43981'); + FLAGS = \\(.*IOK,READONLY,pIOK\\) + IV = 43981'); do_test( 9, undef, @@ -154,12 +154,10 @@ do_test(11, FLAGS = \\(IOK,pIOK\\) IV = 123 Elt No. 1 - SV = PVNV\\($ADDR\\) at $ADDR + SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(IOK,NOK,pIOK,pNOK\\) - IV = 456 - NV = 456 - PV = 0'); + FLAGS = \\(IOK,pIOK\\) + IV = 456'); do_test(12, {$b=>$c}, @@ -180,12 +178,10 @@ do_test(12, RITER = -1 EITER = 0x0 Elt "123" HASH = $ADDR - SV = PVNV\\($ADDR\\) at $ADDR + SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(IOK,NOK,pIOK,pNOK\\) - IV = 456 - NV = 456 - PV = 0'); + FLAGS = \\(IOK,pIOK\\) + IV = 456'); do_test(13, sub(){@_}, diff --git a/t/lib/tie-substrhash.t b/t/lib/tie-substrhash.t index d21ca0ab1b..8256db7b58 100644 --- a/t/lib/tie-substrhash.t +++ b/t/lib/tie-substrhash.t @@ -7,7 +7,7 @@ BEGIN { push @INC, '../lib'; } -print "1..16\n"; +print "1..20\n"; use strict; @@ -97,3 +97,15 @@ 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 --git a/t/op/cmp.t b/t/op/cmp.t index 4a7e68d448..ffd34c62dd 100755 --- a/t/op/cmp.t +++ b/t/op/cmp.t @@ -1,35 +1,185 @@ #!./perl -@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1); +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +# 2s complement assumption. Won't break test, just makes the internals of +# the SVs less interesting if were not on 2s complement system. +my $uv_max = ~0; +my $uv_maxm1 = ~0 ^ 1; +my $uv_big = $uv_max; +$uv_big = ($uv_big - 20000) | 1; +my ($iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big, $iv_small); +$iv_max = $uv_max; # Do copy, *then* divide +$iv_max /= 2; +$iv_min = $iv_max; +{ + use integer; + $iv0 = 2 - 2; + $iv1 = 3 - 2; + $ivm1 = 2 - 3; + $iv_max -= 1; + $iv_min += 0; + $iv_big = $iv_max - 3; + $iv_small = $iv_min + 2; +} +my $uv_bigi = $iv_big; +$uv_bigi |= 0x0; + +# Seems one needs to perform the maths on 'Inf' to get the NV correctly primed. +@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1, 3.14, 1e37, 0.632120558, -.5, + 'Inf'+1, '-Inf'-1, 0x0, 0x1, 0x5, 0xFFFFFFFF, $uv_max, $uv_maxm1, + $uv_big, $uv_bigi, $iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big, + $iv_small); -$expect = ($#FOO+2) * ($#FOO+1); +$expect = 6 * ($#FOO+2) * ($#FOO+1); print "1..$expect\n"; my $ok = 0; for my $i (0..$#FOO) { for my $j ($i..$#FOO) { $ok++; - my $cmp = $FOO[$i] <=> $FOO[$j]; - if (!defined($cmp) || - $cmp == -1 && $FOO[$i] < $FOO[$j] || - $cmp == 0 && $FOO[$i] == $FOO[$j] || - $cmp == 1 && $FOO[$i] > $FOO[$j]) + # Comparison routines may convert these internally, which would change + # what is used to determine the comparison on later runs. Hence copy + my ($i1, $i2, $i3, $i4, $i5, $i6, $i7, $i8, $i9, $i10, + $i11, $i12, $i13, $i14, $i15) = + ($FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], + $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], + $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i]); + my ($j1, $j2, $j3, $j4, $j5, $j6, $j7, $j8, $j9, $j10, + $j11, $j12, $j13, $j14, $j15) = + ($FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], + $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], + $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j]); + my $cmp = $i1 <=> $j1; + if (!defined($cmp) ? !($i2 < $j2) + : ($cmp == -1 && $i2 < $j2 || + $cmp == 0 && !($i2 < $j2) || + $cmp == 1 && !($i2 < $j2))) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, < disagrees\n"; + } + $ok++; + if (!defined($cmp) ? !($i4 == $j4) + : ($cmp == -1 && !($i4 == $j4) || + $cmp == 0 && $i4 == $j4 || + $cmp == 1 && !($i4 == $j4))) + { + 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) + : ($cmp == -1 && !($i5 > $j5) || + $cmp == 0 && !($i5 > $j5) || + $cmp == 1 && ($i5 > $j5))) + { + 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) + : ($cmp == -1 && !($i6 >= $j6) || + $cmp == 0 && $i6 >= $j6 || + $cmp == 1 && $i6 >= $j6)) + { + 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 + if (!defined($cmp) ? ($i7 != $j7) + : ($cmp == -1 && $i7 != $j7 || + $cmp == 0 && !($i7 != $j7) || + $cmp == 1 && $i7 != $j7)) + { + 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) + : ($cmp == -1 && $i8 <= $j8 || + $cmp == 0 && $i8 <= $j8 || + $cmp == 1 && !($i8 <= $j8))) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, <= disagrees\n"; + } + $ok++; + $cmp = $i9 cmp $j9; + if ($cmp == -1 && $i10 lt $j10 || + $cmp == 0 && !($i10 lt $j10) || + $cmp == 1 && !($i10 lt $j10)) + { + print "ok $ok\n"; + } + else { + print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, lt disagrees\n"; + } + $ok++; + if ($cmp == -1 && !($i11 eq $j11) || + $cmp == 0 && ($i11 eq $j11) || + $cmp == 1 && !($i11 eq $j11)) + { + 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) || + $cmp == 0 && !($i12 gt $j12) || + $cmp == 1 && ($i12 gt $j12)) + { + 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 || + $cmp == 0 && ($i13 le $j13) || + $cmp == 1 && !($i13 le $j13)) + { + 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) || + $cmp == 0 && !($i14 ne $j14) || + $cmp == 1 && ($i14 ne $j14)) { print "ok $ok\n"; } else { - print "not ok $ok ($FOO[$i] <=> $FOO[$j]) gives: '$cmp'\n"; + print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, ne disagrees\n"; } $ok++; - $cmp = $FOO[$i] cmp $FOO[$j]; - if ($cmp == -1 && $FOO[$i] lt $FOO[$j] || - $cmp == 0 && $FOO[$i] eq $FOO[$j] || - $cmp == 1 && $FOO[$i] gt $FOO[$j]) + if ($cmp == -1 && !($i15 ge $j15) || + $cmp == 0 && ($i15 ge $j15) || + $cmp == 1 && ($i15 ge $j15)) { print "ok $ok\n"; } else { - print "not ok $ok ($FOO[$i] cmp $FOO[$j]) gives '$cmp'\n"; + print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, ge disagrees\n"; } } } diff --git a/t/op/numconvert.t b/t/op/numconvert.t index f3c9867a91..3db280bbfd 100755 --- a/t/op/numconvert.t +++ b/t/op/numconvert.t @@ -85,8 +85,15 @@ my @list = (1, $yet_smaller_than_iv, $smaller_than_iv, $max_iv, $max_iv + 1, unshift @list, (reverse map -$_, @list), 0; # 15 elts @list = map "$_", @list; # Normalize -# print "@list\n"; +print "# @list\n"; +# need to special case ++ for max_uv, as ++ "magic" on a string gives +# another string, whereas ++ magic on a string used as a number gives +# a number. Not a problem when NV preserves UV, but if it doesn't then +# stringification of the latter gives something in e notation. + +my $max_uv_pp = "$max_uv"; $max_uv_pp++; +my $max_uv_p1 = "$max_uv"; $max_uv_p1+=0; $max_uv_p1++; my @opnames = split //, "-+UINPuinp"; @@ -178,9 +185,18 @@ for my $num_chain (1..$max_chain) { } push @ans, $inpt; } - $nok++, - print "# '$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]\n" - if $ans[0] ne $ans[1]; + if ($ans[0] ne $ans[1]) { + print "# '$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]\n"; + # XXX ought to check that "+" was in the list of opnames + if ((($ans[0] eq $max_uv_pp) and ($ans[1] eq $max_uv_p1)) + or (($ans[1] eq $max_uv_pp) and ($ans[0] eq $max_uv_p1))) { + # string ++ versus numeric ++. Tolerate this little + # bit of insanity + print "# ok, as string ++ of max_uv is \"$max_uv_pp\", numeric is $max_uv_p1\n" + } else { + $nok++, + } + } } print "not " if $nok; print "ok $test\n"; diff --git a/t/pragma/overload.t b/t/pragma/overload.t index c7105dc9ca..bf24c07ec9 100755 --- a/t/pragma/overload.t +++ b/t/pragma/overload.t @@ -133,6 +133,7 @@ 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] } ) ]; @@ -581,12 +581,6 @@ */ /*#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. @@ -957,12 +951,6 @@ */ #define SH_PATH "" /**/ -/* 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 /**/ - /* CROSSCOMPILE: * This symbol, if defined, signifies that we our * build process is a cross-compilation. @@ -2107,6 +2095,18 @@ */ /*#define HAS_STRTOLL / **/ +/* HAS_STRTOQ: + * This symbol, if defined, indicates that the strtoq routine is + * available to convert strings to long longs (quads). + */ +# HAS_STRTOQ /**/ + +/* HAS_STRTOQ: + * This symbol, if defined, indicates that the strtoq routine is + * available to convert strings to long longs (quads). + */ +# HAS_STRTOQ /**/ + /* HAS_STRTOULL: * This symbol, if defined, indicates that the strtoull routine is * available to convert strings to unsigned long longs. @@ -3187,6 +3187,30 @@ /*#define HAS_SETPGRP / **/ /*#define USE_BSD_SETPGRP / **/ +/* HAS_STRTOUL: + * This symbol, if defined, indicates that the strtoul routine is + * available to provide conversion of strings to unsigned long. + */ +/*#define HAS_STRTOUL / **/ + +/* 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_STRTOUL: + * This symbol, if defined, indicates that the strtoul routine is + * available to provide conversion of strings to unsigned long. + */ +/*#define HAS_STRTOUL / **/ + +/* 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__FWALK: * This symbol, if defined, indicates that the _fwalk system call is * available to apply a function to all the file handles. diff --git a/utils/h2xs.PL b/utils/h2xs.PL index 96b38006f0..edc2bb5750 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -403,7 +403,7 @@ See L<perlxs> and L<perlxstut> for additional details. use strict; -my( $H2XS_VERSION ) = ' $Revision: 1.20 $ ' =~ /\$Revision:\s+([^\s]+)/; +my( $H2XS_VERSION ) = ' $Revision: 1.21 $ ' =~ /\$Revision:\s+([^\s]+)/; my $TEMPLATE_VERSION = '0.01'; my @ARGS = @ARGV; my $compat_version = $]; @@ -1043,7 +1043,7 @@ my $pod = <<"END" unless $opt_P; $exp_doc$meth_doc$revhist #=head1 AUTHOR # -#$author, $email +#$author, E<lt>${email}E<gt> # #=head1 SEE ALSO # @@ -1717,6 +1717,9 @@ WriteMakefile( 'NAME' => '$module', 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1 + (\$] >= 5.005 ? ## Add these new keywords supported since 5.005 + (ABSTRACT_FROM => '$modfname.pm', # retrieve abstract from module + AUTHOR => '$author <$email>') : ()), END if (!$opt_X) { # print C stuff, unless XS is disabled $opt_F = '' unless defined $opt_F; @@ -1745,6 +1748,52 @@ END print PL ");\n"; close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n"; +# Create a simple README since this is a CPAN requirement +# and it doesnt hurt to have one +warn "Writing $ext$modpname/README\n"; +open(RM, ">README") || die "Can't create $ext$modpname/README:$!\n"; +my $thisyear = (gmtime)[5] + 1900; +my $rmhead = "$modpname version $TEMPLATE_VERSION"; +my $rmheadeq = "=" x length($rmhead); +print RM <<_RMEND_; +$rmhead +$rmheadeq + +The README is used to introduce the module and provide instructions on +how to install the module, any machine dependencies it may have (for +example C compilers and installed libraries) and any other information +that should be provided before the module is installed. + +A README file is required for CPAN modules since CPAN extracts the +README file from a module distribution so that people browsing the +archive can use it get an idea of the modules uses. It is usually a +good idea to provide version information here so that people can +decide whether fixes for the module are worth downloading. + +INSTALLATION + +To install this module type the following: + + perl Makefile.PL + make + make test + make install + +DEPENDENCIES + +This module requires these other modules and libraries: + + blah blah blah + +COPYRIGHT AND LICENCE + +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_'; @@ -98,6 +98,9 @@ struct itmlst_3 { #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d) #define getredirection(a,b) mp_getredirection(aTHX_ a,b) +/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */ +#define PERL_LNM_MAX_ALLOWED_INDEX 127 + static char *__mystrtolower(char *str) { if (str) for (; *str; ++str) *str= tolower(*str); @@ -152,7 +155,7 @@ Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx, } #endif - if (!lnm || !eqv || idx > LNM$_MAX_INDEX) { + if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) { set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0; } for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) { diff --git a/vos/config.alpha.def b/vos/config.alpha.def index 92ac45796c..7a2093731a 100644 --- a/vos/config.alpha.def +++ b/vos/config.alpha.def @@ -254,6 +254,7 @@ $d_strtod='define' $d_strtol='define' $d_strtold='undef' $d_strtoll='undef' +$d_strtoq='undef' $d_strtoul='define' $d_strtoull='undef' $d_strtouq='undef' diff --git a/vos/config.alpha.h b/vos/config.alpha.h index 634466880c..aaeb129cba 100644 --- a/vos/config.alpha.h +++ b/vos/config.alpha.h @@ -2136,6 +2136,18 @@ */ /*#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 * available to convert strings to unsigned long longs. diff --git a/vos/config.ga.def b/vos/config.ga.def index f6949775d5..46cbc202da 100644 --- a/vos/config.ga.def +++ b/vos/config.ga.def @@ -254,6 +254,7 @@ $d_strtod='define' $d_strtol='define' $d_strtold='undef' $d_strtoll='undef' +$d_strtoq='undef' $d_strtoul='define' $d_strtoull='undef' $d_strtouq='undef' diff --git a/vos/config.ga.h b/vos/config.ga.h index 834764a78e..d235ba11ce 100644 --- a/vos/config.ga.h +++ b/vos/config.ga.h @@ -601,6 +601,18 @@ */ #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. diff --git a/win32/config.bc b/win32/config.bc index e171ab886c..8427200514 100644 --- a/win32/config.bc +++ b/win32/config.bc @@ -338,6 +338,7 @@ d_strtod='define' d_strtol='define' d_strtold='undef' d_strtoll='undef' +d_strtoq='undef' d_strtoul='define' d_strtoull='undef' d_strtouq='undef' diff --git a/win32/config.gc b/win32/config.gc index aa2d188a1f..f43007fc0e 100644 --- a/win32/config.gc +++ b/win32/config.gc @@ -338,6 +338,7 @@ d_strtod='define' d_strtol='define' d_strtold='undef' d_strtoll='undef' +d_strtoq='undef' d_strtoul='define' d_strtoull='undef' d_strtouq='undef' diff --git a/win32/config.vc b/win32/config.vc index 9346ae00aa..2cbd63cd46 100644 --- a/win32/config.vc +++ b/win32/config.vc @@ -338,6 +338,7 @@ d_strtod='define' d_strtol='define' d_strtold='undef' d_strtoll='undef' +d_strtoq='undef' d_strtoul='define' d_strtoull='undef' d_strtouq='undef' |