diff options
126 files changed, 4535 insertions, 1652 deletions
@@ -79,6 +79,599 @@ Version 5.005_57 Development release working toward 5.006 ---------------- ____________________________________________________________________________ +[ 3379] By: gsar on 1999/05/10 12:17:26 + Log: From: jan.dubois@ibm.net (Jan Dubois) + Date: Sat, 01 May 1999 22:55:36 +0200 + Message-ID: <373067e9.56194713@smtp1.ibm.net> + Subject: [PATCH 5.005_56] Win32 and VC++ 98 doesn't support CASTI + Branch: perl + ! pod/perlfunc.pod pod/perlop.pod win32/config.vc + ! win32/config_H.vc +____________________________________________________________________________ +[ 3378] By: gsar on 1999/05/10 12:07:13 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Fri, 30 Apr 1999 22:26:09 -0400 (EDT) + Message-Id: <199905010226.WAA19127@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_56] Self-consistent numeric conversion again + Branch: perl + + t/op/numconvert.t + ! MANIFEST doio.c dump.c perl.h pp.c pp_hot.c sv.c sv.h toke.c + ! util.c +____________________________________________________________________________ +[ 3377] By: gsar on 1999/05/10 11:39:48 + Log: pp_modulo comment tweak from Ilya + Branch: perl + ! pp.c +____________________________________________________________________________ +[ 3376] By: gsar on 1999/05/10 11:30:40 + Log: From: Joshua Pritikin <joshua.pritikin@db.com> + Date: Fri, 7 May 1999 11:31:00 -0400 (EDT) + Message-ID: <Pine.GSO.4.02.9905071127100.1449-100000@eq1062.wks.na.deuba.com> + Subject: Test.pm update [PATCH _56] + Branch: perl + ! lib/Test.pm +____________________________________________________________________________ +[ 3375] By: gsar on 1999/05/10 11:28:30 + Log: From: jan.dubois@ibm.net (Jan Dubois) + Date: Fri, 07 May 1999 00:59:54 +0200 + Message-ID: <373318ae.19292461@smtp1.ibm.net> + Subject: Re: Using existing memory for an SV's PV + Branch: perl + ! sv.c +____________________________________________________________________________ +[ 3374] By: gsar on 1999/05/10 11:23:44 + Log: From: jan.dubois@ibm.net (Jan Dubois) + Date: Fri, 07 May 1999 00:59:52 +0200 + Message-ID: <37321800.19118320@smtp1.ibm.net> + Subject: [PATCH 5.005_56] Fix -Dm memory debugging for PERL_OBJECT + Branch: perl + ! perl.h +____________________________________________________________________________ +[ 3373] By: gsar on 1999/05/10 11:22:10 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Thu, 6 May 1999 18:17:28 -0400 + Message-ID: <19990506181728.A12433@monk.mps.ohio-state.edu> + Subject: Re: [PATCH 5.005_56] Make open(F,"command |") return correct err(no) + Branch: perl + ! doio.c embed.h global.sym objXSUB.h pod/perldiag.pod proto.h + ! util.c +____________________________________________________________________________ +[ 3372] By: gsar on 1999/05/10 10:57:49 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Thu, 6 May 1999 01:21:05 -0400 (EDT) + Message-Id: <199905060521.BAA03485@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_56] Cosmetic: data-driven REx-dump + Branch: perl + ! regcomp.c regcomp.pl +____________________________________________________________________________ +[ 3371] By: gsar on 1999/05/10 10:54:01 + Log: From: lane@duphy4.physics.drexel.edu + Date: Tue, 04 May 1999 10:19:25 -0700 + Message-Id: <3.0.6.32.19990504101925.02ecde30@ous.edu> + Subject: [PATCH 5.005.56] pod->html VMS fixes + Branch: perl + ! installhtml lib/Pod/Html.pm +____________________________________________________________________________ +[ 3370] By: gsar on 1999/05/10 10:45:52 + Log: testsuite nits + Branch: perl + ! t/lib/io_linenum.t t/op/filetest.t +____________________________________________________________________________ +[ 3369] By: gsar on 1999/05/10 10:35:22 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Mon, 3 May 1999 22:38:50 -0400 (EDT) + Message-Id: <199905040238.WAA01865@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_53] Quickier thread-specific data on OS/2 + Branch: perl + ! os2/os2ish.h os2/os2thread.h +____________________________________________________________________________ +[ 3368] By: gsar on 1999/05/10 10:00:11 + Log: From: Albert Dvornik <bert@genscan.com> + Date: 03 May 1999 12:20:57 -0400 + Message-ID: <tqlnf6gm52.fsf@puma.genscan.com> + Subject: [PATCH 5.005_56] do_sv_dump does dump (core) on IO handles + Branch: perl + ! dump.c +____________________________________________________________________________ +[ 3367] By: gsar on 1999/05/10 09:55:51 + Log: shadow password support for Solaris (needs Configure help to + determine HAS_GETSPENT) + From: "Patrick O'Brien" <pdo@cs.umd.edu> + Date: Sat, 01 May 1999 19:41:17 -0400 + Message-Id: <199905012341.TAA23989@optimus.cs.umd.edu> + Subject: getpwent() under solaris + Branch: perl + ! pp_sys.c +____________________________________________________________________________ +[ 3366] By: gsar on 1999/05/10 09:45:58 + Log: From: jan.dubois@ibm.net (Jan Dubois) + Date: Sat, 01 May 1999 23:45:47 +0200 + Message-ID: <373373fb.59284266@smtp1.ibm.net> + Subject: [PATCH 5.005_56] Add POLLUTE=1 option to MakeMaker + Branch: perl + ! lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MakeMaker.pm + ! pod/perldelta.pod +____________________________________________________________________________ +[ 3365] By: gsar on 1999/05/10 09:34:22 + Log: test suite and fix input_line_number() + From: Paul Johnson <pjcj@transeda.com> + Date: Thu, 29 Apr 1999 06:28:14 +0100 + Message-ID: <19990429062814.A17906@west-tip.transeda.com> + Subject: [PATCH] IO::Handle 1.20 (was Re: FAIL Gedcom-1.01 i86pc-solaris 2.6) + Branch: perl + + t/lib/io_linenum.t + ! MANIFEST ext/IO/lib/IO/Handle.pm +____________________________________________________________________________ +[ 3364] By: gsar on 1999/05/10 09:20:56 + Log: fix overeager [:foo:] parsing + From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + Date: Fri, 30 Apr 1999 09:26:18 +0100 + Message-Id: <199904300826.JAA01257@crypt.compulink.co.uk> + Subject: [PATCH 5.005_{56,03}] Re: Regular expression difference b/n 5.004 & 5.005 + Branch: perl + ! regcomp.c t/op/re_tests +____________________________________________________________________________ +[ 3363] By: gsar on 1999/05/10 09:09:21 + Log: documentation for Win32 builtins (somewhat modified) + From: jan.dubois@ibm.net (Jan Dubois) + Date: Tue, 30 Mar 1999 08:05:03 +0200 + Message-ID: <37006783.1926460@smtp1.ibm.net> + Subject: Re: Issues with build 509 + Branch: perl + + pod/Win32.pod + ! MANIFEST +____________________________________________________________________________ +[ 3362] By: gsar on 1999/05/10 08:22:07 + Log: provide File::Copy::syscopy() via Win32::CopyFile() on win32 + Branch: perl + ! lib/File/Copy.pm win32/win32.c +____________________________________________________________________________ +[ 3361] By: gsar on 1999/05/10 08:11:29 + Log: escape ampersands in <pre> sections + Branch: perl + ! Changes lib/Pod/Html.pm +____________________________________________________________________________ +[ 3360] By: gsar on 1999/05/10 08:04:14 + Log: AIX hints enhancements (threads build, SOCKS support) + From: "David R. Favor" <dfavor@austin.ibm.com> + Date: Wed, 28 Apr 1999 08:45:28 -0500 + Message-ID: <372710F8.B1F73BEB@austin.ibm.com> + Subject: Working build for AIX + gcc + threading + Branch: perl + ! hints/aix.sh +____________________________________________________________________________ +[ 3359] By: gsar on 1999/05/10 07:49:26 + Log: more Compiler patches from Vishal Bhatia <vishalb@my-dejanews.com> + Date: Tue, 27 Apr 1999 23:47:24 PDT + Message-ID: <19990428064724.95244.qmail@hotmail.com> + Subject: [PATCH 5.005_56] Saving Tied hashes ( C.pm) + -- + Date: Thu, 29 Apr 1999 18:21:06 -0700 + Message-ID: <GEFPBFDJADFJBAAA@my-dejanews.com> + Subject: [PATCH 5.005_56] double constants ( C.pm) + -- + Date: Mon, 03 May 1999 20:21:31 PDT + Message-ID: <19990504032131.81113.qmail@hotmail.com> + Subject: [PATCH 5.005_56] Overloading implementation ( Compiler) + -- + Date: Thu, 06 May 1999 17:57:09 -0700 + Message-ID: <FCJELBLAJBOBAAAA@my-dejanews.com> + Subject: Stash.pm + Branch: perl + ! ext/B/B.pm ext/B/B.xs ext/B/B/Bblock.pm ext/B/B/C.pm + ! ext/B/B/CC.pm ext/B/B/Stash.pm t/harness +____________________________________________________________________________ +[ 3358] By: gsar on 1999/05/10 04:39:15 + Log: cygwin32 update (untested adaptation of patch against 5.005_03) + From: alexander smishlajev <als@turnhere.com> + Date: Sun, 25 Apr 1999 14:58:29 +0300 + Message-ID: <37230365.5F68B460@turnhere.com> + Subject: [PATCH]5.005_03 (CORE) cygwin32 port + Branch: perl + + cygwin32/Makefile.SHs cygwin32/build-instructions.READFIRST + + cygwin32/build-instructions.charles-wilson + + cygwin32/build-instructions.sebastien-barre + + cygwin32/build-instructions.steven-morlock + + cygwin32/build-instructions.steven-morlock2 + + cygwin32/impure_ptr.c cygwin32/ld2.in cygwin32/perlld.in + - cygwin32/cw32imp.h cygwin32/gcc2 cygwin32/ld2 cygwin32/perlgcc + - cygwin32/perlld + ! Configure EXTERN.h MANIFEST Makefile.SH README.cygwin32 XSUB.h + ! cflags.SH config_h.SH dosish.h ext/POSIX/Makefile.PL + ! ext/SDBM_File/sdbm/pair.c hints/cygwin32.sh installperl + ! lib/Cwd.pm lib/ExtUtils/MakeMaker.pm lib/perl5db.pl + ! makedepend.SH perl.h perlvars.h pp_hot.c pp_sys.c regcomp.c + ! t/io/fs.t t/io/tell.t t/lib/anydbm.t t/op/stat.t util.c +____________________________________________________________________________ +[ 3357] By: gsar on 1999/05/10 04:07:07 + Log: applied suggested patch, modulo already applied parts + From: Charles Bailey <BAILEY@newman.upenn.edu> + Date: Sat, 24 Apr 1999 20:12:43 -0400 (EDT) + Message-id: <01JAF9UAV9XG002O0W@mail.newman.upenn.edu> + Subject: [Patch 5.005_56] VMS consolidated patch #2 + Branch: perl + ! configure.com t/op/filetest.t t/op/taint.t t/pragma/warn/doio + ! t/pragma/warn/mg t/pragma/warn/pp_sys t/pragma/warn/sv + ! vms/descrip_mms.template vms/ext/vmsish.t vms/perlvms.pod + ! vms/subconfigure.com vms/test.com vms/vms.c +____________________________________________________________________________ +[ 3356] By: gsar on 1999/05/10 03:48:08 + Log: applied suggested patch, with win32 and PERL_OBJECT additions + From: Tom Hughes <tom@compton.nu> + Date: Sat, 24 Apr 1999 18:11:59 +0100 + Message-ID: <609bdff748.tom@compton.compton.nu> + Subject: ByteLoader patch + Branch: perl + + ext/ByteLoader/ByteLoader.pm ext/ByteLoader/ByteLoader.xs + + ext/ByteLoader/Makefile.PL utils/perlbc.PL + ! MANIFEST bytecode.h bytecode.pl byterun.c byterun.h embed.h + ! embed.pl ext/B/B.xs ext/B/B/Asmdata.pm ext/B/B/Bytecode.pm + ! ext/B/B/Debug.pm objXSUB.h op.c pp_ctl.c proto.h + ! utils/Makefile win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 3355] By: gsar on 1999/05/10 03:22:49 + Log: document 'test' attribute (from Andreas Koenig) + Branch: perl + ! lib/ExtUtils/MakeMaker.pm +____________________________________________________________________________ +[ 3354] By: gsar on 1999/05/10 03:12:37 + Log: From: pmarquess@bfsec.bt.co.uk + Date: Thu, 22 Apr 1999 23:12:08 +0100 + Message-ID: <5104D4DBC598D211B5FE0000F8FE7EB29C6B45@mbtlipnt02.btlabs.bt.co.uk> + Subject: PATCH for small bug in scan_bin + Branch: perl + ! util.c +____________________________________________________________________________ +[ 3353] By: gsar on 1999/05/10 02:39:33 + Log: more bulletproof workaround for mangled paths (updates changes#3345,3350); + provide Win32::GetLongPathName() to complement Win32::GetShortPathName() + Branch: perl + ! t/op/magic.t win32/makedef.pl win32/runperl.c win32/win32.c + ! win32/win32iop.h +____________________________________________________________________________ +[ 3352] By: gsar on 1999/05/09 22:47:39 + Log: flush all open output buffers before fork(), exec(), system, qx// + and pipe open() operations, simplifying buffering headaches faced + by users; uses fflush(NULL), which may need Configure test + Branch: perl + ! perl.h pod/perldelta.pod pod/perlfunc.pod pod/perlipc.pod + ! pp_sys.c util.c vmesa/vmesa.c vms/vms.c win32/win32.c +____________________________________________________________________________ +[ 3351] By: gsar on 1999/05/09 21:11:51 + Log: perlcc on win32 (correct version of fix suggested by Jean-Louis + Leroy <jll@skynet.be>) + Branch: perl + ! utils/perlcc.PL +____________________________________________________________________________ +[ 3350] By: gsar on 1999/05/09 20:39:11 + Log: normalize $^X to full pathname on win32 + Branch: perl + ! win32/runperl.c +____________________________________________________________________________ +[ 3349] By: gsar on 1999/05/09 20:23:07 + Log: allow readline($globref), <$globref> already works + Branch: perl + ! pp_hot.c +____________________________________________________________________________ +[ 3348] By: gsar on 1999/05/09 20:00:09 + Log: perldoc cleanups (variant of changes suggested by Christian Lemburg + <lemburg@online-club.de>) + Branch: perl + ! utils/perldoc.PL +____________________________________________________________________________ +[ 3347] By: gsar on 1999/05/09 18:47:21 + Log: additions to Thread.pm docs from Tuomas J. Lukka + <lukka@fas.harvard.edu> + Branch: perl + ! ext/Thread/Thread.pm +____________________________________________________________________________ +[ 3346] By: gsar on 1999/05/09 18:38:00 + Log: From: Stephen McCamant <smccam@uclink4.berkeley.edu> + Date: Sat, 17 Apr 1999 02:46:13 -0700 (PDT) + Message-ID: <14103.57454.614253.598264@fre-76-120.reshall.berkeley.edu> + Subject: [PATCH _56] Re: pdt: Perl Development Tools? + Branch: perl + ! ext/B/B/Xref.pm +____________________________________________________________________________ +[ 3345] By: gsar on 1999/05/09 18:22:43 + Log: work around mangled archname on win32 while finding privlib/sitelib; + normalize lib paths to forward slashes internally + Branch: perl + ! win32/win32.c +____________________________________________________________________________ +[ 3344] By: gsar on 1999/05/09 03:20:06 + Log: fix typo in dbm filters that caused odbm.t to fail + Branch: perl + ! ext/ODBM_File/ODBM_File.xs t/lib/odbm.t +____________________________________________________________________________ +[ 3343] By: gsar on 1999/05/09 02:02:59 + Log: tweak test totals + Branch: perl + ! Changes t/lib/tie-stdhandle.t +____________________________________________________________________________ +[ 3342] By: gsar on 1999/05/09 01:42:06 + Log: import list propagation busted (pointed out by Ton Hospel + <thospel@mail.dma.be>) + Branch: perl + ! lib/autouse.pm +____________________________________________________________________________ +[ 3341] By: gsar on 1999/05/09 00:54:18 + Log: hpux needs {SHLIB_PATH,LDOPTS} rather than LD_{LIBRARY,RUN}_PATH + (as suggested by Eric Boehm <boehm@nortelnetworks.com>) + Branch: perl + ! Configure Makefile.SH +____________________________________________________________________________ +[ 3340] By: gsar on 1999/05/09 00:40:41 + Log: generate manpages for newly added utils + Branch: perl + ! installman +____________________________________________________________________________ +[ 3339] By: gsar on 1999/05/09 00:33:50 + Log: From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + Date: Sun, 02 May 1999 17:59:24 +0100 + Message-Id: <199905021659.RAA14016@crypt.compulink.co.uk> + Subject: [PATCH] Re: ptr to realloced memory in yylex + Branch: perl + ! toke.c +____________________________________________________________________________ +[ 3338] By: jhi on 1999/05/08 22:40:29 + Log: Remove CONFIG item, add Digital UNIX 'ld' bug. + Branch: cfgperl + ! INSTALL +____________________________________________________________________________ +[ 3337] By: jhi on 1999/05/08 22:22:26 + Log: Integrate from mainperl. + Branch: cfgperl + +> pod/perldbmfilter.pod t/io/open.t t/lib/tie-stdhandle.t + !> (integrate 54 files) +____________________________________________________________________________ +[ 3336] By: gsar on 1999/05/08 21:48:22 + Log: make perldoc -f grok nested =items + Branch: perl + ! utils/perldoc.PL +____________________________________________________________________________ +[ 3335] By: gsar on 1999/05/08 19:48:11 + Log: allow AV/HV dereferences on pseudohashes ($ph->{foo}[1], etc.) + Branch: perl + ! op.c t/lib/fields.t +____________________________________________________________________________ +[ 3334] By: gsar on 1999/05/08 19:09:41 + Log: update test totals + Branch: perl + ! t/lib/bigintpm.t +____________________________________________________________________________ +[ 3333] By: gsar on 1999/05/08 16:56:02 + Log: mention unpack('pP',...) footshot (from Albert Dvornik <bert@genscan.com>) + Branch: perl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 3332] By: gsar on 1999/05/08 16:46:44 + Log: applied suggested patch, added tests + From: William Mann <wmann@avici.com> + Date: Mon, 12 Apr 1999 12:25:22 -0400 (EDT) + Message-Id: <199904121625.MAA00983@hwsrv1.avici.com> + Subject: BigInt.pm extensions for logical operations + Branch: perl + ! lib/Math/BigInt.pm pod/perldelta.pod t/lib/bigintpm.t +____________________________________________________________________________ +[ 3331] By: gsar on 1999/05/08 16:09:33 + Log: avoid temporary files named 'tmp' + Branch: perl + ! Makefile.SH pp.c +____________________________________________________________________________ +[ 3330] By: nick on 1999/05/08 14:16:30 + Log: Implement OPEN, EOF, SEEK, TELL, BINMODE and FILENO as TIEHANDLE methods. + Provide Tie::StdHandle + Basic update of docs. + Branch: perl + + t/lib/tie-stdhandle.t + ! lib/Tie/Handle.pm pod/perltie.pod pp_sys.c +____________________________________________________________________________ +[ 3329] By: nick on 1999/05/08 12:03:45 + Log: Tweaks to open(my $fh,...) stuff + Branch: perl + ! op.c pp.c pp_sys.c t/io/open.t +____________________________________________________________________________ +[ 3328] By: nick on 1999/05/08 11:18:42 + Log: Bring SDBM_File.xs into line with new typemap + Branch: perl + ! ext/SDBM_File/SDBM_File.xs +____________________________________________________________________________ +[ 3327] By: gsar on 1999/05/08 00:07:11 + Log: add test case for AUTOLOAD reentrancy fix in change#3279 + Branch: perl + ! t/lib/autoloader.t +____________________________________________________________________________ +[ 3326] By: nick on 1999/05/07 21:24:50 + Log: Implement open( my $fh, ...) and similar. + Set flag in op.c for "constructor ops" + In pp_rv2gv, if flag is set and arg is PADSV and uninit + vivify as reference to a detached GV. + (Name of GV is the pad name.) + This scheme should "just work" for pipe/socket etc. too. + + #if 0 out the open(FH,undef) for now. + Change t/io/open.t to test open(my $fh,...) + Branch: perl + ! op.c pp.c pp_sys.c t/io/open.t +____________________________________________________________________________ +[ 3325] By: nick on 1999/05/07 21:18:42 + Log: Correct SvLEN vs SvCUR which leads to odd "chunk" vs "line" in mess(). + Branch: perl + ! util.c +____________________________________________________________________________ +[ 3324] By: gsar on 1999/05/07 20:28:31 + Log: avoid using PL_sv_mutex in condpair_magic() (avoids hangs when + intervening code has to allocate SVs) + Branch: perl + ! util.c +____________________________________________________________________________ +[ 3323] By: gsar on 1999/05/07 19:45:08 + Log: allow line numbers to show in diagnostics during global destruction + Branch: perl + ! util.c +____________________________________________________________________________ +[ 3322] By: gsar on 1999/05/07 09:38:11 + Log: From: Dan Sugalski <sugalskd@ous.edu> + Date: Fri, 09 Apr 1999 16:16:39 -0700 + Message-Id: <3.0.6.32.19990409161639.02ea1050@ous.edu> + Subject: [PATCH 5.005_03]Bug in MM_VMS.PM + Branch: perl + ! lib/ExtUtils/MM_VMS.pm +____________________________________________________________________________ +[ 3321] By: gsar on 1999/05/07 09:08:23 + Log: From: kwzh@gnu.org (Karl Heuer) + Date: Wed, 7 Apr 1999 23:58:58 -0400 + Message-Id: <199904080358.XAA01192@mescaline.gnu.org> + Subject: [perl-5.005.02] detect lack of /dev/tty + Branch: perl + ! Makefile.SH +____________________________________________________________________________ +[ 3320] By: gsar on 1999/05/07 08:52:14 + Log: allow distinct prefix for versioned executables + From: Roderick Schertler <roderick@argon.org> + Date: Wed, 07 Apr 1999 15:34:56 -0400 + Message-ID: <3003.923513696@eeyore.ibcinc.com> + Subject: perl55.00503 -> perl5.00503 patch for installperl + Branch: perl + ! INSTALL installperl +____________________________________________________________________________ +[ 3319] By: gsar on 1999/05/07 08:07:02 + Log: From: Dan Sugalski <sugalskd@osshe.edu> + Date: Mon, 05 Apr 1999 15:38:42 -0700 + Message-Id: <3.0.6.32.19990405153842.0367b650@ous.edu> + Subject: Re: chomp fails with $/ in fixed-length record mode + -- + From: Roderick Schertler <roderick@argon.org> + Date: Tue, 06 Apr 1999 21:11:37 -0400 + Message-ID: <2795.923447497@eeyore.ibcinc.com> + Subject: Re: chomp fails with $/ in fixed-length record mode + Branch: perl + ! doop.c pod/perlfunc.pod t/op/chop.t +____________________________________________________________________________ +[ 3318] By: gsar on 1999/05/07 07:56:35 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Tue, 6 Apr 1999 01:40:36 -0400 + Message-ID: <19990406014035.A1238@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_*] Make % use fmod() + Branch: perl + ! pp.c t/op/arith.t +____________________________________________________________________________ +[ 3317] By: gsar on 1999/05/07 04:18:11 + Log: DBM Filters (via private mail) + From: pmarquess@bfsec.bt.co.uk + Date: Sun, 18 Apr 1999 21:05:52 +0100 + Message-Id: <199904182009.NAA19152@activestate.com> + Subject: DBM Filters + Branch: perl + + pod/perldbmfilter.pod + ! MANIFEST ext/DB_File/Changes ext/DB_File/DB_File.pm + ! ext/DB_File/DB_File.xs ext/DB_File/typemap + ! ext/GDBM_File/GDBM_File.pm ext/GDBM_File/GDBM_File.xs + ! ext/GDBM_File/typemap ext/NDBM_File/NDBM_File.pm + ! ext/NDBM_File/NDBM_File.xs ext/NDBM_File/typemap + ! ext/ODBM_File/ODBM_File.pm ext/ODBM_File/ODBM_File.xs + ! ext/ODBM_File/typemap ext/SDBM_File/SDBM_File.pm + ! ext/SDBM_File/SDBM_File.xs ext/SDBM_File/typemap + ! lib/AnyDBM_File.pm pod/Makefile pod/buildtoc pod/perl.pod + ! pod/perldelta.pod t/lib/db-btree.t t/lib/db-hash.t + ! t/lib/db-recno.t t/lib/gdbm.t t/lib/ndbm.t t/lib/odbm.t + ! t/lib/sdbm.t +____________________________________________________________________________ +[ 3316] By: gsar on 1999/05/07 03:28:53 + Log: avoid negative return value from Win32::GetTickCount() + From: jan.dubois@ibm.net (Jan Dubois) + Date: Sat, 03 Apr 1999 19:04:18 +0200 + Message-ID: <37084742.22824479@smtp1.ibm.net> + Subject: Re: Win32::GetTickCount + Branch: perl + ! win32/win32.c +____________________________________________________________________________ +[ 3315] By: nick on 1999/05/06 21:44:38 + Log: open(FH,undef) # creates new_tmpfile opened read/write + Add t/io/open.t with test for above. + Branch: perl + + t/io/open.t + ! pp_sys.c +____________________________________________________________________________ +[ 3314] By: gsar on 1999/05/06 08:01:23 + Log: compiler fixes from Vishal Bhatia <vishalb@hotmail.com> + Date: Tue, 30 Mar 1999 23:40:34 PST + Message-ID: <19990331074034.6117.qmail@hotmail.com> + Subject: [PATCH 5.005_56] pp_entersub and pp_leavewrite(CC.pm) + -- + Date: Wed, 07 Apr 1999 00:28:23 -0800 + Message-ID: <FGBNLNPOEELFAAAA@my-dejanews.com> + Subject: [PATCH 5.005_56] function prototypes(B.pm) + -- + Date: Thu, 22 Apr 1999 23:40:52 -0700 + Message-ID: <OEAOMKBMLDADCAAA@my-dejanews.com> + Subject: [PATCH 5.005_56 ] discarding worthless padsvs + -- + Date: Tue, 27 Apr 1999 01:14:49 PDT + Message-ID: <19990427081449.28615.qmail@hotmail.com> + Subject: [PATCH 5.005_56] pp_ncmp implementation ( CC.pm) + Branch: perl + ! ext/B/B.pm ext/B/B/CC.pm ext/B/B/Stackobj.pm t/op/gv.t + ! t/op/ref.t +____________________________________________________________________________ +[ 3313] By: jhi on 1999/05/06 07:59:52 + Log: Integrate from mainperl. + Branch: cfgperl + !> (integrate 33 files) +____________________________________________________________________________ +[ 3312] By: gsar on 1999/05/06 07:11:50 + Log: add Ethiopic section to unicode master database (from Ken + Whistler <kenw@sybase.com>) + Branch: perl + ! lib/unicode/UnicodeData-Latest.txt +____________________________________________________________________________ +[ 3311] By: gsar on 1999/05/06 05:37:55 + Log: From: Damon Atkins <n107844@sysmgtdev.nabaus.com.au> + Date: Tue, 30 Mar 1999 11:26:11 +1000 (EST) + Message-Id: <199903300126.LAA20870@sysmgtdev.nabaus.com.au> + Subject: Largefiles for Solaris + Branch: perl + ! hints/solaris_2.sh +____________________________________________________________________________ +[ 3310] By: gsar on 1999/05/06 05:14:35 + Log: emit more accurate diagnostic for syntax errors involving <> + within eval"" + Branch: perl + ! toke.c utils/perldoc.PL +____________________________________________________________________________ +[ 3309] By: gsar on 1999/05/06 04:36:31 + Log: additional test for IPC::Open3 (courtesy RonaldWS@aol.com) + Branch: perl + ! t/lib/open3.t +____________________________________________________________________________ +[ 3308] By: gsar on 1999/05/06 03:19:16 + Log: applied first part of suggested patch (bug described cannot be + reproduced any longer, so the second inconclusive part has not + been applied) + From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + Date: Sun, 28 Mar 1999 04:51:34 +0100 + Message-Id: <199903280351.EAA20430@crypt.compulink.co.uk> + Subject: [PATCH 5.005_56] Re: A core dump + Branch: perl + ! toke.c +____________________________________________________________________________ +[ 3307] By: gsar on 1999/05/06 01:56:06 + Log: fix bogus OPf_REF context in C<sort BLOCK @foo> (extension of + change#3810) + Branch: perl + ! op.c +____________________________________________________________________________ +[ 3306] By: gsar on 1999/05/05 17:17:34 + Log: applied non-conflicting parts of suggested patch + From: Charles Bailey <BAILEY@newman.upenn.edu> + Date: Sat, 27 Mar 1999 00:16:51 -0400 (EDT) + Message-id: <01J9AZY8I2PW001O2S@mail.newman.upenn.edu> + Subject: [Patch 5.005_56] Revised VMS patch + Branch: perl + ! Changes ext/B/defsubs.h.PL hv.c iperlsys.h perl.c + ! pod/perldiag.pod proto.h util.c vms/perlvms.pod vms/vms.c +____________________________________________________________________________ [ 3305] By: gsar on 1999/05/05 16:20:19 Log: make perldoc use backslashed pathnames within system() on win32 Branch: perl @@ -4342,11 +4342,13 @@ echo "Your cpp writes the filename in the $pos field of the line." $cat >findhdr <<EOF $startsh wanted=\$1 -name='' -if test -f $usrinc/\$wanted; then - echo "$usrinc/\$wanted" - exit 0 -fi +for usrincdir in $usrinc +do + if test -f \$usrincdir/\$wanted; then + echo "\$usrincdir/\$wanted" + exit 0 + fi +done awkprg='{ print \$$fieldn }' echo "#include <\$wanted>" > foo\$\$.c $cppstdin $cppminus $cppflags < foo\$\$.c 2>/dev/null | \ @@ -4354,7 +4356,7 @@ $grep "^[ ]*#.*\$wanted" | \ while read cline; do name=\`echo \$cline | $awk "\$awkprg" | $tr -d '"'\` case "\$name" in - */\$wanted) echo "\$name"; exit 0;; + *[/\\\\]\$wanted) echo "\$name"; exit 0;; *) name='';; esac; done; @@ -5448,6 +5450,10 @@ if "$useshrplib"; then beos) # beos doesn't like the default, either. ;; + hpux*) + # hpux doesn't like the default, either. + tmp_shrpenv="env LDOPTS=\"+s +b${shrpdir}\"" + ;; *) tmp_shrpenv="env LD_RUN_PATH=$shrpdir" ;; @@ -40,10 +40,17 @@ # define dEXTCONST const # endif # else -# define EXT extern -# define dEXT -# define EXTCONST extern const -# define dEXTCONST const +# if defined(CYGWIN32) && defined(USEIMPORTLIB) +# define EXT extern __declspec(dllimport) +# define dEXT +# define EXTCONST extern __declspec(dllimport) const +# define dEXTCONST const +# else +# define EXT extern +# define dEXT +# define EXTCONST extern const +# define dEXTCONST const +# endif # endif #endif @@ -72,11 +72,15 @@ configure.com Configure-equivalent for VMS configure.gnu Crude emulation of GNU configure cop.h Control operator header cv.h Code value header -cygwin32/cw32imp.h Cygwin32 port -cygwin32/gcc2 Cygwin32 port -cygwin32/ld2 Cygwin32 port -cygwin32/perlgcc Cygwin32 port -cygwin32/perlld Cygwin32 port +cygwin32/Makefile.SHs Shared library generation for Cygwin32 port +cygwin32/ld2.in ld wrapper template for Cygwin32 port +cygwin32/perlld.in dll generator template for Cygwin32 port +cygwin32/impure_ptr.c impure pointer stub for dlls +cygwin32/build-instructions.charles-wilson Cygwin32 porters notes +cygwin32/build-instructions.READFIRST Cygwin32 porters notes +cygwin32/build-instructions.steven-morlock2 Cygwin32 porters notes +cygwin32/build-instructions.sebastien-barre Cygwin32 porters notes +cygwin32/build-instructions.steven-morlock Cygwin32 porters notes deb.c Debugging routines djgpp/config.over DOS/DJGPP port djgpp/configure.bat DOS/DJGPP port @@ -195,6 +199,9 @@ ext/B/ramblings/magic Compiler ramblings: notes on magic ext/B/ramblings/reg.alloc Compiler ramblings: register allocation ext/B/ramblings/runtime.porting Compiler ramblings: porting PP enging ext/B/typemap Compiler backend interface types +ext/ByteLoader/ByteLoader.pm Bytecode loader Perl module +ext/ByteLoader/ByteLoader.xs Bytecode loader external subroutines +ext/ByteLoader/Makefile.PL Bytecode loader makefile writer ext/DB_File/Changes Berkeley DB extension change log ext/DB_File/DB_File.pm Berkeley DB extension Perl module ext/DB_File/DB_File.xs Berkeley DB extension external subroutines @@ -939,6 +946,7 @@ plan9/plan9ish.h Plan9 port: Plan9-specific C header file plan9/setup.rc Plan9 port: script for easy build+install plan9/versnum Plan9 port: script to print version number pod/Makefile Make pods into something else +pod/Win32.pod Documentation for Win32 extras pod/buildtoc generate perltoc.pod pod/checkpods.PL Tool to check for common errors in pods pod/perl.pod Top level perl man page @@ -1112,6 +1120,7 @@ t/lib/hostname.t See if Sys::Hostname works t/lib/io_const.t See if constants from IO work t/lib/io_dir.t See if directory-related methods from IO work t/lib/io_dup.t See if dup()-related methods from IO work +t/lib/io_linenum.t See if I/O line numbers are tracked correctly t/lib/io_multihomed.t See if INET sockets work with multi-homed hosts t/lib/io_pipe.t See if pipe()-related methods from IO work t/lib/io_poll.t See if poll()-related methods from IO work @@ -1195,6 +1204,7 @@ t/op/method.t See if method calls work t/op/misc.t See if miscellaneous bugs have been fixed t/op/mkdir.t See if mkdir works t/op/my.t See if lexical scoping works +t/op/numconvert.t See if accessing fields does not change numeric values t/op/nothread.t local @_ test which does not work threaded t/op/oct.t See if oct and hex work t/op/ord.t See if ord works @@ -1311,6 +1321,7 @@ utils/c2ph.PL program to translate dbx stabs to perl utils/h2ph.PL A thing to turn C .h files into perl .ph files utils/h2xs.PL Program to make .xs files from C header files utils/perlbug.PL A simple tool to submit a bug report +utils/perlbc.PL Front-end for bytecode compiler utils/perlcc.PL Front-end for compiler utils/perldoc.PL A simple tool to find & display perl's documentation utils/pl2pm.PL A pl to pm translator diff --git a/Makefile.SH b/Makefile.SH index 1ba5e80101..aa0e3f278e 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -46,6 +46,9 @@ true) rhapsody*) ldlibpth="DYLD_LIBRARY_PATH=`pwd`/Perl:$DYLD_LIBRARY_PATH" ;; + cygwin*) ldlibpth="PATH=`pwd`:$PATH" + linklibperl="-lperl" + ;; os2*) # OS/2 doesn't need anything special for LD_LIBRARY_PATH. ldlibpth='' ;; @@ -68,8 +71,9 @@ true) aixinstdir=`pwd | sed 's/\/UU$//'` linklibperl="-L $archlibexp/CORE -L $aixinstdir -lperl" ;; - hpux10*|hpux11*) - linklibperl="-L `pwd | sed 's/\/UU$//'` -Wl,+b$archlibexp/CORE -lperl" + hpux*) + linklibperl="-L `pwd | sed 's/\/UU$//'` -Wl,+s -Wl,+b$archlibexp/CORE -lperl" + ldlibpth="SHLIB_PATH=`pwd`:${SHLIB_PATH}" ;; beos*) ldlibpth="LIBRARY_PATH=`pwd`:$LIBRARY_PATH" ;; @@ -295,11 +299,20 @@ ext.libs: $(static_ext) # How to build libperl. This is still rather convoluted. # Load up custom Makefile.SH fragment for shared loading and executables: -if test -r $osname/Makefile.SHs ; then - . $osname/Makefile.SHs +case "$osname" in +cygwin*) + Makefile_s="cygwin32/Makefile.SHs" + ;; +*) + Makefile_s="$osname/Makefile.SHs" + ;; +esac + +if test -r $Makefile_s ; then + . $Makefile_s $spitshell >>Makefile <<!GROK!THIS! -Makefile: $osname/Makefile.SHs +Makefile: $Makefile_s !GROK!THIS! else $spitshell >>Makefile <<'!NO!SUBS!' diff --git a/README.cygwin32 b/README.cygwin32 index 3b89e52d46..fee1fb3bee 100644 --- a/README.cygwin32 +++ b/README.cygwin32 @@ -1,28 +1,93 @@ -The following assumes you have the GNU-Win32 package, version b17.1 or -later, installed and configured on your system. See -http://www.cygnus.com/misc/gnu-win32/ for details on the GNU-Win32 -project and the Cygwin32 API. +If you read this file _as_is_, just ignore the funny characters you +see. It is written in the POD format (see pod/perlpod.pod) which is +specially designed to be readable as is. -1) Copy the contents of the cygwin32 directory to the Perl source - root directory. +=head1 NAME -2) Modify the ld2 and gcc2 scripts by making the PERLPATH variable contain - the Perl source root directory. For example, if you extracted perl to - "/perl5.005", change the scripts so they contain the line: +README.cygwin32 - notes about porting Perl to Cygwin32 - PERLPATH=/perl5.005 +=head1 SYNOPSIS -3) Copy the two scripts ld2 and gcc2 from the cygwin32 subdirectory to a - directory in your PATH environment variable. For example, copy to - /bin, assuming /bin is in your PATH. (These two scripts are 'wrapper' - scripts that encapsulate the multiple-pass dll building steps used by - GNU-Win32 ld/gcc.) +=over -4) Run the perl Configuration script as stated in the perl README file: +=item Cygwin32 - sh Configure + The Cygwin tools are ports of the popular GNU development tools for +Windows NT, 95, and 98. They run thanks to the Cygwin library which +provides the UNIX system calls and environment these programs expect. +More info about this project can be found at it's home page +http://sourceware.cygnus.com/cygwin/ - When confronted with this prompt: + Cygnus Solutions also made the first set of notes and tools for +building perl under Cygwin32 beta17. + +=item als + +no, i am not hunting the patch pumpkin. i just wanted to have working +non-ActiveState perl binaries for Windows NT that can load dynamic +extensions. after several days of internet searching i went to conclusion +that the most promising way is to build it myself. i was wrong. + +=back + +=head1 BUILDING + +=head2 Prerequisites + +=over + +=item Cygwin b20.1 + +since you are willing to build things yourself, you are supposed to use +not-so-archaic tools. the latest stable Cygwin suite is beta20.1. it may be +downloaded from ftp://go.cygnus.com/pub/sourceware.cygnus.com/cygwin/latest/ +or many mirror sites around the world. + +=item egcs-1.1.2 + +i've tried to build with egcs-1.1 that comes with cygwin b20.1, and +had no luck. maybe, if a week ago i was as experienced as now, +things would go different... maybe. but this port was built with +egcs-1.1.2 downloaded from +ftp://ftp.xraylith.wisc.edu/pub/khan/gnu-win32/cygwin/egcs-1.1.2/ + +=item my patches + +if you are reading this, those are probably applied already. + +=item crypt library + +you do not want to see messages about excessive paranoia, do you? +well, http://miracle.geol.msu.ru/sos/ points to two different crypt +libraries ported to cygwin. i used libcrypt.tgz by Andy Piper. +his home page can be found at http://www.xemacs.freeserve.co.uk/ + +=item environment + +the locations of cygwin instllation are, well, a little unusual. +Configure will run smoother if you make more common aliases for cygwin +directories. it can be made either by C<mount>ing or by creating +directory symlinks like this: + +ln -s /cygnus/cygwin-b20/H-i586-cygwin32/bin/ $prefix/bin +ln -s /cygnus/cygwin-b20/H-i586-cygwin32/i586-cygwin32/include/ \ + $prefix/include +ln -s /cygnus/cygwin-b20/H-i586-cygwin32/i586-cygwin32/lib/ $prefix/lib + +$prefix may be empty (root), /usr, or /usr/local, as you preffer. +i used /usr. futhermore, t/io/taint.t requires cygwin1.dll to be +present in build directory or somewhere in system path (/WINNT, +/WINNT/System, /WINNT/System32). + +=back + +=head2 Configure + +run "sh Configure". + +When confronted with this prompt: + +=begin text First time through, eh? I have some defaults handy for the following systems: @@ -31,29 +96,76 @@ project and the Cygwin32 API. . Which of these apply, if any? - Select "cygwin32". +=end text + +guess what system do you have. (hint: select "cygwin32"). + +i do not use malloc that comes with perl, but haven't put this setting +to hints file. perl defaults to use own malloc. + +Configure proposes additional -fpic flag for shared library module +compilation. say "none" because gcc complains that -fpic is useless. + +i hope that further defaults are ok. please double-chek it. + +=head2 make + +run "make". after that, run "make test" to see how unstable your system is. +for me, lib/io_sock.t waits for died child that has to be killed manually. +other test scripts seem to be more or less harmless. the result of +./perl harness reads: + +=begin text + +Failed Test Status Wstat Total Fail Failed List of failed +------------------------------------------------------------------------------- +lib/anydbm.t 2 512 12 8 66.67% 5-12 +lib/findbin.t 1 1 100.00% 1 +lib/io_sock.t 1 256 5 4 80.00% 2-5 +lib/sdbm.t 2 512 18 15 83.33% 2, 5-18 +op/magic.t 35 3 8.57% 1, 23, 30 +op/stat.t 58 3 5.17% 2, 9, 26 +pragma/locale.t 11 2816 102 4 3.92% 99-102 +8 tests skipped, plus 35 subtests skipped. +Failed 7/190 test scripts, 96.32% okay. 38/6454 subtests failed, 99.41% okay. + +=end text + +=head1 BUGS + +a lot of warnings about incompatible pointer types and comparison +lacking a cast. this is because of __declspec(dllimport). + +upon each start, make warns that a rule for perlmain.o is overrided. +yes, it is. in order to use libperl.dll, perlmain needs to import +symbols from there. i saw no better solution than adding an explicit +define to the rule. + +as said above, IO::Socket generates access violation. don't know why. +don't need IO::Socket for now. + +make clean does not remove library .def and .exe.core files + +ld2 script is installed with reference to source directory. you should +change this to /usr/local/bin (or whatever) after install. + +.bat wrappers for installed utility scripts are not made during installation. - The defaults should be OK for everything, except for the specific - pathnames for the cygwin32 libs, include files, installation dirs, - etc. on your system; answer those questions appropriately. +library man pages are not installed correctly due to file system limitations. +use perldoc script to read about things like foo::bar. - NOTE: On windows 95, the configuration script only stops every other - time for responses from the command line. In this case you can manually - copy hints/cygwin32.sh to config.sh, edit config.sh for your paths, and - run Configure non-interactively using sh Configure -d. +=head1 AUTHOR -5) Run "make" as stated in the perl README file. +alexander smishlajev <als@turnhere.com> -6) Run "make test". Some tests will fail, but you should get around a - 83% success rate. (Most failures seem to be due to Unixisms that don't - apply to win32.) +=head1 DISCLAIMER -7) Install. If you just run "perl installperl", it appears that perl - can't find itself when it forks because it changes to another directory - during the install process. You can get around this by invoking the - install script using a full pathname for perl, such as: +i am not going to maintain this document or this port. i only wanted +to make perl porting a bit easier. if failed, i can't be helpful for you. - /perl5.004/perl installperl +=head1 HISTORY - This should complete the installation process. +17..25-apr-1999. perl 5.005_03. cygwin b20.1 egcs 1.1.2. + far 1.60. nescafe classic. +=cut @@ -4,7 +4,13 @@ # ifdef PERL_OBJECT # define XS(name) void name(CV* cv, CPerlObj* pPerl) # else -# define XS(name) void name(CV* cv) +# if defined(CYGWIN32) && defined(USE_DYNAMIC_LOADING) +# define XS(name) __declspec(dllexport) void name(CV* cv) + extern struct _reent *_impure_ptr; + void impure_setup(struct _reent *_impure_ptrMain); +# else +# define XS(name) void name(CV* cv) +# endif # endif #else # define XS(name) void name(cv) CV* cv; diff --git a/bytecode.h b/bytecode.h index 8564aed411..9f4f781b8e 100644 --- a/bytecode.h +++ b/bytecode.h @@ -154,7 +154,10 @@ typedef IV IV64; o->op_ppaddr = PL_ppaddr[arg]; \ } STMT_END #define BSET_op_ppaddr(o, arg) croak("op_ppaddr not yet implemented") -#define BSET_curpad(pad, arg) pad = AvARRAY(arg) +#define BSET_curpad(pad, arg) STMT_START { \ + PL_comppad = (AV *)arg; \ + pad = AvARRAY(arg); \ + } STMT_END #define BSET_OBJ_STORE(obj, ix) \ (I32)ix > PL_bytecode_obj_list_fill ? \ diff --git a/bytecode.pl b/bytecode.pl index 126ea5ff00..c61b7aa04e 100644 --- a/bytecode.pl +++ b/bytecode.pl @@ -386,6 +386,7 @@ cop_filegv *(SV**)&cCOP->cop_filegv svindex cop_seq cCOP->cop_seq U32 cop_arybase cCOP->cop_arybase I32 cop_line cCOP->cop_line line_t +cop_warnings cCOP->cop_warnings svindex main_start PL_main_start opindex main_root PL_main_root opindex curpad PL_curpad svindex x @@ -838,21 +838,28 @@ void byterun(PerlIO *fp) cCOP->cop_line = arg; break; } - case INSN_MAIN_START: /* 116 */ + case INSN_COP_WARNINGS: /* 116 */ + { + svindex arg; + BGET_svindex(arg); + cCOP->cop_warnings = arg; + break; + } + case INSN_MAIN_START: /* 117 */ { opindex arg; BGET_opindex(arg); PL_main_start = arg; break; } - case INSN_MAIN_ROOT: /* 117 */ + case INSN_MAIN_ROOT: /* 118 */ { opindex arg; BGET_opindex(arg); PL_main_root = arg; break; } - case INSN_CURPAD: /* 118 */ + case INSN_CURPAD: /* 119 */ { svindex arg; BGET_svindex(arg); @@ -17,9 +17,7 @@ struct bytestream { }; #endif /* INDIRECT_BGET_MACROS */ -#ifndef PERL_OBJECT void *bset_obj_store _((void *, I32)); -#endif enum { INSN_RET, /* 0 */ @@ -138,10 +136,11 @@ enum { INSN_COP_SEQ, /* 113 */ INSN_COP_ARYBASE, /* 114 */ INSN_COP_LINE, /* 115 */ - INSN_MAIN_START, /* 116 */ - INSN_MAIN_ROOT, /* 117 */ - INSN_CURPAD, /* 118 */ - MAX_INSN = 118 + INSN_COP_WARNINGS, /* 116 */ + INSN_MAIN_START, /* 117 */ + INSN_MAIN_ROOT, /* 118 */ + INSN_CURPAD, /* 119 */ + MAX_INSN = 119 }; enum { @@ -76,7 +76,10 @@ for file do : allow variables like toke_cflags to be evaluated - eval 'eval ${'"${file}_cflags"'-""}' + if echo $file | grep -v / >/dev/null + then + eval 'eval ${'"${file}_cflags"'-""}' + fi : or customize here diff --git a/config_h.SH b/config_h.SH index f933c78d23..00388e0fa6 100644 --- a/config_h.SH +++ b/config_h.SH @@ -1449,17 +1449,17 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- * This macro surrounds its token with double quotes. */ #if $cpp_stuff == 1 -#define CAT2(a,b)a/**/b -#define STRINGIFY(a)"a" +# define CAT2(a,b)a/**/b +# define STRINGIFY(a)"a" /* If you can get stringification with catify, tell me how! */ -#endif -#if $cpp_stuff == 42 -#define CAT2(a,b)a ## b -#define StGiFy(a)# a -#define STRINGIFY(a)StGiFy(a) -#endif -#if $cpp_stuff != 1 && $cpp_stuff != 42 -#include "Bletch: How does this C preprocessor catenate tokens?" +#else +# if $cpp_stuff == 42 +# define CAT2(a,b)a ## b +# define StGiFy(a)# a +# define STRINGIFY(a)StGiFy(a) +# else +# include "Bletch: How does this C preprocessor catenate tokens?" +# endif #endif /* CPPSTDIN: diff --git a/configure.com b/configure.com index e31d98bd65..388ba6b929 100644 --- a/configure.com +++ b/configure.com @@ -39,6 +39,7 @@ $ cat = "type" $ gcc_symbol = "gcc" $ ans = "" $ macros = "" +$ use_vmsdebug_perl = "N" $ use_debugging_perl = "Y" $ C_Compiler_Replace = "CC=" $ Thread_Live_Dangerously = "MT=" @@ -1670,6 +1671,24 @@ $ IF ans.eqs."socketshr" then has_socketshr = "T" $ endif $! $! +$! Ask if they want to build with VMS_DEBUG perl +$ echo "Perl can be built to run under the VMS debugger." +$ echo "You should only select this option if you are debugging" +$ echo "perl itself. This can be a useful feature if you are " +$ echo "embedding perl in a program." +$ echo "" +$ dflt = "N" +$ rp = "Build a VMS-DEBUG version of Perl? [''dflt'] " +$ GOSUB myread +$ if ans.eqs."" then ans = dflt +$ if (f$extract(0, 1, "''ans'").eqs."Y").or.(f$extract(0, 1, "''ans'").eqs."y") +$ THEN +$ use_vmsdebug_perl = "Y" +$ macros = macros + """__DEBUG__=1""," +$ ELSE +$ use_vmsdebug_perl = "N" +$ ENDIF +$! $! Ask if they want to build with MULTIPLICITY $ echo "The perl interpreter engine can be built in a way that makes it $ echo "possible for a program that embeds perl into it (and yep, you can @@ -1988,11 +2007,25 @@ $ ELSE $ WRITE CONFIG "$! This perl configured & administered by ''perladmin'" $ ENDIF $ WRITE CONFIG "$!" +$ prefix = prefix - "000000." $ IF F$LOCATE(".]",prefix) .EQ. F$LENGTH(prefix) THEN - prefix = prefix - "]" + ".]" $ WRITE CONFIG "$ define/translation=concealed Perl_Root ''prefix'" -$ WRITE CONFIG "$ perl :== $Perl_Root:[000000]Perl" -$ WRITE CONFIG "$ define PerlShr Perl_Root:[000000]PerlShr.Exe" +$ write config "$ ext = "".exe""" +$ if sharedperl .eqs. "Y" +$ then +$ write config "$ if f$getsyi(""ARCH_NAME"") .nes. ""VAX"" then ext = "".AXE""" +$ endif +$ IF use_vmsdebug_perl .eqs. "Y" +$ then +$ WRITE CONFIG "$ dbgperl :== $Perl_Root:[000000]dbgPerl'ext'" +$ WRITE CONFIG "$ perl :== $Perl_Root:[000000]ndbgPerl'ext'" +$ WRITE CONFIG "$ define dbgPerlShr Perl_Root:[000000]dbgPerlShr'ext'" +$ else +$ WRITE CONFIG "$ perl :== $Perl_Root:[000000]Perl'ext'" +$ WRITE CONFIG "$ define PerlShr Perl_Root:[000000]PerlShr'ext'" +$ endif +$! $ IF (tzneedset) $ THEN $ WRITE CONFIG "$ define SYS$TIMEZONE_DIFFERENTIAL ''tzd'" diff --git a/cygwin32/Makefile.SHs b/cygwin32/Makefile.SHs new file mode 100644 index 0000000000..fcbc318022 --- /dev/null +++ b/cygwin32/Makefile.SHs @@ -0,0 +1,176 @@ +# This file is read by Makefile.SH to produce rules for $(LIBPERL) (and +# some additional rules as well). + +# Rerun `sh Makefile.SH; make depend' after making any change. + +# Additional rules supported: libperls.a (for static linking), +# ld2, perlld (dynamic linking tools) +# + +#! /bin/sh +case $CONFIG in +'') + if test -f config.sh; then TOP=.; + elif test -f ../config.sh; then TOP=..; + elif test -f ../../config.sh; then TOP=../..; + elif test -f ../../../config.sh; then TOP=../../..; + elif test -f ../../../../config.sh; then TOP=../../../..; + else + echo "Can't find config.sh."; exit 1 + fi + . $TOP/config.sh + ;; +esac + +addtopath=`pwd` +$spitshell >>Makefile <<!GROK!THIS! + +# shell script feeding perlld to decent perl +ld2: $& Makefile perlld ${src}/cygwin32/ld2.in ${src}/impure_ptr\$(OBJ_EXT) + @echo "extracting ld2 (with variable substitutions)" + @$sed s,@buildpath@,$addtopath,g <${src}/cygwin32/ld2.in >ld2 +!GROK!THIS! + +$spitshell >>Makefile <<!GROK!THIS! + +# perlld parameters +# +# this one is pretty mandatory +DLLWRAP = 'dllwrap' + +# following are optional. +WRAPDRIVER = gcc +DLLTOOL = dlltool +EXPORT_ALL = 1 + +# if some of extensions are empty, +# no corresponding output will be done. +# most probably, you'd like to have an export library +DEF_EXT = .def +EXP_EXT = .exp + +perlld: $& Makefile ${src}/cygwin32/perlld.in ${src}/impure_ptr\$(OBJ_EXT) + @echo "extracting perlld (with variable substitutions)" + @$sed -e s,@CC@,\${CC}, -e s,@DLLWRAP@,\${DLLWRAP},g \\ + -e s,@WRAPDRIVER@,\${WRAPDRIVER},g -e s,@DLLTOOL@,\${DLLTOOL},g \\ + -e s,@AS@,\${AS},g -e s,@EXPORT_ALL@,\${EXPORT_ALL},g \\ + -e s,@DEF_EXT@,\${DEF_EXT},g -e s,@EXP_EXT@,\${EXP_EXT},g \\ + -e s,@LIB_EXT@,\${LIB_EXT},g \\ + ${src}/cygwin32/perlld.in >perlld + +!GROK!THIS! + +# make sure that all library names are not malformed +libperl=`echo $libperl|sed -e s,\\\..*,,` + +# it would be nice to allow dll to have any name, +# but for now i insist on 'lib<whatever>.dll' +if ( ! ( echo $libperl | grep '^lib' >/dev/null ) ) +then + libperl=lib$libperl +fi +linklibperl=-l`echo $libperl|sed -e s,^lib,,` + +$spitshell >>Makefile <<!GROK!THIS! +LIBPERL = $libperl +LLIBPERL= $linklibperl +LDLIBPTH= PATH=$addtopath:\${PATH} +CLDFLAGS= -L$addtopath $ldflags +CAT = $cat +AWK = $awk +!GROK!THIS! + +case "$useshrplib" in +true) + $spitshell >>Makefile <<'!NO!SUBS!' +# impure pointer initialisation +cwobj = impure_ptr$(OBJ_EXT) $(obj) + +# override default rule (NB: make croaks!) to force dll usage +perlmain$(OBJ_EXT): perlmain.c + $(CCCMD) $(PLDLFLAGS) -DUSEIMPORTLIB=\"$(LIBPERL)$(LIB_EXT)\" $*.c + +# library used to make statically linked executables +# miniperl is linked against it to avoid libperl.dll locking +$(LIBPERL)s$(LIB_EXT): $& perl$(OBJ_EXT) $(cwobj) + $(AR) rcu $@ perl$(OBJ_EXT) $(cwobj) + +impure_ptr$(OBJ_EXT): cygwin32/impure_ptr.c + $(CCCMD) $(PLDLFLAGS) cygwin32/impure_ptr.c + +# dll and import library +$(LIBPERL)$(LIB_EXT): $& perl$(OBJ_EXT) $(cwobj) ld2 + $(LDLIBPTH) ld2 $(SHRPLDFLAGS) -o $(LIBPERL)$(DLSUFFIX) \ + perl$(OBJ_EXT) $(cwobj) $(libs) + +# How to build executables. + +# The miniperl -w -MExporter line is a basic cheap test to catch errors +# before make goes on to run preplibrary and then MakeMaker on extensions. +# This is very handy because later errors are often caused by miniperl +# build problems but that's not obvious to the novice. +# The Module used here must not depend on Config or any extensions. + +miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL)s$(LIB_EXT) + $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) $(LLIBPERL)s $(libs) + $(LDLIBPTH) ./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest + +!NO!SUBS! + ;; +*) +$spitshell >>Makefile <<'!NO!SUBS!' + +# perl library +$(LIBPERL)$(LIB_EXT): $& perl$(OBJ_EXT) $(cwobj) + $(AR) rcu $@ perl$(OBJ_EXT) $(cwobj) + +# How to build executables. + +# The miniperl -w -MExporter line is a basic cheap test to catch errors +# before make goes on to run preplibrary and then MakeMaker on extensions. +# This is very handy because later errors are often caused by miniperl +# build problems but that's not obvious to the novice. +# The Module used here must not depend on Config or any extensions. + +miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL)$(LIB_EXT) + $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) $(LLIBPERL) $(libs) + $(LDLIBPTH) ./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest + +!NO!SUBS! + ;; +esac + +# libperl.a is _the_ library both in dll and static cases +# $(LIBPERL)$(LIB_EXT) expands to this name dependless of build model +# +$spitshell >>Makefile <<'!NO!SUBS!' + +perl: $& perlmain$(OBJ_EXT) $(LIBPERL)$(LIB_EXT) $(DYNALOADER) $(static_ext) ext.libs + $(SHRPENV) $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) + +pureperl: $& perlmain$(OBJ_EXT) $(LIBPERL)$(LIB_EXT) $(DYNALOADER) $(static_ext) ext.libs + $(SHRPENV) $(LDLIBPTH) purify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) + +purecovperl: $& perlmain$(OBJ_EXT) $(LIBPERL)$(LIB_EXT) $(DYNALOADER) $(static_ext) ext.libs + $(SHRPENV) $(LDLIBPTH) purecov $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o purecovperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) + +quantperl: $& perlmain$(OBJ_EXT) $(LIBPERL)$(LIB_EXT) $(DYNALOADER) $(static_ext) ext.libs + $(SHRPENV) $(LDLIBPTH) quantify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) + +!NO!SUBS! + +# suid perl is removed - i've never seen suid scripts for win32 + +############################################## +# additional targets + +$spitshell >>Makefile <<'!NO!SUBS!' + +DIST_DIRECTORY = .dist + +distdir: miniperl + -mkdir $(DIST_DIRECTORY) + ./miniperl '-MExtUtils::Manifest' \ + -e "ExtUtils::Manifest::manicopy(ExtUtils::Manifest::maniread(),'$(DIST_DIRECTORY)')" + +!NO!SUBS! diff --git a/cygwin32/build-instructions.READFIRST b/cygwin32/build-instructions.READFIRST new file mode 100644 index 0000000000..4cdd1990d7 --- /dev/null +++ b/cygwin32/build-instructions.READFIRST @@ -0,0 +1,37 @@ +The perl source distribution is available from + http://www.cpan.org/src/index.html + +For the easiest build of perl under Cygwin, do the following: + +(1) read + *(a) README.cygwin from the perl source distribution + *(b) read build-instructions.charles-wilson + (b) read build-instructions.sebastien-barre + (c) read build-instructions.steven-morlock + (d) read build-instructions.steven-morlock2 + (e) read build-instructions.teun-burgers + +(2) prepare the source + (a) unpack perl source distribution in /usr/local/src + (b) copy perl5.005_03.patch into /usr/local/src/perl5.005_03/ + (c) cd /usr/local/src/perl5.005_03 + (d) chmod -R +w * + (e) patch -p1 < perl5.005_03.patch + +(3) get ready to build + (a) cp cygwin32/* . + (b) cp gcc2 /usr/local/bin + (c) cp ld2 /usr/local/bin + (d) cp hints/cygwin32.sh config.sh + (e) sh Configure -d + (automatically does a make depend) + +(4) build and install + (b) make + (c) make test + (d) make install + +To customize, look around in the patchfile or ignore the patch and follow the build-instructions.* directly. If you want to edit the paths in the patchfile to reflect your system, search for "/usr/" within the patchfile. + +* MUST read. + diff --git a/cygwin32/build-instructions.charles-wilson b/cygwin32/build-instructions.charles-wilson new file mode 100644 index 0000000000..e758d34d23 --- /dev/null +++ b/cygwin32/build-instructions.charles-wilson @@ -0,0 +1,71 @@ +DATE: 2 April 99 + +Here are a few hints for building perl with cygwin: + +(1) There have been some problems compiling with the default compiler installed with cygwin-b20.1. Some of the patches in perl5.005_03.patch attempt to correct this, but it would probably be a good idea to upgrade your compiler to egcs-1.1.1 (or better) from Mumit Khan's website -- http://www.xraylith.wisc.edu/~khan/software/gnu-win32/ + +(2) To avoid some failures when doing a "make test", use CYGWIN=ntea while testing. However, see the Cygwin FAQ concerning the use of ntea with FAT partitions. The tests that fail are those that deal with file ownership and access. + +(3) Perl should build without trouble under text mounts or binary mounts. However, some tests ("make test") may fail when using text mounts. The tests that fail are those that involve using tie() to attach a hashtable variable to a file. + +(4) As of 3/8/98, building and linking new modules into the perl executable rus into problems when using binary mounts. We're still tracking this one down. + +(5) There have been a few hints that some tests may also fail depending on whether you're building, testing, and/or installing as a normal user, or as a member of the Administrators group (NT only). However, we're not sure about this one yet. + +(6) When compiling static modules for perl, don't mix modules compiled under text mounts and modules compiled under binary mounts. + +(7) The sourcefiles in the tarball extract as "-r--r--r--" by default, so you need to "chmod -R +w *' in order to patch successfully. + +(8) To make life easier, you should download ftp://ftp.franken.de/pub/win32/develop/gnuwin32/cygwin/porters/Humblet_Pierre_A/install-cygwin-b20.sh, and use it as your install "executable." Just follow the instructions that are embedding as comments in the .sh file. + +(9) There were a number of failed operations when installing. These were + (a) trying to create man pages whose names had ":" in them -- i.e. man/man3/Tie::Array.3 + (b) for some reason, the installer had difficulty copying the SRCDIR/pod/*.pod files to /usr/local/lib/perl5/perl5.00503/pod/ directory. I did it by hand. It's not really that important - the pod files are converted to man pages, and the man pages are installed successfully. So you don't really need to keep the pod's around. + + +RESULTS: +**************************************************** + +I built and tested as a normal user (not Administrator and not a member of the Administrators group). However, I had to switch to Administrator to install because the permissions on my /usr/local/bin were wrong. + +RESULTS: make test +------------------ + +Failed 4 test scripts out of 190, 92.63% okay. +u=2.143 s=4.897 cu=120.165 cs=159.697 scripts=180 tests=6430 + +RESULTS: ./perl harness +----------------------- +most things were "foo/bar............ok" with the following exceptions: + + +base/rs.............ok, 4/14 subtests skipped +op/groups...........skipping test on this platform +op/magic............FAILED test 23 + Failed 1/35 tests, 97.14% okay (-4 skipped tests: 30 okay, 85.71%) +op/stat.............ls: /dev: No such file or directory +FAILED tests 4, 35 + Failed 2/58 tests, 96.55% okay +op/taint............FAILED tests 1, 3, 31 + Failed 3/149 tests, 97.99% okay (-12 skipped tests: 134 okay, 89.93%) + (Also got the following popup message four times - "The dynamic link + library cygwin1.dll could not be found in the specified path + F:\cygnus\cygwin-b20\usr\local\src\perl5.005_03\t;.; + E:\WINNT\System32;E:\WINNT\system;E:\WINNT;..") +lib/findbin.........FAILED test 1 + Failed 1/1 tests, 0.00% okay +lib/gdbm............skipping test on this platform +lib/ipc_sysv........skipping test on this platform +lib/ndbm............skipping test on this platform +lib/odbm............skipping test on this platform +lib/posix...........skipping test on this platform +lib/thread..........skipping test on this platform + +Failed Test Status Wstat Total Fail Failed List of failed +------------------------------------------------------------------------------- +lib/findbin.t 1 1 100.00% 1 +op/magic.t 35 1 2.86% 23 +op/stat.t 58 2 3.45% 4, 35 +op/taint.t 149 3 2.01% 1, 3, 31 +10 tests skipped, plus 20 subtests skipped. +Failed 4/190 test scripts, 97.89% okay. 7/6430 subtests failed, 99.89% okay. diff --git a/cygwin32/build-instructions.sebastien-barre b/cygwin32/build-instructions.sebastien-barre new file mode 100644 index 0000000000..3e29b35d66 --- /dev/null +++ b/cygwin32/build-instructions.sebastien-barre @@ -0,0 +1,69 @@ +The included patch, perl5.005_02.patch, implements all of the suggestions below. Results in a static build, 93.85% successful test on NT. + + +********************************** +Subject: Re: Compiling Perl under b20.1 + Date: Fri, 05 Mar 1999 16:41:52 +0100 + From: Sebastien Barre <Sebastien.Barre@utc.fr> + To: Allan Peda <allan@interport.net> + CC: Cygwin Mailing List <cygwin@sourceware.cygnus.com> + +At 22:04 04/03/99 -0500, Allan Peda wrote: + +>Has there been much success with this? I've done it with MSVC + nmake, +>but I'd get more of a thrill using cygwin. + +I did (5.005_002 static build, 91.4% successfull test). + +As many people from this list helped me, I'd glad to offer the same. + +Basically, + +*) Read the README.cywin32 + +*) Edit the hints/cygwin32.sh file to reflect your paths. + +Here are also a couple of settings I found useful when performing automatic +build (copy hints/cygwin32.sh to config.sh, and do sh Configure -d) + +usedl='n' +i_stdarg='define' +i_varargs='undef' +osname='cygwin_nt-4.0' +osvers='20.1' +archname='cygwin32' +signal_t='int' +d_voidsig='define' +i_sysselct='undef' +signal_t='void' + +*) Browse Usenet archives (DejaNews), and find "HOWTO: Builiding Perl +under Win95/98 using Cygwin32 " +Steven Morlock <newspost@morlock.net> +1998/12/21 +comp.lang.perl.misc + +*) Then apply this patch (Thanks to Todd Goodman) + +This is my change in Cwd.pm: +--- cwd.pm Fri Feb 26 21:52:42 1999 ++++ cwd.pm.orig Fri Jan 22 20:49:54 1999 +@@ -208,8 +208,6 @@ + my $start = @_ ? shift : '.'; + my($dotdots, $cwd, @pst, @cst, $dir, @tst); + +- return cwd() if ( $^O =~ /cygwin/ ); +- + unless (@cst = stat( $start )) + { + +And tell me (email) if it fails. + +______________________________________________________________ +Sebastien Barre http://www.hds.utc.fr/~barre/ + +-- +Want to unsubscribe from this list? +Send a message to cygwin-unsubscribe@sourceware.cygnus.com + + diff --git a/cygwin32/build-instructions.steven-morlock b/cygwin32/build-instructions.steven-morlock new file mode 100644 index 0000000000..58d19936c3 --- /dev/null +++ b/cygwin32/build-instructions.steven-morlock @@ -0,0 +1,235 @@ +From comp.lang.perl.misc. The included patch, perl5.005_02.patch, implements most of the suggestions below. My observations during the build process are commented within the body of Mr. Morlock's message, set off by ******CSW****** + + +************************************** +Subject: HOWTO: Builiding Perl under Win95/98 using Cygwin32 +Author: Steven Morlock <newspost@morlock.net> +Date: 1998/12/21 +Forum: comp.lang.perl.misc + +If you have a desire to build Perl under Windows 95/98 using Cygnus' +Cygwin Win32 ports of the GNU development tools (Cygwin32) you might +get something out of my experience of building it. + +An advantage of the versions Perl built with Cygwin32 is that Cygwin32 +has a POSIX compatible library including support for the fork() function. + +Steve + +-- +Steven Morlock +Foliage Software Systems +aka The Nerd Farm +http://www.foliage.com +== + +These are the steps I took to build the latest development +version of Perl (5.005.53) under the Windows 95 & Window 98 +operating system using Cygnus' Cygwin Win32 ports of the GNU +development tools. + +The release of the Cygwin32 tools used was B20.1. These tools +can be found at: + + http://sourceware.cygnus.com/cygwin + +Install Cygwin32 as described on the Cygnus web site. Additionally +you should mount /bin as described in the following document: + + http://sourceware.cygnus.com/cygwin/cygwin-ug-net/setup-mount.html + +Note that the mount command shown in their example should appear on a +single line: + + mount C:/cygnus/cygwin-b20/H-i586-cygwin32/bin /bin + +You must run the described build process below under the Cygwin32 +'bash' shell. + +In the following <PERL> will refer to the perl source/build +directory. <INST> will refer to the perl target/install directory. + +* Pre-build checklist: + + - I found that building Perl on a unmounted partition/drive other than the + root will fail. It appears that the double forward slash that Cygwin32 + uses to reference drives other than the root drive (typically C:) gets + converted to a single forward slash at several points in the build process. + I have not tried, but expect it would work, to mount the non-root drive. + This problem held true for both the drive where the perl source were and + the drive where the Cygwin32 binaries where located. In the build + described in these notes the Perl source and Cygwin32 binaries were located + on the root drive. + + - Following the instructions in <PERL>/README.cygwin32: +*******CSW******** +apply the patch, first +****************** + + + Copy the contents of the <PERL>cygwin32 directory to <PERL> + + + Edit the 'ld2' & 'gcc2' scripts to reflect the build path <PERL> + + + Either move 'ld2' & 'gcc2' to a directory on your path or add + <PERL> to you path. + + - Edit <PERL>/hints/cygwin32.sh: + + + Add the following lines to the script: +*******CSW******** +the patch does this +****************** + i_stdarg='define' + i_varargs='undef' + + This change allows us to pick up the right version of va_start(). + Cygwin32 has both a signal and double parameter versions floating + around in their header files. + + + Remove support for dynamic linking. I found that all DynaLoader'd + extensions crashed during the running of the test suite. Add or edit + 'usedl' entry to read: +*******CSW******** +the patch does this +****************** + usedl='n' + + If there is enough push I will try to sort out the problems with + dynamic loading. I have made several unsuccessful attempts at + modifying <PERL>/perlld to fix this problem. If you are interested, + write me. + + + Change the path to the Cygwin32 directories. This includes the + entries for 'usrinc', 'libpth', 'lddlflags', 'libc' and 'usrinc'. +*******CSW******** +the patch does this ^ +****************** + + - Edit makedepend.SH. The original version of makedepend.SH produces + dependencies that include double backslashes. This can not be processed + by Cygwin32's 'make'. Apply the following modification to makedepend.SH + to correct these unfortunate filenames: +*******CSW******** +and this, as well \/ +****************** + +*** makedepend.SH.ORIG Wed Sep 23 09:51:56 1998 +--- makedepend.SH Mon Dec 21 09:27:30 1998 +*************** +*** 100,105 **** +--- 100,107 ---- + # for file in `cat /dev/null`; do + if [ "$osname" = uwin ]; then + uwinfix="-e s,\\\\\\\\,/,g -e s,\\([a-zA-Z]\\):/,/\\1/,g" ++ elif [ "$archname" = cygwin32 ]; then ++ uwinfix="-e s,\\\\\\\\,/,g" + else + uwinfix= + fi + + - Edit config_h.SH. The original version of config_h.SH has an bogus + #include that gets propagated into the dependency list in Makefile + create from the makedepend script. The Apply the following modification + to config_h.SH to work around this unfortunate filename: +*******CSW******** +the patch does this, too +****************** + +*** config_h.SH.ORIG Wed Oct 28 23:16:10 1998 +--- config_h.SH Mon Dec 21 10:14:28 1998 +*************** +*** 1412,1416 **** + #endif + #if $cpp_stuff != 1 && $cpp_stuff != 42 +! #include "Bletch: How does this C preprocessor catenate tokens?" + #endif + +--- 1412,1416 ---- + #endif + #if $cpp_stuff != 1 && $cpp_stuff != 42 +! #include "#Bletch: How does this C preprocessor catenate tokens?" + #endif + + The real source of the problem appears that the 'make depend' in the + 'x2p' directory has problems. The following messages are generated by + that 'make depend': + + Finding dependencies for hash.o. + gcc2: Can't open gcc2 + ... [similar messages to above] + You don't seem to have a proper C preprocessor. Using grep instead. + Updating GNUmakefile... + + So the grep is pulling the bogus #include from the file. The patch + turns the #include'd message into a comment. + + - Run the Configure in the <PERL> directory as described in the document + <PERL>/README.cygwin32 + + I receive the message "THIS PACKAGE SEEMS INCOMPLETE.". This does not + appear to be a problem. + + When presented with the list of handy defaults, select 'cygwin32' + + You can use the defaults for the remainder of the prompts. + +* Building: + + - Issue the command 'make' in the directory <PERL>. + Cross fingers, wait and be patient. + +*******CSW******** +I didn't see this problem \/ +****************** + - I experience problems when building two files 'pp_sys.o' & 'doio.o'. The + build process will crash with a Windows dialog during the build of these two + files. The way I get by the problem is to control-C the make and issue + the build commands for the two files by hand. In the Perl directory issue + the following commands: + + `sh cflags libperl.a pp_sys.o` pp_sys.c + `sh cflags libperl.a doio.o` doio.c + + This appears to be a problem with Cygwin32's make. + + Hopefully if you follow the instructions above you will experience no + problems building Perl. + +* Testing: + + I found that the majority of the tests passed. There were no errors + that I thought particularly scary. There were several unexpected results + such as a couple 'A required .DLL file, CYGWIN1.DLL, was not found' dialogs + and 'Perl perform an illegal operation' dialogs. + +*******CSW******** +saw the "missing dll" during one test +****************** + + As long as I can run all my own scripts, things are fine by me... + + - Renamed or delete the file <PERL>/t/lib/io_sock.t so it will not be + executed. This test hangs the system. I have made no attempts to + fix the problem. From the <PERL> directory issue the following command: + +*******CSW******** +I didn't do this, and saw no problems. +****************** + + mv t/lib/io_sock.t t/lib/io_sock.t.ORIG + + - Issue the command 'make test' in the directory <PERL>. + Cross fingers, wait and be patient. + +* Installing: + + The install seems to work okay. There are problems when install the man + pages, but we don't need any stinkin' man pages, right? + +*******CSW******** +the man pages that didn't install were those that had "::" in their filename. +****************** + + - Issue the command 'make install' in the directory <PERL>. + +Configuration files available by request to perl@morlock.net diff --git a/cygwin32/build-instructions.steven-morlock2 b/cygwin32/build-instructions.steven-morlock2 new file mode 100644 index 0000000000..0370b7053c --- /dev/null +++ b/cygwin32/build-instructions.steven-morlock2 @@ -0,0 +1,76 @@ +This is an addendum to Steven Morlock's original post. The patch, perl5.005_02.patch, contains the USEMYBINMODE correction described below. + +***************************** +Subject: Re: HOWTO: Builiding Perl under Win95/98 using Cygwin32 +Author: Steven Morlock <newspost@morlock.net> +Date: 1998/12/22 +Forum: comp.lang.perl.misc + +I realized that in my original post I left out a couple important +details. I'd like to correct that here. + +There is a need to address the issue of end of lines being CR/NL or +NL on the Windows platform. Cygwin32 by default converts NL to CR/NL +during file I/O by non Cygwin32-savvy applications. This means that +Perl, since it does not support 'binmode' for the Cygwin32 platform, will +not be able to read & write untranslated/binary files. There are two +methods of over coming this. The first is to mount the Cygwin32 +partitions in binary mode. The second is to enable binmode support +in Perl. In the original post I had mounted the partition as binary +and neglected to include that fact in the post. + +* Using a binary partition: + + Mount the Perl source & installation destination partitions in binary + mode. Refer to the Cygnus documentation on 'mount' for details: + + http://sourceware.cygnus.com/cygwin/cygwin-ug-net/mount.html + + On my system since everything was in the root partition I issued the + following commands from the bash shell: + + umount / + mount -b c:\\ / + + You must also get and install the gzip'd version of the Perl source code + archive. The zip'd version of the archive has all NL converted to CR/NL + pairs in all text files. So you should be downloading the files ending in + '.gz', not '.zip'. + +* Patching Perl to add Cygwin32 binmode support: + + For this method you can use either the gzip'd or zip'd version of the + Perl source archive. + + Apply the following patch to <PERL>/perl.h: + +*** perl.h.ORIG Tue Dec 22 09:22:42 1998 +--- perl.h Tue Dec 22 09:43:10 1998 +*************** +*** 1480,1483 **** +--- 1480,1495 ---- + #endif + ++ #if defined(__CYGWIN32__) ++ /* USEMYBINMODE ++ * This symbol, if defined, indicates that the program should ++ * use the routine my_binmode(FILE *fp, char iotype) to insure ++ * that a file is in "binary" mode -- that is, that no translation ++ * of bytes occurs on read or write operations. ++ */ ++ #define USEMYBINMODE / **/ ++ #define my_binmode(fp, iotype) \ ++ (PerlLIO_setmode(PerlIO_fileno(fp), O_BINARY) != -1 ? TRUE : NULL) ++ #endif ++ + #include "regexp.h" + #include "sv.h" + +Regards, +Steve + +-- +Steven Morlock +Foliage Software Systems +aka The Nerd Farm +http://www.foliage.com diff --git a/cygwin32/cw32imp.h b/cygwin32/cw32imp.h deleted file mode 100644 index 885cbb1202..0000000000 --- a/cygwin32/cw32imp.h +++ /dev/null @@ -1,355 +0,0 @@ -/* include file for building of extension libs using GNU-Win32 toolkit, - which is based on the Cygnus Cygwin32 API. This file is included by - the extension dlls when they are built. Global vars defined in perl - exe are referenced by the extension module dll by using __imp_varName, - where varName is the name of the global variable in perl.exe. - GNU-Win32 has no equivalent to MSVC's __declspec(dllimport) keyword to - define a imported global, so we have to use this approach to access - globals exported by perl.exe. - -jc 4/1/97 -*/ - -#define impure_setupptr (*__imp_impure_setupptr) -#define Perl_reall_srchlen (*__imp_Perl_reall_srchlen) -#define Perl_yychar (*__imp_Perl_yychar) -#define Perl_yycheck (*__imp_Perl_yycheck) -#define Perl_yydebug (*__imp_Perl_yydebug) -#define Perl_yydefred (*__imp_Perl_yydefred) -#define Perl_yydgoto (*__imp_Perl_yydgoto) -#define Perl_yyerrflag (*__imp_Perl_yyerrflag) -#define Perl_yygindex (*__imp_Perl_yygindex) -#define Perl_yylen (*__imp_Perl_yylen) -#define Perl_yylhs (*__imp_Perl_yylhs) -#define Perl_yylval (*__imp_Perl_yylval) -#define Perl_yynerrs (*__imp_Perl_yynerrs) -#define Perl_yyrindex (*__imp_Perl_yyrindex) -#define Perl_yysindex (*__imp_Perl_yysindex) -#define Perl_yytable (*__imp_Perl_yytable) -#define Perl_yyval (*__imp_Perl_yyval) -#define Perl_regarglen (*__imp_Perl_regarglen) -#define Perl_regdummy (*__imp_Perl_regdummy) -#define Perl_regkind (*__imp_Perl_regkind) -#define Perl_simple (*__imp_Perl_simple) -#define Perl_varies (*__imp_Perl_varies) -#define Perl_watchaddr (*__imp_Perl_watchaddr) -#define Perl_watchok (*__imp_Perl_watchok) -#define Argv (*__imp_Argv) -#define Cmd (*__imp_Cmd) -#define DBgv (*__imp_DBgv) -#define DBline (*__imp_DBline) -#define DBsignal (*__imp_DBsignal) -#define DBsingle (*__imp_DBsingle) -#define DBsub (*__imp_DBsub) -#define DBtrace (*__imp_DBtrace) -#define Error (*__imp_Error) -#define Perl_AMG_names (*__imp_Perl_AMG_names) -#define Perl_No (*__imp_Perl_No) -#define Perl_Sv (*__imp_Perl_Sv) -#define Perl_Xpv (*__imp_Perl_Xpv) -#define Perl_Yes (*__imp_Perl_Yes) -#define Perl_amagic_generation (*__imp_Perl_amagic_generation) -#define Perl_an (*__imp_Perl_an) -#define Perl_buf (*__imp_Perl_buf) -#define Perl_bufend (*__imp_Perl_bufend) -#define Perl_bufptr (*__imp_Perl_bufptr) -#define Perl_check (*__imp_Perl_check) -#define Perl_collation_ix (*__imp_Perl_collation_ix) -#define Perl_collation_name (*__imp_Perl_collation_name) -#define Perl_collation_standard (*__imp_Perl_collation_standard) -#define Perl_collxfrm_base (*__imp_Perl_collxfrm_base) -#define Perl_collxfrm_mult (*__imp_Perl_collxfrm_mult) -#define Perl_compcv (*__imp_Perl_compcv) -#define Perl_compiling (*__imp_Perl_compiling) -#define Perl_comppad (*__imp_Perl_comppad) -#define Perl_comppad_name (*__imp_Perl_comppad_name) -#define Perl_comppad_name_fill (*__imp_Perl_comppad_name_fill) -#define Perl_cop_seqmax (*__imp_Perl_cop_seqmax) -#define Perl_curcop (*__imp_Perl_curcop) -#define Perl_curcopdb (*__imp_Perl_curcopdb) -#define Perl_curinterp (*__imp_Perl_curinterp) -#define Perl_curpad (*__imp_Perl_curpad) -#define Perl_dc (*__imp_Perl_dc) -#define Perl_di (*__imp_Perl_di) -#define Perl_ds (*__imp_Perl_ds) -#define Perl_egid (*__imp_Perl_egid) -#define Perl_envgv (*__imp_Perl_envgv) -#define Perl_error_count (*__imp_Perl_error_count) -#define Perl_euid (*__imp_Perl_euid) -#define Perl_evalseq (*__imp_Perl_evalseq) -#define Perl_expect (*__imp_Perl_expect) -#define Perl_fold_locale (*__imp_Perl_fold_locale) -#define Perl_gid (*__imp_Perl_gid) -#define Perl_he_root (*__imp_Perl_he_root) -#define Perl_hexdigit (*__imp_Perl_hexdigit) -#define Perl_hints (*__imp_Perl_hints) -#define Perl_in_my (*__imp_Perl_in_my) -#define Perl_last_lop (*__imp_Perl_last_lop) -#define Perl_last_lop_op (*__imp_Perl_last_lop_op) -#define Perl_last_uni (*__imp_Perl_last_uni) -#define Perl_lex_brackets (*__imp_Perl_lex_brackets) -#define Perl_lex_brackstack (*__imp_Perl_lex_brackstack) -#define Perl_lex_casemods (*__imp_Perl_lex_casemods) -#define Perl_lex_casestack (*__imp_Perl_lex_casestack) -#define Perl_lex_defer (*__imp_Perl_lex_defer) -#define Perl_lex_dojoin (*__imp_Perl_lex_dojoin) -#define Perl_lex_expect (*__imp_Perl_lex_expect) -#define Perl_lex_fakebrack (*__imp_Perl_lex_fakebrack) -#define Perl_lex_formbrack (*__imp_Perl_lex_formbrack) -#define Perl_lex_inpat (*__imp_Perl_lex_inpat) -#define Perl_lex_inwhat (*__imp_Perl_lex_inwhat) -#define Perl_lex_op (*__imp_Perl_lex_op) -#define Perl_lex_repl (*__imp_Perl_lex_repl) -#define Perl_lex_starts (*__imp_Perl_lex_starts) -#define Perl_lex_state (*__imp_Perl_lex_state) -#define Perl_lex_stuff (*__imp_Perl_lex_stuff) -#define Perl_linestr (*__imp_Perl_linestr) -#define Perl_markstack (*__imp_Perl_markstack) -#define Perl_markstack_max (*__imp_Perl_markstack_max) -#define Perl_markstack_ptr (*__imp_Perl_markstack_ptr) -#define Perl_max_intro_pending (*__imp_Perl_max_intro_pending) -#define Perl_maxo (*__imp_Perl_maxo) -#define Perl_min_intro_pending (*__imp_Perl_min_intro_pending) -#define Perl_multi_close (*__imp_Perl_multi_close) -#define Perl_multi_end (*__imp_Perl_multi_end) -#define Perl_multi_open (*__imp_Perl_multi_open) -#define Perl_multi_start (*__imp_Perl_multi_start) -#define Perl_na (*__imp_Perl_na) -#define Perl_nexttoke (*__imp_Perl_nexttoke) -#define Perl_nexttype (*__imp_Perl_nexttype) -#define Perl_nextval (*__imp_Perl_nextval) -#define Perl_nomemok (*__imp_Perl_nomemok) -#define Perl_numeric_local (*__imp_Perl_numeric_local) -#define Perl_numeric_name (*__imp_Perl_numeric_name) -#define Perl_numeric_standard (*__imp_Perl_numeric_standard) -#define Perl_oldbufptr (*__imp_Perl_oldbufptr) -#define Perl_oldoldbufptr (*__imp_Perl_oldoldbufptr) -#define Perl_op (*__imp_Perl_op) -#define Perl_op_desc (*__imp_Perl_op_desc) -#define Perl_op_name (*__imp_Perl_op_name) -#define Perl_op_seqmax (*__imp_Perl_op_seqmax) -#define Perl_opargs (*__imp_Perl_opargs) -#define Perl_origalen (*__imp_Perl_origalen) -#define Perl_origenviron (*__imp_Perl_origenviron) -#define Perl_osname (*__imp_Perl_osname) -#define Perl_padix (*__imp_Perl_padix) -#define Perl_patleave (*__imp_Perl_patleave) -#define Perl_pidstatus (*__imp_Perl_pidstatus) -#define Perl_ppaddr (*__imp_Perl_ppaddr) -#define Perl_profiledata (*__imp_Perl_profiledata) -#define Perl_psig_name (*__imp_Perl_psig_name) -#define Perl_psig_ptr (*__imp_Perl_psig_ptr) -#define Perl_regbol (*__imp_Perl_regbol) -#define Perl_regcode (*__imp_Perl_regcode) -#define Perl_regendp (*__imp_Perl_regendp) -#define Perl_regeol (*__imp_Perl_regeol) -#define Perl_reginput (*__imp_Perl_reginput) -#define Perl_reglastparen (*__imp_Perl_reglastparen) -#define Perl_regnaughty (*__imp_Perl_regnaughty) -#define Perl_regnpar (*__imp_Perl_regnpar) -#define Perl_regparse (*__imp_Perl_regparse) -#define Perl_regprecomp (*__imp_Perl_regprecomp) -#define Perl_regprev (*__imp_Perl_regprev) -#define Perl_regsawback (*__imp_Perl_regsawback) -#define Perl_regsize (*__imp_Perl_regsize) -#define Perl_regstartp (*__imp_Perl_regstartp) -#define Perl_regtill (*__imp_Perl_regtill) -#define Perl_regxend (*__imp_Perl_regxend) -#define Perl_retstack (*__imp_Perl_retstack) -#define Perl_retstack_ix (*__imp_Perl_retstack_ix) -#define Perl_retstack_max (*__imp_Perl_retstack_max) -#define Perl_rsfp (*__imp_Perl_rsfp) -#define Perl_rsfp_filters (*__imp_Perl_rsfp_filters) -#define Perl_savestack (*__imp_Perl_savestack) -#define Perl_savestack_ix (*__imp_Perl_savestack_ix) -#define Perl_savestack_max (*__imp_Perl_savestack_max) -#define Perl_scopestack (*__imp_Perl_scopestack) -#define Perl_scopestack_ix (*__imp_Perl_scopestack_ix) -#define Perl_scopestack_max (*__imp_Perl_scopestack_max) -#define Perl_sh_path (*__imp_Perl_sh_path) -#define Perl_sig_name (*__imp_Perl_sig_name) -#define Perl_sig_num (*__imp_Perl_sig_num) -#define Perl_siggv (*__imp_Perl_siggv) -#define Perl_stack_base (*__imp_Perl_stack_base) -#define Perl_stack_max (*__imp_Perl_stack_max) -#define Perl_stack_sp (*__imp_Perl_stack_sp) -#define Perl_statbuf (*__imp_Perl_statbuf) -#define Perl_sub_generation (*__imp_Perl_sub_generation) -#define Perl_subline (*__imp_Perl_subline) -#define Perl_subname (*__imp_Perl_subname) -#define Perl_sv_no (*__imp_Perl_sv_no) -#define Perl_sv_undef (*__imp_Perl_sv_undef) -#define Perl_sv_yes (*__imp_Perl_sv_yes) -#define Perl_tainting (*__imp_Perl_tainting) -#define Perl_thisexpr (*__imp_Perl_thisexpr) -#define Perl_timesbuf (*__imp_Perl_timesbuf) -#define Perl_tokenbuf (*__imp_Perl_tokenbuf) -#define Perl_uid (*__imp_Perl_uid) -#define Perl_vert (*__imp_Perl_vert) -#define Perl_vtbl_amagic (*__imp_Perl_vtbl_amagic) -#define Perl_vtbl_amagicelem (*__imp_Perl_vtbl_amagicelem) -#define Perl_vtbl_arylen (*__imp_Perl_vtbl_arylen) -#define Perl_vtbl_bm (*__imp_Perl_vtbl_bm) -#define Perl_vtbl_collxfrm (*__imp_Perl_vtbl_collxfrm) -#define Perl_vtbl_dbline (*__imp_Perl_vtbl_dbline) -#define Perl_vtbl_env (*__imp_Perl_vtbl_env) -#define Perl_vtbl_envelem (*__imp_Perl_vtbl_envelem) -#define Perl_vtbl_fm (*__imp_Perl_vtbl_fm) -#define Perl_vtbl_glob (*__imp_Perl_vtbl_glob) -#define Perl_vtbl_isa (*__imp_Perl_vtbl_isa) -#define Perl_vtbl_isaelem (*__imp_Perl_vtbl_isaelem) -#define Perl_vtbl_itervar (*__imp_Perl_vtbl_itervar) -#define Perl_vtbl_mglob (*__imp_Perl_vtbl_mglob) -#define Perl_vtbl_nkeys (*__imp_Perl_vtbl_nkeys) -#define Perl_vtbl_pack (*__imp_Perl_vtbl_pack) -#define Perl_vtbl_packelem (*__imp_Perl_vtbl_packelem) -#define Perl_vtbl_pos (*__imp_Perl_vtbl_pos) -#define Perl_vtbl_sig (*__imp_Perl_vtbl_sig) -#define Perl_vtbl_sigelem (*__imp_Perl_vtbl_sigelem) -#define Perl_vtbl_substr (*__imp_Perl_vtbl_substr) -#define Perl_vtbl_sv (*__imp_Perl_vtbl_sv) -#define Perl_vtbl_taint (*__imp_Perl_vtbl_taint) -#define Perl_vtbl_uvar (*__imp_Perl_vtbl_uvar) -#define Perl_vtbl_vec (*__imp_Perl_vtbl_vec) -#define Perl_xiv_arenaroot (*__imp_Perl_xiv_arenaroot) -#define Perl_xiv_root (*__imp_Perl_xiv_root) -#define Perl_xnv_root (*__imp_Perl_xnv_root) -#define Perl_xpv_root (*__imp_Perl_xpv_root) -#define Perl_xrv_root (*__imp_Perl_xrv_root) -#define ampergv (*__imp_ampergv) -#define argvgv (*__imp_argvgv) -#define argvoutgv (*__imp_argvoutgv) -#define basetime (*__imp_basetime) -#define beginav (*__imp_beginav) -#define bodytarget (*__imp_bodytarget) -#define cddir (*__imp_cddir) -#define chopset (*__imp_chopset) -#define comppad_name_floor (*__imp_comppad_name_floor) -#define copline (*__imp_copline) -#define curpm (*__imp_curpm) -#define curstack (*__imp_curstack) -#define curstash (*__imp_curstash) -#define curstname (*__imp_curstname) -#define cxstack (*__imp_cxstack) -#define cxstack_ix (*__imp_cxstack_ix) -#define cxstack_max (*__imp_cxstack_max) -#define dbargs (*__imp_dbargs) -#define debdelim (*__imp_debdelim) -#define debname (*__imp_debname) -#define debstash (*__imp_debstash) -#define debug (*__imp_debug) -#define defgv (*__imp_defgv) -#define defoutgv (*__imp_defoutgv) -#define defstash (*__imp_defstash) -#define delaymagic (*__imp_delaymagic) -#define diehook (*__imp_diehook) -#define dirty (*__imp_dirty) -#define dlevel (*__imp_dlevel) -#define dlmax (*__imp_dlmax) -#define do_undump (*__imp_do_undump) -#define doextract (*__imp_doextract) -#define doswitches (*__imp_doswitches) -#define dowarn (*__imp_dowarn) -#define dumplvl (*__imp_dumplvl) -#define e_fp (*__imp_e_fp) -#define e_tmpname (*__imp_e_tmpname) -#define endav (*__imp_endav) -#define errgv (*__imp_errgv) -#define eval_root (*__imp_eval_root) -#define eval_start (*__imp_eval_start) -#define fdpid (*__imp_fdpid) -#define filemode (*__imp_filemode) -#define firstgv (*__imp_firstgv) -#define forkprocess (*__imp_forkprocess) -#define formfeed (*__imp_formfeed) -#define formtarget (*__imp_formtarget) -#define gensym (*__imp_gensym) -#define in_eval (*__imp_in_eval) -#define incgv (*__imp_incgv) -#define inplace (*__imp_inplace) -#define last_in_gv (*__imp_last_in_gv) -#define lastfd (*__imp_lastfd) -#define lastscream (*__imp_lastscream) -#define lastsize (*__imp_lastsize) -#define lastspbase (*__imp_lastspbase) -#define laststatval (*__imp_laststatval) -#define laststype (*__imp_laststype) -#define leftgv (*__imp_leftgv) -#define lineary (*__imp_lineary) -#define localizing (*__imp_localizing) -#define localpatches (*__imp_localpatches) -#define main_cv (*__imp_main_cv) -#define main_root (*__imp_main_root) -#define main_start (*__imp_main_start) -#define mainstack (*__imp_mainstack) -#define maxscream (*__imp_maxscream) -#define maxsysfd (*__imp_maxsysfd) -#define minus_F (*__imp_minus_F) -#define minus_a (*__imp_minus_a) -#define minus_c (*__imp_minus_c) -#define minus_l (*__imp_minus_l) -#define minus_n (*__imp_minus_n) -#define minus_p (*__imp_minus_p) -#define multiline (*__imp_multiline) -#define mystack_base (*__imp_mystack_base) -#define mystack_max (*__imp_mystack_max) -#define mystack_sp (*__imp_mystack_sp) -#define mystrk (*__imp_mystrk) -#define nice_chunk (*__imp_nice_chunk) -#define nice_chunk_size (*__imp_nice_chunk_size) -#define nrs (*__imp_nrs) -#define ofmt (*__imp_ofmt) -#define ofs (*__imp_ofs) -#define ofslen (*__imp_ofslen) -#define oldlastpm (*__imp_oldlastpm) -#define oldname (*__imp_oldname) -#define op_mask (*__imp_op_mask) -#define origargc (*__imp_origargc) -#define origargv (*__imp_origargv) -#define origfilename (*__imp_origfilename) -#define ors (*__imp_ors) -#define orslen (*__imp_orslen) -#define pad_reset_pending (*__imp_pad_reset_pending) -#define padix_floor (*__imp_padix_floor) -#define parsehook (*__imp_parsehook) -#define patchlevel (*__imp_patchlevel) -#define perl_destruct_level (*__imp_perl_destruct_level) -#define perldb (*__imp_perldb) -#define preambleav (*__imp_preambleav) -#define preambled (*__imp_preambled) -#define preprocess (*__imp_preprocess) -#define regflags (*__imp_regflags) -#define restartop (*__imp_restartop) -#define rightgv (*__imp_rightgv) -#define rs (*__imp_rs) -#define runlevel (*__imp_runlevel) -#define sawampersand (*__imp_sawampersand) -#define sawstudy (*__imp_sawstudy) -#define sawvec (*__imp_sawvec) -#define screamfirst (*__imp_screamfirst) -#define screamnext (*__imp_screamnext) -#define secondgv (*__imp_secondgv) -#define signalstack (*__imp_signalstack) -#define sortcop (*__imp_sortcop) -#define sortstack (*__imp_sortstack) -#define sortstash (*__imp_sortstash) -#define splitstr (*__imp_splitstr) -#define statcache (*__imp_statcache) -#define statgv (*__imp_statgv) -#define statname (*__imp_statname) -#define statusvalue (*__imp_statusvalue) -#define stdingv (*__imp_stdingv) -#define strchop (*__imp_strchop) -#define strtab (*__imp_strtab) -#define sv_arenaroot (*__imp_sv_arenaroot) -#define sv_count (*__imp_sv_count) -#define sv_objcount (*__imp_sv_objcount) -#define sv_root (*__imp_sv_root) -#define tainted (*__imp_tainted) -#define tmps_floor (*__imp_tmps_floor) -#define tmps_ix (*__imp_tmps_ix) -#define tmps_max (*__imp_tmps_max) -#define tmps_stack (*__imp_tmps_stack) -#define top_env (*__imp_top_env) -#define toptarget (*__imp_toptarget) -#define unsafe (*__imp_unsafe) -#define warnhook (*__imp_warnhook) diff --git a/cygwin32/gcc2 b/cygwin32/gcc2 deleted file mode 100644 index 6751348bd3..0000000000 --- a/cygwin32/gcc2 +++ /dev/null @@ -1,14 +0,0 @@ -#!/bin/sh -# -# gcc wrapper for building dynamic lib version of perl -# if -buildperl found on command line, then all args passed to -# perlgcc, else pass all args to gcc. -# jc 3/24/97 -# - -PERLPATH=/perl5.005 - -case "$*" in -*-buildperl*) $PERLPATH/miniperl perlgcc "$@" ;; -*) gcc "$@" ;; -esac diff --git a/cygwin32/impure_ptr.c b/cygwin32/impure_ptr.c new file mode 100644 index 0000000000..bbe98714fe --- /dev/null +++ b/cygwin32/impure_ptr.c @@ -0,0 +1,18 @@ +/* + * impure_ptr initialization routine. This is needed + * for any DLL that needs to output to the main (calling) + * executable's stdout, stderr, etc. + */ + +struct _reent *_impure_ptr; /* this will be the Dlls local copy of impure ptr */ + +/********************************************* + * Function to set our local (in this dll) + * copy of impure_ptr to the main's + * (calling executable's) impure_ptr + */ +void impure_setup(struct _reent *_impure_ptrMain){ + + _impure_ptr = _impure_ptrMain; + +} diff --git a/cygwin32/ld2 b/cygwin32/ld2 deleted file mode 100644 index 0bc98bd36e..0000000000 --- a/cygwin32/ld2 +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/sh -# -# ld wrapper for building dynamic lib version of perl; -# passes all args to ld. -# - -PERLPATH=/perl5.005 - -$PERLPATH/perl $PERLPATH/perlld -L$PERLPATH "$@" diff --git a/cygwin32/ld2.in b/cygwin32/ld2.in new file mode 100644 index 0000000000..3776c71f87 --- /dev/null +++ b/cygwin32/ld2.in @@ -0,0 +1,20 @@ +#!/bin/sh +# +# ld wrapper for building dynamic lib version of perl; +# passes all args to perlld +# + +# own miniperl is first candidate 'cause it doesn not lock libperl.dll +for trythis in @buildpath@/miniperl @buildpath@/perl perl +do + if [ -x $trythis ] + then + $trythis @buildpath@/perlld "$@" + exit $? + fi +done +# hard luck! +echo i see no perl executable around there +echo perl is required to build dynamic libraries +echo go fetch one or build this one static +exit 1 diff --git a/cygwin32/perlgcc b/cygwin32/perlgcc deleted file mode 100644 index 202ed29a4f..0000000000 --- a/cygwin32/perlgcc +++ /dev/null @@ -1,84 +0,0 @@ -# - -# Perl script be a wrapper around the gnu gcc. the exportable perl.exe -# is built, special processing is done. -# This script is caled by the gcc2 shell script when the flag -# -buildperl is passed to gcc2 - -print "perlgcc: building exportable perl...\n"; - -# get all libs: -my @libobs; -my @obs; -my @libFlags; -my $libstring; -foreach (@ARGV){ - if( /\.[a]$/){ - push @libobs,$_; - } - elsif(/^\-l/){ - push @libFlags,$_; - } - if( /\.[o]$/){ - push @obs,$_; - } -} -$libstring = join(" ",@libobs); -$obsString = join(" ",@obs); -$libflagString = join(" ",@libFlags); - -# make exports file -my $command = "echo EXPORTS > perl.def"; -print "$command\n"; -system($command) == 0 or die "system() failed.\n"; - -$command ="nm $libstring | grep '^........ [TCD] _'| grep -v _impure_ptr | sed 's/[^_]*_//' >> perl.def"; -print "$command\n"; -system($command) == 0 or die "system() failed.\n"; - -# Build the perl.a lib to link to: -$command ="dlltool --as=as --dllname perl.exe --def perl.def --output-lib perl.a"; -print "$command\n"; -system($command) == 0 or die "system() failed.\n"; - -# change name of export lib to libperlexp so that is can be understood by ld2/perlld -$command ="mv perl.a libperlexp.a"; -print "$command\n"; -system($command) == 0 or die "system() failed.\n"; - -# get the full path name of a few libs: -my $crt0 = `gcc -print-file-name=crt0.o`; -chomp $crt0; -my $libdir = `gcc -print-file-name=libcygwin.a`; -chomp $libdir; -$libdir =~ s/libcygwin\.a//g; - -# when $crt0 and $libdir get used in the system calls below, the \'s -# from the gcc -print-file-name get used to create special characters, -# such as \n, \t. Replace the \'s with /'s so that this does not -# happen: -$crt0 =~ s:\\:/:g; -$libdir =~ s:\\:/:g; - -# Link exe: -$command = "ld --base-file perl.base -o perl.exe $crt0 $obsString $libstring -L$libdir $libflagString"; -print "$command\n"; -system($command) == 0 or die "system() failed.\n"; - -$command = "dlltool --as=as --dllname perl.exe --def perl.def --base-file perl.base --output-exp perl.exp"; -print "$command\n"; -system($command) == 0 or die "system() failed.\n"; - -$command = "ld --base-file perl.base perl.exp -o perl.exe $crt0 $obsString $libstring -L$libdir $libflagString"; -print "$command\n"; -system($command) == 0 or die "system() failed.\n"; - -$command = "dlltool --as=as --dllname perl.exe --def perl.def --base-file perl.base --output-exp perl.exp"; -print "$command\n"; -system($command) == 0 or die "system() failed.\n"; - -$command = "ld perl.exp -o perl.exe $crt0 $obsString $libstring -L$libdir $libflagString"; -print "$command\n"; -system($command) == 0 or die "system() failed.\n"; - -print "perlgcc: Completed\n"; diff --git a/cygwin32/perlld b/cygwin32/perlld deleted file mode 100644 index 97edfd64dd..0000000000 --- a/cygwin32/perlld +++ /dev/null @@ -1,192 +0,0 @@ -# -# Perl script be a wrapper around the gnu ld. When a dll is specified to -# to be built, special processing is done, else the standard ld is called. -# -# Modified 3/14/97 to include the impure_ptr setup routine in init.cc -# Modified to make dll in current directory then copy to another dir if -# a path name specified on the command name with the -o parm. -# - -my $args = join(" ",@ARGV); # get args -my $arg; - -my @objs; -my @flags; -my $libname; -my $init = "init"; -my $fixup = "fixup"; - -my $path; - - -sub writefixup; -sub writeInit; - -if( $args=~/\-o (.+?)\.dll/i){ - $libname = $1; - # print "libname = <$libname>\n"; - # Check for path: - if( $libname =~ /($\.+?\/)(\w+$)/){ - $path = $1; - $libname = $2; - # print "<$path> <$libname>\n"; - } - - foreach $arg(@ARGV){ - if( $arg=~/\.[oa]$/){ - push @objs,$arg; - next; - } - if( $arg =~/\-o/ or $arg =~ /.+?\.dll/i ){ - next; - } - push @flags,$arg; - } - - writefixup(); - writeInit(); - $command = "gcc -c $fixup.c\n"; - print $command; - system($command) == 0 or die "system() failed.\n"; - $command = "gcc -c $init.cc\n"; - print $command; - system($command) == 0 or die "system() failed.\n"; - - $command = "echo EXPORTS > $libname.def\n"; - print $command; - system($command) == 0 or die "system() failed.\n"; - $command = "nm ".join(" ",@objs)." $init.o $fixup.o | grep '^........ [TCD] _' | sed 's/[^_]*_//' >> $libname.def\n"; - print $command; - system($command) == 0 or die "system() failed.\n"; - - $command = "ld --base-file $libname.base --dll -o $libname.dll ".join(" ",@objs)." $init.o $fixup.o "; - $command .= join(" ",@flags)." -e _dll_entry\@12 \n"; - print $command; - system($command) == 0 or die "system() failed.\n"; - - $command = "dlltool --as=as --dllname $libname.dll --def $libname.def --base-file $libname.base --output-exp $libname.exp\n"; - print $command; - system($command) == 0 or die "system() failed.\n"; - - $command = "ld --base-file $libname.base $libname.exp --dll -o $libname.dll ".join(" ",@objs)." $init.o $fixup.o "; - $command .= join(" ",@flags)." -e _dll_entry\@12 \n"; - print $command; - system($command) == 0 or die "system() failed.\n"; - - $command = "dlltool --as=as --dllname $libname.dll --def $libname.def --base-file $libname.base --output-exp $libname.exp\n"; - print $command; - system($command) == 0 or die "system() failed.\n"; - - $command = "ld $libname.exp --dll -o $libname.dll ".join(" ",@objs)." $init.o $fixup.o "; - $command .= join(" ",@flags)." -e _dll_entry\@12 \n"; - print $command; - system($command) == 0 or die "system() failed.\n"; - - print "Build the import lib\n"; - $command = "dlltool --as=as --dllname $libname.dll --def $libname.def --output-lib $libname.a\n"; - print $command; - system($command) == 0 or die "system() failed.\n"; - - # if there was originally a path, copy the dll and a to that location: - if($path && $path ne "./" && $path."\n" ne "`pwd`"){ - $command = "mv $libname.dll $path".$libname.".dll\n"; - print $command; - system($command) == 0 or die "system() failed.\n"; - $command = "mv $libname.a $path".$libname.".a\n"; - print $command; - system($command) == 0 or die "system() failed.\n"; - - } - -} -else{ # no special processing, just call ld - $command = "ld $args\n"; - print $command; - system($command) == 0 or die "system() failed.\n"; -} - -#--------------------------------------------------------------------------- -sub writeInit{ - -open(OUTFILE,">$init.cc") or die("Can't open $init.cc\n"); - -print OUTFILE <<'EOF'; -/* init.cc for WIN32. - - Copyright 1996 Cygnus Solutions - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -// Added impure_ptr initialization routine. This is needed for any DLL that needs -// to output to the main (calling) executable's stdout, stderr, etc. This routine -// needs to be called from the executable using the DLL before any other DLL -// routines are called. jc 3/14/97 - -#include <windows.h> - -extern "C" -{ - int WINAPI dll_entry (HANDLE h, DWORD reason, void *ptr); - void impure_setup(struct _reent *_impure_ptrMain); -}; - -struct _reent *_impure_ptr; // this will be the Dlls local copy of impure ptr - -int WINAPI dll_entry (HANDLE , - DWORD reason, - void *) -{ - switch (reason) - { - case DLL_PROCESS_ATTACH: - break; - case DLL_PROCESS_DETACH: - break; - case DLL_THREAD_ATTACH: - break; - case DLL_THREAD_DETACH: - break; - } - return 1; -} - - -//******************************************** -// Function to set our local (in this dll) copy of impure_ptr to the -// main's (calling executable's) impure_ptr -void impure_setup(struct _reent *_impure_ptrMain){ - - _impure_ptr = _impure_ptrMain; - -} -EOF - -close OUTFILE; - -} - -#--------------------------------------------------------------------------- -sub writefixup{ - -open(OUTFILE,">$fixup.c") or die("Can't open $fixup.c\n"); - -print OUTFILE <<'EOF'; -/* This is needed to terminate the list of inport stuff */ -/* Copied from winsup/dcrt0.cc in the cygwin32 source distribution. */ - asm(".section .idata$3\n" ".long 0,0,0,0, 0,0,0,0"); - -EOF -close OUTFILE; -} diff --git a/cygwin32/perlld.in b/cygwin32/perlld.in new file mode 100644 index 0000000000..1e82877178 --- /dev/null +++ b/cygwin32/perlld.in @@ -0,0 +1,89 @@ +# +# Perl script being a wrapper around the gnu ld. When a dll is specified to +# to be built, special processing is done, else the standard ld is called. +# + +# theese are pretty mandatory +my $CC = '@CC@'; +my $DLLWRAP = '@DLLWRAP@'; + +# following are optional. +my $WRAPDRIVER = '@WRAPDRIVER@'; +my $AS = '@AS@'; +my $DLLTOOL = '@DLLTOOL@'; +my $EXPORT_ALL = @EXPORT_ALL@; +# if some of extensions are undefined, +# no corresponding output will be done. +# most probably, you'd like to have an export library +my $DEF_EXT = '@DEF_EXT@'; +# my $EXP_EXT = '@EXP_EXT@'; +my $LIB_EXT = '@LIB_EXT@'; + +#my $DEBUG ="perlld.out"; +my $DEBUG =undef; + +my $args = join(" ",@ARGV); # get args +my $verbose =grep(/^\-(v|\-verbose)$/, @ARGV); + +sub shellexec; + +if ($DEBUG) { + open DEBUGFILE, ">>$DEBUG"; + print DEBUGFILE "\n--- " .localtime() ."\nargs:\n$args\n\nenvironment:\n"; + foreach (keys(%ENV)) { print DEBUGFILE $_, "=", $ENV{$_}, "\n"; }; +} + +if ($args !~ /\-o (\S+)/) { + print DEBUGFILE "+ no dll output -- passing to gcc\n\n" if $DEBUG; + shellexec("$CC $args\n"); +} else { + my ($path, $command, $dllname, $libname) =''; + + $dllname =$1; + print DEBUGFILE "output file: $dllname\n" if $DEBUG; + # remove -o from args + $args =~ s/(^| )\-o \S+/$1/; + + # Check for path: + if( $dllname =~ /.*[\/\\]/){ + $dllname = $'; + $path = $&; + $path =~ s,[/\\](\.[/\\])*,/,g; + } + if ($dllname =~ /\./) { $libname =$`; } else { $libname =$dllname; }; + $dllname ="$libname.dll"; + $libname ="lib$libname" unless ($libname =~ /^lib/); + print DEBUGFILE "dll name: $dllname\nimport library: $libname\npath: $path\n" if $DEBUG; + + $command ="$DLLWRAP --dllname $dllname --exclude-symbol=_impure_ptr"; + $command .=" --driver-name $WRAPDRIVER" if $WRAPDRIVER; + $command .=" --dlltool $DLLTOOL" if $DLLTOOL; + $command .=" --export-all-symbols" if $EXPORT_ALL; + $command .=" --as $AS" if $AS; + $command .=" --verbose" if $verbose; + + $command .=" --output-def $libname$DEF_EXT" if $DEF_EXT; + $command .=" --output-exp $libname$EXP_EXT" if $EXP_EXT; + $command .=" --output-lib $libname$LIB_EXT" if $LIB_EXT; + + # other args are passed through + shellexec("$command \\\n$args\n"); + + if ($path) { + $command ="mv $dllname"; + $command .=" $libname$LIB_EXT" if $LIB_EXT; + shellexec("$command $path\n"); + }; +}; +close DEBUGFILE if $DEBUG; + +#--------------------------------------------------------------------------- +sub shellexec{ + my $command =shift; + print $command; + print DEBUGFILE $command if $DEBUG; + system($command) == 0 + or die "perlld: *** system() failed to execute\n$command\n"; +}; + +1; @@ -913,7 +913,10 @@ do_print(register SV *sv, PerlIO *fp) if (SvIOK(sv)) { if (SvGMAGICAL(sv)) mg_get(sv); - PerlIO_printf(fp, "%ld", (long)SvIVX(sv)); + if (SvIsUV(sv)) /* XXXX 64-bit? */ + PerlIO_printf(fp, "%lu", (unsigned long)SvUVX(sv)); + else + PerlIO_printf(fp, "%ld", (long)SvIVX(sv)); return !PerlIO_error(fp); } /* FALL THROUGH */ @@ -1061,6 +1064,12 @@ do_execfree(void) bool do_exec(char *cmd) { + return do_exec3(cmd,0,0); +} + +bool +do_exec3(char *cmd, int fd, int do_report) +{ register char **a; register char *s; char flags[10]; @@ -1141,9 +1150,15 @@ do_exec(char *cmd) } { dTHR; + int e = errno; + if (ckWARN(WARN_EXEC)) warner(WARN_EXEC, "Can't exec \"%s\": %s", PL_Argv[0], Strerror(errno)); + if (do_report) { + PerlLIO_write(fd, (void*)&e, sizeof(int)); + PerlLIO_close(fd); + } } } do_execfree(); @@ -23,8 +23,22 @@ # define PERL_SYS_INIT(c,v) Perl_win32_init(c,v) # define BIT_BUCKET "nul" # else -# define PERL_SYS_INIT(c,v) -# define BIT_BUCKET "\\dev\\nul" /* "wanna be like, umm, Newlined, or somethin?" */ +# ifdef CYGWIN32 + extern struct _reent *__imp_reent_data; /* global impure pointer */ +# define PERL_SYS_INIT(c,v) \ + MALLOC_INIT; impure_setup(__imp_reent_data); +# define OP_BINARY O_BINARY +# define BIT_BUCKET "nul" +# define HAS_IOCTL +# define HAS_UTIME +# define HAS_KILL +# define HAS_WAIT +# define HAS_CHOWN +# define HAS_GROUP +# else +# define PERL_SYS_INIT(c,v) +# define BIT_BUCKET "\\dev\\nul" /* "wanna be like, umm, Newlined, or somethin?" */ +# endif # endif #endif /* DJGPP */ @@ -279,8 +279,12 @@ sv_peek(SV *sv) SET_NUMERIC_STANDARD(); sv_catpvf(t, "(%g)",SvNVX(sv)); } - else if (SvIOKp(sv)) - sv_catpvf(t, "(%ld)",(long)SvIVX(sv)); + else if (SvIOKp(sv)) { /* XXXX: IV, UV? */ + if (SvIsUV(sv)) + sv_catpvf(t, "(%lu)",(unsigned long)SvUVX(sv)); + else + sv_catpvf(t, "(%ld)",(long)SvIVX(sv)); + } else sv_catpv(t, "()"); @@ -781,6 +785,7 @@ do_sv_dump(I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, if (CvCLONE(sv)) sv_catpv(d, "CLONE,"); if (CvCLONED(sv)) sv_catpv(d, "CLONED,"); if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,"); + if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,"); break; case SVt_PVHV: if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,"); @@ -803,9 +808,14 @@ do_sv_dump(I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, sv_catpv(d, " ),"); } } + /* FALL THROGH */ + default: + if (SvEVALED(sv)) sv_catpv(d, "EVALED,"); + if (SvIsUV(sv)) sv_catpv(d, "IsUV,"); + break; case SVt_PVBM: if (SvTAIL(sv)) sv_catpv(d, "TAIL,"); - if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,"); + if (SvVALID(sv)) sv_catpv(d, "VALID,"); break; } @@ -869,7 +879,10 @@ do_sv_dump(I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, return; } if (type >= SVt_PVIV || type == SVt_IV) { - dump_indent(level, file, " IV = %ld", (long)SvIVX(sv)); + if (SvIsUV(sv)) + dump_indent(level, file, " UV = %lu", (unsigned long)SvUVX(sv)); + else + dump_indent(level, file, " IV = %ld", (long)SvIVX(sv)); if (SvOOK(sv)) PerlIO_printf(file, " (OFFSET)"); PerlIO_putc(file, '\n'); @@ -1100,14 +1113,20 @@ do_sv_dump(I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, dump_indent(level, file, " PAGE = %ld\n", (long)IoPAGE(sv)); dump_indent(level, file, " PAGE_LEN = %ld\n", (long)IoPAGE_LEN(sv)); dump_indent(level, file, " LINES_LEFT = %ld\n", (long)IoLINES_LEFT(sv)); - dump_indent(level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv)); + if (IoTOP_NAME(sv)) + dump_indent(level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv)); do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv)); - dump_indent(level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv)); + if (IoFMT_NAME(sv)) + dump_indent(level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv)); do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv)); - dump_indent(level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv)); + if (IoBOTTOM_NAME(sv)) + dump_indent(level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv)); do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv)); dump_indent(level, file, " SUBPROCESS = %ld\n", (long)IoSUBPROCESS(sv)); - dump_indent(level, file, " TYPE = %c\n", IoTYPE(sv)); + if (isPRINT(IoTYPE(sv))) + dump_indent(level, file, " TYPE = '%c'\n", IoTYPE(sv)); + else + dump_indent(level, file, " TYPE = '\\%o'\n", IoTYPE(sv)); dump_indent(level, file, " FLAGS = 0x%lx\n", (long)IoFLAGS(sv)); break; } @@ -107,6 +107,7 @@ #define do_close Perl_do_close #define do_eof Perl_do_eof #define do_exec Perl_do_exec +#define do_exec3 Perl_do_exec3 #define do_execfree Perl_do_execfree #define do_gv_dump Perl_do_gv_dump #define do_gvgv_dump Perl_do_gvgv_dump @@ -1092,6 +1093,7 @@ #define do_close CPerlObj::Perl_do_close #define do_eof CPerlObj::Perl_do_eof #define do_exec CPerlObj::Perl_do_exec +#define do_exec3 CPerlObj::Perl_do_exec3 #define do_execfree CPerlObj::Perl_do_execfree #define do_gv_dump CPerlObj::Perl_do_gv_dump #define do_gvgv_dump CPerlObj::Perl_do_gvgv_dump @@ -1137,6 +1139,7 @@ #define dofindlabel CPerlObj::Perl_dofindlabel #define dofindlabel CPerlObj::Perl_dofindlabel #define doform CPerlObj::Perl_doform +#define doopen CPerlObj::Perl_doopen #define doparseform CPerlObj::Perl_doparseform #define dopoptoeval CPerlObj::Perl_dopoptoeval #define dopoptoeval CPerlObj::Perl_dopoptoeval @@ -254,6 +254,7 @@ my @staticfuncs = qw( dopoptosub_at save_lines doeval + doopen sv_ncmp sv_i_ncmp amagic_ncmp diff --git a/ext/B/B.pm b/ext/B/B.pm index f864883b99..0bfceafd7d 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -11,7 +11,7 @@ require Exporter; @ISA = qw(Exporter DynaLoader); @EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname class peekop cast_I32 cstring cchar hash threadsv_names - main_root main_start main_cv svref_2object opnumber + main_root main_start main_cv svref_2object opnumber amagic_generation walkoptree walkoptree_slow walkoptree_exec walksymtable parents comppadlist sv_undef compile_stats timing_info init_av); sub OPf_KIDS (); @@ -750,6 +750,10 @@ Returns the SV object corresponding to the C variable C<sv_yes>. Returns the SV object corresponding to the C variable C<sv_no>. +=item amagic_generation + +Returns the SV object corresponding to the C variable C<amagic_generation>. + =item walkoptree(OP, METHOD) Does a tree-walk of the syntax tree based at OP and calls METHOD on diff --git a/ext/B/B.xs b/ext/B/B.xs index ccac053da9..466091d679 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -454,6 +454,7 @@ BOOT: #define B_init_av() PL_initav #define B_main_root() PL_main_root #define B_main_start() PL_main_start +#define B_amagic_generation() PL_amagic_generation #define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv)) #define B_sv_undef() &PL_sv_undef #define B_sv_yes() &PL_sv_yes @@ -471,6 +472,9 @@ B_main_root() B::OP B_main_start() +long +B_amagic_generation() + B::AV B_comppadlist() @@ -808,6 +812,7 @@ LOOP_lastop(o) #define COP_cop_seq(o) o->cop_seq #define COP_arybase(o) o->cop_arybase #define COP_line(o) o->cop_line +#define COP_warnings(o) o->cop_warnings MODULE = B PACKAGE = B::COP PREFIX = COP_ @@ -835,6 +840,10 @@ U16 COP_line(o) B::COP o +B::SV +COP_warnings(o) + B::COP o + MODULE = B PACKAGE = B::SV PREFIX = Sv U32 diff --git a/ext/B/B/Asmdata.pm b/ext/B/B/Asmdata.pm index f3e57a17d0..ddc391b388 100644 --- a/ext/B/B/Asmdata.pm +++ b/ext/B/B/Asmdata.pm @@ -136,9 +136,10 @@ $insn_data{cop_filegv} = [112, \&PUT_svindex, "GET_svindex"]; $insn_data{cop_seq} = [113, \&PUT_U32, "GET_U32"]; $insn_data{cop_arybase} = [114, \&PUT_I32, "GET_I32"]; $insn_data{cop_line} = [115, \&PUT_U16, "GET_U16"]; -$insn_data{main_start} = [116, \&PUT_opindex, "GET_opindex"]; -$insn_data{main_root} = [117, \&PUT_opindex, "GET_opindex"]; -$insn_data{curpad} = [118, \&PUT_svindex, "GET_svindex"]; +$insn_data{cop_warnings} = [116, \&PUT_svindex, "GET_svindex"]; +$insn_data{main_start} = [117, \&PUT_opindex, "GET_opindex"]; +$insn_data{main_root} = [118, \&PUT_opindex, "GET_opindex"]; +$insn_data{curpad} = [119, \&PUT_svindex, "GET_svindex"]; my ($insn_name, $insn_data); while (($insn_name, $insn_data) = each %insn_data) { diff --git a/ext/B/B/Bblock.pm b/ext/B/B/Bblock.pm index cb007ff2ba..14001b3c73 100644 --- a/ext/B/B/Bblock.pm +++ b/ext/B/B/Bblock.pm @@ -21,8 +21,8 @@ sub mark_leader { sub find_leaders { my ($root, $start) = @_; $bblock = {}; - mark_leader($start); - walkoptree($root, "mark_if_leader"); + mark_leader($start) if ( ref $start ne "B::NULL" ); + walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ; return $bblock; } @@ -103,6 +103,12 @@ sub B::LISTOP::mark_if_leader { mark_leader($op->next); } +sub B::LISTOP::mark_if_leader { + my $op = shift; + mark_leader($op->first); + mark_leader($op->next); +} + sub B::PMOP::mark_if_leader { my $op = shift; if ($op->ppaddr ne "pp_pushre") { diff --git a/ext/B/B/Bytecode.pm b/ext/B/B/Bytecode.pm index de2bf99180..29683b899b 100644 --- a/ext/B/B/Bytecode.pm +++ b/ext/B/B/Bytecode.pm @@ -293,6 +293,8 @@ sub B::COP::bytecode { my $filegv = $op->filegv; my $filegvix = $filegv->objix; my $line = $op->line; + my $warnings = $op->warnings; + my $warningsix = $warnings->objix; if ($debug_bc) { printf "# line %s:%d\n", $filegv->SV->PV, $line; } @@ -305,6 +307,7 @@ cop_seq %d cop_filegv $filegvix cop_arybase %d cop_line $line +cop_warnings $warningsix EOT $filegv->bytecode; $stash->bytecode; diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm index ec39de2674..4aa80a1ae7 100644 --- a/ext/B/B/C.pm +++ b/ext/B/B/C.pm @@ -49,7 +49,7 @@ use Exporter (); use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop class cstring cchar svref_2object compile_stats comppadlist hash - threadsv_names main_cv init_av opnumber + threadsv_names main_cv init_av opnumber amagic_generation AVf_REAL HEf_SVKEY); use B::Asmdata qw(@specialsv_name); @@ -401,7 +401,9 @@ sub B::NV::save { my ($sv) = @_; my $sym = objsym($sv); return $sym if defined $sym; - $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $sv->NVX)); + my $val= $sv->NVX; + $val .= '.00' if $val =~ /^-?\d+$/; + $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val)); $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); @@ -453,8 +455,10 @@ sub B::PVNV::save { $pv = '' unless defined $pv; my $len = length($pv); my ($pvsym, $pvmax) = savepv($pv); + my $val= $sv->NVX; + $val .= '.00' if $val =~ /^-?\d+$/; $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s", - $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX)); + $pvsym, $len, $pvmax, $sv->IVX, $val)); $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); if (!$pv_copy_on_grow) { @@ -524,6 +528,7 @@ sub B::PVMG::save_magic { my ($sv) = @_; #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug my $stash = $sv->SvSTASH; + $stash->save; if ($$stash) { warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash) if $debug_mg; @@ -542,6 +547,7 @@ sub B::PVMG::save_magic { class($sv), $$sv, class($obj), $$obj, cchar($type), cstring($ptr)); } + $obj->save; if ($len == HEf_SVKEY){ #The pointer is an SV* $ptrsv=svref_2object($ptr)->save; @@ -884,6 +890,7 @@ sub B::HV::save { } $init->add("}"); } + $hv->save_magic(); return savesym($hv, "(HV*)&sv_list[$sv_list_index]"); } @@ -1297,11 +1304,13 @@ sub save_context my $curpad_sym = (comppadlist->ARRAY)[1]->save; my $inc_hv = svref_2object(\%INC)->save; my $inc_av = svref_2object(\@INC)->save; + my $amagic_generate= amagic_generation; $init->add( "PL_curpad = AvARRAY($curpad_sym);", "GvHV(PL_incgv) = $inc_hv;", "GvAV(PL_incgv) = $inc_av;", "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", - "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));"); + "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));", + "PL_amagic_generation= $amagic_generate;" ); } sub descend_marked_unused { diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm index 143ae41178..649f6e10f7 100644 --- a/ext/B/B/CC.pm +++ b/ext/B/B/CC.pm @@ -8,7 +8,7 @@ package B::CC; use strict; use B qw(main_start main_root class comppadlist peekop svref_2object - timing_info init_av sv_undef + timing_info init_av sv_undef amagic_generation OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR @@ -1424,7 +1424,12 @@ sub cc { warn sprintf("Basic block analysis at %s\n", timing_info); } $leaders = find_leaders($root, $start); - @bblock_todo = ($start, values %$leaders); + my @leaders= keys %$leaders; + if ($#leaders > -1) { + @bblock_todo = ($start, values %$leaders) ; + } else{ + runtime("return PL_op?PL_op->op_next:0;"); + } if ($debug_timings) { warn sprintf("Compilation at %s\n", timing_info); } @@ -1488,6 +1493,7 @@ sub cc_main { my $inc_hv = svref_2object(\%INC)->save; my $inc_av = svref_2object(\@INC)->save; + my $amagic_generate= amagic_generation; return if $errors; if (!defined($module)) { $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), @@ -1498,6 +1504,7 @@ sub cc_main { "GvAV(PL_incgv) = $inc_av;", "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));", + "PL_amagic_generation= $amagic_generate;", ); } diff --git a/ext/B/B/Debug.pm b/ext/B/B/Debug.pm index 7754a5a807..d10db9cb1a 100644 --- a/ext/B/B/Debug.pm +++ b/ext/B/B/Debug.pm @@ -68,13 +68,14 @@ sub B::COP::debug { my ($op) = @_; $op->B::OP::debug(); my ($filegv) = $op->filegv; - printf <<'EOT', $op->label, ${$op->stash}, $$filegv, $op->seq, $op->arybase, $op->line; + printf <<'EOT', $op->label, ${$op->stash}, $$filegv, $op->seq, $op->arybase, $op->line, ${$op->warnings}; cop_label %s cop_stash 0x%x cop_filegv 0x%x cop_seq %d cop_arybase %d cop_line %d + cop_warnings 0x%x EOT $filegv->debug; } diff --git a/ext/B/B/Stash.pm b/ext/B/B/Stash.pm index 42c8bc0fd3..828ffac3c0 100644 --- a/ext/B/B/Stash.pm +++ b/ext/B/B/Stash.pm @@ -11,12 +11,15 @@ END { } sub scan{ my $start=shift; + my $prefix=shift; + $prefix = '' unless defined $prefix; my @return; foreach my $key ( keys %{$start}){ +# print $prefix,$key,"\n"; if ($key =~ /::$/){ unless ($start eq ${$start}{$key} or $key eq "B::" ){ - push @return, $key ; - foreach my $subscan ( scan(${$start}{$key})){ + push @return, $key unless omit($prefix.$key); + foreach my $subscan ( scan(${$start}{$key},$prefix.$key)){ push @return, "$key".$subscan; } } @@ -24,6 +27,16 @@ sub scan{ } return @return; } -1; - +sub omit{ + my $module = shift; + my %omit=("DynaLoader::" => 1 , "CORE::" => 1 , + "CORE::GLOBAL::" => 1, "UNIVERSAL::" => 1 ); + return 1 if $omit{$module}; + if ($module eq "IO::" or $module eq "IO::Handle::"){ + $module =~ s/::/\//g; + return 1 unless $INC{$module}; + } + return 0; +} +1; diff --git a/ext/B/B/Xref.pm b/ext/B/B/Xref.pm index 15382aa2e5..854db71189 100644 --- a/ext/B/B/Xref.pm +++ b/ext/B/B/Xref.pm @@ -141,7 +141,7 @@ sub load_pad { for ($ix = 1; $ix < @namelist; $ix++) { my $namesv = $namelist[$ix]; next if class($namesv) eq "SPECIAL"; - my ($type, $name) = $namesv->PV =~ /^(.)(.*)$/; + my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/; $pad[$ix] = ["(lexical)", $type, $name]; } } diff --git a/ext/ByteLoader/ByteLoader.pm b/ext/ByteLoader/ByteLoader.pm new file mode 100644 index 0000000000..9faec2e08c --- /dev/null +++ b/ext/ByteLoader/ByteLoader.pm @@ -0,0 +1,45 @@ +package ByteLoader; + +use strict; +use vars qw($VERSION @ISA); + +require DynaLoader; + +@ISA = qw(DynaLoader); + +$VERSION = 0.01; + +bootstrap ByteLoader $VERSION; + +# Preloaded methods go here. + +1; +__END__ + +=head1 NAME + +ByteLoader - load byte compiled perl code + +=head1 SYNOPSIS + + use ByteLoader 0.01; + <byte code> + + use ByteLoader 0.01; + <byte code> + +=head1 DESCRIPTION + +This module is used to load byte compiled perl code. It uses the source +filter mechanism to read the byte code and insert it into the compiled +code at the appropriate point. + +=head1 AUTHOR + +Tom Hughes <tom@compton.nu> based on the ideas of Tim Bunce and others. + +=head1 SEE ALSO + +perl(1). + +=cut diff --git a/ext/ByteLoader/ByteLoader.xs b/ext/ByteLoader/ByteLoader.xs new file mode 100644 index 0000000000..98053c7918 --- /dev/null +++ b/ext/ByteLoader/ByteLoader.xs @@ -0,0 +1,64 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "byterun.c" + +/* defgv must be accessed differently under threaded perl */ +/* DEFSV et al are in 5.004_56 */ +#ifndef DEFSV +#define DEFSV GvSV(defgv) +#endif + +static I32 +#ifdef PERL_OBJECT +byteloader_filter(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen) +#else +byteloader_filter(int idx, SV *buf_sv, int maxlen) +#endif +{ + OP *saveroot = PL_main_root; + OP *savestart = PL_main_start; + +#ifdef INDIRECT_BGET_MACROS + struct bytesream bs; + + bs.data = PL_rsfp; + bs.fgetc = (int(*) _((void*)))fgetc; + bs.fread = (int(*) _((char*,size_t,size_t,void*)))fread; + bs.freadpv = freadpv; +#else + byterun(PL_rsfp); +#endif + + if (PL_in_eval) { + OP *o; + + PL_eval_start = PL_main_start; + + o = newSVOP(OP_CONST, 0, newSViv(1)); + PL_eval_root = newLISTOP(OP_LINESEQ, 0, PL_main_root, o); + PL_main_root->op_next = o; + PL_eval_root = newUNOP(OP_LEAVEEVAL, 0, PL_eval_root); + o->op_next = PL_eval_root; + + PL_main_root = saveroot; + PL_main_start = savestart; + } + + return 0; +} + +MODULE = ByteLoader PACKAGE = ByteLoader + +PROTOTYPES: ENABLE + +void +import(...) + PPCODE: + filter_add(byteloader_filter, NULL); + +void +unimport(...) + PPCODE: + filter_del(byteloader_filter); diff --git a/ext/ByteLoader/Makefile.PL b/ext/ByteLoader/Makefile.PL new file mode 100644 index 0000000000..4aabe79683 --- /dev/null +++ b/ext/ByteLoader/Makefile.PL @@ -0,0 +1,10 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + 'NAME' => 'ByteLoader', + 'VERSION_FROM' => 'ByteLoader.pm', # finds $VERSION + 'LIBS' => [''], # e.g., '-lm' + 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' + 'INC' => '-I$(PERL_SRC)', # e.g., '-I/usr/include/other' +); diff --git a/ext/IO/lib/IO/Handle.pm b/ext/IO/lib/IO/Handle.pm index 1063f1ad83..02595e50a5 100644 --- a/ext/IO/lib/IO/Handle.pm +++ b/ext/IO/lib/IO/Handle.pm @@ -468,16 +468,31 @@ sub input_record_separator { } sub input_line_number { + # local $. does not work properly, so we need to do it some other + # way. We use select, although this is not quite right. What we + # really need to know is the file handle that was the subject of the + # last read, seek or tell. my $now = select; my $keep = $.; my $tell = tell qualify($_[0], caller) if ref($_[0]); my $prev = $.; $. = $_[1] if @_ > 1; + no strict "refs"; $tell = tell $now; $. = $keep; $prev; } +=for when local $. works properly +sub input_line_number { + local $.; + my $tell = tell qualify($_[0], caller) if ref($_[0]); + my $prev = $.; + $. = $_[1] if @_ > 1; + $prev; +} +=cut + sub format_page_number { my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); my $prev = $%; diff --git a/ext/ODBM_File/ODBM_File.xs b/ext/ODBM_File/ODBM_File.xs index 0ab06ef6b1..9ad794da89 100644 --- a/ext/ODBM_File/ODBM_File.xs +++ b/ext/ODBM_File/ODBM_File.xs @@ -121,7 +121,7 @@ DESTROY(db) dbmrefcnt--; dbmclose(); -datum_key +datum_value odbm_FETCH(db, key) ODBM_File db datum_key key @@ -161,7 +161,7 @@ odbm_NEXTKEY(db, key) RETVAL = newSVsv(db->type) ; \ if (db->type && (code == &PL_sv_undef)) { \ SvREFCNT_dec(db->type) ; \ - db->type = NULL ; \ + db->type = Nullsv ; \ } \ else if (code) { \ if (db->type) \ diff --git a/ext/POSIX/Makefile.PL b/ext/POSIX/Makefile.PL index d379fdb908..62a87cacac 100644 --- a/ext/POSIX/Makefile.PL +++ b/ext/POSIX/Makefile.PL @@ -1,7 +1,9 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'POSIX', - ($^O eq 'MSWin32' ? () : (LIBS => ["-lm -lposix -lcposix"])), + ($^O eq 'MSWin32' ? () : ($^O =~ /cygwin/ ? (LIBS => ["-lmsvcrt"]) : + (LIBS => ["-lm -lposix -lcposix"]) + )), MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'POSIX.pm', diff --git a/ext/SDBM_File/sdbm/pair.c b/ext/SDBM_File/sdbm/pair.c index d03bfb30a7..24deb772de 100644 --- a/ext/SDBM_File/sdbm/pair.c +++ b/ext/SDBM_File/sdbm/pair.c @@ -8,7 +8,12 @@ */ #include "config.h" -#include "EXTERN.h" +#ifdef CYGWIN32 +# define EXT extern +# define EXTCONST extern const +#else +# include "EXTERN.h" +#endif #include "sdbm.h" #include "tune.h" #include "pair.h" diff --git a/ext/Thread/Thread.pm b/ext/Thread/Thread.pm index c8bca0db71..1dacdc0482 100644 --- a/ext/Thread/Thread.pm +++ b/ext/Thread/Thread.pm @@ -18,22 +18,29 @@ Thread - multithreading my $t = new Thread \&start_sub, @start_args; - $t->join; + $result = $t->join; + $result = $t->eval; + $t->detach; - my $tid = Thread->self->tid; + if($t->equal($another_thread)) { + # ... + } + my $tid = Thread->self->tid; my $tlist = Thread->list; lock($scalar); + yield(); use Thread 'async'; - use Thread 'eval'; - =head1 DESCRIPTION The C<Thread> module provides multithreading support for perl. +WARNING: Threading is an experimental feature. Both the interface +and implementation are subject to change drastically. + =head1 FUNCTIONS =over 8 @@ -122,6 +129,11 @@ The C<cond_broadcast> function works similarly to C<cond_wait>. C<cond_broadcast>, though, will unblock B<all> the threads that are blocked in a C<cond_wait> on the locked variable, rather than only one. +=item yield + +The C<yield> function allows another thread to take control of the +CPU. The exact results are implementation-dependent. + =back =head1 METHODS @@ -145,6 +157,18 @@ The C<eval> method wraps an C<eval> around a C<join>, and so waits for a thread to exit, passing along any values the thread might have returned. Errors, of course, get placed into C<$@>. +=item detach + +C<detach> tells a thread that it is never going to be joined i.e. +that all traces of its existence can be removed once it stops running. +Errors in detached threads will not be visible anywhere - if you want +to catch them, you should use $SIG{__DIE__} or something like that. + +=item equal + +C<equal> tests whether two thread objects represent the same thread and +returns true if they do. + =item tid The C<tid> method returns the tid of a thread. The tid is a monotonically diff --git a/global.sym b/global.sym index e7d1e365e4..09520a9406 100644 --- a/global.sym +++ b/global.sym @@ -98,6 +98,7 @@ do_chop do_close do_eof do_exec +do_exec3 do_execfree do_hv_dump do_gv_dump diff --git a/hints/aix.sh b/hints/aix.sh index 7b111ffc5f..d5ce75529d 100644 --- a/hints/aix.sh +++ b/hints/aix.sh @@ -6,6 +6,32 @@ # Merged on Mon Feb 6 10:22:35 EST 1995 by # Andy Dougherty <doughera@lafcol.lafayette.edu> +# +# Contact dfavor@corridor.com for any of the following: +# +# - AIX 43x and above support +# - gcc + threads support +# - socks support +# +# Apr 99 changes: +# +# - use nm in AIX 43x and above +# - gcc + threads now builds +# - added support for socks, when Dccflags=-DSOCKS specified +# +# Notes: +# +# - shared libperl support is tricky. if ever libperl.a ends up +# in /usr/local/lib/* it can override any subsequent builds of +# that same perl release. to make sure you know where the shared +# libperl.a is coming from do a 'dump -Hv perl' and check all the +# library search paths in the loader header. +# +# it would be nice to warn the user if a libperl.a exists that is +# going to override the current build, but that would be complex. +# +# better yet, a solid fix for this situation should be developed. +# # Configure finds setrgid and setruid, but they're useless. The man # pages state: @@ -15,19 +41,28 @@ d_setrgid='undef' d_setruid='undef' -# Neither do these functions work like Perl expects them to. -d_setregid='undef' -d_setreuid='undef' - alignbytes=8 -# Intuiting the existence of system calls under AIX is difficult, at best; -# the safest (and slowest...) technique is to find them empirically. -usenm='undef' +usemymalloc='n' + +# Intuiting the existence of system calls under AIX is difficult, +# at best; the safest technique is to find them empirically. + +# AIX 4.3.* and above default to using nm for symbol extraction +case "$osvers" in + 3.*|4.1.*|4.2.*) + usenm='undef' + ;; + *) + usenm='true' + ;; +esac so="a" dlext="so" +# Trying to set this breaks the POSIX.c compilation + # Make setsockopt work correctly. See man page. # ccflags='-D_BSD=44' @@ -50,13 +85,17 @@ case "$osvers" in ;; esac +# These functions don't work like Perl expects them to. +d_setregid='undef' +d_setreuid='undef' + # Changes for dynamic linking by Wayne Scott <wscott@ichips.intel.com> # # Tell perl which symbols to export for dynamic linking. case "$cc" in -*gcc*) ccdlflags="$ccdlflags -Xlinker" ;; +*gcc*) ccdlflags='-Xlinker -bE:perl.exp' ;; +*) ccdlflags='-bE:perl.exp' ;; esac -ccdlflags="$ccdlflags -bE:perl.exp" # The first 3 options would not be needed if dynamic libs. could be linked # with the compiler instead of ld. @@ -65,13 +104,84 @@ ccdlflags="$ccdlflags -bE:perl.exp" # symbol: boot_$(EXP) can it be auto-generated? case "$osvers" in 3*) - lddlflags="$lddlflags -H512 -T512 -bhalt:4 -bM:SRE -bI:$(PERL_INC)/perl.exp -bE:$(BASEEXT).exp -e _nostart -lc" + lddlflags='-H512 -T512 -bhalt:4 -bM:SRE -bI:$(PERL_INC)/perl.exp -bE:$(BASEEXT).exp -e _nostart' ;; *) - lddlflags="$lddlflags -bhalt:4 -bM:SRE -bI:$(PERL_INC)/perl.exp -bE:$(BASEEXT).exp -b noentry -lc" + lddlflags='-bhalt:4 -bM:SRE -bI:$(PERL_INC)/perl.exp -bE:$(BASEEXT).exp -b noentry' ;; esac +# +# if $ccflags contains -DSOCKS, then add socks library support. +# +# SOCKS support also requires each source module with socket support +# add the following lines directly after the #include <socket.h>: +# +# #ifdef SOCKS +# #include <socks.h> +# #endif +# +# It is expected that libsocks.a resides in /usr/local/lib and that +# socks.h resides in /usr/local/include. If these files live some +# different place then modify +# + +for arg in $ccflags ; do + + if [ "$arg" = "-DSOCKS" ] ; then + + sockslib=socks5 + incpath=/usr/local/include + libpath=/usr/local/lib + + echo >&4 "SOCKS using $incpath/socks.h and $libpath/lib${sockslib}.a" + echo >&4 "SOCKS requires source modifications. #include <socket.h> must change to:" + echo >&4 + echo >&4 " #include <socket.h>" + echo >&4 " #ifdef SOCKS" + echo >&4 " #include <socks.h>" + echo >&4 " #endif" + echo >&4 + echo >&4 "in some or all of the following files:" + echo >&4 + + for arg in `find . \( -name '*.c' -o -name '*.xs' -o -name '*.h' \) \ + -exec egrep -l '#.*include.*socket\.h' {} \; | \ + egrep -v "win32|vms|t/lib|Socket.c` ; do + echo >&4 " $arg" + done + + echo >&4 + + lddlflags="$lddlflags -l$sockslib" + + # setting $libs here breaks the optional libraries search + # for some reason, so use $libswanted instead + #libs="$libs -lsocks5" + + libswanted="$libswanted $sockslib" + + # + # path for include file + # + + locincpth="$locincpath /usr/local/include" + + # + # path for library not needed, if in /usr/local/lib as that + # directory is already searched. + # + + #loclibpth="$loclibpath /usr/local/lib" + + break + + fi + +done + +lddllibc="-lc" + # This script UU/usethreads.cbu will get 'called-back' by Configure # after it has prompted the user for whether to use threads. cat > UU/usethreads.cbu <<'EOCBU' @@ -79,17 +189,21 @@ case "$usethreads" in $define|true|[yY]*) ccflags="$ccflags -DNEED_PTHREAD_INIT" case "$cc" in - xlc_r) ;; - cc) - echo >&4 "Switching cc to xlc_r because of POSIX threads." - cc=xlc_r + gcc) ;; + cc_r) ;; + cc|xlc_r) + echo >&4 "Switching cc to cc_r because of POSIX threads." + # xlc_r has been known to produce buggy code in AIX 4.3.2. + # (e.g. pragma/overload core dumps) + # --jhi@iki.fi + cc=cc_r ;; - '' | cc_r) - cc=xlc_r + '') + cc=cc_r ;; *) cat >&4 <<EOM -For pthreads you should use the AIX C compiler xlc_r. +For pthreads you should use the AIX C compiler cc_r. (now your compiler was '$cc') Cannot continue, aborting. EOM @@ -99,20 +213,17 @@ EOM # Add the POSIX threads library and the re-entrant libc. - lddlflags=`echo $lddlflags | sed 's/ -lc$/ -lpthreads -lc_r -lc/'` + lddllibc="-lpthreads -lc_r" # Add the c_r library to the list of wanted libraries. # Make sure the c_r library is before the c library or # make will fail. - set `echo X "$libswanted "| sed -e 's/ c / c_r c /'` + set `echo X "$libswanted "| sed -e 's/ c / pthreads c_r /'` shift libswanted="$*" - - # Perl's malloc doesn't survive threaded AIX. - case "$usemymalloc" in - '') usemymalloc='n' ;; - esac - ;; esac + +lddlflags="$lddlflags $lddllibc" + EOCBU diff --git a/hints/cygwin32.sh b/hints/cygwin32.sh index 5853499954..ced980069f 100644 --- a/hints/cygwin32.sh +++ b/hints/cygwin32.sh @@ -1,50 +1,59 @@ #! /bin/sh # cygwin32.sh - hintsfile for building perl on Windows NT using the # Cygnus Win32 Development Kit. -# See "http://www.cygnus.com/misc/gnu-win32/" to learn about the kit. # -path_sep=\; +_a='.a' +_exe='.exe' +_o='.o' +archname='cygwin32' +# hmm... why Configure doesn't look for this? +#bash='/usr/bin/bash' +bin='/usr/local/bin' +binexp='/usr/local/bin' +byteorder='1234' +cc='gcc' +cccdlflags='' +# ccflags='-I/usr/local/include -ggdb3 -DCYGWIN32 -DDEBUGGING' +# ok, debugging may be not appropriate for everyone +ccflags='-DCYGWIN32' +clocktype='clock_t' +cryptlib='-lcrypt' +dlext='dll' +dlsrc='dl_cygwin32.xs' exe_ext='.exe' +# work around case-insensitive file names firstmakefile='GNUmakefile' -if test -f $sh.exe; then sh=$sh.exe; fi -startsh="#!$sh" -cc='gcc2' -ld='ld2' -usrinc='/gnuwin32/H-i386-cygwin32/i386-cygwin32/include' -libpth='/gnuwin32/H-i386-cygwin32/i386-cygwin32/lib /gnuwin32/H-i386-cygwin32/lib' -libs='-lcygwin -lm -lc -lkernel32' -# dynamic lib stuff -so='dll' -#i_dlfcn='define' -dlsrc='dl_cygwin32.xs' -usedl='y' -# flag to include the perl.exe export variable translation file cw32imp.h -# when building extension libs -cccdlflags='-DCYGWIN32 -DDLLIMPORT ' -# flag that signals gcc2 to build exportable perl -ccdlflags='-buildperl ' -lddlflags='-L../.. -L/gnuwin32/H-i386-cygwin32/i386-cygwin32/lib -lperlexp -lcygwin' -d_voidsig='undef' -extensions='Fcntl IO Opcode SDBM_File' -lns='cp' -signal_t='int' -useposix='false' -rd_nodata='0' -eagain='EAGAIN' -archname='cygwin32' -# - -installbin='/usr/local/bin' -installman1dir='' -installman3dir='' -installprivlib='/usr/local/lib/perl5' +gidtype='gid_t' +installman1dir='/usr/local/man/man1' +installman3dir='/usr/local/man/man3' installscript='/usr/local/bin' - installsitelib='/usr/local/lib/perl5/site_perl' -libc='/gnuwin32/H-i386-cygwin32/i386-cygwin32/lib/libc.a' - -perlpath='/usr/local/bin/perl' - +installusrbinperl='undef' +ld='ld2' +lddlflags='-DCYGWIN32 --export-dynamic --strip-debug' +ldflags="-L. -L`pwd`" +lib_ext='.a' +libperl='libperl.a' +libpth='/usr/lib /usr/local/lib /cygnus/cygwin-b20/H-i586-cygwin32/lib' +libs='-lcygwin -lm -lc -lkernel32' +man1dir='/usr/local/man/man1' +man1direxp='/usr/local/man/man1' +man1ext='1' +man3dir='/usr/local/man/man3' +man3direxp='/usr/local/man/man3' +man3ext='3' +obj_ext='.o' +optimize='-O' +path_sep=':' +prefix='/usr/local' +prefixexp='/usr/local' +scriptdir='/usr/local/bin' +scriptdirexp='/usr/local/bin' sitelib='/usr/local/lib/perl5/site_perl' sitelibexp='/usr/local/lib/perl5/site_perl' -usrinc='/gnuwin32/H-i386-cygwin32/i386-cygwin32/include' +sysman='/usr/local/man/man1' +usenm='false' +useperlio='define' +useshrplib='true' +usevfork='true' +usrinc='/usr/i586-cygwin32/include' diff --git a/installhtml b/installhtml index db1e612865..d73124ce13 100755 --- a/installhtml +++ b/installhtml @@ -515,7 +515,7 @@ sub installdir { || die "$0: error opening directory $podroot/$dir: $!\n"; # find the directories to recurse on - @dirlist = map { "$dir/$_" } + @dirlist = map { if ($^O eq 'VMS') {/^(.*)\.dir$/i; "$dir/$1";} else {"$dir/$_";}} grep(-d "$podroot/$dir/$_" && !/^\.{1,2}/, readdir(DIR)) if $recurse; rewinddir(DIR); diff --git a/installman b/installman index 51e20196d2..4f62be5860 100755 --- a/installman +++ b/installman @@ -65,6 +65,7 @@ runpod2man('lib', $man3dir, $man3ext); runpod2man('utils', $man1dir, $man1ext, 'c2ph'); runpod2man('utils', $man1dir, $man1ext, 'h2ph'); runpod2man('utils', $man1dir, $man1ext, 'h2xs'); +runpod2man('utils', $man1dir, $man1ext, 'perlcc'); runpod2man('utils', $man1dir, $man1ext, 'perldoc'); runpod2man('utils', $man1dir, $man1ext, 'perlbug'); runpod2man('utils', $man1dir, $man1ext, 'pl2pm'); @@ -73,6 +74,9 @@ runpod2man('x2p', $man1dir, $man1ext, 's2p'); runpod2man('x2p', $man1dir, $man1ext, 'a2p.pod'); runpod2man('pod', $man1dir, $man1ext, 'pod2man'); runpod2man('pod', $man1dir, $man1ext, 'pod2html'); +runpod2man('pod', $man1dir, $man1ext, 'pod2usage'); +runpod2man('pod', $man1dir, $man1ext, 'podchecker'); +runpod2man('pod', $man1dir, $man1ext, 'podselect'); # It would probably be better to have this page linked # to the c2ph man page. Or, this one could say ".so man1/c2ph.1", diff --git a/installperl b/installperl index 4e9b391aa8..7689005edd 100755 --- a/installperl +++ b/installperl @@ -8,12 +8,13 @@ BEGIN { } use strict; -use vars qw($Is_VMS $Is_W32 $Is_OS2 $nonono $versiononly $depth); +use vars qw($Is_VMS $Is_W32 $Is_OS2 $Is_Cygwin $nonono $versiononly $depth); BEGIN { $Is_VMS = $^O eq 'VMS'; $Is_W32 = $^O eq 'MSWin32'; $Is_OS2 = $^O eq 'os2'; + $Is_Cygwin = $^O =~ /cygwin/i; if ($Is_VMS) { eval 'use VMS::Filespec;' } } @@ -141,10 +142,24 @@ if ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; } || warn "WARNING: You've never run 'make test'!!!", " (Installing anyway.)\n"; -if ($Is_W32) { - -my $perldll = 'perl.' . $dlext; -$perldll = 'perlcore.' . $dlext if $Config{'ccflags'} =~ /PERL_OBJECT/i; +if ($Is_W32 or $Is_Cygwin) { + my $perldll; + +if ($Is_Cygwin) { + $perldll = $libperl; + $perldll =~ s/(\..*)?$/.$dlext/; + if ($Config{useshrplib} eq 'true') { + # install ld2 and perlld as well + foreach ('ld2', 'perlld') { + safe_unlink("$installbin/$_"); + copy("$_", "$installbin/$_"); + chmod(0755, "$installbin/$_"); + }; + }; +} else { + $perldll = 'perl.' . $dlext; + $perldll = 'perlcore.' . $dlext if $Config{'ccflags'} =~ /PERL_OBJECT/i; +} -f $perldll || die "No perl DLL built\n"; @@ -227,7 +242,13 @@ if ($Is_VMS) { # We did core file selection during build @corefiles = <$coredir/*.*>; } else { + # [als] hard-coded 'libperl' name... not good! @corefiles = <*.h libperl*.*>; + + # cygwin needs special stub for dll loading + push @corefiles, 'impure_ptr.o' + if ($Is_Cygwin and $Config{useshrplib} eq 'true'); + # AIX needs perl.exp installed as well. push(@corefiles,'perl.exp') if $^O eq 'aix'; if ($^O eq 'mpeix') { @@ -439,7 +460,7 @@ sub unlink { foreach my $name (@names) { next unless -e $name; - chmod 0777, $name if ($Is_OS2 || $Is_W32); + chmod 0777, $name if ($Is_OS2 || $Is_W32 || $Is_Cygwin); print STDERR " unlink $name\n"; ( CORE::unlink($name) and ++$cnt or warn "Couldn't unlink $name: $!\n" ) unless $nonono; diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 655782145b..df40649a42 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -209,6 +209,8 @@ sub abs_path my $start = @_ ? shift : '.'; my($dotdots, $cwd, @pst, @cst, $dir, @tst); + return cwd() if ( $^O =~ /cygwin/ ); + unless (@cst = stat( $start )) { carp "stat($start): $!"; diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 8d09668ff8..40a8256475 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -384,6 +384,11 @@ sub cflags { $self->{OPTIMIZE} =~ s/-TP(\s|$)//; } } + + if ($self->{POLLUTE}) { + $self->{CCFLAGS} .= ' -DPERL_POLLUTE '; + } + return $self->{CFLAGS} = qq{ CCFLAGS = $self->{CCFLAGS} OPTIMIZE = $self->{OPTIMIZE} diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index 08a1c66ccd..a8ea73ea40 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -70,6 +70,7 @@ $Is_VMS = $^O eq 'VMS'; $Is_OS2 = $^O eq 'os2'; $Is_Mac = $^O eq 'MacOS'; $Is_Win32 = $^O eq 'MSWin32'; +$Is_Cygwin= $^O =~ /cygwin/i; require ExtUtils::MM_Unix; @@ -86,6 +87,9 @@ if ($Is_Mac) { if ($Is_Win32) { require ExtUtils::MM_Win32; } +if ($Is_Cygwin) { + require ExtUtils::MM_Cygwin; +} # The SelfLoader would bring a lot of overhead for MakeMaker, because # we know for sure we will use most of the autoloaded functions once @@ -245,7 +249,7 @@ sub full_setup { LINKTYPE MAKEAPERL MAKEFILE MAN1PODS MAN3PODS MAP_TARGET MYEXTLIB NAME NEEDS_LINKING NOECHO NORECURS NO_VC OBJECT OPTIMIZE PERL PERLMAINCC PERL_ARCHLIB PERL_LIB PERL_SRC PERM_RW PERM_RWX - PL_FILES PM PMLIBDIRS PPM_INSTALL_EXEC PPM_INSTALL_SCRIPT PREFIX + PL_FILES PM PMLIBDIRS POLLUTE PPM_INSTALL_EXEC PPM_INSTALL_SCRIPT PREFIX PREREQ_PM SKIP TYPEMAPS VERSION VERSION_FROM XS XSOPT XSPROTOARG XS_VERSION clean depend dist dynamic_lib linkext macro realclean tool_autosplit @@ -441,11 +445,13 @@ sub ExtUtils::MakeMaker::new { } if ($self->{PARENT}) { $self->{PARENT}->{CHILDREN}->{$newclass} = $self; - if (exists $self->{PARENT}->{CAPI} - and not exists $self->{CAPI}) - { - # inherit, but only if already unspecified - $self->{CAPI} = $self->{PARENT}->{CAPI}; + foreach my $opt (qw(CAPI POLLUTE)) { + if (exists $self->{PARENT}->{$opt} + and not exists $self->{$opt}) + { + # inherit, but only if already unspecified + $self->{$opt} = $self->{PARENT}->{$opt}; + } } } } else { @@ -1613,6 +1619,18 @@ they contain will be installed in the corresponding location in the library. A libscan() method can be used to alter the behaviour. Defining PM in the Makefile.PL will override PMLIBDIRS. +=item POLLUTE + +Release 5.005 grandfathered old global symbol names by providing preprocessor +macros for extension source compatibility. As of release 5.006, these +preprocessor definitions are not available by default. The POLLUTE flag +specifies that the old names should still be defined: + + perl Makefile.PL POLLUTE=1 + +Please inform the module author if this is necessary to successfully install +a module under 5.006 or later. + =item PPM_INSTALL_EXEC Name of the executable used to run C<PPM_INSTALL_SCRIPT> below. (e.g. perl) @@ -1776,9 +1794,13 @@ be linked. {FILES => '$(INST_ARCHAUTODIR)/*.xyz'} +=item test + + {TESTS => 't/*.t'} + =item tool_autosplit - {MAXLEN =E<gt> 8} + {MAXLEN => 8} =back diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm index e1da6b6e59..fd812bc721 100644 --- a/lib/File/Copy.pm +++ b/lib/File/Copy.pm @@ -64,6 +64,7 @@ sub copy { && !$to_a_handle && !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles && !($from_a_handle && $^O eq 'mpeix') # and neither can MPE/iX. + && !($from_a_handle && $^O eq 'MSWin32') ) { return syscopy($from, $to); @@ -186,6 +187,11 @@ unless (defined &syscopy) { # preserve MPE file attributes. return system('/bin/cp', '-f', $_[0], $_[1]) == 0; }; + } elsif ($^O eq 'MSWin32') { + *syscopy = sub { + return 0 unless @_ == 2; + return Win32::CopyFile(@_, 1); + }; } else { *syscopy = \© } @@ -272,9 +278,9 @@ second parameter, preserving OS-specific attributes and file structure. For Unix systems, this is equivalent to the simple C<copy> routine. For VMS systems, this calls the C<rmscopy> routine (see below). For OS/2 systems, this calls the C<syscopy> -XSUB directly. +XSUB directly. For Win32 systems, this calls C<Win32::CopyFile>. -=head2 Special behaviour if C<syscopy> is defined (VMS and OS/2) +=head2 Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32) If both arguments to C<copy> are not file handles, then C<copy> will perform a "system copy" of diff --git a/lib/Pod/Html.pm b/lib/Pod/Html.pm index 4fe7586025..ee303d353f 100644 --- a/lib/Pod/Html.pm +++ b/lib/Pod/Html.pm @@ -1397,8 +1397,7 @@ sub process_puretext { # sub pre_escape { my($str) = @_; - - $$str =~ s,&,&,g; + $$str =~ s/&(?!\w+;|#)/&/g; # XXX not bulletproof } # @@ -1406,6 +1405,7 @@ sub pre_escape { # sub dosify { my($str) = @_; + return lc($str) if $^O eq 'VMS'; # VMS just needs casing if ($Is83) { $str = lc $str; $str =~ s/(\.\w+)/substr ($1,0,4)/ge; diff --git a/lib/Test.pm b/lib/Test.pm index 00b32368d8..2187e8cd85 100644 --- a/lib/Test.pm +++ b/lib/Test.pm @@ -4,7 +4,7 @@ use Test::Harness 1.1601 (); use Carp; use vars (qw($VERSION @ISA @EXPORT @EXPORT_OK $ntest $TestLevel), #public-ish qw($TESTOUT $ONFAIL %todo %history $planned @FAILDETAIL)); #private-ish -$VERSION = '1.121'; +$VERSION = '1.13'; require Exporter; @ISA=('Exporter'); @EXPORT=qw(&plan &ok &skip); @@ -63,7 +63,11 @@ sub ok ($;$$) { } else { $expected = to_value(shift); my ($regex,$ignore); - if ((ref($expected)||'') eq 'Regexp') { + if (!defined $expected) { + $ok = !defined $result; + } elsif (!defined $result) { + $ok = 0; + } elsif ((ref($expected)||'') eq 'Regexp') { $ok = $result =~ /$expected/; } elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or ($ignore, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) { @@ -94,7 +98,8 @@ sub ok ($;$$) { } } else { my $prefix = "Test $ntest"; - print $TESTOUT "# $prefix got: '$result' ($context)\n"; + print $TESTOUT "# $prefix got: ". + (defined $result? "'$result'":'<UNDEF>')." ($context)\n"; $prefix = ' ' x (length($prefix) - 5); if ((ref($expected)||'') eq 'Regexp') { $expected = 'qr/'.$expected.'/' @@ -162,7 +167,7 @@ __END__ ok(sub { 1+1 }, 2); # success: '2' eq '2' ok(sub { 1+1 }, 3); # failure: '2' ne '3' - ok(0, int(rand(2)); # (just kidding! :-) + ok(0, int(rand(2)); # (just kidding :-) my @list = (0,0); ok @list, 3, "\@list=".join(',',@list); #extra diagnostics @@ -239,7 +244,7 @@ L<Test::Harness> and, perhaps, test coverage analysis tools. =head1 AUTHOR -Copyright (C) 1998 Joshua Nathaniel Pritikin. All rights reserved. +Copyright (c) 1998-1999 Joshua Nathaniel Pritikin. All rights reserved. This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified diff --git a/lib/autouse.pm b/lib/autouse.pm index 4445c6c419..179c382ca2 100644 --- a/lib/autouse.pm +++ b/lib/autouse.pm @@ -3,7 +3,7 @@ package autouse; #use strict; # debugging only use 5.003_90; # ->can, for my $var -$autouse::VERSION = '1.01'; +$autouse::VERSION = '1.02'; $autouse::DEBUG ||= 0; @@ -25,7 +25,7 @@ sub import { vet_import $module; local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; # $Exporter::Verbose = 1; - return $module->import(map { (my $f = $_) =~ s/\(.*?\)$// } @_); + return $module->import(map { (my $f = $_) =~ s/\(.*?\)$//; $f } @_); } # It is not loaded: need to do real work. diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 18196278d9..f6b0ecbc95 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -296,7 +296,10 @@ if ($notty) { #require Term::ReadLine; - if (-e "/dev/tty") { + if ($^O =~ /cygwin/) { + # /dev/tty is binary. use stdin for textmode + undef $console; + } elsif (-e "/dev/tty") { $console = "/dev/tty"; } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') { $console = "con"; diff --git a/makedepend.SH b/makedepend.SH index ba90d72abb..e1c28468bd 100755 --- a/makedepend.SH +++ b/makedepend.SH @@ -105,7 +105,11 @@ for file in `$cat .clist`; do if [ "$osname" = os2 ]; then uwinfix="-e s,\\\\\\\\,/,g" else - uwinfix= + if [ "$archname" = cygwin32 ]; then + uwinfix="-e s,\\\\\\\\,/,g" + else + uwinfix= + fi fi fi case "$file" in @@ -1047,6 +1047,8 @@ #define do_eof pPerl->Perl_do_eof #undef do_exec #define do_exec pPerl->Perl_do_exec +#undef do_exec3 +#define do_exec3 pPerl->Perl_do_exec3 #undef do_execfree #define do_execfree pPerl->Perl_do_execfree #undef do_gv_dump @@ -1137,6 +1139,8 @@ #define dofindlabel pPerl->Perl_dofindlabel #undef doform #define doform pPerl->Perl_doform +#undef doopen +#define doopen pPerl->Perl_doopen #undef doparseform #define doparseform pPerl->Perl_doparseform #undef dopoptoeval @@ -1722,6 +1722,8 @@ newPROG(OP *o) { dTHR; if (PL_in_eval) { + if (PL_eval_root) + return; PL_eval_root = newUNOP(OP_LEAVEEVAL, ((PL_in_eval & 4) ? OPf_SPECIAL : 0), o); PL_eval_start = linklist(PL_eval_root); PL_eval_root->op_next = 0; diff --git a/os2/os2ish.h b/os2/os2ish.h index 97b489b40d..cfd13c8335 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -148,10 +148,17 @@ extern int rc; #define dTHR struct thread *thr = THR */ -#define pthread_getspecific(k) (*_threadstore()) -#define pthread_setspecific(k,v) (*_threadstore()=v,0) +#ifdef USE_SLOW_THREAD_SPECIFIC +# define pthread_getspecific(k) (*_threadstore()) +# define pthread_setspecific(k,v) (*_threadstore()=v,0) +# define pthread_key_create(keyp,flag) (*keyp=_gettid(),0) +#else +# define pthread_getspecific(k) (*(k)) +# define pthread_setspecific(k,v) (*(k)=(v),0) +# define pthread_key_create(keyp,flag) (DosAllocThreadLocalMemory(1,(U32*)keyp) ? croak("LocalMemory"),1 : 0) +#endif +#define pthread_key_delete(keyp) #define pthread_self() _gettid() -#define pthread_key_create(keyp,flag) (*keyp=_gettid(),0) #define YIELD DosSleep(0) #ifdef PTHREADS_INCLUDED /* For ./x2p stuff. */ diff --git a/os2/os2thread.h b/os2/os2thread.h index d56fe160dd..9516ddda0b 100644 --- a/os2/os2thread.h +++ b/os2/os2thread.h @@ -8,7 +8,11 @@ typedef _rmutex perl_mutex; /*typedef HEV perl_cond;*/ /* Will include os2.h into all C files. */ typedef unsigned long perl_cond; +#ifdef USE_SLOW_THREAD_SPECIFIC typedef int perl_key; +#else +typedef void** perl_key; +#endif typedef unsigned long pthread_attr_t; #define PTHREADS_INCLUDED @@ -218,7 +218,7 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); */ /* define this once if either system, instead of cluttering up the src */ -#if defined(MSDOS) || defined(atarist) || defined(WIN32) +#if defined(MSDOS) || defined(atarist) || defined(WIN32) || defined(CYGWIN32) #define DOSISH 1 #endif @@ -1449,6 +1449,14 @@ typedef pthread_key_t perl_key; # define STATUS_ALL_FAILURE (PL_statusvalue = 1) #endif +/* This defines a way to flush all output buffers. This may be a + * performance issue, so we allow people to disable it. + * XXX the default needs a Configure test, as it may not work everywhere. + */ +#ifndef PERL_FLUSHALL_FOR_CHILD +#define PERL_FLUSHALL_FOR_CHILD PerlIO_flush((PerlIO*)NULL) +#endif + /* Some unistd.h's give a prototype for pause() even though HAS_PAUSE ends up undefined. This causes the #define below to be rejected by the compmiler. Sigh. @@ -1487,11 +1495,7 @@ union any { #define ARGSproto void #endif /* USE_THREADS */ -/* Work around some cygwin32 problems with importing global symbols */ #if defined(CYGWIN32) -# if defined(DLLIMPORT) -# include "cw32imp.h" -# endif /* USEMYBINMODE * This symbol, if defined, indicates that the program should * use the routine my_binmode(FILE *fp, char iotype) to insure @@ -1648,6 +1652,11 @@ typedef I32 CHECKPOINT; #define U_V(what) (cast_uv((double)(what))) #endif +/* Used with UV/IV arguments: */ + /* XXXX: need to speed it up */ +#define CLUMP_2UV(iv) ((iv) < 0 ? 0 : (UV)(iv)) +#define CLUMP_2IV(uv) ((uv) > (UV)IV_MAX ? IV_MAX : (IV)(uv)) + struct Outrec { I32 o_lines; char *o_str; @@ -1685,7 +1694,11 @@ Gid_t getegid _((void)); #define DEBUG_o(a) if (PL_debug & 16) a #define DEBUG_c(a) if (PL_debug & 32) a #define DEBUG_P(a) if (PL_debug & 64) a -#define DEBUG_m(a) if (PL_curinterp && PL_debug & 128) a +# ifdef PERL_OBJECT +# define DEBUG_m(a) if (PL_debug & 128) a +# else +# define DEBUG_m(a) if (PL_curinterp && PL_debug & 128) a +# endif #define DEBUG_f(a) if (PL_debug & 256) a #define DEBUG_r(a) if (PL_debug & 512) a #define DEBUG_x(a) if (PL_debug & 1024) a @@ -2300,7 +2313,7 @@ struct perl_vars { EXT struct perl_vars PL_Vars; EXT struct perl_vars *PL_VarsPtr INIT(&PL_Vars); #else /* PERL_CORE */ -#if !defined(__GNUC__) || !defined(WIN32) +#if !defined(__GNUC__) || !(defined(WIN32) || defined(CYGWIN32)) EXT #endif /* WIN32 */ struct perl_vars *PL_VarsPtr; diff --git a/perlvars.h b/perlvars.h index 174747884f..67dc7c181f 100644 --- a/perlvars.h +++ b/perlvars.h @@ -138,7 +138,7 @@ PERLVAR(Gcryptseen, I32) /* has fast crypt() been initialized? */ PERLVAR(Ghints, U32) /* pragma-tic compile-time flags */ -PERLVAR(Gdo_undump, bool) /* -u or dump seen? */ +PERLVARI(Gdo_undump, bool, FALSE) /* -u or dump seen? */ PERLVAR(Gdebug, VOL U32) /* flags given to -D switch */ PERLVAR(Gamagic_generation, long) diff --git a/pod/Win32.pod b/pod/Win32.pod new file mode 100644 index 0000000000..a0bf040b74 --- /dev/null +++ b/pod/Win32.pod @@ -0,0 +1,283 @@ +=head1 NAME + +Win32 - Interfaces to some Win32 API Functions + +=head1 DESCRIPTION + +Perl on Win32 contains several functions to access Win32 APIs. Some +are included in Perl itself (on Win32) and some are only available +after explicitly requesting the Win32 module with: + + use Win32; + +The builtin functions are marked as [CORE] and the other ones +as [EXT] in the following alphabetical listing. The C<Win32> module +is not part of the Perl source distribution; it is distributed in +the libwin32 bundle of Win32::* modules on CPAN. The module is +already preinstalled in binary distributions like ActivePerl. + +=head2 Alphabetical Listing of Win32 Functions + +=over + +=item Win32::AbortSystemShutdown(MACHINE) + +[EXT] Aborts a system shutdown (started by the +InitiateSystemShutdown function) on the specified MACHINE. + +=item Win32::BuildNumber() + +[CORE] Returns the ActivePerl build number. This function is +only available in the ActivePerl binary distribution. + +=item Win32::CopyFile(FROM, TO, OVERWRITE) + +The Win32::CopyFile() function copies an existing file to a new file. All +file information like creation time and file attributes will be copied to +the new file. However it will B<not> copy the security information. If the +destination file already exists it will only be overwritten when the +OVERWRITE parameter is true. But even this will not overwrite a read-only +file; you have to unlink() it first yourself. + +=item Win32::DomainName() + +[CORE] Returns the name of the Microsoft Network domain that the +owner of the current perl process is logged into. + +=item Win32::ExpandEnvironmentStrings(STRING) + +[EXT] Takes STRING and replaces all referenced environment variable +names with their defined values. References to environment variables +take the form C<%VariableName%>. Case is ignored when looking up the +VariableName in the environment. If the variable is not found then the +original C<%VariableName%> text is retained. Has the same effect +as the following: + + $string =~ s/%([^%]*)%/$ENV{$1} || "%$1%"/eg + +=item Win32::FormatMessage(ERRORCODE) + +[CORE] Converts the supplied Win32 error number (e.g. returned by +Win32::GetLastError()) to a descriptive string. Analogous to the +perror() standard-C library function. Note that C<$^E> used +in a string context has much the same effect. + + C:\> perl -e "$^E = 26; print $^E;" + The specified disk or diskette cannot be accessed + +=item Win32::FsType() + +[CORE] Returns the name of the filesystem of the currently active +drive (like 'FAT' or 'NTFS'). In list context it returns three values: +(FSTYPE, FLAGS, MAXCOMPLEN). FSTYPE is the filesystem type as +before. FLAGS is a combination of values of the following table: + + 0x00000001 supports case-sensitive filenames + 0x00000002 preserves the case of filenames + 0x00000004 supports Unicode in filenames + 0x00000008 preserves and enforces ACLs + 0x00000010 supports file-based compression + 0x00000020 supports disk quotas + 0x00000040 supports sparse files + 0x00000080 supports reparse points + 0x00000100 supports remote storage + 0x00008000 is a compressed volume (e.g. DoubleSpace) + 0x00010000 supports object identifiers + 0x00020000 supports the Encrypted File System (EFS) + +MAXCOMPLEN is the maximum length of a filename component (the part +between two backslashes) on this file system. + +=item Win32::FreeLibrary(HANDLE) + +[EXT] Unloads a previously loaded dynamic-link library. The HANDLE is +no longer valid after this call. See L<LoadLibrary> for information on +dynamically loading a library. + +=item Win32::GetArchName() + +[EXT] Use of this function is deprecated. It is equivalent with +$ENV{PROCESSOR_ARCHITECTURE}. This might not work on Win9X. + +=item Win32::GetChipName() + +[EXT] Returns the processor type: 386, 486 or 586 for Intel processors, +21064 for the Alpha chip. + +=item Win32::GetCwd() + +[CORE] Returns the current active drive and directory. This function +does not return a UNC path, since the functionality required for such +a feature is not available under Windows 95. + +=item Win32::GetFullPathName(FILENAME) + +[CORE] GetFullPathName combines the FILENAME with the current drive +and directory name and returns a fully qualified (aka, absolute) +path name. In list context it returns two elements: (PATH, FILE) where +PATH is the complete pathname component (including trailing backslash) +and FILE is just the filename part. Note that no attempt is made to +convert 8.3 components in the supplied FILENAME to longnames or +vice-versa. Compare with Win32::GetShortPathName and +Win32::GetLongPathName. + +This function has been added for Perl 5.006. + +=item Win32::GetLastError() + +[CORE] Returns the last error value generated by a call to a Win32 API +function. Note that C<$^E> used in a numeric context amounts to the +same value. + +=item Win32::GetLongPathName(PATHNAME) + +[CORE] Returns a representaion of PATHNAME comprised of longname +compnents (if any). The result may not necessarily be longer +than PATHNAME. No attempt is made to convert PATHNAME to the +absolute path. Compare with Win32::GetShortPathName and +Win32::GetFullPathName. + +This function has been added for Perl 5.006. + +=item Win32::GetNextAvailDrive() + +[CORE] Returns a string in the form of "<d>:" where <d> is the first +available drive letter. + +=item Win32::GetOSVersion() + +[CORE] Returns the array (STRING, MAJOR, MINOR, BUILD, ID), where +the elements are, respectively: An arbitrary descriptive string, the +major version number of the operating system, the minor version +number, the build number, and a digit indicating the actual operating +system. For ID, the values are 0 for Win32s, 1 for Windows 9X and 2 +for Windows NT. In scalar context it returns just the ID. + +=item Win32::GetShortPathName(PATHNAME) + +[CORE] Returns a representation of PATHNAME comprised only of +short (8.3) path components. The result may not necessarily be +shorter than PATHNAME. Compare with Win32::GetFullPathName and +Win32::GetLongPathName. + +=item Win32::GetProcAddress(INSTANCE, PROCNAME) + +[EXT] Returns the address of a function inside a loaded library. The +information about what you can do with this address has been lost in +the mist of time. Use the Win32::API module instead of this deprecated +function. + +=item Win32::GetTickCount() + +[CORE] Returns the number of milliseconds elapsed since the last +system boot. Resolution is limited to system timer ticks (about 10ms +on WinNT and 55ms on Win9X). + +=item Win32::InitiateSystemShutdown(MACHINE, MESSAGE, TIMEOUT, FORCECLOSE, REBOOT) + +[EXT] Shutsdown the specified MACHINE, notifying users with the +supplied MESSAGE, within the specified TIMEOUT interval. Forces +closing of all documents without prompting the user if FORCECLOSE is +true, and reboots the machine if REBOOT is true. This function works +only on WinNT. + +=item Win32::IsWinNT() + +[CORE] Returns non zero if the Win32 subsystem is Windows NT. + +=item Win32::IsWin95() + +[CORE] Returns non zero if the Win32 subsystem is Windows 95. + +=item Win32::LoadLibrary(LIBNAME) + +[EXT] Loads a dynamic link library into memory and returns its module +handle. This handle can be used with Win32::GetProcAddress and +Win32::FreeLibrary. This function is deprecated. Use the Win32::API +module instead. + +=item Win32::LoginName() + +[CORE] Returns the username of the owner of the current perl process. + +=item Win32::LookupAccountName(SYSTEM, ACCOUNT, DOMAIN, SID, SIDTYPE) + +[EXT] Looks up ACCOUNT on SYSTEM and returns the domain name the SID and +the SID type. + +=item Win32::LookupAccountSID(SYSTEM, SID, ACCOUNT, DOMAIN, SIDTYPE) + +[EXT] ]Looks up SID on SYSTEM and returns the account name, domain name, +and the SID type. + +=item Win32::MsgBox(MESSAGE [, FLAGS [, TITLE]]) + +[EXT] Create a dialogbox containing MESSAGE. FLAGS specifies the +required icon and buttons according to the following table: + + 0 = OK + 1 = OK and Cancel + 2 = Abort, Retry, and Ignore + 3 = Yes, No and Cancel + 4 = Yes and No + 5 = Retry and Cancel + + MB_ICONSTOP "X" in a red circle + MB_ICONQUESTION question mark in a bubble + MB_ICONEXCLAMATION exclamation mark in a yellow triangle + MB_ICONINFORMATION "i" in a bubble + +TITLE specifies an optional window title. The default is "Perl". + +The function returns the menu id of the selected push button: + + 0 Error + + 1 OK + 2 Cancel + 3 Abort + 4 Retry + 5 Ignore + 6 Yes + 7 No + +=item Win32::NodeName() + +[CORE] Returns the Microsoft Network node-name of the current machine. + +=item Win32::RegisterServer(LIBRARYNAME) + +[EXT] Loads the DLL LIBRARYNAME and calls the function DllRegisterServer. + +=item Win32::SetCwd(NEWDIRECTORY) + +[CORE] Sets the current active drive and directory. This function does not +work with UNC paths, since the functionality required to required for +such a feature is not available under Windows 95. + +=item Win32::SetLastError(ERROR) + +[CORE] Sets the value of the last error encountered to ERROR. This is +that value that will be returned by the Win32::GetLastError() +function. This functions has been added for Perl 5.006. + +=item Win32::Sleep(TIME) + +[CORE] Pauses for TIME milliseconds. The timeslices are made available +to other processes and threads. + +=item Win32::Spawn(COMMAND, ARGS, PID) + +[CORE] Spawns a new process using the supplied COMMAND, passing in +arguments in the string ARGS. The pid of the new process is stored in +PID. This function is deprecated. Please use the Win32::Process module +instead. + +=item Win32::UnregisterServer(LIBRARYNAME) + +[EXT] Loads the DLL LIBRARYNAME and calls the function +DllUnregisterServer. + +=back + +=cut diff --git a/pod/perldelta.pod b/pod/perldelta.pod index ca6a6386b8..d2ef10daa0 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -21,7 +21,11 @@ None known at this time. Release 5.005 grandfathered old global symbol names by providing preprocessor macros for extension source compatibility. As of release 5.006, these preprocessor definitions are not available by default. You need to explicitly -compile perl with C<-DPERL_POLLUTE> in order to get these definitions. +compile perl with C<-DPERL_POLLUTE> in order to get these definitions. For +extensions that are still using the old symbols, this option can be +specified via MakeMaker: + + perl Makefile.PL POLLUTE=1 =item C<PERL_POLLUTE_MALLOC> @@ -217,6 +221,14 @@ Parsing of here documents used to be flawed when they appeared as the replacement expression in C<eval 's/.../.../e'>. This has been fixed. +=head2 Automatic flushing of output buffers + +fork(), exec(), system(), qx// and pipe open()s now flush the buffers +of all files that were opened for output at the time the operation +was attempted. The mostly eliminates the often confusing effects of +buffering mishaps suffered by users unaware of how Perl internally +handled I/O. + =head1 Supported Platforms =over 4 diff --git a/pod/perldiag.pod b/pod/perldiag.pod index cc9160e2ac..4b18882b28 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -2021,6 +2021,10 @@ and then discovered it wasn't a context we know how to do a goto in. (P) The lexer got into a bad state parsing a string with brackets. +=item panic: kid popen errno read + +(F) forked child returned an incomprehensible message about its errno. + =item panic: last (P) We popped the context stack to a block context, and then discovered diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index a65e3e3e46..d409319a09 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -290,8 +290,8 @@ X<-S>X<-b>X<-c>X<-t>X<-u>X<-g>X<-k>X<-T>X<-B>X<-M>X<-A>X<-C> -g File has setgid bit set. -k File has sticky bit set. - -T File is a text file. - -B File is a binary file (opposite of -T). + -T File is an ASCII text file. + -B File is a "binary" file (opposite of -T). -M Age of file in days when script started. -A Same for access time. @@ -1311,12 +1311,9 @@ the argument is checked for shell metacharacters, and if there are any, the entire argument is passed to the system's command shell for parsing (this is C</bin/sh -c> on Unix platforms, but varies on other platforms). If there are no shell metacharacters in the argument, it is split into -words and passed directly to C<execvp()>, which is more efficient. Note: -C<exec()> and C<system()> do not flush your output buffer, so you may need to -set C<$|> to avoid lost output. Examples: +words and passed directly to C<execvp()>, which is more efficient. - exec '/bin/echo', 'Your arguments are: ', @ARGV; - exec "sort $outfile | uniq"; +All files opened for output are flushed before attempting the exec(). If you don't really want to execute the first argument, but want to lie to the program you are executing about its own name, you can specify @@ -1542,9 +1539,7 @@ fork(), great care has gone into making it extremely efficient (for example, using copy-on-write technology on data pages), making it the dominant paradigm for multitasking over the last few decades. -Note: unflushed buffers remain unflushed in both processes, which means -you may need to set C<$|> ($AUTOFLUSH in English) or call the C<autoflush()> -method of C<IO::Handle> to avoid duplicate output. +All files opened for output are flushed before forking the child process. If you C<fork()> without ever waiting on your children, you will accumulate zombies. On some systems, you can avoid this by setting @@ -2527,11 +2522,10 @@ The following pairs are more or less equivalent: See L<perlipc/"Safe Pipe Opens"> for more examples of this. -NOTE: On any operation that may do a fork, any unflushed buffers remain -unflushed in both processes, which means you may need to set C<$|> to -avoid duplicate output. On systems that support a close-on-exec flag on -files, the flag will be set for the newly opened file descriptor as -determined by the value of $^F. See L<perlvar/$^F>. +NOTE: On any operation that may do a fork, all files opened for output +are flushed before the fork is attempted. On systems that support a +close-on-exec flag on files, the flag will be set for the newly opened +file descriptor as determined by the value of $^F. See L<perlvar/$^F>. Closing any piped filehandle causes the parent process to wait for the child to finish, and returns the status value in C<$?>. diff --git a/pod/perlipc.pod b/pod/perlipc.pod index 2f99d10e23..1492ccfc31 100644 --- a/pod/perlipc.pod +++ b/pod/perlipc.pod @@ -307,8 +307,7 @@ To catch it, you could use this: Both the main process and any child processes it forks share the same STDIN, STDOUT, and STDERR filehandles. If both processes try to access -them at once, strange things can happen. You'll certainly want to any -stdio flush output buffers before forking. You may also want to close +them at once, strange things can happen. You may also want to close or reopen the filehandles for the child. You can get around this by opening your pipe with open(), but on some systems this means that the child process cannot outlive the parent. @@ -473,7 +472,6 @@ Here's an example of using open2(): use FileHandle; use IPC::Open2; $pid = open2(*Reader, *Writer, "cat -u -n" ); - Writer->autoflush(); # default here, actually print Writer "stuff\n"; $got = <Reader>; diff --git a/pod/perlop.pod b/pod/perlop.pod index f70311b8e1..106b9a9a87 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -365,12 +365,14 @@ Use "or" for assignment is unlikely to do what you want; see below. Binary ".." is the range operator, which is really two different operators depending on the context. In list context, it returns an -array of values counting (by ones) from the left value to the right -value. This is useful for writing C<foreach (1..10)> loops and for -doing slice operations on arrays. In the current implementation, no -temporary array is created when the range operator is used as the -expression in C<foreach> loops, but older versions of Perl might burn -a lot of memory when you write something like this: +array of values counting (up by ones) from the left value to the right +value. If the left value is greater than the right value then it +returns the empty array. The range operator is useful for writing +C<foreach (1..10)> loops and for doing slice operations on arrays. In +the current implementation, no temporary array is created when the +range operator is used as the expression in C<foreach> loops, but older +versions of Perl might burn a lot of memory when you write something +like this: for (1 .. 1_000_000) { # code @@ -869,7 +869,7 @@ PP(pp_predec) djSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) croak(PL_no_modify); - if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) { --SvIVX(TOPs); @@ -887,7 +887,7 @@ PP(pp_postinc) if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) croak(PL_no_modify); sv_setsv(TARG, TOPs); - if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) { ++SvIVX(TOPs); @@ -908,7 +908,7 @@ PP(pp_postdec) if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) croak(PL_no_modify); sv_setsv(TARG, TOPs); - if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) { --SvIVX(TOPs); @@ -1003,8 +1003,8 @@ PP(pp_modulo) else { dleft = POPn; if (!use_double) { - use_double = 1; - dright = right; + use_double = 1; + dright = right; } left_neg = dleft < 0; if (left_neg) @@ -1015,16 +1015,16 @@ PP(pp_modulo) double dans; #if 1 - /* Tried: DOUBLESIZE <= UV_SIZE = Precision of UV more than of NV. - * But in fact this is an optimization - trunc may be slow */ - /* Somehow U_V is pessimized even if CASTFLAGS is 0 */ # if CASTFLAGS & 2 # define CAST_D2UV(d) U_V(d) # else # define CAST_D2UV(d) ((UV)(d)) # endif - + /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE, + * or, in other words, precision of UV more than of NV. + * But in fact the approach below turned out to be an + * optimization - floor() may be slow */ if (dright <= UV_MAX && dleft <= UV_MAX) { right = CAST_D2UV(dright); left = CAST_D2UV(dleft); @@ -1033,13 +1033,8 @@ PP(pp_modulo) #endif /* Backward-compatibility clause: */ -#if 0 - dright = trunc(dright + 0.5); - dleft = trunc(dleft + 0.5); -#else dright = floor(dright + 0.5); dleft = floor(dleft + 0.5); -#endif if (!dright) DIE("Illegal modulus zero"); @@ -41,6 +41,7 @@ static void save_lines _((AV *array, SV *sv)); static I32 sortcv _((SV *a, SV *b)); static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b))); static OP *doeval _((int gimme, OP** startop)); +static PerlIO *doopen _((const char *name, const char *mode)); static I32 sv_ncmp _((SV *a, SV *b)); static I32 sv_i_ncmp _((SV *a, SV *b)); static I32 amagic_ncmp _((SV *a, SV *b)); @@ -2771,6 +2772,35 @@ doeval(int gimme, OP** startop) RETURNOP(PL_eval_start); } +static PerlIO * +doopen(const char *name, const char *mode) +{ + STRLEN namelen = strlen(name); + PerlIO *fp; + + if (namelen > 3 && strcmp(name + namelen - 3, ".pm") == 0) { + SV *pmcsv = newSVpvf("%s%c", name, 'c'); + char *pmc = SvPV_nolen(pmcsv); + Stat_t pmstat; + Stat_t pmcstat; + if (PerlLIO_stat(pmc, &pmcstat) < 0) { + fp = PerlIO_open(name, mode); + } else { + if (PerlLIO_stat(name, &pmstat) < 0 || + pmstat.st_mtime < pmcstat.st_mtime) { + fp = PerlIO_open(pmc, mode); + } else { + fp = PerlIO_open(name, mode); + } + } + SvREFCNT_dec(pmcsv); + } else { + fp = PerlIO_open(name, mode); + } + + return fp; +} + PP(pp_require) { djSP; @@ -2821,7 +2851,7 @@ PP(pp_require) ) { tryname = name; - tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE); + tryrsfp = doopen(name,PERL_SCRIPT_MODE); } else { AV *ar = GvAVn(PL_incgv); @@ -2845,7 +2875,7 @@ PP(pp_require) #endif TAINT_PROPER("require"); tryname = SvPVX(namesv); - tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE); + tryrsfp = doopen(tryname, PERL_SCRIPT_MODE); if (tryrsfp) { if (tryname[0] == '.' && tryname[1] == '/') tryname += 2; @@ -204,19 +204,15 @@ PP(pp_readline) { tryAMAGICunTARGET(iter, 0); PL_last_in_gv = (GV*)(*PL_stack_sp--); - if (PL_op->op_flags & OPf_SPECIAL) { /* Are called as <$var> */ - if (SvROK(PL_last_in_gv)) { - if (SvTYPE(SvRV(PL_last_in_gv)) != SVt_PVGV) - goto hard_way; + if (SvTYPE(PL_last_in_gv) != SVt_PVGV) { + if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV) PL_last_in_gv = (GV*)SvRV(PL_last_in_gv); - } else if (SvTYPE(PL_last_in_gv) != SVt_PVGV) { - hard_way: { + else { dSP; XPUSHs((SV*)PL_last_in_gv); PUTBACK; pp_rv2gv(ARGS); PL_last_in_gv = (GV*)(*PL_stack_sp--); - } } } return do_readline(); @@ -237,7 +233,7 @@ PP(pp_preinc) djSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) croak(PL_no_modify); - if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) { ++SvIVX(TOPs); @@ -1236,9 +1232,15 @@ do_readline(void) sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */ sv_catsv(tmpcmd, tmpglob); #else +#ifdef CYGWIN32 + sv_setpv(tmpcmd, "for a in "); + sv_catsv(tmpcmd, tmpglob); + sv_catpv(tmpcmd, "; do echo -e \"$a\\0\\c\"; done |"); +#else sv_setpv(tmpcmd, "perlglob "); sv_catsv(tmpcmd, tmpglob); sv_catpv(tmpcmd, " |"); +#endif /* !CYGWIN */ #endif /* !DJGPP */ #endif /* !OS2 */ #else /* !DOSISH */ @@ -17,6 +17,11 @@ #include "EXTERN.h" #include "perl.h" +#ifdef HAS_GETSPENT +/* Shadow password support for solaris - pdo@cs.umd.edu*/ +#include <shadow.h> +#endif + /* XXX If this causes problems, set i_unistd=undef in the hint file. */ #ifdef I_UNISTD # include <unistd.h> @@ -3491,6 +3496,7 @@ PP(pp_fork) GV *tmpgv; EXTEND(SP, 1); + PERL_FLUSHALL_FOR_CHILD; childpid = fork(); if (childpid < 0) RETSETUNDEF; @@ -3509,7 +3515,7 @@ PP(pp_fork) PP(pp_wait) { -#if !defined(DOSISH) || defined(OS2) || defined(WIN32) +#if !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN32) djSP; dTARGET; Pid_t childpid; int argflags; @@ -3525,7 +3531,7 @@ PP(pp_wait) PP(pp_waitpid) { -#if !defined(DOSISH) || defined(OS2) || defined(WIN32) +#if !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN32) djSP; dTARGET; Pid_t childpid; int optype; @@ -3559,6 +3565,7 @@ PP(pp_system) TAINT_PROPER("system"); } } + PERL_FLUSHALL_FOR_CHILD; #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) while ((childpid = vfork()) == -1) { if (errno != EAGAIN) { @@ -3617,6 +3624,7 @@ PP(pp_exec) I32 value; STRLEN n_a; + PERL_FLUSHALL_FOR_CHILD; if (PL_op->op_flags & OPf_STACKED) { SV *really = *++MARK; value = (I32)do_aexec(really, MARK, SP); @@ -4545,6 +4553,9 @@ PP(pp_gpwent) register SV *sv; struct passwd *pwent; STRLEN n_a; +#ifdef HAS_GETSPENT + struct spwd *spwent; +#endif if (which == OP_GPWNAM) pwent = getpwnam(POPpx); @@ -4553,6 +4564,15 @@ PP(pp_gpwent) else pwent = (struct passwd *)getpwent(); +#ifdef HAS_GETSPENT + if (which == OP_GPWNAM) + spwent = getspnam(pwent->pw_name); + else if (which == OP_GPWUID) + spwent = getspnam(pwent->pw_name); + else + spwent = (struct spwd *)getspent(); +#endif + EXTEND(SP, 10); if (GIMME != G_ARRAY) { PUSHs(sv = sv_newmortal()); @@ -4571,8 +4591,15 @@ PP(pp_gpwent) PUSHs(sv = sv_mortalcopy(&PL_sv_no)); #ifdef PWPASSWD +#ifdef HAS_GETSPENT + if (spwent) + sv_setpv(sv, spwent->sp_pwdp); + else + sv_setpv(sv, pwent->pw_passwd); +#else sv_setpv(sv, pwent->pw_passwd); #endif +#endif PUSHs(sv = sv_mortalcopy(&PL_sv_no)); sv_setiv(sv, (IV)pwent->pw_uid); @@ -4635,6 +4662,9 @@ PP(pp_spwent) djSP; #if defined(HAS_PASSWD) && defined(HAS_SETPWENT) && !defined(CYGWIN32) setpwent(); +#ifdef HAS_GETSPENT + setspent(); +#endif RETPUSHYES; #else DIE(PL_no_func, "setpwent"); @@ -4646,6 +4676,9 @@ PP(pp_epwent) djSP; #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT) endpwent(); +#ifdef HAS_GETSPENT + endspent(); +#endif RETPUSHYES; #else DIE(PL_no_func, "endpwent"); @@ -99,6 +99,7 @@ VIRTUAL void do_chop _((SV* asv, SV* sv)); VIRTUAL bool do_close _((GV* gv, bool not_implicit)); VIRTUAL bool do_eof _((GV* gv)); VIRTUAL bool do_exec _((char* cmd)); +VIRTUAL bool do_exec3 _((char* cmd, int fd, int flag)); VIRTUAL void do_execfree _((void)); #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) I32 do_ipcctl _((I32 optype, SV** mark, SV** sp)); @@ -752,6 +753,7 @@ I32 dopoptosub _((I32 startingblock)); I32 dopoptosub_at _((PERL_CONTEXT* cxstk, I32 startingblock)); void save_lines _((AV *array, SV *sv)); OP *doeval _((int gimme, OP** startop)); +PerlIO *doopen _((const char *name, const char *mode)); I32 sv_ncmp _((SV *a, SV *b)); I32 sv_i_ncmp _((SV *a, SV *b)); I32 amagic_ncmp _((SV *a, SV *b)); @@ -2149,6 +2149,10 @@ regpposixcc(I32 value) PL_regcomp_parse++; /* skip over the ending ] */ posixcc = s + 1; } + else { + /* maternal grandfather */ + PL_regcomp_parse = s; + } } } @@ -2909,199 +2913,28 @@ regprop(SV *sv, regnode *o) { #ifdef DEBUGGING dTHR; - register char *p = 0; + register int k; sv_setpvn(sv, "", 0); - switch (OP(o)) { - case BOL: - p = "BOL"; - break; - case MBOL: - p = "MBOL"; - break; - case SBOL: - p = "SBOL"; - break; - case EOL: - p = "EOL"; - break; - case EOS: - p = "EOS"; - break; - case MEOL: - p = "MEOL"; - break; - case SEOL: - p = "SEOL"; - break; - case REG_ANY: - p = "ANY"; - break; - case SANY: - p = "SANY"; - break; - case ANYUTF8: - p = "ANYUTF8"; - break; - case SANYUTF8: - p = "SANYUTF8"; - break; - case ANYOFUTF8: - p = "ANYOFUTF8"; - break; - case ANYOF: - p = "ANYOF"; - break; - case BRANCH: - p = "BRANCH"; - break; - case EXACT: - sv_catpvf(sv, "EXACT <%s%s%s>", PL_colors[0], OPERAND(o) + 1, PL_colors[1]); - break; - case EXACTF: - sv_catpvf(sv, "EXACTF <%s%s%s>", PL_colors[0], OPERAND(o) + 1, PL_colors[1]); - break; - case EXACTFL: - sv_catpvf(sv, "EXACTFL <%s%s%s>", PL_colors[0], OPERAND(o) + 1, PL_colors[1]); - break; - case NOTHING: - p = "NOTHING"; - break; - case TAIL: - p = "TAIL"; - break; - case BACK: - p = "BACK"; - break; - case END: - p = "END"; - break; - case BOUND: - p = "BOUND"; - break; - case BOUNDL: - p = "BOUNDL"; - break; - case NBOUND: - p = "NBOUND"; - break; - case NBOUNDL: - p = "NBOUNDL"; - break; - case CURLY: - sv_catpvf(sv, "CURLY {%d,%d}", ARG1(o), ARG2(o)); - break; - case CURLYM: - sv_catpvf(sv, "CURLYM[%d] {%d,%d}", o->flags, ARG1(o), ARG2(o)); - break; - case CURLYN: - sv_catpvf(sv, "CURLYN[%d] {%d,%d}", o->flags, ARG1(o), ARG2(o)); - break; - case CURLYX: - sv_catpvf(sv, "CURLYX {%d,%d}", ARG1(o), ARG2(o)); - break; - case REF: - sv_catpvf(sv, "REF%d", ARG(o)); - break; - case REFF: - sv_catpvf(sv, "REFF%d", ARG(o)); - break; - case REFFL: - sv_catpvf(sv, "REFFL%d", ARG(o)); - break; - case OPEN: - sv_catpvf(sv, "OPEN%d", ARG(o)); - break; - case CLOSE: - sv_catpvf(sv, "CLOSE%d", ARG(o)); - p = NULL; - break; - case STAR: - p = "STAR"; - break; - case PLUS: - p = "PLUS"; - break; - case MINMOD: - p = "MINMOD"; - break; - case GPOS: - p = "GPOS"; - break; - case UNLESSM: - sv_catpvf(sv, "UNLESSM[-%d]", o->flags); - break; - case IFMATCH: - sv_catpvf(sv, "IFMATCH[-%d]", o->flags); - break; - case SUCCEED: - p = "SUCCEED"; - break; - case WHILEM: - p = "WHILEM"; - break; - case DIGIT: - p = "DIGIT"; - break; - case NDIGIT: - p = "NDIGIT"; - break; - case ALNUM: - p = "ALNUM"; - break; - case NALNUM: - p = "NALNUM"; - break; - case SPACE: - p = "SPACE"; - break; - case NSPACE: - p = "NSPACE"; - break; - case ALNUML: - p = "ALNUML"; - break; - case NALNUML: - p = "NALNUML"; - break; - case SPACEL: - p = "SPACEL"; - break; - case NSPACEL: - p = "NSPACEL"; - break; - case EVAL: - p = "EVAL"; - break; - case LONGJMP: - p = "LONGJMP"; - break; - case BRANCHJ: - p = "BRANCHJ"; - break; - case IFTHEN: - p = "IFTHEN"; - break; - case GROUPP: - sv_catpvf(sv, "GROUPP%d", ARG(o)); - break; - case LOGICAL: - sv_catpvf(sv, "LOGICAL[%d]", o->flags); - break; - case SUSPEND: - p = "SUSPEND"; - break; - case RENUM: - p = "RENUM"; - break; - case OPTIMIZED: - p = "OPTIMIZED"; - break; - default: + if (OP(o) >= reg_num) /* regnode.type is unsigned */ FAIL("corrupted regexp opcode"); + sv_catpv(sv, (char*)reg_name[OP(o)]); /* Take off const! */ + + k = PL_regkind[(U8)OP(o)]; + + if (k == EXACT) + sv_catpvf(sv, " <%s%s%s>", PL_colors[0], OPERAND(o) + 1, PL_colors[1]); + else if (k == CURLY) { + if (OP(o) == CURLYM || OP(o) == CURLYN) + sv_catpvf(sv, "[%d]", o->flags); /* Parenth number */ + sv_catpvf(sv, " {%d,%d}", ARG1(o), ARG2(o)); } - if (p) - sv_catpv(sv, p); + else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP ) + sv_catpvf(sv, "%d", ARG(o)); /* Parenth number */ + else if (k == LOGICAL) + sv_catpvf(sv, "[%d]", ARG(o)); /* 2: embedded, otherwise 1 */ + else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH)) + sv_catpvf(sv, "[-%d]", o->flags); #endif /* DEBUGGING */ } @@ -3203,7 +3036,12 @@ re_croak2(const char* pat1,const char* pat2,...) Copy(pat2, buf + l1, l2 , char); buf[l1 + l2] = '\n'; buf[l1 + l2 + 1] = '\0'; +#ifdef I_STDARG + /* ANSI variant takes additional second argument */ va_start(args, pat2); +#else + va_start(args); +#endif msv = mess(buf, &args); va_end(args); message = SvPV(msv,l1); diff --git a/regcomp.pl b/regcomp.pl index d78321895c..d7d0733010 100644 --- a/regcomp.pl +++ b/regcomp.pl @@ -21,7 +21,7 @@ open OUT, ">$tmp_h"; print OUT <<EOP; /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! - This file is built by regcomp.pl from regcomp.sym. + This file is built by regcomp.pl from regcomp.sym. Any changes made here will be lost! */ @@ -79,7 +79,7 @@ EOP $ind = 0; while (++$ind <= $tot) { $size = $longj[$ind] || 0; - + print OUT <<EOP; $size, /* $name[$ind] */ EOP @@ -87,6 +87,27 @@ EOP print OUT <<EOP; }; + +#ifdef DEBUGGING +const static char * const reg_name[] = { +EOP + +$ind = 0; +while (++$ind <= $tot) { + $hind = sprintf "%#4x", $ind-1; + $size = $longj[$ind] || 0; + + print OUT <<EOP; + "$name[$ind]", /* $hind */ +EOP +} + +print OUT <<EOP; +}; + +const static int reg_num = $tot; + +#endif /* DEBUGGING */ #endif /* REG_COMP_C */ EOP diff --git a/regnodes.h b/regnodes.h index 8e834eea59..030fa1a2c0 100644 --- a/regnodes.h +++ b/regnodes.h @@ -1,5 +1,5 @@ /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! - This file is built by regcomp.pl from regcomp.sym. + This file is built by regcomp.pl from regcomp.sym. Any changes made here will be lost! */ @@ -322,5 +322,89 @@ const static char reg_off_by_arg[] = { 1, /* RENUM */ 0, /* OPTIMIZED */ }; + +#ifdef DEBUGGING +const static char * const reg_name[] = { + "END", /* 0 */ + "SUCCEED", /* 0x1 */ + "BOL", /* 0x2 */ + "MBOL", /* 0x3 */ + "SBOL", /* 0x4 */ + "EOS", /* 0x5 */ + "EOL", /* 0x6 */ + "MEOL", /* 0x7 */ + "SEOL", /* 0x8 */ + "BOUND", /* 0x9 */ + "BOUNDUTF8", /* 0xa */ + "BOUNDL", /* 0xb */ + "BOUNDLUTF8", /* 0xc */ + "NBOUND", /* 0xd */ + "NBOUNDUTF8", /* 0xe */ + "NBOUNDL", /* 0xf */ + "NBOUNDLUTF8", /* 0x10 */ + "GPOS", /* 0x11 */ + "REG_ANY", /* 0x12 */ + "ANYUTF8", /* 0x13 */ + "SANY", /* 0x14 */ + "SANYUTF8", /* 0x15 */ + "ANYOF", /* 0x16 */ + "ANYOFUTF8", /* 0x17 */ + "ALNUM", /* 0x18 */ + "ALNUMUTF8", /* 0x19 */ + "ALNUML", /* 0x1a */ + "ALNUMLUTF8", /* 0x1b */ + "NALNUM", /* 0x1c */ + "NALNUMUTF8", /* 0x1d */ + "NALNUML", /* 0x1e */ + "NALNUMLUTF8", /* 0x1f */ + "SPACE", /* 0x20 */ + "SPACEUTF8", /* 0x21 */ + "SPACEL", /* 0x22 */ + "SPACELUTF8", /* 0x23 */ + "NSPACE", /* 0x24 */ + "NSPACEUTF8", /* 0x25 */ + "NSPACEL", /* 0x26 */ + "NSPACELUTF8", /* 0x27 */ + "DIGIT", /* 0x28 */ + "DIGITUTF8", /* 0x29 */ + "NDIGIT", /* 0x2a */ + "NDIGITUTF8", /* 0x2b */ + "CLUMP", /* 0x2c */ + "BRANCH", /* 0x2d */ + "BACK", /* 0x2e */ + "EXACT", /* 0x2f */ + "EXACTF", /* 0x30 */ + "EXACTFL", /* 0x31 */ + "NOTHING", /* 0x32 */ + "TAIL", /* 0x33 */ + "STAR", /* 0x34 */ + "PLUS", /* 0x35 */ + "CURLY", /* 0x36 */ + "CURLYN", /* 0x37 */ + "CURLYM", /* 0x38 */ + "CURLYX", /* 0x39 */ + "WHILEM", /* 0x3a */ + "OPEN", /* 0x3b */ + "CLOSE", /* 0x3c */ + "REF", /* 0x3d */ + "REFF", /* 0x3e */ + "REFFL", /* 0x3f */ + "IFMATCH", /* 0x40 */ + "UNLESSM", /* 0x41 */ + "SUSPEND", /* 0x42 */ + "IFTHEN", /* 0x43 */ + "GROUPP", /* 0x44 */ + "LONGJMP", /* 0x45 */ + "BRANCHJ", /* 0x46 */ + "EVAL", /* 0x47 */ + "MINMOD", /* 0x48 */ + "LOGICAL", /* 0x49 */ + "RENUM", /* 0x4a */ + "OPTIMIZED", /* 0x4b */ +}; + +const static int reg_num = 76; + +#endif /* DEBUGGING */ #endif /* REG_COMP_C */ @@ -1034,10 +1034,9 @@ sv_setiv_mg(register SV *sv, IV i) void sv_setuv(register SV *sv, UV u) { - if (u <= IV_MAX) - sv_setiv(sv, u); - else - sv_setnv(sv, (double)u); + sv_setiv(sv, 0); + SvIsUV_on(sv); + SvUVX(sv) = u; } void @@ -1141,6 +1140,15 @@ not_a_number(SV *sv) warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf); } +/* the number can be converted to _integer_ with atol() */ +#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 */ + +/* Actually, ISO C leaves conversion of UV to IV undefined, but + until proven guilty, assume that things are not that bad... */ + IV sv_2iv(register SV *sv) { @@ -1151,10 +1159,7 @@ sv_2iv(register SV *sv) if (SvIOKp(sv)) return SvIVX(sv); if (SvNOKp(sv)) { - if (SvNVX(sv) < 0.0) - return I_V(SvNVX(sv)); - else - return (IV) U_V(SvNVX(sv)); + return I_V(SvNVX(sv)); } if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); @@ -1176,10 +1181,7 @@ sv_2iv(register SV *sv) } if (SvREADONLY(sv)) { if (SvNOKp(sv)) { - if (SvNVX(sv) < 0.0) - return I_V(SvNVX(sv)); - else - return (IV) U_V(SvNVX(sv)); + return I_V(SvNVX(sv)); } if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); @@ -1191,37 +1193,103 @@ sv_2iv(register SV *sv) return 0; } } - switch (SvTYPE(sv)) { - case SVt_NULL: - sv_upgrade(sv, SVt_IV); - break; - case SVt_PV: - sv_upgrade(sv, SVt_PVIV); - break; - case SVt_NV: - sv_upgrade(sv, SVt_PVNV); - break; + if (SvIOKp(sv)) { + if (SvIsUV(sv)) { + return (IV)(SvUVX(sv)); + } + else { + return SvIVX(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. XXXX 64-bit? + */ + + if (SvTYPE(sv) == SVt_NV) + sv_upgrade(sv, SVt_PVNV); + (void)SvIOK_on(sv); - if (SvNVX(sv) < 0.0) + if (SvNVX(sv) < (double)IV_MAX + 0.5) SvIVX(sv) = I_V(SvNVX(sv)); - else + else { SvUVX(sv) = U_V(SvNVX(sv)); + SvIsUV_on(sv); + ret_iv_max: + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%lx 2iv(%lu => %ld) (as unsigned)\n", + (unsigned long)sv, + (unsigned long)SvUVX(sv), (long)(IV)SvUVX(sv))); + return (IV)SvUVX(sv); + } } else if (SvPOKp(sv) && SvLEN(sv)) { - (void)SvIOK_on(sv); - SvIVX(sv) = asIV(sv); + I32 numtype = looks_like_number(sv); + + /* We want to avoid a possible problem when we cache an IV which + may be later translated to an NV, and the resulting NV is not + the translation of the initial data. + + This means that if we cache such an IV, we need to cache the + NV as well. Moreover, we trade speed for space, and do not + 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. */ + double d; + + SET_NUMERIC_STANDARD(); + 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); + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%lx 2nv(%g)\n",(unsigned long)sv, + SvNVX(sv))); + if (SvNVX(sv) < (double)IV_MAX + 0.5) + SvIVX(sv) = I_V(SvNVX(sv)); + else { + SvUVX(sv) = U_V(SvNVX(sv)); + SvIsUV_on(sv); + goto ret_iv_max; + } + } + else if (numtype) { + /* 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) = atol(SvPVX(sv)); /* XXXX 64-bit? */ + } + else { /* Not a number. Cache 0. */ + dTHR; + + if (SvTYPE(sv) < SVt_PVIV) + sv_upgrade(sv, SVt_PVIV); + SvIVX(sv) = 0; + (void)SvIOK_on(sv); + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } } else { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) warner(WARN_UNINITIALIZED, PL_warn_uninit); + if (SvTYPE(sv) < SVt_IV) + /* Typically the caller expects that sv_any is not NULL now. */ + sv_upgrade(sv, SVt_IV); return 0; } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n", (unsigned long)sv,(long)SvIVX(sv))); - return SvIVX(sv); + return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); } UV @@ -1267,24 +1335,105 @@ sv_2uv(register SV *sv) return 0; } } - switch (SvTYPE(sv)) { - case SVt_NULL: - sv_upgrade(sv, SVt_IV); - break; - case SVt_PV: - sv_upgrade(sv, SVt_PVIV); - break; - case SVt_NV: - sv_upgrade(sv, SVt_PVNV); - break; + if (SvIOKp(sv)) { + if (SvIsUV(sv)) { + return SvUVX(sv); + } + else { + return (UV)SvIVX(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. XXXX 64-bit? + */ + if (SvTYPE(sv) == SVt_NV) + sv_upgrade(sv, SVt_PVNV); (void)SvIOK_on(sv); - SvUVX(sv) = U_V(SvNVX(sv)); + if (SvNVX(sv) >= -0.5) { + SvIsUV_on(sv); + SvUVX(sv) = U_V(SvNVX(sv)); + } + else { + SvIVX(sv) = I_V(SvNVX(sv)); + ret_zero: + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%lx 2uv(%ld => %lu) (as signed)\n", + (unsigned long)sv,(long)SvIVX(sv), + (long)(UV)SvIVX(sv))); + return (UV)SvIVX(sv); + } } else if (SvPOKp(sv) && SvLEN(sv)) { - (void)SvIOK_on(sv); - SvUVX(sv) = asUV(sv); + I32 numtype = looks_like_number(sv); + + /* We want to avoid a possible problem when we cache a UV which + may be later translated to an NV, and the resulting NV is not + the translation of the initial data. + + This means that if we cache such a UV, we need to cache the + 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. */ + double d; + + SET_NUMERIC_STANDARD(); + d = atof(SvPVX(sv)); /* XXXX 64-bit? */ + + if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); + SvNVX(sv) = d; + (void)SvNOK_on(sv); + (void)SvIOK_on(sv); + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%lx 2nv(%g)\n",(unsigned long)sv, + SvNVX(sv))); + 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) { + /* 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)); /* XXXX 64-bit? */ + } + 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) + sv_upgrade(sv, SVt_PVIV); + (void)SvIOK_on(sv); + (void)SvIsUV_on(sv); +#ifdef HAS_STRTOUL + SvUVX(sv) = strtoul(SvPVX(sv), Null(char**), 10); /* XXXX 64-bit? */ +#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)); /* XXXX 64-bit? */ +#endif + } + else { /* Not a number. Cache 0. */ + dTHR; + + if (SvTYPE(sv) < SVt_PVIV) + sv_upgrade(sv, SVt_PVIV); + SvUVX(sv) = 0; /* We assume that 0s have the + same bitmap in IV and UV. */ + (void)SvIOK_on(sv); + (void)SvIsUV_on(sv); + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } } else { if (!(SvFLAGS(sv) & SVs_PADTMP)) { @@ -1292,11 +1441,15 @@ sv_2uv(register SV *sv) if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) warner(WARN_UNINITIALIZED, PL_warn_uninit); } + if (SvTYPE(sv) < SVt_IV) + /* Typically the caller expects that sv_any is not NULL now. */ + sv_upgrade(sv, SVt_IV); return 0; } + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n", (unsigned long)sv,SvUVX(sv))); - return SvUVX(sv); + return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv); } double @@ -1315,8 +1468,12 @@ sv_2nv(register SV *sv) SET_NUMERIC_STANDARD(); return atof(SvPVX(sv)); } - if (SvIOKp(sv)) - return (double)SvIVX(sv); + if (SvIOKp(sv)) { + if (SvIsUV(sv)) + return (double)SvUVX(sv); + else + return (double)SvIVX(sv); + } if (!SvROK(sv)) { if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; @@ -1341,8 +1498,12 @@ sv_2nv(register SV *sv) SET_NUMERIC_STANDARD(); return atof(SvPVX(sv)); } - if (SvIOKp(sv)) - return (double)SvIVX(sv); + if (SvIOKp(sv)) { + if (SvIsUV(sv)) + return (double)SvUVX(sv); + else + return (double)SvIVX(sv); + } if (ckWARN(WARN_UNINITIALIZED)) warner(WARN_UNINITIALIZED, PL_warn_uninit); return 0.0; @@ -1362,7 +1523,7 @@ sv_2nv(register SV *sv) if (SvIOKp(sv) && (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv))) { - SvNVX(sv) = (double)SvIVX(sv); + SvNVX(sv) = SvIsUV(sv) ? (double)SvUVX(sv) : (double)SvIVX(sv); } else if (SvPOKp(sv) && SvLEN(sv)) { dTHR; @@ -1375,6 +1536,9 @@ sv_2nv(register SV *sv) dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) warner(WARN_UNINITIALIZED, PL_warn_uninit); + if (SvTYPE(sv) < SVt_NV) + /* Typically the caller expects that sv_any is not NULL now. */ + sv_upgrade(sv, SVt_NV); return 0.0; } SvNOK_on(sv); @@ -1390,8 +1554,8 @@ asIV(SV *sv) I32 numtype = looks_like_number(sv); double d; - if (numtype == 1) - return atol(SvPVX(sv)); + if (numtype & IS_NUMBER_TO_INT_BY_ATOL) + return atol(SvPVX(sv)); /* XXXX 64-bit? */ if (!numtype) { dTHR; if (ckWARN(WARN_NUMERIC)) @@ -1399,10 +1563,7 @@ asIV(SV *sv) } SET_NUMERIC_STANDARD(); d = atof(SvPVX(sv)); - if (d < 0.0) - return I_V(d); - else - return (IV) U_V(d); + return I_V(d); } STATIC UV @@ -1411,7 +1572,7 @@ asUV(SV *sv) I32 numtype = looks_like_number(sv); #ifdef HAS_STRTOUL - if (numtype == 1) + if (numtype & IS_NUMBER_TO_INT_BY_ATOL) return strtoul(SvPVX(sv), Null(char**), 10); #endif if (!numtype) { @@ -1423,13 +1584,29 @@ asUV(SV *sv) return U_V(atof(SvPVX(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 + * 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 + * with a possible addition of IS_NUMBER_NEG. + */ + I32 looks_like_number(SV *sv) { + /* XXXX 64-bit? It may be not IS_NUMBER_TO_INT_BY_ATOL, but + * using atof() may lose precision. */ register char *s; register char *send; register char *sbegin; - I32 numtype; + register char *nbegin; + I32 numtype = 0; STRLEN len; if (SvPOK(sv)) { @@ -1445,22 +1622,40 @@ looks_like_number(SV *sv) s = sbegin; while (isSPACE(*s)) s++; - if (*s == '+' || *s == '-') + if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') s++; + nbegin = s; + /* + * we return 1 if the number can be converted to _integer_ with atol() + * and 2 if you need (int)atof(). + */ + /* next must be digit or '.' */ if (isDIGIT(*s)) { do { 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 + numtype |= IS_NUMBER_TO_INT_BY_ATOL; + if (*s == '.') { s++; + numtype |= IS_NUMBER_NOT_IV; while (isDIGIT(*s)) /* optional digits after "." */ s++; } } else if (*s == '.') { s++; + numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV; /* no digits before '.' means we need digits after it */ if (isDIGIT(*s)) { do { @@ -1473,15 +1668,10 @@ looks_like_number(SV *sv) else return 0; - /* - * we return 1 if the number can be converted to _integer_ with atol() - * and 2 if you need (int)atof(). - */ - numtype = 1; - /* we can have an optional exponent part */ if (*s == 'e' || *s == 'E') { - numtype = 2; + numtype &= ~IS_NUMBER_NEG; + numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV; s++; if (*s == '+' || *s == '-') s++; @@ -1498,7 +1688,7 @@ looks_like_number(SV *sv) if (s >= send) return numtype; if (len == 10 && memEQ(sbegin, "0 but true", 10)) - return 1; + return IS_NUMBER_TO_INT_BY_ATOL; return 0; } @@ -1509,13 +1699,42 @@ sv_2pv_nolen(register SV *sv) return sv_2pv(sv, &n_a); } +/* We assume that buf is at least TYPE_CHARS(UV) long. */ +STATIC char * +uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) +{ + STRLEN len; + char *ptr = buf + TYPE_CHARS(UV); + char *ebuf = ptr; + int sign; + char *p; + + if (is_uv) + sign = 0; + else if (iv >= 0) { + uv = iv; + sign = 0; + } else { + uv = -iv; + sign = 1; + } + do { + *--ptr = '0' + (uv % 10); + } while (uv /= 10); + if (sign) + *--ptr = '-'; + *peob = ebuf; + return ptr; +} + char * sv_2pv(register SV *sv, STRLEN *lp) { register char *s; int olderrno; SV *tsv; - char tmpbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ + char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ + char *tmpbuf = tbuf; if (!sv) { *lp = 0; @@ -1527,8 +1746,11 @@ sv_2pv(register SV *sv, STRLEN *lp) *lp = SvCUR(sv); return SvPVX(sv); } - if (SvIOKp(sv)) { - (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv)); + if (SvIOKp(sv)) { /* XXXX 64-bit? */ + if (SvIsUV(sv)) + (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv)); + else + (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv)); tsv = Nullsv; goto tokensave; } @@ -1627,6 +1849,7 @@ sv_2pv(register SV *sv, STRLEN *lp) sv_setpvf(tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); else sv_setpv(tsv, s); + /* XXXX 64-bit? */ sv_catpvf(tsv, "(0x%lx)", (unsigned long)sv); goto tokensaveref; } @@ -1634,14 +1857,21 @@ sv_2pv(register SV *sv, STRLEN *lp) return s; } if (SvREADONLY(sv)) { - if (SvNOKp(sv)) { + if (SvNOKp(sv)) { /* See note in sv_2uv() */ + /* XXXX 64-bit? IV may have better precision... */ SET_NUMERIC_STANDARD(); Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf); tsv = Nullsv; goto tokensave; } if (SvIOKp(sv)) { - (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv)); + char *ebuf; + + if (SvIsUV(sv)) + tmpbuf = uiv_2buf(tbuf, 0, SvUVX(sv), 1, &ebuf); + else + tmpbuf = uiv_2buf(tbuf, SvIVX(sv), 0, 0, &ebuf); + *ebuf = 0; tsv = Nullsv; goto tokensave; } @@ -1654,8 +1884,8 @@ sv_2pv(register SV *sv, STRLEN *lp) return ""; } } - (void)SvUPGRADE(sv, SVt_PV); - if (SvNOKp(sv)) { + if (SvNOKp(sv)) { /* See note in sv_2uv() */ + /* XXXX 64-bit? IV may have better precision... */ if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); SvGROW(sv, 28); @@ -1682,14 +1912,23 @@ sv_2pv(register SV *sv, STRLEN *lp) #endif } else if (SvIOKp(sv)) { - U32 oldIOK = SvIOK(sv); + U32 isIOK = SvIOK(sv); + char buf[TYPE_CHARS(UV)]; + char *ebuf, *ptr; + if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); - olderrno = errno; /* some Xenix systems wipe out errno here */ - sv_setpviv(sv, SvIVX(sv)); - errno = olderrno; + if (SvIsUV(sv)) { + ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf); + sv_setpvn(sv, ptr, ebuf - ptr); + SvIsUV_on(sv); + } + else { + ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf); + sv_setpvn(sv, ptr, ebuf - ptr); + } s = SvEND(sv); - if (oldIOK) + if (isIOK) SvIOK_on(sv); else SvIOKp_on(sv); @@ -1699,6 +1938,9 @@ sv_2pv(register SV *sv, STRLEN *lp) if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) warner(WARN_UNINITIALIZED, PL_warn_uninit); *lp = 0; + if (SvTYPE(sv) < SVt_PV) + /* Typically the caller expects that sv_any is not NULL now. */ + sv_upgrade(sv, SVt_PV); return ""; } *lp = s - SvPVX(sv); @@ -1834,6 +2076,8 @@ sv_setsv(SV *dstr, register SV *sstr) } (void)SvIOK_only(dstr); SvIVX(dstr) = SvIVX(sstr); + if (SvIsUV(sstr)) + SvIsUV_on(dstr); SvTAINT(dstr); return; } @@ -2061,7 +2305,8 @@ sv_setsv(SV *dstr, register SV *sstr) } if (SvPVX(dstr)) { (void)SvOOK_off(dstr); /* backoff */ - Safefree(SvPVX(dstr)); + if (SvLEN(dstr)) + Safefree(SvPVX(dstr)); SvLEN(dstr)=SvCUR(dstr)=0; } } @@ -2075,6 +2320,8 @@ sv_setsv(SV *dstr, register SV *sstr) if (sflags & SVp_IOK) { (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); + if (SvIsUV(sstr)) + SvIsUV_on(dstr); } if (SvAMAGIC(sstr)) { SvAMAGIC_on(dstr); @@ -2098,7 +2345,7 @@ sv_setsv(SV *dstr, register SV *sstr) SvFLAGS(dstr) &= ~SVf_OOK; Safefree(SvPVX(dstr) - SvIVX(dstr)); } - else + else if (SvLEN(dstr)) Safefree(SvPVX(dstr)); } (void)SvPOK_only(dstr); @@ -2129,6 +2376,8 @@ sv_setsv(SV *dstr, register SV *sstr) if (sflags & SVp_IOK) { (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); + if (SvIsUV(sstr)) + SvIsUV_on(dstr); } } else if (sflags & SVp_NOK) { @@ -2137,11 +2386,16 @@ sv_setsv(SV *dstr, register SV *sstr) if (SvIOK(sstr)) { (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); + /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ + if (SvIsUV(sstr)) + SvIsUV_on(dstr); } } else if (sflags & SVp_IOK) { (void)SvIOK_only(dstr); SvIVX(dstr) = SvIVX(sstr); + if (SvIsUV(sstr)) + SvIsUV_on(dstr); } else { if (dtype == SVt_PVGV) { @@ -2227,7 +2481,7 @@ sv_usepvn(register SV *sv, register char *ptr, register STRLEN len) return; } (void)SvOOK_off(sv); - if (SvPVX(sv)) + if (SvPVX(sv) && SvLEN(sv)) Safefree(SvPVX(sv)); Renew(ptr, len+1, char); SvPVX(sv) = ptr; @@ -2273,10 +2527,17 @@ sv_chop(register SV *sv, register char *ptr) /* like set but assuming ptr is in sv_upgrade(sv,SVt_PVIV); if (!SvOOK(sv)) { + if (!SvLEN(sv)) { /* make copy of shared string */ + char *pvx = SvPVX(sv); + STRLEN len = SvCUR(sv); + SvGROW(sv, len + 1); + Move(pvx,SvPVX(sv),len,char); + *SvEND(sv) = '\0'; + } SvIVX(sv) = 0; SvFLAGS(sv) |= SVf_OOK; } - SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK); + SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV); delta = ptr - SvPVX(sv); SvLEN(sv) -= delta; SvCUR(sv) -= delta; @@ -3444,11 +3705,19 @@ sv_inc(register SV *sv) return; } if (flags & SVp_IOK) { - if (SvIVX(sv) == IV_MAX) - sv_setnv(sv, (double)IV_MAX + 1.0); - else { - (void)SvIOK_only(sv); - ++SvIVX(sv); + if (SvIsUV(sv)) { + if (SvUVX(sv) == UV_MAX) + sv_setnv(sv, (double)UV_MAX + 1.0); + else + (void)SvIOK_only_UV(sv); + ++SvUVX(sv); + } else { + if (SvIVX(sv) == IV_MAX) + sv_setnv(sv, (double)IV_MAX + 1.0); + else { + (void)SvIOK_only(sv); + ++SvIVX(sv); + } } return; } @@ -3537,11 +3806,22 @@ sv_dec(register SV *sv) return; } if (flags & SVp_IOK) { - if (SvIVX(sv) == IV_MIN) - sv_setnv(sv, (double)IV_MIN - 1.0); - else { - (void)SvIOK_only(sv); - --SvIVX(sv); + if (SvIsUV(sv)) { + if (SvUVX(sv) == 0) { + (void)SvIOK_only(sv); + SvIVX(sv) = -1; + } + else { + (void)SvIOK_only_UV(sv); + --SvUVX(sv); + } + } else { + if (SvIVX(sv) == IV_MIN) + sv_setnv(sv, (double)IV_MIN - 1.0); + else { + (void)SvIOK_only(sv); + --SvIVX(sv); + } } return; } @@ -3911,16 +4191,22 @@ sv_true(register SV *sv) IV sv_iv(register SV *sv) { - if (SvIOK(sv)) + if (SvIOK(sv)) { + if (SvIsUV(sv)) + return (IV)SvUVX(sv); return SvIVX(sv); + } return sv_2iv(sv); } UV sv_uv(register SV *sv) { - if (SvIOK(sv)) - return SvUVX(sv); + if (SvIOK(sv)) { + if (SvIsUV(sv)) + return SvUVX(sv); + return (UV)SvIVX(sv); + } return sv_2uv(sv); } @@ -4205,41 +4491,22 @@ sv_tainted(SV *sv) void sv_setpviv(SV *sv, IV iv) { - STRLEN len; - char buf[TYPE_DIGITS(UV)]; - char *ptr = buf + sizeof(buf); - int sign; - UV uv; - char *p; + char buf[TYPE_CHARS(UV)]; + char *ebuf; + char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); - sv_setpvn(sv, "", 0); - if (iv >= 0) { - uv = iv; - sign = 0; - } else { - uv = -iv; - sign = 1; - } - do { - *--ptr = '0' + (uv % 10); - } while (uv /= 10); - len = (buf + sizeof(buf)) - ptr; - /* taking advantage of SvCUR(sv) == 0 */ - SvGROW(sv, sign + len + 1); - p = SvPVX(sv); - if (sign) - *p++ = '-'; - memcpy(p, ptr, len); - p += len; - *p = '\0'; - SvCUR(sv) = p - SvPVX(sv); + sv_setpvn(sv, ptr, ebuf - ptr); } void sv_setpviv_mg(SV *sv, IV iv) { - sv_setpviv(sv,iv); + char buf[TYPE_CHARS(UV)]; + char *ebuf; + char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); + + sv_setpvn(sv, ptr, ebuf - ptr); SvSETMAGIC(sv); } @@ -153,11 +153,15 @@ struct io { /* Some private flags. */ -#define SVpfm_COMPILED 0x80000000 +#define SVf_IVisUV 0x80000000 /* use XPVUV instead of XPVIV */ + +#define SVpfm_COMPILED 0x80000000 /* FORMLINE is compiled */ #define SVpbm_VALID 0x80000000 #define SVpbm_TAIL 0x40000000 +#define SVrepl_EVAL 0x40000000 /* Replacement part of s///e */ + #define SVphv_SHAREKEYS 0x20000000 /* keys live on shared string table */ #define SVphv_LAZYDEL 0x40000000 /* entry in xhv_eiter must be deleted */ @@ -320,10 +324,13 @@ struct xpvio { #define SvNIOK(sv) (SvFLAGS(sv) & (SVf_IOK|SVf_NOK)) #define SvNIOKp(sv) (SvFLAGS(sv) & (SVp_IOK|SVp_NOK)) #define SvNIOK_off(sv) (SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK| \ - SVp_IOK|SVp_NOK)) + SVp_IOK|SVp_NOK|SVf_IVisUV)) #define SvOK(sv) (SvFLAGS(sv) & SVf_OK) -#define SvOK_off(sv) (SvFLAGS(sv) &= ~(SVf_OK|SVf_AMAGIC), \ +#define SvOK_off(sv) (SvFLAGS(sv) &= ~(SVf_OK|SVf_AMAGIC| \ + SVf_IVisUV), \ + SvOOK_off(sv)) +#define SvOK_off_exc_UV(sv) (SvFLAGS(sv) &= ~(SVf_OK|SVf_AMAGIC), \ SvOOK_off(sv)) #define SvOKp(sv) (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) @@ -337,9 +344,20 @@ struct xpvio { #define SvIOK(sv) (SvFLAGS(sv) & SVf_IOK) #define SvIOK_on(sv) (SvOOK_off(sv), \ SvFLAGS(sv) |= (SVf_IOK|SVp_IOK)) -#define SvIOK_off(sv) (SvFLAGS(sv) &= ~(SVf_IOK|SVp_IOK)) +#define SvIOK_off(sv) (SvFLAGS(sv) &= ~(SVf_IOK|SVp_IOK|SVf_IVisUV)) #define SvIOK_only(sv) (SvOK_off(sv), \ SvFLAGS(sv) |= (SVf_IOK|SVp_IOK)) +#define SvIOK_only_UV(sv) (SvOK_off_exc_UV(sv), \ + SvFLAGS(sv) |= (SVf_IOK|SVp_IOK)) + +#define SvIOK_UV(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) \ + == (SVf_IOK|SVf_IVisUV)) +#define SvIOK_notUV(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) \ + == SVf_IOK) + +#define SvIsUV(sv) (SvFLAGS(sv) & SVf_IVisUV) +#define SvIsUV_on(sv) (SvFLAGS(sv) |= SVf_IVisUV) +#define SvIsUV_off(sv) (SvFLAGS(sv) &= ~SVf_IVisUV) #define SvNOK(sv) (SvFLAGS(sv) & SVf_NOK) #define SvNOK_on(sv) (SvFLAGS(sv) |= (SVf_NOK|SVp_NOK)) @@ -350,7 +368,7 @@ struct xpvio { #define SvPOK(sv) (SvFLAGS(sv) & SVf_POK) #define SvPOK_on(sv) (SvFLAGS(sv) |= (SVf_POK|SVp_POK)) #define SvPOK_off(sv) (SvFLAGS(sv) &= ~(SVf_POK|SVp_POK)) -#define SvPOK_only(sv) (SvFLAGS(sv) &= ~(SVf_OK|SVf_AMAGIC), \ +#define SvPOK_only(sv) (SvFLAGS(sv) &= ~(SVf_OK|SVf_AMAGIC|SVf_IVisUV), \ SvFLAGS(sv) |= (SVf_POK|SVp_POK)) #define SvOOK(sv) (SvFLAGS(sv) & SVf_OOK) @@ -423,6 +441,10 @@ struct xpvio { #define SvCOMPILED_on(sv) (SvFLAGS(sv) |= SVpfm_COMPILED) #define SvCOMPILED_off(sv) (SvFLAGS(sv) &= ~SVpfm_COMPILED) +#define SvEVALED(sv) (SvFLAGS(sv) & SVrepl_EVAL) +#define SvEVALED_on(sv) (SvFLAGS(sv) |= SVrepl_EVAL) +#define SvEVALED_off(sv) (SvFLAGS(sv) &= ~SVrepl_EVAL) + #define SvTAIL(sv) (SvFLAGS(sv) & SVpbm_TAIL) #define SvTAIL_on(sv) (SvFLAGS(sv) |= SVpbm_TAIL) #define SvTAIL_off(sv) (SvFLAGS(sv) &= ~SVpbm_TAIL) @@ -522,12 +544,13 @@ struct xpvio { #define SvIV(sv) SvIVx(sv) #define SvNV(sv) SvNVx(sv) -#define SvUV(sv) SvIVx(sv) +#define SvUV(sv) SvUVx(sv) #define SvTRUE(sv) SvTRUEx(sv) #ifndef CRIPPLED_CC /* redefine some things to more efficient inlined versions */ +/* Let us hope that bitmaps for UV and IV are the same */ #undef SvIV #define SvIV(sv) (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) @@ -19,15 +19,43 @@ $Test::Harness::verbose = shift if @ARGV && $ARGV[0] eq '-v'; @tests = <base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t lib/*.t> unless @tests; Test::Harness::runtests @tests; - -%infinite = ('comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); +exit(0) unless -e "../testcompile"; + +%infinite = qw( + op/bop.t 1 + lib/hostname.t 1 + ); +#fudge DATA for now. +%datahandle = qw( + lib/bigint.t 1 + lib/bigintpm.t 1 + lib/bigfloat.t 1 + lib/bigfloatpm.t 1 + ); + +my $dhwrapper = <<'EOT'; +open DATA,"<".__FILE__; +until (($_=<DATA>) =~ /^__END__/) {}; +EOT @tests = grep (!$infinite{$_}, @tests); - -if (-e "../testcompile") -{ - print "The tests ", join(' ', keys(%infinite)), - " generate infinite loops! Skipping!\n"; - - $ENV{'COMPILE_TEST'} = 1; Test::Harness::runtests @tests; +@tests = map { + my $new = $_; + if ($datahandle{$_}) { + $new .= '.t'; + local(*F, *T); + open(F,"<$_") or die "Can't open $_: $!"; + open(T,">$new") or die "Can't open $new: $!"; + print T $dhwrapper, <F>; + close F; + close T; + } + $new; + } @tests; + +print "The tests ", join(' ', keys(%infinite)), + " generate infinite loops! Skipping!\n"; +$ENV{'COMPILE_TEST'} = 1; Test::Harness::runtests @tests; +foreach (keys %datahandle) { + unlink "$_.t"; } @@ -10,7 +10,7 @@ BEGIN { use Config; $Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or - $^O eq 'os2' or $^O eq 'mint'); + $^O eq 'os2' or $^O eq 'mint' or $^O =~ /cygwin/); print "1..28\n"; diff --git a/t/io/tell.t b/t/io/tell.t index afcfcb5800..8df0228c31 100755 --- a/t/io/tell.t +++ b/t/io/tell.t @@ -6,8 +6,11 @@ print "1..21\n"; $TST = 'tst'; +$Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or + $^O eq 'os2' or $^O eq 'mint' or $^O =~ /cygwin/); + open($TST, '../Configure') || (die "Can't open ../Configure"); -binmode $TST if $^O eq 'MSWin32'; +binmode $TST if $Is_Dosish; if (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; } $firstline = <$TST>; diff --git a/t/lib/anydbm.t b/t/lib/anydbm.t index 4d33e2233a..a38b5f680e 100755 --- a/t/lib/anydbm.t +++ b/t/lib/anydbm.t @@ -12,6 +12,9 @@ use Fcntl; print "1..12\n"; +$Is_Dosish = ($^O eq 'amigaos' || $^O eq 'MSWin32' or $^O eq 'dos' or + $^O eq 'os2' or $^O eq 'mint' or $^O =~ /cygwin/); + unlink <Op_dbmx*>; umask(0); @@ -22,7 +25,7 @@ $Dfile = "Op_dbmx.pag"; if (! -e $Dfile) { ($Dfile) = <Op_dbmx*>; } -if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') { +if ($Is_Dosish) { print "ok 2 # Skipped: different file permission semantics\n"; } else { diff --git a/t/lib/io_linenum.t b/t/lib/io_linenum.t new file mode 100755 index 0000000000..0d28e1898c --- /dev/null +++ b/t/lib/io_linenum.t @@ -0,0 +1,69 @@ +#!./perl + +# test added 29th April 1998 by Paul Johnson (pjcj@transeda.com) + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; +} + +use strict; +use IO::File; +use Test; + +BEGIN { + plan tests => 9 #, todo => [10] +} + +sub lineno +{ + my ($f) = @_; + my $l; + $l .= "$. "; + $l .= $f->input_line_number; + $l .= " $."; + $l; +} + +sub OK +{ + my $s = select STDOUT; # work around a bug in Test.pm 1.04 + &ok; + select $s; +} + +my $t; + +open (Q, __FILE__) or die $!; +my $w = IO::File->new(__FILE__) or die $!; + +<Q> for (1 .. 10); +OK(lineno($w), "10 0 10"); + +$w->getline for (1 .. 5); +OK(lineno($w), "5 5 5"); + +<Q>; +OK(lineno($w), "11 5 11"); + +$w->getline; +OK(lineno($w), "6 6 6"); + +$t = tell Q; # tell Q; provokes a warning - the world is full of bugs... +OK(lineno($w), "11 6 11"); + +<Q>; +OK(lineno($w), "12 6 12"); + +select Q; +OK(lineno($w), "12 6 12"); + +<Q> for (1 .. 10); +OK(lineno($w), "22 6 22"); + +$w->getline for (1 .. 5); +OK(lineno($w), "11 11 11"); +__END__ +# This test doesn't work. It probably won't until local $. does. +$t = tell Q; +OK(lineno($w), "22 11 22", 'waiting for local $.'); diff --git a/t/lib/odbm.t b/t/lib/odbm.t index c5458d5e19..0ef2592c93 100755 --- a/t/lib/odbm.t +++ b/t/lib/odbm.t @@ -215,6 +215,8 @@ EOM sub checkOutput { my($fk, $sk, $fv, $sv) = @_ ; + print "# ", join('|', $fetch_key, $fk, $store_key, $sk, + $fetch_value, $fv, $store_value, $sv, $_), "\n"; return $fetch_key eq $fk && $store_key eq $sk && $fetch_value eq $fv && $store_value eq $sv && diff --git a/t/lib/tie-stdhandle.t b/t/lib/tie-stdhandle.t index c74669a5b3..cb8303d94d 100755 --- a/t/lib/tie-stdhandle.t +++ b/t/lib/tie-stdhandle.t @@ -10,7 +10,7 @@ tie *tst,Tie::StdHandle; $f = 'tst'; -print "1..12\n"; +print "1..13\n"; # my $file tests diff --git a/t/op/filetest.t b/t/op/filetest.t index 9228b5730b..1e095be7e1 100644 --- a/t/op/filetest.t +++ b/t/op/filetest.t @@ -5,8 +5,10 @@ BEGIN { chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; } +use Config; print "1..10\n"; print "not " unless -d 'op'; @@ -50,8 +52,12 @@ eval '$> = $oldeuid'; # switch uid back (may not be implemented) # this would fail for the euid 1 # (unless we have unpacked the source code as uid 1...) -print "not " unless -w 'op'; -print "ok 8\n"; +if ($Config{d_seteuid}) { + print "not " unless -w 'op'; + print "ok 8\n"; +} else { + print "ok 8 #skipped, no seteuid\n"; +} print "not " unless -x 'op'; # Hohum. Are directories -x everywhere? print "ok 9\n"; diff --git a/t/op/magic.t b/t/op/magic.t index 9b819a8d7b..8486512b35 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -120,8 +120,9 @@ ok 18, $$ > 0, $$; $script = "$wd/show-shebang"; if ($Is_MSWin32) { chomp($wd = `cd`); - $perl = "$wd\\perl.exe"; - $script = "$wd\\show-shebang.bat"; + $wd =~ s|\\|/|g; + $perl = "$wd/perl.exe"; + $script = "$wd/show-shebang.bat"; $headmaybe = <<EOH ; \@rem =' \@echo off diff --git a/t/op/numconvert.t b/t/op/numconvert.t new file mode 100755 index 0000000000..405f721d20 --- /dev/null +++ b/t/op/numconvert.t @@ -0,0 +1,193 @@ +#!./perl + +# +# test the conversion operators +# +# Notations: +# +# "N p i N vs N N": Apply op-N, then op-p, then op-i, then reporter-N +# Compare with application of op-N, then reporter-N +# Right below are descriptions of different ops and reporters. + +# We do not use these subroutines any more, sub overhead makes a "switch" +# solution better: + +# obviously, 0, 1 and 2, 3 are destructive. (XXXX 64-bit? 4 destructive too) + +# *0 = sub {--$_[0]}; # - +# *1 = sub {++$_[0]}; # + + +# # Converters +# *2 = sub { $_[0] = $max_uv & $_[0]}; # U +# *3 = sub { use integer; $_[0] += $zero}; # I +# *4 = sub { $_[0] += $zero}; # N +# *5 = sub { $_[0] = "$_[0]" }; # P + +# # Side effects +# *6 = sub { $max_uv & $_[0]}; # u +# *7 = sub { use integer; $_[0] + $zero}; # i +# *8 = sub { $_[0] + $zero}; # n +# *9 = sub { $_[0] . "" }; # p + +# # Reporters +# sub a2 { sprintf "%u", $_[0] } # U +# sub a3 { sprintf "%d", $_[0] } # I +# sub a4 { sprintf "%g", $_[0] } # N +# sub a5 { "$_[0]" } # P + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use strict 'vars'; + +my $max_chain = $ENV{PERL_TEST_NUMCONVERTS}; +unless (defined $max_chain) { + my $is_debug; + eval <<'EOE'; + use Config; + $is_debug = 1 if $Config{ccflags} =~ /-DDEBUGGING\b/; +EOE + $max_chain = $is_debug ? 3 : 2; +} + +# Bulk out if unsigned type is hopelessly wrong: +my $max_uv1 = ~0; +my $max_uv2 = sprintf "%u", $max_uv1 ** 6; # 6 is an arbitrary number here +my $big_iv = do {use integer; $max_uv1 * 16}; # 16 is an arbitrary number here + +if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1) { + print "1..0\n# Unsigned arithmetic is not sane\n"; + exit 0; +} + +my $st_t = 4*4; # We try 4 initializers and 4 reporters + +my $num = 0; +$num += 10**$_ - 4**$_ for 1.. $max_chain; +$num *= $st_t; +print "1..$num\n"; # In fact 15 times more subsubtests... + +my $max_uv = ~0; +my $max_iv = int($max_uv/2); +my $zero = 0; + +my $l_uv = length $max_uv; +my $l_iv = length $max_iv; + +# Hope: the first digits are good +my $larger_than_uv = substr 97 x 100, 0, $l_uv; +my $smaller_than_iv = substr 12 x 100, 0, $l_iv; +my $yet_smaller_than_iv = substr 97 x 100, 0, ($l_iv - 1); + +my @list = (1, $yet_smaller_than_iv, $smaller_than_iv, $max_iv, $max_iv + 1, + $max_uv, $max_uv + 1); +unshift @list, (reverse map -$_, @list), 0; # 15 elts +@list = map "$_", @list; # Normalize + +# print "@list\n"; + + +my @opnames = split //, "-+UINPuinp"; + +# @list = map { 2->($_), 3->($_), 4->($_), 5->($_), } @list; # Prepare input + +#print "@list\n"; +#print "'@ops'\n"; + +my $test = 1; +my $nok; +for my $num_chain (1..$max_chain) { + my @ops = map [split //], grep /[4-9]/, + map { sprintf "%0${num_chain}d", $_ } 0 .. 10**$num_chain - 1; + + #@ops = ([]) unless $num_chain; + #@ops = ([6, 4]); + + # print "'@ops'\n"; + for my $op (@ops) { + for my $first (2..5) { + for my $last (2..5) { + $nok = 0; + my @otherops = grep $_ <= 3, @$op; + my @curops = ($op,\@otherops); + + for my $num (@list) { + my $inpt; + my @ans; + + for my $short (0, 1) { + # undef $inpt; # Forget all we had - some bugs were masked + + $inpt = $num; # Try to not contaminate $num... + $inpt = "$inpt"; + if ($first == 2) { + $inpt = $max_uv & $inpt; # U 2 + } elsif ($first == 3) { + use integer; $inpt += $zero; # I 3 + } elsif ($first == 4) { + $inpt += $zero; # N 4 + } else { + $inpt = "$inpt"; # P 5 + } + + # Saves 20% of time - not with this logic: + #my $tmp = $inpt; + #my $tmp1 = $num; + #next if $num_chain > 1 + # and "$tmp" ne "$tmp1"; # Already the coercion gives problems... + + for my $curop (@{$curops[$short]}) { + if ($curop < 5) { + if ($curop < 3) { + if ($curop == 0) { + --$inpt; # - 0 + } elsif ($curop == 1) { + ++$inpt; # + 1 + } else { + $inpt = $max_uv & $inpt; # U 2 + } + } elsif ($curop == 3) { + use integer; $inpt += $zero; + } else { + $inpt += $zero; # N 4 + } + } elsif ($curop < 8) { + if ($curop == 5) { + $inpt = "$inpt"; # P 5 + } elsif ($curop == 6) { + $max_uv & $inpt; # u 6 + } else { + use integer; $inpt + $zero; + } + } elsif ($curop == 8) { + $inpt + $zero; # n 8 + } else { + $inpt . ""; # p 9 + } + } + + if ($last == 2) { + $inpt = sprintf "%u", $inpt; # U 2 + } elsif ($last == 3) { + $inpt = sprintf "%d", $inpt; # I 3 + } elsif ($last == 4) { + $inpt = sprintf "%g", $inpt; # N 4 + } else { + $inpt = "$inpt"; # P 5 + } + 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]; + } + print "not " if $nok; + print "ok $test\n"; + #print $txt if $nok; + $test++; + } + } + } +} diff --git a/t/op/re_tests b/t/op/re_tests index 5abe217b05..ba824aeefa 100644 --- a/t/op/re_tests +++ b/t/op/re_tests @@ -475,6 +475,7 @@ $(?<=^(a)) a y $1 a ([[.]+) a.[b]. y $1 .[ [a[:xyz: - c - /[a[:xyz:/: unmatched [] in regexp [a[:xyz:] - c - /[a[:xyz:]/: unmatched [] in regexp +[a[:]b[:c] abc y $& abc ([a[:xyz:]b]+) pbaq y $1 ba ((?>a+)b) aaab y $1 aaab (?>(a+))b aaab y $1 aaa diff --git a/t/op/stat.t b/t/op/stat.t index 6f2d00b7e6..ae627f6070 100755 --- a/t/op/stat.t +++ b/t/op/stat.t @@ -13,7 +13,7 @@ print "1..58\n"; $Is_MSWin32 = $^O eq 'MSWin32'; $Is_Dos = $^O eq 'dos'; -$Is_Dosish = $Is_Dos || $^O eq 'os2' || $Is_MSWin32; +$Is_Dosish = $Is_Dos || $^O eq 'os2' || $Is_MSWin32 || $^O =~ /cygwin/; chop($cwd = ($Is_MSWin32 ? `cd` : `pwd`)); $DEV = `ls -l /dev` unless $Is_Dosish; @@ -93,6 +93,9 @@ foreach ((12,13,14,15,16,17)) { print "ok $_\n"; #deleted tests } +# in ms windows, Op.stat.tmp inherits owner uid from directory +# not sure about os/2, but chown is harmless anyway +chown $>,'Op.stat.tmp'; chmod 0700,'Op.stat.tmp'; if (-r 'Op.stat.tmp') {print "ok 18\n";} else {print "not ok 18\n";} if (-w 'Op.stat.tmp') {print "ok 19\n";} else {print "not ok 19\n";} diff --git a/t/op/taint.t b/t/op/taint.t index d75bc1807a..fdd1c79b83 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -19,6 +19,13 @@ use Config; # just because Errno possibly failing. eval { require Errno; import Errno }; +BEGIN { + if ($^O eq 'VMS' && !defined($Config{d_setenv})) { + $ENV{PATH} = $ENV{PATH}; + $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy'; + } +} + my $Is_VMS = $^O eq 'VMS'; my $Is_MSWin32 = $^O eq 'MSWin32'; my $Is_Dos = $^O eq 'dos'; @@ -33,7 +40,7 @@ if ($Is_VMS) { } eval <<EndOfCleanup; END { - \$ENV{PATH} = ''; + \$ENV{PATH} = '' if $Config{d_setenv}; warn "# Note: logical name 'PATH' may have been deleted\n"; \@ENV{keys %old} = values %old; } diff --git a/t/pragma/warn/doio b/t/pragma/warn/doio index cd0d55831a..97f0804bfa 100644 --- a/t/pragma/warn/doio +++ b/t/pragma/warn/doio @@ -44,7 +44,8 @@ __END__ # doio.c use warning 'io' ; -open(F, "|$^X -e 1|") +open(F, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|"); +close(F); EXPECT Can't do bidirectional pipe at - line 3. ######## @@ -111,4 +112,4 @@ use warning 'io' ; exec "lskdjfalksdjfdjfkls", "abc" ; EXPECT OPTION regex -Can't exec "lskdjfalksdjfdjfkls": .+ +Can't exec "lskdjfalksdjfdjfkls(:? abc)?": .+ diff --git a/t/pragma/warn/mg b/t/pragma/warn/mg index 44e7634952..14307e0de0 100644 --- a/t/pragma/warn/mg +++ b/t/pragma/warn/mg @@ -16,8 +16,8 @@ No such signal: SIGFRED at - line 3. ######## # mg.c use warning 'signal' ; -if ($^O eq 'MSWin32') { - print "SKIPPED\n# win32, can't kill() to raise()\n"; exit; +if ($^O eq 'MSWin32' || $^O eq 'VMS') { + print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit; } $|=1; $SIG{"INT"} = "fred"; kill "INT",$$; diff --git a/t/pragma/warn/pp_sys b/t/pragma/warn/pp_sys index 7588827744..8f2c255bc3 100644 --- a/t/pragma/warn/pp_sys +++ b/t/pragma/warn/pp_sys @@ -113,7 +113,7 @@ ghi . $= = 1 ; $- =1 ; -open STDOUT, ">/dev/null" ; +open STDOUT, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ; write ; EXPECT page overflow at - line 13. diff --git a/t/pragma/warn/sv b/t/pragma/warn/sv index 0f1d83c2e5..f453de96d3 100644 --- a/t/pragma/warn/sv +++ b/t/pragma/warn/sv @@ -181,7 +181,7 @@ Subroutine fred redefined at - line 5. ######## # sv.c use warning 'printf' ; -open F, ">/dev/null" ; +open F, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ; printf F "%q\n" ; my $a = sprintf "%q" ; printf F "%" ; @@ -823,7 +823,7 @@ sublex_done(void) PL_lex_casemods = 0; *PL_lex_casestack = '\0'; PL_lex_starts = 0; - if (SvCOMPILED(PL_lex_repl)) { + if (SvEVALED(PL_lex_repl)) { PL_lex_state = LEX_INTERPNORMAL; PL_lex_starts++; /* we don't clear PL_lex_repl here, so that we can check later @@ -1854,7 +1854,7 @@ int yylex(PERL_YYLEX_PARAM_DECL) return ')'; } if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl - && SvCOMPILED(PL_lex_repl)) + && SvEVALED(PL_lex_repl)) { if (PL_bufptr != PL_bufend) croak("Bad evalled substitution pattern"); @@ -2723,6 +2723,7 @@ int yylex(PERL_YYLEX_PARAM_DECL) } d = s; + tmp = (I32)*s; if (PL_lex_state == LEX_NORMAL) s = skipspace(s); @@ -2764,7 +2765,7 @@ int yylex(PERL_YYLEX_PARAM_DECL) } PL_expect = XOPERATOR; - if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) { + if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) { bool islop = (PL_last_lop == PL_oldoldbufptr); if (!islop || PL_last_lop_op == OP_GREPSTART) PL_expect = XOPERATOR; @@ -5362,7 +5363,7 @@ scan_subst(char *start) sv_catpvn(repl, "{ ", 2); sv_catsv(repl, PL_lex_repl); sv_catpvn(repl, " };", 2); - SvCOMPILED_on(repl); + SvEVALED_on(repl); SvREFCNT_dec(PL_lex_repl); PL_lex_repl = repl; } @@ -1910,7 +1910,10 @@ my_popen(char *cmd, char *mode) register I32 pid; SV *sv; I32 doexec = strNE(cmd,"-"); + I32 did_pipes = 0; + int pp[2]; + PERL_FLUSHALL_FOR_CHILD; #ifdef OS2 if (doexec) { return my_syspopen(cmd,mode); @@ -1924,9 +1927,15 @@ my_popen(char *cmd, char *mode) } if (PerlProc_pipe(p) < 0) return Nullfp; + if (doexec && PerlProc_pipe(pp) >= 0) + did_pipes = 1; while ((pid = (doexec?vfork():fork())) < 0) { if (errno != EAGAIN) { PerlLIO_close(p[This]); + if (did_pipes) { + PerlLIO_close(pp[0]); + PerlLIO_close(pp[1]); + } if (!doexec) croak("Can't fork"); return Nullfp; @@ -1941,6 +1950,12 @@ my_popen(char *cmd, char *mode) #define THIS that #define THAT This PerlLIO_close(p[THAT]); + if (did_pipes) { + PerlLIO_close(pp[0]); +#if defined(HAS_FCNTL) && defined(F_SETFD) + fcntl(pp[1], F_SETFD, FD_CLOEXEC); +#endif + } if (p[THIS] != (*mode == 'r')) { PerlLIO_dup2(p[THIS], *mode == 'r'); PerlLIO_close(p[THIS]); @@ -1953,9 +1968,10 @@ my_popen(char *cmd, char *mode) #define NOFILE 20 #endif for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) - PerlLIO_close(fd); + if (fd != pp[1]) + PerlLIO_close(fd); #endif - do_exec(cmd); /* may or may not use the shell */ + do_exec3(cmd,pp[1],did_pipes); /* may or may not use the shell */ PerlProc__exit(1); } /*SUPPRESS 560*/ @@ -1969,6 +1985,8 @@ my_popen(char *cmd, char *mode) } do_execfree(); /* free any memory malloced by child on vfork */ PerlLIO_close(p[that]); + if (did_pipes) + PerlLIO_close(pp[1]); if (p[that] < p[This]) { PerlLIO_dup2(p[This], p[that]); PerlLIO_close(p[This]); @@ -1978,18 +1996,39 @@ my_popen(char *cmd, char *mode) (void)SvUPGRADE(sv,SVt_IV); SvIVX(sv) = pid; PL_forkprocess = pid; + if (did_pipes && pid > 0) { + int errkid; + int n = 0, n1; + + while (n < sizeof(int)) { + n1 = PerlLIO_read(pp[0], + (void*)(((char*)&errkid)+n), + (sizeof(int)) - n); + if (n1 <= 0) + break; + n += n1; + } + if (n) { /* Error */ + if (n != sizeof(int)) + croak("panic: kid popen errno read"); + PerlLIO_close(pp[0]); + errno = errkid; /* Propagate errno from kid */ + return Nullfp; + } + } + if (did_pipes) + PerlLIO_close(pp[0]); return PerlIO_fdopen(p[This], mode); } #else #if defined(atarist) || defined(DJGPP) FILE *popen(); PerlIO * -my_popen(cmd,mode) -char *cmd; -char *mode; +my_popen(char *cmd, char *mode) { /* Needs work for PerlIO ! */ /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */ + PERL_FLUSHALL_FOR_CHILD; return popen(PerlIO_exportFILE(cmd, 0), mode); } #endif @@ -2209,7 +2248,7 @@ my_pclose(PerlIO *ptr) } #endif /* !DOSISH */ -#if !defined(DOSISH) || defined(OS2) || defined(WIN32) +#if !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN32) I32 wait4pid(int pid, int *statusp, int flags) { @@ -2373,8 +2412,14 @@ cast_i32(double f) IV cast_iv(double f) { - if (f >= IV_MAX) - return (IV) IV_MAX; + if (f >= IV_MAX) { + UV uv; + + if (f >= (double)UV_MAX) + return (IV) UV_MAX; + uv = (UV) f; + return (IV)uv; + } if (f <= IV_MIN) return (IV) IV_MIN; return (IV) f; @@ -2385,6 +2430,14 @@ cast_uv(double f) { if (f >= MY_UV_MAX) return (UV) MY_UV_MAX; + if (f < 0) { + IV iv; + + if (f < IV_MIN) + return (UV)IV_MIN; + iv = (IV) f; + return (UV) iv; + } return (UV) f; } @@ -2440,7 +2493,7 @@ scan_bin(char *start, I32 len, I32 *retlen) retval = n | (*s++ - '0'); len--; } - if (len && (*s >= '2' || *s <= '9')) { + if (len && (*s >= '2' && *s <= '9')) { dTHR; if (ckWARN(WARN_UNSAFE)) warner(WARN_UNSAFE, "Illegal binary digit '%c' ignored", *s); diff --git a/utils/Makefile b/utils/Makefile index 2df16d8060..b650bbdca1 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -5,9 +5,9 @@ REALPERL = ../perl # Files to be built with variable substitution after miniperl is # available. Dependencies handled manually below (for now). -pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL splain.PL perlcc.PL -plextract = c2ph h2ph h2xs perlbug perldoc pl2pm splain perlcc -plextractexe = c2ph.exe h2ph.exe h2xs.exe perlbug.exe perldoc.exe pl2pm.exe splain.exe perlcc.exe +pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL splain.PL perlcc.PL perlbc.PL +plextract = c2ph h2ph h2xs perlbug perldoc pl2pm splain perlcc perlbc +plextractexe = c2ph.exe h2ph.exe h2xs.exe perlbug.exe perldoc.exe pl2pm.exe splain.exe perlcc.exe perlbc.exe all: $(plextract) @@ -31,7 +31,9 @@ pl2pm: pl2pm.PL ../config.sh splain: splain.PL ../config.sh ../lib/diagnostics.pm -perlcc: perlcc.PL ../config.sh +perlcc: perlcc.PL ../config.sh + +perlbc: perlbc.PL ../config.sh clean: diff --git a/utils/perlbc.PL b/utils/perlbc.PL new file mode 100644 index 0000000000..51d074be66 --- /dev/null +++ b/utils/perlbc.PL @@ -0,0 +1,80 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); +use Cwd; + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. +# Wanted: $archlibexp + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +$origdir = cwd; +chdir dirname($0); +$file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; + +use strict; +use warning; +no warning qw(once); + +use Config; + +require ByteLoader; + +foreach my $infile (@ARGV) +{ + if ($infile =~ /\.p[ml]$/) + { + my $outfile = $infile . "c"; + + open(OUT,"> $outfile") || die "Can't open $outfile: $!"; + + if ($infile =~ /\.pl$/) + { + print OUT "$Config{startperl}\n"; + print OUT " eval 'exec $Config{perlpath} -S \$0 \${1+\"\$@\"}'\n"; + print OUT " if \$running_under_some_shell;\n\n"; + } + + print OUT "use ByteLoader $ByteLoader::VERSION;\n"; + + close(OUT); + + print "$^X -MO=Bytecode $infile >> $outfile\n"; + + system("$^X -MO=Bytecode $infile >> $outfile"); + } + else + { + warn "Don't know how to byte compile $infile"; + } +} +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; +chdir $origdir; diff --git a/utils/perlcc.PL b/utils/perlcc.PL index 7aca1d8726..afad20a2b4 100644 --- a/utils/perlcc.PL +++ b/utils/perlcc.PL @@ -308,16 +308,18 @@ sub _ccharness if (!grep(/^-[cS]$/, @args)) { - my $lperl = $^O eq 'os2' ? '-llibperl' : '-lperl'; + my $lperl = $^O eq 'os2' ? '-llibperl' + : $^O eq 'MSWin32' ? "$Config{archlibexp}\\CORE\\perl.lib" + : '-lperl'; my $flags = $type eq 'dynamic' ? $Config{lddlflags} : $Config{ldflags}; - $linkargs = "$flags $libdir $lperl @Config{libs}"; + $linkargs = "$flags $libdir $lperl $Config{libs}"; } my @sharedobjects = _getSharedObjects($sourceprog); my $dynaloader = "$Config{'installarchlib'}/auto/DynaLoader/DynaLoader.a"; my $optimize = $Config{'optimize'} =~ /-O\d/ ? '' : $Config{'optimize'}; my $cccmd = - "$Config{cc} @Config{qw(ccflags)} $optimize $incdir @sharedobjects @args $dynaloader $linkargs"; + "$Config{cc} $Config{ccflags} $optimize $incdir @sharedobjects @args $dynaloader $linkargs"; _print ("$cccmd\n", 36); @@ -331,16 +333,16 @@ sub _getSharedObjects my (@return); local($") = " -I"; - if ($Config{'osname'} eq 'MSWin32') { - # _addstuff; - } - else - { - my ($tmpprog); - ($tmpprog = $sourceprog) =~ s"(.*)[\/\\](.*)"$2"; - $tmpfile = "/tmp/$tmpprog.tst"; - $incfile = "/tmp/$tmpprog.val"; + my ($tmpprog); + ($tmpprog = $sourceprog) =~ s"(.*)[\/\\](.*)"$2"; + my $tempdir = '/tmp'; + if ($Config{'osname'} eq 'MSWin32') { + $tempdir = $ENV{TEMP}; + $tempdir =~ s[\\][/]g; + } + $tmpfile = "$tempdir/$tmpprog.tst"; + $incfile = "$tempdir/$tmpprog.val"; } my $fd = new FileHandle("> $tmpfile") || die "Couldn't open $tmpfile!\n"; diff --git a/utils/perldoc.PL b/utils/perldoc.PL index e591479279..bd23350482 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -47,7 +47,7 @@ print OUT <<'!NO!SUBS!'; # man replacement, written in perl. This perldoc is strictly for reading # the perl manuals, though it too is written in perl. -if(@ARGV<1) { +if (@ARGV<1) { my $me = $0; # Editing $0 is unportable $me =~ s,.*/,,; die <<EOF; @@ -82,7 +82,7 @@ perldoc [options] -q FAQRegex Options: -h Display this help message -r Recursive search (slow) - -i Ignore case + -i Ignore case -t Display pod using pod2text instead of pod2man and nroff (-t is the default on win32) -u Display unformatted pod text @@ -94,10 +94,10 @@ Options: -q Search the text of questions (not answers) in perlfaq[1-9] PageName|ModuleName... - is the name of a piece of documentation that you want to look at. You + is the name of a piece of documentation that you want to look at. You may either give a descriptive name of the page (as in the case of - `perlfunc') the name of a module, either like `Term::Info', - `Term/Info', the partial name of a module, like `info', or + `perlfunc') the name of a module, either like `Term::Info', + `Term/Info', the partial name of a module, like `info', or `makemaker', or the name of a program, like `perldoc'. BuiltinFunction @@ -108,14 +108,14 @@ FAQRegex is a regex. Will search perlfaq[1-9] for and extract any questions that match. -Any switches in the PERLDOC environment variable will be used before the +Any switches in the PERLDOC environment variable will be used before the command line arguments. The optional pod index file contains a list of filenames, one per line. EOF } -if( defined $ENV{"PERLDOC"} ) { +if (defined $ENV{"PERLDOC"}) { require Text::ParseWords; unshift(@ARGV, Text::ParseWords::shellwords($ENV{"PERLDOC"})); } @@ -134,14 +134,15 @@ print OUT <<'!NO!SUBS!'; usage if $opt_h; my $podidx; -if( $opt_X ) { +if ($opt_X) { $podidx = "$Config{'archlib'}/pod.idx"; $podidx = "" unless -f $podidx && -r _ && -M _ <= 7; } -if( (my $opts = do{ local $^W; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) { +if ((my $opts = do{ local $^W; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) { usage("only one of -t, -u, -m or -l") -} elsif ($Is_MSWin32 || $Is_Dos) { +} +elsif ($Is_MSWin32 || $Is_Dos) { $opt_t = 1 unless $opts } @@ -149,11 +150,13 @@ if ($opt_t) { require Pod::Text; import Pod::Text; } my @pages; if ($opt_f) { - @pages = ("perlfunc"); -} elsif ($opt_q) { - @pages = ("perlfaq1" .. "perlfaq9"); -} else { - @pages = @ARGV; + @pages = ("perlfunc"); +} +elsif ($opt_q) { + @pages = ("perlfaq1" .. "perlfaq9"); +} +else { + @pages = @ARGV; } # Does this look like a module or extension directory? @@ -164,15 +167,13 @@ if (-f "Makefile.PL") { require ExtUtils::testlib; } - - sub containspod { my($file, $readit) = @_; return 1 if !$readit && $file =~ /\.pod$/i; local($_); open(TEST,"<$file"); - while(<TEST>) { - if(/^=head/) { + while (<TEST>) { + if (/^=head/) { close(TEST); return 1; } @@ -186,7 +187,7 @@ sub minus_f_nocase { my $path = join('/',$dir,$file); return $path if -f $path and -r _; if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') { - # on a case-forgiving file system or if case is important + # on a case-forgiving file system or if case is important # that is it all we can do warn "Ignored $path: unreadable\n" if -f _; return ''; @@ -198,7 +199,7 @@ sub minus_f_nocase { foreach $p (split(/\//, $file)){ my $try = "@p/$p"; stat $try; - if (-d _){ + if (-d _) { push @p, $p; if ( $p eq $global_target) { my $tmp_path = join ('/', @p); @@ -209,11 +210,14 @@ sub minus_f_nocase { push (@global_found, $tmp_path) unless $path_f; print STDERR "Found as @p but directory\n" if $opt_v; } - } elsif (-f _ && -r _) { + } + elsif (-f _ && -r _) { return $try; - } elsif (-f _) { + } + elsif (-f _) { warn "Ignored $try: unreadable\n"; - } else { + } + else { my $found=0; my $lcp = lc $p; opendir DIR, "@p"; @@ -238,7 +242,8 @@ sub check_file { my($dir,$file) = @_; if ($opt_m) { return minus_f_nocase($dir,$file); - } else { + } + else { my $path = minus_f_nocase($dir,$file); return $path if length $path and containspod($path); } @@ -264,7 +269,7 @@ sub searchfor { or ( $ret = check_file $dir,$s) or ( $Is_VMS and $ret = check_file $dir,"$s.com") - or ( $^O eq 'os2' and + or ( $^O eq 'os2' and $ret = check_file $dir,"$s.cmd") or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and $ret = check_file $dir,"$s.bat") @@ -300,73 +305,142 @@ sub filter_nroff { join "\n\n", @data; } +sub printout { + my ($file, $tmp, $filter) = @_; + my $err; + + if ($opt_t) { + open(TMP,">>$tmp") + or warn("Can't open $tmp: $!"), return; + Pod::Text::pod2text($file,*TMP); + close TMP; + } + elsif (not $opt_u) { + my $cmd = "pod2man --lax $file | nroff -man"; + $cmd .= " | col -x" if $^O =~ /hpux/; + my $rslt = `$cmd`; + $rslt = filter_nroff($rslt) if $filter; + unless (($err = $?)) { + open(TMP,">>$tmp") or warn("Can't open $tmp: $!"), return; + print TMP $rslt; + close TMP; + } + } + if ($opt_u or $err or -z $tmp) { + open(OUT,">>$tmp") or warn("Can't open $tmp: $!"), return; + open(IN,"<$file") or warn("Can't open $file: $!"), return; + my $cut = 1; + while (<IN>) { + $cut = $1 eq 'cut' if /^=(\w+)/; + next if $cut; + print OUT; + } + close IN; + close OUT; + } +} + +sub page { + my ($tmp, $no_tty, @pagers) = @_; + if ($no_tty) { + open(TMP,"<$tmp") or warn("Can't open $tmp: $!"), return; + print while <TMP>; + close TMP; + } + else { + foreach my $pager (@pagers) { + system("$pager $tmp") or last; + } + } +} + +sub cleanup { + my @files = @_; + for (@files) { + 1 while unlink($_); #Possibly pointless VMSism + } +} + +sub safe_exit { + my ($val, @files) = @_; + cleanup(@files); + exit $val; +} + +sub safe_die { + my ($msg, @files) = @_; + cleanup(@files); + die $msg; +} + my @found; foreach (@pages) { - if ($podidx && open(PODIDX, $podidx)) { - my $searchfor = $_; - local($_); - $searchfor =~ s,::,/,g; - print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v; - while (<PODIDX>) { - chomp; - push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?$,i; - } - close(PODIDX); - next; - } - print STDERR "Searching for $_\n" if $opt_v; - # We must look both in @INC for library modules and in PATH - # for executables, like h2xs or perldoc itself. - my @searchdirs = @INC; - if ($opt_F) { - next unless -r; - push @found, $_ if $opt_m or containspod($_); - next; + if ($podidx && open(PODIDX, $podidx)) { + my $searchfor = $_; + local($_); + $searchfor =~ s,::,/,g; + print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v; + while (<PODIDX>) { + chomp; + push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?$,i; } - unless ($opt_m) { - if ($Is_VMS) { - my($i,$trn); - for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) { - push(@searchdirs,$trn); - } - push(@searchdirs,'perl_root:[lib.pod]') # installed pods - } else { - push(@searchdirs, grep(-d, split($Config{path_sep}, - $ENV{'PATH'}))); + close(PODIDX); + next; + } + print STDERR "Searching for $_\n" if $opt_v; + # We must look both in @INC for library modules and in PATH + # for executables, like h2xs or perldoc itself. + my @searchdirs = @INC; + if ($opt_F) { + next unless -r; + push @found, $_ if $opt_m or containspod($_); + next; + } + unless ($opt_m) { + if ($Is_VMS) { + my($i,$trn); + for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) { + push(@searchdirs,$trn); } + push(@searchdirs,'perl_root:[lib.pod]') # installed pods + } + else { + push(@searchdirs, grep(-d, split($Config{path_sep}, + $ENV{'PATH'}))); } - my @files = searchfor(0,$_,@searchdirs); - if( @files ) { - print STDERR "Found as @files\n" if $opt_v; - } else { - # no match, try recursive search - - @searchdirs = grep(!/^\.$/,@INC); - - @files= searchfor(1,$_,@searchdirs) if $opt_r; - if( @files ) { - print STDERR "Loosely found as @files\n" if $opt_v; - } else { - print STDERR "No documentation found for \"$_\".\n"; - if (@global_found) { - print STDERR "However, try\n"; - for my $dir (@global_found) { - opendir(DIR, $dir) or die "$!"; - while (my $file = readdir(DIR)) { - next if ($file =~ /^\./); - $file =~ s/\.(pm|pod)$//; - print STDERR "\tperldoc $_\::$file\n"; - } - closedir DIR; - } - } + } + my @files = searchfor(0,$_,@searchdirs); + if (@files) { + print STDERR "Found as @files\n" if $opt_v; + } + else { + # no match, try recursive search + @searchdirs = grep(!/^\.$/,@INC); + @files= searchfor(1,$_,@searchdirs) if $opt_r; + if (@files) { + print STDERR "Loosely found as @files\n" if $opt_v; + } + else { + print STDERR "No documentation found for \"$_\".\n"; + if (@global_found) { + print STDERR "However, try\n"; + for my $dir (@global_found) { + opendir(DIR, $dir) or die "$!"; + while (my $file = readdir(DIR)) { + next if ($file =~ /^\./); + $file =~ s/\.(pm|pod)$//; + print STDERR "\tperldoc $_\::$file\n"; + } + closedir DIR; } + } } - push(@found,@files); + } + push(@found,@files); } -if(!@found) { - exit ($Is_VMS ? 98962 : 1); +if (!@found) { + exit ($Is_VMS ? 98962 : 1); } if ($opt_l) { @@ -377,164 +451,143 @@ if ($opt_l) { my $lines = $ENV{LINES} || 24; my $no_tty; -if( ! -t STDOUT ) { $no_tty = 1 } +if (! -t STDOUT) { $no_tty = 1 } + +# until here we could simply exit or die +# now we create temporary files that we have to clean up +# namely $tmp, $buffer my $tmp; +my $buffer; if ($Is_MSWin32) { - $tmp = "$ENV{TEMP}\\perldoc1.$$"; - push @pagers, qw( more< less notepad ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; - for (@found) { s,/,\\,g } -} elsif ($Is_VMS) { - $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$; - push @pagers, qw( most more less type/page ); -} elsif ($Is_Dos) { - $tmp = "$ENV{TEMP}/perldoc1.$$"; - $tmp =~ tr!\\/!//!s; - push @pagers, qw( less.exe more.com< ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; -} else { - if ($^O eq 'os2') { - require POSIX; - $tmp = POSIX::tmpnam(); - unshift @pagers, 'less', 'cmd /c more <'; - } else { - $tmp = "/tmp/perldoc1.$$"; - } - push @pagers, qw( more less pg view cat ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + $tmp = "$ENV{TEMP}\\perldoc1.$$"; + $buffer = "$ENV{TEMP}\\perldoc1.b$$"; + push @pagers, qw( more< less notepad ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + for (@found) { s,/,\\,g } +} +elsif ($Is_VMS) { + $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$; + $buffer = 'Sys$Scratch:perldoc.tmp1_b'.$$; + push @pagers, qw( most more less type/page ); +} +elsif ($Is_Dos) { + $tmp = "$ENV{TEMP}/perldoc1.$$"; + $buffer = "$ENV{TEMP}/perldoc1.b$$"; + $tmp =~ tr!\\/!//!s; + $buffer =~ tr!\\/!//!s; + push @pagers, qw( less.exe more.com< ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; +} +else { + if ($^O eq 'os2') { + require POSIX; + $tmp = POSIX::tmpnam(); + $buffer = POSIX::tmpnam(); + unshift @pagers, 'less', 'cmd /c more <'; + } + else { + $tmp = "/tmp/perldoc1.$$"; + $buffer = "/tmp/perldoc1.b$$"; + } + push @pagers, qw( more less pg view cat ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; } unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER}; +# all exit calls from here on have to be safe_exit calls (see above) +# and all die calls safe_die calls to guarantee removal of files and +# dir as needed + if ($opt_m) { - foreach my $pager (@pagers) { - system("$pager @found") or exit; - } - if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' } - exit 1; + foreach my $pager (@pagers) { + system("$pager @found") or safe_exit(0, $tmp, $buffer); + } + if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' } + # I don't get the line above. Please patch yourself as needed. + safe_exit(1, $tmp, $buffer); } my @pod; if ($opt_f) { - my $perlfunc = shift @found; - open(PFUNC, $perlfunc) or die "Can't open $perlfunc: $!"; - - # Functions like -r, -e, etc. are listed under `-X'. - my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) ? 'I<-X' : $opt_f ; - - # Skip introduction - while (<PFUNC>) { - last if /^=head2 Alphabetical Listing of Perl Functions/; - } - - # Look for our function - my $found = 0; - my $inlist = 0; - while (<PFUNC>) { - if (/^=item\s+\Q$search_string\E\b/o) { - $found = 1; - } elsif (/^=item/) { - last if $found > 1 and not $inlist; - } - next unless $found; - if (/^=over/) { - ++$inlist; - } - elsif (/^=back/) { - --$inlist; - } - push @pod, $_; - ++$found if /^\w/; # found descriptive text - } - if (!@pod) { - die "No documentation for perl function `$opt_f' found\n"; - } -} + my $perlfunc = shift @found; + open(PFUNC, $perlfunc) + or safe_die("Can't open $perlfunc: $!", $tmp, $buffer); -if ($opt_q) { - local @ARGV = @found; # I'm lazy, sue me. - my $found = 0; - my %found_in; - - while (<>) { - if (/^=head2\s+.*(?:$opt_q)/oi) { - $found = 1; - push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++; - } elsif (/^=head2/) { - $found = 0; - } - next unless $found; - push @pod, $_; - } - - if (!@pod) { - die "No documentation for perl FAQ keyword `$opt_q' found\n"; - } -} - -my $tmp1; -my $filter; - -if (@pod) { - $tmp1 = $tmp . "_"; - open(TMP,">$tmp1") or die "open '$tmp1': $!"; - print TMP "=over 8\n\n"; - print TMP @pod; - print TMP "=back\n"; - close(TMP) or die "close '$tmp1': $!"; - @found = $tmp1; - $filter = 1; -} + # Functions like -r, -e, etc. are listed under `-X'. + my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) + ? 'I<-X' : $opt_f ; -foreach (@found) { + # Skip introduction + while (<PFUNC>) { + last if /^=head2 Alphabetical Listing of Perl Functions/; + } - my $err; - if($opt_t) { - open(TMP,">>$tmp"); - Pod::Text::pod2text($_,*TMP); - close(TMP); - } elsif(not $opt_u) { - my $cmd = "pod2man --lax $_ | nroff -man"; - $cmd .= " | col -x" if $^O =~ /hpux/; - my $rslt = `$cmd`; - $rslt = filter_nroff $rslt if $filter; - unless(($err = $?)) { - open(TMP,">>$tmp"); - print TMP $rslt; - close TMP; - } + # Look for our function + my $found = 0; + my $inlist = 0; + while (<PFUNC>) { + if (/^=item\s+\Q$search_string\E\b/o) { + $found = 1; } - - if( $opt_u or $err or -z $tmp) { - open(OUT,">>$tmp"); - open(IN,"<$_"); - my $cut = 1; - while (<IN>) { - $cut = $1 eq 'cut' if /^=(\w+)/; - next if $cut; - print OUT; - } - close(IN); - close(OUT); + elsif (/^=item/) { + last if $found > 1 and not $inlist; + } + next unless $found; + if (/^=over/) { + ++$inlist; + } + elsif (/^=back/) { + --$inlist; } + push @pod, $_; + ++$found if /^\w/; # found descriptive text + } + if (!@pod) { + die "No documentation for perl function `$opt_f' found\n"; + } } -if( $no_tty ) { - open(TMP,"<$tmp"); - print while <TMP>; - close(TMP); -} else { - foreach my $pager (@pagers) { - system("$pager $tmp") or last; +if ($opt_q) { + local @ARGV = @found; # I'm lazy, sue me. + my $found = 0; + my %found_in; + + while (<>) { + if (/^=head2\s+.*(?:$opt_q)/oi) { + $found = 1; + push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++; } + elsif (/^=head2/) { + $found = 0; + } + next unless $found; + push @pod, $_; + } + if (!@pod) { + safe_die("No documentation for perl FAQ keyword `$opt_q' found\n", + $tmp, $buffer); + } +} + +my $filter; + +if (@pod) { + open(TMP,">$buffer") or safe_die("Can't open '$buffer': $!", $tmp, $buffer); + print TMP "=over 8\n\n"; + print TMP @pod; + print TMP "=back\n"; + close TMP; + @found = $buffer; + $filter = 1; } -1 while unlink($tmp); #Possibly pointless VMSism -if (defined $tmp1) { - 1 while unlink($tmp1); #Possibly pointless VMSism +foreach (@found) { + printout($_, $tmp, $filter); } +page($tmp, $no_tty, @pagers); -exit 0; +safe_exit(0, $tmp, $buffer); __END__ @@ -627,7 +680,7 @@ name, you will only get the first one. =head1 ENVIRONMENT -Any switches in the C<PERLDOC> environment variable will be used before the +Any switches in the C<PERLDOC> environment variable will be used before the command line arguments. C<perldoc> also searches directories specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not defined) and C<PATH> environment variables. @@ -639,11 +692,16 @@ used if C<perldoc> was told to display plain text or unformatted pod.) One useful value for C<PERLDOC_PAGER> is C<less -+C -E>. +=head1 VERSION + +This is perldoc v2.0. + =head1 AUTHOR Kenneth Albanowski <kjahds@kjahds.com> -Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu> +Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>, +and others. =cut @@ -661,7 +719,7 @@ Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu> # Kenneth Albanowski <kjahds@kjahds.com> # -added Charles Bailey's further VMS patches, and -u switch # -added -t switch, with pod2text support -# +# # Version 1.10: Thu Nov 9 07:23:47 EST 1995 # Kenneth Albanowski <kjahds@kjahds.com> # -added VMS support diff --git a/vmesa/vmesa.c b/vmesa/vmesa.c index 11854335e0..0e7894aeb9 100644 --- a/vmesa/vmesa.c +++ b/vmesa/vmesa.c @@ -408,6 +408,7 @@ my_popen(char *cmd, char *mode) Perl_stdin_fd = pFd[that]; if (strNE(cmd,"-")) { + PERL_FLUSHALL_FOR_CHILD; pid = spawn_cmd(cmd, Perl_stdin_fd, Perl_stdout_fd); if (pid >= 0) { diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index db39c7f7e6..206740890e 100644 --- a/vms/descrip_mms.template +++ b/vms/descrip_mms.template @@ -788,7 +788,7 @@ perly$(O) : perly.c, perly.h, $(h) Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET) test : all [.t.lib]vmsfspec.t [.t.lib]vmsish.t - - @[.VMS]Test.Com "$(E)" + - @[.VMS]Test.Com "$(E)" "$(__DEBUG__)" # install ought not need a source, but it doesn't work if one's not # there. Go figure... diff --git a/vms/ext/vmsish.t b/vms/ext/vmsish.t index f68b3ac89c..24a9f437ef 100644 --- a/vms/ext/vmsish.t +++ b/vms/ext/vmsish.t @@ -115,7 +115,7 @@ else { print "ok 5\n"; } } else { print "ok 15\n"; } - if ($utcmtime - $vmsmtime + $offset > 10) { + if ($vmsmtime - $utcmtime + $offset > 10) { print "not ok 16 # (stat) UTC: $utcmtime VMS: $vmsmtime\n"; } else { print "ok 16\n"; } diff --git a/vms/perlvms.pod b/vms/perlvms.pod index 56f66497d8..1705bf882f 100644 --- a/vms/perlvms.pod +++ b/vms/perlvms.pod @@ -715,17 +715,24 @@ that F<PERL_ENV_TABLES> is set up so that the logical name C<story> is found, rather than a CLI symbol or CRTL C<environ> element with the same name. -When an element of C<%ENV> is set to a non-empty string, the +When an element of C<%ENV> is set to a defined string, the corresponding definition is made in the location to which the first translation of F<PERL_ENV_TABLES> points. If this causes a logical name to be created, it is defined in supervisor mode. +(The same is done if an existing logical name was defined in +executive or kernel mode; an existing user or supervisor mode +logical name is reset to the new value.) If the value is an empty +string, the logical name's translation is defined as a single NUL +(ASCII 00) character, since a logical name cannot translate to a +zero-length string. (This restriction does not apply to CLI symbols +or CRTL C<environ> values; they are set to the empty string.) An element of the CRTL C<environ> array can be set only if your copy of Perl knows about the CRTL's C<setenv()> function. (This is present only in some versions of the DECCRTL; check C<$Config{d_setenv}> to see whether your copy of Perl was built with a CRTL that has this function.) -When an element of C<%ENV> is set to an empty string or C<undef>, +When an element of C<%ENV> is set to C<undef>, the element is looked up as if it were being read, and if it is found, it is deleted. (An item "deleted" from the CRTL C<environ> array is set to the empty string; this can only be done if your @@ -734,8 +741,9 @@ C<delete> to remove an element from C<%ENV> has a similar effect, but after the element is deleted, another attempt is made to look up the element, so an inner-mode logical name or a name in another location will replace the logical name just deleted. -It is not possible at present to define a search list logical name -via %ENV. +In either case, only the first value found searching PERL_ENV_TABLES +is altered. It is not possible at present to define a search list +logical name via %ENV. The element C<$ENV{DEFAULT}> is special: when read, it returns Perl's current default device and directory, and when set, it diff --git a/vms/subconfigure.com b/vms/subconfigure.com index 039f4dda30..d96c845a80 100644 --- a/vms/subconfigure.com +++ b/vms/subconfigure.com @@ -1,4 +1,4 @@ - $! SUBCONFIGURE.COM - build a config.sh for VMS Perl. +$! SUBCONFIGURE.COM - build a config.sh for VMS Perl. $! $! Note for folks from other platforms changing things in here: $! Fancy changes (based on compiler capabilities or VMS version or @@ -2448,6 +2448,77 @@ $ $ perl_ptrsize=line $ WRITE_RESULT "ptrsize is ''perl_ptrsize'" $! +$! +$! Check rand48 and its ilk +$! +$ OS +$ WS "#ifdef __DECC +$ WS "#include <stdlib.h> +$ WS "#endif +$ WS "#include <stdio.h> +$ WS "int main() +$ WS "{" +$ WS "srand48(12L);" +$ WS "exit(0); +$ WS "}" +$ CS +$! copy temp.c sys$output +$! +$ DEFINE SYS$ERROR _NLA0: +$ DEFINE SYS$OUTPUT _NLA0: +$ ON ERROR THEN CONTINUE +$ ON WARNING THEN CONTINUE +$ 'Checkcc' temp +$ If (Needs_Opt.eqs."Yes") +$ THEN +$ link temp,temp.opt/opt +$ else +$ link temp +$ endif +$ teststatus = f$extract(9,1,$status) +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ if (teststatus.nes."1") +$ THEN +$ perl_drand01="random()" +$ perl_randseedtype = "unsigned" +$ perl_seedfunc = "srandom" +$ ENDIF +$ OS +$ WS "#ifdef __DECC +$ WS "#include <stdlib.h> +$ WS "#endif +$ WS "#include <stdio.h> +$ WS "int main() +$ WS "{" +$ WS "srandom(12);" +$ WS "exit(0); +$ WS "}" +$ CS +$! copy temp.c sys$output +$! +$ DEFINE SYS$ERROR _NLA0: +$ DEFINE SYS$OUTPUT _NLA0: +$ ON ERROR THEN CONTINUE +$ ON WARNING THEN CONTINUE +$ 'Checkcc' temp +$ If (Needs_Opt.eqs."Yes") +$ THEN +$ link temp,temp.opt/opt +$ else +$ link temp +$ endif +$ teststatus = f$extract(9,1,$status) +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ if (teststatus.nes."1") +$ THEN +$ perl_drand01="(((float)rand())/((float)RAND_MAX))" +$ perl_randseedtype = "unsigned" +$ perl_seedfunc = "srand" +$ ENDIF +$ WRITE_RESULT "drand01 is ''perl_drand01'" +$! $ set nover $! Done with compiler checks. Clean up. $ if f$search("temp.c").nes."" then DELETE/NOLOG temp.c;* @@ -2645,6 +2716,14 @@ $ THEN $ perl_ccflags="/Include=[]/Obj=''perl_obj_ext'/NoList''cc_flags'" $ ENDIF $ ENDIF +$ if use_vmsdebug_perl .eqs. "Y" +$ then +$ perl_optimize="/Debug/NoOpt" +$ perl_dbgprefix = "DBG" +$ else +$ perl_optimize= "" +$ perl_dbgprefix = "" +$ endif $! $! Finally clean off any leading zeros from the patchlevel or subversion $ perl_patchlevel = perl_patchlevel + 0 @@ -2700,6 +2779,8 @@ $ WC "vms_cc_type='" + perl_vms_cc_type + "'" $ WC "d_attribut='" + perl_d_attribut + "'" $ WC "cc='" + perl_cc + "'" $ WC "ccflags='" + perl_ccflags + "'" +$ WC "optimize='" + perl_optimize + "'" +$ WC "dbgprefix='" + perl_dbgprefix + "'" $ WC "d_vms_do_sockets='" + perl_d_vms_do_sockets + "'" $ WC "d_socket='" + perl_d_socket + "'" $ WC "d_sockpair='" + perl_d_sockpair + "'" @@ -3283,7 +3364,8 @@ $ exts1 = F$Edit(p1,"Compress") $ p2 = F$Edit(p2,"Upcase,Compress,Trim") $ If F$Locate("MCR ",p2).eq.0 Then p2 = F$Extract(3,255,p2) $ miniperl = "$" + F$Search(F$Parse(p2,".Exe")) -$ mmk = p3 +$ makeutil = p3 +$ if f$type('p3') .nes. "" then makeutil = 'p3' $ targ = F$Edit(p4,"Lowercase") $ i = 0 $ next_ext: @@ -3315,7 +3397,7 @@ $ On Error Then Continue $ EndIf $ If redesc Then - miniperl "-I[''up'.lib]" Makefile.PL "INST_LIB=[''up'.lib]" "INST_ARCHLIB=[''up'.lib]" -$ mmk 'targ' +$ makeutil 'targ' $ i = i + 1 $ Set Def &def $ Goto next_ext diff --git a/vms/test.com b/vms/test.com index 15c0e8a949..039d844ea9 100644 --- a/vms/test.com +++ b/vms/test.com @@ -32,9 +32,17 @@ $ Write Sys$Error "Descrip.MMS or used the AXE=1 macro in the MM[SK] command $ Write Sys$Error "" $ Exit 44 $ EndIf +$! +$! "debug" perl if second parameter is nonblank +$! +$ dbg = "" +$ ndbg = "" +$ if p2.nes."" then dbg = "dbg" +$ if p2.nes."" then ndbg = "ndbg" +$! $! Pick up a copy of perl to use for the tests $ Delete/Log/NoConfirm Perl.;* -$ Copy/Log/NoConfirm [-]Perl'exe' []Perl. +$ Copy/Log/NoConfirm [-]'ndbg'Perl'exe' []Perl. $ $! Make the environment look a little friendlier to tests which assume Unix $ cat = "Type" @@ -85,8 +93,8 @@ $ $! And do it $ Show Process/Accounting $ testdir = "Directory/NoHead/NoTrail/Column=1" -$ Define/User Perlshr Sys$Disk:[-]PerlShr'exe' -$ MCR Sys$Disk:[]Perl. "-I[-.lib]" - "''p2'" "''p3'" "''p4'" "''p5'" "''p6'" +$ Define/User 'dbg'Perlshr Sys$Disk:[-]'dbg'PerlShr'exe' +$ MCR Sys$Disk:[]Perl. "-I[-.lib]" - "''p3'" "''p4'" "''p5'" "''p6'" $ Deck/Dollar=$$END-OF-TEST$$ # $RCSfile: TEST,v $$Revision: 4.1 $$Date: 92/08/07 18:27:00 $ # Modified for VMS 30-Sep-1994 Charles Bailey bailey@newman.upenn.edu @@ -166,6 +174,7 @@ while ($test = shift) { open(results,"\$ MCR Sys\$Disk:[]Perl. \"-I[-.lib]\" $switch $test |") || (print "can't run.\n"); $ok = 0; $next = 0; + $pending_not = 0; while (<results>) { if ($verbose) { print "$te$_"; @@ -182,7 +191,10 @@ while ($test = shift) { $next = $1, $ok = 0, last if /^not ok ([0-9]*)/; next if /^\s*$/; # our 'echo' substitute produces one more \n than Unix' if (/^ok (.*)/ && $1 == $next) { + $next = $1, $ok=0, last if $pending_not; $next = $next + 1; + } elsif (/^not/) { + $pending_not = 1; } else { $ok = 0; } @@ -2,8 +2,8 @@ * * VMS-specific routines for perl5 * - * Last revised: 13-Sep-1998 by Charles Bailey bailey@newman.upenn.edu - * Version: 5.5.2 + * Last revised: 24-Apr-1999 by Charles Bailey bailey@newman.upenn.edu + * Version: 5.5.58 */ #include <acedef.h> @@ -51,6 +51,10 @@ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +/* Anticipating future expansion in lexical warnings . . . */ +#ifndef WARN_INTERNAL +# define WARN_INTERNAL WARN_MISC +#endif /* gcc's header files don't #define direct access macros * corresponding to VAXC's variant structs */ @@ -153,9 +157,10 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0); if (retsts & 1) { if (eqvlen > 1024) { - if (PL_curinterp && PL_dowarn) warn("Value of CLI symbol \"%s\" too long",lnm); - eqvlen = 1024; set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU); + eqvlen = 1024; + if (ckWARN(WARN_MISC)) + warner(WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm); } strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen); } @@ -297,7 +302,7 @@ prime_env_iter(void) { dTHR; static int primed = 0; - HV *seenhv = NULL, *envhv = GvHVn(PL_envgv); + HV *seenhv = NULL, *envhv; char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch; unsigned short int chan; #ifndef CLI$M_TRUSTED @@ -317,9 +322,10 @@ prime_env_iter(void) MUTEX_INIT(&primenv_mutex); #endif - if (primed) return; + if (primed || !PL_envgv) return; MUTEX_LOCK(&primenv_mutex); if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; } + envhv = GvHVn(PL_envgv); /* Perform a dummy fetch as an lval to insure that the hash table is * set up. Otherwise, the hv_store() will turn into a nullop. */ (void) hv_fetch(envhv,"DEFAULT",7,TRUE); @@ -342,8 +348,8 @@ prime_env_iter(void) int j; for (j = 0; environ[j]; j++) { if (!(start = strchr(environ[j],'='))) { - if (PL_curinterp && PL_dowarn) - warn("Ill-formed CRTL environ value \"%s\"\n",environ[j]); + if (ckWARN(WARN_INTERNAL)) + warner(WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]); } else { start++; @@ -411,8 +417,8 @@ prime_env_iter(void) } continue; } - if (sts == SS$_BUFFEROVF && PL_curinterp && PL_dowarn) - warn("Buffer overflow in prime_env_iter: %s",buf); + if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL)) + warner(WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf); for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ; if (*cp1 == '(' || /* Logical name table name */ @@ -424,8 +430,8 @@ prime_env_iter(void) while (*cp2 && *cp2 != '=') cp2++; while (*cp2 && *cp2 != '"') cp2++; for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ; - if (!keylen || (cp1 - cp2 <= 0)) { - warn("Ill-formed message in prime_env_iter: |%s|",buf); + if ((!keylen || (cp1 - cp2 <= 0)) && ckWARN(WARN_INTERNAL)) { + warner(WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf); continue; } /* Skip "" surrounding translation */ @@ -460,6 +466,7 @@ prime_env_iter(void) * vmstrnenv(). If an element is to be deleted, it's removed from * the first place it's found. If it's to be set, it's set in the * place designated by the first element of the table vector. + * Like setenv() returns 0 for success, non-zero on error. */ int vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) @@ -483,23 +490,25 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) lnmdsc.dsc$w_length = cp1 - lnm; if (!tabvec || !*tabvec) tabvec = env_tables; - if (!eqv || !*eqv) { /* we're deleting a symbol */ + if (!eqv) { /* we're deleting n element */ for (curtab = 0; tabvec[curtab]; curtab++) { if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) { int i; -#ifdef HAS_SETENV for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */ if ((cp1 = strchr(environ[i],'=')) && !strncmp(environ[i],lnm,cp1 - environ[i])) { - setenv(lnm,eqv,1); - return; +#ifdef HAS_SETENV + return setenv(lnm,eqv,1) ? vaxc$errno : 0; } } ivenv = 1; retsts = SS$_NOLOGNAM; #else - if (PL_curinterp && PL_dowarn) - warn("This Perl can't reset CRTL environ elements (%s)",lnm) - ivenv = 1; retsts = SS$_NOSUCHPGM; + if (ckWARN(WARN_INTERNAL)) + warner(WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm); + ivenv = 1; retsts = SS$_NOSUCHPGM; + break; + } + } #endif } else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) && @@ -511,8 +520,8 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) symtype = LIB$K_CLI_LOCAL_SYM; else symtype = LIB$K_CLI_GLOBAL_SYM; retsts = lib$delete_symbol(&lnmdsc,&symtype); - if (retsts = LIB$_INVSYMNAM) { ivsym = 1; continue; } - if (retsts = LIB$_NOSUCHSYM) continue; + if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; } + if (retsts == LIB$_NOSUCHSYM) continue; break; } else if (!ivlnm) { @@ -527,10 +536,10 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) else { /* we're defining a value */ if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) { #ifdef HAS_SETENV - return setenv(lnm,eqv,1) ? vaxc$errno : SS$_NORMAL; + return setenv(lnm,eqv,1) ? vaxc$errno : 0; #else - if (PL_curinterp && PL_dowarn) - warn("This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv) + if (ckWARN(WARN_INTERNAL)) + warner(WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv); retsts = SS$_NOSUCHPGM; #endif } @@ -547,7 +556,10 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) else symtype = LIB$K_CLI_GLOBAL_SYM; retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype); } - else retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0); + else { + if (!*eqv) eqvdsc.dsc$w_length = 1; + retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0); + } } } if (!(retsts & 1)) { @@ -567,7 +579,15 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) set_vaxc_errno(retsts); return (int) retsts || 44; /* retsts should never be 0, but just in case */ } - else if (retsts != SS$_NORMAL) { /* alternate success codes */ + else { + /* We reset error values on success because Perl does an hv_fetch() + * before each hv_store(), and if the thing we're setting didn't + * previously exist, we've got a leftover error message. (Of course, + * this fails in the face of + * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo'; + * in that the error reported in $! isn't spurious, + * but it's right more often than not.) + */ set_errno(0); set_vaxc_errno(retsts); return 0; } @@ -855,19 +875,78 @@ static struct pipe_details *open_pipes = NULL; static $DESCRIPTOR(nl_desc, "NL:"); static int waitpid_asleep = 0; +/* Send an EOF to a mbx. N.B. We don't check that fp actually points + * to a mbx; that's the caller's responsibility. + */ +static unsigned long int +pipe_eof(FILE *fp) +{ + char devnam[NAM$C_MAXRSS+1], *cp; + unsigned long int chan, iosb[2], retsts, retsts2; + struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam}; + + if (fgetname(fp,devnam,1)) { + /* It oughta be a mailbox, so fgetname should give just the device + * name, but just in case . . . */ + if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0'; + devdsc.dsc$w_length = strlen(devnam); + _ckvmssts(sys$assign(&devdsc,&chan,0,0)); + retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0); + if (retsts & 1) retsts = iosb[0]; + retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */ + if (retsts & 1) retsts = retsts2; + _ckvmssts(retsts); + return retsts; + } + else _ckvmssts(vaxc$errno); /* Should never happen */ + return (unsigned long int) vaxc$errno; +} + static unsigned long int pipe_exit_routine() { + struct pipe_details *info; unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT; - int sts; + int sts, did_stuff; + + /* + first we try sending an EOF...ignore if doesn't work, make sure we + don't hang + */ + did_stuff = 0; + info = open_pipes; + + while (info) { + if (info->mode != 'r' && !info->done) { + if (pipe_eof(info->fp) & 1) did_stuff = 1; + } + info = info->next; + } + if (did_stuff) sleep(1); /* wait for EOF to have an effect */ - while (open_pipes != NULL) { - if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/ - _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort)); - sleep(1); + did_stuff = 0; + info = open_pipes; + while (info) { + if (!info->done) { /* Tap them gently on the shoulder . . .*/ + sts = sys$forcex(&info->pid,0,&abort); + if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts); + did_stuff = 1; } - if (!open_pipes->done) /* We tried to be nice . . . */ - _ckvmssts(sys$delprc(&open_pipes->pid,0)); + info = info->next; + } + if (did_stuff) sleep(1); /* wait for them to respond */ + + info = open_pipes; + while (info) { + if (!info->done) { /* We tried to be nice . . . */ + sts = sys$delprc(&info->pid,0); + if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts); + info->done = 1; /* so my_pclose doesn't try to write EOF */ + } + info = info->next; + } + + while(open_pipes) { if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno; else if (!(sts & 1)) retsts = sts; } @@ -957,6 +1036,7 @@ my_popen(char *cmd, char *mode) { TAINT_ENV(); TAINT_PROPER("popen"); + PERL_FLUSHALL_FOR_CHILD; return safe_popen(cmd,mode); } @@ -980,25 +1060,7 @@ I32 my_pclose(FILE *fp) /* If we were writing to a subprocess, insure that someone reading from * the mailbox gets an EOF. It looks like a simple fclose() doesn't * produce an EOF record in the mailbox. */ - if (info->mode != 'r') { - char devnam[NAM$C_MAXRSS+1], *cp; - unsigned long int chan, iosb[2], retsts, retsts2; - struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam}; - - if (fgetname(info->fp,devnam,1)) { - /* It oughta be a mailbox, so fgetname should give just the device - * name, but just in case . . . */ - if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0'; - devdsc.dsc$w_length = strlen(devnam); - _ckvmssts(sys$assign(&devdsc,&chan,0,0)); - retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0); - if (retsts & 1) retsts = iosb[0]; - retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */ - if (retsts & 1) retsts = retsts2; - _ckvmssts(retsts); - } - else _ckvmssts(vaxc$errno); /* Should never happen */ - } + if (info->mode != 'r' && !info->done) pipe_eof(info->fp); PerlIO_close(info->fp); if (info->done) retsts = info->completion; @@ -1037,11 +1099,11 @@ my_waitpid(Pid_t pid, int *statusp, int flags) unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid; unsigned long int interval[2],sts; - if (PL_dowarn) { + if (ckWARN(WARN_EXEC)) { _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)); _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0)); if (ownerpid != mypid) - warn("pid %x not a child",pid); + warner(WARN_EXEC,"pid %x not a child",pid); } _ckvmssts(sys$bintim(&intdsc,interval)); @@ -1117,7 +1179,7 @@ do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts) struct FAB myfab = cc$rms_fab; struct NAM mynam = cc$rms_nam; STRLEN speclen; - unsigned long int retsts, haslower = 0, isunix = 0; + unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0; if (!filespec || !*filespec) { set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL); @@ -1186,13 +1248,37 @@ do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts) if (islower(*out)) { haslower = 1; break; } if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; } else { out = esa; speclen = mynam.nam$b_esl; } - if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) && - (!defspec || !*defspec || !strchr(myfab.fab$l_dna,';'))) - speclen = mynam.nam$l_ver - out; - if (!(mynam.nam$l_fnb & NAM$M_EXP_TYPE) && - (!defspec || !*defspec || defspec[myfab.fab$b_dns-1] != '.' || - defspec[myfab.fab$b_dns-2] == '.')) - speclen = mynam.nam$l_type - out; + /* Trim off null fields added by $PARSE + * If type > 1 char, must have been specified in original or default spec + * (not true for version; $SEARCH may have added version of existing file). + */ + trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER); + trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) && + (mynam.nam$l_ver - mynam.nam$l_type == 1); + if (trimver || trimtype) { + if (defspec && *defspec) { + char defesa[NAM$C_MAXRSS]; + struct FAB deffab = cc$rms_fab; + struct NAM defnam = cc$rms_nam; + + deffab.fab$l_nam = &defnam; + deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns; + defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa; + defnam.nam$b_nop = NAM$M_SYNCHK; + if (sys$parse(&deffab,0,0) & 1) { + if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER); + if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE); + } + } + if (trimver) speclen = mynam.nam$l_ver - out; + if (trimtype) { + /* If we didn't already trim version, copy down */ + if (speclen > mynam.nam$l_ver - out) + memcpy(mynam.nam$l_type, mynam.nam$l_ver, + speclen - (mynam.nam$l_ver - out)); + speclen -= mynam.nam$l_ver - mynam.nam$l_type; + } + } /* If we just had a directory spec on input, $PARSE "helpfully" * adds an empty name and type for us */ if (mynam.nam$l_name == mynam.nam$l_type && @@ -3115,12 +3201,12 @@ seekdir(DIR *dd, long count) * in 'VMSish fashion' (i.e. not after a call to vfork) The args * are concatenated to form a DCL command string. If the first arg * begins with '$' (i.e. the perl script had "\$ Type" or some such), - * the the command string is hrnded off to DCL directly. Otherwise, + * the the command string is handed off to DCL directly. Otherwise, * the first token of the command is taken as the filespec of an image * to run. The filespec is expanded using a default type of '.EXE' and - * the process defaults for device, directory, etc., and the resultant + * the process defaults for device, directory, etc., and if found, the resultant * filespec is invoked using the DCL verb 'MCR', and passed the rest of - * the command string as parameters. This is perhaps a bit compicated, + * the command string as parameters. This is perhaps a bit complicated, * but I hope it will form a happy medium between what VMS folks expect * from lib$spawn and what Unix folks expect from exec. */ @@ -3186,8 +3272,10 @@ setup_argstr(SV *really, SV **mark, SV **sp) else *PL_Cmd = '\0'; while (++mark <= sp) { if (*mark) { - strcat(PL_Cmd," "); - strcat(PL_Cmd,SvPVx(*mark,n_a)); + char *s = SvPVx(*mark,n_a); + if (!*s) continue; + if (*PL_Cmd) strcat(PL_Cmd," "); + strcat(PL_Cmd,s); } } return PL_Cmd; @@ -3202,7 +3290,7 @@ setup_cmddsc(char *cmd, int check_img) $DESCRIPTOR(defdsc,".EXE"); $DESCRIPTOR(resdsc,resspec); struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; - unsigned long int cxt = 0, flags = 1, retsts; + unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL; register char *s, *rest, *cp; register int isdcl = 0; @@ -3220,43 +3308,45 @@ setup_cmddsc(char *cmd, int check_img) } } else isdcl = 1; - if (isdcl) { /* It's a DCL command, just do it. */ - VMScmd.dsc$w_length = strlen(cmd); - if (cmd == PL_Cmd) { - VMScmd.dsc$a_pointer = PL_Cmd; - PL_Cmd = Nullch; /* Don't try to free twice in vms_execfree() */ - } - else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length); - } - else { /* assume first token is an image spec */ + if (!isdcl) { cmd = s; while (*s && !isspace(*s)) s++; rest = *s ? s : 0; imgdsc.dsc$a_pointer = cmd; imgdsc.dsc$w_length = s - cmd; retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags); - if (!(retsts & 1)) { - /* just hand off status values likely to be due to user error */ - if (retsts == RMS$_FNF || retsts == RMS$_DNF || - retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN || - (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts; - else { _ckvmssts(retsts); } - } - else { + if (retsts & 1) { _ckvmssts(lib$find_file_end(&cxt)); s = resspec; while (*s && !isspace(*s)) s++; *s = '\0'; - if (!cando_by_name(S_IXUSR,0,resspec)) return RMS$_PRV; - New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char); - strcpy(VMScmd.dsc$a_pointer,"$ MCR "); - strcat(VMScmd.dsc$a_pointer,resspec); - if (rest) strcat(VMScmd.dsc$a_pointer,rest); - VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer); + if (cando_by_name(S_IXUSR,0,resspec)) { + New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char); + strcpy(VMScmd.dsc$a_pointer,"$ MCR "); + strcat(VMScmd.dsc$a_pointer,resspec); + if (rest) strcat(VMScmd.dsc$a_pointer,rest); + VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer); + return retsts; + } + else retsts = RMS$_PRV; } } + /* It's either a DCL command or we couldn't find a suitable image */ + VMScmd.dsc$w_length = strlen(cmd); + if (cmd == PL_Cmd) { + VMScmd.dsc$a_pointer = PL_Cmd; + PL_Cmd = Nullch; /* Don't try to free twice in vms_execfree() */ + } + else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length); + if (!(retsts & 1)) { + /* just hand off status values likely to be due to user error */ + if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV || + retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN || + (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts; + else { _ckvmssts(retsts); } + } - return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL); + return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts); } /* end of setup_cmddsc() */ @@ -3323,8 +3413,10 @@ vms_do_exec(char *cmd) set_errno(EVMSERR); } set_vaxc_errno(retsts); - if (PL_dowarn) - warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno)); + if (ckWARN(WARN_EXEC)) { + warner(WARN_EXEC,"Can't exec \"%*s\": %s", + VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno)); + } vms_execfree(); } @@ -3380,9 +3472,12 @@ do_spawn(char *cmd) set_errno(EVMSERR); } set_vaxc_errno(sts); - if (PL_dowarn) - warn("Can't spawn \"%s\": %s", - hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno)); + if (ckWARN(WARN_EXEC)) { + warner(WARN_EXEC,"Can't spawn \"%*s\": %s", + hadcmd ? VMScmd.dsc$w_length : 0, + hadcmd ? VMScmd.dsc$a_pointer : "", + Strerror(errno)); + } } vms_execfree(); return substs; diff --git a/win32/Makefile b/win32/Makefile index 49271f27cd..ffa8c6b1a4 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -509,7 +509,7 @@ SETARGV_OBJ = setargv$(o) !ENDIF DYNAMIC_EXT = Socket IO Fcntl Opcode SDBM_File POSIX attrs Thread B re \ - Data/Dumper Devel/Peek + Data/Dumper Devel/Peek ByteLoader STATIC_EXT = DynaLoader NONXS_EXT = Errno @@ -527,6 +527,7 @@ RE = $(EXTDIR)\re\re DUMPER = $(EXTDIR)\Data\Dumper\Dumper ERRNO = $(EXTDIR)\Errno\Errno PEEK = $(EXTDIR)\Devel\Peek\Peek +BYTELOADER = $(EXTDIR)\ByteLoader SOCKET_DLL = $(AUTODIR)\Socket\Socket.dll FCNTL_DLL = $(AUTODIR)\Fcntl\Fcntl.dll @@ -540,6 +541,7 @@ B_DLL = $(AUTODIR)\B\B.dll DUMPER_DLL = $(AUTODIR)\Data\Dumper\Dumper.dll PEEK_DLL = $(AUTODIR)\Devel\Peek\Peek.dll RE_DLL = $(AUTODIR)\re\re.dll +BYTELOADER_DLL = $(AUTODIR)\ByteLoader\ByteLoader.dll ERRNO_PM = $(LIBDIR)\Errno.pm @@ -555,7 +557,8 @@ EXTENSION_C = \ $(RE).c \ $(DUMPER).c \ $(PEEK).c \ - $(B).c + $(B).c \ + $(BYTELOADER).c EXTENSION_DLL = \ $(SOCKET_DLL) \ @@ -567,7 +570,8 @@ EXTENSION_DLL = \ $(ATTRS_DLL) \ $(DUMPER_DLL) \ $(PEEK_DLL) \ - $(B_DLL) + $(B_DLL) \ + $(BYTELOADER_DLL) EXTENSION_PM = \ $(ERRNO_PM) @@ -857,6 +861,12 @@ $(SOCKET_DLL): $(PERLEXE) $(SOCKET).xs $(MAKE) cd ..\..\win32 +$(BYTELOADER_DLL): $(PERLEXE) $(BYTELOADER).xs + cd $(EXTDIR)\$(*B) + ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl + $(MAKE) + cd ..\..\win32 + $(ERRNO_PM): $(PERLEXE) $(ERRNO)_pm.PL cd $(EXTDIR)\$(*B) ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl @@ -889,7 +899,7 @@ distclean: clean -del /f $(LIBDIR)\ops.pm $(LIBDIR)\Safe.pm $(LIBDIR)\Thread.pm -del /f $(LIBDIR)\SDBM_File.pm $(LIBDIR)\Socket.pm $(LIBDIR)\POSIX.pm -del /f $(LIBDIR)\B.pm $(LIBDIR)\O.pm $(LIBDIR)\re.pm - -del /f $(LIBDIR)\Data\Dumper.pm + -del /f $(LIBDIR)\Data\Dumper.pm $(LIBDIR)\ByteLoader.pm -del /f $(LIBDIR)\Devel\Peek.pm -rmdir /s /q $(LIBDIR)\IO || rmdir /s $(LIBDIR)\IO -rmdir /s /q $(LIBDIR)\Thread || rmdir /s $(LIBDIR)\Thread diff --git a/win32/config.vc b/win32/config.vc index cf4799baa4..ea86e5f530 100644 --- a/win32/config.vc +++ b/win32/config.vc @@ -82,7 +82,7 @@ d_bsd='define' d_bsdgetpgrp='undef' d_bsdsetpgrp='undef' d_bzero='undef' -d_casti32='define' +d_casti32='undef' d_castneg='define' d_charvspr='undef' d_chown='undef' diff --git a/win32/config_H.vc b/win32/config_H.vc index aab6935aca..432e95d95d 100644 --- a/win32/config_H.vc +++ b/win32/config_H.vc @@ -1091,7 +1091,7 @@ * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. */ -#define CASTI32 /**/ +/*#define CASTI32 /**/ /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative diff --git a/win32/makedef.pl b/win32/makedef.pl index 0a753fbfe1..f13c1da0a7 100644 --- a/win32/makedef.pl +++ b/win32/makedef.pl @@ -462,6 +462,7 @@ win32_telldir win32_seekdir win32_rewinddir win32_closedir +win32_longpath Perl_win32_init Perl_init_os_extras Perl_getTHR diff --git a/win32/makefile.mk b/win32/makefile.mk index 32056a9d33..bee351ce03 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -624,7 +624,7 @@ SETARGV_OBJ = setargv$(o) .ENDIF DYNAMIC_EXT = Socket IO Fcntl Opcode SDBM_File POSIX attrs Thread B re \ - Data/Dumper Devel/Peek + Data/Dumper Devel/Peek ByteLoader STATIC_EXT = DynaLoader NONXS_EXT = Errno @@ -642,6 +642,7 @@ RE = $(EXTDIR)\re\re DUMPER = $(EXTDIR)\Data\Dumper\Dumper ERRNO = $(EXTDIR)\Errno\Errno PEEK = $(EXTDIR)\Devel\Peek\Peek +BYTELOADER = $(EXTDIR)\ByteLoader SOCKET_DLL = $(AUTODIR)\Socket\Socket.dll FCNTL_DLL = $(AUTODIR)\Fcntl\Fcntl.dll @@ -655,6 +656,7 @@ B_DLL = $(AUTODIR)\B\B.dll DUMPER_DLL = $(AUTODIR)\Data\Dumper\Dumper.dll PEEK_DLL = $(AUTODIR)\Devel\Peek\Peek.dll RE_DLL = $(AUTODIR)\re\re.dll +BYTELOADER_DLL = $(AUTODIR)\ByteLoader\ByteLoader.dll ERRNO_PM = $(LIBDIR)\Errno.pm @@ -670,7 +672,8 @@ EXTENSION_C = \ $(RE).c \ $(DUMPER).c \ $(PEEK).c \ - $(B).c + $(B).c \ + $(BYTELOADER).c EXTENSION_DLL = \ $(SOCKET_DLL) \ @@ -682,7 +685,8 @@ EXTENSION_DLL = \ $(ATTRS_DLL) \ $(DUMPER_DLL) \ $(PEEK_DLL) \ - $(B_DLL) + $(B_DLL) \ + $(BYTELOADER_DLL) EXTENSION_PM = \ $(ERRNO_PM) @@ -1024,6 +1028,11 @@ $(SOCKET_DLL): $(PERLEXE) $(SOCKET).xs ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\$(*B) && $(MAKE) +$(BYTELOADER_DLL): $(PERLEXE) $(BYTELOADER).xs + cd $(EXTDIR)\$(*B) && \ + ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl + cd $(EXTDIR)\$(*B) && $(MAKE) + $(ERRNO_PM): $(PERLEXE) $(ERRNO)_pm.PL cd $(EXTDIR)\$(*B) && \ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl @@ -1052,7 +1061,7 @@ distclean: clean -del /f $(LIBDIR)\ops.pm $(LIBDIR)\Safe.pm $(LIBDIR)\Thread.pm -del /f $(LIBDIR)\SDBM_File.pm $(LIBDIR)\Socket.pm $(LIBDIR)\POSIX.pm -del /f $(LIBDIR)\B.pm $(LIBDIR)\O.pm $(LIBDIR)\re.pm - -del /f $(LIBDIR)\Data\Dumper.pm + -del /f $(LIBDIR)\Data\Dumper.pm $(LIBDIR)\ByteLoader.pm -del /f $(LIBDIR)\Devel\Peek.pm -rmdir /s /q $(LIBDIR)\IO || rmdir /s $(LIBDIR)\IO -rmdir /s /q $(LIBDIR)\Thread || rmdir /s $(LIBDIR)\Thread diff --git a/win32/runperl.c b/win32/runperl.c index 8cf521d4ea..1b569d2557 100644 --- a/win32/runperl.c +++ b/win32/runperl.c @@ -41,8 +41,10 @@ main(int argc, char **argv, char **env) * want to free() argv after main() returns. As luck would have it, * Borland's CRT does the right thing to argv[0] already. */ char szModuleName[MAX_PATH]; + char *ptr; GetModuleFileName(NULL, szModuleName, sizeof(szModuleName)); + (void)win32_longpath(szModuleName); argv[0] = szModuleName; #endif @@ -87,7 +89,10 @@ main(int argc, char **argv, char **env) * want to free() argv after main() returns. As luck would have it, * Borland's CRT does the right thing to argv[0] already. */ char szModuleName[MAX_PATH]; + char *ptr; + GetModuleFileName(NULL, szModuleName, sizeof(szModuleName)); + (void)win32_longpath(szModuleName); argv[0] = szModuleName; #endif return RunPerl(argc, argv, env, (void*)0); diff --git a/win32/win32.c b/win32/win32.c index 1848e9ba27..414e4c5dfc 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -100,6 +100,7 @@ static long find_pid(int pid); static char * qualified_path(const char *cmd); HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE; +char w32_module_name[MAX_PATH+1]; static DWORD w32_platform = (DWORD)-1; #ifdef USE_THREADS @@ -192,19 +193,39 @@ get_emd_part(char *prev_path, char *trailing_path, ...) sprintf(base, "%5.3f", (double)PERL_REVISION + ((double)PERL_VERSION / (double)1000)); - GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE) - ? GetModuleHandle(NULL) : w32_perldll_handle), - mod_name, sizeof(mod_name)); - ptr = strrchr(mod_name, '\\'); + if (!*w32_module_name) { + GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE) + ? GetModuleHandle(NULL) + : w32_perldll_handle), + w32_module_name, sizeof(w32_module_name)); + + /* try to get full path to binary (which may be mangled when perl is + * run from a 16-bit app) */ + /*PerlIO_printf(PerlIO_stderr(), "Before %s\n", w32_module_name);*/ + (void)win32_longpath(w32_module_name); + /*PerlIO_printf(PerlIO_stderr(), "After %s\n", w32_module_name);*/ + + /* normalize to forward slashes */ + ptr = w32_module_name; + while (*ptr) { + if (*ptr == '\\') + *ptr = '/'; + ++ptr; + } + } + strcpy(mod_name, w32_module_name); + ptr = strrchr(mod_name, '/'); while (ptr && strip) { /* look for directories to skip back */ optr = ptr; *ptr = '\0'; - ptr = strrchr(mod_name, '\\'); + ptr = strrchr(mod_name, '/'); if (!ptr || stricmp(ptr+1, strip) != 0) { - if(!(*strip == '5' && *(ptr+1) == '5' && strncmp(strip, base, 5) == 0 - && strncmp(ptr+1, base, 5) == 0)) { - *optr = '\\'; + if(!(*strip == '5' && *(ptr+1) == '5' + && strncmp(strip, base, 5) == 0 + && strncmp(ptr+1, base, 5) == 0)) + { + *optr = '/'; ptr = optr; } } @@ -213,7 +234,7 @@ get_emd_part(char *prev_path, char *trailing_path, ...) if (!ptr) { ptr = mod_name; *ptr++ = '.'; - *ptr = '\\'; + *ptr = '/'; } va_end(ap); strcpy(++ptr, trailing_path); @@ -273,7 +294,7 @@ win32_get_sitelib(char *pl) /* $sitelib .= * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/site/$]/lib"; */ - sprintf(pathstr, "site\\%s\\lib", pl); + sprintf(pathstr, "site/%s/lib", pl); path1 = get_emd_part(path1, pathstr, ARCHNAME, "bin", pl, Nullch); /* $HKCU{'sitelib'} || $HKLM{'sitelib'} . ---; */ @@ -281,7 +302,7 @@ win32_get_sitelib(char *pl) /* $sitelib .= * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/site/lib"; */ - path2 = get_emd_part(path2, "site\\lib", ARCHNAME, "bin", pl, Nullch); + path2 = get_emd_part(path2, "site/lib", ARCHNAME, "bin", pl, Nullch); if (!path1) return path2; @@ -365,8 +386,7 @@ my_popen(char *cmd, char *mode) #define fixcmd(x) #endif fixcmd(cmd); - win32_fflush(stdout); - win32_fflush(stderr); + PERL_FLUSHALL_FOR_CHILD; return win32_popen(cmd, mode); } @@ -968,6 +988,83 @@ win32_stat(const char *path, struct stat *buffer) return res; } +/* Find the longname of a given path. path is destructively modified. + * It should have space for at least MAX_PATH characters. */ +DllExport char * +win32_longpath(char *path) +{ + WIN32_FIND_DATA fdata; + HANDLE fhand; + char tmpbuf[MAX_PATH+1]; + char *tmpstart = tmpbuf; + char *start = path; + char sep; + if (!path) + return Nullch; + + /* drive prefix */ + if (isALPHA(path[0]) && path[1] == ':' && + (path[2] == '/' || path[2] == '\\')) + { + start = path + 2; + *tmpstart++ = path[0]; + *tmpstart++ = ':'; + } + /* UNC prefix */ + else if ((path[0] == '/' || path[0] == '\\') && + (path[1] == '/' || path[1] == '\\')) + { + start = path + 2; + *tmpstart++ = '/'; + *tmpstart++ = '/'; + /* copy machine name */ + while (*start && *start != '/' && *start != '\\') + *tmpstart++ = *start++; + if (*start) { + *tmpstart++ = '/'; + start++; + /* copy share name */ + while (*start && *start != '/' && *start != '\\') + *tmpstart++ = *start++; + } + } + sep = *start++; + if (sep == '/' || sep == '\\') + *tmpstart++ = '/'; + *tmpstart = '\0'; + while (sep) { + /* walk up to slash */ + while (*start && *start != '/' && *start != '\\') + ++start; + + /* discard doubled slashes */ + while (*start && (start[1] == '/' || start[1] == '\\')) + ++start; + sep = *start; + + /* stop and find full name of component */ + *start = '\0'; + fhand = FindFirstFile(path,&fdata); + if (fhand != INVALID_HANDLE_VALUE) { + strcpy(tmpstart, fdata.cFileName); + tmpstart += strlen(fdata.cFileName); + if (sep) + *tmpstart++ = '/'; + *tmpstart = '\0'; + *start++ = sep; + FindClose(fhand); + } + else { + /* failed a step, just return without side effects */ + /*PerlIO_printf(PerlIO_stderr(), "Failed to find %s\n", path);*/ + *start = sep; + return Nullch; + } + } + strcpy(path,tmpbuf); + return path; +} + #ifndef USE_WIN32_RTL_ENV DllExport char * @@ -2832,6 +2929,29 @@ XS(w32_GetFullPathName) } static +XS(w32_GetLongPathName) +{ + dXSARGS; + SV *path; + char tmpbuf[MAX_PATH+1]; + char *pathstr; + STRLEN len; + + if (items != 1) + croak("usage: Win32::GetLongPathName($pathname)"); + + path = ST(0); + pathstr = SvPV(path,len); + strcpy(tmpbuf, pathstr); + pathstr = win32_longpath(tmpbuf); + if (pathstr) { + ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr))); + XSRETURN(1); + } + XSRETURN_EMPTY; +} + +static XS(w32_Sleep) { dXSARGS; @@ -2841,6 +2961,17 @@ XS(w32_Sleep) XSRETURN_YES; } +static +XS(w32_CopyFile) +{ + dXSARGS; + if (items != 3) + croak("usage: Win32::CopyFile($from, $to, $overwrite)"); + if (CopyFile(SvPV_nolen(ST(0)), SvPV_nolen(ST(1)), !SvTRUE(ST(2)))) + XSRETURN_YES; + XSRETURN_NO; +} + void Perl_init_os_extras() { @@ -2871,6 +3002,8 @@ Perl_init_os_extras() newXS("Win32::GetTickCount", w32_GetTickCount, file); newXS("Win32::GetShortPathName", w32_GetShortPathName, file); newXS("Win32::GetFullPathName", w32_GetFullPathName, file); + newXS("Win32::GetLongPathName", w32_GetLongPathName, file); + newXS("Win32::CopyFile", w32_CopyFile, file); newXS("Win32::Sleep", w32_Sleep, file); /* XXX Bloat Alert! The following Activeware preloads really diff --git a/win32/win32iop.h b/win32/win32iop.h index a0649b1623..bcdc304511 100644 --- a/win32/win32iop.h +++ b/win32/win32iop.h @@ -122,6 +122,7 @@ DllExport unsigned win32_sleep(unsigned int); DllExport int win32_times(struct tms *timebuf); DllExport unsigned win32_alarm(unsigned int sec); DllExport int win32_stat(const char *path, struct stat *buf); +DllExport char* win32_longpath(char *path); DllExport int win32_ioctl(int i, unsigned int u, char *data); DllExport int win32_utime(const char *f, struct utimbuf *t); DllExport int win32_uname(struct utsname *n); @@ -207,6 +208,7 @@ END_EXTERN_C #define abort() win32_abort() #define fstat(fd,bufptr) win32_fstat(fd,bufptr) #define stat(pth,bufptr) win32_stat(pth,bufptr) +#define longpath(pth) win32_longpath(pth) #define rename(old,new) win32_rename(old,new) #define setmode(fd,mode) win32_setmode(fd,mode) #define lseek(fd,offset,orig) win32_lseek(fd,offset,orig) |