diff options
| author | Jarkko Hietaniemi <jhi@iki.fi> | 1998-12-01 11:08:16 +0000 |
|---|---|---|
| committer | Jarkko Hietaniemi <jhi@iki.fi> | 1998-12-01 11:08:16 +0000 |
| commit | 0fbecbbf53e77b8d40c396f3fae3f94dd3efd35d (patch) | |
| tree | afc655e6b661d80a249fda0bbb8c2850231870d9 | |
| parent | c7404c214c8382be08fc3c8ba7390a940642c871 (diff) | |
| parent | db4a4bfef3d0670c19c876489f6c14478d1740b8 (diff) | |
| download | perl-0fbecbbf53e77b8d40c396f3fae3f94dd3efd35d.tar.gz | |
Integrate from _54 mainperl modulo the NetBSD ifdef in util.c.
p4raw-id: //depot/cfgperl@2428
101 files changed, 8884 insertions, 557 deletions
@@ -79,6 +79,937 @@ Version 5.005_54 Development release working toward 5.006 ---------------- ____________________________________________________________________________ +[ 2405] By: gsar on 1998/11/30 00:28:55 + Log: patchlevel up to 54 + Branch: perl + ! patchlevel.h win32/Makefile win32/config_H.bc + ! win32/config_H.gc win32/config_H.vc win32/makefile.mk +____________________________________________________________________________ +[ 2403] By: gsar on 1998/11/29 23:35:50 + Log: integrate cfgperl changes into mainline + Branch: perl + !> Configure Porting/Glossary Porting/config.sh Porting/config_H + !> config_h.SH pod/perlfunc.pod t/op/grent.t t/op/pwent.t util.c +____________________________________________________________________________ +[ 2402] By: gsar on 1998/11/29 23:08:42 + Log: sync Text::Wrap version number + Branch: perl + ! lib/Text/Wrap.pm +____________________________________________________________________________ +[ 2401] By: gsar on 1998/11/29 22:56:21 + Log: textfill.t tweak + Branch: perl + ! t/lib/textfill.t +____________________________________________________________________________ +[ 2400] By: gsar on 1998/11/29 22:50:41 + Log: update to Text::Wrap 98.112901 from David Muir Sharnoff + <muir@idiom.com> + Branch: perl + + t/lib/textfill.t + ! MANIFEST lib/Text/Wrap.pm +____________________________________________________________________________ +[ 2399] By: gsar on 1998/11/29 22:28:05 + Log: updated to Text::Wrap 98.112801 from CPAN; one published change + has happened without the authors knowledge or consent; the subversive + version (which is in 5.00502) breaks one of the tests in the + authors testsuite; attempts are being made to find a fix that + avoids breaking code already running with the 5.005_02 version + From: David Muir Sharnoff <muir@idiom.com> + Date: Sat, 28 Nov 1998 04:34:17 PST + Message-Id: <199811281234.EAA03082@idiom.com> + Subject: Updated Text::Wrap, Time::ParseDate, File::Flock + Branch: perl + ! lib/Text/Wrap.pm t/lib/textwrap.t +____________________________________________________________________________ +[ 2397] By: nick on 1998/11/29 20:13:58 + Log: Update docs and English.pm for $^C + Branch: perl + ! lib/English.pm pod/perlvar.pod +____________________________________________________________________________ +[ 2396] By: jhi on 1998/11/29 20:13:03 + Log: Mirror #2384. + Branch: cfgperl + ! t/op/pwent.t +____________________________________________________________________________ +[ 2395] By: jhi on 1998/11/29 19:59:12 + Log: Newer NetBSDs don't have NSIG in <sys/signal.h>, they need <signal.h>. + Branch: cfgperl + ! util.c +____________________________________________________________________________ +[ 2394] By: gsar on 1998/11/29 19:49:08 + Log: updated perlreftut.pod + Branch: perl + ! pod/perlreftut.pod +____________________________________________________________________________ +[ 2393] By: gsar on 1998/11/29 19:31:56 + Log: misc tweaks + Branch: perl + ! ext/IO/Makefile.PL lib/Test.pm t/lib/io_poll.t t/op/sort.t +____________________________________________________________________________ +[ 2392] By: gsar on 1998/11/29 19:31:18 + Log: notes about -DPERL_POLLUTE + Branch: perl + ! INSTALL pod/perldelta.pod win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 2391] By: gsar on 1998/11/29 19:13:52 + Log: explain various win32 build caveats more clearly + Branch: perl + ! README.win32 win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 2390] By: gsar on 1998/11/29 16:51:59 + Log: remove I_POLL detection (Configure will do that now) + Branch: perl + ! ext/IO/Makefile.PL +____________________________________________________________________________ +[ 2389] By: jhi on 1998/11/29 16:39:16 + Log: Add I_POLL for IO 1.20. + Branch: cfgperl + ! Configure Porting/Glossary Porting/config.sh Porting/config_H + ! config_h.SH +____________________________________________________________________________ +[ 2388] By: gsar on 1998/11/29 16:23:30 + Log: add p4desc (augments 'p4 describe' output with diffs for new files) + Branch: perl + + Porting/p4desc + ! MANIFEST +____________________________________________________________________________ +[ 2387] By: gsar on 1998/11/29 16:08:03 + Log: another threads reliability fix: serialize writes to thr->threadsv + avoid most uses of PL_na (which is much more inefficient than a + simple local); update docs to suit; PL_na now being thr->Tna may + be a minor compatibility issue for extensions--will require dTHR + outside of XSUBs (those get automatic dTHR) + Branch: perl + ! XSUB.h djgpp/djgpp.c doio.c doop.c dump.c ext/B/B.xs + ! ext/DB_File/DB_File.xs ext/DynaLoader/dl_next.xs + ! ext/Opcode/Opcode.xs ext/POSIX/POSIX.xs ext/Thread/Thread.xs + ! ext/attrs/attrs.xs gv.c malloc.c mg.c op.c + ! os2/OS2/REXX/REXX.xs os2/os2.c perl.c perly.c perly.y + ! pod/perlcall.pod pod/perlembed.pod pod/perlguts.pod + ! pod/perlxs.pod pp.c pp.h pp_ctl.c pp_hot.c pp_sys.c run.c sv.c + ! t/op/pwent.t taint.c toke.c universal.c vmesa/vmesa.c + ! vms/ext/Stdio/Stdio.xs vms/perly_c.vms vms/vms.c win32/win32.c +____________________________________________________________________________ +[ 2386] By: jhi on 1998/11/29 15:40:42 + Log: Tune the "if" entry. + Branch: cfgperl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 2385] By: gsar on 1998/11/29 12:40:28 + Log: various fixes for race conditions under threads: mutex locks based + on PL_threadnum were seriously flawed, since it means more than one + thread could enter the critical region; PL_na was global instead of + thread-local; child thread could finish and free thr structures + before Thread->new() got around to creating the Thread object; + cv_clone() needed locking, as it mucks with PL_comppad and other + global data; new_struct_thread() needed to lock template-thread's + mutex while copying its data + Branch: perl + ! embedvar.h ext/Thread/Thread.xs gv.c op.c perl.c perlvars.h + ! pp_hot.c thrdvar.h thread.h util.c win32/win32thread.c +____________________________________________________________________________ +[ 2384] By: gsar on 1998/11/29 10:54:38 + Log: s/warn/print/ on multiply defined groups + Branch: perl + ! t/op/grent.t +____________________________________________________________________________ +[ 2383] By: gsar on 1998/11/29 10:48:39 + Log: backout change#2334 + Branch: perl + ! pod/perlfunc.pod pp_hot.c sv.c thrdvar.h +____________________________________________________________________________ +[ 2382] By: jhi on 1998/11/29 10:33:40 + Log: Better NetInfo behaviour. + Branch: cfgperl + ! t/op/grent.t t/op/pwent.t +____________________________________________________________________________ +[ 2381] By: jhi on 1998/11/29 10:08:15 + Log: Integrate from mainperl. + Branch: cfgperl + +> ext/IO/ChangeLog ext/IO/lib/IO/Dir.pm ext/IO/lib/IO/Poll.pm + +> ext/IO/lib/IO/Socket/INET.pm ext/IO/lib/IO/Socket/UNIX.pm + +> ext/IO/poll.c ext/IO/poll.h pod/perlreftut.pod + +> t/lib/io_const.t t/lib/io_dir.t t/lib/io_multihomed.t + +> t/lib/io_poll.t t/lib/io_unix.t + !> (integrate 58 files) +____________________________________________________________________________ +[ 2380] By: gsar on 1998/11/29 08:22:49 + Log: prefer IO::Handle for IO if FileHandle:: is empty (as suggested by + Tim Bunce) + Branch: perl + ! gv.c +____________________________________________________________________________ +[ 2379] By: gsar on 1998/11/29 07:06:43 + Log: fix for pat.t failure under USE_THREADS + Branch: perl + ! pp_ctl.c regexec.c +____________________________________________________________________________ +[ 2378] By: nick on 1998/11/28 22:46:57 + Log: More C.pm tweaks + Save globs even if we have saved cv itself before - may be imported. + + While we don't save "bootstrap" CV we need to provide a stub, + so that if we require it later we don't fall through and attempt + to DynaLoad module again. + + Attempt to save %INC so that "require" does not reload things + we have compiled-in (does not work right yet - seems to be due + to PL_incgv being created in perl_parse() current scheme setting + GvHV() is "better" than saving the glob, but still does not + work as I expect). + Branch: perl + ! ext/B/B/C.pm +____________________________________________________________________________ +[ 2377] By: gsar on 1998/11/28 22:30:38 + Log: various tweaks; result passes all tests for normal build on Solaris; + fails two pat.t tests under USE_THREADS; io_poll.t test#3 fails on + win32 due to lack of select() that works on non-socket fds + Branch: perl + ! ext/IO/poll.c regcomp.c regexec.c scope.c + ! t/lib/io_multihomed.t win32/makefile.mk +____________________________________________________________________________ +[ 2376] By: gsar on 1998/11/28 20:44:39 + Log: add $config_args to perl -V display (suggested by Ilya Zakharevich) + Branch: perl + ! myconfig +____________________________________________________________________________ +[ 2375] By: gsar on 1998/11/28 20:42:58 + Log: integrate cfgperl changes into mainline + Branch: perl + !> Configure ext/POSIX/hints/dynixptx.pl myconfig t/op/grent.t + !> t/op/pwent.t t/op/undef.t t/pragma/locale.t util.c +____________________________________________________________________________ +[ 2374] By: gsar on 1998/11/28 20:02:03 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Thu, 5 Nov 1998 02:21:12 -0500 (EST) + Message-Id: <199811050721.CAA27998@monk.mps.ohio-state.edu> + Subject: [PATCH 5.00553] Yet another OS/2 patch + Branch: perl + ! os2/Changes os2/Makefile.SHs os2/os2.c t/pragma/warn/op +____________________________________________________________________________ +[ 2373] By: gsar on 1998/11/28 19:30:06 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Sat, 28 Nov 1998 01:51:56 -0500 (EST) + Message-Id: <199811280651.BAA18095@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_53] Change $#+ + Branch: perl + ! mg.c pod/perlvar.pod t/op/pat.t +____________________________________________________________________________ +[ 2372] By: gsar on 1998/11/28 19:28:00 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Sat, 28 Nov 1998 00:33:17 -0500 (EST) + Message-Id: <199811280533.AAA25654@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_53] Finishing off SNOBOL: $1 in (?{}) + Branch: perl + ! embedvar.h mg.c objXSUB.h perl.c regexec.c t/op/pat.t + ! thrdvar.h +____________________________________________________________________________ +[ 2371] By: gsar on 1998/11/28 19:23:53 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Fri, 27 Nov 1998 16:16:48 -0500 (EST) + Message-Id: <199811272116.QAA03502@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_53] better -Mre=debugcolor + Branch: perl + ! embedvar.h objXSUB.h regexec.c thrdvar.h +____________________________________________________________________________ +[ 2370] By: gsar on 1998/11/28 19:21:17 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Fri, 27 Nov 1998 15:22:19 -0500 (EST) + Message-Id: <199811272022.PAA17874@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_*] regcolors + Branch: perl + ! embed.h global.sym objXSUB.h proto.h regcomp.c regexec.c +____________________________________________________________________________ +[ 2369] By: gsar on 1998/11/28 19:00:15 + Log: allow final period in a file (not followed by a newline) to + terminate format spec + Branch: perl + ! toke.c +____________________________________________________________________________ +[ 2368] By: gsar on 1998/11/28 18:58:25 + Log: Liblist tweak suggested by Swen Thuemmler <Swen.Thuemmler@paderlinx.de>; + add C<$Config{installarchlib}/CORE> to the default locations searched + on win32 + Branch: perl + ! lib/ExtUtils/Liblist.pm +____________________________________________________________________________ +[ 2367] By: gsar on 1998/11/28 18:46:05 + Log: applied suggested patch with PERL_OBJECT tweaks + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Thu, 26 Nov 1998 02:46:20 -0500 (EST) + Message-Id: <199811260746.CAA23164@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_53] Enable $_ and pos() inside (?{ CODE }) in RExen + Branch: perl + ! embed.h embed.pl embedvar.h objXSUB.h pp_ctl.c proto.h + ! regexec.c t/op/pat.t thrdvar.h +____________________________________________________________________________ +[ 2366] By: gsar on 1998/11/28 18:38:34 + Log: additional documentation for qr// + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Message-Id: <199811260751.CAA24560@monk.mps.ohio-state.edu> + Date: Thu, 26 Nov 1998 02:51:09 -0500 (EST) + Subject: [PATCH 5.005_*] Documentation (fwd) + Branch: perl + ! pod/perlfunc.pod pod/perlop.pod pod/perlpod.pod +____________________________________________________________________________ +[ 2365] By: gsar on 1998/11/28 18:35:35 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Wed, 25 Nov 1998 23:33:45 -0500 (EST) + Message-Id: <199811260433.XAA29281@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_*] Fix \G in REx without //g + Branch: perl + ! cop.h embedvar.h objXSUB.h pp.c pp_ctl.c pp_hot.c regexec.c + ! regexp.h t/op/pat.t thrdvar.h +____________________________________________________________________________ +[ 2364] By: gsar on 1998/11/28 18:24:20 + Log: update Test.pm to Test-1.12; tweak 're' detection + Branch: perl + ! lib/Test.pm +____________________________________________________________________________ +[ 2363] By: gsar on 1998/11/28 18:12:04 + Log: avoid command-line quoting portability problems in lex_assign.t + Branch: perl + ! t/op/lex_assign.t +____________________________________________________________________________ +[ 2362] By: gsar on 1998/11/28 18:08:50 + Log: From: John Tobey <jtobey@channel1.com> + Date: Thu, 19 Nov 1998 14:14:15 -0500 (EST) + Message-Id: <m0zgZWx-000FOgC@feynman.localnet> + Subject: PATCH: document English.pm sawampersand and thread issues + Branch: perl + ! lib/English.pm pod/perlvar.pod +____________________________________________________________________________ +[ 2361] By: gsar on 1998/11/28 18:03:04 + Log: fix uninitialized warnings + From: Brian Callaghan <callagh@itginc.com> + Date: Thu, 19 Nov 1998 17:49:10 -0800 + Message-Id: <3654CA96.B64FCAEB@itginc.com> + Subject: Complete.pm patch (version 1.1) + Branch: perl + ! lib/Term/Complete.pm +____________________________________________________________________________ +[ 2360] By: gsar on 1998/11/28 17:59:16 + Log: s/Array/List/ suggested by John Tobey + Branch: perl + ! pod/perldata.pod +____________________________________________________________________________ +[ 2359] By: gsar on 1998/11/28 17:47:48 + Log: update tie() entry in perlfunc to reflect TIEARRAY and TIEHANDLE + Branch: perl + ! lib/Tie/Handle.pm pod/perlfunc.pod +____________________________________________________________________________ +[ 2358] By: jhi on 1998/11/28 17:23:15 + Log: Revamp the locale tests. + (0) Instead of rewiring a few locales scan for them. + (1) Bogus test #101 removed. + (2) All the locales are checked, the lists of failed + and non-failed ones are displayed. + (3) The test #103 is again 'active' so that it may fail. + (4) To balance (3) a hopefully pacifying message is shown + if the #103 fails. + Branch: cfgperl + ! t/pragma/locale.t +____________________________________________________________________________ +[ 2357] By: gsar on 1998/11/28 17:21:07 + Log: add perlreftut.pod + Branch: perl + + pod/perlreftut.pod + ! MANIFEST pod/Makefile pod/buildtoc pod/perl.pod + ! pod/perlref.pod pod/roffitall vms/descrip_mms.template + ! win32/pod.mak +____________________________________________________________________________ +[ 2356] By: jhi on 1998/11/28 16:58:01 + Log: Change #2346 fallout. + Branch: cfgperl + ! t/op/undef.t +____________________________________________________________________________ +[ 2355] By: gsar on 1998/11/28 16:46:43 + Log: IO.xs tweaks; avoid coredump in io_xs.t; remove newCONSTSUB(); + ANSI prototypes + Branch: perl + ! ext/IO/IO.xs +____________________________________________________________________________ +[ 2354] By: gsar on 1998/11/28 16:08:07 + Log: add IO-1.20; mess with t/lib/io_*.t in an attempt to + keep platform hacks that aren't in the 1.20 dist; add new files + to MANIFEST; hack Makefile.PL; result hasn't been tested + anywhere + Branch: perl + + ext/IO/ChangeLog ext/IO/lib/IO/Dir.pm ext/IO/lib/IO/Poll.pm + + ext/IO/lib/IO/Socket/INET.pm ext/IO/lib/IO/Socket/UNIX.pm + + ext/IO/poll.c ext/IO/poll.h t/lib/io_const.t t/lib/io_dir.t + + t/lib/io_multihomed.t t/lib/io_poll.t t/lib/io_unix.t + ! MANIFEST ext/IO/IO.pm ext/IO/IO.xs ext/IO/Makefile.PL + ! ext/IO/README ext/IO/lib/IO/File.pm ext/IO/lib/IO/Handle.pm + ! ext/IO/lib/IO/Pipe.pm ext/IO/lib/IO/Seekable.pm + ! ext/IO/lib/IO/Select.pm ext/IO/lib/IO/Socket.pm + ! t/lib/io_sock.t t/lib/io_udp.t +____________________________________________________________________________ +[ 2353] By: jhi on 1998/11/28 15:51:03 + Log: Locale collation, ctype, and numeric, were initialized wrong + (if LC_ALL or LANG were unset, so were the collation/ctype/numeric), + as reported by + + From: Ilya.Sandler@etak.com (Ilya Sandler) + Subject: a bug in locale handling: LC_COLLATE ignored sometimes + To: perlbug@perl.com + Date: 25 Nov 1998 04:53:52 +0200 + Message-ID: <MLIST_199811250226.SAA12590@axi001.etak.sw> + Branch: cfgperl + ! util.c +____________________________________________________________________________ +[ 2352] By: nick on 1998/11/28 15:21:59 + Log: Implement $^C to allow perl access to -c flag - I think this + was agreed once... + Branch: perl + ! gv.c mg.c +____________________________________________________________________________ +[ 2351] By: jhi on 1998/11/28 15:14:24 + Log: Change #2251 fixup. + Branch: cfgperl + ! myconfig +____________________________________________________________________________ +[ 2350] By: jhi on 1998/11/28 14:58:19 + Log: Integrate from mainperl. + Branch: cfgperl + +> ext/Devel/Peek/Changes ext/Devel/Peek/Makefile.PL + +> ext/Devel/Peek/Peek.pm ext/Devel/Peek/Peek.xs + +> pod/perl5005delta.pod + !> (integrate 49 files) +____________________________________________________________________________ +[ 2349] By: jhi on 1998/11/28 14:27:36 + Log: Passwd and group file groveling. + Branch: cfgperl + ! t/op/grent.t t/op/pwent.t +____________________________________________________________________________ +[ 2348] By: gsar on 1998/11/28 14:09:50 + Log: more conservative version of changes#2345,2346,2347; those break + C<defined(@{"foo::ISA"})> which seems to be extensively used in + the libs :-( + Branch: perl + ! pp.c t/op/method.t +____________________________________________________________________________ +[ 2347] By: gsar on 1998/11/28 13:36:08 + Log: tweak bogus test + Branch: perl + ! t/op/method.t +____________________________________________________________________________ +[ 2346] By: gsar on 1998/11/28 13:20:34 + Log: test cases for previous change + Branch: perl + ! t/op/undef.t +____________________________________________________________________________ +[ 2345] By: gsar on 1998/11/28 13:07:17 + Log: fix typo in pp_defined() causing C<defined %tied> to fail + Branch: perl + ! pp.c +____________________________________________________________________________ +[ 2344] By: gsar on 1998/11/28 13:03:29 + Log: s/comment/comment_t/ tweak (suggested by John Gorman + <jgorman@webbysoft.com>) + Branch: perl + ! ext/B/B/Assembler.pm ext/B/B/Disassembler.pm +____________________________________________________________________________ +[ 2343] By: gsar on 1998/11/28 12:52:40 + Log: add (stub) perldelta.pod + Branch: perl + + pod/perldelta.pod +____________________________________________________________________________ +[ 2342] By: gsar on 1998/11/28 12:49:26 + Log: rename perldelta.pod to perl5005delta.pod in preparation for + starting a new one + Branch: perl + +> pod/perl5005delta.pod + - pod/perldelta.pod + ! MANIFEST pod/perl.pod +____________________________________________________________________________ +[ 2341] By: gsar on 1998/11/28 12:41:55 + Log: fix MALLOC_LOCK #define + Branch: perl + ! malloc.c +____________________________________________________________________________ +[ 2340] By: gsar on 1998/11/28 12:18:23 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Sun, 15 Nov 1998 20:25:50 -0500 (EST) + Message-Id: <199811160125.UAA05268@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_53] OS/2 events get closer to Perl + Branch: perl + ! os2/Changes os2/os2.c os2/os2.sym os2/os2ish.h +____________________________________________________________________________ +[ 2339] By: jhi on 1998/11/28 11:59:01 + Log: Add -lm to dynix/ptx POSIX hints. + From: "Martin J. Bligh" <mbligh@sequent.com> + To: jhi@iki.fi + Subject: Re: Making Perl work on DYNIX/ptx + Date: Wed, 25 Nov 1998 10:34:41 -0800 + Message-ID: <1457015007.911990081@w-186d219.rhe.sequent.com> + Branch: cfgperl + ! ext/POSIX/hints/dynixptx.pl +____________________________________________________________________________ +[ 2338] By: jhi on 1998/11/28 11:57:19 + Log: Detypo. + Branch: cfgperl + ! lib/filetest.pm +____________________________________________________________________________ +[ 2337] By: jhi on 1998/11/28 11:56:29 + Log: Better LD_LIBRARY_PATH instructions for Bourneists. + Branch: cfgperl + ! Configure +____________________________________________________________________________ +[ 2336] By: gsar on 1998/11/28 11:41:14 + Log: teach CPAN.pm to ignore beta perl distributions when looking for + modules + From: root@dogberry.rutgers.edu (root) + Date: Thu, 12 Nov 1998 23:08:39 -0500 + Message-Id: <199811130408.XAA10578@dogberry.rutgers.edu> + Subject: recompile tries getting a perl distribution + Branch: perl + ! lib/CPAN.pm +____________________________________________________________________________ +[ 2335] By: gsar on 1998/11/28 11:27:46 + Log: make $1 et al readonly under threads; make C<undef $1> fail like + C<$1 = undef> does + Branch: perl + ! op.c pp.c t/op/undef.t +____________________________________________________________________________ +[ 2334] By: gsar on 1998/11/28 10:24:52 + Log: s/Regexp/re/ and clarify policy on lowercased object namespaces + Branch: perl + ! pod/perlfunc.pod pp_hot.c sv.c thrdvar.h +____________________________________________________________________________ +[ 2333] By: gsar on 1998/11/28 09:36:40 + Log: document changed PERL_HASH() + Branch: perl + ! pod/perlfunc.pod pod/perlguts.pod +____________________________________________________________________________ +[ 2332] By: nick on 1998/11/27 21:10:27 + Log: Handle INIT list in C.pm + 1. Provide init_av() from B.xs + 2. Export it in B.pm + 3. Use it in C.pm + Also disable some pruning in savecv() which seems to undo + my previous patch. + Experimental feature - save pathnames of .so files in easily + grep-able form for use in wrapper to feed to linker. + Branch: perl + ! ext/B/B.pm ext/B/B.xs ext/B/B/C.pm +____________________________________________________________________________ +[ 2327] By: gsar on 1998/11/27 15:12:01 + Log: integrate change#2315 from maint-5.005 + Branch: perl + ! t/op/sort.t + !> op.c sv.c +____________________________________________________________________________ +[ 2326] By: gsar on 1998/11/27 15:00:42 + Log: integrate changes#2304,2305,2306,2308 from maint-5.005 + Branch: perl + !> ext/DynaLoader/dl_mpeix.xs installperl lib/ExtUtils/MM_Unix.pm + !> lib/ExtUtils/MM_VMS.pm lib/ExtUtils/MakeMaker.pm + !> lib/ExtUtils/typemap +____________________________________________________________________________ +[ 2325] By: gsar on 1998/11/27 14:46:18 + Log: malloc bugfix and documentation from Ilya Zakharevich + Date: Tue, 24 Nov 1998 17:24:55 -0500 (EST) + Message-Id: <199811242224.RAA22618@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_*] Re: Internal coredump + -- + Date: Thu, 26 Nov 1998 03:06:10 -0500 (EST) + Message-Id: <199811260806.DAA28913@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_*] malloc.c documentation + Branch: perl + ! malloc.c +____________________________________________________________________________ +[ 2324] By: gsar on 1998/11/27 14:41:38 + Log: B::C tweaks to allow Tk compiles from Nick Ing-Simmons + Branch: perl + ! ext/B/B/C.pm +____________________________________________________________________________ +[ 2323] By: gsar on 1998/11/27 14:33:44 + Log: From: maeda@src.ricoh.co.jp + Date: Tue, 24 Nov 1998 10:37:45 +0900 + Message-Id: <199811240137.KAA05867@luna.src.ricoh.co.jp> + Subject: format "..." bug + Branch: perl + ! pp_ctl.c t/op/write.t +____________________________________________________________________________ +[ 2322] By: gsar on 1998/11/27 14:20:12 + Log: add ext/Devel/Peek + From: jan.dubois@ibm.net (Jan Dubois) + Date: Mon, 23 Nov 1998 00:48:11 +0100 + Message-ID: <36589ec9.49964585@smtp1.ibm.net> + Subject: [PATCH 5.005_53] Devel::Peek integration + Branch: perl + + ext/Devel/Peek/Changes ext/Devel/Peek/Makefile.PL + + ext/Devel/Peek/Peek.pm ext/Devel/Peek/Peek.xs + ! MANIFEST dump.c embed.h embedvar.h global.sym intrpvar.h + ! objXSUB.h perl.c perl.h proto.h sv.c sv.h thrdvar.h + ! win32/GenCAPI.pl win32/Makefile win32/makefile.mk +____________________________________________________________________________ +[ 2321] By: gsar on 1998/11/27 13:03:08 + Log: ensure 'make regen_headers' even without perl installed + (suggested by Ilya Zakharevich) + Branch: perl + ! bytecode.pl warning.pl +____________________________________________________________________________ +[ 2320] By: gsar on 1998/11/27 12:58:36 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Mon, 9 Nov 1998 19:03:25 -0500 (EST) + Message-Id: <199811100003.TAA05815@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_*] Cosmetic malloc patch + Branch: perl + ! malloc.c +____________________________________________________________________________ +[ 2319] By: gsar on 1998/11/27 12:56:13 + Log: eliminate dup hunk from integration + Branch: perl + ! lib/filetest.pm perl.h +____________________________________________________________________________ +[ 2318] By: gsar on 1998/11/27 12:50:08 + Log: integrate cfgperl changes into mainline + Branch: perl + +> ext/DB_File/hints/dynixptx.pl ext/POSIX/hints/dynixptx.pl + ! pod/perlfaq4.pod + !> (integrate 30 files) +____________________________________________________________________________ +[ 2317] By: jhi on 1998/11/27 11:38:13 + Log: C<-x>. + Branch: cfgperl + ! lib/filetest.pm +____________________________________________________________________________ +[ 2316] By: jhi on 1998/11/27 11:10:22 + Log: Integrate from mainperl. + Branch: cfgperl + !> XSUB.h embed.h embed.pl embedvar.h ext/Thread/Thread.xs + !> iperlsys.h mg.c objXSUB.h op.c pp_ctl.c pp_sys.c proto.h + !> t/comp/package.t t/lib/dumper.t t/pragma/warn/pp_ctl + !> universal.c util.c win32/GenCAPI.pl win32/win32.h + !> win32/win32sck.c +____________________________________________________________________________ +[ 2315] By: gbarr on 1998/11/27 05:16:50 + Log: integrate change#2246 from mainline, while still allowing + C<sort $globref @foo> + + allow C<sort $coderef @foo> + Branch: maint-5.005/perl + ! op.c sv.c + !> t/op/sort.t +____________________________________________________________________________ +[ 2308] By: gbarr on 1998/11/27 00:11:44 + Log: Updates for MPE/iX DynaLoader and installperl, via private mail + forwarded by Jarkko Hietaniemi from Mark Bixby + Branch: maint-5.005/perl + ! ext/DynaLoader/dl_mpeix.xs installperl +____________________________________________________________________________ +[ 2306] By: gbarr on 1998/11/26 23:44:47 + Log: Allow PL_FILES to have multiple targets from one source by allowing + an array ref as the value in the hash + Branch: maint-5.005/perl + ! lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MM_VMS.pm + ! lib/ExtUtils/MakeMaker.pm +____________________________________________________________________________ +[ 2305] By: gbarr on 1998/11/26 23:38:06 + Log: fix unsigned variables to use SvUV and sv_setuv + Branch: maint-5.005/perl + ! lib/ExtUtils/typemap +____________________________________________________________________________ +[ 2304] By: gbarr on 1998/11/26 23:36:17 + Log: Fix embeded \n in ABSTRACT and <> in AUTHOR + Branch: maint-5.005/perl + ! lib/ExtUtils/MM_Unix.pm +____________________________________________________________________________ +[ 2301] By: gsar on 1998/11/26 10:16:54 + Log: fix PL_defoutgv leak under threads + Branch: perl + ! ext/Thread/Thread.xs +____________________________________________________________________________ +[ 2300] By: gsar on 1998/11/26 09:04:44 + Log: properly free temporaries created by threads + Branch: perl + ! ext/Thread/Thread.xs +____________________________________________________________________________ +[ 2299] By: gsar on 1998/11/26 06:51:16 + Log: fix C<if (...) { package Foo; ... }> misoptimization that fails + to set the package for the block properly + Branch: perl + ! op.c t/comp/package.t t/lib/dumper.t +____________________________________________________________________________ +[ 2298] By: nick on 1998/11/24 22:04:20 + Log: Part-1 of tweaks to allow Tk to be "compiled" + Make XS_UNIVERSAL_xxx non-static so they can be found in libperl. + (May also need attention to exports etc. - to follow.) + Branch: perl + ! universal.c +____________________________________________________________________________ +[ 2294] By: jhi on 1998/11/23 10:44:26 + Log: The new socket tests need in some platforms + to #include <sys/types.h>. + Branch: cfgperl + ! Configure +____________________________________________________________________________ +[ 2293] By: jhi on 1998/11/23 10:33:42 + Log: From: Gerben Wierda <G.C.Th.Wierda@AWT.nl> + To: Jarkko Hietaniemi <jhi@cc.hut.fi> + Subject: Re: Test results for perl5.005_53 under NEXTSTEP 3.3 (intel) + Date: Mon, 23 Nov 1998 10:07:04 +0100 + Message-Id: <9811230907.AA06484@AWT.nl> + + NeXTstep NetInfo uses nidump to get the user/group databases. + Branch: cfgperl + ! t/op/grent.t t/op/pwent.t +____________________________________________________________________________ +[ 2291] By: TimBunce on 1998/11/22 22:23:09 + Log: Updated Porting/patchls utility. + Branch: maint-5.004/perl + ! Porting/patchls +____________________________________________________________________________ +[ 2288] By: TimBunce on 1998/11/22 21:46:11 + Log: Title: "Buglet in Sys::Syslog.pm (with fix)" + From: Henrik Tougaard <ht.000@foa.dk> + Msg-ID: <Pine.OSF.3.95.981117092651.1492C-100000@sula.pensam.dk> + Files: lib/Sys/Syslog.pm + Branch: maint-5.004/perl + ! lib/Sys/Syslog.pm +____________________________________________________________________________ +[ 2286] By: jhi on 1998/11/22 19:08:42 + Log: Change#2284 aid: allow also for plain old MSG_ and SCM_ #defines. + Branch: cfgperl + ! ext/Socket/Socket.xs +____________________________________________________________________________ +[ 2285] By: jhi on 1998/11/22 18:21:07 + Log: MSG_PROXY for GNU/Hurd (previously we believed that + all GNU libc platforms have MSG_PROXY. Untrue). + In fact this ended up as a major MSG_* and SCM_* + update. The MSG_XXX known to be enums in some + versions of the glibc are now probed for and respective + HAS_MSG_XXX are defined. While I was at it I noticed + SCM_RIGHTS being similarly an enum. This reminded me of + an ancient discussion in perl5-porters: + http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/9612/msg01017.html + The BSD socket interface has a nifty feature for passing + file descriptors and credentials--via sockets. It may be + too late to add this functionality to the CORE but + at least Configure now probes for the functions, + structs, and includes, defining the appropriate + HAS_YYY and I_ZZZ, and the Socket extension exports + the constants, in case somebody wants to write an + extension for this interface. + Branch: cfgperl + ! Configure Porting/Glossary Porting/config.sh Porting/config_H + ! config_h.SH ext/Socket/Socket.pm ext/Socket/Socket.xs + ! iperlsys.h +____________________________________________________________________________ +[ 2284] By: jhi on 1998/11/22 18:13:21 + Log: perlhist.pod 1.54, containing 5_53. + Branch: cfgperl + ! pod/perlhist.pod +____________________________________________________________________________ +[ 2274] By: TimBunce on 1998/11/22 16:25:46 + Log: Preserve errno around fcntl(fd,F_SETFD,fd > maxsysfd) in do_open() + Branch: maint-5.004/perl + ! doio.c +____________________________________________________________________________ +[ 2273] By: TimBunce on 1998/11/22 16:17:43 + Log: Improve op/die_exit.t test for implicit close changing $! + Branch: maint-5.004/perl + ! t/op/die_exit.t +____________________________________________________________________________ +[ 2268] By: jhi on 1998/11/22 14:44:11 + Log: Fix thinko. + Branch: cfgperl + ! hints/dynixptx.sh +____________________________________________________________________________ +[ 2267] By: jhi on 1998/11/22 13:19:41 + Log: Document the d_socket override. + Branch: cfgperl + ! hints/dynixptx.sh +____________________________________________________________________________ +[ 2266] By: jhi on 1998/11/22 12:12:29 + Log: From: John Tobey <jtobey@channel1.com> + Subject: [PATCH] perlfaq typos + To: perl5-porters@perl.com + Date: 22 Nov 1998 04:25:15 +0200 + Message-ID: <MLIST_m0zhPeF-000FOgC@feynman.localnet> + Branch: cfgperl + ! pod/perlfaq3.pod pod/perlfaq4.pod pod/perlfaq5.pod + ! pod/perlfaq7.pod pod/perlfaq8.pod +____________________________________________________________________________ +[ 2265] By: jhi on 1998/11/22 12:06:29 + Log: From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Subject: DB_File 1.61 patch for 5.005_53 & 5.005_02 + Newsgroups: hut.lists.perl5-porters + To: gsar@engin.umich.edu (Gurusamy Sarathy) + Cc: perl5-porters@perl.org (Perl5 Porters) + Date: 20 Nov 1998 12:20:41 +0200 + Branch: cfgperl + ! ext/DB_File/Changes ext/DB_File/DB_File.pm + ! ext/DB_File/DB_File.xs +____________________________________________________________________________ +[ 2264] By: jhi on 1998/11/22 11:55:09 + Log: NeXTstep /etc/group and /etc/passwd are used only at boot time, + From: Gerben Wierda <G.C.Th.Wierda@AWT.nl> + Subject: Test results for perl5.005_53 under NEXTSTEP 3.3 (intel) + To: perlbug@perl.com + Date: 20 Nov 1998 18:39:06 +0200 + Lines: 47 + Message-ID: <MLIST_9811201533.AA22148@AWT.nl> + Branch: cfgperl + ! t/op/grent.t t/op/pwent.t +____________________________________________________________________________ +[ 2263] By: jhi on 1998/11/22 11:42:59 + Log: Permission testing is tricky when we have too much power. + Problem reported in + From: Gerben Wierda <G.C.Th.Wierda@AWT.nl> + Subject: Test results for perl5.005_53 under NEXTSTEP 3.3 (intel) + To: perlbug@perl.com + Date: 20 Nov 1998 18:39:06 +0200 + Message-ID: <MLIST_9811201533.AA22148@AWT.nl> + Branch: cfgperl + ! t/op/filetest.t +____________________________________________________________________________ +[ 2262] By: gsar on 1998/11/22 11:37:02 + Log: fix broken CAPI generation + Branch: perl + ! win32/GenCAPI.pl +____________________________________________________________________________ +[ 2261] By: jhi on 1998/11/22 11:17:00 + Log: -x should be C<-x>, reported by Gerben Wierda. + Branch: cfgperl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 2260] By: gsar on 1998/11/22 11:12:02 + Log: phase 2 of PERL_OBJECT cleanup; objXSUB.h autogeneration + Branch: perl + ! XSUB.h embed.h embed.pl embedvar.h iperlsys.h objXSUB.h + ! proto.h +____________________________________________________________________________ +[ 2259] By: jhi on 1998/11/22 11:06:40 + Log: From: "Kurt D. Starsinic" <kstar@chapin.edu> + Subject: Re: [PATCH] Re: pod2man bug in date generated line + To: Albert Dvornik <bert@genscan.com>, "Larry W. Virden" <lvirden@cas.org> + Cc: perlbug@perl.com + Date: 20 Nov 1998 21:30:17 +0200 + Message-ID: <MLIST_19981120131523.A464@O2.chapin.edu> + Branch: cfgperl + ! pod/pod2man.PL +____________________________________________________________________________ +[ 2256] By: jhi on 1998/11/21 10:44:01 + Log: From: Thomas Bowditch <bowditch@inmet.com> + Subject: Benchmark.pm suggestion + To: jhi@iki.fi, Tim.Bunce@ig.co.uk + Date: Fri, 20 Nov 1998 17:43:46 -0500 + Message-Id: <199811202243.RAA26252@harp.camb.inmet.com> + + Added timesum(). + Branch: cfgperl + ! lib/Benchmark.pm +____________________________________________________________________________ +[ 2255] By: gsar on 1998/11/21 08:45:06 + Log: another win32 portability fix: make sysread() and syswrite() + work on sockets + Branch: perl + ! pp_sys.c win32/win32.h +____________________________________________________________________________ +[ 2254] By: gsar on 1998/11/21 07:49:06 + Log: win32_recvfrom() compatibility fix + Branch: perl + ! win32/win32sck.c +____________________________________________________________________________ +[ 2253] By: jhi on 1998/11/20 08:22:06 + Log: From: Mark Bixby <markb@spock.dis.cccd.edu> + To: jhi@iki.fi + Subject: MPE/iX Perl 5.005_02 oops + Date: Thu, 19 Nov 1998 17:10:45 -0800 (PST) + Message-Id: <199811200110.RAA07395@spock.dis.cccd.edu> + Branch: cfgperl + ! ext/DynaLoader/dl_mpeix.xs installperl +____________________________________________________________________________ +[ 2252] By: gsar on 1998/11/19 17:38:03 + Log: mess_sv tweak for change#2249 + Branch: perl + ! util.c +____________________________________________________________________________ +[ 2251] By: jhi on 1998/11/18 12:32:19 + Log: Display use64bits and usemultiplicity but only if necessary. + Branch: cfgperl + ! myconfig +____________________________________________________________________________ +[ 2250] By: jhi on 1998/11/18 12:26:50 + Log: From: Horst von Brand <vonbrand@sleipnir.valparaiso.cl> + Subject: pp.c uses 'unsigned Quad_t' + To: perlbug@perl.com + Date: Sun, 15 Nov 1998 20:57:05 -0300 + Message-Id: <199811152357.UAA12768@sleipnir.valparaiso.cl> + Branch: cfgperl + ! perl.h pp.c +____________________________________________________________________________ +[ 2249] By: gsar on 1998/11/18 05:43:11 + Log: use PL_mess_sv only during global destruction (fixes problems with + overlapping invocations of form()/warn()/die()/croak() trampling on + each other's messages) + Branch: perl + ! mg.c util.c +____________________________________________________________________________ +[ 2248] By: gsar on 1998/11/18 05:39:36 + Log: tweak change#2245 to skip previous message if any + Branch: perl + ! pp_ctl.c t/pragma/warn/pp_ctl +____________________________________________________________________________ +[ 2247] By: jhi on 1998/11/17 11:46:56 + Log: Integrate from mainperl. + Branch: cfgperl + !> (integrate 26 files) +____________________________________________________________________________ +[ 2246] By: gsar on 1998/11/17 09:41:10 + Log: allow C<sort $coderef @foo> + Branch: perl + ! op.c t/op/sort.t t/pragma/overload.t +____________________________________________________________________________ +[ 2245] By: gsar on 1998/11/17 08:28:26 + Log: propagate failures in DESTROY() as (optional) warnings + Branch: perl + ! pod/perldiag.pod pp_ctl.c t/pragma/warn/pp_ctl +____________________________________________________________________________ +[ 2244] By: gsar on 1998/11/17 07:43:08 + Log: ensure PL_dirty is reinit-ed properly under -DMULTIPLICITY + Branch: perl + ! perl.c thrdvar.h +____________________________________________________________________________ +[ 2243] By: gsar on 1998/11/17 07:40:09 + Log: sort WARN_FOO symbols to avoid hash traversal order dependency + Branch: perl + ! lib/warning.pm warning.h warning.pl +____________________________________________________________________________ +[ 2242] By: gsar on 1998/11/17 06:32:39 + Log: fix skipspace() to properly account for newlines in eval''-ed + strings (caused bogus line numbers in diagnostics and debugger) + Branch: perl + ! t/pragma/warn/pp_ctl t/pragma/warn/toke toke.c +____________________________________________________________________________ +[ 2241] By: gsar on 1998/11/17 03:48:12 + Log: s/Perl_utf8skip/PL_utf8skip/g + Branch: perl + ! embed.h embed.pl global.sym globvar.sym regexec.c utf8.h +____________________________________________________________________________ +[ 2240] By: gsar on 1998/11/14 06:09:06 + Log: rework op/groups.t + Branch: perl + ! t/op/filetest.t t/op/groups.t +____________________________________________________________________________ +[ 2235] By: gsar on 1998/11/14 00:17:05 + Log: catch a neophyte trap: open(<FH>), close(<FH>) etc. + Branch: perl + ! op.c +____________________________________________________________________________ +[ 2234] By: gsar on 1998/11/14 00:14:02 + Log: update Changes + Branch: perl + ! Changes win32/config.bc win32/config.gc win32/config.vc +____________________________________________________________________________ +[ 2233] By: gsar on 1998/11/13 09:43:03 + Log: doc tweak + Branch: perl + ! README.win32 +____________________________________________________________________________ [ 2230] By: jhi on 1998/11/12 17:07:45 Log: Allow hints file override for d_socket (based on Sequent-induced change #2229). @@ -26,6 +26,13 @@ For information on what's new in this release, see the pod/perldelta.pod file. For more detailed information about specific changes, see the Changes file. +IMPORTANT NOTE: 5.005_53 and later releases do not export unadorned +global symbols anymore. This means most CPAN modules probably won't +build under this release without adding '-DPERL_POLLUTE' to ccflags +in config.sh. This is not the default because we want the modules +to get fixed *before* the 5.006 release. pod/perldelta.pod contains +additional notes about this. + =head1 DESCRIPTION This document is written in pod format as an easy way to indicate its @@ -62,7 +69,8 @@ The standard extensions supplied with Perl will be handled automatically. In a related issue, old extensions may possibly be affected by the changes in the Perl language in the current release. Please see -pod/perldelta.pod for a description of what's changed. +pod/perldelta.pod (and pod/perl500Xdelta.pod) for a description of +what's changed. =head1 WARNING: This version requires a compiler that supports ANSI C. @@ -25,6 +25,7 @@ Porting/fixvars Find undeclared variables with C compiler and fix em Porting/genlog Generate formatted changelogs by querying p4d Porting/makerel Release making utility Porting/p4d2p Generate standard patches from p4 diffs +Porting/p4desc Smarter 'p4 describe', outputs diffs for new files Porting/patching.pod How to report changes made to Perl Porting/patchls Flexible patch file listing utility Porting/pumpkin.pod Guidelines and hints for Perl maintainers @@ -456,6 +457,34 @@ installman Perl script to install man pages for pods installperl Perl script to do "make install" dirty work intrpvar.h Variables held in each interpreter instance iperlsys.h Perl's interface to the system +jpl/JNI/Changes Java Native Interface changes +jpl/JNI/JNI.pm Java Native Interface module +jpl/JNI/JNI.xs Java Native Interface external subroutines +jpl/JNI/Makefile.PL Java Native Interface makefile generator +jpl/JNI/test.pl Java Native Interface tests +jpl/JNI/typemap Java/Perl interface typemap +jpl/JPL/AutoLoader.pm Java/Perl compiler module +jpl/JPL/Class.pm Java/Perl compiler module +jpl/JPL/Compile.pm Java/Perl compiler module +jpl/JPL/Makefile.PL Java/Perl makefile generator +jpl/JPL_Rolo/JPL_Rolo.jpl Rolodex sample application +jpl/JPL_Rolo/Makefile.PL Makefile generator +jpl/JPL_Rolo/README Instructions +jpl/JPL_Rolo/cardfile Rolodex sample application +jpl/PerlInterpreter/Makefile.PL Makefile generator +jpl/PerlInterpreter/PerlInterpreter.c Perl interpreter abstraction +jpl/PerlInterpreter/PerlInterpreter.h Perl interpreter abstraction +jpl/PerlInterpreter/PerlInterpreter.java Perl interpreter abstraction +jpl/README JPL instructions +jpl/Sample/Makefile.PL JPL sample makefile generator +jpl/Sample/Sample.jpl JPL sample +jpl/Test/Makefile.PL JPL tests makefile generator +jpl/Test/Test.jpl JPL tests +jpl/bin/jpl JPL compiler +jpl/get_jdk/README Instructions for using get_jdk.pl +jpl/get_jdk/get_jdk.pl JDK download tool +jpl/get_jdk/jdk_hosts JDK availability list +jpl/install-jpl JPL install utility keywords.h The keyword numbers keywords.pl Program to write keywords.h lib/AnyDBM_File.pm Perl module to emulate dbmopen @@ -1058,7 +1087,8 @@ t/lib/socket.t See if Socket works t/lib/soundex.t See if Soundex works t/lib/symbol.t See if Symbol works t/lib/texttabs.t See if Text::Tabs works -t/lib/textwrap.t See if Text::Wrap works +t/lib/textfill.t See if Text::Wrap::fill works +t/lib/textwrap.t See if Text::Wrap::wrap works t/lib/thread.t Basic test of threading (skipped if no threads) t/lib/tie-push.t Test for Tie::Array t/lib/tie-stdarray.t Test for Tie::StdArray diff --git a/Porting/p4desc b/Porting/p4desc new file mode 100755 index 0000000000..062a6f122b --- /dev/null +++ b/Porting/p4desc @@ -0,0 +1,106 @@ +#!/l/local/bin/perl -wpi.bak + +# +# Munge "p4 describe ..." output to include new files. +# +# Gurusamy Sarathy <gsar@umich.edu> +# + +use vars qw($thisfile $change $file $fnum $h $v $p4port @addfiles); + +BEGIN { + $0 =~ s|^.*/||; + $p4port = $ENV{P4PORT} || 'localhost:1666'; + for (@ARGV) { + if ($p4port =~ /^\s+$/) { + $p4port = $_; + } + elsif (/^-p(.*)$/) { + $p4port = $1 || ' '; + } + elsif (/^-v$/) { + $v++; + } + elsif (/^-h/) { + $h++; + } + else { + push @files, $_; + } + } + unless (@files) { @files = '-'; undef $^I; } + @ARGV = @files; + if ($h) { + print STDERR <<USAGE; +Usage: $0 [-p \$P4PORT] [-v] [-h] [files] + + -p host:port p4 port (e.g. myhost:1666) + -h print this help + -v output progress messages + +A smart 'cat'. When fed the spew from "p4 describe ..." on STDIN, +spits it right out on STDOUT, followed by patches for any new files +detected in the spew. Can also be used to edit insitu a bunch of +files containing said spew. + +WARNING: Currently only emits unified diffs. + +Examples: + p4 describe -du 123 | $0 > change-123.desc + p4 describe -du 123 | $0 | p4d2p > change-123.patch + +USAGE + exit(0); + } + $thisfile = ""; +} + + +if ($ARGV ne $thisfile) { + warn "processing patchfile [$ARGV]\n" unless $ARGV eq '-'; + $thisfile = $ARGV; +} + +my $cur = m|^Affected files| ... m|^Differences|; + +# while we are within range +if ($cur) { + if (m|^\.\.\. (//depot/.+?#\d+) add$|) { + my $newfile = $1; + push @addfiles, $newfile; + warn "$newfile add, revision != 1!\n" unless $newfile =~ /#1$/; + } + warn "file [$file] line [$cur] file# [$fnum]\n" if $v; +} + +if (/^Change (\d+) by/) { + $_ = "\n\n" . $_ if $change; # start of a new change list + $change = $1; + my $new = newfiles(); + if ($new) { + $_ = $new . $_; + } +} + +if (eof) { + $_ .= newfiles(); +} + +sub newfiles { + my $addfile; + my $ret = ""; + for $addfile (@addfiles) { + my @new = `p4 -p $p4port print $addfile`; + if ($?) { + die "$0: `p4 -p $p4port print $addfile` failed, status[$?]\n"; + } + my $desc = shift @new; # discard initial description + $ret .= "\n==== $addfile (text) ====\n\n"; + my $lines = "," . @new; + $lines = "" if @new < 2; + $ret .= "\@\@ -0,0 +1$lines \@\@\n"; + $ret .= join("+","",@new); + } + @addfiles = (); + return $ret; +} diff --git a/Porting/patchls b/Porting/patchls index 38c4dd1f47..8808c20431 100644 --- a/Porting/patchls +++ b/Porting/patchls @@ -17,7 +17,7 @@ use Text::Tabs qw(expand unexpand); use strict; use vars qw($VERSION); -$VERSION = 2.08; +$VERSION = 2.10; sub usage { die qq{ @@ -93,7 +93,7 @@ my %cat_title = ( 'UTIL' => 'UTILITIES', 'OTHER' => 'OTHER CHANGES', 'EXT' => 'EXTENSIONS', - 'UNKNOWN' => 'UNKNOWN - NO FILES PATCH', + 'UNKNOWN' => 'UNKNOWN - NO FILES PATCHED', ); @@ -131,7 +131,11 @@ sub get_meta_info { # Style 2: # --- perl5.004001/mg.c Sun Jun 08 12:26:24 1997 # +++ perl5.004-bc/mg.c Sun Jun 08 11:56:08 1997 -# @@ -656,9 +656,27 @@ +# @@ .. @@ +# or for deletions +# --- perl5.004001/mg.c Sun Jun 08 12:26:24 1997 +# +++ /dev/null Sun Jun 08 11:56:08 1997 +# @@ ... @@ # or (rcs, note the different date format) # --- 1.18 1997/05/23 19:22:04 # +++ ./pod/perlembed.pod 1997/06/03 21:41:38 @@ -145,12 +149,16 @@ my $in; my $ls; my $prevline = ''; my $prevtype = ''; -my (@removed, @added); +my (%removed, %added); my $prologue = 1; # assume prologue till patch or /^exit\b/ seen foreach my $argv (@ARGV) { $in = $argv; + if (-d $in) { + warn "Ignored directory $in\n"; + next; + } unless (open F, "<$in") { warn "Unable to open $in: $!\n"; next; @@ -163,8 +171,8 @@ foreach my $argv (@ARGV) { # not an interesting patch line # but possibly meta-information or prologue if ($prologue) { - push @added, $1 if /^touch\s+(\S+)/; - push @removed, $1 if /^rm\s+(?:-f)?\s*(\S+)/; + $added{$1} = 1 if /^touch\s+(\S+)/; + $removed{$1} = 1 if /^rm\s+(?:-f)?\s*(\S+)/; $prologue = 0 if /^exit\b/; } get_meta_info($ls, $_) if $::opt_m; @@ -182,7 +190,7 @@ foreach my $argv (@ARGV) { # to the file which describes the problem being fixed. if (/^Index:\s+(.*)/) { my $f; - foreach $f (split(/ /, $1)) { add_file($ls, $f) } + foreach $f (split(/ /, $1)) { add_patched_file($ls, $f) } next; } @@ -190,7 +198,13 @@ foreach my $argv (@ARGV) { or ($type eq '+++' and $prevtype eq '---') # Style 2 ) { if (/^[-+*]{3} (\S+)\s*(.*?\d\d:\d\d:\d\d)?/) { # double check - add_file($ls, $1); + if ($1 eq "/dev/null") { + $prevline =~ /^[-+*]{3} (\S+)\s*/; + add_deleted_file($ls, $1); + } + else { + add_patched_file($ls, $1); + } } else { warn "$in $.: parse error (prev $prevtype, type $type)\n$prevline$_"; @@ -226,7 +240,7 @@ foreach my $argv (@ARGV) { } # if we don't have a title for -m then use the file name - $ls->{Title}{$in}=1 if $::opt_m + $ls->{Title}{"Untitled: $in"}=1 if $::opt_m and !$ls->{Title} and $ls->{out}; $ls->{category} = $::opt_c @@ -263,16 +277,18 @@ if ($::opt_f) { # filter out patches based on -f <regexp> if ($::opt_4) { my $tail = ($::opt_5) ? "|| exit 1" : ""; - print map { "p4 delete $_$tail\n" } @removed if @removed; - print map { "p4 add $_$tail\n" } @added if @added; + print map { "p4 delete $_$tail\n" } sort keys %removed if %removed; + print map { "p4 add $_$tail\n" } sort keys %added if %added; my @patches = sort grep { $_->{is_in} } @ls; my @no_outs = grep { keys %{$_->{out}} == 0 } @patches; warn "Warning: Some files contain no patches:", join("\n\t", '', map { $_->{in} } @no_outs), "\n" if @no_outs; + my %patched = map { ($_, 1) } map { keys %{$_->{out}} } @patches; - delete @patched{@added}; + delete @patched{keys %added}; my @patched = sort keys %patched; foreach(@patched) { + next if $removed{$_}; my $edit = ($::opt_e && !-f $_) ? "add " : "edit"; print "p4 $edit $_$tail\n"; } @@ -312,8 +328,8 @@ if ($::opt_I) { print "\n"; } } - print "Added files: @added\n" if @added; - print "Removed files: @removed\n" if @removed; + print "Added files: ".join(" ",sort keys %added )."\n" if %added; + print "Removed files: ".join(" ",sort keys %removed)."\n" if %removed; exit 0+@missing; } @@ -353,12 +369,15 @@ exit 0; # --- -sub add_file { +sub add_patched_file { my $ls = shift; - print "add_file '$_[0]'\n" if $::opt_d; - my $out = trim_name(shift); + my $raw_name = shift; + my $action = shift || 1; # 1==patched, 2==deleted - $ls->{out}->{$out} = 1; + my $out = trim_name($raw_name); + print "add_patched_file '$out' ($raw_name, $action)\n" if $::opt_d; + + $ls->{out}->{$out} = $action; warn "$out patched but not present\n" if $::opt_e && !-f $out; @@ -371,13 +390,24 @@ sub add_file { $i->{out}->{$in} = 1; } +sub add_deleted_file { + my $ls = shift; + my $raw_name = shift; + my $out = trim_name($raw_name); + print "add_deleted_file '$out' ($raw_name)\n" if $::opt_d; + $removed{$out} = 1; + #add_patched_file(@_[0,1], 2); +} + sub trim_name { # reduce/tidy file paths from diff lines my $name = shift; - $name = "$name ($in)" if $name eq "/dev/null"; $name =~ s:\\:/:g; # adjust windows paths $name =~ s://:/:g; # simplify (and make win \\share into absolute path) - if (defined $::opt_p) { + if ($name eq "/dev/null") { + # do nothing (XXX but we need a way to record deletions) + } + elsif (defined $::opt_p) { # strip on -p levels of directory prefix my $dc = $::opt_p; $name =~ s:^[^/]+/(.+)$:$1: while $dc-- > 0; @@ -385,7 +415,7 @@ sub trim_name { # reduce/tidy file paths from diff lines else { # try to strip off leading path to perl directory # if absolute path, strip down to any *perl* directory first $name =~ s:^/.*?perl.*?/::i; - $name =~ s:.*perl[-_]?5?[._]?[-_a-z0-9.+]*/::i; + $name =~ s:.*(perl|maint)[-_]?5?[._]?[-_a-z0-9.+]*/::i; $name =~ s:^\./::; } return $name; @@ -436,7 +466,9 @@ sub list_files_by_patch { # a twisty maze of little options my $cat = ($ls->{category} and !$::opt_m) ? "\t$ls->{category}" : ""; print "$name$cat: " unless ($::opt_h and !$::opt_v) or !"$name$cat"; - print join('',"\n",@meta) if @meta; + my $sep = "\n"; + $sep = "" if @show_meta==1 && $::opt_c && $::opt_h; + print join('', $sep, @meta) if @meta; return if $::opt_m && !$show_meta{Files}; my @v = sort PATORDER keys %{ $ls->{out} }; diff --git a/README.win32 b/README.win32 index 7fcc58fa4e..099c88110e 100644 --- a/README.win32 +++ b/README.win32 @@ -75,6 +75,9 @@ your mileage may vary. The surest way to build it is on WindowsNT, using the cmd shell. +Make sure the path to the build directory does not contain spaces. The +build usually works in this circumstance, but some tests will fail. + =item Borland C++ If you are using the Borland compiler, you will need dmake, a freely @@ -182,7 +185,14 @@ Perl will also build without des_fcrypt(), but the crypt() builtin will fail at run time. You will also have to make sure CCHOME points to wherever you installed -your compiler. +your compiler. Make sure this path has no spaces in it. If you +insist on spaces in your path names, there is no telling what else +will fail, but you can try putting the path in double quotes. Some +parts of perl try to accomodate that, but not all pieces do. + +The default value for CCHOME in the makefiles for Visual C++ +may not be correct if you have a version later than 5.2. Make +sure the default exists and is valid. Other options are explained in the makefiles. Be sure to read the instructions carefully. @@ -223,9 +233,10 @@ Type "dmake test" (or "nmake test"). This will run most of the tests from the testsuite (many tests will be skipped, and but no test should fail). If some tests do fail, it may be because you are using a different command -shell than the native "cmd.exe". +shell than the native "cmd.exe", or because you are building from a path +that contains spaces. So don't do that. -If you used the Borland compiler, you may see a failure in op/taint.t +If you're using the Borland compiler, you may see a failure in op/taint.t arising from the inability to find the Borland Runtime DLLs on the system default path. You will need to copy the DLLs reported by the messages from where Borland chose to install it, into the Windows system directory @@ -473,7 +484,7 @@ all of the ActiveState extensions and most other Win32 extensions from CPAN in source form, along with many added bugfixes, and with MakeMaker support. This bundle is available at: - http://www.perl.com/CPAN/authors/id/GSAR/libwin32-0.12.zip + http://www.perl.com/CPAN/authors/id/GSAR/libwin32-0.14.zip See the README in that distribution for building and installation instructions. Look for later versions that may be available at the @@ -707,7 +718,7 @@ Borland support was added in 5.004_01 (Gurusamy Sarathy). GCC/mingw32 support was added in 5.005 (Nick Ing-Simmons). -Last updated: 22 September 1998 +Last updated: 29 November 1998 =cut @@ -57,8 +57,8 @@ #ifdef XS_VERSION # define XS_VERSION_BOOTCHECK \ STMT_START { \ - SV *tmpsv; \ - char *vn = Nullch, *module = SvPV(ST(0),PL_na); \ + SV *tmpsv; STRLEN n_a; \ + char *vn = Nullch, *module = SvPV(ST(0),n_a); \ if (items >= 2) /* version supplied as bootstrap arg */ \ tmpsv = ST(1); \ else { \ @@ -69,7 +69,7 @@ tmpsv = perl_get_sv(form("%s::%s", module, \ vn = "VERSION"), FALSE); \ } \ - if (tmpsv && (!SvOK(tmpsv) || strNE(XS_VERSION, SvPV(tmpsv, PL_na)))) \ + if (tmpsv && (!SvOK(tmpsv) || strNE(XS_VERSION, SvPV(tmpsv, n_a)))) \ croak("%s object version %s does not match %s%s%s%s %_", \ module, XS_VERSION, \ vn ? "$" : "", vn ? module : "", vn ? "::" : "", \ diff --git a/djgpp/djgpp.c b/djgpp/djgpp.c index 4d0d9fd0a1..07eb80e1f7 100644 --- a/djgpp/djgpp.c +++ b/djgpp/djgpp.c @@ -134,6 +134,7 @@ do_aspawn (SV *really,SV **mark,SV **sp) dTHR; int rc; char **a,*tmps,**argv; + STRLEN n_a; if (sp<=mark) return -1; @@ -141,7 +142,7 @@ do_aspawn (SV *really,SV **mark,SV **sp) while (++mark <= sp) if (*mark) - *a++ = SvPVx(*mark, PL_na); + *a++ = SvPVx(*mark, n_a); else *a++ = ""; *a = Nullch; @@ -152,7 +153,7 @@ do_aspawn (SV *really,SV **mark,SV **sp) ) /* will swawnvp use PATH? */ TAINT_ENV(); /* testing IFS here is overkill, probably */ - if (really && *(tmps = SvPV(really, PL_na))) + if (really && *(tmps = SvPV(really, n_a))) rc=spawnvp (P_WAIT,tmps,argv); else rc=spawnvp (P_WAIT,argv[0],argv); @@ -366,8 +366,12 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe PerlIO_clearerr(fp); } #if defined(HAS_FCNTL) && defined(F_SETFD) - fd = PerlIO_fileno(fp); - fcntl(fd,F_SETFD,fd > PL_maxsysfd); + { + int save_errno = errno; + fd = PerlIO_fileno(fp); + fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */ + errno = save_errno; + } #endif IoIFP(io) = fp; if (writing) { @@ -552,7 +556,7 @@ nextargv(register GV *gv) } else PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n", - SvPV(sv, PL_na), Strerror(errno)); + SvPV(sv, oldlen), Strerror(errno)); } if (PL_inplace) { (void)do_close(PL_argvoutgv,FALSE); @@ -941,6 +945,7 @@ my_stat(ARGSproto) else { SV* sv = POPs; char *s; + STRLEN n_a; PUTBACK; if (SvTYPE(sv) == SVt_PVGV) { tmpgv = (GV*)sv; @@ -951,7 +956,7 @@ my_stat(ARGSproto) goto do_fstat; } - s = SvPV(sv, PL_na); + s = SvPV(sv, n_a); PL_statgv = Nullgv; sv_setpv(PL_statname, s); PL_laststype = OP_STAT; @@ -967,6 +972,7 @@ my_lstat(ARGSproto) { djSP; SV *sv; + STRLEN n_a; if (PL_op->op_flags & OPf_REF) { EXTEND(SP,1); if (cGVOP->op_gv == PL_defgv) { @@ -981,13 +987,13 @@ my_lstat(ARGSproto) PL_statgv = Nullgv; sv = POPs; PUTBACK; - sv_setpv(PL_statname,SvPV(sv, PL_na)); + sv_setpv(PL_statname,SvPV(sv, n_a)); #ifdef HAS_LSTAT - PL_laststatval = PerlLIO_lstat(SvPV(sv, PL_na),&PL_statcache); + PL_laststatval = PerlLIO_lstat(SvPV(sv, n_a),&PL_statcache); #else - PL_laststatval = PerlLIO_stat(SvPV(sv, PL_na),&PL_statcache); + PL_laststatval = PerlLIO_stat(SvPV(sv, n_a),&PL_statcache); #endif - if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, PL_na), '\n')) + if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n')) warner(WARN_NEWLINE, PL_warn_nl, "lstat"); return PL_laststatval; } @@ -997,6 +1003,7 @@ do_aexec(SV *really, register SV **mark, register SV **sp) { register char **a; char *tmps; + STRLEN n_a; if (sp > mark) { dTHR; @@ -1004,14 +1011,14 @@ do_aexec(SV *really, register SV **mark, register SV **sp) a = PL_Argv; while (++mark <= sp) { if (*mark) - *a++ = SvPVx(*mark, PL_na); + *a++ = SvPVx(*mark, n_a); else *a++ = ""; } *a = Nullch; if (*PL_Argv[0] != '/') /* will execvp use PATH? */ TAINT_ENV(); /* testing IFS here is overkill, probably */ - if (really && *(tmps = SvPV(really, PL_na))) + if (really && *(tmps = SvPV(really, n_a))) PerlProc_execvp(tmps,PL_Argv); else PerlProc_execvp(PL_Argv[0],PL_Argv); @@ -1142,6 +1149,7 @@ apply(I32 type, register SV **mark, register SV **sp) char *what; char *s; SV **oldmark = mark; + STRLEN n_a; #define APPLY_TAINT_PROPER() \ STMT_START { \ @@ -1167,7 +1175,7 @@ apply(I32 type, register SV **mark, register SV **sp) APPLY_TAINT_PROPER(); tot = sp - mark; while (++mark <= sp) { - char *name = SvPVx(*mark, PL_na); + char *name = SvPVx(*mark, n_a); APPLY_TAINT_PROPER(); if (PerlLIO_chmod(name, val)) tot--; @@ -1184,7 +1192,7 @@ apply(I32 type, register SV **mark, register SV **sp) APPLY_TAINT_PROPER(); tot = sp - mark; while (++mark <= sp) { - char *name = SvPVx(*mark, PL_na); + char *name = SvPVx(*mark, n_a); APPLY_TAINT_PROPER(); if (PerlLIO_chown(name, val, val2)) tot--; @@ -1204,7 +1212,7 @@ nothing in the core. APPLY_TAINT_PROPER(); if (mark == sp) break; - s = SvPVx(*++mark, PL_na); + s = SvPVx(*++mark, n_a); if (isUPPER(*s)) { if (*s == 'S' && s[1] == 'I' && s[2] == 'G') s += 3; @@ -1274,7 +1282,7 @@ nothing in the core. APPLY_TAINT_PROPER(); tot = sp - mark; while (++mark <= sp) { - s = SvPVx(*mark, PL_na); + s = SvPVx(*mark, n_a); APPLY_TAINT_PROPER(); if (PL_euid || PL_unsafe) { if (UNLINK(s)) @@ -1319,7 +1327,7 @@ nothing in the core. APPLY_TAINT_PROPER(); tot = sp - mark; while (++mark <= sp) { - char *name = SvPVx(*mark, PL_na); + char *name = SvPVx(*mark, n_a); APPLY_TAINT_PROPER(); if (PerlLIO_utime(name, &utbuf)) tot--; @@ -921,7 +921,8 @@ do_vop(I32 optype, SV *sv, SV *left, SV *right) len = leftlen < rightlen ? leftlen : rightlen; lensave = len; if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) { - dc = SvPV_force(sv, PL_na); + STRLEN n_a; + dc = SvPV_force(sv, n_a); if (SvCUR(sv) < len) { dc = SvGROW(sv, len + 1); (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1); @@ -146,7 +146,7 @@ char * sv_peek(SV *sv) { SV *t = sv_newmortal(); - STRLEN prevlen; + STRLEN n_a; int unref = 0; sv_setpvn(t, "", 0); @@ -289,7 +289,7 @@ sv_peek(SV *sv) while (unref--) sv_catpv(t, ")"); } - return SvPV(t, PL_na); + return SvPV(t, n_a); } void @@ -362,6 +362,7 @@ void do_op_dump(I32 level, PerlIO *file, OP *o) { dTHR; + STRLEN n_a; dump_indent(level, file, "{\n"); level++; if (o->op_seq) @@ -500,7 +501,7 @@ do_op_dump(I32 level, PerlIO *file, OP *o) ENTER; SAVEFREESV(tmpsv); gv_fullname3(tmpsv, cGVOPo->op_gv, Nullch); - dump_indent(level, file, "GV = %s\n", SvPV(tmpsv, PL_na)); + dump_indent(level, file, "GV = %s\n", SvPV(tmpsv, n_a)); LEAVE; } else @@ -736,6 +737,7 @@ do_sv_dump(I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, char *s; U32 flags; U32 type; + STRLEN n_a; if (!sv) { dump_indent(level, file, "SV = 0\n"); @@ -1020,7 +1022,7 @@ do_sv_dump(I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, break; case SVt_PVCV: if (SvPOK(sv)) - dump_indent(level, file, " PROTOTYPE = \"%s\"\n", SvPV(sv,PL_na)); + dump_indent(level, file, " PROTOTYPE = \"%s\"\n", SvPV(sv,n_a)); /* FALL THROUGH */ case SVt_PVFM: do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv)); diff --git a/embedvar.h b/embedvar.h index 4d28711ee5..bc1d495cda 100644 --- a/embedvar.h +++ b/embedvar.h @@ -47,6 +47,7 @@ #define PL_markstack_ptr (PL_curinterp->Tmarkstack_ptr) #define PL_maxscream (PL_curinterp->Tmaxscream) #define PL_modcount (PL_curinterp->Tmodcount) +#define PL_na (PL_curinterp->Tna) #define PL_nrs (PL_curinterp->Tnrs) #define PL_ofs (PL_curinterp->Tofs) #define PL_ofslen (PL_curinterp->Tofslen) @@ -438,6 +439,7 @@ #define PL_Tmarkstack_ptr PL_markstack_ptr #define PL_Tmaxscream PL_maxscream #define PL_Tmodcount PL_modcount +#define PL_Tna PL_na #define PL_Tnrs PL_nrs #define PL_Tofs PL_ofs #define PL_Tofslen PL_ofslen @@ -572,6 +574,7 @@ #define PL_markstack_ptr (thr->Tmarkstack_ptr) #define PL_maxscream (thr->Tmaxscream) #define PL_modcount (thr->Tmodcount) +#define PL_na (thr->Tna) #define PL_nrs (thr->Tnrs) #define PL_ofs (thr->Tofs) #define PL_ofslen (thr->Tofslen) @@ -727,7 +730,6 @@ #define PL_multi_end (PL_Vars.Gmulti_end) #define PL_multi_open (PL_Vars.Gmulti_open) #define PL_multi_start (PL_Vars.Gmulti_start) -#define PL_na (PL_Vars.Gna) #define PL_nexttoke (PL_Vars.Gnexttoke) #define PL_nexttype (PL_Vars.Gnexttype) #define PL_nextval (PL_Vars.Gnextval) @@ -860,7 +862,6 @@ #define PL_Gmulti_end PL_multi_end #define PL_Gmulti_open PL_multi_open #define PL_Gmulti_start PL_multi_start -#define PL_Gna PL_na #define PL_Gnexttoke PL_nexttoke #define PL_Gnexttype PL_nexttype #define PL_Gnextval PL_nextval diff --git a/ext/B/B.xs b/ext/B/B.xs index 5943e128de..678bbbdbaf 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -267,7 +267,8 @@ static SV * cchar(SV *sv) { SV *sstr = newSVpv("'", 0); - char *s = SvPV(sv, PL_na); + STRLEN n_a; + char *s = SvPV(sv, n_a); if (*s == '\'') sv_catpv(sstr, "\\'"); diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index 5856f4f862..aa76cb9481 100644 --- a/ext/DB_File/DB_File.xs +++ b/ext/DB_File/DB_File.xs @@ -593,6 +593,7 @@ SV * sv ; DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; void * openinfo = NULL ; INFO * info = &RETVAL->info ; + STRLEN n_a; /* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */ Zero(RETVAL, 1, DB_File_type) ; @@ -734,11 +735,11 @@ SV * sv ; #endif svp = hv_fetch(action, "bfname", 6, FALSE); if (svp && SvOK(*svp)) { - char * ptr = SvPV(*svp,PL_na) ; + char * ptr = SvPV(*svp,n_a) ; #ifdef DB_VERSION_MAJOR - name = (char*) PL_na ? ptr : NULL ; + name = (char*) n_a ? ptr : NULL ; #else - info->db_RE_bfname = (char*) (PL_na ? ptr : NULL) ; + info->db_RE_bfname = (char*) (n_a ? ptr : NULL) ; #endif } else @@ -754,7 +755,7 @@ SV * sv ; { int value ; if (SvPOK(*svp)) - value = (int)*SvPV(*svp, PL_na) ; + value = (int)*SvPV(*svp, n_a) ; else value = SvIV(*svp) ; @@ -772,7 +773,7 @@ SV * sv ; if (svp && SvOK(*svp)) { if (SvPOK(*svp)) - info->db_RE_bval = (u_char)*SvPV(*svp, PL_na) ; + info->db_RE_bval = (u_char)*SvPV(*svp, n_a) ; else info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ; DB_flags(info->flags, DB_DELIMITER) ; @@ -1116,9 +1117,10 @@ db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_H { char * name = (char *) NULL ; SV * sv = (SV *) NULL ; + STRLEN n_a; if (items >= 3 && SvOK(ST(2))) - name = (char*) SvPV(ST(2), PL_na) ; + name = (char*) SvPV(ST(2), n_a) ; if (items == 6) sv = ST(5) ; @@ -1248,6 +1250,7 @@ unshift(db, ...) int i ; int One ; DB * Db = db->dbp ; + STRLEN n_a; DBT_flags(key) ; DBT_flags(value) ; @@ -1261,8 +1264,8 @@ unshift(db, ...) #endif for (i = items-1 ; i > 0 ; --i) { - value.data = SvPV(ST(i), PL_na) ; - value.size = PL_na ; + value.data = SvPV(ST(i), n_a) ; + value.size = n_a ; One = 1 ; key.data = &One ; key.size = sizeof(int) ; @@ -1345,6 +1348,7 @@ push(db, ...) DBT value ; DB * Db = db->dbp ; int i ; + STRLEN n_a; DBT_flags(key) ; DBT_flags(value) ; @@ -1360,8 +1364,8 @@ push(db, ...) { ++ (* (int*)key.data) ; - value.data = SvPV(ST(i), PL_na) ; - value.size = PL_na ; + value.data = SvPV(ST(i), n_a) ; + value.size = n_a ; RETVAL = (Db->put)(Db, NULL, &key, &value, 0) ; if (RETVAL != 0) break; @@ -1369,8 +1373,8 @@ push(db, ...) #else for (i = items - 1 ; i > 0 ; --i) { - value.data = SvPV(ST(i), PL_na) ; - value.size = PL_na ; + value.data = SvPV(ST(i), n_a) ; + value.size = n_a ; RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ; if (RETVAL != 0) break; diff --git a/ext/DynaLoader/dl_next.xs b/ext/DynaLoader/dl_next.xs index 2b547f0f00..dfa8a3eac8 100644 --- a/ext/DynaLoader/dl_next.xs +++ b/ext/DynaLoader/dl_next.xs @@ -172,6 +172,7 @@ static char *dlopen(char *path, int mode /* mode is ignored */) I32 i, psize; char *result; char **p; + STRLEN n_a; /* Do not load what is already loaded into this process */ if (hv_fetch(dl_loaded_files, path, strlen(path), 0)) @@ -182,7 +183,7 @@ static char *dlopen(char *path, int mode /* mode is ignored */) p = (char **) safemalloc(psize * sizeof(char*)); p[0] = path; for(i=1; i<psize-1; i++) { - p[i] = SvPVx(*av_fetch(dl_resolve_using, i-1, TRUE), PL_na); + p[i] = SvPVx(*av_fetch(dl_resolve_using, i-1, TRUE), n_a); } p[psize-1] = 0; rld_success = rld_load(nxerr, (struct mach_header **)0, p, diff --git a/ext/IO/Makefile.PL b/ext/IO/Makefile.PL index 05c7227dcb..095d7c2b51 100644 --- a/ext/IO/Makefile.PL +++ b/ext/IO/Makefile.PL @@ -1,24 +1,9 @@ use ExtUtils::MakeMaker; use Config qw(%Config); -#--- Attempt to find <poll.h> - -my $define = ""; - -my @inc = split(/\s+/, join(" ",$Config{'usrinc'},$Config{'incpth'},$Config{'locincpth'})); -foreach $path (@inc) { - if(-f $path . "/poll.h") { - $define .= "-DI_POLL "; - last; - } -} - -#--- Write the Makefile - WriteMakefile( VERSION_FROM => "IO.pm", NAME => "IO", OBJECT => '$(O_FILES)', - DEFINE => $define, MAN3PODS => {}, # Pods will be built by installman. ); diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs index e853cf19a3..e93b90046a 100644 --- a/ext/Opcode/Opcode.xs +++ b/ext/Opcode/Opcode.xs @@ -400,7 +400,8 @@ PPCODE: } else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) { int b, j; - char *bitmap = SvPV(bitspec,PL_na); + STRLEN n_a; + char *bitmap = SvPV(bitspec,n_a); myopcode = 0; for (b=0; b < opset_len; b++) { U16 bits = bitmap[b]; diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 7c70bca55b..c948cc6fad 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -3179,10 +3179,11 @@ sigaction(sig, action, oldaction = 0) PL_sig_name[sig], strlen(PL_sig_name[sig]), TRUE); + STRLEN n_a; /* Remember old handler name if desired. */ if (oldaction) { - char *hand = SvPVx(*sigsvp, PL_na); + char *hand = SvPVx(*sigsvp, n_a); svp = hv_fetch(oldaction, "HANDLER", 7, TRUE); sv_setpv(*svp, *hand ? hand : "DEFAULT"); } @@ -3193,7 +3194,7 @@ sigaction(sig, action, oldaction = 0) svp = hv_fetch(action, "HANDLER", 7, FALSE); if (!svp) croak("Can't supply an action without a HANDLER"); - sv_setpv(*sigsvp, SvPV(*svp, PL_na)); + sv_setpv(*sigsvp, SvPV(*svp, n_a)); mg_set(*sigsvp); /* handles DEFAULT and IGNORE */ act.sa_handler = sighandler; diff --git a/ext/Thread/Thread.xs b/ext/Thread/Thread.xs index 09751c5f1a..543ecf00cf 100644 --- a/ext/Thread/Thread.xs +++ b/ext/Thread/Thread.xs @@ -249,11 +249,13 @@ newthread (SV *startsv, AV *initargs, char *classname) XPUSHs(SvREFCNT_inc(*av_fetch(initargs, i, FALSE))); XPUSHs(SvREFCNT_inc(startsv)); PUTBACK; + + /* On your marks... */ + MUTEX_LOCK(&thr->mutex); + #ifdef THREAD_CREATE err = THREAD_CREATE(thr, threadstart); #else - /* On your marks... */ - MUTEX_LOCK(&thr->mutex); /* Get set... */ sigfillset(&fullmask); if (sigprocmask(SIG_SETMASK, &fullmask, &oldmask) == -1) @@ -272,10 +274,10 @@ newthread (SV *startsv, AV *initargs, char *classname) } if (err == 0) err = PTHREAD_CREATE(&thr->self, attr, threadstart, (void*) thr); - /* Go */ - MUTEX_UNLOCK(&thr->mutex); #endif + if (err) { + MUTEX_UNLOCK(&thr->mutex); DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: create of %p failed %d\n", savethread, thr, err)); @@ -288,16 +290,23 @@ newthread (SV *startsv, AV *initargs, char *classname) SvREFCNT_dec(startsv); return NULL; } + #ifdef THREAD_POST_CREATE THREAD_POST_CREATE(thr); #else if (sigprocmask(SIG_SETMASK, &oldmask, 0)) croak("panic: sigprocmask"); #endif + sv = newSViv(thr->tid); sv_magic(sv, thr->oursv, '~', 0, 0); SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE; - return sv_bless(newRV_noinc(sv), gv_stashpv(classname, TRUE)); + sv = sv_bless(newRV_noinc(sv), gv_stashpv(classname, TRUE)); + + /* Go */ + MUTEX_UNLOCK(&thr->mutex); + + return sv; #else croak("No threads in this perl"); return &PL_sv_undef; @@ -364,7 +373,8 @@ join(t) for (i = 1; i <= AvFILL(av); i++) XPUSHs(sv_2mortal(*av_fetch(av, i, FALSE))); } else { - char *mess = SvPV(*av_fetch(av, 1, FALSE), PL_na); + STRLEN n_a; + char *mess = SvPV(*av_fetch(av, 1, FALSE), n_a); DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: join propagating die message: %s\n", thr, mess)); diff --git a/ext/attrs/attrs.xs b/ext/attrs/attrs.xs index da952d5a3f..7f7970d207 100644 --- a/ext/attrs/attrs.xs +++ b/ext/attrs/attrs.xs @@ -27,7 +27,8 @@ char * Class if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv))) croak("can't set attributes outside a subroutine scope"); for (i = 1; i < items; i++) { - char *attr = SvPV(ST(i), PL_na); + STRLEN n_a; + char *attr = SvPV(ST(i), n_a); cv_flags_t flag = get_flag(attr); if (!flag) croak("invalid attribute name %s", attr); @@ -47,7 +48,8 @@ SV * sub sub = Nullsv; } else { - char *name = SvPV(sub, PL_na); + STRLEN n_a; + char *name = SvPV(sub, n_a); sub = (SV*)perl_get_cv(name, FALSE); } if (!sub) @@ -112,6 +112,7 @@ gv_init(GV *gv, HV *stash, char *name, STRLEN len, int multi) if (doproto) { /* Replicate part of newSUB here. */ SvIOK_off(gv); ENTER; + /* XXX unsafe for threads if eval_owner isn't held */ start_subparse(0,0); /* Create CV in compcv. */ GvCV(gv) = PL_compcv; LEAVE; @@ -1018,6 +1019,7 @@ Gv_AMupdate(HV *stash) MAGIC* mg=mg_find((SV*)stash,'c'); AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL; AMT amt; + STRLEN n_a; if (mg && amtp->was_ok_am == PL_amagic_generation && amtp->was_ok_sub == PL_sub_generation) @@ -1065,7 +1067,7 @@ Gv_AMupdate(HV *stash) default: if (!SvROK(sv)) { if (!SvOK(sv)) break; - gv = gv_fetchmethod(stash, SvPV(sv, PL_na)); + gv = gv_fetchmethod(stash, SvPV(sv, n_a)); if (gv) cv = GvCV(gv); break; } @@ -1126,7 +1128,7 @@ Gv_AMupdate(HV *stash) GV *ngv; DEBUG_o( deb("Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n", - SvPV(GvSV(gv), PL_na), cp, HvNAME(stash)) ); + SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) ); if (!SvPOK(GvSV(gv)) || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)), FALSE))) diff --git a/jpl/JNI/Changes b/jpl/JNI/Changes new file mode 100644 index 0000000000..dd2edf7c0c --- /dev/null +++ b/jpl/JNI/Changes @@ -0,0 +1,5 @@ +Revision history for Perl extension JNI. + +0.01 Wed Jun 4 13:16:03 1997 + - original version; created by h2xs 1.18 + diff --git a/jpl/JNI/JNI.pm b/jpl/JNI/JNI.pm new file mode 100644 index 0000000000..7797ad632a --- /dev/null +++ b/jpl/JNI/JNI.pm @@ -0,0 +1,270 @@ +package JNI; + +use strict; +use Carp; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD $JVM @JVM_ARGS $JAVALIB); + +require Exporter; +require DynaLoader; +require AutoLoader; + +@ISA = qw(Exporter DynaLoader); + +@EXPORT = qw( + JNI_ABORT + JNI_COMMIT + JNI_ERR + JNI_FALSE + JNI_H + JNI_OK + JNI_TRUE + GetVersion + DefineClass + FindClass + GetSuperclass + IsAssignableFrom + Throw + ThrowNew + ExceptionOccurred + ExceptionDescribe + ExceptionClear + FatalError + NewGlobalRef + DeleteGlobalRef + DeleteLocalRef + IsSameObject + AllocObject + NewObject + NewObjectA + GetObjectClass + IsInstanceOf + GetMethodID + CallObjectMethod + CallObjectMethodA + CallBooleanMethod + CallBooleanMethodA + CallByteMethod + CallByteMethodA + CallCharMethod + CallCharMethodA + CallShortMethod + CallShortMethodA + CallIntMethod + CallIntMethodA + CallLongMethod + CallLongMethodA + CallFloatMethod + CallFloatMethodA + CallDoubleMethod + CallDoubleMethodA + CallVoidMethod + CallVoidMethodA + CallNonvirtualObjectMethod + CallNonvirtualObjectMethodA + CallNonvirtualBooleanMethod + CallNonvirtualBooleanMethodA + CallNonvirtualByteMethod + CallNonvirtualByteMethodA + CallNonvirtualCharMethod + CallNonvirtualCharMethodA + CallNonvirtualShortMethod + CallNonvirtualShortMethodA + CallNonvirtualIntMethod + CallNonvirtualIntMethodA + CallNonvirtualLongMethod + CallNonvirtualLongMethodA + CallNonvirtualFloatMethod + CallNonvirtualFloatMethodA + CallNonvirtualDoubleMethod + CallNonvirtualDoubleMethodA + CallNonvirtualVoidMethod + CallNonvirtualVoidMethodA + GetFieldID + GetObjectField + GetBooleanField + GetByteField + GetCharField + GetShortField + GetIntField + GetLongField + GetFloatField + GetDoubleField + SetObjectField + SetBooleanField + SetByteField + SetCharField + SetShortField + SetIntField + SetLongField + SetFloatField + SetDoubleField + GetStaticMethodID + CallStaticObjectMethod + CallStaticObjectMethodA + CallStaticBooleanMethod + CallStaticBooleanMethodA + CallStaticByteMethod + CallStaticByteMethodA + CallStaticCharMethod + CallStaticCharMethodA + CallStaticShortMethod + CallStaticShortMethodA + CallStaticIntMethod + CallStaticIntMethodA + CallStaticLongMethod + CallStaticLongMethodA + CallStaticFloatMethod + CallStaticFloatMethodA + CallStaticDoubleMethod + CallStaticDoubleMethodA + CallStaticVoidMethod + CallStaticVoidMethodA + GetStaticFieldID + GetStaticObjectField + GetStaticBooleanField + GetStaticByteField + GetStaticCharField + GetStaticShortField + GetStaticIntField + GetStaticLongField + GetStaticFloatField + GetStaticDoubleField + SetStaticObjectField + SetStaticBooleanField + SetStaticByteField + SetStaticCharField + SetStaticShortField + SetStaticIntField + SetStaticLongField + SetStaticFloatField + SetStaticDoubleField + NewString + GetStringLength + GetStringChars + NewStringUTF + GetStringUTFLength + GetStringUTFChars + GetArrayLength + NewObjectArray + GetObjectArrayElement + SetObjectArrayElement + NewBooleanArray + NewByteArray + NewCharArray + NewShortArray + NewIntArray + NewLongArray + NewFloatArray + NewDoubleArray + GetBooleanArrayElements + GetByteArrayElements + GetCharArrayElements + GetShortArrayElements + GetIntArrayElements + GetLongArrayElements + GetFloatArrayElements + GetDoubleArrayElements + GetBooleanArrayRegion + GetByteArrayRegion + GetCharArrayRegion + GetShortArrayRegion + GetIntArrayRegion + GetLongArrayRegion + GetFloatArrayRegion + GetDoubleArrayRegion + SetBooleanArrayRegion + SetByteArrayRegion + SetCharArrayRegion + SetShortArrayRegion + SetIntArrayRegion + SetLongArrayRegion + SetFloatArrayRegion + SetDoubleArrayRegion + RegisterNatives + UnregisterNatives + MonitorEnter + MonitorExit + GetJavaVM +); + +$VERSION = '0.01'; + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. If a constant is not found then control is passed + # to the AUTOLOAD in AutoLoader. + + my $constname; + ($constname = $AUTOLOAD) =~ s/.*:://; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + croak "Your vendor has not defined JNI macro $constname"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +bootstrap JNI $VERSION; + +if (not $JPL::_env_) { + $ENV{JAVA_HOME} ||= "/usr/local/java"; + + chop(my $arch = `uname -p`); + chop($arch = `uname -m`) unless -d "$ENV{JAVA_HOME}/lib/$arch"; + + my @CLASSPATH = split(/:/, $ENV{CLASSPATH}); + @CLASSPATH = "." unless @CLASSPATH; + push @CLASSPATH, + "$ENV{JAVA_HOME}/classes", + "$ENV{JAVA_HOME}/lib/classes.zip"; + $ENV{CLASSPATH} = join(':', @CLASSPATH); + + $ENV{THREADS_TYPE} ||= "green_threads"; + + $JAVALIB = "$ENV{JAVA_HOME}/lib/$arch/$ENV{THREADS_TYPE}"; + $ENV{LD_LIBRARY_PATH} .= ":$JAVALIB"; + + $JVM = GetJavaVM("$JAVALIB/libjava.so",@JVM_ARGS); +} + +1; +__END__ + +=head1 NAME + +JNI - Perl encapsulation of the Java Native Interface + +=head1 SYNOPSIS + + use JNI; + +=head1 DESCRIPTION + +=head1 Exported constants + + JNI_ABORT + JNI_COMMIT + JNI_ERR + JNI_FALSE + JNI_H + JNI_OK + JNI_TRUE + + +=head1 AUTHOR + +Copyright 1998, O'Reilly & Associates, Inc. + +This package may be copied under the same terms as Perl itself. + +=head1 SEE ALSO + +perl(1). + +=cut diff --git a/jpl/JNI/JNI.xs b/jpl/JNI/JNI.xs new file mode 100644 index 0000000000..10eb2cf4ab --- /dev/null +++ b/jpl/JNI/JNI.xs @@ -0,0 +1,3138 @@ +/* + * Copyright 1997, O'Reilly & Associate, Inc. + * + * This package may be copied under the same terms as Perl itself. + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <perl.h> +#include <jni.h> +#include <dlfcn.h> + +extern SV** stack_sp; +extern JNIEnv* jplcurenv; +extern int jpldebug; + +#define SysRet jint + +static void call_my_exit(jint status) +{ + my_exit(status); +} + +jvalue* +makeargs(char *sig, SV** svp, int items) +{ + jvalue* jv = (jvalue*)safemalloc(sizeof(jvalue) * items); + int ix = 0; + char *s = sig; + JNIEnv* env = jplcurenv; + char *start; + STRLEN n_a; + + if (jpldebug) + fprintf(stderr, "sig = %s, items = %d\n", sig, items); + if (*s++ != '(') + goto cleanup; + + while (items--) { + SV *sv = *svp++; + start = s; + switch (*s++) { + case 'Z': + jv[ix++].z = (jboolean)(SvIV(sv) != 0); + break; + case 'B': + jv[ix++].b = (jbyte)SvIV(sv); + break; + case 'C': + jv[ix++].c = (jchar)SvIV(sv); + break; + case 'S': + jv[ix++].s = (jshort)SvIV(sv); + break; + case 'I': + jv[ix++].i = (jint)SvIV(sv); + break; + case 'J': + jv[ix++].j = (jlong)SvNV(sv); + break; + case 'F': + jv[ix++].f = (jfloat)SvNV(sv); + break; + case 'D': + jv[ix++].d = (jdouble)SvNV(sv); + break; + case '[': + switch (*s++) { + case 'Z': + if (SvROK(sv)) { + SV* rv = (SV*)SvRV(sv); + if (SvOBJECT(rv)) + jv[ix++].l = (jobject)(void*)SvIV(rv); + else if (SvTYPE(rv) == SVt_PVAV) { + jsize len = av_len((AV*)rv) + 1; + jboolean* buf = (jboolean*)malloc(len * sizeof(jboolean)); + int i; + SV** esv; + + jbooleanArray ja = (*env)->NewBooleanArray(env, len); + for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) + buf[i] = (jboolean)SvIV(*esv); + (*env)->SetBooleanArrayRegion(env, ja, 0, len, buf); + free((void*)buf); + jv[ix++].l = (jobject)ja; + } + else + jv[ix++].l = (jobject)(void*)0; + } + else if (SvPOK(sv)) { + jsize len = sv_len(sv) / sizeof(jboolean); + + jbooleanArray ja = (*env)->NewBooleanArray(env, len); + (*env)->SetBooleanArrayRegion(env, ja, 0, len, (jboolean*)SvPV(sv,n_a)); + jv[ix++].l = (jobject)ja; + } + else + jv[ix++].l = (jobject)(void*)0; + break; + case 'B': + if (SvROK(sv)) { + SV* rv = (SV*)SvRV(sv); + if (SvOBJECT(rv)) + jv[ix++].l = (jobject)(void*)SvIV(rv); + else if (SvTYPE(rv) == SVt_PVAV) { + jsize len = av_len((AV*)rv) + 1; + jbyte* buf = (jbyte*)malloc(len * sizeof(jbyte)); + int i; + SV** esv; + + jbyteArray ja = (*env)->NewByteArray(env, len); + for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) + buf[i] = (jbyte)SvIV(*esv); + (*env)->SetByteArrayRegion(env, ja, 0, len, buf); + free((void*)buf); + jv[ix++].l = (jobject)ja; + } + else + jv[ix++].l = (jobject)(void*)0; + } + else if (SvPOK(sv)) { + jsize len = sv_len(sv) / sizeof(jbyte); + + jbyteArray ja = (*env)->NewByteArray(env, len); + (*env)->SetByteArrayRegion(env, ja, 0, len, (jbyte*)SvPV(sv,n_a)); + jv[ix++].l = (jobject)ja; + } + else + jv[ix++].l = (jobject)(void*)0; + break; + case 'C': + if (SvROK(sv)) { + SV* rv = (SV*)SvRV(sv); + if (SvOBJECT(rv)) + jv[ix++].l = (jobject)(void*)SvIV(rv); + else if (SvTYPE(rv) == SVt_PVAV) { + jsize len = av_len((AV*)rv) + 1; + jchar* buf = (jchar*)malloc(len * sizeof(jchar)); + int i; + SV** esv; + + jcharArray ja = (*env)->NewCharArray(env, len); + for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) + buf[i] = (jchar)SvIV(*esv); + (*env)->SetCharArrayRegion(env, ja, 0, len, buf); + free((void*)buf); + jv[ix++].l = (jobject)ja; + } + else + jv[ix++].l = (jobject)(void*)0; + } + else if (SvPOK(sv)) { + jsize len = sv_len(sv) / sizeof(jchar); + + jcharArray ja = (*env)->NewCharArray(env, len); + (*env)->SetCharArrayRegion(env, ja, 0, len, (jchar*)SvPV(sv,n_a)); + jv[ix++].l = (jobject)ja; + } + else + jv[ix++].l = (jobject)(void*)0; + break; + case 'S': + if (SvROK(sv)) { + SV* rv = (SV*)SvRV(sv); + if (SvOBJECT(rv)) + jv[ix++].l = (jobject)(void*)SvIV(rv); + else if (SvTYPE(rv) == SVt_PVAV) { + jsize len = av_len((AV*)rv) + 1; + jshort* buf = (jshort*)malloc(len * sizeof(jshort)); + int i; + SV** esv; + + jshortArray ja = (*env)->NewShortArray(env, len); + for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) + buf[i] = (jshort)SvIV(*esv); + (*env)->SetShortArrayRegion(env, ja, 0, len, buf); + free((void*)buf); + jv[ix++].l = (jobject)ja; + } + else + jv[ix++].l = (jobject)(void*)0; + } + else if (SvPOK(sv)) { + jsize len = sv_len(sv) / sizeof(jshort); + + jshortArray ja = (*env)->NewShortArray(env, len); + (*env)->SetShortArrayRegion(env, ja, 0, len, (jshort*)SvPV(sv,n_a)); + jv[ix++].l = (jobject)ja; + } + else + jv[ix++].l = (jobject)(void*)0; + break; + case 'I': + if (SvROK(sv)) { + SV* rv = (SV*)SvRV(sv); + if (SvOBJECT(rv)) + jv[ix++].l = (jobject)(void*)SvIV(rv); + else if (SvTYPE(rv) == SVt_PVAV) { + jsize len = av_len((AV*)rv) + 1; + jint* buf = (jint*)malloc(len * sizeof(jint)); + int i; + SV** esv; + + jintArray ja = (*env)->NewIntArray(env, len); + for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) + buf[i] = (jint)SvIV(*esv); + (*env)->SetIntArrayRegion(env, ja, 0, len, buf); + free((void*)buf); + jv[ix++].l = (jobject)ja; + } + else + jv[ix++].l = (jobject)(void*)0; + } + else if (SvPOK(sv)) { + jsize len = sv_len(sv) / sizeof(jint); + + jintArray ja = (*env)->NewIntArray(env, len); + (*env)->SetIntArrayRegion(env, ja, 0, len, (jint*)SvPV(sv,n_a)); + jv[ix++].l = (jobject)ja; + } + else + jv[ix++].l = (jobject)(void*)0; + break; + case 'J': + if (SvROK(sv)) { + SV* rv = (SV*)SvRV(sv); + if (SvOBJECT(rv)) + jv[ix++].l = (jobject)(void*)SvIV(rv); + else if (SvTYPE(rv) == SVt_PVAV) { + jsize len = av_len((AV*)rv) + 1; + jlong* buf = (jlong*)malloc(len * sizeof(jlong)); + int i; + SV** esv; + + jlongArray ja = (*env)->NewLongArray(env, len); + for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) + buf[i] = (jlong)SvNV(*esv); + (*env)->SetLongArrayRegion(env, ja, 0, len, buf); + free((void*)buf); + jv[ix++].l = (jobject)ja; + } + else + jv[ix++].l = (jobject)(void*)0; + } + else if (SvPOK(sv)) { + jsize len = sv_len(sv) / sizeof(jlong); + + jlongArray ja = (*env)->NewLongArray(env, len); + (*env)->SetLongArrayRegion(env, ja, 0, len, (jlong*)SvPV(sv,n_a)); + jv[ix++].l = (jobject)ja; + } + else + jv[ix++].l = (jobject)(void*)0; + break; + case 'F': + if (SvROK(sv)) { + SV* rv = (SV*)SvRV(sv); + if (SvOBJECT(rv)) + jv[ix++].l = (jobject)(void*)SvIV(rv); + else if (SvTYPE(rv) == SVt_PVAV) { + jsize len = av_len((AV*)rv) + 1; + jfloat* buf = (jfloat*)malloc(len * sizeof(jfloat)); + int i; + SV** esv; + + jfloatArray ja = (*env)->NewFloatArray(env, len); + for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) + buf[i] = (jfloat)SvNV(*esv); + (*env)->SetFloatArrayRegion(env, ja, 0, len, buf); + free((void*)buf); + jv[ix++].l = (jobject)ja; + } + else + jv[ix++].l = (jobject)(void*)0; + } + else if (SvPOK(sv)) { + jsize len = sv_len(sv) / sizeof(jfloat); + + jfloatArray ja = (*env)->NewFloatArray(env, len); + (*env)->SetFloatArrayRegion(env, ja, 0, len, (jfloat*)SvPV(sv,n_a)); + jv[ix++].l = (jobject)ja; + } + else + jv[ix++].l = (jobject)(void*)0; + break; + case 'D': + if (SvROK(sv)) { + SV* rv = (SV*)SvRV(sv); + if (SvOBJECT(rv)) + jv[ix++].l = (jobject)(void*)SvIV(rv); + else if (SvTYPE(rv) == SVt_PVAV) { + jsize len = av_len((AV*)rv) + 1; + jdouble* buf = (jdouble*)malloc(len * sizeof(jdouble)); + int i; + SV** esv; + + jdoubleArray ja = (*env)->NewDoubleArray(env, len); + for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) + buf[i] = (jdouble)SvNV(*esv); + (*env)->SetDoubleArrayRegion(env, ja, 0, len, buf); + free((void*)buf); + jv[ix++].l = (jobject)ja; + } + else + jv[ix++].l = (jobject)(void*)0; + } + else if (SvPOK(sv)) { + jsize len = sv_len(sv) / sizeof(jdouble); + + jdoubleArray ja = (*env)->NewDoubleArray(env, len); + (*env)->SetDoubleArrayRegion(env, ja, 0, len, (jdouble*)SvPV(sv,n_a)); + jv[ix++].l = (jobject)ja; + } + else + jv[ix++].l = (jobject)(void*)0; + break; + case 'L': + while (*s != ';') s++; + s++; + if (strnEQ(start, "[Ljava/lang/String;", 19)) { + if (SvROK(sv)) { + SV* rv = (SV*)SvRV(sv); + if (SvOBJECT(rv)) + jv[ix++].l = (jobject)(void*)SvIV(rv); + else if (SvTYPE(rv) == SVt_PVAV) { + jsize len = av_len((AV*)rv) + 1; + int i; + SV** esv; + static jclass jcl = 0; + jarray ja; + + if (!jcl) + jcl = (*env)->FindClass(env, "java/lang/String"); + ja = (*env)->NewObjectArray(env, len, jcl, 0); + for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) { + jobject str = (jobject)(*env)->NewStringUTF(env, SvPV(*esv,n_a)); + (*env)->SetObjectArrayElement(env, ja, i, str); + } + jv[ix++].l = (jobject)ja; + } + else + jv[ix++].l = (jobject)(void*)0; + } + else + jv[ix++].l = (jobject)(void*)0; + break; + } + /* FALL THROUGH */ + default: + if (SvROK(sv)) { + SV* rv = (SV*)SvRV(sv); + if (SvOBJECT(rv)) + jv[ix++].l = (jobject)(void*)SvIV(rv); + else if (SvTYPE(rv) == SVt_PVAV) { + jsize len = av_len((AV*)rv) + 1; + int i; + SV** esv; + static jclass jcl = 0; + jarray ja; + + if (!jcl) + jcl = (*env)->FindClass(env, "java/lang/Object"); + ja = (*env)->NewObjectArray(env, len, jcl, 0); + for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) { + if (SvROK(*esv) && (rv = SvRV(*esv)) && SvOBJECT(rv)) { + (*env)->SetObjectArrayElement(env, ja, i, + (jobject)(void*)SvIV(rv)); + } + else { + jobject str = (jobject)(*env)->NewStringUTF(env, + SvPV(*esv,n_a)); + (*env)->SetObjectArrayElement(env, ja, i, str); + } + } + jv[ix++].l = (jobject)ja; + } + else + jv[ix++].l = (jobject)(void*)0; + } + else + jv[ix++].l = (jobject)(void*)0; + break; + } + break; + case 'L': + if (!SvROK(sv) || strnEQ(s, "java/lang/String;", 17)) { + s += 17; + jv[ix++].l = (jobject)(*env)->NewStringUTF(env, + (char*) SvPV(sv,n_a)); + break; + } + while (*s != ';') s++; + s++; + if (SvROK(sv)) { + SV* rv = SvRV(sv); + jv[ix++].l = (jobject)(void*)SvIV(rv); + } + break; + case ')': + croak("too many arguments, signature: %s", sig); + goto cleanup; + default: + croak("panic: malformed signature: %s", s-1); + goto cleanup; + } + + } + if (*s != ')') { + croak("not enough arguments, signature: %s", sig); + goto cleanup; + } + return jv; + +cleanup: + safefree((char*)jv); + return 0; +} + +static int +not_here(s) +char *s; +{ + croak("%s not implemented on this architecture", s); + return -1; +} + +static double +constant(name, arg) +char *name; +int arg; +{ + errno = 0; + switch (*name) { + case 'A': + break; + case 'B': + break; + case 'C': + break; + case 'D': + break; + case 'E': + break; + case 'F': + break; + case 'G': + break; + case 'H': + break; + case 'I': + break; + case 'J': + if (strEQ(name, "JNI_ABORT")) +#ifdef JNI_ABORT + return JNI_ABORT; +#else + goto not_there; +#endif + if (strEQ(name, "JNI_COMMIT")) +#ifdef JNI_COMMIT + return JNI_COMMIT; +#else + goto not_there; +#endif + if (strEQ(name, "JNI_ERR")) +#ifdef JNI_ERR + return JNI_ERR; +#else + goto not_there; +#endif + if (strEQ(name, "JNI_FALSE")) +#ifdef JNI_FALSE + return JNI_FALSE; +#else + goto not_there; +#endif + if (strEQ(name, "JNI_H")) +#ifdef JNI_H + return JNI_H; +#else + goto not_there; +#endif + if (strEQ(name, "JNI_OK")) +#ifdef JNI_OK + return JNI_OK; +#else + goto not_there; +#endif + if (strEQ(name, "JNI_TRUE")) +#ifdef JNI_TRUE + return JNI_TRUE; +#else + goto not_there; +#endif + break; + case 'K': + break; + case 'L': + break; + case 'M': + break; + case 'N': + break; + case 'O': + break; + case 'P': + break; + case 'Q': + break; + case 'R': + break; + case 'S': + break; + case 'T': + break; + case 'U': + break; + case 'V': + break; + case 'W': + break; + case 'X': + break; + case 'Y': + break; + case 'Z': + break; + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +#define FETCHENV jplcurenv +#define RESTOREENV jplcurenv = env + +MODULE = JNI PACKAGE = JNI + +PROTOTYPES: ENABLE + +double +constant(name,arg) + char * name + int arg + +jint +GetVersion() + JNIEnv * env = FETCHENV; + CODE: + { + RETVAL = (*env)->GetVersion(env); + RESTOREENV; + } + OUTPUT: + RETVAL + +jclass +DefineClass(name, loader, buf) + JNIEnv * env = FETCHENV; + STRLEN tmplen = NO_INIT; + jsize buf_len_ = NO_INIT; + const char * name + jobject loader + const jbyte * buf + CODE: + { + RETVAL = (*env)->DefineClass(env, name, loader, buf, (jsize)buf_len_); + RESTOREENV; + } + OUTPUT: + RETVAL + +jclass +FindClass(name) + JNIEnv * env = FETCHENV; + const char * name + CODE: + { + RETVAL = (*env)->FindClass(env, name); + RESTOREENV; + } + OUTPUT: + RETVAL + +jclass +GetSuperclass(sub) + JNIEnv * env = FETCHENV; + jclass sub + CODE: + { + RETVAL = (*env)->GetSuperclass(env, sub); + RESTOREENV; + } + OUTPUT: + RETVAL + +jboolean +IsAssignableFrom(sub, sup) + JNIEnv * env = FETCHENV; + jclass sub + jclass sup + CODE: + { + RETVAL = (*env)->IsAssignableFrom(env, sub, sup); + RESTOREENV; + } + OUTPUT: + RETVAL + +SysRet +Throw(obj) + JNIEnv * env = FETCHENV; + jthrowable obj + CODE: + { + RETVAL = (*env)->Throw(env, obj); + RESTOREENV; + } + OUTPUT: + RETVAL + +SysRet +ThrowNew(clazz, msg) + JNIEnv * env = FETCHENV; + jclass clazz + const char * msg + CODE: + { + RETVAL = (*env)->ThrowNew(env, clazz, msg); + RESTOREENV; + } + OUTPUT: + RETVAL + +jthrowable +ExceptionOccurred() + JNIEnv * env = FETCHENV; + CODE: + { + RETVAL = (*env)->ExceptionOccurred(env); + RESTOREENV; + } + OUTPUT: + RETVAL + +void +ExceptionDescribe() + JNIEnv * env = FETCHENV; + CODE: + { + (*env)->ExceptionDescribe(env); + RESTOREENV; + } + +void +ExceptionClear() + JNIEnv * env = FETCHENV; + CODE: + { + (*env)->ExceptionClear(env); + RESTOREENV; + } + +void +FatalError(msg) + JNIEnv * env = FETCHENV; + const char * msg + CODE: + { + (*env)->FatalError(env, msg); + RESTOREENV; + } + +jobject +NewGlobalRef(lobj) + JNIEnv * env = FETCHENV; + jobject lobj + CODE: + { + RETVAL = (*env)->NewGlobalRef(env, lobj); + RESTOREENV; + } + OUTPUT: + RETVAL + +void +DeleteGlobalRef(gref) + JNIEnv * env = FETCHENV; + jobject gref + CODE: + { + (*env)->DeleteGlobalRef(env, gref); + RESTOREENV; + } + +void +DeleteLocalRef(obj) + JNIEnv * env = FETCHENV; + jobject obj + CODE: + { + (*env)->DeleteLocalRef(env, obj); + RESTOREENV; + } + +jboolean +IsSameObject(obj1,obj2) + JNIEnv * env = FETCHENV; + jobject obj1 + jobject obj2 + CODE: + { + RETVAL = (*env)->IsSameObject(env, obj1,obj2); + RESTOREENV; + } + OUTPUT: + RETVAL + +jobject +AllocObject(clazz) + JNIEnv * env = FETCHENV; + jclass clazz + CODE: + { + RETVAL = (*env)->AllocObject(env, clazz); + RESTOREENV; + } + OUTPUT: + RETVAL + +jobject +NewObject(clazz,methodID,...) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->NewObjectA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jobject +NewObjectA(clazz,methodID,args) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->NewObjectA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jclass +GetObjectClass(obj) + JNIEnv * env = FETCHENV; + jobject obj + CODE: + { + RETVAL = (*env)->GetObjectClass(env, obj); + RESTOREENV; + } + OUTPUT: + RETVAL + +jboolean +IsInstanceOf(obj,clazz) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + CODE: + { + RETVAL = (*env)->IsInstanceOf(env, obj,clazz); + RESTOREENV; + } + OUTPUT: + RETVAL + +jmethodID +GetMethodID(clazz,name,sig) + JNIEnv * env = FETCHENV; + jclass clazz + const char * name + const char * sig + CODE: + { + RETVAL = (*env)->GetMethodID(env, clazz,name,sig); + RESTOREENV; + } + OUTPUT: + RETVAL + +jobject +CallObjectMethod(obj,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallObjectMethodA(env, obj,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jobject +CallObjectMethodA(obj,methodID,args) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallObjectMethodA(env, obj,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jboolean +CallBooleanMethod(obj,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallBooleanMethodA(env, obj,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jboolean +CallBooleanMethodA(obj,methodID, args) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallBooleanMethodA(env, obj,methodID, args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jbyte +CallByteMethod(obj,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallByteMethodA(env, obj,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jbyte +CallByteMethodA(obj,methodID,args) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallByteMethodA(env, obj,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jchar +CallCharMethod(obj,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallCharMethodA(env, obj,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jchar +CallCharMethodA(obj,methodID,args) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallCharMethodA(env, obj,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jshort +CallShortMethod(obj,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallShortMethodA(env, obj,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jshort +CallShortMethodA(obj,methodID,args) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallShortMethodA(env, obj,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jint +CallIntMethod(obj,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallIntMethodA(env, obj,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jint +CallIntMethodA(obj,methodID,args) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallIntMethodA(env, obj,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jlong +CallLongMethod(obj,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallLongMethodA(env, obj,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jlong +CallLongMethodA(obj,methodID,args) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallLongMethodA(env, obj,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jfloat +CallFloatMethod(obj,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallFloatMethodA(env, obj,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jfloat +CallFloatMethodA(obj,methodID,args) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallFloatMethodA(env, obj,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jdouble +CallDoubleMethod(obj,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallDoubleMethodA(env, obj,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jdouble +CallDoubleMethodA(obj,methodID,args) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallDoubleMethodA(env, obj,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +void +CallVoidMethod(obj,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + (*env)->CallVoidMethodA(env, obj,methodID,args); + RESTOREENV; + } + +void +CallVoidMethodA(obj,methodID,args) + JNIEnv * env = FETCHENV; + jobject obj + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + (*env)->CallVoidMethodA(env, obj,methodID,args); + RESTOREENV; + } + +jobject +CallNonvirtualObjectMethod(obj,clazz,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallNonvirtualObjectMethodA(env, obj,clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jobject +CallNonvirtualObjectMethodA(obj,clazz,methodID,args) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallNonvirtualObjectMethodA(env, obj,clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jboolean +CallNonvirtualBooleanMethod(obj,clazz,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallNonvirtualBooleanMethodA(env, obj,clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jboolean +CallNonvirtualBooleanMethodA(obj,clazz,methodID, args) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallNonvirtualBooleanMethodA(env, obj,clazz,methodID, args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jbyte +CallNonvirtualByteMethod(obj,clazz,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallNonvirtualByteMethodA(env, obj,clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jbyte +CallNonvirtualByteMethodA(obj,clazz,methodID,args) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallNonvirtualByteMethodA(env, obj,clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jchar +CallNonvirtualCharMethod(obj,clazz,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallNonvirtualCharMethodA(env, obj,clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jchar +CallNonvirtualCharMethodA(obj,clazz,methodID,args) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallNonvirtualCharMethodA(env, obj,clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jshort +CallNonvirtualShortMethod(obj,clazz,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallNonvirtualShortMethodA(env, obj,clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jshort +CallNonvirtualShortMethodA(obj,clazz,methodID,args) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallNonvirtualShortMethodA(env, obj,clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jint +CallNonvirtualIntMethod(obj,clazz,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallNonvirtualIntMethodA(env, obj,clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jint +CallNonvirtualIntMethodA(obj,clazz,methodID,args) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallNonvirtualIntMethodA(env, obj,clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jlong +CallNonvirtualLongMethod(obj,clazz,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallNonvirtualLongMethodA(env, obj,clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jlong +CallNonvirtualLongMethodA(obj,clazz,methodID,args) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallNonvirtualLongMethodA(env, obj,clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jfloat +CallNonvirtualFloatMethod(obj,clazz,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallNonvirtualFloatMethodA(env, obj,clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jfloat +CallNonvirtualFloatMethodA(obj,clazz,methodID,args) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallNonvirtualFloatMethodA(env, obj,clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jdouble +CallNonvirtualDoubleMethod(obj,clazz,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallNonvirtualDoubleMethodA(env, obj,clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jdouble +CallNonvirtualDoubleMethodA(obj,clazz,methodID,args) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallNonvirtualDoubleMethodA(env, obj,clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +void +CallNonvirtualVoidMethod(obj,clazz,methodID,...) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + (*env)->CallNonvirtualVoidMethodA(env, obj,clazz,methodID,args); + RESTOREENV; + } + +void +CallNonvirtualVoidMethodA(obj,clazz,methodID,args) + JNIEnv * env = FETCHENV; + jobject obj + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + (*env)->CallNonvirtualVoidMethodA(env, obj,clazz,methodID,args); + RESTOREENV; + } + +jfieldID +GetFieldID(clazz,name,sig) + JNIEnv * env = FETCHENV; + jclass clazz + const char * name + const char * sig + CODE: + { + RETVAL = (*env)->GetFieldID(env, clazz,name,sig); + RESTOREENV; + } + OUTPUT: + RETVAL + +jobject +GetObjectField(obj,fieldID) + JNIEnv * env = FETCHENV; + jobject obj + jfieldID fieldID + char * sig = 0; + CODE: + { + RETVAL = (*env)->GetObjectField(env, obj,fieldID); + RESTOREENV; + } + OUTPUT: + RETVAL + +jboolean +GetBooleanField(obj,fieldID) + JNIEnv * env = FETCHENV; + jobject obj + jfieldID fieldID + char * sig = 0; + CODE: + { + RETVAL = (*env)->GetBooleanField(env, obj,fieldID); + RESTOREENV; + } + OUTPUT: + RETVAL + +jbyte +GetByteField(obj,fieldID) + JNIEnv * env = FETCHENV; + jobject obj + jfieldID fieldID + char * sig = 0; + CODE: + { + RETVAL = (*env)->GetByteField(env, obj,fieldID); + RESTOREENV; + } + OUTPUT: + RETVAL + +jchar +GetCharField(obj,fieldID) + JNIEnv * env = FETCHENV; + jobject obj + jfieldID fieldID + char * sig = 0; + CODE: + { + RETVAL = (*env)->GetCharField(env, obj,fieldID); + RESTOREENV; + } + OUTPUT: + RETVAL + +jshort +GetShortField(obj,fieldID) + JNIEnv * env = FETCHENV; + jobject obj + jfieldID fieldID + char * sig = 0; + CODE: + { + RETVAL = (*env)->GetShortField(env, obj,fieldID); + RESTOREENV; + } + OUTPUT: + RETVAL + +jint +GetIntField(obj,fieldID) + JNIEnv * env = FETCHENV; + jobject obj + jfieldID fieldID + char * sig = 0; + CODE: + { + RETVAL = (*env)->GetIntField(env, obj,fieldID); + RESTOREENV; + } + OUTPUT: + RETVAL + +jlong +GetLongField(obj,fieldID) + JNIEnv * env = FETCHENV; + jobject obj + jfieldID fieldID + char * sig = 0; + CODE: + { + RETVAL = (*env)->GetLongField(env, obj,fieldID); + RESTOREENV; + } + OUTPUT: + RETVAL + +jfloat +GetFloatField(obj,fieldID) + JNIEnv * env = FETCHENV; + jobject obj + jfieldID fieldID + char * sig = 0; + CODE: + { + RETVAL = (*env)->GetFloatField(env, obj,fieldID); + RESTOREENV; + } + OUTPUT: + RETVAL + +jdouble +GetDoubleField(obj,fieldID) + JNIEnv * env = FETCHENV; + jobject obj + jfieldID fieldID + char * sig = 0; + CODE: + { + RETVAL = (*env)->GetDoubleField(env, obj,fieldID); + RESTOREENV; + } + OUTPUT: + RETVAL + +void +SetObjectField(obj,fieldID,val) + JNIEnv * env = FETCHENV; + jobject obj + jfieldID fieldID + char * sig = 0; + jobject val + CODE: + { + (*env)->SetObjectField(env, obj,fieldID,val); + RESTOREENV; + } + +void +SetBooleanField(obj,fieldID,val) + JNIEnv * env = FETCHENV; + jobject obj + jfieldID fieldID + char * sig = 0; + jboolean val + CODE: + { + (*env)->SetBooleanField(env, obj,fieldID,val); + RESTOREENV; + } + +void +SetByteField(obj,fieldID,val) + JNIEnv * env = FETCHENV; + jobject obj + jfieldID fieldID + char * sig = 0; + jbyte val + CODE: + { + (*env)->SetByteField(env, obj,fieldID,val); + RESTOREENV; + } + +void +SetCharField(obj,fieldID,val) + JNIEnv * env = FETCHENV; + jobject obj + jfieldID fieldID + char * sig = 0; + jchar val + CODE: + { + (*env)->SetCharField(env, obj,fieldID,val); + RESTOREENV; + } + +void +SetShortField(obj,fieldID,val) + JNIEnv * env = FETCHENV; + jobject obj + jfieldID fieldID + char * sig = 0; + jshort val + CODE: + { + (*env)->SetShortField(env, obj,fieldID,val); + RESTOREENV; + } + +void +SetIntField(obj,fieldID,val) + JNIEnv * env = FETCHENV; + jobject obj + jfieldID fieldID + char * sig = 0; + jint val + CODE: + { + (*env)->SetIntField(env, obj,fieldID,val); + RESTOREENV; + } + +void +SetLongField(obj,fieldID,val) + JNIEnv * env = FETCHENV; + jobject obj + jfieldID fieldID + char * sig = 0; + jlong val + CODE: + { + (*env)->SetLongField(env, obj,fieldID,val); + RESTOREENV; + } + +void +SetFloatField(obj,fieldID,val) + JNIEnv * env = FETCHENV; + jobject obj + jfieldID fieldID + char * sig = 0; + jfloat val + CODE: + { + (*env)->SetFloatField(env, obj,fieldID,val); + RESTOREENV; + } + +void +SetDoubleField(obj,fieldID,val) + JNIEnv * env = FETCHENV; + jobject obj + jfieldID fieldID + char * sig = 0; + jdouble val + CODE: + { + (*env)->SetDoubleField(env, obj,fieldID,val); + RESTOREENV; + } + +jmethodID +GetStaticMethodID(clazz,name,sig) + JNIEnv * env = FETCHENV; + jclass clazz + const char * name + const char * sig + CODE: + { + RETVAL = (*env)->GetStaticMethodID(env, clazz,name,sig); + RESTOREENV; + } + OUTPUT: + RETVAL + +jobject +CallStaticObjectMethod(clazz,methodID,...) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallStaticObjectMethodA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jobject +CallStaticObjectMethodA(clazz,methodID,args) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallStaticObjectMethodA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jboolean +CallStaticBooleanMethod(clazz,methodID,...) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallStaticBooleanMethodA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jboolean +CallStaticBooleanMethodA(clazz,methodID,args) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallStaticBooleanMethodA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jbyte +CallStaticByteMethod(clazz,methodID,...) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallStaticByteMethodA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jbyte +CallStaticByteMethodA(clazz,methodID,args) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallStaticByteMethodA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jchar +CallStaticCharMethod(clazz,methodID,...) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallStaticCharMethodA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jchar +CallStaticCharMethodA(clazz,methodID,args) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallStaticCharMethodA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jshort +CallStaticShortMethod(clazz,methodID,...) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallStaticShortMethodA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jshort +CallStaticShortMethodA(clazz,methodID,args) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallStaticShortMethodA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jint +CallStaticIntMethod(clazz,methodID,...) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallStaticIntMethodA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jint +CallStaticIntMethodA(clazz,methodID,args) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallStaticIntMethodA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jlong +CallStaticLongMethod(clazz,methodID,...) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallStaticLongMethodA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jlong +CallStaticLongMethodA(clazz,methodID,args) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallStaticLongMethodA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jfloat +CallStaticFloatMethod(clazz,methodID,...) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallStaticFloatMethodA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jfloat +CallStaticFloatMethodA(clazz,methodID,args) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallStaticFloatMethodA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jdouble +CallStaticDoubleMethod(clazz,methodID,...) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + RETVAL = (*env)->CallStaticDoubleMethodA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +jdouble +CallStaticDoubleMethodA(clazz,methodID,args) + JNIEnv * env = FETCHENV; + jclass clazz + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + RETVAL = (*env)->CallStaticDoubleMethodA(env, clazz,methodID,args); + RESTOREENV; + } + OUTPUT: + RETVAL + +void +CallStaticVoidMethod(cls,methodID,...) + JNIEnv * env = FETCHENV; + jclass cls + jmethodID methodID + char * sig = 0; + int argoff = $min_args; + CODE: + { + jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + (*env)->CallStaticVoidMethodA(env, cls,methodID,args); + RESTOREENV; + } + +void +CallStaticVoidMethodA(cls,methodID,args) + JNIEnv * env = FETCHENV; + jclass cls + jmethodID methodID + char * sig = 0; + jvalue * args + CODE: + { + (*env)->CallStaticVoidMethodA(env, cls,methodID,args); + RESTOREENV; + } + +jfieldID +GetStaticFieldID(clazz,name,sig) + JNIEnv * env = FETCHENV; + jclass clazz + const char * name + const char * sig + CODE: + { + RETVAL = (*env)->GetStaticFieldID(env, clazz,name,sig); + RESTOREENV; + } + OUTPUT: + RETVAL + +jobject +GetStaticObjectField(clazz,fieldID) + JNIEnv * env = FETCHENV; + jclass clazz + jfieldID fieldID + char * sig = 0; + CODE: + { + RETVAL = (*env)->GetStaticObjectField(env, clazz,fieldID); + RESTOREENV; + } + OUTPUT: + RETVAL + +jboolean +GetStaticBooleanField(clazz,fieldID) + JNIEnv * env = FETCHENV; + jclass clazz + jfieldID fieldID + char * sig = 0; + CODE: + { + RETVAL = (*env)->GetStaticBooleanField(env, clazz,fieldID); + RESTOREENV; + } + OUTPUT: + RETVAL + +jbyte +GetStaticByteField(clazz,fieldID) + JNIEnv * env = FETCHENV; + jclass clazz + jfieldID fieldID + char * sig = 0; + CODE: + { + RETVAL = (*env)->GetStaticByteField(env, clazz,fieldID); + RESTOREENV; + } + OUTPUT: + RETVAL + +jchar +GetStaticCharField(clazz,fieldID) + JNIEnv * env = FETCHENV; + jclass clazz + jfieldID fieldID + char * sig = 0; + CODE: + { + RETVAL = (*env)->GetStaticCharField(env, clazz,fieldID); + RESTOREENV; + } + OUTPUT: + RETVAL + +jshort +GetStaticShortField(clazz,fieldID) + JNIEnv * env = FETCHENV; + jclass clazz + jfieldID fieldID + char * sig = 0; + CODE: + { + RETVAL = (*env)->GetStaticShortField(env, clazz,fieldID); + RESTOREENV; + } + OUTPUT: + RETVAL + +jint +GetStaticIntField(clazz,fieldID) + JNIEnv * env = FETCHENV; + jclass clazz + jfieldID fieldID + char * sig = 0; + CODE: + { + RETVAL = (*env)->GetStaticIntField(env, clazz,fieldID); + RESTOREENV; + } + OUTPUT: + RETVAL + +jlong +GetStaticLongField(clazz,fieldID) + JNIEnv * env = FETCHENV; + jclass clazz + jfieldID fieldID + char * sig = 0; + CODE: + { + RETVAL = (*env)->GetStaticLongField(env, clazz,fieldID); + RESTOREENV; + } + OUTPUT: + RETVAL + +jfloat +GetStaticFloatField(clazz,fieldID) + JNIEnv * env = FETCHENV; + jclass clazz + jfieldID fieldID + char * sig = 0; + CODE: + { + RETVAL = (*env)->GetStaticFloatField(env, clazz,fieldID); + RESTOREENV; + } + OUTPUT: + RETVAL + +jdouble +GetStaticDoubleField(clazz,fieldID) + JNIEnv * env = FETCHENV; + jclass clazz + jfieldID fieldID + char * sig = 0; + CODE: + { + RETVAL = (*env)->GetStaticDoubleField(env, clazz,fieldID); + RESTOREENV; + } + OUTPUT: + RETVAL + +void +SetStaticObjectField(clazz,fieldID,value) + JNIEnv * env = FETCHENV; + jclass clazz + jfieldID fieldID + char * sig = 0; + jobject value + CODE: + { + (*env)->SetStaticObjectField(env, clazz,fieldID,value); + RESTOREENV; + } + +void +SetStaticBooleanField(clazz,fieldID,value) + JNIEnv * env = FETCHENV; + jclass clazz + jfieldID fieldID + char * sig = 0; + jboolean value + CODE: + { + (*env)->SetStaticBooleanField(env, clazz,fieldID,value); + RESTOREENV; + } + +void +SetStaticByteField(clazz,fieldID,value) + JNIEnv * env = FETCHENV; + jclass clazz + jfieldID fieldID + char * sig = 0; + jbyte value + CODE: + { + (*env)->SetStaticByteField(env, clazz,fieldID,value); + RESTOREENV; + } + +void +SetStaticCharField(clazz,fieldID,value) + JNIEnv * env = FETCHENV; + jclass clazz + jfieldID fieldID + char * sig = 0; + jchar value + CODE: + { + (*env)->SetStaticCharField(env, clazz,fieldID,value); + RESTOREENV; + } + +void +SetStaticShortField(clazz,fieldID,value) + JNIEnv * env = FETCHENV; + jclass clazz + jfieldID fieldID + char * sig = 0; + jshort value + CODE: + { + (*env)->SetStaticShortField(env, clazz,fieldID,value); + RESTOREENV; + } + +void +SetStaticIntField(clazz,fieldID,value) + JNIEnv * env = FETCHENV; + jclass clazz + jfieldID fieldID + char * sig = 0; + jint value + CODE: + { + (*env)->SetStaticIntField(env, clazz,fieldID,value); + RESTOREENV; + } + +void +SetStaticLongField(clazz,fieldID,value) + JNIEnv * env = FETCHENV; + jclass clazz + jfieldID fieldID + char * sig = 0; + jlong value + CODE: + { + (*env)->SetStaticLongField(env, clazz,fieldID,value); + RESTOREENV; + } + +void +SetStaticFloatField(clazz,fieldID,value) + JNIEnv * env = FETCHENV; + jclass clazz + jfieldID fieldID + char * sig = 0; + jfloat value + CODE: + { + (*env)->SetStaticFloatField(env, clazz,fieldID,value); + RESTOREENV; + } + +void +SetStaticDoubleField(clazz,fieldID,value) + JNIEnv * env = FETCHENV; + jclass clazz + jfieldID fieldID + char * sig = 0; + jdouble value + CODE: + { + (*env)->SetStaticDoubleField(env, clazz,fieldID,value); + RESTOREENV; + } + +jstring +NewString(unicode) + JNIEnv * env = FETCHENV; + STRLEN tmplen = NO_INIT; + jsize unicode_len_ = NO_INIT; + const jchar * unicode + CODE: + { + RETVAL = (*env)->NewString(env, unicode, unicode_len_); + RESTOREENV; + } + OUTPUT: + RETVAL + +jsize +GetStringLength(str) + JNIEnv * env = FETCHENV; + jstring str + CODE: + { + RETVAL = (*env)->GetStringLength(env, str); + RESTOREENV; + } + OUTPUT: + RETVAL + +const jchar * +GetStringChars(str) + JNIEnv * env = FETCHENV; + jstring str + jboolean isCopy = NO_INIT; + jsize RETVAL_len_ = NO_INIT; + CODE: + { + RETVAL = (*env)->GetStringChars(env, str,&isCopy); + RETVAL_len_ = (*env)->GetStringLength(env, str); + RESTOREENV; + } + OUTPUT: + RETVAL + CLEANUP: + (*env)->ReleaseStringChars(env, str,RETVAL); + +jstring +NewStringUTF(utf) + JNIEnv * env = FETCHENV; + const char * utf + CODE: + { + RETVAL = (*env)->NewStringUTF(env, utf); + RESTOREENV; + } + OUTPUT: + RETVAL + +jsize +GetStringUTFLength(str) + JNIEnv * env = FETCHENV; + jstring str + CODE: + { + RETVAL = (*env)->GetStringUTFLength(env, str); + RESTOREENV; + } + OUTPUT: + RETVAL + +const char * +GetStringUTFChars(str) + JNIEnv * env = FETCHENV; + jstring str + jboolean isCopy = NO_INIT; + CODE: + { + RETVAL = (*env)->GetStringUTFChars(env, str,&isCopy); + RESTOREENV; + } + OUTPUT: + RETVAL + CLEANUP: + (*env)->ReleaseStringUTFChars(env, str, RETVAL); + + +jsize +GetArrayLength(array) + JNIEnv * env = FETCHENV; + jarray array + CODE: + { + RETVAL = (*env)->GetArrayLength(env, array); + RESTOREENV; + } + OUTPUT: + RETVAL + +jobjectArray +NewObjectArray(len,clazz,init) + JNIEnv * env = FETCHENV; + jsize len + jclass clazz + jobject init + CODE: + { + RETVAL = (*env)->NewObjectArray(env, len,clazz,init); + RESTOREENV; + } + OUTPUT: + RETVAL + +jobject +GetObjectArrayElement(array,index) + JNIEnv * env = FETCHENV; + jobjectArray array + jsize index + CODE: + { + RETVAL = (*env)->GetObjectArrayElement(env, array,index); + RESTOREENV; + } + OUTPUT: + RETVAL + +void +SetObjectArrayElement(array,index,val) + JNIEnv * env = FETCHENV; + jobjectArray array + jsize index + jobject val + CODE: + { + (*env)->SetObjectArrayElement(env, array,index,val); + RESTOREENV; + } + +jbooleanArray +NewBooleanArray(len) + JNIEnv * env = FETCHENV; + jsize len + CODE: + { + RETVAL = (*env)->NewBooleanArray(env, len); + RESTOREENV; + } + OUTPUT: + RETVAL + +jbyteArray +NewByteArray(len) + JNIEnv * env = FETCHENV; + jsize len + CODE: + { + RETVAL = (*env)->NewByteArray(env, len); + RESTOREENV; + } + OUTPUT: + RETVAL + +jcharArray +NewCharArray(len) + JNIEnv * env = FETCHENV; + jsize len + CODE: + { + RETVAL = (*env)->NewCharArray(env, len); + RESTOREENV; + } + OUTPUT: + RETVAL + +jshortArray +NewShortArray(len) + JNIEnv * env = FETCHENV; + jsize len + CODE: + { + RETVAL = (*env)->NewShortArray(env, len); + RESTOREENV; + } + OUTPUT: + RETVAL + +jintArray +NewIntArray(len) + JNIEnv * env = FETCHENV; + jsize len + CODE: + { + RETVAL = (*env)->NewIntArray(env, len); + RESTOREENV; + } + OUTPUT: + RETVAL + +jlongArray +NewLongArray(len) + JNIEnv * env = FETCHENV; + jsize len + CODE: + { + RETVAL = (*env)->NewLongArray(env, len); + RESTOREENV; + } + OUTPUT: + RETVAL + +jfloatArray +NewFloatArray(len) + JNIEnv * env = FETCHENV; + jsize len + CODE: + { + RETVAL = (*env)->NewFloatArray(env, len); + RESTOREENV; + } + OUTPUT: + RETVAL + +jdoubleArray +NewDoubleArray(len) + JNIEnv * env = FETCHENV; + jsize len + CODE: + { + RETVAL = (*env)->NewDoubleArray(env, len); + RESTOREENV; + } + OUTPUT: + RETVAL + +jboolean * +GetBooleanArrayElements(array) + JNIEnv * env = FETCHENV; + jsize RETVAL_len_ = NO_INIT; + jbooleanArray array + jboolean isCopy = NO_INIT; + PPCODE: + { + RETVAL = (*env)->GetBooleanArrayElements(env, array,&isCopy); + RETVAL_len_ = (*env)->GetArrayLength(env, array); + if (GIMME == G_ARRAY) { + int i; + jboolean* r = RETVAL; + EXTEND(sp, RETVAL_len_); + for (i = RETVAL_len_; i; --i) { + PUSHs(sv_2mortal(newSViv(*r++))); + } + } + else { + if (RETVAL_len_) { + PUSHs(sv_2mortal(newSVpv((char*)RETVAL, + (STRLEN)RETVAL_len_ * sizeof(jboolean)))); + } + else + PUSHs(&PL_sv_no); + } + (*env)->ReleaseBooleanArrayElements(env, array,RETVAL,JNI_ABORT); + RESTOREENV; + } + +jbyte * +GetByteArrayElements(array) + JNIEnv * env = FETCHENV; + jsize RETVAL_len_ = NO_INIT; + jbyteArray array + jboolean isCopy = NO_INIT; + PPCODE: + { + RETVAL = (*env)->GetByteArrayElements(env, array,&isCopy); + RETVAL_len_ = (*env)->GetArrayLength(env, array); + if (GIMME == G_ARRAY) { + int i; + jbyte* r = RETVAL; + EXTEND(sp, RETVAL_len_); + for (i = RETVAL_len_; i; --i) { + PUSHs(sv_2mortal(newSViv(*r++))); + } + } + else { + if (RETVAL_len_) { + PUSHs(sv_2mortal(newSVpv((char*)RETVAL, + (STRLEN)RETVAL_len_ * sizeof(jbyte)))); + } + else + PUSHs(&PL_sv_no); + } + (*env)->ReleaseByteArrayElements(env, array,RETVAL,JNI_ABORT); + RESTOREENV; + } + +jchar * +GetCharArrayElements(array) + JNIEnv * env = FETCHENV; + jsize RETVAL_len_ = NO_INIT; + jcharArray array + jboolean isCopy = NO_INIT; + PPCODE: + { + RETVAL = (*env)->GetCharArrayElements(env, array,&isCopy); + RETVAL_len_ = (*env)->GetArrayLength(env, array); + if (GIMME == G_ARRAY) { + int i; + jchar* r = RETVAL; + EXTEND(sp, RETVAL_len_); + for (i = RETVAL_len_; i; --i) { + PUSHs(sv_2mortal(newSViv(*r++))); + } + } + else { + if (RETVAL_len_) { + PUSHs(sv_2mortal(newSVpv((char*)RETVAL, + (STRLEN)RETVAL_len_ * sizeof(jchar)))); + } + else + PUSHs(&PL_sv_no); + } + (*env)->ReleaseCharArrayElements(env, array,RETVAL,JNI_ABORT); + RESTOREENV; + } + +jshort * +GetShortArrayElements(array) + JNIEnv * env = FETCHENV; + jsize RETVAL_len_ = NO_INIT; + jshortArray array + jboolean isCopy = NO_INIT; + PPCODE: + { + RETVAL = (*env)->GetShortArrayElements(env, array,&isCopy); + RETVAL_len_ = (*env)->GetArrayLength(env, array); + if (GIMME == G_ARRAY) { + int i; + jshort* r = RETVAL; + EXTEND(sp, RETVAL_len_); + for (i = RETVAL_len_; i; --i) { + PUSHs(sv_2mortal(newSViv(*r++))); + } + } + else { + if (RETVAL_len_) { + PUSHs(sv_2mortal(newSVpv((char*)RETVAL, + (STRLEN)RETVAL_len_ * sizeof(jshort)))); + } + else + PUSHs(&PL_sv_no); + } + (*env)->ReleaseShortArrayElements(env, array,RETVAL,JNI_ABORT); + RESTOREENV; + } + +jint * +GetIntArrayElements(array) + JNIEnv * env = FETCHENV; + jsize RETVAL_len_ = NO_INIT; + jintArray array + jboolean isCopy = NO_INIT; + PPCODE: + { + RETVAL = (*env)->GetIntArrayElements(env, array,&isCopy); + RETVAL_len_ = (*env)->GetArrayLength(env, array); + if (GIMME == G_ARRAY) { + int i; + jint* r = RETVAL; + EXTEND(sp, RETVAL_len_); + for (i = RETVAL_len_; i; --i) { + PUSHs(sv_2mortal(newSViv(*r++))); + } + } + else { + if (RETVAL_len_) { + PUSHs(sv_2mortal(newSVpv((char*)RETVAL, + (STRLEN)RETVAL_len_ * sizeof(jint)))); + } + else + PUSHs(&PL_sv_no); + } + (*env)->ReleaseIntArrayElements(env, array,RETVAL,JNI_ABORT); + RESTOREENV; + } + +jlong * +GetLongArrayElements(array) + JNIEnv * env = FETCHENV; + jsize RETVAL_len_ = NO_INIT; + jlongArray array + jboolean isCopy = NO_INIT; + PPCODE: + { + RETVAL = (*env)->GetLongArrayElements(env, array,&isCopy); + RETVAL_len_ = (*env)->GetArrayLength(env, array); + if (GIMME == G_ARRAY) { + int i; + jlong* r = RETVAL; + EXTEND(sp, RETVAL_len_); + for (i = RETVAL_len_; i; --i) { + PUSHs(sv_2mortal(newSViv(*r++))); + } + } + else { + if (RETVAL_len_) { + PUSHs(sv_2mortal(newSVpv((char*)RETVAL, + (STRLEN)RETVAL_len_ * sizeof(jlong)))); + } + else + PUSHs(&PL_sv_no); + } + (*env)->ReleaseLongArrayElements(env, array,RETVAL,JNI_ABORT); + RESTOREENV; + } + +jfloat * +GetFloatArrayElements(array) + JNIEnv * env = FETCHENV; + jsize RETVAL_len_ = NO_INIT; + jfloatArray array + jboolean isCopy = NO_INIT; + PPCODE: + { + RETVAL = (*env)->GetFloatArrayElements(env, array,&isCopy); + RETVAL_len_ = (*env)->GetArrayLength(env, array); + if (GIMME == G_ARRAY) { + int i; + jfloat* r = RETVAL; + EXTEND(sp, RETVAL_len_); + for (i = RETVAL_len_; i; --i) { + PUSHs(sv_2mortal(newSVnv(*r++))); + } + } + else { + if (RETVAL_len_) { + PUSHs(sv_2mortal(newSVpv((char*)RETVAL, + (STRLEN)RETVAL_len_ * sizeof(jfloat)))); + } + else + PUSHs(&PL_sv_no); + } + (*env)->ReleaseFloatArrayElements(env, array,RETVAL,JNI_ABORT); + RESTOREENV; + } + +jdouble * +GetDoubleArrayElements(array) + JNIEnv * env = FETCHENV; + jsize RETVAL_len_ = NO_INIT; + jdoubleArray array + jboolean isCopy = NO_INIT; + PPCODE: + { + RETVAL = (*env)->GetDoubleArrayElements(env, array,&isCopy); + RETVAL_len_ = (*env)->GetArrayLength(env, array); + if (GIMME == G_ARRAY) { + int i; + jdouble* r = RETVAL; + EXTEND(sp, RETVAL_len_); + for (i = RETVAL_len_; i; --i) { + PUSHs(sv_2mortal(newSVnv(*r++))); + } + } + else { + if (RETVAL_len_) { + PUSHs(sv_2mortal(newSVpv((char*)RETVAL, + (STRLEN)RETVAL_len_ * sizeof(jdouble)))); + } + else + PUSHs(&PL_sv_no); + } + (*env)->ReleaseDoubleArrayElements(env, array,RETVAL,JNI_ABORT); + RESTOREENV; + } + +void +GetBooleanArrayRegion(array,start,len,buf) + JNIEnv * env = FETCHENV; + jbooleanArray array + jsize start + jsize len + STRLEN tmplen = len * sizeof(jboolean) + 1; + char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen); + jboolean * buf = (jboolean*)sv_grow(ST(3),len * sizeof(jboolean)+1); + CODE: + { + (*env)->GetBooleanArrayRegion(env, array,start,len,buf); + SvCUR_set(ST(3), len * sizeof(jboolean)); + *SvEND(ST(3)) = '\0'; + RESTOREENV; + } + +void +GetByteArrayRegion(array,start,len,buf) + JNIEnv * env = FETCHENV; + jbyteArray array + jsize start + jsize len + STRLEN tmplen = len * sizeof(jboolean) + 1; + char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen); + jbyte * buf = (jbyte*)sv_grow(ST(3),len * sizeof(jbyte)+1); + CODE: + { + (*env)->GetByteArrayRegion(env, array,start,len,buf); + SvCUR_set(ST(3), len * sizeof(jbyte)); + *SvEND(ST(3)) = '\0'; + RESTOREENV; + } + +void +GetCharArrayRegion(array,start,len,buf) + JNIEnv * env = FETCHENV; + jcharArray array + jsize start + jsize len + STRLEN tmplen = len * sizeof(jboolean) + 1; + char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen); + jchar * buf = (jchar*)sv_grow(ST(3),len * sizeof(jchar)+1); + CODE: + { + (*env)->GetCharArrayRegion(env, array,start,len,buf); + SvCUR_set(ST(3), len * sizeof(jchar)); + *SvEND(ST(3)) = '\0'; + RESTOREENV; + } + +void +GetShortArrayRegion(array,start,len,buf) + JNIEnv * env = FETCHENV; + jshortArray array + jsize start + jsize len + STRLEN tmplen = len * sizeof(jboolean) + 1; + char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen); + jshort * buf = (jshort*)sv_grow(ST(3),len * sizeof(jshort)+1); + CODE: + { + (*env)->GetShortArrayRegion(env, array,start,len,buf); + SvCUR_set(ST(3), len * sizeof(jshort)); + *SvEND(ST(3)) = '\0'; + RESTOREENV; + } + +void +GetIntArrayRegion(array,start,len,buf) + JNIEnv * env = FETCHENV; + jintArray array + jsize start + jsize len + STRLEN tmplen = len * sizeof(jboolean) + 1; + char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen); + jint * buf = (jint*)sv_grow(ST(3),len * sizeof(jint)+1); + CODE: + { + (*env)->GetIntArrayRegion(env, array,start,len,buf); + SvCUR_set(ST(3), len * sizeof(jint)); + *SvEND(ST(3)) = '\0'; + RESTOREENV; + } + +void +GetLongArrayRegion(array,start,len,buf) + JNIEnv * env = FETCHENV; + jlongArray array + jsize start + jsize len + STRLEN tmplen = len * sizeof(jboolean) + 1; + char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen); + jlong * buf = (jlong*)sv_grow(ST(3),len * sizeof(jlong)+1); + CODE: + { + (*env)->GetLongArrayRegion(env, array,start,len,buf); + SvCUR_set(ST(3), len * sizeof(jlong)); + *SvEND(ST(3)) = '\0'; + RESTOREENV; + } + +void +GetFloatArrayRegion(array,start,len,buf) + JNIEnv * env = FETCHENV; + jfloatArray array + jsize start + jsize len + STRLEN tmplen = len * sizeof(jboolean) + 1; + char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen); + jfloat * buf = (jfloat*)sv_grow(ST(3),len * sizeof(jfloat)+1); + CODE: + { + (*env)->GetFloatArrayRegion(env, array,start,len,buf); + SvCUR_set(ST(3), len * sizeof(jfloat)); + *SvEND(ST(3)) = '\0'; + RESTOREENV; + } + +void +GetDoubleArrayRegion(array,start,len,buf) + JNIEnv * env = FETCHENV; + jdoubleArray array + jsize start + jsize len + STRLEN tmplen = len * sizeof(jboolean) + 1; + char * tmpbuf = (char*)sv_pvn_force(ST(3), &tmplen); + jdouble * buf = (jdouble*)sv_grow(ST(3),len * sizeof(jdouble)+1); + CODE: + { + (*env)->GetDoubleArrayRegion(env, array,start,len,buf); + SvCUR_set(ST(3), len * sizeof(jdouble)); + *SvEND(ST(3)) = '\0'; + RESTOREENV; + } + +void +SetBooleanArrayRegion(array,start,len,buf) + JNIEnv * env = FETCHENV; + STRLEN tmplen = NO_INIT; + jbooleanArray array + jsize start + jsize len + jsize buf_len_ = NO_INIT; + jboolean * buf + CODE: + { + if (buf_len_ < len) + croak("string is too short"); + else if (buf_len_ > len && PL_dowarn) + warn("string is too long"); + (*env)->SetBooleanArrayRegion(env, array,start,len,buf); + RESTOREENV; + } + +void +SetByteArrayRegion(array,start,len,buf) + JNIEnv * env = FETCHENV; + STRLEN tmplen = NO_INIT; + jbyteArray array + jsize start + jsize len + jsize buf_len_ = NO_INIT; + jbyte * buf + CODE: + { + if (buf_len_ < len) + croak("string is too short"); + else if (buf_len_ > len && PL_dowarn) + warn("string is too long"); + (*env)->SetByteArrayRegion(env, array,start,len,buf); + RESTOREENV; + } + +void +SetCharArrayRegion(array,start,len,buf) + JNIEnv * env = FETCHENV; + STRLEN tmplen = NO_INIT; + jcharArray array + jsize start + jsize len + jsize buf_len_ = NO_INIT; + jchar * buf + CODE: + { + if (buf_len_ < len) + croak("string is too short"); + else if (buf_len_ > len && PL_dowarn) + warn("string is too long"); + (*env)->SetCharArrayRegion(env, array,start,len,buf); + RESTOREENV; + } + +void +SetShortArrayRegion(array,start,len,buf) + JNIEnv * env = FETCHENV; + STRLEN tmplen = NO_INIT; + jshortArray array + jsize start + jsize len + jsize buf_len_ = NO_INIT; + jshort * buf + CODE: + { + if (buf_len_ < len) + croak("string is too short"); + else if (buf_len_ > len && PL_dowarn) + warn("string is too long"); + (*env)->SetShortArrayRegion(env, array,start,len,buf); + RESTOREENV; + } + +void +SetIntArrayRegion(array,start,len,buf) + JNIEnv * env = FETCHENV; + STRLEN tmplen = NO_INIT; + jintArray array + jsize start + jsize len + jsize buf_len_ = NO_INIT; + jint * buf + CODE: + { + if (buf_len_ < len) + croak("string is too short"); + else if (buf_len_ > len && PL_dowarn) + warn("string is too long"); + (*env)->SetIntArrayRegion(env, array,start,len,buf); + RESTOREENV; + } + +void +SetLongArrayRegion(array,start,len,buf) + JNIEnv * env = FETCHENV; + STRLEN tmplen = NO_INIT; + jlongArray array + jsize start + jsize len + jsize buf_len_ = NO_INIT; + jlong * buf + CODE: + { + if (buf_len_ < len) + croak("string is too short"); + else if (buf_len_ > len && PL_dowarn) + warn("string is too long"); + (*env)->SetLongArrayRegion(env, array,start,len,buf); + RESTOREENV; + } + +void +SetFloatArrayRegion(array,start,len,buf) + JNIEnv * env = FETCHENV; + STRLEN tmplen = NO_INIT; + jfloatArray array + jsize start + jsize len + jsize buf_len_ = NO_INIT; + jfloat * buf + CODE: + { + if (buf_len_ < len) + croak("string is too short"); + else if (buf_len_ > len && PL_dowarn) + warn("string is too long"); + (*env)->SetFloatArrayRegion(env, array,start,len,buf); + RESTOREENV; + } + +void +SetDoubleArrayRegion(array,start,len,buf) + JNIEnv * env = FETCHENV; + STRLEN tmplen = NO_INIT; + jdoubleArray array + jsize start + jsize len + jsize buf_len_ = NO_INIT; + jdouble * buf + CODE: + { + if (buf_len_ < len) + croak("string is too short"); + else if (buf_len_ > len && PL_dowarn) + warn("string is too long"); + (*env)->SetDoubleArrayRegion(env, array,start,len,buf); + RESTOREENV; + } + +SysRet +RegisterNatives(clazz,methods,nMethods) + JNIEnv * env = FETCHENV; + jclass clazz + JNINativeMethod * methods + jint nMethods + CODE: + { + RETVAL = (*env)->RegisterNatives(env, clazz,methods,nMethods); + } + +SysRet +UnregisterNatives(clazz) + JNIEnv * env = FETCHENV; + jclass clazz + CODE: + { + RETVAL = (*env)->UnregisterNatives(env, clazz); + } + OUTPUT: + RETVAL + +SysRet +MonitorEnter(obj) + JNIEnv * env = FETCHENV; + jobject obj + CODE: + { + RETVAL = (*env)->MonitorEnter(env, obj); + RESTOREENV; + } + OUTPUT: + RETVAL + +SysRet +MonitorExit(obj) + JNIEnv * env = FETCHENV; + jobject obj + CODE: + { + RETVAL = (*env)->MonitorExit(env, obj); + RESTOREENV; + } + OUTPUT: + RETVAL + +JavaVM * +GetJavaVM(...) + JNIEnv * env = FETCHENV; + CODE: + { + if (env) { /* We're embedded. */ + if ((*env)->GetJavaVM(env, &RETVAL) < 0) + RETVAL = 0; + } + else { /* We're embedding. */ + JDK1_1InitArgs vm_args; + char *lib; + + if (items--) { + ++mark; + lib = SvPV(*mark, PL_na); + } + else + lib = 0; + + if (!dlopen("libjava.so", RTLD_LAZY|RTLD_GLOBAL)) { + if (lib && !dlopen(lib, RTLD_LAZY|RTLD_GLOBAL)) + croak("Can't load libjava.so"); + } + + JNI_GetDefaultJavaVMInitArgs(&vm_args); + vm_args.exit = &call_my_exit; + while (items > 1) { + char *s = SvPV(*++mark,PL_na); + items -= 2; + if (strEQ(s, "checkSource")) + vm_args.checkSource = (jint)SvIV(*++mark); + else if (strEQ(s, "nativeStackSize")) + vm_args.nativeStackSize = (jint)SvIV(*++mark); + else if (strEQ(s, "javaStackSize")) + vm_args.javaStackSize = (jint)SvIV(*++mark); + else if (strEQ(s, "minHeapSize")) + vm_args.minHeapSize = (jint)SvIV(*++mark); + else if (strEQ(s, "maxHeapSize")) + vm_args.maxHeapSize = (jint)SvIV(*++mark); + else if (strEQ(s, "verifyMode")) + vm_args.verifyMode = (jint)SvIV(*++mark); + else if (strEQ(s, "classpath")) + vm_args.classpath = savepv(SvPV(*++mark,PL_na)); + else if (strEQ(s, "enableClassGC")) + vm_args.enableClassGC = (jint)SvIV(*++mark); + else if (strEQ(s, "enableVerboseGC")) + vm_args.enableVerboseGC = (jint)SvIV(*++mark); + else if (strEQ(s, "disableAsyncGC")) + vm_args.disableAsyncGC = (jint)SvIV(*++mark); + else if (strEQ(s, "verbose")) + vm_args.verbose = (jint)SvIV(*++mark); + else if (strEQ(s, "debugging")) + vm_args.debugging = (jboolean)SvIV(*++mark); + else if (strEQ(s, "debugPort")) + vm_args.debugPort = (jint)SvIV(*++mark); + else + croak("unrecognized option: %s", s); + } + JNI_CreateJavaVM(&RETVAL, &jplcurenv, &vm_args); + } + } + diff --git a/jpl/JNI/Makefile.PL b/jpl/JNI/Makefile.PL new file mode 100644 index 0000000000..2611ff172c --- /dev/null +++ b/jpl/JNI/Makefile.PL @@ -0,0 +1,24 @@ +#!/usr/bin/perl + +$JPL_SRC = ".."; + +use ExtUtils::MakeMaker; +use Config; + +eval `$JPL_SRC/setvars -perl`; + +$java = $ENV{JAVA_HOME}; +$jpl = $ENV{JPL_HOME}; + +$ARCHNAME = $Config{archname}; + +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + NAME => 'JNI', + VERSION_FROM => 'JNI.pm', + LIBS => ["-R$Config{archlib}/CORE -L$Config{archlib}/CORE -R$jpl/lib/$ARCHNAME -L$jpl/lib/$ARCHNAME -lperl -lPerlInterpreter"], + DEFINE => '', + LINKTYPE => 'dynamic', + INC => "-I$java/include -I$java/include/$^O -I$java/include/genunix", +); diff --git a/jpl/JNI/test.pl b/jpl/JNI/test.pl new file mode 100644 index 0000000000..816e28bcf2 --- /dev/null +++ b/jpl/JNI/test.pl @@ -0,0 +1,20 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..1\n"; } +END {print "not ok 1\n" unless $loaded;} +use JNI; +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): + diff --git a/jpl/JNI/typemap b/jpl/JNI/typemap new file mode 100644 index 0000000000..9bd0691be2 --- /dev/null +++ b/jpl/JNI/typemap @@ -0,0 +1,386 @@ +JavaVM * T_JPTROBJ +JNINativeMethod * T_JPTROBJ +const char * T_PV +const jbyte * T_JMEM +const jchar * T_JMEM +jarray T_JPTROBJ +jboolean T_IV +jboolean * T_JMEM +jbooleanArray T_JPTROBJ +jbyte T_IV +jbyte * T_JMEM +jbyteArray T_JPTROBJ +jchar T_IV +jchar * T_JMEM +jcharArray T_JPTROBJ +jclass T_JPTROBJ +jdouble T_NV +jdouble * T_JMEM +jdoubleArray T_JPTROBJ +jfieldID T_JIDSIG +jfloat T_NV +jfloat * T_JMEM +jfloatArray T_JPTROBJ +jint T_IV +jint * T_JMEM +jintArray T_JPTROBJ +jlong T_NV +jlong * T_JMEM +jlongArray T_JPTROBJ +jmethodID T_JIDSIG +jobject T_JPTROBJ +jobjectArray T_JPTROBJ +jshort T_IV +jshort * T_JMEM +jshortArray T_JPTROBJ +jsize T_IV +jstring T_JSTRING +jthrowable T_JPTROBJ +jvalue * T_JVALUELIST + +INPUT +T_JMEM + { + $var = ($type)SvPV($arg,tmplen); + ${var}_len_ = (jsize) tmplen / sizeof(${subtype}); + } +T_JSTRING + if (SvROK($arg)) { + $var = ($type)(void*)SvIV(SvRV($arg)); + } + else + $var = ($type)(*env)->NewStringUTF(env, (char *) SvPV($arg,PL_na)) +T_JVALUELIST + if (SvROK($arg)) { + AV* av = (AV*)SvRV($arg); + if (SvTYPE(av) == SVt_PVAV) { + I32 maxarg = AvFILL(av) + 1; + $var = makeargs(sig, AvARRAY(av), maxarg); + } + else + croak(\"$var is not an array reference\"); + } + else + croak(\"$var is not a reference\") +T_JIDSIG + { + $var = ($type)SvIV($arg); + sig = (char*)SvPV($arg,PL_na); + } +T_JPTROBJ + if (SvROK($arg) && SvOBJECT(SvRV($arg))) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = ($type) tmp; + } + else + croak(\"$var is not of type ${ntype}\") + +OUTPUT +T_JMEM + sv_setpvn((SV*)$arg, (char*)$var, (STRLEN)${var}_len_ * sizeof(${subtype})); +T_JSTRING + { + static HV* ${var}_stashhv_ = 0; + if (!${var}_stashhv_) + ${var}_stashhv_ = gv_stashpv("java::lang::String", TRUE); + + sv_bless( + sv_setref_iv($arg, Nullch, (IV)(void*)${var}), + ${var}_stashhv_); + + } +T_JIDSIG + sv_setiv($arg, (IV)(void*)$var); + sv_setpv($arg, (char*)sig); + SvIOK_on($arg); +T_JPTROBJ + sv_setref_pv($arg, \"${ntype}\", (void*)$var); + +# basic C types +# int T_IV +# unsigned T_IV +# unsigned int T_IV +# long T_IV +# unsigned long T_IV +# short T_IV +# unsigned short T_IV +# char T_CHAR +# unsigned char T_U_CHAR +# char * T_PV +# unsigned char * T_PV +# caddr_t T_PV +# wchar_t * T_PV +# wchar_t T_IV +# bool_t T_IV +# size_t T_IV +# ssize_t T_IV +# time_t T_NV +# unsigned long * T_OPAQUEPTR +# char ** T_PACKED +# void * T_PTR +# Time_t * T_PV +# SV * T_SV +# SVREF T_SVREF +# AV * T_AVREF +# HV * T_HVREF +# CV * T_CVREF +# +# IV T_IV +# I32 T_IV +# I16 T_IV +# I8 T_IV +# U32 T_U_LONG +# U16 T_U_SHORT +# U8 T_IV +# Result T_U_CHAR +# Boolean T_IV +# double T_DOUBLE +# SysRet T_SYSRET +# SysRetLong T_SYSRET +# FILE * T_IN +# FileHandle T_PTROBJ +# InputStream T_IN +# InOutStream T_INOUT +# OutputStream T_OUT +# bool T_BOOL +# +############################################################################# +# INPUT +# T_SV +# $var = $arg +# T_SVREF +# if (sv_isa($arg, \"${ntype}\")) +# $var = (SV*)SvRV($arg); +# else +# croak(\"$var is not of type ${ntype}\") +# T_AVREF +# if (sv_isa($arg, \"${ntype}\")) +# $var = (AV*)SvRV($arg); +# else +# croak(\"$var is not of type ${ntype}\") +# T_HVREF +# if (sv_isa($arg, \"${ntype}\")) +# $var = (HV*)SvRV($arg); +# else +# croak(\"$var is not of type ${ntype}\") +# T_CVREF +# if (sv_isa($arg, \"${ntype}\")) +# $var = (CV*)SvRV($arg); +# else +# croak(\"$var is not of type ${ntype}\") +# T_SYSRET +# $var NOT IMPLEMENTED +# T_IV +# $var = ($type)SvIV($arg) +# T_INT +# $var = (int)SvIV($arg) +# T_ENUM +# $var = ($type)SvIV($arg) +# T_BOOL +# $var = (int)SvIV($arg) +# T_U_INT +# $var = (unsigned int)SvIV($arg) +# T_SHORT +# $var = (short)SvIV($arg) +# T_U_SHORT +# $var = (unsigned short)SvIV($arg) +# T_LONG +# $var = (long)SvIV($arg) +# T_U_LONG +# $var = (unsigned long)SvIV($arg) +# T_CHAR +# $var = (char)*SvPV($arg,PL_na) +# T_U_CHAR +# $var = (unsigned char)SvIV($arg) +# T_FLOAT +# $var = (float)SvNV($arg) +# T_NV +# $var = ($type)SvNV($arg) +# T_DOUBLE +# $var = (double)SvNV($arg) +# T_PV +# $var = ($type)SvPV($arg,PL_na) +# T_PTR +# $var = ($type)SvIV($arg) +# T_PTRREF +# if (SvROK($arg)) { +# IV tmp = SvIV((SV*)SvRV($arg)); +# $var = ($type) tmp; +# } +# else +# croak(\"$var is not a reference\") +# T_REF_IV_REF +# if (sv_isa($arg, \"${type}\")) { +# IV tmp = SvIV((SV*)SvRV($arg)); +# $var = *($type *) tmp; +# } +# else +# croak(\"$var is not of type ${ntype}\") +# T_REF_IV_PTR +# if (sv_isa($arg, \"${type}\")) { +# IV tmp = SvIV((SV*)SvRV($arg)); +# $var = ($type) tmp; +# } +# else +# croak(\"$var is not of type ${ntype}\") +# T_PTROBJ +# if (sv_derived_from($arg, \"${ntype}\")) { +# IV tmp = SvIV((SV*)SvRV($arg)); +# $var = ($type) tmp; +# } +# else +# croak(\"$var is not of type ${ntype}\") +# T_PTRDESC +# if (sv_isa($arg, \"${ntype}\")) { +# IV tmp = SvIV((SV*)SvRV($arg)); +# ${type}_desc = (\U${type}_DESC\E*) tmp; +# $var = ${type}_desc->ptr; +# } +# else +# croak(\"$var is not of type ${ntype}\") +# T_REFREF +# if (SvROK($arg)) { +# IV tmp = SvIV((SV*)SvRV($arg)); +# $var = *($type) tmp; +# } +# else +# croak(\"$var is not a reference\") +# T_REFOBJ +# if (sv_isa($arg, \"${ntype}\")) { +# IV tmp = SvIV((SV*)SvRV($arg)); +# $var = *($type) tmp; +# } +# else +# croak(\"$var is not of type ${ntype}\") +# T_OPAQUE +# $var NOT IMPLEMENTED +# T_OPAQUEPTR +# $var = ($type)SvPV($arg,PL_na) +# T_PACKED +# $var = XS_unpack_$ntype($arg) +# T_PACKEDARRAY +# $var = XS_unpack_$ntype($arg) +# T_CALLBACK +# $var = make_perl_cb_$type($arg) +# T_ARRAY +# $var = $ntype(items -= $argoff); +# U32 ix_$var = $argoff; +# while (items--) { +# DO_ARRAY_ELEM; +# } +# T_IN +# $var = IoIFP(sv_2io($arg)) +# T_INOUT +# $var = IoIFP(sv_2io($arg)) +# T_OUT +# $var = IoOFP(sv_2io($arg)) +############################################################################## +# OUTPUT +# T_SV +# $arg = $var; +# T_SVREF +# $arg = newRV((SV*)$var); +# T_AVREF +# $arg = newRV((SV*)$var); +# T_HVREF +# $arg = newRV((SV*)$var); +# T_CVREF +# $arg = newRV((SV*)$var); +# T_IV +# sv_setiv($arg, (IV)$var); +# T_INT +# sv_setiv($arg, (IV)$var); +# T_SYSRET +# if ($var != -1) { +# if ($var == 0) +# sv_setpvn($arg, "0 but true", 10); +# else +# sv_setiv($arg, (IV)$var); +# } +# T_ENUM +# sv_setiv($arg, (IV)$var); +# T_BOOL +# $arg = boolSV($var); +# T_U_INT +# sv_setiv($arg, (IV)$var); +# T_SHORT +# sv_setiv($arg, (IV)$var); +# T_U_SHORT +# sv_setiv($arg, (IV)$var); +# T_LONG +# sv_setiv($arg, (IV)$var); +# T_U_LONG +# sv_setiv($arg, (IV)$var); +# T_CHAR +# sv_setpvn($arg, (char *)&$var, 1); +# T_U_CHAR +# sv_setiv($arg, (IV)$var); +# T_FLOAT +# sv_setnv($arg, (double)$var); +# T_NV +# sv_setnv($arg, (double)$var); +# T_DOUBLE +# sv_setnv($arg, (double)$var); +# T_PV +# sv_setpv((SV*)$arg, $var); +# T_PTR +# sv_setiv($arg, (IV)$var); +# T_PTRREF +# sv_setref_pv($arg, Nullch, (void*)$var); +# T_REF_IV_REF +# sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var)); +# T_REF_IV_PTR +# sv_setref_pv($arg, \"${ntype}\", (void*)$var); +# T_PTROBJ +# sv_setref_pv($arg, \"${ntype}\", (void*)$var); +# T_PTRDESC +# sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var)); +# T_REFREF +# sv_setrefref($arg, \"${ntype}\", XS_service_$ntype, +# ($var ? (void*)new $ntype($var) : 0)); +# T_REFOBJ +# NOT IMPLEMENTED +# T_OPAQUE +# sv_setpvn($arg, (char *)&$var, sizeof($var)); +# T_OPAQUEPTR +# sv_setpvn($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var); +# T_PACKED +# XS_pack_$ntype($arg, $var); +# T_PACKEDARRAY +# XS_pack_$ntype($arg, $var, count_$ntype); +# T_DATAUNIT +# sv_setpvn($arg, $var.chp(), $var.size()); +# T_CALLBACK +# sv_setpvn($arg, $var.context.value().chp(), +# $var.context.value().size()); +# T_ARRAY +# ST_EXTEND($var.size); +# for (U32 ix_$var = 0; ix_$var < $var.size; ix_$var++) { +# ST(ix_$var) = sv_newmortal(); +# DO_ARRAY_ELEM +# } +# sp += $var.size - 1; +# T_IN +# { +# GV *gv = newGVgen("$Package"); +# if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) +# sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); +# else +# $arg = &PL_sv_undef; +# } +# T_INOUT +# { +# GV *gv = newGVgen("$Package"); +# if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) +# sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); +# else +# $arg = &PL_sv_undef; +# } +# T_OUT +# { +# GV *gv = newGVgen("$Package"); +# if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) +# sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); +# else +# $arg = &PL_sv_undef; +# } diff --git a/jpl/JPL/AutoLoader.pm b/jpl/JPL/AutoLoader.pm new file mode 100644 index 0000000000..94d98563fd --- /dev/null +++ b/jpl/JPL/AutoLoader.pm @@ -0,0 +1,352 @@ +package JPL::AutoLoader; + +use strict; + +use vars qw(@ISA @EXPORT $AUTOLOAD); + +use Exporter; +@ISA = "Exporter"; +@EXPORT = ("AUTOLOAD", "getmeth"); + +my %callmethod = ( + V => 'Void', + Z => 'Boolean', + B => 'Byte', + C => 'Char', + S => 'Short', + I => 'Int', + J => 'Long', + F => 'Float', + D => 'Double', +); + +# A lookup table to convert the data types that Java +# developers are used to seeing into the JNI-mangled +# versions. +# +# bjepson 13 August 1997 +# +my %type_table = ( + 'void' => 'V', + 'boolean' => 'Z', + 'byte' => 'B', + 'char' => 'C', + 'short' => 'S', + 'int' => 'I', + 'long' => 'J', + 'float' => 'F', + 'double' => 'D' +); + +# A cache for method ids. +# +# bjepson 13 August 1997 +# +my %MID_CACHE; + +# A cache for methods. +# +# bjepson 13 August 1997 +# +my %METHOD_CACHE; + +use JNI; + +# XXX We're assuming for the moment that method ids are persistent... + +sub AUTOLOAD { + + print "AUTOLOAD $AUTOLOAD(@_)\n" if $JPL::DEBUG; + my ($classname, $methodsig) = $AUTOLOAD =~ /^(.*)::(.*)/; + print "class = $classname, method = $methodsig\n" if $JPL::DEBUG; + + if ($methodsig eq "DESTROY") { + print "sub $AUTOLOAD {}\n" if $JPL::DEBUG; + eval "sub $AUTOLOAD {}"; + return; + } + + (my $jclassname = $classname) =~ s/^JPL:://; + $jclassname =~ s{::}{/}g; + my $class = JNI::FindClass($jclassname) + or die "Can't find Java class $jclassname\n"; + + # This method lookup allows the user to pass in + # references to two array that contain the input and + # output data types of the method. + # + # bjepson 13 August 1997 + # + my ($methodname, $sig, $retsig, $slow_way); + if (ref $_[1] eq 'ARRAY' && ref $_[2] eq 'ARRAY') { + + $slow_way = 1; + + # First we strip out the input and output args. + # + my ($in,$out) = splice(@_, 1, 2); + + # let's mangle up the input argument types. + # + my @in = jni_mangle($in); + + # if they didn't hand us any output values types, make + # them void by default. + # + unless (@{ $out }) { + $out = ['void']; + } + + # mangle the output types + # + my @out = jni_mangle($out); + + $methodname = $methodsig; + $retsig = join("", @out); + $sig = "(" . join("", @in) . ")" . $retsig; + + } else { + + ($methodname, $sig) = split /__/, $methodsig, 2; + $sig ||= "__V"; # default is void return + + # Now demangle the signature. + + $sig =~ s/_3/[/g; + $sig =~ s/_2/;/g; + my $tmp; + $sig =~ s{ + (s|L[^;]*;) + }{ + $1 eq 's' + ? "Ljava/lang/String;" + : (($tmp = $1) =~ tr[_][/], $tmp) + }egx; + if ($sig =~ s/(.*)__(.*)/($1)$2/) { + $retsig = $2; + } + else { # void return is assumed + $sig = "($sig)V"; + $retsig = "V"; + } + $sig =~ s/_1/_/g; + } + print "sig = $sig\n" if $JPL::DEBUG; + + # Now look up the method's ID somehow or other. + # + $methodname = "<init>" if $methodname eq 'new'; + my $mid; + + # Added a method id cache to compensate for avoiding + # Perl's method cache... + # + if ($MID_CACHE{qq[$classname:$methodname:$sig]}) { + + $mid = $MID_CACHE{qq[$classname:$methodname:$sig]}; + print "got method " . ($mid + 0) . " from cache.\n" if $JPL::DEBUG; + + } elsif (ref $_[0] or $methodname eq '<init>') { + + # Look up an instance method or a constructor + # + $mid = JNI::GetMethodID($class, $methodname, $sig); + + } else { + + # Look up a static method + # + $mid = JNI::GetStaticMethodID($class, $methodname, $sig); + + } + + # Add this method to the cache. + # + # bjepson 13 August 1997 + # + $MID_CACHE{qq[$classname:$methodname:$sig]} = $mid if $slow_way; + + if ($mid == 0) { + + JNI::ExceptionClear(); + # Could do some guessing here on return type... + die "Can't get method id for $AUTOLOAD($sig)\n"; + + } + + print "mid = ", $mid + 0, ", $mid\n" if $JPL::DEBUG; + my $rettype = $callmethod{$retsig} || "Object"; + print "*** rettype = $rettype\n" if $JPL::DEBUG; + + my $blesspack; + no strict 'refs'; + if ($rettype eq "Object") { + $blesspack = $retsig; + $blesspack =~ s/^L//; + $blesspack =~ s/;$//; + $blesspack =~ s#/#::#g; + print "*** Some sort of wizardry...\n" if $JPL::DEBUG; + print %{$blesspack . "::"}, "\n" if $JPL::DEBUG; + print defined %{$blesspack . "::"}, "\n" if $JPL::DEBUG; + if (not defined %{$blesspack . "::"}) { + #if ($blesspack eq "java::lang::String") { + if ($blesspack =~ /java::/) { + eval <<"END" . <<'ENDQ'; +package $blesspack; +END +use JPL::AutoLoader; +use overload + '""' => sub { JNI::GetStringUTFChars($_[0]) }, + '0+' => sub { 0 + "$_[0]" }, + fallback => 1; +ENDQ + } + else { + eval <<"END"; +package $blesspack; +use JPL::AutoLoader; +END + } + } + } + + # Finally, call the method. Er, somehow... + # + my $METHOD; + + my $real_mid = $mid + 0; # weird overloading that I + # don't understand ?! + if (ref ${$METHOD_CACHE{qq[$real_mid]}} eq 'CODE') { + + $METHOD = ${$METHOD_CACHE{qq[$real_mid]}}; + print qq[Pulled $classname, $methodname, $sig from cache.\n] if $JPL::DEBUG; + + } elsif ($methodname eq "<init>") { + $METHOD = sub { + my $self = shift; + my $class = JNI::FindClass($jclassname); + bless $class->JNI::NewObjectA($mid, \@_), $classname; + }; + } + elsif (ref $_[0]) { + if ($blesspack) { + $METHOD = sub { + my $self = shift; + if (ref $self eq $classname) { + my $callmethod = "JNI::Call${rettype}MethodA"; + bless $self->$callmethod($mid, \@_), $blesspack; + } + else { + my $callmethod = "JNI::CallNonvirtual${rettype}MethodA"; + bless $self->$callmethod($class, $mid, \@_), $blesspack; + } + }; + } + else { + $METHOD = sub { + my $self = shift; + if (ref $self eq $classname) { + my $callmethod = "JNI::Call${rettype}MethodA"; + $self->$callmethod($mid, \@_); + } + else { + my $callmethod = "JNI::CallNonvirtual${rettype}MethodA"; + $self->$callmethod($class, $mid, \@_); + } + }; + } + } + else { + my $callmethod = "JNI::CallStatic${rettype}MethodA"; + if ($blesspack) { + $METHOD = sub { + my $self = shift; + bless $class->$callmethod($mid, \@_), $blesspack; + }; + } + else { + $METHOD = sub { + my $self = shift; + $class->$callmethod($mid, \@_); + }; + } + } + if ($slow_way) { + $METHOD_CACHE{qq[$real_mid]} = \$METHOD; + &$METHOD; + } + else { + *$AUTOLOAD = $METHOD; + goto &$AUTOLOAD; + } +} + +sub jni_mangle { + + my $arr = shift; + my @ret; + + foreach my $arg (@{ $arr }) { + + my $ret; + + # Count the dangling []s. + # + $ret = '[' x $arg =~ s/\[\]//g; + + # Is it a primitive type? + # + if ($type_table{$arg}) { + $ret .= $type_table{$arg}; + } else { + # some sort of class + # + $arg =~ s#\.#/#g; + $ret .= "L$arg;"; + } + push @ret, $ret; + + } + + return @ret; + +} + +sub getmeth { + my ($meth, $in, $out) = @_; + my @in = jni_mangle($in); + + # if they didn't hand us any output values types, make + # them void by default. + # + unless ($out and @$out) { + $out = ['void']; + } + + # mangle the output types + # + my @out = jni_mangle($out); + + my $sig = join("", '#', @in, '#', @out); + $sig =~ s/_/_1/g; + my $tmp; + $sig =~ s{ + (L[^;]*;) + }{ + ($tmp = $1) =~ tr[/][_], $tmp + }egx; + $sig =~ s{Ljava/lang/String;}{s}g; + $sig =~ s/;/_2/g; + $sig =~ s/\[/_3/g; + $sig =~ s/#/__/g; + $meth . $sig; +} + +{ + package java::lang::String; + use overload + '""' => sub { JNI::GetStringUTFChars($_[0]) }, + '0+' => sub { 0 + "$_[0]" }, + fallback => 1; +} +1; diff --git a/jpl/JPL/Class.pm b/jpl/JPL/Class.pm new file mode 100644 index 0000000000..1bc97688a8 --- /dev/null +++ b/jpl/JPL/Class.pm @@ -0,0 +1,13 @@ +package JPL::Class; +use JPL::AutoLoader (); + +sub DESTROY {} + +sub import { + my $class = shift; + foreach $class (@_) { + *{$class . "::AUTOLOAD"} = *JPL::AutoLoader::AUTOLOAD; + *{$class . "::DESTROY"} = \&DESTROY; + } +} +1; diff --git a/jpl/JPL/Compile.pm b/jpl/JPL/Compile.pm new file mode 100755 index 0000000000..6d9511245e --- /dev/null +++ b/jpl/JPL/Compile.pm @@ -0,0 +1,769 @@ +#!/usr/bin/perl -w + +# Copyright 1997, O'Reilly & Associate, Inc. +# +# This package may be copied under the same terms as Perl itself. + +package JPL::Compile; +use Exporter (); +@ISA = qw(Exporter); +@EXPORT = qw(files file); + +use strict; + + +warn "You don't have a recent JDK kit your PATH, so this may fail.\n" + unless $ENV{PATH} =~ /(java|jdk1.[1-9])/; + +sub emit; + +my $PERL = ""; +my $LASTCLASS = ""; +my $PERLLINE = 0; +my $PROTO; + +my @protos; + +my $plfile; +my $jpfile; +my $hfile; +my $h_file; +my $cfile; +my $jfile; +my $classfile; + +my $DEBUG = $ENV{JPLDEBUG}; + +my %ptype = qw( + Z boolean + B byte + C char + S short + I int + J long + F float + D double +); + +$ENV{CLASSPATH} =~ s/^/.:/ unless $ENV{CLASSPATH} =~ /^\.(?::|$)/; + +unless (caller) { + files(@ARGV); +} + +####################################################################### + +sub files { + foreach my $jpfile (@_) { + file($jpfile); + } + print "make\n"; + system "make"; +} + +sub file { + my $jpfile = shift; + my $JAVA = ""; + my $lastpos = 0; + my $linenum = 2; + my %classseen; + my %fieldsig; + my %staticfield; + + (my $file = $jpfile) =~ s/\.jpl$//; + $jpfile = "$file.jpl"; + $jfile = "$file.java"; + $hfile = "$file.h"; + $cfile = "$file.c"; + $plfile = "$file.pl"; + $classfile = "$file.class"; + + ($h_file = $hfile) =~ s/_/_0005f/g; + + emit_c_header(); + + # Extract out arg names from .java file, since .class doesn't have 'em. + + open(JPFILE, $jpfile) or die "Can't open $jpfile: $!\n"; + undef $/; + $_ = <JPFILE>; + close JPFILE; + + die "$jpfile doesn't seem to define class $file!\n" + unless /class\s+\b$file\b[\w\s.,]*{/; + + @protos = (); + open(JFILE, ">$jfile") or die "Can't create $jfile: $!\n"; + + while (m/\bperl\b([^\n]*?\b(\w+)\s*\(\s*(.*?)\s*\)[\s\w.,]*)\{\{(.*?)\}\}/sg) { + $JAVA = substr($`, $lastpos); + $lastpos = pos $_; + $JAVA .= "native"; + $JAVA .= $1; + + my $method = $2; + + my $proto = $3; + + my $perl = $4; + (my $repl = $4) =~ tr/\n//cd; + $JAVA .= ';'; + $linenum += $JAVA =~ tr/\n/\n/; + $JAVA .= $repl; + print JFILE $JAVA; + + $proto =~ s/\s+/ /g; + $perl =~ s/^[ \t]+\Z//m; + $perl =~ s/^[ \t]*\n//; + push(@protos, [$method, $proto, $perl, $linenum]); + + $linenum += $repl =~ tr/\n/\n/; + } + + print JFILE <<"END"; + static { + System.loadLibrary("$file"); + PerlInterpreter pi = new PerlInterpreter().fetch(); + // pi.eval("\$JPL::DEBUG = \$ENV{JPLDEBUG};"); + pi.eval("warn qq{loading $file\\n} if \$JPL::DEBUG"); + pi.eval("eval {require '$plfile'}; print \$@ if \$@;"); + } +END + + print JFILE substr($_, $lastpos); + + close JFILE; + + # Produce the corresponding .h file. Should really use make... + + if (not -s $hfile or -M $hfile > -M $jfile) { + if (not -s $classfile or -M $classfile > -M $jfile) { + unlink $classfile; + print "javac $jfile\n"; + system "javac $jfile" and die "Couldn't run javac: exit $?\n"; + if (not -s $classfile or -M $classfile > -M $jfile) { + die "Couldn't produce $classfile from $jfile!"; + } + } + unlink $hfile; + print "javah -jni $file\n"; + system "javah -jni $file" and die "Couldn't run javah: exit $?\n"; + if (not -s $hfile and -s $h_file) { + rename $h_file, $hfile; + } + if (not -s $hfile or -M $hfile > -M $jfile) { + die "Couldn't produce $hfile from $classfile!"; + } + } + + # Easiest place to get fields is from javap. + + print "javap -s $file\n"; + open(JP, "javap -s $file|"); + $/ = "\n"; + while (<JP>) { + if (/^\s+([A-Za-z_].*) (\w+)[\[\d\]]*;/) { + my $jtype = $1; + my $name = $2; + $_ = <JP>; + s!^\s*/\*\s*!!; + s!\s*\*/\s*!!; + print "Field $jtype $name $_\n" if $DEBUG; + $fieldsig{$name} = $_; + $staticfield{$name} = $jtype =~ /\bstatic\b/; + } + while (m/L([^;]*);/g) { + my $pclass = j2p_class($1); + $classseen{$pclass}++; + } + } + close JP; + + open(HFILE, $hfile) or die "Couldn't open $hfile: $!\n"; + undef $/; + $_ = <HFILE>; + close HFILE; + + die "panic: native method mismatch" if @protos != s/^JNIEXPORT/JNIEXPORT/gm; + + $PROTO = 0; + while (m{ + \*\s*Class:\s*(\w+)\s* + \*\s*Method:\s*(\w+)\s* + \*\s*Signature:\s*(\S+)\s*\*/\s* + JNIEXPORT\s*(.*?)\s*JNICALL\s*(\w+)\s*\((.*?)\) + }gx) { + my $class = $1; + my $method = $2; + my $signature = $3; + my $rettype = $4; + my $cname = $5; + my $ctypes = $6; + $class =~ s/_0005f/_/g; + if ($method ne $protos[$PROTO][0]) { + die "Method name mismatch: $method vs $protos[$PROTO][0]\n"; + } + print "$class.$method($protos[$PROTO][1]) => + $signature + $rettype $cname($ctypes)\n" if $DEBUG; + + # Insert argument names into parameter list. + + my $env = "env"; + my $obj = "obj"; + my @jargs = split(/\s*,\s*/, $protos[$PROTO][1]); + foreach my $arg (@jargs) { + $arg =~ s/^.*\b(\w+).*$/${1}/; + } + my @tmpargs = @jargs; + unshift(@tmpargs, $env, $obj); + print "\t@tmpargs\n" if $DEBUG; + $ctypes .= ","; + $ctypes =~ s/,/' ' . shift(@tmpargs) . '_,'/eg; + $ctypes =~ s/,$//; + $ctypes =~ s/env_/env/; + $ctypes =~ s/obj_/obj/; + print "\t$ctypes\n" if $DEBUG; + + my $jlen = @jargs + 1; + + (my $mangclass = $class) =~ s/_/_1/g; + (my $mangmethod = $method) =~ s/_/_1/g; + my $plname = $cname; + $plname =~ s/^Java_${mangclass}_${mangmethod}/JPL::${class}::${method}/; + $plname =~ s/Ljava_lang_String_2/s/g; + + # Make glue code for each argument. + + (my $sig = $signature) =~ s/^\(//; + + my $decls = ""; + my $glue = ""; + + foreach my $jarg (@jargs) { + if ($sig =~ s/^[ZBCSI]//) { + $glue .= <<""; +! /* $jarg */ +! PUSHs(sv_2mortal(newSViv(${jarg}_))); +! + + } + elsif ($sig =~ s/^[JFD]//) { + $glue .= <<""; +! /* $jarg */ +! PUSHs(sv_2mortal(newSVnv(${jarg}_))); +! + + } + elsif ($sig =~ s#^Ljava/lang/String;##) { + $glue .= <<""; +! /* $jarg */ +! tmpjb = (jbyte*)(*env)->GetStringUTFChars(env,${jarg}_,0); +! PUSHs(sv_2mortal(newSVpv((char*)tmpjb,0))); +! (*env)->ReleaseStringUTFChars(env,${jarg}_,tmpjb); +! + + } + elsif ($sig =~ s/^L([^;]*);//) { + my $pclass = j2p_class($1); + $classseen{$pclass}++; + $glue .= <<""; +! /* $jarg */ +! if (!${jarg}_stashhv_) +! ${jarg}_stashhv_ = gv_stashpv("$pclass", TRUE); +! +! PUSHs(sv_bless( +! sv_setref_iv(sv_newmortal(), Nullch, (IV)(void*)${jarg}_), +! ${jarg}_stashhv_)); +! if (jpldebug) +! fprintf(stderr, "Done with $jarg\\n"); +! + + $decls .= <<""; +! static HV* ${jarg}_stashhv_ = 0; + + + } + elsif ($sig =~ s/^\[+([ZBCSIJFD]|L[^;]*;)//) { + my $pclass = "jarray"; + $classseen{$pclass}++; + $glue .= <<""; +! /* $jarg */ +! if (!${jarg}_stashhv_) +! ${jarg}_stashhv_ = gv_stashpv("$pclass", TRUE); +! +! PUSHs(sv_bless( +! sv_setref_iv(sv_newmortal(), Nullch, (IV)(void*)${jarg}_), +! ${jarg}_stashhv_)); +! if (jpldebug) +! fprintf(stderr, "Done with $jarg\\n"); +! + + $decls .= <<""; +! static HV* ${jarg}_stashhv_ = 0; + + } + else { + die "Short signature: $signature\n" if $sig eq ""; + die "Unrecognized letter '" . substr($sig, 0, 1) . "' in signature $signature\n"; + } + } + + $sig =~ s/^\)// or die "Argument mismatch in signature: $method$signature\n"; + + my $void = $signature =~ /\)V$/; + + $decls .= <<"" if $signature =~ m#java/lang/String#; +! jbyte* tmpjb; + + $decls .= <<"" unless $void; +! SV* retsv; +! $rettype retval; +! +! if (jpldebug) +! fprintf(stderr, "Got to $cname\\n"); +! ENTER; +! SAVETMPS; + + emit <<""; +!JNIEXPORT $rettype JNICALL +!$cname($ctypes) +!{ +! static SV* methodsv = 0; +! static HV* stashhv = 0; +! dSP; +$decls +! PUSHMARK(sp); +! EXTEND(sp,$jlen); +! +! sv_setiv(perl_get_sv("JPL::_env_", 1), (IV)(void*)env); +! jplcurenv = env; +! +! if (jpldebug) +! fprintf(stderr, "env = %lx\\n", (long)$env); +! +! if (!methodsv) +! methodsv = (SV*)perl_get_cv("$plname", TRUE); +! if (!stashhv) +! stashhv = gv_stashpv("JPL::$class", TRUE); +! +! if (jpldebug) +! fprintf(stderr, "blessing obj = %lx\\n", obj); +! PUSHs(sv_bless( +! sv_setref_iv(sv_newmortal(), Nullch, (IV)(void*)obj), +! stashhv)); +! +$glue + + # Finally, call the subroutine. + + my $mod; + $mod = "|G_DISCARD" if $void; + + if ($void) { + emit <<""; +! PUTBACK; +! perl_call_sv(methodsv, G_EVAL|G_KEEPERR|G_DISCARD); +! + + } + else { + emit <<""; +! PUTBACK; +! if (perl_call_sv(methodsv, G_EVAL|G_KEEPERR)) +! retsv = *PL_stack_sp--; +! else +! retsv = &PL_sv_undef; +! + + } + + emit <<""; +! if (SvTRUE(ERRSV)) { +! jthrowable newExcCls; +! +! (*env)->ExceptionDescribe(env); +! (*env)->ExceptionClear(env); +! +! newExcCls = (*env)->FindClass(env, "java/lang/RuntimeException"); +! if (newExcCls) +! (*env)->ThrowNew(env, newExcCls, SvPV(ERRSV,PL_na)); +! } +! + + # Fix up the return value, if any. + + if ($sig =~ s/^V//) { + emit <<""; +! return; + + } + elsif ($sig =~ s/^[ZBCSI]//) { + emit <<""; +! retval = ($rettype)SvIV(retsv); +! FREETMPS; +! LEAVE; +! return retval; + + } + elsif ($sig =~ s/^[JFD]//) { + emit <<""; +! retval = ($rettype)SvNV(retsv); +! FREETMPS; +! LEAVE; +! return retval; + + } + elsif ($sig =~ s#^Ljava/lang/String;##) { + emit <<""; +! retval = (*env)->NewStringUTF(env, SvPV(retsv,PL_na)); +! FREETMPS; +! LEAVE; +! return retval; + + } + elsif ($sig =~ s/^L[^;]*;//) { + emit <<""; +! if (SvROK(retsv)) { +! SV* rv = (SV*)SvRV(retsv); +! if (SvOBJECT(rv)) +! retval = ($rettype)(void*)SvIV(rv); +! else +! retval = ($rettype)(void*)0; +! } +! else +! retval = ($rettype)(void*)0; +! FREETMPS; +! LEAVE; +! return retval; + + } + elsif ($sig =~ s/^\[([ZBCSIJFD])//) { + my $elemtype = $1; + my $ptype = "\u$ptype{$elemtype}"; + my $ntype = "j$ptype{$elemtype}"; + my $in = $elemtype =~ /^[JFD]/ ? "N" : "I"; + emit <<""; +! if (SvROK(retsv)) { +! SV* rv = (SV*)SvRV(retsv); +! if (SvOBJECT(rv)) +! retval = ($rettype)(void*)SvIV(rv); +! else if (SvTYPE(rv) == SVt_PVAV) { +! jsize len = av_len((AV*)rv) + 1; +! $ntype* buf = ($ntype*)malloc(len * sizeof($ntype)); +! int i; +! SV** esv; +! +! ${ntype}Array ja = (*env)->New${ptype}Array(env, len); +! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) +! buf[i] = ($ntype)Sv${in}V(*esv); +! (*env)->Set${ptype}ArrayRegion(env, ja, 0, len, buf); +! free((void*)buf); +! retval = ($rettype)ja; +! } +! else +! retval = ($rettype)(void*)0; +! } +! else if (SvPOK(retsv)) { +! jsize len = sv_len(retsv) / sizeof($ntype); +! +! ${ntype}Array ja = (*env)->New${ptype}Array(env, len); +! (*env)->Set${ptype}ArrayRegion(env, ja, 0, len, ($ntype*)SvPV(retsv,PL_na)); +! retval = ($rettype)ja; +! } +! else +! retval = ($rettype)(void*)0; +! FREETMPS; +! LEAVE; +! return retval; + + } + elsif ($sig =~ s!^\[Ljava/lang/String;!!) { + emit <<""; +! if (SvROK(retsv)) { +! SV* rv = (SV*)SvRV(retsv); +! if (SvOBJECT(rv)) +! retval = ($rettype)(void*)SvIV(rv); +! else if (SvTYPE(rv) == SVt_PVAV) { +! jsize len = av_len((AV*)rv) + 1; +! int i; +! SV** esv; +! static jclass jcl = 0; +! jarray ja; +! +! if (!jcl) +! jcl = (*env)->FindClass(env, "java/lang/String"); +! ja = (*env)->NewObjectArray(env, len, jcl, 0); +! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) { +! jobject str = (jobject)(*env)->NewStringUTF(env, SvPV(*esv,PL_na)); +! (*env)->SetObjectArrayElement(env, ja, i, str); +! } +! retval = ($rettype)ja; +! } +! else +! retval = ($rettype)(void*)0; +! } +! else +! retval = ($rettype)(void*)0; +! FREETMPS; +! LEAVE; +! return retval; + + } + elsif ($sig =~ s/^(\[+)([ZBCSIJFD]|L[^;]*;)//) { + my $arity = length $1; + my $elemtype = $2; + emit <<""; +! if (SvROK(retsv)) { +! SV* rv = (SV*)SvRV(retsv); +! if (SvOBJECT(rv)) +! retval = ($rettype)(void*)SvIV(rv); +! else if (SvTYPE(rv) == SVt_PVAV) { +! jsize len = av_len((AV*)rv) + 1; +! int i; +! SV** esv; +! static jclass jcl = 0; +! jarray ja; +! +! if (!jcl) +! jcl = (*env)->FindClass(env, "java/lang/Object"); +! ja = (*env)->NewObjectArray(env, len, jcl, 0); +! for (esv = AvARRAY((AV*)rv), i = 0; i < len; esv++, i++) { +! if (SvROK(*esv) && (rv = SvRV(*esv)) && SvOBJECT(rv)) { +! (*env)->SetObjectArrayElement(env, ja, i, +! (jobject)(void*)SvIV(rv)); +! } +! else { +! jobject str = (jobject)(*env)->NewStringUTF(env, +! SvPV(*esv,PL_na)); +! (*env)->SetObjectArrayElement(env, ja, i, str); +! } +! } +! retval = ($rettype)ja; +! } +! else +! retval = ($rettype)(void*)0; +! } +! else +! retval = ($rettype)(void*)0; +! FREETMPS; +! LEAVE; +! return retval; + + } + else { + die "No return type: $signature\n" if $sig eq ""; + die "Unrecognized return type '" . substr($sig, 0, 1) . "' in signature $signature\n"; + } + + emit <<""; +!} +! + + my $perl = ""; + + if ($class ne $LASTCLASS) { + $LASTCLASS = $class; + $perl .= <<""; +package JPL::${class}; +use JNI; +use JPL::AutoLoader; +\@ISA = qw(jobject); +\$clazz = JNI::FindClass("$file");\n + + foreach my $field (sort keys %fieldsig) { + my $sig = $fieldsig{$field}; + my $ptype = $ptype{$sig}; + if ($ptype) { + $ptype = "\u$ptype"; + if ($staticfield{$field}) { + $perl .= <<""; +\$${field}_FieldID = JNI::GetStaticFieldID(\$clazz, "$field", "$sig"); +sub $field (\$;\$) { + my \$self = shift; + if (\@_) { + JNI::SetStatic${ptype}Field(\$clazz, \$${field}_FieldID, \$_[0]); + } + else { + JNI::GetStatic${ptype}Field(\$clazz, \$${field}_FieldID); + } +}\n + + } + else { + $perl .= <<""; +\$${field}_FieldID = JNI::GetFieldID(\$clazz, "$field", "$sig"); +sub $field (\$;\$) { + my \$self = shift; + if (\@_) { + JNI::Set${ptype}Field(\$self, \$${field}_FieldID, \$_[0]); + } + else { + JNI::Get${ptype}Field(\$self, \$${field}_FieldID); + } +}\n + + } + } + else { + my $pltype = $sig; + if ($pltype =~ s/^L(.*);/$1/) { + $pltype =~ s!/!::!g; + } + else { + $pltype = 'jarray'; + } + if ($pltype eq "java::lang::String") { + if ($staticfield{$field}) { + $perl .= <<""; +\$${field}_FieldID = JNI::GetStaticFieldID(\$clazz, "$field", "$sig"); +sub $field (\$;\$) { + my \$self = shift; + if (\@_) { + JNI::SetStaticObjectField(\$clazz, \$${field}_FieldID, + ref \$_[0] ? \$_[0] : JNI::NewStringUTF(\$_[0])); + } + else { + JNI::GetStringUTFChars(JNI::GetStaticObjectField(\$clazz, \$${field}_FieldID)); + } +}\n + + } + else { + $perl .= <<""; +\$${field}_FieldID = JNI::GetFieldID(\$clazz, "$field", "$sig"); +sub $field (\$;\$) { + my \$self = shift; + if (\@_) { + JNI::SetObjectField(\$self, \$${field}_FieldID, + ref \$_[0] ? \$_[0] : JNI::NewStringUTF(\$_[0])); + } + else { + JNI::GetStringUTFChars(JNI::GetObjectField(\$self, \$${field}_FieldID)); + } +}\n + + } + } + else { + if ($staticfield{$field}) { + $perl .= <<""; +\$${field}_FieldID = JNI::GetStaticFieldID(\$clazz, "$field", "$sig"); +sub $field (\$;\$) { + my \$self = shift; + if (\@_) { + JNI::SetStaticObjectField(\$clazz, \$${field}_FieldID, \$_[0]); + } + else { + bless JNI::GetStaticObjectField(\$clazz, \$${field}_FieldID), "$pltype"; + } +}\n + + } + else { + $perl .= <<""; +\$${field}_FieldID = JNI::GetFieldID(\$clazz, "$field", "$sig"); +sub $field (\$;\$) { + my \$self = shift; + if (\@_) { + JNI::SetObjectField(\$self, \$${field}_FieldID, \$_[0]); + } + else { + bless JNI::GetObjectField(\$self, \$${field}_FieldID), "$pltype"; + } +}\n + + } + } + } + } + } + + $plname =~ s/^JPL::${class}:://; + + my $proto = '$' x (@jargs + 1); + $perl .= "sub $plname ($proto) {\n"; + $perl .= ' my ($self, '; + foreach my $jarg (@jargs) { + $perl .= "\$$jarg, "; + } + $perl =~ s/, $/) = \@_;\n/; + $perl .= <<"END"; + warn "JPL::${class}::$plname(\@_)\\n" if \$JPL::DEBUG; +#line $protos[$PROTO][3] "$jpfile" +$protos[$PROTO][2]} + +END + + $PERLLINE += $perl =~ tr/\n/\n/ + 2; + $perl .= <<"END"; +#line $PERLLINE "" +END + $PERLLINE--; + + $PERL .= $perl; + } + continue { + $PROTO++; + print "\n" if $DEBUG; + } + + emit_c_footer(); + + rename $cfile, "$cfile.old"; + rename "$cfile.new", $cfile; + + open(PLFILE, ">$plfile") or die "Can't create $plfile: $!\n"; + print PLFILE "BEGIN { \$JPL::_env_ ||= 1; } # suppress bogus embedding\n\n"; + if (%classseen) { + my @classes = sort keys %classseen; + print PLFILE "use JPL::Class qw(@classes);\n\n"; + } + print PLFILE $PERL; + print PLFILE "1;\n"; + close PLFILE; + + print "perl -c $plfile\n"; + system "perl -c $plfile" and die "jpl stopped\n"; +} + +sub emit_c_header { + open(CFILE, ">$cfile.new") or die "Can't create $cfile.new: $!\n"; + emit <<""; +!/* This file is automatically generated. Do not modify! */ +! +!#include "$hfile" +! +!#include "EXTERN.h" +!#include "perl.h" +! +!#ifndef EXTERN_C +!# ifdef __cplusplus +!# define EXTERN_C extern "C" +!# else +!# define EXTERN_C extern +!# endif +!#endif +! +!extern int jpldebug; +!extern JNIEnv* jplcurenv; +! + +} + + +sub emit_c_footer { + close CFILE; +} + +sub emit { + my $string = shift; + $string =~ s/^!//mg; + print CFILE $string; +} + +sub j2p_class { + my $jclass = shift; + $jclass =~ s#/#::#g; + $jclass; +} diff --git a/jpl/JPL/Makefile.PL b/jpl/JPL/Makefile.PL new file mode 100644 index 0000000000..efb606da17 --- /dev/null +++ b/jpl/JPL/Makefile.PL @@ -0,0 +1,36 @@ +#!/usr/bin/perl + +$JPL_SRC = ".."; + +use Config; + +eval `$JPL_SRC/setvars -perl`; + +open(MAKEFILE, ">Makefile"); + +print MAKEFILE <<"SUBS"; +PERL = perl$] +ARCHNAME = $Config{archname} +JAVA_HOME = $ENV{JAVA_HOME} +JPL_HOME = $ENV{JPL_HOME} +PERLARCHDIR = $Config{archlib} + +SUBS + +print MAKEFILE <<'NOSUBS'; + +all: + +debug: + +test: + +install: + mkdir -p $(JPL_HOME)/perl/JPL + cp *.p[ml] $(JPL_HOME)/perl/JPL + +clean: + +NOSUBS + +close MAKEFILE; diff --git a/jpl/JPL_Rolo/JPL_Rolo.jpl b/jpl/JPL_Rolo/JPL_Rolo.jpl new file mode 100755 index 0000000000..3c77fb2690 --- /dev/null +++ b/jpl/JPL_Rolo/JPL_Rolo.jpl @@ -0,0 +1,553 @@ +import java.awt.*; +import java.awt.event.*; +import java.lang.*; +import java.util.*; + +public class JPL_Rolo extends Frame { + + // The primary key of the row that is current onscreen. + // + int current_row = 0; + + // TextField objects for each column. + // + TextField fld_name, fld_address, fld_city, fld_state, fld_zip, fld_id; + + // Add or Edit mode. + // + String edit_status; + + // a layout manager for the Frame + // + GridBagLayout gb = new GridBagLayout(); + + // Action buttons. + // + Button next, previous, quit, save, newrow, edit, cancel, delete; + + // A Panel for the action buttons. + // + Panel actionbuttons; + + /** + * Construct a new instance of JPL_Rolo. + */ + public JPL_Rolo(String[] argv) { + CreateForm(); + addWindowListener(new WinEventHandler() ); + } + + public void CreateForm() { + + // set the layout for the frame + // + this.setLayout(gb); + + // this is the offset within the GridBagLayout. If + // I want the next object on a different line, I + // postincrement. If not, I don't. + // + int i = 0; + + // Add a text field for the name. + // + AddToFrame(new Label("Name:"), 0, i); + fld_name = new TextField(20); + fld_name.setEditable(false); + AddToFrame(fld_name, 1, i++); + + // The address. + // + AddToFrame(new Label("Address:"), 0, i); + fld_address = new TextField(35); + fld_address.setEditable(false); + AddToFrame(fld_address, 1, i++); + + // The City. I'm not going to increment i, so the + // next field will show up on the same line. + // + AddToFrame(new Label("City:"), 0, i); + fld_city = new TextField(20); + fld_city.setEditable(false); + AddToFrame(fld_city, 1, i); + + // The State. + // + AddToFrame(new Label("State:"), 2, i); + fld_state = new TextField(2); + fld_state.setEditable(false); + AddToFrame(fld_state, 3, i++); + + // The Zip Code. + // + AddToFrame(new Label("Zip:"), 0, i); + fld_zip = new TextField(11); + fld_zip.setEditable(false); + AddToFrame(fld_zip, 1, i++); + + // The id - this is always read-only. + // + AddToFrame(new Label("Id:"), 0, i); + fld_id = new TextField(4); + fld_id.setEditable(false); + AddToFrame(fld_id, 1, i++); + + // create the button panel and give it a FlowLayout + // + actionbuttons = new Panel(); + actionbuttons.setLayout(new FlowLayout(FlowLayout.CENTER, 5, 5)); + + // Add the button panel to the Frame. The AddToFrame + // method isn't really set up to handle this sort of + // panel, so we will go through the tedious process + // of managing the GridBagConstraints... + // + GridBagConstraints c = new GridBagConstraints(); + c.gridwidth = 3; c.gridheight = 1; + c.fill = GridBagConstraints.NONE; + c.anchor = GridBagConstraints.CENTER; + c.weightx = 0.0; c.weighty = 0.0; + c.gridx = 0; c.gridy = i; + ((GridBagLayout)this.getLayout()).setConstraints(actionbuttons, c); + this.add(actionbuttons); + + // instantiate and add each of the buttons + // + previous = new Button("Previous"); + actionbuttons.add(previous); + previous.addActionListener( new PrevRowHandler() ); + + next = new Button("Next"); + actionbuttons.add(next); + next.addActionListener( new NextRowHandler() ); + + quit = new Button("Quit"); + actionbuttons.add(quit); + quit.addActionListener( new QuitHandler() ); + + newrow = new Button("New"); + actionbuttons.add(newrow); + newrow.addActionListener( new NewRowHandler() ); + + edit = new Button("Edit"); + actionbuttons.add(edit); + edit.addActionListener( new EditRowHandler() ); + + delete = new Button("Delete"); + actionbuttons.add(delete); + delete.addActionListener( new DeleteRowHandler() ); + + // save and cancel are disabled until the user + // is adding or editing. + // + save = new Button("Save"); + actionbuttons.add(save); + save.setEnabled(false); + save.addActionListener( new SaveHandler() ); + + cancel = new Button("Cancel"); + actionbuttons.add(cancel); + cancel.setEnabled(false); + cancel.addActionListener( new CancelHandler() ); + + // Invoke getRow() to display the first row in the table. + // + getRow(0); + + } + + /** + * Return the id of the current row. + */ + public int getCurrentRowVal() { + return current_row; + } + + public void setCols(String name, String address, String city, String state, String zip, String id) { + + clearForm(); + + fld_name.setText(name); + fld_address.setText(address); + fld_city.setText(city); + fld_state.setText(state); + fld_zip.setText(zip); + fld_id.setText(id); + current_row = Integer.parseInt(id); + + } + + + public void setCurrentRow(int r) { + current_row = r; + } + + public String getName() { return fld_name.getText(); } + public String getAddress() { return fld_address.getText(); } + public String getCity() { return fld_city.getText(); } + public String getState() { return fld_state.getText(); } + public String getZip() { return fld_zip.getText(); } + public String getId() { return fld_id.getText(); } + + /** + * This eventhandler will move to the previous row. + */ + class PrevRowHandler implements ActionListener { + public void actionPerformed( ActionEvent e) { + getRow(-1); + } + } + + /** + * This eventhandler will move to the next row. + */ + class NextRowHandler implements ActionListener { + public void actionPerformed( ActionEvent e) { + getRow(1); + } + } + + /** + * This eventhandler will terminate the application. + */ + class QuitHandler implements ActionListener { + public void actionPerformed( ActionEvent e) { + System.exit(0); + } + } + + /** + * This eventhandler will display a blank record and put + * this application in new record mode. + */ + class NewRowHandler implements ActionListener { + public void actionPerformed( ActionEvent e) { + clearForm(); + edit_status = "new"; + setEdit(); + } + } + + /** + * This eventhandler will put the application in edit + * mode (for the current row). + */ + class EditRowHandler implements ActionListener { + public void actionPerformed( ActionEvent e) { + edit_status = "edit"; + setEdit(); + } + } + /** + * This eventhandler will delete the current row. + */ + class DeleteRowHandler implements ActionListener { + public void actionPerformed( ActionEvent e) { + delRow(); + } + } + + /** + * This eventhandler will save (update or insert) the + * current record. + */ + class SaveHandler implements ActionListener { + public void actionPerformed( ActionEvent e) { + + if (edit_status.equals("new")) { + saveIt(); + } + if (edit_status.equals("edit")) { + updateRow(); + } + + // set the edit_status to "browse", and call setBrowse() + // + edit_status = "browse"; + setBrowse(); + } + } + + /** + * This eventhandler cancels any pending edit. + */ + class CancelHandler implements ActionListener { + public void actionPerformed( ActionEvent e) { + // if it was new, make sure that they can't edit the + // id field... + + if (edit_status.equals("new")) { + fld_id.setEditable(false); + } + + // return the edit_status to browse, call getRow() + // to retrieve the row they were looking at + // before editing or adding, and call setBrowse() + // + edit_status = "browse"; + getRow(0); + setBrowse(); + } + } + + // This is the event handler to deal with cases where + // the user closes the window with a window control. + // + class WinEventHandler extends WindowAdapter { + public void windowClosing(WindowEvent e) { + System.exit(0); + } + } + + /** + * clearForm() + */ + protected void clearForm () { + fld_name.setText(""); + fld_address.setText(""); + fld_city.setText(""); + fld_state.setText(""); + fld_zip.setText(""); + fld_id.setText(""); + } + + /** + * AddToFrame() + * A convenience method to wrap the living hell + * that is GridBagConstraints() + */ + protected void AddToFrame (Component item, int x, int y) { + + // some sane layout defaults. + // + GridBagConstraints c = new GridBagConstraints(); + c.gridwidth = 1; c.gridheight = 1; + c.fill = GridBagConstraints.NONE; + c.anchor = GridBagConstraints.NORTHWEST; + c.weightx = 0.0; c.weighty = 0.0; + + // set the grid coordinates + // + c.gridx = x; c.gridy = y; + + // set the constraints, and add the item to the layout + // + + ((GridBagLayout)this.getLayout()).setConstraints(item, c); + this.add(item); + } + + /** + * setEdit() + * + * prepare the form for editing/adding + */ + protected void setEdit () { + + // disable all these buttons + // + next.setEnabled(false); + previous.setEnabled(false); + newrow.setEnabled(false); + edit.setEnabled(false); + delete.setEnabled(false); + + // set everything except the id to be editable + // + fld_name.setEditable(true); + fld_address.setEditable(true); + fld_city.setEditable(true); + fld_state.setEditable(true); + fld_zip.setEditable(true); + + // enable these two buttons + // + save.setEnabled(true); + cancel.setEnabled(true); + } + + /** + * setBrowse() + * + * prepare the form for viewing + * + */ + protected void setBrowse() { + + // enable all these buttons + // + next.setEnabled(true); + previous.setEnabled(true); + newrow.setEnabled(true); + edit.setEnabled(true); + delete.setEnabled(true); + + // disable the fields + // + fld_name.setEditable(false); + fld_address.setEditable(false); + fld_city.setEditable(false); + fld_state.setEditable(false); + fld_zip.setEditable(false); + fld_id.setEditable(false); + + // disable these two buttons + // + save.setEnabled(false); + cancel.setEnabled(false); + } + + perl void delRow() {{ + + my $id = $self->getId____s(); + + $sql = qq[delete from cardfile ] . + qq[where (id = $id)]; + + use Sprite; + my $rdb = new Sprite(); + my @data = $rdb->sql($sql); + $rdb->close("cardfile"); + my $status = shift @data; + if (!$status) { + print STDERR "Bummer - couldn't execute query!\n"; + die; + } + $self->setCurrentRow__I(0); + $self->getRow__I(0); + + }} + + perl void updateRow() {{ + + my $name = $self->getName____s(); + my $address = $self->getAddress____s(); + my $city = $self->getCity____s(); + my $state = $self->getState____s(); + my $zip = $self->getZip____s(); + my $id = $self->getId____s(); + + $sql = qq[update cardfile ] . + qq[set name = ('$name'), ] . + qq[set address = ('$address'), ] . + qq[set city = ('$city'), ] . + qq[set state = ('$state'), ] . + qq[set zip = ('$zip') ] . + qq[where (id = $id)]; + + use Sprite; + my $rdb = new Sprite(); + my @data = $rdb->sql($sql); + $rdb->close("cardfile"); + my $status = shift @data; + if (!$status) { + print STDERR "Bummer - couldn't execute query!\n"; + die; + } + + }} + + + /** + * getRow() + * + * This method is used to either fetch this current row, + * in which case it is given an argument of zero, or it + * can be used to move relative to the current row, in + * which case it must be given an argument of 1 or -1. + * + */ + + + perl void getRow(int direction) {{ + + use Sprite; + my $rdb = new Sprite(); + + my $nextid = $self->getCurrentRowVal____I() + $direction; + my $op; + if ($direction == -1) { + $op = "<="; + } else { + $op = ">="; + } + my @data = $rdb->sql("select name, address, city, state, zip, id from cardfile where id $op $nextid"); + $rdb->close("cardfile"); + + my $status = shift @data; + if (!$status) { + print STDERR "Bummer - couldn't execute query!\n"; + die; + } + + my $numrows = scalar(@data); + + if (!$numrows) { + print STDERR "End of file reached.\n"; + return; + } + + my $index; + if ($direction == -1) { + $index = $#data; + } else { + $index = 0; + } + my($name, $address, $city, $state, $zip, $id) = split (/\0/, $data[$index], 6); + $self->setCols__ssssss($name, $address, $city, $state, $zip, $id); + + }} + + perl void saveIt() {{ + + use Sprite; + my $rdb = new Sprite(); + + my @data = $rdb->sql("select id, name from cardfile"); + + my $status = shift @data; + if (!$status) { + print STDERR "Bummer - couldn't execute query!\n"; + die; + } + + my @ids; + foreach $record (@data) { + my ($id, $name) = split (/\0/, $record, 2); + push @ids, $id; + } + @ids = sort @ids; + my $newid = $ids[$#ids] + 1; + + my $name = $self->getName____s(); + my $address = $self->getAddress____s(); + my $city = $self->getCity____s(); + my $state = $self->getState____s(); + my $zip = $self->getZip____s(); + + my $sql = "insert into cardfile (name, address, city, state, zip, id) values ('$name', '$address', '$city', '$state', '$zip', $newid)"; + @data = $rdb->sql($sql); + $rdb->close("cardfile"); + + $status = shift @data; + if (!$status) { + print STDERR "Bummer - couldn't execute insert!\n"; + die; + } + + $self->setCurrentRow__I($newid); + + }} + + public static void main(String[] args) { + + // make a new JPL_Rolo, pack() it and show() it. + JPL_Rolo cardfile = new JPL_Rolo(args); + cardfile.pack(); + cardfile.show(); + + } + +} + + diff --git a/jpl/JPL_Rolo/Makefile.PL b/jpl/JPL_Rolo/Makefile.PL new file mode 100644 index 0000000000..3dd1f84411 --- /dev/null +++ b/jpl/JPL_Rolo/Makefile.PL @@ -0,0 +1,84 @@ +#!/usr/bin/perl + +$JPL_HOME = $ENV{JPL_HOME} + or die "You have not run setvars to set your environment variables.\n" . + "See the JPL README file for more information.\n"; + +use Config; + +eval `$JPL_HOME/setvars -perl`; + +chop($WHAT = `pwd`); +$WHAT =~ s#.*/##; + +if ($^O eq 'linux') { + $flags = "-Dbool=char"; # avoid builtin bool altogether + $libs = "-lc -lm -ldl"; +} +else { + $flags = ""; + $libs = "-lc -lm -ldl"; +} +chop($cwd = `pwd`); +($jpldir = $cwd) =~ s#/[^/]*$##; + +open(MAKEFILE, ">Makefile"); + +print MAKEFILE <<"SUBS"; +CC = $Config{cc} +WHAT = $WHAT +PERL = perl$] +ARCHNAME = $Config{archname} +JAVA_HOME = $ENV{JAVA_HOME} +JPL_HOME = $ENV{JPL_HOME} +PERLARCHDIR = $Config{archlib} +FLAGS = $Config{cccdlflags} $Config{ccdlflags} $Config{lddlflags} $flags +INCL = -I\$(PERLARCHDIR)/CORE \\ + -I\$(JAVA_HOME)/include \\ + -I\$(JAVA_HOME)/include/$^O \\ + -I\$(JAVA_HOME)/include/genunix +LIBS = $libs + +SUBS + +print MAKEFILE <<'NOSUBS'; +.SUFFIXES: .jpl .class + +.jpl.class: + $(PERL) -MJPL::Compile -e "file('$*.jpl')" + +all: $(WHAT).class lib$(WHAT).so + +debug: $(WHAT)_g.class lib$(WHAT)_g.so + +lib$(WHAT).so: $(WHAT).c $(JPL_HOME)/lib/$(ARCHNAME)/libPerlInterpreter.so + $(CC) $(FLAGS) $(INCL) $(WHAT).c \ + $(PERLARCHDIR)/CORE/libperl.so \ + $(JPL_HOME)/lib/$(ARCHNAME)/libPerlInterpreter.so \ + $(LIBS) \ + -o lib$(WHAT).so + +lib$(WHAT)_g.so: $(WHAT).c $(JPL_HOME)/lib/$(ARCHNAME)/libPerlInterpreter_g.so + $(CC) -g $(FLAGS) $(INCL) $(WHAT).c \ + $(PERLARCHDIR)/CORE/libperl.so \ + $(JPL_HOME)/lib/$(ARCHNAME)/libPerlInterpreter_g.so \ + $(LIBS) \ + -o lib$(WHAT)_g.so + +test: + +install: all + cp $(WHAT).class $(JPL_HOME)/lib + cp lib$(WHAT).so $(JPL_HOME)/lib/$(ARCHNAME) + cp $(WHAT).pl $(JPL_HOME)/perl + +clean: + rm -f $(WHAT).c $(WHAT).h \ + $(WHAT)*.class $(WHAT)*.pl lib$(WHAT).so $(WHAT)*.java + +distclean: clean + rm -f Makefile + +NOSUBS + +close MAKEFILE; diff --git a/jpl/JPL_Rolo/README b/jpl/JPL_Rolo/README new file mode 100644 index 0000000000..6d4b14b3fe --- /dev/null +++ b/jpl/JPL_Rolo/README @@ -0,0 +1,27 @@ +Welcome to the Sprite sample application for Larry Wall's JPL. This +application showcases a merging of Java and Perl in which Java is employed +to generate a user interface, and Perl is used for data access. +Specifically, Perl is used with Shishir Gundavaram's Sprite module to offer +permanent storage through SQL manipulation of text files. This application +is a Rolodex(tm)-style address file, offering the ability to add, edit or +delete names and addresses. You may also navigate through the address list. + +To use this example, you will need to install the Sprite module from CPAN. + +To install the sample, you must first have JPL installed and working. +Please ensure that you have set environment variables as directed in the +JPL README and that the JPL Sample program works. Once this has been +accomplished, you can build the files in this directory with the following +commmands: + + perl Makefile.PL + make + make install + +You can run this by typing: + + java JPL_Rolo + +The application should appear with some sample data, and you can mess +around with it and put all your friends in the address book. Far out! + diff --git a/jpl/JPL_Rolo/cardfile b/jpl/JPL_Rolo/cardfile new file mode 100755 index 0000000000..eecc8067ba --- /dev/null +++ b/jpl/JPL_Rolo/cardfile @@ -0,0 +1,7 @@ +name,address,city,state,zip,id +Brian Jepson,50 Hudson Street,Providence,RI,02909,100 +Elvis Presley,50 Hudson Street,Providence,RI,02909,101 +AS220,115 Empire Street,Providence,RI,02909,600 +Mr. Jones,100 Loudermilk Drive,Springfield,??,,602 +George Maciunas,Canal Street,New York,NY,????,603 +Emmett Williams,Broome Street,New York,NY,?????,605 diff --git a/jpl/PerlInterpreter/Makefile.PL b/jpl/PerlInterpreter/Makefile.PL new file mode 100644 index 0000000000..76852c6cc8 --- /dev/null +++ b/jpl/PerlInterpreter/Makefile.PL @@ -0,0 +1,70 @@ +#!/usr/bin/perl + +$JPL_SRC = ".."; + +use Config; + +eval `$JPL_SRC/setvars -perl`; + +if ($^O eq 'linux') { + $flags = "-Dbool=char"; # avoid builtin bool altogether + $libs = "-lc -lm -ldl"; +} +else { + $flags = ""; + $libs = "-lc -lm -ldl"; +} + +open(MAKEFILE, ">Makefile"); + +print MAKEFILE <<"SUBS"; +WHAT = PerlInterpreter +JAVA_HOME = $ENV{JAVA_HOME} +JPL_HOME = $ENV{JPL_HOME} +ARCHNAME = $Config{archname} +PERLARCHDIR = $Config{archlib} +CC = $Config{cc} +FLAGS = $Config{cccdlflags} $Config{ccdlflags} $Config{lddlflags} $flags +INCL = -I\$(PERLARCHDIR)/CORE \\ + -I\$(JAVA_HOME)/include \\ + -I\$(JAVA_HOME)/include/$^O \\ + -I\$(JAVA_HOME)/include/genunix +LIBS = $libs + +SUBS + + +print MAKEFILE <<'NOSUBS'; +.SUFFIXES: .java .class + +.java.class: + javac $*.java + +.class.h: + javah -jni $* + +all: PerlInterpreter.class libPerlInterpreter.so + +PerlInterpreter.class: PerlInterpreter.java + +PerlInterpreter.h: PerlInterpreter.class + +libPerlInterpreter.so: PerlInterpreter.c PerlInterpreter.h + $(CC) $(FLAGS) $(INCL) PerlInterpreter.c \ + $(PERLARCHDIR)/auto/DynaLoader/DynaLoader.a \ + $(LIBS) \ + -o libPerlInterpreter.so + +test: + +install: all + mkdir -p $(JPL_HOME)/lib/$(ARCHNAME) + cp libPerlInterpreter.so $(JPL_HOME)/lib/$(ARCHNAME) + cp $(WHAT).class $(JPL_HOME)/lib + +clean: + rm -f libPerlInterpreter.so + rm -f PerlInterpreter.class +NOSUBS + +close MAKEFILE; diff --git a/jpl/PerlInterpreter/PerlInterpreter.c b/jpl/PerlInterpreter/PerlInterpreter.c new file mode 100644 index 0000000000..8bf3f5f17a --- /dev/null +++ b/jpl/PerlInterpreter/PerlInterpreter.c @@ -0,0 +1,129 @@ +/* + * "The Road goes ever on and on, down from the door where it began." + */ + +#include "PerlInterpreter.h" +#include <dlfcn.h> + +#include "EXTERN.h" +#include "perl.h" + +#ifndef EXTERN_C +# ifdef __cplusplus +# define EXTERN_C extern "C" +# else +# define EXTERN_C extern +# endif +#endif + +static void xs_init _((void)); +static PerlInterpreter *my_perl; + +int jpldebug = 0; +JNIEnv *jplcurenv; + +JNIEXPORT void JNICALL +Java_PerlInterpreter_init(JNIEnv *env, jobject obj, jstring js) +{ + int exitstatus; + int argc = 3; + SV* envsv; + SV* objsv; + + static char *argv[] = {"perl", "-e", "1", 0}; + + if (getenv("JPLDEBUG")) + jpldebug = atoi(getenv("JPLDEBUG")); + + if (jpldebug) + fprintf(stderr, "init\n"); + + if (!dlopen("libperl.so", RTLD_LAZY|RTLD_GLOBAL)) { + fprintf(stderr, "%s\n", dlerror()); + exit(1); + } + + if (PL_curinterp) + return; + + perl_init_i18nl10n(1); + + if (!PL_do_undump) { + my_perl = perl_alloc(); + if (!my_perl) + exit(1); + perl_construct( my_perl ); + PL_perl_destruct_level = 0; + } + + exitstatus = perl_parse( my_perl, xs_init, argc, argv, (char **) NULL ); + + if (!exitstatus) + Java_PerlInterpreter_eval(env, obj, js); + +} + +JNIEXPORT void JNICALL +Java_PerlInterpreter_eval(JNIEnv *env, jobject obj, jstring js) +{ + SV* envsv; + SV* objsv; + dSP; + jbyte* jb; + + ENTER; + SAVETMPS; + + jplcurenv = env; + envsv = perl_get_sv("JPL::_env_", 1); + sv_setiv(envsv, (IV)(void*)env); + objsv = perl_get_sv("JPL::_obj_", 1); + sv_setiv(objsv, (IV)(void*)obj); + + jb = (jbyte*)(*env)->GetStringUTFChars(env,js,0); + + if (jpldebug) + fprintf(stderr, "eval %s\n", (char*)jb); + + perl_eval_pv( (char*)jb, 0 ); + + if (SvTRUE(ERRSV)) { + jthrowable newExcCls; + + (*env)->ExceptionDescribe(env); + (*env)->ExceptionClear(env); + + newExcCls = (*env)->FindClass(env, "java/lang/RuntimeException"); + if (newExcCls) + (*env)->ThrowNew(env, newExcCls, SvPV(ERRSV,PL_na)); + } + + (*env)->ReleaseStringUTFChars(env,js,jb); + FREETMPS; + LEAVE; + +} + +/* +JNIEXPORT jint JNICALL +Java_PerlInterpreter_eval(JNIEnv *env, jobject obj, jint ji) +{ + op = (OP*)(void*)ji; + op = (*op->op_ppaddr)(); + return (jint)(void*)op; +} +*/ + +/* Register any extra external extensions */ + +/* Do not delete this line--writemain depends on it */ +EXTERN_C void boot_DynaLoader _((CV* cv)); +EXTERN_C void boot_JNI _((CV* cv)); + +static void +xs_init() +{ + char *file = __FILE__; + dXSUB_SYS; + newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); +} diff --git a/jpl/PerlInterpreter/PerlInterpreter.h b/jpl/PerlInterpreter/PerlInterpreter.h new file mode 100644 index 0000000000..22fdf526dc --- /dev/null +++ b/jpl/PerlInterpreter/PerlInterpreter.h @@ -0,0 +1,29 @@ +/* DO NOT EDIT THIS FILE - it is machine generated */ +#include <jni.h> +/* Header for class PerlInterpreter */ + +#ifndef _Included_PerlInterpreter +#define _Included_PerlInterpreter +#ifdef __cplusplus +extern "C" { +#endif +/* + * Class: PerlInterpreter + * Method: init + * Signature: (Ljava/lang/String;)V + */ +JNIEXPORT void JNICALL Java_PerlInterpreter_init + (JNIEnv *, jobject, jstring); + +/* + * Class: PerlInterpreter + * Method: eval + * Signature: (Ljava/lang/String;)V + */ +JNIEXPORT void JNICALL Java_PerlInterpreter_eval + (JNIEnv *, jobject, jstring); + +#ifdef __cplusplus +} +#endif +#endif diff --git a/jpl/PerlInterpreter/PerlInterpreter.java b/jpl/PerlInterpreter/PerlInterpreter.java new file mode 100644 index 0000000000..c26a4f2ba4 --- /dev/null +++ b/jpl/PerlInterpreter/PerlInterpreter.java @@ -0,0 +1,21 @@ +class PerlInterpreter { + static boolean initted = false; + + public native void init(String s); + public native void eval(String s); + +// public native long op(long i); + + public PerlInterpreter fetch () { + if (!initted) { + init("$JPL::DEBUG = $ENV{JPLDEBUG}"); + initted = true; + } + return this; + } + + static { + System.loadLibrary("PerlInterpreter"); + } +} + diff --git a/jpl/README b/jpl/README new file mode 100644 index 0000000000..eb900f024c --- /dev/null +++ b/jpl/README @@ -0,0 +1,83 @@ +Copyright 1998, O'Reilly & Associates, Inc. + +This package may be copied under the same terms as Perl itself. + +Disclaimers +----------- +This is a work in progress, and relies on bleeding-edge technology +from the network. Don't expect not to be surprised occasionally. + +Requirements +------------ +Perl 5.005_02 (or later) must be compiled and installed as a shared library +(libperl.so). I had to use the system's malloc. JPL was originally built +and tested with 5.004_04 and early Java 1.1 development kits. This version +has not been well tested under 5.005_02, so you can expect some rough edges. + +You need JDK 1.1. On Solaris 1.1.5 has been verified to work. Linux +users can try the latest version (1.1.3 or later) available from (for +example): + + ftp://ftp.blackdown.org/pub/Linux/JDK/1.1.3/updates/libjava-1.1.3v2-1.tar.gz + +The get_jdk directory contains a script that will download JDK (but not +the patch file above) off of the net for you. (This presumes you've +already installed the modules mentioned in ../README.) + +You may need to ensure that all files under the ../jpl directory are writable. +install-jpl expects to be run with super-user privileges so that it can +put things in the right places. + +What the heck is JPL? +--------------------- +JPL is a hybrid (to use the polite term) language. It's basically Java +in which the methods can optionally be implemented by Perl code. A +preprocessor called "JPL::Compile" looks at your .jpl file and spits +out the appropriate .java, .c, .h, .pl, and .so files to accomplish the +desired task. Hopefully a lot of those files can go away in the future +as jpl mutates into a Perl-to-Java compiler. The long-term goal is for +jpl to be able to take a pure Perl file and spit out a java .class +file. This initial version of JPL is an attempt to begin to mesh the +semantics of Java and Perl. Some people may find it useful in its +current form, but you should know right up front that we've still got a +ways to go with it. A journey of a thousand miles continues with the +second step... + +JPL Syntax +---------- +JPL syntax is trivial, given that you know Java and Perl. Pretend like +you're writing a native Java method, but say "perl" instead of +"native", and then instead of omitting the body of the method, put your +Perl code in double curlies. (See Sample.jpl for an example.) + +Calling back from Perl to Java is done through the JNI (Java Native +Interface). No weird transmogrifications are done by the preprocessor +to your Perl code--it's all normal Perl. The preprocessor just wraps +it up into funny subroutines you don't see unless you peek at the .pl +file it generates. + +Installation +------------ +Run "install-jpl". You have to tell it whether you want to use the +current directory for JPL_HOME or some other directory. Everything +else should take care of itself, except that after install-jpl +writes the setvars program, you are responsible to invoke it properly +before any JPL applications can be compiled under the current shell. + + sh: eval `setvars -sh` + csh: eval `setvars -csh` + perl: eval `setvars -perl`; + +More Info +--------- + +You can look at the Sample and Test directories, as well as the ../eg +directory for examples. + +Perhaps the most important bit of advice we can give you is to watch + + http://perl.oreilly.com + +for further information on how to get further information. + +Have the appropriate amount of fun. diff --git a/jpl/Sample/Makefile.PL b/jpl/Sample/Makefile.PL new file mode 100644 index 0000000000..944c7e180d --- /dev/null +++ b/jpl/Sample/Makefile.PL @@ -0,0 +1,84 @@ +#!/usr/bin/perl + +$JPL_HOME = $ENV{JPL_HOME} + or die "You have not run setvars to set your environment variables.\n" . + "See the JPL README file for more information.\n"; + +use Config; + +eval `$JPL_HOME/setvars -perl`; + +chop($WHAT = `pwd`); +$WHAT =~ s#.*/##; + +if ($^O eq 'linux') { + $flags = "-Dbool=char"; # avoid builtin bool altogether + $libs = "-lc -lm -ldl"; +} +else { + $flags = ""; + $libs = "-lc -lm -ldl"; +} +chop($cwd = `pwd`); +($jpldir = $cwd) =~ s#/[^/]*$##; + +open(MAKEFILE, ">Makefile"); + +print MAKEFILE <<"SUBS"; +CC = $Config{cc} +WHAT = $WHAT +PERL = perl$] +ARCHNAME = $Config{archname} +JAVA_HOME = $ENV{JAVA_HOME} +JPL_HOME = $ENV{JPL_HOME} +PERLARCHDIR = $Config{archlib} +FLAGS = $Config{cccdlflags} $Config{ccdlflags} $Config{lddlflags} $flags +INCL = -I\$(PERLARCHDIR)/CORE \\ + -I\$(JAVA_HOME)/include \\ + -I\$(JAVA_HOME)/include/$^O \\ + -I\$(JAVA_HOME)/include/genunix +LIBS = $libs + +SUBS + +print MAKEFILE <<'NOSUBS'; +.SUFFIXES: .jpl .class + +.jpl.class: + $(PERL) -MJPL::Compile -e "file('$*.jpl')" + +all: $(WHAT).class lib$(WHAT).so + +debug: $(WHAT)_g.class lib$(WHAT)_g.so + +lib$(WHAT).so: $(WHAT).c $(JPL_HOME)/lib/$(ARCHNAME)/libPerlInterpreter.so + $(CC) $(FLAGS) $(INCL) $(WHAT).c \ + $(PERLARCHDIR)/CORE/libperl.so \ + $(JPL_HOME)/lib/$(ARCHNAME)/libPerlInterpreter.so \ + $(LIBS) \ + -o lib$(WHAT).so + +lib$(WHAT)_g.so: $(WHAT).c $(JPL_HOME)/lib/$(ARCHNAME)/libPerlInterpreter_g.so + $(CC) -g $(FLAGS) $(INCL) $(WHAT).c \ + $(PERLARCHDIR)/CORE/libperl.so \ + $(JPL_HOME)/lib/$(ARCHNAME)/libPerlInterpreter_g.so \ + $(LIBS) \ + -o lib$(WHAT)_g.so + +test: + +install: all + cp *.class $(JPL_HOME)/lib + cp lib$(WHAT).so $(JPL_HOME)/lib/$(ARCHNAME) + cp $(WHAT).pl $(JPL_HOME)/perl + +clean: + rm -f $(WHAT).c $(WHAT).h \ + $(WHAT)*.class $(WHAT)*.pl lib$(WHAT).so $(WHAT)*.java + +distclean: clean + rm -f Makefile + +NOSUBS + +close MAKEFILE; diff --git a/jpl/Sample/Sample.jpl b/jpl/Sample/Sample.jpl new file mode 100644 index 0000000000..a09520141f --- /dev/null +++ b/jpl/Sample/Sample.jpl @@ -0,0 +1,48 @@ +class Sample { + public static void main(String[] args) { + Sample sam = new Sample(); + System.out.println(sam.foo("manny","moe","jack")); + System.out.println(sam.foo(1)); + System.out.println(sam.foo(3.0)); + sam.foo(); + } + + public static int thrice(int i) { + return i * 3; + } + + perl void foo() {{ + use POSIX; + print "TZ = ", POSIX::tzname(), "\n"; + print "Got to ${self}->foo() method\n"; + print "foo__I(2) = ", $self->foo__I__I(2),"\n"; + print "thrice(123) = ", JPL::Sample->thrice__I__I(123), "\n"; + print "thrice(12) = ", JPL::Sample->thrice__I__I(12), "\n"; + print $self->foo__sss__s("MANNY", "MOE", "JACK"), "\n"; + print 41 + $self->foo__sss__s("1", "2", "3"), "\n"; + print "Perl version is $]\n"; + }} + + perl int foo(int a) {{ + $a + $a; + }} + + perl double foo(double a) {{ + use JPL::Class 'java::util::Random'; + $rng = java::util::Random->new(); + print "RNG = $rng\n"; + print $rng->nextDouble____D(), "\n"; + print $rng->nextDouble____D(), "\n"; + print $rng->nextDouble____D(), "\n"; + print $rng->nextDouble____D(), "\n"; + return $a * $a; + }} + + perl String foo( String a, + String b, + String c ) {{ + print "a = $a, b = $b, c = $c\n"; + join "+", $a, $b, $c; + }} + +} diff --git a/jpl/Test/Makefile.PL b/jpl/Test/Makefile.PL new file mode 100644 index 0000000000..3dd1f84411 --- /dev/null +++ b/jpl/Test/Makefile.PL @@ -0,0 +1,84 @@ +#!/usr/bin/perl + +$JPL_HOME = $ENV{JPL_HOME} + or die "You have not run setvars to set your environment variables.\n" . + "See the JPL README file for more information.\n"; + +use Config; + +eval `$JPL_HOME/setvars -perl`; + +chop($WHAT = `pwd`); +$WHAT =~ s#.*/##; + +if ($^O eq 'linux') { + $flags = "-Dbool=char"; # avoid builtin bool altogether + $libs = "-lc -lm -ldl"; +} +else { + $flags = ""; + $libs = "-lc -lm -ldl"; +} +chop($cwd = `pwd`); +($jpldir = $cwd) =~ s#/[^/]*$##; + +open(MAKEFILE, ">Makefile"); + +print MAKEFILE <<"SUBS"; +CC = $Config{cc} +WHAT = $WHAT +PERL = perl$] +ARCHNAME = $Config{archname} +JAVA_HOME = $ENV{JAVA_HOME} +JPL_HOME = $ENV{JPL_HOME} +PERLARCHDIR = $Config{archlib} +FLAGS = $Config{cccdlflags} $Config{ccdlflags} $Config{lddlflags} $flags +INCL = -I\$(PERLARCHDIR)/CORE \\ + -I\$(JAVA_HOME)/include \\ + -I\$(JAVA_HOME)/include/$^O \\ + -I\$(JAVA_HOME)/include/genunix +LIBS = $libs + +SUBS + +print MAKEFILE <<'NOSUBS'; +.SUFFIXES: .jpl .class + +.jpl.class: + $(PERL) -MJPL::Compile -e "file('$*.jpl')" + +all: $(WHAT).class lib$(WHAT).so + +debug: $(WHAT)_g.class lib$(WHAT)_g.so + +lib$(WHAT).so: $(WHAT).c $(JPL_HOME)/lib/$(ARCHNAME)/libPerlInterpreter.so + $(CC) $(FLAGS) $(INCL) $(WHAT).c \ + $(PERLARCHDIR)/CORE/libperl.so \ + $(JPL_HOME)/lib/$(ARCHNAME)/libPerlInterpreter.so \ + $(LIBS) \ + -o lib$(WHAT).so + +lib$(WHAT)_g.so: $(WHAT).c $(JPL_HOME)/lib/$(ARCHNAME)/libPerlInterpreter_g.so + $(CC) -g $(FLAGS) $(INCL) $(WHAT).c \ + $(PERLARCHDIR)/CORE/libperl.so \ + $(JPL_HOME)/lib/$(ARCHNAME)/libPerlInterpreter_g.so \ + $(LIBS) \ + -o lib$(WHAT)_g.so + +test: + +install: all + cp $(WHAT).class $(JPL_HOME)/lib + cp lib$(WHAT).so $(JPL_HOME)/lib/$(ARCHNAME) + cp $(WHAT).pl $(JPL_HOME)/perl + +clean: + rm -f $(WHAT).c $(WHAT).h \ + $(WHAT)*.class $(WHAT)*.pl lib$(WHAT).so $(WHAT)*.java + +distclean: clean + rm -f Makefile + +NOSUBS + +close MAKEFILE; diff --git a/jpl/Test/Test.jpl b/jpl/Test/Test.jpl new file mode 100644 index 0000000000..ab6a1ce56d --- /dev/null +++ b/jpl/Test/Test.jpl @@ -0,0 +1,122 @@ +import java.util.*; + +public class Test { + + int myint = 123; + double mydouble = 3.14159265; + String mystring = "my string"; + static String ourstring = "our string"; + static boolean embedded = false; + int array[] = {1,2,3}; + Vector v; + + public Test() { + + + v = new Vector(); + v.addElement("Hello"); + printfields(); + Vector x = perlTryVec(v); + x.addElement("World"); + Vector y = perlTryVec(x); + if (!embedded) System.err.println("Thank you, perlTryVec!"); + + if (!embedded) System.err.println(retchars()); + if (!embedded) System.err.println("Thank you, retchars!"); + + String[] s = retstrings(); + if (!embedded) System.err.println(s[0] + s[1] + s[2] + s[3]); + if (!embedded) System.err.println("Thank you, retstrings!"); + + Object[] o = retobjects(v, x, y); + if (!embedded) System.err.println(o[1]); + if (!embedded) System.err.println(o[3]); + if (!embedded) System.err.println(o[4]); + if (!embedded) System.err.println("Thank you, retobjects!"); + + passarray(s); + + if (!embedded) System.err.println(s[0] + s[1] + s[2] + s[3]); + if (!embedded) System.err.println("Thank you, passarray!"); + + printfields(); + if (!embedded) System.err.println("Thank you, printfields!"); + setfields(); + if (!embedded) System.err.println("Thank you, setfields!"); + printfields(); + if (!embedded) System.err.println("Thank you, printfields!"); + } + + perl Vector perlTryVec(Vector v) throws RuntimeException {{ + print "v is: $v\n"; + print "v isa: ", ref $v,"\n"; + + print "In perlTryVec() - Vector size is: ", $v->size([],['int']), "\n"; + @foo = times; + $size ||= getmeth('size', [], ['int']); + for ($i = 10000; $i; --$i) { + $x = $v->$size(); + } + @bar = times; + printf "%5.2fu %5.2fs\n", $bar[0] - $foo[0], $bar[1] - $foo[1]; + return $v; + }} + + perl char[] retchars() {{ + print "In retchars()\n"; + return [65,66,67]; + }} + + perl String[] retstrings() {{ + print "In retstrings()\n"; + return [1,2,3,"many"]; + }} + + perl Object[] retobjects(Vector v, Vector x, Vector y) {{ + print "In retstrings()\n"; + return [$v, $x, $y, "this is only a test", 123]; + }} + + perl void passarray(String[] s) {{ + print "In passarray()\n"; + print "s = $s\n"; + $t = GetObjectArrayElement($s,3); + print "t = $t\n"; + $x = GetStringUTFChars($t); + print "$x\n"; + $t = SetObjectArrayElement($s,3,NewStringUTF("infinity")); + }} + + perl void printfields() {{ + + $| = 1; + eval {print $self->v->toString____s(), "\n";}; + print $@ if $@; + + print $self->myint, "\n"; + print $self->mydouble, "\n"; + print $self->mystring, "\n"; + print JPL::Test->ourstring, "\n"; + + @nums = GetIntArrayElements($self->array()); + print "@nums\n"; + + @nums = unpack("i*", scalar GetIntArrayElements($self->array())); + print "@nums\n"; + }} + + perl void setfields() {{ + $self->myint(321); + $self->mydouble(2.7182918); + $self->mystring("MY STRING!!!"); + JPL::Test->ourstring("OUR STRING!!!"); + }} + + public static void main(String[] argv) { + if (java.lang.reflect.Array.getLength(argv) > 0 && + argv[0].equals("-nothanks")) + embedded = true; + Test f = new Test(); + if (!embedded) System.err.println("Thank you, Test!"); + } +} diff --git a/jpl/bin/jpl b/jpl/bin/jpl new file mode 100755 index 0000000000..ba39ce1985 --- /dev/null +++ b/jpl/bin/jpl @@ -0,0 +1,8 @@ +#!/usr/bin/perl -w + +# Copyright 1997, O'Reilly & Associate, Inc. +# +# This package may be copied under the same terms as Perl itself. + +use JPL::Compile qw(files); +files(@ARGV); diff --git a/jpl/get_jdk/README b/jpl/get_jdk/README new file mode 100644 index 0000000000..0c38ccf7fd --- /dev/null +++ b/jpl/get_jdk/README @@ -0,0 +1,74 @@ + +This archive contains the following files: +README - the README file which explains how to use this program (this file) +get_jdk.pl - the program to download JDK +jdk_hosts - the descriptor file required by the program + +Nate Patwardhan (nvp@oreilly.com) wrote get_jdk.pl to automate the +download of JDK (Java Development Kit) from a distribution site based +on your Unix flavor. This program is based on some of the examples +found in the LWP cookbook that was included with your LWP distribution. + +Current Unix flavors that appear in the descriptor file (more +suggestions from Beta testers will be welcomed): + Solaris + Linux + FreeBSD + +To use get_jdk.pl properly, you *must* have LWP (libwww) and its +dependencies installed. Once you've installed LWP, you should be able +to use this module without any problems on any Unix flavor. + +By default, get_jdk.pl uses #!/usr/local/bin/perl in its shebang path, +so you may have to execute get_jdk.pl like: + + perl get_jdk.pl + +-OR- + + perl5 get_jdk.pl + +based on your site's Perl installation. + +get_jdk.pl reads the $^O to determine what Unix flavor you're using, +and compares the value of $^O to the first field shown in the +descriptor file, jdk_hosts. For example, $^O for Solaris versions of +Perl is: 'solaris'; Solaris is represented in the descriptor file +like: + + solaris=>ftp://ftp.javasoft.com/pub/jdk1.1/jdk1.1.3-solaris2-sparc.bin + +When get_jdk.pl reads the descriptor file, it splits the fields on +'=>', and reads them into a hash, %HOSTS. get_jdk.pl then compares +the value of $^O to $HOSTS{'osname'}, and returns the address of the +JDK distribution site if $^O eq $HOSTS{'osname'}. If there is not a +match, get_jdk.pl fails. + +get_jdk.pl represents the hostname of distribution sites in URL +format: protocol://hostname.some.com/path/filename.extension +When a URL is found, get_jdk.pl parses out the filename; this is +significant, because the output from the remote host is directed to +the file parsed from the URL. + +When you execute get_jdk.pl, you'll know it's working correctly if it +outputs something like: + + A JDK port for your OS has been found. + Contacting: + ftp://ftp.javasoft.com/pub/jdk1.1/jdk1.1.3-solaris2-sparc.bin + Attempting to download: jdk1.1.3-solaris2-sparc.bin + 0% - 1460 bytes received + 0% - 4380 bytes received + 0% - 7300 bytes received + 0% - 8192 bytes received + [etc etc etc until you reach 100%] + +Future (PRK release) versions of get_jdk.pl will allow the user to +update the descriptor file from the ora.com (oreilly.com) FTP/WWW +site. This version does not support the -update flag. + +Happy JDK'ing! :-) + +-- +Nate Patwardhan +nvp@oreilly.com diff --git a/jpl/get_jdk/get_jdk.pl b/jpl/get_jdk/get_jdk.pl new file mode 100755 index 0000000000..d6d399d669 --- /dev/null +++ b/jpl/get_jdk/get_jdk.pl @@ -0,0 +1,71 @@ +#!/usr/bin/perl -w + +# Based on an ftp client found in the LWP Cookbook and +# revised by Nathan V. Patwardhan <nvp@ora.com>. + +# Copyright 1997 O'Reilly and Associates +# This package may be copied under the same terms as Perl itself. +# +# Code appears in the Unix version of the Perl Resource Kit + +use LWP::UserAgent; +use URI::URL; + +my $ua = new LWP::UserAgent; + +# check to see if a JDK port exists for the OS. i'd say +# that we should use solaris by default, but a 9meg tarfile +# is a hard pill to swallow if it won't work for somebody. :-) +my $os_type = $^O; my $URL = lookup_jdk_port($os_type); +die("No JDK port found. Contact your vendor for details. Exiting.\n") + if $URL eq ''; + +print "A JDK port for your OS has been found.\nContacting: ".$URL."\n"; + +# Now, parse the URL using URI::URL +my($jdk_file) = (url($URL)->crack)[5]; +$jdk_file =~ /(.+)\/(.+)/; $jdk_file = $2; + +print "Attempting to download: $jdk_file\n"; + +my $expected_length; +my $bytes_received = 0; + +open(OUT, ">".$jdk_file) or die("Can't open $jdk_file: $!"); +$ua->request(HTTP::Request->new('GET', $URL), + sub { + my($chunk, $res) = @_; + + $bytes_received += length($chunk); + unless (defined $expected_length) { + $expected_length = $res->content_length || 0; + } + if ($expected_length) { + printf STDERR "%d%% - ", + 100 * $bytes_received / $expected_length; + } + print STDERR "$bytes_received bytes received\n"; + + print OUT $chunk; + } +); +close(OUT); + +sub lookup_jdk_port { + my($port_os) = @_; + my $jdk_hosts = 'jdk_hosts'; + my %HOSTS = (); + + open(CFG, $jdk_hosts) or die("hosts error: $!"); + while(<CFG>) { + chop; + ($os, $host) = split(/\s*=>\s*/, $_); + next unless $os eq $port_os; + push(@HOSTS, $host); + } + close(CFG); + + return "" unless @HOSTS; + return $HOSTS[rand @HOSTS]; # Pick one at random. +} + diff --git a/jpl/get_jdk/jdk_hosts b/jpl/get_jdk/jdk_hosts new file mode 100644 index 0000000000..fa50b511eb --- /dev/null +++ b/jpl/get_jdk/jdk_hosts @@ -0,0 +1,4 @@ +solaris => ftp://ftp.javasoft.com/pub/jdk1.1/jdk1.1.3-solaris2-sparc.bin +linux => ftp://ftp.infomagic.com/pub/mirrors/linux/Java/JDK-1.1.3/linux-jdk.1.1.3-v2.tar.gz +linux => ftp://ftp.connectnet.com/pub/java/JDK-1.1.3/linux-jdk.1.1.3-v2.tar.gz +freebsd => http://www.csi.uottawa.ca/~kwhite/jdkbinaries/jdk1.1-FreeBSD.tar.gz diff --git a/jpl/install-jpl b/jpl/install-jpl new file mode 100755 index 0000000000..546ae91cc1 --- /dev/null +++ b/jpl/install-jpl @@ -0,0 +1,229 @@ +#!/usr/bin/perl + +print <<'END' if $>; +NOTE: Since you're not running as root, the installation will su at +the appropriate time later. You will need to supply the root password +for the su program. + +END + +# Gather data. + +# JPL_SRC + +chop($JPL_SRC = `pwd`); +print "JPL_SRC = $JPL_SRC\n"; + +# JAVA_HOME + +foreach $dir ( + $ENV{JAVA_HOME}, + "/usr/java", + "/usr/local/java", + "/usr/lib/java", + "/usr/local/lib/java", +) { + $JAVA_HOME = $dir, last if $dir and -d "$dir/bin"; +} +die "You must set the \$JAVA_HOME environment variable first.\n" + unless $JAVA_HOME; +print "JAVA_HOME = $JAVA_HOME\n"; + +# JPL_HOME + +($likelyjpl = $JAVA_HOME) =~ s#(.*)/.*#$1/jpl#; + +print <<"END"; + +You need to decide which directory JPL files are to be installed in. +Applications will look in subdirectories of this directory for any JPL +related files. + +You may use the current directory ($JPL_SRC) +or you may use a directory such as $likelyjpl. + +END + +$| = 1; +until (-d $JPL_HOME) { + print "Install JPL files where: [$JPL_SRC] "; + chop($JPL_HOME = <STDIN>); + $JPL_HOME ||= $JPL_SRC; + unless (-d $JPL_HOME) { + print "Warning: $JPL_HOME doesn't exist yet!\n\n"; + print "Do you want to create it? [y] "; + chop($ans = <STDIN>); + $ans ||= 'y'; + next unless $ans =~ /^y/i; + + system "mkdir -p $JPL_HOME"; + if ($> and not -d $JPL_HOME) { + warn "Couldn't create $JPL_HOME!\nTrying again as root...running su...\n"; + system "set -x +su root -c 'mkdir -p $JPL_HOME && chown $> $JPL_HOME && chmod 0755 $JPL_HOME'"; + warn "Couldn't create $JPL_HOME!\n" unless -d $JPL_HOME; + } + } +} +print "JPL_HOME = $JPL_HOME\n"; + +######################################################################### +# Spit out setvars. + +print "Writing setvars...\n"; + +unlink "$JPL_SRC/setvars"; +open(SETVARS, ">$JPL_HOME/setvars") or die "Can't create setvars: $!\n"; +while (<DATA>) { + s/^JPL_SRC=.*/JPL_SRC='$JPL_SRC'/; + s/^JAVA_HOME=.*/JAVA_HOME='$JAVA_HOME'/; + s/^JPL_HOME=.*/JPL_HOME='$JPL_HOME'/; + print SETVARS $_; +} +close SETVARS; +chmod 0755, "$JPL_HOME/setvars"; +symlink "$JPL_HOME/setvars", "$JPL_SRC/setvars" if $JPL_HOME ne $JPL_SRC; + +######################################################################### +# Pretend we're make. + +eval `./setvars -perl`; # Take our own medicine. + +print "\n\nStarting install...\n"; + +system <<'END' and die "Couldn't install JPL\n"; +set -x +cd JPL +perl Makefile.PL +make clean +perl Makefile.PL +make install +END + +print "\nInstalling PerlInterpreter class\n"; + +system <<'END' and die "Couldn't install PerlInterpreter\n"; +set -x +cd PerlInterpreter +perl Makefile.PL +make clean +perl Makefile.PL +make install +END + +print "\nInstalling JNI module\n"; + +system <<'END' and die "Couldn't install JNI\n"; +set -x +cd JNI +perl Makefile.PL +make clean +perl Makefile.PL +make +echo 'Attempting to install JNI as root' +su root -c "make install" +END + +#touch Makefile +#make -f makefile.jv +## These should be executed as root +#rm -rf /usr/lib/perl5/site_perl/i586-linux/auto/JNI +#rm -rf /usr/lib/perl5/site_perl/auto/JNI +#rm -f /usr/lib/perl5/site_perl/JNI.pm +#make -f makefile.jv install UNINST=1 + +print "\nInstalling Sample JPL program\n"; + +system <<'END' and die "Couldn't install Sample\n"; +set -x +cd Sample +perl Makefile.PL +make clean +perl Makefile.PL +make install +END + +# Test +print "\n\nTesting Sample...\n"; +system <<'END' and die "Couldn't run Sample\n"; +set -x +cd Sample +JPLDEBUG=1 +export JPLDEBUG +java Sample +END + +__END__ +#!/bin/sh + +# You can edit this, but your changes will only last until the next +# time you run install-jpl. + +# Where jpl is currently installed + +cd `dirname $0` +JPL_SRC=`pwd` + +# Where java is installed + +JAVA_HOME=/usr/local/java +export JAVA_HOME + +# Where jpl will be installed + +JPL_HOME="$JPL_SRC" +export JPL_HOME + +# Which perl to run + +JPLPERL=perl`perl -e "print $]"` +#JPLPERL=perl5.00404 +export JPLPERL + +# Some derivative variables +archname=`$JPLPERL -MConfig -e 'print $Config{archname}'` + archlib=`$JPLPERL -MConfig -e 'print $Config{archlib}'` + +CLASSPATH=".:$JPL_HOME/lib${CLASSPATH:+:$CLASSPATH}" +export CLASSPATH + +LD_LIBRARY_PATH=".:$JPL_HOME/lib/$archname:$archlib/CORE${LD_LIBRARY_PATH:+:$LD_LIBRARY_PATH}" +export LD_LIBRARY_PATH + +PERL5LIB="$JPL_HOME/perl${PERL5LIB:+:$PERL5LIB}" +export PERL5LIB + +# Make sure the right java programs are selected. +PATH="$JAVA_HOME/bin:$PATH" +export PATH + +case "$1" in +-perl) + cat <<END +\$ENV{PATH} = '$PATH'; +\$ENV{JAVA_HOME} = '$JAVA_HOME'; +\$ENV{JPL_HOME} = '$JPL_HOME'; +\$ENV{JPLPERL} = '$JPLPERL'; +\$ENV{CLASSPATH} = '$CLASSPATH'; +\$ENV{LD_LIBRARY_PATH} = '$LD_LIBRARY_PATH'; +\$ENV{PERL5LIB} = '$PERL5LIB'; +END + ;; +-sh) + cat <<END + PATH='$PATH';export PATH;JAVA_HOME='$JAVA_HOME';export JAVA_HOME;JPL_HOME='$JPL_HOME';export JPL_HOME;JPLPERL='$JPLPERL';export JPLPERL;CLASSPATH='$CLASSPATH';export CLASSPATH;LD_LIBRARY_PATH='$LD_LIBRARY_PATH';export LD_LIBRARY_PATH;PERL5LIB='$PERL5LIB';export PERL5LIB +END + ;; +-csh) + cat <<END +setenv PATH '$PATH'; +setenv JAVA_HOME '$JAVA_HOME'; +setenv JPL_HOME '$JPL_HOME'; +setenv JPLPERL '$JPLPERL'; +setenv CLASSPATH '$CLASSPATH'; +setenv LD_LIBRARY_PATH '$LD_LIBRARY_PATH'; +setenv PERL5LIB '$PERL5LIB'; +END + ;; +esac + diff --git a/lib/English.pm b/lib/English.pm index 7aa0d84617..9f29a487dc 100644 --- a/lib/English.pm +++ b/lib/English.pm @@ -168,6 +168,7 @@ sub import { *PERL_VERSION = *] ; *ACCUMULATOR = *^A ; + *COMPILING = *^C ; *DEBUGGING = *^D ; *SYSTEM_FD_MAX = *^F ; *INPLACE_EDIT = *^I ; diff --git a/lib/Sys/Syslog.pm b/lib/Sys/Syslog.pm index e8faac7126..f0cbb71924 100644 --- a/lib/Sys/Syslog.pm +++ b/lib/Sys/Syslog.pm @@ -124,7 +124,8 @@ sub openlog { $lo_ndelay = $logopt =~ /\bndelay\b/; $lo_cons = $logopt =~ /\bcons\b/; $lo_nowait = $logopt =~ /\bnowait\b/; - &connect if $lo_ndelay; + return 1 unless $lo_ndelay; + &connect; } sub closelog { diff --git a/lib/Test.pm b/lib/Test.pm index 22f947acf1..daf6e4e127 100644 --- a/lib/Test.pm +++ b/lib/Test.pm @@ -63,7 +63,7 @@ sub ok ($;$$) { } else { $expected = to_value(shift); my ($regex,$ignore); - if ((ref($expected)||'') eq 're') { + if ((ref($expected)||'') eq 'Regexp') { $ok = $result =~ /$expected/; } elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or ($ignore, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) { @@ -96,7 +96,7 @@ sub ok ($;$$) { my $prefix = "Test $ntest"; print $TESTOUT "# $prefix got: '$result' ($context)\n"; $prefix = ' ' x (length($prefix) - 5); - if ((ref($expected)||'') eq 're') { + if ((ref($expected)||'') eq 'Regexp') { $expected = 'qr/'.$expected.'/' } else { $expected = "'$expected'"; diff --git a/lib/Text/Wrap.pm b/lib/Text/Wrap.pm index 8566bb6a16..046dfaee33 100644 --- a/lib/Text/Wrap.pm +++ b/lib/Text/Wrap.pm @@ -1,69 +1,65 @@ package Text::Wrap; -use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $columns $debug $min_wrap_width); -use strict; -use Exporter; +require Exporter; -$VERSION = "97.03"; @ISA = qw(Exporter); -@EXPORT = qw(wrap); -@EXPORT_OK = qw($columns $tabstop $min_wrap_width fill); +@EXPORT = qw(wrap fill); +@EXPORT_OK = qw($columns $break $huge); -use Text::Tabs qw(expand unexpand $tabstop); +$VERSION = 98.112902; +use vars qw($VERSION $columns $debug $break $huge); +use strict; BEGIN { - $columns = 76; # <= screen width - $debug = 0; - # minimum wrap width (leaders will be shortened to accomodate this) - $min_wrap_width = int($columns/5); + $columns = 76; # <= screen width + $debug = 0; + $break = '\s'; + $huge = 'wrap'; # alternatively: 'die' } +use Text::Tabs qw(expand unexpand); + sub wrap { - my ($ip, $xp, @t) = @_; - - my @rv; - my $t = expand(join(" ",@t)); - - my $xll = $columns - length(expand($xp)) - 1; - while ($xll < $min_wrap_width) { - chop $xp; - $xll = $columns - length(expand($xp)) - 1; - } - - my $ll = $columns - length(expand($ip)) - 1; - while ($ll < $min_wrap_width) { - chop $ip; - $ll = $columns - length(expand($ip)) - 1; - } - my $lead = $ip; - my $nl = ""; - - $t =~ s/^\s+//; - while(length($t) > $ll) { - # remove up to a line length of things that - # aren't new lines and tabs. - if ($t =~ s/^([^\n]{0,$ll})(\s|\Z(?!\n))//) { - my ($l,$r) = ($1,$2); - $l =~ s/\s+$//; - print "WRAP $lead$l..($r)\n" if $debug; - push @rv, unexpand($lead . $l), "\n"; - - } elsif ($t =~ s/^([^\n]{$ll})//) { - print "SPLIT $lead$1..\n" if $debug; - push @rv, unexpand($lead . $1),"\n"; + my ($ip, $xp, @t) = @_; + + my $r = ""; + my $t = expand(join(" ",@t)); + my $lead = $ip; + my $ll = $columns - length(expand($ip)) - 1; + my $nll = $columns - length(expand($xp)) - 1; + my $nl = ""; + my $remainder = ""; + + while ($t !~ /^\s*$/) { + if ($t =~ s/^([^\n]{0,$ll})($break|\Z(?!\n))//xm) { + $r .= unexpand($nl . $lead . $1); + $remainder = $2; + } elsif ($huge eq 'wrap' && $t =~ s/^([^\n]{$ll})//) { + $r .= unexpand($nl . $lead . $1); + $remainder = "\n"; + } elsif ($huge eq 'die') { + die "couldn't wrap '$t'"; + } else { + die "This shouldn't happen"; + } + + $lead = $xp; + $ll = $nll; + $nl = "\n"; } - # reset the leader - $lead = $xp; - $ll = $xll; - $t =~ s/^\s+//; - } - print "TAIL $lead$t\n" if $debug; - push @rv, $lead.$t if $t ne ""; - return join '', @rv; -} + $r .= $remainder; + print "-----------$r---------\n" if $debug; + + print "Finish up with '$lead', '$t'\n" if $debug; + + $r .= $lead . $t if $t ne ""; + + print "-----------$r---------\n" if $debug;; + return $r; +} sub fill { @@ -95,25 +91,28 @@ Text::Wrap - line wrapping to form simple paragraphs use Text::Wrap print wrap($initial_tab, $subsequent_tab, @text); + print fill($initial_tab, $subsequent_tab, @text); - use Text::Wrap qw(wrap $columns $tabstop fill); + use Text::Wrap qw(wrap $columns $huge); $columns = 132; - $tabstop = 4; - - print fill($initial_tab, $subsequent_tab, @text); - print fill("", "", `cat book`); + $huge = 'die'; + $huge = 'wrap'; =head1 DESCRIPTION Text::Wrap::wrap() is a very simple paragraph formatter. It formats a single paragraph at a time by breaking lines at word boundries. Indentation is controlled for the first line ($initial_tab) and -all subsquent lines ($subsequent_tab) independently. $Text::Wrap::columns -should be set to the full width of your output device (default is 76). -$Text::Wrap::min_wrap_width controls the minimum number of columns that -are reserved for the wrapped text (default is 15). Indentation will -be reduced to accomodate this value. +all subsquent lines ($subsequent_tab) independently. + +Lines are wrapped at $Text::Wrap::columns columns. +$Text::Wrap::columns should be set to the full width of your output device. + +When words that are longer than $columns are encountered, they +are broken up. Previous versions of wrap() die()ed instead. +To restore the old (dying) behavior, set $Text::Wrap::huge to +'die'. Text::Wrap::fill() is a simple multi-paragraph formatter. It formats each paragraph separately and then joins them together when it's done. It @@ -126,15 +125,8 @@ it acts like wrap(). print wrap("\t","","This is a bit of text that forms a normal book-style paragraph"); -=head1 BUGS - -It's not clear what the correct behavior should be when Wrap() is -presented with a word that is longer than a line. The previous -behavior was to die. Now the word is now split at line-length. - =head1 AUTHOR David Muir Sharnoff <muir@idiom.com> with help from Tim Pierce and -others. Updated by Jacqui Caren. +many many others. -=cut @@ -726,6 +726,7 @@ emergency_sbrk(MEM_SIZE size) SV *sv; char *pv; int have = 0; + STRLEN n_a; if (emergency_buffer_size) { add_to_chain(emergency_buffer, emergency_buffer_size, 0); @@ -741,7 +742,7 @@ emergency_sbrk(MEM_SIZE size) return (char *)-1; /* Now die die die... */ } /* Got it, now detach SvPV: */ - pv = SvPV(sv, PL_na); + pv = SvPV(sv, n_a); /* Check alignment: */ if (((UV)(pv - sizeof(union overhead))) & ((1<<LOG_OF_MIN_ARENA) - 1)) { PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n"); @@ -421,8 +421,10 @@ magic_len(SV *sv, MAGIC *mg) return (STRLEN)PL_orslen; } magic_get(sv,mg); - if (!SvPOK(sv) && SvNIOK(sv)) - sv_2pv(sv, &PL_na); + if (!SvPOK(sv) && SvNIOK(sv)) { + STRLEN n_a; + sv_2pv(sv, &n_a); + } if (SvPOK(sv)) return SvCUR(sv); return 0; @@ -845,7 +847,8 @@ magic_setenv(SV *sv, MAGIC *mg) int magic_clearenv(SV *sv, MAGIC *mg) { - my_setenv(MgPV(mg,PL_na),Nullch); + STRLEN n_a; + my_setenv(MgPV(mg,n_a),Nullch); return 0; } @@ -858,12 +861,13 @@ magic_set_all_env(SV *sv, MAGIC *mg) dTHR; if (PL_localizing) { HE* entry; + STRLEN n_a; magic_clear_all_env(sv,mg); hv_iterinit((HV*)sv); while (entry = hv_iternext((HV*)sv)) { I32 keylen; my_setenv(hv_iterkey(entry, &keylen), - SvPV(hv_iterval((HV*)sv, entry), PL_na)); + SvPV(hv_iterval((HV*)sv, entry), n_a)); } } #endif @@ -911,8 +915,9 @@ int magic_getsig(SV *sv, MAGIC *mg) { I32 i; + STRLEN n_a; /* Are we fetching a signal entry? */ - i = whichsig(MgPV(mg,PL_na)); + i = whichsig(MgPV(mg,n_a)); if (i) { if(PL_psig_ptr[i]) sv_setsv(sv,PL_psig_ptr[i]); @@ -934,8 +939,9 @@ int magic_clearsig(SV *sv, MAGIC *mg) { I32 i; + STRLEN n_a; /* Are we clearing a signal entry? */ - i = whichsig(MgPV(mg,PL_na)); + i = whichsig(MgPV(mg,n_a)); if (i) { if(PL_psig_ptr[i]) { SvREFCNT_dec(PL_psig_ptr[i]); @@ -1223,11 +1229,12 @@ magic_setdbline(SV *sv, MAGIC *mg) I32 i; GV* gv; SV** svp; + STRLEN n_a; gv = PL_DBline; i = SvTRUE(sv); svp = av_fetch(GvAV(gv), - atoi(MgPV(mg,PL_na)), FALSE); + atoi(MgPV(mg,n_a)), FALSE); if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp))) o->op_private = i; else @@ -1344,10 +1351,11 @@ magic_setglob(SV *sv, MAGIC *mg) { register char *s; GV* gv; + STRLEN n_a; if (!SvOK(sv)) return 0; - s = SvPV(sv, PL_na); + s = SvPV(sv, n_a); if (*s == '*' && s[1]) s++; gv = gv_fetchpv(s,TRUE, SVt_PVGV); @@ -1547,6 +1555,7 @@ vivify_defelem(SV *sv) return; if (mg->mg_obj) { SV *ahv = LvTARG(sv); + STRLEN n_a; if (SvTYPE(ahv) == SVt_PVHV) { HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0); if (he) @@ -1558,7 +1567,7 @@ vivify_defelem(SV *sv) value = *svp; } if (!value || value == &PL_sv_undef) - croak(PL_no_helem, SvPV(mg->mg_obj, PL_na)); + croak(PL_no_helem, SvPV(mg->mg_obj, n_a)); } else { AV* av = (AV*)LvTARG(sv); @@ -1695,7 +1704,7 @@ magic_set(SV *sv, MAGIC *mg) if (PL_inplace) Safefree(PL_inplace); if (SvOK(sv)) - PL_inplace = savepv(SvPV(sv,PL_na)); + PL_inplace = savepv(SvPV(sv,len)); else PL_inplace = Nullch; break; @@ -1703,7 +1712,7 @@ magic_set(SV *sv, MAGIC *mg) if (PL_osname) Safefree(PL_osname); if (SvOK(sv)) - PL_osname = savepv(SvPV(sv,PL_na)); + PL_osname = savepv(SvPV(sv,len)); else PL_osname = Nullch; break; @@ -1733,12 +1742,12 @@ magic_set(SV *sv, MAGIC *mg) break; case '^': Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); - IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,PL_na)); + IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len)); IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO); break; case '~': Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); - IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,PL_na)); + IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len)); IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO); break; case '=': @@ -1795,7 +1804,7 @@ magic_set(SV *sv, MAGIC *mg) case '#': if (PL_ofmt) Safefree(PL_ofmt); - PL_ofmt = savepv(SvPV(sv,PL_na)); + PL_ofmt = savepv(SvPV(sv,len)); break; case '[': PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); @@ -1903,7 +1912,7 @@ magic_set(SV *sv, MAGIC *mg) case ')': #ifdef HAS_SETGROUPS { - char *p = SvPV(sv, PL_na); + char *p = SvPV(sv, len); Groups_t gary[NGROUPS]; SET_NUMERIC_STANDARD(); @@ -1951,7 +1960,7 @@ magic_set(SV *sv, MAGIC *mg) PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); break; case ':': - PL_chopset = SvPV_force(sv,PL_na); + PL_chopset = SvPV_force(sv,len); break; case '0': if (!PL_origalen) { @@ -56,9 +56,10 @@ static OP *new_logop _((I32 type, I32 flags, OP **firstp, OP **otherp)); STATIC char* gv_ename(GV *gv) { + STRLEN n_a; SV* tmpsv = sv_newmortal(); gv_efullname3(tmpsv, gv, Nullch); - return SvPV(tmpsv,PL_na); + return SvPV(tmpsv,n_a); } STATIC OP * @@ -549,11 +550,15 @@ find_threadsv(char *name) if (!p) return NOT_IN_PAD; key = p - PL_threadsv_names; + MUTEX_LOCK(&thr->mutex); svp = av_fetch(thr->threadsv, key, FALSE); - if (!svp) { + if (svp) + MUTEX_UNLOCK(&thr->mutex); + else { SV *sv = NEWSV(0, 0); av_store(thr->threadsv, key, sv); thr->threadsvp = AvARRAY(thr->threadsv); + MUTEX_UNLOCK(&thr->mutex); /* * Some magic variables used to be automagically initialised * in gv_fetchpv. Those which are now per-thread magicals get @@ -1130,6 +1135,7 @@ mod(OP *o, I32 type) dTHR; OP *kid; SV *sv; + STRLEN n_a; if (!o || PL_error_count) return o; @@ -1257,7 +1263,7 @@ mod(OP *o, I32 type) PL_modcount++; if (!type) croak("Can't localize lexical variable %s", - SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), PL_na)); + SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a)); break; #ifdef USE_THREADS @@ -3430,13 +3436,15 @@ newLOOPEX(I32 type, OP *label) { dTHR; OP *o; + STRLEN n_a; + if (type != OP_GOTO || label->op_type == OP_CONST) { /* "last()" means "last" */ if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) o = newOP(type, OPf_SPECIAL); else { o = newPVOP(type, 0, savepv(label->op_type == OP_CONST - ? SvPVx(((SVOP*)label)->op_sv, PL_na) + ? SvPVx(((SVOP*)label)->op_sv, n_a) : "")); } op_free(label); @@ -3690,7 +3698,11 @@ cv_clone2(CV *proto, CV *outside) CV * cv_clone(CV *proto) { - return cv_clone2(proto, CvOUTSIDE(proto)); + CV *cv; + MUTEX_LOCK(&PL_cred_mutex); /* XXX create separate mutex */ + cv = cv_clone2(proto, CvOUTSIDE(proto)); + MUTEX_UNLOCK(&PL_cred_mutex); /* XXX create separate mutex */ + return cv; } void @@ -3766,10 +3778,11 @@ CV * newSUB(I32 floor, OP *o, OP *proto, OP *block) { dTHR; - char *name = o ? SvPVx(cSVOPo->op_sv, PL_na) : Nullch; + STRLEN n_a; + char *name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch; GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI | (block ? 0 : GV_NOINIT), SVt_PVCV); - char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, PL_na) : Nullch; + char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch; register CV *cv=0; I32 ix; @@ -3876,7 +3889,7 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) else { /* force display of errors found but not reported */ sv_catpv(ERRSV, not_safe); - croak("%s", SvPVx(ERRSV, PL_na)); + croak("%s", SvPVx(ERRSV, n_a)); } } } @@ -4002,6 +4015,7 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) return cv; } +/* XXX unsafe for threads if eval_owner isn't held */ void newCONSTSUB(HV *stash, char *name, SV *sv) { @@ -4118,9 +4132,10 @@ newFORM(I32 floor, OP *o, OP *block) char *name; GV *gv; I32 ix; + STRLEN n_a; if (o) - name = SvPVx(cSVOPo->op_sv, PL_na); + name = SvPVx(cSVOPo->op_sv, n_a); else name = "STDOUT"; gv = gv_fetchpv(name,TRUE, SVt_PVFM); @@ -4469,6 +4484,7 @@ ck_rvconst(register OP *o) int iscv; GV *gv; SV *kidsv = kid->op_sv; + STRLEN n_a; /* Is it a constant from cv_const_sv()? */ if (SvROK(kidsv) && SvREADONLY(kidsv)) { @@ -4507,7 +4523,7 @@ ck_rvconst(register OP *o) croak("Constant is not %s reference", badtype); return o; } - name = SvPV(kidsv, PL_na); + name = SvPV(kidsv, n_a); if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { char *badthing = Nullch; switch (o->op_type) { @@ -4570,8 +4586,9 @@ ck_ftst(OP *o) SVOP *kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { + STRLEN n_a; OP *newop = newGVOP(type, OPf_REF, - gv_fetchpv(SvPVx(kid->op_sv, PL_na), TRUE, SVt_PVIO)); + gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO)); op_free(o); return newop; } @@ -4606,6 +4623,7 @@ ck_fun(OP *o) } if (o->op_flags & OPf_KIDS) { + STRLEN n_a; tokid = &cLISTOPo->op_first; kid = cLISTOPo->op_first; if (kid->op_type == OP_PUSHMARK || @@ -4635,7 +4653,7 @@ ck_fun(OP *o) case OA_AVREF: if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - char *name = SvPVx(((SVOP*)kid)->op_sv, PL_na); + char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); OP *newop = newAVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVAV) )); if (ckWARN(WARN_SYNTAX)) @@ -4654,7 +4672,7 @@ ck_fun(OP *o) case OA_HVREF: if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - char *name = SvPVx(((SVOP*)kid)->op_sv, PL_na); + char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); OP *newop = newHVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVHV) )); if (ckWARN(WARN_SYNTAX)) @@ -4686,7 +4704,7 @@ ck_fun(OP *o) if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { OP *newop = newGVOP(OP_GV, 0, - gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, PL_na), TRUE, + gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE, SVt_PVIO) ); op_free(kid); kid = newop; @@ -5135,6 +5153,7 @@ ck_subr(OP *o) GV *namegv = 0; int optional = 0; I32 arg = 0; + STRLEN n_a; for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ; if (cvop->op_type == OP_RV2CV) { @@ -5146,7 +5165,7 @@ ck_subr(OP *o) cv = GvCVu(tmpop->op_sv); if (cv && SvPOK(cv) && !(o->op_private & OPpENTERSUB_AMPER)) { namegv = CvANON(cv) ? (GV*)tmpop->op_sv : CvGV(cv); - proto = SvPV((SV*)cv, PL_na); + proto = SvPV((SV*)cv, n_a); } } } @@ -5238,7 +5257,7 @@ ck_subr(OP *o) default: oops: croak("Malformed prototype for %s: %s", - gv_ename(namegv), SvPV((SV*)cv, PL_na)); + gv_ename(namegv), SvPV((SV*)cv, n_a)); } } else @@ -5282,6 +5301,8 @@ peep(register OP *o) { dTHR; register OP* oldop = 0; + STRLEN n_a; + if (!o || o->op_seq) return; ENTER; @@ -5444,7 +5465,7 @@ peep(register OP *o) indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); if (!indsvp) { croak("No such field \"%s\" in variable %s of type %s", - key, SvPV(lexname, PL_na), HvNAME(SvSTASH(lexname))); + key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname))); } ind = SvIV(*indsvp); if (ind < 1) diff --git a/os2/OS2/REXX/REXX.xs b/os2/OS2/REXX/REXX.xs index 2d13f3e81e..60266f4f16 100644 --- a/os2/OS2/REXX/REXX.xs +++ b/os2/OS2/REXX/REXX.xs @@ -96,7 +96,8 @@ exec_in_REXX(char *cmd, char * handlerName, RexxFunctionHandler *handler) } if (rc || SvTRUE(GvSV(PL_errgv))) { if (SvTRUE(GvSV(PL_errgv))) { - die ("Error inside perl function called from REXX compartment.\n%s", SvPV(GvSV(PL_errgv), PL_na)) ; + STRLEN n_a; + die ("Error inside perl function called from REXX compartment.\n%s", SvPV(GvSV(PL_errgv), n_a)) ; } die ("REXX compartment returned non-zero status %li", rc); } @@ -162,7 +162,8 @@ int os2_cond_wait(perl_cond *c, perl_mutex *m) { int rc; - if ((rc = DosResetEventSem(*c,&PL_na)) && (rc != ERROR_ALREADY_RESET)) + STRLEN n_a; + if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET)) croak("panic: COND_WAIT-reset: rc=%i", rc); if (m) MUTEX_UNLOCK(m); if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT)) @@ -475,6 +476,7 @@ char *inicmd; char **argsp = fargs; char nargs = 4; int force_shell; + STRLEN n_a; if (flag == P_WAIT) flag = P_NOWAIT; @@ -489,7 +491,7 @@ char *inicmd; ) /* will spawnvp use PATH? */ TAINT_ENV(); /* testing IFS here is overkill, probably */ /* We should check PERL_SH* and PERLLIB_* as well? */ - if (!really || !*(tmps = SvPV(really, PL_na))) + if (!really || !*(tmps = SvPV(really, n_a))) tmps = PL_Argv[0]; reread: @@ -794,6 +796,7 @@ register SV **sp; char *tmps = NULL; int rc; int flag = P_WAIT, trueflag, err, secondtry = 0; + STRLEN n_a; if (sp > mark) { New(1301,PL_Argv, sp - mark + 3, char*); @@ -806,7 +809,7 @@ register SV **sp; while (++mark <= sp) { if (*mark) - *a++ = SvPVx(*mark, PL_na); + *a++ = SvPVx(*mark, n_a); else *a++ = ""; } @@ -1184,8 +1187,9 @@ XS(XS_File__Copy_syscopy) if (items < 2 || items > 3) croak("Usage: File::Copy::syscopy(src,dst,flag=0)"); { - char * src = (char *)SvPV(ST(0),PL_na); - char * dst = (char *)SvPV(ST(1),PL_na); + STRLEN n_a; + char * src = (char *)SvPV(ST(0),n_a); + char * dst = (char *)SvPV(ST(1),n_a); U32 flag; int RETVAL, rc; @@ -1214,6 +1218,7 @@ mod2fname(sv) AV *av; SV *svp; char *s; + STRLEN n_a; if (!SvROK(sv)) croak("Not a reference given to mod2fname"); sv = SvRV(sv); @@ -1224,7 +1229,7 @@ mod2fname(sv) if (avlen < 0) croak("Empty array reference given to mod2fname"); - s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na); + s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a); strncpy(fname, s, 8); len = strlen(s); if (len < 6) pos = len; @@ -1234,7 +1239,7 @@ mod2fname(sv) } avlen --; while (avlen >= 0) { - s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na); + s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a); while (*s) { sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */ } @@ -1473,9 +1478,10 @@ XS(XS_OS2_Errors2Drive) if (items != 1) croak("Usage: OS2::Errors2Drive(drive)"); { + STRLEN n_a; SV *sv = ST(0); int suppress = SvOK(sv); - char *s = suppress ? SvPV(sv, PL_na) : NULL; + char *s = suppress ? SvPV(sv, n_a) : NULL; char drive = (s ? *s : 0); unsigned long rc; @@ -1660,7 +1666,8 @@ XS(XS_Cwd_sys_chdir) if (items != 1) croak("Usage: Cwd::sys_chdir(path)"); { - char * path = (char *)SvPV(ST(0),PL_na); + STRLEN n_a; + char * path = (char *)SvPV(ST(0),n_a); bool RETVAL; RETVAL = sys_chdir(path); @@ -1676,7 +1683,8 @@ XS(XS_Cwd_change_drive) if (items != 1) croak("Usage: Cwd::change_drive(d)"); { - char d = (char)*SvPV(ST(0),PL_na); + STRLEN n_a; + char d = (char)*SvPV(ST(0),n_a); bool RETVAL; RETVAL = change_drive(d); @@ -1692,7 +1700,8 @@ XS(XS_Cwd_sys_is_absolute) if (items != 1) croak("Usage: Cwd::sys_is_absolute(path)"); { - char * path = (char *)SvPV(ST(0),PL_na); + STRLEN n_a; + char * path = (char *)SvPV(ST(0),n_a); bool RETVAL; RETVAL = sys_is_absolute(path); @@ -1708,7 +1717,8 @@ XS(XS_Cwd_sys_is_rooted) if (items != 1) croak("Usage: Cwd::sys_is_rooted(path)"); { - char * path = (char *)SvPV(ST(0),PL_na); + STRLEN n_a; + char * path = (char *)SvPV(ST(0),n_a); bool RETVAL; RETVAL = sys_is_rooted(path); @@ -1724,7 +1734,8 @@ XS(XS_Cwd_sys_is_relative) if (items != 1) croak("Usage: Cwd::sys_is_relative(path)"); { - char * path = (char *)SvPV(ST(0),PL_na); + STRLEN n_a; + char * path = (char *)SvPV(ST(0),n_a); bool RETVAL; RETVAL = sys_is_relative(path); @@ -1755,7 +1766,8 @@ XS(XS_Cwd_sys_abspath) if (items < 1 || items > 2) croak("Usage: Cwd::sys_abspath(path, dir = NULL)"); { - char * path = (char *)SvPV(ST(0),PL_na); + STRLEN n_a; + char * path = (char *)SvPV(ST(0),n_a); char * dir; char p[MAXPATHLEN]; char * RETVAL; @@ -1763,7 +1775,7 @@ XS(XS_Cwd_sys_abspath) if (items < 2) dir = NULL; else { - dir = (char *)SvPV(ST(1),PL_na); + dir = (char *)SvPV(ST(1),n_a); } if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) { path += 2; @@ -1903,7 +1915,8 @@ XS(XS_Cwd_extLibpath_set) if (items < 1 || items > 2) croak("Usage: Cwd::extLibpath_set(s, type = 0)"); { - char * s = (char *)SvPV(ST(0),PL_na); + STRLEN n_a; + char * s = (char *)SvPV(ST(0),n_a); bool type; U32 rc; bool RETVAL; diff --git a/patchlevel.h b/patchlevel.h index 70948b98cc..f01a059ac4 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1,7 +1,7 @@ #ifndef __PATCHLEVEL_H_INCLUDED__ #define PATCHLEVEL 5 #undef SUBVERSION /* OS/390 has a SUBVERSION in a system header */ -#define SUBVERSION 53 +#define SUBVERSION 54 /* local_patches -- list of locally applied less-than-subversion patches. @@ -1145,6 +1145,7 @@ CV* perl_get_cv(char *name, I32 create) { GV* gv = gv_fetchpv(name, create, SVt_PVCV); + /* XXX unsafe for threads if eval_owner isn't held */ if (create && !GvCVu(gv)) return newSUB(start_subparse(FALSE, 0), newSVOP(OP_CONST, 0, newSVpv(name,0)), @@ -1447,8 +1448,10 @@ perl_eval_pv(char *p, I32 croak_on_error) sv = POPs; PUTBACK; - if (croak_on_error && SvTRUE(ERRSV)) - croak(SvPVx(ERRSV, PL_na)); + if (croak_on_error && SvTRUE(ERRSV)) { + STRLEN n_a; + croak(SvPVx(ERRSV, n_a)); + } return sv; } @@ -2137,6 +2140,7 @@ validate_suid(char *validarg, char *scriptname, int fdscript) croak("Can't stat script \"%s\"",PL_origfilename); if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) { I32 len; + STRLEN n_a; #ifdef IAMSUID #ifndef HAS_SETREUID @@ -2209,12 +2213,12 @@ validate_suid(char *validarg, char *scriptname, int fdscript) PL_doswitches = FALSE; /* -s is insecure in suid */ PL_curcop->cop_line++; if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch || - strnNE(SvPV(PL_linestr,PL_na),"#!",2) ) /* required even on Sys V */ + strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */ croak("No #! line"); - s = SvPV(PL_linestr,PL_na)+2; + s = SvPV(PL_linestr,n_a)+2; if (*s == ' ') s++; while (!isSPACE(*s)) s++; - for (s2 = s; (s2 > SvPV(PL_linestr,PL_na)+2 && + for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 && (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ; if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */ croak("Not a perl script"); @@ -2753,7 +2757,7 @@ incpush(char *p, int addsubdirs) char *unix; STRLEN len; - if ((unix = tounixspec_ts(SvPV(libdir,PL_na),Nullch)) != Nullch) { + if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) { len = strlen(unix); while (unix[len-1] == '/') len--; /* Cosmetic */ sv_usepvn(libdir,unix,len); @@ -2761,7 +2765,7 @@ incpush(char *p, int addsubdirs) else PerlIO_printf(PerlIO_stderr(), "Failed to unixify @INC element \"%s\"\n", - SvPV(libdir,PL_na)); + SvPV(libdir,len)); #endif /* .../archname/version if -d .../archname/version/auto */ sv_setsv(subdir, libdir); diff --git a/perlvars.h b/perlvars.h index 17924a9154..3860345409 100644 --- a/perlvars.h +++ b/perlvars.h @@ -73,8 +73,6 @@ PERLVAR(Gnice_chunk_size, U32) /* how nice the chunk of memory is */ PERLVARI(Grunops, runops_proc_t, FUNC_NAME_TO_PTR(RUNOPS_DEFAULT)) PERLVAR(Gtokenbuf[256], char) -PERLVAR(Gna, STRLEN) /* for use in SvPV when length is - Not Applicable */ PERLVAR(Gsv_undef, SV) PERLVAR(Gsv_no, SV) @@ -1771,7 +1771,7 @@ case 56: break; case 57: #line 302 "perly.y" -{ char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv, PL_na); +{ STRLEN n_a; char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv, n_a); if (strEQ(name, "BEGIN") || strEQ(name, "END") || strEQ(name, "INIT")) CvUNIQUE_on(PL_compcv); @@ -304,7 +304,7 @@ startformsub: /* NULL */ /* start a format subroutine scope */ { $$ = start_subparse(TRUE, 0); } ; -subname : WORD { char *name = SvPV(((SVOP*)$1)->op_sv, PL_na); +subname : WORD { STRLEN n_a; char *name = SvPV(((SVOP*)$1)->op_sv,n_a); if (strEQ(name, "BEGIN") || strEQ(name, "END") || strEQ(name, "INIT")) CvUNIQUE_on(PL_compcv); diff --git a/pod/perlcall.pod b/pod/perlcall.pod index c239cfe324..e3e02de613 100644 --- a/pod/perlcall.pod +++ b/pod/perlcall.pod @@ -971,7 +971,8 @@ and some C to call it /* Check the eval first */ if (SvTRUE(ERRSV)) { - printf ("Uh oh - %s\n", SvPV(ERRSV, PL_na)) ; + STRLEN n_a; + printf ("Uh oh - %s\n", SvPV(ERRSV, n_a)) ; POPs ; } else @@ -1013,7 +1014,8 @@ The code if (SvTRUE(ERRSV)) { - printf ("Uh oh - %s\n", SvPV(ERRSV, PL_na)) ; + STRLEN n_a; + printf ("Uh oh - %s\n", SvPV(ERRSV, n_a)) ; POPs ; } diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 7cd721b549..d4fe20f299 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -1,6 +1,6 @@ =head1 NAME -perldelta - what's new for perl5.006 +perldelta - what's new for perl5.006 (as of 5.005_54) =head1 DESCRIPTION @@ -8,20 +8,64 @@ This document describes differences between the 5.005 release and this one. =head1 Incompatible Changes +=head2 Perl Source Incompatibilities + +None known at this time. + +=head2 C Source Incompatibilities + +=over 4 + +=item C<PERL_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. You need to explicitly +compile perl with C<-DPERL_POLLUTE> in order to get these definitions. + +=item C<PL_na> and C<dTHR> Issues + +The C<PL_na> global is now thread local, so a C<dTHR> declaration is needed +in the scope in which it appears. XSUBs should handle this automatically, +but if you have used C<PL_na> in support functions, you either need to +change the C<PL_na> to a local variable (which is recommended), or put in +a C<dTHR>. + +=back + +=head2 Binary Incompatibilities + +This release is not binary compatible with the 5.005 release and its +maintenance versions. + =head1 Core Changes +Todo. + =head1 Supported Platforms +Todo. + =head1 Modules and Pragmata +Todo. + =head1 Utility Changes +Todo. + =head1 Documentation Changes +Todo. + =head1 New Diagnostics +Todo. + =head1 Obsolete Diagnostics +Todo. + =head1 BUGS If you find what you think is a bug, you might check the headers of diff --git a/pod/perlembed.pod b/pod/perlembed.pod index c09d6e33cb..1314350f9e 100644 --- a/pod/perlembed.pod +++ b/pod/perlembed.pod @@ -285,6 +285,7 @@ the first, a C<float> from the second, and a C<char *> from the third. main (int argc, char **argv, char **env) { + STRLEN n_a; char *embedding[] = { "", "-e", "0" }; my_perl = perl_alloc(); @@ -303,7 +304,7 @@ the first, a C<float> from the second, and a C<char *> from the third. /** Treat $a as a string **/ perl_eval_pv("$a = 'rekcaH lreP rehtonA tsuJ'; $a = reverse($a);", TRUE); - printf("a = %s\n", SvPV(perl_get_sv("a", FALSE), PL_na)); + printf("a = %s\n", SvPV(perl_get_sv("a", FALSE), n_a)); perl_destruct(my_perl); perl_free(my_perl); @@ -325,8 +326,9 @@ possible and in most cases a better strategy to fetch the return value from I<perl_eval_pv()> instead. Example: ... + STRLEN n_a; SV *val = perl_eval_pv("reverse 'rekcaH lreP rehtonA tsuJ'", TRUE); - printf("%s\n", SvPV(val,PL_na)); + printf("%s\n", SvPV(val,n_a)); ... This way, we avoid namespace pollution by not creating global @@ -371,6 +373,7 @@ been wrapped here): { dSP; SV* retval; + STRLEN n_a; PUSHMARK(SP); perl_eval_sv(sv, G_SCALAR); @@ -380,7 +383,7 @@ been wrapped here): PUTBACK; if (croak_on_error && SvTRUE(ERRSV)) - croak(SvPVx(ERRSV, PL_na)); + croak(SvPVx(ERRSV, n_a)); return retval; } @@ -395,9 +398,10 @@ been wrapped here): I32 match(SV *string, char *pattern) { SV *command = NEWSV(1099, 0), *retval; + STRLEN n_a; sv_setpvf(command, "my $string = '%s'; $string =~ %s", - SvPV(string,PL_na), pattern); + SvPV(string,n_a), pattern); retval = my_perl_eval_sv(command, TRUE); SvREFCNT_dec(command); @@ -416,9 +420,10 @@ been wrapped here): I32 substitute(SV **string, char *pattern) { SV *command = NEWSV(1099, 0), *retval; + STRLEN n_a; sv_setpvf(command, "$string = '%s'; ($string =~ %s)", - SvPV(*string,PL_na), pattern); + SvPV(*string,n_a), pattern); retval = my_perl_eval_sv(command, TRUE); SvREFCNT_dec(command); @@ -439,9 +444,10 @@ been wrapped here): { SV *command = NEWSV(1099, 0); I32 num_matches; + STRLEN n_a; sv_setpvf(command, "my $string = '%s'; @array = ($string =~ %s)", - SvPV(string,PL_na), pattern); + SvPV(string,n_a), pattern); my_perl_eval_sv(command, TRUE); SvREFCNT_dec(command); @@ -459,6 +465,7 @@ been wrapped here): AV *match_list; I32 num_matches, i; SV *text = NEWSV(1099,0); + STRLEN n_a; perl_construct(my_perl); perl_parse(my_perl, NULL, 3, embedding, NULL); @@ -480,7 +487,7 @@ been wrapped here): printf("matches: m/(wi..)/g found %d matches...\n", num_matches); for (i = 0; i < num_matches; i++) - printf("match: %s\n", SvPV(*av_fetch(match_list, i, FALSE),PL_na)); + printf("match: %s\n", SvPV(*av_fetch(match_list, i, FALSE),n_a)); printf("\n"); /** Remove all vowels from text **/ @@ -488,7 +495,7 @@ been wrapped here): if (num_matches) { printf("substitute: s/[aeiou]//gi...%d substitutions made.\n", num_matches); - printf("Now text is: %s\n\n", SvPV(text,PL_na)); + printf("Now text is: %s\n\n", SvPV(text,n_a)); } /** Attempt a substitution **/ @@ -726,6 +733,7 @@ with L<perlfunc/my> whenever possible. char *args[] = { "", DO_CLEAN, NULL }; char filename [1024]; int exitstatus = 0; + STRLEN n_a; if((perl = perl_alloc()) == NULL) { fprintf(stderr, "no memory!"); @@ -747,7 +755,7 @@ with L<perlfunc/my> whenever possible. /* check $@ */ if(SvTRUE(ERRSV)) - fprintf(stderr, "eval error: %s\n", SvPV(ERRSV,PL_na)); + fprintf(stderr, "eval error: %s\n", SvPV(ERRSV,n_a)); } } diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 7900fb57fc..557d418546 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -454,9 +454,10 @@ Always use the two-argument version if the function doing the blessing might be inherited by a derived class. See L<perltoot> and L<perlobj> for more about the blessing (and blessings) of objects. -Creating objects in lowercased CLASSNAMEs should be avoided. Such -namespaces should be considered reserved for Perl pragmata and objects -that may be created to implement internal operations. +Consider always blessing objects in CLASSNAMEs that are mixed case. +Namespaces with all lowercase names are considered reserved for Perl +pragmata. Builtin types have all uppercase names, so to prevent confusion, +it is best to avoid such package names as well. See L<perlmod/"Perl Modules">. diff --git a/pod/perlguts.pod b/pod/perlguts.pod index b835b59a38..38d75691f2 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -95,7 +95,8 @@ or string. In the C<SvPV> macro, the length of the string returned is placed into the variable C<len> (this is a macro, so you do I<not> use C<&len>). If you do not -care what the length of the data is, use the global variable C<PL_na>. Remember, +care what the length of the data is, use the global variable C<PL_na>, though +this is rather less efficient than using a local variable. Remember, however, that Perl allows arbitrary strings of data that may both contain NULs and might not be terminated by a NUL. @@ -1636,7 +1637,7 @@ the SV which holds the name of the sub being debugged. This is the C variable which corresponds to Perl's $DB::sub variable. See C<PL_DBsingle>. The sub name can be found by - SvPV( GvSV( PL_DBsub ), PL_na ) + SvPV( GvSV( PL_DBsub ), len ) =item PL_DBtrace @@ -1856,7 +1857,8 @@ Returns the key slot of the hash entry as a C<char*> value, doing any necessary dereferencing of possibly C<SV*> keys. The length of the string is placed in C<len> (this is a macro, so do I<not> use C<&len>). If you do not care about what the length of the key is, -you may use the global variable C<PL_na>. Remember though, that hash +you may use the global variable C<PL_na>, though this is rather less +efficient than using a local variable. Remember though, that hash keys in perl are free to contain embedded nulls, so using C<strlen()> or similar is not a good way to find the length of hash keys. This is very similar to the C<SvPV()> macro described elsewhere in @@ -2179,8 +2181,9 @@ the type. Can do overlapping moves. See also C<Copy>. =item PL_na -A variable which may be used with C<SvPV> to tell Perl to calculate the -string length. +A convenience variable which is typically used with C<SvPV> when one doesn't +care about the length of the string. It is usually more efficient to +declare a local variable and use that instead. =item New @@ -3008,8 +3011,7 @@ Checks the B<private> setting. Use C<SvPOK>. =item SvPV Returns a pointer to the string in the SV, or a stringified form of the SV -if the SV does not contain a string. If C<len> is C<PL_na> then Perl will -handle the length on its own. Handles 'get' magic. +if the SV does not contain a string. Handles 'get' magic. char* SvPV (SV* sv, int len ) diff --git a/pod/perlreftut.pod b/pod/perlreftut.pod index 2fac79df00..4526e4a2a0 100644 --- a/pod/perlreftut.pod +++ b/pod/perlreftut.pod @@ -11,8 +11,8 @@ nested hashes. To enable these, Perl 5 introduced a feature called `references', and using references is the key to managing complicated, structured data in Perl. Unfortunately, there's a lot of funny syntax to learn, and the main manual page can be hard to follow. The manual -is quite complete, and sometimes people find that a problem, because it -can be hard to tell what is important and what isn't. +is quite complete, and sometimes people find that a problem, because +it can be hard to tell what is important and what isn't. Fortunately, you only need to know 10% of what's in the main page to get 90% of the benefit. This page will show you that 10%. @@ -24,27 +24,27 @@ hash whose values were lists. Perl 4 had hashes, of course, but the values had to be scalars; they couldn't be lists. Why would you want a hash of lists? Let's take a simple example: You -have a file of city and state names, like this: +have a file of city and country names, like this: - Chicago, Illinois - New York, New York - Albany, New York - Springfield, Illinois - Trenton, New Jersey - Evanston, Illinois + Chicago, USA + Frankfurt, Germany + Berlin, Germany + Washington, USA + Helsinki, Finland + New York, USA -and you want to produce an output like this, with each state mentioned -once, and then an alphabetical list of the cities in that state: +and you want to produce an output like this, with each country mentioned +once, and then an alphabetical list of the cities in that country: - Illinois: Chicago, Evanston, Springfield. - New Jersey: Trenton. - New York: Albany, New York. + Finland: Helsinki. + Germany: Berlin, Frankfurt. + USA: Chicago, New York, Washington. -The natural way to do this is to have a hash whose keys are state -names. Associated with each state name key is a list of the cities in -that state. Each time you read a line of input, split it into a state +The natural way to do this is to have a hash whose keys are country +names. Associated with each country name key is a list of the cities in +that country. Each time you read a line of input, split it into a country and a city, look up the list of cities already known to be in that -state, and append the new city to the list. When you're done reading +country, and append the new city to the list. When you're done reading the input, iterate over the hash as usual, sorting each list of cities before you print it out. @@ -59,12 +59,12 @@ use them. =head1 The Solution -Unfortunately, by the time Perl 5 rolled around, we were already stuck -with this design: Hash values must be scalars. The solution to this is +By the time Perl 5 rolled around, we were already stuck with this +design: Hash values must be scalars. The solution to this is references. A reference is a scalar value that I<refers to> an entire array or an -entire hash (or to just about anything else.) Names are one kind of +entire hash (or to just about anything else). Names are one kind of reference that you're already familiar with. Think of the President: a messy, inconvenient bag of blood and bones. But to talk about him, or to represent him in a computer program, all you need is the easy, @@ -84,7 +84,7 @@ an entire array, and references are scalars, so you can have a hash of references to arrays, and it'll act a lot like a hash of arrays, and it'll be just as useful as a hash of arrays. -We'll come back to this city-state problem later, after we've seen +We'll come back to this city-country problem later, after we've seen some syntax for managing references. @@ -255,18 +255,18 @@ the unreadable C<${${$x[2]}[3]}[5]>. =head1 Solution -Here's the answer to the problem I posed the the beginning of the -article, of reformatting a file of city and state names. +Here's the answer to the problem I posed earlier, of reformatting a +file of city and country names. 1 while (<>) { 2 chomp; - 3 my ($city, $state) = split /, /; - 4 push @{$table{$state}}, $city; + 3 my ($city, $country) = split /, /; + 4 push @{$table{$country}}, $city; 5 } 6 - 7 foreach $state (sort keys %table) { - 8 print "$state: "; - 9 my @cities = @{$table{$state}}; + 7 foreach $country (sort keys %table) { + 8 print "$country: "; + 9 my @cities = @{$table{$country}}; 10 print join ', ', sort @cities; 11 print ".\n"; 12 } @@ -277,45 +277,45 @@ data structure, and lines 7--12 analyze the data and print out the report. In the first part, line 4 is the important one. We're going to have a -hash, C<%table>, whose keys are state names, and whose values are +hash, C<%table>, whose keys are country names, and whose values are (references to) arrays of city names. After acquiring a city and -state name, the program looks up C<$table{$state}>, which holds (a -reference to) the list of cities seen in that state so far. Line 4 is +country name, the program looks up C<$table{$country}>, which holds (a +reference to) the list of cities seen in that country so far. Line 4 is totally analogous to push @array, $city; except that the name C<array> has been replaced by the reference -C<{$table{$state}}>. The C<push> adds a city name to the end of the +C<{$table{$country}}>. The C<push> adds a city name to the end of the referred-to array. In the second part, line 9 is the important one. Again, -C<$table{$state}> is (a reference to) the list of cities in the state, so +C<$table{$country}> is (a reference to) the list of cities in the country, so we can recover the original list, and copy it into the array C<@cities>, -by using C<@{$table{$state}}>. Line 9 is totally analogous to +by using C<@{$table{$country}}>. Line 9 is totally analogous to @cities = @array; except that the name C<array> has been replaced by the reference -C<{$table{$state}}>. The C<@> tells Perl to get the entire array. +C<{$table{$country}}>. The C<@> tells Perl to get the entire array. The rest of the program is just familiar uses of C<chomp>, C<split>, C<sort>, C<print>, and doesn't involve references at all. There's one fine point I skipped. Suppose the program has just read -the first line in its input that happens to mention the state of Ohio. -Control is at line 4, C<$state> is C<'Ohio'>, and C<$city> is -C<'Cleveland'>. Since this is the first city in Ohio, -C<$table{$state}> is undefined---in fact there isn't an C<'Ohio'> key +the first line in its input that happens to mention Greece. +Control is at line 4, C<$country> is C<'Greece'>, and C<$city> is +C<'Athens'>. Since this is the first city in Greece, +C<$table{$country}> is undefined---in fact there isn't an C<'Greece'> key in C<%table> at all. What does line 4 do here? - 4 push @{$table{$state}}, $city; + 4 push @{$table{$country}}, $city; This is Perl, so it does the exact right thing. It sees that you want -to push C<Cleveland> onto an array that doesn't exist, so it helpfully +to push C<Athens> onto an array that doesn't exist, so it helpfully makes a new, empty, anonymous array for you, installs it in the table, -and then pushes C<Cleveland> onto it. This is called `autovivification'. +and then pushes C<Athens> onto it. This is called `autovivification'. =head1 The Rest @@ -336,9 +336,10 @@ other references. =item * -In B<USE RULE 1>, you can often omit the curly braces. For example, +In B<USE RULE 1>, you can omit the curly braces whenever the thing +inside them is an atomic scalar variable like C<$aref>. For example, C<@$aref> is the same as C<@{$aref}>, and C<$$aref[1]> is the same as -C<${$aref}[1]>. If you're jsut starting out, you might want to adopt +C<${$aref}[1]>. If you're just starting out, you may want to adopt the habit of always including the curly braces. =item * @@ -346,7 +347,7 @@ the habit of always including the curly braces. To see if a variable contains a reference, use the `ref' function. It returns true if its argument is a reference. Actually it's a little better than that: It returns HASH for hash references and -ARRAYfor array references. +ARRAY for array references. =item * @@ -387,11 +388,29 @@ to do with references. Author: Mark-Jason Dominus, Plover Systems (C<mjd-perl-ref@plover.com>) -This article originally appeared in I<The Perl Journal> volume 3, #2. -Reprinted with permission. +This article originally appeared in I<The Perl Journal> +(http://tpj.com) volume 3, #2. Reprinted with permission. The original title was I<Understand References Today>. +=head2 Distribution Conditions + +Copyright 1998 The Perl Journal. + +When included as part of the Standard Version of Perl, or as part of +its complete documentation whether printed or otherwise, this work may +be distributed only under the terms of Perl's Artistic License. Any +distribution of this file or derivatives thereof outside of that +package require that special arrangements be made with copyright +holder. + +Irrespective of its distribution, all code examples in these files are +hereby placed into the public domain. You are permitted and +encouraged to use this code in your own programs for fun or for profit +as you see fit. A simple comment in the code giving credit would be +courteous but is not required. -=cut + + +=cut diff --git a/pod/perlvar.pod b/pod/perlvar.pod index 8c6305ccad..fb27bfba46 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -674,6 +674,15 @@ of perl in the right bracket?) Example: See also the documentation of C<use VERSION> and C<require VERSION> for a convenient way to fail if the Perl interpreter is too old. +=item $COMPILING + +=item $^C + +The current value of the flag associated with the B<-c> switch. Mainly +of use with B<-MO=...> to allow code to alter its behaviour when being compiled. +(For example to automatically AUTOLOADing at compile time rather than normal +deferred loading.) Setting C<$^C = 1> is similar to calling C<B::minus_c>. + =item $DEBUGGING =item $^D diff --git a/pod/perlxs.pod b/pod/perlxs.pod index 2e022477ea..89ddf3e132 100644 --- a/pod/perlxs.pod +++ b/pod/perlxs.pod @@ -553,9 +553,10 @@ The XS code, with ellipsis, follows. time_t timep = NO_INIT PREINIT: char *host = "localhost"; + STRLEN n_a; CODE: if( items > 1 ) - host = (char *)SvPV(ST(1), PL_na); + host = (char *)SvPV(ST(1), n_a); RETVAL = rpcb_gettime( host, &timep ); OUTPUT: timep @@ -786,9 +787,10 @@ prototypes. PROTOTYPE: $;$ PREINIT: char *host = "localhost"; + STRLEN n_a; CODE: if( items > 1 ) - host = (char *)SvPV(ST(1), PL_na); + host = (char *)SvPV(ST(1), n_a); RETVAL = rpcb_gettime( host, &timep ); OUTPUT: timep @@ -226,6 +226,7 @@ PP(pp_rv2gv) else { if (SvTYPE(sv) != SVt_PVGV) { char *sym; + STRLEN n_a; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -240,7 +241,7 @@ PP(pp_rv2gv) warner(WARN_UNINITIALIZED, PL_warn_uninit); RETSETUNDEF; } - sym = SvPV(sv, PL_na); + sym = SvPV(sv, n_a); if (PL_op->op_private & HINT_STRICT_REFS) DIE(PL_no_symref, sym, "a symbol"); sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV); @@ -271,6 +272,7 @@ PP(pp_rv2sv) else { GV *gv = (GV*)sv; char *sym; + STRLEN n_a; if (SvTYPE(gv) != SVt_PVGV) { if (SvGMAGICAL(sv)) { @@ -286,7 +288,7 @@ PP(pp_rv2sv) warner(WARN_UNINITIALIZED, PL_warn_uninit); RETSETUNDEF; } - sym = SvPV(sv, PL_na); + sym = SvPV(sv, n_a); if (PL_op->op_private & HINT_STRICT_REFS) DIE(PL_no_symref, sym, "a SCALAR"); gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV); @@ -544,9 +546,10 @@ PP(pp_gelem) SV *tmpRef; char *elem; djSP; - + STRLEN n_a; + sv = POPs; - elem = SvPV(sv, PL_na); + elem = SvPV(sv, n_a); gv = (GV*)POPs; tmpRef = Nullsv; sv = Nullsv; @@ -1797,8 +1800,9 @@ PP(pp_hex) djSP; dTARGET; char *tmps; I32 argtype; + STRLEN n_a; - tmps = POPp; + tmps = POPpx; XPUSHu(scan_hex(tmps, 99, &argtype)); RETURN; } @@ -1809,8 +1813,9 @@ PP(pp_oct) UV value; I32 argtype; char *tmps; + STRLEN n_a; - tmps = POPp; + tmps = POPpx; while (*tmps && isSPACE(*tmps)) tmps++; if (*tmps == '0') @@ -1922,7 +1927,8 @@ PP(pp_substr) if (lvalue) { /* it's an lvalue! */ if (!SvGMAGICAL(sv)) { if (SvROK(sv)) { - SvPV_force(sv,PL_na); + STRLEN n_a; + SvPV_force(sv,n_a); if (ckWARN(WARN_SUBSTR)) warner(WARN_SUBSTR, "Attempt to use reference as lvalue in substr"); @@ -2131,7 +2137,8 @@ PP(pp_ord) { djSP; dTARGET; UV value; - U8 *tmps = (U8*)POPp; + STRLEN n_a; + U8 *tmps = (U8*)POPpx; I32 retlen; if (IN_UTF8 && (*tmps & 0x80)) @@ -2174,12 +2181,13 @@ PP(pp_chr) PP(pp_crypt) { djSP; dTARGET; dPOPTOPssrl; + STRLEN n_a; #ifdef HAS_CRYPT - char *tmps = SvPV(left, PL_na); + char *tmps = SvPV(left, n_a); #ifdef FCRYPT - sv_setpv(TARG, fcrypt(tmps, SvPV(right, PL_na))); + sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a))); #else - sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, PL_na))); + sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a))); #endif #else DIE( @@ -2231,7 +2239,7 @@ PP(pp_ucfirst) sv = TARG; SETs(sv); } - s = (U8*)SvPV_force(sv, PL_na); + s = (U8*)SvPV_force(sv, slen); if (*s) { if (PL_op->op_private & OPpLOCALE) { TAINT; @@ -2287,7 +2295,7 @@ PP(pp_lcfirst) sv = TARG; SETs(sv); } - s = (U8*)SvPV_force(sv, PL_na); + s = (U8*)SvPV_force(sv, slen); if (*s) { if (PL_op->op_private & OPpLOCALE) { TAINT; @@ -2658,8 +2666,10 @@ PP(pp_hslice) svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0); } if (lval) { - if (!svp || *svp == &PL_sv_undef) - DIE(PL_no_helem, SvPV(keysv, PL_na)); + if (!svp || *svp == &PL_sv_undef) { + STRLEN n_a; + DIE(PL_no_helem, SvPV(keysv, n_a)); + } if (PL_op->op_private & OPpLVAL_INTRO) save_helem(hv, keysv, svp); } @@ -3699,6 +3709,7 @@ PP(pp_unpack) } else if (++bytes >= sizeof(UV)) { /* promote to string */ char *t; + STRLEN n_a; sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv); while (s < strend) { @@ -3708,7 +3719,7 @@ PP(pp_unpack) break; } } - t = SvPV(sv, PL_na); + t = SvPV(sv, n_a); while (*t == '0') t++; sv_chop(sv, t); @@ -3956,8 +3967,9 @@ doencodes(register SV *sv, register char *s, register I32 len) STATIC SV * is_an_int(char *s, STRLEN l) { + STRLEN n_a; SV *result = newSVpv("", l); - char *result_c = SvPV(result, PL_na); /* convenience */ + char *result_c = SvPV(result, n_a); /* convenience */ char *out = result_c; bool skip = 1; bool ignore = 0; @@ -4462,6 +4474,7 @@ PP(pp_pack) if (fromstr == &PL_sv_undef) aptr = NULL; else { + STRLEN n_a; /* XXX better yet, could spirit away the string to * a safe spot and hang on to it until the result * of pack() (and all copies of the result) are @@ -4471,9 +4484,9 @@ PP(pp_pack) warner(WARN_UNSAFE, "Attempt to pack pointer to temporary value"); if (SvPOK(fromstr) || SvNIOK(fromstr)) - aptr = SvPV(fromstr,PL_na); + aptr = SvPV(fromstr,n_a); else - aptr = SvPV_force(fromstr,PL_na); + aptr = SvPV_force(fromstr,n_a); } sv_catpvn(cat, (char*)&aptr, sizeof(char*)); } @@ -58,14 +58,16 @@ #define RETURNX(x) return x, PUTBACK, NORMAL #define POPs (*sp--) -#define POPp (SvPVx(POPs, PL_na)) +#define POPp (SvPVx(POPs, PL_na)) /* deprecated */ +#define POPpx (SvPVx(POPs, n_a)) #define POPn (SvNVx(POPs)) #define POPi ((IV)SvIVx(POPs)) #define POPu ((UV)SvUVx(POPs)) #define POPl ((long)SvIVx(POPs)) #define TOPs (*sp) -#define TOPp (SvPV(TOPs, PL_na)) +#define TOPp (SvPV(TOPs, PL_na)) /* deprecated */ +#define TOPpx (SvPV(TOPs, n_a)) #define TOPn (SvNV(TOPs)) #define TOPi ((IV)SvIV(TOPs)) #define TOPu ((UV)SvUV(TOPs)) @@ -872,10 +872,11 @@ PP(pp_sort) if (*up = *++MARK) { /* Weed out nulls. */ SvTEMP_off(*up); if (!PL_sortcop && !SvPOK(*up)) { + STRLEN n_a; if (SvAMAGIC(*up)) overloading = 1; else - (void)sv_2pv(*up, &PL_na); + (void)sv_2pv(*up, &n_a); } up++; } @@ -1006,11 +1007,11 @@ PP(pp_flop) } else { SV *final = sv_mortalcopy(right); - STRLEN len; + STRLEN len, n_a; char *tmps = SvPV(final, len); sv = sv_mortalcopy(left); - SvPV_force(sv,PL_na); + SvPV_force(sv,n_a); while (!SvNIOKp(sv) && SvCUR(sv) <= len) { XPUSHs(sv); if (strEQ(SvPVX(sv),tmps)) @@ -1233,6 +1234,7 @@ OP * die_where(char *message) { dSP; + STRLEN n_a; if (PL_in_eval) { I32 cxix; register PERL_CONTEXT *cx; @@ -1268,7 +1270,7 @@ die_where(char *message) sv_setpv(ERRSV, message); } else - message = SvPVx(ERRSV, PL_na); + message = SvPVx(ERRSV, n_a); while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) { dounwind(-1); @@ -1295,14 +1297,14 @@ die_where(char *message) LEAVE; if (optype == OP_REQUIRE) { - char* msg = SvPVx(ERRSV, PL_na); + char* msg = SvPVx(ERRSV, n_a); DIE("%s", *msg ? msg : "Compilation failed in require"); } return pop_return(); } } if (!message) - message = SvPVx(ERRSV, PL_na); + message = SvPVx(ERRSV, n_a); PerlIO_printf(PerlIO_stderr(), "%s",message); PerlIO_flush(PerlIO_stderr()); my_failure_exit(); @@ -1480,11 +1482,12 @@ PP(pp_reset) { djSP; char *tmps; + STRLEN n_a; if (MAXARG < 1) tmps = ""; else - tmps = POPp; + tmps = POPpx; sv_reset(tmps, PL_curcop->cop_stash); PUSHs(&PL_sv_yes); RETURN; @@ -1940,6 +1943,7 @@ PP(pp_goto) label = 0; if (PL_op->op_flags & OPf_STACKED) { SV *sv = POPs; + STRLEN n_a; /* This egregious kludge implements goto &subroutine */ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { @@ -2189,7 +2193,7 @@ PP(pp_goto) } } else - label = SvPV(sv,PL_na); + label = SvPV(sv,n_a); } else if (PL_op->op_flags & OPf_SPECIAL) { if (! do_dump) @@ -2338,7 +2342,8 @@ PP(pp_cswitch) if (PL_multiline) PL_op = PL_op->op_next; /* can't assume anything */ else { - match = *(SvPVx(GvSV(cCOP->cop_gv), PL_na)) & 255; + STRLEN n_a; + match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255; match -= cCOP->uop.scop.scop_offset; if (match < 0) match = 0; @@ -2577,6 +2582,7 @@ doeval(int gimme, OP** startop) I32 gimme; PERL_CONTEXT *cx; I32 optype = 0; /* Might be reset by POPEVAL. */ + STRLEN n_a; PL_op = saveop; if (PL_eval_root) { @@ -2592,10 +2598,10 @@ doeval(int gimme, OP** startop) lex_end(); LEAVE; if (optype == OP_REQUIRE) { - char* msg = SvPVx(ERRSV, PL_na); + char* msg = SvPVx(ERRSV, n_a); DIE("%s", *msg ? msg : "Compilation failed in require"); } else if (startop) { - char* msg = SvPVx(ERRSV, PL_na); + char* msg = SvPVx(ERRSV, n_a); POPBLOCK(cx,PL_curpm); POPEVAL(cx); @@ -2668,13 +2674,14 @@ PP(pp_require) SV** svp; I32 gimme = G_SCALAR; PerlIO *tryrsfp = 0; + STRLEN n_a; sv = POPs; if (SvNIOKp(sv) && !SvPOKp(sv)) { SET_NUMERIC_STANDARD(); if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv)) DIE("Perl %s required--this is only version %s, stopped", - SvPV(sv,PL_na),PL_patchlevel); + SvPV(sv,n_a),PL_patchlevel); RETPUSHYES; } name = SvPV(sv, len); @@ -2717,7 +2724,7 @@ PP(pp_require) { namesv = NEWSV(806, 0); for (i = 0; i <= AvFILL(ar); i++) { - char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na); + char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a); #ifdef VMS char *unixdir; if ((unixdir = tounixpath(dir, Nullch)) == Nullch) @@ -2753,7 +2760,7 @@ PP(pp_require) sv_catpv(msg, " (did you run h2ph?)"); sv_catpv(msg, " (@INC contains:"); for (i = 0; i <= AvFILL(ar); i++) { - char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na); + char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a); sv_setpvf(dirmsgsv, " %s", dir); sv_catsv(msg, dirmsgsv); } @@ -322,6 +322,7 @@ PP(pp_print) IO *io; register PerlIO *fp; MAGIC *mg; + STRLEN n_a; if (PL_op->op_flags & OPf_STACKED) gv = (GV*)*++MARK; @@ -353,7 +354,7 @@ PP(pp_print) if (ckWARN(WARN_UNOPENED)) { SV* sv = sv_newmortal(); gv_fullname3(sv, gv, Nullch); - warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,PL_na)); + warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a)); } SETERRNO(EBADF,RMS$_IFI); @@ -365,10 +366,10 @@ PP(pp_print) gv_fullname3(sv, gv, Nullch); if (IoIFP(io)) warner(WARN_IO, "Filehandle %s opened only for input", - SvPV(sv,PL_na)); + SvPV(sv,n_a)); else if (ckWARN(WARN_CLOSED)) warner(WARN_CLOSED, "print on closed filehandle %s", - SvPV(sv,PL_na)); + SvPV(sv,n_a)); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; @@ -447,6 +448,7 @@ PP(pp_rv2av) if (SvTYPE(sv) != SVt_PVGV) { char *sym; + STRLEN n_a; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -465,7 +467,7 @@ PP(pp_rv2av) } RETSETUNDEF; } - sym = SvPV(sv,PL_na); + sym = SvPV(sv,n_a); if (PL_op->op_private & HINT_STRICT_REFS) DIE(PL_no_symref, sym, "an ARRAY"); gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV); @@ -536,6 +538,7 @@ PP(pp_rv2hv) if (SvTYPE(sv) != SVt_PVGV) { char *sym; + STRLEN n_a; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -554,7 +557,7 @@ PP(pp_rv2hv) } RETSETUNDEF; } - sym = SvPV(sv,PL_na); + sym = SvPV(sv,n_a); if (PL_op->op_private & HINT_STRICT_REFS) DIE(PL_no_symref, sym, "a HASH"); gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV); @@ -819,7 +822,7 @@ PP(pp_qr) djSP; register PMOP *pm = cPMOP; SV *rv = sv_newmortal(); - SV *sv = newSVrv(rv, "re"); + SV *sv = newSVrv(rv, "Regexp"); sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0); RETURNX(PUSHs(rv)); } @@ -1389,8 +1392,10 @@ PP(pp_helem) if (!svp || *svp == &PL_sv_undef) { SV* lv; SV* key2; - if (!defer) - DIE(PL_no_helem, SvPV(keysv, PL_na)); + if (!defer) { + STRLEN n_a; + DIE(PL_no_helem, SvPV(keysv, n_a)); + } lv = sv_newmortal(); sv_upgrade(lv, SVt_PVLV); LvTYPE(lv) = 'y'; @@ -2018,6 +2023,7 @@ PP(pp_entersub) default: if (!SvROK(sv)) { char *sym; + STRLEN n_a; if (sv == &PL_sv_yes) { /* unfound import, ignore */ if (hasargs) @@ -2029,7 +2035,7 @@ PP(pp_entersub) sym = SvPOKp(sv) ? SvPVX(sv) : Nullch; } else - sym = SvPV(sv, PL_na); + sym = SvPV(sv, n_a); if (!sym) DIE(PL_no_usym, "a subroutine"); if (PL_op->op_private & HINT_STRICT_REFS) @@ -2170,8 +2176,7 @@ PP(pp_entersub) * (3) instead of (2) so we'd have to clone. Would the fact * that we released the mutex more quickly make up for this? */ - if (PL_threadnum && - (svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE))) + if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE))) { /* We already have a clone to use */ MUTEX_UNLOCK(CvMUTEXP(cv)); @@ -2525,7 +2530,7 @@ PP(pp_method) } } - name = SvPV(TOPs, PL_na); + name = SvPV(TOPs, packlen); sv = *(PL_stack_base + TOPMARK + 1); if (SvGMAGICAL(sv)) @@ -298,7 +298,8 @@ PP(pp_backtick) { djSP; dTARGET; PerlIO *fp; - char *tmps = POPp; + STRLEN n_a; + char *tmps = POPpx; I32 gimme = GIMME_V; TAINT_PROPER("``"); @@ -384,7 +385,8 @@ PP(pp_glob) #if 0 /* XXX never used! */ PP(pp_indread) { - PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), PL_na), TRUE,SVt_PVIO); + STRLEN n_a; + PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO); return do_readline(); } #endif @@ -399,21 +401,22 @@ PP(pp_warn) { djSP; dMARK; char *tmps; + STRLEN n_a; if (SP - MARK != 1) { dTARGET; do_join(TARG, &PL_sv_no, MARK, SP); - tmps = SvPV(TARG, PL_na); + tmps = SvPV(TARG, n_a); SP = MARK + 1; } else { - tmps = SvPV(TOPs, PL_na); + tmps = SvPV(TOPs, n_a); } if (!tmps || !*tmps) { SV *error = ERRSV; (void)SvUPGRADE(error, SVt_PV); if (SvPOK(error) && SvCUR(error)) sv_catpv(error, "\t...caught"); - tmps = SvPV(error, PL_na); + tmps = SvPV(error, n_a); } if (!tmps || !*tmps) tmps = "Warning: something's wrong"; @@ -427,15 +430,16 @@ PP(pp_die) char *tmps; SV *tmpsv = Nullsv; char *pat = "%s"; + STRLEN n_a; if (SP - MARK != 1) { dTARGET; do_join(TARG, &PL_sv_no, MARK, SP); - tmps = SvPV(TARG, PL_na); + tmps = SvPV(TARG, n_a); SP = MARK + 1; } else { tmpsv = TOPs; - tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, PL_na); + tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, n_a); } if (!tmps || !*tmps) { SV *error = ERRSV; @@ -465,7 +469,7 @@ PP(pp_die) else { if (SvPOK(error) && SvCUR(error)) sv_catpv(error, "\t...propagated"); - tmps = SvPV(error, PL_na); + tmps = SvPV(error, n_a); } } if (!tmps || !*tmps) @@ -660,6 +664,7 @@ PP(pp_tie) char *methname; int how = 'P'; U32 items; + STRLEN n_a; varsv = *++MARK; switch(SvTYPE(varsv)) { @@ -696,7 +701,7 @@ PP(pp_tie) stash = gv_stashsv(*MARK, FALSE); if (!stash || !(gv = gv_fetchmethod(stash, methname))) { DIE("Can't locate object method \"%s\" via package \"%s\"", - methname, SvPV(*MARK,PL_na)); + methname, SvPV(*MARK,n_a)); } ENTER; PUSHSTACKi(PERLSI_MAGIC); @@ -835,6 +840,7 @@ PP(pp_sselect) struct timeval *tbuf = &timebuf; I32 growsize; char *fd_sets[4]; + STRLEN n_a; #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 I32 masksize; I32 offset; @@ -903,7 +909,7 @@ PP(pp_sselect) continue; } else if (!SvPOK(sv)) - SvPV_force(sv,PL_na); /* force string conversion */ + SvPV_force(sv,n_a); /* force string conversion */ j = SvLEN(sv); if (j < growsize) { Sv_Grow(sv, growsize); @@ -1230,6 +1236,7 @@ PP(pp_prtf) PerlIO *fp; SV *sv; MAGIC *mg; + STRLEN n_a; if (PL_op->op_flags & OPf_STACKED) gv = (GV*)*++MARK; @@ -1260,7 +1267,7 @@ PP(pp_prtf) if (!(io = GvIO(gv))) { if (ckWARN(WARN_UNOPENED)) { gv_fullname3(sv, gv, Nullch); - warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,PL_na)); + warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a)); } SETERRNO(EBADF,RMS$_IFI); goto just_say_no; @@ -1270,10 +1277,10 @@ PP(pp_prtf) gv_fullname3(sv, gv, Nullch); if (IoIFP(io)) warner(WARN_IO, "Filehandle %s opened only for input", - SvPV(sv,PL_na)); + SvPV(sv,n_a)); else if (ckWARN(WARN_CLOSED)) warner(WARN_CLOSED, "printf on closed filehandle %s", - SvPV(sv,PL_na)); + SvPV(sv,n_a)); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; @@ -1643,11 +1650,12 @@ PP(pp_truncate) Off_t len = (Off_t)POPn; int result = 1; GV *tmpgv; + STRLEN n_a; SETERRNO(0,0); #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP) if (PL_op->op_flags & OPf_SPECIAL) { - tmpgv = gv_fetchpv(POPp, FALSE, SVt_PVIO); + tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO); do_ftruncate: TAINT_PROPER("truncate"); if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) || @@ -1661,6 +1669,7 @@ PP(pp_truncate) else { SV *sv = POPs; char *name; + STRLEN n_a; if (SvTYPE(sv) == SVt_PVGV) { tmpgv = (GV*)sv; /* *main::FRED for example */ @@ -1671,7 +1680,7 @@ PP(pp_truncate) goto do_ftruncate; } - name = SvPV(sv, PL_na); + name = SvPV(sv, n_a); TAINT_PROPER("truncate"); #ifdef HAS_TRUNCATE if (truncate(name, len) < 0) @@ -2149,8 +2158,9 @@ PP(pp_ssockopt) char *buf; int aint; if (SvPOKp(sv)) { - buf = SvPV(sv, PL_na); - len = PL_na; + STRLEN l; + buf = SvPV(sv, l); + len = l; } else { aint = (int)SvIV(sv); @@ -2263,6 +2273,7 @@ PP(pp_stat) GV *tmpgv; I32 gimme; I32 max = 13; + STRLEN n_a; if (PL_op->op_flags & OPf_REF) { tmpgv = cGVOP->op_gv; @@ -2287,17 +2298,17 @@ PP(pp_stat) tmpgv = (GV*)SvRV(sv); goto do_fstat; } - sv_setpv(PL_statname, SvPV(sv,PL_na)); + sv_setpv(PL_statname, SvPV(sv,n_a)); PL_statgv = Nullgv; #ifdef HAS_LSTAT PL_laststype = PL_op->op_type; if (PL_op->op_type == OP_LSTAT) - PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, PL_na), &PL_statcache); + PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache); else #endif - PL_laststatval = PerlLIO_stat(SvPV(PL_statname, PL_na), &PL_statcache); + PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache); if (PL_laststatval < 0) { - if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, PL_na), '\n')) + if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n')) warner(WARN_NEWLINE, PL_warn_nl, "stat"); max = 0; } @@ -2349,8 +2360,9 @@ PP(pp_ftrread) I32 result; djSP; #if defined(HAS_ACCESS) && defined(R_OK) + STRLEN n_a; if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { - result = access(TOPp, R_OK); + result = access(TOPpx, R_OK); if (result == 0) RETPUSHYES; if (result < 0) @@ -2375,8 +2387,9 @@ PP(pp_ftrwrite) I32 result; djSP; #if defined(HAS_ACCESS) && defined(W_OK) + STRLEN n_a; if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { - result = access(TOPp, W_OK); + result = access(TOPpx, W_OK); if (result == 0) RETPUSHYES; if (result < 0) @@ -2401,8 +2414,9 @@ PP(pp_ftrexec) I32 result; djSP; #if defined(HAS_ACCESS) && defined(X_OK) + STRLEN n_a; if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { - result = access(TOPp, X_OK); + result = access(TOPpx, X_OK); if (result == 0) RETPUSHYES; if (result < 0) @@ -2427,8 +2441,9 @@ PP(pp_fteread) I32 result; djSP; #ifdef PERL_EFF_ACCESS_R_OK + STRLEN n_a; if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { - result = PERL_EFF_ACCESS_R_OK(TOPp); + result = PERL_EFF_ACCESS_R_OK(TOPpx); if (result == 0) RETPUSHYES; if (result < 0) @@ -2453,8 +2468,9 @@ PP(pp_ftewrite) I32 result; djSP; #ifdef PERL_EFF_ACCESS_W_OK + STRLEN n_a; if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { - result = PERL_EFF_ACCESS_W_OK(TOPp); + result = PERL_EFF_ACCESS_W_OK(TOPpx); if (result == 0) RETPUSHYES; if (result < 0) @@ -2479,8 +2495,9 @@ PP(pp_fteexec) I32 result; djSP; #ifdef PERL_EFF_ACCESS_X_OK + STRLEN n_a; if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { - result = PERL_EFF_ACCESS_X_OK(TOPp); + result = PERL_EFF_ACCESS_X_OK(TOPpx); if (result == 0) RETPUSHYES; if (result < 0) @@ -2701,6 +2718,7 @@ PP(pp_fttty) int fd; GV *gv; char *tmps = Nullch; + STRLEN n_a; if (PL_op->op_flags & OPf_REF) gv = cGVOP->op_gv; @@ -2709,7 +2727,7 @@ PP(pp_fttty) else if (SvROK(TOPs) && isGV(SvRV(TOPs))) gv = (GV*)SvRV(POPs); else - gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO); + gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO); if (GvIO(gv) && IoIFP(GvIOp(gv))) fd = PerlIO_fileno(IoIFP(GvIOp(gv))); @@ -2741,6 +2759,7 @@ PP(pp_fttext) register IO *io; register SV *sv; GV *gv; + STRLEN n_a; if (PL_op->op_flags & OPf_REF) gv = cGVOP->op_gv; @@ -2804,14 +2823,14 @@ PP(pp_fttext) really_filename: PL_statgv = Nullgv; PL_laststatval = -1; - sv_setpv(PL_statname, SvPV(sv, PL_na)); + sv_setpv(PL_statname, SvPV(sv, n_a)); #ifdef HAS_OPEN3 - i = PerlLIO_open3(SvPV(sv, PL_na), O_RDONLY, 0); + i = PerlLIO_open3(SvPV(sv, n_a), O_RDONLY, 0); #else - i = PerlLIO_open(SvPV(sv, PL_na), 0); + i = PerlLIO_open(SvPV(sv, n_a), 0); #endif if (i < 0) { - if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, PL_na), '\n')) + if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n')) warner(WARN_NEWLINE, PL_warn_nl, "open"); RETPUSHUNDEF; } @@ -2867,26 +2886,27 @@ PP(pp_chdir) djSP; dTARGET; char *tmps; SV **svp; + STRLEN n_a; if (MAXARG < 1) tmps = Nullch; else - tmps = POPp; + tmps = POPpx; if (!tmps || !*tmps) { svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE); if (svp) - tmps = SvPV(*svp, PL_na); + tmps = SvPV(*svp, n_a); } if (!tmps || !*tmps) { svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE); if (svp) - tmps = SvPV(*svp, PL_na); + tmps = SvPV(*svp, n_a); } #ifdef VMS if (!tmps || !*tmps) { svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE); if (svp) - tmps = SvPV(*svp, PL_na); + tmps = SvPV(*svp, n_a); } #endif TAINT_PROPER("chdir"); @@ -2918,7 +2938,8 @@ PP(pp_chroot) djSP; dTARGET; char *tmps; #ifdef HAS_CHROOT - tmps = POPp; + STRLEN n_a; + tmps = POPpx; TAINT_PROPER("chroot"); PUSHi( chroot(tmps) >= 0 ); RETURN; @@ -2961,9 +2982,10 @@ PP(pp_rename) { djSP; dTARGET; int anum; + STRLEN n_a; - char *tmps2 = POPp; - char *tmps = SvPV(TOPs, PL_na); + char *tmps2 = POPpx; + char *tmps = SvPV(TOPs, n_a); TAINT_PROPER("rename"); #ifdef HAS_RENAME anum = PerlLIO_rename(tmps, tmps2); @@ -2987,8 +3009,9 @@ PP(pp_link) { djSP; dTARGET; #ifdef HAS_LINK - char *tmps2 = POPp; - char *tmps = SvPV(TOPs, PL_na); + STRLEN n_a; + char *tmps2 = POPpx; + char *tmps = SvPV(TOPs, n_a); TAINT_PROPER("link"); SETi( link(tmps, tmps2) >= 0 ); #else @@ -3001,8 +3024,9 @@ PP(pp_symlink) { djSP; dTARGET; #ifdef HAS_SYMLINK - char *tmps2 = POPp; - char *tmps = SvPV(TOPs, PL_na); + STRLEN n_a; + char *tmps2 = POPpx; + char *tmps = SvPV(TOPs, n_a); TAINT_PROPER("symlink"); SETi( symlink(tmps, tmps2) >= 0 ); RETURN; @@ -3018,11 +3042,12 @@ PP(pp_readlink) char *tmps; char buf[MAXPATHLEN]; int len; + STRLEN n_a; #ifndef INCOMPLETE_TAINTS TAINT; #endif - tmps = POPp; + tmps = POPpx; len = readlink(tmps, buf, sizeof buf); EXTEND(SP, 1); if (len < 0) @@ -3131,7 +3156,8 @@ PP(pp_mkdir) #ifndef HAS_MKDIR int oldumask; #endif - char *tmps = SvPV(TOPs, PL_na); + STRLEN n_a; + char *tmps = SvPV(TOPs, n_a); TAINT_PROPER("mkdir"); #ifdef HAS_MKDIR @@ -3149,8 +3175,9 @@ PP(pp_rmdir) { djSP; dTARGET; char *tmps; + STRLEN n_a; - tmps = POPp; + tmps = POPpx; TAINT_PROPER("rmdir"); #ifdef HAS_RMDIR XPUSHi( PerlDir_rmdir(tmps) >= 0 ); @@ -3166,7 +3193,8 @@ PP(pp_open_dir) { djSP; #if defined(Direntry_t) && defined(HAS_READDIR) - char *dirname = POPp; + STRLEN n_a; + char *dirname = POPpx; GV *gv = (GV*)POPs; register IO *io = GvIOn(gv); @@ -3411,10 +3439,11 @@ PP(pp_system) int result; int status; Sigsave_t ihand,qhand; /* place to save signals during system() */ + STRLEN n_a; if (SP - MARK == 1) { if (PL_tainting) { - char *junk = SvPV(TOPs, PL_na); + char *junk = SvPV(TOPs, n_a); TAINT_ENV(); TAINT_PROPER("system"); } @@ -3450,7 +3479,7 @@ PP(pp_system) else if (SP - MARK != 1) value = (I32)do_aexec(Nullsv, MARK, SP); else { - value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na)); + value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a)); } PerlProc__exit(-1); #else /* ! FORK or VMS or OS/2 */ @@ -3461,7 +3490,7 @@ PP(pp_system) else if (SP - MARK != 1) value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP); else { - value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), PL_na)); + value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a)); } STATUS_NATIVE_SET(value); do_execfree(); @@ -3475,6 +3504,7 @@ PP(pp_exec) { djSP; dMARK; dORIGMARK; dTARGET; I32 value; + STRLEN n_a; if (PL_op->op_flags & OPf_STACKED) { SV *really = *++MARK; @@ -3495,18 +3525,18 @@ PP(pp_exec) #endif else { if (PL_tainting) { - char *junk = SvPV(*SP, PL_na); + char *junk = SvPV(*SP, n_a); TAINT_ENV(); TAINT_PROPER("exec"); } #ifdef VMS - value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), PL_na)); + value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a)); #else # ifdef __OPEN_VM - (void) do_spawn(SvPVx(sv_mortalcopy(*SP), PL_na)); + (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a)); value = 0; # else - value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na)); + value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a)); # endif #endif } @@ -3930,11 +3960,12 @@ PP(pp_ghostent) #endif struct hostent *hent; unsigned long len; + STRLEN n_a; EXTEND(SP, 10); if (which == OP_GHBYNAME) #ifdef HAS_GETHOSTBYNAME - hent = PerlSock_gethostbyname(POPp); + hent = PerlSock_gethostbyname(POPpx); #else DIE(PL_no_sock_func, "gethostbyname"); #endif @@ -4037,10 +4068,11 @@ PP(pp_gnetent) struct netent *PerlSock_getnetent(void); #endif struct netent *nent; + STRLEN n_a; if (which == OP_GNBYNAME) #ifdef HAS_GETNETBYNAME - nent = PerlSock_getnetbyname(POPp); + nent = PerlSock_getnetbyname(POPpx); #else DIE(PL_no_sock_func, "getnetbyname"); #endif @@ -4124,10 +4156,11 @@ PP(pp_gprotoent) struct protoent *PerlSock_getprotoent(void); #endif struct protoent *pent; + STRLEN n_a; if (which == OP_GPBYNAME) #ifdef HAS_GETPROTOBYNAME - pent = PerlSock_getprotobyname(POPp); + pent = PerlSock_getprotobyname(POPpx); #else DIE(PL_no_sock_func, "getprotobyname"); #endif @@ -4206,11 +4239,12 @@ PP(pp_gservent) struct servent *PerlSock_getservent(void); #endif struct servent *sent; + STRLEN n_a; if (which == OP_GSBYNAME) { #ifdef HAS_GETSERVBYNAME - char *proto = POPp; - char *name = POPp; + char *proto = POPpx; + char *name = POPpx; if (proto && !*proto) proto = Nullch; @@ -4222,7 +4256,7 @@ PP(pp_gservent) } else if (which == OP_GSBYPORT) { #ifdef HAS_GETSERVBYPORT - char *proto = POPp; + char *proto = POPpx; unsigned short port = POPu; #ifdef HAS_HTONS @@ -4399,9 +4433,10 @@ PP(pp_gpwent) I32 which = PL_op->op_type; register SV *sv; struct passwd *pwent; + STRLEN n_a; if (which == OP_GPWNAM) - pwent = getpwnam(POPp); + pwent = getpwnam(POPpx); else if (which == OP_GPWUID) pwent = getpwuid(POPi); else @@ -4532,9 +4567,10 @@ PP(pp_ggrent) register char **elem; register SV *sv; struct group *grent; + STRLEN n_a; if (which == OP_GGRNAM) - grent = (struct group *)getgrnam(POPp); + grent = (struct group *)getgrnam(POPpx); else if (which == OP_GGRGID) grent = (struct group *)getgrgid(POPi); else @@ -4626,6 +4662,7 @@ PP(pp_syscall) register I32 i = 0; I32 retval = -1; MAGIC *mg; + STRLEN n_a; if (PL_tainting) { while (++MARK <= SP) { @@ -4648,7 +4685,7 @@ PP(pp_syscall) else if (*MARK == &PL_sv_undef) a[i++] = 0; else - a[i++] = (unsigned long)SvPV_force(*MARK, PL_na); + a[i++] = (unsigned long)SvPV_force(*MARK, n_a); if (i > 15) break; } @@ -73,6 +73,7 @@ debop(OP *o) { #ifdef DEBUGGING SV *sv; + STRLEN n_a; deb("%s", PL_op_name[o->op_type]); switch (o->op_type) { case OP_CONST: @@ -83,7 +84,7 @@ debop(OP *o) if (cGVOPo->op_gv) { sv = NEWSV(0,0); gv_fullname3(sv, cGVOPo->op_gv, Nullch); - PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, PL_na)); + PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, n_a)); SvREFCNT_dec(sv); } else @@ -1569,7 +1569,7 @@ sv_2pv(register SV *sv, STRLEN *lp) if ( ((SvFLAGS(sv) & (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) == (SVs_OBJECT|SVs_RMG)) - && strEQ(s=HvNAME(SvSTASH(sv)), "re") + && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp") && (mg = mg_find(sv, 'r'))) { dTHR; regexp *re = (regexp *)mg->mg_obj; @@ -3843,6 +3843,7 @@ sv_2io(SV *sv) { IO* io; GV* gv; + STRLEN n_a; switch (SvTYPE(sv)) { case SVt_PVIO: @@ -3859,13 +3860,13 @@ sv_2io(SV *sv) croak(PL_no_usym, "filehandle"); if (SvROK(sv)) return sv_2io(SvRV(sv)); - gv = gv_fetchpv(SvPV(sv,PL_na), FALSE, SVt_PVIO); + gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO); if (gv) io = GvIO(gv); else io = 0; if (!io) - croak("Bad filehandle: %s", SvPV(sv,PL_na)); + croak("Bad filehandle: %s", SvPV(sv,n_a)); break; } return io; @@ -3876,6 +3877,7 @@ sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) { GV *gv; CV *cv; + STRLEN n_a; if (!sv) return *gvp = Nullgv, Nullcv; @@ -3917,7 +3919,7 @@ sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) else if (isGV(sv)) gv = (GV*)sv; else - gv = gv_fetchpv(SvPV(sv, PL_na), lref, SVt_PVCV); + gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV); *gvp = gv; if (!gv) return Nullcv; @@ -3934,7 +3936,7 @@ sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) Nullop); LEAVE; if (!GvCVu(gv)) - croak("Unable to create sub named \"%s\"", SvPV(sv,PL_na)); + croak("Unable to create sub named \"%s\"", SvPV(sv,n_a)); } return GvCVu(gv); } diff --git a/t/lib/io_poll.t b/t/lib/io_poll.t index d907d5414b..a0d081b034 100755 --- a/t/lib/io_poll.t +++ b/t/lib/io_poll.t @@ -34,6 +34,11 @@ print "ok 2\n"; $poll->poll(0.1); +if ($^O eq 'MSWin32') { +print "ok 3 # skipped, doesn't work on non-socket fds\n"; +print "ok 4 # skipped, doesn't work on non-socket fds\n"; +} +else { print "not " unless $poll->events($stdout) == POLLOUT; print "ok 3\n"; @@ -41,6 +46,7 @@ print "ok 3\n"; print "not " if $poll->events($dupout); print "ok 4\n"; +} my @h = $poll->handles; print "not " diff --git a/t/lib/textfill.t b/t/lib/textfill.t new file mode 100755 index 0000000000..857ae2f755 --- /dev/null +++ b/t/lib/textfill.t @@ -0,0 +1,99 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +@tests = (split(/\nEND\n/s, <<DONE)); +TEST1 +Cyberdog Information + +Cyberdog & Netscape in the news +Important Press Release regarding Cyberdog and Netscape. Check it out! + +Cyberdog Plug-in Support! +Cyberdog support for Netscape Plug-ins is now available to download! Go +to the Cyberdog Beta Download page and download it now! + +Cyberdog Book +Check out Jesse Feiler's way-cool book about Cyberdog. You can find +details out about the book as well as ordering information at Philmont +Software Mill site. + +Java! +Looking to view Java applets in Cyberdog 1.1 Beta 3? Download and install +the Mac OS Runtime for Java and try it out! + +Cyberdog 1.1 Beta 3 +We hope that Cyberdog and OpenDoc 1.1 will be available within the next +two weeks. In the meantime, we have released another version of +Cyberdog, Cyberdog 1.1 Beta 3. This version fixes several bugs that were +reported to us during out public beta period. You can check out our release +notes to see what we fixed! +END + Cyberdog Information + Cyberdog & Netscape in the news Important Press Release regarding + Cyberdog and Netscape. Check it out! + Cyberdog Plug-in Support! Cyberdog support for Netscape Plug-ins is now + available to download! Go to the Cyberdog Beta Download page and download + it now! + Cyberdog Book Check out Jesse Feiler's way-cool book about Cyberdog. + You can find details out about the book as well as ordering information at + Philmont Software Mill site. + Java! Looking to view Java applets in Cyberdog 1.1 Beta 3? Download and + install the Mac OS Runtime for Java and try it out! + Cyberdog 1.1 Beta 3 We hope that Cyberdog and OpenDoc 1.1 will be + available within the next two weeks. In the meantime, we have released + another version of Cyberdog, Cyberdog 1.1 Beta 3. This version fixes + several bugs that were reported to us during out public beta period. You + can check out our release notes to see what we fixed! +END +DONE + + +$| = 1; + +print "1.."; +print @tests/2; +print "\n"; + +use Text::Wrap; + +$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; + +$tn = 1; +while (@tests) { + my $in = shift(@tests); + my $out = shift(@tests); + + $in =~ s/^TEST(\d+)?\n//; + + my $back = fill(' ', ' ', $in); + + if ($back eq $out) { + print "ok $tn\n"; + } elsif ($rerun) { + my $oi = $in; + require File::Slurp; + File::Slurp::write_file("#o", $back); + File::Slurp::write_file("#e", $out); + foreach ($in, $back, $out) { + s/\t/^I\t/gs; + s/\n/\$\n/gs; + } + print "------------ input ------------\n"; + print $in; + print "\n------------ output -----------\n"; + print $back; + print "\n------------ expected ---------\n"; + print $out; + print "\n-------------------------------\n"; + $Text::Wrap::debug = 1; + fill(' ', ' ', $oi); + exit(1); + } else { + print "not ok $tn\n"; + } + $tn++; +} diff --git a/t/lib/textwrap.t b/t/lib/textwrap.t index 9c8d1b4975..3b6a1eaac2 100755 --- a/t/lib/textwrap.t +++ b/t/lib/textwrap.t @@ -1,40 +1,130 @@ -#!./perl +#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } -print "1..5\n"; +@tests = (split(/\nEND\n/s, <<DONE)); +TEST1 +This +is +a +test +END + This + is + a + test +END +TEST2 +This is a test of a very long line. It should be broken up and put onto multiple lines. +This is a test of a very long line. It should be broken up and put onto multiple lines. -use Text::Wrap qw(wrap $columns); +This is a test of a very long line. It should be broken up and put onto multiple lines. +END + This is a test of a very long line. It should be broken up and put onto + multiple lines. + This is a test of a very long line. It should be broken up and put onto + multiple lines. + + This is a test of a very long line. It should be broken up and put onto + multiple lines. +END +TEST3 +This is a test of a very long line. It should be broken up and put onto multiple lines. +END + This is a test of a very long line. It should be broken up and put onto + multiple lines. +END +TEST4 +This is a test of a very long line. It should be broken up and put onto multiple lines. -$columns = 30; +END + This is a test of a very long line. It should be broken up and put onto + multiple lines. -$text = <<'EOT'; -Text::Wrap is a very simple paragraph formatter. It formats a -single paragraph at a time by breaking lines at word boundries. -Indentation is controlled for the first line ($initial_tab) and -all subsquent lines ($subsequent_tab) independently. $Text::Wrap::columns -should be set to the full width of your output device. -EOT +END +TEST5 +This is a test of a very long line. It should be broken up and put onto multiple This is a test of a very long line. It should be broken up and put +END + This is a test of a very long line. It should be broken up and put onto + multiple This is a test of a very long line. It should be broken up and + put +END +TEST6 +11111111 22222222 33333333 44444444 55555555 66666666 77777777 888888888 999999999 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee ffffffff gggggggg hhhhhhhh iiiiiiii jjjjjjjj kkkkkkkk llllllll mmmmmmmmm nnnnnnnnn ooooooooo ppppppppp qqqqqqqqq rrrrrrrrr sssssssss +END + 11111111 22222222 33333333 44444444 55555555 66666666 77777777 888888888 + 999999999 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee ffffffff + gggggggg hhhhhhhh iiiiiiii jjjjjjjj kkkkkkkk llllllll mmmmmmmmm nnnnnnnnn + ooooooooo ppppppppp qqqqqqqqq rrrrrrrrr sssssssss +END +TEST7 +c3t1d0s6 c4t1d0s6 c5t1d0s6 c6t1d0s6 c7t1d0s6 c8t1d0s6 c9t1d0s6 c10t1d0s6 c11t1d0s6 c12t1d0s6 c13t1d0s6 c14t1d0s6 c15t1d0s6 c16t1d0s6 c3t1d0s0 c4t1d0s0 c5t1d0s0 c6t1d0s0 c7t1d0s0 c8t1d0s0 c9t1d0s0 c10t1d0s0 c11t1d0s0 c12t1d0s0 c13t1d0s0 c14t1d0s0 c15t1d0s0 c16t1d0s0 +END + c3t1d0s6 c4t1d0s6 c5t1d0s6 c6t1d0s6 c7t1d0s6 c8t1d0s6 c9t1d0s6 c10t1d0s6 + c11t1d0s6 c12t1d0s6 c13t1d0s6 c14t1d0s6 c15t1d0s6 c16t1d0s6 c3t1d0s0 + c4t1d0s0 c5t1d0s0 c6t1d0s0 c7t1d0s0 c8t1d0s0 c9t1d0s0 c10t1d0s0 c11t1d0s0 + c12t1d0s0 c13t1d0s0 c14t1d0s0 c15t1d0s0 c16t1d0s0 +END +TEST8 +A test of a very very long word. +a123456789b123456789c123456789d123456789e123456789f123456789g123456789g1234567 +END + A test of a very very long word. + a123456789b123456789c123456789d123456789e123456789f123456789g123456789g123 + 4567 +END +TEST9 +A test of a very very long word. a123456789b123456789c123456789d123456789e123456789f123456789g123456789g1234567 +END + A test of a very very long word. + a123456789b123456789c123456789d123456789e123456789f123456789g123456789g123 + 4567 +END +DONE -$text =~ s/\n/ /g; -$_ = wrap "| ", "|", $text; -#print "$_\n"; +$| = 1; -print "not " unless /^\| Text::Wrap is/; # start is ok -print "ok 1\n"; +print "1.."; +print @tests/2; +print "\n"; -print "not " if /^.{31,}$/m; # no line longer than 30 chars -print "ok 2\n"; +use Text::Wrap; -print "not " unless /^\|\w/m; # other lines start with -print "ok 3\n"; +$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; -print "not " unless /\bsubsquent\b/; # look for a random word -print "ok 4\n"; +$tn = 1; +while (@tests) { + my $in = shift(@tests); + my $out = shift(@tests); -print "not " unless /\bdevice\./; # look for last word -print "ok 5\n"; + $in =~ s/^TEST(\d+)?\n//; + + my $back = wrap(' ', ' ', $in); + + if ($back eq $out) { + print "ok $tn\n"; + } elsif ($rerun) { + my $oi = $in; + foreach ($in, $back, $out) { + s/\t/^I\t/gs; + s/\n/\$\n/gs; + } + print "------------ input ------------\n"; + print $in; + print "\n------------ output -----------\n"; + print $back; + print "\n------------ expected ---------\n"; + print $out; + print "\n-------------------------------\n"; + $Text::Wrap::debug = 1; + wrap(' ', ' ', $oi); + exit(1); + } else { + print "not ok $tn\n"; + } + $tn++; +} diff --git a/t/op/die_exit.t b/t/op/die_exit.t index 26b477a8c9..e24d01d24c 100755 --- a/t/op/die_exit.t +++ b/t/op/die_exit.t @@ -31,7 +31,7 @@ my %tests = ( 15 => [ 255, 1], 16 => [ 255, 256], # see if implicit close preserves $? - 17 => [ 0, 512, '{ local *F; open F, q[TEST]; close F } die;'], + 17 => [ 0, 512, '{ local *F; open F, q[TEST]; close F; $!=0 } die;'], ); my $max = keys %tests; diff --git a/t/op/grent.t b/t/op/grent.t index 2e5aaa9fb8..d054ccc2b9 100755 --- a/t/op/grent.t +++ b/t/op/grent.t @@ -80,7 +80,7 @@ foreach (sort keys %seen) { if ($times > 1) { # Multiply defined groups are rarely intentional. local $" = ", "; - warn "# Group '$_' defined multiple times in $where, lines: @{$seen{$_}}.\n"; + print "# Group '$_' defined multiple times in $where, lines: @{$seen{$_}}.\n"; delete $suspect{$_}; } } diff --git a/t/op/sort.t b/t/op/sort.t index df8d434741..fdb4e347a5 100755 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -2,6 +2,9 @@ print "1..29\n"; +# XXX known to leak scalars +$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; + sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } my $upperfirst = 'A' lt 'a'; @@ -89,9 +89,10 @@ taint_env(void) svp = hv_fetch(GvHVn(PL_envgv),"TERM",4,FALSE); if (svp && *svp && SvTAINTED(*svp)) { dTHR; /* just for taint */ + STRLEN n_a; bool was_tainted = PL_tainted; - char *t = SvPV(*svp, PL_na); - char *e = t + PL_na; + char *t = SvPV(*svp, n_a); + char *e = t + n_a; PL_tainted = was_tainted; if (t < e && isALNUM(*t)) t++; @@ -52,6 +52,8 @@ PERLVAR(Tretstack_max, I32) PERLVAR(TSv, SV *) /* used to hold temporary values */ PERLVAR(TXpv, XPV *) /* used to hold temporary values */ +PERLVAR(Tna, STRLEN) /* for use in SvPV when length is + Not Applicable */ /* stat stuff */ PERLVAR(Tstatbuf, Stat_t) @@ -167,7 +169,7 @@ PERLVARI(Tregcompp, regcomp_t, FUNC_NAME_TO_PTR(pregcomp)) /* Pointer to RE compiler */ PERLVARI(Tregexecp, regexec_t, FUNC_NAME_TO_PTR(regexec_flags)) /* Pointer to RE executer */ -PERLVARI(Treginterp_cnt,int, 0) /* Whether `re' +PERLVARI(Treginterp_cnt,int, 0) /* Whether `Regexp' was interpolated. */ PERLVARI(Treg_starttry, char *, 0) /* -Dr: where regtry was called. */ #ifdef DEBUGGING @@ -216,6 +216,8 @@ struct perl_thread *getTHR _((void)); * from thrsv which is cached in the per-interpreter structure. * Systems with very fast pthread_get_specific (which should be all systems * but unfortunately isn't) may wish to simplify to "...*thr = THR". + * + * The use of PL_threadnum should be safe here. */ #ifndef dTHR # define dTHR \ @@ -238,30 +240,27 @@ struct perl_thread *getTHR _((void)); * try only locking them if there may be more than one thread in existence. * Systems with very fast mutexes (and/or slow conditionals) may wish to * remove the "if (threadnum) ..." test. + * XXX do NOT use C<if (PL_threadnum) ...> -- it sets up race conditions! */ #define LOCK_SV_MUTEX \ STMT_START { \ - if (PL_threadnum) \ - MUTEX_LOCK(&PL_sv_mutex); \ + MUTEX_LOCK(&PL_sv_mutex); \ } STMT_END #define UNLOCK_SV_MUTEX \ STMT_START { \ - if (PL_threadnum) \ - MUTEX_UNLOCK(&PL_sv_mutex); \ + MUTEX_UNLOCK(&PL_sv_mutex); \ } STMT_END /* Likewise for strtab_mutex */ #define LOCK_STRTAB_MUTEX \ STMT_START { \ - if (PL_threadnum) \ - MUTEX_LOCK(&PL_strtab_mutex); \ + MUTEX_LOCK(&PL_strtab_mutex); \ } STMT_END #define UNLOCK_STRTAB_MUTEX \ STMT_START { \ - if (PL_threadnum) \ - MUTEX_UNLOCK(&PL_strtab_mutex); \ + MUTEX_UNLOCK(&PL_strtab_mutex); \ } STMT_END #ifndef THREAD_RET_TYPE @@ -1452,8 +1452,10 @@ filter_add(filter_t funcp, SV *datasv) if (!SvUPGRADE(datasv, SVt_PVIO)) die("Can't upgrade filter_add data to SVt_PVIO"); IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */ - if (filter_debug) - warn("filter_add func %p (%s)", funcp, SvPV(datasv,PL_na)); + if (filter_debug) { + STRLEN n_a; + warn("filter_add func %p (%s)", funcp, SvPV(datasv, n_a)); + } av_unshift(PL_rsfp_filters, 1); av_store(PL_rsfp_filters, 0, datasv) ; return(datasv); @@ -1529,9 +1531,11 @@ filter_read(int idx, SV *buf_sv, int maxlen) } /* Get function pointer hidden within datasv */ funcp = (filter_t)IoDIRP(datasv); - if (filter_debug) + if (filter_debug) { + STRLEN n_a; warn("filter_read %d: via function %p (%s)\n", - idx, funcp, SvPV(datasv,PL_na)); + idx, funcp, SvPV(datasv,n_a)); + } /* Call function. The function is expected to */ /* call "FILTER_READ(idx+1, buf_sv)" first. */ /* Return: <0:error, =0:eof, >0:not eof */ @@ -2965,6 +2969,7 @@ int yylex(PERL_YYLEX_PARAM_DECL) case 'z': case 'Z': keylookup: { + STRLEN n_a; gv = Nullgv; gvp = 0; @@ -3161,7 +3166,7 @@ int yylex(PERL_YYLEX_PARAM_DECL) if (gv && GvCVu(gv)) { CV *cv; if ((cv = GvCV(gv)) && SvPOK(cv)) - PL_last_proto = SvPV((SV*)cv, PL_na); + PL_last_proto = SvPV((SV*)cv, n_a); for (d = s + 1; *d == ' ' || *d == '\t'; d++) ; if (*d == ')' && (sv = cv_const_sv(cv))) { s = d + 1; @@ -4119,7 +4124,7 @@ int yylex(PERL_YYLEX_PARAM_DECL) PL_lex_stuff = Nullsv; } - if (*SvPV(PL_subname,PL_na) == '?') { + if (*SvPV(PL_subname,n_a) == '?') { sv_setpv(PL_subname,"__ANON__"); TOKEN(ANONSUB); } diff --git a/universal.c b/universal.c index d0ef90dcdb..4f76d92255 100644 --- a/universal.c +++ b/universal.c @@ -113,12 +113,13 @@ XS(XS_UNIVERSAL_isa) dXSARGS; SV *sv; char *name; + STRLEN n_a; if (items != 2) croak("Usage: UNIVERSAL::isa(reference, kind)"); sv = ST(0); - name = (char *)SvPV(ST(1),PL_na); + name = (char *)SvPV(ST(1),n_a); ST(0) = boolSV(sv_derived_from(sv, name)); XSRETURN(1); @@ -131,12 +132,13 @@ XS(XS_UNIVERSAL_can) char *name; SV *rv; HV *pkg = NULL; + STRLEN n_a; if (items != 2) croak("Usage: UNIVERSAL::can(object-ref, method)"); sv = ST(0); - name = (char *)SvPV(ST(1),PL_na); + name = (char *)SvPV(ST(1),n_a); rv = &PL_sv_undef; if(SvROK(sv)) { @@ -191,9 +193,11 @@ XS(XS_UNIVERSAL_VERSION) undef = "(undef)"; } - if (items > 1 && (undef || (req = SvNV(ST(1)), req > SvNV(sv)))) + if (items > 1 && (undef || (req = SvNV(ST(1)), req > SvNV(sv)))) { + STRLEN n_a; croak("%s version %s required--this is only version %s", - HvNAME(pkg), SvPV(ST(1),PL_na), undef ? undef : SvPV(sv,PL_na)); + HvNAME(pkg), SvPV(ST(1),n_a), undef ? undef : SvPV(sv,n_a)); + } ST(0) = sv; @@ -15,7 +15,6 @@ #include "EXTERN.h" #include "perl.h" -/* XXX Configure test needed */ #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) #include <signal.h> #endif @@ -2838,11 +2837,6 @@ new_struct_thread(struct perl_thread *t) thr->flags = THRf_R_JOINABLE; MUTEX_INIT(&thr->mutex); - PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */ - PL_defstash = t->Tdefstash; /* XXX maybe these should */ - PL_curstash = t->Tcurstash; /* always be set to main? */ - - /* top_env needs to be non-zero. It points to an area in which longjmp() stuff is stored, as C callstack info there at least is thread specific this has to @@ -2859,6 +2853,25 @@ new_struct_thread(struct perl_thread *t) PL_in_eval = FALSE; PL_restartop = 0; + PL_statname = NEWSV(66,0); + PL_maxscream = -1; + PL_regcompp = FUNC_NAME_TO_PTR(pregcomp); + PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags); + PL_regindent = 0; + PL_reginterp_cnt = 0; + PL_lastscream = Nullsv; + PL_screamfirst = 0; + PL_screamnext = 0; + PL_reg_start_tmp = 0; + PL_reg_start_tmpl = 0; + + /* parent thread's data needs to be locked while we make copy */ + MUTEX_LOCK(&t->mutex); + + PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */ + PL_defstash = t->Tdefstash; /* XXX maybe these should */ + PL_curstash = t->Tcurstash; /* always be set to main? */ + PL_tainted = t->Ttainted; PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */ PL_nrs = newSVsv(t->Tnrs); @@ -2872,18 +2885,6 @@ new_struct_thread(struct perl_thread *t) PL_bodytarget = newSVsv(t->Tbodytarget); PL_toptarget = newSVsv(t->Ttoptarget); - PL_statname = NEWSV(66,0); - PL_maxscream = -1; - PL_regcompp = FUNC_NAME_TO_PTR(pregcomp); - PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags); - PL_regindent = 0; - PL_reginterp_cnt = 0; - PL_lastscream = Nullsv; - PL_screamfirst = 0; - PL_screamnext = 0; - PL_reg_start_tmp = 0; - PL_reg_start_tmpl = 0; - /* Initialise all per-thread SVs that the template thread used */ svp = AvARRAY(t->threadsv); for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) { @@ -2906,6 +2907,9 @@ new_struct_thread(struct perl_thread *t) thr->next->prev = thr; MUTEX_UNLOCK(&PL_threads_mutex); + /* done copying parent's state */ + MUTEX_UNLOCK(&t->mutex); + #ifdef HAVE_THREAD_INTERN init_thread_intern(thr); #endif /* HAVE_THREAD_INTERN */ diff --git a/vmesa/vmesa.c b/vmesa/vmesa.c index 6169e70d78..11854335e0 100644 --- a/vmesa/vmesa.c +++ b/vmesa/vmesa.c @@ -116,6 +116,7 @@ do_aspawn(SV* really, SV **mark, SV **sp) fdMap[3]; SV *sv, **p_sv; + STRLEN n_a; status = FAIL; if (sp > mark) @@ -126,7 +127,7 @@ do_aspawn(SV* really, SV **mark, SV **sp) while (++mark <= sp) { if (*mark) - *a++ = SvPVx(*mark, PL_na); + *a++ = SvPVx(*mark, n_a); else *a++ = ""; } @@ -142,7 +143,7 @@ do_aspawn(SV* really, SV **mark, SV **sp) /*-----------------------------------------------------*/ if (*PL_Argv[0] != '/') TAINT_ENV(); - if (really && *(tmps = SvPV(really, PL_na))) + if (really && *(tmps = SvPV(really, n_a))) pid = spawnp(tmps, nFd, fdMap, &inherit, (const char **) PL_Argv, (const char **) environ); diff --git a/vms/ext/Stdio/Stdio.xs b/vms/ext/Stdio/Stdio.xs index 6fa1b29bbe..53b491575d 100644 --- a/vms/ext/Stdio/Stdio.xs +++ b/vms/ext/Stdio/Stdio.xs @@ -164,11 +164,12 @@ setdef(...) struct FAB deffab = cc$rms_fab; struct NAM defnam = cc$rms_nam; struct dsc$descriptor_s dirdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + STRLEN n_a; if (items) { SV *defsv = ST(items-1); /* mimic chdir() */ ST(0) = &PL_sv_undef; if (!SvPOK(defsv)) { SETERRNO(EINVAL,LIB$_INVARG); XSRETURN(1); } - if (tovmsspec(SvPV(defsv,PL_na),vmsdef) == NULL) { XSRETURN(1); } + if (tovmsspec(SvPV(defsv,n_a),vmsdef) == NULL) { XSRETURN(1); } deffab.fab$l_fna = vmsdef; deffab.fab$b_fns = strlen(vmsdef); } else { @@ -232,6 +233,7 @@ vmsopen(spec,...) char *args[8],mode[3] = {'r','\0','\0'}, type = '<'; register int i, myargc; FILE *fp; + STRLEN n_a; if (!spec || !*spec) { SETERRNO(EINVAL,LIB$_INVARG); @@ -250,7 +252,7 @@ vmsopen(spec,...) } else if (*spec == '<') spec++; myargc = items - 1; - for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+1),PL_na); + for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+1),n_a); /* This hack brought to you by C's opaque arglist management */ switch (myargc) { case 0: @@ -298,13 +300,14 @@ vmssysopen(spec,mode,perm,...) int i, myargc, fd; FILE *fp; SV *fh; + STRLEN n_a; if (!spec || !*spec) { SETERRNO(EINVAL,LIB$_INVARG); XSRETURN_UNDEF; } if (items > 11) croak("too many args"); myargc = items - 3; - for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+3),PL_na); + for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+3),n_a); /* More fun with C calls; can't combine with above because args 2,3 of different types in fopen() and open() */ switch (myargc) { diff --git a/vms/perly_c.vms b/vms/perly_c.vms index db1f255c56..3a4ef8b3cb 100644 --- a/vms/perly_c.vms +++ b/vms/perly_c.vms @@ -31,7 +31,7 @@ dep(void) #line 30 "perly.y" #define YYERRCODE 256 -dEXT short yylhs[] = { -1, +static short yylhs[] = { -1, 45, 0, 9, 7, 10, 8, 11, 11, 11, 12, 12, 12, 12, 24, 24, 24, 24, 24, 24, 24, 15, 15, 15, 14, 14, 42, 42, 13, 13, 13, @@ -51,7 +51,7 @@ dEXT short yylhs[] = { -1, 34, 34, 34, 2, 2, 43, 23, 18, 19, 20, 21, 22, 35, 35, 35, 35, }; -dEXT short yylen[] = { 2, +static short yylen[] = { 2, 0, 2, 4, 0, 4, 0, 0, 2, 2, 2, 1, 2, 3, 1, 1, 3, 3, 3, 3, 3, 0, 2, 6, 7, 7, 0, 2, 8, 8, 10, @@ -71,7 +71,7 @@ dEXT short yylen[] = { 2, 0, 1, 2, 1, 1, 1, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, }; -dEXT short yydefred[] = { 1, +static short yydefred[] = { 1, 0, 7, 0, 45, 56, 54, 0, 54, 8, 46, 9, 11, 0, 47, 48, 49, 0, 0, 0, 63, 64, 14, 4, 157, 0, 0, 130, 0, 152, 0, @@ -110,14 +110,14 @@ dEXT short yydefred[] = { 1, 22, 0, 0, 0, 31, 5, 0, 30, 0, 0, 33, 0, 23, }; -dEXT short yydgoto[] = { 1, +static short yydgoto[] = { 1, 9, 66, 10, 18, 95, 17, 86, 339, 89, 328, 3, 11, 12, 68, 344, 263, 70, 71, 72, 73, 74, 75, 76, 269, 78, 270, 259, 261, 264, 272, 260, 262, 113, 198, 91, 79, 238, 81, 83, 179, 250, 142, 267, 13, 2, 14, 15, 16, 85, 256, }; -dEXT short yysindex[] = { 0, +static short yysindex[] = { 0, 0, 0, -66, 0, 0, 0, -48, 0, 0, 0, 0, 0, 645, 0, 0, 0, -232, -227, -27, 0, 0, 0, 0, 0, -23, -23, 0, -6, 0, 2099, @@ -156,7 +156,7 @@ dEXT short yysindex[] = { 0, 0, 2099, -206, 256, 0, 0, 259, 0, 92, 92, 0, -238, 0, }; -dEXT short yyrindex[] = { 0, +static short yyrindex[] = { 0, 0, 0, 249, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 184, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, @@ -195,7 +195,7 @@ dEXT short yyrindex[] = { 0, 0, 0, 59, 0, 0, 0, 0, 0, 0, 0, 0, 154, 0, }; -dEXT short yygindex[] = { 0, +static short yygindex[] = { 0, 0, 0, 0, 374, 351, 0, -12, 0, 946, 413, -83, 0, 0, 0, -311, -13, 4007, 2893, 0, 0, 0, 0, 0, 372, -8, 0, 0, 246, -131, 43, @@ -203,7 +203,7 @@ dEXT short yygindex[] = { 0, 0, -271, 0, 0, 0, 0, 0, 0, 0, 0, }; #define YYTABLESIZE 4293 -dEXT short yytable[] = { 69, +static short yytable[] = { 69, 207, 62, 181, 104, 168, 102, 104, 204, 168, 248, 20, 208, 62, 253, 58, 285, 274, 170, 298, 345, 104, 104, 172, 202, 80, 104, 311, 148, 149, 82, @@ -635,7 +635,7 @@ dEXT short yytable[] = { 69, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 317, }; -dEXT short yycheck[] = { 13, +static short yycheck[] = { 13, 41, 36, 86, 41, 91, 40, 44, 59, 91, 59, 59, 93, 36, 183, 59, 59, 41, 91, 41, 331, 58, 59, 91, 40, 257, 63, 41, 297, 298, 257, @@ -1073,7 +1073,7 @@ dEXT short yycheck[] = { 13, #endif #define YYMAXTOKEN 314 #if YYDEBUG -dEXT char * yyname[] = { +static char *yyname[] = { "end-of-file",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, "'!'",0,0,"'$'","'%'","'&'",0,"'('","')'","'*'","'+'","','","'-'",0,0,0,0,0,0,0, 0,0,0,0,0,"':'","';'",0,0,0,"'?'","'@'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, @@ -1090,7 +1090,7 @@ dEXT char * yyname[] = { "SHIFTOP","MATCHOP","UMINUS","REFGEN","POWOP","PREINC","PREDEC","POSTINC", "POSTDEC","ARROW", }; -dEXT char * yyrule[] = { +static char *yyrule[] = { "$accept : prog", "$$1 :", "prog : $$1 lineseq", @@ -1775,7 +1775,7 @@ case 56: break; case 57: #line 302 "perly.y" -{ char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv, PL_na); +{ STRLEN n_a; char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv, n_a); if (strEQ(name, "BEGIN") || strEQ(name, "END") || strEQ(name, "INIT")) CvUNIQUE_on(PL_compcv); @@ -2848,6 +2848,7 @@ setup_argstr(SV *really, SV **mark, SV **sp) register size_t cmdlen = 0; size_t rlen; register SV **idx; + STRLEN n_a; idx = mark; if (really) { @@ -2874,7 +2875,7 @@ setup_argstr(SV *really, SV **mark, SV **sp) while (++mark <= sp) { if (*mark) { strcat(PL_Cmd," "); - strcat(PL_Cmd,SvPVx(*mark,PL_na)); + strcat(PL_Cmd,SvPVx(*mark,n_a)); } } return PL_Cmd; @@ -4407,12 +4408,13 @@ rmsexpand_fromperl(CV *cv) { dXSARGS; char *fspec, *defspec = NULL, *rslt; + STRLEN n_a; if (!items || items > 2) croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])"); - fspec = SvPV(ST(0),PL_na); + fspec = SvPV(ST(0),n_a); if (!fspec || !*fspec) XSRETURN_UNDEF; - if (items == 2) defspec = SvPV(ST(1),PL_na); + if (items == 2) defspec = SvPV(ST(1),n_a); rslt = do_rmsexpand(fspec,NULL,1,defspec,0); ST(0) = sv_newmortal(); @@ -4425,9 +4427,10 @@ vmsify_fromperl(CV *cv) { dXSARGS; char *vmsified; + STRLEN n_a; if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)"); - vmsified = do_tovmsspec(SvPV(ST(0),PL_na),NULL,1); + vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1); ST(0) = sv_newmortal(); if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified)); XSRETURN(1); @@ -4438,9 +4441,10 @@ unixify_fromperl(CV *cv) { dXSARGS; char *unixified; + STRLEN n_a; if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)"); - unixified = do_tounixspec(SvPV(ST(0),PL_na),NULL,1); + unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1); ST(0) = sv_newmortal(); if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified)); XSRETURN(1); @@ -4451,9 +4455,10 @@ fileify_fromperl(CV *cv) { dXSARGS; char *fileified; + STRLEN n_a; if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)"); - fileified = do_fileify_dirspec(SvPV(ST(0),PL_na),NULL,1); + fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1); ST(0) = sv_newmortal(); if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified)); XSRETURN(1); @@ -4464,9 +4469,10 @@ pathify_fromperl(CV *cv) { dXSARGS; char *pathified; + STRLEN n_a; if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)"); - pathified = do_pathify_dirspec(SvPV(ST(0),PL_na),NULL,1); + pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1); ST(0) = sv_newmortal(); if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified)); XSRETURN(1); @@ -4477,9 +4483,10 @@ vmspath_fromperl(CV *cv) { dXSARGS; char *vmspath; + STRLEN n_a; if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)"); - vmspath = do_tovmspath(SvPV(ST(0),PL_na),NULL,1); + vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1); ST(0) = sv_newmortal(); if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath)); XSRETURN(1); @@ -4490,9 +4497,10 @@ unixpath_fromperl(CV *cv) { dXSARGS; char *unixpath; + STRLEN n_a; if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)"); - unixpath = do_tounixpath(SvPV(ST(0),PL_na),NULL,1); + unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1); ST(0) = sv_newmortal(); if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath)); XSRETURN(1); @@ -4505,6 +4513,7 @@ candelete_fromperl(CV *cv) char fspec[NAM$C_MAXRSS+1], *fsp; SV *mysv; IO *io; + STRLEN n_a; if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)"); @@ -4518,7 +4527,7 @@ candelete_fromperl(CV *cv) fsp = fspec; } else { - if (mysv != ST(0) || !(fsp = SvPV(mysv,PL_na)) || !*fsp) { + if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) { set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); ST(0) = &PL_sv_no; XSRETURN(1); @@ -4540,6 +4549,7 @@ rmscopy_fromperl(CV *cv) unsigned long int sts; SV *mysv; IO *io; + STRLEN n_a; if (items < 2 || items > 3) croak("Usage: File::Copy::rmscopy(from,to[,date_flag])"); @@ -4554,7 +4564,7 @@ rmscopy_fromperl(CV *cv) inp = inspec; } else { - if (mysv != ST(0) || !(inp = SvPV(mysv,PL_na)) || !*inp) { + if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) { set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); ST(0) = &PL_sv_no; XSRETURN(1); @@ -4570,7 +4580,7 @@ rmscopy_fromperl(CV *cv) outp = outspec; } else { - if (mysv != ST(1) || !(outp = SvPV(mysv,PL_na)) || !*outp) { + if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) { set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); ST(0) = &PL_sv_no; XSRETURN(1); diff --git a/win32/Makefile b/win32/Makefile index be10a082a4..bee48c0764 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -29,7 +29,7 @@ INST_TOP = $(INST_DRV)\perl # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # -INST_VER = \5.00553 +INST_VER = \5.00554 # # uncomment to enable threads-capabilities @@ -113,12 +113,28 @@ INST_VER = \5.00553 # Some versions of Visual C don't define MSVCDIR in the environment, # so you may have to set CCHOME explicitly. # +# If the path contains spaces, you can try putting it in double +# quotes, but support for this is not well-tested, and various +# other things may break, so you're kinda on your own if you are +# into specious paths. :-) +# #CCHOME = f:\msvc20 CCHOME = $(MSVCDIR) CCINCDIR = $(CCHOME)\include CCLIBDIR = $(CCHOME)\lib # +# additional compiler flags can be specified here. +# +# Adding -DPERL_POLLUTE enables support for old symbols, at the expense of +# extreme pollution. You most probably want this if you're compiling modules +# from CPAN, or other such serious uses of this experimental perl release. +# We don't enable this by default because we want the modules to get fixed +# instead of clinging to shortcuts like this one. +# +#BUILDOPT = -DPERL_POLLUTE + +# # specify space-separated list of extra directories to look for libraries # EXTRALIBDIRS = @@ -160,9 +176,6 @@ USE_THREADS = undef USE_MULTI = undef !ENDIF -#BUILDOPT = -DPERL_GLOBAL_STRUCT -# -DUSE_PERLIO -D__STDC__=1 -DUSE_SFIO -DI_SFIO -I\sfio97\include - !IF "$(PROCESSOR_ARCHITECTURE)" == "" PROCESSOR_ARCHITECTURE = x86 !ENDIF diff --git a/win32/config_H.bc b/win32/config_H.bc index 415151d424..d0283cbb80 100644 --- a/win32/config_H.bc +++ b/win32/config_H.bc @@ -34,8 +34,8 @@ * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ -#define BIN "c:\\perl\\5.00553\\bin\\MSWin32-x86" /**/ -#define BIN_EXP "c:\\perl\\5.00553\\bin\\MSWin32-x86" /**/ +#define BIN "c:\\perl\\5.00554\\bin\\MSWin32-x86" /**/ +#define BIN_EXP "c:\\perl\\5.00554\\bin\\MSWin32-x86" /**/ /* HAS_ALARM: * This symbol, if defined, indicates that the alarm routine is @@ -1891,7 +1891,7 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "c:\\perl\\5.00553\\lib\\MSWin32-x86" /**/ +#define ARCHLIB "c:\\perl\\5.00554\\lib\\MSWin32-x86" /**/ /*#define ARCHLIB_EXP "" /**/ /* DLSYM_NEEDS_UNDERSCORE: @@ -2061,8 +2061,8 @@ * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define PRIVLIB "c:\\perl\\5.00553\\lib" /**/ -#define PRIVLIB_EXP (win32_get_privlib("5.00553")) /**/ +#define PRIVLIB "c:\\perl\\5.00554\\lib" /**/ +#define PRIVLIB_EXP (win32_get_privlib("5.00554")) /**/ /* SELECT_MIN_BITS: * This symbol holds the minimum number of bits operated by select. @@ -2086,7 +2086,7 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "c:\\perl\\site\\5.00553\\lib\\MSWin32-x86" /**/ +#define SITEARCH "c:\\perl\\site\\5.00554\\lib\\MSWin32-x86" /**/ /*#define SITEARCH_EXP "" /**/ /* SITELIB: @@ -2102,8 +2102,8 @@ * This symbol contains the ~name expanded version of SITELIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITELIB "c:\\perl\\site\\5.00553\\lib" /**/ -#define SITELIB_EXP (win32_get_sitelib("5.00553")) /**/ +#define SITELIB "c:\\perl\\site\\5.00554\\lib" /**/ +#define SITELIB_EXP (win32_get_sitelib("5.00554")) /**/ /* STARTPERL: * This variable contains the string to put in front of a perl diff --git a/win32/config_H.gc b/win32/config_H.gc index df77678242..3c8ff09c21 100644 --- a/win32/config_H.gc +++ b/win32/config_H.gc @@ -34,8 +34,8 @@ * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ -#define BIN "c:\\perl\\5.00553\\bin\\MSWin32-x86" /**/ -#define BIN_EXP "c:\\perl\\5.00553\\bin\\MSWin32-x86" /**/ +#define BIN "c:\\perl\\5.00554\\bin\\MSWin32-x86" /**/ +#define BIN_EXP "c:\\perl\\5.00554\\bin\\MSWin32-x86" /**/ /* HAS_ALARM: * This symbol, if defined, indicates that the alarm routine is @@ -1891,7 +1891,7 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "c:\\perl\\5.00553\\lib\\MSWin32-x86" /**/ +#define ARCHLIB "c:\\perl\\5.00554\\lib\\MSWin32-x86" /**/ /*#define ARCHLIB_EXP "" /**/ /* DLSYM_NEEDS_UNDERSCORE: @@ -2061,8 +2061,8 @@ * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define PRIVLIB "c:\\perl\\5.00553\\lib" /**/ -#define PRIVLIB_EXP (win32_get_privlib("5.00553")) /**/ +#define PRIVLIB "c:\\perl\\5.00554\\lib" /**/ +#define PRIVLIB_EXP (win32_get_privlib("5.00554")) /**/ /* SELECT_MIN_BITS: * This symbol holds the minimum number of bits operated by select. @@ -2086,7 +2086,7 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "c:\\perl\\site\\5.00553\\lib\\MSWin32-x86" /**/ +#define SITEARCH "c:\\perl\\site\\5.00554\\lib\\MSWin32-x86" /**/ /*#define SITEARCH_EXP "" /**/ /* SITELIB: @@ -2102,8 +2102,8 @@ * This symbol contains the ~name expanded version of SITELIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITELIB "c:\\perl\\site\\5.00553\\lib" /**/ -#define SITELIB_EXP (win32_get_sitelib("5.00553")) /**/ +#define SITELIB "c:\\perl\\site\\5.00554\\lib" /**/ +#define SITELIB_EXP (win32_get_sitelib("5.00554")) /**/ /* STARTPERL: * This variable contains the string to put in front of a perl diff --git a/win32/config_H.vc b/win32/config_H.vc index 455c967017..a086d75f99 100644 --- a/win32/config_H.vc +++ b/win32/config_H.vc @@ -34,8 +34,8 @@ * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ -#define BIN "c:\\perl\\5.00553\\bin\\MSWin32-x86" /**/ -#define BIN_EXP "c:\\perl\\5.00553\\bin\\MSWin32-x86" /**/ +#define BIN "c:\\perl\\5.00554\\bin\\MSWin32-x86" /**/ +#define BIN_EXP "c:\\perl\\5.00554\\bin\\MSWin32-x86" /**/ /* HAS_ALARM: * This symbol, if defined, indicates that the alarm routine is @@ -1891,7 +1891,7 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "c:\\perl\\5.00553\\lib\\MSWin32-x86" /**/ +#define ARCHLIB "c:\\perl\\5.00554\\lib\\MSWin32-x86" /**/ /*#define ARCHLIB_EXP "" /**/ /* DLSYM_NEEDS_UNDERSCORE: @@ -2061,8 +2061,8 @@ * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define PRIVLIB "c:\\perl\\5.00553\\lib" /**/ -#define PRIVLIB_EXP (win32_get_privlib("5.00553")) /**/ +#define PRIVLIB "c:\\perl\\5.00554\\lib" /**/ +#define PRIVLIB_EXP (win32_get_privlib("5.00554")) /**/ /* SELECT_MIN_BITS: * This symbol holds the minimum number of bits operated by select. @@ -2086,7 +2086,7 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "c:\\perl\\site\\5.00553\\lib\\MSWin32-x86" /**/ +#define SITEARCH "c:\\perl\\site\\5.00554\\lib\\MSWin32-x86" /**/ /*#define SITEARCH_EXP "" /**/ /* SITELIB: @@ -2102,8 +2102,8 @@ * This symbol contains the ~name expanded version of SITELIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITELIB "c:\\perl\\site\\5.00553\\lib" /**/ -#define SITELIB_EXP (win32_get_sitelib("5.00553")) /**/ +#define SITELIB "c:\\perl\\site\\5.00554\\lib" /**/ +#define SITELIB_EXP (win32_get_sitelib("5.00554")) /**/ /* STARTPERL: * This variable contains the string to put in front of a perl diff --git a/win32/makefile.mk b/win32/makefile.mk index e74dc687fa..56f17ea77c 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -33,7 +33,7 @@ INST_TOP *= $(INST_DRV)\perl # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # -INST_VER *= \5.00553 +INST_VER *= \5.00554 # # uncomment to enable threads-capabilities @@ -124,6 +124,11 @@ CCTYPE *= BORLAND # Some versions of Visual C don't define MSVCDIR in the environment, # so you may have to set CCHOME explicitly. # +# If the path contains spaces, you can try putting it in double +# quotes, but support for this is not well-tested, and various +# other things may break, so you're kinda on your own if you are +# into specious paths. :-) +# CCHOME *= C:\bc5 #CCHOME *= $(MSVCDIR) #CCHOME *= D:\packages\mingw32 @@ -131,6 +136,17 @@ CCINCDIR *= $(CCHOME)\include CCLIBDIR *= $(CCHOME)\lib # +# additional compiler flags can be specified here. +# +# Adding -DPERL_POLLUTE enables support for old symbols, at the expense of +# extreme pollution. You most probably want this if you're compiling modules +# from CPAN, or other such serious uses of this experimental perl release. +# We don't enable this by default because we want the modules to get fixed +# instead of clinging to shortcuts like this one. +# +#BUILDOPT *= -DPERL_POLLUTE + +# # specify space-separated list of extra directories to look for libraries # EXTRALIBDIRS *= @@ -171,9 +187,6 @@ PERL_MALLOC *= undef USE_THREADS *= undef USE_MULTI *= undef -#BUILDOPT *= -DPERL_GLOBAL_STRUCT -# -DUSE_PERLIO -D__STDC__=1 -DUSE_SFIO -DI_SFIO -I\sfio97\include - .IMPORT .IGNORE : PROCESSOR_ARCHITECTURE PROCESSOR_ARCHITECTURE *= x86 diff --git a/win32/win32.c b/win32/win32.c index be5f5e1e0c..e9619d637c 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -469,6 +469,7 @@ do_aspawn(void *vreally, void **vmark, void **vsp) int status; int flag = P_WAIT; int index = 0; + STRLEN n_a; if (sp <= mark) return -1; @@ -482,7 +483,7 @@ do_aspawn(void *vreally, void **vmark, void **vsp) } while (++mark <= sp) { - if (*mark && (str = SvPV(*mark, PL_na))) + if (*mark && (str = SvPV(*mark, n_a))) argv[index++] = str; else argv[index++] = ""; @@ -490,7 +491,7 @@ do_aspawn(void *vreally, void **vmark, void **vsp) argv[index++] = 0; status = win32_spawnvp(flag, - (const char*)(really ? SvPV(really,PL_na) : argv[0]), + (const char*)(really ? SvPV(really,n_a) : argv[0]), (const char* const*)argv); if (status < 0 && errno == ENOEXEC) { @@ -503,7 +504,7 @@ do_aspawn(void *vreally, void **vmark, void **vsp) argv[sh_items] = w32_perlshell_vec[sh_items]; status = win32_spawnvp(flag, - (const char*)(really ? SvPV(really,PL_na) : argv[0]), + (const char*)(really ? SvPV(really,n_a) : argv[0]), (const char* const*)argv); } @@ -2158,9 +2159,10 @@ static XS(w32_SetCwd) { dXSARGS; + STRLEN n_a; if (items != 1) croak("usage: Win32::SetCurrentDirectory($cwd)"); - if (SetCurrentDirectory(SvPV(ST(0),PL_na))) + if (SetCurrentDirectory(SvPV(ST(0),n_a))) XSRETURN_YES; XSRETURN_NO; @@ -2339,12 +2341,13 @@ XS(w32_Spawn) PROCESS_INFORMATION stProcInfo; STARTUPINFO stStartInfo; BOOL bSuccess = FALSE; + STRLEN n_a; if (items != 3) croak("usage: Win32::Spawn($cmdName, $args, $PID)"); - cmd = SvPV(ST(0),PL_na); - args = SvPV(ST(1), PL_na); + cmd = SvPV(ST(0), n_a); + args = SvPV(ST(1), n_a); memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */ stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */ diff --git a/win32/win32thread.c b/win32/win32thread.c index 1eb0e872c6..b40c5aa251 100644 --- a/win32/win32thread.c +++ b/win32/win32thread.c @@ -92,7 +92,6 @@ Perl_thread_create(struct perl_thread *thr, thread_func_t *fn) DWORD junk; unsigned long th; - MUTEX_LOCK(&thr->mutex); DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: create OS thread\n", thr)); #ifdef USE_RTL_THREAD_API @@ -126,7 +125,6 @@ Perl_thread_create(struct perl_thread *thr, thread_func_t *fn) #endif /* !USE_RTL_THREAD_API */ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: OS thread = %p, id=%ld\n", thr, thr->self, junk)); - MUTEX_UNLOCK(&thr->mutex); return thr->self ? 0 : -1; } #endif |